{-
- ``Control/Monad/EventM''
- (c) 2009 Cook, J. MR SSD, Inc.
-}{-# LANGUAGE
GeneralizedNewtypeDeriving,
MultiParamTypeClasses,
FlexibleContexts,
FlexibleInstances,
UndecidableInstances,
TypeSynonymInstances,
KindSignatures
#-}moduleControl.Monad.EventM(EventM,EventIO,runEventIO,runEventGraph,runEventGraphWithState,newEventIOState,onClockChanged,onEventDispatch,onEventComplete,onEventSchedule,onEventCancel,addHandler,removeHandler)whereimportControl.Monad.Event.ClassesimportControl.Monad.Event.Internal.TypesimportData.HandlerimportData.PriorityQueueimportData.StateRefimportControl.Monad.ReaderimportControl.Monad.LoopsimportText.PrettyPrint.HughesPJ{- Time management -}instanceMonadTime(EventIOt)twheregetCurrentTime=EventIO(askscurrentTime)>>=readReference{- Time Management (internal) -}setCurrentTime::t->EventIOt()setCurrentTimet1=dostate<-EventIOaskt0<-atomicModifyReference(currentTimestate)(\t0->(t1,t0))invokeHandleronClockChanged(t0,t1){- simulation control -}instanceMonadSimControl(EventIOt)whereresumeSimulation=dostate<-EventIOaskwriteReference(simRunningstate)TruepauseSimulation=dostate<-EventIOaskwriteReference(simRunningstate)FalseisSimulationRunning=EventIO(askssimRunning)>>=readReference{- MonadEvent instance for unadorned (EventIO t) actions -}instanceMonadEvent(EventIOt)(EventIOta)wheredescribeEvente=return(text"Undocumented Event")runEvente=e>>return()instanceMonadEvent(EventIOt)(IOa)wheredescribeEvente=EventIO.lift.return$text"Undocumented Event"runEvente=EventIO.lift$(e>>return()){- MonadEvent instance for Event Descriptors - this does most of
the real grunt work of running an event -}instanceShowt=>MonadEvent(EventIOt)(EventDescriptor(EventIOt)t)wheredescribeEvent(EventDescriptor{eventId=eid,eventTime=t,event=e})=doeventDescription<-describeEventereturn(brackets(text(fill5(showeid))<>text"|"<>text(fill10(showt)))<>colon<+>eventDescription)wherefilln[]=replicaten' 'fill0xs=xsfill(n+1)(x:xs)=x:fillnxsrunEventevent@(EventDescriptor{event=e})=dosetCurrentTime(eventTimeevent)invokeHandleronEventDispatcheventEventIO(local(\env->env{currentEvent=Justevent})(unWrapEventIO(runEvente)))invokeHandleronEventCompleteevent{- event scheduling, canceling, etc. -}instance(MonadEvent(EventIOt)e)=>ScheduleEvent(EventIOt)tewherescheduleEventAtte=doeid<-getNextEventIdletevent=EventDescriptor{eventId=eid,eventTime=t,event=e}q<-getEventQueueenqueueqeventinvokeHandleronEventScheduleeventreturneidinstanceCancelEvent(EventIOt)twherecancelEventeid=doq<-getEventQueuemaybeEvent<-dequeueWhereq(\e->eventIde==eid)invokeHandleronEventCancel(maybe(Lefteid)RightmaybeEvent)returnmaybeEvent{- services for use in implementing events -}instanceGetCurrentEvent(EventIOt)twheregetCurrentEvent=EventIO(askscurrentEvent)instanceRetryEvent(EventIOt)twhereretryEventAtt=domaybeCe<-getCurrentEventcasemaybeCeofNothing->fail"retry called outside an event"Just(EventDescriptor{event=e})->scheduleEventAtteinstanceMonadEventQueueInfo(EventIOt)twhereeventQueueSize=getEventQueue>>=queueSizeeventQueueContents=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.instanceHasRef(EventIOt)wherenewRefx=fmapRef((newReference::a->EventIOt(IORefa))x)instanceNewRef(RefIOa)(EventIOt)awherenewReference=liftIO.newRefinstanceReadRef(RefIOa)(EventIOt)awherereadReference=liftIO.readReferenceinstanceWriteRef(RefIOa)(EventIOt)awherewriteReferencer=liftIO.writeReferencerinstanceModifyRef(RefIOa)(EventIOt)awheremodifyReferencer=liftIO.modifyReferenceratomicModifyReferencer=liftIO.atomicModifyReferencerinstanceNewRef(Ref(EventIOt)a)IOawherenewReferencex=dor<-newReferencex`asTypeOf`(undefined::IO(IORefa))return(Refr)typeEventM=EventIODoublenewtypeEventIOta=EventIO{unWrapEventIO::ReaderT(EventIOStatet)IOa}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::EventIOta->EventIOStatet->IOarunEventIO(EventIOx)state=runReaderTxstate-- |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::(Ordt,Showt)=>EventIOStatet->IO()runEventGraphWithStatestate=runEventIO(whileJust_dequeueNextEventrunEvent)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(EventIOt)e,Ordt,Numt,Showt)=>e->IO(EventIOStatet)runEventGraphe=dostate<-newEventIOState0runEventIO(scheduleEventIn0e)staterunEventGraphWithStatestatereturnstate{- the main state vectors -}dataEventIOStatet=EventIOState{currentEvent::Maybe(EventDescriptor(EventIOt)t),currentTime::RefIOt,simRunning::RefIOBool,nextEventId::RefIOEventID,eventQueue::EventQueuet,handlers::EventIOHandlerst}newEventIOState::Ordt=>t->IO(EventIOStatet)newEventIOStatet=docurrentTime<-newReftsimRunning<-newRefTruenextEventId<-newRef(EventID1)eventQueue<-newPriorityQueueeventTimehandlers<-newEventIOHandlersreturn$EventIOState{currentEvent=Nothing,currentTime=currentTime,simRunning=simRunning,nextEventId=nextEventId,eventQueue=eventQueue,handlers=handlers}{- Miscellaneous small state management functions -}getNextEventId::EventIOtEventIDgetNextEventId=dostate<-EventIOaskatomicModifyReference(nextEventIdstate)(\i->(succi,i)){- Support for debugging event handlers -}dataEventIOHandlerst=EventIOHandlers{onEventSchedule::RefIO(HandlerSet(EventIOt)(EventDescriptor(EventIOt)t)()),onEventCancel::RefIO(HandlerSet(EventIOt)(EitherEventID(EventDescriptor(EventIOt)t))()),onEventDispatch::RefIO(HandlerSet(EventIOt)(EventDescriptor(EventIOt)t)()),onEventComplete::RefIO(HandlerSet(EventIOt)(EventDescriptor(EventIOt)t)()),onClockChanged::RefIO(HandlerSet(EventIOt)(t,t)())-- (old time, new time)}typeHandlerAccessortab=EventIOHandlerst->RefIO(HandlerSet(EventIOt)ab)newEventIOHandlers::IO(EventIOHandlerst)newEventIOHandlers=doonEventSchedule<-newRefemptyHandlerSetonEventCancel<-newRefemptyHandlerSetonEventDispatch<-newRefemptyHandlerSetonEventComplete<-newRefemptyHandlerSetonClockChanged<-newRefemptyHandlerSetreturn$EventIOHandlers{onEventSchedule=onEventSchedule,onEventCancel=onEventCancel,onEventDispatch=onEventDispatch,onEventComplete=onEventComplete,onClockChanged=onClockChanged}-- |Add an event handler to be called when the specified event happens.addHandler::HandlerAccessortab->(a->EventIOtb)->EventIOtHandlerIDaddHandlerhSelh=dohSet<-EventIO(asks(hSel.handlers))atomicModifyReferencehSet(addHandlerToSeth)-- |Remove an event handler given its ID, and return it if it was in the set.removeHandler::HandlerAccessortab->HandlerID->EventIOt(Maybe(a->EventIOtb))removeHandlerhSelhId=dohSet<-EventIO(asks(hSel.handlers))atomicModifyReferencehSet(removeHandlerFromSethId)invokeHandler::HandlerAccessortab->a->EventIOtbinvokeHandlerhargs=dohSet<-EventIO(asks(h.handlers))>>=readReferenceinvokeHandlershSetargs{- internal support relating to the event queue -}typeEventQueuet=PriorityQueue(EventIOt)(EventDescriptor(EventIOt)t)getEventQueue::EventIOt(EventQueuet)getEventQueue=EventIO(askseventQueue)dequeueNextEvent::EventIOt(Maybe(EventDescriptor(EventIOt)t))dequeueNextEvent=dorunning<-isSimulationRunningifrunningthengetEventQueue>>=dequeueelsereturnNothing