module Control.Monad.EventT
(
EventT
, runEventT
, runEventGraph
, runEventGraphWithState
, newEventT_RState
, newEventT_RWState
, 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.RWS
import Control.Monad.Loops
import Text.PrettyPrint.HughesPJ
import IO
import Control.Monad.Trans
import Control.Concurrent (threadDelay)
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
instance Monad m => MonadTime (EventT t m) t where
getCurrentTime = EventT (gets currentTime)
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)
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)
instance Monad m => MonadEvent (EventT t m) (EventT t m a) where
describeEvent e = return (text "Undocumented Event")
runEvent e = e >> return ()
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 (
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 eventDispatchHandler event
EventT (local (\env -> env {currentEvent = Just event}) (unWrapEventT (runEvent e)))
invokeHandler eventCompleteHandler event
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}
enqueue eventQueueRef event
invokeHandler eventScheduleHandler event
return eid
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
instance Monad m => GetCurrentEvent (EventT t m) t where
getCurrentEvent = EventT (asks currentEvent)
instance Monad m => RetryEvent (EventT t m) 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 (Monad m, Ord t) => MonadEventQueueInfo (EventT t m) t where
eventQueueSize = withEventQueue queueSize
eventQueueContents = withEventQueue peekQueue
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
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
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
instance MonadCont m => MonadCont (EventT t m) where
callCC f = EventT $
callCC $ \cont ->
unWrapEventT (f (EventT . cont))
instance MonadFix m => MonadFix (EventT t m) where
mfix f = EventT $
mfix $ \x ->
unWrapEventT (f x)
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)
runEventGraphWithState ::
( 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
return rwState
runEventGraph ::
( Monad m, MonadEvent (EventT t m) e
, Ord t, Num t, Show 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)
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
}
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
}
newEventT_RState :: EventT_RState t m
newEventT_RState = EventT_RState
{ currentEvent = Nothing
}
getNextEventId :: Monad m => EventT t m EventID
getNextEventId = do
rwState <- EventT get
let eID = nextEventId rwState
EventT (put (rwState {nextEventId = succ eID}))
return eID
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) ()
}
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
)
onEventSchedule :: HandlerAccessor t m (EventDescriptor (EventT t m) t) ()
onEventSchedule = (eventScheduleHandler, \h hs -> hs {eventScheduleHandler = h})
onEventCancel :: HandlerAccessor t m (Either EventID (EventDescriptor (EventT t m) t)) ()
onEventCancel = (eventCancelHandler, \h hs -> hs {eventCancelHandler = h})
onEventDispatch :: HandlerAccessor t m (EventDescriptor (EventT t m) t) ()
onEventDispatch = (eventDispatchHandler, \h hs -> hs {eventDispatchHandler = h})
onEventComplete :: HandlerAccessor t m (EventDescriptor (EventT t m) t) ()
onEventComplete = (eventCompleteHandler, \h hs -> hs {eventCompleteHandler = h})
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
}
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
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
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
data DebugHandlerOptions = DebugHandlerOptions
{
sync :: Bool
,
showDispatches :: Bool
,
showCancels :: Bool
,
showSchedules :: Bool
,
dumpQueue :: Bool
} deriving Show
defaultHandlerOptions = DebugHandlerOptions
{ sync = False
, showDispatches = False
, showCancels = False
, showSchedules = False
, dumpQueue = False
}