{-# LANGUAGE ScopedTypeVariables #-}-- | This module, given a changing source of 'PureGraph's, transforms it into-- a 'Graph'. -}moduleGraphs.PureGraphToGraph(pureGraphToGraph,)whereimportData.ListimportqualifiedData.MapasMapimportData.IORefimportUtil.Computation(done)importUtil.SourcesimportUtil.SinkimportUtil.AtomStringimportUtil.ExtendedPreludeimportGraphs.GraphimportGraphs.NewNamesimportGraphs.PureGraph-- -------------------------------------------------------------------------- Data types-- ------------------------------------------------------------------------dataStatenodeKeynodeInfoarcInfo=State{nameSource::NameSource,-- ^ source of new namespureGraph::PureGraph(nodeKey,Node)(arcInfo,Arc),-- ^ current annotated graphtoNodeInfo::nodeKey->nodeInfo-- ^ current node info}-- -------------------------------------------------------------------------- Functions-- ------------------------------------------------------------------------pureGraphToGraph::(OrdnodeKey,OrdarcInfo,EqnodeInfo)=>SimpleSource(PureGraphnodeKeyarcInfo,nodeKey->nodeInfo)->GraphConnectionnodeInfo()arcInfo()pureGraphToGraph(simpleSource::SimpleSource(PureGraphnodeKeyarcInfo,nodeKey->nodeInfo))=letsource1::Source(PureGraphnodeKeyarcInfo,nodeKey->nodeInfo)(PureGraphnodeKeyarcInfo,nodeKey->nodeInfo)source1=toSourcesimpleSourcesource2::Source(StatenodeKeynodeInfoarcInfo,CannedGraphnodeInfo()arcInfo())[UpdatenodeInfo()arcInfo()]source2=foldSourceIOgetStateFnfoldStateFnsource1source3::Source(StatenodeKeynodeInfoarcInfo,CannedGraphnodeInfo()arcInfo())(UpdatenodeInfo()arcInfo())source3=map2MultiUpdatesource2addConnectiondoUpdate=do((state,cannedGraph),sink)<-addNewSinksource3doUpdatenameSourceBranch<-branch(nameSourcestate)letgraphConnectionData=GraphConnectionData{graphState=cannedGraph,deRegister=invalidatesink,graphUpdate=(\update->done),-- updates from the client are ignorednameSourceBranch=nameSourceBranch}returngraphConnectionDatainaddConnectiongetStateFn::(OrdnodeKey,OrdarcInfo,EqnodeInfo)=>(PureGraphnodeKeyarcInfo,nodeKey->nodeInfo)->IO(StatenodeKeynodeInfoarcInfo,CannedGraphnodeInfo()arcInfo())getStateFn(pureGraph0,toNodeInfo0)=donameSource<-useBranchinitialBranch(pureGraph1,updates0)<-modifyPureGraphnameSourceemptyPureGraphpureGraph0(error"PureGraphToGraph: no old nodes")toNodeInfo0letstate=State{nameSource=nameSource,pureGraph=pureGraph1,toNodeInfo=toNodeInfo0}updates1=typeUpdates++updates0cannedGraph=CannedGraph{updates=updates1}return(state,cannedGraph)foldStateFn::(OrdnodeKey,OrdarcInfo,EqnodeInfo)=>StatenodeKeynodeInfoarcInfo->(PureGraphnodeKeyarcInfo,nodeKey->nodeInfo)->IO(StatenodeKeynodeInfoarcInfo,[UpdatenodeInfo()arcInfo()])foldStateFnstate(pureGraph0,toNodeInfo1)=do(pureGraph1,updates)<-modifyPureGraph(nameSourcestate)(pureGraphstate)pureGraph0(toNodeInfostate)toNodeInfo1return(state{pureGraph=pureGraph1,toNodeInfo=toNodeInfo1},updates)modifyPureGraph::(OrdnodeKey,OrdarcInfo,EqnodeInfo)=>NameSource-- ^ How we generate new Node and Arc values->PureGraph(nodeKey,Node)(arcInfo,Arc)-- ^ the old graph, annotated with corresponding node and arc values->PureGraphnodeKeyarcInfo-- ^ the new graph->(nodeKey->nodeInfo)-- ^ old toNodeInfo function->(nodeKey->nodeInfo)-- ^ new toNodeInfo function->IO(PureGraph(nodeKey,Node)(arcInfo,Arc),[UpdatenodeInfo()arcInfo()])-- ^ the new annotated graph, and the changes to get to it.modifyPureGraphnameSource(pg@(PureGrapholdFM0::PureGraph(nodeKey,Node)(arcInfo,Arc)))(PureGraphnewFM0::PureGraphnodeKeyarcInfo)(oldToNodeInfo::nodeKey->nodeInfo)(toNodeInfo::nodeKey->nodeInfo)=do-- Node-generating mechanism. We generate nodes dynamically as we-- look them up.(nodeIORef::IORef(Map.MapnodeKeyNode))<-newIORefMap.emptyletlookupNode::nodeKey->IONodelookupNodenodeKey=caselookupPureNodepgnodeKeyofJustnode->returnnodeNothing->dofm<-readIORefnodeIORefcaseMap.lookupnodeKeyfmofJustnode->returnnodeNothing->donodeStr<-getNewNamenameSourceletnode=fromStringnodeStrwriteIORefnodeIORef(Map.insertnodeKeynodefm)returnnodeoldFM0List::[((nodeKey,Node),NodeData(nodeKey,Node)(arcInfo,Arc))]oldFM0List=Map.toListoldFM0newFM0List::[(nodeKey,NodeDatanodeKeyarcInfo)]newFM0List=Map.toListnewFM0-- type arguments for generalisedMerge-- a :: ((nodeKey,Node),NodeData (nodeKey,Node)-- (arcInfo,Arc))-- b :: (nodeKey,NodeData nodeKey arcInfo)-- c :: [Update nodeInfo () arcInfo ()]toKey1::((nodeKey,Node),NodeData(nodeKey,Node)(arcInfo,Arc))->nodeKeytoKey1=fst.fsttoKey2::(nodeKey,NodeDatanodeKeyarcInfo)->nodeKeytoKey2=fstcompareFnab=compare(toKey1a)(toKey2b)mergeFn::Maybe((nodeKey,Node),NodeData(nodeKey,Node)(arcInfo,Arc))->Maybe(nodeKey,NodeDatanodeKeyarcInfo)->IO(Maybe((nodeKey,Node),NodeData(nodeKey,Node)(arcInfo,Arc)),Maybe[UpdatenodeInfo()arcInfo()])mergeFn(Just((nodeKey,node),nodeData))Nothing=-- this node must be deleteddoletupdate1=DeleteNodenode([],updates)<-modifyArcs(parentsnodeData)[]nodenameSourcelookupNodereturn(Nothing,Just(update1:updates))mergeFnNothing(Just(nodeKey,nodeData))=-- this node must be addeddonode<-lookupNodenodeKeyletnodeInfo=toNodeInfonodeKeyupdate1=NewNodenodetheNodeTypenodeInfo(arcDatas,updates)<-modifyArcs[](parentsnodeData)nodenameSourcelookupNodereturn(Just((nodeKey,node),NodeData{parents=arcDatas}),Just(update1:updates))mergeFn(Just(nn@(nodeKey1,node),nodeData1))(Just(nodeKey2,nodeData2))=-- node needs to be neither added nor deleted, but the NodeData-- might have changed and we might need to change the nodeDatado(arcDatas,updates1)<-modifyArcs(parentsnodeData1)(parentsnodeData2)nodenameSourcelookupNodeletnodeInfo1=oldToNodeInfonodeKey1nodeInfo2=toNodeInfonodeKey2updates2=ifnodeInfo1==nodeInfo2then[]else[SetNodeLabelnodenodeInfo2]updates=updates1++updates2return(Just(nn,NodeData{parents=arcDatas}),Justupdates)(newFM1List,updatess0)<-generalisedMergeoldFM0ListnewFM0ListcompareFnmergeFn-- To make the updates consistent, sort them into the order-- (delete arcs) (delete nodes) (add nodes) (set node labels) (add arcs)letpg1=PureGraph(Map.fromListnewFM1List)updates0=concatupdatess0updates1=[update|(update@(DeleteArc_))<-updates0]++[update|(update@(DeleteNode_))<-updates0]++[update|(update@(NewNode___))<-updates0]++[update|(update@(NewArc_____))<-updates0]++[update|(update@(SetNodeLabel__))<-updates0]return(pg1,updates1)lookupPureNode::OrdnodeKey=>PureGraph(nodeKey,Node)(arcInfo,arc)->nodeKey->MaybeNodelookupPureNode(PureGraphfm)nodeKey0=casefilter(\((nodeKey1,_),_)->nodeKey1==nodeKey0)$Map.toListfmof((_,node),_):_->Justnode_->NothingmodifyArcs::(OrdnodeKey,OrdarcInfo)-- Invariant. fromArcs should only be generated by modifyArcs or-- else []. This means we can assume it is sorted.=>[ArcData(nodeKey,Node)(arcInfo,Arc)]->[ArcDatanodeKeyarcInfo]->Node->NameSource->(nodeKey->IONode)->IO([ArcData(nodeKey,Node)(arcInfo,Arc)],[UpdatenodeInfo()arcInfo()])modifyArcs(fromArcs::[ArcData(nodeKey,Node)(arcInfo,Arc)])ontoArcs0sourceNodenameSourcelookupNode=lettoKey::ArcData(nodeKey,Node)(arcInfo,Arc)->ArcDatanodeKeyarcInfotoKeyarcData0=ArcData{arcInfo=fst.arcInfo$arcData0,target=fst.target$arcData0}-- (1) sort ontoArcs. (fromArcs should already be sorted)ontoArcs1=sortontoArcs0-- (2) define functions for generalisedMergecompareFn::ArcData(nodeKey,Node)(arcInfo,Arc)->ArcDatanodeKeyarcInfo->OrderingcompareFnarc1arc2=compare(toKeyarc1)arc2mergeFn::Maybe(ArcData(nodeKey,Node)(arcInfo,Arc))->Maybe(ArcDatanodeKeyarcInfo)->IO(Maybe(ArcData(nodeKey,Node)(arcInfo,Arc)),Maybe(UpdatenodeInfo()arcInfo()))mergeFn(JustarcData)Nothing=return(Nothing,Just(DeleteArc(snd.arcInfo$arcData)))mergeFnNothing(JustarcData0)=doarcStr<-getNewNamenameSourceletarc::Arcarc=fromStringarcStr(targetNode::Node)<-lookupNode(targetarcData0)letarcInfo1=arcInfoarcData0arcData1=ArcData{arcInfo=(arcInfo1,arc),target=(targetarcData0,targetNode)}return(JustarcData1,Just(NewArcarctheArcTypearcInfo1targetNodesourceNode))mergeFn(JustarcData1)(Just_)=return(JustarcData1,Nothing)ingeneralisedMergefromArcsontoArcs1compareFnmergeFn-- ------------------------------------------------------------------------ Node and Arc types-- We only have one of each.-- ----------------------------------------------------------------------theNodeType::NodeTypetheNodeType=fromString""theArcType::ArcTypetheArcType=fromString""typeUpdates::[UpdatenodeInfo()arcInfo()]typeUpdates=[NewNodeTypetheNodeType(),NewArcTypetheArcType()]