{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}

-- | #########################################################################
--
-- This Graph Editor is inspired by the one by Einar Karlsen but uses
-- the new graph interface.
--
-- #########################################################################


module Graphs.GraphEditor (
   newGraphEditor, -- start a GraphEditor, given a Graph

   GraphEditor, -- a running GraphEditor

   -- Graph types associated with graph editors
   Displayable,
   DisplayableUpdate,
   DisplayableGraphConnection,
   DisplayableCannedGraph,
   ) where

import Control.Concurrent(forkIO,killThread)

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

import Reactor.InfoBus
import Events.Events
import Events.Channels
import Events.Destructible

import Graphs.DisplayGraph
import Graphs.Graph
import qualified Graphs.GraphDisp as GraphDisp
import Graphs.GraphConfigure
import Graphs.GetAttributes

type Displayable graph =
   graph String (NodeTypeAttributes Node) () ArcTypeAttributes

-- DisplayableUpdate, DisplayableGraphConnection and DisplayableCannedGraph
-- are used elsewhere to refer to the types associated with an editable graph.
type DisplayableUpdate =
   Update String (NodeTypeAttributes Node) () ArcTypeAttributes

type DisplayableGraphConnection =
   GraphConnection String (NodeTypeAttributes Node) () ArcTypeAttributes

type DisplayableCannedGraph =
   CannedGraph String (NodeTypeAttributes Node) () ArcTypeAttributes


newGraphEditor ::
   (GraphAllConfig dispGraph graphParms
      node nodeType nodeTypeParms arc arcType arcTypeParms,
    HasConfigValue Shape nodeTypeParms,

    Graph graph)
   => (GraphDisp.Graph dispGraph graphParms node nodeType nodeTypeParms
         arc arcType arcTypeParms)
   -> Displayable graph
   -> IO GraphEditor
newGraphEditor :: Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> Displayable graph -> IO GraphEditor
newGraphEditor
      (Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
displaySort :: GraphDisp.Graph dispGraph graphParms
         node nodeType nodeTypeParms arc arcType arcTypeParms)
      (Displayable graph
graph :: Displayable graph) =
   do
      NodeArcTypeRegistry
registry <- Displayable graph -> IO NodeArcTypeRegistry
forall (graph :: * -> * -> * -> * -> *).
Graph graph =>
Displayable graph -> IO NodeArcTypeRegistry
newNodeArcTypeRegistry Displayable graph
graph

      let
         (graphParms
graphParms :: graphParms) =
            String -> GraphTitle
GraphTitle String
"Graph Editor" GraphTitle -> graphParms -> graphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
            MenuPrim (Maybe String) (IO ()) -> GlobalMenu
GlobalMenu (
               Maybe String
-> [MenuPrim (Maybe String) (IO ())]
-> MenuPrim (Maybe String) (IO ())
forall subMenuValue value.
subMenuValue
-> [MenuPrim subMenuValue value] -> MenuPrim subMenuValue value
Menu (String -> Maybe String
forall a. a -> Maybe a
Just String
"New Types") [
                  String -> IO () -> MenuPrim (Maybe String) (IO ())
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button String
"New Node Type" (Displayable graph -> NodeArcTypeRegistry -> IO ()
forall (graph :: * -> * -> * -> * -> *).
Graph graph =>
Displayable graph -> NodeArcTypeRegistry -> IO ()
makeNewNodeType Displayable graph
graph NodeArcTypeRegistry
registry),
                  String -> IO () -> MenuPrim (Maybe String) (IO ())
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button String
"New Arc Type" (Displayable graph -> NodeArcTypeRegistry -> IO ()
forall (graph :: * -> * -> * -> * -> *).
Graph graph =>
Displayable graph -> NodeArcTypeRegistry -> IO ()
makeNewArcType Displayable graph
graph NodeArcTypeRegistry
registry)
                  ]
               )  GlobalMenu -> graphParms -> graphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
            IO () -> GraphGesture
GraphGesture (Displayable graph -> NodeArcTypeRegistry -> IO (Maybe Node)
forall (graph :: * -> * -> * -> * -> *).
Graph graph =>
Displayable graph -> NodeArcTypeRegistry -> IO (Maybe Node)
makeNewNode Displayable graph
graph NodeArcTypeRegistry
registry IO (Maybe Node) -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall (m :: * -> *). Monad m => m ()
done) GraphGesture -> graphParms -> graphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
            Bool -> SurveyView
