diff --git a/Events/Cells.hs b/Events/Cells.hs new file mode 100644 --- /dev/null +++ b/Events/Cells.hs @@ -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 #-} diff --git a/Events/Channels.hs b/Events/Channels.hs new file mode 100644 --- /dev/null +++ b/Events/Channels.hs @@ -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 + + + + diff --git a/Events/DeleteQueue.hs b/Events/DeleteQueue.hs new file mode 100644 --- /dev/null +++ b/Events/DeleteQueue.hs @@ -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))) + diff --git a/Events/Destructible.hs b/Events/Destructible.hs new file mode 100644 --- /dev/null +++ b/Events/Destructible.hs @@ -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) diff --git a/Events/EqGuard.hs b/Events/EqGuard.hs new file mode 100644 --- /dev/null +++ b/Events/EqGuard.hs @@ -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) diff --git a/Events/Events.hs b/Events/Events.hs new file mode 100644 --- /dev/null +++ b/Events/Events.hs @@ -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) + diff --git a/Events/Examples.hs b/Events/Examples.hs new file mode 100644 --- /dev/null +++ b/Events/Examples.hs @@ -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 ()))) + + + diff --git a/Events/FMQueue.hs b/Events/FMQueue.hs new file mode 100644 --- /dev/null +++ b/Events/FMQueue.hs @@ -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 + }) diff --git a/Events/GuardedChannels.hs b/Events/GuardedChannels.hs new file mode 100644 --- /dev/null +++ b/Events/GuardedChannels.hs @@ -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 + + diff --git a/Events/GuardedEvents.hs b/Events/GuardedEvents.hs new file mode 100644 --- /dev/null +++ b/Events/GuardedEvents.hs @@ -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 + diff --git a/Events/NullGuard.hs b/Events/NullGuard.hs new file mode 100644 --- /dev/null +++ b/Events/NullGuard.hs @@ -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) + + + diff --git a/Events/RefQueue.hs b/Events/RefQueue.hs new file mode 100644 --- /dev/null +++ b/Events/RefQueue.hs @@ -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) + + diff --git a/Events/Spawn.hs b/Events/Spawn.hs new file mode 100644 --- /dev/null +++ b/Events/Spawn.hs @@ -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 () + diff --git a/Events/Synchronized.hs b/Events/Synchronized.hs new file mode 100644 --- /dev/null +++ b/Events/Synchronized.hs @@ -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 diff --git a/Events/Toggle.hs b/Events/Toggle.hs new file mode 100644 --- /dev/null +++ b/Events/Toggle.hs @@ -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 #-} + + + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/uni-events.cabal b/uni-events.cabal new file mode 100644 --- /dev/null +++ b/uni-events.cabal @@ -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