{-# LANGUAGE TypeFamilies, FlexibleInstances #-}

-- |
-- Module     : Simulation.Aivika.Distributed.Optimistic.Internal.Event
-- Copyright  : Copyright (c) 2015-2017, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 7.10.3
--
-- The module defines an event queue.
--
module Simulation.Aivika.Distributed.Optimistic.Internal.Event
       (queueInputMessages,
        queueOutputMessages,
        queueLog,
        expectEvent,
        processMonitorSignal,
        leaveSimulation) where

import Data.Maybe
import Data.IORef
import Data.Time.Clock

import System.Timeout

import Control.Monad
import Control.Monad.Trans
import Control.Exception
import qualified Control.Distributed.Process as DP

import qualified Simulation.Aivika.PriorityQueue.EventQueue.Pure as PQ

import Simulation.Aivika.Trans
import Simulation.Aivika.Trans.Internal.Types
import Simulation.Aivika.Trans.Internal.Event
import Simulation.Aivika.Trans.Internal.Cont
import Simulation.Aivika.Trans.Internal.Process

import Simulation.Aivika.Distributed.Optimistic.Internal.Priority
import Simulation.Aivika.Distributed.Optimistic.Internal.Channel
import Simulation.Aivika.Distributed.Optimistic.Internal.DIO
import Simulation.Aivika.Distributed.Optimistic.Internal.IO
import Simulation.Aivika.Distributed.Optimistic.Internal.Message
import Simulation.Aivika.Distributed.Optimistic.Internal.TimeServer
import Simulation.Aivika.Distributed.Optimistic.Internal.TimeWarp
import {-# SOURCE #-} Simulation.Aivika.Distributed.Optimistic.Internal.SignalHelper
import {-# SOURCE #-} Simulation.Aivika.Distributed.Optimistic.Internal.InputMessageQueue
import {-# SOURCE #-} Simulation.Aivika.Distributed.Optimistic.Internal.OutputMessageQueue
import Simulation.Aivika.Distributed.Optimistic.Internal.TransientMessageQueue
import Simulation.Aivika.Distributed.Optimistic.Internal.UndoableLog
import {-# SOURCE #-} Simulation.Aivika.Distributed.Optimistic.Internal.AcknowledgementMessageQueue
import {-# SOURCE #-} qualified Simulation.Aivika.Distributed.Optimistic.Internal.Ref.Strict as R
import Simulation.Aivika.Distributed.Optimistic.State

-- | Convert microseconds to seconds.
microsecondsToSeconds :: Int -> Rational
microsecondsToSeconds :: Int -> Rational
microsecondsToSeconds Int
x = (Integer -> Rational
forall a. Num a => Integer -> a
fromInteger (Integer -> Rational) -> Integer -> Rational
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
x) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
1000000

-- | An implementation of the 'EventQueueing' type class.
instance EventQueueing DIO where

  -- | The event queue type.
  data EventQueue DIO =
    EventQueue { EventQueue DIO -> InputMessageQueue
queueInputMessages :: InputMessageQueue,
                 -- ^ the input message queue
                 EventQueue DIO -> OutputMessageQueue
queueOutputMessages :: OutputMessageQueue,
                 -- ^ the output message queue
                 EventQueue DIO -> TransientMessageQueue
queueTransientMessages :: TransientMessageQueue,
                 -- ^ the transient message queue
                 EventQueue DIO -> AcknowledgementMessageQueue
queueAcknowledgementMessages :: AcknowledgementMessageQueue,
                 -- ^ the acknowledgement message queue
                 EventQueue DIO -> UndoableLog
queueLog :: UndoableLog,
                 -- ^ the undoable log of operations
                 EventQueue DIO -> Ref (PriorityQueue (Point DIO -> DIO ()))
queuePQ :: R.Ref (PQ.PriorityQueue (Point DIO -> DIO ())),
                 -- ^ the underlying priority queue
                 EventQueue DIO -> IORef Bool
queueBusy :: IORef Bool,
                 -- ^ whether the queue is currently processing events
                 EventQueue DIO -> IORef Double
queueTime :: IORef Double,
                 -- ^ the actual time of the event queue
                 EventQueue DIO -> IORef Double
queueGlobalTime :: IORef Double,
                 -- ^ the global time
                 EventQueue DIO -> IORef Bool
queueInFind :: IORef Bool,
                 -- ^ whether the queue is in find mode
                 EventQueue DIO -> SignalSource DIO ProcessMonitorNotification
queueProcessMonitorNotificationSource :: SignalSource DIO DP.ProcessMonitorNotification,
                 -- ^ the source of process monitor notifications
                 EventQueue DIO -> IORef Bool
queueIsLeaving :: IORef Bool
                 -- ^ whether the logical process tries to leave the simulation
               }

  newEventQueue :: Specs DIO -> DIO (EventQueue DIO)
newEventQueue Specs DIO
specs =
    do IORef Bool
f <- IO (IORef Bool) -> DIO (IORef Bool)
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO (IORef Bool) -> DIO (IORef Bool))
-> IO (IORef Bool) -> DIO (IORef Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
       IORef Double
t <- IO (IORef Double) -> DIO (IORef Double)
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO (IORef Double) -> DIO (IORef Double))
-> IO (IORef Double) -> DIO (IORef Double)
forall a b. (a -> b) -> a -> b
$ Double -> IO (IORef Double)
forall a. a -> IO (IORef a)
newIORef (Double -> IO (IORef Double)) -> Double -> IO (IORef Double)
forall a b. (a -> b) -> a -> b
$ Specs DIO -> Double
forall (m :: * -> *). Specs m -> Double
spcStartTime Specs DIO
specs
       IORef Double
gt <- IO (IORef Double) -> DIO (IORef Double)
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO (IORef Double) -> DIO (IORef Double))
-> IO (IORef Double) -> DIO (IORef Double)
forall a b. (a -> b) -> a -> b
$ Double -> IO (IORef Double)
forall a. a -> IO (IORef a)
newIORef (Double -> IO (IORef Double)) -> Double -> IO (IORef Double)
forall a b. (a -> b) -> a -> b
$ Specs DIO -> Double
forall (m :: * -> *). Specs m -> Double
spcStartTime Specs DIO
specs
       Ref (PriorityQueue (Point DIO -> DIO ()))
pq <- PriorityQueue (Point DIO -> DIO ())
-> DIO (Ref (PriorityQueue (Point DIO -> DIO ())))
forall a. a -> DIO (Ref a)
R.newRef0 PriorityQueue (Point DIO -> DIO ())
forall a. PriorityQueue a
PQ.emptyQueue
       UndoableLog
log <- DIO UndoableLog
newUndoableLog
       TransientMessageQueue
transient <- DIO TransientMessageQueue
newTransientMessageQueue
       OutputMessageQueue
output <- (Message -> IO ()) -> DIO OutputMessageQueue
newOutputMessageQueue ((Message -> IO ()) -> DIO OutputMessageQueue)
-> (Message -> IO ()) -> DIO OutputMessageQueue
forall a b. (a -> b) -> a -> b
$ TransientMessageQueue -> Message -> IO ()
enqueueTransientMessage TransientMessageQueue
transient
       InputMessageQueue
input <- UndoableLog
-> (Bool -> TimeWarp DIO ())
-> (Bool -> TimeWarp DIO ())
-> TimeWarp DIO ()
-> DIO InputMessageQueue
newInputMessageQueue UndoableLog
log Bool -> TimeWarp DIO ()
rollbackEventPre Bool -> TimeWarp DIO ()
rollbackEventPost TimeWarp DIO ()
rollbackEventTime
       AcknowledgementMessageQueue
ack <- DIO AcknowledgementMessageQueue
newAcknowledgementMessageQueue
       IORef Bool
infind <- IO (IORef Bool) -> DIO (IORef Bool)
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO (IORef Bool) -> DIO (IORef Bool))
-> IO (IORef Bool) -> DIO (IORef Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
       SignalSource DIO ProcessMonitorNotification
s <- DIO (SignalSource DIO ProcessMonitorNotification)
forall a. DIO (SignalSource DIO a)
newDIOSignalSource0
       IORef Bool
leaving <- IO (IORef Bool) -> DIO (IORef Bool)
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO (IORef Bool) -> DIO (IORef Bool))
-> IO (IORef Bool) -> DIO (IORef Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
       EventQueue DIO -> DIO (EventQueue DIO)
forall a. a -> DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return EventQueue { queueInputMessages :: InputMessageQueue
queueInputMessages = InputMessageQueue
input,
                           queueOutputMessages :: OutputMessageQueue
queueOutputMessages = OutputMessageQueue
output,
                           queueTransientMessages :: TransientMessageQueue
queueTransientMessages = TransientMessageQueue
transient,
                           queueAcknowledgementMessages :: AcknowledgementMessageQueue
queueAcknowledgementMessages = AcknowledgementMessageQueue
ack,
                           queueLog :: UndoableLog
queueLog  = UndoableLog
log,
                           queuePQ :: Ref (PriorityQueue (Point DIO -> DIO ()))
queuePQ   = Ref (PriorityQueue (Point DIO -> DIO ()))
pq,
                           queueBusy :: IORef Bool
queueBusy = IORef Bool
f,
                           queueTime :: IORef Double
queueTime = IORef Double
t,
                           queueGlobalTime :: IORef Double
queueGlobalTime = IORef Double
gt,
                           queueInFind :: IORef Bool
queueInFind = IORef Bool
infind,
                           queueProcessMonitorNotificationSource :: SignalSource DIO ProcessMonitorNotification
queueProcessMonitorNotificationSource = SignalSource DIO ProcessMonitorNotification
s,
                           queueIsLeaving :: IORef Bool
queueIsLeaving = IORef Bool
leaving }

  enqueueEventWithPriority :: Double -> Int -> Event DIO () -> Event DIO ()
enqueueEventWithPriority Double
t Int
priority (Event Point DIO -> DIO ()
m) =
    (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
    let pq :: Ref (PriorityQueue (Point DIO -> DIO ()))
pq = EventQueue DIO -> Ref (PriorityQueue (Point DIO -> DIO ()))
queuePQ (EventQueue DIO -> Ref (PriorityQueue (Point DIO -> DIO ())))
-> EventQueue DIO -> Ref (PriorityQueue (Point DIO -> DIO ()))
forall a b. (a -> b) -> a -> b
$ Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
    in Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO () -> DIO ()) -> Event DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       Ref (PriorityQueue (Point DIO -> DIO ()))
-> (PriorityQueue (Point DIO -> DIO ())
    -> PriorityQueue (Point DIO -> DIO ()))
-> Event DIO ()
forall a. Ref a -> (a -> a) -> Event DIO ()
R.modifyRef Ref (PriorityQueue (Point DIO -> DIO ()))
pq ((PriorityQueue (Point DIO -> DIO ())
  -> PriorityQueue (Point DIO -> DIO ()))
 -> Event DIO ())
-> (PriorityQueue (Point DIO -> DIO ())
    -> PriorityQueue (Point DIO -> DIO ()))
-> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \PriorityQueue (Point DIO -> DIO ())
x -> PriorityQueue (Point DIO -> DIO ())
-> Double
-> Int
-> (Point DIO -> DIO ())
-> PriorityQueue (Point DIO -> DIO ())
forall a. PriorityQueue a -> Double -> Int -> a -> PriorityQueue a
PQ.enqueue PriorityQueue (Point DIO -> DIO ())
x Double
t Int
priority Point DIO -> DIO ()
m

  runEventWith :: forall a. EventProcessing -> Event DIO a -> Dynamics DIO a
runEventWith EventProcessing
processing (Event Point DIO -> DIO a
e) =
    (Point DIO -> DIO a) -> Dynamics DIO a
forall (m :: * -> *) a. (Point m -> m a) -> Dynamics m a
Dynamics ((Point DIO -> DIO a) -> Dynamics DIO a)
-> (Point DIO -> DIO a) -> Dynamics DIO a
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
    do Point DIO
p0 <- Point DIO -> Event DIO (Point DIO) -> DIO (Point DIO)
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p Event DIO (Point DIO)
currentEventPoint
       Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p0 (Event DIO () -> DIO ()) -> Event DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ Double -> Event DIO () -> Event DIO ()
forall (m :: * -> *).
EventQueueing m =>
Double -> Event m () -> Event m ()
enqueueEvent (Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) (() -> Event DIO ()
forall a. a -> Event DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
       Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO () -> DIO ()) -> Event DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ EventProcessing -> Event DIO ()
syncEvents EventProcessing
processing
       Point DIO -> DIO a
e Point DIO
p

  eventQueueCount :: Event DIO Int
eventQueueCount =
    (Point DIO -> DIO Int) -> Event DIO Int
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO Int) -> Event DIO Int)
-> (Point DIO -> DIO Int) -> Event DIO Int
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
    let pq :: Ref (PriorityQueue (Point DIO -> DIO ()))
pq = EventQueue DIO -> Ref (PriorityQueue (Point DIO -> DIO ()))
queuePQ (EventQueue DIO -> Ref (PriorityQueue (Point DIO -> DIO ())))
-> EventQueue DIO -> Ref (PriorityQueue (Point DIO -> DIO ()))
forall a b. (a -> b) -> a -> b
$ Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
    in Point DIO -> Event DIO Int -> DIO Int
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO Int -> DIO Int) -> Event DIO Int -> DIO Int
forall a b. (a -> b) -> a -> b
$
       (PriorityQueue (Point DIO -> DIO ()) -> Int)
-> Event DIO (PriorityQueue (Point DIO -> DIO ())) -> Event DIO Int
forall a b. (a -> b) -> Event DIO a -> Event DIO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PriorityQueue (Point DIO -> DIO ()) -> Int
forall a. PriorityQueue a -> Int
PQ.queueCount (Event DIO (PriorityQueue (Point DIO -> DIO ())) -> Event DIO Int)
-> Event DIO (PriorityQueue (Point DIO -> DIO ())) -> Event DIO Int
forall a b. (a -> b) -> a -> b
$ Ref (PriorityQueue (Point DIO -> DIO ()))
-> Event DIO (PriorityQueue (Point DIO -> DIO ()))
forall a. Ref a -> Event DIO a
R.readRef Ref (PriorityQueue (Point DIO -> DIO ()))
pq

-- | The first stage of rolling the changes back.
rollbackEventPre :: Bool -> TimeWarp DIO ()
rollbackEventPre :: Bool -> TimeWarp DIO ()
rollbackEventPre Bool
including =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     UndoableLog -> Double -> Bool -> DIO ()
rollbackLog (EventQueue DIO -> UndoableLog
queueLog EventQueue DIO
q) (Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) Bool
including

-- | The post stage of rolling the changes back.
rollbackEventPost :: Bool -> TimeWarp DIO ()
rollbackEventPost :: Bool -> TimeWarp DIO ()
rollbackEventPost Bool
including =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     OutputMessageQueue -> Double -> Bool -> DIO ()
rollbackOutputMessages (EventQueue DIO -> OutputMessageQueue
queueOutputMessages EventQueue DIO
q) (Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) Bool
including

-- | Rollback the event time.
rollbackEventTime :: TimeWarp DIO ()
rollbackEventTime :: TimeWarp DIO ()
rollbackEventTime =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
         t :: Double
t = Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p
     ---
     --- logDIO DEBUG $
     ---   "Setting the queue time = " ++ show t
     ---
     IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (EventQueue DIO -> IORef Double
queueTime EventQueue DIO
q) Double
t
     Double
t0 <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef (EventQueue DIO -> IORef Double
queueGlobalTime EventQueue DIO
q)
     Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
t0 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
t) (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       do ---
          --- logDIO DEBUG $
          ---   "Setting the global time = " ++ show t
          ---
          IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (EventQueue DIO -> IORef Double
queueGlobalTime EventQueue DIO
q) Double
t

-- | Return the current event time.
currentEventTime :: Event DIO Double
{-# INLINE currentEventTime #-}
currentEventTime :: Event DIO Double
currentEventTime =
  (Point DIO -> DIO Double) -> Event DIO Double
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO Double) -> Event DIO Double)
-> (Point DIO -> DIO Double) -> Event DIO Double
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef (EventQueue DIO -> IORef Double
queueTime EventQueue DIO
q)

