{-
 -      ``Control/Monad/Event/BasicEvents''
 -}
{-# LANGUAGE
        MultiParamTypeClasses,
        FunctionalDependencies,
        FlexibleInstances,
        ExistentialQuantification,
        Rank2Types,
        KindSignatures,
        DeriveDataTypeable
  #-}

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

{- reified simulation control events -}
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 ()



-- |An event with description and effect supplied at run time
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

-- |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, Typeable1 m) => 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)