{-# OPTIONS_HADDOCK hide #-}

{- |
   Module      : Data.GraphViz.Types.State
   Description : Create lookups for 'Attribute's.
   Copyright   : (c) Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   This module provides functions to assist with building 'Attribute'
   lookups.
-}
module Data.GraphViz.Types.State
       ( Path
       , recursiveCall
         --
       , GraphState
       , ClusterLookup
       , getGraphInfo
       , addSubGraph
       , addGraphGlobals
         --
       , NodeState
       , NodeLookup
       , getNodeLookup
       , toDotNodes
       , addNodeGlobals
       , addNode
       , addEdgeNodes
         --
       , EdgeState
       , getDotEdges
       , addEdgeGlobals
       , addEdge
       ) where

import Data.GraphViz.Attributes.Complete   (Attributes, usedByClusters,
                                            usedByGraphs)
import Data.GraphViz.Attributes.Same
import Data.GraphViz.Types.Internal.Common

import           Control.Arrow       ((&&&), (***))
import           Control.Monad       (when)
import           Control.Monad.State (State, execState, gets, modify)
import           Data.DList          (DList)
import qualified Data.DList          as DList
import           Data.Function       (on)
import           Data.Map            (Map)
import qualified Data.Map            as Map
import           Data.Sequence       (Seq, ViewL(..), (|>))
import qualified Data.Sequence       as Seq
import qualified Data.Set            as Set

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

type GVState s a = State (StateValue s) a

data StateValue a = SV { forall a. StateValue a -> SAttrs
globalAttrs :: SAttrs
                       , forall a. StateValue a -> Bool
useGlobals  :: Bool
                       , forall a. StateValue a -> Path
globalPath  :: Path
                       , forall a. StateValue a -> a
value       :: a
                       }
                  deriving (StateValue a -> StateValue a -> Bool
(StateValue a -> StateValue a -> Bool)
-> (StateValue a -> StateValue a -> Bool) -> Eq (StateValue a)
forall a. Eq a => StateValue a -> StateValue a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => StateValue a -> StateValue a -> Bool
== :: StateValue a -> StateValue a -> Bool
$c/= :: forall a. Eq a => StateValue a -> StateValue a -> Bool
/= :: StateValue a -> StateValue a -> Bool
Eq, Eq (StateValue a)
Eq (StateValue a) =>
(StateValue a -> StateValue a -> Ordering)
-> (StateValue a -> StateValue a -> Bool)
-> (StateValue a -> StateValue a -> Bool)
-> (StateValue a -> StateValue a -> Bool)
-> (StateValue a -> StateValue a -> Bool)
-> (StateValue a -> StateValue a -> StateValue a)
-> (StateValue a -> StateValue a -> StateValue a)
-> Ord (StateValue a)
StateValue a -> StateValue a -> Bool
StateValue a -> StateValue a -> Ordering
StateValue a -> StateValue a -> StateValue a
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 a. Ord a => Eq (StateValue a)
forall a. Ord a => StateValue a -> StateValue a -> Bool
forall a. Ord a => StateValue a -> StateValue a -> Ordering
forall a. Ord a => StateValue a -> StateValue a -> StateValue a
$ccompare :: forall a. Ord a => StateValue a -> StateValue a -> Ordering
compare :: StateValue a -> StateValue a -> Ordering
$c< :: forall a. Ord a => StateValue a -> StateValue a -> Bool
< :: StateValue a -> StateValue a -> Bool
$c<= :: forall a. Ord a => StateValue a -> StateValue a -> Bool
<= :: StateValue a -> StateValue a -> Bool
$c> :: forall a. Ord a => StateValue a -> StateValue a -> Bool
> :: StateValue a -> StateValue a -> Bool
$c>= :: forall a. Ord a => StateValue a -> StateValue a -> Bool
>= :: StateValue a -> StateValue a -> Bool
$cmax :: forall a. Ord a => StateValue a -> StateValue a -> StateValue a
max :: StateValue a -> StateValue a -> StateValue a
$cmin :: forall a. Ord a => StateValue a -> StateValue a -> StateValue a
min :: StateValue a -> StateValue a -> StateValue a
Ord, Int -> StateValue a -> ShowS
[StateValue a] -> ShowS
StateValue a -> String
(Int -> StateValue a -> ShowS)
-> (StateValue a -> String)
-> ([StateValue a] -> ShowS)
-> Show (StateValue a)
forall a. Show a => Int -> StateValue a -> ShowS
forall a. Show a => [StateValue a] -> ShowS
forall a. Show a => StateValue a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> StateValue a -> ShowS
showsPrec :: Int -> StateValue a -> ShowS
$cshow :: forall a. Show a => StateValue a -> String
show :: StateValue a -> String
$cshowList :: forall a. Show a => [StateValue a] -> ShowS
showList :: [StateValue a] -> ShowS
Show, ReadPrec [StateValue a]
ReadPrec (StateValue a)
Int -> ReadS (StateValue a)
ReadS [StateValue a]
(Int -> ReadS (StateValue a))
-> ReadS [StateValue a]
-> ReadPrec (StateValue a)
-> ReadPrec [StateValue a]
-> Read (StateValue a)
forall a. Read a => ReadPrec [StateValue a]
forall a. Read a => ReadPrec (StateValue a)
forall a. Read a => Int -> ReadS (StateValue a)
forall a. Read a => ReadS [StateValue a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (StateValue a)
readsPrec :: Int -> ReadS (StateValue a)
$creadList :: forall a. Read a => ReadS [StateValue a]
readList :: ReadS [StateValue a]
$creadPrec :: forall a. Read a => ReadPrec (StateValue a)
readPrec :: ReadPrec (StateValue a)
$creadListPrec :: forall a. Read a => ReadPrec [StateValue a]
readListPrec :: ReadPrec [StateValue a]
Read)

-- | The path of clusters that must be traversed to reach this spot.
type Path = Seq (Maybe GraphID)

modifyGlobal   :: (SAttrs -> SAttrs) -> GVState s ()
modifyGlobal :: forall s. (SAttrs -> SAttrs) -> GVState s ()
modifyGlobal SAttrs -> SAttrs
f = (StateValue s -> StateValue s) -> StateT (StateValue s) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify StateValue s -> StateValue s
forall {a}. StateValue a -> StateValue a
f'
  where
    f' :: StateValue a -> StateValue a
f' sv :: StateValue a
sv@(SV{globalAttrs :: forall a. StateValue a -> SAttrs
globalAttrs = SAttrs
gas}) = StateValue a
sv{globalAttrs = f gas}

modifyValue   :: (s -> s) -> GVState s ()
modifyValue :: forall s. (s -> s) -> GVState s ()
modifyValue s -> s
f = (StateValue s -> StateValue s) -> StateT (StateValue s) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify StateValue s -> StateValue s
f'
  where
    f' :: StateValue s -> StateValue s
f' sv :: StateValue s
sv@(SV{value :: forall a. StateValue a -> a
value = s
s}) = StateValue s
sv{value = f s}

addGlobals    :: Attributes -> GVState s ()
addGlobals :: forall s. Attributes -> GVState s ()
addGlobals Attributes
as = do Bool
addG <- (StateValue s -> Bool) -> StateT (StateValue s) Identity Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StateValue s -> Bool
forall a. StateValue a -> Bool
useGlobals
                   Bool -> GVState s () -> GVState s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
addG (GVState s () -> GVState s ()) -> GVState s () -> GVState s ()
forall a b. (a -> b) -> a -> b
$ (SAttrs -> SAttrs) -> GVState s ()
forall s. (SAttrs -> SAttrs) -> GVState s ()
modifyGlobal (SAttrs -> Attributes -> SAttrs
`unionWith` Attributes
as)

getGlobals :: GVState s SAttrs
getGlobals :: forall s. GVState s SAttrs
getGlobals = (StateValue s -> SAttrs) -> StateT (StateValue s) Identity SAttrs
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StateValue s -> SAttrs
forall a. StateValue a -> SAttrs
globalAttrs

getPath :: GVState s Path
getPath :: forall s. GVState s Path
getPath = (StateValue s -> Path) -> StateT (StateValue s) Identity Path
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets StateValue s -> Path
forall a. StateValue a -> Path
globalPath

modifyPath   :: (Path -> Path) -> GVState s ()
modifyPath :: forall s. (Path -> Path) -> GVState s ()
modifyPath Path -> Path
f = (StateValue s -> StateValue s) -> StateT (StateValue s) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify StateValue s -> StateValue s
forall {a}. StateValue a -> StateValue a
f'
  where
    f' :: StateValue a -> StateValue a
f' sv :: StateValue a
sv@(SV{globalPath :: forall a. StateValue a -> Path
globalPath = Path
p}) = StateValue a
sv{globalPath = f p}

-- When calling recursively, back-up and restore the global attrs
-- since they shouldn't change.
--
-- Outer Maybe: Nothing for subgraphs, Just for clusters
recursiveCall      :: Maybe (Maybe GraphID) -> GVState s () -> GVState s ()
recursiveCall :: forall s. Maybe (Maybe GraphID) -> GVState s () -> GVState s ()
recursiveCall Maybe (Maybe GraphID)
mc GVState s ()
s = do SAttrs
gas <- GVState s SAttrs
forall s. GVState s SAttrs
getGlobals
                        Path
p   <- GVState s Path
forall s. GVState s Path
getPath
                        GVState s ()
-> (Maybe GraphID -> GVState s ())
-> Maybe (Maybe GraphID)
-> GVState s ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> GVState s ()
forall a. a -> StateT (StateValue s) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((Path -> Path) -> GVState s ()
forall s. (Path -> Path) -> GVState s ()
modifyPath ((Path -> Path) -> GVState s ())
-> (Maybe GraphID -> Path -> Path) -> Maybe GraphID -> GVState s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> Maybe GraphID -> Path) -> Maybe GraphID -> Path -> Path
forall a b c. (a -> b -> c) -> b -> a -> c
flip Path -> Maybe GraphID -> Path
forall a. Seq a -> a -> Seq a
(|>)) Maybe (Maybe GraphID)
mc
                        GVState s ()
s
                        (SAttrs -> SAttrs) -> GVState s ()
forall s. (SAttrs -> SAttrs) -> GVState s ()
modifyGlobal (SAttrs -> SAttrs -> SAttrs
forall a b. a -> b -> a
const SAttrs
gas)
                        (Path -> Path) -> GVState s ()
forall s. (Path -> Path) -> GVState s ()
modifyPath (Path -> Path -> Path
forall a b. a -> b -> a
const Path
p)

unionWith        :: SAttrs -> Attributes -> SAttrs
unionWith :: SAttrs -> Attributes -> SAttrs
unionWith SAttrs
sas Attributes
as = Attributes -> SAttrs
toSAttr Attributes
as SAttrs -> SAttrs -> SAttrs
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` SAttrs
sas

-- -----------------------------------------------------------------------------
-- Dealing with sub-graphs

type GraphState a = GVState ClusterLookup' a

-- | The available information for each cluster; the @['Path']@
--   denotes all locations where that particular cluster is located
--   (more than one location can indicate possible problems).
type ClusterLookup = Map (Maybe GraphID) ([Path], GlobalAttributes)

type ClusterLookup' = Map (Maybe GraphID) ClusterInfo

type ClusterInfo = (DList Path, SAttrs)

getGraphInfo :: GraphState a -> (GlobalAttributes, ClusterLookup)
getGraphInfo :: forall a. GraphState a -> (GlobalAttributes, ClusterLookup)
getGraphInfo = ((SAttrs -> GlobalAttributes
graphGlobal (SAttrs -> GlobalAttributes)
-> (StateValue ClusterLookup' -> SAttrs)
-> StateValue ClusterLookup'
-> GlobalAttributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateValue ClusterLookup' -> SAttrs
forall a. StateValue a -> SAttrs
globalAttrs) (StateValue ClusterLookup' -> GlobalAttributes)
-> (StateValue ClusterLookup' -> ClusterLookup)
-> StateValue ClusterLookup'
-> (GlobalAttributes, ClusterLookup)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (ClusterLookup' -> ClusterLookup
forall {k}.
Map k (DList Path, SAttrs) -> Map k ([Path], GlobalAttributes)
convert (ClusterLookup' -> ClusterLookup)
-> (StateValue ClusterLookup' -> ClusterLookup')
-> StateValue ClusterLookup'
-> ClusterLookup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateValue ClusterLookup' -> ClusterLookup'
forall a. StateValue a -> a
value))
               (StateValue ClusterLookup' -> (GlobalAttributes, ClusterLookup))
-> (GraphState a -> StateValue ClusterLookup')
-> GraphState a
-> (GlobalAttributes, ClusterLookup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GraphState a
-> StateValue ClusterLookup' -> StateValue ClusterLookup'
forall s a. State s a -> s -> s
`execState` StateValue ClusterLookup'
forall {k} {a}. StateValue (Map k a)
initState)
  where
    convert :: Map k (DList Path, SAttrs) -> Map k ([Path], GlobalAttributes)
convert = ((DList Path, SAttrs) -> ([Path], GlobalAttributes))
-> Map k (DList Path, SAttrs) -> Map k ([Path], GlobalAttributes)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (([Path] -> [Path]
uniq ([Path] -> [Path])
-> (DList Path -> [Path]) -> DList Path -> [Path]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DList Path -> [Path]
forall a. DList a -> [a]
DList.toList) (DList Path -> [Path])
-> (SAttrs -> GlobalAttributes)
-> (DList Path, SAttrs)
-> ([Path], GlobalAttributes)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** SAttrs -> GlobalAttributes
toGlobal)
    toGlobal :: SAttrs -> GlobalAttributes
toGlobal = Attributes -> GlobalAttributes
GraphAttrs (Attributes -> GlobalAttributes)
-> (SAttrs -> Attributes) -> SAttrs -> GlobalAttributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attribute -> Bool) -> Attributes -> Attributes
forall a. (a -> Bool) -> [a] -> [a]
filter Attribute -> Bool
usedByClusters (Attributes -> Attributes)
-> (SAttrs -> Attributes) -> SAttrs -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SAttrs -> Attributes
unSame
    graphGlobal :: SAttrs -> GlobalAttributes
graphGlobal = Attributes -> GlobalAttributes
GraphAttrs (Attributes -> GlobalAttributes)
-> (SAttrs -> Attributes) -> SAttrs -> GlobalAttributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attribute -> Bool) -> Attributes -> Attributes
forall a. (a -> Bool) -> [a] -> [a]
filter Attribute -> Bool
usedByGraphs (Attributes -> Attributes)
-> (SAttrs -> Attributes) -> SAttrs -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SAttrs -> Attributes
unSame
    initState :: StateValue (Map k a)
initState = SAttrs -> Bool -> Path -> Map k a -> StateValue (Map k a)
forall a. SAttrs -> Bool -> Path -> a -> StateValue a
SV SAttrs
forall a. Set a
Set.empty Bool
True Path
forall a. Seq a
Seq.empty Map k a
forall k a. Map k a
Map.empty
    uniq :: [Path] -> [Path]
uniq = Set Path -> [Path]
forall a. Set a -> [a]
Set.toList (Set Path -> [Path]) -> ([Path] -> Set Path) -> [Path] -> [Path]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Path] -> Set Path
forall a. Ord a => [a] -> Set a
Set.fromList

mergeCInfos          :: ClusterInfo -> ClusterInfo -> ClusterInfo
mergeCInfos :: (DList Path, SAttrs)
-> (DList Path, SAttrs) -> (DList Path, SAttrs)
mergeCInfos (DList Path
p1,SAttrs
as1) = DList Path -> DList Path -> DList Path
forall a. DList a -> DList a -> DList a
DList.append DList Path
p1 (DList Path -> DList Path)
-> (SAttrs -> SAttrs)
-> (DList Path, SAttrs)
-> (DList Path, SAttrs)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** SAttrs -> SAttrs -> SAttrs
forall a. Ord a => Set a -> Set a -> Set a
Set.union SAttrs
as1

addCluster                 :: Maybe (Maybe GraphID) -> Path -> SAttrs
                              -> GraphState ()
addCluster :: Maybe (Maybe GraphID) -> Path -> SAttrs -> GraphState ()
addCluster Maybe (Maybe GraphID)
Nothing    Path
_ SAttrs
_  = () -> GraphState ()
forall a. a -> StateT (StateValue ClusterLookup') Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
addCluster (Just Maybe GraphID
gid) Path
p SAttrs
as = (ClusterLookup' -> ClusterLookup') -> GraphState ()
forall s. (s -> s) -> GVState s ()
modifyValue ((ClusterLookup' -> ClusterLookup') -> GraphState ())
-> (ClusterLookup' -> ClusterLookup') -> GraphState ()
forall a b. (a -> b) -> a -> b
$ ((DList Path, SAttrs)
 -> (DList Path, SAttrs) -> (DList Path, SAttrs))
-> Maybe GraphID
-> (DList Path, SAttrs)
-> ClusterLookup'
-> ClusterLookup'
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (DList Path, SAttrs)
-> (DList Path, SAttrs) -> (DList Path, SAttrs)
mergeCInfos Maybe GraphID
gid (DList Path, SAttrs)
ci
  where
    ci :: (DList Path, SAttrs)
ci = (Path -> DList Path
forall a. a -> DList a
DList.singleton Path
p, SAttrs
as)

-- Use this instead of recursiveCall
addSubGraph           :: Maybe (Maybe GraphID) -> GraphState a -> GraphState ()
addSubGraph :: forall a. Maybe (Maybe GraphID) -> GraphState a -> GraphState ()
addSubGraph Maybe (Maybe GraphID)
mid GraphState a
cntns = do Path
pth <- GVState ClusterLookup' Path
forall s. GVState s Path
getPath -- Want path before we add it...
                           Maybe (Maybe GraphID) -> GraphState () -> GraphState ()
forall s. Maybe (Maybe GraphID) -> GVState s () -> GVState s ()
recursiveCall Maybe (Maybe GraphID)
mid (GraphState () -> GraphState ()) -> GraphState () -> GraphState ()
forall a b. (a -> b) -> a -> b
$ do GraphState a
cntns
                                                  -- But want attrs after we
                                                  -- finish it.
                                                  SAttrs
gas <- GVState ClusterLookup' SAttrs
forall s. GVState s SAttrs
getGlobals
                                                  Maybe (Maybe GraphID) -> Path -> SAttrs -> GraphState ()
addCluster Maybe (Maybe GraphID)
mid Path
pth SAttrs
gas

addGraphGlobals                 :: GlobalAttributes -> GraphState ()
addGraphGlobals :: GlobalAttributes -> GraphState ()
addGraphGlobals (GraphAttrs Attributes
as) = Attributes -> GraphState ()
forall s. Attributes -> GVState s ()
addGlobals Attributes
as
addGraphGlobals GlobalAttributes
_               = () -> GraphState ()
forall a. a -> StateT (StateValue ClusterLookup') Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- -----------------------------------------------------------------------------
-- Dealing with DotNodes

-- | The available information on each 'DotNode' (both explicit and implicit).
type NodeLookup n = Map n (Path, Attributes)

type NodeLookup' n = Map n NodeInfo

data NodeInfo = NI { NodeInfo -> SAttrs
atts     :: SAttrs
                   , NodeInfo -> SAttrs
gAtts    :: SAttrs -- from globals
                   , NodeInfo -> Path
location :: Path
                   }
              deriving (NodeInfo -> NodeInfo -> Bool
(NodeInfo -> NodeInfo -> Bool)
-> (NodeInfo -> NodeInfo -> Bool) -> Eq NodeInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NodeInfo -> NodeInfo -> Bool
== :: NodeInfo -> NodeInfo -> Bool
$c/= :: NodeInfo -> NodeInfo -> Bool
/= :: NodeInfo -> NodeInfo -> Bool
Eq, Eq NodeInfo
Eq NodeInfo =>
(NodeInfo -> NodeInfo -> Ordering)
-> (NodeInfo -> NodeInfo -> Bool)
-> (NodeInfo -> NodeInfo -> Bool)
-> (NodeInfo -> NodeInfo -> Bool)
-> (NodeInfo -> NodeInfo -> Bool)
-> (NodeInfo -> NodeInfo -> NodeInfo)
-> (NodeInfo -> NodeInfo -> NodeInfo)
-> Ord NodeInfo
NodeInfo -> NodeInfo -> Bool
NodeInfo -> NodeInfo -> Ordering
NodeInfo -> NodeInfo -> NodeInfo
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
$ccompare :: NodeInfo -> NodeInfo -> Ordering
compare :: NodeInfo -> NodeInfo -> Ordering
$c< :: NodeInfo -> NodeInfo -> Bool
< :: NodeInfo -> NodeInfo -> Bool
$c<= :: NodeInfo -> NodeInfo -> Bool
<= :: NodeInfo -> NodeInfo -> Bool
$c> :: NodeInfo -> NodeInfo -> Bool
> :: NodeInfo -> NodeInfo -> Bool
$c>= :: NodeInfo -> NodeInfo -> Bool
>= :: NodeInfo -> NodeInfo -> Bool
$cmax :: NodeInfo -> NodeInfo -> NodeInfo
max :: NodeInfo -> NodeInfo -> NodeInfo
$cmin :: NodeInfo -> NodeInfo -> NodeInfo
min :: NodeInfo -> NodeInfo -> NodeInfo
Ord, Int -> NodeInfo -> ShowS
[NodeInfo] -> ShowS
NodeInfo -> String
(Int -> NodeInfo -> ShowS)
-> (NodeInfo -> String) -> ([NodeInfo] -> ShowS) -> Show NodeInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NodeInfo -> ShowS
showsPrec :: Int -> NodeInfo -> ShowS
$cshow :: NodeInfo -> String
show :: NodeInfo -> String
$cshowList :: [NodeInfo] -> ShowS
showList :: [NodeInfo] -> ShowS
Show, ReadPrec [NodeInfo]
ReadPrec NodeInfo
Int -> ReadS NodeInfo
ReadS [NodeInfo]
(Int -> ReadS NodeInfo)
-> ReadS [NodeInfo]
-> ReadPrec NodeInfo
-> ReadPrec [NodeInfo]
-> Read NodeInfo
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS NodeInfo
readsPrec :: Int -> ReadS NodeInfo
$creadList :: ReadS [NodeInfo]
readList :: ReadS [NodeInfo]
$creadPrec :: ReadPrec NodeInfo
readPrec :: ReadPrec NodeInfo
$creadListPrec :: ReadPrec [NodeInfo]
readListPrec :: ReadPrec [NodeInfo]
Read)

type NodeState n a = GVState (NodeLookup' n) a

toDotNodes :: NodeLookup n -> [DotNode n]
toDotNodes :: forall n. NodeLookup n -> [DotNode n]
toDotNodes = ((n, (Path, Attributes)) -> DotNode n)
-> [(n, (Path, Attributes))] -> [DotNode n]
forall a b. (a -> b) -> [a] -> [b]
map (\(n
n,(Path
_,Attributes
as)) -> n -> Attributes -> DotNode n
forall n. n -> Attributes -> DotNode n
DotNode n
n Attributes
as) ([(n, (Path, Attributes))] -> [DotNode n])
-> (NodeLookup n -> [(n, (Path, Attributes))])
-> NodeLookup n
-> [DotNode n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeLookup n -> [(n, (Path, Attributes))]
forall k a. Map k a -> [(k, a)]
Map.assocs

getNodeLookup       :: Bool -> NodeState n a -> NodeLookup n
getNodeLookup :: forall n a. Bool -> NodeState n a -> NodeLookup n
getNodeLookup Bool
addGs = (NodeInfo -> (Path, Attributes))
-> Map n NodeInfo -> Map n (Path, Attributes)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map NodeInfo -> (Path, Attributes)
combine (Map n NodeInfo -> Map n (Path, Attributes))
-> (NodeState n a -> Map n NodeInfo)
-> NodeState n a
-> Map n (Path, Attributes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateValue (Map n NodeInfo) -> Map n NodeInfo
forall a. StateValue a -> a
value (StateValue (Map n NodeInfo) -> Map n NodeInfo)
-> (NodeState n a -> StateValue (Map n NodeInfo))
-> NodeState n a
-> Map n NodeInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeState n a
-> StateValue (Map n NodeInfo) -> StateValue (Map n NodeInfo)
forall s a. State s a -> s -> s
`execState` StateValue (Map n NodeInfo)
forall {k} {a}. StateValue (Map k a)
initState)
  where
    initState :: StateValue (Map k a)
initState = SAttrs -> Bool -> Path -> Map k a -> StateValue (Map k a)
forall a. SAttrs -> Bool -> Path -> a -> StateValue a
SV SAttrs
forall a. Set a
Set.empty Bool
addGs Path
forall a. Seq a
Seq.empty Map k a
forall k a. Map k a
Map.empty
    combine :: NodeInfo -> (Path, Attributes)
combine NodeInfo
ni = (NodeInfo -> Path
location NodeInfo
ni, SAttrs -> Attributes
unSame (SAttrs -> Attributes) -> SAttrs -> Attributes
forall a b. (a -> b) -> a -> b
$ NodeInfo -> SAttrs
atts NodeInfo
ni SAttrs -> SAttrs -> SAttrs
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` NodeInfo -> SAttrs
gAtts NodeInfo
ni)