-- | Return the current event point.
currentEventPoint :: Event DIO (Point DIO)
{-# INLINE currentEventPoint #-}
currentEventPoint :: Event DIO (Point DIO)
currentEventPoint =
  (Point DIO -> DIO (Point DIO)) -> Event DIO (Point DIO)
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO (Point DIO)) -> Event DIO (Point DIO))
-> (Point DIO -> DIO (Point DIO)) -> Event DIO (Point DIO)
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     Double
t' <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef (EventQueue DIO -> IORef Double
queueTime EventQueue DIO
q)
     if Double
t' Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p
       then Point DIO -> DIO (Point DIO)
forall a. a -> DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return Point DIO
p
       else let sc :: Specs DIO
sc = Point DIO -> Specs DIO
forall (m :: * -> *). Point m -> Specs m
pointSpecs Point DIO
p
                t0 :: Double
t0 = Specs DIO -> Double
forall (m :: * -> *). Specs m -> Double
spcStartTime Specs DIO
sc
                dt :: Double
dt = Specs DIO -> Double
forall (m :: * -> *). Specs m -> Double
spcDT Specs DIO
sc
                n' :: Int
n' = 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 b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor ((Double
t' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
t0) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
dt)
            in Point DIO -> DIO (Point DIO)
forall a. a -> DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return Point DIO
p { pointTime = t',
                          pointIteration = n',
                          pointPhase = -1 }

-- | Process the pending events.
processPendingEventsCore :: Bool -> Dynamics DIO ()
processPendingEventsCore :: Bool -> Dynamics DIO ()
processPendingEventsCore Bool
includingCurrentEvents = (Point DIO -> DIO ()) -> Dynamics DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Dynamics m a
Dynamics Point DIO -> DIO ()
r where
  r :: Point DIO -> DIO ()
r Point DIO
p =
    do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
           f :: IORef Bool
f = EventQueue DIO -> IORef Bool
queueBusy EventQueue DIO
q
       Bool
f' <- IO Bool -> DIO Bool
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Bool -> DIO Bool) -> IO Bool -> DIO Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
f
       if Bool
f'
         then [Char] -> DIO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
              [Char]
"Detected an event loop, which may indicate to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
              [Char]
"a logical error in the model: processPendingEventsCore"
         else do IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
f Bool
True
                 EventQueue DIO -> Point DIO -> Point DIO -> DIO ()
call EventQueue DIO
q Point DIO
p Point DIO
p
                 IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
f Bool
False
  call :: EventQueue DIO -> Point DIO -> Point DIO -> DIO ()
call EventQueue DIO
q Point DIO
p Point DIO
p0 =
    do let pq :: Ref (PriorityQueue (Point DIO -> DIO ()))
pq = EventQueue DIO -> Ref (PriorityQueue (Point DIO -> DIO ()))
queuePQ EventQueue DIO
q
           r :: Run DIO
r  = Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
       -- process external messages
       Point DIO
p1 <- Point DIO -> Event DIO (Point DIO) -> DIO (Point DIO)
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p0 Event DIO (Point DIO)
currentEventPoint
       Bool
ok <- Point DIO -> Event DIO Bool -> DIO Bool
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p1 (Event DIO Bool -> DIO Bool) -> Event DIO Bool -> DIO Bool
forall a b. (a -> b) -> a -> b
$ TimeWarp DIO () -> Event DIO Bool
runTimeWarp TimeWarp DIO ()
processChannelMessages
       if Bool -> Bool
not Bool
ok
         then EventQueue DIO -> Point DIO -> Point DIO -> DIO ()
call EventQueue DIO
q Point DIO
p Point DIO
p1
         else do -- proceed with processing the events
                 Bool
f <- Point DIO -> Event DIO Bool -> DIO Bool
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p1 (Event DIO Bool -> DIO Bool) -> Event DIO Bool -> DIO Bool
forall a b. (a -> b) -> a -> b
$ (PriorityQueue (Point DIO -> DIO ()) -> Bool)
-> Event DIO (PriorityQueue (Point DIO -> DIO ()))
-> Event DIO Bool
forall a b. (a -> b) -> Event DIO a -> Event DIO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PriorityQueue (Point DIO -> DIO ()) -> Bool
forall a. PriorityQueue a -> Bool
PQ.queueNull (Event DIO (PriorityQueue (Point DIO -> DIO ())) -> Event DIO Bool)
-> Event DIO (PriorityQueue (Point DIO -> DIO ()))
-> Event DIO Bool
forall a b. (a -> b) -> a -> b
$ Ref (PriorityQueue (Point DIO -> DIO ()))
-> Event DIO (PriorityQueue (Point DIO -> DIO ()))
forall a. Ref a -> Event DIO a
R.readRef Ref (PriorityQueue (Point DIO -> DIO ()))
pq
                 Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
