msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Optionally include C run-time support

Browse Source 
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.
This commit is contained in:
hallgren
2014-01-20 17:06:11 +00:00
parent 801a20d27a
commit 9d71ffc831
6 changed files with 179 additions and 56 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
Setup.hs
View File

@@ -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 =

25
gf.cabal
View File

@@ -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

3
src/compiler/GF/Infra/BuildInfo.hs
View File

@@ -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

2
src/compiler/GFServer.hs
View File

@@ -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

10
src/runtime/haskell-bind/CRuntimeFFI.hsc
View File

@@ -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

191
src/server/PGFService.hs
View File

@@ -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 =