forked from GitHub/gf-core
bb585fef2c
The editor needs to keep track of both the raw term and the nice term returned by exprToAPI. (Manually constructed linearization rules will now have the raw term and can not be tested.) Also replace metavariables in generalized terms with the apropriate parameter from the linearization rule. Also fix communication problems caused by inconsistent use of show/read vs showExpr/readExpr.
120 lines
3.8 KiB
Haskell
120 lines
3.8 KiB
Haskell
module ExampleService(cgiMain,newPGFCache) where
|
|
import Data.Map(fromList)
|
|
import Data.Char(isDigit)
|
|
import Data.Maybe(fromJust)
|
|
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 cache =
|
|
handleErrors . handleCGIErrors $
|
|
do command <- getInp "command"
|
|
environ <- parseEnviron =<< getInp "state"
|
|
cgiMain' cache command environ
|
|
|
|
cgiMain' cache command environ =
|
|
case command of
|
|
"possibilities" -> outputJSONP (E.getNext environ)
|
|
"provide_example" -> doProvideExample cache environ
|
|
"abstract_example" -> doAbstractExample cache environ
|
|
"test_function" -> doTestFunction cache environ
|
|
_ -> throwCGIError 400 ("Unknown command: "++command) []
|
|
|
|
doProvideExample cache environ =
|
|
do Just lang <- readInput "lang"
|
|
fun <- getCId "fun"
|
|
parsePGF <- readParsePGF cache
|
|
pgf <- liftIO . readCache cache =<< getInp "grammar"
|
|
let Just (e,s) = E.provideExample environ fun parsePGF pgf lang
|
|
res = (showExpr [] e,s)
|
|
liftIO $ logError $ "proveExample ... = "++show res
|
|
outputJSONP res
|
|
|
|
doAbstractExample 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 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 cache environ =
|
|
do fun <- getCId "fun"
|
|
parsePGF <- readParsePGF 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 cache = liftIO $ readCache cache "ParseEngAbs.pgf"
|
|
|
|
parseEnviron s = do state <- liftIO $ readIO s
|
|
return $ environ state
|
|
|
|
getInp name = maybe err return =<< 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
|