{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | 'displayGraph' displays something implementing the
-- "Graph" interface with something implementing with "GraphDisp" interface.
-- 'displayGraph0' is a slightly more general version that also returns the
-- actual graph.
module Graphs.DisplayGraph(
   displayGraph,
   displayGraph0,
   displayGraph1,

   DisplayGraph
   ) where

import Control.Concurrent(forkIO)

import Util.Dynamics
import Util.Registry
import Util.Computation (done)
import Util.Object

import Reactor.InfoBus

import Events.Events
import Events.Channels
import Events.Destructible

import qualified Graphs.GraphDisp as GraphDisp
    (Graph, newGraph, newNode, newNodeType, newArc, newArcType)
import Graphs.GraphDisp hiding
    (Graph, newGraph, newNode, newNodeType, newArc, newArcType)
import qualified Graphs.Graph as Graph (Graph)
import Graphs.Graph hiding (Graph)

#ifdef DEBUG
#define getRegistryValue (getRegistryValueSafe (__FILE__ ++ show (__LINE__)))
#endif

displayGraph ::
      (GraphAll dispGraph graphParms node nodeType nodeTypeParms
            arc arcType arcTypeParms,
         Typeable nodeLabel,Typeable nodeTypeLabel,Typeable arcLabel,
         Typeable arcTypeLabel,
         Graph.Graph graph)
   => (GraphDisp.Graph dispGraph graphParms node nodeType nodeTypeParms
          arc arcType arcTypeParms)
   -> (graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
   -> graphParms -- these are the parameters to use setting up the graph
   -> (DisplayGraph -> NodeType -> nodeTypeLabel
          -> IO (nodeTypeParms Node))
                 -- this gets parameters for setting up a node type.
                 -- NB - we don't (and can't) recompute the parameters
                 -- if we get a SetNodeTypeLabel or SetArcTypeLabel update.
                 -- We provide the function with the DisplayGraph
                 -- this function will return, to make tying the knot easier
                 -- in versions/VersionGraph.hs
   -> (DisplayGraph -> ArcType -> arcTypeLabel
         -> IO (arcTypeParms Arc))
                 -- see previous argument.
   -> IO DisplayGraph
displayGraph :: Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> graphParms
-> (DisplayGraph
    -> NodeType -> nodeTypeLabel -> IO (nodeTypeParms Node))
-> (DisplayGraph
    -> ArcType -> arcTypeLabel -> IO (arcTypeParms Arc))
-> IO DisplayGraph
displayGraph Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
displaySort graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graph graphParms
graphParms DisplayGraph
-> NodeType -> nodeTypeLabel -> IO (nodeTypeParms Node)
getNodeParms DisplayGraph -> ArcType -> arcTypeLabel -> IO (arcTypeParms Arc)
getArcParms =
   do
      (DisplayGraph
displayedGraph,Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
_) <- Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> graphParms
-> (DisplayGraph
    -> NodeType -> nodeTypeLabel -> IO (nodeTypeParms Node))
-> (DisplayGraph
    -> ArcType -> arcTypeLabel -> IO (arcTypeParms Arc))
-> IO
     (DisplayGraph,
      Graph
        dispGraph
        graphParms
        node
        nodeType
        nodeTypeParms
        arc
        arcType
        arcTypeParms)
forall dispGraph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) nodeLabel nodeTypeLabel arcLabel
       arcTypeLabel (graph :: * -> * -> * -> * -> *).
(GraphAll
   dispGraph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable nodeLabel, Typeable nodeTypeLabel, Typeable arcLabel,
 Typeable arcTypeLabel, Graph graph) =>
Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> graphParms
-> (DisplayGraph
    -> NodeType -> nodeTypeLabel -> IO (nodeTypeParms Node))
-> (DisplayGraph
    -> ArcType -> arcTypeLabel -> IO (arcTypeParms Arc))
-> IO
     (DisplayGraph,
      Graph
        dispGraph
        graphParms
        node
        nodeType
        nodeTypeParms
        arc
        arcType
        arcTypeParms)
displayGraph0 Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
displaySort graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graph graphParms
graphParms
         DisplayGraph
-> NodeType -> nodeTypeLabel -> IO (nodeTypeParms Node)
getNodeParms DisplayGraph -> ArcType -> arcTypeLabel -> IO (arcTypeParms Arc)
getArcParms
      DisplayGraph -> IO DisplayGraph
