{-# LANGUAGE CPP, FlexibleContexts, MultiParamTypeClasses, OverloadedStrings #-}

{- |
   Module      : Data.GraphViz
   Description : Graphviz bindings for Haskell.
   Copyright   : (c) Matthew Sackman, Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   This is the top-level module for the graphviz library.  It provides
   functions to convert 'Data.Graph.Inductive.Graph.Graph's into the
   /Dot/ language used by the /Graphviz/ suite of programs (as well as a
   limited ability to perform the reverse operation).

   If you wish to construct a Haskell representation of a Dot graph
   yourself rather than using the conversion functions here, please
   see the "Data.GraphViz.Types" module as a starting point for how to
   do so.

   Information about Graphviz and the Dot language can be found at:
   <http://graphviz.org/>
 -}

module Data.GraphViz
    ( -- * Conversion from graphs to /Dot/ format.
      -- ** Specifying parameters.
      -- $params
      GraphvizParams(..)
    , quickParams
    , defaultParams
    , nonClusteredParams
    , blankParams
    , setDirectedness
      -- *** Specifying clusters.
    , NodeCluster(..)
    , LNodeCluster
      -- ** Converting graphs.
    , graphToDot
    , graphElemsToDot
      -- ** Pseudo-inverse conversion.
    , dotToGraph
      -- * Graph augmentation.
      -- $augment
      -- ** Type aliases for @Node@ and @Edge@ labels.
    , AttributeNode
    , AttributeEdge
      -- ** Customisable augmentation.
    , graphToGraph
      -- ** Quick augmentation.
    , dotizeGraph
      -- ** Manual augmentation.
      -- $manualAugment
    , EdgeID
    , addEdgeIDs
    , setEdgeIDAttribute
    , dotAttributes
    , augmentGraph
      -- * Utility functions
    , preview
      -- * Re-exporting other modules.
    , module Data.GraphViz.Types
    , module Data.GraphViz.Types.Canonical
    , module Data.GraphViz.Attributes
    , module Data.GraphViz.Commands
    ) where

import Data.GraphViz.Algorithms.Clustering
import Data.GraphViz.Attributes
import Data.GraphViz.Attributes.Complete   (AttributeName, CustomAttribute,
                                            customAttribute, customValue,
                                            findSpecifiedCustom)
import Data.GraphViz.Commands
import Data.GraphViz.Commands.IO           (hGetDot)
import Data.GraphViz.Internal.Util         (uniq, uniqBy)
import Data.GraphViz.Types
import Data.GraphViz.Types.Canonical       (DotGraph (..), DotStatements (..),
                                            DotSubGraph (..))
import Data.GraphViz.Types.Generalised     (FromGeneralisedDot (..))

import           Control.Arrow              (first, (&&&))
import           Control.Concurrent         (forkIO)
import           Data.Graph.Inductive.Graph
import qualified Data.Map                   as Map
import           Data.Maybe                 (fromJust, mapMaybe)
import qualified Data.Set                   as Set
import           Data.Text.Lazy             (Text)
import qualified Data.Text.Lazy             as T
import           System.IO.Unsafe           (unsafePerformIO)

#if !(MIN_VERSION_base (4,8,0))
import Data.Functor ((<$>))
#endif

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

-- | Determine if the given graph is undirected.
isUndirected   :: (Ord b, Graph g) => g a b -> Bool
isUndirected :: forall b (g :: * -> * -> *) a. (Ord b, Graph g) => g a b -> Bool
isUndirected g a b
g = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Node, Node, b) -> Bool
hasFlip [(Node, Node, b)]
es
  where
    es :: [(Node, Node, b)]
es = forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges g a b
g
    eSet :: Set (Node, Node, b)
eSet = forall a. Ord a => [a] -> Set a
Set.fromList [(Node, Node, b)]
es
    hasFlip :: (Node, Node, b) -> Bool
hasFlip (Node, Node, b)
e = forall a. Ord a => a -> Set a -> Bool
Set.member (forall {b} {a} {c}. (b, a, c) -> (a, b, c)
flippedEdge (Node, Node, b)
e) Set (Node, Node, b)
eSet
    flippedEdge :: (b, a, c) -> (a, b, c)
flippedEdge (b
f,a
t,c
l) = (a
t,b
f,c
l)

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

