module Text.Dot
(
Dot
, node
, NodeId
, userNodeId
, userNode
, edge
, showDot
, scope
, attribute
, nodeAttributes
, edgeAttributes
, graphAttributes
, share
, same
, cluster
, Record
, field
, portField
, hcat
, hcat'
, vcat
, vcat'
, record
, record'
, record_
, mrecord
, mrecord'
, mrecord_
) where
import Data.Char (isSpace)
import Data.List (intersperse)
import Control.Monad (liftM, ap)
import Control.Applicative (Applicative(..))
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 Functor Dot where
fmap f m = Dot $ \ uq -> case unDot m uq of (a,b,x) -> (a,b,f x)
instance Applicative Dot where
pure = return
(<*>) = ap
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)
rawNode :: [(String,String)] -> Dot NodeId
rawNode attrs = Dot $ \ uq ->
let nid = NodeId $ "n" ++ show uq
in ( [ GraphNode nid attrs ],succ uq,nid)
node :: [(String,String)] -> Dot NodeId
node = rawNode . map fixLabel
where
fixLabel ("label",lbl) = ("label", fixMultiLineLabel lbl)
fixLabel attr = attr
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,()))
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,()))
nodeAttributes :: [(String,String)] -> Dot ()
nodeAttributes attrs = Dot (\uq -> ([ GraphNode (NodeId "node") attrs],uq,()))
edgeAttributes :: [(String,String)] -> Dot ()
edgeAttributes attrs = Dot (\uq -> ([ GraphNode (NodeId "edge") attrs],uq,()))
graphAttributes :: [(String,String)] -> Dot ()
graphAttributes attrs = Dot (\uq -> ([ GraphNode (NodeId "graph") attrs],uq,()))
showDot :: Dot a -> String
showDot (Dot dm) = case dm 0 of
(elems,_,_) -> "digraph G {\n" ++ unlines (map showGraphElement elems) ++ "\n}\n"
showGraphElement :: GraphElement -> String
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 :: [(String, String)] -> String
showAttrs [] = ""
showAttrs xs = "[" ++ showAttrs' xs ++ "]"
where
showAttrs' [a] = showAttr a
showAttrs' (a:as) = showAttr a ++ "," ++ showAttrs' as
showAttrs' [] = error "showAttrs: the impossible happended"
showAttr :: (String, String) -> String
showAttr (name, val) =
name ++ "=\"" ++ concatMap escape val ++ "\""
where
escape '\n' = "\\l"
escape '"' = "\\\""
escape c = [c]
fixMultiLineLabel :: String -> String
fixMultiLineLabel lbl
| '\n' `elem` lbl = unlines $ map useNonBreakingSpace $ lines lbl
| otherwise = lbl
where
useNonBreakingSpace line = case span isSpace line of
(spaces, rest) -> concat (replicate (length spaces) " ") ++ rest
data Record a =
Field (Maybe a) String
| HCat [Record a]
| VCat [Record a]
deriving( Eq, Ord, Show )
mkField :: Maybe a -> String -> Record a
mkField port = Field port . fixMultiLineLabel
field :: String -> Record a
field = mkField Nothing
portField :: a -> String -> Record a
portField port = mkField (Just port)
hcat :: [Record a] -> Record a
hcat = HCat
hcat' :: [String] -> Record a
hcat' = hcat . map field
vcat :: [Record a] -> Record a
vcat = VCat
vcat' :: [String] -> Record a
vcat' = vcat . map field
renderRecord :: Record a -> Dot (String, NodeId -> [(a,NodeId)])
renderRecord = render True
where
render _ (Field Nothing l) = return (escape l, const [])
render _ (Field (Just p) l) =
Dot $ \uq -> let pid = "n" ++ show uq
lbl = "<"++pid++"> "++escape l
in ([], succ uq, (lbl, \nId -> [(p,NodeId (show nId++":"++pid))]))
render horiz (HCat rs) = do
(lbls, ids) <- liftM unzip $ mapM (render True) rs
let rawLbl = concat (intersperse "|" lbls)
lbl = if horiz then "{{"++rawLbl++"}}" else "{"++rawLbl++"}"
return (lbl, \nId -> concatMap (\i -> i nId) ids)
render horiz (VCat rs) = do
(lbls, ids) <- liftM unzip $ mapM (render False) rs
let rawLbl = concat (intersperse "|" lbls)
lbl = if horiz then "{"++rawLbl++"}" else "{{"++rawLbl++"}}"
return (lbl, \nId -> concatMap (\i -> i nId) ids)
escape = concatMap esc
esc '|' = "\\|"
esc '{' = "\\{"
esc '}' = "\\}"
esc '<' = "\\<"
esc '>' = "\\>"
esc c = [c]
genRecord :: String -> Record a -> [(String,String)] -> Dot (NodeId, [(a,NodeId)])
genRecord shape rec attrs = do
(lbl, ids) <- renderRecord rec
i <- rawNode ([("shape",shape),("label",lbl)] ++ attrs)
return (i, ids i)
record :: Record a -> [(String,String)] -> Dot (NodeId, [(a,NodeId)])
record = genRecord "record"
record' :: Record a -> [(String,String)] -> Dot (NodeId, [NodeId])
record' rec attrs = do (nId, ids) <- record rec attrs
return (nId, map snd ids)
record_ :: Record a -> [(String,String)] -> Dot NodeId
record_ rec attrs = liftM fst $ record rec attrs
mrecord :: Record a -> [(String,String)] -> Dot (NodeId, [(a,NodeId)])
mrecord = genRecord "Mrecord"
mrecord' :: Record a -> [(String,String)] -> Dot (NodeId, [NodeId])
mrecord' rec attrs = do (nId, ids) <- mrecord rec attrs
return (nId, map snd ids)
mrecord_ :: Record a -> [(String,String)] -> Dot NodeId
mrecord_ rec attrs = liftM fst $ mrecord rec attrs