{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
module Graphs.GraphEditor (
newGraphEditor,
GraphEditor,
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
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
data GraphEditor = GraphEditor {
GraphEditor -> ObjectID
oID :: ObjectID,
GraphEditor -> IO ()
destroyAction :: IO (),
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
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
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)
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
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
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)
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
})