f (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
                   do (Double
t2, Int
priority2, Point DIO -> DIO ()
c2) <- Point DIO
-> Event DIO (Double, Int, Point DIO -> DIO ())
-> DIO (Double, Int, Point DIO -> DIO ())
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p1 (Event DIO (Double, Int, Point DIO -> DIO ())
 -> DIO (Double, Int, Point DIO -> DIO ()))
-> Event DIO (Double, Int, Point DIO -> DIO ())
-> DIO (Double, Int, Point DIO -> DIO ())
forall a b. (a -> b) -> a -> b
$ (PriorityQueue (Point DIO -> DIO ())
 -> (Double, Int, Point DIO -> DIO ()))
-> Event DIO (PriorityQueue (Point DIO -> DIO ()))
-> Event DIO (Double, Int, Point DIO -> DIO ())
forall a b. (a -> b) -> Event DIO a -> Event DIO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PriorityQueue (Point DIO -> DIO ())
-> (Double, Int, Point DIO -> DIO ())
forall a. PriorityQueue a -> (Double, Int, a)
PQ.queueFront (Event DIO (PriorityQueue (Point DIO -> DIO ()))
 -> Event DIO (Double, Int, Point DIO -> DIO ()))
-> Event DIO (PriorityQueue (Point DIO -> DIO ()))
-> Event DIO (Double, Int, Point DIO -> DIO ())
forall a b. (a -> b) -> a -> b
$ Ref (PriorityQueue (Point DIO -> DIO ()))
-> Event DIO (PriorityQueue (Point DIO -> DIO ()))
forall a. Ref a -> Event DIO a
R.readRef Ref (PriorityQueue (Point DIO -> DIO ()))
pq
                      let t :: IORef Double
t = EventQueue DIO -> IORef Double
queueTime EventQueue DIO
q
                      Double
t' <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef IORef Double
t
                      Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
t2 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
t') (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ 
                        -- error "The time value is too small: processPendingEventsCore"
                        [Char] -> DIO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
                        [Char]
"The time value is too small (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
t2 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                        [Char]
" < " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
t' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"): processPendingEventsCore"
                      Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Double
t2 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) Bool -> Bool -> Bool
||
                            (Bool
includingCurrentEvents Bool -> Bool -> Bool
&& (Double
t2 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p))) (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
                        do let sc :: Specs DIO
sc = Point DIO -> Specs DIO
forall (m :: * -> *). Point m -> Specs m
pointSpecs Point DIO
p
                               t0 :: Double
t0 = Specs DIO -> Double
forall (m :: * -> *). Specs m -> Double
spcStartTime Specs DIO
sc
                               dt :: Double
dt = Specs DIO -> Double
forall (m :: * -> *). Specs m -> Double
spcDT Specs DIO
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 b. Integral b => Double -> b
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)
                               p2 :: Point DIO
p2 = Point DIO
p { pointTime = t2,
                                        pointPriority = priority2,
                                        pointIteration = n2,
                                        pointPhase = -1 }
                           ---
                           --- ps <- dioParams
                           --- when (dioLoggingPriority ps <= DEBUG) $
                           ---   invokeEvent p2 $
                           ---   writeLog (queueLog q) $
                           ---   logDIO DEBUG $
                           ---   "Reverting the queue time " ++ show t2 ++ " --> " ++ show t'
                           ---
                           IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Double
t Double
t2
                           Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p2 (Event DIO () -> DIO ()) -> Event DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ Ref (PriorityQueue (Point DIO -> DIO ()))
-> (PriorityQueue (Point DIO -> DIO ())
    -> PriorityQueue (Point DIO -> DIO ()))
-> Event DIO ()
forall a. Ref a -> (a -> a) -> Event DIO ()
R.modifyRef Ref (PriorityQueue (Point DIO -> DIO ()))
pq PriorityQueue (Point DIO -> DIO ())
-> PriorityQueue (Point DIO -> DIO ())
forall a. PriorityQueue a -> PriorityQueue a
PQ.dequeue
                           DIO () -> (SimulationRetry -> DIO ()) -> DIO ()
forall e a. Exception e => DIO a -> (e -> DIO a) -> DIO a
forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
m a -> (e -> m a) -> m a
catchComp
                             (Point DIO -> DIO ()
c2 Point DIO
p2)
                             (\e :: SimulationRetry
e@(SimulationRetry [Char]
_) -> Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p2 (Event DIO () -> DIO ()) -> Event DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ SimulationRetry -> Event DIO ()
handleEventRetry SimulationRetry
e) 
                           EventQueue DIO -> Point DIO -> Point DIO -> DIO ()
call EventQueue DIO
q Point DIO
p Point DIO
p2

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

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

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

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

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

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

-- | Whether there is an overflow.
isEventOverflow :: Event DIO Bool
isEventOverflow :: Event DIO Bool
isEventOverflow =
  (Point DIO -> DIO Bool) -> Event DIO Bool
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO Bool) -> Event DIO Bool)
-> (Point DIO -> DIO Bool) -> Event DIO Bool
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     Int
n1 <- IO Int -> DIO Int
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Int -> DIO Int) -> IO Int -> DIO Int
forall a b. (a -> b) -> a -> b
$ UndoableLog -> IO Int
logSize (EventQueue DIO -> UndoableLog
queueLog EventQueue DIO
q)
     Int
n2 <- IO Int -> DIO Int
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Int -> DIO Int) -> IO Int -> DIO Int
forall a b. (a -> b) -> a -> b
$ OutputMessageQueue -> IO Int
outputMessageQueueSize (EventQueue DIO -> OutputMessageQueue
queueOutputMessages EventQueue DIO
q)
     Int
n3 <- IO Int -> DIO Int
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Int -> DIO Int) -> IO Int -> DIO Int
forall a b. (a -> b) -> a -> b
$ TransientMessageQueue -> IO Int
transientMessageQueueSize (EventQueue DIO -> TransientMessageQueue
queueTransientMessages EventQueue DIO
q)
     DIOParams
ps <- DIO DIOParams
dioParams
     let th1 :: Int
th1 = DIOParams -> Int
dioUndoableLogSizeThreshold DIOParams
ps
         th2 :: Int
th2 = DIOParams -> Int
dioOutputMessageQueueSizeThreshold DIOParams
ps
         th3 :: Int
th3 = DIOParams -> Int
dioTransientMessageQueueSizeThreshold DIOParams
ps
     if (Int
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
th1) Bool -> Bool -> Bool
|| (Int
n2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
th2) Bool -> Bool -> Bool
|| (Int
n3 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
th3)
       then do Priority -> [Char] -> DIO ()
logDIO Priority
NOTICE ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
                 [Char]
"t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Double -> [Char]
forall a. Show a => a -> [Char]
show (Double -> [Char]) -> Double -> [Char]
forall a b. (a -> b) -> a -> b
$ Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                 [Char]
": detected the event overflow"
               Bool -> DIO Bool
forall a. a -> DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       else Bool -> DIO Bool
forall a. a -> DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Whether the time horizon has exceeded.
isTimeHorizonExceeded :: Event DIO Bool
isTimeHorizonExceeded :: Event DIO Bool
isTimeHorizonExceeded =
  (Point DIO -> DIO Bool) -> Event DIO Bool
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO Bool) -> Event DIO Bool)
-> (Point DIO -> DIO Bool) -> Event DIO Bool
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do DIOParams
ps <- DIO DIOParams
dioParams
     case DIOParams -> Maybe Double
dioTimeHorizon DIOParams
ps of
       Maybe Double
Nothing -> Bool -> DIO Bool
forall a. a -> DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
       Just Double
th ->
         do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
            Double
gvt <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef (EventQueue DIO -> IORef Double
queueGlobalTime EventQueue DIO
q)
            Double
t   <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef (EventQueue DIO -> IORef Double
queueTime EventQueue DIO
q)
            if Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
gvt Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
th
              then do Priority -> [Char] -> DIO ()
logDIO Priority
INFO ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
                        [Char]
"t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Double -> [Char]
forall a. Show a => a -> [Char]
show (Double -> [Char]) -> Double -> [Char]
forall a b. (a -> b) -> a -> b
$ Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                        [Char]
": exceeded the time horizon"
                      Bool -> DIO Bool
forall a. a -> DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
              else Bool -> DIO Bool
forall a. a -> DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Throttle the message channel.
throttleMessageChannel :: TimeWarp DIO ()
throttleMessageChannel :: TimeWarp DIO ()
throttleMessageChannel =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do -- invokeEvent p requestGlobalTime
     Channel LogicalProcessMessage
ch <- DIO (Channel LogicalProcessMessage)
messageChannel
     Int
dt <- (DIOParams -> Int) -> DIO DIOParams -> DIO Int
forall a b. (a -> b) -> DIO a -> DIO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DIOParams -> Int
dioSyncTimeout DIO DIOParams
dioParams
     IO (Maybe ()) -> DIO (Maybe ())
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO (Maybe ()) -> DIO (Maybe ()))
-> IO (Maybe ()) -> DIO (Maybe ())
forall a b. (a -> b) -> a -> b
$
       Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
dt (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ Channel LogicalProcessMessage -> IO ()
forall a. Channel a -> IO ()
awaitChannel Channel LogicalProcessMessage
ch
     Point DIO -> TimeWarp DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> TimeWarp m a -> m a
invokeTimeWarp Point DIO
p (TimeWarp DIO () -> DIO ()) -> TimeWarp DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ TimeWarp DIO ()
processChannelMessages

-- | Process the channel messages.
processChannelMessages :: TimeWarp DIO ()
processChannelMessages :: TimeWarp DIO ()
processChannelMessages =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do Channel LogicalProcessMessage
ch <- DIO (Channel LogicalProcessMessage)
messageChannel
     Bool
f  <- IO Bool -> DIO Bool
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Bool -> DIO Bool) -> IO Bool -> DIO Bool
forall a b. (a -> b) -> a -> b
$ Channel LogicalProcessMessage -> IO Bool
forall a. Channel a -> IO Bool
channelEmpty Channel LogicalProcessMessage
ch
     Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
f (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       do [LogicalProcessMessage]
xs <- IO [LogicalProcessMessage] -> DIO [LogicalProcessMessage]
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO [LogicalProcessMessage] -> DIO [LogicalProcessMessage])
-> IO [LogicalProcessMessage] -> DIO [LogicalProcessMessage]
forall a b. (a -> b) -> a -> b
$ Channel LogicalProcessMessage -> IO [LogicalProcessMessage]
forall a. Channel a -> IO [a]
readChannel Channel LogicalProcessMessage
ch
          [LogicalProcessMessage]
-> (LogicalProcessMessage -> DIO ()) -> DIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [LogicalProcessMessage]
xs ((LogicalProcessMessage -> DIO ()) -> DIO ())
-> (LogicalProcessMessage -> DIO ()) -> DIO ()
forall a b. (a -> b) -> a -> b
$ \LogicalProcessMessage
x ->
            do Point DIO
p' <- Point DIO -> Event DIO (Point DIO) -> DIO (Point DIO)
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p Event DIO (Point DIO)
currentEventPoint
               Point DIO -> TimeWarp DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> TimeWarp m a -> m a
invokeTimeWarp Point DIO
p' (TimeWarp DIO () -> DIO ()) -> TimeWarp DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ LogicalProcessMessage -> TimeWarp DIO ()
processChannelMessage LogicalProcessMessage
x
     Point DIO
p' <- Point DIO -> Event DIO (Point DIO) -> DIO (Point DIO)
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p Event DIO (Point DIO)
currentEventPoint
     Bool
f2 <- Point DIO -> Event DIO Bool -> DIO Bool
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p' Event DIO Bool
isEventOverflow
     if Bool
f2
       then Point DIO -> TimeWarp DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> TimeWarp m a -> m a
invokeTimeWarp Point DIO
p' TimeWarp DIO ()
throttleMessageChannel
       else do Bool
f3 <- Point DIO -> Event DIO Bool -> DIO Bool
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p' Event DIO Bool
isTimeHorizonExceeded
               if Bool
f3
                 then Point DIO -> TimeWarp DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> TimeWarp m a -> m a
invokeTimeWarp Point DIO
p' TimeWarp DIO ()
throttleMessageChannel
                 else () -> DIO ()