forall (m :: * -> *) a. Monad m => a -> m a
return DisplayGraph
displayedGraph


displayGraph0 ::
      (GraphAll dispGraph graphParms node nodeType nodeTypeParms
            arc arcType arcTypeParms,
         Typeable nodeLabel,Typeable nodeTypeLabel,Typeable arcLabel,
         Typeable arcTypeLabel,
         Graph.Graph graph)
   => (GraphDisp.Graph dispGraph graphParms node nodeType nodeTypeParms
          arc arcType arcTypeParms)
   -> (graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
   -> graphParms -- these are the parameters to use setting up the graph
   -> (DisplayGraph -> NodeType -> nodeTypeLabel
          -> IO (nodeTypeParms Node))
                 -- this gets parameters for setting up a node type.
                 -- NB - we don't (and can't) recompute the parameters
                 -- if we get a SetNodeTypeLabel or SetArcTypeLabel update.
                 -- We provide the function with the DisplayGraph
                 -- this function will return, to make tying the knot easier
                 -- in versions/VersionGraph.hs
   -> (DisplayGraph -> ArcType -> arcTypeLabel
         -> IO (arcTypeParms Arc))
                 -- see previous argument.
   -> IO (DisplayGraph,GraphDisp.Graph dispGraph graphParms
      node nodeType nodeTypeParms arc arcType arcTypeParms)
displayGraph0 :: Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> graphParms
-> (DisplayGraph
    -> NodeType -> nodeTypeLabel -> IO (nodeTypeParms Node))
-> (DisplayGraph
    -> ArcType -> arcTypeLabel -> IO (arcTypeParms Arc))
-> IO
     (DisplayGraph,
      Graph
        dispGraph
        graphParms
        node
        nodeType
        nodeTypeParms
        arc
        arcType
        arcTypeParms)
displayGraph0 Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
displaySort
   (graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graph :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
   graphParms
graphParms
   (DisplayGraph
-> NodeType -> nodeTypeLabel -> IO (nodeTypeParms Node)
getNodeParms0 :: DisplayGraph -> NodeType -> nodeTypeLabel
      -> IO (nodeTypeParms Node))
   (DisplayGraph -> ArcType -> arcTypeLabel -> IO (arcTypeParms Arc)
getArcParms0 :: DisplayGraph -> ArcType -> arcTypeLabel
      -> IO (arcTypeParms Arc)) =
   let
      getNodeParms1 :: DisplayGraph -> NodeType -> nodeTypeLabel
         -> IO (nodeTypeParms (Node,nodeLabel))
      getNodeParms1 :: DisplayGraph
-> NodeType
-> nodeTypeLabel
-> IO (nodeTypeParms (Node, nodeLabel))
getNodeParms1 DisplayGraph
graph NodeType
nodeType nodeTypeLabel
nodeTypeLabel =
         do
            nodeTypeParms Node
nodeParms0 <- DisplayGraph
-> NodeType -> nodeTypeLabel -> IO (nodeTypeParms Node)
getNodeParms0 DisplayGraph
graph NodeType
nodeType nodeTypeLabel
nodeTypeLabel
            nodeTypeParms (Node, nodeLabel)
-> IO (nodeTypeParms (Node, nodeLabel))
forall (m :: * -> *) a. Monad m => a -> m a
return (((Node, nodeLabel) -> Node)
-> nodeTypeParms Node -> nodeTypeParms (Node, nodeLabel)
forall (nodeTypeParms :: * -> *) value1 value2.
(NodeTypeParms nodeTypeParms, Typeable value1, Typeable value2) =>
(value2 -> value1) -> nodeTypeParms value1 -> nodeTypeParms value2
coMapNodeTypeParms (Node, nodeLabel) -> Node
forall a b. (a, b) -> a
fst nodeTypeParms Node
nodeParms0)

      getArcParms1 :: DisplayGraph -> ArcType -> arcTypeLabel
         -> IO (arcTypeParms (Arc,arcLabel))
      getArcParms1 :: DisplayGraph
-> ArcType -> arcTypeLabel -> IO (arcTypeParms (Arc, arcLabel))
getArcParms1 DisplayGraph
graph ArcType
arcType arcTypeLabel
arcTypeLabel =
         do
            arcTypeParms Arc
arcParms0 <- DisplayGraph -> ArcType -> arcTypeLabel -> IO (arcTypeParms Arc)
getArcParms0 DisplayGraph
graph ArcType
arcType arcTypeLabel
arcTypeLabel
            arcTypeParms (Arc, arcLabel) -> IO (arcTypeParms (Arc, arcLabel))
forall (m :: * -> *) a. Monad m => a -> m a
return (((Arc, arcLabel) -> Arc)
-> arcTypeParms Arc -> arcTypeParms (Arc, arcLabel)
forall (arcTypeParms :: * -> *) value1 value2.
(ArcTypeParms arcTypeParms, Typeable value1, Typeable value2) =>
(value2 -> value1) -> arcTypeParms value1 -> arcTypeParms value2
coMapArcTypeParms (Arc, arcLabel) -> Arc
forall a b. (a, b) -> a
fst arcTypeParms Arc
arcParms0)
   in
      Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> graphParms
-> (DisplayGraph
    -> NodeType
    -> nodeTypeLabel
    -> IO (nodeTypeParms (Node, nodeLabel)))
-> (DisplayGraph
    -> ArcType -> arcTypeLabel -> IO (arcTypeParms (Arc, arcLabel)))
-> IO
     (DisplayGraph,
      Graph
        dispGraph
        graphParms
        node
        nodeType
        nodeTypeParms
        arc
        arcType
        arcTypeParms)
forall dispGraph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) nodeLabel nodeTypeLabel arcLabel
       arcTypeLabel.
