{-# LANGUAGE RecursiveDo, RankNTypes #-}

-- |
-- Module     : Simulation.Aivika.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
--
-- This is an internal implementation module that should never be used directly.
--
-- The module defines the 'Event' monad which is very similar to the 'Dynamics'
-- monad but only now the computation is strongly synchronized with the event queue.
--
-- The @Dynamics@ computation is defined in all time points simultaneously, while
-- the @Event@ computation can be described in every time point differently and can change
-- in discrete steps. Therefore, the former is destined for differential and difference
-- equations of System Dynamics, while the latter is destined for discrete event simulation,
-- being its core actually.
--
module Simulation.Aivika.Internal.Event
       (-- * Event Monad
        Event(..),
        EventLift(..),
        EventProcessing(..),
        invokeEvent,
        runEvent,
        runEventWith,
        runEventInStartTime,
        runEventInStopTime,
        -- * Event Queue
        enqueueEvent,
        enqueueEventWithCancellation,
        enqueueEventWithStartTime,
        enqueueEventWithStopTime,
        enqueueEventWithTimes,
        enqueueEventWithPoints,
        enqueueEventWithIntegTimes,
        yieldEvent,
        eventQueueCount,
        -- * Cancelling Event
        EventCancellation,
        cancelEvent,
        eventCancelled,
        eventFinished,
        -- * Error Handling
        catchEvent,
        finallyEvent,
        throwEvent,
        -- * Memoization
        memoEvent,
        memoEventInTime,
        -- * Disposable
        DisposableEvent(..),
        -- * Retrying Computation
        retryEvent,
        -- * Debugging
        traceEvent) where

import Data.IORef
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 qualified Simulation.Aivika.PriorityQueue as PQ

import Simulation.Aivika.Internal.Specs
import Simulation.Aivika.Internal.Parameter
import Simulation.Aivika.Internal.Simulation
import Simulation.Aivika.Internal.Dynamics

-- | A value in the 'Event' monad represents a polymorphic time varying function
-- which is strongly synchronized with the event queue.
newtype Event a = Event (Point -> IO a)

instance Monad Event where
  return :: a -> Event a
return  = a -> Event a
forall a. a -> Event a
returnE
  Event a
m >>= :: Event a -> (a -> Event b) -> Event b
>>= a -> Event b
k = Event a -> (a -> Event b) -> Event b
forall a b. Event a -> (a -> Event b) -> Event b
bindE Event a
m a -> Event b
k

returnE :: a -> Event a
{-# INLINE returnE #-}
returnE :: a -> Event a
returnE a
a = (Point -> IO a) -> Event a
forall a. (Point -> IO a) -> Event a
Event (\Point
p -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a)

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

instance Functor Event where
  fmap :: (a -> b) -> Event a -> Event b
fmap = (a -> b) -> Event a -> Event b
forall a b. (a -> b) -> Event a -> Event b
liftME

instance Applicative Event where
  pure :: a -> Event a
pure = a -> Event a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: Event (a -> b) -> Event a -> Event b
(<*>) = Event (a -> b) -> Event a -> Event b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance MonadFail Event where
  fail :: String -> Event a
fail = String -> Event a
forall a. HasCallStack => String -> a
error

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

instance MonadIO Event where
  liftIO :: IO a -> Event a
liftIO IO a
m = (Point -> IO a) -> Event a
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO a) -> Event a) -> (Point -> IO a) -> Event a
forall a b. (a -> b) -> a -> b
$ IO a -> Point -> IO a
forall a b. a -> b -> a
const IO a
m

instance ParameterLift Event where
  liftParameter :: Parameter a -> Event a
liftParameter = Parameter a -> Event a
forall a. Parameter a -> Event a
liftPS

instance SimulationLift Event where
  liftSimulation :: Simulation a -> Event a
liftSimulation = Simulation a -> Event a
forall a. Simulation a -> Event a
liftES

instance DynamicsLift Event where
  liftDynamics :: Dynamics a -> Event a
liftDynamics = Dynamics a -> Event a
forall a. Dynamics a -> Event a
liftDS
    
liftPS :: Parameter a -> Event a
{-# INLINE liftPS #-}
liftPS :: Parameter a -> Event a
liftPS (Parameter Run -> IO a
m) =
  (Point -> IO a) -> Event a
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO a) -> Event a) -> (Point -> IO a) -> Event a
forall a b. (a -> b) -> a -> b
$ \Point
p -> Run -> IO a
m (Run -> IO a) -> Run -> IO a
forall a b. (a -> b) -> a -> b
$ Point -> Run
pointRun Point
p
    
