From 1b7d61ea2eb96c5cdbdec700099c04c9efca6803 Mon Sep 17 00:00:00 2001
From: aarne <aarne@chalmers.se>
Date: Wed, 4 Nov 2015 17:28:09 +0000
Subject: [PATCH] prepared visualize_parse for showing dependency labels

---
 src/compiler/GF/Command/Commands.hs      |  1 +
 src/runtime/haskell/PGF/VisualizeTree.hs | 50 ++++++++++++++++++++----
 src/server/PGFService.hs                 |  1 +
 3 files changed, 45 insertions(+), 7 deletions(-)

diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs
index 488d8cbfd..32612df2c 100644
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -597,6 +597,7 @@ pgfCommands = Map.fromList [
          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),
+                                          noDep = True, ---- TODO
                                           nodeFont = valStrOpts "nodefont" "" opts,
                                           leafFont = valStrOpts "leaffont" "" opts,
                                           nodeColor = valStrOpts "nodecolor" "" opts,
diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs
index cb6affe41..ad043a505 100644
--- a/src/runtime/haskell/PGF/VisualizeTree.hs
+++ b/src/runtime/haskell/PGF/VisualizeTree.hs
@@ -44,6 +44,7 @@ import Text.PrettyPrint
 data GraphvizOptions = GraphvizOptions {noLeaves :: Bool,
                                         noFun :: Bool,
                                         noCat :: Bool,
+                                        noDep :: Bool,
                                         nodeFont :: String,
                                         leafFont :: String,
                                         nodeColor :: String,
@@ -52,7 +53,7 @@ data GraphvizOptions = GraphvizOptions {noLeaves :: Bool,
                                         leafEdgeStyle :: String
                                        }
 
-graphvizDefaults = GraphvizOptions False False False "" "" "" "" "" ""
+graphvizDefaults = GraphvizOptions False False False True "" "" "" "" "" ""
 
 
 -- | Renders abstract syntax tree in Graphviz format
@@ -208,13 +209,15 @@ graphvizDependencyTree format debug mlab ms pgf lang t = render $
 getDepLabels :: [String] -> Labels
 getDepLabels ss = Map.fromList [(mkCId f,ls) | f:ls <- map words ss]
 
-
+-- the old function, without dependencies
 graphvizParseTree :: PGF -> Language -> GraphvizOptions -> Tree -> String
-graphvizParseTree pgf lang opts = graphvizBracketedString opts . bracketedLinearize pgf lang
+graphvizParseTree = graphvizParseTreeDep Nothing
 
+graphvizParseTreeDep :: Maybe Labels -> PGF -> Language -> GraphvizOptions -> Tree -> String
+graphvizParseTreeDep mbl pgf lang opts tree = graphvizBracketedString opts mbl tree $ bracketedLinearize pgf lang tree
 
-graphvizBracketedString :: GraphvizOptions -> [BracketedString] -> String
-graphvizBracketedString opts bss = render graphviz_code
+graphvizBracketedString :: GraphvizOptions -> Maybe Labels -> Tree -> [BracketedString] -> String
+graphvizBracketedString opts mbl tree bss = render graphviz_code
     where
       graphviz_code
           = text "graph {" $$
@@ -258,7 +261,7 @@ graphvizBracketedString opts bss = render graphviz_code
       getInternals []    = []
       getInternals nodes
           = nub [(parent, fid, mkNode fun cat) |
-                 (parent, Bracket cat fid _ fun _ _) <- nodes]
+                 (parent, Bracket cat fid lind fun _ _) <- nodes]
             : getInternals [(fid, child) |
                             (_, Bracket _ fid _ _ _ children) <- nodes,
                             child <- children]
@@ -279,9 +282,42 @@ graphvizBracketedString opts bss = render graphviz_code
                    ) $$
             text "}" $$
             -- the following is for the edges between parent and children:
-            vcat [tag pid <> text " -- " <> tag id <> semi | (pid, id, _) <- nodes, pid /= nil] $$
+            vcat [tag pid <> text " -- " <> tag id <> text (depLabel node) | node@(pid, id, _) <- nodes, pid /= nil] $$
             space
 
+      depLabel node@(parent,id,lbl) 
+        | noDep opts = ";"
+        | otherwise = case getArg id of
+            Just (fun,arg) -> (mkOption "" "label" (showCId fun ++ "#" ++ show arg))
+            _ -> ";"
+      getArg i = getArgumentPlace i (expr2numtree tree) Nothing
+
+---- to restore the argument place from bracketed linearization
+data NumTree = NumTree Int CId [NumTree]
+
+getArgumentPlace :: Int -> NumTree -> Maybe (CId,Int) -> Maybe (CId,Int)
+getArgumentPlace i tree@(NumTree int fun ts) mfi
+ | i == int  = mfi
+ | otherwise = case [fj | (t,x) <- zip ts [0..], Just fj <- [getArgumentPlace i t (Just (fun,x))]] of
+     fj:_ -> Just fj
+     _ -> Nothing
+
+expr2numtree :: Expr -> NumTree
+expr2numtree = fst . renumber 0 . flatten where
+  flatten e = case e of
+    EApp f a -> case flatten f of
+      NumTree _ g ts -> NumTree 0 g (ts ++ [flatten a])
+    EFun f -> NumTree 0 f []
+  renumber i t@(NumTree _ f ts) = case renumbers i ts of
+    (ts',j) -> (NumTree j f ts', j+1)
+  renumbers i ts = case ts of
+    t:tt -> case renumber i t of
+      (t',j) -> case renumbers j tt of (tt',k) -> (t':tt',k)
+    _ -> ([],i)
+----- end this terrible stuff
+ 
+
+
 
 type Rel = (Int,[Int])
 -- possibly needs changes after clearing about many-to-many on this level
diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs
index 5889c07b8..08090f309 100644
--- a/src/server/PGFService.hs
+++ b/src/server/PGFService.hs
@@ -448,6 +448,7 @@ pgfMain command (t,pgf) =
         PGF.GraphvizOptions # bool "noleaves"
                             % bool "nofun"
                             % bool "nocat"
+                            % bool "nodep"
                             % string "nodefont"
                             % string "leaffont"
                             % string "nodecolor"