forall a. a -> DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Process the channel message.
processChannelMessage :: LogicalProcessMessage -> TimeWarp DIO ()
processChannelMessage :: LogicalProcessMessage -> TimeWarp DIO ()
processChannelMessage x :: LogicalProcessMessage
x@(QueueMessage Message
m) =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     ---
     --- invokeEvent p $
     ---   logMessage x
     ---
     Bool
infind <- IO Bool -> DIO Bool
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Bool -> DIO Bool) -> IO Bool -> DIO Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (EventQueue DIO -> IORef Bool
queueInFind EventQueue DIO
q)
     AcknowledgementMessage -> DIO ()
deliverAcknowledgementMessage (Bool -> Message -> AcknowledgementMessage
acknowledgementMessage Bool
infind Message
m)
     Double
t0 <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef (EventQueue DIO -> IORef Double
queueGlobalTime EventQueue DIO
q)
     Point DIO
p' <- Point DIO -> Event DIO (Point DIO) -> DIO (Point DIO)
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p Event DIO (Point DIO)
currentEventPoint
     if Message -> Double
messageReceiveTime Message
m Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
t0
       then do Bool
f <- (DIOParams -> Bool) -> DIO DIOParams -> DIO Bool
forall a b. (a -> b) -> DIO a -> DIO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DIOParams -> Bool
dioAllowSkippingOutdatedMessage DIO DIOParams
dioParams
               if Bool
f
                 then Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p' Event DIO ()
logOutdatedMessage
                 else [Char] -> DIO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Received the outdated message: processChannelMessage"
       else do DIOParams
ps <- DIO DIOParams
dioParams
               Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DIOParams -> Bool
dioProcessReconnectingEnabled DIOParams
ps) (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
                 IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
                 AcknowledgementMessageQueue -> AcknowledgementMessage -> IO ()
enqueueAcknowledgementMessage (EventQueue DIO -> AcknowledgementMessageQueue
queueAcknowledgementMessages EventQueue DIO
q) (AcknowledgementMessage -> IO ())
-> AcknowledgementMessage -> IO ()
forall a b. (a -> b) -> a -> b
$
                 Bool -> Message -> AcknowledgementMessage
acknowledgementMessage Bool
infind Message
m
               Point DIO -> TimeWarp DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> TimeWarp m a -> m a
invokeTimeWarp Point DIO
p' (TimeWarp DIO () -> DIO ()) -> TimeWarp DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
                 InputMessageQueue -> Message -> TimeWarp DIO ()
enqueueMessage (EventQueue DIO -> InputMessageQueue
queueInputMessages EventQueue DIO
q) Message
m
processChannelMessage x :: LogicalProcessMessage
x@(QueueMessageBulk [Message]
ms) =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     ---
     --- invokeEvent p $
     ---   logMessage x
     ---
     Bool
infind <- IO Bool -> DIO Bool
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Bool -> DIO Bool) -> IO Bool -> DIO Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (EventQueue DIO -> IORef Bool
queueInFind EventQueue DIO
q)
     [AcknowledgementMessage] -> DIO ()
deliverAcknowledgementMessages ([AcknowledgementMessage] -> DIO ())
-> [AcknowledgementMessage] -> DIO ()
forall a b. (a -> b) -> a -> b
$ (Message -> AcknowledgementMessage)
-> [Message] -> [AcknowledgementMessage]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Message -> AcknowledgementMessage
acknowledgementMessage Bool
infind) [Message]
ms
     Double
t0 <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef (EventQueue DIO -> IORef Double
queueGlobalTime EventQueue DIO
q)
     [Message] -> (Message -> DIO ()) -> DIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Message]
ms ((Message -> DIO ()) -> DIO ()) -> (Message -> DIO ()) -> DIO ()
forall a b. (a -> b) -> a -> b
$ \Message
m ->
       do Point DIO
p' <- Point DIO -> Event DIO (Point DIO) -> DIO (Point DIO)
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p Event DIO (Point DIO)
currentEventPoint
          if Message -> Double
messageReceiveTime Message
m Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
t0
            then do Bool
f <- (DIOParams -> Bool) -> DIO DIOParams -> DIO Bool
forall a b. (a -> b) -> DIO a -> DIO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DIOParams -> Bool
dioAllowSkippingOutdatedMessage DIO DIOParams
dioParams
                    if Bool
f
                      then Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p' Event DIO ()
logOutdatedMessage
                      else [Char] -> DIO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Received the outdated message: processChannelMessage"
            else do DIOParams
ps <- DIO DIOParams
dioParams
                    Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DIOParams -> Bool
dioProcessReconnectingEnabled DIOParams
ps) (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
                      IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
                      AcknowledgementMessageQueue -> AcknowledgementMessage -> IO ()
enqueueAcknowledgementMessage (EventQueue DIO -> AcknowledgementMessageQueue
queueAcknowledgementMessages EventQueue DIO
q) (AcknowledgementMessage -> IO ())
-> AcknowledgementMessage -> IO ()
forall a b. (a -> b) -> a -> b
$
                      Bool -> Message -> AcknowledgementMessage
acknowledgementMessage Bool
infind Message
m
                    Point DIO -> TimeWarp DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> TimeWarp m a -> m a
invokeTimeWarp Point DIO
p' (TimeWarp DIO () -> DIO ()) -> TimeWarp DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
                      InputMessageQueue -> Message -> TimeWarp DIO ()
enqueueMessage (EventQueue DIO -> InputMessageQueue
queueInputMessages EventQueue DIO
q) Message
m
processChannelMessage x :: LogicalProcessMessage
x@(AcknowledgementQueueMessage AcknowledgementMessage
m) =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     ---
     --- invokeEvent p $
     ---   logMessage x
     ---
     IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       TransientMessageQueue -> AcknowledgementMessage -> IO ()
processAcknowledgementMessage (EventQueue DIO -> TransientMessageQueue
queueTransientMessages EventQueue DIO
q) AcknowledgementMessage
m
processChannelMessage x :: LogicalProcessMessage
x@(AcknowledgementQueueMessageBulk [AcknowledgementMessage]
ms) =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     ---
     --- invokeEvent p $
     ---   logMessage x
     ---
     IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       [AcknowledgementMessage]
-> (AcknowledgementMessage -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [AcknowledgementMessage]
ms ((AcknowledgementMessage -> IO ()) -> IO ())
-> (AcknowledgementMessage -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
       TransientMessageQueue -> AcknowledgementMessage -> IO ()
processAcknowledgementMessage (EventQueue DIO -> TransientMessageQueue
queueTransientMessages EventQueue DIO
q)
processChannelMessage x :: LogicalProcessMessage
x@LogicalProcessMessage
ComputeLocalTimeMessage =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     ---
     --- invokeEvent p $
     ---   logMessage x
     ---
     IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (EventQueue DIO -> IORef Bool
queueInFind EventQueue DIO
q) Bool
True
     Double
t' <- Point DIO -> Event DIO Double -> DIO Double
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p Event DIO Double
getLocalTime
     ProcessId
sender   <- DIO ProcessId
messageInboxId
     ProcessId
receiver <- DIO ProcessId
timeServerId
     ProcessId -> ProcessId -> Double -> DIO ()
sendLocalTimeDIO ProcessId
receiver ProcessId
sender Double
t'
processChannelMessage x :: LogicalProcessMessage
x@(GlobalTimeMessage Double
globalTime) =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     ---
     --- invokeEvent p $
     ---   logMessage x
     ---
     IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       do IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (EventQueue DIO -> IORef Bool
queueInFind EventQueue DIO
q) Bool
False
          TransientMessageQueue -> IO ()
resetAcknowledgementMessageTime (EventQueue DIO -> TransientMessageQueue
queueTransientMessages EventQueue DIO
q)
     Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO () -> DIO ()) -> Event DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       Double -> Event DIO ()
updateGlobalTime Double
globalTime
processChannelMessage x :: LogicalProcessMessage
x@(ProcessMonitorNotificationMessage y :: ProcessMonitorNotification
y@(DP.ProcessMonitorNotification MonitorRef
_ ProcessId
pid DiedReason
reason)) =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     ---
     --- invokeEvent p $
     ---   logMessage x
     ---
     Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO () -> DIO ()) -> Event DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       SignalSource DIO ProcessMonitorNotification
-> ProcessMonitorNotification -> Event DIO ()
forall (m :: * -> *) a. SignalSource m a -> a -> Event m ()
triggerSignal (EventQueue DIO -> SignalSource DIO ProcessMonitorNotification
queueProcessMonitorNotificationSource EventQueue DIO
q) ProcessMonitorNotification
y
processChannelMessage x :: LogicalProcessMessage
x@(ReconnectProcessMessage ProcessId
pid) =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     ---
     --- invokeEvent p $
     ---   logMessage x
     ---
     Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO () -> DIO ()) -> Event DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       ProcessId -> Event DIO ()
reconnectProcess ProcessId
pid
processChannelMessage x :: LogicalProcessMessage
x@(ProvideLogicalProcessStateMessage ProcessId
pid) =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do ---
     --- invokeEvent p $
     ---   logMessage x
     ---
     Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO () -> DIO ()) -> Event DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       ProcessId -> Event DIO ()
sendState ProcessId
pid
processChannelMessage x :: LogicalProcessMessage
x@LogicalProcessMessage
AbortSimulationMessage =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do ---
     --- invokeEvent p $
     ---   logMessage x
     ---
     Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO () -> DIO ()) -> Event DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       SimulationAbort -> Event DIO ()
forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> Event m a
throwEvent (SimulationAbort -> Event DIO ())
-> SimulationAbort -> Event DIO ()
forall a b. (a -> b) -> a -> b
$
       [Char] -> SimulationAbort
SimulationAbort [Char]
"Aborted by the outer process."
processChannelMessage x :: LogicalProcessMessage
x@(DisconnectProcessMessage ProcessId
pid) =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     ---
     --- invokeEvent p $
     ---   logMessage x
     ---
     Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO () -> DIO ()) -> Event DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       ProcessId -> Event DIO ()
disconnectProcess ProcessId
pid

-- | Return the local minimum time.
getLocalTime :: Event DIO Double
getLocalTime :: Event DIO Double
getLocalTime =
  (Point DIO -> DIO Double) -> Event DIO Double
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO Double) -> Event DIO Double)
-> (Point DIO -> DIO Double) -> Event DIO Double
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     Double
t1 <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef (EventQueue DIO -> IORef Double
queueTime EventQueue DIO
q)
     Double
t2 <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ TransientMessageQueue -> IO Double
transientMessageQueueTime (EventQueue DIO -> TransientMessageQueue
queueTransientMessages EventQueue DIO
q)
     Double
t3 <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ TransientMessageQueue -> IO Double
acknowledgementMessageTime (EventQueue DIO -> TransientMessageQueue
queueTransientMessages EventQueue DIO
q)
     let t' :: Double
t' = Double
t1 Double -> Double -> Double
forall a. Ord a => a -> a -> a
`min` Double
t2 Double -> Double -> Double
forall a. Ord a => a -> a -> a
`min` Double
t3
     ---
     --- n <- liftIOUnsafe $ transientMessageQueueSize (queueTransientMessages q)
     --- logDIO ERROR $
     ---   "t = " ++ show (pointTime p) ++
     ---   ": queue time = " ++ show t1 ++
     ---   ", unacknowledged time = " ++ show t2 ++
     ---   ", marked acknowledged time = " ++ show t3 ++
     ---   ", transient queue size = " ++ show n ++
     ---   " -> " ++ show t'
     ---
     Double -> DIO Double