(GraphAll
   dispGraph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable nodeLabel, Typeable nodeTypeLabel, Typeable arcLabel,
 Typeable arcTypeLabel) =>
Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> graphParms
-> (DisplayGraph
    -> NodeType
    -> nodeTypeLabel
    -> IO (nodeTypeParms (Node, nodeLabel)))
-> (DisplayGraph
    -> ArcType -> arcTypeLabel -> IO (arcTypeParms (Arc, arcLabel)))
-> IO
     (DisplayGraph,
      Graph
        dispGraph
        graphParms
        node
        nodeType
        nodeTypeParms
        arc
        arcType
        arcTypeParms)
displayGraph1 Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
displaySort (graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
forall (graph :: * -> * -> * -> * -> *) nodeLabel nodeTypeLabel
       arcLabel arcTypeLabel.
Graph graph =>
graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
shareGraph graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graph) graphParms
graphParms DisplayGraph
-> NodeType
-> nodeTypeLabel
-> IO (nodeTypeParms (Node, nodeLabel))
getNodeParms1
         DisplayGraph
-> ArcType -> arcTypeLabel -> IO (arcTypeParms (Arc, arcLabel))
getArcParms1

displayGraph1 ::
      (GraphAll dispGraph graphParms node nodeType nodeTypeParms
            arc arcType arcTypeParms,
         Typeable nodeLabel,Typeable nodeTypeLabel,Typeable arcLabel,
         Typeable arcTypeLabel)
   => (GraphDisp.Graph dispGraph graphParms node nodeType nodeTypeParms
          arc arcType arcTypeParms)
   -> (GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
   -> graphParms -- these are the parameters to use setting up the graph
   -> (DisplayGraph -> NodeType -> nodeTypeLabel
          -> IO (nodeTypeParms (Node,nodeLabel)))
                 -- this gets parameters for setting up a node type.
                 -- NB - we don't (and can't) recompute the parameters
                 -- if we get a SetNodeTypeLabel or SetArcTypeLabel update.
                 -- We provide the function with the DisplayGraph
                 -- this function will return, to make tying the knot easier
                 -- in versions/VersionGraph.hs
   -> (DisplayGraph -> ArcType -> arcTypeLabel
         -> IO (arcTypeParms (Arc,arcLabel)))
                 -- see previous argument.
   -> IO (DisplayGraph,GraphDisp.Graph dispGraph graphParms
      node nodeType nodeTypeParms arc arcType arcTypeParms)
displayGraph1 :: Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> graphParms
-> (DisplayGraph
    -> NodeType
    -> nodeTypeLabel
    -> IO (nodeTypeParms (Node, nodeLabel)))
-> (DisplayGraph
    -> ArcType -> arcTypeLabel -> IO (arcTypeParms (Arc, arcLabel)))
