    -- |
    -- 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 str :: String
    str) = String
    str
      show (UserNodeId i :: Int
    i)
            | Int
    i Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < 0     = "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 = "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
    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
    $ \ uq :: Int
    uq -> ([],Int
    uq,a
    a)
      m :: Dot a
    m >>= :: Dot a -> (a -> Dot b) -> Dot b
    >>= k :: 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
    $ \ uq :: Int
    uq -> case Dot a -> Int -> ([GraphElement], Int, a)
    forall a. Dot a -> Int -> ([GraphElement], Int, a)
    unDot Dot a
    m Int
    uq of
                               (g1 :: [GraphElement]
    g1,uq' :: Int
    uq',r :: 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
                                               (g2 :: [GraphElement]
    g2,uq2 :: Int
    uq2,r2 :: 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 attrs :: [(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
    $ \ uq :: Int
    uq -> let nid :: NodeId
    nid = String -> NodeId
    NodeId (String -> NodeId) -> String -> NodeId
    forall a b. (a -> b) -> a -> b
    $ "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 i :: 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 nId :: NodeId
    nId attrs :: [(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
    $ \ uq :: 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  from :: NodeId
    from to :: NodeId
    to attrs :: [(String, String)]
    attrs = (Int -> ([GraphElement], Int, ())) -> Dot ()
    forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
    Dot (\ uq :: 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'  from :: NodeId
    from optF :: Maybe String
    optF to :: NodeId
    to optT :: Maybe String
    optT attrs :: [(String, String)]
    attrs = (Int -> ([GraphElement], Int, ())) -> Dot ()
    forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
    Dot (\ uq :: 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 ()
    (.->.) from :: NodeId
    from to :: 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 fn :: Int -> ([GraphElement], Int, a)
    fn) = (Int -> ([GraphElement], Int, a)) -> Dot a
    forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
    Dot (\ uq :: Int
    uq -> case Int -> ([GraphElement], Int, a)
    fn Int
    uq of
                                  ( elems :: [GraphElement]
    elems,uq' :: Int
    uq',a :: 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 attrs :: [(String, String)]
    attrs nodeids :: [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
    $ \ uq :: Int
    uq ->
          ( [ [GraphElement] -> GraphElement
    Scope ( [ String -> String -> GraphElement
    GraphAttribute String
    name String
    val | (name :: String
    name,val :: 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 [("rank","same")]

    -- | 'cluster' builds an explicit, internally named subgraph (called cluster).
    cluster :: Dot a -> Dot (NodeId,a)
    cluster :: Dot a -> Dot (NodeId, a)
    cluster (Dot fn :: Int -> ([GraphElement], Int, a)
    fn) = (Int -> ([GraphElement], Int, (NodeId, a))) -> Dot (NodeId, a)
    forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
    Dot (\ uq :: Int
    uq ->
                    let cid :: NodeId
    cid = String -> NodeId
    NodeId (String -> NodeId) -> String -> NodeId
    forall a b. (a -> b) -> a -> b
    $ "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
                        (elems :: [GraphElement]
    elems,uq' :: Int
    uq',a :: 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 (name :: String
    name,val :: String
    val) = (Int -> ([GraphElement], Int, ())) -> Dot ()
    forall a. (Int -> ([GraphElement], Int, a)) -> Dot a
    Dot (\ uq :: 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 dm :: Int -> ([GraphElement], Int, a)
    dm) = case Int -> ([GraphElement], Int, a)
    dm 0 of
                        (elems :: [GraphElement]
    elems,_,_) -> "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]
    ++ "\n}\n"

    showGraphElement :: GraphElement -> String
    showGraphElement :: GraphElement -> String
    showGraphElement (GraphAttribute name :: String
    name val :: String
    val) = (String, String) -> String
    showAttr (String
    name,String
    val) String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ ";"
    showGraphElement (GraphNode nid :: NodeId
    nid attrs :: [(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]
    ++ ";"
    showGraphElement (GraphEdge from :: NodeId
    from to :: NodeId
    to attrs :: [(String, String)]
    attrs) = NodeId -> String
    forall a. Show a => a -> String
    show NodeId
    from String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ " -> " 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]
    ++ ";"
    showGraphElement (GraphEdge' from :: NodeId
    from optF :: Maybe String
    optF to :: NodeId
    to optT :: Maybe String
    optT attrs :: [(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 -> 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]
    ++ ";"
        where showName :: a -> Maybe String -> String
    showName n :: a
    n Nothing = a -> String
    forall a. Show a => a -> String
    show a
    n
              showName n :: a
    n (Just t :: String
    t) = a -> String
    forall a. Show a => a -> String
    show a
    n String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ ":" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    t
    showGraphElement (Scope elems :: [GraphElement]
    elems) = "{\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]
    ++ "\n}"
    showGraphElement (SubGraph nid :: NodeId
    nid elems :: [GraphElement]
    elems) = "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]
    ++ " {\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]
    ++ "\n}"

    showAttrs :: [(String, String)] -> String
    showAttrs :: [(String, String)] -> String
    showAttrs [] = ""
    showAttrs xs :: [(String, String)]
    xs = "[" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ [(String, String)] -> String
    showAttrs' [(String, String)]
    xs String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ "]"
        where
            showAttrs' :: [(String, String)] -> String
    showAttrs' [a :: (String, String)
    a]    = (String, String) -> String
    showAttr (String, String)
    a
            showAttrs' (a :: (String, String)
    a:as :: [(String, String)]
    as) = (String, String) -> String
    showAttr (String, String)
    a String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ "," String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ [(String, String)] -> String
    showAttrs' [(String, String)]
    as
            showAttrs' []     = ShowS
    forall a. HasCallStack => String -> a
    error "The list should never be empty"

    showAttr :: (String, String) -> String
    showAttr :: (String, String) -> String
    showAttr (name :: String
    name,val :: String
    val) = String
    name String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ "=\""   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
    val String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ "\""

    showsDotChar :: Char -> ShowS
    showsDotChar :: Char -> ShowS
    showsDotChar '"'  = ("\\\"" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++)
    showsDotChar '\\' = ("\\\\" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++)
    showsDotChar x :: 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 attrFn :: b -> [(String, String)]
    attrFn outFn :: b -> [a]
    outFn assocs :: [(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
    a,_) <- [(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 | (_,b :: 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
    a,b :: 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)
                  | (dst :: a
    dst,b :: b
    b) <- [(a, b)]
    assocs
                  , a
    src     <- b -> [a]
    outFn b
    b
                  ]
        () -> Dot ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()