SurveyView Bool
True SurveyView -> graphParms -> graphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
            Bool -> AllowDragging
AllowDragging Bool
True AllowDragging -> graphParms -> graphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
            graphParms
forall graphParms. GraphParms graphParms => graphParms
GraphDisp.emptyGraphParms

         makeNodeTypeParms :: DisplayGraph -> NodeType
            -> NodeTypeAttributes Node -> IO (nodeTypeParms Node)
         makeNodeTypeParms :: DisplayGraph
-> NodeType -> NodeTypeAttributes Node -> IO (nodeTypeParms Node)
makeNodeTypeParms DisplayGraph
_ NodeType
nodeType NodeTypeAttributes Node
nodeTypeAttributes =
            nodeTypeParms Node -> IO (nodeTypeParms Node)
forall (m :: * -> *) a. Monad m => a -> m a
return (
               (Node -> IO String) -> ValueTitle Node
forall value. (value -> IO String) -> ValueTitle value
ValueTitle (\ Node
node ->
                  do
                     String
nodeOwnTitle <- Displayable graph -> Node -> IO String
forall (graph :: * -> * -> * -> * -> *) nodeLabel nodeTypeLabel
       arcLabel arcTypeLabel.
Graph graph =>
graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Node -> IO nodeLabel
getNodeLabel Displayable graph
graph Node
node
                     String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (
                        (NodeTypeAttributes Node -> String
forall nodeLabel. NodeTypeAttributes nodeLabel -> String
nodeTypeTitle NodeTypeAttributes Node
nodeTypeAttributes) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++
                           String
nodeOwnTitle
                        )
                  ) ValueTitle Node -> nodeTypeParms Node -> nodeTypeParms Node
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
               MenuPrim (Maybe String) (Node -> IO ()) -> LocalMenu Node
forall value.
MenuPrim (Maybe String) (value -> IO ()) -> LocalMenu value
LocalMenu (
                  String
-> (Node -> IO ()) -> MenuPrim (Maybe String) (Node -> IO ())
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button String
"Delete" (\ Node
toDelete -> Displayable graph -> Node -> IO ()
forall (graph :: * -> * -> * -> * -> *).
Graph graph =>
Displayable graph -> Node -> IO ()
deleteNode Displayable graph
graph Node
toDelete)
                  ) LocalMenu Node -> nodeTypeParms Node -> nodeTypeParms Node
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
               (Node -> IO ()) -> NodeGesture Node
forall value. (value -> IO ()) -> NodeGesture value
NodeGesture (\ Node
source -> Displayable graph -> NodeArcTypeRegistry -> Node -> IO ()
forall (graph :: * -> * -> * -> * -> *).
Graph graph =>
Displayable graph -> NodeArcTypeRegistry -> Node -> IO ()
makeNewNodeArc Displayable graph
graph NodeArcTypeRegistry
registry Node
source)
                                                                         NodeGesture Node -> nodeTypeParms Node -> nodeTypeParms Node
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
               (Dyn -> Node -> IO ()) -> NodeDragAndDrop Node
forall value. (Dyn -> value -> IO ()) -> NodeDragAndDrop value
NodeDragAndDrop (\ Dyn
sourceDyn Node
target ->
                  do
                     let
                        Just Node
source = Dyn -> Maybe Node
forall a. Typeable a => Dyn -> Maybe a
fromDynamic Dyn
sourceDyn
                     Displayable graph -> NodeArcTypeRegistry -> Node -> Node -> IO ()
forall (graph :: * -> * -> * -> * -> *).
Graph graph =>
Displayable graph -> NodeArcTypeRegistry -> Node -> Node -> IO ()
makeNewArc Displayable graph
graph NodeArcTypeRegistry
registry Node
source Node
target
                  ) NodeDragAndDrop Node -> nodeTypeParms Node -> nodeTypeParms Node
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
               NodeTypeAttributes Node -> Shape Node
forall nodeLabel. NodeTypeAttributes nodeLabel -> Shape nodeLabel
shape NodeTypeAttributes Node
nodeTypeAttributes Shape Node -> nodeTypeParms Node -> nodeTypeParms Node
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
               nodeTypeParms Node
forall (nodeTypeParms :: * -> *) value.
(NodeTypeParms nodeTypeParms, Typeable value) =>
nodeTypeParms value
GraphDisp.emptyNodeTypeParms
               )

         makeArcTypeParms :: p -> p -> p -> m (configuration Arc)
