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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = String
"u_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int -> Int
forall a. Num a => a -> a
negate Int
i)
| Bool
otherwise = String
"u" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
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 = (a -> b) -> Dot a -> Dot b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative Dot where
pure :: forall a. a -> Dot a
pure = a -> Dot a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: forall a b. Dot (a -> b) -> Dot a -> Dot 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 = (Int -> ([GraphElement], Int, a)) -> Dot a
forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
Dot ((Int -> ([GraphElement], Int, a)) -> Dot a)
-> (Int -> ([GraphElement], Int, a)) -> Dot a
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 = (Int -> ([GraphElement], Int, b)) -> Dot b
forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
Dot ((Int -> ([GraphElement], Int, b)) -> Dot b)
-> (Int -> ([GraphElement], Int, b)) -> Dot b
forall a b. (a -> b) -> a -> b
$ \ Int
uq -> case Dot a -> Int -> ([GraphElement], Int, a)
forall a. Dot a -> Int -> ([GraphElement], Int, a)
unDot Dot a
m Int
uq of
([GraphElement]
g1,Int
uq',a
r) -> case Dot b -> Int -> ([GraphElement], Int, b)
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 [GraphElement] -> [GraphElement] -> [GraphElement]
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 = (Int -> ([GraphElement], Int, NodeId)) -> Dot NodeId
forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
Dot ((Int -> ([GraphElement], Int, NodeId)) -> Dot NodeId)
-> (Int -> ([GraphElement], Int, NodeId)) -> Dot NodeId
forall a b. (a -> b) -> a -> b
$ \ Int
uq -> let nid :: NodeId
nid = String -> NodeId
NodeId (String -> NodeId) -> String -> NodeId
forall a b. (a -> b) -> a -> b
$ String
"n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
uq
in ( [ NodeId -> [(String, String)] -> GraphElement
GraphNode NodeId
nid [(String, String)]
attrs ],Int -> Int
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 = (Int -> ([GraphElement], Int, ())) -> Dot ()
forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
Dot ((Int -> ([GraphElement], Int, ())) -> Dot ())
-> (Int -> ([GraphElement], Int, ())) -> 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 = (Int -> ([GraphElement], Int, ())) -> Dot ()
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 = (Int -> ([GraphElement], Int, ())) -> Dot ()
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) = (Int -> ([GraphElement], Int, a)) -> Dot a
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 = (Int -> ([GraphElement], Int, ())) -> Dot ()
forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
Dot ((Int -> ([GraphElement], Int, ())) -> Dot ())
-> (Int -> ([GraphElement], Int, ())) -> 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]
[GraphElement] -> [GraphElement] -> [GraphElement]
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) = (Int -> ([GraphElement], Int, (NodeId, a))) -> Dot (NodeId, a)
forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
Dot (\ Int
uq ->
let cid :: NodeId
cid = String -> NodeId
NodeId (String -> NodeId) -> String -> NodeId
forall a b. (a -> b) -> a -> b
$ String
"cluster_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
uq
in case Int -> ([GraphElement], Int, a)
fn (Int -> Int
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) = (Int -> ([GraphElement], Int, ())) -> Dot ()
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" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((GraphElement -> String) -> [GraphElement] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map GraphElement -> String
showGraphElement [GraphElement]
elems) String -> ShowS
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) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
";"
showGraphElement (GraphNode NodeId
nid [(String, String)]
attrs) = NodeId -> String
forall a. Show a => a -> String
show NodeId
nid String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
showAttrs [(String, String)]
attrs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
";"
showGraphElement (GraphEdge NodeId
from NodeId
to [(String, String)]
attrs) = NodeId -> String
forall a. Show a => a -> String
show NodeId
from String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NodeId -> String
forall a. Show a => a -> String
show NodeId
to String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
showAttrs [(String, String)]
attrs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
";"
showGraphElement (GraphEdge' NodeId
from Maybe String
optF NodeId
to Maybe String
optT [(String, String)]
attrs) = NodeId -> Maybe String -> String
forall {a}. Show a => a -> Maybe String -> String
showName NodeId
from Maybe String
optF String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NodeId -> Maybe String -> String
forall {a}. Show a => a -> Maybe String -> String
showName NodeId
to Maybe String
optT String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
showAttrs [(String, String)]
attrs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
";"
where showName :: a -> Maybe String -> String
showName a
n Maybe String
Nothing = a -> String
forall a. Show a => a -> String
show a
n
showName a
n (Just String
t) = a -> String
forall a. Show a => a -> String
show a
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t
showGraphElement (Scope [GraphElement]
elems) = String
"{\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((GraphElement -> String) -> [GraphElement] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map GraphElement -> String
showGraphElement [GraphElement]
elems) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n}"
showGraphElement (SubGraph NodeId
nid [GraphElement]
elems) = String
"subgraph " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NodeId -> String
forall a. Show a => a -> String
show NodeId
nid String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" {\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((GraphElement -> String) -> [GraphElement] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map GraphElement -> String
showGraphElement [GraphElement]
elems) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n}"
showAttrs :: [(String, String)] -> String
showAttrs :: [(String, String)] -> String
showAttrs [] = String
""
showAttrs [(String, String)]
xs = String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
showAttrs' [(String, String)]
xs String -> ShowS
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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
showAttrs' [(String, String)]
as
showAttrs' [] = ShowS
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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"=\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> ShowS) -> String -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> ShowS
showsDotChar String
"" String
val String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\""
showsDotChar :: Char -> ShowS
showsDotChar :: Char -> ShowS
showsDotChar Char
'"' = (String
"\\\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++)
showsDotChar Char
'\\' = (String
"\\\\" String -> ShowS
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 = [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ [ a
a | (a
a,b
_) <- [(a, b)]
assocs ]
let outs :: Set a
outs = [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
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 <- [Dot (a, NodeId)] -> Dot [(a, NodeId)]
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)
(a, NodeId) -> Dot (a, NodeId)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,NodeId
nd)
| (a
a,b
b) <- [(a, b)]
assocs ]
[(a, NodeId)]
otherTab <- [Dot (a, NodeId)] -> Dot [(a, NodeId)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ do NodeId
nd <- [(String, String)] -> Dot NodeId
node []
(a, NodeId) -> Dot (a, NodeId)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
o,NodeId
nd)
| a
o <- Set a -> [a]
forall a. Set a -> [a]
S.toList Set a
outs
, a
o a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set a
nodes
]
let fm :: Map a NodeId
fm = [(a, NodeId)] -> Map a NodeId
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(a, NodeId)]
nodeTab [(a, NodeId)] -> [(a, NodeId)] -> [(a, NodeId)]
forall a. [a] -> [a] -> [a]
++ [(a, NodeId)]
otherTab)
[Dot ()] -> Dot ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ (Map a NodeId
fm Map a NodeId -> a -> NodeId
forall k a. Ord k => Map k a -> k -> a
M.! a
src) NodeId -> NodeId -> Dot ()
.->. (Map a NodeId
fm Map a NodeId -> a -> NodeId
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
]
() -> Dot ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()