diff --git a/event-monad.cabal b/event-monad.cabal --- a/event-monad.cabal +++ b/event-monad.cabal @@ -1,5 +1,5 @@ name: event-monad -version: 0.0.0.2 +version: 0.0.1.0 stability: experimental license: PublicDomain @@ -13,7 +13,9 @@ 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. + event-graph simulation system as a monad transformer, + as well as a version using mutable state references + for performance and for concurrency support. tested-with: GHC @@ -23,6 +25,7 @@ Control.Monad.Event.BasicEvents Control.Monad.Event.Classes Control.Monad.EventT + Control.Monad.EventM other-modules: Control.Monad.Event.Internal.Types Control.Monad.Event.Internal.EventID build-depends: base >= 3, @@ -31,6 +34,7 @@ haskell98, monad-loops, mtl, - priority-queue, - stateref >= 0.2.1.1, - wl-pprint + pretty, + prettyclass, + priority-queue >= 0.1.2, + stateref >= 0.2.1.1 diff --git a/src/Control/Monad/Event.hs b/src/Control/Monad/Event.hs --- a/src/Control/Monad/Event.hs +++ b/src/Control/Monad/Event.hs @@ -1,37 +1,19 @@ {- - ``Control/Monad/Event'' - - (c) 2008 Cook, J. MR SSD, Inc. -} module Control.Monad.Event - ( module Control.Monad.Event + ( EventT, EventM , 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.EventM 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 --- a/src/Control/Monad/Event/BasicEvents.hs +++ b/src/Control/Monad/Event/BasicEvents.hs @@ -1,6 +1,5 @@ {- - ``Control/Monad/Event/BasicEvents'' - - (c) 2008 Cook, J. MR SSD, Inc. -} {-# LANGUAGE MultiParamTypeClasses, @@ -16,17 +15,19 @@ import Control.Monad.Event.Classes import Control.Monad.Trans -import Text.PrettyPrint.Leijen +import Text.PrettyPrint.HughesPJ +import Text.PrettyPrint.HughesPJClass {- 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" + pPrint StopSim = text "Stop Simulation" + pPrint StartSim = text "Start Simulation" instance MonadSimControl m => MonadEvent m (SimControl m) where - describeEvent e = return (pretty e) + describeEvent e = return (pPrint e) runEvent StopSim = pauseSimulation >> return () runEvent StartSim = resumeSimulation >> return () @@ -41,7 +42,7 @@ -- |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 ()) +description ?: action = AdHocEvent (return (pPrint description)) (action >> return ()) -- |Same thing, but use an action to generate the description infixr 2 ?:: @@ -50,19 +51,6 @@ --- |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 @@ -71,7 +59,7 @@ doc = do d1 <- describeEvent e1 d2 <- describeEvent e2 - return (d1 d2) + return (fsep [d1, d2]) e3 = do runEvent e1 runEvent e2 @@ -100,9 +88,9 @@ -- |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 +(@:) :: (ScheduleEvent m t e, Pretty t, Num 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) + return (parens (text "@" <+> text "+" <> pPrint t) <> colon <+> description) diff --git a/src/Control/Monad/Event/Classes.hs b/src/Control/Monad/Event/Classes.hs --- a/src/Control/Monad/Event/Classes.hs +++ b/src/Control/Monad/Event/Classes.hs @@ -1,6 +1,5 @@ {- - ``Control/Monad/Event/Classes'' - - (c) 2008 Cook, J. MR SSD, Inc. -} {-# LANGUAGE MultiParamTypeClasses, @@ -10,7 +9,7 @@ module Control.Monad.Event.Classes where import Control.Monad.Event.Internal.Types -import Text.PrettyPrint.Leijen +import Text.PrettyPrint.HughesPJ -- |A type-class for monads with a concept of time. That concept need not -- necessarily meet any prior conditions - not even an Eq instance. @@ -36,16 +35,15 @@ -- | 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 +class (MonadEvent m e, MonadTime m t) => ScheduleEvent m t e | m -> t where + -- |Schedule an event for execution at a time. + -- The meaning of \"time\" 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 + _\". + -- an instance of 'Num' and/or is totally ordered in the usual way. -- -- Returns an 'EventID' that can be used to identify the event -- if needed later (for example, to cancel it). - scheduleEventIn :: t -> e -> m EventID + scheduleEventAt :: 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 @@ -59,7 +57,19 @@ -- 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 () + doNext e = do + now <- getCurrentTime + scheduleEventAt now e + return () +-- |schedule an event at an absolute time (see 'scheduleEventIn') +scheduleEventIn :: (ScheduleEvent m t e, Num t) => t -> e -> m EventID +scheduleEventIn dt e = do + now <- getCurrentTime + let t = now + dt + + scheduleEventAt t e + -- | A monad in which an event (presumably one previously scheduled) -- can be canceled. class MonadTime m t => CancelEvent m t | m -> t where @@ -76,12 +86,21 @@ 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 +-- Note that calling 'retryEventAt' 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 +-- decision is made, it's probably best to make 'retryEventAt' 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 + retryEventAt :: t -> m EventID + +-- |retry the currently-executing event at an absolute time (see 'retryEventIn') +retryEventIn :: (RetryEvent m t, Num t) + => t -> m EventID +retryEventIn dt = do + now <- getCurrentTime + let t = now + dt + + retryEventAt t -- |A monad in which information about the event queue can be retrieved. class MonadTime m t => MonadEventQueueInfo m t | m -> t where diff --git a/src/Control/Monad/Event/Classes.hs-boot b/src/Control/Monad/Event/Classes.hs-boot --- a/src/Control/Monad/Event/Classes.hs-boot +++ b/src/Control/Monad/Event/Classes.hs-boot @@ -1,6 +1,5 @@ {- - ``Control/Monad/Event/Classes'' - - (c) 2008 Cook, J. MR SSD, Inc. -} {-# LANGUAGE MultiParamTypeClasses, @@ -12,9 +11,15 @@ import Control.Monad.Event.Internal.EventID -class MonadTime (m :: * -> *) t | m -> t +class Monad m => MonadTime m t | m -> t where + getCurrentTime :: m t + class MonadEvent (m :: * -> *) e | e -> m -class (MonadEvent m e, MonadTime m t) => ScheduleEvent m t e | m -> t, e -> m +class (MonadEvent m e, MonadTime m t) => ScheduleEvent m t e | m -> t where - scheduleEventIn :: t -> e -> m EventID + scheduleEventAt :: t -> e -> m EventID doNext :: e -> m () + doNext e = do + now <- getCurrentTime + scheduleEventAt now e + return () diff --git a/src/Control/Monad/Event/Internal/EventID.hs b/src/Control/Monad/Event/Internal/EventID.hs --- a/src/Control/Monad/Event/Internal/EventID.hs +++ b/src/Control/Monad/Event/Internal/EventID.hs @@ -1,6 +1,5 @@ {- - ``Control/Monad/Event/Internal/EventID'' - - (c) 2008 Cook, J. MR SSD, Inc. -} {-# LANGUAGE GeneralizedNewtypeDeriving @@ -8,8 +7,9 @@ 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) + deriving (Eq, Ord, Enum) + +instance Show EventID where + showsPrec p (EventID i) = showsPrec p i diff --git a/src/Control/Monad/Event/Internal/Types.hs b/src/Control/Monad/Event/Internal/Types.hs --- a/src/Control/Monad/Event/Internal/Types.hs +++ b/src/Control/Monad/Event/Internal/Types.hs @@ -1,6 +1,5 @@ {- - ``Control/Monad/Event/Internal/Types'' - - (c) 2008 Cook, J. MR SSD, Inc. -} {-# LANGUAGE ExistentialQuantification, diff --git a/src/Control/Monad/EventM.hs b/src/Control/Monad/EventM.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/EventM.hs @@ -0,0 +1,272 @@ +{- + - ``Control/Monad/EventM'' + - (c) 2009 Cook, J. MR SSD, Inc. + -} +{-# LANGUAGE + GeneralizedNewtypeDeriving, + MultiParamTypeClasses, + FlexibleContexts, + FlexibleInstances, + UndecidableInstances, + TypeSynonymInstances, + KindSignatures + #-} + + +module Control.Monad.EventM + ( + EventM + , EventIO + , runEventIO + , runEventGraph + , runEventGraphWithState + + , newEventIOState + + , onClockChanged + , onEventDispatch + , onEventComplete + , onEventSchedule + , onEventCancel + + , addHandler + , removeHandler + ) where + + +import Control.Monad.Event.Classes +import Control.Monad.Event.Internal.Types + +import Data.Handler +import Data.PriorityQueue +import Data.StateRef +import Control.Monad.Reader +import Control.Monad.Loops + +import Text.PrettyPrint.HughesPJ + +{- Time management -} +instance MonadTime (EventIO t) t where + getCurrentTime = EventIO (asks currentTime) >>= readRef + +{- Time Management (internal) -} +setCurrentTime :: t -> EventIO t () +setCurrentTime t1 = do + state <- EventIO ask + t0 <- atomicModifyRef (currentTime state) (\t0 -> (t1, t0)) + + invokeHandler onClockChanged (t0,t1) + +{- simulation control -} +instance MonadSimControl (EventIO t) where + resumeSimulation = do + state <- EventIO ask + writeRef (simRunning state) True + pauseSimulation = do + state <- EventIO ask + writeRef (simRunning state) False + isSimulationRunning = EventIO (asks simRunning) >>= readRef + +{- MonadEvent instance for unadorned (EventIO t) actions -} +instance MonadEvent (EventIO t) (EventIO t a) where + describeEvent e = return (text "Undocumented Event") + runEvent e = e >> return () + +instance MonadEvent (EventIO t) (IO a) where + describeEvent e = EventIO . lift . return $ text "Undocumented Event" + runEvent e = EventIO . lift $ (e >> return ()) + +{- MonadEvent instance for Event Descriptors - this does most of + the real grunt work of running an event -} +instance Show t => MonadEvent (EventIO t) (EventDescriptor (EventIO t) t) where + describeEvent (EventDescriptor {eventId = eid, eventTime = t, event = e}) = do + eventDescription <- describeEvent e + return ( + brackets ( + text (fill 5 (show eid)) + <> text "|" + <> text (fill 10 (show t)) + ) <> colon + <+> eventDescription + ) + + where fill n [] = replicate n ' ' + fill 0 xs = xs + fill (n+1) (x:xs) = x : fill n xs + runEvent event@(EventDescriptor {event = e}) = do + setCurrentTime (eventTime event) + + invokeHandler onEventDispatch event + + EventIO (local (\env -> env {currentEvent = Just event}) (unWrapEventIO (runEvent e))) + + invokeHandler onEventComplete event + +{- event scheduling, canceling, etc. -} +instance (MonadEvent (EventIO t) e) => ScheduleEvent (EventIO t) t e where + scheduleEventAt t e = do + eid <- getNextEventId + let event = EventDescriptor + {eventId = eid, eventTime = t, event = e} + + q <- getEventQueue + enqueue q event + invokeHandler onEventSchedule event + + return eid + +instance CancelEvent (EventIO t) t where + cancelEvent eid = do + q <- getEventQueue + maybeEvent <- dequeueWhere q (\e -> eventId e == eid) + + invokeHandler onEventCancel (maybe (Left eid) Right maybeEvent) + return maybeEvent + +{- services for use in implementing events -} +instance GetCurrentEvent (EventIO t) t where + getCurrentEvent = EventIO (asks currentEvent) + +instance RetryEvent (EventIO t) t where + retryEventAt t = do + maybeCe <- getCurrentEvent + case maybeCe of + Nothing -> fail "retry called outside an event" + Just (EventDescriptor {event = e}) -> + scheduleEventAt t e + +instance MonadEventQueueInfo (EventIO t) t where + eventQueueSize = getEventQueue >>= queueSize + eventQueueContents = getEventQueue >>= peekQueue + + +{- The EventT type and related administrative bits (state management stuff) -} +-- |A monad which extends IO with an event queue and related operations. +-- 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. +instance DefaultStateRef (TVar a) (EventIO t) a +type EventM = EventIO Double +newtype EventIO t a = EventIO { unWrapEventIO :: ReaderT (EventIOState t) IO a } + deriving (Functor, Monad, MonadIO, MonadFix) + +{- Running (EventIO t) 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. +runEventIO :: EventIO t a -> EventIOState t -> IO a +runEventIO (EventIO x) state = runReaderT x state + +-- |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 :: (Ord t, Show t) => EventIOState t -> IO () +runEventGraphWithState state = runEventIO (whileJust_ dequeueNextEvent runEvent) state + +-- |Initialize the event queue and other stuff, run the provided \"start +-- event\", and run the queue until it's empty or until the simulation is +-- paused. +runEventGraph :: + ( MonadEvent (EventIO t) e + , Ord t, Num t, Show t + ) => e -> IO (EventIOState t) +runEventGraph e = do + state <- newEventIOState 0 + + runEventIO (scheduleEventIn 0 e) state + runEventGraphWithState state + + return state + +{- the main state vectors -} +data EventIOState t = EventIOState + { currentEvent :: Maybe (EventDescriptor (EventIO t) t) + , currentTime :: TVar t + , simRunning :: TVar Bool + , nextEventId :: TVar EventID + , eventQueue :: EventQueue t + , handlers :: EventIOHandlers t + } + +newEventIOState :: Ord t => t -> IO (EventIOState t) +newEventIOState t = do + currentTime <- newRef t + simRunning <- newRef True + nextEventId <- newRef (EventID 1) + eventQueue <- newPriorityQueue eventTime + handlers <- newEventIOHandlers + + return $ EventIOState + { currentEvent = Nothing + , currentTime = currentTime + , simRunning = simRunning + , nextEventId = nextEventId + , eventQueue = eventQueue + , handlers = handlers + } + +{- Miscellaneous small state management functions -} +getNextEventId :: EventIO t EventID +getNextEventId = do + state <- EventIO ask + atomicModifyRef (nextEventId state) (\i -> (succ i, i)) + +{- Support for debugging event handlers -} +data EventIOHandlers t = EventIOHandlers + { onEventSchedule :: TVar (HandlerSet (EventIO t) (EventDescriptor (EventIO t) t) ()) + , onEventCancel :: TVar (HandlerSet (EventIO t) (Either EventID (EventDescriptor (EventIO t) t)) ()) + , onEventDispatch :: TVar (HandlerSet (EventIO t) (EventDescriptor (EventIO t) t) ()) + , onEventComplete :: TVar (HandlerSet (EventIO t) (EventDescriptor (EventIO t) t) ()) + , onClockChanged :: TVar (HandlerSet (EventIO t) (t, t) ()) -- (old time, new time) + } + +type HandlerAccessor t a b = EventIOHandlers t -> TVar (HandlerSet (EventIO t) a b) + +newEventIOHandlers :: IO (EventIOHandlers t) +newEventIOHandlers = do + onEventSchedule <- newRef emptyHandlerSet + onEventCancel <- newRef emptyHandlerSet + onEventDispatch <- newRef emptyHandlerSet + onEventComplete <- newRef emptyHandlerSet + onClockChanged <- newRef emptyHandlerSet + return $ EventIOHandlers + { onEventSchedule = onEventSchedule + , onEventCancel = onEventCancel + , onEventDispatch = onEventDispatch + , onEventComplete = onEventComplete + , onClockChanged = onClockChanged + } + +-- |Add an event handler to be called when the specified event happens. +addHandler :: HandlerAccessor t a b -> (a -> EventIO t b) -> EventIO t HandlerID +addHandler hSel h = do + hSet <- EventIO (asks (hSel.handlers)) + atomicModifyRef hSet (addHandlerToSet h) + +-- |Remove an event handler given its ID, and return it if it was in the set. +removeHandler :: HandlerAccessor t a b -> HandlerID -> EventIO t (Maybe (a -> EventIO t b)) +removeHandler hSel hId = do + hSet <- EventIO (asks (hSel.handlers)) + atomicModifyRef hSet (removeHandlerFromSet hId) + +invokeHandler :: HandlerAccessor t a b -> a -> EventIO t b +invokeHandler h args = do + hSet <- EventIO (asks (h.handlers)) >>= readRef + invokeHandlers hSet args + + +{- internal support relating to the event queue -} +type EventQueue t = PriorityQueue (EventIO t) (EventDescriptor (EventIO t) t) + +getEventQueue :: EventIO t (EventQueue t) +getEventQueue = EventIO (asks eventQueue) + +dequeueNextEvent :: EventIO t (Maybe (EventDescriptor (EventIO t) t)) +dequeueNextEvent = do + running <- isSimulationRunning + if running + then getEventQueue >>= dequeue + else return Nothing + diff --git a/src/Control/Monad/EventT.hs b/src/Control/Monad/EventT.hs --- a/src/Control/Monad/EventT.hs +++ b/src/Control/Monad/EventT.hs @@ -1,6 +1,5 @@ {- - ``Control/Monad/Event/EventT'' - - (c) 2008 Cook, J. MR SSD, Inc. -} {-# LANGUAGE GeneralizedNewtypeDeriving, @@ -15,7 +14,6 @@ module Control.Monad.EventT ( EventT - , EventM , runEventT , runEventGraph , runEventGraphWithState @@ -31,10 +29,6 @@ , addHandler , removeHandler - - , SetDebugHandlers(..) - , DebugHandlerOptions(..) - , defaultHandlerOptions ) where import Control.Monad.Event.Classes @@ -46,16 +40,17 @@ import Control.Monad.RWS import Control.Monad.Loops -import Text.PrettyPrint.Leijen +import Text.PrettyPrint.HughesPJ 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 Control.Monad.Error.Class (MonadError(..)) +import Control.Monad (MonadPlus(..)) +import Control.Monad.Cont.Class (MonadCont(..)) +import Control.Monad.Fix (MonadFix(..)) import qualified Data.Map as M @@ -90,17 +85,22 @@ {- 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 +instance (Monad m, Show 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 5 (show eid)) <> text "|" - <> fill 10 (pretty t) + <> text (fill 10 (show t)) ) <> colon - <+> align eventDescription + <+> eventDescription ) + + where fill n [] = replicate n ' ' + fill 0 xs = xs + fill (n+1) (x:xs) = x : fill n xs + runEvent event@(EventDescriptor {event = e}) = do setCurrentTime (eventTime event) @@ -111,11 +111,8 @@ 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) - +instance (Monad m, Ord t, MonadEvent (EventT t m) e) => ScheduleEvent (EventT t m) t e where + scheduleEventAt t e = do eid <- getNextEventId let event = EventDescriptor {eventId = eid, eventTime = t, event = e} @@ -124,8 +121,6 @@ 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 @@ -139,12 +134,12 @@ getCurrentEvent = EventT (asks currentEvent) instance Monad m => RetryEvent (EventT t m) t where - retryEventIn dt = do + retryEventAt t = do maybeCe <- getCurrentEvent case maybeCe of Nothing -> fail "retry called outside an event" Just (EventDescriptor {event = e}) -> - scheduleEventIn dt e + scheduleEventAt t e instance (Monad m, Ord t) => MonadEventQueueInfo (EventT t m) t where eventQueueSize = withEventQueue queueSize @@ -228,8 +223,10 @@ 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 +instance MonadFix m => MonadFix (EventT t m) where + mfix f = EventT $ + mfix $ \x -> + unWrapEventT (f x) {- Running (EventT t m) actions and whole event graphs -} -- |Run an 'EventT' wrapped action. This is a \"raw\" action - there is no @@ -244,7 +241,7 @@ -- empty or until the simulation is paused using 'pauseSimulation' -- or something equivalent. runEventGraphWithState :: - ( Monad m, Ord t, Pretty t + ( Monad m, Ord t, Show 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 @@ -255,7 +252,7 @@ -- paused. runEventGraph :: ( Monad m, MonadEvent (EventT t m) e - , Ord t, Num t, Pretty t + , Ord t, Num t, Show t ) => e -> m (EventT_RState t m, EventT_RWState t m) runEventGraph e = do let rState = newEventT_RState @@ -430,47 +427,3 @@ , 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 () -