mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-11 13:59:31 -06:00
126 lines
4.0 KiB
Haskell
126 lines
4.0 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- 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)
|