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

{- |
   Module      : Data.GraphViz.Types.Graph
   Description : A graph-like representation of Dot graphs.
   Copyright   : (c) Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   It is sometimes useful to be able to manipulate a Dot graph /as/ an
   actual graph.  This representation lets you do so, using an
   inductive approach based upon that from FGL (note that 'DotGraph'
   is /not/ an instance of the FGL classes due to having the wrong
   kind).  Note, however, that the API is not as complete as proper
   graph implementations.

   For purposes of manipulation, all edges are found in the root graph
   and not in a cluster; as such, having 'EdgeAttrs' in a cluster's
   'GlobalAttributes' is redundant.

   Printing is achieved via "Data.GraphViz.Types.Canonical" (using
   'toCanonical') and parsing via "Data.GraphViz.Types.Generalised"
   (so /any/ piece of Dot code can be parsed in).

   This representation doesn't allow non-cluster sub-graphs.  Also, all
   clusters /must/ have a unique identifier.  For those functions (with
   the exception of 'DotRepr' methods) that take or return a \"@Maybe
   GraphID@\", a value of \"@Nothing@\" refers to the root graph; \"@Just
   clust@\" refers to the cluster with the identifier \"@clust@\".

   You would not typically explicitly create these values, instead
   converting existing Dot graphs (via 'fromDotRepr').  However, one
   way of constructing the sample graph would be:

   > setID (Str "G")
   > . setStrictness False
   > . setIsDirected True
   > . setClusterAttributes (Int 0) [GraphAttrs [style filled, color LightGray, textLabel "process #1"], NodeAttrs [style filled, color White]]
   > . setClusterAttributes (Int 1) [GraphAttrs [textLabel "process #2", color Blue], NodeAttrs [style filled]]
   > $ composeList [ Cntxt "a0"    (Just $ Int 0)   []               [("a3",[]),("start",[])] [("a1",[])]
   >               , Cntxt "a1"    (Just $ Int 0)   []               []                       [("a2",[]),("b3",[])]
   >               , Cntxt "a2"    (Just $ Int 0)   []               []                       [("a3",[])]
   >               , Cntxt "a3"    (Just $ Int 0)   []               [("b2",[])]              [("end",[])]
   >               , Cntxt "b0"    (Just $ Int 1)   []               [("start",[])]           [("b1",[])]
   >               , Cntxt "b1"    (Just $ Int 1)   []               []                       [("b2",[])]
   >               , Cntxt "b2"    (Just $ Int 1)   []               []                       [("b3",[])]
   >               , Cntxt "b3"    (Just $ Int 1)   []               []                       [("end",[])]
   >               , Cntxt "end"   Nothing          [shape MSquare]  []                       []
   >               , Cntxt "start" Nothing          [shape MDiamond] []                       []]

 -}
module Data.GraphViz.Types.Graph
       ( DotGraph
       , GraphID(..)
       , Context(..)
         -- * Conversions
       , toCanonical
       , unsafeFromCanonical
       , fromDotRepr
         -- * Graph information
       , isEmpty
       , hasClusters
       , isEmptyGraph
       , graphAttributes
       , parentOf
       , clusterAttributes
       , foundInCluster
       , attributesOf
       , predecessorsOf
       , successorsOf
       , adjacentTo
       , adjacent
         -- * Graph construction
       , mkGraph
       , emptyGraph
       , (&)
       , composeList
       , addNode
       , DotNode(..)
       , addDotNode
       , addEdge
       , DotEdge(..)
       , addDotEdge
       , addCluster
       , setClusterParent
       , setClusterAttributes
         -- * Graph deconstruction
       , decompose
       , decomposeAny
       , decomposeList
       , deleteNode
       , deleteAllEdges
       , deleteEdge
       , deleteDotEdge
       , deleteCluster
       , removeEmptyClusters
       ) where

import           Data.GraphViz.Algorithms            (CanonicaliseOptions(..),
                                                      canonicaliseOptions)
import           Data.GraphViz.Algorithms.Clustering
import           Data.GraphViz.Attributes.Complete   (Attributes)
import           Data.GraphViz.Attributes.Same
import           Data.GraphViz.Internal.Util         (groupSortBy,
                                                      groupSortCollectBy)