{- $params

   A 'GraphvizParams' value contains all the information necessary to
   manipulate 'Graph's with this library.  As such, its components deal
   with:

   * Whether to treat graphs as being directed or not;

   * Which top-level 'GlobalAttributes' values should be applied;

   * How to define (and name) clusters;

   * How to format clusters, nodes and edges.

   Apart from not having to pass multiple values around, another
   advantage of using 'GraphvizParams' over the previous approach is that
   there is no distinction between clustering and non-clustering variants
   of the same functions.

   Example usages of 'GraphvizParams' follow:

   * Quickly visualise a graph using the default parameters.  Note the
     usage of @'nonClusteredParams'@ over @'defaultParams'@ to avoid
     type-checking problems with the cluster type.

     > defaultVis :: (Graph gr) => gr nl el -> DotGraph Node
     > defaultVis = graphToDot nonClusteredParams

   * As with @defaultVis@, but determine whether or not the graph is
     directed or undirected.

     > checkDirectednessVis :: (Graph gr, Ord el) => gr nl el -> DotGraph Node
     > checkDirectednessVis = setDirectedness graphToDot nonClusteredParams

   * Clustering nodes based upon whether they are even or odd.  We
     have the option of either constructing a @GraphvizParams@
     directly, or using @'blankParams'@.  Using the latter to avoid
     setting @'isDirected'@:

     > evenOdd :: (Graph gr, Ord el) => gr Int el -> DotGraph Node
     > evenOdd = setDirectedness graphToDot params
     >   where
     >     params = blankParams { globalAttributes = []
     >                          , clusterBy        = clustBy
     >                          , clusterID        = Num . Int
     >                          , fmtCluster       = clFmt
     >                          , fmtNode          = const []
     >                          , fmtEdge          = const []
     >                          }
     >     clustBy (n,l) = C (n `mod` 2) $ N (n,l)
     >     clFmt m = [GraphAttrs [toLabel $ "n == " ++ show m ++ " (mod 2)"]]

   For more examples, see the source of 'dotizeGraph' and 'preview'.

 -}

-- | Defines the parameters used to convert a 'Graph' into a 'DotRepr'.
--
--   A value of type @'GraphvizParams' n nl el cl l@ indicates that
--   the 'Graph' has a node type of @n@, node labels of type @nl@,
--   edge labels of type @el@, corresponding clusters of type @cl@ and
--   after clustering the nodes have a label of type @l@ (which may or
--   may not be the same as @nl@).
--
--   The tuples in the function types represent labelled nodes (for
--   @(n,nl)@ and @(n,l)@) and labelled edges (@(n,n,el)@; the value
--   @(f,t,ftl)@ is an edge from @f@ to @l@ with a label of @ftl@).
--   These correspond to 'LNode' and 'LEdge' in FGL graphs.
--
--   The clustering in 'clusterBy' can be to arbitrary depth.
--
--   Note that the term \"cluster\" is slightly conflated here: in
--   terms of @GraphvizParams@ values, a cluster is a grouping of
--   nodes; the 'isDotCluster' function lets you specify whether it is
--   a cluster in the Dot sense or just a sub-graph.
data GraphvizParams n nl el cl l
     = Params { -- | @True@ if the graph is directed; @False@
                --   otherwise.
                forall n nl el cl l. GraphvizParams n nl el cl l -> Bool
isDirected       :: Bool
                -- | The top-level global 'Attributes' for the entire
                --   graph.
              , forall n nl el cl l.
GraphvizParams n nl el cl l -> [GlobalAttributes]
globalAttributes :: [GlobalAttributes]
                -- | A function to specify which cluster a particular
                --   node is in.
              , forall n nl el cl l.
GraphvizParams n nl el cl l -> (n, nl) -> NodeCluster cl (n, l)
clusterBy        :: ((n,nl) -> NodeCluster cl (n,l))
                -- | Is this \"cluster\" actually a cluster, or just a
                --   sub-graph?
              , forall n nl el cl l. GraphvizParams n nl el cl l -> cl -> Bool
isDotCluster     :: (cl -> Bool)
                -- | The name/identifier for a cluster.
              , forall n nl el cl l. GraphvizParams n nl el cl l -> cl -> GraphID
clusterID        :: (cl -> GraphID)
                -- | Specify which global attributes are applied in
                --   the given cluster.
              , forall n nl el cl l.
GraphvizParams n nl el cl l -> cl -> [GlobalAttributes]
fmtCluster       :: (cl -> [GlobalAttributes])
                -- | The specific @Attributes@ for a node.
              , forall n nl el cl l.
GraphvizParams n nl el cl l -> (n, l) -> Attributes
fmtNode          :: ((n,l) -> Attributes)
                -- | The specific @Attributes@ for an edge.
              , forall n nl el cl l.
GraphvizParams n nl el cl l -> (n, n, el) -> Attributes
fmtEdge          :: ((n,n,el) -> Attributes)
              }


-- | An alias for 'NodeCluster' when dealing with FGL graphs.
type LNodeCluster cl l = NodeCluster cl (Node,l)

-- | Especially useful for quick explorations in ghci, this is a "do
--   what I mean" set of parameters that prints the specified labels
--   of a non-clustered graph.
quickParams :: (Labellable nl, Labellable el) => GraphvizParams n nl el () nl
quickParams :: forall nl el n.
(Labellable nl, Labellable el) =>
GraphvizParams n nl el () nl
quickParams = forall n nl el. GraphvizParams n nl el () nl
nonClusteredParams { fmtNode :: (n, nl) -> Attributes
fmtNode = forall {a} {a}. Labellable a => (a, a) -> Attributes
nodeFmt, fmtEdge :: (n, n, el) -> Attributes
fmtEdge = forall {a} {a} {b}. Labellable a => (a, b, a) -> Attributes
edgeFmt }
  where
    nodeFmt :: (a, a) -> Attributes
