module Graphs.EmptyGraphSort(
emptyGraphSort,
) where
import Data.IORef
import Util.Dynamics
import Util.Delayer
import Util.Computation
import Util.Object
import Util.ExtendedPrelude
import Util.VariableList
import Events.Events
import Events.Destructible
import Events.Channels
import Graphs.GraphDisp hiding (redraw)
import Graphs.GraphConfigure
data EmptyGraph = EmptyGraph {
delayer :: Delayer,
destructChan :: Channel (),
oId :: ObjectID
} deriving (Typeable)
data EmptyGraphParms = EmptyGraphParms
data EmptyNode value = EmptyNode {
ioRefN :: IORef value,
oIdN :: ObjectID
} deriving (Typeable)
data EmptyNodeType value = EmptyNodeType deriving (Typeable)
data EmptyNodeTypeParms value = EmptyNodeTypeParms
data EmptyArc value = EmptyArc {
ioRefE :: IORef (Maybe value),
oIdE :: ObjectID
} deriving (Typeable)
newtype EmptyArcType value = EmptyArcType {oIdET :: ObjectID}
deriving (Typeable)
data EmptyArcTypeParms value = EmptyArcTypeParms
emptyGraphSort :: Graph EmptyGraph
EmptyGraphParms EmptyNode EmptyNodeType EmptyNodeTypeParms
EmptyArc EmptyArcType EmptyArcTypeParms
emptyGraphSort = displaySort
instance GraphAllConfig EmptyGraph EmptyGraphParms
EmptyNode EmptyNodeType EmptyNodeTypeParms
EmptyArc EmptyArcType EmptyArcTypeParms
instance Eq EmptyGraph where
(==) = mapEq oId
instance Ord EmptyGraph where
compare = mapOrd oId
instance Destroyable EmptyGraph where
destroy graph = sync (noWait (send (destructChan graph) ()))
instance Destructible EmptyGraph where
destroyed graph = receive (destructChan graph)
instance HasDelayer EmptyGraph where
toDelayer = delayer
instance GraphClass EmptyGraph where
redrawPrim _ = done
instance NewGraph EmptyGraph EmptyGraphParms where
newGraphPrim _ =
do
delayer <- newDelayer
destructChan <- newChannel
oId <- newObject
let
graph = EmptyGraph {
delayer = delayer,
destructChan = destructChan,
oId = oId
}
return graph
instance GraphParms EmptyGraphParms where
emptyGraphParms = EmptyGraphParms
instance GraphConfig graphConfig
=> HasConfig graphConfig EmptyGraphParms where
($$) _ parms = parms
configUsed _ _ = True
instance Eq1 EmptyNode where
eq1 = mapEq oIdN
instance Ord1 EmptyNode where
compare1 = mapOrd oIdN
instance NodeClass EmptyNode
instance NodeTypeClass EmptyNodeType
instance NodeTypeParms EmptyNodeTypeParms where
emptyNodeTypeParms = EmptyNodeTypeParms
coMapNodeTypeParms _ _ = EmptyNodeTypeParms
instance NewNode EmptyGraph EmptyNode EmptyNodeType where
newNodePrim _ _ value =
do
ioRef <- newIORef value
oId <- newObject
let
node = EmptyNode {ioRefN = ioRef,oIdN = oId}
return node
setNodeTypePrim _ _ _ = done
instance DeleteNode EmptyGraph EmptyNode where
deleteNodePrim _ _ = done
getNodeValuePrim _ node = readIORef (ioRefN node)
setNodeValuePrim _ node = writeIORef (ioRefN node)
getMultipleNodesPrim _ getA =
do
a <- getA never
return a
instance SetNodeFocus EmptyGraph EmptyNode where
setNodeFocusPrim _ _ = done
instance NewNodeType EmptyGraph EmptyNodeType EmptyNodeTypeParms where
newNodeTypePrim _ _ = return EmptyNodeType
instance NodeTypeConfig nodeTypeConfig
=> HasConfigValue nodeTypeConfig EmptyNodeTypeParms where
($$$) _ parms = parms
configUsed' _ _ = True
instance HasModifyValue FontStyle EmptyGraph EmptyNode where
modify _ _ _ = done
instance HasModifyValue Border EmptyGraph EmptyNode where
modify _ _ _ = done
instance HasModifyValue NodeArcsHidden EmptyGraph EmptyNode where
modify _ _ _ = done
instance Eq1 EmptyArc where
eq1 = mapEq oIdE
instance Ord1 EmptyArc where
compare1 = mapOrd oIdE
instance Eq1 EmptyArcType where
eq1 = mapEq oIdET
instance Ord1 EmptyArcType where
compare1 = mapOrd oIdET
instance ArcClass EmptyArc
instance ArcTypeClass EmptyArcType where
invisibleArcType = EmptyArcType {oIdET = staticObject 1}
instance ArcTypeParms EmptyArcTypeParms where
emptyArcTypeParms = EmptyArcTypeParms
invisibleArcTypeParms = EmptyArcTypeParms
coMapArcTypeParms _ _ = EmptyArcTypeParms
instance NewArcType EmptyGraph EmptyArcType EmptyArcTypeParms where
newArcTypePrim _ _ =
do
oId <- newObject
return (EmptyArcType {oIdET = oId})
instance NewArc EmptyGraph EmptyNode EmptyNode EmptyArc EmptyArcType where
newArcPrim _ _ value _ _ =
do
ioRef <- newIORef (Just value)
oId <- newObject
return (EmptyArc {ioRefE = ioRef,oIdE = oId})
newArcListDrawerPrim _ _ = listDrawer
instance SetArcType EmptyGraph EmptyArc EmptyArcType where
setArcTypePrim _ _ _ = done
listDrawer :: ListDrawer
(EmptyArcType value,value,WrappedNode EmptyNode) (EmptyArc value)
listDrawer =
let
newPos _ endOpt =
do
ioRef <- newIORef (mapOpt endOpt)
oId <- newObject
return (EmptyArc {ioRefE = ioRef,oIdE = oId})
setPos (EmptyArc {ioRefE = ioRef}) endOpt =
writeIORef ioRef (mapOpt endOpt)
delPos _ = done
mapOpt = fmap (\ (_,value,_) -> value)
in
ListDrawer {
newPos = newPos,
setPos = setPos,
delPos = delPos,
redraw = done
}
instance DeleteArc EmptyGraph EmptyArc where
deleteArcPrim _ _ = done
setArcValuePrim _ (EmptyArc {ioRefE = ioRef}) value =
writeIORef ioRef (Just value)
getArcValuePrim _ (EmptyArc {ioRefE = ioRef}) =
do
valueOpt <- readIORef ioRef
case valueOpt of
Just value -> return value
instance ArcTypeConfig arcTypeConfig
=> HasConfigValue arcTypeConfig EmptyArcTypeParms where
($$$) _ parms = parms
configUsed' _ _ = True