diff options
Diffstat (limited to 'src-3.0/GF/Visualization')
| -rw-r--r-- | src-3.0/GF/Visualization/Graphviz.hs | 116 | ||||
| -rw-r--r-- | src-3.0/GF/Visualization/VisualizeGrammar.hs | 125 | ||||
| -rw-r--r-- | src-3.0/GF/Visualization/VisualizeTree.hs | 58 |
3 files changed, 299 insertions, 0 deletions
diff --git a/src-3.0/GF/Visualization/Graphviz.hs b/src-3.0/GF/Visualization/Graphviz.hs new file mode 100644 index 000000000..b59e3ecd2 --- /dev/null +++ b/src-3.0/GF/Visualization/Graphviz.hs @@ -0,0 +1,116 @@ +---------------------------------------------------------------------- +-- | +-- Module : Graphviz +-- Maintainer : BB +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/15 18:10:44 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Graphviz DOT format representation and printing. +----------------------------------------------------------------------------- + +module GF.Visualization.Graphviz ( + Graph(..), GraphType(..), + Node(..), Edge(..), + Attr, + addSubGraphs, + setName, + setAttr, + prGraphviz + ) where + +import Data.Char + +import GF.Data.Utilities + +-- | Graph type, graph ID, graph attirbutes, graph nodes, graph edges, subgraphs +data Graph = Graph { + gType :: GraphType, + gId :: Maybe String, + gAttrs :: [Attr], + gNodes :: [Node], + gEdges :: [Edge], + gSubgraphs :: [Graph] + } + deriving (Show) + +data GraphType = Directed | Undirected + deriving (Show) + +data Node = Node String [Attr] + deriving Show + +data Edge = Edge String String [Attr] + deriving Show + +type Attr = (String,String) + +-- +-- * Graph construction +-- + +addSubGraphs :: [Graph] -> Graph -> Graph +addSubGraphs gs g = g { gSubgraphs = gs ++ gSubgraphs g } + +setName :: String -> Graph -> Graph +setName n g = g { gId = Just n } + +setAttr :: String -> String -> Graph -> Graph +setAttr n v g = g { gAttrs = tableSet n v (gAttrs g) } + +-- +-- * Pretty-printing +-- + +prGraphviz :: Graph -> String +prGraphviz g@(Graph t i _ _ _ _) = + graphtype t ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}\n" + +prSubGraph :: Graph -> String +prSubGraph g@(Graph _ i _ _ _ _) = + "subgraph" ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}" + +prGraph :: Graph -> String +prGraph (Graph t id at ns es ss) = + unlines $ map (++";") (map prAttr at + ++ map prNode ns + ++ map (prEdge t) es + ++ map prSubGraph ss) + +graphtype :: GraphType -> String +graphtype Directed = "digraph" +graphtype Undirected = "graph" + +prNode :: Node -> String +prNode (Node n at) = esc n ++ " " ++ prAttrList at + +prEdge :: GraphType -> Edge -> String +prEdge t (Edge x y at) = esc x ++ " " ++ edgeop t ++ " " ++ esc y ++ " " ++ prAttrList at + +edgeop :: GraphType -> String +edgeop Directed = "->" +edgeop Undirected = "--" + +prAttrList :: [Attr] -> String +prAttrList [] = "" +prAttrList at = "[" ++ join "," (map prAttr at) ++ "]" + +prAttr :: Attr -> String +prAttr (n,v) = esc n ++ " = " ++ esc v + +esc :: String -> String +esc s | needEsc s = "\"" ++ concat [ if shouldEsc c then ['\\',c] else [c] | c <- s ] ++ "\"" + | otherwise = s + where shouldEsc = (`elem` ['"', '\\']) + +needEsc :: String -> Bool +needEsc [] = True +needEsc xs | all isDigit xs = False +needEsc (x:xs) = not (isIDFirst x && all isIDChar xs) + +isIDFirst, isIDChar :: Char -> Bool +isIDFirst c = c `elem` (['_']++['a'..'z']++['A'..'Z']) +isIDChar c = isIDFirst c || isDigit c diff --git a/src-3.0/GF/Visualization/VisualizeGrammar.hs b/src-3.0/GF/Visualization/VisualizeGrammar.hs new file mode 100644 index 000000000..b5446aec8 --- /dev/null +++ b/src-3.0/GF/Visualization/VisualizeGrammar.hs @@ -0,0 +1,125 @@ +---------------------------------------------------------------------- +-- | +-- Module : VisualizeGrammar +-- Maintainer : BB +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/14 15:17:30 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.10 $ +-- +-- Print a graph of module dependencies in Graphviz DOT format +-- FIXME: change this to use GF.Visualization.Graphviz, +-- instead of rolling its own. +----------------------------------------------------------------------------- + +module GF.Visualization.VisualizeGrammar ( visualizeCanonGrammar, + visualizeSourceGrammar + ) where + +import qualified GF.Infra.Modules as M +import GF.Canon.GFC +import GF.Infra.Ident +import GF.Infra.Option +import GF.Grammar.Grammar (SourceGrammar) + +import Data.List (intersperse, nub) +import Data.Maybe (maybeToList) + +data GrType = GrAbstract + | GrConcrete + | GrResource + | GrInterface + | GrInstance + deriving Show + +data Node = Node { + label :: String, + url :: String, + grtype :: GrType, + extends :: [String], + opens :: [String], + implements :: Maybe String + } + deriving Show + + +visualizeCanonGrammar :: Options -> CanonGrammar -> String +visualizeCanonGrammar opts = prGraph . canon2graph + +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 = l, + url = l ++ ".gf", -- FIXME: might be in a different directory + grtype = t, + extends = map prIdent (M.extends 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) = fromModType (M.mtype m) + +fromModType :: M.ModuleType Ident -> (GrType, Maybe String) +fromModType t = case t 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.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 + +-- | FIXME: there is something odd about OQualif with 'with' modules, +-- both names seem to be the same. +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 + t = grtype n + stmts = [l ++ " [" ++ prAttributes attrs ++ "]"] + ++ map (prExtend t l) (extends n) + ++ map (prOpen l) (opens n) + ++ 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 :: 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 :: 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 ++ "]" + +prAttributes :: [(String,String)] -> String +prAttributes = concat . intersperse ", " . map (\ (n,v) -> n ++ " = " ++ show v) diff --git a/src-3.0/GF/Visualization/VisualizeTree.hs b/src-3.0/GF/Visualization/VisualizeTree.hs new file mode 100644 index 000000000..5fe740c12 --- /dev/null +++ b/src-3.0/GF/Visualization/VisualizeTree.hs @@ -0,0 +1,58 @@ +---------------------------------------------------------------------- +-- | +-- Module : VisualizeTree +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: +-- > CVS $Author: +-- > CVS $Revision: +-- +-- Print a graph of an abstract syntax tree in Graphviz DOT format +-- Based on BB's VisualizeGrammar +-- FIXME: change this to use GF.Visualization.Graphviz, +-- instead of rolling its own. +----------------------------------------------------------------------------- + +module GF.Visualization.VisualizeTree ( visualizeTrees + ) where + +import GF.Infra.Ident +import GF.Infra.Option +import GF.Grammar.Abstract +import GF.Data.Zipper +import GF.Grammar.PrGrammar + +import Data.List (intersperse, nub) +import Data.Maybe (maybeToList) + +visualizeTrees :: Options -> [Tree] -> String +visualizeTrees opts = unlines . map (prGraph opts . tree2graph opts) + +tree2graph :: Options -> Tree -> [String] +tree2graph opts = prf [] where + prf ps t@(Tr (node, trees)) = + let (nod,lab) = prn ps node in + (nod ++ " [label = " ++ lab ++ ", style = \"solid\", shape = \"plaintext\"] ;") : + [ pra (j:ps) nod t | (j,t) <- zip [0..] trees] ++ + concat [prf (j:ps) t | (j,t) <- zip [0..] trees] + prn ps (N (bi,at,val,_,_)) = + let + lab = + "\"" ++ + prb bi ++ + prc at val ++ + "\"" + in if oElem (iOpt "g") opts then (lab,lab) else (show(show (ps :: [Int])),lab) + prb [] = "" + prb bi = "\\" ++ concat (intersperse "," (map (prt_ . fst) bi)) ++ " -> " + pra i nod t@(Tr (node,_)) = nod ++ arr ++ fst (prn i node) ++ " [style = \"solid\"];" + prc a v + | oElem (iOpt "c") opts = prt_ v + | oElem (iOpt "f") opts = prt_ a + | otherwise = prt_ a ++ " : " ++ prt_ v + arr = if oElem (iOpt "g") opts then " -> " else " -- " + +prGraph opts ns = concat $ map (++"\n") $ [graph ++ "{\n"] ++ ns ++ ["}"] where + graph = if oElem (iOpt "g") opts then "digraph" else "graph" |