liftES :: Simulation a -> Event a
{-# INLINE liftES #-}
liftES :: Simulation a -> Event a
liftES (Simulation Run -> IO a
m) =
  (Point -> IO a) -> Event a
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO a) -> Event a) -> (Point -> IO a) -> Event a
forall a b. (a -> b) -> a -> b
$ \Point
p -> Run -> IO a
m (Run -> IO a) -> Run -> IO a
forall a b. (a -> b) -> a -> b
$ Point -> Run
pointRun Point
p

liftDS :: Dynamics a -> Event a
{-# INLINE liftDS #-}
liftDS :: Dynamics a -> Event a
liftDS (Dynamics Point -> IO a
m) =
  (Point -> IO a) -> Event a
forall a. (Point -> IO a) -> Event a
Event Point -> IO a
m

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

instance EventLift Event where
  liftEvent :: Event a -> Event a
liftEvent = Event a -> Event a
forall a. a -> a
id
  
-- | Exception handling within 'Event' computations.
catchEvent :: Exception e => Event a -> (e -> Event a) -> Event a
catchEvent :: Event a -> (e -> Event a) -> Event a
catchEvent (Event Point -> IO a
m) e -> Event a
h =
  (Point -> IO a) -> Event a
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO a) -> Event a) -> (Point -> IO a) -> Event a
forall a b. (a -> b) -> a -> b
$ \Point
p -> 
  IO a -> (e -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Point -> IO a
m Point
p) ((e -> IO a) -> IO a) -> (e -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \e
e ->
  let Event Point -> IO a
m' = e -> Event a
h e
e in Point -> IO a
m' Point
p
                           
-- | A computation with finalization part like the 'finally' function.
finallyEvent :: Event a -> Event b -> Event a
finallyEvent :: Event a -> Event b -> Event a
finallyEvent (Event Point -> IO a
m) (Event Point -> IO b
m') =
  (Point -> IO a) -> Event a
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO a) -> Event a) -> (Point -> IO a) -> Event a
forall a b. (a -> b) -> a -> b
$ \Point
p ->
  IO a -> IO b -> IO a
forall a b. IO a -> IO b -> IO a
finally (Point -> IO a
m Point
p) (Point -> IO b
m' Point
p)

-- | Like the standard 'throw' function.
throwEvent :: Exception e => e -> Event a
throwEvent :: e -> Event a
throwEvent = e -> Event a
forall a e. Exception e => e -> a
throw

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

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

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