makeArcTypeParms p
_ p
arcType p
arcTypeAttributes =
            configuration Arc -> m (configuration Arc)
forall (m :: * -> *) a. Monad m => a -> m a
return
               (MenuPrim (Maybe String) (Arc -> IO ()) -> LocalMenu Arc
forall value.
MenuPrim (Maybe String) (value -> IO ()) -> LocalMenu value
LocalMenu (
                  String -> (Arc -> IO ()) -> MenuPrim (Maybe String) (Arc -> IO ())
forall subMenuValue value.
String -> value -> MenuPrim subMenuValue value
Button String
"Delete" (\ Arc
toDelete -> Displayable graph -> Arc -> IO ()
forall (graph :: * -> * -> * -> * -> *).
Graph graph =>
Displayable graph -> Arc -> IO ()
deleteArc Displayable graph
graph Arc
toDelete)
                  ) LocalMenu Arc -> configuration Arc -> configuration Arc
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                  configuration Arc
forall (arcTypeParms :: * -> *) value.
(ArcTypeParms arcTypeParms, Typeable value) =>
arcTypeParms value
GraphDisp.emptyArcTypeParms
                  )

      DisplayGraph
displayGraphInstance <-
         Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> Displayable graph
-> graphParms
-> (DisplayGraph
    -> NodeType -> NodeTypeAttributes Node -> IO (nodeTypeParms Node))
-> (DisplayGraph
    -> ArcType -> ArcTypeAttributes -> IO (arcTypeParms Arc))
-> IO DisplayGraph
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
displayGraph Graph
  dispGraph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
displaySort Displayable graph
graph graphParms
graphParms
            DisplayGraph
-> NodeType -> NodeTypeAttributes Node -> IO (nodeTypeParms Node)
makeNodeTypeParms DisplayGraph
-> ArcType -> ArcTypeAttributes -> IO (arcTypeParms Arc)
forall (m :: * -> *) (configuration :: * -> *) p p p.
(Monad m, HasConfigValue LocalMenu configuration,
 ArcTypeParms configuration) =>
p -> p -> p -> m (configuration Arc)
makeArcTypeParms

      ObjectID
oID <- IO ObjectID
newObject
      let
         graphEditor :: GraphEditor
graphEditor = GraphEditor :: ObjectID -> IO () -> Event () -> GraphEditor
GraphEditor {
            oID :: ObjectID
oID = ObjectID
oID,
            destroyAction :: IO ()
destroyAction =
               do
                  NodeArcTypeRegistry -> IO ()
destroyRegistry NodeArcTypeRegistry
registry
                  DisplayGraph -> IO ()
forall o. Destroyable o => o -> IO ()
destroy DisplayGraph
displayGraphInstance
               ,
            destroyedEvent :: Event ()
destroyedEvent = DisplayGraph -> Event ()
forall o. Destructible o => o -> Event ()
destroyed DisplayGraph
displayGraphInstance
            }

      GraphEditor -> IO ()
forall t. (Object t, Destroyable t) => t -> IO ()
registerTool GraphEditor
graphEditor

      GraphEditor -> IO GraphEditor
forall (m :: * -> *) a. Monad m => a -> m a
return GraphEditor
graphEditor

-- -----------------------------------------------------------------------
-- GraphEditor
-- This type is only there to allow us to destroy it.
-- -----------------------------------------------------------------------

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

instance Object GraphEditor where
   objectID :: GraphEditor -> ObjectID
objectID GraphEditor
graphEditor = GraphEditor -> ObjectID
oID GraphEditor
graphEditor

instance Destroyable GraphEditor where
   destroy :: GraphEditor -> IO ()
destroy GraphEditor
graphEditor = GraphEditor -> IO ()
destroyAction GraphEditor
graphEditor

instance Destructible GraphEditor where
   destroyed :: GraphEditor -> Event ()
