{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses #-}

{- |
   Module      : Data.GraphViz.Types.Monadic
   Description : A monadic interface for making Dot graphs.
   Copyright   : (c) Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   This module is based upon the /dotgen/ library by Andy Gill:
   <http://hackage.haskell.org/package/dotgen>

   It provides a monadic interface for constructing generalised Dot
   graphs.  Note that this does /not/ have an instance for @DotRepr@
   (e.g. what would be the point of the @fromCanonical@ function, as
   you can't do anything with the result): it is purely for
   construction purposes.  Use the generalised Dot graph instance for
   printing, etc.

   Note that the generalised Dot graph types are /not/ re-exported, in
   case it causes a clash with other modules you may choose to import.

   The example graph in "Data.GraphViz.Types" can be written as:

   > digraph (Str "G") $ do
   >
   >    cluster (Int 0) $ do
   >        graphAttrs [style filled, color LightGray]
   >        nodeAttrs [style filled, color White]
   >        "a0" --> "a1"
   >        "a1" --> "a2"
   >        "a2" --> "a3"
   >        graphAttrs [textLabel "process #1"]
   >
   >    cluster (Int 1) $ do
   >        nodeAttrs [style filled]
   >        "b0" --> "b1"
   >        "b1" --> "b2"
   >        "b2" --> "b3"
   >        graphAttrs [textLabel "process #2", color Blue]
   >
   >    "start" --> "a0"
   >    "start" --> "b0"
   >    "a1" --> "b3"
   >    "b2" --> "a3"
   >    "a3" --> "end"
   >    "b3" --> "end"
   >
   >    node "start" [shape MDiamond]
   >    node "end" [shape MSquare]

 -}
module Data.GraphViz.Types.Monadic
       ( Dot
       , DotM
       , GraphID(..)
         -- * Creating a generalised DotGraph.
       , digraph
       , digraph'
       , graph
       , graph'
         -- * Adding global attributes.
       , graphAttrs
       , nodeAttrs
       , edgeAttrs
         -- * Adding items to the graph.
         -- ** Subgraphs and clusters
       , subgraph
       , anonSubgraph
       , cluster
         -- ** Nodes
       , node
       , node'
         -- ** Edges
         -- $edges
       , edge
       , (-->)
       , (<->)
       ) where

import Data.GraphViz.Attributes        (Attributes)
import Data.GraphViz.Types.Generalised

import           Data.DList    (DList)
import qualified Data.DList    as DL
import qualified Data.Sequence as Seq

#if !(MIN_VERSION_base (4,8,0))
import Control.Applicative (Applicative(..))
import Data.Monoid         (Monoid(..))
#endif

#if MIN_VERSION_base (4,9,0) && !MIN_VERSION_base (4,13,0)
import Data.Semigroup (Semigroup(..))
#endif

import Control.Monad.Fix (MonadFix (mfix))

-- -----------------------------------------------------------------------------
-- The Dot monad.

-- | The monadic representation of a Dot graph.
type Dot n = DotM n ()

-- | The actual monad; as with 'Dot' but allows you to return a value
--   within the do-block.  The actual implementation is based upon the
--   Writer monad.
newtype DotM n a = DotM { forall n a. DotM n a -> (a, DotStmts n)
runDot :: (a, DotStmts n) }

execDot :: DotM n a -> DotStmts n
execDot :: forall n a. DotM n a -> DotStmts n
execDot = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n a. DotM n a -> (a, DotStmts n)
runDot

instance Functor (DotM n) where
  fmap :: forall a b. (a -> b) -> DotM n a -> DotM n b
fmap a -> b
f (DotM (a
a,DotStmts n
stmts)) = forall n a. (a, DotStmts n) -> DotM n a
DotM (a -> b
f a
a, DotStmts n
stmts)

instance Applicative (DotM n) where
  pure :: forall a. a -> DotM n a
pure = forall n a. (a, DotStmts n) -> DotM n a
DotM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) forall a. DList a
DL.empty

  (DotM (a -> b
f,DotStmts n
stmts1)) <*> :: forall a b. DotM n (a -> b) -> DotM n a -> DotM n b
<*> (DotM (a
a,DotStmts n
stmts2)) = forall n a. (a, DotStmts n) -> DotM n a
DotM (a -> b
f a
a, DotStmts n
stmts1 forall a. DList a -> DList a -> DList a
`DL.append` DotStmts n
stmts2)

instance Monad (DotM n) where
  return :: forall a. a -> DotM n a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure

  DotM n a
dt >>= :: forall a b. DotM n a -> (a -> DotM n b) -> DotM n b
>>= a -> DotM n b
f = forall n a. (a, DotStmts n) -> DotM n a
DotM
             forall a b. (a -> b) -> a -> b
$ let ~(a
a,DotStmts n
stmts)  = forall n a. DotM n a -> (a, DotStmts n)
runDot DotM n a
dt
                   ~(b
b,DotStmts n
stmts') = forall n a. DotM n a -> (a, DotStmts n)
runDot forall a b. (a -> b) -> a -> b
$ a -> DotM n b
f a
a
               in (b
b, DotStmts n
stmts forall a. DList a -> DList a -> DList a
`DL.append` DotStmts n
stmts')

instance MonadFix (DotM n) where
  mfix :: forall a. (a -> DotM n a) -> DotM n a
mfix a -> DotM n a
m = let (a
a,DotStmts n
n) = forall n a. DotM n a -> (a, DotStmts n)
runDot forall a b. (a -> b) -> a -> b
$ a -> DotM n a
m a
a
           in  forall n a. (a, DotStmts n) -> DotM n a
DotM (a
a,DotStmts n
n)

#if MIN_VERSION_base (4,9,0)
instance Semigroup a => Semigroup (DotM n a) where
  DotM (a, DotStmts n)
x1 <> :: DotM n a -> DotM n a -> DotM n a
<> DotM (a, DotStmts n)
x2 = forall n a. (a, DotStmts n) -> DotM n a
DotM ((a, DotStmts n)
x1 forall a. Semigroup a => a -> a -> a
<> (a, DotStmts n)
x2)
#endif

instance Monoid a => Monoid (DotM n a) where
  mappend :: DotM n a -> DotM n a -> DotM n a
mappend (DotM (a, DotStmts n)
x1) (DotM (a, DotStmts n)
x2) = forall n a. (a, DotStmts n) -> DotM n a
DotM (forall a. Monoid a => a -> a -> a
mappend (a, DotStmts n)
x1 (a, DotStmts n)
x2)
  mempty :: DotM n a
mempty = forall n a. (a, DotStmts n) -> DotM n a
DotM forall a. Monoid a => a
mempty

tell :: DotStmts n -> Dot n
tell :: forall n. DotStmts n -> Dot n
tell = forall n a. (a, DotStmts n) -> DotM n a
DotM forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) ()

tellStmt :: DotStmt n -> Dot n
tellStmt :: forall n. DotStmt n -> Dot n
tellStmt = forall n. DotStmts n -> Dot n
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> DList a
DL.singleton

-- -----------------------------------------------------------------------------
-- Creating the DotGraph

-- | Create a directed dot graph with the specified graph ID.
digraph :: GraphID -> DotM n a -> DotGraph n
digraph :: forall n a. GraphID -> DotM n a -> DotGraph n
digraph = forall n a. Bool -> Maybe GraphID -> DotM n a -> DotGraph n
mkGraph Bool
True forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just

-- | Create a directed dot graph with no graph ID.
digraph' :: DotM n a -> DotGraph n
digraph' :: forall n a. DotM n a -> DotGraph n
digraph' = forall n a. Bool -> Maybe GraphID -> DotM n a -> DotGraph n
mkGraph Bool
True forall a. Maybe a
Nothing

-- | Create a undirected dot graph with the specified graph ID.
graph :: GraphID -> DotM n a -> DotGraph n
graph :: forall n a. GraphID -> DotM n a -> DotGraph n
graph = forall n a. Bool -> Maybe GraphID -> DotM n a -> DotGraph n
mkGraph Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just

-- | Create a undirected dot graph with no graph ID.
graph' :: DotM n a -> DotGraph n
graph' :: forall n a. DotM n a -> DotGraph n
graph' = forall n a. Bool -> Maybe GraphID -> DotM n a -> DotGraph n
mkGraph Bool
False forall a. Maybe a
Nothing

mkGraph :: Bool -> Maybe GraphID -> DotM n a -> DotGraph n
mkGraph :: forall n a. Bool -> Maybe GraphID -> DotM n a -> DotGraph n
mkGraph Bool
isDir Maybe GraphID
mid DotM n a
dot = DotGraph { strictGraph :: Bool
strictGraph     = Bool
False
                                 , directedGraph :: Bool
directedGraph   = Bool
isDir
                                 , graphID :: Maybe GraphID
graphID         = Maybe GraphID
mid
                                 , graphStatements :: DotStatements n
graphStatements = forall n a. DotM n a -> DotStatements n
execStmts DotM n a
dot
                                 }

-- -----------------------------------------------------------------------------
-- Statements

type DotStmts n = DList (DotStmt n)

execStmts :: DotM n a -> DotStatements n
execStmts :: forall n a. DotM n a -> DotStatements n
execStmts = forall n. DotStmts n -> DotStatements n
convertStatements forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n a. DotM n a -> DotStmts n
execDot

convertStatements :: DotStmts n -> DotStatements n
convertStatements :: forall n. DotStmts n -> DotStatements n
convertStatements = forall a. [a] -> Seq a
Seq.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall n. DotStmt n -> DotStatement n
convertStatement forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. DList a -> [a]
DL.toList

data DotStmt n = MA GlobalAttributes
               | MS (Subgraph n)
               | MN (DotNode n)
               | ME (DotEdge n)

convertStatement          :: DotStmt n -> DotStatement n
convertStatement :: forall n. DotStmt n -> DotStatement n
convertStatement (MA GlobalAttributes
gas) = forall n. GlobalAttributes -> DotStatement n
GA GlobalAttributes
gas
convertStatement (MS Subgraph n
sg)  = forall n. DotSubGraph n -> DotStatement n
SG forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Bool -> Maybe GraphID -> DotStatements n -> DotSubGraph n
DotSG (forall n. Subgraph n -> Bool
sgIsClust Subgraph n
sg) (forall n. Subgraph n -> Maybe GraphID
sgID Subgraph n
sg)
                                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n a. DotM n a -> DotStatements n
execStmts forall a b. (a -> b) -> a -> b
$ forall n. Subgraph n -> Dot n
sgStmts Subgraph n
sg
convertStatement (MN DotNode n
dn)  = forall n. DotNode n -> DotStatement n
DN DotNode n
dn
convertStatement (ME DotEdge n
de)  = forall n. DotEdge n -> DotStatement n
DE DotEdge n
de

-- -----------------------------------------------------------------------------
-- Global Attributes

-- | Add graph\/sub-graph\/cluster attributes.
graphAttrs :: Attributes -> Dot n
graphAttrs :: forall n. Attributes -> Dot n
graphAttrs = forall n. DotStmt n -> Dot n
tellStmt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. GlobalAttributes -> DotStmt n
MA forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> GlobalAttributes
GraphAttrs

-- | Add global node attributes.
nodeAttrs :: Attributes -> Dot n
nodeAttrs :: forall n. Attributes -> Dot n
nodeAttrs = forall n. DotStmt n -> Dot n
tellStmt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. GlobalAttributes -> DotStmt n
MA forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> GlobalAttributes
NodeAttrs

-- | Add global edge attributes
edgeAttrs :: Attributes -> Dot n
edgeAttrs :: forall n. Attributes -> Dot n
edgeAttrs = forall n. DotStmt n -> Dot n
tellStmt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. GlobalAttributes -> DotStmt n
MA forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> GlobalAttributes
EdgeAttrs

-- -----------------------------------------------------------------------------
-- Subgraphs (including Clusters)

data Subgraph n = Sg { forall n. Subgraph n -> Bool
sgIsClust :: Bool
                     , forall n. Subgraph n -> Maybe GraphID
sgID      :: Maybe GraphID
                     , forall n. Subgraph n -> Dot n
sgStmts   :: Dot n
                     }

-- | Add a named subgraph to the graph.
subgraph :: GraphID -> DotM n a -> Dot n
subgraph :: forall n a. GraphID -> DotM n a -> Dot n
subgraph = forall n a. Maybe GraphID -> DotM n a -> Dot n
nonClust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just

-- | Add an anonymous subgraph to the graph.
--
--   It is highly recommended you use 'subgraph' instead.
anonSubgraph :: DotM n a -> Dot n
anonSubgraph :: forall n a. DotM n a -> Dot n
anonSubgraph = forall n a. Maybe GraphID -> DotM n a -> Dot n
nonClust forall a. Maybe a
Nothing

nonClust :: Maybe GraphID -> DotM n a -> Dot n
nonClust :: forall n a. Maybe GraphID -> DotM n a -> Dot n
nonClust = forall n a. Bool -> Maybe GraphID -> DotM n a -> Dot n
createSubGraph Bool
False

createSubGraph :: Bool -> Maybe GraphID -> DotM n a -> Dot n
createSubGraph :: forall n a. Bool -> Maybe GraphID -> DotM n a -> Dot n
createSubGraph Bool
isCl Maybe GraphID
mid = forall n. DotStmt n -> Dot n
tellStmt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Subgraph n -> DotStmt n
MS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Bool -> Maybe GraphID -> Dot n -> Subgraph n
Sg Bool
isCl Maybe GraphID
mid forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Add a named cluster to the graph.
cluster :: GraphID -> DotM n a -> Dot n
cluster :: forall n a. GraphID -> DotM n a -> Dot n
cluster = forall n a. Bool -> Maybe GraphID -> DotM n a -> Dot n
createSubGraph Bool
True forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just

-- -----------------------------------------------------------------------------
-- Nodes

-- | Add a node to the graph.
node   :: n -> Attributes -> Dot n
node :: forall n. n -> Attributes -> Dot n
node n
n = forall n. DotStmt n -> Dot n
tellStmt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. DotNode n -> DotStmt n
MN forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. n -> Attributes -> DotNode n
DotNode n
n

-- | Add a node with no attributes to the graph.
node' :: n -> Dot n
node' :: forall n. n -> Dot n
node' = (forall n. n -> Attributes -> Dot n
`node` [])

-- -----------------------------------------------------------------------------
-- Edges

{- $edges

   If you wish to use something analogous to Dot's ability to write
   multiple edges with in-line subgraphs such as:

   > {a b c} -> {d e f}

   Then you can use '-->' and '<->' in combination with monadic
   traversal functions such as @traverse_@, @for_@, @mapM_@, @forM_@
   and @zipWithM_@; for example:

   > ("a" -->) `traverse_` ["d", "e", "f"]
   > ["a", "b", "c"] `for_` (--> "d")
   > zipWithM_ (-->) ["a", "b", "c"] ["d", "e", "f"]

 -}

-- | Add an edge to the graph.
edge     :: n -> n -> Attributes -> Dot n
edge :: forall n. n -> n -> Attributes -> Dot n
edge n
f n
t = forall n. DotStmt n -> Dot n
tellStmt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. DotEdge n -> DotStmt n
ME forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. n -> n -> Attributes -> DotEdge n
DotEdge n
f n
t

-- | Add an edge with no attributes.
(-->) :: n -> n -> Dot n
n
f --> :: forall n. n -> n -> Dot n
--> n
t = forall n. n -> n -> Attributes -> Dot n
edge n
f n
t []

infixr 9 -->

-- | An alias for '-->' to make edges look more undirected.
(<->) :: n -> n -> Dot n
<-> :: forall n. n -> n -> Dot n
(<->) = forall n. n -> n -> Dot n
(-->)

infixr 9 <->

-- -----------------------------------------------------------------------------