-- | Invoke the 'Event' computation.
invokeEvent :: Point -> Event a -> IO a
{-# INLINE invokeEvent #-}
invokeEvent :: Point -> Event a -> IO a
invokeEvent Point
p (Event Point -> IO a
m) = Point -> IO a
m Point
p

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

instance MC.MonadThrow Event where
  throwM :: e -> Event a
throwM = e -> Event a
forall e a. Exception e => e -> Event a
throwEvent

instance MC.MonadCatch Event where
  catch :: Event a -> (e -> Event a) -> Event a
catch = Event a -> (e -> Event a) -> Event a
forall e a. Exception e => Event a -> (e -> Event a) -> Event a
catchEvent

instance MC.MonadMask Event where
  mask :: ((forall a. Event a -> Event a) -> Event b) -> Event b
mask = ((forall a. Event a -> Event a) -> Event b) -> Event b
forall b. ((forall a. Event a -> Event a) -> Event b) -> Event b
maskEvent
  uninterruptibleMask :: ((forall a. Event a -> Event a) -> Event b) -> Event b
uninterruptibleMask = ((forall a. Event a -> Event a) -> Event b) -> Event b
forall b. ((forall a. Event a -> Event a) -> Event b) -> Event b
uninterruptibleMaskEvent
  generalBracket :: Event a
-> (a -> ExitCase b -> Event c) -> (a -> Event b) -> Event (b, c)
generalBracket = Event a
-> (a -> ExitCase b -> Event c) -> (a -> Event b) -> Event (b, c)
forall a b c.
Event a
-> (a -> ExitCase b -> Event c) -> (a -> Event b) -> Event (b, c)
generalBracketEvent

-- | Defines how the events are processed.
data EventProcessing = CurrentEvents
                       -- ^ either process all earlier and then current events,
                       -- or raise an error if the current simulation time is less
                       -- than the actual time of the event queue (safe within
                       -- the 'Event' computation as this is protected by the type system)
                     | EarlierEvents
                       -- ^ either process all earlier events not affecting
                       -- the events at the current simulation time,
                       -- or raise an error if the current simulation time is less
                       -- than the actual time of the event queue (safe within
                       -- the 'Event' computation as this is protected by the type system)
                     | CurrentEventsOrFromPast
                       -- ^ either process all earlier and then current events,
                       -- or do nothing if the current simulation time is less
                       -- than the actual time of the event queue
                       -- (do not use unless the documentation states the opposite)
                     | EarlierEventsOrFromPast
                       -- ^ either process all earlier events,
                       -- or do nothing if the current simulation time is less
                       -- than the actual time of the event queue
                       -- (do not use unless the documentation states the opposite)
                     deriving (EventProcessing -> EventProcessing -> Bool
(EventProcessing -> EventProcessing -> Bool)
-> (EventProcessing -> EventProcessing -> Bool)
-> Eq EventProcessing
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EventProcessing -> EventProcessing -> Bool
$c/= :: EventProcessing -> EventProcessing -> Bool
== :: EventProcessing -> EventProcessing -> Bool
$c== :: EventProcessing -> EventProcessing -> Bool
Eq, Eq EventProcessing
Eq EventProcessing
-> (EventProcessing -> EventProcessing -> Ordering)
-> (EventProcessing -> EventProcessing -> Bool)
-> (EventProcessing -> EventProcessing -> Bool)
-> (EventProcessing -> EventProcessing -> Bool)
-> (EventProcessing -> EventProcessing -> Bool)
-> (EventProcessing -> EventProcessing -> EventProcessing)
-> (EventProcessing -> EventProcessing -> EventProcessing)
-> Ord EventProcessing
EventProcessing -> EventProcessing -> Bool
EventProcessing -> EventProcessing -> Ordering
EventProcessing -> EventProcessing -> EventProcessing
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EventProcessing -> EventProcessing -> EventProcessing
$cmin :: EventProcessing -> EventProcessing -> EventProcessing
max :: EventProcessing -> EventProcessing -> EventProcessing
$cmax :: EventProcessing -> EventProcessing -> EventProcessing
>= :: EventProcessing -> EventProcessing -> Bool
$c>= :: EventProcessing -> EventProcessing -> Bool
> :: EventProcessing -> EventProcessing -> Bool
$c> :: EventProcessing -> EventProcessing -> Bool
<= :: EventProcessing -> EventProcessing -> Bool
$c<= :: EventProcessing -> EventProcessing -> Bool
< :: EventProcessing -> EventProcessing -> Bool
$c< :: EventProcessing -> EventProcessing -> Bool
compare :: EventProcessing -> EventProcessing -> Ordering
$ccompare :: EventProcessing -> EventProcessing -> Ordering
$cp1Ord :: Eq EventProcessing
Ord, Int -> EventProcessing -> ShowS
[EventProcessing] -> ShowS
EventProcessing -> String
(Int -> EventProcessing -> ShowS)
-> (EventProcessing -> String)
-> ([EventProcessing] -> ShowS)
-> Show EventProcessing
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EventProcessing] -> ShowS
$cshowList :: [EventProcessing] -> ShowS
show :: EventProcessing -> String
$cshow :: EventProcessing -> String
showsPrec :: Int -> EventProcessing -> ShowS
$cshowsPrec :: Int -> EventProcessing -> ShowS
Show)

-- | Enqueue the event which must be actuated at the specified time.
enqueueEvent :: Double -> Event () -> Event ()
enqueueEvent :: Double -> Event () -> Event ()
enqueueEvent Double
t (Event Point -> IO ()
m) =
  (Point -> IO ()) -> Event ()
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO ()) -> Event ()) -> (Point -> IO ()) -> Event ()
forall a b. (a -> b) -> a -> b
$ \Point
p ->
  let pq :: PriorityQueue (Point -> IO ())