destroyed GraphEditor
graphEditor = GraphEditor -> Event ()
destroyedEvent GraphEditor
graphEditor


-- -----------------------------------------------------------------------
-- Nodes
-- -----------------------------------------------------------------------

-- This action is used when the user requests a new type
makeNewNodeType :: Graph graph
   => Displayable graph
   -> NodeArcTypeRegistry
   -> IO ()
makeNewNodeType :: Displayable graph -> NodeArcTypeRegistry -> IO ()
makeNewNodeType Displayable graph
graph NodeArcTypeRegistry
registry =
   do
      Maybe (NodeTypeAttributes Node)
attributesOpt <- IO (Maybe (NodeTypeAttributes Node))
forall nodeLabel. IO (Maybe (NodeTypeAttributes nodeLabel))
getNodeTypeAttributes
      case Maybe (NodeTypeAttributes Node)
attributesOpt of
         Maybe (NodeTypeAttributes Node)
Nothing -> IO ()
forall (m :: * -> *). Monad m => m ()
done
         Just (NodeTypeAttributes Node
attributes :: NodeTypeAttributes Node) ->
            do
               NodeType
nodeType <- Displayable graph -> NodeTypeAttributes Node -> IO NodeType
forall (graph :: * -> * -> * -> * -> *) nodeLabel nodeTypeLabel
       arcLabel arcTypeLabel.
Graph graph =>
graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> nodeTypeLabel -> IO NodeType
newNodeType Displayable graph
graph NodeTypeAttributes Node
attributes
               NodeTypeRegistry -> String -> NodeType -> IO ()
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> to -> IO ()
setValue (NodeArcTypeRegistry -> NodeTypeRegistry
nodeTypes NodeArcTypeRegistry
registry)
                  (NodeTypeAttributes Node -> String
forall nodeLabel. NodeTypeAttributes nodeLabel -> String
nodeTypeTitle NodeTypeAttributes Node
attributes) NodeType
nodeType

-- This action is used to construct a new node.
-- (This is sometimes used as part of a node-and-edge construction)
makeNewNode :: Graph graph
   => Displayable graph
   -> NodeArcTypeRegistry
   -> IO (Maybe Node)
makeNewNode :: Displayable graph -> NodeArcTypeRegistry -> IO (Maybe Node)
makeNewNode Displayable graph
graph NodeArcTypeRegistry
registry =
   do
      Maybe (NodeAttributes NodeType)
attributesOpt <- NodeTypeRegistry -> IO (Maybe (NodeAttributes NodeType))
forall nodeType.
Registry String nodeType -> IO (Maybe (NodeAttributes nodeType))
getNodeAttributes (NodeArcTypeRegistry -> NodeTypeRegistry
nodeTypes NodeArcTypeRegistry
registry)
      case Maybe (NodeAttributes NodeType)
attributesOpt of
         Maybe (NodeAttributes NodeType)
Nothing -> Maybe Node -> IO (Maybe Node)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Node
forall a. Maybe a
Nothing
         Just NodeAttributes NodeType
attributes ->
            do
               Node
node <- Displayable graph -> NodeType -> String -> IO Node
forall (graph :: * -> * -> * -> * -> *) nodeLabel nodeTypeLabel
       arcLabel arcTypeLabel.
Graph graph =>
graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> NodeType -> nodeLabel -> IO Node
newNode Displayable graph
graph (NodeAttributes NodeType -> NodeType
forall nodeType. NodeAttributes nodeType -> nodeType
nodeType NodeAttributes NodeType
attributes)
                  (NodeAttributes NodeType -> String
forall nodeType. NodeAttributes nodeType -> String
nodeTitle NodeAttributes NodeType
attributes)
               Maybe Node -> IO (Maybe Node)
forall (m :: * -> *) a. Monad m => a -> m a
return (Node -> Maybe Node
forall a. a -> Maybe a
Just Node
node)

deleteNode :: Graph graph
   => Displayable graph
   -> Node -> IO ()
deleteNode :: Displayable graph -> Node -> IO ()
deleteNode Displayable graph
graph Node
node = Displayable graph
-> Update String (NodeTypeAttributes Node) () ArcTypeAttributes
-> IO ()
forall (graph :: * -> * -> * -> * -> *) nodeLabel nodeTypeLabel
       arcLabel arcTypeLabel.
