command dg for showing source grammar dep graph restored

1 files changed, 58 insertions, 0 deletions

diff --git a/src/GF/Infra/Dependencies.hs b/src/GF/Infra/Dependencies.hs
new file mode 100644
index 000000000..084cfce1c
--- /dev/null
+++ b/src/GF/Infra/Dependencies.hs
@@ -0,0 +1,58 @@
+module GF.Infra.Dependencies (
+  depGraph
+  ) where
+
+import GF.Grammar.Grammar
+import GF.Grammar.PrGrammar
+import GF.Infra.Modules
+import GF.Infra.Ident
+
+depGraph :: SourceGrammar -> String
+depGraph = prDepGraph . grammar2moddeps
+
+prDepGraph :: [(Ident,ModDeps)] -> String
+prDepGraph deps = unlines $ [
+  "digraph {"
+  ] ++
+  map mkNode deps ++
+  concatMap mkArrows deps ++ [
+  "}"
+  ]
+ where
+   mkNode (i,dep) = unwords [prt i, "[",nodeAttr (modtype dep),"]"]
+   nodeAttr ty = case ty of
+       MTAbstract   -> "style = \"solid\", shape = \"box\""
+       MTConcrete _ -> "style = \"solid\", shape = \"ellipse\""
+       _ -> "style = \"dashed\", shape = \"ellipse\""
+   mkArrows (i,dep) = 
+     [unwords [prt i,"->",prt j,"[",arrowAttr "of","]"] | j <- ofs dep] ++
+     [unwords [prt i,"->",prt j,"[",arrowAttr "ex","]"] | j <- extendeds dep] ++
+     [unwords [prt i,"->",prt j,"[",arrowAttr "op","]"] | j <- openeds dep]
+   arrowAttr s = case s of
+     "of" -> "style = \"solid\", arrowhead = \"empty\""
+     "ex" -> "style = \"solid\""
+     "op" -> "style = \"dashed\""
+
+data ModDeps = ModDeps {
+  modtype    :: ModuleType Ident,
+  ofs        :: [Ident],
+  extendeds  :: [Ident], 
+  openeds    :: [Ident],
+  functors   :: [Ident],
+  interfaces :: [Ident],
+  instances  :: [Ident]
+  }
+
+noModDeps = ModDeps MTAbstract [] [] [] [] [] []
+
+grammar2moddeps :: SourceGrammar -> [(Ident,ModDeps)]
+grammar2moddeps gr = [(i,depMod m) | (i,ModMod m) <- modules gr] where
+  depMod m = noModDeps{
+    modtype = mtype m,
+    ofs     = case mtype m of 
+                MTConcrete i -> [i]
+                MTInstance i -> [i]
+                _ -> [],
+    extendeds = map fst (extend m),
+    openeds = map openedModule (opens m)
+    }