module UDrawGraph.Graph(
daVinciSort,
DaVinciGraph (pendingChangesLock),
DaVinciGraphParms,
DaVinciNode,
DaVinciNodeType,
DaVinciNodeTypeParms,
DaVinciArc,
DaVinciArcType,
DaVinciArcTypeParms,
getDaVinciGraphContext
) 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
daVinciSort :: GraphDisp.Graph DaVinciGraph
DaVinciGraphParms DaVinciNode DaVinciNodeType DaVinciNodeTypeParms
DaVinciArc DaVinciArcType DaVinciArcTypeParms
daVinciSort = displaySort
instance GraphAllConfig DaVinciGraph DaVinciGraphParms
DaVinciNode DaVinciNodeType DaVinciNodeTypeParms
DaVinciArc DaVinciArcType DaVinciArcTypeParms
data DaVinciGraph = DaVinciGraph {
context :: Context,
nodes :: Registry NodeId NodeData,
edges :: Registry EdgeId ArcData,
pendingChangesMVar :: MVar [MixedUpdate],
pendingChangesLock :: BSem,
globalMenuActions :: Registry MenuId (IO ()),
otherActions :: Registry DaVinciAnswer (IO ()),
lastSelectionRef :: IORef LastSelection,
doImprove :: Bool,
destructionChannel :: Channel (),
destroyActions :: IO (),
redrawChannel :: Channel Bool,
delayer :: Delayer,
redrawAction :: DelayedAction
} deriving (Typeable)
data LastSelection = LastNone | LastNode NodeId | LastEdge EdgeId
data DaVinciGraphParms = DaVinciGraphParms {
graphConfigs :: [DaVinciGraph -> IO ()],
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) ()))
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
let
handler :: DaVinciAnswer -> IO ()
handler daVinciAnswer
= configActionWrapper (handler1 daVinciAnswer)
handler1 :: DaVinciAnswer -> IO ()
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
actNodeSelections :: [NodeId] -> IO ()
actNodeSelections [nodeId] =
writeIORef lastSelectionRef (LastNode nodeId)
actNodeSelections _ = done
actEdgeSelections :: EdgeId -> IO ()
actEdgeSelections edgeId =
writeIORef lastSelectionRef (LastEdge edgeId)
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
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
(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
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))
doInContext (AppMenu (ControlFileEvents)) context
let
fileMenuIds = fmap
(\ (option,_) -> MenuId ("#%"++(fromFileMenuOption option)))
(Map.toList configFileMenuActions)
globalMenuIds <- case configGlobalMenu of
Nothing -> return []
Just globalMenu -> mkGlobalMenu daVinciGraph globalMenu
doInContext
(AppMenu (ActivateMenus (fileMenuIds ++ globalMenuIds)))
context
addSink
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}
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
data DaVinciNode value = DaVinciNode NodeId deriving (Typeable)
data DaVinciNodeType value = DaVinciNodeType {
nodeType :: Type,
nodeText :: value -> IO (SimpleSource String),
fontStyle :: Maybe (value -> IO (SimpleSource FontStyle)),
border :: Maybe (value -> IO (SimpleSource Border)),
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)
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 :: 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)
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
goAhead <-
do
nodeDataOpt <- getValueOpt (nodes graph) nodeId
return (case nodeDataOpt of
Nothing -> False
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
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
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
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}
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 ->
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)
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}
data DaVinciArc value = DaVinciArc EdgeId deriving (Typeable)
data DaVinciArcType value = DaVinciArcType {
arcType :: Type,
arcMenuActions :: Registry MenuId (value -> IO ()),
arcDoubleClickAction :: value -> IO (),
arcArcText :: value -> IO (SimpleSource String)
} deriving (Typeable)
data DaVinciArcTypeParms value =
DaVinciArcTypeParms {
arcAttributes :: Attributes value,
configArcDoubleClickAction :: value -> IO (),
configArcText :: value -> IO (SimpleSource 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 =
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
delPos arc
case aOpt of
Nothing -> done
Just (daVinciArcType,value,WrappedNode nodeTo) ->
addArcGeneral daVinciGraph daVinciArcType arc
value nodeFrom nodeTo
delPos (DaVinciArc edgeId) =
do
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
}) =
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 ValueTitle DaVinciArcTypeParms where
configUsed' _ _ = True
($$$) (ValueTitle arcText') parms =
let
arcText value =
do
initial <- arcText' value
return (staticSimpleSource initial)
in
parms { configArcText = arcText }
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
(\ (LocalMenu menu0) ->
(LocalMenu (mapMenuPrim (. coMapFn) menu0))
)
menuOpt0
in
Attributes{options = options,menuOpt = menuOpt1}
data Att value = Att String String
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)
encodeLocalMenu :: Typeable value => LocalMenu value -> DaVinciGraph
-> IO (Registry MenuId (value -> IO ()),[MenuEntry])
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]
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]
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
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
sortPendingChanges pendingChanges =
if isJust daVinciVersion
then
Graph(UpdateMixed (reverse pendingChanges))
else
sortPendingChanges1 pendingChanges
sortPendingChanges1 :: [MixedUpdate] -> DaVinciCmd
sortPendingChanges1 pendingChanges =
let
(nodeUpdates :: [NodeUpdate],edgeUpdates1 :: [EdgeUpdate]) =
foldr
(\ 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
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
_ -> 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
sequence_ (fmap
(\ pendingChange -> case pendingChange of
NU (DeleteNode nodeId) -> deleteFromRegistry nodes nodeId
EU (DeleteEdge edgeId) -> deleteFromRegistry edges edgeId
_ -> done
)
(toFinalState pendingChanges)
)
)
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
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
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
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
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")
]
coDyn :: (Typeable a,Typeable b) => a -> b
coDyn valueA =
case Data.Dynamic.cast valueA of
Just valueB -> valueB
getValueHere :: GetSetRegistry registry from to => registry -> from -> IO to
getValueHere =
if isDebug
then
getValueSafe "DaVinciGraph getValue"
else
getValue