diff options
| -rw-r--r-- | src/GF/UseGrammar/Custom.hs | 2 | ||||
| -rw-r--r-- | src/GF/Visualization/VisualizeGrammar.hs | 79 | ||||
| -rw-r--r-- | src/Makefile | 4 |
3 files changed, 83 insertions, 2 deletions
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) |