nodeFmt (a
_,a
l) = [forall a. Labellable a => a -> Attribute
toLabel a
l]
    edgeFmt :: (a, b, a) -> Attributes
edgeFmt (a
_,b
_,a
l) = [forall a. Labellable a => a -> Attribute
toLabel a
l]

-- | A default 'GraphvizParams' value which assumes the graph is
--   directed, contains no clusters and has no 'Attribute's set.
--
--   If you wish to have the labels of the nodes to have a different
--   type after applying 'clusterBy' from before clustering, then you
--   will have to specify your own 'GraphvizParams' value from
--   scratch (or use 'blankParams').
--
--   If you use a custom 'clusterBy' function (which if you actually
--   want clusters you should) then you should also override the
--   (nonsensical) default 'clusterID'.
defaultParams :: GraphvizParams n nl el cl nl
defaultParams :: forall n nl el cl. GraphvizParams n nl el cl nl
defaultParams = Params { isDirected :: Bool
isDirected       = Bool
True
                       , globalAttributes :: [GlobalAttributes]
globalAttributes = []
                       , clusterBy :: (n, nl) -> NodeCluster cl (n, nl)
clusterBy        = forall c a. a -> NodeCluster c a
N
                       , isDotCluster :: cl -> Bool
isDotCluster     = forall a b. a -> b -> a
const Bool
True
                       , clusterID :: cl -> GraphID
clusterID        = forall a b. a -> b -> a
const (Number -> GraphID
Num forall a b. (a -> b) -> a -> b
$ Node -> Number
Int Node
0)
                       , fmtCluster :: cl -> [GlobalAttributes]
fmtCluster       = forall a b. a -> b -> a
const []
                       , fmtNode :: (n, nl) -> Attributes
fmtNode          = forall a b. a -> b -> a
const []
                       , fmtEdge :: (n, n, el) -> Attributes
fmtEdge          = forall a b. a -> b -> a
const []
                       }

-- | A variant of 'defaultParams' that enforces that the clustering
--   type is @'()'@ (i.e.: no clustering); this avoids problems when
--   using 'defaultParams' internally within a function without any
--   constraint on what the clustering type is.
nonClusteredParams :: GraphvizParams n nl el () nl
nonClusteredParams :: forall n nl el. GraphvizParams n nl el () nl
nonClusteredParams = forall n nl el cl. GraphvizParams n nl el cl nl
defaultParams

-- | A 'GraphvizParams' value where every field is set to
--   @'undefined'@.  This is useful when you have a function that will
--   set some of the values for you (e.g. 'setDirectedness') but you
--   don't want to bother thinking of default values to set in the
--   meantime.  This is especially useful when you are
--   programmatically setting the clustering function (and as such do
--   not know what the types might be).
blankParams :: GraphvizParams n nl el cl l
blankParams :: forall n nl el cl l. GraphvizParams n nl el cl l
blankParams = Params { isDirected :: Bool
isDirected       = forall a. HasCallStack => [Char] -> a
error [Char]
"Unspecified definition of isDirected"
                     , globalAttributes :: [GlobalAttributes]
globalAttributes = forall a. HasCallStack => [Char] -> a
error [Char]
"Unspecified definition of globalAttributes"
                     , clusterBy :: (n, nl) -> NodeCluster cl (n, l)
clusterBy        = forall a. HasCallStack => [Char] -> a
error [Char]
"Unspecified definition of clusterBy"
                     , isDotCluster :: cl -> Bool
isDotCluster     = forall a. HasCallStack => [Char] -> a
error [Char]
"Unspecified definition of isDotCluster"
                     , clusterID :: cl -> GraphID
clusterID        = forall a. HasCallStack => [Char] -> a
error [Char]
"Unspecified definition of clusterID"
                     , fmtCluster :: cl -> [GlobalAttributes]
fmtCluster       = forall a. HasCallStack => [Char] -> a
error [Char]
"Unspecified definition of fmtCluster"
                     , fmtNode :: (n, l) -> Attributes
fmtNode          = forall a. HasCallStack => [Char] -> a
error [Char]
"Unspecified definition of fmtNode"
                     , fmtEdge :: (n, n, el) -> Attributes
fmtEdge          = forall a. HasCallStack => [Char] -> a
error [Char]
"Unspecified definition of fmtEdge"
                     }

-- | Determine if the provided 'Graph' is directed or not and set the
--   value of 'isDirected' appropriately.
setDirectedness             :: (Ord el, Graph gr)
                               => (GraphvizParams Node nl el cl l -> gr nl el -> a)
                               -> GraphvizParams Node nl el cl l -> gr nl el -> a
setDirectedness :: forall el (gr :: * -> * -> *) nl cl l a.
(Ord el, Graph gr) =>
(GraphvizParams Node nl el cl l -> gr nl el -> a)
-> GraphvizParams Node nl el cl l -> gr nl el -> a
setDirectedness GraphvizParams Node nl el cl l -> gr nl el -> a
f GraphvizParams Node nl el cl l
params gr nl el
gr = GraphvizParams Node nl el cl l -> gr nl el -> a
f GraphvizParams Node nl el cl l
params' gr nl el
gr
  where
    params' :: GraphvizParams Node nl el cl l
