graphviz-2999.20.0.0: Data/GraphViz/Types/State.hs
{-# 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 { globalAttrs :: SAttrs
, useGlobals :: Bool
, globalPath :: Path
, value :: a
}
deriving (Eq, Ord, Show, Read)
-- | The path of clusters that must be traversed to reach this spot.
type Path = Seq (Maybe GraphID)
modifyGlobal :: (SAttrs -> SAttrs) -> GVState s ()
modifyGlobal f = modify f'
where
f' sv@(SV{globalAttrs = gas}) = sv{globalAttrs = f gas}
modifyValue :: (s -> s) -> GVState s ()
modifyValue f = modify f'
where
f' sv@(SV{value = s}) = sv{value = f s}
addGlobals :: Attributes -> GVState s ()
addGlobals as = do addG <- gets useGlobals
when addG $ modifyGlobal (`unionWith` as)
getGlobals :: GVState s SAttrs
getGlobals = gets globalAttrs
getPath :: GVState s Path
getPath = gets globalPath
modifyPath :: (Path -> Path) -> GVState s ()
modifyPath f = modify f'
where
f' sv@(SV{globalPath = p}) = 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 mc s = do gas <- getGlobals
p <- getPath
maybe (return ()) (modifyPath . flip (|>)) mc
s
modifyGlobal (const gas)
modifyPath (const p)
unionWith :: SAttrs -> Attributes -> SAttrs
unionWith sas as = toSAttr as `Set.union` 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 = ((graphGlobal . globalAttrs) &&& (convert . value))
. (`execState` initState)
where
convert = Map.map ((uniq . DList.toList) *** toGlobal)
toGlobal = GraphAttrs . filter usedByClusters . unSame
graphGlobal = GraphAttrs . filter usedByGraphs . unSame
initState = SV Set.empty True Seq.empty Map.empty
uniq = Set.toList . Set.fromList
mergeCInfos :: ClusterInfo -> ClusterInfo -> ClusterInfo
mergeCInfos (p1,as1) = DList.append p1 *** Set.union as1
addCluster :: Maybe (Maybe GraphID) -> Path -> SAttrs
-> GraphState ()
addCluster Nothing _ _ = return ()
addCluster (Just gid) p as = modifyValue $ Map.insertWith mergeCInfos gid ci
where
ci = (DList.singleton p, as)
-- Use this instead of recursiveCall
addSubGraph :: Maybe (Maybe GraphID) -> GraphState a -> GraphState ()
addSubGraph mid cntns = do pth <- getPath -- Want path before we add it...
recursiveCall mid $ do cntns
-- But want attrs after we
-- finish it.
gas <- getGlobals
addCluster mid pth gas
addGraphGlobals :: GlobalAttributes -> GraphState ()
addGraphGlobals (GraphAttrs as) = addGlobals as
addGraphGlobals _ = 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 { atts :: SAttrs
, gAtts :: SAttrs -- from globals
, location :: Path
}
deriving (Eq, Ord, Show, Read)
type NodeState n a = GVState (NodeLookup' n) a
toDotNodes :: NodeLookup n -> [DotNode n]
toDotNodes = map (\(n,(_,as)) -> DotNode n as) . Map.assocs
getNodeLookup :: Bool -> NodeState n a -> NodeLookup n
getNodeLookup addGs = Map.map combine . value . (`execState` initState)
where
initState = SV Set.empty addGs Seq.empty Map.empty
combine ni = (location ni, unSame $ atts ni `Set.union` gAtts 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 (NI a1 ga1 p1) (NI a2 ga2 p2) = NI (a1 `Set.union` a2)
-- old one takes precendence
(ga2 `Set.union` ga1)
-- old one takes precendence
(mergePs p2 p1)
-- | If one 'Path' is a prefix of another, then take the longer one;
-- otherwise, take the first 'Path'.
mergePs :: Path -> Path -> Path
mergePs p1 p2 = mrg' p1 p2
where
mrg' = mrg `on` Seq.viewl
mrg EmptyL _ = p2
mrg _ EmptyL = p1
mrg (c1 :< p1') (c2 :< p2')
| c1 == c2 = mrg' p1' p2'
| otherwise = p1
addNodeGlobals :: GlobalAttributes -> NodeState n ()
addNodeGlobals (NodeAttrs as) = addGlobals as
addNodeGlobals _ = return ()
mergeNode :: (Ord n) => n -> Attributes -> SAttrs -> Path
-> NodeState n ()
mergeNode n as gas p = modifyValue $ Map.insertWith mergeNInfos n ni
where
ni = NI (toSAttr as) gas p
addNode :: (Ord n) => DotNode n -> NodeState n ()
addNode (DotNode n as) = do gas <- getGlobals
p <- getPath
-- insertWith takes func (new -> old -> inserted)
mergeNode n as gas p
addEdgeNodes :: (Ord n) => DotEdge n -> NodeState n ()
addEdgeNodes (DotEdge f t _) = do gas <- getGlobals
p <- getPath
addEN f gas p
addEN t gas p
where
addEN n = mergeNode n []
-- -----------------------------------------------------------------------------
-- Dealing with DotEdges
type EdgeState n a = GVState (DList (DotEdge n)) a
getDotEdges :: Bool -> EdgeState n a -> [DotEdge n]
getDotEdges addGs = DList.toList . value . (`execState` initState)
where
initState = SV Set.empty addGs Seq.empty DList.empty
addEdgeGlobals :: GlobalAttributes -> EdgeState n ()
addEdgeGlobals (EdgeAttrs as) = addGlobals as
addEdgeGlobals _ = return ()
addEdge :: DotEdge n -> EdgeState n ()
addEdge de@DotEdge{edgeAttributes = as}
= do gas <- getGlobals
let de' = de { edgeAttributes = unSame $ unionWith gas as }
modifyValue $ (`DList.snoc` de')