{-# 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.
-}moduleData.GraphViz.Types.State(Path,recursiveCall--,GraphState,ClusterLookup,getGraphInfo,addSubGraph,addGraphGlobals--,NodeState,NodeLookup,getNodeLookup,toDotNodes,addNodeGlobals,addNode,addEdgeNodes--,EdgeState,getDotEdges,addEdgeGlobals,addEdge)whereimportData.GraphViz.Types.CommonimportData.GraphViz.Attributes.Complete(Attributes,usedByClusters,usedByGraphs)importData.GraphViz.Attributes.SameimportData.Function(on)importqualifiedData.DListasDListimportData.DList(DList)importqualifiedData.MapasMapimportData.Map(Map)importqualifiedData.SetasSetimportqualifiedData.SequenceasSeqimportData.Sequence(Seq,(|>),ViewL(..))importControl.Arrow((&&&),(***))importControl.Monad(when)importControl.Monad.Trans.State-- -----------------------------------------------------------------------------typeGVStatesa=State(StateValues)adataStateValuea=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.typePath=Seq(MaybeGraphID)modifyGlobal::(SAttrs->SAttrs)->GVStates()modifyGlobalf=modifyf'wheref'sv@(SV{globalAttrs=gas})=sv{globalAttrs=fgas}modifyValue::(s->s)->GVStates()modifyValuef=modifyf'wheref'sv@(SV{value=s})=sv{value=fs}addGlobals::Attributes->GVStates()addGlobalsas=doaddG<-getsuseGlobalswhenaddG$modifyGlobal(`unionWith`as)getGlobals::GVStatesSAttrsgetGlobals=getsglobalAttrsgetPath::GVStatesPathgetPath=getsglobalPathmodifyPath::(Path->Path)->GVStates()modifyPathf=modifyf'wheref'sv@(SV{globalPath=p})=sv{globalPath=fp}-- When calling recursively, back-up and restore the global attrs-- since they shouldn't change.---- Outer Maybe: Nothing for subgraphs, Just for clustersrecursiveCall::Maybe(MaybeGraphID)->GVStates()->GVStates()recursiveCallmcs=dogas<-getGlobalsp<-getPathmaybe(return())(modifyPath.flip(|>))mcsmodifyGlobal(constgas)modifyPath(constp)unionWith::SAttrs->Attributes->SAttrsunionWithsasas=toSAttras`Set.union`sas-- ------------------------------------------------------------------------------- Dealing with sub-graphstypeGraphStatea=GVStateClusterLookup'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).typeClusterLookup=Map(MaybeGraphID)([Path],GlobalAttributes)typeClusterLookup'=Map(MaybeGraphID)ClusterInfotypeClusterInfo=(DListPath,SAttrs)getGraphInfo::GraphStatea->(GlobalAttributes,ClusterLookup)getGraphInfo=((graphGlobal.globalAttrs)&&&(convert.value)).flipexecStateinitStatewhereconvert=Map.map((uniq.DList.toList)***toGlobal)toGlobal=GraphAttrs.filterusedByClusters.unSamegraphGlobal=GraphAttrs.filterusedByGraphs.unSameinitState=SVSet.emptyTrueSeq.emptyMap.emptyuniq=Set.toList.Set.fromListmergeCInfos::ClusterInfo->ClusterInfo->ClusterInfomergeCInfos(p1,as1)=DList.appendp1***Set.unionas1addCluster::Maybe(MaybeGraphID)->Path->SAttrs->GraphState()addClusterNothing__=return()addCluster(Justgid)pas=modifyValue$Map.insertWithmergeCInfosgidciwhereci=(DList.singletonp,as)-- Use this instead of recursiveCalladdSubGraph::Maybe(MaybeGraphID)->GraphStatea->GraphState()addSubGraphmidcntns=dopth<-getPath-- Want path before we add it...recursiveCallmid$docntns-- But want attrs after we-- finish it.gas<-getGlobalsaddClustermidpthgasaddGraphGlobals::GlobalAttributes->GraphState()addGraphGlobals(GraphAttrsas)=addGlobalsasaddGraphGlobals_=return()-- ------------------------------------------------------------------------------- Dealing with DotNodes-- | The available information on each 'DotNode' (both explicit and implicit).typeNodeLookupn=Mapn(Path,Attributes)typeNodeLookup'n=MapnNodeInfodataNodeInfo=NI{atts::SAttrs,gAtts::SAttrs-- from globals,location::Path}deriving(Eq,Ord,Show,Read)typeNodeStatena=GVState(NodeLookup'n)atoDotNodes::(Ordn)=>NodeLookupn->[DotNoden]toDotNodes=map(\(n,(_,as))->DotNodenas).Map.assocsgetNodeLookup::(Ordn)=>Bool->NodeStatena->NodeLookupngetNodeLookupaddGs=Map.mapcombine.value.flipexecStateinitStatewhereinitState=SVSet.emptyaddGsSeq.emptyMap.emptycombineni=(locationni,unSame$attsni`Set.union`gAttsni)-- New -> Old -> Inserted---- For specific attributes, newer one takes precedence; for global-- attributes and path, older one takes precedence.mergeNInfos::NodeInfo->NodeInfo->NodeInfomergeNInfos(NIa1ga1p1)(NIa2ga2p2)=NI(a1`Set.union`a2)-- old one takes precendence(ga2`Set.union`ga1)-- old one takes precendence(mergePsp2p1)-- | If one 'Path' is a prefix of another, then take the longer one;-- otherwise, take the first 'Path'.mergePs::Path->Path->PathmergePsp1p2=mrg'p1p2wheremrg'=mrg`on`Seq.viewlmrgEmptyL_=p2mrg_EmptyL=p1mrg(c1:<p1')(c2:<p2')|c1==c2=mrg'p1'p2'|otherwise=p1addNodeGlobals::GlobalAttributes->NodeStaten()addNodeGlobals(NodeAttrsas)=addGlobalsasaddNodeGlobals_=return()mergeNode::(Ordn)=>n->Attributes->SAttrs->Path->NodeStaten()mergeNodenasgasp=modifyValue$Map.insertWithmergeNInfosnniwhereni=NI(toSAttras)gaspaddNode::(Ordn)=>DotNoden->NodeStaten()addNode(DotNodenas)=dogas<-getGlobalsp<-getPath-- insertWith takes func (new -> old -> inserted)mergeNodenasgaspaddEdgeNodes::(Ordn)=>DotEdgen->NodeStaten()addEdgeNodes(DotEdgeft_)=dogas<-getGlobalsp<-getPathaddENfgaspaddENtgaspwhereaddENn=mergeNoden[]-- ------------------------------------------------------------------------------- Dealing with DotEdgestypeEdgeStatena=GVState(DList(DotEdgen))agetDotEdges::Bool->EdgeStatena->[DotEdgen]getDotEdgesaddGs=DList.toList.value.flipexecStateinitStatewhereinitState=SVSet.emptyaddGsSeq.emptyDList.emptyaddEdgeGlobals::GlobalAttributes->EdgeStaten()addEdgeGlobals(EdgeAttrsas)=addGlobalsasaddEdgeGlobals_=return()addEdge::DotEdgen->EdgeStaten()addEdgede@DotEdge{edgeAttributes=as}=dogas<-getGlobalsletde'=de{edgeAttributes=unSame$unionWithgasas}modifyValue$flipDList.snocde'