forall a. a -> DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return Double
t'

-- | Test whether the local time is ending.
isLocalTimeEnding :: Event DIO Bool
isLocalTimeEnding :: Event DIO Bool
isLocalTimeEnding =
  (Point DIO -> DIO Bool) -> Event DIO Bool
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO Bool) -> Event DIO Bool)
-> (Point DIO -> DIO Bool) -> Event DIO Bool
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q  = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
         t0 :: Double
t0 = Specs DIO -> Double
forall (m :: * -> *). Specs m -> Double
spcStopTime (Specs DIO -> Double) -> Specs DIO -> Double
forall a b. (a -> b) -> a -> b
$ Point DIO -> Specs DIO
forall (m :: * -> *). Point m -> Specs m
pointSpecs Point DIO
p 
     Double
t1 <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef (EventQueue DIO -> IORef Double
queueTime EventQueue DIO
q)
     Double
t2 <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ TransientMessageQueue -> IO Double
transientMessageQueueTime (EventQueue DIO -> TransientMessageQueue
queueTransientMessages EventQueue DIO
q)
     Double
t3 <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ TransientMessageQueue -> IO Double
acknowledgementMessageTime (EventQueue DIO -> TransientMessageQueue
queueTransientMessages EventQueue DIO
q)
     Bool -> DIO Bool
forall a. a -> DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> DIO Bool) -> Bool -> DIO Bool
forall a b. (a -> b) -> a -> b
$ (Double
t1 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
t0) Bool -> Bool -> Bool
&& (Double
t2 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
t0) Bool -> Bool -> Bool
&& (Double
t3 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
t0)

-- | Update the global time.
updateGlobalTime :: Double -> Event DIO ()
updateGlobalTime :: Double -> Event DIO ()
updateGlobalTime Double
t =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     Double
t' <- Point DIO -> Event DIO Double -> DIO Double
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p Event DIO Double
getLocalTime
     if Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
t'
       then Priority -> [Char] -> DIO ()
logDIO Priority
WARNING ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
            [Char]
"t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
t' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
            [Char]
": Ignored the global time that is greater than the current local time"
       else do IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
                 IORef Double -> Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (EventQueue DIO -> IORef Double
queueGlobalTime EventQueue DIO
q) Double
t
               Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO () -> DIO ()) -> Event DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
                 Double -> Event DIO ()
reduceEvents Double
t

-- | Request for the global minimum time.
requestGlobalTime :: Event DIO ()
requestGlobalTime :: Event DIO ()
requestGlobalTime =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     ---
     --- invokeEvent p $
     ---   logRequestGlobalTime
     ---
     ProcessId
sender   <- DIO ProcessId
messageInboxId
     ProcessId
receiver <- DIO ProcessId
timeServerId
     ProcessId -> ProcessId -> DIO ()
sendRequestGlobalTimeDIO ProcessId
receiver ProcessId
sender

-- | Show the message.
showMessage :: Message -> ShowS
showMessage :: Message -> [Char] -> [Char]
showMessage Message
m =
  [Char] -> [Char] -> [Char]
showString [Char]
"{ " ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  [Char] -> [Char] -> [Char]
showString [Char]
"sendTime = " ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Double -> [Char] -> [Char]
forall a. Show a => a -> [Char] -> [Char]
shows (Message -> Double
messageSendTime Message
m) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  [Char] -> [Char] -> [Char]
showString [Char]
", receiveTime = " ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Double -> [Char] -> [Char]
forall a. Show a => a -> [Char] -> [Char]
shows (Message -> Double
messageReceiveTime Message
m) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (if Message -> Bool
messageAntiToggle Message
m
   then [Char] -> [Char] -> [Char]
showString [Char]
", antiToggle = True"
   else [Char] -> [Char] -> [Char]
showString [Char]
"") ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  [Char] -> [Char] -> [Char]
showString [Char]
" }"

-- | Log the message at the specified time.
logMessage :: LogicalProcessMessage -> Event DIO ()
logMessage :: LogicalProcessMessage -> Event DIO ()
logMessage (QueueMessage Message
m) =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  Priority -> [Char] -> DIO ()
logDIO Priority
INFO ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
  [Char]
"t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Double -> [Char]
forall a. Show a => a -> [Char]
show (Double -> [Char]) -> Double -> [Char]
forall a b. (a -> b) -> a -> b
$ Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
  [Char]
": QueueMessage " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
  Message -> [Char] -> [Char]
showMessage Message
m []
logMessage (QueueMessageBulk [Message]
ms) =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  Priority -> [Char] -> DIO ()
logDIO Priority
INFO ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
  [Char]
"t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Double -> [Char]
forall a. Show a => a -> [Char]
show (Double -> [Char]) -> Double -> [Char]
forall a b. (a -> b) -> a -> b
$ Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
  [Char]
": QueueMessageBulk [ " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
  let fs :: [Char] -> [Char]
fs = (([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char])
-> [[Char] -> [Char]] -> [Char] -> [Char]
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\[Char] -> [Char]
a [Char] -> [Char]
b -> [Char] -> [Char]
a ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString [Char]
", " ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
b) ([[Char] -> [Char]] -> [Char] -> [Char])
-> [[Char] -> [Char]] -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Message -> [Char] -> [Char]) -> [Message] -> [[Char] -> [Char]]
forall a b. (a -> b) -> [a] -> [b]
map Message -> [Char] -> [Char]
showMessage [Message]
ms
  in [Char] -> [Char]
fs [] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" ]" 
logMessage LogicalProcessMessage
m =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  Priority -> [Char] -> DIO ()
logDIO Priority
DEBUG ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
  [Char]
"t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Double -> [Char]
forall a. Show a => a -> [Char]
show (Double -> [Char]) -> Double -> [Char]
forall a b. (a -> b) -> a -> b
$ Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
  [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ LogicalProcessMessage -> [Char]
forall a. Show a => a -> [Char]
show LogicalProcessMessage
m

-- | Log that the local time is to be synchronized.
logSyncLocalTime :: Event DIO ()
logSyncLocalTime :: Event DIO ()
logSyncLocalTime =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     Double
t' <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef (EventQueue DIO -> IORef Double
queueGlobalTime EventQueue DIO
q)
     Priority -> [Char] -> DIO ()
logDIO Priority
DEBUG ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
       [Char]
"t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Double -> [Char]
forall a. Show a => a -> [Char]
show (Double -> [Char]) -> Double -> [Char]
forall a b. (a -> b) -> a -> b
$ Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
       [Char]
", global t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Double -> [Char]
forall a. Show a => a -> [Char]
show Double
t') [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
       [Char]
": synchronizing the local time..."

-- | Log that the local time is to be synchronized in ring 0.
logSyncLocalTime0 :: Event DIO ()
logSyncLocalTime0 :: Event DIO ()
logSyncLocalTime0 =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     Double
t' <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef (EventQueue DIO -> IORef Double
queueGlobalTime EventQueue DIO
q)
     Priority -> [Char] -> DIO ()
logDIO Priority
DEBUG ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
       [Char]
"t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Double -> [Char]
forall a. Show a => a -> [Char]
show (Double -> [Char]) -> Double -> [Char]
forall a b. (a -> b) -> a -> b
$ Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
       [Char]
", global t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Double -> [Char]
forall a. Show a => a -> [Char]
show Double
t') [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
       [Char]
": synchronizing the local time in ring 0..."

-- | Log that the global time is requested.
logRequestGlobalTime :: Event DIO ()
logRequestGlobalTime :: Event DIO ()
logRequestGlobalTime =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     Double
t' <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef (EventQueue DIO -> IORef Double
queueGlobalTime EventQueue DIO
q)
     Priority -> [Char] -> DIO ()
logDIO Priority
DEBUG ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
       [Char]
"t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Double -> [Char]
forall a. Show a => a -> [Char]
show (Double -> [Char]) -> Double -> [Char]
forall a b. (a -> b) -> a -> b
$ Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
       [Char]
", global t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Double -> [Char]
forall a. Show a => a -> [Char]
show Double
t') [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
       [Char]
": requesting for a new global time..."

-- | Log an evidence of the premature IO.
logPrematureIO :: Event DIO ()
logPrematureIO :: Event DIO ()
logPrematureIO =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  Priority -> [Char] -> DIO ()
logDIO Priority
ERROR ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
  [Char]
"t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Double -> [Char]
forall a. Show a => a -> [Char]
show (Double -> [Char]) -> Double -> [Char]
forall a b. (a -> b) -> a -> b
$ Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
  [Char]
": detected a premature IO action"

-- | Log an evidence of receiving the outdated message.
logOutdatedMessage :: Event DIO ()
logOutdatedMessage :: Event DIO ()
logOutdatedMessage =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  Priority -> [Char] -> DIO ()
logDIO Priority
WARNING ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
  [Char]
"t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Double -> [Char]
forall a. Show a => a -> [Char]
show (Double -> [Char]) -> Double -> [Char]
forall a b. (a -> b) -> a -> b
$ Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
  [Char]
": skipping the outdated message"

-- | Reduce events till the specified time.
reduceEvents :: Double -> Event DIO ()
reduceEvents :: Double -> Event DIO ()
reduceEvents Double
t =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     DIOParams
ps <- DIO DIOParams
dioParams 
     IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       do InputMessageQueue -> Double -> IO ()
reduceInputMessages (EventQueue DIO -> InputMessageQueue
queueInputMessages EventQueue DIO
q) Double
t
          OutputMessageQueue -> Double -> IO ()
reduceOutputMessages (EventQueue DIO -> OutputMessageQueue
queueOutputMessages EventQueue DIO
q) Double
t
          UndoableLog -> Double -> IO ()
reduceLog (EventQueue DIO -> UndoableLog
queueLog EventQueue DIO
q) Double
t
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DIOParams -> Bool
dioProcessReconnectingEnabled DIOParams
ps) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            AcknowledgementMessageQueue -> Double -> IO ()
reduceAcknowledgementMessages (EventQueue DIO -> AcknowledgementMessageQueue
queueAcknowledgementMessages EventQueue DIO
q) Double
t

instance {-# OVERLAPPING #-} MonadIO (Event DIO) where

  liftIO :: forall a. IO a -> Event DIO a
liftIO IO a
m =
    (Point DIO -> DIO a) -> Event DIO a
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO a) -> Event DIO a)
-> (Point DIO -> DIO a) -> Event DIO a
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
    do Bool
ok <- Point DIO -> Event DIO Bool -> DIO Bool
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO Bool -> DIO Bool) -> Event DIO Bool -> DIO Bool
forall a b. (a -> b) -> a -> b
$
             TimeWarp DIO () -> Event DIO Bool
runTimeWarp (TimeWarp DIO () -> Event DIO Bool)
-> TimeWarp DIO () -> Event DIO Bool
forall a b. (a -> b) -> a -> b
$
             Dynamics DIO () -> TimeWarp DIO ()