-- New -> Old -> Inserted
--
-- For specific attributes, newer one takes precedence; for global
-- attributes and path, older one takes precedence.
mergeNInfos :: NodeInfo -> NodeInfo -> NodeInfo
mergeNInfos :: NodeInfo -> NodeInfo -> NodeInfo
mergeNInfos (NI SAttrs
a1 SAttrs
ga1 Path
p1) (NI SAttrs
a2 SAttrs
ga2 Path
p2) = SAttrs -> SAttrs -> Path -> NodeInfo
NI (SAttrs
a1 SAttrs -> SAttrs -> SAttrs
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` SAttrs
a2)
                                                -- old one takes precendence
                                               (SAttrs
ga2 SAttrs -> SAttrs -> SAttrs
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` SAttrs
ga1)
                                                -- old one takes precendence
                                               (Path -> Path -> Path
mergePs Path
p2 Path
p1)

-- | If one 'Path' is a prefix of another, then take the longer one;
--   otherwise, take the first 'Path'.
mergePs :: Path -> Path -> Path
mergePs :: Path -> Path -> Path
mergePs Path
p1 Path
p2 = Path -> Path -> Path
mrg' Path
p1 Path
p2
  where
    mrg' :: Path -> Path -> Path
mrg' = ViewL (Maybe GraphID) -> ViewL (Maybe GraphID) -> Path
mrg (ViewL (Maybe GraphID) -> ViewL (Maybe GraphID) -> Path)
-> (Path -> ViewL (Maybe GraphID)) -> Path -> Path -> Path
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Path -> ViewL (Maybe GraphID)
forall a. Seq a -> ViewL a
Seq.viewl
    mrg :: ViewL (Maybe GraphID) -> ViewL (Maybe GraphID) -> Path
