From 6d72126ffced8aaee001d1c766dfce41935d9b6d Mon Sep 17 00:00:00 2001 From: hallgren Date: Tue, 24 Mar 2015 17:37:43 +0000 Subject: [PATCH] PGF Service: add an option to return syntax trees in JSON format 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). --- src/runtime/haskell/PGF.hs | 6 ++-- src/server/PGFService.hs | 72 ++++++++++++++++++++++++++------------ 2 files changed, 52 insertions(+), 26 deletions(-) diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index 8c901c7a9..d2e70166c 100644 --- a/src/runtime/haskell/PGF.hs +++ b/src/runtime/haskell/PGF.hs @@ -349,12 +349,12 @@ browse pgf id = fmap (\def -> (def,producers,consumers)) definition expIds _ ids = ids -- | A type for plain applicative trees -data ATree = Other Tree | App CId [ATree] deriving Show -data Trie = Oth Tree | Ap CId [[Trie ]] deriving Show +data ATree t = Other t | App CId [ATree t] deriving Show +data Trie = Oth Tree | Ap CId [[Trie ]] deriving Show -- ^ A type for tries of plain applicative trees -- | Convert a 'Tree' to an 'ATree' -toATree :: Tree -> ATree +toATree :: Tree -> ATree Tree toATree e = maybe (Other e) app (unApp e) where app (f,es) = App f (map toATree es) diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index 037f32587..ec940bfde 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -128,10 +128,10 @@ getFile get path = cpgfMain qsem command (t,(pgf,pc)) = case command of "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-translate" -> withQSem qsem $ - out t=<< join (trans # input % to % start % limit % trie) + out t=< out t=<< morpho # from1 % textInput "c-flush" -> out t=<< flush "c-grammar" -> out t grammar @@ -155,15 +155,15 @@ cpgfMain qsem command (t,(pgf,pc)) = where 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 - 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 bad err = ["parseFailed".=err] 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: parse' start mlimit ((from,concr),input) = @@ -194,7 +194,7 @@ cpgfMain qsem command (t,(pgf,pc)) = lin' tree (tos,unlex) = [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 return $ showJSON [ makeObj ["from".=from, @@ -203,9 +203,9 @@ cpgfMain qsem command (t,(pgf,pc)) = jsonParses = either bad good where bad err = [makeObj ["error".=err]] - good parses = [makeObj ["tree".=tree, - "prob".=prob, - "linearizations".=lin' tree to] + good parses = [makeObj (addTree jsontree tree++ + ["prob".=prob, + "linearizations".=lin' tree to]) | (tree,prob) <- parses] morpho (from,concr) input = @@ -293,6 +293,17 @@ instance JSON C.Expr where readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . C.readExpr 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 -------------------------------------------------------------------------------- @@ -340,14 +351,14 @@ unlexer = maybe (return id) unlexerfun =<< getInput "unlexer" --pgfMain :: String -> PGF -> CGI CGIResult pgfMain command (t,pgf) = 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 "linearize" -> o =<< doLinearize pgf # tree % to "linearizeAll" -> o =<< doLinearizes pgf # tree % to "linearizeTable" -> o =<< doLinearizeTabular pgf # tree % to "random" -> o =<< join (doRandom 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 "lookupmorpho" -> o =<< doLookupMorpho pgf # from1 % textInput "grammar" -> o =<< doGrammar t pgf # requestAcceptLanguage @@ -467,9 +478,10 @@ depth = readInput "depth" start :: CGI Int start = maybe 0 id # readInput "start" -trie :: CGI Bool -trie = maybe False toBool # getInput "trie" +treeopts :: CGI TreeOpts +treeopts = (,) # getBool "trie" % getBool "jsontree" +getBool x = maybe False toBool # getInput x toBool s = s `elem` ["","yes","true","True"] missing = badRequest "Missing parameter" @@ -515,9 +527,10 @@ doLookupMorpho pgf from input = type From = (Maybe PGF.Language,String) type To = ([PGF.Language],Unlexer) +type TreeOpts = (Bool,Bool) -- (trie,jsontree) -doTranslate :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> Bool -> JSValue -doTranslate pgf (mfrom,input) mcat (tos,unlex) mlimit trie = +doTranslate :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> TreeOpts -> JSValue +doTranslate pgf (mfrom,input) mcat (tos,unlex) mlimit (trie,jsontree) = showJSON [makeObj ("from".=from : "brackets".=bs : jsonTranslateOutput po) | (from,po,bs) <- parse' pgf input mcat mfrom] @@ -527,11 +540,11 @@ doTranslate pgf (mfrom,input) mcat (tos,unlex) mlimit trie = PGF.ParseOk trees -> addTrie trie trees++ ["translations".= - [makeObj ["tree".=tree, - "linearizations".= + [makeObj (addTree jsontree tree++ + ["linearizations".= [makeObj ["to".=to, "text".=unlex text, "brackets".=bs] - | (to,text,bs)<- linearizeAndBind pgf tos tree]] + | (to,text,bs)<- linearizeAndBind pgf tos tree]]) | tree <- maybe id take mlimit trees]] PGF.ParseIncomplete -> ["incomplete".=True] PGF.ParseFailed n -> ["parseFailed".=n] @@ -590,15 +603,17 @@ doTranslateGroup pgf (mfrom,input) mcat (tos,unlex) mlimit = notDisamb = (/="Disamb") . take 6 . PGF.showLanguage -doParse :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> Bool -> JSValue -doParse pgf (mfrom,input) mcat mlimit trie = showJSON $ map makeObj +doParse :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> TreeOpts -> JSValue +doParse pgf (mfrom,input) mcat mlimit (trie,jsontree) = 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] + PGF.ParseOk trees -> ["trees".=trees'] + ++["jsontrees".=map jsonExpr trees'|jsontree] ++addTrie trie trees + where trees' = maybe id take mlimit trees PGF.TypeError errs -> jsonTypeErrors errs PGF.ParseIncomplete -> ["incomplete".=True] PGF.ParseFailed n -> ["parseFailed".=n] @@ -606,6 +621,9 @@ doParse pgf (mfrom,input) mcat mlimit trie = showJSON $ map makeObj addTrie trie trees = ["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 (mfrom,input) mcat mlimit full = showJSON [makeObj ( @@ -859,8 +877,16 @@ doBrowse pgf (Just id) cssClass href _ pn = -- default to "html" format annotatePrintNames = "
"++(unwords pns)++"
" where pns = ["
"++(show lang)++"
"++(PGF.showPrintName pgf lang id)++"
" | 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 -jsonExpr e = evalState (expr (PGF.toATree e)) 0 +jsonExpr e = evalState (expr (toATree e)) 0 where expr e = case e of