From a16a420bedda8fcff69c8ecbe138ccb3a4f7a066 Mon Sep 17 00:00:00 2001
From: bringert <unknown>
Date: Wed, 24 Nov 2004 17:54:58 +0000
Subject: [PATCH] Added module graph visualization.

---
 src/GF/UseGrammar/Custom.hs              |  2 +
 src/GF/Visualization/VisualizeGrammar.hs | 79 ++++++++++++++++++++++++
 src/Makefile                             |  4 +-
 3 files changed, 83 insertions(+), 2 deletions(-)
 create mode 100644 src/GF/Visualization/VisualizeGrammar.hs

diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index f28bfc6e1..a2180491a 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/src/GF/UseGrammar/Custom.hs
@@ -52,6 +52,7 @@ import qualified PrintParser as Prt
 import GFC
 import qualified MkGFC as MC
 import PrintCFGrammar (prCanonAsCFGM)
+import VisualizeGrammar (visualizeGrammar)
 
 import MyParser
 
@@ -229,6 +230,7 @@ customMultiGrammarPrinter =
    (strCI "gfcm", MC.prCanon)
   ,(strCI "header", MC.prCanonMGr)
   ,(strCI "cfgm", prCanonAsCFGM)
+  ,(strCI "graph", visualizeGrammar)
   ]
   ++ moreCustomMultiGrammarPrinter
 
diff --git a/src/GF/Visualization/VisualizeGrammar.hs b/src/GF/Visualization/VisualizeGrammar.hs
new file mode 100644
index 000000000..5c920e36d
--- /dev/null
+++ b/src/GF/Visualization/VisualizeGrammar.hs
@@ -0,0 +1,79 @@
+-- Print a graph of module dependencies in Graphviz DOT format
+module VisualizeGrammar where
+
+import qualified Modules as M
+import GFC
+import Ident
+
+import Data.List (intersperse)
+import Data.Maybe (maybeToList)
+
+data GrType = GrAbstract | GrConcrete | GrResource
+	    deriving Show
+
+data Node = Node { 
+		  label :: String,
+		  grtype :: GrType,
+		  extends :: [String],
+		  opens :: [String],
+		  implements :: Maybe String
+		  }
+		  deriving Show
+
+
+visualizeGrammar :: CanonGrammar -> String
+visualizeGrammar gr = prGraph ns
+    where
+    ns = [ toNode i m | (i,M.ModMod m) <- M.modules gr ]
+
+toNode :: Ident -> M.Module Ident f Info -> Node
+toNode i m = Node {
+		   label = prIdent i,
+		   grtype = t,
+		   extends = map prIdent (M.extends m),
+		   opens = map openName (M.opens m),
+		   implements = is
+		  }
+    where 
+    (t,is) = case M.mtype m of
+			  M.MTAbstract -> (GrAbstract, Nothing)
+			  M.MTConcrete i -> (GrConcrete, Just (prIdent i))
+			  M.MTResource -> (GrResource, Nothing)
+			  -- FIXME: transfer and resource
+    
+openName :: M.OpenSpec Ident -> String
+openName (M.OSimple q i) = prIdent i
+openName (M.OQualif q i _) = prIdent i
+
+prGraph :: [Node] -> String
+prGraph ns = concat $ map (++"\n") $ ["digraph {\n"] ++ map prNode ns ++ ["}"]
+
+prNode :: Node -> String
+prNode n = concat (map (++";\n") stmts)
+    where 
+    l = label n
+    stmts = [l ++ " [" ++ prAttributes attrs ++ "]"]
+	    ++ map (prExtend l) (extends n)
+	    ++ map (prOpen l) (opens n)
+	    ++ map (prImplement l) (maybeToList (implements n))
+    style = case grtype n of
+			  GrAbstract -> "solid"
+			  GrConcrete -> "dashed"
+			  GrResource -> "dotted"
+    attrs = [("style",style)]
+
+
+prExtend :: String -> String -> String
+prExtend f t = prEdge f t []
+
+prOpen :: String -> String -> String
+prOpen f t = prEdge f t [("style","dotted")]
+
+prImplement :: String -> String -> String
+prImplement f t = prEdge f t [("arrowhead","empty"),("style","dashed")]
+
+prEdge :: String -> String -> [(String,String)] -> String
+prEdge f t as = f ++ " -> " ++ t ++ " [" ++ prAttributes as ++ "]"
+
+prAttributes :: [(String,String)] -> String
+prAttributes = concat . intersperse ", " . map (\ (n,v) -> n ++ " = " ++ v)
diff --git a/src/Makefile b/src/Makefile
index 74f179716..1c968568e 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -8,8 +8,8 @@ GHCOPTFLAGS=-O $(GHCFLAGS)
 GHCFUDFLAG=
 JAVAFLAGS=-target 1.4 -source 1.4
 
-HUGSINCLUDE    =.:for-hugs:api:source:canonical:cf:grammar:infra:shell:useGrammar:compile:newparsing:trace:
-BASICINCLUDE   =-iapi -icompile -igrammar -iinfra -ishell -isource -icanonical -iuseGrammar -icf -inewparsing -iparsers -inotrace -icfgm -ispeech
+HUGSINCLUDE    =.:for-hugs:api:source:canonical:cf:grammar:infra:shell:useGrammar:compile:newparsing:trace:visualization:
+BASICINCLUDE   =-iapi -icompile -igrammar -iinfra -ishell -isource -icanonical -iuseGrammar -icf -inewparsing -iparsers -inotrace -icfgm -ispeech -ivisualization
 GHCINCLUDE     =-ifor-ghc       $(BASICINCLUDE)
 GHCINCLUDENOFUD=-ifor-ghc-nofud $(BASICINCLUDE) 
 GHCINCLUDEGFT  =-ifor-gft       $(BASICINCLUDE)