module Control.Monad.Event.BasicEvents
( SimControl(..), AdHocEvent(..)
, (?:), (?::), (&), (&-), (@:)
) where
import Control.Monad.Event.Classes
import Control.Monad.Trans
import Text.PrettyPrint.HughesPJ
import Text.PrettyPrint.HughesPJClass
import Data.Typeable
data SimControl (m :: * -> *) = StopSim | StartSim
deriving (Eq, Show)
tyCon_SimControl = mkTyCon "Control.Monad.Event.BasicEvents.SimControl"
instance Typeable1 m => Typeable (SimControl m) where
typeOf y = mkTyConApp tyCon_SimControl [typeOf1 ((undefined :: SimControl m -> m ()) y)]
instance Pretty (SimControl m) where
pPrint StopSim = text "Stop Simulation"
pPrint StartSim = text "Start Simulation"
instance (MonadSimControl m, Typeable1 m) => MonadEvent m (SimControl m) where
describeEvent e = return (pPrint e)
runEvent StopSim = pauseSimulation >> return ()
runEvent StartSim = resumeSimulation >> return ()
data AdHocEvent m = AdHocEvent (m Doc) (m ())
tyCon_AdHocEvent = mkTyCon "Control.Monad.Event.BasicEvents.AdHocEvent"
instance Typeable1 m => Typeable (AdHocEvent m) where
typeOf y = mkTyConApp tyCon_AdHocEvent [typeOf1 ((undefined :: AdHocEvent m -> m ()) y)]
instance (Monad m, Typeable1 m) => MonadEvent m (AdHocEvent m) where
describeEvent (AdHocEvent doc _) = doc
runEvent (AdHocEvent _ action) = action
infixr 2 ?:
(?:) :: (Monad m, Pretty desc) => desc -> m a -> AdHocEvent m
description ?: action = AdHocEvent (return (pPrint description)) (action >> return ())
infixr 2 ?::
(?::) :: (Monad m) => m Doc -> m a -> AdHocEvent m
description ?:: action = AdHocEvent (description) (action >> return ())
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
infixr 0 &-
(&-) :: (ScheduleEvent m t e2, MonadEvent m e1, Typeable1 m) => e1 -> e2 -> AdHocEvent m
e1 &- e2 = e1 & (describeEvent e2 ?:: doNext e2)
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)