uni-events (empty) → 2.2.0.0
raw patch · 18 files changed
+2177/−0 lines, 18 filesdep +basedep +containersdep +uni-utilsetup-changed
Dependencies added: base, containers, uni-util
Files
- Events/Cells.hs +31/−0
- Events/Channels.hs +212/−0
- Events/DeleteQueue.hs +82/−0
- Events/Destructible.hs +32/−0
- Events/EqGuard.hs +150/−0
- Events/Events.hs +433/−0
- Events/Examples.hs +116/−0
- Events/FMQueue.hs +110/−0
- Events/GuardedChannels.hs +318/−0
- Events/GuardedEvents.hs +79/−0
- Events/NullGuard.hs +99/−0
- Events/RefQueue.hs +167/−0
- Events/Spawn.hs +40/−0
- Events/Synchronized.hs +9/−0
- Events/Toggle.hs +136/−0
- LICENSE +123/−0
- Setup.hs +2/−0
- uni-events.cabal +38/−0
+ Events/Cells.hs view
@@ -0,0 +1,31 @@+-- | A Cell is a container for a value. It is created with the value in it.+-- The only change we can make is to remove the value, and we cannot put+-- it back again.+module Events.Cells(+ Cell, -- The Cell type+ newCell, -- :: a -> IO (Cell a)+ emptyCell, -- :: Cell a -> IO ()+ -- emptying an already empty cell does nothing.+ inspectCell, -- :: Cell a -> IO (Maybe a)+ -- returns the value, or Nothing if the Cell has been cleared.+ ) where++import Data.IORef++newtype Cell a = Cell (IORef (Maybe a))++newCell :: a -> IO (Cell a)+newCell val =+ do+ ioRef <- newIORef (Just val)+ return (Cell ioRef)++emptyCell :: Cell a -> IO ()+emptyCell (Cell ioRef) = writeIORef ioRef Nothing++inspectCell :: Cell a -> IO (Maybe a)+inspectCell (Cell ioRef) = readIORef ioRef++{-# INLINE newCell #-}+{-# INLINE emptyCell #-}+{-# INLINE inspectCell #-}
+ Events/Channels.hs view
@@ -0,0 +1,212 @@+-- | This is a bare-bones implementation of CML-style channels, IE no+-- guards. Why not use NullGuardChannel you might ask? Because all the+-- gunge we add to do guards makes it too inefficient.+--+-- To avoid memory-leaks we need to clean out superannuated registrations+-- occasionally, as otherwise we will gradually run out of memory if the+-- user continually polls a receive channel event, but no-one is sending+-- anything. (The memory lost is potentially quite big, since it includes+-- all the continuations we will never need.)+--+-- Although this is not expressed by the type, there are three possible states+-- for the channel+-- (1) we have >=0 queued send events and no queued receive events.+-- (2) we have >=0 queued receive events and no queued send events.+-- (3) we have both send and receive events queued, but they all come+-- from the same synchronisation.+-- When we have a new send event, and there are queued receive events+-- not from the same synchronisation, we can match. Otherwise the+-- send event must be queued. For receive events the situation is exactly+-- the same in reverse.+--+-- Our quick and dirty strategy is to maintain an integer counter for the+-- channel. This is initially 0 and on each send or receive registration+-- changes as follows:+-- 1) If we match an event set counter to 0.+-- 2) If we try to match an event, but fail because the event was already+-- matched by someone else (Anticipated), leave counter as it is.+-- 3) If finally we have to queue an event, look at counter. If it+-- exceeds 10, clean the queue and set counter to 0, otherwise increment it.+-- \"cleaning\" means removing all items from the front of the queue which+-- have flipped toggles.+module Events.Channels(+ Channel,+ newChannel, -- :: IO Channel a+ -- A Channel is an instance of HasSend and HasReceive.+ ) where++import Control.Concurrent++import Util.Computation(done)+import Util.Queue+++import Events.Toggle+import Events.Events++-- | A synchronous channel+newtype Channel a = Channel (MVar (Queue (Toggle,a,IO () -> IO ()),+ Queue (Toggle,IO a -> IO ()),Int))++data Res a = None | Anticipated | Found a+++cleanPar :: Int -- this is how high the counter has to get before we clean.+cleanPar = 10++-- | Create a new channel+newChannel :: IO (Channel a)+newChannel =+ do+ mVar <- newMVar (emptyQ,emptyQ,0)+ return (Channel mVar)+++instance HasSend Channel where+ send (Channel mVar) value = Event (+ \ toggle continuation ->+ do+ (sQueue,rQueue,counter) <- takeMVar mVar+ (rQueueOut,res) <- matchSend toggle rQueue+ case res of+ None ->+ do+ let+ sQueue2 = insertQ sQueue (toggle,value,continuation)+ (sQueue3,counter) <-+ if counter>=cleanPar+ then+ do+ sQueue3 <- cleanSends sQueue2+ return (sQueue3,0)+ else+ return (sQueue2,counter+1)+ putMVar mVar (sQueue3,rQueueOut,counter)+ return(Awaiting done)+ Anticipated ->+ do+ putMVar mVar (sQueue,rQueueOut,counter)+ return Immediate+ Found acontinuation ->+ do+ putMVar mVar (sQueue,rQueueOut,0)+ continuation (return ())+ acontinuation (return value)+ return Immediate)+++cleanSends :: Queue (Toggle,a,IO () -> IO ())+ -> IO (Queue (Toggle,a,IO () -> IO()))+cleanSends queue =+ case removeQ queue of+ Nothing -> return emptyQ+ Just (sendReg@(toggle,_,_),rest) ->+ do+ peek <- peekToggle toggle+ if peek+ then+ return (insertAtEndQ rest sendReg)+ else+ cleanSends rest++matchSend :: Toggle -> Queue (Toggle,IO a -> IO ())+ -> IO (Queue (Toggle,IO a -> IO ()),Res (IO a -> IO ()))+matchSend sendToggle queueIn =+ case removeQ queueIn of+ Nothing -> return (queueIn,None)+ Just (rc@(receiveToggle,continuation),queueOut) ->+ do+ tog <- toggle2 sendToggle receiveToggle+ case tog of+ Nothing -> return (queueOut,Found continuation)+ Just(True,True) ->+ do+ match2 <- matchSend sendToggle queueOut+ case match2 of+ (queueOut,None) ->+ return (insertAtEndQ queueOut rc,None)+ (queueOut,Anticipated) ->+ return (queueOut,Anticipated)+ (queueOut,found) ->+ return (queueOut,found)+ Just(True,False) -> matchSend sendToggle queueOut+ Just(False,True) ->+ return (insertAtEndQ queueOut rc,Anticipated)+ Just(False,False) -> return (queueOut,Anticipated)++instance HasReceive Channel where+ receive (Channel mVar) = Event (+ \ toggle acontinuation ->+ do+ (sQueue,rQueue,counter) <- takeMVar mVar+ (sQueueOut,res) <- matchReceive toggle sQueue+ case res of+ None ->+ do+ let+ rQueue2 = insertQ rQueue (toggle,acontinuation)+ (rQueue3,counter) <-+ if counter>=cleanPar+ then+ do+ rQueue3 <- cleanReceives rQueue2+ return (rQueue3,0)+ else+ return (rQueue2,counter+1)++ putMVar mVar (sQueueOut,rQueue3,counter)+ return(Awaiting done)+ Anticipated ->+ do+ putMVar mVar (sQueueOut,rQueue,counter)+ return Immediate+ Found (value,continuation) ->+ do+ putMVar mVar (sQueueOut,rQueue,counter)+ continuation (return ())+ acontinuation (return value)+ return Immediate+ )+++matchReceive :: Toggle -> Queue (Toggle,a,IO () -> IO ())+ -> IO (Queue (Toggle,a,IO () -> IO ()),Res (a,IO () -> IO ()))+matchReceive receiveToggle queueIn =+ case removeQ queueIn of+ Nothing -> return (queueIn,None)+ Just (rc@(sendToggle,value,continuation),queueOut) ->+ do+ tog <- toggle2 receiveToggle sendToggle+ case tog of+ Nothing -> return (queueOut,Found (value,continuation))+ Just(True,True) ->+ do+ match2 <- matchReceive receiveToggle queueOut+ case match2 of+ (queueOut,None) ->+ return (insertAtEndQ queueOut rc,None)+ (queueOut,Anticipated) ->+ return (queueOut,Anticipated)+ (queueOut,found) ->+ return (queueOut,found)+ Just(True,False) -> matchReceive receiveToggle queueOut+ Just(False,True) ->+ return (insertAtEndQ queueOut rc,Anticipated)+ Just(False,False) -> return (queueOut,Anticipated)+cleanReceives :: Queue (Toggle,IO a -> IO ())+ -> IO (Queue (Toggle,IO a -> IO ()))+cleanReceives queue =+ case removeQ queue of+ Nothing -> return emptyQ+ Just (receiveReg@(toggle,_),rest) ->+ do+ peek <- peekToggle toggle+ if peek+ then+ return (insertAtEndQ rest receiveReg)+ else+ cleanReceives rest++++
+ Events/DeleteQueue.hs view
@@ -0,0 +1,82 @@+-- | A DeleteQueue is a queue where entries can be deleted by an+-- IO action. This is a fairly specialised implementation, designed+-- for event handling.+--+-- Queue entries are either active or invalid. Once invalid,+-- removeQueue will not return them, but they still take up (a little) memory.+--+-- addQueue, removeQueue, isEmptyQueue, cleanQueue all take a delete queue+-- as argument. We assume that this argument is not used again.+--+-- Either removeQueue or isEmptyQueue or cleanQueue should be run+-- occasionally, to remove invalid entries.+module Events.DeleteQueue(+ DeleteQueue,+ emptyQueue, -- :: DeleteQueue v+ addQueue, -- :: DeleteQueue v -> v -> IO (DeleteQueue v,IO ())+ -- add an item to the queue, returning the new queue + a new action which+ -- will invalidate that item.+ removeQueue,+ -- :: DeleteQueue v -> IO (Maybe (v,DeleteQueue v,DeleteQueue v))+ -- returns the next active element of the queue, and the succeeding+ -- queue. 3rd result is a queue which is identical to the original+ -- queue.+ isEmptyQueue, -- :: DeleteQueue v -> IO (Maybe (DeleteQueue v))+ -- If queue has active entries, returns it, otherwise return Nothing.+ cleanQueue, -- :: DeleteQueue v -> IO (DeleteQueue v)+ ) where++import Util.Queue+import Events.Cells++newtype DeleteQueue v = DeleteQueue (Queue (Cell v))++emptyQueue :: DeleteQueue v+emptyQueue = DeleteQueue emptyQ++addQueue :: DeleteQueue v -> v -> IO (DeleteQueue v,IO ())+addQueue (DeleteQueue queue) v =+ do+ cell <- newCell v+ let deleteQueue1 = DeleteQueue (insertQ queue cell)+ return (deleteQueue1,emptyCell cell)++cleanQueue :: DeleteQueue v -> IO (DeleteQueue v)+-- cleanQueue pops empty cells from the front of the queue as long as possible+cleanQueue deleteQueue@(DeleteQueue queue) =+ case removeQ queue of+ Nothing -> return deleteQueue+ Just (cell,queue2) ->+ do+ cellContents <- inspectCell cell+ case cellContents of+ Nothing -> cleanQueue (DeleteQueue queue2)+ Just _ -> return (DeleteQueue (insertAtEndQ queue2 cell))+++isEmptyQueue :: DeleteQueue v -> IO (Maybe (DeleteQueue v))+-- isEmptyQueue is like cleanQueue, but if the queue is empty returns Nothing.+isEmptyQueue deleteQueue@(DeleteQueue queue) =+ case removeQ queue of+ Nothing -> return Nothing+ Just (cell,queue2) ->+ do+ cellContents <- inspectCell cell+ case cellContents of+ Nothing -> isEmptyQueue (DeleteQueue queue2)+ Just _ ->+ return (Just (DeleteQueue (insertAtEndQ queue2 cell)))++removeQueue :: DeleteQueue v -> IO (Maybe (v,DeleteQueue v,DeleteQueue v))+removeQueue (DeleteQueue queue) =+ case removeQ queue of+ Nothing -> return Nothing+ Just (cell,queue2) ->+ do+ vOpt <- inspectCell cell+ case vOpt of+ Nothing -> removeQueue (DeleteQueue queue2)+ Just v ->+ return (Just(v,DeleteQueue queue2,+ DeleteQueue(insertAtEndQ queue2 cell)))+
+ Events/Destructible.hs view
@@ -0,0 +1,32 @@+-- | Things which instance Destroyable and Destructible can be destroyed.+module Events.Destructible (+ Destroyable(..),+ Destructible(..),++ doOnce,+ -- :: IO () -> IO (IO ())+ -- doOnce can be used to produce an action which is identical+ -- to its argument, except that if it's already been called, it+ -- does nothing.+ ) where++import Events.Events++import Events.Toggle++class Destroyable o where+ -- | Destroys an object+ destroy :: o -> IO ()++class Destroyable o => Destructible o where+ -- | An event which occurs when the object is destroyed.+ destroyed :: o -> Event ()++-- | doOnce can be used to produce an action which is identical+-- to its argument, except that if it\'s already been called, it+-- does nothing.+doOnce :: IO () -> IO (IO ())+doOnce action =+ do+ sToggle <- newSimpleToggle+ return (ifSimpleToggle sToggle action)
+ Events/EqGuard.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | Here we create a simple guarded queue which allows guarding by equality+-- according to an ordered key. Thus guards have three values,+-- match anything, match nothing, and match this value.+--+-- To simplify the implementation, we specify that an Eq match has higher+-- priority than a MatchAnything match, and when we must choose between+-- values for MatchAnything, do not necessarily choose the first+-- (more likely the one with the lowest key value). But we do respect+-- FIFO order when only Eq guards are involved.+module Events.EqGuard(+ EqGuardedChannel, -- the channel+ EqMatch(..), -- the guard.+ newEqGuardedChannel, -- construct a channel+ ) where++import Util.Computation++import Events.GuardedEvents+import Events.GuardedChannels+import Events.DeleteQueue+import Events.FMQueue++type EqGuardedChannel key value = GuardedChannel (EqMatch key) (key,value)++newEqGuardedChannel :: Ord key => IO (EqGuardedChannel key value)+newEqGuardedChannel =+ newEqGuardedChannelPrim (error "EqGuard.1") (error "EqGuard.2")++newEqGuardedChannelPrim :: Ord key => key -> value+ -> IO (EqGuardedChannel key value)+-- The arguments to newEqGuardedChannelPrim are not looked at, but+-- help us to avoid overloading woes.+newEqGuardedChannelPrim (_::key) (_ ::value) =+ newGuardedChannel (error "newEq1" :: (GQ (EqGuardQueue key) (key,value)))+ (error "newEq2" :: (VQ (EqValueQueue key value)))++-- --------------------------------------------------------------------+-- The Guard type+-- --------------------------------------------------------------------++data EqMatch key =+ Eq !key+ | EqMatchAny+ | EqMatchNone++instance Ord key => Guard (EqMatch key) where+ nullGuard = EqMatchAny++ andGuard EqMatchAny x = x+ andGuard EqMatchNone x = EqMatchNone+ andGuard x EqMatchAny = x+ andGuard x EqMatchNone = EqMatchNone+ andGuard (Eq key1) (Eq key2) =+ if key1 == key2 then Eq key1 else EqMatchNone++-- --------------------------------------------------------------------+-- The value queue.+-- --------------------------------------------------------------------++newtype Ord key => EqValueQueue key value valueCont =+ EqValueQueue (FMQueue key ((key,value),valueCont))++instance Ord key => HasEmpty (EqValueQueue key value) where+ newEmpty = return (EqValueQueue emptyFMQueue)++instance Ord key => HasAdd (EqValueQueue key value) (key,value) where+ add (EqValueQueue fmQueue) keyValue@(key,value) valueCont =+ do+ (fmQueue2,invalidate) <- addFMQueue fmQueue key (keyValue,valueCont)+ return (EqValueQueue fmQueue2,invalidate)++instance Ord key => HasRemove (EqValueQueue key value) (EqMatch key)+ (key,value) where+ remove (EqValueQueue fmQueue) EqMatchAny =+ do+ (removed,fmQueue0) <- removeFMQueueAny fmQueue+ case removed of+ Nothing -> return (Nothing,EqValueQueue fmQueue0)+ (Just (_,(keyValue,valueCont),fmQueue2)) ->+ return (Just(keyValue,valueCont,+ return (EqValueQueue fmQueue0)),+ EqValueQueue fmQueue2)+ remove (EqValueQueue fmQueue) (Eq key) =+ do+ (removed,fmQueue0) <- removeFMQueue fmQueue key+ case removed of+ Nothing -> return (Nothing,EqValueQueue fmQueue0)+ (Just ((keyValue,valueCont),fmQueue2)) ->+ return (Just(keyValue,valueCont,+ return (EqValueQueue fmQueue0)),+ EqValueQueue fmQueue2)++-- --------------------------------------------------------------------+-- The Guard Queue+-- --------------------------------------------------------------------++data Ord key => EqGuardQueue key guardCont =+ EqGuardQueue {+ matchAnys :: DeleteQueue guardCont,+ eqs :: FMQueue key guardCont+ }++instance Ord key => HasEmpty (EqGuardQueue key) where+ newEmpty = return (EqGuardQueue {+ matchAnys = emptyQueue,+ eqs = emptyFMQueue+ })++instance Ord key => HasAdd (EqGuardQueue key) (EqMatch key) where+ add guardQueue guard guardCont =+ case guard of+ Eq key ->+ do+ let fmQueue = eqs guardQueue+ (fmQueue2,invalidate) <- addFMQueue fmQueue key guardCont+ return (guardQueue {eqs = fmQueue2},invalidate)+ EqMatchAny ->+ do+ let deleteQueue = matchAnys guardQueue+ (deleteQueue2,invalidate) <- addQueue deleteQueue guardCont+ deleteQueue3 <- cleanQueue deleteQueue2+ return (guardQueue {matchAnys = deleteQueue2},invalidate)+ EqMatchNone -> return (guardQueue,done)++instance Ord key => HasRemove (EqGuardQueue key) (key,value) (EqMatch key) where+ remove guardQueue (key,_) =+ do+ removed <- removeFMQueue (eqs guardQueue) key+ case removed of+ (Just (guardCont,fmQueue2),fmQueue0) ->+ do+ let gq fmq = guardQueue {eqs = fmq}+ return (Just(Eq key,guardCont,return(gq fmQueue0)),+ gq fmQueue2)+ (Nothing,fmQueue0) ->+ do+ let+ mAs = matchAnys guardQueue+ gq dq = EqGuardQueue {matchAnys = dq,eqs = fmQueue0}+ removed2 <- removeQueue mAs+ case removed2 of+ Just (guardCont,dqueue2,dqueue0) ->+ return (Just (EqMatchAny,guardCont,+ return (gq dqueue0)),+ gq dqueue2)+ Nothing ->+ return (Nothing,gq mAs)
+ Events/Events.hs view
@@ -0,0 +1,433 @@+-- |+-- Description: Higher-order Events+--+-- 'Event's and combinators for them.+module Events.Events(+ Result(..),+ Event(..),+ -- The event type. Instance of HasEvent and Monad.+ HasEvent(..), -- things which can be lifted to an Event++ never, -- the event which never happens+ always, -- the event which always happens++ sync, poll, -- synchronises or polls an event+ (>>>=), (>>>), -- wraps Events+ (+>), -- choice between Events++ choose, -- chooses between many Events.+ tryEV, -- Replaces an event by one which checks for errors in the+ -- continuations.+ computeEvent, -- Allows you to compute the event with an IO action.+ wrapAbort,+ -- Allows you to specify pre- and post-registration actions.+ -- The post-registration action is executed when the pre-registration+ -- was, and some other event is registered.++ noWait, -- :: Event a -> Event ()+ -- Execute event asynchronously and immediately return.+ HasSend(..), -- overloaded send function+ HasReceive(..), -- overloaded receive function+ -- functions to send and receive without going via events.+ sendIO, -- :: HasSend chan => chan a -> a -> IO ()+ receiveIO, -- :: HasReceive chan => chan a -> IO a+++ allowWhile,+ -- :: Event () -> Event a -> Event a+ -- Allow one event to happen while waiting for another.++ Request(..),+ -- Datatype encapsulating server calls which get a delayed+ -- response.+ request,+ -- :: Request a b -> a -> IO b+ -- Simple use of Request.+ doRequest, -- :: Request a b -> a -> IO (Event b,IO ())+ -- More complicated use+ spawnEvent, -- :: Event () -> IO (IO ())+ -- spawnEvent syncs on the given event in a thread.+ -- the returned action should be executed to kill the thread.++ getAllQueued, -- :: Event a -> IO [a]+ -- getAllQueued synchronises on the event as much as possible+ -- without having to wait.++ -- Functions for monadic events. (Don't use these directly, they+ -- are only here so GHC can export the inlined versions of them . . .)+ thenGetEvent, -- :: Event a -> (a -> Event b) -> Event b+ thenEvent, -- :: Event a -> Event b -> Event b+ doneEvent, -- :: a -> Event a++ syncNoWait++ ) where++import Control.Exception+import Control.Concurrent++import Util.Computation++import Events.Toggle+import Events.Spawn++data Result = Immediate | Awaiting (IO ()) | AwaitingAlways (IO ())++-- ----------------------------------------------------------------------+-- Events and the HasEvent class.+-- ----------------------------------------------------------------------++newtype Event a = Event (Toggle -> (IO a -> IO ()) -> IO Result)+-- The function inside an Event registers that event for the synchronisation+-- associated with this toggle. The three results+-- can be interpreted as follows:+-- Immediate can occur in two cases. Either+-- (1) the event was immediately matched and we performed the provided+-- action fun with an action returning an a.+-- (2) the event was not immediately matched because someone else had+-- already flipped the toggle.+-- In both cases, the event is not registered after the function returns.+-- Awaiting action means that the event was registered.+-- The caller should always ensure that the action is executed after the+-- synchronisation has succeeded.+-- AwaitingAlways action means that the event must be done after the+-- synchronisation whether or not the action succeeds.++-- | HasEvent represents those event-like things which can be converted to+-- an event.+class HasEvent eventType where+ ---+ -- converts to an event.+ toEvent :: eventType a -> Event a++instance HasEvent Event where+ toEvent = id++-- ----------------------------------------------------------------------+-- Three trivial events.+-- ----------------------------------------------------------------------+++-- | The event that never happens+never :: Event a+never = Event (\ toggle aActSink -> return (Awaiting done))++-- | The event that always happens, immediately+always :: IO a -> Event a+always aAction = Event (+ \ toggle aActSink ->+ do+ ifToggle toggle (aActSink aAction)+ return Immediate+ )++-- ----------------------------------------------------------------------+-- Continuations+-- ----------------------------------------------------------------------++-- | Attach an action to be done after the event occurs.+(>>>=) :: Event a -> (a -> IO b) -> Event b+(>>>=) (Event registerFn) continuation = Event (+ \ toggle bActionSink ->+ registerFn toggle (+ \ aAction ->+ bActionSink (+ do+ a <- aAction+ continuation a+ )+ )+ )+infixl 2 >>>=++-- | Attach an action to be done after the event occurs.+(>>>) :: Event a -> IO b -> Event b+(>>>) event continuation = event >>>= (const continuation)+infixl 2 >>>++{-# INLINE (>>>) #-}++-- ----------------------------------------------------------------------+-- Choice+-- ----------------------------------------------------------------------++-- | Choose between two events. The first one takes priority.+(+>) :: Event a -> Event a -> Event a+(+>) (Event registerFn1) (Event registerFn2) = Event (+ \ toggle aActSink ->+ do+ status1 <- registerFn1 toggle aActSink+ let+ doSecond postAction1 =+ do+ let+ doThird postAction2 =return (AwaitingAlways (+ do+ postAction1+ postAction2+ ))+ status2 <- registerFn2 toggle aActSink+ case status2 of+ Immediate ->+ do+ postAction1+ return Immediate+ Awaiting postAction2 -> doThird postAction2+ AwaitingAlways postAction2 -> doThird postAction2+ case status1 of+ Immediate -> return Immediate+ Awaiting postAction1 -> doSecond postAction1+ AwaitingAlways postAction1 -> doSecond postAction1+ )++infixl 1 +>++-- | Choose between a list of events.+choose :: [Event a] -> Event a+choose [] = never+choose nonEmpty = foldr1 (+>) nonEmpty++-- ----------------------------------------------------------------------+-- Catching Errors+-- ----------------------------------------------------------------------++-- | Catch an error if it occurs during an action attached to an event.+tryEV :: Event a -> Event (Either Exception a)+tryEV (Event registerFn) = Event (+ \ toggle errorOraSink ->+ registerFn toggle (\ aAct ->+ errorOraSink (Control.Exception.try aAct)+ )+ )++-- ----------------------------------------------------------------------+-- Allowing an event to vary+-- ---------------------------------------------------------------------++-- | Construct a new event using an action which is called at each+-- synchronisation+computeEvent :: IO (Event a) -> Event a+computeEvent getEvent = Event (+ \ toggle aActSink ->+ do+ (Event registerFn) <- getEvent+ registerFn toggle aActSink+ )++-- ----------------------------------------------------------------------+-- Getting information about when an event is aborted.+-- ---------------------------------------------------------------------++-- | When we synchronise on wrapAbort preAction+-- preAction is evaluated to yield (event,postAction).+-- Then exactly one of the following:+-- (1) thr event is satisfied, and postAction is not done.+-- (2) some other event in this synchronisation is satisfied+-- (so this one isn\'t), and postAction is done.+-- (3) no event is satisfied (and so we will deadlock).+wrapAbort :: IO (Event a,IO ()) -> Event a+wrapAbort preAction =+ computeEvent (+ do+ postDone <- newSimpleToggle+ (Event registerFn,postAction) <- preAction+ let doAfter = ifSimpleToggle postDone postAction+ return (Event (+ \ toggle aActSink ->+ do+ status <- registerFn toggle+ (\ aAct ->+ do+ simpleToggle postDone+ aActSink aAct+ )+ case status of+ -- Even with Immediate we must do doAfter, as+ -- the toggle may have been flipped by someone else.+ Immediate -> (doAfter >> return Immediate)+ Awaiting action -> return (Awaiting (doAfter >> action))+ AwaitingAlways action ->+ return (AwaitingAlways (doAfter >> action))+ ))+ )++-- ----------------------------------------------------------------------+-- Synchronisation and Polling.+-- Sigh. Because GHC makes takeMVar/putMVar interruptible, I don't+-- know how to ensure that the postAction will get done if an+-- asynchronous exception is raised.+-- ---------------------------------------------------------------------++-- | Synchronise on an event, waiting on it until it happens, then returning+-- the attached value.+sync :: Event a -> IO a+sync (Event registerFn) =+ do+ toggle <- newToggle+ aActMVar <- newEmptyMVar+ status <- registerFn toggle (\ aAct -> putMVar aActMVar aAct)+ aAct <- takeMVar aActMVar+ case status of+ AwaitingAlways postAction -> postAction+ _ -> done+ aAct++-- | Synchronise on an event, but return immediately with Nothing if it+-- can\'t be satisfied at once.+poll :: Event a -> IO (Maybe a)+poll event =+ sync (+ (event >>>= (\ a -> return (Just a)))+ +> (always (return Nothing))+ )++-- ----------------------------------------------------------------------+-- The noWait combinator+-- ----------------------------------------------------------------------++-- | Turns an event into one which is always satisfied at once but registers+-- the value to be done later. WARNING - only to be used with events without+-- actions attached, as any actions will not get done. noWait is typically+-- used with send events, where we don\'t want to wait for someone to pick up+-- the value.+noWait :: Event a -> Event ()+noWait (Event registerFn) = Event (+ \ toggle unitActSink ->+ do+ ifToggle toggle (+ do+ toggle' <- newToggle+ registerFn toggle' (const done)+ unitActSink (return ())+ done+ )+ return Immediate+ )++-- | Register an event as synchronised but don\'t wait for it to complete.+-- WARNING - only to be used with events without+-- actions attached, as any actions will not get done. noWait is typically+-- used with send events, where we don\'t want to wait for someone to pick up+-- the value.+-- synchronise on something without waiting+syncNoWait :: Event a -> IO ()+syncNoWait (Event registerFn) =+ do+ toggle <- newToggle+ registerFn toggle (const done)+ done++{-# RULES+"syncNoWait" forall event . sync (noWait event) = syncNoWait event+"syncNoWait2"+ forall event continuation . sync ((noWait event) >>>= continuation) =+ (syncNoWait event >> continuation ())+ #-}+++-- ----------------------------------------------------------------------+-- The HasSend and HasReceive classes+-- ----------------------------------------------------------------------++-- | HasSend represents things like channels on which we can send values+class HasSend chan where+ ---+ -- Returns an event which corresponds to sending something on a channel.+ -- For a synchronous channel (most channels are synchronous) this event+ -- is not satisfied until someone accepts the value.+ send :: chan a -> a -> Event ()++-- | HasReceive represents things like channels from which we can take values.+class HasReceive chan where+ ---+ -- Returns an event which corresponds to something arriving on a channel.+ receive :: chan a -> Event a++-- Two handy abbreviations++-- | Send a value along a channel (as an IO action)+sendIO :: HasSend chan => chan a -> a -> IO ()+sendIO chan msg = sync (send chan msg)++-- | Get a value from a channel (as an IO action)+receiveIO :: HasReceive chan => chan a -> IO a+receiveIO chan = sync (receive chan)++-- ----------------------------------------------------------------------+-- Monadic Events+-- We include some extra GHC magic here, so that using "always"+-- in monadic events is not especially inefficient.+-- ----------------------------------------------------------------------++instance Monad Event where+ (>>=) = thenGetEvent+ (>>) = thenEvent+ return = doneEvent++ fail str = always (ioError (userError str))++thenGetEvent :: Event a -> (a -> Event b) -> Event b+thenGetEvent event1 getEvent2 = event1 >>>= (\ val -> sync(getEvent2 val))++thenEvent :: Event a -> Event b -> Event b+thenEvent event1 event2 = event1 >>> (sync(event2))++doneEvent :: a -> Event a+doneEvent val = always (return val)++{-# INLINE thenGetEvent #-}+{-# INLINE thenEvent #-}+{-# INLINE doneEvent #-}++-- Rules allowing us to use "always" in monadic events efficiently.+{-# RULES+"always1" forall action . sync (always action) = action+"always" forall action continuation .+ (>>>=) (always action) continuation = always (action >>= continuation)+ #-}++-- ----------------------------------------------------------------------+-- Other miscellaneous event functions.+-- ----------------------------------------------------------------------++-- | allowWhile event1 event2 waits for event2, while handling event1.+allowWhile :: Event () -> Event a -> Event a+allowWhile event1 event2 =+ event2+ +>(do+ event1+ allowWhile event1 event2+ )++data Request a b = Request (a -> IO (Event b,IO ()))+-- A Request operation represents a call to a server to evaluate+-- a function :: a->b. The Event b is activated with the result.+-- The client should call the supplied action if the event is+-- no longer needed.++request :: Request a b -> a -> IO b+request rq a =+ do+ (event,_) <- doRequest rq a+ sync event++doRequest :: Request a b -> a -> IO (Event b,IO ())+doRequest (Request rqFn) request = rqFn request++-- | Synchronise on an event in a different thread.+-- The kill action it returns is unsafe since it can cause deadlocks if+-- it occurs at an awkward moment. To avoid this use spawnEvent, if possible.+spawnEvent :: Event () -> IO (IO ())+spawnEvent reactor = spawn (sync reactor)++-- | get all we can get from the event without waiting.+getAllQueued :: Event a -> IO [a]+getAllQueued event = gAQ event []+ where+ gAQ event acc =+ do+ maybeA <- poll event+ case maybeA of+ Nothing -> return (reverse acc)+ Just a -> gAQ event (a:acc)+
+ Events/Examples.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | Examples is meant to contain examples of using events which+-- are too small to go into their own module.+module Events.Examples(+ EventSet, -- These encode a set of events+ emptyEventSet, -- :: EventSet a+ addToEventSet, -- :: EventSet a -> Event a -> EventSet a+ fromEventSet, -- :: EventSet a -> Event (a,EventSet a)+ isEmptyEventSet, -- :: EventSet a -> Bool++ watch, -- :: Event a -> IO (Event a,IO ())+ -- watch is used for events which can be dropped occasionally.+++ spawnRepeatedEvent, -- :: Event () -> IO (IO ())+ -- spawnRepeatedEvent concurrently syncs on the event until the+ -- given action is used; it is somewhat safer than spawnEvent.++ ) where++import qualified Data.IntMap as IntMap++import Events.Events+import Events.Channels++-- ------------------------------------------------------------------+-- Event Sets+-- ------------------------------------------------------------------++data EventSet a = EventSet Int (IntMap.IntMap (Event a))++emptyEventSet :: EventSet a+emptyEventSet = EventSet 0 IntMap.empty++addToEventSet :: EventSet a -> Event a -> EventSet a+addToEventSet (EventSet next fmap) event =+ EventSet (next+1) (IntMap.insert next event fmap)++fromEventSet :: EventSet a -> Event (a,EventSet a)+-- fromEventSet turns the event set into an event which+-- waits for one of the events to happen, and then returns+-- the value, plus the event set containing the remaining events.+fromEventSet (EventSet next fmap) =+ choose+ (map+ (\ (key,event) ->+ event >>>=+ (\ a -> return (a,EventSet next (IntMap.delete key fmap)))+ )+ (IntMap.toList fmap)+ )++isEmptyEventSet :: EventSet a -> Bool+isEmptyEventSet (EventSet _ fmap) = IntMap.null fmap++-- ------------------------------------------------------------------+-- Watchers+-- ------------------------------------------------------------------++-- | watch is used for events like mouse motion events where+-- if we can\'t find time we don\'t want them queued.+-- The event returned waits until the original event next happens and+-- returns it. A worker thread is needed to run this; the attached action+-- should be used to stop that thread when we are no longer interested.+watch :: Event a -> IO (Event a,IO ())+watch (event :: Event a) =+ do+ channel <- newChannel+ dieChannel <- newChannel+ let+ die = receive dieChannel++ waitForNext :: Event ()+ waitForNext =+ do+ next <- event+ passOn next+ +> die+ passOn :: a -> Event ()+ passOn val =+ waitForNext+ +> (do+ send channel val+ waitForNext+ )+ +> die++ _ <- spawnEvent waitForNext++ return (receive channel,sync(send dieChannel ()))+++-- | spawnRepeatedEvent concurrently syncs on the event until the+-- given action is used; it is somewhat safer than spawnEvent.+-- It also never interrupts the handler event attached to+-- the event.+spawnRepeatedEvent :: Event () -> IO (IO ())+spawnRepeatedEvent event =+ do+ dieChannel <- newChannel+ let++ die = receive dieChannel++ handleEvent =+ die+ +> (do+ event+ handleEvent+ )+ _ <- spawnEvent handleEvent+ return (sync(noWait(send dieChannel ())))+++
+ Events/FMQueue.hs view
@@ -0,0 +1,110 @@+-- | FMQueue handles finite maps of delete queues, so that we+-- can implement EqGuard.+module Events.FMQueue(+ FMQueue,+ emptyFMQueue,+ -- :: FMQueue key contents+ addFMQueue,+ -- :: Ord key => FMQueue key contents -> key -> contents ->+ -- IO (FMQueue key contents,IO ())+ -- adds an item, returning the new queue and an invalidate action.+ removeFMQueue,+ -- :: Ord key => FMQueue key contents -> key ->+ -- IO (Maybe (contents,FMQueue key contents),FMQueue key contents)+ removeFMQueueAny+ -- :: Ord key => FMQueue key contents ->+ -- IO (Maybe (key,contents,FMQueue key contents),FMQueue key contents)+ ) where++import qualified Data.Map as Map++import Events.DeleteQueue++data Ord key => FMQueue key contents =+ FMQueue {+ dqMap :: Map.Map key (DeleteQueue contents),+ cleanList :: [key]+ -- To clear out the map, we go through the keys in cleanList+ -- each time we add an item, and check for empty deleteQueues.+ }++emptyFMQueue :: Ord key => FMQueue key contents+emptyFMQueue = FMQueue {+ dqMap = Map.empty,+ cleanList = []+ }++addFMQueue :: Ord key => FMQueue key contents -> key -> contents ->+ IO (FMQueue key contents,IO ())+addFMQueue fmQueue key contents =+ do+ let+ fmMap = (dqMap fmQueue)+ deleteQueue = Map.findWithDefault emptyQueue key fmMap+ (deleteQueue2,invalidate) <-+ addQueue deleteQueue contents+ let+ fmMap2 = Map.insert key deleteQueue2 fmMap+ fmQueue2 = fmQueue {dqMap = fmMap2}+ fmQueue3 <- doClean fmQueue2+ return (fmQueue3,invalidate)++removeFMQueue :: Ord key => FMQueue key contents -> key ->+ IO (Maybe (contents,FMQueue key contents),FMQueue key contents)+ -- The last returned item is the queue WITHOUT an item removed.+removeFMQueue fmQueue key=+ do+ let fmMap = dqMap fmQueue+ case Map.lookup key fmMap of+ Nothing -> return (Nothing,fmQueue)+ Just deleteQueue ->+ do+ pop <- removeQueue deleteQueue+ case pop of+ Nothing ->+ return (Nothing,fmQueue {dqMap = Map.delete key fmMap})+ Just (contents,deleteQueue2,deleteQueue0) ->+ do+ let updateQueue queue =+ fmQueue {dqMap = Map.insert key queue fmMap}+ return (Just (contents,updateQueue deleteQueue2),+ updateQueue deleteQueue0)++removeFMQueueAny :: Ord key => FMQueue key contents ->+ IO (Maybe (key,contents,FMQueue key contents),FMQueue key contents)+ -- Like removeFMQueue, but matches any key, and returns it.+removeFMQueueAny fmQueue =+ let+ keyContents = Map.keys (dqMap fmQueue)+ in+ doRemove fmQueue keyContents+ where+ doRemove fmQueue [] = return (Nothing,emptyFMQueue)+ doRemove fmQueue (key:keys) =+ do+ tryRemove <- removeFMQueue fmQueue key+ case tryRemove of+ (Nothing,fmQueue0) -> doRemove fmQueue0 keys+ (Just (contents,fmQueue2),fmQueue0) ->+ return (Just(key,contents,fmQueue2),fmQueue0)++doClean :: Ord key => FMQueue key contents -> IO (FMQueue key contents)+doClean fmQueue =+ case cleanList fmQueue of+ [] ->+ return (fmQueue {cleanList = Map.keys (dqMap fmQueue)})+ toClean:nextCleanList ->+ do+ let fmMap = dqMap fmQueue+ nextMap <- case Map.lookup toClean fmMap of+ Nothing -> return fmMap+ Just deleteQueue ->+ do+ isEmpty <- isEmptyQueue deleteQueue+ case isEmpty of+ Nothing -> return (Map.delete toClean fmMap)+ Just cleaned -> return (Map.insert toClean cleaned fmMap)+ return (FMQueue {+ dqMap = nextMap,+ cleanList = nextCleanList+ })
+ Events/GuardedChannels.hs view
@@ -0,0 +1,318 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++-- | GuardedEvents implements guarded events for channels.+module Events.GuardedChannels(+ GuardedChannel,+ -- parameterised on the guard and the value,+ --+ -- instance of HasSend, HasListen (and hence automatically HasReceive)++ GQ,VQ, -- Type abbreviations, used in the next declaration.+ newGuardedChannel,+ -- :: HasGuardedChannel guardQueue valueQueue guard value+ -- => GQ guardQueue value -> VQ valueQueue+ -- IO GuardedChannel guard value+ -- the guardQueue and valueQueue are not read, and just provide+ -- the types to use.++ sneak,+ -- :: ( .. context .. )+ -- => GuardedChannel guard value+ -- -> GuardedEvent guard (Maybe value)+ replace,+ -- :: ( .. context .. )+ -- => GuardedChannel guard value -> value+ -- -> GuardedEvent guard (Maybe value)++ -- Classes the user should instance to construct different sorts of+ -- queue. Actually you only need to instance HasEmpty, HasRemove and+ -- HasAdd, since the others just+ HasEmpty(..),+ HasRemove(..),+ HasAdd(..),++ CanSendX,+ HasGuardedChannel,+ ) where++import Control.Concurrent++import Util.Computation (done)++import Events.Toggle++import Events.Events+import Events.GuardedEvents++-- ---------------------------------------------------------------+-- Guarded Channels and their creation.+-- ---------------------------------------------------------------++data GuardedChannel guard value =+ forall guardQueue valueQueue .+ HasGuardedChannel guardQueue valueQueue guard value+ => GuardedChannel (MVar (Contents guardQueue valueQueue value))++data Contents guardQueue valueQueue value =+ Contents !(guardQueue (GuardInfo value)) !(valueQueue ValueInfo)++-- GuardInfo and ValueInfo give toggles + continuations+type GuardInfo value = ToggledData (IO value -> IO ())+type ValueInfo = ToggledData (IO () -> IO ())++type GQ guardQueue value = guardQueue (GuardInfo value)+type VQ valueQueue = valueQueue ValueInfo++newGuardedChannel :: HasGuardedChannel guardQueue valueQueue guard value+ => GQ guardQueue value -> VQ valueQueue+ -> IO (GuardedChannel guard value)+newGuardedChannel+ (_ :: guardQueue (GuardInfo value)) (_ :: valueQueue ValueInfo) =+ do+ (emptyGuardQueue :: guardQueue (GuardInfo value)) <- newEmpty+ (emptyValueQueue :: valueQueue ValueInfo) <- newEmpty+ mVar <- newMVar (Contents emptyGuardQueue emptyValueQueue)+ return (GuardedChannel mVar)++-- ---------------------------------------------------------------+-- Implementing the channel events+-- ---------------------------------------------------------------++instance HasListen GuardedChannel where+ listen (GuardedChannel mVar) =+ GuardedEvent+ (\ guard -> Event (+ \ toggle guardContinuation ->+ do+ (Contents guardQueue valueQueue) <- takeMVar mVar+ (guardQueue2,valueQueue2,sendResult) <- sendX+ guardQueue valueQueue toggle guard guardContinuation+ putMVar mVar (Contents guardQueue2 valueQueue2)+ -- Now perform the continuations if any and return.+ case sendResult of+ Anticipated -> return Immediate+ Queued invalidate -> return (Awaiting invalidate)+ Matched value valueContinuation ->+ do+ valueContinuation (return ())+ guardContinuation (return value)+ return Immediate+ )+ )+ nullGuard++instance Guard guard => HasReceive (GuardedChannel guard) where+ receive = toEvent . listen++instance HasSend (GuardedChannel guard) where+ send (GuardedChannel mVar :: GuardedChannel guard value)+ (value :: value) =+ Event (+ \ toggle valueContinuation ->+ do+ (Contents guardQueue valueQueue) <- takeMVar mVar+ (valueQueue2,guardQueue2,sendResult)+ <- sendX valueQueue guardQueue toggle value valueContinuation+ putMVar mVar (Contents guardQueue2 valueQueue2)+ -- Now perform the continuations if any and return.+ case sendResult of+ Anticipated -> return Immediate+ Queued invalidate -> return (Awaiting invalidate)+ Matched (guard :: guard) guardContinuation ->+ do+ valueContinuation (return ())+ guardContinuation (return value)+ return Immediate+ )++atomicUpdate :: Guard guard => (value -> value) -> GuardedChannel guard value+ -> GuardedEvent guard (Maybe value)+-- atomicUpdate updateFn+-- is like listen except (a) it doesn't wait, instead returning+-- Nothing if it can't match immediately; (b) if it can match immediately,+-- it computes a new value and puts it back into the queue (at the end),+-- without leaving a gap, so that even if someone attempts to poll the+-- channel at this moment they won't see a point when it's empty;+-- it also returns the original value.+atomicUpdate updateFn (GuardedChannel mVar :: GuardedChannel guard value) =+ GuardedEvent (+ \ (guard :: guard) -> Event (+ \ toggle guardContinuation ->+ do+ (Contents guardQueue valueQueue) <- takeMVar mVar+ (guardQueue2,valueQueue2,+ sendResult :: (SendResult value (IO () -> IO ())))+ <- sendX guardQueue valueQueue toggle guard+ (\ valueAct -> guardContinuation+ (valueAct >>= (return . Just)))+ case sendResult of+ Anticipated ->+ do+ putMVar mVar (Contents guardQueue2 valueQueue2)+ return Immediate+ Queued invalidate ->+ do+ putMVar mVar (Contents guardQueue2 valueQueue2)+ -- force the event to happen anyway+ resultNothing <- toggle1 toggle+ if resultNothing+ then+ do+ invalidate+ guardContinuation (return Nothing)+ else+ done+ return Immediate+ Matched value valueContinuation ->+ do+ let newValue = updateFn value+ toggle' <- newToggle+ (valueQueue3,guardQueue3,+ sendResult :: SendResult guard (IO value -> IO()))+ <- sendX valueQueue2 guardQueue2 toggle' newValue+ (\ _ -> return ())+ putMVar mVar (Contents guardQueue3 valueQueue3)+ -- execute all the continuations we have, and return.+ valueContinuation (return ())+ guardContinuation (return (Just value))+ case sendResult of+ Queued invalidate -> return Immediate+ -- We never invalidate this event.+ Matched (guard :: guard) guardContinuation ->+ do+ guardContinuation (return newValue)+ return Immediate+ -- Anticipated should be impossible here.+ )+ )+ nullGuard++++sneak :: Guard guard => GuardedChannel guard value+ -> GuardedEvent guard (Maybe value)+sneak guardedChannel = atomicUpdate id guardedChannel++replace :: Guard guard => GuardedChannel guard value -> value+ -> GuardedEvent guard (Maybe value)+replace guardedChannel newValue = atomicUpdate (const newValue) guardedChannel++-- ---------------------------------------------------------------+-- The classes the user should instance.+-- ---------------------------------------------------------------++class HasEmpty xQueue where+ newEmpty :: IO (xQueue xData)++class HasRemove yQueue x y where+ remove :: yQueue yData -> x ->+ IO (Maybe (y,yData,IO (yQueue yData)),yQueue yData)+ -- remove yQueue x attempts to match an x with a value in yQueue.+ -- It returns a pair.+ -- If there is no match, we get (Nothing,newQueue)+ -- If there is a match, we get (Just(y,yData,restoreQueue),newQueue)+ -- where newQueue is the queue with the match removed, and+ -- restoreQueue is an action which restores the queue to the way it+ -- was before.++class HasAdd xQueue x where+ add :: xQueue xData -> x -> xData -> IO (xQueue xData,IO ())++class (HasRemove yQueue x y,HasAdd xQueue x) =>+ CanSendX xQueue yQueue x y++instance (HasRemove yQueue x y,HasAdd xQueue x) =>+ CanSendX xQueue yQueue x y++class (Guard guard,HasEmpty guardQueue,HasEmpty valueQueue,+ CanSendX guardQueue valueQueue guard value,+ CanSendX valueQueue guardQueue value guard)+ => HasGuardedChannel guardQueue valueQueue guard value++instance (Guard guard,HasEmpty guardQueue,HasEmpty valueQueue,+ CanSendX guardQueue valueQueue guard value,+ CanSendX valueQueue guardQueue value guard)+ => HasGuardedChannel guardQueue valueQueue guard value++-- ---------------------------------------------------------------+-- Implementing searching for matching events.+-- ---------------------------------------------------------------++data ToggledData continuation = ToggledData !Toggle continuation++data SendResult y yContinuation =+ Matched y yContinuation+ -- the event has been matched with this y + Continuation.+ | Queued (IO ())+ -- the event has been queued; the supplied action may be used to+ -- cancel it, once the toggle for this synchronisation has been+ -- toggled by someone.+ | Anticipated+ -- The toggle for the synchronisation has already been toggled by+ -- someone else.++sendX :: (CanSendX xQueue yQueue x y)+ => xQueue (ToggledData xContinuation) -> yQueue (ToggledData yContinuation)+ -> Toggle -> x -> xContinuation+ -> IO (xQueue (ToggledData xContinuation),+ yQueue (ToggledData yContinuation),(SendResult y yContinuation))+sendX xQueue yQueue xToggle x xContinuation =+ do+ (match,yQueue2) <- remove yQueue x+ case match of+ Nothing ->+ -- no matching event. Add x to xQueue.+ do+ (xQueue2,invalidate) <-+ add xQueue x (ToggledData xToggle xContinuation)++ return (xQueue2,yQueue2,Queued invalidate)+ Just (y,ToggledData yToggle yContinuation,getYQueue0) ->+ -- matching event found. Attempt to handle it+ do+ toggled <- toggle2 xToggle yToggle+ case toggled of+ Nothing -> -- toggle successful+ return (xQueue,yQueue2,Matched y yContinuation)+ Just (True,False) ->+ -- toggle failed because the matching event has been+ -- done. Repeat with remaining queue.+ sendX xQueue yQueue2 xToggle x xContinuation+ Just (False,True) ->+ -- toggle failed because the event we are synchronising+ -- on has been done. So put the item back on the yQueue+ -- and return+ do+ yQueue0 <- getYQueue0+ return (xQueue,yQueue0,Anticipated)+ Just (False,False) ->+ -- both of the above . . .+ return (xQueue,yQueue2,Anticipated)+ Just (True,True) ->+ -- toggle failed because we are synchronising+ -- a send and listen operation on the same channel.+ do+ (matchRest @ (xQueue3,yQueue3,success)) <-+ sendX xQueue yQueue2 xToggle x xContinuation+ case success of+ Queued _ ->+ -- the xToggle event was added to xQueue3,+ -- so put the event we just rejected back on+ -- the yQueue+ do+ yQueue0 <- getYQueue0+ return (xQueue3,yQueue0,success)+ _ ->+ -- Otherwise the containing synchronisation has+ -- been satisfied, and thus the original matched+ -- event, which is also part of that+ -- synchronisation, can be thrown away. This is+ -- good, because otherwise I don't know what+ -- we'd do with it.+ return matchRest++
+ Events/GuardedEvents.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}++-- | In GuardedEvents we extend the notion of PrimEvents to allow Guarded+-- Events, which can be guarded with the new (|>) operator. GuardedChannels+-- will implement guarded events on channels, which will hopefully be the+-- only guarded event we will ever need.+module Events.GuardedEvents(+ GuardedEvent(..),+ -- the datatype of guarded events. Instance of HasGuard,+ -- IsBaseEvent (and hence IsEvent), HasContinuation, HasChoice+ --+ HasGuard(..), -- the class implementing |>+ Guard(..), -- the class of guards.++ HasListen(..), -- the class of (guarded) channels implementing listen.+ ) where++import Events.Events++-- | A GuardedEvent guard a represents a source of values of type a, which+-- may be selected from according to guards of type guard.+data Guard guard => GuardedEvent guard a =+ GuardedEvent !(guard -> Event a) !guard++-- ----------------------------------------------------------------------+-- The Guard class+-- ----------------------------------------------------------------------++-- | A Guard represents some condition on a value which we impose on+-- a channel, selecting those values we are interested in.+class Guard guard where+ -- NB. Instances of this class should try to force evaluation as+ -- much as possible before returning the guard value, because+ -- otherwise it has to be done while the channel is locked to+ -- everyone else.++ -- | this should be the guard that always matches+ nullGuard :: guard++ -- | this should be the guard that corresponds to the conjunction+ -- of the two given guards.+ andGuard :: guard -> guard -> guard++-- ----------------------------------------------------------------------+-- The HasGuard class+-- ----------------------------------------------------------------------++infixr 2 |>+-- So higher precedence than >>>/>>>= or +>+++class Guard guard => HasGuard eventType guard where+ ---+ -- Qualify an event source by a guard.+ (|>) :: eventType a -> guard -> eventType a++-- ----------------------------------------------------------------------+-- The HasListen class+-- ----------------------------------------------------------------------++-- | Class of those channels which have guarded events.+class HasListen chan where+ ---+ -- Generate a guarded event from a channel (which may then be+ -- synchronised on, or qualified using |>+ listen :: Guard guard => chan guard a -> GuardedEvent guard a++-- ----------------------------------------------------------------------+-- Instances+-- ----------------------------------------------------------------------++instance Guard guard => HasGuard (GuardedEvent guard) guard where+ (|>) (GuardedEvent getEvent guard1) guard2 =+ GuardedEvent getEvent (guard2 `andGuard` guard1)++instance Guard guard => HasEvent (GuardedEvent guard) where+ toEvent (GuardedEvent getEvent guard) = getEvent guard+
+ Events/NullGuard.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}++-- | Here we implement a null guard channel that provides no guards,+-- but is hopefully useful as an example.+module Events.NullGuard (+ NullGuardedChannel,+ newNullGuardedChannel+ ) where++import Events.GuardedEvents+import Events.GuardedChannels+import Events.DeleteQueue++++type NullGuardedChannel value = GuardedChannel () value++newNullGuardedChannel :: IO (NullGuardedChannel value)+newNullGuardedChannel = newNullGuardedChannelPrim (error "newNull")++-- The argument to newNullGuardedChannelPrim is not looked at,+-- but helps us to avoid overloading woes.+newNullGuardedChannelPrim :: value -> IO (NullGuardedChannel value)+newNullGuardedChannelPrim (_ :: value) =+ newGuardedChannel (error "newNull1" :: (GQ NullGuardQueue value))+ (error "newNull2" :: (VQ (NullValueQueue value)))+++-- --------------------------------------------------------------------+-- The Guard type+-- --------------------------------------------------------------------++instance Guard () where+ nullGuard = ()+ andGuard _ _ = ()++-- --------------------------------------------------------------------+-- The Value Queue.+-- --------------------------------------------------------------------++data NullValueQueue value valueCont =+ NullValueQueue (DeleteQueue (value,valueCont))++emptyNullValueQueue :: NullValueQueue value a+emptyNullValueQueue = NullValueQueue emptyQueue++instance HasEmpty (NullValueQueue value) where+ newEmpty = return emptyNullValueQueue++instance HasAdd (NullValueQueue value) value where+ add (NullValueQueue deleteQueue) value valueCont =+ do+ (deleteQueue2,invalidate) <- addQueue deleteQueue (value,valueCont)+ return (NullValueQueue deleteQueue2,invalidate)++instance HasRemove (NullValueQueue value) () value where+ remove (NullValueQueue deleteQueue) () =+ do+ removed <- removeQueue deleteQueue+ case removed of+ Nothing -> return (Nothing,emptyNullValueQueue)+ Just ((value,valueCont),deleteQueue2,deleteQueue0) ->+ return (Just(value,valueCont,+ return (NullValueQueue deleteQueue0)),+ NullValueQueue deleteQueue2)+-- --------------------------------------------------------------------+-- The Guard Queue+-- --------------------------------------------------------------------++data NullGuardQueue guardCont = NullGuardQueue (DeleteQueue guardCont)++emptyNullGuardQueue :: NullGuardQueue a+emptyNullGuardQueue = NullGuardQueue emptyQueue++instance HasEmpty NullGuardQueue where+ newEmpty = return emptyNullGuardQueue++instance HasAdd NullGuardQueue () where+ add (NullGuardQueue deleteQueue) () guardCont =+ do+ (deleteQueue2,invalidate) <- addQueue deleteQueue guardCont+ deleteQueue3 <- cleanQueue deleteQueue2+ return (NullGuardQueue deleteQueue3,invalidate)++instance HasRemove NullGuardQueue value () where+ remove (NullGuardQueue deleteQueue) value =+ do+ removed <- removeQueue deleteQueue+ case removed of+ Nothing -> return (Nothing,emptyNullGuardQueue)+ Just (guardCont,deleteQueue2,deleteQueue0) ->+ return (Just((),guardCont,+ return (NullGuardQueue deleteQueue0)),+ NullGuardQueue deleteQueue2)+++
+ Events/RefQueue.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | RefQueue are standard non-functional+-- queues using pointers (aka IORefs). Events can be deleted asynchronously,+-- but this is done only by nulling the cell they are contained in, otherwise+-- we would need to double-link. Other operations, IE the push and pop+-- function must not occur on the same queue concurrently.+--+-- Although the queues are impure, we return the new queue to be used+-- in future after push and search operations.+--+-- RefQueue are intended for use for queues of guarded strings,+-- hence the specialised implementation.+module Events.RefQueue(+ RefQueue,+ newRefQueue, -- :: IO (RefQueue a)+ pushRefQueue, -- :: RefQueue a -> a -> IO (RefQueue a,IO ())+ -- place an item on the queue. The action argument deletes tje+ -- item.+ searchRefQueue, -- :: RefQueue a -> (a -> Bool) ->+ -- IO (Maybe (a,IO (RefQueue a)),RefQueue a)+ -- searchRefQueue searchs a queue from the front+ -- for an item matching the given condition. If returns (second+ -- argument) the new queue with (if the item was found) the item+ -- deleted. The first argument then contains a and a RefQueue+ -- which puts a back in the queue where it was PROVIDED THAT+ -- no operations were done on the queue inbetween except+ -- for pushRefQueue, action arguments returned from it, and+ -- searchRefQueue with the same function as the one provided.+ ) where+++import Data.IORef++import Util.Computation(done)++import Events.Cells++type ListPtr a = IORef (Maybe (ListItem a))++data ListItem a = ListItem ! (Cell a) ! (ListPtr a)++data RefQueue a = RefQueue {+ front :: ! (ListPtr a),+ backRef :: ! (IORef (ListPtr a)),+ sinceClean :: ! Int+ }++newRefQueue :: IO (RefQueue a)+newRefQueue =+ do+ ioRef <- newIORef Nothing+ backRef <- newIORef ioRef+ return (RefQueue {front = ioRef,backRef = backRef,sinceClean = 0})++pushRefQueue :: RefQueue a -> a -> IO (RefQueue a,IO ())+pushRefQueue (refQueue@RefQueue {backRef = backRef,sinceClean = sinceClean})+ val =+ do+ cell <- newCell val+ newBack <- newIORef Nothing+ oldBack <- readIORef backRef+ writeIORef oldBack (Just (ListItem cell newBack))+ writeIORef backRef newBack+ let+ refQueue2 = refQueue {sinceClean = sinceClean+1}+ refQueue3 <- if sinceClean >= 10+ then+ do+ (cleanedQueue,_) <- cleanRefQueue refQueue2+ return cleanedQueue+ else+ return refQueue2+ return (refQueue3,emptyCell cell)+{-# INLINE pushRefQueue #-}++searchRefQueue :: RefQueue a -> (a -> Bool)+ -> IO (Maybe (a,IO (RefQueue a)),RefQueue a)+searchRefQueue (refQueue :: RefQueue a) (filter :: a -> Bool) =+ do+ (refQueue2,listItem') <- cleanRefQueue refQueue+ case listItem' of+ Nothing -> return (Nothing,refQueue2)+ Just listItem ->+ do+ valFound' <- searchPtr (front refQueue2) listItem+ let+ valAndAct' = fmap+ (\ (b,act) -> (b,(act >> return refQueue2)))+ valFound'+ return (valAndAct',refQueue2)+ where+ switchBack :: ListPtr a -> ListPtr a -> IO ()+ -- switchBack oldPtr newPtr indicates that a cell has+ -- just moved from oldPtr to newPtr, and updates backRef+ -- if necessary+ switchBack oldPtr newPtr =+ do+ oldBack <- readIORef (backRef refQueue)+ if (oldBack == oldPtr)+ then+ writeIORef (backRef refQueue) newPtr+ else+ done++ searchPtr :: ListPtr a -> ListItem a+ -> IO (Maybe (a,IO ()))+ -- The second argument is (Just ptr) to make ptr the new+ -- backref.+ searchPtr ptr (listItem0 @ (ListItem cell next)) =+ do+ cellContents <- inspectCell cell+ case cellContents of+ Nothing ->+ do+ -- Unlink this item from the list+ listItem' <- readIORef next+ writeIORef ptr listItem'+ switchBack next ptr+ case listItem' of+ Nothing -> return Nothing+ Just listItem -> searchPtr next listItem+ Just a ->+ do+ if filter a+ then+ do+ -- Unlink this item from the list+ listItem' <- readIORef next+ writeIORef ptr listItem'+ switchBack next ptr+ let+ relink =+ do+ switchBack ptr next+ writeIORef ptr (Just listItem0)+ return (Just(a,relink))+ else+ do+ listItem' <- readIORef next+ case listItem' of+ Nothing -> return Nothing+ Just listItem -> searchPtr next listItem+{-# INLINE searchRefQueue #-}++cleanRefQueue :: RefQueue a -> IO (RefQueue a,Maybe (ListItem a))+-- cleanRefQueue cleans items from the front of the queue, and returns+-- the front list element, if any.+cleanRefQueue refQueue =+ do+ (newFront,listItem') <- cleanQueue (front refQueue)+ return (refQueue {front = newFront,sinceClean=0},listItem')+ where+ cleanQueue :: ListPtr a -> IO (ListPtr a,Maybe (ListItem a))+ cleanQueue ptr =+ do+ contents <- readIORef ptr+ case contents of+ Nothing -> return (ptr,Nothing)+ Just (listItem @ (ListItem cell next)) ->+ do+ cellContents <- inspectCell cell+ case cellContents of+ Nothing -> cleanQueue next+ Just _ -> return (ptr,Just listItem)++
+ Events/Spawn.hs view
@@ -0,0 +1,40 @@+-- | Spawn provides an interface to Concurrent.forkIO which is supposed+-- to be implementable for both Hugs and GHC.+--+-- This is the GHC implementation.+module Events.Spawn(+ spawn -- :: IO () -> IO (IO ())+ ) where++import Control.Concurrent+import Control.Exception++-- | Do a fork, returning an action which may attempt to+-- kill the forked thread. (Or may not . . .)+spawn :: IO () -> IO (IO ())+spawn action =+ do+ let quietAction = goesQuietly action+ threadId <- forkIO quietAction+ return (killThread threadId)+++-- --------------------------------------------------------------------------+-- goesQuietly+-- --------------------------------------------------------------------------++goesQuietly :: IO () -> IO ()+goesQuietly action =+ do+ result <-+ tryJust+ (\ exception -> case exception of+ AsyncException ThreadKilled -> Just ()+ BlockedOnDeadMVar -> Just ()+ _ -> Nothing+ )+ action+ case result of+ Left () -> return ()+ Right () -> return ()+
+ Events/Synchronized.hs view
@@ -0,0 +1,9 @@+module Events.Synchronized (++ Synchronized(..)++) where++class Synchronized a where+ -- | acquire lock on a, and while we\'ve got it do this action.+ synchronize :: a -> IO b -> IO b
+ Events/Toggle.hs view
@@ -0,0 +1,136 @@+-- | A toggle is a switch initially True, which can only be made false+-- (when some action is performed, say). This module implements+-- toggles, allowing atomic switching to false of 1 toggle, or+-- 2 toggles together. To avoid deadlock we use a supply of unique+-- integers.+module Events.Toggle(+ Toggle, -- toggle type+ newToggle, -- create a new toggle+ toggle1, -- set the toggle to false, and return the original value.+ toggle2, -- if toggles are both true, change them to false, otherwise+ -- leave the toggle settings unchanged and return them.+ ifToggle, -- :: Toggle -> IO () -> IO ()+ -- If the toggle is true, change it to false and execute action.+ peekToggle, -- :: Toggle -> IO Bool+ -- peek at the contents of a toggle, without changing it.++ SimpleToggle, -- A simple toggle. We can only flip these one at a time.+ newSimpleToggle, -- create a new simple toggle+ simpleToggle, -- set this toggle to false, and return the original value.+ ifSimpleToggle, -- like ifToggle+ ) where++import Control.Concurrent++import Util.Computation+import Util.Object++-- ----------------------------------------------------------------------+-- Simple Toggles+-- ----------------------------------------------------------------------++newtype SimpleToggle = SimpleToggle (MVar Bool)++newSimpleToggle :: IO SimpleToggle+newSimpleToggle =+ do+ mVar <- newMVar True+ return (SimpleToggle mVar)++simpleToggle :: SimpleToggle -> IO Bool+simpleToggle (SimpleToggle mVar) =+ do+ oldVal <- takeMVar mVar+ putMVar mVar False+ return oldVal++ifSimpleToggle :: SimpleToggle -> IO () -> IO ()+ifSimpleToggle sToggle action =+ do+ goAhead <- simpleToggle sToggle+ if goAhead then action else done++-- simpleToggle2 is not safe from deadlocks+simpleToggle2 :: SimpleToggle -> SimpleToggle -> IO (Maybe (Bool,Bool))+simpleToggle2 (SimpleToggle mVar1) (SimpleToggle mVar2) =+ do+ oldVal1 <- takeMVar mVar1+ oldVal2 <- takeMVar mVar2+ if (oldVal1 && oldVal2)+ then+ do+ putMVar mVar2 False+ putMVar mVar1 False+ return Nothing+ else+ do+ putMVar mVar2 oldVal2+ putMVar mVar1 oldVal1+ return (Just (oldVal1,oldVal2))+++-- peekSimpleToggle is used by toggle2+peekSimpleToggle :: SimpleToggle -> IO Bool+peekSimpleToggle (SimpleToggle mVar) = readMVar mVar++-- ----------------------------------------------------------------------+-- Toggles+-- ----------------------------------------------------------------------++data Toggle = Toggle !ObjectID !SimpleToggle++newToggle :: IO Toggle+newToggle =+ do+ uniqVal <- newObject+ stoggle <- newSimpleToggle+ return (Toggle uniqVal stoggle)++toggle1 :: Toggle -> IO Bool+-- switch bool to false, returning original value.+toggle1 (Toggle _ stoggle) = simpleToggle stoggle++ifToggle :: Toggle -> IO () -> IO ()+ifToggle toggle action =+ do+ goAhead <- toggle1 toggle+ if goAhead then action else done++toggle2 :: Toggle -> Toggle -> IO(Maybe(Bool,Bool))+-- Switch both toggles to from True to False, atomically, if possible.+-- If we can't do this, return Just (the current status of the toggles).+toggle2 (Toggle unique1 stoggle1) (Toggle unique2 stoggle2) =+ case compare unique1 unique2 of+ LT -> simpleToggle2 stoggle1 stoggle2+ GT ->+ do+ result <- simpleToggle2 stoggle2 stoggle1+ case result of+ Nothing -> return Nothing+ Just (r1,r2) -> return (Just (r2,r1))+ EQ ->+ do+ r <- peekSimpleToggle stoggle1+ return (Just (r,r))++-- peekToggle is used in Channels.hs to avoid a memory leak.+peekToggle :: Toggle -> IO Bool+peekToggle (Toggle _ sToggle) = peekSimpleToggle sToggle+++-- ----------------------------------------------------------------------+-- Optimisations+-- ----------------------------------------------------------------------+++{-# INLINE newToggle #-}+{-# INLINE toggle1 #-}+{-# INLINE toggle2 #-}+{-# INLINE peekToggle #-}+{-# INLINE newSimpleToggle #-}+{-# INLINE simpleToggle #-}+{-# INLINE simpleToggle2 #-}++++
+ LICENSE view
@@ -0,0 +1,123 @@+License Agreement++Preamble++The aim of this licence agreement is to enable the free use of the+software that is described in the sequel by anyone. In order to+guarantee this, it is necessary to set up rules for the use of the+software that hold for any user.++Provider of this licence is the University of Bremen, represented by+its principal (called "licence provider" in the sequel). The provider+of the licence has developed the "Uniform Workbench" (just+called "software" in the sequel). The software includes a+graphical tool for accessing documents stored in a versioned repository,+but also contains libraries and some other tools.++Following the ideas of open source software, the licence provider+gives access to the software without fee for anyone (called "licence+taker" in the sequel) under the following conditions which are similar+to the Lesser Gnu Public License (LGPL). Each licence taker obligates+himself to follow the terms of use below.++++1 Principle++Each licence taker appreciating these terms of use receives a simple+right, not resctricted in time and space and without any fee, to use+the software, in particular, to copy, distribute and process+it. Exclusively the following terms of use do hold. The licence+provider explicitly contradicts any conflicting terms of business. By+making use of the rights described below, in particular by copying or+distributing it, a licence treaty between the licence provider and the+licence takes is concluded.++++2 Copying++The licence taker has the right to make and distribute unmodified+copies of the software on any media. Prerequisite for this is that the+licence provider and this licence agreement is clearly recognizable,+and that the sources are distributed together with the software.++++3 Modification and Distribution++The licence taker has the right to modify copies of the software (or+parts thereof) and to distribute these modifications under the terms+of 2 above and the following conditions:++1. The modified software has to carry a clear mark that points to the+original licence provider, the modification that has been made, and+the date of the modification.++2. The licence taker has to ensure that the software as a whole or+parts of it are accessible to third parties under the terms of this+licence agreement without fee.++3. If during the modification a copyright of the licence taker+emerges, then this copyright must be put under the terms of this+licence if the modified software is distributed.+++4 Other duties++1. Reference to the validity of this licence agreement must not be+modified or deleted by the licence taker.++2. The use of the software by third parties must not be conditioned by+the fulfilment of duties that are not mentioned in this licence+agreement.++3. The use of the software must not be prevented or complicated by+means fo technical protection, in particular copy protection means.++++5 Liability, Update++1. Liability of the licence provider is restriced to fraudulent+withheld factual or legal errors. The licence provider does not give+any warranty, and neither ensures any properties of the+software. Furthermore, he is liable only for those damages that are+caused by willful or grossly negligent violation of duty.++2. The licence provider has the right to update these terms of use at+any time.+++++6 Forum for users++The licence provider does provide neither support nor+consultation. Without acknowledgement of any legal duty, the licence+provider will care about the installation of a user forum for+discussions about the software and its further development.+++7 Legal domicile++It is agreed that the law of the Federal Republic of Germany is valid+for this licence agreement. For any lawsuits or legal actions emerging+from this licence agreement, it is agreed that exclusively German+courts are competent. Legal domicile is Bremen.+++8 Termination through Offence++Any violation of a duty of this agreement automatically terminates the+rights of use of the offender.++++9 Salvatorian Clause++If any rule of this agreement should be or become inoperative,+validity of the other rules is not affected. The parties will care+about replacing the invalid rule by some valid rule that comes close+to the purpose of this agreement.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ uni-events.cabal view
@@ -0,0 +1,38 @@+name: uni-events+version: 2.2.0.0+build-type: Simple+license: LGPL+license-file: LICENSE+author: uniform@informatik.uni-bremen.de+maintainer: Christian.Maeder@dfki.de+homepage: http://www.informatik.uni-bremen.de/uniform/wb/+category: Uniform+synopsis: Event handling for the uniform workbench+description: uni events+cabal-version: >= 1.4+Tested-With: GHC==6.8.3, GHC==6.10.4, GHC==6.12.3++library+ exposed-modules:+ Events.Toggle,+ Events.Events,+ Events.Cells,+ Events.GuardedEvents,+ Events.GuardedChannels,+ Events.DeleteQueue,+ Events.NullGuard,+ Events.FMQueue,+ Events.EqGuard,+ Events.Spawn,+ Events.Destructible,+ Events.Channels,+ Events.Examples,+ Events.RefQueue,+ Events.Synchronized++ build-depends: base >=3 && < 4, containers, uni-util++ if impl(ghc < 6.10)+ extensions: PatternSignatures+ else+ ghc-options: -fwarn-unused-imports -fno-warn-warnings-deprecations