Graph graph =>
graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ()
update Displayable graph
graph (Node
-> Update String (NodeTypeAttributes Node) () ArcTypeAttributes
forall nodeLabel nodeTypeLabel arcLabel arcTypeLabel.
Node -> Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
DeleteNode Node
node)


-- -----------------------------------------------------------------------
-- Arcs
-- -----------------------------------------------------------------------

-- This action is used when the user requests a new type
makeNewArcType :: Graph graph
   => Displayable graph
   -> NodeArcTypeRegistry
   -> IO ()
makeNewArcType :: Displayable graph -> NodeArcTypeRegistry -> IO ()
makeNewArcType Displayable graph
graph NodeArcTypeRegistry
registry =
   do
      Maybe ArcTypeAttributes
attributesOpt <- IO (Maybe ArcTypeAttributes)
getArcTypeAttributes
      case Maybe ArcTypeAttributes
attributesOpt of
         Maybe ArcTypeAttributes
Nothing -> IO ()
forall (m :: * -> *). Monad m => m ()
done
         Just (ArcTypeAttributes
attributes :: ArcTypeAttributes) ->
            do
               ArcType
arcType <- Displayable graph -> ArcTypeAttributes -> IO ArcType
forall (graph :: * -> * -> * -> * -> *) nodeLabel nodeTypeLabel
       arcLabel arcTypeLabel.
Graph graph =>
graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> arcTypeLabel -> IO ArcType
newArcType Displayable graph
graph ArcTypeAttributes
attributes
               ArcTypeRegistry -> String -> ArcType -> IO ()
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> to -> IO ()
setValue (NodeArcTypeRegistry -> ArcTypeRegistry
arcTypes NodeArcTypeRegistry
registry)
                  (ArcTypeAttributes -> String
arcTypeTitle ArcTypeAttributes
attributes) ArcType
arcType

-- This action makes a new arc between two nodes.
makeNewArc :: Graph graph
   => Displayable graph
   -> NodeArcTypeRegistry
   -> Node -> Node -> IO ()
makeNewArc :: Displayable graph -> NodeArcTypeRegistry -> Node -> Node -> IO ()
makeNewArc Displayable graph
graph NodeArcTypeRegistry
registry Node
source Node
target =
   do
      Maybe (ArcAttributes ArcType)
attributesOpt <- ArcTypeRegistry -> IO (Maybe (ArcAttributes ArcType))
forall arcType.
Registry String arcType -> IO (Maybe (ArcAttributes arcType))
getArcAttributes (NodeArcTypeRegistry -> ArcTypeRegistry
arcTypes NodeArcTypeRegistry
registry)
      case Maybe (ArcAttributes ArcType)
attributesOpt of
         Maybe (ArcAttributes ArcType)
Nothing -> IO ()
forall (m :: * -> *). Monad m => m ()
done
         Just (ArcAttributes ArcType
attributes :: ArcAttributes ArcType) ->
            do
               Displayable graph -> ArcType -> () -> Node -> Node -> IO Arc
forall (graph :: * -> * -> * -> * -> *) nodeLabel nodeTypeLabel
       arcLabel arcTypeLabel.
Graph graph =>
graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> ArcType -> arcLabel -> Node -> Node -> IO Arc
newArc Displayable graph
graph (ArcAttributes ArcType -> ArcType
forall arcType. ArcAttributes arcType -> arcType
arcType ArcAttributes ArcType
attributes) () Node
source Node
target
               IO ()
forall (m :: * -> *). Monad m => m ()
done
-- This action makes a new node hanging from another one.
makeNewNodeArc :: Graph graph
   => Displayable graph
   -> NodeArcTypeRegistry
   -> Node -> IO ()
makeNewNodeArc :: Displayable graph -> NodeArcTypeRegistry -> Node -> IO ()
makeNewNodeArc Displayable graph
graph NodeArcTypeRegistry
registry Node
source =
   do
      Maybe Node
targetOpt <- Displayable graph -> NodeArcTypeRegistry -> IO (Maybe Node)
forall (graph :: * -> * -> * -> * -> *).
Graph graph =>
Displayable graph -> NodeArcTypeRegistry -> IO (Maybe Node)
makeNewNode Displayable graph
graph NodeArcTypeRegistry
registry
      case Maybe Node
