diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain + diff --git a/event-monad.cabal b/event-monad.cabal new file mode 100644 --- /dev/null +++ b/event-monad.cabal @@ -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 +maintainer: James Cook +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 diff --git a/src/Control/Monad/Event.hs b/src/Control/Monad/Event.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Event.hs @@ -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 diff --git a/src/Control/Monad/Event/BasicEvents.hs b/src/Control/Monad/Event/BasicEvents.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Event/BasicEvents.hs @@ -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) + diff --git a/src/Control/Monad/Event/Classes.hs b/src/Control/Monad/Event/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Event/Classes.hs @@ -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] diff --git a/src/Control/Monad/Event/Classes.hs-boot b/src/Control/Monad/Event/Classes.hs-boot new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Event/Classes.hs-boot @@ -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 () diff --git a/src/Control/Monad/Event/Internal/EventID.hs b/src/Control/Monad/Event/Internal/EventID.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Event/Internal/EventID.hs @@ -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) diff --git a/src/Control/Monad/Event/Internal/Types.hs b/src/Control/Monad/Event/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Event/Internal/Types.hs @@ -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 + } + diff --git a/src/Control/Monad/EventT.hs b/src/Control/Monad/EventT.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/EventT.hs @@ -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 () +