Added visualization of source modules.

src/GF/Shell.hs

@@ -41,6 +41,7 @@ import Operations
 import UseIO
 import UTF8 (encodeUTF8)
 
+import VisualizeGrammar (visualizeSourceGrammar)
 
 ---- import qualified GrammarToGramlet as Gr
 ---- import qualified GrammarToCanonXML2 as Canon
@@ -228,6 +229,8 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of
   CPrintMultiGrammar  -> do
     sa' <- changeState purgeShellState sa
     returnArg (AString (optPrintMultiGrammar opts cgr)) sa'
+  CPrintSourceGrammar -> 
+      returnArg (AString (visualizeSourceGrammar src)) sa
 
 ----  CPrintGramlet       -> returnArg (AString (Gr.prGramlet st)) sa
 ----  CPrintCanonXML      -> returnArg (AString (Canon.prCanonXML st False)) sa

src/GF/Shell/PShell.hs

@@ -113,6 +113,7 @@ pCommand ws = case ws of
   "pxs" : []     -> aUnit CPrintCanonXMLStruct
   "px"  : []     -> aUnit CPrintCanonXML
   "pm"  : []     -> aUnit CPrintMultiGrammar
+  "sg" : []     -> aUnit CPrintSourceGrammar
   "po"  : []     -> aUnit CPrintGlobalOptions
   "pl"  : []     -> aUnit CPrintLanguages
   "h"   : c : [] -> aUnit $ CHelp (Just (abbrevCommand c))

src/GF/Shell/ShellCommands.hs

@@ -57,6 +57,7 @@ data Command =
  | CPrintLanguages
  | CPrintInformation I.Ident
  | CPrintMultiGrammar
+ | CPrintSourceGrammar
  | CPrintGramlet 
  | CPrintCanonXML
  | CPrintCanonXMLStruct 
@@ -166,6 +167,7 @@ optionsOfCommand co = case co of
 
   CPrintGrammar -> both "utf8" "printer lang"
   CPrintMultiGrammar -> both "utf8" "printer"
+  CPrintSourceGrammar -> both "utf8" "printer"
 
   CHelp _ -> opts "all filter length lexer unlexer printer transform depth number"
 

src/GF/UseGrammar/Custom.hs

@@ -52,7 +52,7 @@ import qualified PrintParser as Prt
 import GFC
 import qualified MkGFC as MC
 import PrintCFGrammar (prCanonAsCFGM)
-import VisualizeGrammar (visualizeGrammar)
+import VisualizeGrammar (visualizeCanonGrammar, visualizeSourceGrammar)
 
 import MyParser
 
@@ -230,7 +230,7 @@ customMultiGrammarPrinter =
    (strCI "gfcm", MC.prCanon)
   ,(strCI "header", MC.prCanonMGr)
   ,(strCI "cfgm", prCanonAsCFGM)
-  ,(strCI "graph", visualizeGrammar)
+  ,(strCI "graph", visualizeCanonGrammar)
   ]
   ++ moreCustomMultiGrammarPrinter
 

src/GF/Visualization/VisualizeGrammar.hs

@@ -4,15 +4,21 @@ module VisualizeGrammar where
 import qualified Modules as M
 import GFC
 import Ident
+import Grammar (SourceGrammar)
 
-import Data.List (intersperse)
+import Data.List (intersperse, nub)
 import Data.Maybe (maybeToList)
 
-data GrType = GrAbstract | GrConcrete | GrResource
+data GrType = GrAbstract 
+	    | GrConcrete 
+	    | GrResource 
+	    | GrInterface
+	    | GrInstance
 	    deriving Show
 
 data Node = Node { 
 		  label :: String,
+		  url :: String,
 		  grtype :: GrType,
 		  extends :: [String],
 		  opens :: [String],
@@ -21,28 +27,40 @@ data Node = Node {
 		  deriving Show
 
 
-visualizeGrammar :: CanonGrammar -> String
-visualizeGrammar gr = prGraph ns
-    where
-    ns = [ toNode i m | (i,M.ModMod m) <- M.modules gr ]
+visualizeCanonGrammar :: CanonGrammar -> String
+visualizeCanonGrammar = prGraph . canon2graph
 
-toNode :: Ident -> M.Module Ident f Info -> Node
+visualizeSourceGrammar :: SourceGrammar -> String
+visualizeSourceGrammar = prGraph . source2graph
+
+canon2graph :: CanonGrammar -> [Node]
+canon2graph gr = [ toNode i m | (i,M.ModMod m) <- M.modules gr ]
+
+source2graph :: SourceGrammar -> [Node]
+source2graph gr = [ toNode i m | (i,M.ModMod m) <- M.modules gr ] -- FIXME: handle ModWith
+
+toNode :: Ident -> M.Module Ident f i -> Node
 toNode i m = Node {
-		   label = prIdent i,
+		   label = l,
+		   url = l ++ ".gf", -- FIXME: might be in a different directory
 		   grtype = t,
 		   extends = map prIdent (M.extends m),
-		   opens = map openName (M.opens m),
+		   opens = nub $ map openName (M.opens m), -- FIXME: nub is needed because of triple open with 
+		                                           -- instance modules
 		   implements = is
 		  }
     where 
+    l = prIdent i
     (t,is) = case M.mtype m of
 			  M.MTAbstract -> (GrAbstract, Nothing)
+			  M.MTTransfer _ _ -> error "Can't visualize transfer modules yet" -- FIXME
 			  M.MTConcrete i -> (GrConcrete, Just (prIdent i))
 			  M.MTResource -> (GrResource, Nothing)
-			  M.MTTransfer _ _ -> 
-			      -- FIXME
-			      error "Can't visualize transfer modules yet"
-    
+			  M.MTInterface -> (GrInterface, Nothing)
+			  M.MTInstance i -> (GrInstance, Just (prIdent i))
+			  M.MTReuse rt -> error "Can't visualize reuse modules yet" -- FIXME
+			  M.MTUnion _ _ -> error "Can't visualize union modules yet" -- FIXME
+
 openName :: M.OpenSpec Ident -> String
 openName (M.OSimple q i) = prIdent i
 openName (M.OQualif q i _) = prIdent i
@@ -54,25 +72,28 @@ prNode :: Node -> String
 prNode n = concat (map (++";\n") stmts)
     where 
     l = label n
+    t = grtype n
     stmts = [l ++ " [" ++ prAttributes attrs ++ "]"]
-	    ++ map (prExtend l) (extends n)
+	    ++ map (prExtend t 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),("URL", l++".gf")] -- FIXME: might be in a different directory
+	    ++ map (prImplement t l) (maybeToList (implements n))
+    (shape,style) = case t of
+			   GrAbstract  -> ("ellipse","solid")
+			   GrConcrete  -> ("box","dashed")
+			   GrResource  -> ("ellipse","dashed")
+			   GrInterface -> ("ellipse","dotted")
+			   GrInstance  -> ("diamond","dotted")
+    attrs = [("style", style),("shape", shape),("URL", url n)]
 
 
-prExtend :: String -> String -> String
-prExtend f t = prEdge f t []
+prExtend :: GrType -> String -> String -> String
+prExtend g f t = prEdge f t [("style","solid")]
 
 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")]
+prImplement :: GrType -> String -> String -> String
+prImplement g f t = prEdge f t [("arrowhead","empty"),("style","dashed")]
 
 prEdge :: String -> String -> [(String,String)] -> String
 prEdge f t as = f ++ " -> " ++ t ++ " [" ++ prAttributes as ++ "]"