{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverlappingInstances #-} -- | This is the implementation of modules GraphDisp and GraphConfigure for -- daVinci. See those files for explanation of the names. -- We encode, for example, the type parameter node as DaVinciNode, -- and so on for other type parameters, prefixing with \"DaVinci\" and -- capitalising the next letter. But the only variable you should normally -- need from this module is 'daVinciSort'. module UDrawGraph.Graph( daVinciSort, -- Magic type parameter indicating we want to use daVinci. DaVinciGraph (pendingChangesLock), DaVinciGraphParms, DaVinciNode, DaVinciNodeType, DaVinciNodeTypeParms, DaVinciArc, DaVinciArcType, DaVinciArcTypeParms, getDaVinciGraphContext -- :: DaVinciGraph -> Context ) where import Data.Maybe import Data.IORef import qualified Data.Set as Set import qualified Data.Map as Map import Control.Concurrent import qualified Data.Dynamic import qualified Data.List as List import Util.Sources import Util.Sink import Util.Delayer import qualified Util.UniqueString as UniqueString import qualified Util.VariableList as VariableList import Util.Computation (done) import Util.Dynamics import Util.Registry import Util.ExtendedPrelude import Util.Thread import Util.CompileFlags import Util.Messages import Events.Channels import Events.Events import Events.Destructible import Events.Synchronized import Reactor.BSem import qualified Graphs.GraphDisp as GraphDisp (Graph) import Graphs.GraphDisp hiding (Graph) import qualified Graphs.GraphConfigure as GConf (MenuPrim(Menu), Orientation(..)) import Graphs.GraphConfigure hiding (MenuPrim(Menu), Orientation(..)) import UDrawGraph.Types import UDrawGraph.Basic ------------------------------------------------------------------------ -- How you refer to everything ------------------------------------------------------------------------ daVinciSort :: GraphDisp.Graph DaVinciGraph DaVinciGraphParms DaVinciNode DaVinciNodeType DaVinciNodeTypeParms DaVinciArc DaVinciArcType DaVinciArcTypeParms daVinciSort = displaySort instance GraphAllConfig DaVinciGraph DaVinciGraphParms DaVinciNode DaVinciNodeType DaVinciNodeTypeParms DaVinciArc DaVinciArcType DaVinciArcTypeParms -- ----------------------------------------------------------------------- -- Graphs. -- ----------------------------------------------------------------------- data DaVinciGraph = DaVinciGraph { context :: Context, -- For each node and edge we give (a) its type, (b) its value. nodes :: Registry NodeId NodeData, edges :: Registry EdgeId ArcData, pendingChangesMVar :: MVar [MixedUpdate], -- This refers to changes to the structure of the graph -- which haven't yet been sent to daVinci. Only some -- changes can be delayed in this way, namely -- node and edge additions and deletions. -- Changes to types are not delayed. Changes to attribute values, -- cause this list to be flushed, as does redrawPrim. pendingChangesLock :: BSem, -- This lock is acquired during, flushPendingChanges, newNodePrim, -- and setNodeTitle. -- Where both pendingChangesLock and pendingChangesMVar are needed, -- the first should be got first. globalMenuActions :: Registry MenuId (IO ()), otherActions :: Registry DaVinciAnswer (IO ()), -- The node and edge types contain other event handlers. lastSelectionRef :: IORef LastSelection, doImprove :: Bool, -- improveAll on redrawing graph. destructionChannel :: Channel (), destroyActions :: IO (), -- Various actions to be done when the graph is closed. redrawChannel :: Channel Bool, -- Sending True along this channel indicates that a -- redraw is desired. -- Sending False along it ends the appropriate thread. delayer :: Delayer, redrawAction :: DelayedAction -- this is the action that actually gets done when the user actually -- asks for a redraw. } deriving (Typeable) data LastSelection = LastNone | LastNode NodeId | LastEdge EdgeId data DaVinciGraphParms = DaVinciGraphParms { graphConfigs :: [DaVinciGraph -> IO ()], -- General setups surveyView :: Bool, configDoImprove :: Bool, configFileMenuActions :: Map.Map FileMenuOption (DaVinciGraph -> IO ()), configGlobalMenu :: Maybe GlobalMenu, configActionWrapper :: IO () -> IO (), graphTitleSource :: Maybe (SimpleSource GraphTitle), delayerOpt :: Maybe Delayer, configOrientation :: Maybe GConf.Orientation } instance Eq DaVinciGraph where (==) = mapEq context instance Ord DaVinciGraph where compare = mapOrd context instance Destroyable DaVinciGraph where destroy (daVinciGraph @ DaVinciGraph { context = context,nodes = nodes,edges = edges, globalMenuActions = globalMenuActions,otherActions = otherActions, destroyActions = destroyActions,redrawChannel = redrawChannel, delayer = delayer,redrawAction = redrawAction}) = do cancelDelayedAct delayer redrawAction sync (noWait (send redrawChannel False)) destroyActions destroy context emptyRegistry nodes emptyRegistry edges emptyRegistry globalMenuActions emptyRegistry otherActions signalDestruct daVinciGraph instance Destructible DaVinciGraph where destroyed (DaVinciGraph {destructionChannel = destructionChannel}) = receive destructionChannel getDaVinciGraphContext :: DaVinciGraph -> Context getDaVinciGraphContext g = context g signalDestruct :: DaVinciGraph -> IO () signalDestruct daVinciGraph = sync(noWait(send (destructionChannel daVinciGraph) ())) -- | We run a separate thread for redrawing. The idea is that when more than -- one redraw request arrives while daVinci is already redrawing, we only -- send one. This means it is not too bad when we make a lot of changes, -- redrawing each one. redrawThread :: DaVinciGraph -> IO () redrawThread (daVinciGraph @ DaVinciGraph{ context = context,doImprove = doImprove,redrawChannel = redrawChannel}) = do b1 <- sync (receive redrawChannel) bs <- getAllQueued (receive redrawChannel) if and (b1:bs) then do flushPendingChanges daVinciGraph if doImprove then doInContext (Menu(Layout(ImproveAll))) context else done redrawThread daVinciGraph else done instance HasDelayer DaVinciGraph where toDelayer daVinciGraph = delayer daVinciGraph instance GraphClass DaVinciGraph where redrawPrim (daVinciGraph @ DaVinciGraph{ delayer = delayer,redrawAction = redrawAction}) = delayedAct delayer redrawAction instance NewGraph DaVinciGraph DaVinciGraphParms where newGraphPrim (DaVinciGraphParms {graphConfigs = graphConfigs, configDoImprove = configDoImprove,surveyView = surveyView, configFileMenuActions = configFileMenuActions, configGlobalMenu = configGlobalMenu, configActionWrapper = configActionWrapper, configOrientation = configOrientation, graphTitleSource = graphTitleSource,delayerOpt = delayerOpt}) = do nodes <- newRegistry edges <- newRegistry globalMenuActions <- newRegistry otherActions <- newRegistry lastSelectionRef <- newIORef LastNone graphMVar <- newEmptyMVar -- this will hold the graph when it's completed. This is needed -- by some of the handler actions. let -- We now come to write the handler function for -- the context. This is quite complex so we handle the -- various cases one by one, in separate functions. handler :: DaVinciAnswer -> IO () handler daVinciAnswer = configActionWrapper (handler1 daVinciAnswer) -- -- The handler needs to depend on the context, so that it -- can handle Close and Print events appropriately. handler1 :: DaVinciAnswer -> IO () -- In general, the rule is that if we don't find -- a handler function, we do nothing. We do, however, -- assume that where a menuId is quoted, there is -- an associated handler. If not, this is (probably) -- a bug in daVinci. handler1 daVinciAnswer = case daVinciAnswer of NodeSelectionsLabels nodes -> actNodeSelections nodes NodeDoubleClick -> nodeDoubleClick EdgeSelectionLabel edge -> actEdgeSelections edge EdgeDoubleClick -> edgeDoubleClick MenuSelection menuId -> actGlobalMenu menuId PopupSelectionNode nodeId menuId -> actNodeMenu nodeId menuId PopupSelectionEdge edgeId menuId -> actEdgeMenu edgeId menuId CreateNodeAndEdge nodeId -> actCreateNodeAndEdge nodeId CreateEdge nodeFrom nodeTo -> actCreateEdge nodeFrom nodeTo _ -> do action <- getValueDefault done otherActions daVinciAnswer action -- Update lastSelectionRef. This contains the -- last selected node or edge, in case we are about to -- double-click or call a menu. actNodeSelections :: [NodeId] -> IO () actNodeSelections [nodeId] = writeIORef lastSelectionRef (LastNode nodeId) actNodeSelections _ = done -- not a double-click. actEdgeSelections :: EdgeId -> IO () actEdgeSelections edgeId = writeIORef lastSelectionRef (LastEdge edgeId) -- With node and edge double clicks we also expect the -- node or edge to be recently selected and in lastSelectionRef nodeDoubleClick :: IO () nodeDoubleClick = do lastSelection <- readIORef lastSelectionRef case lastSelection of LastNode nodeId -> do NodeData nodeDataData <- getValueHere nodes nodeId (nodeDoubleClickAction (typeData nodeDataData)) (valueData nodeDataData) _ -> error "DaVinciGraph: confusing node double click" edgeDoubleClick :: IO () edgeDoubleClick = do lastSelection <- readIORef lastSelectionRef case lastSelection of LastEdge edgeId -> do ArcData arcType arcValue <- getValueHere edges edgeId (arcDoubleClickAction arcType) arcValue _ -> error "DaVinciGraph: confusing edge double click" actGlobalMenu :: MenuId -> IO () actGlobalMenu (MenuId ('#':'%':fileMenuStr)) = case toFileMenuOption fileMenuStr of Nothing -> alertMess ("Mysterious daVinci fileMenu " ++ fileMenuStr ++ " ignored") Just reservedMenuOption -> case Map.lookup reservedMenuOption configFileMenuActions of Nothing -> if fileMenuStr == "close" then alertMess ("The application has disabled " ++ " the close action for this window.") else alertMess ("Unexpected daVinci fileMenu " ++ fileMenuStr ++ " ignored") Just graphAction -> do graph <- readMVar graphMVar graphAction graph actGlobalMenu menuId = do action <- getValueHere globalMenuActions menuId action actNodeMenu :: NodeId -> MenuId -> IO () actNodeMenu nodeId menuId = do NodeData nodeDataData <- getValueHere nodes nodeId menuAction <- getValueHere ( nodeMenuActions (typeData nodeDataData)) menuId menuAction (valueData nodeDataData) actEdgeMenu :: EdgeId -> MenuId -> IO () actEdgeMenu edgeId menuId = do ArcData arcType arcValue <- getValueHere edges edgeId menuAction <- getValueHere (arcMenuActions arcType) menuId menuAction arcValue -- We now do the drag-and-drops. There is no special -- handler for the create node action, since this is -- done by the otherActions handler. actCreateNodeAndEdge nodeId = do NodeData nodeDataData <- getValueHere nodes nodeId (createNodeAndEdgeAction (typeData nodeDataData)) (valueData nodeDataData) actCreateEdge :: NodeId -> NodeId -> IO () actCreateEdge nodeId1 nodeId2 = do NodeData nodeDataData1 <- getValueHere nodes nodeId2 NodeData nodeDataData2 <- getValueHere nodes nodeId1 (createEdgeAction (typeData nodeDataData2)) (toDyn (valueData nodeDataData1)) (valueData nodeDataData2) context <- newContext handler pendingChangesMVar <- newMVar [] destructionChannel <- newChannel redrawChannel <- newChannel pendingChangesLock <- newBSem let setTitle :: GraphTitle -> IO () setTitle (GraphTitle graphTitle) = doInContext (Window (Title graphTitle)) context -- Sink for changing the title (addSink,destroySink) <- case graphTitleSource of Nothing -> return (done,done) Just graphTitleSource -> do sink <- newSink setTitle let addSink = do currentTitle <- addOldSink graphTitleSource sink setTitle currentTitle return (addSink,invalidate sink) let setOrientation :: GConf.Orientation -> IO () setOrientation orientation0 = let orientation1 = case orientation0 of GConf.TopDown -> TopDown GConf.BottomUp -> BottomUp GConf.LeftRight -> LeftRight GConf.RightLeft -> RightLeft in doInContext (Menu (Layout ( Orientation orientation1))) context case configOrientation of Nothing -> done Just orientation -> setOrientation orientation -- Set up a delayer and a redraw action which uses it. delayer <- case delayerOpt of Just delayer -> return delayer Nothing -> newDelayer redrawAction <- newDelayedAction (sync(noWait(send redrawChannel True))) let daVinciGraph = DaVinciGraph { context = context, nodes = nodes, edges = edges, globalMenuActions = globalMenuActions, otherActions = otherActions, pendingChangesMVar = pendingChangesMVar, pendingChangesLock = pendingChangesLock, doImprove = configDoImprove, lastSelectionRef = lastSelectionRef, destructionChannel = destructionChannel, destroyActions = destroySink, redrawChannel = redrawChannel, delayer = delayer, redrawAction = redrawAction } putMVar graphMVar daVinciGraph setValue otherActions Closed (signalDestruct daVinciGraph) setValue otherActions Quit (signalDestruct daVinciGraph) sequence_ (fmap ($ daVinciGraph) (reverse graphConfigs)) -- Take control of File Menu events. doInContext (AppMenu (ControlFileEvents)) context let -- Work out which options to enable. fileMenuIds = fmap (\ (option,_) -> MenuId ("#%"++(fromFileMenuOption option))) (Map.toList configFileMenuActions) -- Attach globalMenu if necessary and get its menuids as well. -- (All global menu-ids need to be activated at once.) globalMenuIds <- case configGlobalMenu of Nothing -> return [] Just globalMenu -> mkGlobalMenu daVinciGraph globalMenu -- Activate global menus. doInContext (AppMenu (ActivateMenus (fileMenuIds ++ globalMenuIds))) context addSink -- Do some initial commands. doInContext (DVSet(GapWidth 4)) context doInContext (DVSet(GapHeight 40)) context if surveyView then doInContext (Menu(View(OpenSurveyView))) context else done forkIODebug (redrawThread daVinciGraph) return daVinciGraph instance GraphParms DaVinciGraphParms where emptyGraphParms = DaVinciGraphParms { graphConfigs = [],configDoImprove = False,surveyView = False, graphTitleSource = Nothing,delayerOpt = Nothing, configFileMenuActions = initialFileMenuActions, configActionWrapper = (\ act -> do forkIODebug act done ), configOrientation = Nothing, configGlobalMenu = Nothing } initialFileMenuActions :: Map.Map FileMenuOption (DaVinciGraph -> IO ()) initialFileMenuActions = Map.fromList [ (PrintMenuOption, (\ graph -> doInContext (Menu (File (Print Nothing))) (context graph)) ), (CloseMenuOption, (\ graph -> do proceed <- confirmMess "Really close window?" if proceed then destroy graph else done ) ) ] addGraphConfigCmd :: DaVinciCmd -> DaVinciGraphParms -> DaVinciGraphParms addGraphConfigCmd daVinciCmd daVinciGraphParms = daVinciGraphParms { graphConfigs = (\ daVinciGraph -> doInContext daVinciCmd (context daVinciGraph)) : (graphConfigs daVinciGraphParms) } instance HasConfig GraphTitle DaVinciGraphParms where configUsed _ _ = True ($$) (GraphTitle graphTitle) = addGraphConfigCmd (Window(Title graphTitle)) instance HasConfig Delayer DaVinciGraphParms where configUsed _ _ = True ($$) delayer graphParms = graphParms {delayerOpt = Just delayer} instance HasConfig (SimpleSource GraphTitle) DaVinciGraphParms where configUsed _ _ = True ($$) graphTitleSource graphParms = graphParms {graphTitleSource = Just graphTitleSource} instance HasConfig OptimiseLayout DaVinciGraphParms where configUsed _ _ = True ($$) (OptimiseLayout configDoImprove) daVinciGraphParms = daVinciGraphParms {configDoImprove = configDoImprove} instance HasConfig SurveyView DaVinciGraphParms where configUsed _ _ = True ($$) (SurveyView surveyView) daVinciGraphParms = daVinciGraphParms {surveyView = surveyView} instance HasConfig AllowClose DaVinciGraphParms where configUsed _ _ = True ($$) (AllowClose closeDialogue) = let actFn (graph :: DaVinciGraph) = do proceed <- closeDialogue if proceed then destroy graph else done in ($$) (CloseMenuOption,Just actFn) instance HasConfig FileMenuAct DaVinciGraphParms where configUsed _ _ = True ($$) (FileMenuAct option actFnOpt) = let graphActFnOpt = case actFnOpt of Nothing -> Nothing Just actFn -> let graphActFn :: DaVinciGraph -> IO () graphActFn = const actFn in Just graphActFn in ($$) (option,graphActFnOpt) instance HasConfig (FileMenuOption,(Maybe (DaVinciGraph -> IO ()))) DaVinciGraphParms where configUsed _ _ = True ($$) (option,actFnOpt) daVinciGraphParms = let configFileMenuActions0 = configFileMenuActions daVinciGraphParms configFileMenuActions1 = case actFnOpt of Nothing -> Map.delete option configFileMenuActions0 Just actFn -> Map.insert option actFn configFileMenuActions0 in daVinciGraphParms {configFileMenuActions = configFileMenuActions1} instance HasConfig GConf.Orientation DaVinciGraphParms where configUsed _ _ = True ($$) orientation daVinciGraphParms = daVinciGraphParms {configOrientation = Just orientation} instance HasConfig ActionWrapper DaVinciGraphParms where configUsed _ _ = True ($$) (ActionWrapper wrapper) daVinciGraphParms = daVinciGraphParms {configActionWrapper = wrapper} instance HasConfig AllowDragging DaVinciGraphParms where configUsed _ _ = True ($$) (AllowDragging allowDragging) = addGraphConfigCmd (DragAndDrop (if allowDragging then DraggingOn else DraggingOff)) instance HasConfig GlobalMenu DaVinciGraphParms where configUsed _ _ = True ($$) globalMenu graphParms = graphParms {configGlobalMenu = Just globalMenu} -- Create a global menu and return the ids of the menu-entries, which -- still need to be activated. mkGlobalMenu :: DaVinciGraph -> GlobalMenu -> IO [MenuId] mkGlobalMenu daVinciGraph globalMenu = do menuEntries <- encodeGlobalMenu globalMenu daVinciGraph doInContext (AppMenu(CreateMenus menuEntries)) (context daVinciGraph) return (getMenuIds menuEntries) instance HasConfig GraphGesture DaVinciGraphParms where configUsed _ _ = True ($$) (GraphGesture action) graphParms = graphParms { graphConfigs = (\ daVinciGraph -> setValue (otherActions daVinciGraph) CreateNode action ) : (graphConfigs graphParms) } instance GraphConfig graphConfig => HasConfig graphConfig DaVinciGraphParms where configUsed graphConfig graphParms = False ($$) graphConfig graphParms = graphParms -- ----------------------------------------------------------------------- -- Nodes -- ----------------------------------------------------------------------- data DaVinciNode value = DaVinciNode NodeId deriving (Typeable) -- | Tiresomely we need to make the \"real\" node type untyped. -- This is so that the interactor which handles drag-and-drop -- can get the type out without knowing what it is. data DaVinciNodeType value = DaVinciNodeType { nodeType :: Type, nodeText :: value -> IO (SimpleSource String), -- how to compute the displayed name of the node fontStyle :: Maybe (value -> IO (SimpleSource FontStyle)), -- how to compute the font style of the node border :: Maybe (value -> IO (SimpleSource Border)), -- how to compute the border of the node nodeMenuActions :: Registry MenuId (value -> IO ()), nodeDoubleClickAction :: value -> IO (), createNodeAndEdgeAction :: value -> IO (), createEdgeAction :: Dyn -> value -> IO () } deriving (Typeable) data NodeData = forall value . Typeable value => NodeData (NodeDataData value) -- Extra type is necessary because GHC forbids named typed fields with -- an existential type. data NodeDataData value = NodeDataData { typeData :: DaVinciNodeType value, valueData :: value, sink :: SinkID } data DaVinciNodeTypeParms value = DaVinciNodeTypeParms { nodeAttributes :: Attributes value, configNodeText :: value -> IO (SimpleSource String), configFontStyle :: Maybe (value -> IO (SimpleSource FontStyle)), configBorder :: Maybe (value -> IO (SimpleSource Border)), configNodeDoubleClickAction :: value -> IO (), configCreateNodeAndEdgeAction :: value -> IO (), configCreateEdgeAction :: Dyn -> value -> IO () } instance Eq1 DaVinciNode where eq1 (DaVinciNode n1) (DaVinciNode n2) = (n1 == n2) instance Ord1 DaVinciNode where compare1 (DaVinciNode n1) (DaVinciNode n2) = compare n1 n2 instance Eq1 DaVinciNodeType where eq1 = mapEq nodeType newNodePrim1 :: Typeable value => DaVinciGraph -> DaVinciNodeType value -> value -> NodeId -> IO (DaVinciNode value) newNodePrim1 (daVinciGraph @ DaVinciGraph {context=context,nodes=nodes}) nodeType1 (value :: value) nodeId = do attributes <- setUpNodeType daVinciGraph nodeType1 value nodeId let (daVinciNode :: DaVinciNode value) = DaVinciNode nodeId synchronize (pendingChangesLock daVinciGraph) ( addNodeUpdate daVinciGraph ( NewNode nodeId (nodeType nodeType1) attributes) ) return daVinciNode -- | setUpNodeType is used for doing Haskell-side initialisations -- either after (a) a new node has been created, or (b) we have changed -- the type. setUpNodeType :: Typeable value => DaVinciGraph -> DaVinciNodeType value -> value -> NodeId -> IO [Attribute] setUpNodeType (daVinciGraph @ DaVinciGraph {context=context,nodes=nodes}) (nodeType @ DaVinciNodeType { nodeType = daVinciNodeType,nodeText = nodeText, fontStyle = fontStyle,border = border}) (value :: value) nodeId = do thisNodeTextSource <- nodeText value fontStyleSourceOpt <- case fontStyle of Nothing -> return Nothing Just getFontStyleSource -> do fontStyleSource <- getFontStyleSource value return (Just fontStyleSource) borderSourceOpt <- case border of Nothing -> return Nothing Just getBorderSource -> do borderSource <- getBorderSource value return (Just borderSource) let (daVinciNode :: DaVinciNode value) = DaVinciNode nodeId sinkID <- newSinkID transformValue nodes nodeId (\ nodeDataOpt -> do case nodeDataOpt of Nothing -> done Just (NodeData oldNodeData) -> invalidate (sink oldNodeData) -- this prevents any more updates to these nodes. let newNodeData = NodeDataData { typeData = nodeType, valueData = value, sink = sinkID } return (Just (NodeData newNodeData),()) ) let addNodeAction :: SimpleSource a -> (DaVinciGraph -> DaVinciNode value -> a -> IO b) -> IO a addNodeAction source actFun = do let updateFn a = do actFun daVinciGraph daVinciNode a done (a,_) <- addNewSinkGeneral source updateFn sinkID return a synchronize (pendingChangesLock daVinciGraph) ( do thisNodeText <- addNodeAction thisNodeTextSource setNodeTitle let attributes1 = [titleAttribute thisNodeText] attributes2 <- case fontStyleSourceOpt of Nothing -> return attributes1 Just fontStyleSource -> do thisFontStyle <- addNodeAction fontStyleSource setFontStyle return (fontStyleAttribute thisFontStyle : attributes1) attributes3 <- case borderSourceOpt of Nothing -> return attributes2 Just borderSource -> do thisBorder <- addNodeAction borderSource setBorder return (borderAttribute thisBorder : attributes2) return attributes3 ) instance NewNode DaVinciGraph DaVinciNode DaVinciNodeType where newNodePrim graph nodeType value = do nodeId <- newNodeId (context graph) newNodePrim1 graph nodeType value nodeId setNodeTypePrim graph (node@ (DaVinciNode nodeId) :: DaVinciNode value) nodeType1 = do -- Check first to see if the type really needs changing. goAhead <- do nodeDataOpt <- getValueOpt (nodes graph) nodeId return (case nodeDataOpt of Nothing -> False -- Node seems to have been deleted anyway Just (NodeData nodeData) -> let nodeType0 = typeData nodeData in nodeType nodeType0 /= nodeType nodeType1 ) if goAhead then do flushPendingChanges graph value <- getNodeValuePrim graph node attributes <- setUpNodeType graph nodeType1 value nodeId synchronize (pendingChangesLock graph) ( do doInContext (Graph (ChangeType [NodeType nodeId (nodeType nodeType1)])) (context graph) doInContext (Graph (ChangeAttr [ Node nodeId attributes])) (context graph) ) else done instance DeleteNode DaVinciGraph DaVinciNode where deleteNodePrim (daVinciGraph @ DaVinciGraph {context = context,nodes = nodes}) (DaVinciNode nodeId) = transformValue nodes nodeId (\ nodeDataOpt -> case nodeDataOpt of Nothing -> return (nodeDataOpt,()) Just (NodeData nodeDataData) -> do invalidate (sink nodeDataData) addNodeUpdate daVinciGraph (DeleteNode nodeId) return (Nothing,()) ) getNodeValuePrim (daVinciGraph @ DaVinciGraph { context = context,nodes = nodes}) (DaVinciNode nodeId) = do (Just (NodeData nodeDataData)) <- getValueOpt nodes nodeId return (coDyn (valueData nodeDataData)) setNodeValuePrim (daVinciGraph @ DaVinciGraph {context = context,nodes = nodes}) (daVinciNode @ (DaVinciNode nodeId)) newValue = do typeOpt <- transformValue nodes nodeId (\ nodeDataOpt -> return ( case nodeDataOpt of Nothing -> (nodeDataOpt,Nothing) Just (NodeData nodeDataData0) -> let nodeDataData1 = nodeDataData0 { valueData = coDyn newValue} in (Just (NodeData nodeDataData1), Just (coDyn (typeData nodeDataData1))) ) ) case typeOpt of Nothing -> done -- node has disappeared Just nodeType -> do newTitleSource <- nodeText nodeType newValue newTitle <- readContents newTitleSource setNodeTitle daVinciGraph daVinciNode newTitle done getMultipleNodesPrim daVinciGraph mkAct = do channel <- newChannel lastSel <- newIORef Nothing let mapNode :: NodeId -> DaVinciNodeType value -> DaVinciNode value mapNode nodeId _ = DaVinciNode nodeId closeAct = do errorMess "Unexpected close interrupting multiple node selection!" signalDestruct daVinciGraph newHandler :: DaVinciAnswer -> IO () newHandler answer = case answer of NodeSelectionsLabels [nodeId] -> writeIORef lastSel (Just nodeId) NodeSelectionsLabels _ -> done -- not a double click NodeDoubleClick -> do nodeIdOpt <- readIORef lastSel case nodeIdOpt of Nothing -> errorMess "Confusing node selection ignored" Just nodeId -> do nodeDataOpt <- getValueOpt (nodes daVinciGraph) nodeId case nodeDataOpt of Nothing -> errorMess "Confusing node selection ignored (2)" Just (NodeData nodeDataData) -> do let wrappedNode = WrappedNode (mapNode nodeId ( typeData nodeDataData)) sync(noWait(send channel wrappedNode)) EdgeSelectionLabel _ -> done EdgeSelectionLabels _ _ -> done Closed -> closeAct Quit -> closeAct _ -> errorMess "Other user input ignored during multiple node selection" act = mkAct (receive channel) withHandler newHandler (context daVinciGraph) act instance SetNodeFocus DaVinciGraph DaVinciNode where setNodeFocusPrim (daVinciGraph @ DaVinciGraph {context = context,nodes = nodes}) (DaVinciNode nodeId) = transformValue nodes nodeId (\ nodeDataOpt -> case nodeDataOpt of Nothing -> return (nodeDataOpt,()) Just (NodeData nodeDataData) -> do doInContext (Special (FocusNodeAnimated nodeId)) context return (nodeDataOpt,()) ) instance NodeClass DaVinciNode instance NodeTypeClass DaVinciNodeType instance NewNodeType DaVinciGraph DaVinciNodeType DaVinciNodeTypeParms where newNodeTypePrim (daVinciGraph@(DaVinciGraph {context = context})) (DaVinciNodeTypeParms { nodeAttributes = nodeAttributes, configNodeText = configNodeText, configFontStyle = configFontStyle, configBorder = configBorder, configNodeDoubleClickAction = configNodeDoubleClickAction, configCreateNodeAndEdgeAction = configCreateNodeAndEdgeAction, configCreateEdgeAction = configCreateEdgeAction }) = do nodeType <- newType context (nodeMenuActions,daVinciAttributes) <- encodeAttributes nodeAttributes daVinciGraph doInContext (Visual(AddRules [NR nodeType daVinciAttributes])) context let nodeText = configNodeText fontStyle = configFontStyle border = configBorder nodeDoubleClickAction = configNodeDoubleClickAction createNodeAndEdgeAction = configCreateNodeAndEdgeAction createEdgeAction = configCreateEdgeAction return (DaVinciNodeType { nodeType = nodeType, nodeText = nodeText, fontStyle = fontStyle, border = border, nodeMenuActions = nodeMenuActions, nodeDoubleClickAction = nodeDoubleClickAction, createNodeAndEdgeAction = createNodeAndEdgeAction, createEdgeAction = createEdgeAction }) instance NodeTypeParms DaVinciNodeTypeParms where emptyNodeTypeParms = DaVinciNodeTypeParms { nodeAttributes = emptyAttributes, configNodeText = const (return (staticSimpleSource "")), configFontStyle = Nothing, configBorder = Nothing, configNodeDoubleClickAction = const done, configCreateNodeAndEdgeAction = const done, configCreateEdgeAction = const (const done) } coMapNodeTypeParms coMapFn (DaVinciNodeTypeParms { nodeAttributes = nodeAttributes, configNodeText = configNodeText, configFontStyle = configFontStyle, configBorder = configBorder, configNodeDoubleClickAction = configNodeDoubleClickAction, configCreateNodeAndEdgeAction = configCreateNodeAndEdgeAction, configCreateEdgeAction = configCreateEdgeAction }) = DaVinciNodeTypeParms { nodeAttributes = coMapAttributes coMapFn nodeAttributes, configNodeText = configNodeText . coMapFn, configFontStyle = (fmap (. coMapFn) configFontStyle), configBorder = (fmap (. coMapFn) configBorder), configNodeDoubleClickAction = configNodeDoubleClickAction . coMapFn, configCreateNodeAndEdgeAction = configCreateNodeAndEdgeAction . coMapFn, configCreateEdgeAction = (\ dyn -> (configCreateEdgeAction dyn) . coMapFn) } instance NodeTypeConfig graphConfig => HasConfigValue graphConfig DaVinciNodeTypeParms where configUsed' nodeTypeConfig nodeTypeParms = False ($$$) nodeTypeConfig nodeTypeParms = nodeTypeParms ------------------------------------------------------------------------ -- Node type configs for titles, shapes, and so on. ------------------------------------------------------------------------ instance HasConfigValue ValueTitle DaVinciNodeTypeParms where configUsed' _ _ = True ($$$) (ValueTitle nodeText') parms = let nodeText value = do initial <- nodeText' value return (staticSimpleSource initial) in parms { configNodeText = nodeText } instance HasConfigValue ValueTitleSource DaVinciNodeTypeParms where configUsed' _ _ = True ($$$) (ValueTitleSource nodeText) parms = parms { configNodeText = nodeText } instance HasConfigValue FontStyleSource DaVinciNodeTypeParms where configUsed' _ _ = True ($$$) (FontStyleSource fontStyleSource) parms = parms { configFontStyle = Just fontStyleSource } instance HasConfigValue BorderSource DaVinciNodeTypeParms where configUsed' _ _ = True ($$$) (BorderSource borderSource) parms = parms { configBorder = Just borderSource } instance HasConfigValue Shape DaVinciNodeTypeParms where configUsed' _ _ = True ($$$) shape parms = let nodeAttributes0 = nodeAttributes parms shaped shape = Att "_GO" shape $$$ nodeAttributes0 nodeAttributes1 = case shape of Box -> shaped "box" Circle -> shaped "circle" Ellipse -> shaped "ellipse" Rhombus -> shaped "rhombus" Triangle -> shaped "triangle" Icon filePath -> Att "ICONFILE" filePath $$$ shaped "icon" in parms {nodeAttributes = nodeAttributes1} instance HasConfigValue Color DaVinciNodeTypeParms where configUsed' _ _ = True ($$$) (Color colorName) parms = parms {nodeAttributes = (Att "COLOR" colorName) $$$ (nodeAttributes parms)} instance HasConfigValue LocalMenu DaVinciNodeTypeParms where configUsed' _ _ = True ($$$) localMenu parms = parms {nodeAttributes = localMenu $$$ (nodeAttributes parms)} instance HasConfigValue DoubleClickAction DaVinciNodeTypeParms where configUsed' _ _ = True ($$$) (DoubleClickAction action) parms = parms {configNodeDoubleClickAction = action} ------------------------------------------------------------------------ -- Instances of HasModifyValue ------------------------------------------------------------------------ instance HasModifyValue NodeArcsHidden DaVinciGraph DaVinciNode where modify (NodeArcsHidden hide) daVinciGraph (DaVinciNode nodeId) = do flushPendingChanges daVinciGraph doInContext (Menu ( Abstraction ((if hide then HideEdges else ShowEdges) [nodeId]) )) (context daVinciGraph) case daVinciVersion of Just _ -> done Nothing -> -- work around daVinci 2 bug which causes edge hiding to be -- delayed doInContext (Graph (ChangeAttr ([Node nodeId []]))) (context daVinciGraph) instance HasModifyValue Attribute DaVinciGraph DaVinciNode where modify attribute daVinciGraph (DaVinciNode nodeId) = do flushPendingChanges daVinciGraph doInContext (Graph (ChangeAttr [Node nodeId [attribute]])) (context daVinciGraph) instance HasModifyValue (String,String) DaVinciGraph DaVinciNode where modify (key,value) = modify (A key value) ------------------------------------------------------------------------ -- Node type configs for drag and drop ------------------------------------------------------------------------ instance HasConfigValue NodeGesture DaVinciNodeTypeParms where configUsed' _ _ = True ($$$) (NodeGesture actFn) nodeTypeParms = nodeTypeParms {configCreateNodeAndEdgeAction = actFn} instance HasConfigValue NodeDragAndDrop DaVinciNodeTypeParms where configUsed' _ _ = True ($$$) (NodeDragAndDrop actFn) nodeTypeParms = nodeTypeParms {configCreateEdgeAction = actFn} -- ----------------------------------------------------------------------- -- Arcs -- ----------------------------------------------------------------------- data DaVinciArc value = DaVinciArc EdgeId deriving (Typeable) -- Like nodes, the "real" type is monomorphic. data DaVinciArcType value = DaVinciArcType { arcType :: Type, arcMenuActions :: Registry MenuId (value -> IO ()), arcDoubleClickAction :: value -> IO (), arcArcText :: value -> IO (SimpleSource String) -- arcTitleFunc :: value -> String } deriving (Typeable) data DaVinciArcTypeParms value = DaVinciArcTypeParms { arcAttributes :: Attributes value, configArcDoubleClickAction :: value -> IO (), configArcText :: value -> IO (SimpleSource String) -- configArcTitleFunc :: value -> String } | InvisibleArcTypeParms data ArcData = forall value . Typeable value => ArcData (DaVinciArcType value) value instance Eq1 DaVinciArc where eq1 (DaVinciArc n1) (DaVinciArc n2) = (n1 == n2) instance Ord1 DaVinciArc where compare1 (DaVinciArc n1) (DaVinciArc n2) = compare n1 n2 addArcGeneral :: Typeable value => DaVinciGraph -> DaVinciArcType value -> DaVinciArc value -> value -> DaVinciNode nodeFromValue -> DaVinciNode nodeToValue -> IO () addArcGeneral (daVinciGraph @ DaVinciGraph {edges = edges}) daVinciArcType (DaVinciArc edgeId) value (DaVinciNode nodeFrom) (DaVinciNode nodeTo) = do if daVinciArcType `eq1` invisibleArcType then done else do s <- (arcArcText daVinciArcType) value arcText <- readContents(s) atts <- return ([titleAttribute arcText]) setValue edges edgeId (ArcData daVinciArcType value) addEdgeUpdate daVinciGraph (NewEdge edgeId (arcType daVinciArcType) atts nodeFrom nodeTo) instance NewArc DaVinciGraph DaVinciNode DaVinciNode DaVinciArc DaVinciArcType where newArcPrim daVinciGraph daVinciArcType value nodeFrom nodeTo = do edgeId <- newEdgeId (context daVinciGraph) let newArc = DaVinciArc edgeId addArcGeneral daVinciGraph daVinciArcType newArc value nodeFrom nodeTo return newArc newArcListDrawerPrim (daVinciGraph @ DaVinciGraph {context = context,edges = edges}) nodeFrom = -- We ignore positional data for now, since daVinci does too. let newPos _ aOpt = do edgeId <- newEdgeId context let newArc = DaVinciArc edgeId case aOpt of Nothing -> done Just (daVinciArcType,value,WrappedNode nodeTo) -> addArcGeneral daVinciGraph daVinciArcType newArc value nodeFrom nodeTo return newArc setPos (arc@(DaVinciArc edgeId)) aOpt = do -- Delete the old, if present delPos arc -- Add the new case aOpt of Nothing -> done Just (daVinciArcType,value,WrappedNode nodeTo) -> addArcGeneral daVinciGraph daVinciArcType arc value nodeFrom nodeTo delPos (DaVinciArc edgeId) = do -- Delete the old, if present deleteOld <- deleteFromRegistryBool edges edgeId if deleteOld then addEdgeUpdate daVinciGraph (DeleteEdge edgeId) else done redraw' = redrawPrim daVinciGraph listDrawer = VariableList.ListDrawer { VariableList.newPos = newPos,VariableList.setPos = setPos, VariableList.delPos = delPos,VariableList.redraw = redraw'} in listDrawer instance SetArcType DaVinciGraph DaVinciArc DaVinciArcType where setArcTypePrim daVinciGraph (davinciArc@(DaVinciArc edgeId)) daVinciArcType = error "Sorry, setArcType is not implemented for daVinci" instance DeleteArc DaVinciGraph DaVinciArc where deleteArcPrim (daVinciGraph @ DaVinciGraph {edges=edges,context = context}) (DaVinciArc edgeId) = do addEdgeUpdate daVinciGraph (DeleteEdge edgeId) deleteFromRegistry edges edgeId getArcValuePrim (daVinciGraph @ DaVinciGraph { context = context,edges = edges}) (DaVinciArc edgeId) = do (Just (ArcData _ arcValue)) <- getValueOpt edges edgeId return (coDyn arcValue) setArcValuePrim (daVinciGraph @ DaVinciGraph { context = context,edges = edges}) (DaVinciArc edgeId) newValue = do flushPendingChanges daVinciGraph transformValue edges edgeId (\ (Just (ArcData edgeType _)) -> return (Just (ArcData edgeType (coDyn newValue)),())) instance ArcClass DaVinciArc instance Eq1 DaVinciArcType where eq1 = mapEq arcType instance Ord1 DaVinciArcType where compare1 = mapOrd arcType instance ArcTypeClass DaVinciArcType where invisibleArcType = DaVinciArcType { arcType = Type (UniqueString.newNonUnique "Invisible"), arcMenuActions = error "daVinciGraph.invisible1", arcDoubleClickAction = error "daVinciGraph.invisible2", arcArcText = error "daVinciGraph.invisible3" } instance NewArcType DaVinciGraph DaVinciArcType DaVinciArcTypeParms where newArcTypePrim _ InvisibleArcTypeParms = return invisibleArcType newArcTypePrim (daVinciGraph@DaVinciGraph{context = context}) (DaVinciArcTypeParms{arcAttributes = arcAttributes, configArcDoubleClickAction = configArcDoubleClickAction, configArcText = configArcText -- configArcTitleFunc = configArcTitleFunc }) = do arcType <- newType context (arcMenuActions,attributes) <- encodeAttributes arcAttributes daVinciGraph doInContext (Visual(AddRules [ER arcType attributes])) context let arcDoubleClickAction = configArcDoubleClickAction arcArcText = configArcText return (DaVinciArcType { arcType = arcType, arcMenuActions = arcMenuActions, arcDoubleClickAction = arcDoubleClickAction, arcArcText = arcArcText }) instance ArcTypeParms DaVinciArcTypeParms where emptyArcTypeParms = DaVinciArcTypeParms { arcAttributes = emptyAttributes, configArcDoubleClickAction = const done, configArcText = const (return (staticSimpleSource "")) } invisibleArcTypeParms = InvisibleArcTypeParms coMapArcTypeParms coMapFn (DaVinciArcTypeParms { arcAttributes = arcAttributes, configArcDoubleClickAction = configArcDoubleClickAction, configArcText = configArcText }) = (DaVinciArcTypeParms { arcAttributes = coMapAttributes coMapFn arcAttributes, configArcDoubleClickAction = configArcDoubleClickAction . coMapFn, configArcText = configArcText . coMapFn }) coMapArcTypeParms coMapFn InvisibleArcTypeParms = InvisibleArcTypeParms instance HasConfigValue Color DaVinciArcTypeParms where configUsed' _ _ = True ($$$) (Color colorName) parms = parms {arcAttributes = (Att "EDGECOLOR" colorName) $$$ (arcAttributes parms)} instance HasConfigValue EdgeDir DaVinciArcTypeParms where configUsed' _ _ = True ($$$) (Dir dirStr) parms = parms {arcAttributes = (Att "_DIR" dirStr) $$$ (arcAttributes parms)} instance HasConfigValue Head DaVinciArcTypeParms where configUsed' _ _ = True ($$$) (Head headStr) parms = parms {arcAttributes = (Att "HEAD" headStr) $$$ (arcAttributes parms)} instance HasConfigValue EdgePattern DaVinciArcTypeParms where configUsed' _ _ = True ($$$) edgePattern parms = let pattern = case edgePattern of Solid -> "solid" Dotted -> "dotted" Dashed -> "dashed" Thick -> "thick" Double -> "double" in parms {arcAttributes = (Att "EDGEPATTERN" pattern) $$$ (arcAttributes parms)} instance HasConfigValue LocalMenu DaVinciArcTypeParms where configUsed' _ _ = True ($$$) localMenu parms = parms {arcAttributes = localMenu $$$ (arcAttributes parms)} instance ArcTypeConfig arcTypeConfig => HasConfigValue arcTypeConfig DaVinciArcTypeParms where configUsed' arcTypeConfig arcTypeParms = False ($$$) arcTypeConfig arcTypeParms = arcTypeParms instance HasConfigValue DoubleClickAction DaVinciArcTypeParms where configUsed' _ _ = True ($$$) (DoubleClickAction action) parms = parms {configArcDoubleClickAction = action} {-- instance HasConfigValue TitleFunc DaVinciArcTypeParms where configUsed' _ _ = True ($$$) (TitleFunc func) parms = parms {configArcTitleFunc = func} --} instance HasConfigValue ValueTitle DaVinciArcTypeParms where configUsed' _ _ = True ($$$) (ValueTitle arcText') parms = let arcText value = do initial <- arcText' value return (staticSimpleSource initial) in parms { configArcText = arcText } ------------------------------------------------------------------------ -- Attributes in general -- The Attributes type encodes the attributes in a DaVinciNodeTypeParms -- or a DaVinciArcTypeParms ------------------------------------------------------------------------ data Attributes value = Attributes { options :: Map.Map String String, menuOpt :: Maybe (LocalMenu value) } emptyAttributes :: Attributes value emptyAttributes = Attributes { options = Map.empty, menuOpt = Nothing } coMapAttributes :: (value2 -> value1) -> Attributes value1 -> Attributes value2 coMapAttributes coMapFn (Attributes{options = options,menuOpt = menuOpt0}) = let menuOpt1 = fmap -- deals with Maybe (\ (LocalMenu menu0) -> (LocalMenu (mapMenuPrim (. coMapFn) menu0)) ) menuOpt0 in Attributes{options = options,menuOpt = menuOpt1} data Att value = Att String String -- An attribute instance HasConfigValue Att Attributes where configUsed' _ _ = True ($$$) (Att key value) attributes = attributes { options = Map.insert key value (options attributes) } instance HasConfigValue LocalMenu Attributes where configUsed' _ _ = True ($$$) localMenu attributes = attributes {menuOpt = Just localMenu} encodeAttributes :: Typeable value => Attributes value -> DaVinciGraph -> IO (Registry MenuId (value -> IO ()),[Attribute]) encodeAttributes attributes daVinciGraph = do let keysPart = fmap (\ (key,value) -> A key value) (Map.toList (options attributes)) case menuOpt attributes of Nothing -> return ( error "MenuId returned by daVinci for object with no menu!", keysPart) Just localMenu -> do (registry,menuEntries) <- encodeLocalMenu localMenu daVinciGraph return (registry,M menuEntries : keysPart) ------------------------------------------------------------------------ -- Menus ------------------------------------------------------------------------ encodeLocalMenu :: Typeable value => LocalMenu value -> DaVinciGraph -> IO (Registry MenuId (value -> IO ()),[MenuEntry]) -- Construct a local menu associated with a particular type, -- returning (a) a registry mapping MenuId's to actions; -- (b) the [MenuEntry] to be passed to daVinci. encodeLocalMenu (LocalMenu (menuPrim0 :: GConf.MenuPrim (Maybe String) (value -> IO ()))) (DaVinciGraph {context = context}) = do registry <- newRegistry (menuPrim1 :: GConf.MenuPrim (Maybe String) MenuId) <- mapMMenuPrim (\ valueToAct -> do menuId <- newMenuId context setValue registry menuId valueToAct return menuId ) menuPrim0 (menuPrim2 :: GConf.MenuPrim (Maybe String,MenuId) MenuId) <- mapMMenuPrim' (\ stringOpt -> do menuId <- newMenuId context return (stringOpt,menuId) ) menuPrim1 return (registry,encodeDaVinciMenu menuPrim2) getMenuIds :: [MenuEntry] -> [MenuId] getMenuIds [] = [] getMenuIds (first:rest) = theseIds ++ getMenuIds rest where theseIds :: [MenuId] theseIds = case first of MenuEntry menuId _ -> [menuId] MenuEntryMne menuId _ _ _ _ -> [menuId] SubmenuEntry menuId _ menuEntries -> menuId : getMenuIds menuEntries SubmenuEntryMne menuId _ menuEntries _ -> menuId : getMenuIds menuEntries BlankMenuEntry -> [] _ -> error "DaVinciGraph: (Sub)MenuEntryDisabled not yet handled." encodeGlobalMenu :: GlobalMenu -> DaVinciGraph -> IO [MenuEntry] -- This constructs a global menu. The menuId actions are written -- directly into the graphs globalMenuActions registry. encodeGlobalMenu (GlobalMenu (menuPrim0 :: GConf.MenuPrim (Maybe String) (IO ()))) (DaVinciGraph {context = context,globalMenuActions = globalMenuActions}) = do (menuPrim1 :: GConf.MenuPrim (Maybe String) MenuId) <- mapMMenuPrim (\ action -> do menuId <- newMenuId context setValue globalMenuActions menuId action return menuId ) menuPrim0 (menuPrim2 :: GConf.MenuPrim (Maybe String,MenuId) MenuId) <- mapMMenuPrim' (\ stringOpt -> do menuId <- newMenuId context return (stringOpt,menuId) ) menuPrim1 return (encodeDaVinciMenu menuPrim2) encodeDaVinciMenu :: GConf.MenuPrim (Maybe String,MenuId) MenuId -> [MenuEntry] -- Used for encoding all menus. The MenuId in the first argument is -- used as all submenus need to have a unique menuId, even though -- daVinci can't send that as an event. encodeDaVinciMenu menuHead = case menuHead of GConf.Menu (Nothing,_) menuPrims -> encodeMenuList menuPrims GConf.Menu (Just label,menuId) menuPrims -> [SubmenuEntry menuId (MenuLabel label) (encodeMenuList menuPrims)] single -> [encodeMenuItem single] where encodeMenuList :: [GConf.MenuPrim (Maybe String,MenuId) MenuId] -> [MenuEntry] encodeMenuList menuPrims = fmap encodeMenuItem menuPrims encodeMenuItem :: GConf.MenuPrim (Maybe String,MenuId) MenuId -> MenuEntry encodeMenuItem (Button label menuId) = MenuEntry menuId (MenuLabel label) encodeMenuItem (GConf.Menu (labelOpt,menuId) menuItems) = SubmenuEntry menuId (MenuLabel (fromMaybe "" labelOpt)) (encodeMenuList menuItems) encodeMenuItem Blank = BlankMenuEntry -- ----------------------------------------------------------------------- -- Handling pending changes -- ----------------------------------------------------------------------- addNodeUpdate :: DaVinciGraph -> NodeUpdate -> IO () addNodeUpdate (DaVinciGraph {pendingChangesMVar = pendingChangesMVar}) nodeUpdate = do pendingChanges <- takeMVar pendingChangesMVar putMVar pendingChangesMVar (NU nodeUpdate : pendingChanges) addEdgeUpdate :: DaVinciGraph -> EdgeUpdate -> IO () addEdgeUpdate (DaVinciGraph {pendingChangesMVar = pendingChangesMVar}) edgeUpdate = do pendingChanges <- takeMVar pendingChangesMVar putMVar pendingChangesMVar (EU edgeUpdate : pendingChanges) sortPendingChanges :: [MixedUpdate] -> DaVinciCmd -- This is tricky because for daVinci 2.1 mixed updates don't work properly, -- so we need to feed the updates as a list of node updates followed by -- a list of edge updates. sortPendingChanges pendingChanges = if isJust daVinciVersion then -- daVinci has version at least 3.0, and so multi_update works. Graph(UpdateMixed (reverse pendingChanges)) else sortPendingChanges1 pendingChanges sortPendingChanges1 :: [MixedUpdate] -> DaVinciCmd sortPendingChanges1 pendingChanges = let (nodeUpdates :: [NodeUpdate],edgeUpdates1 :: [EdgeUpdate]) = foldr -- so that the nodes are in the same order as in list. (\ change (nodesSF,edgesSF) -> case change of NU(n @ (NewNode _ _ _)) -> (n:nodesSF,edgesSF) NU(n @ (DeleteNode _)) -> (n:nodesSF,edgesSF) EU(e @ (NewEdge _ _ _ _ _)) -> (nodesSF,e:edgesSF) EU(e @ (DeleteEdge _)) -> (nodesSF,e:edgesSF) ) ([],[]) pendingChanges -- We need to eliminate NewEdge updates for edges -- containing deleted nodes, and DeleteEdge updates for these -- eliminated edges. finalState = toFinalState pendingChanges deletedNodes :: Set.Set NodeId deletedNodes = Set.fromList (mapMaybe (\ update -> case update of NU (DeleteNode nodeId) -> Just nodeId _ -> Nothing ) finalState ) (edgeUpdates2 :: [EdgeUpdate],obsoleteEdges :: Set.Set EdgeId) = foldl (\ (eSF,oSF) e -> case e of (NewEdge edgeId _ _ nodeFrom nodeTo) -> if (Set.member nodeFrom deletedNodes) || (Set.member nodeTo deletedNodes) then (eSF,Set.insert edgeId oSF) else (e:eSF,oSF) _ -> (e:eSF,oSF) ) ([],Set.empty) edgeUpdates1 (edgeUpdates3 :: [EdgeUpdate]) = List.filter (\ e -> case e of DeleteEdge edgeId -> not (Set.member edgeId obsoleteEdges) _ -> True ) (reverse edgeUpdates2) in Graph(Update nodeUpdates edgeUpdates3) removeNullifyingChanges :: [MixedUpdate] -> [MixedUpdate] removeNullifyingChanges [] = [] removeNullifyingChanges (update:r) = case update of NU (DeleteNode nid) -> case findN nid of (r,[]) -> update:removeNullifyingChanges r (h,_:t) -> removeNullifyingChanges $ h ++ t EU (DeleteEdge eid) -> case findE eid of (r,[]) -> update:removeNullifyingChanges r (h,_:t) -> removeNullifyingChanges $ h ++ t -- EU (NewEdgeBehind eid _ _ _ _ _) -> _ -> update:removeNullifyingChanges r where findN i = span (\ mu -> case mu of NU (NewNode nid' _ _) -> i /= nid' _ -> True) r findE i = span (\ mu -> case mu of EU (NewEdge eid' _ _ _ _) -> i /= eid' _ -> True) r flushPendingChanges :: DaVinciGraph -> IO () flushPendingChanges (DaVinciGraph {context = context,nodes = nodes, edges = edges,pendingChangesMVar = pendingChangesMVar, pendingChangesLock = pendingChangesLock}) = synchronize pendingChangesLock ( do pendingChanges <- takeMVar pendingChangesMVar putMVar pendingChangesMVar [] case removeNullifyingChanges pendingChanges of [] -> done ps -> do let isDelete u = case u of NU (DeleteNode _) -> True EU (DeleteEdge _) -> True _ -> False splitUp = List.groupBy (\ u1 u2 -> isDelete u1 == isDelete u2) mapM_ (\ p -> doInContext (sortPendingChanges p) context) $ reverse $ splitUp ps -- Delete registry entries for all now-irrelevant node and edge -- entries. -- NB. This will miss deleting entries for edges which are -- attached to nodes which get deleted without being -- deleted themselves, but I can't be bothered now to do -- anything about this. sequence_ (fmap (\ pendingChange -> case pendingChange of NU (DeleteNode nodeId) -> deleteFromRegistry nodes nodeId EU (DeleteEdge edgeId) -> deleteFromRegistry edges edgeId _ -> done ) (toFinalState pendingChanges) ) ) -- For each node or edge created or destroyed in the list, delete all but -- the first operation applied to it (== the last added to the list) toFinalState :: [MixedUpdate] -> [MixedUpdate] toFinalState = uniqOrdByKeyOrder toId where toId :: MixedUpdate -> Either NodeId EdgeId toId (NU (DeleteNode nodeId)) = Left nodeId toId (NU (NewNode nodeId _ _)) = Left nodeId toId (EU (DeleteEdge edgeId)) = Right edgeId toId (EU (NewEdge edgeId _ _ _ _)) = Right edgeId toId (EU (NewEdgeBehind _ edgeId _ _ _ _)) = Right edgeId -- ----------------------------------------------------------------------- -- Setting node titles and font styles. -- ----------------------------------------------------------------------- -- | This is called internally, by the function set up by newNodePrim. -- The function returns False to indicate that this function failed as -- the node has been deleted. -- (This behaviour may now be useless anyway but I can't be bothered -- to change it.) setNodeTitle :: Typeable value => DaVinciGraph -> DaVinciNode value -> String -> IO Bool setNodeTitle daVinciGraph (daVinciNode@(DaVinciNode nodeId)) newTitle = do flushPendingChanges daVinciGraph nodeDataOpt <- getValueOpt (nodes daVinciGraph) nodeId case nodeDataOpt of Nothing -> return False Just (nodeData :: NodeData) -> do modify (titleAttribute newTitle) daVinciGraph daVinciNode return True titleAttribute :: String -> Attribute titleAttribute title = A "OBJECT" title -- | This function similarly changes the font style. setFontStyle :: Typeable value => DaVinciGraph -> DaVinciNode value -> FontStyle -> IO Bool setFontStyle daVinciGraph (daVinciNode@(DaVinciNode nodeId)) fontStyle = do flushPendingChanges daVinciGraph nodeDataOpt <- getValueOpt (nodes daVinciGraph) nodeId case nodeDataOpt of Nothing -> return False Just (nodeData :: NodeData) -> do modify (fontStyleAttribute fontStyle) daVinciGraph daVinciNode return True fontStyleAttribute :: FontStyle -> Attribute fontStyleAttribute fontStyle = let fontStyleStr = case fontStyle of NormalFontStyle -> "normal" BoldFontStyle -> "bold" ItalicFontStyle -> "italic" BoldItalicFontStyle -> "bold_italic" in A "FONTSTYLE" fontStyleStr -- | This function similarly changes the border. setBorder :: Typeable value => DaVinciGraph -> DaVinciNode value -> Border -> IO Bool setBorder daVinciGraph (daVinciNode@(DaVinciNode nodeId)) border = do flushPendingChanges daVinciGraph nodeDataOpt <- getValueOpt (nodes daVinciGraph) nodeId case nodeDataOpt of Nothing -> return False Just (nodeData :: NodeData) -> do modify (borderAttribute border) daVinciGraph daVinciNode return True borderAttribute :: Border -> Attribute borderAttribute border = let borderStr = case border of NoBorder -> "none" SingleBorder -> "single" DoubleBorder -> "double" in A "BORDER" borderStr -- ----------------------------------------------------------------------- -- Turning a FileMenuOption into a String and vice-versa -- ----------------------------------------------------------------------- fromFileMenuOption :: FileMenuOption -> String fromFileMenuOption option = case lookup option menuOptionList of Just s -> s toFileMenuOption :: String -> Maybe FileMenuOption toFileMenuOption s = lookup s (fmap (\ (o,s) -> (s,o)) menuOptionList) menuOptionList :: [(FileMenuOption,String)] menuOptionList = [ (NewMenuOption, "new"), (OpenMenuOption, "open"), (SaveMenuOption, "save"), (SaveAsMenuOption,"saveas"), (PrintMenuOption, "print"), (CloseMenuOption, "close"), (ExitMenuOption, "exit") ] -- ----------------------------------------------------------------------- -- Miscellaneous functions -- ----------------------------------------------------------------------- -- Transforming one type to another when we know they are -- actually identical . . . coDyn :: (Typeable a,Typeable b) => a -> b coDyn valueA = case Data.Dynamic.cast valueA of Just valueB -> valueB -- --------------------------------------------------------------------- -- A safer version of getValue -- --------------------------------------------------------------------- getValueHere :: GetSetRegistry registry from to => registry -> from -> IO to getValueHere = if isDebug then getValueSafe "DaVinciGraph getValue" else getValue