summaryrefslogtreecommitdiff
path: root/src/example-based/ExampleService.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/example-based/ExampleService.hs')
-rw-r--r--src/example-based/ExampleService.hs43
1 files changed, 33 insertions, 10 deletions
diff --git a/src/example-based/ExampleService.hs b/src/example-based/ExampleService.hs
index 0d105c746..165caccba 100644
--- a/src/example-based/ExampleService.hs
+++ b/src/example-based/ExampleService.hs
@@ -1,5 +1,7 @@
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
@@ -31,18 +33,23 @@ doProvideExample cache environ =
fun <- getCId "fun"
parsePGF <- readParsePGF cache
pgf <- liftIO . readCache cache =<< getInp "grammar"
- let Just s = E.provideExample environ fun parsePGF pgf lang
- outputJSONP s
+ 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 abs <- readInput "abstract"
+ 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
- Just (e,_) <- liftIO $ abstractExample parsePGF environ lang t abs example
- outputJSONP (exprToAPI e)
+ 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)
@@ -77,20 +84,36 @@ instance JSON CId where
readJSON = (readResult =<<) . readJSON
instance JSON Expr where
- showJSON = showJSON . show
- readJSON = (readResult =<<) . readJSON
+ 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,lins,funs) =
+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 \ No newline at end of file
+ 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