{-# LANGUAGE RecursiveDo, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, MonoLocalBinds, RankNTypes #-}

-- |
-- Module     : Simulation.Aivika.Trans.Internal.Event
-- Copyright  : Copyright (c) 2009-2017, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 8.0.1
--
-- The module defines the 'Event' monad transformer which is very similar to the 'Dynamics'
-- monad transformer but only now the computation is strongly synchronized with the event queue.
--
module Simulation.Aivika.Trans.Internal.Event
       (-- * Event Monad
        Event(..),
        EventLift(..),
        EventProcessing(..),
        invokeEvent,
        runEventInStartTime,
        runEventInStopTime,
        -- * Event Queue
        EventPriority(..),
        EventQueueing(..),
        enqueueEventWithCancellation,
        enqueueEventWithStartTime,
        enqueueEventWithStopTime,
        enqueueEventWithTimes,
        enqueueEventWithPoints,
        enqueueEventWithIntegTimes,
        yieldEvent,
        eventPriority,
        -- * Cancelling Event
        EventCancellation,
        cancelEvent,
        eventCancelled,
        eventFinished,
        -- * Error Handling
        catchEvent,
        finallyEvent,
        throwEvent,
        -- * Memoization
        memoEvent,
        memoEventInTime,
        -- * Disposable
        DisposableEvent(..),
        -- * Retrying Computation
        retryEvent,
        -- * Synchronizing IO Actions
        EventIOQueueing(..),
        enqueueEventIOWithStartTime,
        enqueueEventIOWithStopTime,
        enqueueEventIOWithTimes,
        enqueueEventIOWithPoints,
        enqueueEventIOWithIntegTimes,
        -- * Debugging
        traceEvent) where

import Data.Monoid hiding ((<>))
import Data.Semigroup (Semigroup(..))

import Control.Exception
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Fix
import Control.Monad.Fail
import qualified Control.Monad.Catch as MC
import Control.Applicative

import Debug.Trace (trace)

import Simulation.Aivika.Trans.Exception
import Simulation.Aivika.Trans.Ref.Base
import Simulation.Aivika.Trans.Comp
import Simulation.Aivika.Trans.DES
import Simulation.Aivika.Trans.Internal.Types
import Simulation.Aivika.Trans.Internal.Specs
import Simulation.Aivika.Trans.Internal.Parameter
import Simulation.Aivika.Trans.Internal.Simulation
import Simulation.Aivika.Trans.Internal.Dynamics

instance Monad m => Monad (Event m) where

  {-# INLINE (>>=) #-}
  (Event Point m -> m a
m) >>= :: forall a b. Event m a -> (a -> Event m b) -> Event m b
>>= a -> Event m b
k =
    forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p -> 
    do a
a <- Point m -> m a
m Point m
p
       let Event Point m -> m b
m' = a -> Event m b
k a
a
       Point m -> m b
m' Point m
p

instance Functor m => Functor (Event m) where
  
  {-# INLINE fmap #-}
  fmap :: forall a b. (a -> b) -> Event m a -> Event m b
fmap a -> b
f (Event Point m -> m a
x) = forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall a b. (a -> b) -> a -> b
$ Point m -> m a
x Point m
p

instance Applicative m => Applicative (Event m) where
  
  {-# INLINE pure #-}
  pure :: forall a. a -> Event m a
pure = forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  
  {-# INLINE (<*>) #-}
  (Event Point m -> m (a -> b)
x) <*> :: forall a b. Event m (a -> b) -> Event m a -> Event m b
<*> (Event Point m -> m a
y) = forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p -> Point m -> m (a -> b)
x Point m
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Point m -> m a
y Point m
p

instance Monad m => MonadFail (Event m) where

  {-# INLINE fail #-}
  fail :: forall a. String -> Event m a
fail = forall a. HasCallStack => String -> a
error

instance MonadTrans Event where

  {-# INLINE lift #-}
  lift :: forall (m :: * -> *) a. Monad m => m a -> Event m a
lift = forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

instance MonadIO m => MonadIO (Event m) where
  
  {-# INLINE liftIO #-}
  liftIO :: forall a. IO a -> Event m a
liftIO = forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance Monad m => MonadCompTrans Event m where

  {-# INLINE liftComp #-}
  liftComp :: forall a. m a -> Event m a
liftComp = forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

-- | A type class to lift the 'Event' computations into other computations.
class EventLift t m where
  
  -- | Lift the specified 'Event' computation into another computation.
  liftEvent :: Event m a -> t m a

instance Monad m => EventLift Event m where
  
  {-# INLINE liftEvent #-}
  liftEvent :: forall a. Event m a -> Event m a
liftEvent = forall a. a -> a
id

instance Monad m => DynamicsLift Event m where
  
  {-# INLINE liftDynamics #-}
  liftDynamics :: forall a. Dynamics m a -> Event m a
liftDynamics (Dynamics Point m -> m a
x) = forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event Point m -> m a
x

instance Monad m => SimulationLift Event m where

  {-# INLINE liftSimulation #-}
  liftSimulation :: forall a. Simulation m a -> Event m a
liftSimulation (Simulation Run m -> m a
x) = forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ Run m -> m a
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Point m -> Run m
pointRun 

instance Monad m => ParameterLift Event m where

  {-# INLINE liftParameter #-}
  liftParameter :: forall a. Parameter m a -> Event m a
liftParameter (Parameter Run m -> m a
x) = forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ Run m -> m a
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Point m -> Run m
pointRun

-- | Exception handling within 'Event' computations.
catchEvent :: (MonadException m, Exception e) => Event m a -> (e -> Event m a) -> Event m a
{-# INLINABLE catchEvent #-}
catchEvent :: forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
Event m a -> (e -> Event m a) -> Event m a
catchEvent (Event Point m -> m a
m) e -> Event m a
h =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p -> 
  forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
m a -> (e -> m a) -> m a
catchComp (Point m -> m a
m Point m
p) forall a b. (a -> b) -> a -> b
$ \e
e ->
  let Event Point m -> m a
m' = e -> Event m a
h e
e in Point m -> m a
m' Point m
p
                           
-- | A computation with finalization part like the 'finally' function.
finallyEvent :: MonadException m => Event m a -> Event m b -> Event m a
{-# INLINABLE finallyEvent #-}
finallyEvent :: forall (m :: * -> *) a b.
MonadException m =>
Event m a -> Event m b -> Event m a
finallyEvent (Event Point m -> m a
m) (Event Point m -> m b
m') =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  forall (m :: * -> *) a b. MonadException m => m a -> m b -> m a
finallyComp (Point m -> m a
m Point m
p) (Point m -> m b
m' Point m
p)

-- | Like the standard 'throw' function.
throwEvent :: (MonadException m, Exception e) => e -> Event m a
{-# INLINABLE throwEvent #-}
throwEvent :: forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> Event m a
throwEvent e
e =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> m a
throwComp e
e

-- | Runs an action with asynchronous exceptions disabled.
maskEvent :: MC.MonadMask m => ((forall a. Event m a -> Event m a) -> Event m b) -> Event m b
{-# INLINABLE maskEvent #-}
maskEvent :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. Event m a -> Event m a) -> Event m b) -> Event m b
maskEvent (forall a. Event m a -> Event m a) -> Event m b
a =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MC.mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
u ->
  forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p ((forall a. Event m a -> Event m a) -> Event m b
a forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a} {a}.
(m a -> m a) -> Event m a -> Event m a
q forall a. m a -> m a
u)
  where q :: (m a -> m a) -> Event m a -> Event m a
q m a -> m a
u (Event Point m -> m a
b) = forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event (m a -> m a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point m -> m a
b)

-- | Like 'maskEvent', but the masked computation is not interruptible.
uninterruptibleMaskEvent :: MC.MonadMask m => ((forall a. Event m a -> Event m a) -> Event m b) -> Event m b
{-# INLINABLE uninterruptibleMaskEvent #-}
uninterruptibleMaskEvent :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. Event m a -> Event m a) -> Event m b) -> Event m b
uninterruptibleMaskEvent (forall a. Event m a -> Event m a) -> Event m b
a =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MC.uninterruptibleMask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
u ->
  forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p ((forall a. Event m a -> Event m a) -> Event m b
a forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a} {a}.
(m a -> m a) -> Event m a -> Event m a
q forall a. m a -> m a
u)
  where q :: (m a -> m a) -> Event m a -> Event m a
q m a -> m a
u (Event Point m -> m a
b) = forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event (m a -> m a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point m -> m a
b)

-- | An implementation of 'generalBracket'.
generalBracketEvent :: MC.MonadMask m
                       => Event m a
                       -> (a -> MC.ExitCase b -> Event m c)
                       -> (a -> Event m b)
                       -> Event m (b, c)
{-# INLINABLE generalBracketEvent #-}
generalBracketEvent :: forall (m :: * -> *) a b c.
MonadMask m =>
Event m a
-> (a -> ExitCase b -> Event m c)
-> (a -> Event m b)
-> Event m (b, c)
generalBracketEvent Event m a
acquire a -> ExitCase b -> Event m c
release a -> Event m b
use =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p -> do
    forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
MC.generalBracket
      (forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p Event m a
acquire)
      (\a
resource ExitCase b
e -> forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ a -> ExitCase b -> Event m c
release a
resource ExitCase b
e)
      (\a
resource -> forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ a -> Event m b
use a
resource)

instance MonadFix m => MonadFix (Event m) where

  {-# INLINE mfix #-}
  mfix :: forall a. (a -> Event m a) -> Event m a
mfix a -> Event m a
f = 
    forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
    do { rec { a
a <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p (a -> Event m a
f a
a) }; forall (m :: * -> *) a. Monad m => a -> m a
return a
a }

instance MonadException m => MC.MonadThrow (Event m) where

  {-# INLINE throwM #-}
  throwM :: forall e a. Exception e => e -> Event m a
throwM = forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> Event m a
throwEvent

instance MonadException m => MC.MonadCatch (Event m) where

  {-# INLINE catch #-}
  catch :: forall e a.
Exception e =>
Event m a -> (e -> Event m a) -> Event m a
catch = forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
Event m a -> (e -> Event m a) -> Event m a
catchEvent

instance (MonadException m, MC.MonadMask m) => MC.MonadMask (Event m) where

  {-# INLINE mask #-}
  mask :: forall b.
((forall a. Event m a -> Event m a) -> Event m b) -> Event m b
mask = forall (m :: * -> *) b.
MonadMask m =>
((forall a. Event m a -> Event m a) -> Event m b) -> Event m b
maskEvent
  
  {-# INLINE uninterruptibleMask #-}
  uninterruptibleMask :: forall b.
((forall a. Event m a -> Event m a) -> Event m b) -> Event m b
uninterruptibleMask = forall (m :: * -> *) b.
MonadMask m =>
((forall a. Event m a -> Event m a) -> Event m b) -> Event m b
uninterruptibleMaskEvent
  
  {-# INLINE generalBracket #-}
  generalBracket :: forall a b c.
Event m a
-> (a -> ExitCase b -> Event m c)
-> (a -> Event m b)
-> Event m (b, c)
generalBracket = forall (m :: * -> *) a b c.
MonadMask m =>
Event m a
-> (a -> ExitCase b -> Event m c)
-> (a -> Event m b)
-> Event m (b, c)
generalBracketEvent

-- | Run the 'Event' computation in the start time involving all
-- pending 'CurrentEvents' in the processing too.
runEventInStartTime :: MonadDES m => Event m a -> Simulation m a
{-# INLINE runEventInStartTime #-}
runEventInStartTime :: forall (m :: * -> *) a. MonadDES m => Event m a -> Simulation m a
runEventInStartTime = forall (m :: * -> *) a. Dynamics m a -> Simulation m a
runDynamicsInStartTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
EventQueueing m =>
Event m a -> Dynamics m a
runEvent

-- | Run the 'Event' computation in the stop time involving all
-- pending 'CurrentEvents' in the processing too.
runEventInStopTime :: MonadDES m => Event m a -> Simulation m a
{-# INLINE runEventInStopTime #-}
runEventInStopTime :: forall (m :: * -> *) a. MonadDES m => Event m a -> Simulation m a
runEventInStopTime = forall (m :: * -> *) a. Dynamics m a -> Simulation m a
runDynamicsInStopTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
EventQueueing m =>
Event m a -> Dynamics m a
runEvent

-- | Return the current event priority.
eventPriority :: MonadDES m => Event m EventPriority
{-# INLINE eventPriority #-}
eventPriority :: forall (m :: * -> *). MonadDES m => Event m EventPriority
eventPriority =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Point m -> EventPriority
pointPriority

-- | Actuate the event handler in the specified time points.
enqueueEventWithTimes :: MonadDES m => [Double] -> Event m () -> Event m ()
{-# INLINABLE enqueueEventWithTimes #-}
enqueueEventWithTimes :: forall (m :: * -> *).
MonadDES m =>
[Double] -> Event m () -> Event m ()
enqueueEventWithTimes [Double]
ts Event m ()
e = [Double] -> Event m ()
loop [Double]
ts
  where loop :: [Double] -> Event m ()
loop []       = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        loop (Double
t : [Double]
ts) = forall (m :: * -> *).
EventQueueing m =>
Double -> Event m () -> Event m ()
enqueueEvent Double
t forall a b. (a -> b) -> a -> b
$ Event m ()
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Double] -> Event m ()
loop [Double]
ts
       
-- | Actuate the event handler in the specified time points.
enqueueEventWithPoints :: MonadDES m => [Point m] -> Event m () -> Event m ()
{-# INLINABLE enqueueEventWithPoints #-}
enqueueEventWithPoints :: forall (m :: * -> *).
MonadDES m =>
[Point m] -> Event m () -> Event m ()
enqueueEventWithPoints [Point m]
xs (Event Point m -> m ()
e) = [Point m] -> Event m ()
loop [Point m]
xs
  where loop :: [Point m] -> Event m ()
loop []       = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        loop (Point m
x : [Point m]
xs) = forall (m :: * -> *).
EventQueueing m =>
Double -> Event m () -> Event m ()
enqueueEvent (forall (m :: * -> *). Point m -> Double
pointTime Point m
x) forall a b. (a -> b) -> a -> b
$ 
                        forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
                        do Point m -> m ()
e Point m
x    -- N.B. we substitute the time point!
                           forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ [Point m] -> Event m ()
loop [Point m]
xs
                           
-- | Actuate the event handler in the integration time points.
enqueueEventWithIntegTimes :: MonadDES m => Event m () -> Event m ()
{-# INLINABLE enqueueEventWithIntegTimes #-}
enqueueEventWithIntegTimes :: forall (m :: * -> *). MonadDES m => Event m () -> Event m ()
enqueueEventWithIntegTimes Event m ()
e =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  let points :: [Point m]
points = forall (m :: * -> *). Point m -> [Point m]
integPointsStartingFrom Point m
p
  in forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadDES m =>
[Point m] -> Event m () -> Event m ()
enqueueEventWithPoints [Point m]
points Event m ()
e

-- | Actuate the event handler in the start time point.
enqueueEventWithStartTime :: MonadDES m => Event m () -> Event m ()
{-# INLINABLE enqueueEventWithStartTime #-}
enqueueEventWithStartTime :: forall (m :: * -> *). MonadDES m => Event m () -> Event m ()
enqueueEventWithStartTime Event m ()
e =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  let p0 :: Point m
p0 = forall (m :: * -> *). Run m -> Point m
integStartPoint forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Point m -> Run m
pointRun Point m
p
  in forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadDES m =>
[Point m] -> Event m () -> Event m ()
enqueueEventWithPoints [Point m
p0] Event m ()
e

-- | Actuate the event handler in the final time point.
enqueueEventWithStopTime :: MonadDES m => Event m () -> Event m ()
{-# INLINABLE enqueueEventWithStopTime #-}
enqueueEventWithStopTime :: forall (m :: * -> *). MonadDES m => Event m () -> Event m ()
enqueueEventWithStopTime Event m ()
e =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  let p0 :: Point m
p0 = forall (m :: * -> *). Run m -> Point m
simulationStopPoint forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Point m -> Run m
pointRun Point m
p
  in forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadDES m =>
[Point m] -> Event m () -> Event m ()
enqueueEventWithPoints [Point m
p0] Event m ()
e

-- | It allows cancelling the event.
data EventCancellation m =
  EventCancellation { forall (m :: * -> *). EventCancellation m -> Event m ()
cancelEvent :: Event m (),
                      -- ^ Cancel the event.
                      forall (m :: * -> *). EventCancellation m -> Event m Bool
eventCancelled :: Event m Bool,
                      -- ^ Test whether the event was cancelled.
                      forall (m :: * -> *). EventCancellation m -> Event m Bool
eventFinished :: Event m Bool
                      -- ^ Test whether the event was processed and finished.
                    }

-- | Enqueue the event with an ability to cancel it.
enqueueEventWithCancellation :: MonadDES m => Double -> Event m () -> Event m (EventCancellation m)
{-# INLINABLE enqueueEventWithCancellation #-}
enqueueEventWithCancellation :: forall (m :: * -> *).
MonadDES m =>
Double -> Event m () -> Event m (EventCancellation m)
enqueueEventWithCancellation Double
t Event m ()
e =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  do let r :: Run m
r = forall (m :: * -> *). Point m -> Run m
pointRun Point m
p
     Ref m Bool
cancelledRef <- forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => a -> Simulation m (Ref m a)
newRef Bool
False
     Ref m Bool
cancellableRef <- forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => a -> Simulation m (Ref m a)
newRef Bool
True
     Ref m Bool
finishedRef <- forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => a -> Simulation m (Ref m a)
newRef Bool
False
     let cancel :: Event m ()
cancel =
           forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
           do Bool
x <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => Ref m a -> Event m a
readRef Ref m Bool
cancellableRef
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
x forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> Event m ()
writeRef Ref m Bool
cancelledRef Bool
True
         cancelled :: Event m Bool
cancelled =
           forall (m :: * -> *) a. MonadRef m => Ref m a -> Event m a
readRef Ref m Bool
cancelledRef
         finished :: Event m Bool
finished =
           forall (m :: * -> *) a. MonadRef m => Ref m a -> Event m a
readRef Ref m Bool
finishedRef
     forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$
       forall (m :: * -> *).
EventQueueing m =>
Double -> Event m () -> Event m ()
enqueueEvent Double
t forall a b. (a -> b) -> a -> b
$
       forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
       do forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> Event m ()
writeRef Ref m Bool
cancellableRef Bool
False
          Bool
x <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => Ref m a -> Event m a
readRef Ref m Bool
cancelledRef
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
x forall a b. (a -> b) -> a -> b
$
            do forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p Event m ()
e
               forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> Event m ()
writeRef Ref m Bool
finishedRef Bool
True
     forall (m :: * -> *) a. Monad m => a -> m a
return EventCancellation { cancelEvent :: Event m ()
cancelEvent   = Event m ()
cancel,
                                eventCancelled :: Event m Bool
eventCancelled = Event m Bool
cancelled,
                                eventFinished :: Event m Bool
eventFinished = Event m Bool
finished }

-- | Memoize the 'Event' computation, always returning the same value
-- within a simulation run.
memoEvent :: MonadDES m => Event m a -> Simulation m (Event m a)
{-# INLINABLE memoEvent #-}
memoEvent :: forall (m :: * -> *) a.
MonadDES m =>
Event m a -> Simulation m (Event m a)
memoEvent Event m a
m =
  forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall a b. (a -> b) -> a -> b
$ \Run m
r ->
  do Ref m (Maybe a)
ref <- forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => a -> Simulation m (Ref m a)
newRef forall a. Maybe a
Nothing
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
       do Maybe a
x <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => Ref m a -> Event m a
readRef Ref m (Maybe a)
ref
          case Maybe a
x of
            Just a
v -> forall (m :: * -> *) a. Monad m => a -> m a
return a
v
            Maybe a
Nothing ->
              do a
v <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p Event m a
m
                 forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> Event m ()
writeRef Ref m (Maybe a)
ref (forall a. a -> Maybe a
Just a
v)
                 forall (m :: * -> *) a. Monad m => a -> m a
return a
v

-- | Memoize the 'Event' computation, always returning the same value
-- in the same modeling time. After the time changes, the value is
-- recalculated by demand.
--
-- It is possible to implement this function efficiently, for the 'Event'
-- computation is always synchronized with the event queue which time
-- flows in one direction only. This synchronization is a key difference
-- between the 'Event' and 'Dynamics' computations.
memoEventInTime :: MonadDES m => Event m a -> Simulation m (Event m a)
{-# INLINABLE memoEventInTime #-}
memoEventInTime :: forall (m :: * -> *) a.
MonadDES m =>
Event m a -> Simulation m (Event m a)
memoEventInTime Event m a
m =
  forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall a b. (a -> b) -> a -> b
$ \Run m
r ->
  do Ref m (Maybe (Double, a))
ref <- forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => a -> Simulation m (Ref m a)
newRef forall a. Maybe a
Nothing
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
       do Maybe (Double, a)
x <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => Ref m a -> Event m a
readRef Ref m (Maybe (Double, a))
ref
          case Maybe (Double, a)
x of
            Just (Double
t, a
v) | Double
t forall a. Eq a => a -> a -> Bool
== forall (m :: * -> *). Point m -> Double
pointTime Point m
p ->
              forall (m :: * -> *) a. Monad m => a -> m a
return a
v
            Maybe (Double, a)
_ ->
              do a
v <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p Event m a
m
                 forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> Event m ()
writeRef Ref m (Maybe (Double, a))
ref (forall a. a -> Maybe a
Just (forall (m :: * -> *). Point m -> Double
pointTime Point m
p, a
v))
                 forall (m :: * -> *) a. Monad m => a -> m a
return a
v

-- | Enqueue the event which must be actuated with the current modeling time but later.
yieldEvent :: MonadDES m => Event m () -> Event m ()
{-# INLINABLE yieldEvent #-}
yieldEvent :: forall (m :: * -> *). MonadDES m => Event m () -> Event m ()
yieldEvent Event m ()
m =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *).
EventQueueing m =>
Double -> Event m () -> Event m ()
enqueueEvent (forall (m :: * -> *). Point m -> Double
pointTime Point m
p) Event m ()
m

-- | Defines a computation disposing some entity.
newtype DisposableEvent m =
  DisposableEvent { forall (m :: * -> *). DisposableEvent m -> Event m ()
disposeEvent :: Event m ()
                    -- ^ Dispose something within the 'Event' computation.
                  }

instance Monad m => Semigroup (DisposableEvent m) where
  {-# INLINE (<>) #-}
  DisposableEvent Event m ()
x <> :: DisposableEvent m -> DisposableEvent m -> DisposableEvent m
<> DisposableEvent Event m ()
y = forall (m :: * -> *). Event m () -> DisposableEvent m
DisposableEvent forall a b. (a -> b) -> a -> b
$ Event m ()
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Event m ()
y

instance Monad m => Monoid (DisposableEvent m) where

  {-# INLINE mempty #-}
  mempty :: DisposableEvent m
mempty = forall (m :: * -> *). Event m () -> DisposableEvent m
DisposableEvent forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()

  {-# INLINE mappend #-}
  mappend :: DisposableEvent m -> DisposableEvent m -> DisposableEvent m
mappend = forall a. Semigroup a => a -> a -> a
(<>)

-- | Retry the current computation as possible, using the specified argument
-- as a 'SimulationRetry' exception message in case of failure. It makes sense
-- for parallel distributed simulation, when we have to make a rollback,
-- awaiting for incoming messages.
retryEvent :: MonadException m => String -> Event m a
retryEvent :: forall (m :: * -> *) a. MonadException m => String -> Event m a
retryEvent String
message = forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> Event m a
throwEvent forall a b. (a -> b) -> a -> b
$ String -> SimulationRetry
SimulationRetry String
message

-- | Show the debug message with the current simulation time.
traceEvent :: MonadDES m => String -> Event m a -> Event m a
{-# INLINABLE traceEvent #-}
traceEvent :: forall (m :: * -> *) a.
MonadDES m =>
String -> Event m a -> Event m a
traceEvent String
message Event m a
m =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  forall a. String -> a -> a
trace (String
"t = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (m :: * -> *). Point m -> Double
pointTime Point m
p) forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
message) forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p Event m a
m

-- | A type class of monads that allows synchronizing the global modeling time
-- before calling the event handler so that it is rather safe to perform 'IO' actions
-- within such a handler. It is mainly destined for parallel distributed simulation,
-- but it should be supported in other cases too.
--
class (EventQueueing m, MonadIO (Event m)) => EventIOQueueing m where

  -- | Like 'enqueueEvent' but synchronizes the global modeling time before
  -- calling the specified event handler.
  enqueueEventIO :: Double -> Event m () -> Event m ()

-- | Like 'enqueueEventWithTimes' but synchronizes the global modeling time
-- before calling the specified event handler.
enqueueEventIOWithTimes :: (MonadDES m, EventIOQueueing m) => [Double] -> Event m () -> Event m ()
{-# INLINABLE enqueueEventIOWithTimes #-}
enqueueEventIOWithTimes :: forall (m :: * -> *).
(MonadDES m, EventIOQueueing m) =>
[Double] -> Event m () -> Event m ()
enqueueEventIOWithTimes [Double]
ts Event m ()
e = [Double] -> Event m ()
loop [Double]
ts
  where loop :: [Double] -> Event m ()
loop []       = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        loop (Double
t : [Double]
ts) = forall (m :: * -> *).
EventIOQueueing m =>
Double -> Event m () -> Event m ()
enqueueEventIO Double
t forall a b. (a -> b) -> a -> b
$ Event m ()
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Double] -> Event m ()
loop [Double]
ts
       
-- | Like 'enqueueEventWithPoints' but synchronizes the global modeling time
-- before calling the specified event handler.
enqueueEventIOWithPoints :: (MonadDES m, EventIOQueueing m) => [Point m] -> Event m () -> Event m ()
{-# INLINABLE enqueueEventIOWithPoints #-}
enqueueEventIOWithPoints :: forall (m :: * -> *).
(MonadDES m, EventIOQueueing m) =>
[Point m] -> Event m () -> Event m ()
enqueueEventIOWithPoints [Point m]
xs (Event Point m -> m ()
e) = [Point m] -> Event m ()
loop [Point m]
xs
  where loop :: [Point m] -> Event m ()
loop []       = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        loop (Point m
x : [Point m]
xs) = forall (m :: * -> *).
EventIOQueueing m =>
Double -> Event m () -> Event m ()
enqueueEventIO (forall (m :: * -> *). Point m -> Double
pointTime Point m
x) forall a b. (a -> b) -> a -> b
$ 
                        forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
                        do Point m -> m ()
e Point m
x    -- N.B. we substitute the time point!
                           forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ [Point m] -> Event m ()
loop [Point m]
xs
                           
-- | Like 'enqueueEventWithIntegTimes' but synchronizes the global modeling time
-- before calling the specified event handler.
enqueueEventIOWithIntegTimes :: (MonadDES m, EventIOQueueing m) => Event m () -> Event m ()
{-# INLINABLE enqueueEventIOWithIntegTimes #-}
enqueueEventIOWithIntegTimes :: forall (m :: * -> *).
(MonadDES m, EventIOQueueing m) =>
Event m () -> Event m ()
enqueueEventIOWithIntegTimes Event m ()
e =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  let points :: [Point m]
points = forall (m :: * -> *). Point m -> [Point m]
integPointsStartingFrom Point m
p
  in forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadDES m, EventIOQueueing m) =>
[Point m] -> Event m () -> Event m ()
enqueueEventIOWithPoints [Point m]
points Event m ()
e

-- | Like 'enqueueEventWithStartTime' but synchronizes the global modeling time
-- before calling the specified event handler.
enqueueEventIOWithStartTime :: (MonadDES m, EventIOQueueing m) => Event m () -> Event m ()
{-# INLINABLE enqueueEventIOWithStartTime #-}
enqueueEventIOWithStartTime :: forall (m :: * -> *).
(MonadDES m, EventIOQueueing m) =>
Event m () -> Event m ()
enqueueEventIOWithStartTime Event m ()
e =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  let p0 :: Point m
p0 = forall (m :: * -> *). Run m -> Point m
integStartPoint forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Point m -> Run m
pointRun Point m
p
  in forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadDES m, EventIOQueueing m) =>
[Point m] -> Event m () -> Event m ()
enqueueEventIOWithPoints [Point m
p0] Event m ()
e

-- | Like 'enqueueEventWithStopTime' but synchronizes the global modeling time
-- before calling the specified event handler.
enqueueEventIOWithStopTime :: (MonadDES m, EventIOQueueing m) => Event m () -> Event m ()
{-# INLINABLE enqueueEventIOWithStopTime #-}
enqueueEventIOWithStopTime :: forall (m :: * -> *).
(MonadDES m, EventIOQueueing m) =>
Event m () -> Event m ()
enqueueEventIOWithStopTime Event m ()
e =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  let p0 :: Point m
p0 = forall (m :: * -> *). Run m -> Point m
simulationStopPoint forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Point m -> Run m
pointRun Point m
p
  in forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadDES m, EventIOQueueing m) =>
[Point m] -> Event m () -> Event m ()
enqueueEventIOWithPoints [Point m
p0] Event m ()
e