msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Functions merge trees into tries in the GF Shell and the PGF web service

Browse Source 
* In the shell, the new command tt (to_trie) merges a list of trees into a
  trie and prints it in a readable way, where unique subtrees are marked with
  a "*" and alternative subtrees are marked with numbers.
* In the PGF web service, adding the parameter trie=yes to the parse and
  translate commands augments the JSON output with a trie.

Example to try in the shell:

	Phrasebook> p -lang=Eng "your son waits for you" | tt
This commit is contained in:
hallgren
2013-10-24 17:29:02 +00:00
parent 2aa5736cb4
commit ad0e67530b
3 changed files with 91 additions and 21 deletions
Download Patch File Download Diff File Expand all files Collapse all files

56
src/server/PGFService.hs
View File

@@ -59,14 +59,14 @@ cgiMain' cache path =
pgfMain :: String -> PGF -> CGI CGIResult
pgfMain command pgf =
case command of
"parse" -> out =<< doParse pgf # text % cat % from % limit
"parse" -> out =<< doParse pgf # text % cat % from % limit % trie
"complete" -> out =<< doComplete pgf # text % cat % from % limit
"linearize" -> out =<< doLinearize pgf # tree % to
"linearizeAll" -> out =<< doLinearizes pgf # tree % to
"linearizeTable" -> out =<< doLinearizeTabular pgf # tree % to
"random" -> cat >>= \c -> depth >>= \dp -> limit >>= \l -> to >>= \to -> liftIO (doRandom pgf c dp l to) >>= out
"generate" -> out =<< doGenerate pgf # cat % depth % limit % to
"translate" -> out =<< doTranslate pgf # text % cat % from % to % limit
"translate" -> out =<< doTranslate pgf # text % cat % from % to % limit % trie
"translategroup" -> out =<< doTranslateGroup pgf # text % cat % from % to % limit
"grammar" -> out =<< doGrammar pgf # requestAcceptLanguage
"abstrtree" -> outputGraphviz =<< abstrTree pgf # graphvizOptions % tree
@@ -129,6 +129,9 @@ pgfMain command pgf =
to :: CGI [PGF.Language]
to = getLangs "to"
trie :: CGI Bool
trie = maybe False toBool # getInput "trie"
getLangs :: String -> CGI [PGF.Language]
getLangs i = mapM readLang . maybe [] words =<< getInput i
@@ -162,7 +165,8 @@ pgfMain command pgf =
where
string name = maybe "" id # getInput name
bool name = maybe False toBool # getInput name
toBool s = s `elem` ["","yes","true","True"]
toBool s = s `elem` ["","yes","true","True"]
errorMissingId = throwCGIError 400 "Missing identifier" []
@@ -188,8 +192,8 @@ doExternal (Just cmd) input =
liftIO $ removeFile tmpfile2
return r
doTranslate :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [PGF.Language] -> Maybe Int -> JSValue
doTranslate pgf input mcat mfrom tos mlimit =
doTranslate :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [PGF.Language] -> Maybe Int -> Bool -> JSValue
doTranslate pgf input mcat mfrom tos mlimit trie =
showJSON
[makeObj ("from".=from : "brackets".=bs : jsonTranslateOutput po)
| (from,po,bs) <- parse' pgf input mcat mfrom]
@@ -197,6 +201,7 @@ doTranslate pgf input mcat mfrom tos mlimit =
jsonTranslateOutput output =
case output of
PGF.ParseOk trees ->
addTrie trie trees++
["translations".=
[makeObj ["tree".=tree,
"linearizations".=
@@ -264,18 +269,22 @@ doTranslateGroup pgf input mcat mfrom tos mlimit =
notDisamb = (/="Disamb") . take 6 . PGF.showLanguage
doParse :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe Int -> JSValue
doParse pgf input mcat mfrom mlimit = showJSON $ map makeObj
doParse :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe Int -> Bool -> JSValue
doParse pgf input mcat mfrom mlimit trie = showJSON $ map makeObj
["from".=from : "brackets".=bs : jsonParseOutput po
| (from,po,bs) <- parse' pgf input mcat mfrom]
where
jsonParseOutput output =
case output of
PGF.ParseOk trees -> ["trees".=maybe id take mlimit trees]
++addTrie trie trees
PGF.TypeError errs -> jsonTypeErrors errs
PGF.ParseIncomplete -> ["incomlete".=True]
PGF.ParseFailed n -> ["parseFailed".=n]
addTrie trie trees =
["trie".=map head (PGF.toTrie (map PGF.toATree trees))|trie]
doComplete :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe Int -> JSValue
doComplete pgf input mcat mfrom mlimit = showJSON
[makeObj ["from".=from, "brackets".=bs, "completions".=cs, "text".=s]
@@ -505,24 +514,31 @@ doBrowse pgf (Just id) cssClass href _ pn = -- default to "html" format
annotatePrintNames = "<DL>"++(unwords pns)++"</DL>"
where pns = ["<DT>"++(show lang)++"</DT><DD>"++(PGF.showPrintName pgf lang id)++"</DD>" | lang <- PGF.languages pgf ]
instance JSON PGF.CId where
readJSON x = readJSON x >>= maybe (fail "Bad language.") return . PGF.readLanguage
showJSON = showJSON . PGF.showLanguage
jsonExpr e = evalState (expr e) 0
-- | Render trees as JSON with numbered functions
jsonExpr e = evalState (expr (PGF.toATree e)) 0
where
expr e = maybe other app (PGF.unApp e)
where
other = return (makeObj ["other".=e])
app (f,es) = do js <- mapM expr es
let children=["children".=js | not (null js)]
i<-inc
return $ makeObj (["fun".=f,"fid".=i]++children)
expr e =
case e of
PGF.Other e -> return (makeObj ["other".=e])
PGF.App f es ->
do js <- mapM expr es
let children=["children".=js | not (null js)]
i<-inc
return $ makeObj (["fun".=f,"fid".=i]++children)
inc :: State Int Int
inc = do i <- get; put (i+1); return i
instance JSON PGF.Trie where
showJSON (PGF.Oth e) = makeObj ["other".=e]
showJSON (PGF.Ap f [[]]) = makeObj ["fun".=f] -- leaf
-- showJSON (PGF.Ap f [es]) = makeObj ["fun".=f,"children".=es] -- one alternative
showJSON (PGF.Ap f alts) = makeObj ["fun".=f,"alts".=alts]
instance JSON PGF.CId where
readJSON x = readJSON x >>= maybe (fail "Bad language.") return . PGF.readLanguage
showJSON = showJSON . PGF.showLanguage
instance JSON PGF.Expr where
readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . PGF.readExpr
showJSON = showJSON . PGF.showExpr []