syncLocalTime (Dynamics DIO () -> TimeWarp DIO ())
-> Dynamics DIO () -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$
             () -> Dynamics DIO ()
forall a. a -> Dynamics DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       if Bool
ok
         then IO a -> DIO a
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe IO a
m
         else do Bool
f <- (DIOParams -> Bool) -> DIO DIOParams -> DIO Bool
forall a b. (a -> b) -> DIO a -> DIO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DIOParams -> Bool
dioAllowPrematureIO DIO DIOParams
dioParams
                 if Bool
f
                   then do ---
                           --- invokeEvent p $ logPrematureIO
                           ---
                           IO a -> DIO a
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe IO a
m
                   else [Char] -> DIO a
forall a. HasCallStack => [Char] -> a
error ([Char] -> DIO a) -> [Char] -> DIO a
forall a b. (a -> b) -> a -> b
$
                        [Char]
"Detected a premature IO action at t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                        (Double -> [Char]
forall a. Show a => a -> [Char]
show (Double -> [Char]) -> Double -> [Char]
forall a b. (a -> b) -> a -> b
$ Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": liftIO"

-- | Synchronize the local time executing the specified computation.
syncLocalTime :: Dynamics DIO () -> TimeWarp DIO ()
syncLocalTime :: Dynamics DIO () -> TimeWarp DIO ()
syncLocalTime Dynamics DIO ()
m =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do Point DIO -> Dynamics DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Dynamics m a -> m a
invokeDynamics Point DIO
p Dynamics DIO ()
m
     Bool
f <- Point DIO -> Event DIO Bool -> DIO Bool
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p Event DIO Bool
isLocalTimeSynchronized
     Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
f (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       do ---
          --- invokeEvent p logSyncLocalTime
          ---
          Channel LogicalProcessMessage
ch <- DIO (Channel LogicalProcessMessage)
messageChannel
          Int
dt <- (DIOParams -> Int) -> DIO DIOParams -> DIO Int
forall a b. (a -> b) -> DIO a -> DIO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DIOParams -> Int
dioSyncTimeout DIO DIOParams
dioParams
          Maybe ()
f  <- IO (Maybe ()) -> DIO (Maybe ())
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO (Maybe ()) -> DIO (Maybe ()))
-> IO (Maybe ()) -> DIO (Maybe ())
forall a b. (a -> b) -> a -> b
$
                Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
dt (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ Channel LogicalProcessMessage -> IO ()
forall a. Channel a -> IO ()
awaitChannel Channel LogicalProcessMessage
ch
          Bool
ok <- Point DIO -> Event DIO Bool -> DIO Bool
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO Bool -> DIO Bool) -> Event DIO Bool -> DIO Bool
forall a b. (a -> b) -> a -> b
$ TimeWarp DIO () -> Event DIO Bool
runTimeWarp TimeWarp DIO ()
processChannelMessages
          Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
            case Maybe ()
f of
              Just ()
_  ->
                Point DIO -> TimeWarp DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> TimeWarp m a -> m a
invokeTimeWarp Point DIO
p (TimeWarp DIO () -> DIO ()) -> TimeWarp DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ Dynamics DIO () -> TimeWarp DIO ()
syncLocalTime Dynamics DIO ()
m
              Maybe ()
Nothing ->
                do -- invokeEvent p requestGlobalTime
                   Point DIO -> TimeWarp DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> TimeWarp m a -> m a
invokeTimeWarp Point DIO
p (TimeWarp DIO () -> DIO ()) -> TimeWarp DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ Dynamics DIO () -> TimeWarp DIO ()
syncLocalTime0 Dynamics DIO ()
m
  
-- | Synchronize the local time executing the specified computation in ring 0.
syncLocalTime0 :: Dynamics DIO () -> TimeWarp DIO ()
syncLocalTime0 :: Dynamics DIO () -> TimeWarp DIO ()
syncLocalTime0 Dynamics DIO ()
m =
  (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> TimeWarp m a
TimeWarp ((Point DIO -> DIO ()) -> TimeWarp DIO ())
-> (Point DIO -> DIO ()) -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do Point DIO -> Dynamics DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Dynamics m a -> m a
invokeDynamics Point DIO
p Dynamics DIO ()
m
     Bool
f <- Point DIO -> Event DIO Bool -> DIO Bool
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p Event DIO Bool
isLocalTimeSynchronized
     Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
f (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       do ---
          --- invokeEvent p logSyncLocalTime0
          ---
          Channel LogicalProcessMessage
ch <- DIO (Channel LogicalProcessMessage)
messageChannel
          Int
dt <- (DIOParams -> Int) -> DIO DIOParams -> DIO Int
forall a b. (a -> b) -> DIO a -> DIO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DIOParams -> Int
dioSyncTimeout DIO DIOParams
dioParams
          Maybe ()
f  <- IO (Maybe ()) -> DIO (Maybe ())
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO (Maybe ()) -> DIO (Maybe ()))
-> IO (Maybe ()) -> DIO (Maybe ())
forall a b. (a -> b) -> a -> b
$
                Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
dt (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ Channel LogicalProcessMessage -> IO ()
forall a. Channel a -> IO ()
awaitChannel Channel LogicalProcessMessage
ch
          Bool
ok <- Point DIO -> Event DIO Bool -> DIO Bool
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO Bool -> DIO Bool) -> Event DIO Bool -> DIO Bool
forall a b. (a -> b) -> a -> b
$ TimeWarp DIO () -> Event DIO Bool
runTimeWarp TimeWarp DIO ()
processChannelMessages
          Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
            case Maybe ()
f of
              Just ()
_  ->
                Point DIO -> TimeWarp DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> TimeWarp m a -> m a
invokeTimeWarp Point DIO
p (TimeWarp DIO () -> DIO ()) -> TimeWarp DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ Dynamics DIO () -> TimeWarp DIO ()
syncLocalTime Dynamics DIO ()
m
              Maybe ()
Nothing ->
                [Char] -> DIO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Exceeded the timeout when synchronizing the local time: syncLocalTime0"

-- | Test whether the local time is synchronized.
isLocalTimeSynchronized :: Event DIO Bool
isLocalTimeSynchronized :: Event DIO Bool
isLocalTimeSynchronized =
  (Point DIO -> DIO Bool) -> Event DIO Bool
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO Bool) -> Event DIO Bool)
-> (Point DIO -> DIO Bool) -> Event DIO Bool
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
         t :: Double
t = Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p
     Double
t' <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef (EventQueue DIO -> IORef Double
queueGlobalTime EventQueue DIO
q)
     if Double
t' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
t
       then [Char] -> DIO Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Inconsistent time: isLocalTimeSynchronized"
       else if (Double
t Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Specs DIO -> Double
forall (m :: * -> *). Specs m -> Double
spcStartTime (Point DIO -> Specs DIO
forall (m :: * -> *). Point m -> Specs m
pointSpecs Point DIO
p)) Bool -> Bool -> Bool
|| (Double
t' Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
t)
            then Bool -> DIO Bool
forall a. a -> DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            else do Bool
leaving <- IO Bool -> DIO Bool
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Bool -> DIO Bool) -> IO Bool -> DIO Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (EventQueue DIO -> IORef Bool
queueIsLeaving EventQueue DIO
q)
                    if (Bool
leaving Bool -> Bool -> Bool
&& (Double
t Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Specs DIO -> Double
forall (m :: * -> *). Specs m -> Double
spcStopTime (Point DIO -> Specs DIO
forall (m :: * -> *). Point m -> Specs m
pointSpecs Point DIO
p)))
                      then Point DIO -> Event DIO Bool -> DIO Bool
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p Event DIO Bool
isLocalTimeEnding
                      else Bool -> DIO Bool
forall a. a -> DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Run the computation and return a flag indicating whether there was no rollback.
runTimeWarp :: TimeWarp DIO () -> Event DIO Bool
runTimeWarp :: TimeWarp DIO () -> Event DIO Bool
runTimeWarp TimeWarp DIO ()
m =
  (Point DIO -> DIO Bool) -> Event DIO Bool
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO Bool) -> Event DIO Bool)
-> (Point DIO -> DIO Bool) -> Event DIO Bool
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     Int
v0 <- IO Int -> DIO Int
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Int -> DIO Int) -> IO Int -> DIO Int
forall a b. (a -> b) -> a -> b
$ InputMessageQueue -> IO Int
inputMessageQueueVersion (EventQueue DIO -> InputMessageQueue
queueInputMessages EventQueue DIO
q)
     Point DIO -> TimeWarp DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> TimeWarp m a -> m a
invokeTimeWarp Point DIO
p TimeWarp DIO ()
m
     Int
v2 <- IO Int -> DIO Int
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Int -> DIO Int) -> IO Int -> DIO Int
forall a b. (a -> b) -> a -> b
$ InputMessageQueue -> IO Int
inputMessageQueueVersion (EventQueue DIO -> InputMessageQueue
queueInputMessages EventQueue DIO
q)
     Bool -> DIO Bool
forall a. a -> DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
v0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v2)

-- | Synchronize the events.
syncEvents :: EventProcessing -> Event DIO ()
syncEvents :: EventProcessing -> Event DIO ()
syncEvents EventProcessing
processing =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do Bool
ok <- Point DIO -> Event DIO Bool -> DIO Bool
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO Bool -> DIO Bool) -> Event DIO Bool -> DIO Bool
forall a b. (a -> b) -> a -> b
$
           TimeWarp DIO () -> Event DIO Bool
runTimeWarp (TimeWarp DIO () -> Event DIO Bool)
-> TimeWarp DIO () -> Event DIO Bool
forall a b. (a -> b) -> a -> b
$
           Dynamics DIO () -> TimeWarp DIO ()
syncLocalTime (Dynamics DIO () -> TimeWarp DIO ())
-> Dynamics DIO () -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$
           EventProcessing -> Dynamics DIO ()
processEvents EventProcessing
processing
     Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO () -> DIO ()) -> Event DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       EventProcessing -> Event DIO ()
syncEvents EventProcessing
processing

-- | 'DIO' is an instance of 'EventIOQueueing'.
instance EventIOQueueing DIO where

  enqueueEventIO :: Double -> Event DIO () -> Event DIO ()
enqueueEventIO Double
t Event DIO ()
h =
    Double -> Event DIO () -> Event DIO ()
forall (m :: * -> *).
EventQueueing m =>
Double -> Event m () -> Event m ()
enqueueEvent Double
t (Event DIO () -> Event DIO ()) -> Event DIO () -> Event DIO ()
forall a b. (a -> b) -> a -> b
$
    (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
    do Bool
ok <- Point DIO -> Event DIO Bool -> DIO Bool
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO Bool -> DIO Bool) -> Event DIO Bool -> DIO Bool
forall a b. (a -> b) -> a -> b
$
             TimeWarp DIO () -> Event DIO Bool
runTimeWarp (TimeWarp DIO () -> Event DIO Bool)
-> TimeWarp DIO () -> Event DIO Bool
forall a b. (a -> b) -> a -> b
$
             Dynamics DIO () -> TimeWarp DIO ()