params' = GraphvizParams Node nl el cl l
params { isDirected :: Bool
isDirected = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall b (g :: * -> * -> *) a. (Ord b, Graph g) => g a b -> Bool
isUndirected gr nl el
gr }

-- | Convert a graph to /Dot/ format, using the specified parameters
--   to cluster the graph, etc.
graphToDot :: (Ord cl, Graph gr) => GraphvizParams Node nl el cl l
              -> gr nl el -> DotGraph Node
graphToDot :: forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Node nl el cl l -> gr nl el -> DotGraph Node
graphToDot GraphvizParams Node nl el cl l
params gr nl el
graph = forall cl n nl el l.
(Ord cl, Ord n) =>
GraphvizParams n nl el cl l
-> [(n, nl)] -> [(n, n, el)] -> DotGraph n
graphElemsToDot GraphvizParams Node nl el cl l
params (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes gr nl el
graph) (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges gr nl el
graph)

-- | As with 'graphToDot', but this allows you to easily convert other
--   graph-like formats to a Dot graph as long as you can get a list
--   of nodes and edges from it.
graphElemsToDot :: (Ord cl, Ord n) => GraphvizParams n nl el cl l
                   -> [(n,nl)] -> [(n,n,el)] -> DotGraph n
graphElemsToDot :: forall cl n nl el l.
(Ord cl, Ord n) =>
GraphvizParams n nl el cl l
-> [(n, nl)] -> [(n, n, el)] -> DotGraph n
graphElemsToDot GraphvizParams n nl el cl l
params [(n, nl)]
lns [(n, n, el)]
les
  = DotGraph { strictGraph :: Bool
strictGraph     = Bool
False
             , directedGraph :: Bool
directedGraph   = Bool
dirGraph
             , graphID :: Maybe GraphID
graphID         = forall a. Maybe a
Nothing
             , graphStatements :: DotStatements n
graphStatements = DotStatements n
stmts
             }
  where
    dirGraph :: Bool
dirGraph = forall n nl el cl l. GraphvizParams n nl el cl l -> Bool
isDirected GraphvizParams n nl el cl l
params
    stmts :: DotStatements n
stmts = DotStmts { attrStmts :: [GlobalAttributes]
attrStmts = forall n nl el cl l.
GraphvizParams n nl el cl l -> [GlobalAttributes]
globalAttributes GraphvizParams n nl el cl l
params
                     , subGraphs :: [DotSubGraph n]
subGraphs = [DotSubGraph n]
cs
                     , nodeStmts :: [DotNode n]
nodeStmts = [DotNode n]
ns
                     , edgeStmts :: [DotEdge n]
edgeStmts = [DotEdge n]
es
                     }
    ([DotSubGraph n]
cs, [DotNode n]
ns) = forall c n a l.
Ord c =>
((n, a) -> NodeCluster c (n, l))
-> (c -> Bool)
-> (c -> GraphID)
-> (c -> [GlobalAttributes])
-> ((n, l) -> Attributes)
-> [(n, a)]
-> ([DotSubGraph n], [DotNode n])
clustersToNodes (forall n nl el cl l.
GraphvizParams n nl el cl l -> (n, nl) -> NodeCluster cl (n, l)
clusterBy GraphvizParams n nl el cl l
params) (forall n nl el cl l. GraphvizParams n nl el cl l -> cl -> Bool
isDotCluster GraphvizParams n nl el cl l
params)
                               (forall n nl el cl l. GraphvizParams n nl el cl l -> cl -> GraphID
clusterID GraphvizParams n nl el cl l
params) (forall n nl el cl l.
GraphvizParams n nl el cl l -> cl -> [GlobalAttributes]
fmtCluster GraphvizParams n nl el cl l
params) (forall n nl el cl l.
GraphvizParams n nl el cl l -> (n, l) -> Attributes
fmtNode GraphvizParams n nl el cl l
params)
                               [(n, nl)]
lns
    es :: [DotEdge n]
es = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (n, n, el) -> Maybe (DotEdge n)
mkDotEdge [(n, n, el)]
les
    mkDotEdge :: (n, n, el) -> Maybe (DotEdge n)
mkDotEdge e :: (n, n, el)
e@(n
f,n
t,el
_) = if Bool
dirGraph Bool -> Bool -> Bool
|| n
f forall a. Ord a => a -> a -> Bool
<= n
t
                          then forall a. a -> Maybe a
Just
                               DotEdge { fromNode :: n
fromNode       = n
f
                                       , toNode :: n
toNode         = n
t
                                       , edgeAttributes :: Attributes
edgeAttributes = forall n nl el cl l.
GraphvizParams n nl el cl l -> (n, n, el) -> Attributes
fmtEdge GraphvizParams n nl el cl l
params (n, n, el)
e
                                       }
                          else forall a. Maybe a
Nothing

-- | A pseudo-inverse to 'graphToDot'; \"pseudo\" in the sense that
--   the original node and edge labels aren't able to be
--   reconstructed.
dotToGraph    :: (DotRepr dg Node, Graph gr) => dg Node
                 -> gr Attributes Attributes
