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

---
 src/GF/Visualization/VisualizeGrammar.hs | 79 ++++++++++++++++++++++++++++++++
 1 file changed, 79 insertions(+)
 create mode 100644 src/GF/Visualization/VisualizeGrammar.hs

(limited to 'src/GF/Visualization/VisualizeGrammar.hs')

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)
-- 
cgit v1.2.3