pq = EventQueue -> PriorityQueue (Point -> IO ())
queuePQ (EventQueue -> PriorityQueue (Point -> IO ()))
-> EventQueue -> PriorityQueue (Point -> IO ())
forall a b. (a -> b) -> a -> b
$ Run -> EventQueue
runEventQueue (Run -> EventQueue) -> Run -> EventQueue
forall a b. (a -> b) -> a -> b
$ Point -> Run
pointRun Point
p
  in PriorityQueue (Point -> IO ())
-> Double -> (Point -> IO ()) -> IO ()
forall a. PriorityQueue a -> Double -> a -> IO ()
PQ.enqueue PriorityQueue (Point -> IO ())
pq Double
t Point -> IO ()
m

-- | Process the pending events.
processPendingEventsCore :: Bool -> Dynamics ()
processPendingEventsCore :: Bool -> Dynamics ()
processPendingEventsCore Bool
includingCurrentEvents = (Point -> IO ()) -> Dynamics ()
forall a. (Point -> IO a) -> Dynamics a
Dynamics Point -> IO ()
r where
  r :: Point -> IO ()
r Point
p =
    do let q :: EventQueue
q = Run -> EventQueue
runEventQueue (Run -> EventQueue) -> Run -> EventQueue
forall a b. (a -> b) -> a -> b
$ Point -> Run
pointRun Point
p
           f :: IORef Bool
f = EventQueue -> IORef Bool
queueBusy EventQueue
q
       Bool
f' <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
f
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
f' (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
         do IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
f Bool
True
            EventQueue -> Point -> IO ()
call EventQueue
q Point
p
            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
f Bool
False
  call :: EventQueue -> Point -> IO ()
call EventQueue
q Point
p =
    do let pq :: PriorityQueue (Point -> IO ())
pq = EventQueue -> PriorityQueue (Point -> IO ())
queuePQ EventQueue
q
           r :: Run
r  = Point -> Run
pointRun Point
p
       Bool
f <- PriorityQueue (Point -> IO ()) -> IO Bool
forall a. PriorityQueue a -> IO Bool
PQ.queueNull PriorityQueue (Point -> IO ())
pq
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
f (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
         do (Double
t2, Point -> IO ()
c2) <- PriorityQueue (Point -> IO ()) -> IO (Double, Point -> IO ())
forall a. PriorityQueue a -> IO (Double, a)
PQ.queueFront PriorityQueue (Point -> IO ())
pq
            let t :: IORef Double
t = EventQueue -> IORef Double
queueTime EventQueue
q
            Double
t' <- IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef IORef Double
t
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
t2 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
t') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 
              String -> IO ()
forall a. HasCallStack => String -> a
error String
"The time value is too small: processPendingEventsCore"
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Double
t2 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Point -> Double
pointTime Point
p) Bool -> Bool -> Bool
||
                  (Bool
includingCurrentEvents Bool -> Bool -> Bool
&& (Double
t2 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Point -> Double
pointTime Point
p))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              do IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Double
t Double
t2
                 PriorityQueue (Point -> IO ()) -> IO ()
forall a. PriorityQueue a -> IO ()
PQ.dequeue PriorityQueue (Point -> IO ())
pq
                 let sc :: Specs
sc = Point -> Specs
pointSpecs Point
p
                     t0 :: Double
t0 = Specs -> Double
spcStartTime Specs
sc
                     dt :: Double
dt = Specs -> Double
spcDT Specs
sc
                     n2 :: Int
n2 = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor ((Double
t2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
t0) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
dt)
                 Point -> IO ()
c2 (Point -> IO ()) -> Point -> IO ()
forall a b. (a -> b) -> a -> b
$ Point
p { pointTime :: Double
pointTime = Double
t2,
                          pointIteration :: Int
pointIteration = Int
n2,
                          pointPhase :: Int
pointPhase = -Int
1 }
                 EventQueue -> Point -> IO ()
call EventQueue
q Point
p

-- | Process the pending events synchronously, i.e. without past.
processPendingEvents :: Bool -> Dynamics ()
processPendingEvents :: Bool -> Dynamics ()
processPendingEvents Bool
includingCurrentEvents = (Point -> IO ()) -> Dynamics ()
forall a. (Point -> IO a) -> Dynamics a
Dynamics Point -> IO ()
r where
  r :: Point -> IO ()
r Point
p =
    do let q :: EventQueue
q = Run -> EventQueue
runEventQueue (Run -> EventQueue) -> Run -> EventQueue
forall a b. (a -> b) -> a -> b
$ Point -> Run
pointRun Point
p
           t :: IORef Double