dotToGraph :: forall (dg :: * -> *) (gr :: * -> * -> *).
(DotRepr dg Node, Graph gr) =>
dg Node -> gr Attributes Attributes
dotToGraph dg Node
dg = forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [(Node, Attributes)]
ns' [(Node, Node, Attributes)]
es
  where
    d :: Bool
d = forall (dg :: * -> *) n. DotRepr dg n => dg n -> Bool
graphIsDirected dg Node
dg
    -- Applying uniqBy just in case...
    ns :: [(Node, Attributes)]
ns = forall b a. Ord b => (a -> b) -> [a] -> [a]
uniqBy forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a}. DotNode a -> (a, Attributes)
toLN forall a b. (a -> b) -> a -> b
$ forall (dg :: * -> *) n. DotRepr dg n => dg n -> [DotNode n]
graphNodes dg Node
dg
    es :: [(Node, Node, Attributes)]
es = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {b}. DotEdge b -> [(b, b, Attributes)]
toLE forall a b. (a -> b) -> a -> b
$ forall (dg :: * -> *) n. DotRepr dg n => dg n -> [DotEdge n]
graphEdges dg Node
dg
    -- Need to check that for some reason there aren't node IDs in an
    -- edge but not on their own.
    nSet :: Set Node
nSet = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Node, Attributes)]
ns
    nEs :: [(Node, [a])]
nEs = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) [])
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
uniq
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Node
nSet)
          forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Node
n1,Node
n2,Attributes
_) -> [Node
n1,Node
n2]) [(Node, Node, Attributes)]
es
    ns' :: [(Node, Attributes)]
ns' = [(Node, Attributes)]
ns forall a. [a] -> [a] -> [a]
++ forall {a}. [(Node, [a])]
nEs
    -- Conversion functions
    toLN :: DotNode a -> (a, Attributes)
toLN (DotNode a
n Attributes
as) = (a
n,Attributes
as)
    toLE :: DotEdge b -> [(b, b, Attributes)]
toLE (DotEdge b
f b
t Attributes
as) = (if Bool
d then forall a. a -> a
id else (:) (b
t,b
f,Attributes
as)) [(b
f,b
t,Attributes
as)]

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

{- $augment
   The following functions provide support for passing a 'Graph'
   through the appropriate 'GraphvizCommand' to augment the 'Graph' by
   adding positional information, etc.

   A 'CustomAttribute' is used to distinguish multiple edges between
   two nodes from each other.

   Note that the reason that most of these functions do not have
   'unsafePerformIO' applied to them is because if you set a global
   'Attribute' of:

   @
    'Start' ('StartStyle' 'RandomStyle')
   @

   then it will not necessarily be referentially transparent (ideally,
   no matter what the seed is, it will still eventually be drawn to the
   same optimum, but this can't be guaranteed).  As such, if you are sure
   that you're not using such an 'Attribute', then you should be able to
   use 'unsafePerformIO' directly in your own code.
-}

-- | Augment the current node label type with the 'Attributes' applied
--   to that node.
type AttributeNode nl = (Attributes, nl)

-- | Augment the current edge label type with the 'Attributes' applied
--   to that edge.
type AttributeEdge el = (Attributes, el)

-- | Run the appropriate Graphviz command on the graph to get
--   positional information and then combine that information back
--   into the original graph.
graphToGraph :: (Ord cl, Graph gr) => GraphvizParams Node nl el cl l -> gr nl el
                -> IO (gr (AttributeNode nl) (AttributeEdge el))
graphToGraph :: forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Node nl el cl l
-> gr nl el -> IO (gr (AttributeNode nl) (AttributeEdge el))
graphToGraph GraphvizParams Node nl el cl l
params gr nl el
gr = forall (gr :: * -> * -> *) (dg :: * -> *) nl el.
(Graph gr, PPDotRepr dg Node, FromGeneralisedDot dg Node) =>
Bool
-> gr nl (EdgeID el)
-> dg Node
-> IO (gr (AttributeNode nl) (AttributeEdge el))
dotAttributes (forall n nl el cl l. GraphvizParams n nl el cl l -> Bool
isDirected GraphvizParams Node nl el cl l
params) gr nl (EdgeID el)
gr' DotGraph Node
dot
  where
    dot :: DotGraph Node
dot = forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Node nl el cl l -> gr nl el -> DotGraph Node
graphToDot GraphvizParams Node nl (EdgeID el) cl l
params' gr nl (EdgeID el)
gr'
    params' :: GraphvizParams Node nl (EdgeID el) cl l
params' = GraphvizParams Node nl el cl l
params { fmtEdge :: (Node, Node, EdgeID el) -> Attributes
fmtEdge = forall el.
(LEdge el -> Attributes) -> LEdge (EdgeID el) -> Attributes
setEdgeIDAttribute forall a b. (a -> b) -> a -> b
$ forall n nl el cl l.
GraphvizParams n nl el cl l -> (n, n, el) -> Attributes
fmtEdge GraphvizParams Node nl el cl l
params }
    gr' :: gr nl (EdgeID el)
gr' = forall (gr :: * -> * -> *) nl el.
Graph gr =>
gr nl el -> gr nl (EdgeID el)
addEdgeIDs gr nl el
gr

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

-- | This is a \"quick-and-dirty\" graph augmentation function that
--   sets no 'Attributes' and thus should be referentially transparent
--   and is wrapped in 'unsafePerformIO'.
--
--   Note that the provided 'GraphvizParams' is only used for
--   'isDirected', 'clusterBy' and 'clusterID'.
dotizeGraph           :: (Ord cl, Graph gr) => GraphvizParams Node nl el cl l
                         -> gr nl el -> gr (AttributeNode nl) (AttributeEdge el)
dotizeGraph :: forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Node nl el cl l
-> gr nl el -> gr (AttributeNode nl) (AttributeEdge el)
dotizeGraph GraphvizParams Node nl el cl l
params gr nl el
gr = forall a. IO a -> a
unsafePerformIO
                        forall a b. (a -> b) -> a -> b
$ forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Node nl el cl l
-> gr nl el -> IO (gr (AttributeNode nl) (AttributeEdge el))
graphToGraph forall {el}. GraphvizParams Node nl el cl l
params' gr nl el
gr
  where
    params' :: GraphvizParams Node nl el cl l
params' = GraphvizParams Node nl el cl l
params { fmtCluster :: cl -> [GlobalAttributes]
fmtCluster = forall a b. a -> b -> a
const []
                     , fmtNode :: (Node, l) -> Attributes
fmtNode    = forall a b. a -> b -> a
const []
                     , fmtEdge :: (Node, Node, el) -> Attributes
fmtEdge    = forall a b. a -> b -> a
const []
                     }

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

{- $manualAugment

   This section allows you to manually augment graphs by providing
   fine-grained control over the augmentation process (the standard
   augmentation functions compose these together).  Possible reasons for
   manual augmentation are:

   * Gain access to the intermediary 'DotRepr' used.

   * Convert the default 'DotGraph' to a @GDotGraph@ (found in
     "Data.GraphViz.Types.Generalised") so as to have greater control over
     the generated Dot code.

   * Use a specific 'GraphvizCommand' rather than the default.

   Note that whilst these functions provide you with more control, you
   must be careful how you use them: if you use the wrong 'DotRepr' for
   a 'Graph', then the behaviour of 'augmentGraph' (and all functions
   that use it) is undefined.  The main point is to make sure that the
   defined 'DotNode' and 'DotEdge' values aren't removed (or their ID
   values - or the 'Attributes' for the 'DotEdge's - altered) to
   ensure that it is possible to match up the nodes and edges in the
   'Graph' with those in the 'DotRepr'.

-}

