module Text.Dot
(
Dot
, node
, NodeId
, userNodeId
, userNode
, edge
, (.->.)
, showDot
, scope
, attribute
, share
, same
, cluster
) where
data DotGraph = DotGraph [GraphElement]
data NodeId = NodeId String
| UserNodeId Int
instance Show NodeId where
show (NodeId str) = str
show (UserNodeId i)
| i < 0 = "u_" ++ show (negate i)
| otherwise = "u" ++ show i
data GraphElement = GraphAttribute String String
| GraphNode NodeId [(String,String)]
| GraphEdge NodeId NodeId [(String,String)]
| Scope [GraphElement]
| SubGraph NodeId [GraphElement]
data Dot a = Dot { unDot :: Int -> ([GraphElement],Int,a) }
instance Monad Dot where
return a = Dot $ \ uq -> ([],uq,a)
m >>= k = Dot $ \ uq -> case unDot m uq of
(g1,uq',r) -> case unDot (k r) uq' of
(g2,uq2,r2) -> (g1 ++ g2,uq2,r2)
node :: [(String,String)] -> Dot NodeId
node attrs = Dot $ \ uq -> let nid = NodeId $ "n" ++ show uq
in ( [ GraphNode nid attrs ],succ uq,nid)
userNodeId :: Int -> NodeId
userNodeId i = UserNodeId i
userNode :: NodeId -> [(String,String)] -> Dot ()
userNode nId attrs = Dot $ \ uq -> ( [GraphNode nId attrs ],uq,())
edge :: NodeId -> NodeId -> [(String,String)] -> Dot ()
edge from to attrs = Dot (\ uq -> ( [ GraphEdge from to attrs ],uq,()))
(.->.) from to = edge from to []
scope :: Dot a -> Dot a
scope (Dot fn) = Dot (\ uq -> case fn uq of
( elems,uq',a) -> ([Scope elems],uq',a))
share :: [(String,String)] -> [NodeId] -> Dot ()
share attrs nodeids = Dot $ \ uq ->
( [ Scope ( [ GraphAttribute name val | (name,val) <- attrs]
++ [ GraphNode nodeid [] | nodeid <- nodeids ]
)
], uq, ())
same :: [NodeId] -> Dot ()
same = share [("rank","same")]
cluster :: Dot a -> Dot (NodeId,a)
cluster (Dot fn) = Dot (\ uq ->
let cid = NodeId $ "cluster_" ++ show uq
in case fn (succ uq) of
(elems,uq',a) -> ([SubGraph cid elems],uq',(cid,a)))
attribute :: (String,String) -> Dot ()
attribute (name,val) = Dot (\ uq -> ( [ GraphAttribute name val ],uq,()))
showDot :: Dot a -> String
showDot (Dot dm) = case dm 0 of
(elems,_,_) -> "digraph G {\n" ++ unlines (map showGraphElement elems) ++ "\n}\n"
showGraphElement (GraphAttribute name val) = showAttr (name,val) ++ ";"
showGraphElement (GraphNode nid attrs) = show nid ++ showAttrs attrs ++ ";"
showGraphElement (GraphEdge from to attrs) = show from ++ " -> " ++ show to ++ showAttrs attrs ++ ";"
showGraphElement (Scope elems) = "{\n" ++ unlines (map showGraphElement elems) ++ "\n}"
showGraphElement (SubGraph nid elems) = "subgraph " ++ show nid ++ " {\n" ++ unlines (map showGraphElement elems) ++ "\n}"
showAttrs [] = ""
showAttrs xs = "[" ++ showAttrs' xs ++ "]"
where
showAttrs' [a] = showAttr a
showAttrs' (a:as) = showAttr a ++ "," ++ showAttrs' as
showAttr (name,val) = name ++ "=" ++ show val