event-monad (empty) → 0.0.0.2
raw patch · 9 files changed
+824/−0 lines, 9 filesdep +basedep +containersdep +event-handlerssetup-changed
Dependencies added: base, containers, event-handlers, haskell98, monad-loops, mtl, priority-queue, stateref, wl-pprint
Files
- Setup.lhs +5/−0
- event-monad.cabal +36/−0
- src/Control/Monad/Event.hs +37/−0
- src/Control/Monad/Event/BasicEvents.hs +108/−0
- src/Control/Monad/Event/Classes.hs +93/−0
- src/Control/Monad/Event/Classes.hs-boot +20/−0
- src/Control/Monad/Event/Internal/EventID.hs +15/−0
- src/Control/Monad/Event/Internal/Types.hs +34/−0
- src/Control/Monad/EventT.hs +476/−0
+ Setup.lhs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain+
+ event-monad.cabal view
@@ -0,0 +1,36 @@+name: event-monad+version: 0.0.0.2+stability: experimental+license: PublicDomain++cabal-version: >= 1.2+build-type: Simple++author: James Cook <james.cook@usma.edu>+maintainer: James Cook <james.cook@usma.edu>+homepage: http://code.haskell.org/~mokus/event-monad++category: Control+synopsis: Event-graph simulation monad transformer+description: An interface for and simple implementation of an+ event-graph simulation system as a monad transformer.++tested-with: GHC++Library+ hs-source-dirs: src+ exposed-modules: Control.Monad.Event+ Control.Monad.Event.BasicEvents+ Control.Monad.Event.Classes+ Control.Monad.EventT+ other-modules: Control.Monad.Event.Internal.Types+ Control.Monad.Event.Internal.EventID+ build-depends: base >= 3, + containers, + event-handlers >= 0.0.0.2, + haskell98,+ monad-loops, + mtl, + priority-queue, + stateref >= 0.2.1.1, + wl-pprint
+ src/Control/Monad/Event.hs view
@@ -0,0 +1,37 @@+{-+ - ``Control/Monad/Event''+ - (c) 2008 Cook, J. MR SSD, Inc.+ -}++module Control.Monad.Event+ ( module Control.Monad.Event+ + , module Control.Monad.Event.BasicEvents+ , module Control.Monad.Event.Classes+ , module Control.Monad.EventT+ + , module Control.Monad.Event.Internal.Types+ ) where++import Control.Monad.Event.BasicEvents+import Control.Monad.Event.Classes+import Control.Monad.EventT++import Control.Monad.Event.Internal.Types++-- |schedule an event at an absolute time (see 'scheduleEventIn')+scheduleEventAt :: (ScheduleEvent m t e, Num t) => t -> e -> m EventID+scheduleEventAt t e = do+ now <- getCurrentTime+ let dt = t - now+ + scheduleEventIn dt e++-- |retry the currently-executing event at an absolute time (see 'retryEventIn')+retryEventAt :: (RetryEvent m t, Num t)+ => t -> m EventID+retryEventAt t = do+ now <- getCurrentTime+ let dt = t - now+ + retryEventIn dt
+ src/Control/Monad/Event/BasicEvents.hs view
@@ -0,0 +1,108 @@+{-+ - ``Control/Monad/Event/BasicEvents''+ - (c) 2008 Cook, J. MR SSD, Inc.+ -}+{-# LANGUAGE+ MultiParamTypeClasses,+ FunctionalDependencies,+ FlexibleInstances,+ ExistentialQuantification,+ Rank2Types,+ KindSignatures+ #-}++module Control.Monad.Event.BasicEvents where++import Control.Monad.Event.Classes++import Control.Monad.Trans+import Text.PrettyPrint.Leijen++{- reified simulation control events -}+data SimControl (m :: * -> *) = StopSim | StartSim+ deriving (Eq, Show)+instance Pretty (SimControl m) where+ pretty StopSim = text "Stop Simulation"+ pretty StartSim = text "Start Simulation"++instance MonadSimControl m => MonadEvent m (SimControl m) where+ describeEvent e = return (pretty e)+ runEvent StopSim = pauseSimulation >> return ()+ runEvent StartSim = resumeSimulation >> return ()++++-- |An event with description and effect supplied at run time+data AdHocEvent m = AdHocEvent (m Doc) (m ())+instance Monad m => MonadEvent m (AdHocEvent m) where+ describeEvent (AdHocEvent doc _) = doc+ runEvent (AdHocEvent _ action) = action++-- |An infix operator to construct an event from a description and an action+infixr 2 ?:+(?:) :: (Monad m, Pretty desc) => desc -> m a -> AdHocEvent m+description ?: action = AdHocEvent (return (pretty description)) (action >> return ())++-- |Same thing, but use an action to generate the description+infixr 2 ?::+(?::) :: (Monad m) => m Doc -> m a -> AdHocEvent m+description ?:: action = AdHocEvent (description) (action >> return ())++++-- |A simple event that describes a message to be passed to the user.+data Message (m :: * -> *) = Message String++instance Pretty (Message m) where+ pretty (Message str) = pretty "Message" <+> dquotes (align (pretty str))+-- probably not a good idea: simulation implementors will want+-- the freedom to define their own behavior for this message.+-- instance MonadIO m => MonadEvent m (Message m) where+-- describeEvent e = return (pretty e)+-- runEvent (Message msg) = liftIO (putStrLn msg)++++-- |An infix operator for sequential composition of events+infixr 0 &+(&) :: (MonadEvent m e1, MonadEvent m e2) => e1 -> e2 -> AdHocEvent m+e1 & e2 = doc ?:: e3+ where+ doc = do+ d1 <- describeEvent e1+ d2 <- describeEvent e2+ return (d1 </> d2)+ e3 = do+ runEvent e1+ runEvent e2++-- |A version of '&' that preserves distinctness of events+-- at the expense of being able to guarantee \"proper\" interleaving+-- with other events scheduled at the same time. For example, suppose a+-- composite event e1 &- e2 of this type is scheduled, then a third+-- event e3 is scheduled for the same time. The \"expected\" order of+-- execution is e1; e2; e3. What actually happens is e1; e3; e2 - +-- because (e1 &- e2) runs, having the effect of running e1 and +-- scheduling e2, then e3 runs (because it's next in the queue),+-- then e2 finally runs. This situation could be solved by changing+-- the semantics for 'doNext' as proposed there.+-- +-- This is primarily useful for separating an initial 'SetDebugHandlers'+-- event from the other event(s) being fired at the start+-- of the simulation, so that they will be \"seen\" by the +-- newly installed handlers.++infixr 0 &-+(&-) :: (ScheduleEvent m t e2, MonadEvent m e1) => e1 -> e2 -> AdHocEvent m+e1 &- e2 = e1 & (describeEvent e2 ?:: doNext e2)+++-- |An infix operator for defining a \"delayed\" event - or rather a +-- new event that schedules its payload at a later time+infixr 1 @:+(@:) :: (ScheduleEvent m t e, Pretty t) => e -> t -> AdHocEvent m+e @: t = doc ?:: scheduleEventIn t e+ where doc = do+ description <- describeEvent e+ return (parens (text "@" <+> text "+" <> pretty t) <> colon <+> description)+
+ src/Control/Monad/Event/Classes.hs view
@@ -0,0 +1,93 @@+{-+ - ``Control/Monad/Event/Classes''+ - (c) 2008 Cook, J. MR SSD, Inc.+ -}+{-# LANGUAGE+ MultiParamTypeClasses,+ FunctionalDependencies+ #-}++module Control.Monad.Event.Classes where++import Control.Monad.Event.Internal.Types+import Text.PrettyPrint.Leijen++-- |A type-class for monads with a concept of time. That concept need not+-- necessarily meet any prior conditions - not even an Eq instance.+class Monad m => MonadTime m t | m -> t where+ getCurrentTime :: m t++-- |A monad in which there is a concept of running and not-running and+-- unrestricted operations for switching between them.+class Monad m => MonadSimControl m where+ resumeSimulation :: m ()+ pauseSimulation :: m ()+ isSimulationRunning :: m Bool++-- |A monad in which there is a concept of an \"event\" - an action with a+-- sort of a special status, which can be described for humans and can be+-- otherwise manipulated in monads implementing the classes to follow.+class Monad m => MonadEvent m e | e -> m where+ describeEvent :: e -> m Doc+ describeEvent e = return (text "Undocumented event - implement describeEvent")+ + runEvent :: e -> m ()++-- | A monad which can schedule events for later execution. For obvious+-- reasons, such a monad must also have a concept of events (covering the+-- event that the user is trying to schedule) and a concept of time.+class (MonadEvent m e, MonadTime m t) => ScheduleEvent m t e | m -> t, e -> m where+ -- |Schedule an event for execution at a time (relative to the current time).+ -- The meaning of \"relative to\" is left entirely up to the+ -- implementor, however it will generally be the case that time is+ -- an instance of 'Num' and that \"relative to\" means something+ -- along the lines of \"at now + _\".+ --+ -- Returns an 'EventID' that can be used to identify the event+ -- if needed later (for example, to cancel it).+ scheduleEventIn :: t -> e -> m EventID+ + -- |schedule an event to run at the current time. This does not + -- constitute a promise to execute immediately or in any particular+ -- order relative to other events that have been or will be+ -- scheduled for the current time.+ --+ -- If an implementor has a time type which is an instance of 'Num', then+ -- 'doNext' should be equivalent to 'scheduleEventIn' 0 - unless the+ -- monad's documentation clearly warns to the contrary in a really big+ -- typeface. ; ) Note that this clause may change to also strongly+ -- suggest that 'doNext' put its event at the very front of the queue+ -- (ie, before any other events already scheduled for the current time).+ doNext :: e -> m ()++-- | A monad in which an event (presumably one previously scheduled)+-- can be canceled.+class MonadTime m t => CancelEvent m t | m -> t where+ -- |Cancel an event given its 'EventID'. If successful (and+ -- if the monad's implementation allows it), an 'EventDescriptor'+ -- (an existential wrapper describing an event, its ID, and+ -- the time at which it would have run) containing the + -- canceled event is returned.+ cancelEvent :: EventID -> m (Maybe (EventDescriptor m t))++-- | A monad in which an 'EventDescriptor' for the currently-executing+-- event, if any, can be obtained.+class MonadTime m t => GetCurrentEvent m t | m -> t where+ getCurrentEvent :: m (Maybe (EventDescriptor m t))++-- | A monad in which the currently executing event can be rescheduled.+-- Note that calling 'retryEventIn' does not terminate the currently+-- executing event - although perhaps it should. Until a more permanent+-- decision is made, it's probably best to make 'retryEventIn' the last+-- action of an event when it is used, to minimize impact of future changes.+class MonadTime m t => RetryEvent m t | m -> t where+ retryEventIn :: t -> m EventID++-- |A monad in which information about the event queue can be retrieved.+class MonadTime m t => MonadEventQueueInfo m t | m -> t where+ -- |Return the number of events currently scheduled.+ eventQueueSize :: m Int+ -- |Return a list of (some or all of) the events coming up.+ -- There is no obligation on the part of the monad to provide+ -- anything at all.+ eventQueueContents :: m [EventDescriptor m t]
+ src/Control/Monad/Event/Classes.hs-boot view
@@ -0,0 +1,20 @@+{-+ - ``Control/Monad/Event/Classes''+ - (c) 2008 Cook, J. MR SSD, Inc.+ -}+{-# LANGUAGE+ MultiParamTypeClasses,+ FunctionalDependencies,+ KindSignatures+ #-}++module Control.Monad.Event.Classes where++import Control.Monad.Event.Internal.EventID++class MonadTime (m :: * -> *) t | m -> t+class MonadEvent (m :: * -> *) e | e -> m+class (MonadEvent m e, MonadTime m t) => ScheduleEvent m t e | m -> t, e -> m+ where+ scheduleEventIn :: t -> e -> m EventID+ doNext :: e -> m ()
+ src/Control/Monad/Event/Internal/EventID.hs view
@@ -0,0 +1,15 @@+{-+ - ``Control/Monad/Event/Internal/EventID''+ - (c) 2008 Cook, J. MR SSD, Inc.+ -}+{-# LANGUAGE+ GeneralizedNewtypeDeriving+ #-}++module Control.Monad.Event.Internal.EventID where++import Text.PrettyPrint.Leijen++-- |An opaque identifier for events.+newtype EventID = EventID Int+ deriving (Eq, Ord, Enum, Pretty)
+ src/Control/Monad/Event/Internal/Types.hs view
@@ -0,0 +1,34 @@+{-+ - ``Control/Monad/Event/Internal/Types''+ - (c) 2008 Cook, J. MR SSD, Inc.+ -}+{-# LANGUAGE+ ExistentialQuantification,+ KindSignatures+ #-}++module Control.Monad.Event.Internal.Types+ ( module Control.Monad.Event.Internal.Types+ , module Control.Monad.Event.Internal.EventID+ ) where++import {-# SOURCE #-} Control.Monad.Event.Classes+import Control.Monad.Event.Internal.EventID++import Text.Printf -- for the benefit of haddock++-- | An existential wrapper containing an event which can be executed in the+-- monad 'm'.+-- +-- I would like to existentially quantify the time parameter too, since it's+-- uniquely determined according to the functional dependencies of 'MonadTime',+-- but GHC doesn't unify it with its actual type in pattern matches - I was+-- not able to use it as a 'PrintfArg' in:+-- +-- > instance MonadEvent (EventT Double IO) (EventDescriptor (EventT Double IO))+data EventDescriptor (m :: * -> *) t = forall e. ScheduleEvent m t e => EventDescriptor + { eventId :: EventID+ , eventTime :: t+ , event :: e+ }+
+ src/Control/Monad/EventT.hs view
@@ -0,0 +1,476 @@+{-+ - ``Control/Monad/Event/EventT''+ - (c) 2008 Cook, J. MR SSD, Inc.+ -}+{-# LANGUAGE+ GeneralizedNewtypeDeriving,+ MultiParamTypeClasses,+ FlexibleContexts,+ FlexibleInstances,+ UndecidableInstances,+ TypeSynonymInstances,+ KindSignatures+ #-}++module Control.Monad.EventT+ ( + EventT+ , EventM+ , runEventT+ , runEventGraph+ , runEventGraphWithState+ + , newEventT_RState+ , newEventT_RWState+ + , onClockChanged+ , onEventDispatch+ , onEventComplete+ , onEventSchedule+ , onEventCancel+ + , addHandler+ , removeHandler+ + , SetDebugHandlers(..)+ , DebugHandlerOptions(..)+ , defaultHandlerOptions+ ) where++import Control.Monad.Event.Classes+import Control.Monad.Event.Internal.Types++import Data.Handler+import Data.PriorityQueue+import Data.StateRef+import Control.Monad.RWS+import Control.Monad.Loops++import Text.PrettyPrint.Leijen++import IO+import Control.Monad.Trans+import Control.Concurrent (threadDelay)++-- imports just for classes to implement+import Control.Monad.Error (MonadError(..))+import Control.Monad (MonadPlus(..))+import Control.Monad.Cont (MonadCont(..))++import qualified Data.Map as M++{- Time management -}+instance Monad m => MonadTime (EventT t m) t where+ getCurrentTime = EventT (gets currentTime)++{- Time Management (internal) -}+setCurrentTime :: Monad m => t -> EventT t m ()+setCurrentTime t1 = do+ rwState <- EventT get+ + let t0 = currentTime rwState+ EventT (put (rwState {currentTime = t1}))+ + invokeHandler clockChangedHandler (t0,t1)++{- simulation control -}+instance Monad m => MonadSimControl (EventT t m) where+ resumeSimulation = do+ rwState <- EventT get+ EventT (put (rwState {simRunning = True}))+ pauseSimulation = do+ rwState <- EventT get+ EventT (put (rwState {simRunning = False}))+ isSimulationRunning = EventT (gets simRunning)++{- MonadEvent instance for unadorned (EventT t m) actions -}+instance Monad m => MonadEvent (EventT t m) (EventT t m a) where+ describeEvent e = return (text "Undocumented Event")+ runEvent e = e >> return ()++{- MonadEvent instance for Event Descriptors - this does most of + the real grunt work of running an event -}+instance (Monad m, Pretty t) => MonadEvent (EventT t m) (EventDescriptor (EventT t m) t) where+ describeEvent (EventDescriptor {eventId = eid, eventTime = t, event = e}) = do+ eventDescription <- describeEvent e+ return (+ brackets (+ fill 5 (pretty eid)+ <> text "|"+ <> fill 10 (pretty t)+ ) <> colon+ <+> align eventDescription+ )+ runEvent event@(EventDescriptor {event = e}) = do+ setCurrentTime (eventTime event)+ + invokeHandler eventDispatchHandler event+ + EventT (local (\env -> env {currentEvent = Just event}) (unWrapEventT (runEvent e)))+ + invokeHandler eventCompleteHandler event++{- event scheduling, canceling, etc. -}+instance (Monad m, Ord t, Num t, MonadEvent (EventT t m) e) => ScheduleEvent (EventT t m) t e where+ scheduleEventIn dt e = do+ now <- getCurrentTime+ let t = (now + dt)+ + eid <- getNextEventId+ let event = EventDescriptor + {eventId = eid, eventTime = t, event = e}+ + enqueue eventQueueRef event+ invokeHandler eventScheduleHandler event+ + return eid+ + doNext e = scheduleEventIn 0 e >> return ()++instance (Monad m, Ord t) => CancelEvent (EventT t m) t where+ cancelEvent eid = do+ maybeEvent <- dequeueWhere eventQueueRef (\e -> eventId e == eid)+ + invokeHandler eventCancelHandler (maybe (Left eid) Right maybeEvent)+ return maybeEvent++{- services for use in implementing events -}+instance Monad m => GetCurrentEvent (EventT t m) t where+ getCurrentEvent = EventT (asks currentEvent)++instance Monad m => RetryEvent (EventT t m) t where+ retryEventIn dt = do+ maybeCe <- getCurrentEvent+ case maybeCe of+ Nothing -> fail "retry called outside an event"+ Just (EventDescriptor {event = e}) ->+ scheduleEventIn dt e++instance (Monad m, Ord t) => MonadEventQueueInfo (EventT t m) t where+ eventQueueSize = withEventQueue queueSize+ eventQueueContents = withEventQueue peekQueue+++{- The EventT type and related administrative bits (state management stuff) -}+-- |A monad transformer which adds an event queue and related operations to+-- an underlying monad. The \"t\" parameter specifies the type of the+-- simulation time.+--+-- Several hooks are provided to allow special handling of various events,+-- such as the progression of time, the scheduling or canceling or dispatch+-- of an event, etc.+newtype EventT t m a = EventT { unWrapEventT :: RWST (EventT_RState t m) () (EventT_RWState t m) m a }+ deriving (Functor, Monad, MonadIO)++instance MonadTrans (EventT t) where+ lift = EventT . lift++{- Monad type-class pass-through implementations -}+instance MonadReader r m => MonadReader r (EventT t m) where+ ask = EventT (lift ask)+ local f (EventT x) = EventT $ do+ rState <- ask+ rwState <- get+ (a, rwState, w) <- lift (local f (runRWST x rState rwState))+ put rwState+ tell w+ return a++instance MonadWriter w m => MonadWriter w (EventT t m) where+ tell w = EventT (lift (tell w))+ listen (EventT x) = EventT $ do+ rState <- ask+ rwState <- get+ ((a, rwState, w), w2) <- lift (listen (runRWST x rState rwState))+ put rwState+ tell w+ return (a, w2)+ pass (EventT x) = EventT $ do+ rState <- ask+ rwState <- get+ let knot = do+ ((a, f), rwState, w) <- runRWST x rState rwState + return ((a, rwState, w), f)+ (a, rwState, w) <- lift (pass knot)+ put rwState+ tell w+ return a++instance MonadState s m => MonadState s (EventT t m) where+ get = EventT (lift get)+ put s = EventT (lift (put s))++instance MonadError e m => MonadError e (EventT t m) where+ throwError e = EventT (lift (throwError e))+ catchError (EventT x) onErr = EventT $ do+ rState <- ask+ rwState <- get+ let onErr' err = runRWST (unWrapEventT (onErr err)) rState rwState+ (a, rwState, w) <- lift (catchError (runRWST x rState rwState) onErr')+ put rwState+ tell w+ return a++-- is this valid?+instance MonadPlus m => MonadPlus (EventT t m) where+ mzero = EventT (lift mzero)+ mplus (EventT a) (EventT b) = EventT $ do+ rState <- ask+ rwState <- get+ (c, rwState, w) <- lift (runRWST a rState rwState `mplus` runRWST b rState rwState)+ put rwState+ tell w+ return c++-- what semantics does this inherit? is it sensible? is it unique?+instance MonadCont m => MonadCont (EventT t m) where+ callCC f = EventT $+ callCC $ \cont ->+ unWrapEventT (f (EventT . cont))++-- |'EventM' is a shorthand for an event graph monad in IO with clock of type Double+type EventM = EventT Double IO++{- Running (EventT t m) actions and whole event graphs -}+-- |Run an 'EventT' wrapped action. This is a \"raw\" action - there is no +-- interaction with the state (including event graph) except whatever the+-- action itself does.+runEventT :: Monad m => EventT t m a -> EventT_RState t m -> EventT_RWState t m -> m (a, EventT_RWState t m)+runEventT (EventT x) rState rwState = do+ (a, rwState, _) <- runRWST x rState rwState+ return (a, rwState)++-- |Repeatedly pull and run the next event in the queue until it's +-- empty or until the simulation is paused using 'pauseSimulation'+-- or something equivalent.+runEventGraphWithState :: + ( Monad m, Ord t, Pretty t+ ) => EventT_RState t m -> EventT_RWState t m -> m (EventT_RWState t m)+runEventGraphWithState rState rwState = do+ (_, rwState) <- runEventT (whileJust_ dequeueNextEvent runEvent) rState rwState+ return rwState++-- |Initialize the event queue and other stuff, enqueue the provided \"start +-- event\", and run the queue until it's empty or until the simulation is+-- paused.+runEventGraph ::+ ( Monad m, MonadEvent (EventT t m) e+ , Ord t, Num t, Pretty t+ ) => e -> m (EventT_RState t m, EventT_RWState t m)+runEventGraph e = do+ let rState = newEventT_RState+ rwState = newEventT_RWState 0+ + (_, rwState) <- runEventT (scheduleEventIn 0 e) rState rwState+ rwState <- runEventGraphWithState rState rwState+ + return (rState, rwState)+++{- the main state vectors -}+data EventT_RState t m = EventT_RState+ { currentEvent :: Maybe (EventDescriptor (EventT t m) t)+ }++data EventT_RWState t m = EventT_RWState+ { currentTime :: t+ , simRunning :: Bool+ , nextEventId :: EventID+ , eventQueue :: EventQueue t m+ , handlers :: EventTHandlers t m+ }++-- |A new instance of the read/write portion of the 'EventT' internal+-- state. The parameter is the initial time value.+newEventT_RWState :: (Monad m, Ord t) => t -> EventT_RWState t m+newEventT_RWState t = EventT_RWState+ { currentTime = t+ , simRunning = True+ , nextEventId = EventID 1+ , eventQueue = newEventQueue+ , handlers = newEventTHandlers+ }++-- |A new instance of the read-only portion of the 'EventT' internal+-- state.+newEventT_RState :: EventT_RState t m+newEventT_RState = EventT_RState+ { currentEvent = Nothing+ }++{- Miscellaneous small state management functions -}+getNextEventId :: Monad m => EventT t m EventID+getNextEventId = do+ rwState <- EventT get+ let eID = nextEventId rwState+ EventT (put (rwState {nextEventId = succ eID}))+ return eID++{- Support for debugging event handlers -}+data EventTHandlers t m = EventTHandlers+ { eventScheduleHandler :: HandlerSet (EventT t m) (EventDescriptor (EventT t m) t) ()+ , eventCancelHandler :: HandlerSet (EventT t m) (Either EventID (EventDescriptor (EventT t m) t)) ()+ , eventDispatchHandler :: HandlerSet (EventT t m) (EventDescriptor (EventT t m) t) ()+ , eventCompleteHandler :: HandlerSet (EventT t m) (EventDescriptor (EventT t m) t) ()+ , clockChangedHandler :: HandlerSet (EventT t m) (t, t) () -- (old time, new time)+ }++type HandlerAccessor t m a b = + ( EventTHandlers t m -> HandlerSet (EventT t m) a b+ , HandlerSet (EventT t m) a b -> EventTHandlers t m -> EventTHandlers t m+ )++-- |Fires after an event is scheduled. Is passed an 'EventDescriptor' for+-- the event.+onEventSchedule :: HandlerAccessor t m (EventDescriptor (EventT t m) t) ()+onEventSchedule = (eventScheduleHandler, \h hs -> hs {eventScheduleHandler = h})++-- |Fires after an event is canceled. Is passed either an 'EventID' (if the+-- cancellation failed) or an 'EventDescriptor' for the event that was canceled.+onEventCancel :: HandlerAccessor t m (Either EventID (EventDescriptor (EventT t m) t)) ()+onEventCancel = (eventCancelHandler, \h hs -> hs {eventCancelHandler = h})++-- |Fires just before an event is dispatched. Is passed an 'EventDescriptor'+-- describing the event about to be run.+onEventDispatch :: HandlerAccessor t m (EventDescriptor (EventT t m) t) ()+onEventDispatch = (eventDispatchHandler, \h hs -> hs {eventDispatchHandler = h})++-- |Fires after an event returns. Is passed an 'EventDescriptor' for the+-- event that just finished.+onEventComplete :: HandlerAccessor t m (EventDescriptor (EventT t m) t) ()+onEventComplete = (eventCompleteHandler, \h hs -> hs {eventCompleteHandler = h})++-- |Fires whenever the clock changes, and is passed a tuple containing+-- (old time, new time)+onClockChanged :: HandlerAccessor t m (t, t) ()+onClockChanged = (clockChangedHandler, \h hs -> hs {clockChangedHandler = h})++newEventTHandlers :: Monad m => EventTHandlers t m+newEventTHandlers = EventTHandlers+ { eventScheduleHandler = emptyHandlerSet+ , eventCancelHandler = emptyHandlerSet+ , eventDispatchHandler = emptyHandlerSet+ , eventCompleteHandler = emptyHandlerSet+ , clockChangedHandler = emptyHandlerSet+ }++-- |Add an event handler to be called when the specified event happens.+addHandler :: Monad m => HandlerAccessor t m a b -> (a -> EventT t m b) -> EventT t m HandlerID+addHandler (getter, setter) h = do+ hSet <- EventT (gets (getter.handlers))+ + let (newHSet, hId) = addHandlerToSet h hSet+ + EventT (modify (\s -> s {handlers = setter newHSet (handlers s)}))+ return hId++-- |Remove an event handler given its ID, and return it if it was in the set.+removeHandler :: Monad m => HandlerAccessor t m a b -> HandlerID -> EventT t m (Maybe (a -> EventT t m b))+removeHandler (getter, setter) hId = do+ hSet <- EventT (gets (getter.handlers))+ + let (newHSet, h) = removeHandlerFromSet hId hSet+ + EventT (modify (\s -> s {handlers = setter newHSet (handlers s)}))+ return h++invokeHandler :: Monad m => (EventTHandlers t m -> HandlerSet (EventT t m) a b) -> a -> EventT t m b+invokeHandler h args = do+ hSet <- EventT (gets (h.handlers))+ invokeHandlers hSet args+++{- internal support relating to the event queue -}+type EventQueue t m = PQ (EventDescriptor (EventT t m) t)+type EventQueueRef t m = PriorityQueue (EventT t m) (EventDescriptor (EventT t m) t)++newEventQueue :: Ord t => EventQueue t m+newEventQueue = emptyPQ eventTime++withEventQueue :: (Monad m, Ord t) => (EventQueueRef t m -> EventT t m a) -> EventT t m a+withEventQueue f = f eventQueueRef++eventQueueRef :: (Monad m, Ord t) => EventQueueRef t m+eventQueueRef = mkPriorityQueue (UnsafeModifyRef (Accessor (Getter getEventQueue, Setter setEventQueue)))+ where + getEventQueue = EventT (gets eventQueue)+ setEventQueue eq = EventT $ do+ modify (\rwState -> rwState {eventQueue = eq})++dequeueNextEvent :: (Monad m, Ord t) => EventT t m (Maybe (EventDescriptor (EventT t m) t))+dequeueNextEvent = do+ running <- isSimulationRunning+ if running+ then withEventQueue dequeue+ else return Nothing++{- Some handy event handlers for logging and speed regulation -}+{- at some point these may be extracted to a type class -}+-- |(warning: very likely to change or disappear)+-- +-- A collection of 'Bool's telling 'SetDebugHandlers' which handlers to install.+data DebugHandlerOptions = DebugHandlerOptions+ { -- |Run roughly in sync with the wall clock (using seconds as the simulation time unit)+ sync :: Bool+ , -- |Print event dispatches to 'stderr' as they occur+ showDispatches :: Bool + , -- |Print event cancellations to 'stderr' as they occur+ showCancels :: Bool+ , -- |Print event scheduling actions to 'stderr' as they occur+ showSchedules :: Bool+ , -- |Dump the entire contents of the event queue to+ -- 'stderr' every time an event is dispatched+ dumpQueue :: Bool+ } deriving Show++defaultHandlerOptions = DebugHandlerOptions+ { sync = False+ , showDispatches = False+ , showCancels = False+ , showSchedules = False+ , dumpQueue = False+ }++-- |(warning: very likely to change or disappear)+-- +-- An event which installs some very primitive logging event handlers+-- useful for watching what's going on inside the event queue.+data SetDebugHandlers t (m :: * -> *) = SetDebugHandlers DebugHandlerOptions+instance Pretty (SetDebugHandlers t m) where+ pretty (SetDebugHandlers opts) = text "Set debug handlers, using options" <+> colon <> text (show opts)+instance (MonadIO m, RealFrac t, Pretty t) => MonadEvent (EventT t m) (SetDebugHandlers t m) where+ describeEvent e = return (pretty e)+ + runEvent (SetDebugHandlers opts) = do+ let addHandlerIf p hSel h = if p opts then addHandler hSel h >> return () else return ()+ + -- very rough wallclock synchronization+ addHandlerIf sync onClockChanged $ \(t1, t2) -> do+ let dt = t2 - t1+ let delayTime = max 0 (dt * 1000000)+ liftIO (threadDelay (floor delayTime))+ + addHandlerIf showDispatches onEventDispatch $ \e -> do+ description <- describeEvent e+ liftIO (hPutDoc stderr (text "Dispatch: " <> description <> linebreak))+ + addHandlerIf showCancels onEventCancel $ \e -> case e of+ Right e -> do+ description <- describeEvent e+ liftIO (hPutDoc stderr (text "Canceled" <> colon <+> description <> linebreak))+ Left eid -> liftIO (hPutDoc stderr (text "Cancel" <> colon <+> text "event" <+> pretty eid <+> text "failed to be canceled - it probably already ran" <> linebreak))+ + addHandlerIf showSchedules onEventSchedule $ \e -> do+ sz <- eventQueueSize+ qc <- eventQueueContents+ + description <- describeEvent e+ liftIO (hPutDoc stderr (text "Schedule" <> colon <+> align description <> linebreak))+ + addHandlerIf dumpQueue onEventDispatch $ \e -> do+ qc <- eventQueueContents+ descriptions <- mapM describeEvent qc+ liftIO (hPutDoc stderr (text "Event Queue" <> colon <+> align (vcat descriptions) <> linebreak))+ + return ()+