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

* 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
	

3 files changed, 91 insertions, 21 deletions

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 = "<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 []