-- | Used to augment an edge label with a unique identifier.
data EdgeID el = EID { forall el. EdgeID el -> AttributeName
eID  :: Text
                     , forall el. EdgeID el -> el
eLbl :: el
                     }
               deriving (EdgeID el -> EdgeID el -> Bool
forall el. Eq el => EdgeID el -> EdgeID el -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EdgeID el -> EdgeID el -> Bool
$c/= :: forall el. Eq el => EdgeID el -> EdgeID el -> Bool
== :: EdgeID el -> EdgeID el -> Bool
$c== :: forall el. Eq el => EdgeID el -> EdgeID el -> Bool
Eq, EdgeID el -> EdgeID el -> Bool
EdgeID el -> EdgeID el -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {el}. Ord el => Eq (EdgeID el)
forall el. Ord el => EdgeID el -> EdgeID el -> Bool
forall el. Ord el => EdgeID el -> EdgeID el -> Ordering
forall el. Ord el => EdgeID el -> EdgeID el -> EdgeID el
min :: EdgeID el -> EdgeID el -> EdgeID el
$cmin :: forall el. Ord el => EdgeID el -> EdgeID el -> EdgeID el
max :: EdgeID el -> EdgeID el -> EdgeID el
$cmax :: forall el. Ord el => EdgeID el -> EdgeID el -> EdgeID el
>= :: EdgeID el -> EdgeID el -> Bool
$c>= :: forall el. Ord el => EdgeID el -> EdgeID el -> Bool
> :: EdgeID el -> EdgeID el -> Bool
$c> :: forall el. Ord el => EdgeID el -> EdgeID el -> Bool
<= :: EdgeID el -> EdgeID el -> Bool
$c<= :: forall el. Ord el => EdgeID el -> EdgeID el -> Bool
< :: EdgeID el -> EdgeID el -> Bool
$c< :: forall el. Ord el => EdgeID el -> EdgeID el -> Bool
compare :: EdgeID el -> EdgeID el -> Ordering
$ccompare :: forall el. Ord el => EdgeID el -> EdgeID el -> Ordering
Ord, Node -> EdgeID el -> ShowS
forall el. Show el => Node -> EdgeID el -> ShowS
forall el. Show el => [EdgeID el] -> ShowS
forall el. Show el => EdgeID el -> [Char]
forall a.
(Node -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [EdgeID el] -> ShowS
$cshowList :: forall el. Show el => [EdgeID el] -> ShowS
show :: EdgeID el -> [Char]
$cshow :: forall el. Show el => EdgeID el -> [Char]
showsPrec :: Node -> EdgeID el -> ShowS
$cshowsPrec :: forall el. Show el => Node -> EdgeID el -> ShowS
Show)
-- Show is only provided for printing/debugging purposes when using a
-- normal Tree-based graph.  Since it doesn't support Read, neither
-- does EdgeID.

-- | Add unique edge identifiers to each label.  This is useful for
--   when multiple edges between two nodes need to be distinguished.
addEdgeIDs   :: (Graph gr) => gr nl el -> gr nl (EdgeID el)
addEdgeIDs :: forall (gr :: * -> * -> *) nl el.
Graph gr =>
gr nl el -> gr nl (EdgeID el)
addEdgeIDs gr nl el
g = forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode nl]
ns [(Node, Node, EdgeID el)]
es'
  where
    ns :: [LNode nl]
