event-monad 0.0.0.2 → 0.0.1.0

raw patch · 9 files changed

+360/−138 lines, 9 filesdep +prettydep +prettyclassdep −wl-pprintdep ~priority-queuePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: pretty, prettyclass

Dependencies removed: wl-pprint

Dependency ranges changed: priority-queue

API changes (from Hackage documentation)

Files

• event-monad.cabal +9/−5
• src/Control/Monad/Event.hs +2/−20
• src/Control/Monad/Event/BasicEvents.hs +10/−22
• src/Control/Monad/Event/Classes.hs +30/−11
• src/Control/Monad/Event/Classes.hs-boot +9/−4
• src/Control/Monad/Event/Internal/EventID.hs +4/−4
• src/Control/Monad/Event/Internal/Types.hs +0/−1
• src/Control/Monad/EventM.hs +272/−0
• src/Control/Monad/EventT.hs +24/−71

@@ -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

@@ -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

@@ -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) 

@@ -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

@@ -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 ()

@@ -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

@@ -1,6 +1,5 @@ {-  -      ``Control/Monad/Event/Internal/Types''- -      (c) 2008 Cook, J. MR  SSD, Inc.  -} {-# LANGUAGE         ExistentialQuantification,

@@ -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+

@@ -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 ()-