syncLocalTime (Dynamics DIO () -> TimeWarp DIO ())
-> Dynamics DIO () -> TimeWarp DIO ()
forall a b. (a -> b) -> a -> b
$
             () -> Dynamics DIO ()
forall a. a -> Dynamics DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
         Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p Event DIO ()
h

-- | Handle the 'Event' retry.
handleEventRetry :: SimulationRetry -> Event DIO ()
handleEventRetry :: SimulationRetry -> Event DIO ()
handleEventRetry SimulationRetry
e =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
         t :: Double
t = Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p
     ---
     Priority -> [Char] -> DIO ()
logDIO Priority
INFO ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
       [Char]
"t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
       [Char]
": retrying the computations..."
     ---
     Point DIO -> TimeWarp DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> TimeWarp m a -> m a
invokeTimeWarp Point DIO
p (TimeWarp DIO () -> DIO ()) -> TimeWarp DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       InputMessageQueue -> TimeWarp DIO ()
retryInputMessages (EventQueue DIO -> InputMessageQueue
queueInputMessages EventQueue DIO
q)
     let loop :: DIO ()
loop =
           do ---
              --- logDIO DEBUG $
              ---   "t = " ++ show t ++
              ---   ": waiting for arriving a message..."
              ---
              Channel LogicalProcessMessage
ch <- DIO (Channel LogicalProcessMessage)
messageChannel
              Int
dt <- (DIOParams -> Int) -> DIO DIOParams -> DIO Int
forall a b. (a -> b) -> DIO a -> DIO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DIOParams -> Int
dioSyncTimeout DIO DIOParams
dioParams
              Maybe ()
f  <- IO (Maybe ()) -> DIO (Maybe ())
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO (Maybe ()) -> DIO (Maybe ()))
-> IO (Maybe ()) -> DIO (Maybe ())
forall a b. (a -> b) -> a -> b
$
                    Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
dt (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ Channel LogicalProcessMessage -> IO ()
forall a. Channel a -> IO ()
awaitChannel Channel LogicalProcessMessage
ch
              Bool
ok <- Point DIO -> Event DIO Bool -> DIO Bool
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO Bool -> DIO Bool) -> Event DIO Bool -> DIO Bool
forall a b. (a -> b) -> a -> b
$ TimeWarp DIO () -> Event DIO Bool
runTimeWarp TimeWarp DIO ()
processChannelMessages
              Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
                case Maybe ()
f of
                  Just ()
_  -> DIO ()
loop
                  Maybe ()
Nothing -> DIO ()
loop0
         loop0 :: DIO ()
loop0 =
           do ---
              --- logDIO DEBUG $
              ---   "t = " ++ show t ++
              ---   ": waiting for arriving a message in ring 0..."
              ---
              Channel LogicalProcessMessage
ch <- DIO (Channel LogicalProcessMessage)
messageChannel
              Int
dt <- (DIOParams -> Int) -> DIO DIOParams -> DIO Int
forall a b. (a -> b) -> DIO a -> DIO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DIOParams -> Int
dioSyncTimeout DIO DIOParams
dioParams
              Maybe ()
f  <- IO (Maybe ()) -> DIO (Maybe ())
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO (Maybe ()) -> DIO (Maybe ()))
-> IO (Maybe ()) -> DIO (Maybe ())
forall a b. (a -> b) -> a -> b
$
                    Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
dt (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ Channel LogicalProcessMessage -> IO ()
forall a. Channel a -> IO ()
awaitChannel Channel LogicalProcessMessage
ch
              Bool
ok <- Point DIO -> Event DIO Bool -> DIO Bool
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO Bool -> DIO Bool) -> Event DIO Bool -> DIO Bool
forall a b. (a -> b) -> a -> b
$ TimeWarp DIO () -> Event DIO Bool
runTimeWarp TimeWarp DIO ()
processChannelMessages
              Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
                case Maybe ()
f of
                  Just ()
_  -> DIO ()
loop
                  Maybe ()
Nothing ->
                    [Char] -> DIO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
                    [Char]
"Detected a deadlock when retrying the computations: handleEventRetry\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                    [Char]
"--- the nested exception ---\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SimulationRetry -> [Char]
forall a. Show a => a -> [Char]
show SimulationRetry
e 
     DIO ()
loop

-- | Reconnect to the remote process.
reconnectProcess :: DP.ProcessId -> Event DIO ()
reconnectProcess :: ProcessId -> Event DIO ()
reconnectProcess ProcessId
pid =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     ---
     Priority -> [Char] -> DIO ()
logDIO Priority
NOTICE ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
       [Char]
"t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show (Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
       [Char]
": reconnecting to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ProcessId -> [Char]
forall a. Show a => a -> [Char]
show ProcessId
pid [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"..."
     ---
     let ys :: AcknowledgementMessageQueue
ys = EventQueue DIO -> AcknowledgementMessageQueue
queueAcknowledgementMessages EventQueue DIO
q
     [AcknowledgementMessage]
ys' <- IO [AcknowledgementMessage] -> DIO [AcknowledgementMessage]
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO [AcknowledgementMessage] -> DIO [AcknowledgementMessage])
-> IO [AcknowledgementMessage] -> DIO [AcknowledgementMessage]
forall a b. (a -> b) -> a -> b
$
            (AcknowledgementMessage -> Bool)
-> AcknowledgementMessageQueue -> IO [AcknowledgementMessage]
filterAcknowledgementMessages (\AcknowledgementMessage
x -> AcknowledgementMessage -> ProcessId
acknowledgementSenderId AcknowledgementMessage
x ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid) AcknowledgementMessageQueue
ys
     Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([AcknowledgementMessage] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AcknowledgementMessage]
ys') (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       ProcessId -> [AcknowledgementMessage] -> DIO ()
sendAcknowledgementMessagesDIO ProcessId
pid [AcknowledgementMessage]
ys'
     [Message]
xs <- IO [Message] -> DIO [Message]
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO [Message] -> DIO [Message]) -> IO [Message] -> DIO [Message]
forall a b. (a -> b) -> a -> b
$ TransientMessageQueue -> IO [Message]
transientMessages (EventQueue DIO -> TransientMessageQueue
queueTransientMessages EventQueue DIO
q)
     let xs' :: [Message]
xs' = (Message -> Bool) -> [Message] -> [Message]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Message
x -> Message -> ProcessId
messageReceiverId Message
x ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid) [Message]
xs
     Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Message] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
xs') (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       ProcessId -> [Message] -> DIO ()
sendMessagesDIO ProcessId
pid [Message]
xs'

-- | A signal triggered when coming the process monitor notification from the Cloud Haskell back-end.
processMonitorSignal :: Signal DIO DP.ProcessMonitorNotification
processMonitorSignal :: Signal DIO ProcessMonitorNotification
processMonitorSignal =
  Signal { handleSignal :: (ProcessMonitorNotification -> Event DIO ())
-> Event DIO (DisposableEvent DIO)
handleSignal = \ProcessMonitorNotification -> Event DIO ()
h ->
            (Point DIO -> DIO (DisposableEvent DIO))
-> Event DIO (DisposableEvent DIO)
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO (DisposableEvent DIO))
 -> Event DIO (DisposableEvent DIO))
-> (Point DIO -> DIO (DisposableEvent DIO))
-> Event DIO (DisposableEvent DIO)
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
            let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p)
                s :: Signal DIO ProcessMonitorNotification
s = SignalSource DIO ProcessMonitorNotification
-> Signal DIO ProcessMonitorNotification
forall (m :: * -> *) a. SignalSource m a -> Signal m a
publishSignal (EventQueue DIO -> SignalSource DIO ProcessMonitorNotification
queueProcessMonitorNotificationSource EventQueue DIO
q)
            in Point DIO
-> Event DIO (DisposableEvent DIO) -> DIO (DisposableEvent DIO)
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO (DisposableEvent DIO) -> DIO (DisposableEvent DIO))
-> Event DIO (DisposableEvent DIO) -> DIO (DisposableEvent DIO)
forall a b. (a -> b) -> a -> b
$
               Signal DIO ProcessMonitorNotification
-> (ProcessMonitorNotification -> Event DIO ())
-> Event DIO (DisposableEvent DIO)
forall (m :: * -> *) a.
Signal m a -> (a -> Event m ()) -> Event m (DisposableEvent m)
handleSignal Signal DIO ProcessMonitorNotification
s ProcessMonitorNotification -> Event DIO ()
h
         }


-- | Suspend the 'Event' computation until the specified computation is determined.
--
-- The tested computation should depend on messages that come from other logical processes.
-- Moreover, the event must be initiated through the event queue.
expectEvent :: Event DIO (Maybe a) -> (a -> Event DIO ()) -> Event DIO ()
expectEvent :: forall a.
Event DIO (Maybe a) -> (a -> Event DIO ()) -> Event DIO ()
expectEvent Event DIO (Maybe a)
m a -> Event DIO ()
cont =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
         t :: Double
t = Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p
         priority :: Int
priority = Point DIO -> Int
forall (m :: * -> *). Point m -> Int
pointPriority Point DIO
p
     ---
     Priority -> [Char] -> DIO ()
logDIO Priority
INFO ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
       [Char]
"t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show (Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
       [Char]
": expecting the computation result: expectEvent"
     ---
     let loop :: DIO ()
loop =
           do ---
              --- logDIO DEBUG $
              ---   "t = " ++ show (pointTime p) ++
              ---   ": testing the predicate: expectEvent"
              ---
              Maybe a
x <- Point DIO -> Event DIO (Maybe a) -> DIO (Maybe a)
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p Event DIO (Maybe a)
m
              case Maybe a
x of
                Just a
a  -> Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO () -> DIO ()) -> Event DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ a -> Event DIO ()
cont a
a
                Maybe a
Nothing -> DIO () -> DIO ()
next DIO ()
loop0
         loop0 :: DIO ()
loop0 =
           do ---
              --- logDIO DEBUG $
              ---   "t = " ++ show (pointTime p) ++
              ---   ": testing the predicate in ring 0: expectEvent"
              ---
              Maybe a
x <- Point DIO -> Event DIO (Maybe a) -> DIO (Maybe a)
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p Event DIO (Maybe a)
m
              case Maybe a
x of
                Just a
a  -> Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO () -> DIO ()) -> Event DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ a -> Event DIO ()
cont a
a
                Maybe a
Nothing -> DIO () -> DIO ()
next (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> DIO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Detected a deadlock: expectEvent"
         next :: DIO () -> DIO ()
next DIO ()
loop' =
           do PriorityQueue (Point DIO -> DIO ())
pq <- Point DIO
-> Event DIO (PriorityQueue (Point DIO -> DIO ()))
-> DIO (PriorityQueue (Point DIO -> DIO ()))
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO (PriorityQueue (Point DIO -> DIO ()))
 -> DIO (PriorityQueue (Point DIO -> DIO ())))
-> Event DIO (PriorityQueue (Point DIO -> DIO ()))
-> DIO (PriorityQueue (Point DIO -> DIO ()))
forall a b. (a -> b) -> a -> b
$ Ref (PriorityQueue (Point DIO -> DIO ()))
-> Event DIO (PriorityQueue (Point DIO -> DIO ()))
forall a. Ref a -> Event DIO a
R.readRef (Ref (PriorityQueue (Point DIO -> DIO ()))
 -> Event DIO (PriorityQueue (Point DIO -> DIO ())))