t = EventQueue -> IORef Double
queueTime EventQueue
q
       Double
t' <- IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef IORef Double
t
       if Point -> Double
pointTime Point
p Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
t'
         then String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
"The current time is less than " String -> ShowS
forall a. [a] -> [a] -> [a]
++
              String
"the time in the queue: processPendingEvents"
         else Point -> Dynamics () -> IO ()
forall a. Point -> Dynamics a -> IO a
invokeDynamics Point
p Dynamics ()
m
  m :: Dynamics ()
m = Bool -> Dynamics ()
processPendingEventsCore Bool
includingCurrentEvents

-- | A memoized value.
processEventsIncludingCurrent :: Dynamics ()
processEventsIncludingCurrent = Bool -> Dynamics ()
processPendingEvents Bool
True

-- | A memoized value.
processEventsIncludingEarlier :: Dynamics ()
processEventsIncludingEarlier = Bool -> Dynamics ()
processPendingEvents Bool
False

-- | A memoized value.
processEventsIncludingCurrentCore :: Dynamics ()
processEventsIncludingCurrentCore = Bool -> Dynamics ()
processPendingEventsCore Bool
True

-- | A memoized value.
processEventsIncludingEarlierCore :: Dynamics ()
processEventsIncludingEarlierCore = Bool -> Dynamics ()
processPendingEventsCore Bool
True

-- | Process the events.
processEvents :: EventProcessing -> Dynamics ()
processEvents :: EventProcessing -> Dynamics ()
processEvents EventProcessing
CurrentEvents = Dynamics ()
processEventsIncludingCurrent
processEvents EventProcessing
EarlierEvents = Dynamics ()
processEventsIncludingEarlier
processEvents EventProcessing
CurrentEventsOrFromPast = Dynamics ()
processEventsIncludingCurrentCore
processEvents EventProcessing
EarlierEventsOrFromPast = Dynamics ()
processEventsIncludingEarlierCore

-- | Run the 'Event' computation in the current simulation time
-- within the 'Dynamics' computation involving all pending
-- 'CurrentEvents' in the processing too.
runEvent :: Event a -> Dynamics a
runEvent :: Event a -> Dynamics a
runEvent = EventProcessing -> Event a -> Dynamics a
forall a. EventProcessing -> Event a -> Dynamics a
runEventWith EventProcessing
CurrentEvents

-- | Run the 'Event' computation in the current simulation time
-- within the 'Dynamics' computation specifying what pending events 
-- should be involved in the processing.
runEventWith :: EventProcessing -> Event a -> Dynamics a
runEventWith :: EventProcessing -> Event a -> Dynamics a
runEventWith EventProcessing
processing (Event Point -> IO a
e) =
  (Point -> IO a) -> Dynamics a
forall a. (Point -> IO a) -> Dynamics a
Dynamics ((Point -> IO a) -> Dynamics a) -> (Point -> IO a) -> Dynamics a
forall a b. (a -> b) -> a -> b
$ \Point
p ->
  do Point -> Dynamics () -> IO ()
forall a. Point -> Dynamics a -> IO a
invokeDynamics Point
p (Dynamics () -> IO ()) -> Dynamics () -> IO ()
forall a b. (a -> b) -> a -> b
$ EventProcessing -> Dynamics ()
processEvents EventProcessing
processing
     Point -> IO a
e Point
p

-- | Run the 'Event' computation in the start time involving all
-- pending 'CurrentEvents' in the processing too.
runEventInStartTime :: Event a -> Simulation a
runEventInStartTime :: Event a -> Simulation a
runEventInStartTime = Dynamics a -> Simulation a
forall a. Dynamics a -> Simulation a
runDynamicsInStartTime (Dynamics a -> Simulation a)
-> (Event a -> Dynamics a) -> Event a -> Simulation a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event a -> Dynamics a
forall a. Event a -> Dynamics a
runEvent

-- | Run the 'Event' computation in the stop time involving all
-- pending 'CurrentEvents' in the processing too.
runEventInStopTime :: Event a -> Simulation a
runEventInStopTime :: Event a -> Simulation a
runEventInStopTime = Dynamics a -> Simulation a
forall a. Dynamics a -> Simulation a
runDynamicsInStopTime (Dynamics a -> Simulation a)
-> (Event a -> Dynamics a) -> Event a -> Simulation a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event a -> Dynamics a
forall a. Event a -> Dynamics a
runEvent