targetOpt of
         Maybe Node
Nothing -> IO ()
forall (m :: * -> *). Monad m => m ()
done
         Just Node
target -> Displayable graph -> NodeArcTypeRegistry -> Node -> Node -> IO ()
forall (graph :: * -> * -> * -> * -> *).
Graph graph =>
Displayable graph -> NodeArcTypeRegistry -> Node -> Node -> IO ()
makeNewArc Displayable graph
graph NodeArcTypeRegistry
registry Node
source Node
target

deleteArc :: Graph graph
   => Displayable graph
   -> Arc -> IO ()
deleteArc :: Displayable graph -> Arc -> IO ()
deleteArc Displayable graph
graph Arc
arc = Displayable graph
-> Update String (NodeTypeAttributes Node) () ArcTypeAttributes
-> IO ()
forall (graph :: * -> * -> * -> * -> *) nodeLabel nodeTypeLabel
       arcLabel arcTypeLabel.
Graph graph =>
graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ()
update Displayable graph
graph (Arc -> Update String (NodeTypeAttributes Node) () ArcTypeAttributes
forall nodeLabel nodeTypeLabel arcLabel arcTypeLabel.
Arc -> Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
DeleteArc Arc
arc)

-- -----------------------------------------------------------------------
-- Maintaining the Registries of nodes and arc types.
-- (These are used for getting node and arc types when we query
-- the user about new nodes and arcs.)
-- -----------------------------------------------------------------------

type NodeTypeRegistry = Registry String NodeType

type ArcTypeRegistry = Registry String ArcType

data NodeArcTypeRegistry = NodeArcTypeRegistry {
   NodeArcTypeRegistry -> NodeTypeRegistry
nodeTypes :: NodeTypeRegistry,
   NodeArcTypeRegistry -> ArcTypeRegistry
arcTypes :: ArcTypeRegistry,
   NodeArcTypeRegistry -> IO ()
destroyRegistry :: IO ()
   }

newNodeArcTypeRegistry :: Graph graph
   => Displayable graph
   -> IO NodeArcTypeRegistry
newNodeArcTypeRegistry :: Displayable graph -> IO NodeArcTypeRegistry
newNodeArcTypeRegistry Displayable graph
graph =
   do
      (NodeTypeRegistry
nodeTypes :: NodeTypeRegistry) <- IO NodeTypeRegistry
forall registry. NewRegistry registry => IO registry
newRegistry
      (ArcTypeRegistry
arcTypes :: ArcTypeRegistry) <- IO ArcTypeRegistry
forall registry. NewRegistry registry => IO registry
newRegistry

      Channel
  (Update String (NodeTypeAttributes Node) () ArcTypeAttributes)
updateQueue <- IO
  (Channel
     (Update String (NodeTypeAttributes Node) () ArcTypeAttributes))
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 String (NodeTypeAttributes Node) () ArcTypeAttributes]
oldUpdates },
         deRegister :: forall nodeLabel nodeTypeLabel arcLabel arcTypeLabel.
GraphConnectionData nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> IO ()
deRegister = IO ()
deRegister
         } <- Displayable graph
-> GraphConnection
     String (NodeTypeAttributes Node) () ArcTypeAttributes
forall (graph :: * -> * -> * -> * -> *) nodeLabel nodeTypeLabel
       arcLabel arcTypeLabel.
Graph graph =>
graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
shareGraph Displayable graph
graph (Channel
  (Update String (NodeTypeAttributes Node) () ArcTypeAttributes)
-> Update String (NodeTypeAttributes Node) () ArcTypeAttributes
-> IO ()
forall (chan :: * -> *) a. HasSend chan => chan a -> a -> IO ()
sendIO Channel
  (Update String (NodeTypeAttributes Node) () ArcTypeAttributes)
updateQueue)

      let
         handleUpdate :: Update
  nodeLabel (NodeTypeAttributes nodeLabel) arcLabel ArcTypeAttributes
