mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 13:09:33 -06:00
0e87a88f4b
* Introducing the module CGI, re-exporting a subset of the cgi package. It might complete replace the cgi package in the future. * Introducing the module CGIUtils, containing functions from FastCGIUtils that have nothing to do with fastcgi. Some low level hackery with unsafePerformIO and global variables was left in FastCGIUtils, but it is actually not used, neither for gf -server nor exec/pgf-fcgi.hs.
129 lines
4.2 KiB
Haskell
129 lines
4.2 KiB
Haskell
module ExampleService(cgiMain,cgiMain',newPGFCache) where
|
|
import System.Random(newStdGen)
|
|
import System.FilePath((</>),makeRelative)
|
|
import Data.Map(fromList)
|
|
import Data.Char(isDigit)
|
|
import Data.Maybe(fromJust)
|
|
import qualified Codec.Binary.UTF8.String as UTF8 (decodeString)
|
|
import PGF
|
|
import GF.Compile.ToAPI
|
|
import Network.CGI
|
|
import Text.JSON
|
|
import CGIUtils
|
|
import Cache
|
|
import qualified ExampleDemo as E
|
|
|
|
newPGFCache = newCache readPGF
|
|
|
|
|
|
cgiMain :: Cache PGF -> CGI CGIResult
|
|
cgiMain = handleErrors . handleCGIErrors . cgiMain' "." "."
|
|
|
|
cgiMain' root cwd cache =
|
|
do command <- getInp "command"
|
|
environ <- parseEnviron =<< getInp "state"
|
|
case command of
|
|
"possibilities" -> doPossibilities environ
|
|
"provide_example" -> doProvideExample root cwd cache environ
|
|
"abstract_example" -> doAbstractExample cwd cache environ
|
|
"test_function" -> doTestFunction cwd cache environ
|
|
_ -> throwCGIError 400 ("Unknown command: "++command) []
|
|
|
|
doPossibilities environ =
|
|
do example_environ <- parseEnviron =<< getInp "example_state"
|
|
outputJSONP (E.getNext environ example_environ)
|
|
|
|
doProvideExample root cwd cache environ =
|
|
do Just lang <- readInput "lang"
|
|
fun <- getCId "fun"
|
|
parsePGF <- readParsePGF cwd cache
|
|
let adjpath path = root</>makeRelative "/" (makeRelative root cwd</>path)
|
|
pgf <- liftIO . readCache cache . adjpath =<< getInp "grammar"
|
|
gen <- liftIO newStdGen
|
|
let Just (e,s) = E.provideExample gen environ fun parsePGF pgf lang
|
|
res = (showExpr [] e,s)
|
|
liftIO $ logError $ "proveExample ... = "++show res
|
|
outputJSONP res
|
|
|
|
doAbstractExample cwd cache environ =
|
|
do example <- getInp "input"
|
|
Just params <- readInput "params"
|
|
absstr <- getInp "abstract"
|
|
Just abs <- return $ readExpr absstr
|
|
liftIO $ logError $ "abstract = "++showExpr [] abs
|
|
Just cat <- readInput "cat"
|
|
let t = mkType [] cat []
|
|
parsePGF <- readParsePGF cwd cache
|
|
let lang:_ = languages parsePGF
|
|
ae <- liftIO $ abstractExample parsePGF environ lang t abs example
|
|
outputJSONP (fmap (\(e,_)->(exprToAPI (instExpMeta params e),e)) ae)
|
|
|
|
abstractExample parsePGF env lang cat abs example =
|
|
E.searchGoodTree env abs (parse parsePGF lang cat example)
|
|
|
|
doTestFunction cwd cache environ =
|
|
do fun <- getCId "fun"
|
|
parsePGF <- readParsePGF cwd cache
|
|
let lang:_ = languages parsePGF
|
|
Just txt <- return (E.testThis environ fun parsePGF lang)
|
|
outputJSONP txt
|
|
|
|
getCId :: String -> CGI CId
|
|
getCId name = maybe err return =<< fmap readCId (getInp name)
|
|
where err = throwCGIError 400 ("Bad "++name) []
|
|
|
|
getLimit :: CGI Int
|
|
getLimit = maybe err return =<< readInput "limit"
|
|
where err = throwCGIError 400 "Missing/bad limit" []
|
|
|
|
|
|
readParsePGF cwd cache =
|
|
do parsepgf <- getInp "parser"
|
|
liftIO $ readCache cache (cwd</>parsepgf)
|
|
|
|
parseEnviron s = do state <- liftIO $ readIO s
|
|
return $ environ state
|
|
|
|
getInp name = maybe err (return . UTF8.decodeString) =<< getInput name
|
|
where err = throwCGIError 400 ("Missing parameter: "++name) []
|
|
|
|
|
|
instance JSON CId where
|
|
showJSON = showJSON . show
|
|
readJSON = (readResult =<<) . readJSON
|
|
|
|
instance JSON Expr where
|
|
showJSON = showJSON . showExpr []
|
|
readJSON = (m2r . readExpr =<<) . readJSON
|
|
|
|
m2r = maybe (Error "read failed") Ok
|
|
|
|
readResult s = case reads s of
|
|
(x,r):_ | lex r==[("","")] -> Ok x
|
|
_ -> Error "read failed"
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- cat lincat fun lin fun cat cat
|
|
environ :: ([(CId, CId)],[(CId, Expr)],[((CId, CId), [CId])]) -> E.Environ
|
|
environ (lincats,lins0,funs) =
|
|
E.initial (fromList lincats) concmap fs allfs
|
|
where
|
|
concmap = fromList lins
|
|
allfs = map E.mkFuncWithArg funs
|
|
fs = [E.mkFuncWithArg f | f@((fn,_),_)<-funs, fn `elem` cns]
|
|
cns = map fst lins
|
|
lins = filter (not . E.isMeta .snd) lins0
|
|
|
|
|
|
instExpMeta :: [CId] -> Expr -> Expr
|
|
instExpMeta ps = fromJust . readExpr . instMeta ps . showExpr []
|
|
|
|
instMeta :: [CId] -> String -> String
|
|
instMeta ps s =
|
|
case break (=='?') s of
|
|
(s1,'?':s2) ->
|
|
case span isDigit s2 of
|
|
(s21@(_:_),s22) -> s1++show (ps!!(read s21-1))++instMeta ps s22
|
|
("",s22) -> s1++'?':instMeta ps s22
|
|
(_,_) -> s
|