-- | Return the number of pending events that should
-- be yet actuated.
eventQueueCount :: Event Int
eventQueueCount :: Event Int
eventQueueCount =
  (Point -> IO Int) -> Event Int
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO Int) -> Event Int) -> (Point -> IO Int) -> Event Int
forall a b. (a -> b) -> a -> b
$ PriorityQueue (Point -> IO ()) -> IO Int
forall a. PriorityQueue a -> IO Int
PQ.queueCount (PriorityQueue (Point -> IO ()) -> IO Int)
-> (Point -> PriorityQueue (Point -> IO ())) -> Point -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventQueue -> PriorityQueue (Point -> IO ())
queuePQ (EventQueue -> PriorityQueue (Point -> IO ()))
-> (Point -> EventQueue) -> Point -> PriorityQueue (Point -> IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> EventQueue
runEventQueue (Run -> EventQueue) -> (Point -> Run) -> Point -> EventQueue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Run
pointRun

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

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

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

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

-- | Enqueue the event with an ability to cancel it.
enqueueEventWithCancellation :: Double -> Event () -> Event EventCancellation
enqueueEventWithCancellation :: Double -> Event () -> Event EventCancellation
enqueueEventWithCancellation Double
t Event ()
e =
  (Point -> IO EventCancellation) -> Event EventCancellation
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO EventCancellation) -> Event EventCancellation)
-> (Point -> IO EventCancellation) -> Event EventCancellation
forall a b. (a -> b) -> a -> b
$ \Point
p ->
  do IORef Bool
cancelledRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
     IORef Bool
cancellableRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
     IORef Bool
finishedRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
     let cancel :: Event ()
cancel =
           (Point -> IO ()) -> Event ()
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO ()) -> Event ()) -> (Point -> IO ()) -> Event ()
forall a b. (a -> b) -> a -> b
$ \Point
p ->
           do Bool
x <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
cancellableRef
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
x (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
cancelledRef Bool
True
         cancelled :: Event Bool
cancelled =
           (Point -> IO Bool) -> Event Bool
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO Bool) -> Event Bool)
-> (Point -> IO Bool) -> Event Bool
forall a b. (a -> b) -> a -> b
$ \Point
p -> IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
cancelledRef
         finished :: Event Bool
finished =
           (Point -> IO Bool) -> Event Bool
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO Bool) -> Event Bool)
-> (Point -> IO Bool) -> Event Bool
forall a b. (a -> b) -> a -> b
$ \Point
p -> IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
finishedRef
     Point -> Event () -> IO ()
forall a. Point -> Event a -> IO a
invokeEvent Point
p (Event () -> IO ()) -> Event () -> IO ()
forall a b. (a -> b) -> a -> b
$
       Double -> Event () -> Event ()
enqueueEvent Double
t (Event () -> Event ()) -> Event () -> Event ()
forall a b. (a -> b) -> a -> b
$
       (Point -> IO ()) -> Event ()
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO ()) -> Event ()) -> (Point -> IO ()) -> Event ()
forall a b. (a -> b) -> a -> b
$ \Point
p ->
       do IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
cancellableRef Bool
False
          Bool
x <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
cancelledRef
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
x (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            do Point -> Event () -> IO ()
forall a. Point -> Event a -> IO a
invokeEvent Point
p Event ()
e
               IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
finishedRef Bool
True
     EventCancellation -> IO EventCancellation
forall (m :: * -> *) a. Monad m => a -> m a
return EventCancellation :: Event () -> Event Bool -> Event Bool -> EventCancellation
EventCancellation { cancelEvent :: Event ()
cancelEvent   = Event ()
cancel,
                                eventCancelled :: Event Bool
eventCancelled = Event Bool
cancelled,
                                eventFinished :: Event Bool
eventFinished = Event Bool
finished }

-- | Memoize the 'Event' computation, always returning the same value
-- within a simulation run.
memoEvent :: Event a -> Simulation (Event a)
memoEvent :: Event a -> Simulation (Event a)
memoEvent Event a
m =
  do IORef (Maybe a)
ref <- IO (IORef (Maybe a)) -> Simulation (IORef (Maybe a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Maybe a)) -> Simulation (IORef (Maybe a)))
-> IO (IORef (Maybe a)) -> Simulation (IORef (Maybe a))
forall a b. (a -> b) -> a -> b
$ Maybe a -> IO (IORef (Maybe a))
forall a. a -> IO (IORef a)
newIORef Maybe a
forall a. Maybe a
Nothing
     Event a -> Simulation (Event a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Event a -> Simulation (Event a))
