mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 13:09:33 -06:00
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 FastCGIUtils
|
|
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
|