{-# 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
(displaySort :: GraphDisp.Graph dispGraph graphParms
node nodeType nodeTypeParms arc arcType arcTypeParms)
(graph :: Displayable graph) =
do
registry <- newNodeArcTypeRegistry graph
let
(graphParms :: graphParms) =
GraphTitle "Graph Editor" $$
GlobalMenu (
Menu (Just "New Types") [
Button "New Node Type" (makeNewNodeType graph registry),
Button "New Arc Type" (makeNewArcType graph registry)
]
) $$
GraphGesture (makeNewNode graph registry >> done) $$
SurveyView True $$
AllowDragging True $$
GraphDisp.emptyGraphParms
makeNodeTypeParms :: DisplayGraph -> NodeType
-> NodeTypeAttributes Node -> IO (nodeTypeParms Node)
makeNodeTypeParms _ nodeType nodeTypeAttributes =
return (
ValueTitle (\ node ->
do
nodeOwnTitle <- getNodeLabel graph node
return (
(nodeTypeTitle nodeTypeAttributes) ++ "." ++
nodeOwnTitle
)
) $$$
LocalMenu (
Button "Delete" (\ toDelete -> deleteNode graph toDelete)
) $$$
NodeGesture (\ source -> makeNewNodeArc graph registry source)
$$$
NodeDragAndDrop (\ sourceDyn target ->
do
let
Just source = fromDynamic sourceDyn
makeNewArc graph registry source target
) $$$
shape nodeTypeAttributes $$$
GraphDisp.emptyNodeTypeParms
)
makeArcTypeParms _ arcType arcTypeAttributes =
return
(LocalMenu (
Button "Delete" (\ toDelete -> deleteArc graph toDelete)
) $$$
GraphDisp.emptyArcTypeParms
)
displayGraphInstance <-
displayGraph displaySort graph graphParms
makeNodeTypeParms makeArcTypeParms
oID <- newObject
let
graphEditor = GraphEditor {
oID = oID,
destroyAction =
do
destroyRegistry registry
destroy displayGraphInstance
,
destroyedEvent = destroyed displayGraphInstance
}
registerTool graphEditor
return graphEditor
data GraphEditor = GraphEditor {
oID :: ObjectID,
destroyAction :: IO (),
destroyedEvent :: Event ()
}
instance Object GraphEditor where
objectID graphEditor = oID graphEditor
instance Destroyable GraphEditor where
destroy graphEditor = destroyAction graphEditor
instance Destructible GraphEditor where
destroyed graphEditor = destroyedEvent graphEditor
makeNewNodeType :: Graph graph
=> Displayable graph
-> NodeArcTypeRegistry
-> IO ()
makeNewNodeType graph registry =
do
attributesOpt <- getNodeTypeAttributes
case attributesOpt of
Nothing -> done
Just (attributes :: NodeTypeAttributes Node) ->
do
nodeType <- newNodeType graph attributes
setValue (nodeTypes registry)
(nodeTypeTitle attributes) nodeType
makeNewNode :: Graph graph
=> Displayable graph
-> NodeArcTypeRegistry
-> IO (Maybe Node)
makeNewNode graph registry =
do
attributesOpt <- getNodeAttributes (nodeTypes registry)
case attributesOpt of
Nothing -> return Nothing
Just attributes ->
do
node <- newNode graph (nodeType attributes)
(nodeTitle attributes)
return (Just node)
deleteNode :: Graph graph
=> Displayable graph
-> Node -> IO ()
deleteNode graph node = update graph (DeleteNode node)
makeNewArcType :: Graph graph
=> Displayable graph
-> NodeArcTypeRegistry
-> IO ()
makeNewArcType graph registry =
do
attributesOpt <- getArcTypeAttributes
case attributesOpt of
Nothing -> done
Just (attributes :: ArcTypeAttributes) ->
do
arcType <- newArcType graph attributes
setValue (arcTypes registry)
(arcTypeTitle attributes) arcType
makeNewArc :: Graph graph
=> Displayable graph
-> NodeArcTypeRegistry
-> Node -> Node -> IO ()
makeNewArc graph registry source target =
do
attributesOpt <- getArcAttributes (arcTypes registry)
case attributesOpt of
Nothing -> done
Just (attributes :: ArcAttributes ArcType) ->
do
newArc graph (arcType attributes) () source target
done
makeNewNodeArc :: Graph graph
=> Displayable graph
-> NodeArcTypeRegistry
-> Node -> IO ()
makeNewNodeArc graph registry source =
do
targetOpt <- makeNewNode graph registry
case targetOpt of
Nothing -> done
Just target -> makeNewArc graph registry source target
deleteArc :: Graph graph
=> Displayable graph
-> Arc -> IO ()
deleteArc graph arc = update graph (DeleteArc arc)
type NodeTypeRegistry = Registry String NodeType
type ArcTypeRegistry = Registry String ArcType
data NodeArcTypeRegistry = NodeArcTypeRegistry {
nodeTypes :: NodeTypeRegistry,
arcTypes :: ArcTypeRegistry,
destroyRegistry :: IO ()
}
newNodeArcTypeRegistry :: Graph graph
=> Displayable graph
-> IO NodeArcTypeRegistry
newNodeArcTypeRegistry graph =
do
(nodeTypes :: NodeTypeRegistry) <- newRegistry
(arcTypes :: ArcTypeRegistry) <- newRegistry
updateQueue <- newChannel
GraphConnectionData {
graphState = CannedGraph { updates = oldUpdates },
deRegister = deRegister
} <- shareGraph graph (sendIO updateQueue)
let
handleUpdate (NewNodeType nodeType attributes) =
setValue nodeTypes (nodeTypeTitle attributes) nodeType
handleUpdate (NewArcType arcType attributes) =
setValue arcTypes (arcTypeTitle attributes) arcType
handleUpdate (MultiUpdate updates) = mapM_ handleUpdate updates
handleUpdate _ = done
monitorThread =
do
update <- receiveIO updateQueue
handleUpdate update
monitorThread
sequence_ (map handleUpdate oldUpdates)
monitorThreadID <- forkIO monitorThread
let
destroyRegistry =
do
killThread monitorThreadID
deRegister
emptyRegistry nodeTypes
emptyRegistry arcTypes
return (NodeArcTypeRegistry {
nodeTypes = nodeTypes,
arcTypes = arcTypes,
destroyRegistry = destroyRegistry
})