GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

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"