-> IO
     (DisplayGraph,
      Graph
        dispGraph
        graphParms
        node
        nodeType
        nodeTypeParms
        arc
        arcType
        arcTypeParms)
displayGraph1
   (Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
displaySort ::
       GraphDisp.Graph dispGraph graphParms node nodeType nodeTypeParms arc
          arcType arcTypeParms)
   (GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graphConnection
      :: GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
   graphParms
graphParms
   (DisplayGraph
-> NodeType
-> nodeTypeLabel
-> IO (nodeTypeParms (Node, nodeLabel))
getNodeParms :: DisplayGraph -> NodeType -> nodeTypeLabel
      -> IO (nodeTypeParms (Node,nodeLabel)))
   (DisplayGraph
-> ArcType -> arcTypeLabel -> IO (arcTypeParms (Arc, arcLabel))
getArcParms :: DisplayGraph -> ArcType -> arcTypeLabel
      -> IO (arcTypeParms (Arc,arcLabel))) =
   do
      Channel (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
msgQueue <- IO (Channel (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel))
forall a. IO (Channel a)
newChannel

      GraphConnectionData {
         graphState :: forall nodeLabel nodeTypeLabel arcLabel arcTypeLabel.
GraphConnectionData nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> CannedGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graphState = CannedGraph { updates :: forall nodeLabel nodeTypeLabel arcLabel arcTypeLabel.
CannedGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel]
updates = [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel]
updates },
         deRegister :: forall nodeLabel nodeTypeLabel arcLabel arcTypeLabel.
GraphConnectionData nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> IO ()
deRegister = IO ()
deRegister
         } <- GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graphConnection (Event () -> IO ()
forall a. Event a -> IO a
sync(Event () -> IO ())
-> (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
    -> Event ())
-> Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event () -> Event ()
forall a. Event a -> Event ()
noWait (Event () -> Event ())
-> (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
    -> Event ())
-> Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Event ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Channel (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
-> Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> Event ()
forall (chan :: * -> *) a. HasSend chan => chan a -> a -> Event ()
send Channel (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
msgQueue))

-- The nodes of the graph display will have the following types:
#define DispNodeType (nodeType (Node,nodeLabel))
#define DispNode (node (Node,nodeLabel))
#define DispArcType (arcType (Arc,arcLabel))
#define DispArc (arc (Arc,arcLabel))

      (Registry Node (node (Node, nodeLabel))
nodeRegister :: Registry Node DispNode) <- newRegistry
      (Registry NodeType (nodeType (Node, nodeLabel))
nodeTypeRegister :: Registry NodeType DispNodeType)
         <- IO (Registry NodeType (nodeType (Node, nodeLabel)))
forall registry. NewRegistry registry => IO registry
newRegistry
      (Registry Arc (arc (Arc, arcLabel))
arcRegister :: Registry Arc DispArc) <- newRegistry
      (Registry ArcType (arcType (Arc, arcLabel))
arcTypeRegister :: Registry ArcType DispArcType)
         <- IO (Registry ArcType (arcType (Arc, arcLabel)))
forall registry. NewRegistry registry => IO registry
newRegistry

      Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
dispGraph <- Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> graphParms
-> IO
     (Graph
        dispGraph
        graphParms
        node
        nodeType
        nodeTypeParms
        arc
        arcType
        arcTypeParms)
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *).
GraphAll
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> graphParms
-> IO
     (Graph
        graph
        graphParms
        node
        nodeType
        nodeTypeParms
        arc
        arcType
        arcTypeParms)
GraphDisp.newGraph Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
displaySort graphParms
graphParms

      (Channel ()
destructionChannel :: Channel ()) <- IO (Channel ())
forall a. IO (Channel a)
newChannel

      ObjectID
oID <- IO ObjectID
newObject

      let
         displayGraph :: DisplayGraph
displayGraph = DisplayGraph :: ObjectID -> IO () -> Event () -> DisplayGraph
DisplayGraph {
            oID :: ObjectID
oID = ObjectID
oID,
            destroyAction :: IO ()
destroyAction = Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> IO ()
forall o. Destroyable o => o -> IO ()
destroy Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
dispGraph,
            destroyedEvent :: Event ()
destroyedEvent = Channel () -> Event ()
forall (chan :: * -> *) a. HasReceive chan => chan a -> Event a
receive Channel ()
destructionChannel
            }

         handleUpdate :: Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
           -> IO ()
         handleUpdate :: Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ()
handleUpdate (NewNodeType NodeType
nodeType nodeTypeLabel
nodeTypeLabel) =
            do
               nodeTypeParms (Node, nodeLabel)
nodeTypeParms <-
                  DisplayGraph
-> NodeType
-> nodeTypeLabel
-> IO (nodeTypeParms (Node, nodeLabel))
getNodeParms DisplayGraph
displayGraph NodeType
nodeType nodeTypeLabel
nodeTypeLabel
               nodeType (Node, nodeLabel)
dispNodeType <- Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> nodeTypeParms (Node, nodeLabel)
-> IO (nodeType (Node, nodeLabel))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> nodeTypeParms value -> IO (nodeType value)
GraphDisp.newNodeType Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
dispGraph nodeTypeParms (Node, nodeLabel)
nodeTypeParms
               Registry NodeType (nodeType (Node, nodeLabel))
-> NodeType -> nodeType (Node, nodeLabel) -> IO ()
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> to -> IO ()
setValue Registry NodeType (nodeType (Node, nodeLabel))
nodeTypeRegister NodeType
nodeType nodeType (Node, nodeLabel)
dispNodeType
         handleUpdate (SetNodeTypeLabel NodeType
_ nodeTypeLabel
_ ) = IO ()
forall (m :: * -> *). Monad m => m ()
done
         handleUpdate (NewNode Node
node NodeType
nodeType nodeLabel
nodeLabel) =
            do
               nodeType (Node, nodeLabel)
dispNodeType <- Registry NodeType (nodeType (Node, nodeLabel))
-> NodeType -> IO (nodeType (Node, nodeLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry NodeType (nodeType (Node, nodeLabel))
nodeTypeRegister NodeType
nodeType
               node (Node, nodeLabel)
dispNode <-
                  Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> nodeType (Node, nodeLabel)
-> (Node, nodeLabel)
-> IO (node (Node, nodeLabel))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> nodeType value -> value -> IO (node value)
GraphDisp.newNode Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
dispGraph nodeType (Node, nodeLabel)
dispNodeType (Node
node,nodeLabel
nodeLabel)
               Registry Node (node (Node, nodeLabel))
-> Node -> node (Node, nodeLabel) -> IO ()
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> to -> IO ()
setValue Registry Node (node (Node, nodeLabel))
nodeRegister Node
node node (Node, nodeLabel)
dispNode
         handleUpdate (DeleteNode Node
node) =
            do
               node (Node, nodeLabel)
dispNode <- Registry Node (node (Node, nodeLabel))
-> Node -> IO (node (Node, nodeLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry Node (node (Node, nodeLabel))
nodeRegister Node
node
               Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> node (Node, nodeLabel) -> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> node value -> IO ()
deleteNode Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
dispGraph node (Node, nodeLabel)
dispNode
               Registry Node (node (Node, nodeLabel)) -> Node -> IO ()
forall registry from.
KeyOpsRegistry registry from =>
registry -> from -> IO ()
deleteFromRegistry Registry Node (node (Node, nodeLabel))
nodeRegister Node
node
         handleUpdate (SetNodeLabel Node
node nodeLabel
nodeLabel) =
            do
               node (Node, nodeLabel)
dispNode <- Registry Node (node (Node, nodeLabel))
-> Node -> IO (node (Node, nodeLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry Node (node (Node, nodeLabel))
nodeRegister Node
node
               Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> node (Node, nodeLabel) -> (Node, nodeLabel) -> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> node value -> value -> IO ()
setNodeValue Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
dispGraph node (Node, nodeLabel)
dispNode (Node
node,nodeLabel
nodeLabel)
         handleUpdate (SetNodeType Node
node NodeType
nodeType) =
            do
               node (Node, nodeLabel)
dispNode <- Registry Node (node (Node, nodeLabel))
-> Node -> IO (node (Node, nodeLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry Node (node (Node, nodeLabel))
nodeRegister Node
node
               nodeType (Node, nodeLabel)
dispNodeType <- Registry NodeType (nodeType (Node, nodeLabel))
-> NodeType -> IO (nodeType (Node, nodeLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry NodeType (nodeType (Node, nodeLabel))
nodeTypeRegister NodeType
nodeType
               Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> node (Node, nodeLabel) -> nodeType (Node, nodeLabel) -> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> node value -> nodeType value -> IO ()
setNodeType Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
dispGraph node (Node, nodeLabel)
dispNode nodeType (Node, nodeLabel)
dispNodeType
         handleUpdate (NewArcType ArcType
arcType arcTypeLabel
arcTypeLabel) =
            do
               arcTypeParms (Arc, arcLabel)
arcTypeParms <-
                  DisplayGraph
-> ArcType -> arcTypeLabel -> IO (arcTypeParms (Arc, arcLabel))
getArcParms DisplayGraph
displayGraph ArcType
arcType arcTypeLabel
arcTypeLabel
               arcType (Arc, arcLabel)
dispArcType <- Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arcTypeParms (Arc, arcLabel) -> IO (arcType (Arc, arcLabel))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arcTypeParms value -> IO (arcType value)
GraphDisp.newArcType Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
dispGraph arcTypeParms (Arc, arcLabel)
arcTypeParms
               Registry ArcType (arcType (Arc, arcLabel))
-> ArcType -> arcType (Arc, arcLabel) -> IO ()
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> to -> IO ()
setValue Registry ArcType (arcType (Arc, arcLabel))
arcTypeRegister ArcType
arcType arcType (Arc, arcLabel)
dispArcType
         handleUpdate (SetArcTypeLabel ArcType
_ arcTypeLabel
_) = IO ()
forall (m :: * -> *). Monad m => m ()
done
         handleUpdate (NewArc Arc
arc ArcType
arcType arcLabel
arcLabel Node
source Node
target) =
            do
               node (Node, nodeLabel)
dispSource <- Registry Node (node (Node, nodeLabel))
-> Node -> IO (node (Node, nodeLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry Node (node (Node, nodeLabel))
nodeRegister Node
source
               node (Node, nodeLabel)
dispTarget <- Registry Node (node (Node, nodeLabel))
-> Node -> IO (node (Node, nodeLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry Node (node (Node, nodeLabel))
nodeRegister Node
target
               arcType (Arc, arcLabel)
dispArcType <- Registry ArcType (arcType (Arc, arcLabel))
-> ArcType -> IO (arcType (Arc, arcLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry ArcType (arcType (Arc, arcLabel))
arcTypeRegister ArcType
arcType
               arc (Arc, arcLabel)
dispArc <- Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arcType (Arc, arcLabel)
-> (Arc, arcLabel)
-> node (Node, nodeLabel)
-> node (Node, nodeLabel)
-> IO (arc (Arc, arcLabel))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value nodeFromValue nodeToValue.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value, Typeable nodeFromValue, Typeable nodeToValue) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arcType value
-> value
-> node nodeFromValue
-> node nodeToValue
-> IO (arc value)
GraphDisp.newArc Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
dispGraph arcType (Arc, arcLabel)
dispArcType
                  (Arc
arc,arcLabel
arcLabel) node (Node, nodeLabel)
dispSource node (Node, nodeLabel)
dispTarget
               Registry Arc (arc (Arc, arcLabel))
-> Arc -> arc (Arc, arcLabel) -> IO ()
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> to -> IO ()
setValue Registry Arc (arc (Arc, arcLabel))
arcRegister Arc
arc arc (Arc, arcLabel)
dispArc
         handleUpdate (DeleteArc Arc
arc) =
            do
               arc (Arc, arcLabel)
dispArc <- Registry Arc (arc (Arc, arcLabel))
-> Arc -> IO (arc (Arc, arcLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry Arc (arc (Arc, arcLabel))
arcRegister Arc
arc
               Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arc (Arc, arcLabel) -> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arc value -> IO ()
deleteArc Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
dispGraph arc (Arc, arcLabel)
dispArc
               Registry Arc (arc (Arc, arcLabel)) -> Arc -> IO ()
forall registry from.
KeyOpsRegistry registry from =>
registry -> from -> IO ()
deleteFromRegistry Registry Arc (arc (Arc, arcLabel))
arcRegister Arc
arc
         handleUpdate (SetArcLabel Arc
arc arcLabel
arcLabel) =
            do
               arc (Arc, arcLabel)
dispArc <- Registry Arc (arc (Arc, arcLabel))
-> Arc -> IO (arc (Arc, arcLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry Arc (arc (Arc, arcLabel))
arcRegister Arc
arc
               Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arc (Arc, arcLabel) -> (Arc, arcLabel) -> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arc value -> value -> IO ()
setArcValue Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
dispGraph arc (Arc, arcLabel)
dispArc (Arc
arc,arcLabel
arcLabel)
         handleUpdate (MultiUpdate [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel]
updates) = (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ())
-> [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ()
handleUpdate [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel]
updates

      [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ((Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ())
-> [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel]
-> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ()
handleUpdate [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel]
updates)

      Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *).
GraphAll
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> IO ()
redraw Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
dispGraph

      let
         getAllQueued :: IO ()
getAllQueued =
            do
               Maybe (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
updateOpt <- Event (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
-> IO
     (Maybe (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel))
forall a. Event a -> IO (Maybe a)
poll (Channel (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
-> Event (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
forall (chan :: * -> *) a. HasReceive chan => chan a -> Event a
receive Channel (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
msgQueue)
               case Maybe (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
updateOpt of
                  Maybe (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
Nothing -> IO ()
forall (m :: * -> *). Monad m => m ()
done
                  Just Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
update ->
                     do
                        Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ()
handleUpdate Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
update
                        IO ()
getAllQueued

      let
         monitorThread :: IO ()
monitorThread =
            Event () -> IO ()
forall a. Event a -> IO a
sync(
                  (Channel (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
-> Event (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
forall (chan :: * -> *) a. HasReceive chan => chan a -> Event a
receive Channel (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
msgQueue) Event (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
-> (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ())
-> Event ()
forall a b. Event a -> (a -> IO b) -> Event b
>>>=
                     (\ Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
update ->
                        do
                           Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ()
handleUpdate Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
update
                           IO ()
getAllQueued
                           Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *).
GraphAll
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> IO ()
redraw Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
dispGraph
                           IO ()
monitorThread
                         )
               Event () -> Event () -> Event ()
forall a. Event a -> Event a -> Event a
+> (Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> Event ()
forall o. Destructible o => o -> Event ()
destroyed Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
dispGraph) Event () -> IO () -> Event ()
forall a b. Event a -> IO b -> Event b
>>> (
                     do
                        DisplayGraph -> IO ()
forall t. Object t => t -> IO ()
deregisterTool DisplayGraph
displayGraph
                        IO ()
deRegister
                        Channel () -> () -> IO ()
forall (chan :: * -> *) a. HasSend chan => chan a -> a -> IO ()
sendIO Channel ()
destructionChannel ()
                     )
               )

      IO () -> IO ThreadId
forkIO IO ()
monitorThread

      String -> DisplayGraph -> IO ()
forall t. (Object t, Destroyable t) => String -> t -> IO ()
registerToolDebug String
"DisplayGraph" DisplayGraph
displayGraph

      (DisplayGraph,
 Graph
   dispGraph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms)
-> IO
     (DisplayGraph,
      Graph
        dispGraph
        graphParms
        node
        nodeType
        nodeTypeParms
        arc
        arcType
        arcTypeParms)
forall (m :: * -> *) a. Monad m => a -> m a
return (DisplayGraph
displayGraph,Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
dispGraph)

--------------------------------------------------------------------
-- The DisplayGraph type.  (We create this so that we can end
-- the display tidily.)
--------------------------------------------------------------------

data DisplayGraph = DisplayGraph {
   DisplayGraph -> ObjectID
oID :: ObjectID,
   DisplayGraph -> IO ()
destroyAction :: IO (), -- run this to end everything
   DisplayGraph -> Event ()
destroyedEvent :: Event ()
   }

instance Object DisplayGraph where
   objectID :: DisplayGraph -> ObjectID
objectID DisplayGraph
displayGraph = DisplayGraph -> ObjectID
oID DisplayGraph
displayGraph


instance Destroyable DisplayGraph where
   destroy :: DisplayGraph -> IO ()
destroy DisplayGraph
displayGraph = DisplayGraph -> IO ()
destroyAction DisplayGraph
displayGraph

instance Destructible DisplayGraph where
   destroyed :: DisplayGraph -> Event ()
destroyed DisplayGraph
displayGraph = DisplayGraph -> Event ()
destroyedEvent DisplayGraph
displayGraph