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

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

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

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

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

src/runtime/haskell-bind/CRuntimeFFI.hsc

@@ -15,8 +15,8 @@ module CRuntimeFFI(-- * PGF
                    ) where
 
 import Prelude hiding (fromEnum)
-import Control.Monad
+--import Control.Monad
-import System.IO
+--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.C.String
-import Foreign.Ptr
+--import Foreign.Ptr
 
 
-import Data.Char
+--import Data.Char
 import qualified Data.ByteString as BS
 import Data.IORef
 

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
+      "parse"          -> out =<< doParse pgf # input % cat % from % limit % trie
-      "complete"       -> out =<< doComplete pgf # text % cat % from % limit
+      "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
+      "translate"      -> out =<< doTranslate pgf # input % cat % from % to % limit % trie
-      "translategroup" -> out =<< doTranslateGroup pgf # text % cat % from % to % limit
+      "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
@@ -119,36 +195,6 @@ pgfMain command pgf =
     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
 
+    from = getLang "from"
+    to = getLangs "to"
+
+    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"]
 
-errorMissingId = throwCGIError 400 "Missing identifier" []
+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 =