diff options
Diffstat (limited to 'src/example-based/ExampleService.hs')
| -rw-r--r-- | src/example-based/ExampleService.hs | 128 |
1 files changed, 0 insertions, 128 deletions
diff --git a/src/example-based/ExampleService.hs b/src/example-based/ExampleService.hs deleted file mode 100644 index e6312bf96..000000000 --- a/src/example-based/ExampleService.hs +++ /dev/null @@ -1,128 +0,0 @@ -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 |
