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

PGF Service: add an option to return syntax trees in JSON format

Browse Source 
The parse/translate/c-parse/c-translate commands now recognize the option
jsontree=true to augment the returned JSON structure with a field called
"jsontree" next to the field "tree", or "jsontrees" next to "trees",
containing the the returned syntax tree in JSON format (the same format
returned by the abstrjson command, similar to the format returned in the
"brackets" field).
This commit is contained in:
hallgren
2015-03-24 17:37:43 +00:00
parent a3183b07b0
commit 40c431ec6c
2 changed files with 52 additions and 26 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
src/runtime/haskell/PGF.hs
View File

@@ -349,12 +349,12 @@ browse pgf id = fmap (\def -> (def,producers,consumers)) definition
expIds _ ids = ids expIds _ ids = ids
-- | A type for plain applicative trees -- | A type for plain applicative trees
data ATree = Other Tree | App CId [ATree] deriving Show data ATree t = Other t | App CId [ATree t] deriving Show
data Trie = Oth Tree | Ap CId [[Trie ]] deriving Show data Trie = Oth Tree | Ap CId [[Trie ]] deriving Show
-- ^ A type for tries of plain applicative trees -- ^ A type for tries of plain applicative trees
-- | Convert a 'Tree' to an 'ATree' -- | Convert a 'Tree' to an 'ATree'
toATree :: Tree -> ATree toATree :: Tree -> ATree Tree
toATree e = maybe (Other e) app (unApp e) toATree e = maybe (Other e) app (unApp e)
where where
app (f,es) = App f (map toATree es) app (f,es) = App f (map toATree es)

72
src/server/PGFService.hs
View File

