Monadic.hs

{-# 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 { runDot :: (a, DotStmts n) }

execDot :: DotM n a -> DotStmts n
execDot = snd . runDot

instance Functor (DotM n) where
  fmap f (DotM (a,stmts)) = DotM (f a, stmts)

instance Applicative (DotM n) where
  pure = DotM . flip (,) DL.empty

  (DotM (f,stmts1)) <*> (DotM (a,stmts2)) = DotM (f a, stmts1 `DL.append` stmts2)

instance Monad (DotM n) where
  return = pure

  dt >>= f = DotM
             $ let ~(a,stmts)  = runDot dt
                   ~(b,stmts') = runDot $ f a
               in (b, stmts `DL.append` stmts')

instance MonadFix (DotM n) where
  mfix m = let (a,n) = runDot $ m a
           in  DotM (a,n)

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

instance Monoid a => Monoid (DotM n a) where
  mappend (DotM x1) (DotM x2) = DotM (mappend x1 x2)
  mempty = DotM mempty

tell :: DotStmts n -> Dot n
tell = DotM . (,) ()

tellStmt :: DotStmt n -> Dot n
tellStmt = tell . DL.singleton

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

-- | Create a directed dot graph with the specified graph ID.
digraph :: GraphID -> DotM n a -> DotGraph n
digraph = mkGraph True . Just

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

-- | Create a undirected dot graph with the specified graph ID.
graph :: GraphID -> DotM n a -> DotGraph n
graph = mkGraph False . Just

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

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

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

type DotStmts n = DList (DotStmt n)

execStmts :: DotM n a -> DotStatements n
execStmts = convertStatements . execDot

convertStatements :: DotStmts n -> DotStatements n
convertStatements = Seq.fromList . map convertStatement . DL.toList

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

convertStatement          :: DotStmt n -> DotStatement n
convertStatement (MA gas) = GA gas
convertStatement (MS sg)  = SG . DotSG (sgIsClust sg) (sgID sg)
                                 . execStmts $ sgStmts sg
convertStatement (MN dn)  = DN dn
convertStatement (ME de)  = DE de

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

-- | Add graph\/sub-graph\/cluster attributes.
graphAttrs :: Attributes -> Dot n
graphAttrs = tellStmt . MA . GraphAttrs

-- | Add global node attributes.
nodeAttrs :: Attributes -> Dot n
nodeAttrs = tellStmt . MA . NodeAttrs

-- | Add global edge attributes
edgeAttrs :: Attributes -> Dot n
edgeAttrs = tellStmt . MA . EdgeAttrs

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

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

-- | Add a named subgraph to the graph.
subgraph :: GraphID -> DotM n a -> Dot n
subgraph = nonClust . Just

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

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

createSubGraph :: Bool -> Maybe GraphID -> DotM n a -> Dot n
createSubGraph isCl mid = tellStmt . MS . Sg isCl mid . (>> return ())

-- | Add a named cluster to the graph.
cluster :: GraphID -> DotM n a -> Dot n
cluster = createSubGraph True . Just

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

-- | Add a node to the graph.
node   :: n -> Attributes -> Dot n
node n = tellStmt . MN . DotNode n

-- | Add a node with no attributes to the graph.
node' :: n -> Dot n
node' = (`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 f t = tellStmt . ME . DotEdge f t

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

infixr 9 -->

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

infixr 9 <->

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