better visualization of parse trees

2 files changed, 127 insertions, 9 deletions

diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs
index 548874a7d..195caa2e1 100644
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -968,7 +968,7 @@ allCommands = Map.fromList [
      longname = "visualize_parse",
      synopsis = "show parse tree graphically",
      explanation = unlines [
-       "Prints a parse tree the .dot format (the graphviz format).",
+       "Prints a parse tree in the .dot format (the graphviz format).",
        "The graph can be saved in a file by the wf command as usual.",
        "If the -view flag is defined, the graph is saved in a temporary file",
        "which is processed by graphviz and displayed by the program indicated",
@@ -977,7 +977,21 @@ allCommands = Map.fromList [
        ],
      exec = \env@(pgf, mos) opts es -> do
          let lang = optLang pgf opts
-         let grph = if null es then [] else graphvizParseTree pgf lang (head es)
+         let gvOptions = GraphvizOptions {noLeaves = isOpt "noleaves" opts && not (isOpt "showleaves" opts),
+                                          noFun = isOpt "nofun" opts || not (isOpt "showfun" opts),
+                                          noCat = isOpt "nocat" opts && not (isOpt "showcat" opts),
+                                          nodeFont = valStrOpts "nodefont" "" opts,
+                                          leafFont = valStrOpts "leaffont" "" opts,
+                                          nodeColor = valStrOpts "nodecolor" "" opts,
+                                          leafColor = valStrOpts "leafcolor" "" opts,
+                                          nodeEdgeStyle = valStrOpts "nodeedgestyle" "solid" opts,
+                                          leafEdgeStyle = valStrOpts "leafedgestyle" "dashed" opts
+                                         }
+         let grph = if null es then [] 
+                    else if isOpt "old" opts then 
+                             graphvizParseTreeOld pgf lang (head es)
+                         else 
+                             graphvizParseTree pgf lang gvOptions (head es)
          if isFlag "view" opts || isFlag "format" opts then do
            let file s = "_grph." ++ s
            let view = optViewGraph opts
@@ -992,13 +1006,27 @@ allCommands = Map.fromList [
        mkEx "gr | vp -view=\"open\" -- generate a tree and display parse tree on a Mac"
        ],
      options = [
+       ("showcat","show categories in the tree nodes (default)"),
+       ("nocat","don't show categories"),
+       ("showfun","show function names in the tree nodes"),
+       ("nofun","don't show function names (default)"),
+       ("showleaves","show the leaves of the tree (default)"),
+       ("noleaves","don't show the leaves of the tree (i.e., only the abstract tree)"),
+       ("old","use the old tree visualization algorithm")
        ],
      flags = [
        ("format","format of the visualization file (default \"png\")"),
-       ("view","program to open the resulting file (default \"open\")")
+       ("view","program to open the resulting file (default \"open\")"),
+       ("nodefont","font for tree nodes (default: Times -- graphviz standard font)"),
+       ("leaffont","font for tree leaves (default: nodefont)"),
+       ("nodecolor","color for tree nodes (default: black -- graphviz standard color)"),
+       ("leafcolor","color for tree leaves (default: nodecolor)"),
+       ("nodeedgestyle","edge style between tree nodes (solid/dashed/dotted/bold, default: solid)"),
+       ("leafedgestyle","edge style for links to leaves (solid/dashed/dotted/bold, default: dashed)")
        ]
     }),
 
