{-# LANGUAGE TypeFamilies, FlexibleInstances #-}
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
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
instance EventQueueing DIO where
data EventQueue DIO =
EventQueue { EventQueue DIO -> InputMessageQueue
queueInputMessages :: InputMessageQueue,
EventQueue DIO -> OutputMessageQueue
queueOutputMessages :: OutputMessageQueue,
EventQueue DIO -> TransientMessageQueue
queueTransientMessages :: TransientMessageQueue,
EventQueue DIO -> AcknowledgementMessageQueue
queueAcknowledgementMessages :: AcknowledgementMessageQueue,
EventQueue DIO -> UndoableLog
queueLog :: UndoableLog,
EventQueue DIO -> Ref (PriorityQueue (Point DIO -> DIO ()))
queuePQ :: R.Ref (PQ.PriorityQueue (Point DIO -> DIO ())),
EventQueue DIO -> IORef Bool
queueBusy :: IORef Bool,
EventQueue DIO -> IORef Double
queueTime :: IORef Double,
EventQueue DIO -> IORef Double
queueGlobalTime :: IORef Double,
EventQueue DIO -> IORef Bool
queueInFind :: IORef Bool,
EventQueue DIO -> SignalSource DIO ProcessMonitorNotification
queueProcessMonitorNotificationSource :: SignalSource DIO DP.ProcessMonitorNotification,
EventQueue DIO -> IORef Bool
queueIsLeaving :: IORef Bool
}
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
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
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
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
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
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
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)
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 }
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
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
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
$
[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 }
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
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
processEventsIncludingCurrent :: Dynamics DIO ()
processEventsIncludingCurrent :: Dynamics DIO ()
processEventsIncludingCurrent = Bool -> Dynamics DIO ()
processPendingEvents Bool
True
processEventsIncludingEarlier :: Dynamics DIO ()
processEventsIncludingEarlier :: Dynamics DIO ()
processEventsIncludingEarlier = Bool -> Dynamics DIO ()
processPendingEvents Bool
False
processEventsIncludingCurrentCore :: Dynamics DIO ()
processEventsIncludingCurrentCore :: Dynamics DIO ()
processEventsIncludingCurrentCore = Bool -> Dynamics DIO ()
processPendingEventsCore Bool
True
processEventsIncludingEarlierCore :: Dynamics DIO ()
processEventsIncludingEarlierCore :: Dynamics DIO ()
processEventsIncludingEarlierCore = Bool -> Dynamics DIO ()
processPendingEventsCore Bool
True
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
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
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
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
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
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 ()
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
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
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
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
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
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
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
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
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
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
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
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
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
Double -> DIO Double
forall a. a -> DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return Double
t'
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)
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
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
ProcessId
sender <- DIO ProcessId
messageInboxId
ProcessId
receiver <- DIO ProcessId
timeServerId
ProcessId -> ProcessId -> DIO ()
sendRequestGlobalTimeDIO ProcessId
receiver ProcessId
sender
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]
" }"
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
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..."
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..."
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..."
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"
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"
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
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"
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
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
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
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
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"
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
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)
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
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
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
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
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
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'
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
}
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
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
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
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
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 }
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
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