-> Event a -> Simulation (Event a)
forall a b. (a -> b) -> a -> b
$ (Point -> IO a) -> Event a
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO a) -> Event a) -> (Point -> IO a) -> Event a
forall a b. (a -> b) -> a -> b
$ \Point
p ->
       do Maybe a
x <- IORef (Maybe a) -> IO (Maybe a)
forall a. IORef a -> IO a
readIORef IORef (Maybe a)
ref
          case Maybe a
x of
            Just a
v -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
            Maybe a
Nothing ->
              do a
v <- Point -> Event a -> IO a
forall a. Point -> Event a -> IO a
invokeEvent Point
p Event a
m
                 IORef (Maybe a) -> Maybe a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe a)
ref (a -> Maybe a
forall a. a -> Maybe a
Just a
v)
                 a -> IO a
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 :: Event a -> Simulation (Event a)
memoEventInTime :: Event a -> Simulation (Event a)
memoEventInTime Event a
m =
  do IORef (Maybe (Double, a))
ref <- IO (IORef (Maybe (Double, a)))
-> Simulation (IORef (Maybe (Double, a)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Maybe (Double, a)))
 -> Simulation (IORef (Maybe (Double, a))))
-> IO (IORef (Maybe (Double, a)))
-> Simulation (IORef (Maybe (Double, a)))
forall a b. (a -> b) -> a -> b
$ Maybe (Double, a) -> IO (IORef (Maybe (Double, a)))
forall a. a -> IO (IORef a)
newIORef Maybe (Double, a)
forall a. Maybe a
Nothing
     Event a -> Simulation (Event a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Event a -> Simulation (Event a))
-> Event a -> Simulation (Event a)
forall a b. (a -> b) -> a -> b
$ (Point -> IO a) -> Event a
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO a) -> Event a) -> (Point -> IO a) -> Event a
forall a b. (a -> b) -> a -> b
$ \Point
p ->
       do Maybe (Double, a)
x <- IORef (Maybe (Double, a)) -> IO (Maybe (Double, a))
forall a. IORef a -> IO a
readIORef IORef (Maybe (Double, a))
ref
          case Maybe (Double, a)
x of
            Just (Double
t, a
v) | Double
t Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Point -> Double
pointTime Point
p ->
              a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
            Maybe (Double, a)
_ ->
              do a
v <- Point -> Event a -> IO a
forall a. Point -> Event a -> IO a
invokeEvent Point
p Event a
m
                 IORef (Maybe (Double, a)) -> Maybe (Double, a) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (Double, a))
ref ((Double, a) -> Maybe (Double, a)
forall a. a -> Maybe a
Just (Point -> Double
pointTime Point
p, a
v))
                 a -> IO a
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 :: Event () -> Event ()
yieldEvent :: Event () -> Event ()
yieldEvent Event ()
m =
  (Point -> IO ()) -> Event ()
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO ()) -> Event ()) -> (Point -> IO ()) -> Event ()
forall a b. (a -> b) -> a -> b
$ \Point
p ->
  Point -> Event () -> IO ()
forall a. Point -> Event a -> IO a
invokeEvent Point
p (Event () -> IO ()) -> Event () -> IO ()
forall a b. (a -> b) -> a -> b
$
  Double -> Event () -> Event ()
enqueueEvent (Point -> Double
pointTime Point
p) Event ()
m

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

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

instance Monoid DisposableEvent where

  mempty :: DisposableEvent
mempty = Event () -> DisposableEvent
DisposableEvent (Event () -> DisposableEvent) -> Event () -> DisposableEvent
forall a b. (a -> b) -> a -> b
$ () -> Event ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  mappend :: DisposableEvent -> DisposableEvent -> DisposableEvent
mappend = DisposableEvent -> DisposableEvent -> DisposableEvent
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.
retryEvent :: String -> Event a
retryEvent :: String -> Event a
retryEvent String
message = SimulationRetry -> Event a
forall e a. Exception e => e -> Event a
throwEvent (SimulationRetry -> Event a) -> SimulationRetry -> Event a
forall a b. (a -> b) -> a -> b
$ String -> SimulationRetry
SimulationRetry String
message

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