@@ -128,10 +128,10 @@ getFile get path =
cpgfMain qsem command (t,(pgf,pc)) = cpgfMain qsem command (t,(pgf,pc)) =
case command of case command of
"c-parse" -> withQSem qsem $ "c-parse" -> withQSem qsem $
out t=<< join (parse # input % start % limit % trie) out t=<< join (parse # input % start % limit % treeopts)
"c-linearize" -> out t=<< lin # tree % to "c-linearize" -> out t=<< lin # tree % to
"c-translate" -> withQSem qsem $ "c-translate" -> withQSem qsem $
out t=<< join (trans # input % to % start % limit % trie) out t=<<join(trans # input % to % start % limit%treeopts)
"c-lookupmorpho"-> out t=<< morpho # from1 % textInput "c-lookupmorpho"-> out t=<< morpho # from1 % textInput
"c-flush" -> out t=<< flush "c-flush" -> out t=<< flush
"c-grammar" -> out t grammar "c-grammar" -> out t grammar
@@ -155,15 +155,15 @@ cpgfMain qsem command (t,(pgf,pc)) =
where where
languages = [makeObj ["name".= l] | (l,_)<-Map.toList langs] languages = [makeObj ["name".= l] | (l,_)<-Map.toList langs]
parse input@((from,_),_) start mlimit trie = parse input@((from,_),_) start mlimit (trie,json) =
do r <- parse' start mlimit input do r <- parse' start mlimit input
return $ showJSON [makeObj ("from".=from:jsonParseResult r)] return $ showJSON [makeObj ("from".=from:jsonParseResult json r)]
jsonParseResult = either bad good jsonParseResult json = either bad good
where where
bad err = ["parseFailed".=err] bad err = ["parseFailed".=err]
good trees = "trees".=map tp trees :[] -- :addTrie trie trees good trees = "trees".=map tp trees :[] -- :addTrie trie trees
tp (tree,prob) = makeObj ["tree".=tree,"prob".=prob] tp (tree,prob) = makeObj (addTree json tree++["prob".=prob])
-- Without caching parse results: -- Without caching parse results:
parse' start mlimit ((from,concr),input) = parse' start mlimit ((from,concr),input) =
@@ -194,7 +194,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
lin' tree (tos,unlex) = lin' tree (tos,unlex) =
[makeObj ["to".=to,"text".=unlex (C.linearize c tree)]|(to,c)<-tos] [makeObj ["to".=to,"text".=unlex (C.linearize c tree)]|(to,c)<-tos]
trans input@((from,_),_) to start mlimit trie = trans input@((from,_),_) to start mlimit (trie,jsontree) =
do parses <- parse' start mlimit input do parses <- parse' start mlimit input
return $ return $
showJSON [ makeObj ["from".=from, showJSON [ makeObj ["from".=from,
@@ -203,9 +203,9 @@ cpgfMain qsem command (t,(pgf,pc)) =
jsonParses = either bad good jsonParses = either bad good
where where
bad err = [makeObj ["error".=err]] bad err = [makeObj ["error".=err]]
good parses = [makeObj ["tree".=tree, good parses = [makeObj (addTree jsontree tree++
"prob".=prob, ["prob".=prob,
"linearizations".=lin' tree to] "linearizations".=lin' tree to])
| (tree,prob) <- parses] | (tree,prob) <- parses]
morpho (from,concr) input = morpho (from,concr) input =
@@ -293,6 +293,17 @@ instance JSON C.Expr where
readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . C.readExpr readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . C.readExpr
showJSON = showJSON . C.showExpr showJSON = showJSON . C.showExpr
-- | Convert a 'Tree' to an 'ATree'
cToATree :: C.Expr -> PGF.ATree C.Expr
cToATree e = maybe (PGF.Other e) app (C.unApp e)
where
app (f,es) = PGF.App (read f) (map cToATree es)
instance ToATree C.Expr where
showTree = show
toATree = cToATree
#endif #endif
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@@ -340,14 +351,14 @@ unlexer = maybe (return id) unlexerfun =<< getInput "unlexer"
--pgfMain :: String -> PGF -> CGI CGIResult --pgfMain :: String -> PGF -> CGI CGIResult
pgfMain command (t,pgf) = pgfMain command (t,pgf) =
case command of case command of
"parse" -> o =<< doParse pgf # input % cat % limit % trie "parse" -> o =<< doParse pgf # input % cat % limit % treeopts
"complete" -> o =<< doComplete pgf # input % cat % limit % full "complete" -> o =<< doComplete pgf # input % cat % limit % full
"linearize" -> o =<< doLinearize pgf # tree % to "linearize" -> o =<< doLinearize pgf # tree % to
"linearizeAll" -> o =<< doLinearizes pgf # tree % to "linearizeAll" -> o =<< doLinearizes pgf # tree % to
"linearizeTable" -> o =<< doLinearizeTabular pgf # tree % to "linearizeTable" -> o =<< doLinearizeTabular pgf # tree % to
"random" -> o =<< join (doRandom pgf # cat % depth % limit % to) "random" -> o =<< join (doRandom pgf # cat % depth % limit % to)
"generate" -> o =<< doGenerate pgf # cat % depth % limit % to "generate" -> o =<< doGenerate pgf # cat % depth % limit % to
"translate" -> o =<< doTranslate pgf # input % cat % to % limit %trie "translate" -> o =<< doTranslate pgf # input % cat %to%limit%treeopts
"translategroup" -> o =<< doTranslateGroup pgf # input % cat % to % limit "translategroup" -> o =<< doTranslateGroup pgf # input % cat % to % limit
"lookupmorpho" -> o =<< doLookupMorpho pgf # from1 % textInput "lookupmorpho" -> o =<< doLookupMorpho pgf # from1 % textInput
"grammar" -> o =<< doGrammar t pgf # requestAcceptLanguage "grammar" -> o =<< doGrammar t pgf # requestAcceptLanguage
@@ -467,9 +478,10 @@ depth = readInput "depth"
start :: CGI Int start :: CGI Int
start = maybe 0 id # readInput "start" start = maybe 0 id # readInput "start"
trie :: CGI Bool treeopts :: CGI TreeOpts
trie = maybe False toBool # getInput "trie" treeopts = (,) # getBool "trie" % getBool "jsontree"
getBool x = maybe False toBool # getInput x
toBool s = s `elem` ["","yes","true","True"] toBool s = s `elem` ["","yes","true","True"]
missing = badRequest "Missing parameter" missing = badRequest "Missing parameter"
@@ -515,9 +527,10 @@ doLookupMorpho pgf from input =
type From = (Maybe PGF.Language,String) type From = (Maybe PGF.Language,String)
type To = ([PGF.Language],Unlexer) type To = ([PGF.Language],Unlexer)
type TreeOpts = (Bool,Bool) -- (trie,jsontree)
doTranslate :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> Bool -> JSValue doTranslate :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> TreeOpts -> JSValue
doTranslate pgf (mfrom,input) mcat (tos,unlex) mlimit trie = doTranslate pgf (mfrom,input) mcat (tos,unlex) mlimit (trie,jsontree) =
showJSON showJSON
[makeObj ("from".=from : "brackets".=bs : jsonTranslateOutput po) [makeObj ("from".=from : "brackets".=bs : jsonTranslateOutput po)
| (from,po,bs) <- parse' pgf input mcat mfrom] | (from,po,bs) <- parse' pgf input mcat mfrom]
@@ -527,11 +540,11 @@ doTranslate pgf (mfrom,input) mcat (tos,unlex) mlimit trie =
PGF.ParseOk trees -> PGF.ParseOk trees ->
addTrie trie trees++ addTrie trie trees++
["translations".= ["translations".=
[makeObj ["tree".=tree, [makeObj (addTree jsontree tree++
"linearizations".= ["linearizations".=
[makeObj ["to".=to, "text".=unlex text, [makeObj ["to".=to, "text".=unlex text,
"brackets".=bs] "brackets".=bs]
| (to,text,bs)<- linearizeAndBind pgf tos tree]] | (to,text,bs)<- linearizeAndBind pgf tos tree]])
| tree <- maybe id take mlimit trees]] | tree <- maybe id take mlimit trees]]
PGF.ParseIncomplete -> ["incomplete".=True] PGF.ParseIncomplete -> ["incomplete".=True]
PGF.ParseFailed n -> ["parseFailed".=n] PGF.ParseFailed n -> ["parseFailed".=n]
@@ -590,15 +603,17 @@ doTranslateGroup pgf (mfrom,input) mcat (tos,unlex) mlimit =
notDisamb = (/="Disamb") . take 6 . PGF.showLanguage notDisamb = (/="Disamb") . take 6 . PGF.showLanguage
doParse :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> Bool -> JSValue doParse :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> TreeOpts -> JSValue
doParse pgf (mfrom,input) mcat mlimit trie = showJSON $ map makeObj doParse pgf (mfrom,input) mcat mlimit (trie,jsontree) = showJSON $ map makeObj
["from".=from : "brackets".=bs : jsonParseOutput po ["from".=from : "brackets".=bs : jsonParseOutput po
| (from,po,bs) <- parse' pgf input mcat mfrom] | (from,po,bs) <- parse' pgf input mcat mfrom]
where where
jsonParseOutput output = jsonParseOutput output =
case output of case output of
PGF.ParseOk trees -> ["trees".=maybe id take mlimit trees] PGF.ParseOk trees -> ["trees".=trees']
++["jsontrees".=map jsonExpr trees'|jsontree]
++addTrie trie trees ++addTrie trie trees
where trees' = maybe id take mlimit trees
PGF.TypeError errs -> jsonTypeErrors errs PGF.TypeError errs -> jsonTypeErrors errs
PGF.ParseIncomplete -> ["incomplete".=True] PGF.ParseIncomplete -> ["incomplete".=True]
PGF.ParseFailed n -> ["parseFailed".=n] PGF.ParseFailed n -> ["parseFailed".=n]
@@ -606,6 +621,9 @@ doParse pgf (mfrom,input) mcat mlimit trie = showJSON $ map makeObj
addTrie trie trees = addTrie trie trees =
["trie".=map head (PGF.toTrie (map PGF.toATree trees))|trie] ["trie".=map head (PGF.toTrie (map PGF.toATree trees))|trie]
addTree json tree = "tree".=showTree tree:
["jsontree".= jsonExpr tree | json]
doComplete :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> Bool -> JSValue doComplete :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> Bool -> JSValue
doComplete pgf (mfrom,input) mcat mlimit full = showJSON doComplete pgf (mfrom,input) mcat mlimit full = showJSON
[makeObj ( [makeObj (
@@ -859,8 +877,16 @@ doBrowse pgf (Just id) cssClass href _ pn = -- default to "html" format
annotatePrintNames = "<DL>"++(unwords pns)++"</DL>" annotatePrintNames = "<DL>"++(unwords pns)++"</DL>"
where pns = ["<DT>"++(show lang)++"</DT><DD>"++(PGF.showPrintName pgf lang id)++"</DD>" | lang <- PGF.languages pgf ] where pns = ["<DT>"++(show lang)++"</DT><DD>"++(PGF.showPrintName pgf lang id)++"</DD>" | lang <- PGF.languages pgf ]
class ToATree a where
showTree :: a -> String
toATree :: a -> PGF.ATree a
instance ToATree PGF.Expr where
showTree = PGF.showExpr []
toATree = PGF.toATree
-- | Render trees as JSON with numbered functions -- | Render trees as JSON with numbered functions
jsonExpr e = evalState (expr (PGF.toATree e)) 0 jsonExpr e = evalState (expr (toATree e)) 0
where where
expr e = expr e =
case e of case e of