ns = forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes gr nl el
g
    es :: [LEdge el]
es = forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges gr nl el
g
    es' :: [(Node, Node, EdgeID el)]
es' = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a} {a} {b} {el}.
Show a =>
(a, b, el) -> a -> (a, b, EdgeID el)
addID [LEdge el]
es ([Node
1..] :: [Int])
    addID :: (a, b, el) -> a -> (a, b, EdgeID el)
addID (a
f,b
t,el
l) a
i = (a
f,b
t,forall el. AttributeName -> el -> EdgeID el
EID ([Char] -> AttributeName
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show a
i) el
l)

-- | Add a custom attribute to the list of attributes containing the
--   value of the unique edge identifier.
setEdgeIDAttribute     :: (LEdge el -> Attributes)
                          -> (LEdge (EdgeID el) -> Attributes)
setEdgeIDAttribute :: forall el.
(LEdge el -> Attributes) -> LEdge (EdgeID el) -> Attributes
setEdgeIDAttribute LEdge el -> Attributes
f = \ e :: LEdge (EdgeID el)
e@(Node
_,Node
_,EdgeID el
eid) -> AttributeName -> Attribute
identifierAttribute (forall el. EdgeID el -> AttributeName
eID EdgeID el
eid)
                                        forall a. a -> [a] -> [a]
: (LEdge el -> Attributes
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall el. LEdge (EdgeID el) -> LEdge el
stripID) LEdge (EdgeID el)
e

identifierAttrName :: AttributeName
identifierAttrName :: AttributeName
identifierAttrName = AttributeName
"graphviz_distinguish_multiple_edges"

identifierAttribute :: Text -> CustomAttribute
identifierAttribute :: AttributeName -> Attribute
identifierAttribute = AttributeName -> AttributeName -> Attribute
customAttribute AttributeName
identifierAttrName

-- | Remove the unique identifier from the 'LEdge'.
stripID           :: LEdge (EdgeID el) -> LEdge el
stripID :: forall el. LEdge (EdgeID el) -> LEdge el
stripID (Node
f,Node
t,EdgeID el
eid) = (Node
f,Node
t, forall el. EdgeID el -> el
eLbl EdgeID el
eid)

-- | Pass the 'DotRepr' through the relevant command and then augment
--   the 'Graph' that it came from.
dotAttributes :: (Graph gr, PPDotRepr dg Node, FromGeneralisedDot dg Node)
                 => Bool -> gr nl (EdgeID el)
                 -> dg Node -> IO (gr (AttributeNode nl) (AttributeEdge el))
dotAttributes :: forall (gr :: * -> * -> *) (dg :: * -> *) nl el.
(Graph gr, PPDotRepr dg Node, FromGeneralisedDot dg Node) =>
Bool
-> gr nl (EdgeID el)
-> dg Node
-> IO (gr (AttributeNode nl) (AttributeEdge el))
dotAttributes Bool
isDir gr nl (EdgeID el)
gr dg Node
dot
  = forall (gr :: * -> * -> *) (dg :: * -> *) nl el.
(Graph gr, DotRepr dg Node) =>
gr nl (EdgeID el)
-> dg Node -> gr (AttributeNode nl) (AttributeEdge el)
augmentGraph gr nl (EdgeID el)
gr forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotGraph Node -> dg Node
parseDG forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (dg :: * -> *) n a.
PrintDotRepr dg n =>
GraphvizCommand
-> dg n -> GraphvizOutput -> (Handle -> IO a) -> IO a
graphvizWithHandle GraphvizCommand
command dg Node
dot GraphvizOutput
DotOutput forall (dg :: * -> *) n. ParseDotRepr dg n => Handle -> IO (dg n)
hGetDot
  where
    parseDG :: DotGraph Node -> dg Node
parseDG = (forall a. a -> a -> a
`asTypeOf` dg Node
dot) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (dg :: * -> *) n.
FromGeneralisedDot dg n =>
DotGraph n -> dg n
fromGeneralised
    command :: GraphvizCommand
command = if Bool
isDir then GraphvizCommand
dirCommand else GraphvizCommand
undirCommand

