1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
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
|
