{- - ``Control/Monad/Event/BasicEvents'' -} {-# 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.HughesPJ import Text.PrettyPrint.HughesPJClass {- reified simulation control events -} data SimControl (m :: * -> *) = StopSim | StartSim deriving (Eq, Show) instance Pretty (SimControl m) where pPrint StopSim = text "Stop Simulation" pPrint StartSim = text "Start Simulation" instance MonadSimControl m => MonadEvent m (SimControl m) where describeEvent e = return (pPrint 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 (pPrint 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 ()) -- |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 (fsep [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, Num t) => e -> t -> AdHocEvent m e @: t = doc ?:: scheduleEventIn t e where doc = do description <- describeEvent e return (parens (text "@" <+> text "+" <> pPrint t) <> colon <+> description)