uni-uDrawGraph-2.2.0.0: UDrawGraph/Graph.hs
{-# 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