module Text.Dot
(
Dot
, node
, NodeId
, userNodeId
, userNode
, edge
, edge'
, (.->.)
, showDot
, scope
, attribute
, share
, same
, cluster
, netlistGraph
) where
import Control.Applicative
import Control.Monad
import Data.Char
import qualified Data.Map as M
import qualified Data.Set as S
import Prelude
data NodeId = NodeId String
| UserNodeId Int
instance Show NodeId where
show :: NodeId -> String
show (NodeId String
str) = String
str
show (UserNodeId Int
i)
| Int
i forall a. Ord a => a -> a -> Bool
< Int
0 = String
"u_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Num a => a -> a
negate Int
i)
| Bool
otherwise = String
"u" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i
data GraphElement = GraphAttribute String String
| GraphNode NodeId [(String,String)]
| GraphEdge NodeId NodeId [(String,String)]
| GraphEdge' NodeId (Maybe String) NodeId (Maybe String) [(String,String)]
| Scope [GraphElement]
| SubGraph NodeId [GraphElement]
data Dot a = Dot { forall a. Dot a -> Int -> ([GraphElement], Int, a)
unDot :: Int -> ([GraphElement],Int,a) }
instance Functor Dot where
fmap :: forall a b. (a -> b) -> Dot a -> Dot b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative Dot where
pure :: forall a. a -> Dot a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: forall a b. Dot (a -> b) -> Dot a -> Dot b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad Dot where
return :: forall a. a -> Dot a
return a
a = forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
Dot forall a b. (a -> b) -> a -> b
$ \ Int
uq -> ([],Int
uq,a
a)
Dot a
m >>= :: forall a b. Dot a -> (a -> Dot b) -> Dot b
>>= a -> Dot b
k = forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
Dot forall a b. (a -> b) -> a -> b
$ \ Int
uq -> case forall a. Dot a -> Int -> ([GraphElement], Int, a)
unDot Dot a
m Int
uq of
([GraphElement]
g1,Int
uq',a
r) -> case forall a. Dot a -> Int -> ([GraphElement], Int, a)
unDot (a -> Dot b
k a
r) Int
uq' of
([GraphElement]
g2,Int
uq2,b
r2) -> ([GraphElement]
g1 forall a. [a] -> [a] -> [a]
++ [GraphElement]
g2,Int
uq2,b
r2)
node :: [(String,String)] -> Dot NodeId
node :: [(String, String)] -> Dot NodeId
node [(String, String)]
attrs = forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
Dot forall a b. (a -> b) -> a -> b
$ \ Int
uq -> let nid :: NodeId
nid = String -> NodeId
NodeId forall a b. (a -> b) -> a -> b
$ String
"n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
uq
in ( [ NodeId -> [(String, String)] -> GraphElement
GraphNode NodeId
nid [(String, String)]
attrs ],forall a. Enum a => a -> a
succ Int
uq,NodeId
nid)
userNodeId :: Int -> NodeId
userNodeId :: Int -> NodeId
userNodeId Int
i = Int -> NodeId
UserNodeId Int
i
userNode :: NodeId -> [(String,String)] -> Dot ()
userNode :: NodeId -> [(String, String)] -> Dot ()
userNode NodeId
nId [(String, String)]
attrs = forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
Dot forall a b. (a -> b) -> a -> b
$ \ Int
uq -> ( [NodeId -> [(String, String)] -> GraphElement
GraphNode NodeId
nId [(String, String)]
attrs ],Int
uq,())
edge :: NodeId -> NodeId -> [(String,String)] -> Dot ()
edge :: NodeId -> NodeId -> [(String, String)] -> Dot ()
edge NodeId
from NodeId
to [(String, String)]
attrs = forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
Dot (\ Int
uq -> ( [ NodeId -> NodeId -> [(String, String)] -> GraphElement
GraphEdge NodeId
from NodeId
to [(String, String)]
attrs ],Int
uq,()))
edge' :: NodeId -> Maybe String -> NodeId -> Maybe String -> [(String,String)] -> Dot ()
edge' :: NodeId
-> Maybe String
-> NodeId
-> Maybe String
-> [(String, String)]
-> Dot ()
edge' NodeId
from Maybe String
optF NodeId
to Maybe String
optT [(String, String)]
attrs = forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
Dot (\ Int
uq -> ( [ NodeId
-> Maybe String
-> NodeId
-> Maybe String
-> [(String, String)]
-> GraphElement
GraphEdge' NodeId
from Maybe String
optF NodeId
to Maybe String
optT [(String, String)]
attrs ],Int
uq,()))
(.->.) :: NodeId -> NodeId -> Dot ()
.->. :: NodeId -> NodeId -> Dot ()
(.->.) NodeId
from NodeId
to = NodeId -> NodeId -> [(String, String)] -> Dot ()
edge NodeId
from NodeId
to []
scope :: Dot a -> Dot a
scope :: forall a. Dot a -> Dot a
scope (Dot Int -> ([GraphElement], Int, a)
fn) = forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
Dot (\ Int
uq -> case Int -> ([GraphElement], Int, a)
fn Int
uq of
( [GraphElement]
elems,Int
uq',a
a) -> ([[GraphElement] -> GraphElement
Scope [GraphElement]
elems],Int
uq',a
a))
share :: [(String,String)] -> [NodeId] -> Dot ()
share :: [(String, String)] -> [NodeId] -> Dot ()
share [(String, String)]
attrs [NodeId]
nodeids = forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
Dot forall a b. (a -> b) -> a -> b
$ \ Int
uq ->
( [ [GraphElement] -> GraphElement
Scope ( [ String -> String -> GraphElement
GraphAttribute String
name String
val | (String
name,String
val) <- [(String, String)]
attrs]
forall a. [a] -> [a] -> [a]
++ [ NodeId -> [(String, String)] -> GraphElement
GraphNode NodeId
nodeid [] | NodeId
nodeid <- [NodeId]
nodeids ]
)
], Int
uq, ())
same :: [NodeId] -> Dot ()
same :: [NodeId] -> Dot ()
same = [(String, String)] -> [NodeId] -> Dot ()
share [(String
"rank",String
"same")]
cluster :: Dot a -> Dot (NodeId,a)
cluster :: forall a. Dot a -> Dot (NodeId, a)
cluster (Dot Int -> ([GraphElement], Int, a)
fn) = forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
Dot (\ Int
uq ->
let cid :: NodeId
cid = String -> NodeId
NodeId forall a b. (a -> b) -> a -> b
$ String
"cluster_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
uq
in case Int -> ([GraphElement], Int, a)
fn (forall a. Enum a => a -> a
succ Int
uq) of
([GraphElement]
elems,Int
uq',a
a) -> ([NodeId -> [GraphElement] -> GraphElement
SubGraph NodeId
cid [GraphElement]
elems],Int
uq',(NodeId
cid,a
a)))
attribute :: (String,String) -> Dot ()
attribute :: (String, String) -> Dot ()
attribute (String
name,String
val) = forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
Dot (\ Int
uq -> ( [ String -> String -> GraphElement
GraphAttribute String
name String
val ],Int
uq,()))
showDot :: Dot a -> String
showDot :: forall a. Dot a -> String
showDot (Dot Int -> ([GraphElement], Int, a)
dm) = case Int -> ([GraphElement], Int, a)
dm Int
0 of
([GraphElement]
elems,Int
_,a
_) -> String
"digraph G {\n" forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map GraphElement -> String
showGraphElement [GraphElement]
elems) forall a. [a] -> [a] -> [a]
++ String
"\n}\n"
showGraphElement :: GraphElement -> String
showGraphElement :: GraphElement -> String
showGraphElement (GraphAttribute String
name String
val) = (String, String) -> String
showAttr (String
name,String
val) forall a. [a] -> [a] -> [a]
++ String
";"
showGraphElement (GraphNode NodeId
nid [(String, String)]
attrs) = forall a. Show a => a -> String
show NodeId
nid forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
showAttrs [(String, String)]
attrs forall a. [a] -> [a] -> [a]
++ String
";"
showGraphElement (GraphEdge NodeId
from NodeId
to [(String, String)]
attrs) = forall a. Show a => a -> String
show NodeId
from forall a. [a] -> [a] -> [a]
++ String
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show NodeId
to forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
showAttrs [(String, String)]
attrs forall a. [a] -> [a] -> [a]
++ String
";"
showGraphElement (GraphEdge' NodeId
from Maybe String
optF NodeId
to Maybe String
optT [(String, String)]
attrs) = forall {a}. Show a => a -> Maybe String -> String
showName NodeId
from Maybe String
optF forall a. [a] -> [a] -> [a]
++ String
" -> " forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => a -> Maybe String -> String
showName NodeId
to Maybe String
optT forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
showAttrs [(String, String)]
attrs forall a. [a] -> [a] -> [a]
++ String
";"
where showName :: a -> Maybe String -> String
showName a
n Maybe String
Nothing = forall a. Show a => a -> String
show a
n
showName a
n (Just String
t) = forall a. Show a => a -> String
show a
n forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ String
t
showGraphElement (Scope [GraphElement]
elems) = String
"{\n" forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map GraphElement -> String
showGraphElement [GraphElement]
elems) forall a. [a] -> [a] -> [a]
++ String
"\n}"
showGraphElement (SubGraph NodeId
nid [GraphElement]
elems) = String
"subgraph " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show NodeId
nid forall a. [a] -> [a] -> [a]
++ String
" {\n" forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map GraphElement -> String
showGraphElement [GraphElement]
elems) forall a. [a] -> [a] -> [a]
++ String
"\n}"
showAttrs :: [(String, String)] -> String
showAttrs :: [(String, String)] -> String
showAttrs [] = String
""
showAttrs [(String, String)]
xs = String
"[" forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
showAttrs' [(String, String)]
xs forall a. [a] -> [a] -> [a]
++ String
"]"
where
showAttrs' :: [(String, String)] -> String
showAttrs' [(String, String)
a] = (String, String) -> String
showAttr (String, String)
a
showAttrs' ((String, String)
a:[(String, String)]
as) = (String, String) -> String
showAttr (String, String)
a forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
showAttrs' [(String, String)]
as
showAttrs' [] = forall a. HasCallStack => String -> a
error String
"The list should never be empty"
showAttr :: (String, String) -> String
showAttr :: (String, String) -> String
showAttr (String
name,String
val) = String
name forall a. [a] -> [a] -> [a]
++ String
"=\"" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> ShowS
showsDotChar String
"" String
val forall a. [a] -> [a] -> [a]
++ String
"\""
showsDotChar :: Char -> ShowS
showsDotChar :: Char -> ShowS
showsDotChar Char
'"' = (String
"\\\"" forall a. [a] -> [a] -> [a]
++)
showsDotChar Char
'\\' = (String
"\\\\" forall a. [a] -> [a] -> [a]
++)
showsDotChar Char
x
| Char -> Bool
isPrint Char
x = Char -> ShowS
showChar Char
x
| Bool
otherwise = Char -> ShowS
showLitChar Char
x
netlistGraph :: (Ord a)
=> (b -> [(String,String)])
-> (b -> [a])
-> [(a,b)]
-> Dot ()
netlistGraph :: forall a b.
Ord a =>
(b -> [(String, String)]) -> (b -> [a]) -> [(a, b)] -> Dot ()
netlistGraph b -> [(String, String)]
attrFn b -> [a]
outFn [(a, b)]
assocs = do
let nodes :: Set a
nodes = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ [ a
a | (a
a,b
_) <- [(a, b)]
assocs ]
let outs :: Set a
outs = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ [ a
o | (a
_,b
b) <- [(a, b)]
assocs
, a
o <- b -> [a]
outFn b
b
]
[(a, NodeId)]
nodeTab <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ do NodeId
nd <- [(String, String)] -> Dot NodeId
node (b -> [(String, String)]
attrFn b
b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,NodeId
nd)
| (a
a,b
b) <- [(a, b)]
assocs ]
[(a, NodeId)]
otherTab <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ do NodeId
nd <- [(String, String)] -> Dot NodeId
node []
forall (m :: * -> *) a. Monad m => a -> m a
return (a
o,NodeId
nd)
| a
o <- forall a. Set a -> [a]
S.toList Set a
outs
, a
o forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set a
nodes
]
let fm :: Map a NodeId
fm = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(a, NodeId)]
nodeTab forall a. [a] -> [a] -> [a]
++ [(a, NodeId)]
otherTab)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ (Map a NodeId
fm forall k a. Ord k => Map k a -> k -> a
M.! a
src) NodeId -> NodeId -> Dot ()
.->. (Map a NodeId
fm forall k a. Ord k => Map k a -> k -> a
M.! a
dst)
| (a
dst,b
b) <- [(a, b)]
assocs
, a
src <- b -> [a]
outFn b
b
]
forall (m :: * -> *) a. Monad m => a -> m a
return ()