From b8f3914209f37653bb8818ce76c8ce28216d3537 Mon Sep 17 00:00:00 2001 From: hallgren Date: Mon, 20 Jan 2014 17:06:11 +0000 Subject: [PATCH] Optionally include C run-time support If the C run-time library is compiled and installed on your system, you can now do 'cabal configure -fc-runtime' to get the following extras: + The haskell binding to the C run-time library will be included in the PGF library (so you can import it in Haskell applications). Documentation on the new modules will be included when you run 'cabal haddock'. + The new command 'pgf-shell', implemented on top of haskell binding to the C run-time system. + Three new commands in the web API: c-parse, c-linearize and c-translate. Their interfaces are similar to the corresponding commands without the "c-" prefix, but they should be considered preliminary. --- Setup.hs | 4 + gf.cabal | 25 ++- src/compiler/GF/Infra/BuildInfo.hs | 3 + src/compiler/GFServer.hs | 2 +- src/runtime/haskell-bind/CRuntimeFFI.hsc | 10 +- src/server/PGFService.hs | 191 +++++++++++++++++------ 6 files changed, 179 insertions(+), 56 deletions(-) diff --git a/Setup.hs b/Setup.hs index 8085e50b6..ff1a6ada9 100644 --- a/Setup.hs +++ b/Setup.hs @@ -351,8 +351,12 @@ run_gfc pkg lbi args = default_gf pkg lbi = buildDir lbi exeName' exeNameReal where + exeName' = "gf" + exeNameReal = exeName' <.> exeExtension + {- --old solution, could pick the wrong executable if there is more than one exeName' = (exeName . head . executables) pkg exeNameReal = exeName' <.> (if null $ takeExtension exeName' then exeExtension else "") + -} -- | Create autogen module with detailed version info by querying darcs extractDarcsVersion distFlag = diff --git a/gf.cabal b/gf.cabal index 84078a082..7715c1c6d 100644 --- a/gf.cabal +++ b/gf.cabal @@ -1,7 +1,7 @@ name: gf version: 3.5.11-darcs -cabal-version: >= 1.8 +cabal-version: >= 1.10 build-type: Custom license: OtherLicense license-file: LICENSE @@ -57,7 +57,12 @@ flag custom-binary Description: Use a customised version of the binary package Default: True +flag c-runtime + Description: Include functionality from the C run-time library (which must be installed already) + Default: False + Library + default-language: Haskell2010 build-depends: base >= 4.2 && <5, array, fst, @@ -113,7 +118,16 @@ Library PGF.VisualizeTree PGF.OldBinary + if flag(c-runtime) + exposed-modules: CId, CRuntimeFFI + other-modules: Gu, PgfLow + hs-source-dirs: src/runtime/haskell-bind + build-tools: hsc2hs + extra-libraries: gu pgf + cc-options: -std=c99 + Executable gf + default-language: Haskell2010 build-depends: gf, base >= 4.2 && <5, array, @@ -140,6 +154,8 @@ Executable gf other-modules: GFServer hs-source-dirs: src/server src/server/transfer src/example-based + if flag(c-runtime) + cpp-options: -DC_RUNTIME --if flag(new-comp) -- cpp-options: -DNEW_COMP @@ -232,6 +248,13 @@ Executable gf else other-modules: GF.System.NoSignal +executable pgf-shell + if !flag(c-runtime) + buildable: False + main-is: pgf-shell.hs + hs-source-dirs: src/runtime/haskell-bind/examples + build-depends: gf, base + default-language: Haskell2010 test-suite rgl-tests type: exitcode-stdio-1.0 diff --git a/src/compiler/GF/Infra/BuildInfo.hs b/src/compiler/GF/Infra/BuildInfo.hs index cba57cf2a..07f5a0bfc 100644 --- a/src/compiler/GF/Infra/BuildInfo.hs +++ b/src/compiler/GF/Infra/BuildInfo.hs @@ -18,6 +18,9 @@ buildInfo = #endif #ifdef NEW_COMP ++" new-comp" +#endif +#ifdef C_RUNTIME + ++" c-runtime" #endif where details = either (const no_info) info darcs_info diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs index c28a99c5e..a81b6b397 100644 --- a/src/compiler/GFServer.hs +++ b/src/compiler/GFServer.hs @@ -150,7 +150,7 @@ handle documentroot state0 cache execute1 case (takeDirectory path,takeFileName path,takeExtension path) of (_ ,_ ,".pgf") -> wrapCGI $ PS.cgiMain' cache path (dir,"grammars.cgi",_ ) -> grammarList dir (decoded qs) - (dir ,"exb.fcgi" ,_ ) -> wrapCGI $ ES.cgiMain' root dir cache + (dir ,"exb.fcgi" ,_ ) -> wrapCGI $ ES.cgiMain' root dir (fst cache) _ -> liftIO $ serveStaticFile path where path = translatePath rpath _ -> err $ resp400 upath diff --git a/src/runtime/haskell-bind/CRuntimeFFI.hsc b/src/runtime/haskell-bind/CRuntimeFFI.hsc index ff0ed628a..389495962 100644 --- a/src/runtime/haskell-bind/CRuntimeFFI.hsc +++ b/src/runtime/haskell-bind/CRuntimeFFI.hsc @@ -15,8 +15,8 @@ module CRuntimeFFI(-- * PGF ) where import Prelude hiding (fromEnum) -import Control.Monad -import System.IO +--import Control.Monad +--import System.IO import System.IO.Unsafe import CId (CId(..), mkCId, wildCId, @@ -26,11 +26,11 @@ import PgfLow import Foreign hiding ( Pool, newPool, unsafePerformIO ) import Foreign.C -import Foreign.C.String -import Foreign.Ptr +--import Foreign.C.String +--import Foreign.Ptr -import Data.Char +--import Data.Char import qualified Data.ByteString as BS import Data.IORef diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index 1f4e2bdce..6c2232a95 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module PGFService(cgiMain,cgiMain',getPath, logFile,stderrToFile, newPGFCache) where @@ -8,6 +9,11 @@ import Cache import FastCGIUtils import URLEncoding +#if C_RUNTIME +import qualified CRuntimeFFI as C +import qualified CId as C +#endif + import Network.CGI import Text.JSON import Text.PrettyPrint as PP(render, text, (<+>)) @@ -36,7 +42,16 @@ catchIOE = E.catch logFile :: FilePath logFile = "pgf-error.log" -newPGFCache = newCache PGF.readPGF +#ifdef C_RUNTIME +type Caches = (Cache PGF,Cache C.PGF) +newPGFCache = do pgfCache <- newCache PGF.readPGF + cCache <- newCache C.readPGF + return (pgfCache,cCache) +#else +type Caches = (Cache PGF,()) +newPGFCache = do pgfCache <- newCache PGF.readPGF + return (pgfCache,()) +#endif getPath = do path <- getVarWithDefault "PATH_TRANSLATED" "" -- apache mod_fastcgi @@ -44,30 +59,98 @@ getPath = then getVarWithDefault "SCRIPT_FILENAME" "" -- lighttpd else return path -cgiMain :: Cache PGF -> CGI CGIResult +cgiMain :: Caches -> CGI CGIResult cgiMain cache = handleErrors . handleCGIErrors $ cgiMain' cache =<< getPath -cgiMain' :: Cache PGF -> FilePath -> CGI CGIResult +cgiMain' :: Caches -> FilePath -> CGI CGIResult cgiMain' cache path = do command <- liftM (maybe "grammar" (urlDecodeUnicode . UTF8.decodeString)) (getInput "command") case command of "download" -> outputBinary =<< liftIO (BS.readFile path) - _ -> pgfMain command =<< liftIO (readCache cache path) +#ifdef C_RUNTIME + 'c':'-':_ -> cpgfMain command =<< liftIO (readCache (snd cache) path) +#endif + _ -> pgfMain command =<< liftIO (readCache (fst cache) path) + +-------------------------------------------------------------------------------- +-- * C run-time functionality + +#ifdef C_RUNTIME +cpgfMain :: String -> C.PGF -> CGI CGIResult +cpgfMain command pgf = + case command of + "c-parse" -> out =<< parse # input % from % limit % trie + "c-linearize" -> out =<< lin # tree % to + "c-translate" -> out =<< trans # input % from % to % limit % trie + _ -> badRequest "Unknown command" command + where + parse input (from,concr) mlimit trie = + showJSON [makeObj ("from".=from:"trees".=trees :[])] + -- :addTrie trie trees + where + trees = parse' input concr mlimit + + parse' input concr mlimit = + map fst $ -- hmm + maybe id take mlimit (C.parse concr (C.startCat pgf) input) + + lin tree tos = showJSON (lin' tree tos) + lin' tree tos = [makeObj ["to".=to,"text".=C.linearize c tree]|(to,c)<-tos] + + trans input (from,concr) tos mlimit trie = + showJSON [ makeObj ["from".=from, + "translations".= + [makeObj ["tree".=tree, + "linearizations".=lin' tree tos] + | tree <- parse' input concr mlimit]]] + + from = maybe (missing "from") return =<< getLang "from" + + to = getLangs "to" + + getLangs = getLangs' readLang + getLang = getLang' readLang + + readLang :: String -> CGI (C.Language,C.Concr) + readLang l = + case C.readCId l of + Nothing -> badRequest "Bad language" l + Just lang -> + case C.getConcr pgf lang of + Just c -> return (lang,c) + _ -> badRequest "Unknown language" l + + tree = do s <- maybe (missing "tree") return =<< getInput1 "tree" + let t = C.readExpr s + maybe (badRequest "bad tree" s) return t + +instance JSON C.CId where + readJSON x = readJSON x >>= maybe (fail "Bad language.") return . C.readCId + showJSON = showJSON . C.showCId + +instance JSON C.Expr where + readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . C.readExpr + showJSON = showJSON . C.showExpr + +#endif + +-------------------------------------------------------------------------------- +-- * Haskell run-time functionality pgfMain :: String -> PGF -> CGI CGIResult pgfMain command pgf = case command of - "parse" -> out =<< doParse pgf # text % cat % from % limit % trie - "complete" -> out =<< doComplete pgf # text % cat % from % limit + "parse" -> out =<< doParse pgf # input % cat % from % limit % trie + "complete" -> out =<< doComplete pgf # input % cat % from % limit "linearize" -> out =<< doLinearize pgf # tree % to "linearizeAll" -> out =<< doLinearizes pgf # tree % to "linearizeTable" -> out =<< doLinearizeTabular pgf # tree % to "random" -> cat >>= \c -> depth >>= \dp -> limit >>= \l -> to >>= \to -> liftIO (doRandom pgf c dp l to) >>= out "generate" -> out =<< doGenerate pgf # cat % depth % limit % to - "translate" -> out =<< doTranslate pgf # text % cat % from % to % limit % trie - "translategroup" -> out =<< doTranslateGroup pgf # text % cat % from % to % limit + "translate" -> out =<< doTranslate pgf # input % cat % from % to % limit % trie + "translategroup" -> out =<< doTranslateGroup pgf # input % cat % from % to % limit "grammar" -> out =<< doGrammar pgf # requestAcceptLanguage "abstrtree" -> outputGraphviz =<< abstrTree pgf # graphvizOptions % tree "alignment" -> outputGraphviz =<< alignment pgf # tree % to @@ -78,15 +161,9 @@ pgfMain command pgf = "abstrjson" -> out . jsonExpr =<< tree "browse" -> join $ doBrowse pgf # optId % cssClass % href % format "html" % getIncludePrintNames "external" -> do cmd <- getInput "external" - input <- text - doExternal cmd input + doExternal cmd =<< input _ -> throwCGIError 400 "Unknown command" ["Unknown command: " ++ show command] where - out = outputJSONP - - text :: CGI String - text = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input" - tree :: CGI PGF.Tree tree = do ms <- getInput "tree" s <- maybe (throwCGIError 400 "No tree given" ["No tree given"]) return ms @@ -101,10 +178,9 @@ pgfMain command pgf = cat :: CGI (Maybe PGF.Type) cat = - do mcat <- getInput "cat" + do mcat <- getInput1 "cat" case mcat of Nothing -> return Nothing - Just "" -> return Nothing Just cat -> case PGF.readType cat of Nothing -> throwCGIError 400 "Bad category" ["Bad category: " ++ cat] Just typ -> return $ Just typ -- typecheck the category @@ -118,36 +194,6 @@ pgfMain command pgf = cssClass, href :: CGI (Maybe String) cssClass = getInput "css-class" href = getInput "href" - - limit, depth :: CGI (Maybe Int) - limit = readInput "limit" - depth = readInput "depth" - - from :: CGI (Maybe PGF.Language) - from = getLang "from" - - to :: CGI [PGF.Language] - to = getLangs "to" - - trie :: CGI Bool - trie = maybe False toBool # getInput "trie" - - getLangs :: String -> CGI [PGF.Language] - getLangs i = mapM readLang . maybe [] words =<< getInput i - - getLang :: String -> CGI (Maybe PGF.Language) - getLang i = - do mlang <- getInput i - case mlang of - Just l@(_:_) -> Just # readLang l - _ -> return Nothing - - readLang :: String -> CGI PGF.Language - readLang l = - case PGF.readLanguage l of - Nothing -> throwCGIError 400 "Bad language" ["Bad language: " ++ l] - Just lang | lang `elem` PGF.languages pgf -> return lang - | otherwise -> throwCGIError 400 "Unknown language" ["Unknown language: " ++ l] getIncludePrintNames :: CGI Bool getIncludePrintNames = maybe False (const True) # getInput "printnames" @@ -166,12 +212,59 @@ pgfMain command pgf = string name = maybe "" id # getInput name bool name = maybe False toBool # getInput name - toBool s = s `elem` ["","yes","true","True"] + from = getLang "from" + to = getLangs "to" -errorMissingId = throwCGIError 400 "Missing identifier" [] + getLangs = getLangs' readLang + getLang = getLang' readLang + + readLang :: String -> CGI PGF.Language + readLang l = + case PGF.readLanguage l of + Nothing -> throwCGIError 400 "Bad language" ["Bad language: " ++ l] + Just lang | lang `elem` PGF.languages pgf -> return lang + | otherwise -> throwCGIError 400 "Unknown language" ["Unknown language: " ++ l] + +-- * Request parameter access and related auxiliary functions + +out = outputJSONP + +getInput1 x = nonEmpty # getInput x +nonEmpty (Just "") = Nothing +nonEmpty r = r + + +input :: CGI String +input = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input" + +getLangs' readLang i = mapM readLang . maybe [] words =<< getInput i + +getLang' readLang i = + do mlang <- getInput i + case mlang of + Just l@(_:_) -> Just # readLang l + _ -> return Nothing + + +limit, depth :: CGI (Maybe Int) +limit = readInput "limit" +depth = readInput "depth" + +trie :: CGI Bool +trie = maybe False toBool # getInput "trie" + +toBool s = s `elem` ["","yes","true","True"] + +missing = badRequest "Missing parameter" +errorMissingId = badRequest "Missing identifier" "" + +badRequest msg extra = + throwCGIError 400 msg [msg ++(if null extra then "" else ": "++extra)] format def = maybe def id # getInput "format" +-- * Request implementations + -- Hook for simple extensions of the PGF service doExternal Nothing input = throwCGIError 400 "Unknown external command" ["Unknown external command"] doExternal (Just cmd) input =