mrg ViewL (Maybe GraphID)
EmptyL      ViewL (Maybe GraphID)
_           = Path
p2
    mrg ViewL (Maybe GraphID)
_           ViewL (Maybe GraphID)
EmptyL      = Path
p1
    mrg (Maybe GraphID
c1 :< Path
p1') (Maybe GraphID
c2 :< Path
p2')
      | Maybe GraphID
c1 Maybe GraphID -> Maybe GraphID -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe GraphID
c2                = Path -> Path -> Path
mrg' Path
p1' Path
p2'
      | Bool
otherwise               = Path
p1

addNodeGlobals                :: GlobalAttributes -> NodeState n ()
addNodeGlobals :: forall n. GlobalAttributes -> NodeState n ()
addNodeGlobals (NodeAttrs Attributes
as) = Attributes -> GVState (NodeLookup' n) ()
forall s. Attributes -> GVState s ()
addGlobals Attributes
as
addNodeGlobals GlobalAttributes
_              = () -> GVState (NodeLookup' n) ()
forall a. a -> StateT (StateValue (NodeLookup' n)) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

mergeNode            :: (Ord n) => n -> Attributes -> SAttrs -> Path
                        -> NodeState n ()
mergeNode :: forall n.
Ord n =>
n -> Attributes -> SAttrs -> Path -> NodeState n ()
mergeNode n
n Attributes
as SAttrs
gas Path
p = (NodeLookup' n -> NodeLookup' n) -> GVState (NodeLookup' n) ()
forall s. (s -> s) -> GVState s ()
modifyValue ((NodeLookup' n -> NodeLookup' n) -> GVState (NodeLookup' n) ())
-> (NodeLookup' n -> NodeLookup' n) -> GVState (NodeLookup' n) ()
forall a b. (a -> b) -> a -> b
$ (NodeInfo -> NodeInfo -> NodeInfo)
-> n -> NodeInfo -> NodeLookup' n -> NodeLookup' n
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith NodeInfo -> NodeInfo -> NodeInfo
mergeNInfos n
n NodeInfo
ni
  where
    ni :: NodeInfo
ni = SAttrs -> SAttrs -> Path -> NodeInfo
NI (Attributes -> SAttrs
toSAttr Attributes
as) SAttrs
gas Path
p

addNode                :: (Ord n) => DotNode n -> NodeState n ()
addNode :: forall n. Ord n => DotNode n -> NodeState n ()
addNode (DotNode n
n Attributes
as) = do SAttrs
gas <- GVState (NodeLookup' n) SAttrs
forall s. GVState s SAttrs
getGlobals
                            Path
p <- GVState (NodeLookup' n) Path
forall s. GVState s Path
getPath
                            -- insertWith takes func (new -> old -> inserted)
                            n -> Attributes -> SAttrs -> Path -> NodeState n ()
forall n.
Ord n =>
n -> Attributes -> SAttrs -> Path -> NodeState n ()
mergeNode n
n Attributes
as SAttrs
gas Path
p

addEdgeNodes :: (Ord n) => DotEdge n -> NodeState n ()
addEdgeNodes :: forall n. Ord n => DotEdge n -> NodeState n ()
addEdgeNodes (DotEdge n
f n
t Attributes
_) = do SAttrs
gas <- GVState (NodeLookup' n) SAttrs
forall s. GVState s SAttrs
getGlobals
                                  Path
p <- GVState (NodeLookup' n) Path
forall s. GVState s Path
getPath
                                  n -> SAttrs -> Path -> NodeState n ()
forall {n}. Ord n => n -> SAttrs -> Path -> NodeState n ()
addEN n
f SAttrs
gas Path
p
                                  n -> SAttrs -> Path -> NodeState n ()
forall {n}. Ord n => n -> SAttrs -> Path -> NodeState n ()
addEN n
t SAttrs
gas Path
p
  where
    addEN :: n -> SAttrs -> Path -> NodeState n ()
addEN n
n = n -> Attributes -> SAttrs -> Path -> NodeState n ()
forall n.
Ord n =>
n -> Attributes -> SAttrs -> Path -> NodeState n ()
mergeNode n
n []

-- -----------------------------------------------------------------------------
-- Dealing with DotEdges

type EdgeState n a = GVState (DList (DotEdge n)) a

getDotEdges       :: Bool -> EdgeState n a -> [DotEdge n]
getDotEdges :: forall n a. Bool -> EdgeState n a -> [DotEdge n]
getDotEdges Bool
addGs = DList (DotEdge n) -> [DotEdge n]
forall a. DList a -> [a]
DList.toList (DList (DotEdge n) -> [DotEdge n])
-> (EdgeState n a -> DList (DotEdge n))
-> EdgeState n a
-> [DotEdge n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateValue (DList (DotEdge n)) -> DList (DotEdge n)
forall a. StateValue a -> a
value (StateValue (DList (DotEdge n)) -> DList (DotEdge n))
-> (EdgeState n a -> StateValue (DList (DotEdge n)))
-> EdgeState n a
-> DList (DotEdge n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EdgeState n a
-> StateValue (DList (DotEdge n)) -> StateValue (DList (DotEdge n))
forall s a. State s a -> s -> s
`execState` StateValue (DList (DotEdge n))
forall {a}. StateValue (DList a)
initState)
  where
    initState :: StateValue (DList a)
initState = SAttrs -> Bool -> Path -> DList a -> StateValue (DList a)
forall a. SAttrs -> Bool -> Path -> a -> StateValue a
SV SAttrs
forall a. Set a
Set.empty Bool
addGs Path
forall a. Seq a
Seq.empty DList a
forall a. DList a
DList.empty

addEdgeGlobals                :: GlobalAttributes -> EdgeState n ()
addEdgeGlobals :: forall n. GlobalAttributes -> EdgeState n ()
addEdgeGlobals (EdgeAttrs Attributes
as) = Attributes -> GVState (DList (DotEdge n)) ()
forall s. Attributes -> GVState s ()
addGlobals Attributes
as
addEdgeGlobals GlobalAttributes
_              = () -> GVState (DList (DotEdge n)) ()
forall a. a -> StateT (StateValue (DList (DotEdge n))) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

addEdge :: DotEdge n -> EdgeState n ()
addEdge :: forall n. DotEdge n -> EdgeState n ()
addEdge de :: DotEdge n
de@DotEdge{edgeAttributes :: forall n. DotEdge n -> Attributes
edgeAttributes = Attributes
as}
  = do SAttrs
gas <- GVState (DList (DotEdge n)) SAttrs
forall s. GVState s SAttrs
getGlobals
       let de' :: DotEdge n
de' = DotEdge n
de { edgeAttributes = unSame $ unionWith gas as }
       (DList (DotEdge n) -> DList (DotEdge n)) -> EdgeState n ()
forall s. (s -> s) -> GVState s ()
modifyValue ((DList (DotEdge n) -> DList (DotEdge n)) -> EdgeState n ())
-> (DList (DotEdge n) -> DList (DotEdge n)) -> EdgeState n ()
forall a b. (a -> b) -> a -> b
$ (DList (DotEdge n) -> DotEdge n -> DList (DotEdge n)
forall a. DList a -> a -> DList a
`DList.snoc` DotEdge n
de')