import           Data.GraphViz.Types
import qualified Data.GraphViz.Types.Canonical       as C
import qualified Data.GraphViz.Types.Generalised     as G
import           Data.GraphViz.Types.Internal.Common (partitionGlobal)
import qualified Data.GraphViz.Types.State           as St

import           Control.Applicative             (liftA2, (<|>))
import           Control.Arrow                   ((***))
import qualified Data.Foldable                   as F
import           Data.List                       (delete, foldl', unfoldr)
import           Data.Map                        (Map)
import qualified Data.Map                        as M
import           Data.Maybe                      (fromMaybe, mapMaybe,
                                                  maybeToList)
import qualified Data.Sequence                   as Seq
import qualified Data.Set                        as S
import           Text.ParserCombinators.ReadPrec (prec)
import           Text.Read                       (Lexeme(Ident), lexP, parens,
                                                  readPrec)

#if !(MIN_VERSION_base (4,8,0))
import Control.Applicative ((<$>), (<*>))
#endif

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

-- | A Dot graph that allows graph operations on it.
data DotGraph n = DG { strictGraph   :: !Bool
                     , directedGraph :: !Bool
                     , graphAttrs    :: !GlobAttrs
                     , graphID       :: !(Maybe GraphID)
                     , clusters      :: !(Map GraphID ClusterInfo)
                     , values        :: !(NodeMap n)
                     }
                deriving (Eq, Ord)

-- | It should be safe to substitute 'unsafeFromCanonical' for
--   'fromCanonical' in the output of this.
instance (Show n) => Show (DotGraph n) where
  showsPrec d dg = showParen (d > 10) $
                   showString "fromCanonical " . shows (toCanonical dg)

-- | If the graph is the output from 'show', then it should be safe to
--   substitute 'unsafeFromCanonical' for 'fromCanonical'.
instance (Ord n, Read n) => Read (DotGraph n) where
  readPrec = parens . prec 10
             $ do Ident "fromCanonical" <- lexP
                  cdg <- readPrec
                  return $ fromCanonical cdg

data GlobAttrs = GA { graphAs :: !SAttrs
                    , nodeAs  :: !SAttrs
                    , edgeAs  :: !SAttrs
                    }
               deriving (Eq, Ord, Show, Read)

data NodeInfo n = NI { _inCluster    :: !(Maybe GraphID)
                     , _attributes   :: !Attributes
                     , _predecessors :: !(EdgeMap n)
                     , _successors   :: !(EdgeMap n)
                     }
                deriving (Eq, Ord, Show, Read)

data ClusterInfo = CI { parentCluster :: !(Maybe GraphID)
                      , clusterAttrs  :: !GlobAttrs
                      }
                 deriving (Eq, Ord, Show, Read)

type NodeMap n = Map n (NodeInfo n)

type EdgeMap n = Map n [Attributes]

-- | The decomposition of a node from a dot graph.  Any loops should
--   be found in 'successors' rather than 'predecessors'.  Note also
--   that these are created\/consumed as if for /directed/ graphs.
data Context n = Cntxt { node         :: !n
                         -- | The cluster this node can be found in;
                         --   @Nothing@ indicates the node can be
                         --   found in the root graph.
                       , inCluster    :: !(Maybe GraphID)
                       , attributes   :: !Attributes
                       , predecessors :: ![(n, Attributes)]
                       , successors   :: ![(n, Attributes)]
                       }
               deriving (Eq, Ord, Show, Read)

adjacent :: Context n -> [DotEdge n]
adjacent c = mapU (`DotEdge` n) (predecessors c)
             ++ mapU (DotEdge n) (successors c)
  where
    n = node c
    mapU = map . uncurry

emptyGraph :: DotGraph n
emptyGraph = DG { strictGraph   = False
                , directedGraph = True
                , graphID       = Nothing
                , graphAttrs    = emptyGA
                , clusters      = M.empty
                , values        = M.empty
                }

emptyGA :: GlobAttrs
emptyGA = GA S.empty S.empty S.empty

-- -----------------------------------------------------------------------------
-- Construction

-- | Merge the 'Context' into the graph.  Assumes that the specified
--   node is not in the graph but that all endpoints in the
--   'successors' and 'predecessors' (with the exception of loops)
--   are.  If the cluster is not present in the graph, then it will be
--   added with no attributes with a parent of the root graph.
--
--   Note that @&@ and @'decompose'@ are /not/ quite inverses, as this
--   function will add in the cluster if it does not yet exist in the
--   graph, but 'decompose' will not delete it.
(&) :: (Ord n) => Context n -> DotGraph n -> DotGraph n
(Cntxt n mc as ps ss) & dg = withValues merge dg'
  where
    ps' = toMap ps
    ps'' = fromMap (M.delete n ps')
    ss' = toMap ss
    ss'' = fromMap (M.delete n ss')

    dg' = addNode n mc as dg

    merge = addSuccRev n ps'' . addPredRev n ss''
            -- Add reverse edges
            . M.adjust (\ni -> ni { _predecessors = ps', _successors = ss' }) n
            -- Add actual edges

infixr 5 &

-- | Recursively merge the list of contexts.
--
--   > composeList = foldr (&) emptyGraph
composeList :: (Ord n) => [Context n] -> DotGraph n
composeList = foldr (&) emptyGraph

addSuccRev :: (Ord n) => n -> [(n, Attributes)] -> NodeMap n -> NodeMap n
addSuccRev = addEdgeLinks niSkip niSucc

addPredRev :: (Ord n) => n -> [(n, Attributes)] -> NodeMap n -> NodeMap n
addPredRev = addEdgeLinks niSkip niPred

addEdgeLinks :: (Ord n) => UpdateEdgeMap n -> UpdateEdgeMap n
                -> n -> [(n, Attributes)] -> NodeMap n -> NodeMap n
addEdgeLinks fwd rev f tas = updRev . updFwd
  where
    updFwd = M.adjust addFwd f

    addFwd ni = foldl' (\ni' (t,as) -> fwd (M.insertWith (++) t [as]) ni') ni tas

    updRev nm = foldl' (\nm' (t,as) -> M.adjust (addRev as) t nm') nm tas

    addRev as = rev (M.insertWith (++) f [as])

-- | Add a node to the current graph. Merges attributes and edges if
--   the node already exists in the graph.
--
--   If the specified cluster does not yet exist in the graph, then it
--   will be added (as a sub-graph of the overall graph and no
--   attributes).
addNode :: (Ord n)
           => n
           -> Maybe GraphID -- ^ The cluster the node can be found in
                            --   (@Nothing@ refers to the root graph).
           -> Attributes
           -> DotGraph n
           -> DotGraph n
addNode n mc as dg = addEmptyCluster mc $ dg { values = ns' }
  where
    ns = values dg
    ns' = M.insertWith mergeLogic n (NI mc as M.empty M.empty) ns
    mergeLogic (NI newClust newAttrs newPreds newSuccs) (NI oldClust oldAttrs oldPreds oldSuccs) =
        NI resClust resAttrs resPreds resSuccs
      where
        resClust = newClust <|> oldClust
        resAttrs = unSame $ S.union (toSAttr newAttrs) (toSAttr oldAttrs)
        resPreds = M.unionWith (++) newPreds oldPreds
        resSuccs = M.unionWith (++) newSuccs oldSuccs

-- | A variant of 'addNode' that takes in a DotNode (not in a
--   cluster).
addDotNode                :: (Ord n) => DotNode n -> DotGraph n -> DotGraph n
addDotNode (DotNode n as) = addNode n Nothing as

-- | Add the specified edge to the graph; assumes both node values are
--   already present in the graph.  If the graph is undirected then
--   the order of nodes doesn't matter.
addEdge :: (Ord n) => n -> n -> Attributes -> DotGraph n -> DotGraph n
addEdge f t as = withValues merge
  where
    merge = addEdgeLinks niSucc niPred f [(t,as)]

-- | A variant of 'addEdge' that takes a 'DotEdge' value.
addDotEdge                  :: (Ord n) => DotEdge n -> DotGraph n -> DotGraph n
addDotEdge (DotEdge f t as) = addEdge f t as

-- | Add a new cluster to the graph; throws an error if the cluster
--   already exists.  Assumes that it doesn't match the identifier of
--   the overall graph.  If the parent cluster doesn't already exist
--   in the graph then it will be added.
addCluster :: GraphID          -- ^ The identifier for this cluster.
              -> Maybe GraphID -- ^ The parent of this cluster
                               --   (@Nothing@ refers to the root
                               --   graph)
              -> [GlobalAttributes]
              -> DotGraph n
              -> DotGraph n
addCluster c mp gas dg
  | c `M.member` cs = error "Cluster already exists in the graph"
  | otherwise       = addEmptyCluster mp
                      $ dg { clusters = M.insert c ci cs }
  where
    cs = clusters dg
    ci = CI mp $ toGlobAttrs gas

-- Used to make sure that the parent cluster exists
addEmptyCluster :: Maybe GraphID -> DotGraph n -> DotGraph n
addEmptyCluster = maybe id (withClusters . (`dontReplace` defCI))
  where
    dontReplace = M.insertWith (const id)
    defCI = CI Nothing emptyGA

-- | Specify the parent of the cluster; adds both in if not already present.
setClusterParent     :: GraphID -> Maybe GraphID -> DotGraph n -> DotGraph n
setClusterParent c p = withClusters (M.adjust setP c) . addCs
  where
    addCs = addEmptyCluster p . addEmptyCluster (Just c)
    setP ci = ci { parentCluster = p }

-- | Specify the attributes of the cluster; adds it if not already
--   present.
setClusterAttributes       :: GraphID -> [GlobalAttributes]
                              -> DotGraph n -> DotGraph n
setClusterAttributes c gas = withClusters (M.adjust setAs c)
                             . addEmptyCluster (Just c)
  where
    setAs ci = ci { clusterAttrs = toGlobAttrs gas }

-- | Create a graph with no clusters.
mkGraph :: (Ord n) => [DotNode n] -> [DotEdge n] -> DotGraph n
mkGraph ns es = flip (foldl' $ flip addDotEdge) es
                $ foldl' (flip addDotNode) emptyGraph ns

-- | Convert this DotGraph into canonical form.  All edges are found
--   in the outer graph rather than in clusters.
toCanonical :: DotGraph n -> C.DotGraph n
toCanonical dg = C.DotGraph { C.strictGraph     = strictGraph dg
                            , C.directedGraph   = directedGraph dg
                            , C.graphID         = graphID dg
                            , C.graphStatements = stmts
                            }
  where
    stmts = C.DotStmts { C.attrStmts = fromGlobAttrs $ graphAttrs dg
                       , C.subGraphs = cs
                       , C.nodeStmts = ns
                       , C.edgeStmts = getEdgeInfo False dg
                       }

    cls = clusters dg
    pM = clusterPath' dg

    clustAs = maybe [] (fromGlobAttrs . clusterAttrs) . (`M.lookup`cls)

    lns = map (\ (n,ni) -> (n,(_inCluster ni, _attributes ni)))
          . M.assocs $ values dg

    (cs,ns) = clustersToNodes pathOf (const True) id clustAs snd lns

    pathOf (n,(c,as)) = pathFrom c (n,as)
    pathFrom c ln = F.foldr C (N ln) . fromMaybe Seq.empty $ (`M.lookup`pM) =<< c

-- -----------------------------------------------------------------------------
-- Deconstruction

-- | A partial inverse of @'&'@, in that if a node exists in a graph
--   then it will be decomposed, but will not remove the cluster that
--   it was in even if it was the only node in that cluster.
decompose :: (Ord n) => n -> DotGraph n -> Maybe (Context n, DotGraph n)
decompose n dg
  | n `M.notMember` ns = Nothing
  | otherwise          = Just (c, dg')
  where
    ns = values dg
    (Just (NI mc as ps ss), ns') = M.updateLookupWithKey (const . const Nothing) n ns

    c = Cntxt n mc as (fromMap $ n `M.delete` ps) (fromMap ss)
    dg' = dg { values = delSucc n ps . delPred n ss $ ns' }

-- | As with 'decompose', but do not specify /which/ node to
--   decompose.
decomposeAny :: (Ord n) => DotGraph n -> Maybe (Context n, DotGraph n)
decomposeAny dg
  | isEmpty dg = Nothing
  | otherwise  = decompose (fst . M.findMin $ values dg) dg

-- | Recursively decompose the Dot graph into a list of contexts such
--   that if @(c:cs) = decomposeList dg@, then @dg = c & 'composeList' cs@.
--
--   Note that all global attributes are lost, so this is /not/
--   suitable for representing a Dot graph on its own.
decomposeList :: (Ord n) => DotGraph n -> [Context n]
decomposeList = unfoldr decomposeAny

delSucc :: (Ord n) => n -> EdgeMap n -> NodeMap n -> NodeMap n
delSucc = delPS niSucc

delPred :: (Ord n) => n -> EdgeMap n -> NodeMap n -> NodeMap n
delPred = delPS niPred

-- Only takes in EdgeMap rather than [n] to make it easier to call
-- from decompose
delPS :: (Ord n) => ((EdgeMap n -> EdgeMap n) -> NodeInfo n -> NodeInfo n)
         -> n -> EdgeMap n -> NodeMap n -> NodeMap n
delPS fni t fm nm = foldl' delE nm $ M.keys fm
  where
    delE nm' f = M.adjust (fni $ M.delete t) f nm'

-- | Delete the specified node from the graph; returns the original
--   graph if that node isn't present.
deleteNode      :: (Ord n) => n -> DotGraph n -> DotGraph n
deleteNode n dg = maybe dg snd $ decompose n dg

-- | Delete all edges between the two nodes; returns the original
--   graph if there are no edges.
deleteAllEdges          :: (Ord n) => n -> n -> DotGraph n -> DotGraph n
deleteAllEdges n1 n2 = withValues (delAE n1 n2 . delAE n2 n1)
  where
    delAE f t = delSucc f t' . delPred f t'
      where
        t' = M.singleton t []

-- | Deletes the specified edge from the DotGraph (note: for unordered
--   graphs both orientations are considered).
deleteEdge :: (Ord n) => n -> n -> Attributes -> DotGraph n -> DotGraph n
deleteEdge n1 n2 as dg = withValues delEs dg
  where
    delE f t = M.adjust (niSucc $ M.adjust (delete as) t) f
               . M.adjust (niPred $ M.adjust (delete as) f) t

    delEs | directedGraph dg = delE n1 n2
          | otherwise        = delE n1 n2 . delE n2 n1

-- | As with 'deleteEdge' but takes a 'DotEdge' rather than individual
--   values.
deleteDotEdge :: (Ord n) => DotEdge n -> DotGraph n -> DotGraph n
deleteDotEdge (DotEdge n1 n2 as) = deleteEdge n1 n2 as

-- | Delete the specified cluster, and makes any clusters or nodes
--   within it be in its root cluster (or the overall graph if
--   required).
deleteCluster      :: GraphID -> DotGraph n -> DotGraph n
deleteCluster c dg = withValues (M.map adjNode)
                     . withClusters (M.map adjCluster . M.delete c)
                     $ dg
  where
    p = parentCluster =<< c `M.lookup` clusters dg

    adjParent p'
      | p' == Just c = p
      | otherwise    = p'

    adjNode ni = ni { _inCluster = adjParent $ _inCluster ni }

    adjCluster ci = ci { parentCluster = adjParent $ parentCluster ci }

-- | Remove clusters with no sub-clusters and no nodes within them.
removeEmptyClusters :: DotGraph n -> DotGraph n
removeEmptyClusters dg = dg { clusters = cM' }
  where
    cM = clusters dg
    cM' = (cM `M.difference` invCs) `M.difference` invNs

    invCs = usedClustsIn $ M.map parentCluster cM
    invNs = usedClustsIn . M.map _inCluster $ values dg

    usedClustsIn = M.fromAscList
                   . map ((,) <$> fst . head <*> map snd)
                   . groupSortBy fst
                   . mapMaybe (uncurry (fmap . flip (,)))
                   . M.assocs

-- -----------------------------------------------------------------------------
-- Information

-- | Does this graph have any nodes?
isEmpty :: DotGraph n -> Bool
isEmpty = M.null . values

-- | Does this graph have any clusters?
hasClusters :: DotGraph n -> Bool
hasClusters = M.null . clusters

-- | Determine if this graph has nodes or clusters.
isEmptyGraph :: DotGraph n -> Bool
isEmptyGraph = liftA2 (&&) isEmpty (not . hasClusters)

graphAttributes :: DotGraph n -> [GlobalAttributes]
graphAttributes = fromGlobAttrs . graphAttrs

-- | Return the ID for the cluster the node is in.
foundInCluster :: (Ord n) => DotGraph n -> n -> Maybe GraphID
foundInCluster dg n = _inCluster $ values dg M.! n

-- | Return the attributes for the node.
attributesOf :: (Ord n) => DotGraph n -> n -> Attributes
attributesOf dg n = _attributes $ values dg M.! n

-- | Predecessor edges for the specified node.  For undirected graphs
--   equivalent to 'adjacentTo'.
predecessorsOf :: (Ord n) => DotGraph n -> n -> [DotEdge n]
predecessorsOf dg t
  | directedGraph dg = emToDE (`DotEdge` t)
                       . _predecessors $ values dg M.! t
  | otherwise        = adjacentTo dg t

-- | Successor edges for the specified node.  For undirected graphs
--   equivalent to 'adjacentTo'.
successorsOf :: (Ord n) => DotGraph n -> n -> [DotEdge n]
successorsOf dg f
  | directedGraph dg = emToDE (DotEdge f)
                       . _successors $ values dg M.! f
  | otherwise        = adjacentTo dg f

-- | All edges involving this node.
adjacentTo :: (Ord n) => DotGraph n -> n -> [DotEdge n]
adjacentTo dg n = sucs ++ preds
  where
    ni = values dg M.! n
    sucs = emToDE (DotEdge n) $ _successors ni
    preds = emToDE (`DotEdge` n) $ n `M.delete` _predecessors ni

emToDE :: (n -> Attributes -> DotEdge n) -> EdgeMap n -> [DotEdge n]
emToDE f = map (uncurry f) . fromMap

-- | Which cluster (or the root graph) is this cluster in?
parentOf :: DotGraph n -> GraphID -> Maybe GraphID
parentOf dg c = parentCluster $ clusters dg M.! c

clusterAttributes :: DotGraph n -> GraphID -> [GlobalAttributes]
clusterAttributes dg c = fromGlobAttrs . clusterAttrs $ clusters dg M.! c

-- -----------------------------------------------------------------------------
-- For DotRepr instance

instance (Ord n) => DotRepr DotGraph n where
  fromCanonical = fromDotRepr

  getID = graphID

  setID i g = g { graphID = Just i }

  graphIsDirected = directedGraph

  setIsDirected d g = g { directedGraph = d }

  graphIsStrict = strictGraph

  setStrictness s g = g { strictGraph = s }

  mapDotGraph = mapNs

  graphStructureInformation = getGraphInfo

  nodeInformation = getNodeInfo

  edgeInformation = getEdgeInfo

  unAnonymise = id -- No anonymous clusters!

instance (Ord n) => G.FromGeneralisedDot DotGraph n where
  fromGeneralised = fromDotRepr

instance (Ord n, PrintDot n) => PrintDotRepr DotGraph n
instance (Ord n, ParseDot n) => ParseDotRepr DotGraph n
instance (Ord n, PrintDot n, ParseDot n) => PPDotRepr DotGraph n

-- | Uses the PrintDot instance for canonical 'C.DotGraph's.
instance (PrintDot n) => PrintDot (DotGraph n) where
  unqtDot = unqtDot . toCanonical

-- | Uses the ParseDot instance for generalised 'G.DotGraph's.
instance (Ord n, ParseDot n) => ParseDot (DotGraph n) where
  parseUnqt = fromGDot <$> parseUnqt
    where
      -- fromGDot :: G.DotGraph n -> DotGraph n
      fromGDot = fromDotRepr . (`asTypeOf` (undefined :: G.DotGraph n))

  parse = parseUnqt -- Don't want the option of quoting

cOptions :: CanonicaliseOptions
cOptions = COpts { edgesInClusters = False
                 , groupAttributes = True
                 }

-- | Convert any existing DotRepr instance to a 'DotGraph'.
fromDotRepr :: (DotRepr dg n) => dg n -> DotGraph n
fromDotRepr = unsafeFromCanonical . canonicaliseOptions cOptions . unAnonymise

-- | Convert a canonical Dot graph to a graph-based one.  This assumes
--   that the canonical graph is the same format as returned by
--   'toCanonical'.  The \"unsafeness\" is that:
--
--   * All clusters must have a unique identifier ('unAnonymise' can
--     be used to make sure all clusters /have/ an identifier, but it
--     doesn't ensure uniqueness).
--
--   * All nodes are assumed to be explicitly listed precisely once.
--
--   * Only edges found in the root graph are considered.
--
--   If this isn't the case, use 'fromCanonical' instead.
--
--   The 'graphToDot' function from "Data.GraphViz" produces output
--   suitable for this function (assuming all clusters are provided
--   with a unique identifier); 'graphElemsToDot' is suitable if all
--   nodes are specified in the input list (rather than just the
--   edges).
unsafeFromCanonical :: (Ord n) => C.DotGraph n -> DotGraph n
unsafeFromCanonical dg = DG { strictGraph   = C.strictGraph dg
                            , directedGraph = dirGraph
                            , graphAttrs    = as
                            , graphID       = mgid
                            , clusters      = cs
                            , values        = ns
                            }
  where
    stmts = C.graphStatements dg
    mgid = C.graphID dg
    dirGraph = C.directedGraph dg

    (as, cs, ns) = fCStmt Nothing stmts

    fCStmt p stmts' = (sgAs, cs', ns')
      where
        sgAs = toGlobAttrs $ C.attrStmts stmts'
        (cs', sgNs) = (M.unions *** M.unions) . unzip
                      . map (fCSG p) $ C.subGraphs stmts'
        nNs = M.fromList . map (fDN p) $ C.nodeStmts stmts'
        ns' = sgNs `M.union` nNs

    fCSG p sg = (M.insert sgid ci cs', ns')
      where
        msgid@(Just sgid) = C.subGraphID sg
        (as', cs', ns') = fCStmt msgid $ C.subGraphStmts sg
        ci = CI p as'

    fDN p (DotNode n as') = ( n
                            , NI { _inCluster    = p
                                 , _attributes   = as'
                                 , _predecessors = eSel n tEs
                                 , _successors   = eSel n fEs
                                 }
                            )

    es = C.edgeStmts stmts
    fEs = toEdgeMap fromNode toNode es
    tEs = delLoops $ toEdgeMap toNode fromNode es
    eSel n es' = fromMaybe M.empty $ n `M.lookup` es'
    delLoops = M.mapWithKey M.delete

toEdgeMap     :: (Ord n) => (DotEdge n -> n) -> (DotEdge n -> n) -> [DotEdge n]
                 -> Map n (EdgeMap n)
toEdgeMap f t = M.map eM . M.fromList . groupSortCollectBy f t'
  where
    t' = liftA2 (,) t edgeAttributes
    eM = M.fromList . groupSortCollectBy fst snd

mapNs :: (Ord n') => (n -> n') -> DotGraph n -> DotGraph n'
mapNs f (DG st d as mid cs vs) = DG st d as mid cs
                                 $ mapNM vs
  where
    mapNM = M.map mapNI . mpM
    mapNI (NI mc as' ps ss) = NI mc as' (mpM ps) (mpM ss)
    mpM = M.mapKeys f

getGraphInfo    :: DotGraph n -> (GlobalAttributes, ClusterLookup)
getGraphInfo dg = (gas, cl)
  where
    toGA = GraphAttrs . unSame
    (gas, cgs) = (toGA *** M.map toGA) $ globAttrMap graphAs dg
    pM = M.map pInit $ clusterPath dg

    cl = M.mapWithKey addPath $ M.mapKeysMonotonic Just cgs

    addPath c as = ( maybeToList $ c `M.lookup` pM
                   , as
                   )

    pInit p = case Seq.viewr p of
                (p' Seq.:> _) -> p'
                _             -> Seq.empty

getNodeInfo             :: Bool -> DotGraph n -> NodeLookup n
getNodeInfo withGlob dg = M.map toLookup ns
  where
    (gGlob, aM) = globAttrMap nodeAs dg
    pM = clusterPath dg

    ns = values dg

    toLookup ni = (pth, as')
      where
        as = _attributes ni
        mp = _inCluster ni
        pth = fromMaybe Seq.empty $ mp `M.lookup` pM
        pAs = fromMaybe gGlob $ (`M.lookup` aM) =<< mp
        as' | withGlob  = unSame $ toSAttr as `S.union` pAs
            | otherwise = as

getEdgeInfo             :: Bool -> DotGraph n -> [DotEdge n]
getEdgeInfo withGlob dg = concatMap (uncurry mkDotEdges) es
  where
    gGlob = edgeAs $ graphAttrs dg

    es = concatMap (uncurry (map . (,)))
         . M.assocs . M.map (M.assocs . _successors)
         $ values dg

    addGlob as
      | withGlob  = unSame $ toSAttr as `S.union` gGlob
      | otherwise = as

    mkDotEdges f (t, ass) = map (DotEdge f t . addGlob) ass

globAttrMap       :: (GlobAttrs -> SAttrs) -> DotGraph n
                     -> (SAttrs, Map GraphID SAttrs)
globAttrMap af dg = (gGlob, aM)
  where
    gGlob = af $ graphAttrs dg

    cs = clusters dg

    aM = M.map attrsFor cs

    attrsFor ci = as `S.union` pAs
      where
        as = af $ clusterAttrs ci
        p = parentCluster ci
        pAs = fromMaybe gGlob $ (`M.lookup` aM) =<< p

clusterPath :: DotGraph n -> Map (Maybe GraphID) St.Path
clusterPath = M.mapKeysMonotonic Just . M.map (fmap Just) . clusterPath'

clusterPath' :: DotGraph n -> Map GraphID (Seq.Seq GraphID)
clusterPath' dg = pM
  where
    cs = clusters dg

    pM = M.mapWithKey pathOf cs

    pathOf c ci = pPth Seq.|> c
      where
        mp = parentCluster ci
        pPth = fromMaybe Seq.empty $ (`M.lookup` pM) =<< mp

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

withValues      :: (NodeMap n -> NodeMap n) -> DotGraph n -> DotGraph n
withValues f dg = dg { values = f $ values dg }

withClusters      :: (Map GraphID ClusterInfo -> Map GraphID ClusterInfo)
                     -> DotGraph n -> DotGraph n
withClusters f dg = dg { clusters = f $ clusters dg }

toGlobAttrs :: [GlobalAttributes] -> GlobAttrs
toGlobAttrs = mkGA . partitionGlobal
  where
    mkGA (ga,na,ea) = GA (toSAttr ga) (toSAttr na) (toSAttr ea)

fromGlobAttrs :: GlobAttrs -> [GlobalAttributes]
fromGlobAttrs (GA ga na ea) = filter (not . null . attrs)
                              [ GraphAttrs $ unSame ga
                              , NodeAttrs  $ unSame na
                              , EdgeAttrs  $ unSame ea
                              ]

type UpdateEdgeMap n = (EdgeMap n -> EdgeMap n) -> NodeInfo n -> NodeInfo n

niSucc      :: UpdateEdgeMap n
niSucc f ni = ni { _successors = f $ _successors ni }

niPred      :: UpdateEdgeMap n
niPred f ni = ni { _predecessors = f $ _predecessors ni }

niSkip      :: UpdateEdgeMap n
niSkip _ ni = ni

toMap :: (Ord n) => [(n, Attributes)] -> EdgeMap n
toMap = M.fromAscList . groupSortCollectBy fst snd

fromMap :: EdgeMap n -> [(n, Attributes)]
fromMap = concatMap (uncurry (map . (,))) . M.toList