-> IO ()
handleUpdate (NewNodeType NodeType
nodeType NodeTypeAttributes nodeLabel
attributes) =
            NodeTypeRegistry -> String -> NodeType -> IO ()
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> to -> IO ()
setValue NodeTypeRegistry
nodeTypes (NodeTypeAttributes nodeLabel -> String
forall nodeLabel. NodeTypeAttributes nodeLabel -> String
nodeTypeTitle NodeTypeAttributes nodeLabel
attributes) NodeType
nodeType
         handleUpdate (NewArcType ArcType
arcType ArcTypeAttributes
attributes) =
            ArcTypeRegistry -> String -> ArcType -> IO ()
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> to -> IO ()
setValue ArcTypeRegistry
arcTypes (ArcTypeAttributes -> String
arcTypeTitle ArcTypeAttributes
attributes) ArcType
arcType
         handleUpdate (MultiUpdate [Update
   nodeLabel
   (NodeTypeAttributes nodeLabel)
   arcLabel
   ArcTypeAttributes]
updates) = (Update
   nodeLabel (NodeTypeAttributes nodeLabel) arcLabel ArcTypeAttributes
 -> IO ())
-> [Update
      nodeLabel
      (NodeTypeAttributes nodeLabel)
      arcLabel
      ArcTypeAttributes]
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Update
  nodeLabel (NodeTypeAttributes nodeLabel) arcLabel ArcTypeAttributes
-> IO ()
handleUpdate [Update
   nodeLabel
   (NodeTypeAttributes nodeLabel)
   arcLabel
   ArcTypeAttributes]
updates

         handleUpdate Update
  nodeLabel (NodeTypeAttributes nodeLabel) arcLabel ArcTypeAttributes
_ = IO ()
forall (m :: * -> *). Monad m => m ()
done

         monitorThread :: IO b
monitorThread =
            do
               Update String (NodeTypeAttributes Node) () ArcTypeAttributes
update <- Channel
  (Update String (NodeTypeAttributes Node) () ArcTypeAttributes)
-> IO
     (Update String (NodeTypeAttributes Node) () ArcTypeAttributes)
forall (chan :: * -> *) a. HasReceive chan => chan a -> IO a
receiveIO Channel
  (Update String (NodeTypeAttributes Node) () ArcTypeAttributes)
updateQueue
               Update String (NodeTypeAttributes Node) () ArcTypeAttributes
-> IO ()
forall nodeLabel nodeLabel arcLabel.
Update
  nodeLabel (NodeTypeAttributes nodeLabel) arcLabel ArcTypeAttributes
-> IO ()
handleUpdate Update String (NodeTypeAttributes Node) () ArcTypeAttributes
update
               IO b
monitorThread

      [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ((Update String (NodeTypeAttributes Node) () ArcTypeAttributes
 -> IO ())
-> [Update String (NodeTypeAttributes Node) () ArcTypeAttributes]
-> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map Update String (NodeTypeAttributes Node) () ArcTypeAttributes
-> IO ()
forall nodeLabel nodeLabel arcLabel.
Update
  nodeLabel (NodeTypeAttributes nodeLabel) arcLabel ArcTypeAttributes
-> IO ()
handleUpdate [Update String (NodeTypeAttributes Node) () ArcTypeAttributes]
oldUpdates)

      ThreadId
monitorThreadID <- IO () -> IO ThreadId
forkIO IO ()
forall b. IO b
monitorThread

      let
         destroyRegistry :: IO ()
destroyRegistry =
            do
               ThreadId -> IO ()
killThread ThreadId
monitorThreadID
               IO ()
deRegister
               NodeTypeRegistry -> IO ()
forall registry. NewRegistry registry => registry -> IO ()
emptyRegistry NodeTypeRegistry
nodeTypes
               ArcTypeRegistry -> IO ()
forall registry. NewRegistry registry => registry -> IO ()
emptyRegistry ArcTypeRegistry
arcTypes
      NodeArcTypeRegistry -> IO NodeArcTypeRegistry
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeArcTypeRegistry :: NodeTypeRegistry -> ArcTypeRegistry -> IO () -> NodeArcTypeRegistry
NodeArcTypeRegistry {
         nodeTypes :: NodeTypeRegistry
nodeTypes = NodeTypeRegistry
nodeTypes,
         arcTypes :: ArcTypeRegistry
arcTypes = ArcTypeRegistry
arcTypes,
         destroyRegistry :: IO ()
destroyRegistry = IO ()
destroyRegistry
         })