diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index 8643f8a75..681b64f0d 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -687,6 +687,12 @@ allCommands = Map.fromList [ ("to", "forward-apply transliteration defined in this file") ] }), + ("tt", emptyCommandInfo { + longname = "to_trie", + syntax = "to_trie", + synopsis = "combine a list of trees into a trie", + exec = \ _ _ -> return . fromString . trie + }), ("pt", emptyCommandInfo { longname = "put_tree", syntax = "pt OPT? TREE", @@ -1407,3 +1413,18 @@ execToktok (pgf, _) opts exprs = do getLang [] = Nothing getLang (OFlag "lang" (VId l):_) = readLanguage l getLang (_:os) = getLang os + + + +trie = render . pptss . toTrie . map toATree + where + pptss [ts] = text "*"<+>nest 2 (ppts ts) + pptss tss = vcat [int i<+>nest 2 (ppts ts)|(i,ts)<-zip [1..] tss] + + ppts = vcat . map ppt + + ppt t = + case t of + Oth e -> text (showExpr [] e) + Ap f [[]] -> text (showCId f) + Ap f tss -> text (showCId f) $$ nest 2 (pptss tss) diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index d0eadd764..1d0d13f97 100644 --- a/src/runtime/haskell/PGF.hs +++ b/src/runtime/haskell/PGF.hs @@ -136,7 +136,9 @@ module PGF( -- forExample, -- * Browsing - browse + browse, + -- * Tries + ATree(..),Trie(..),toATree,toTrie ) where import PGF.CId @@ -328,3 +330,34 @@ browse pgf id = fmap (\def -> (def,producers,consumers)) definition expIds (EFun id) ids = id : ids expIds (ETyped e _) ids = expIds e ids 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 +-- ^ A type for tries of plain applicative trees + +-- | Convert a 'Tree' to an 'ATree' +toATree :: Tree -> ATree +toATree e = maybe (Other e) app (unApp e) + where + app (f,es) = App f (map toATree es) + +-- | Combine a list of trees into a trie +toTrie = combines . map ((:[]) . singleton) + where + singleton t = case t of + Other e -> Oth e + App f ts -> Ap f [map singleton ts] + + combines [] = [] + combines (ts:tss) = ts1:combines tss2 + where + (ts1,tss2) = combines2 [] tss ts + combines2 ots [] ts1 = (ts1,reverse ots) + combines2 ots (ts2:tss) ts1 = + maybe (combines2 (ts2:ots) tss ts1) (combines2 ots tss) (combine ts1 ts2) + + combine ts us = mapM combine2 (zip ts us) + where + combine2 (Ap f ts,Ap g us) | f==g = Just (Ap f (combines (ts++us))) + combine2 _ = Nothing diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index 5b1f65448..fcda86e7c 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -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 = "
"++(unwords pns)++"
" where pns = ["
"++(show lang)++"
"++(PGF.showPrintName pgf lang id)++"
" | 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 []