-> Ref (PriorityQueue (Point DIO -> DIO ()))
-> Event DIO (PriorityQueue (Point DIO -> DIO ()))
forall a b. (a -> b) -> a -> b
$ EventQueue DIO -> Ref (PriorityQueue (Point DIO -> DIO ()))
queuePQ EventQueue DIO
q
              let f :: Bool
f = PriorityQueue (Point DIO -> DIO ()) -> Bool
forall a. PriorityQueue a -> Bool
PQ.queueNull PriorityQueue (Point DIO -> DIO ())
pq
              if Bool
f
                then DIO () -> DIO ()
await DIO ()
loop'
                else do let (Double
t2, Int
priority2, Point DIO -> DIO ()
_) = PriorityQueue (Point DIO -> DIO ())
-> (Double, Int, Point DIO -> DIO ())
forall a. PriorityQueue a -> (Double, Int, a)
PQ.queueFront PriorityQueue (Point DIO -> DIO ())
pq
                        if (Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
t2) Bool -> Bool -> Bool
|| (Double
t Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
t2 Bool -> Bool -> Bool
&& Int
priority Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
priority2)
                          then DIO () -> DIO ()
await DIO ()
loop'
                          else Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO () -> DIO ()) -> Event DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
                               Double -> Event DIO () -> Event DIO ()
forall (m :: * -> *).
EventQueueing m =>
Double -> Event m () -> Event m ()
enqueueEvent Double
t (Event DIO () -> Event DIO ()) -> Event DIO () -> Event DIO ()
forall a b. (a -> b) -> a -> b
$
                               (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p -> DIO ()
loop
         await :: DIO () -> DIO ()
await DIO ()
loop' =
           do ---
              --- logDIO DEBUG $
              ---   "t = " ++ show t ++
              ---   ": waiting for arriving a message: expectEvent"
              ---
              Channel LogicalProcessMessage
ch <- DIO (Channel LogicalProcessMessage)
messageChannel
              Int
dt <- (DIOParams -> Int) -> DIO DIOParams -> DIO Int
forall a b. (a -> b) -> DIO a -> DIO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DIOParams -> Int
dioSyncTimeout DIO DIOParams
dioParams
              Maybe ()
f  <- IO (Maybe ()) -> DIO (Maybe ())
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO (Maybe ()) -> DIO (Maybe ()))
-> IO (Maybe ()) -> DIO (Maybe ())
forall a b. (a -> b) -> a -> b
$
                    Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
dt (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ Channel LogicalProcessMessage -> IO ()
forall a. Channel a -> IO ()
awaitChannel Channel LogicalProcessMessage
ch
              Bool
ok <- Point DIO -> Event DIO Bool -> DIO Bool
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO Bool -> DIO Bool) -> Event DIO Bool -> DIO Bool
forall a b. (a -> b) -> a -> b
$ TimeWarp DIO () -> Event DIO Bool
runTimeWarp TimeWarp DIO ()
processChannelMessages
              Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
                case Maybe ()
f of
                  Just ()
_  -> DIO ()
loop
                  Maybe ()
Nothing -> DIO ()
loop'
     DIO ()
loop

-- | Send the simulation monitoring message about the current state of the logical process.
sendState :: DP.ProcessId -> Event DIO ()
sendState :: ProcessId -> Event DIO ()
sendState ProcessId
pid =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     PriorityQueue (Point DIO -> DIO ())
pq <- Point DIO
-> Event DIO (PriorityQueue (Point DIO -> DIO ()))
-> DIO (PriorityQueue (Point DIO -> DIO ()))
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO (PriorityQueue (Point DIO -> DIO ()))
 -> DIO (PriorityQueue (Point DIO -> DIO ())))
-> Event DIO (PriorityQueue (Point DIO -> DIO ()))
-> DIO (PriorityQueue (Point DIO -> DIO ()))
forall a b. (a -> b) -> a -> b
$ Ref (PriorityQueue (Point DIO -> DIO ()))
-> Event DIO (PriorityQueue (Point DIO -> DIO ()))
forall a. Ref a -> Event DIO a
R.readRef (EventQueue DIO -> Ref (PriorityQueue (Point DIO -> DIO ()))
queuePQ EventQueue DIO
q)
     Int
n1 <- IO Int -> DIO Int
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Int -> DIO Int) -> IO Int -> DIO Int
forall a b. (a -> b) -> a -> b
$ UndoableLog -> IO Int
logSize (EventQueue DIO -> UndoableLog
queueLog EventQueue DIO
q)
     Int
n2 <- IO Int -> DIO Int
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Int -> DIO Int) -> IO Int -> DIO Int
forall a b. (a -> b) -> a -> b
$ InputMessageQueue -> IO Int
inputMessageQueueSize (EventQueue DIO -> InputMessageQueue
queueInputMessages EventQueue DIO
q)
     Int
n3 <- IO Int -> DIO Int
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Int -> DIO Int) -> IO Int -> DIO Int
forall a b. (a -> b) -> a -> b
$ OutputMessageQueue -> IO Int
outputMessageQueueSize (EventQueue DIO -> OutputMessageQueue
queueOutputMessages EventQueue DIO
q)
     Int
n4 <- IO Int -> DIO Int
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Int -> DIO Int) -> IO Int -> DIO Int
forall a b. (a -> b) -> a -> b
$ TransientMessageQueue -> IO Int
transientMessageQueueSize (EventQueue DIO -> TransientMessageQueue
queueTransientMessages EventQueue DIO
q)
     Int
n5 <- IO Int -> DIO Int
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Int -> DIO Int) -> IO Int -> DIO Int
forall a b. (a -> b) -> a -> b
$ InputMessageQueue -> IO Int
inputMessageQueueVersion (EventQueue DIO -> InputMessageQueue
queueInputMessages EventQueue DIO
q)
     let n6 :: Int
n6 = PriorityQueue (Point DIO -> DIO ()) -> Int
forall a. PriorityQueue a -> Int
PQ.queueCount PriorityQueue (Point DIO -> DIO ())
pq
         sc :: Specs DIO
sc = Point DIO -> Specs DIO
forall (m :: * -> *). Point m -> Specs m
pointSpecs Point DIO
p
         t0 :: Double
t0 = Specs DIO -> Double
forall (m :: * -> *). Specs m -> Double
spcStartTime Specs DIO
sc
         t2 :: Double
t2 = Specs DIO -> Double
forall (m :: * -> *). Specs m -> Double
spcStopTime Specs DIO
sc
     Double
tq <- IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ IORef Double -> IO Double
forall a. IORef a -> IO a
readIORef (EventQueue DIO -> IORef Double
queueTime EventQueue DIO
q)
     Double
t' <- Point DIO -> Event DIO Double -> DIO Double
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p Event DIO Double
getLocalTime
     DIOParams
ps <- DIO DIOParams
dioParams
     let name :: [Char]
name = DIOParams -> [Char]
dioName DIOParams
ps
     ProcessId
inbox <- DIO ProcessId
messageInboxId
     Process () -> DIO ()
forall a. Process a -> DIO a
liftDistributedUnsafe (Process () -> DIO ()) -> Process () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       ProcessId -> LogicalProcessState -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
DP.send ProcessId
pid (LogicalProcessState -> Process ())
-> LogicalProcessState -> Process ()
forall a b. (a -> b) -> a -> b
$
       LogicalProcessState { lpStateId :: ProcessId
lpStateId = ProcessId
inbox,
                             lpStateName :: [Char]
lpStateName = [Char]
name,
                             lpStateStartTime :: Double
lpStateStartTime = Double
t0,
                             lpStateStopTime :: Double
lpStateStopTime = Double
t2,
                             lpStateLocalTime :: Double
lpStateLocalTime = Double
t',
                             lpStateEventQueueTime :: Double
lpStateEventQueueTime = Double
tq,
                             lpStateEventQueueSize :: Int
lpStateEventQueueSize = Int
n6,
                             lpStateLogSize :: Int
lpStateLogSize = Int
n1,
                             lpStateInputMessageCount :: Int
lpStateInputMessageCount = Int
n2,
                             lpStateOutputMessageCount :: Int
lpStateOutputMessageCount = Int
n3,
                             lpStateTransientMessageCount :: Int
lpStateTransientMessageCount = Int
n4,
                             lpStateRollbackCount :: Int
lpStateRollbackCount = Int
n5 }

-- | Try to leave the simulation.
--
-- It enqueues a new event with obligatory synchronization with the global virtual time.
-- If that event will not be reverted during rollback, then the logical process will
-- leave the simulation immediately after approaching the final modeling time without
-- synchronization with the global virtual time anymore if it has no unacknowledged
-- sent messages.
--
-- It makes sense to use this action if logical processes can enter and leave your long-running
-- distributed simulation by demand.
--
leaveSimulation :: Event DIO ()
leaveSimulation :: Event DIO ()
leaveSimulation =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
         t :: Double
t = Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p
     Point DIO -> Event DIO () -> DIO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point DIO
p (Event DIO () -> DIO ()) -> Event DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       Double -> Event DIO () -> Event DIO ()
forall (m :: * -> *).
EventIOQueueing m =>
Double -> Event m () -> Event m ()
enqueueEventIO Double
t (Event DIO () -> Event DIO ()) -> Event DIO () -> Event DIO ()
forall a b. (a -> b) -> a -> b
$
       (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
       IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (EventQueue DIO -> IORef Bool
queueIsLeaving EventQueue DIO
q) Bool
True

-- | Disconnect to the remote process.
disconnectProcess :: DP.ProcessId -> Event DIO ()
disconnectProcess :: ProcessId -> Event DIO ()
disconnectProcess ProcessId
pid =
  (Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
  do let q :: EventQueue DIO
q = Run DIO -> EventQueue DIO
forall (m :: * -> *). Run m -> EventQueue m
runEventQueue (Run DIO -> EventQueue DIO) -> Run DIO -> EventQueue DIO
forall a b. (a -> b) -> a -> b
$ Point DIO -> Run DIO
forall (m :: * -> *). Point m -> Run m
pointRun Point DIO
p
     ---
     Priority -> [Char] -> DIO ()
logDIO Priority
NOTICE ([Char] -> DIO ()) -> [Char] -> DIO ()
forall a b. (a -> b) -> a -> b
$
       [Char]
"t = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show (Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
       [Char]
": disconnecting from " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ProcessId -> [Char]
forall a. Show a => a -> [Char]
show ProcessId
pid [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"..."
     ---
     DIOParams
ps <- DIO DIOParams
dioParams
     Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DIOParams -> Bool
dioProcessReconnectingEnabled DIOParams
ps) (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       [Char] -> DIO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"The logical process cannot be in the reconnecting state: disconnectProcess"
     IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
       TransientMessageQueue -> ProcessId -> IO ()
dequeueTransientMessages (EventQueue DIO -> TransientMessageQueue
queueTransientMessages EventQueue DIO
q) ProcessId
pid