{-# LANGUAGE ScopedTypeVariables #-} -- | This module, given a changing source of 'PureGraph's, transforms it into -- a 'Graph'. -} module Graphs.PureGraphToGraph( pureGraphToGraph, ) where import Data.List import qualified Data.Map as Map import Data.IORef import Util.Computation(done) import Util.Sources import Util.Sink import Util.AtomString import Util.ExtendedPrelude import Graphs.Graph import Graphs.NewNames import Graphs.PureGraph -- ------------------------------------------------------------------------ -- Data types -- ------------------------------------------------------------------------ data State nodeKey nodeInfo arcInfo = State { nameSource :: NameSource, -- ^ source of new names pureGraph :: PureGraph (nodeKey,Node) (arcInfo,Arc), -- ^ current annotated graph toNodeInfo :: nodeKey -> nodeInfo -- ^ current node info } -- ------------------------------------------------------------------------ -- Functions -- ------------------------------------------------------------------------ pureGraphToGraph :: (Ord nodeKey,Ord arcInfo,Eq nodeInfo) => SimpleSource (PureGraph nodeKey arcInfo,nodeKey -> nodeInfo) -> GraphConnection nodeInfo () arcInfo () pureGraphToGraph (simpleSource :: SimpleSource (PureGraph nodeKey arcInfo,nodeKey -> nodeInfo)) = let source1 :: Source (PureGraph nodeKey arcInfo,nodeKey -> nodeInfo) (PureGraph nodeKey arcInfo,nodeKey -> nodeInfo) source1 = toSource simpleSource source2 :: Source (State nodeKey nodeInfo arcInfo, CannedGraph nodeInfo () arcInfo ()) [Update nodeInfo () arcInfo ()] source2 = foldSourceIO getStateFn foldStateFn source1 source3 :: Source (State nodeKey nodeInfo arcInfo, CannedGraph nodeInfo () arcInfo ()) (Update nodeInfo () arcInfo ()) source3 = map2 MultiUpdate source2 addConnection doUpdate = do ((state,cannedGraph),sink)<- addNewSink source3 doUpdate nameSourceBranch <- branch (nameSource state) let graphConnectionData = GraphConnectionData { graphState = cannedGraph, deRegister = invalidate sink, graphUpdate = (\ update -> done), -- updates from the client are ignored nameSourceBranch = nameSourceBranch } return graphConnectionData in addConnection getStateFn :: (Ord nodeKey,Ord arcInfo,Eq nodeInfo) => (PureGraph nodeKey arcInfo,nodeKey -> nodeInfo) -> IO (State nodeKey nodeInfo arcInfo,CannedGraph nodeInfo () arcInfo ()) getStateFn (pureGraph0,toNodeInfo0) = do nameSource <- useBranch initialBranch (pureGraph1,updates0) <- modifyPureGraph nameSource emptyPureGraph pureGraph0 (error "PureGraphToGraph: no old nodes") toNodeInfo0 let state = State { nameSource = nameSource, pureGraph = pureGraph1, toNodeInfo = toNodeInfo0 } updates1 = typeUpdates ++ updates0 cannedGraph = CannedGraph {updates = updates1} return (state,cannedGraph) foldStateFn :: (Ord nodeKey,Ord arcInfo,Eq nodeInfo) => State nodeKey nodeInfo arcInfo -> (PureGraph nodeKey arcInfo,nodeKey -> nodeInfo) -> IO (State nodeKey nodeInfo arcInfo,[Update nodeInfo () arcInfo ()]) foldStateFn state (pureGraph0,toNodeInfo1) = do (pureGraph1,updates) <- modifyPureGraph (nameSource state) (pureGraph state) pureGraph0 (toNodeInfo state) toNodeInfo1 return (state {pureGraph = pureGraph1,toNodeInfo = toNodeInfo1},updates) modifyPureGraph :: (Ord nodeKey,Ord arcInfo,Eq nodeInfo) => NameSource -- ^ How we generate new Node and Arc values -> PureGraph (nodeKey,Node) (arcInfo,Arc) -- ^ the old graph, annotated with corresponding node and arc values -> PureGraph nodeKey arcInfo -- ^ the new graph -> (nodeKey -> nodeInfo) -- ^ old toNodeInfo function -> (nodeKey -> nodeInfo) -- ^ new toNodeInfo function -> IO (PureGraph (nodeKey,Node) (arcInfo,Arc), [Update nodeInfo () arcInfo ()]) -- ^ the new annotated graph, and the changes to get to it. modifyPureGraph nameSource (pg @ (PureGraph oldFM0 :: PureGraph (nodeKey,Node) (arcInfo,Arc))) (PureGraph newFM0 :: PureGraph nodeKey arcInfo) (oldToNodeInfo :: nodeKey -> nodeInfo) (toNodeInfo :: nodeKey -> nodeInfo) = do -- Node-generating mechanism. We generate nodes dynamically as we -- look them up. (nodeIORef :: IORef (Map.Map nodeKey Node)) <- newIORef Map.empty let lookupNode :: nodeKey -> IO Node lookupNode nodeKey = case lookupPureNode pg nodeKey of Just node -> return node Nothing -> do fm <- readIORef nodeIORef case Map.lookup nodeKey fm of Just node -> return node Nothing -> do nodeStr <- getNewName nameSource let node = fromString nodeStr writeIORef nodeIORef (Map.insert nodeKey node fm) return node oldFM0List :: [((nodeKey,Node), NodeData (nodeKey,Node) (arcInfo,Arc))] oldFM0List = Map.toList oldFM0 newFM0List :: [(nodeKey,NodeData nodeKey arcInfo)] newFM0List = Map.toList newFM0 -- 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)) -> nodeKey toKey1 = fst . fst toKey2 :: (nodeKey,NodeData nodeKey arcInfo) -> nodeKey toKey2 = fst compareFn a b = compare (toKey1 a) (toKey2 b) mergeFn :: Maybe ((nodeKey,Node), NodeData (nodeKey,Node) (arcInfo,Arc)) -> Maybe (nodeKey,NodeData nodeKey arcInfo) -> IO (Maybe ((nodeKey,Node), NodeData (nodeKey,Node) (arcInfo,Arc)),Maybe [Update nodeInfo () arcInfo ()]) mergeFn (Just ((nodeKey,node),nodeData)) Nothing = -- this node must be deleted do let update1 = DeleteNode node ([],updates) <- modifyArcs (parents nodeData) [] node nameSource lookupNode return (Nothing,Just (update1:updates)) mergeFn Nothing (Just (nodeKey,nodeData)) = -- this node must be added do node <- lookupNode nodeKey let nodeInfo = toNodeInfo nodeKey update1 = NewNode node theNodeType nodeInfo (arcDatas,updates) <- modifyArcs [] (parents nodeData) node nameSource lookupNode return (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 nodeData do (arcDatas,updates1) <- modifyArcs (parents nodeData1) (parents nodeData2) node nameSource lookupNode let nodeInfo1 = oldToNodeInfo nodeKey1 nodeInfo2 = toNodeInfo nodeKey2 updates2 = if nodeInfo1 == nodeInfo2 then [] else [SetNodeLabel node nodeInfo2] updates = updates1 ++ updates2 return (Just (nn,NodeData {parents = arcDatas}),Just updates) (newFM1List,updatess0) <- generalisedMerge oldFM0List newFM0List compareFn mergeFn -- To make the updates consistent, sort them into the order -- (delete arcs) (delete nodes) (add nodes) (set node labels) (add arcs) let pg1 = PureGraph (Map.fromList newFM1List) updates0 = concat updatess0 updates1 = [ update | (update @ (DeleteArc _ )) <- updates0 ] ++ [ update | (update @ (DeleteNode _ )) <- updates0 ] ++ [ update | (update @ (NewNode _ _ _ )) <- updates0 ] ++ [ update | (update @ (NewArc _ _ _ _ _ )) <- updates0 ] ++ [ update | (update @ (SetNodeLabel _ _)) <- updates0 ] return (pg1,updates1) lookupPureNode :: Ord nodeKey => PureGraph (nodeKey,Node) (arcInfo,arc) -> nodeKey -> Maybe Node lookupPureNode (PureGraph fm) nodeKey0 = case filter (\ ((nodeKey1, _), _) -> nodeKey1 == nodeKey0) $ Map.toList fm of ((_,node),_) : _ -> Just node _ -> Nothing modifyArcs :: (Ord nodeKey,Ord arcInfo) -- Invariant. fromArcs should only be generated by modifyArcs or -- else []. This means we can assume it is sorted. => [ArcData (nodeKey,Node) (arcInfo,Arc)] -> [ArcData nodeKey arcInfo] -> Node -> NameSource -> (nodeKey -> IO Node) -> IO ([ArcData (nodeKey,Node) (arcInfo,Arc)], [Update nodeInfo () arcInfo ()]) modifyArcs (fromArcs :: [ArcData (nodeKey,Node) (arcInfo,Arc)]) ontoArcs0 sourceNode nameSource lookupNode = let toKey :: ArcData (nodeKey,Node) (arcInfo,Arc) -> ArcData nodeKey arcInfo toKey arcData0 = ArcData { arcInfo = fst . arcInfo $ arcData0, target = fst . target $ arcData0 } -- (1) sort ontoArcs. (fromArcs should already be sorted) ontoArcs1 = sort ontoArcs0 -- (2) define functions for generalisedMerge compareFn :: ArcData (nodeKey,Node) (arcInfo,Arc) -> ArcData nodeKey arcInfo -> Ordering compareFn arc1 arc2 = compare (toKey arc1) arc2 mergeFn :: Maybe (ArcData (nodeKey,Node) (arcInfo,Arc)) -> Maybe (ArcData nodeKey arcInfo) -> IO (Maybe (ArcData (nodeKey,Node) (arcInfo,Arc)), Maybe (Update nodeInfo () arcInfo ())) mergeFn (Just arcData) Nothing = return (Nothing,Just (DeleteArc (snd . arcInfo $ arcData))) mergeFn Nothing (Just arcData0) = do arcStr <- getNewName nameSource let arc :: Arc arc = fromString arcStr (targetNode :: Node) <- lookupNode (target arcData0) let arcInfo1 = arcInfo arcData0 arcData1 = ArcData { arcInfo = (arcInfo1,arc), target = (target arcData0,targetNode) } return (Just arcData1,Just (NewArc arc theArcType arcInfo1 targetNode sourceNode)) mergeFn (Just arcData1) (Just _) = return (Just arcData1,Nothing) in generalisedMerge fromArcs ontoArcs1 compareFn mergeFn -- ---------------------------------------------------------------------- -- Node and Arc types -- We only have one of each. -- ---------------------------------------------------------------------- theNodeType :: NodeType theNodeType = fromString "" theArcType :: ArcType theArcType = fromString "" typeUpdates :: [Update nodeInfo () arcInfo ()] typeUpdates = [NewNodeType theNodeType (),NewArcType theArcType ()]