BasicEvents.hs

{-
 -      ``Control/Monad/Event/BasicEvents''
 -      (c) 2008 Cook, J. MR  SSD, Inc.
 -}
{-# 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.Leijen

{- 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"

instance MonadSimControl m => MonadEvent m (SimControl m) where
        describeEvent e         = return (pretty 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 (pretty 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 ())



-- |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
e1 & e2 = doc ?:: e3
        where
                doc = do
                        d1 <- describeEvent e1
                        d2 <- describeEvent e2
                        return (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) => e -> t -> AdHocEvent m
e @: t = doc ?:: scheduleEventIn t e
        where doc = do
                description <- describeEvent e
                return (parens (text "@" <+> text "+" <> pretty t) <> colon <+> description)