summaryrefslogtreecommitdiff
path: root/src/example-based/ExampleService.hs
diff options
context:
space:
mode:
authorKrasimir Angelov <kr.angelov@gmail.com>2018-11-28 14:34:15 +0100
committerKrasimir Angelov <kr.angelov@gmail.com>2018-11-28 14:34:15 +0100
commit05c2cfb628147f7d6fa0a6c2f38eb9d67b2eb007 (patch)
tree407747233fb9092bdf50ae9fd83ce1ce2c9d9ae6 /src/example-based/ExampleService.hs
parent69ad1e617ed9e40d52b1ec2c4b383879c5d622f2 (diff)
remove the example-based folder. The code is still in the archive
Diffstat (limited to 'src/example-based/ExampleService.hs')
-rw-r--r--src/example-based/ExampleService.hs128
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