+
   ("vt", emptyCommandInfo {
      longname = "visualize_tree",
      synopsis = "show a set of trees graphically",
diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs
index 6cc5e64eb..c9a5686fc 100644
--- a/src/runtime/haskell/PGF/VisualizeTree.hs
+++ b/src/runtime/haskell/PGF/VisualizeTree.hs
@@ -16,8 +16,10 @@
 -----------------------------------------------------------------------------
 
 module PGF.VisualizeTree 
-             ( graphvizAbstractTree
+             ( GraphvizOptions(..)
+             , graphvizAbstractTree
              , graphvizParseTree
+             , graphvizParseTreeOld
              , graphvizDependencyTree
              , graphvizBracketedString
              , graphvizAlignment
@@ -45,6 +47,18 @@ import qualified Data.Set as Set
 import qualified Text.ParserCombinators.ReadP as RP
 
 
+data GraphvizOptions = GraphvizOptions {noLeaves :: Bool,
+                                        noFun :: Bool,
+                                        noCat :: Bool,
+                                        nodeFont :: String,
+                                        leafFont :: String,
+                                        nodeColor :: String,
+                                        leafColor :: String,
+                                        nodeEdgeStyle :: String,
+                                        leafEdgeStyle :: String
+                                       }
+
+
 -- | Renders abstract syntax tree in Graphviz format
 graphvizAbstractTree :: PGF -> (Bool,Bool) -> Tree -> String
 graphvizAbstractTree pgf (funs,cats) = render . tree2graph
@@ -169,11 +183,87 @@ getDepLabels :: [String] -> Labels
 getDepLabels ss = Map.fromList [(mkCId f,ls) | f:ls <- map words ss]
 
 
-graphvizParseTree :: PGF -> Language -> Tree -> String
-graphvizParseTree pgf lang = graphvizBracketedString . bracketedLinearize pgf lang
-
-graphvizBracketedString :: BracketedString -> String
-graphvizBracketedString = render . lin2tree
+graphvizParseTree :: PGF -> Language -> GraphvizOptions -> Tree -> String
+graphvizParseTree pgf lang opts = graphvizBracketedString opts . bracketedLinearize pgf lang
+
+
+graphvizBracketedString :: GraphvizOptions -> BracketedString -> String
+graphvizBracketedString opts bs = render graphviz_code
+    where
+      graphviz_code 
+          = text "graph {" $$
+            text node_style $$
+            vcat internal_nodes $$
+            (if noLeaves opts then empty
+             else text leaf_style $$
+                  leaf_nodes
+            ) $$ text "}" 
+
+      leaf_style = mkOption "edge" "style" (leafEdgeStyle opts) ++
+                   mkOption "edge" "color" (leafColor opts) ++
+                   mkOption "node" "fontcolor" (leafColor opts) ++
+                   mkOption "node" "fontname" (leafFont opts) ++
+                   mkOption "node" "shape" "plaintext"
+
+      node_style = mkOption "edge" "style" (nodeEdgeStyle opts) ++
+                   mkOption "edge" "color" (nodeColor opts) ++
+                   mkOption "node" "fontcolor" (nodeColor opts) ++
+                   mkOption "node" "fontname" (nodeFont opts) ++
+                   mkOption "node" "shape" nodeshape
+          where nodeshape | noFun opts && noCat opts = "point"
+                          | otherwise = "plaintext"
+
+      mkOption object optname optvalue 
+          | null optvalue  = "" 
+          | otherwise      = object ++ "[" ++ optname ++ "=\"" ++ optvalue ++ "\"]; "
+
+      mkNode fun cat
+          | noFun opts = showCId cat
+          | noCat opts = showCId fun
+          | otherwise  = showCId fun ++ " : " ++ showCId cat
+
+      nil = -1
+      internal_nodes = [mkLevel internals | 
+                        internals <- getInternals [(nil, bs)], 
+                        not (null internals)]
+      leaf_nodes = mkLevel [(parent, id, word) | 
+                            (id, (parent, word)) <- zip [100000..] (getLeaves nil bs)]
+
+      getInternals []    = []
+      getInternals nodes 
+          = nub [(parent, fid, mkNode fun cat) | 
+                 (parent, Bracket cat fid _ fun _ _) <- nodes] 
+            : getInternals [(fid, child) | 
+                            (_, Bracket _ fid _ _ _ children) <- nodes, 
+                            child <- children]
+
+      getLeaves parent (Leaf word) = [(parent, word)]
+      getLeaves parent (Bracket _ fid i _ _ children)
+          = concatMap (getLeaves fid) children
+
+      mkLevel nodes 
+          = text "subgraph {rank=same;" $$
+            nest 2 (-- the following gives the name of the node and its label:
+                    vcat [tag id <> text (mkOption "" "label" lbl) | (_, id, lbl) <- nodes] $$
+                    -- the following is for fixing the order between the children:
+                    (if length nodes > 1 then
+                         text (mkOption "edge" "style" "invis") $$
+                         hsep (intersperse (text " -- ") [tag id | (_, id, _) <- nodes]) <+> semi 
+                     else empty)
+                   ) $$
+            text "}" $$
+            -- the following is for the edges between parent and children:
+            vcat [tag pid <> text " -- " <> tag id <> semi | (pid, id, _) <- nodes, pid /= nil] $$
+            space
+
+
+
+graphvizParseTreeOld :: PGF -> Language -> Tree -> String
+graphvizParseTreeOld pgf lang = graphvizBracketedStringOld . bracketedLinearize pgf lang
+
+
+graphvizBracketedStringOld :: BracketedString -> String
+graphvizBracketedStringOld = render . lin2tree
   where
     lin2tree bs =
       text "graph {" $$