-- | Use the 'Attributes' in the provided 'DotGraph' to augment the
--   node and edge labels in the provided 'Graph'.  The unique
--   identifiers on the edges are also stripped off.
--
--   Please note that the behaviour for this function is undefined if
--   the 'DotGraph' does not come from the original 'Graph' (either
--   by using a conversion function or by passing the result of a
--   conversion function through a 'GraphvizCommand' via the
--   'DotOutput' or similar).
augmentGraph      :: (Graph gr, DotRepr dg Node) => gr nl (EdgeID el)
                     -> dg Node -> gr (AttributeNode nl) (AttributeEdge el)
augmentGraph :: forall (gr :: * -> * -> *) (dg :: * -> *) nl el.
(Graph gr, DotRepr dg Node) =>
gr nl (EdgeID el)
-> dg Node -> gr (AttributeNode nl) (AttributeEdge el)
augmentGraph gr nl (EdgeID el)
g dg Node
dg = forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [(Node, (Attributes, nl))]
lns [(Node, Node, (Attributes, el))]
les
  where
    lns :: [(Node, (Attributes, nl))]
lns = forall a b. (a -> b) -> [a] -> [b]
map (\(Node
n, nl
l) -> (Node
n, (Map Node Attributes
nodeMap forall k a. Ord k => Map k a -> k -> a
Map.! Node
n, nl
l)))
          forall a b. (a -> b) -> a -> b
$ forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes gr nl (EdgeID el)
g
    les :: [(Node, Node, (Attributes, el))]
les = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {b}. (a, b, EdgeID b) -> (a, b, (Attributes, b))
augmentEdge forall a b. (a -> b) -> a -> b
$ forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges gr nl (EdgeID el)
g
    augmentEdge :: (a, b, EdgeID b) -> (a, b, (Attributes, b))
augmentEdge (a
f,b
t,EID AttributeName
eid b
l) = (a
f,b
t, (Map AttributeName Attributes
edgeMap forall k a. Ord k => Map k a -> k -> a
Map.! AttributeName
eid, b
l))
    ns :: [DotNode Node]
ns = forall (dg :: * -> *) n. DotRepr dg n => dg n -> [DotNode n]
graphNodes dg Node
dg
    es :: [DotEdge Node]
es = forall (dg :: * -> *) n. DotRepr dg n => dg n -> [DotEdge n]
graphEdges dg Node
dg
    nodeMap :: Map Node Attributes
nodeMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall n. DotNode n -> n
nodeID forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall n. DotNode n -> Attributes
nodeAttributes) [DotNode Node]
ns
    edgeMap :: Map AttributeName Attributes
edgeMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {n}. DotEdge n -> (AttributeName, Attributes)
edgeIDAttrs [DotEdge Node]
es
    edgeIDAttrs :: DotEdge n -> (AttributeName, Attributes)
edgeIDAttrs = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Attribute -> AttributeName
customValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttributeName -> Attributes -> Maybe (Attribute, Attributes)
findSpecifiedCustom AttributeName
identifierAttrName
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. DotEdge n -> Attributes
edgeAttributes

-- -----------------------------------------------------------------------------
-- Utility Functions

-- | Quickly visualise a graph using the 'Xlib' 'GraphvizCanvas'.  If
--   your label types are not (and cannot) be instances of 'Labellable',
--   you may wish to use 'gmap', 'nmap' or 'emap' to set them to a value
--   such as @\"\"@.
preview   :: (Ord el, Graph gr, Labellable nl, Labellable el) => gr nl el -> IO ()
preview :: forall el (gr :: * -> * -> *) nl.
(Ord el, Graph gr, Labellable nl, Labellable el) =>
gr nl el -> IO ()
preview gr nl el
g = forall {a}. IO a -> IO ()
ign forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (forall {a}. IO a -> IO ()
ign forall a b. (a -> b) -> a -> b
$ forall (dg :: * -> *) n.
PrintDotRepr dg n =>
dg n -> GraphvizCanvas -> IO ()
runGraphvizCanvas' DotGraph Node
dg GraphvizCanvas
Xlib)
  where
    dg :: DotGraph Node
dg = forall el (gr :: * -> * -> *) nl cl l a.
(Ord el, Graph gr) =>
(GraphvizParams Node nl el cl l -> gr nl el -> a)
-> GraphvizParams Node nl el cl l -> gr nl el -> a
setDirectedness forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Node nl el cl l -> gr nl el -> DotGraph Node
graphToDot forall {n}. GraphvizParams n nl el () nl
params gr nl el
g
    params :: GraphvizParams n nl el () nl
params = forall n nl el. GraphvizParams n nl el () nl
nonClusteredParams { fmtNode :: (n, nl) -> Attributes
fmtNode = \ (n
_,nl
l) -> [forall a. Labellable a => a -> Attribute
toLabel nl
l]
                                , fmtEdge :: (n, n, el) -> Attributes
fmtEdge = \ (n
_, n
_, el
l) -> [forall a. Labellable a => a -> Attribute
toLabel el
l]
                                }
    ign :: IO a -> IO ()
ign = (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ())