-- |
-- Module: Text.Dot
-- Copyright: Andy Gill
-- License: BSD3
--
-- Maintainer: Andy Gill <andygill@ku.edu>
-- Stability: unstable
-- Portability: portable
--
-- This module provides a simple interface for building .dot graph files, for input into the dot and graphviz tools. 
-- It includes a monadic interface for building graphs.

module Text.Dot 
        ( 
          -- * Dot
          Dot           -- abstract
          -- * Nodes
        , node
        , NodeId        -- abstract
        , userNodeId
        , userNode
          -- * Edges
        , edge
        , edge'
        , (.->.)
          -- * Showing a graph
        , showDot
          -- * Other combinators
        , scope
        , attribute
        , share
        , same
        , cluster
        -- * Simple netlist generation
        , 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 DotGraph = DotGraph [GraphElement]

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 { Dot a -> Int -> ([GraphElement], Int, a)
unDot :: Int -> ([GraphElement],Int,a) }

-- Support 7.10
instance Functor Dot where
  fmap :: (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 :: a -> Dot a
pure  = a -> Dot a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: 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 :: 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 >>= :: 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' takes a list of attributes, generates a new node, and gives a 'NodeId'.
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' allows a user to use their own (Int-based) node id's, without needing to remap them.
userNodeId :: Int -> NodeId
userNodeId :: Int -> NodeId
userNodeId Int
i = Int -> NodeId
UserNodeId Int
i

-- | 'userNode' takes a NodeId, and adds some attributes to that node. 
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' generates an edge between two 'NodeId's, with attributes.
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' generates an edge between two 'NodeId's, with optional node sub-labels, and attributes.
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,()))

-- | '.->.' generates an edge between two 'NodeId's.
(.->.)     :: NodeId -> NodeId -> Dot ()
.->. :: NodeId -> NodeId -> Dot ()
(.->.) NodeId
from NodeId
to = NodeId -> NodeId -> [(String, String)] -> Dot ()
edge NodeId
from NodeId
to []

-- | 'scope' groups a subgraph together; in dot these are the subgraphs inside "{" and "}".
scope     :: Dot a -> Dot a
scope :: 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' is when a set of nodes share specific attributes. Usually used for layout tweaking.
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' provides a combinator for a common pattern; a set of 'NodeId's with the same rank.
same :: [NodeId] -> Dot ()
same :: [NodeId] -> Dot ()
same = [(String, String)] -> [NodeId] -> Dot ()
share [(String
"rank",String
"same")]


-- | 'cluster' builds an explicit, internally named subgraph (called cluster). 
cluster :: Dot a -> Dot (NodeId,a)
cluster :: 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' gives a attribute to the current scope.
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' renders a dot graph as a 'String'.
showDot :: Dot a -> String
showDot :: 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' generates a simple graph from a netlist.
netlistGraph :: (Ord a) 
          => (b -> [(String,String)])   -- ^ Attributes for each node
          -> (b -> [a])                 -- ^ Out edges leaving each node
          -> [(a,b)]                    -- ^ The netlist
          -> Dot ()
netlistGraph :: (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 ()