-- |
-- Module     : Simulation.Aivika.Trans.GPSS.Transact
-- Copyright  : Copyright (c) 2017, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 8.0.2
--
-- This module defines a GPSS transact.
--
module Simulation.Aivika.Trans.GPSS.Transact
       (Transact,
        transactValue,
        transactArrivalDelay,
        transactArrivalTime,
        transactPriority,
        transactAssemblySet,
        newTransact,
        splitTransact,
        assignTransactValue,
        assignTransactValueM,
        assignTransactPriority,
        takeTransact,
        releaseTransact,
        transactPreemptionBegin,
        transactPreemptionEnd,
        requireTransactProcessId,
        transferTransact,
        reactivateTransacts,
        registerTransactQueueEntry,
        unregisterTransactQueueEntry) where

import Control.Monad
import Control.Monad.Trans
import Control.Exception

import Data.Functor

import qualified Data.HashMap.Lazy as HM

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

import {-# SOURCE #-} Simulation.Aivika.Trans.GPSS.Queue
import {-# SOURCE #-} Simulation.Aivika.Trans.GPSS.AssemblySet

-- | Represents a GPSS transact.
data Transact m a =
  Transact { forall (m :: * -> *) a. Transact m a -> a
transactValue :: a,
             -- ^ The data of the transact.
             forall (m :: * -> *) a. Transact m a -> Maybe Double
transactArrivalDelay :: Maybe Double,
             -- ^ The delay between the transacts generated.
             forall (m :: * -> *) a. Transact m a -> Double
transactArrivalTime :: Double,
             -- ^ The time at which the transact was generated.
             forall (m :: * -> *) a. Transact m a -> Int
transactPriority :: Int,
             -- ^ The transact priority.
             forall (m :: * -> *) a.
Transact m a -> Ref m (Maybe (AssemblySet m))
transactAssemblySetRef :: Ref m (Maybe (AssemblySet m)),
             -- ^ The assembly set.
             forall (m :: * -> *) a. Transact m a -> Ref m Int
transactPreemptionCountRef :: Ref m Int,
             -- ^ How many times the transact is preempted.
             forall (m :: * -> *) a. Transact m a -> Ref m (Maybe (ProcessId m))
transactProcessIdRef :: Ref m (Maybe (ProcessId m)),
             -- ^ An identifier of the process that handles the transact at present
             forall (m :: * -> *) a.
Transact m a -> Ref m (Maybe (FrozenCont m ()))
transactProcessContRef :: Ref m (Maybe (FrozenCont m ())),
             -- ^ A continuation of the process that tried to handle the transact.
             forall (m :: * -> *) a.
Transact m a -> Ref m (HashMap (Queue m) (QueueEntry m))
transactQueueEntryRef :: Ref m (HM.HashMap (Queue m) (QueueEntry m))
             -- ^ The queue entries registered by the the transact.
           }

instance MonadDES m => Eq (Transact m a) where

  {-# INLINABLE (==) #-}
  Transact m a
x == :: Transact m a -> Transact m a -> Bool
== Transact m a
y = (forall (m :: * -> *) a. Transact m a -> Ref m (Maybe (ProcessId m))
transactProcessIdRef Transact m a
x) forall a. Eq a => a -> a -> Bool
== (forall (m :: * -> *) a. Transact m a -> Ref m (Maybe (ProcessId m))
transactProcessIdRef Transact m a
y)

instance MonadDES m => Functor (Transact m) where

  {-# INLINABLE fmap #-}
  fmap :: forall a b. (a -> b) -> Transact m a -> Transact m b
fmap a -> b
f Transact m a
t = Transact m a
t { transactValue :: b
transactValue = a -> b
f (forall (m :: * -> *) a. Transact m a -> a
transactValue Transact m a
t) }

-- | Create a new transact.
newTransact :: MonadDES m
               => Arrival a
               -- ^ the arrival data
               -> Int
               -- ^ the transact priority
               -> Simulation m (Transact m a)
{-# INLINABLE newTransact #-}
newTransact :: forall (m :: * -> *) a.
MonadDES m =>
Arrival a -> Int -> Simulation m (Transact m a)
newTransact Arrival a
a Int
priority =
  forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall a b. (a -> b) -> a -> b
$ \Run m
r ->
  do Ref m Int
r0 <- forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => a -> Simulation m (Ref m a)
newRef Int
0
     Ref m (Maybe (ProcessId m))
r1 <- forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => a -> Simulation m (Ref m a)
newRef forall a. Maybe a
Nothing
     Ref m (Maybe (FrozenCont m ()))
r2 <- forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => a -> Simulation m (Ref m a)
newRef forall a. Maybe a
Nothing
     Ref m (HashMap (Queue m) (QueueEntry m))
r3 <- forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => a -> Simulation m (Ref m a)
newRef forall k v. HashMap k v
HM.empty
     Ref m (Maybe (AssemblySet m))
r4 <- forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => a -> Simulation m (Ref m a)
newRef forall a. Maybe a
Nothing
     forall (m :: * -> *) a. Monad m => a -> m a
return Transact { transactValue :: a
transactValue = forall a. Arrival a -> a
arrivalValue Arrival a
a,
                       transactArrivalDelay :: Maybe Double
transactArrivalDelay = forall a. Arrival a -> Maybe Double
arrivalDelay Arrival a
a,
                       transactArrivalTime :: Double
transactArrivalTime = forall a. Arrival a -> Double
arrivalTime Arrival a
a,
                       transactPriority :: Int
transactPriority = Int
priority,
                       transactAssemblySetRef :: Ref m (Maybe (AssemblySet m))
transactAssemblySetRef = Ref m (Maybe (AssemblySet m))
r4,
                       transactPreemptionCountRef :: Ref m Int
transactPreemptionCountRef = Ref m Int
r0,
                       transactProcessIdRef :: Ref m (Maybe (ProcessId m))
transactProcessIdRef = Ref m (Maybe (ProcessId m))
r1,
                       transactProcessContRef :: Ref m (Maybe (FrozenCont m ()))
transactProcessContRef = Ref m (Maybe (FrozenCont m ()))
r2,
                       transactQueueEntryRef :: Ref m (HashMap (Queue m) (QueueEntry m))
transactQueueEntryRef = Ref m (HashMap (Queue m) (QueueEntry m))
r3
                     }

-- | Split the transact.
splitTransact :: MonadDES m => Transact m a -> Simulation m (Transact m a)
{-# INLINABLE splitTransact #-}
splitTransact :: forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Simulation m (Transact m a)
splitTransact Transact m a
t =
  forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall a b. (a -> b) -> a -> b
$ \Run m
r ->
  do Ref m Int
r0 <- forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => a -> Simulation m (Ref m a)
newRef Int
0
     Ref m (Maybe (ProcessId m))
r1 <- forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => a -> Simulation m (Ref m a)
newRef forall a. Maybe a
Nothing
     Ref m (Maybe (FrozenCont m ()))
r2 <- forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => a -> Simulation m (Ref m a)
newRef forall a. Maybe a
Nothing
     Ref m (HashMap (Queue m) (QueueEntry m))
r3 <- forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => a -> Simulation m (Ref m a)
newRef forall k v. HashMap k v
HM.empty
     forall (m :: * -> *) a. Monad m => a -> m a
return Transact { transactValue :: a
transactValue = forall (m :: * -> *) a. Transact m a -> a
transactValue Transact m a
t,
                       transactArrivalDelay :: Maybe Double
transactArrivalDelay = forall (m :: * -> *) a. Transact m a -> Maybe Double
transactArrivalDelay Transact m a
t,
                       transactArrivalTime :: Double
transactArrivalTime = forall (m :: * -> *) a. Transact m a -> Double
transactArrivalTime Transact m a
t,
                       transactPriority :: Int
transactPriority = forall (m :: * -> *) a. Transact m a -> Int
transactPriority Transact m a
t,
                       transactAssemblySetRef :: Ref m (Maybe (AssemblySet m))
transactAssemblySetRef = forall (m :: * -> *) a.
Transact m a -> Ref m (Maybe (AssemblySet m))
transactAssemblySetRef Transact m a
t,
                       transactPreemptionCountRef :: Ref m Int
transactPreemptionCountRef = Ref m Int
r0,
                       transactProcessIdRef :: Ref m (Maybe (ProcessId m))
transactProcessIdRef = Ref m (Maybe (ProcessId m))
r1,
                       transactProcessContRef :: Ref m (Maybe (FrozenCont m ()))
transactProcessContRef = Ref m (Maybe (FrozenCont m ()))
r2,
                       transactQueueEntryRef :: Ref m (HashMap (Queue m) (QueueEntry m))
transactQueueEntryRef = Ref m (HashMap (Queue m) (QueueEntry m))
r3
                     }

-- | Return the transact assembly set.
transactAssemblySet :: MonadDES m => Transact m a -> Event m (AssemblySet m)
{-# INLINABLE transactAssemblySet #-}
transactAssemblySet :: forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Event m (AssemblySet m)
transactAssemblySet Transact m a
t =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  do let r :: Run m
r = forall (m :: * -> *). Point m -> Run m
pointRun Point m
p
     Maybe (AssemblySet m)
x <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) a.
Transact m a -> Ref m (Maybe (AssemblySet m))
transactAssemblySetRef Transact m a
t)
     case Maybe (AssemblySet m)
x of
       Just AssemblySet m
a  -> forall (m :: * -> *) a. Monad m => a -> m a
return AssemblySet m
a
       Maybe (AssemblySet m)
Nothing ->
         do AssemblySet m
a <- forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r forall (m :: * -> *). MonadDES m => Simulation m (AssemblySet m)
newAssemblySet
            forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *) a.
Transact m a -> Ref m (Maybe (AssemblySet m))
transactAssemblySetRef Transact m a
t) (forall a. a -> Maybe a
Just AssemblySet m
a)
            forall (m :: * -> *) a. Monad m => a -> m a
return AssemblySet m
a

-- | Take the transact.
takeTransact :: MonadDES m => Transact m a -> Process m ()
{-# INLINABLE takeTransact #-}
takeTransact :: forall (m :: * -> *) a. MonadDES m => Transact m a -> Process m ()
takeTransact Transact m a
t =
  forall (m :: * -> *) a. (ProcessId m -> Cont m a) -> Process m a
Process forall a b. (a -> b) -> a -> b
$ \ProcessId m
pid ->
  forall (m :: * -> *) a. (ContParams m a -> Event m ()) -> Cont m a
Cont forall a b. (a -> b) -> a -> b
$ \ContParams m ()
c0 ->
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  do Maybe (ProcessId m)
pid0 <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) a. Transact m a -> Ref m (Maybe (ProcessId m))
transactProcessIdRef Transact m a
t)
     case Maybe (ProcessId m)
pid0 of
       Just ProcessId m
pid0 ->
         forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> m a
throwComp forall a b. (a -> b) -> a -> b
$
         String -> SimulationRetry
SimulationRetry
         String
"The transact is acquired by another process: takeTransact"
       Maybe (ProcessId m)
Nothing   ->
         do let priority :: Int
priority = forall (m :: * -> *) a. Transact m a -> Int
transactPriority Transact m a
t
            forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *) a. Transact m a -> Ref m (Maybe (ProcessId m))
transactProcessIdRef Transact m a
t) (forall a. a -> Maybe a
Just ProcessId m
pid)
            Int
n <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) a. Transact m a -> Ref m Int
transactPreemptionCountRef Transact m a
t)
            if Int
n forall a. Eq a => a -> a -> Bool
== Int
0
              then if Int
priority forall a. Eq a => a -> a -> Bool
== forall (m :: * -> *). Point m -> Int
pointPriority Point m
p
                   then forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$
                        forall (m :: * -> *) a.
MonadDES m =>
ContParams m a -> a -> Event m ()
resumeCont ContParams m ()
c0 ()
                   else forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$
                        forall (m :: * -> *) a.
MonadDES m =>
ContParams m a -> a -> Event m ()
resumeCont (forall (m :: * -> *) a.
MonadDES m =>
ContParams m a -> Int -> ContParams m a
substituteContPriority ContParams m ()
c0 Int
priority) ()
              else do let c :: ContParams m ()
c = forall (m :: * -> *) a.
MonadDES m =>
ContParams m a -> Int -> ContParams m a
substituteContPriority ContParams m ()
c0 Int
priority
                      FrozenCont m ()
c <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$
                           forall (m :: * -> *) a.
MonadDES m =>
ContParams m a -> a -> Event m () -> Event m (FrozenCont m a)
freezeContReentering ContParams m ()
c () forall a b. (a -> b) -> a -> b
$
                           forall (m :: * -> *) a. ContParams m a -> Cont m a -> Event m ()
invokeCont ContParams m ()
c forall a b. (a -> b) -> a -> b
$
                           forall (m :: * -> *) a. ProcessId m -> Process m a -> Cont m a
invokeProcess ProcessId m
pid forall a b. (a -> b) -> a -> b
$
                           forall (m :: * -> *) a. MonadDES m => Transact m a -> Process m ()
takeTransact Transact m a
t
                      forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$
                        forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *) a.
Transact m a -> Ref m (Maybe (FrozenCont m ()))
transactProcessContRef Transact m a
t) (forall a. a -> Maybe a
Just FrozenCont m ()
c)
                      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
n] forall a b. (a -> b) -> a -> b
$ \Int
_ ->
                        forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$
                        forall (m :: * -> *). MonadDES m => ProcessId m -> Event m ()
processPreemptionBegin ProcessId m
pid

-- | Release the transact.
releaseTransact :: MonadDES m => Transact m a -> Process m ()
{-# INLINABLE releaseTransact #-}
releaseTransact :: forall (m :: * -> *) a. MonadDES m => Transact m a -> Process m ()
releaseTransact Transact m a
t =
  forall (m :: * -> *) a. (ProcessId m -> Cont m a) -> Process m a
Process forall a b. (a -> b) -> a -> b
$ \ProcessId m
pid ->
  forall (m :: * -> *) a. (ContParams m a -> Event m ()) -> Cont m a
Cont forall a b. (a -> b) -> a -> b
$ \ContParams m ()
c ->
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  do Maybe (ProcessId m)
pid0 <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) a. Transact m a -> Ref m (Maybe (ProcessId m))
transactProcessIdRef Transact m a
t)
     case Maybe (ProcessId m)
pid0 of
       Maybe (ProcessId m)
Nothing ->
         forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> m a
throwComp forall a b. (a -> b) -> a -> b
$
         String -> SimulationRetry
SimulationRetry
         String
"The transact is not acquired by any process: releaseTransact"
       Just ProcessId m
pid0 | ProcessId m
pid0 forall a. Eq a => a -> a -> Bool
/= ProcessId m
pid ->
         forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> m a
throwComp forall a b. (a -> b) -> a -> b
$
         String -> SimulationRetry
SimulationRetry
         String
"The transact is acquired by another process: releaseTransact"
       Just ProcessId m
pid0 ->
         do forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *) a. Transact m a -> Ref m (Maybe (ProcessId m))
transactProcessIdRef Transact m a
t) forall a. Maybe a
Nothing
            forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *) a.
Transact m a -> Ref m (Maybe (FrozenCont m ()))
transactProcessContRef Transact m a
t) forall a. Maybe a
Nothing
            forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadDES m =>
ContParams m a -> a -> Event m ()
resumeCont ContParams m ()
c ()

-- | Preempt the computation that handles the transact.
transactPreemptionBegin :: MonadDES m => Transact m a -> Event m ()
{-# INLINABLE transactPreemptionBegin #-}
transactPreemptionBegin :: forall (m :: * -> *) a. MonadDES m => Transact m a -> Event m ()
transactPreemptionBegin Transact m a
t =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  do Int
n <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) a. Transact m a -> Ref m Int
transactPreemptionCountRef Transact m a
t)
     let n' :: Int
n' = Int
n forall a. Num a => a -> a -> a
+ Int
1
     Int
n' seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *) a. Transact m a -> Ref m Int
transactPreemptionCountRef Transact m a
t) Int
n'
     Maybe (ProcessId m)
pid <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) a. Transact m a -> Ref m (Maybe (ProcessId m))
transactProcessIdRef Transact m a
t)
     case Maybe (ProcessId m)
pid of
       Maybe (ProcessId m)
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Just ProcessId m
pid -> forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadDES m => ProcessId m -> Event m ()
processPreemptionBegin ProcessId m
pid

-- | Proceed with the computation after the transact was preempted earlier.
transactPreemptionEnd :: MonadDES m => Transact m a -> Event m ()
{-# INLINABLE transactPreemptionEnd #-}
transactPreemptionEnd :: forall (m :: * -> *) a. MonadDES m => Transact m a -> Event m ()
transactPreemptionEnd Transact m a
t =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  do Int
n <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) a. Transact m a -> Ref m Int
transactPreemptionCountRef Transact m a
t)
     let n' :: Int
n' = Int
n forall a. Num a => a -> a -> a
- Int
1
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n' forall a. Ord a => a -> a -> Bool
>= Int
0) forall a b. (a -> b) -> a -> b
$
       forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> m a
throwComp forall a b. (a -> b) -> a -> b
$
       String -> SimulationRetry
SimulationRetry
       String
"The transact preemption count cannot be negative: transactPreemptionEnd"
     Int
n' seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *) a. Transact m a -> Ref m Int
transactPreemptionCountRef Transact m a
t) Int
n'
     Maybe (ProcessId m)
pid <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) a. Transact m a -> Ref m (Maybe (ProcessId m))
transactProcessIdRef Transact m a
t)
     case Maybe (ProcessId m)
pid of
       Maybe (ProcessId m)
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Just ProcessId m
pid ->
         do forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadDES m => ProcessId m -> Event m ()
processPreemptionEnd ProcessId m
pid
            Maybe (FrozenCont m ())
c <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) a.
Transact m a -> Ref m (Maybe (FrozenCont m ()))
transactProcessContRef Transact m a
t)
            case Maybe (FrozenCont m ())
c of
              Maybe (FrozenCont m ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
              Just FrozenCont m ()
c  ->
                do forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *) a.
Transact m a -> Ref m (Maybe (FrozenCont m ()))
transactProcessContRef Transact m a
t) forall a. Maybe a
Nothing
                   Maybe (ContParams m ())
c <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
FrozenCont m a -> Event m (Maybe (ContParams m a))
unfreezeCont FrozenCont m ()
c
                   case Maybe (ContParams m ())
c of
                     Maybe (ContParams m ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                     Just ContParams m ()
c  -> forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
EventQueueing m =>
Double -> Event m () -> Event m ()
enqueueEvent (forall (m :: * -> *). Point m -> Double
pointTime Point m
p) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadDES m =>
ContParams m a -> a -> Event m ()
resumeCont ContParams m ()
c ()

-- | Require to return an identifier of the process associated with the transact.
requireTransactProcessId :: MonadDES m => Transact m a -> Event m (ProcessId m)
{-# INLINABLE requireTransactProcessId #-}
requireTransactProcessId :: forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Event m (ProcessId m)
requireTransactProcessId Transact m a
t =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  do Maybe (ProcessId m)
a <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) a. Transact m a -> Ref m (Maybe (ProcessId m))
transactProcessIdRef Transact m a
t)
     case Maybe (ProcessId m)
a of
       Maybe (ProcessId m)
Nothing ->
         forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> m a
throwComp forall a b. (a -> b) -> a -> b
$
         String -> SimulationRetry
SimulationRetry
         String
"The transact must be associated with any process: requireTransactProcessId"
       Just ProcessId m
pid ->
         forall (m :: * -> *) a. Monad m => a -> m a
return ProcessId m
pid

-- | Like the GoTo statement, it associates the transact with another process.
transferTransact :: MonadDES m => Transact m a -> Process m () -> Event m ()
{-# INLINABLE transferTransact #-}
transferTransact :: forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Process m () -> Event m ()
transferTransact Transact m a
t Process m ()
transfer =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  do Maybe (ProcessId m)
a <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) a. Transact m a -> Ref m (Maybe (ProcessId m))
transactProcessIdRef Transact m a
t)
     case Maybe (ProcessId m)
a of
       Maybe (ProcessId m)
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Just ProcessId m
pid ->
         forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadDES m => ProcessId m -> Event m ()
cancelProcessWithId ProcessId m
pid
     forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *) a. Transact m a -> Ref m (Maybe (ProcessId m))
transactProcessIdRef Transact m a
t) forall a. Maybe a
Nothing
     forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *) a.
Transact m a -> Ref m (Maybe (FrozenCont m ()))
transactProcessContRef Transact m a
t) forall a. Maybe a
Nothing
     forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$
       forall (m :: * -> *). MonadDES m => Process m () -> Event m ()
runProcess forall a b. (a -> b) -> a -> b
$
       do forall (m :: * -> *) a. MonadDES m => Transact m a -> Process m ()
takeTransact Transact m a
t
          forall (m :: * -> *) a. MonadDES m => Process m () -> Process m a
transferProcess Process m ()
transfer

-- | Register the queue entry in the transact.
registerTransactQueueEntry :: MonadDES m => Transact m a -> QueueEntry m -> Event m ()
{-# INLINABLE registerTransactQueueEntry #-}
registerTransactQueueEntry :: forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> QueueEntry m -> Event m ()
registerTransactQueueEntry Transact m a
t QueueEntry m
e =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  do let q :: Queue m
q = forall (m :: * -> *). QueueEntry m -> Queue m
entryQueue QueueEntry m
e
     HashMap (Queue m) (QueueEntry m)
m <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) a.
Transact m a -> Ref m (HashMap (Queue m) (QueueEntry m))
transactQueueEntryRef Transact m a
t)
     case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Queue m
q HashMap (Queue m) (QueueEntry m)
m of
       Just QueueEntry m
e0 ->
         forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> m a
throwComp forall a b. (a -> b) -> a -> b
$
         String -> SimulationRetry
SimulationRetry
         String
"There is already another queue entry for the specified queue: registerTransactQueueEntry"
       Maybe (QueueEntry m)
Nothing ->
         forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *) a.
Transact m a -> Ref m (HashMap (Queue m) (QueueEntry m))
transactQueueEntryRef Transact m a
t) (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Queue m
q QueueEntry m
e HashMap (Queue m) (QueueEntry m)
m)

-- | Unregister the queue entry from the transact.
unregisterTransactQueueEntry :: MonadDES m => Transact m a -> Queue m -> Event m (QueueEntry m)
{-# INLINABLE unregisterTransactQueueEntry #-}
unregisterTransactQueueEntry :: forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Queue m -> Event m (QueueEntry m)
unregisterTransactQueueEntry Transact m a
t Queue m
q =
  forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  do HashMap (Queue m) (QueueEntry m)
m <- forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> Event m a
readRef (forall (m :: * -> *) a.
Transact m a -> Ref m (HashMap (Queue m) (QueueEntry m))
transactQueueEntryRef Transact m a
t)
     case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Queue m
q HashMap (Queue m) (QueueEntry m)
m of
       Maybe (QueueEntry m)
Nothing ->
         forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> m a
throwComp forall a b. (a -> b) -> a -> b
$
         String -> SimulationRetry
SimulationRetry
         String
"There is no queue entry for the specified queue: unregisterTransactQueueEntry"
       Just QueueEntry m
e  ->
         do forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point m
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Ref m a -> a -> Event m ()
writeRef (forall (m :: * -> *) a.
Transact m a -> Ref m (HashMap (Queue m) (QueueEntry m))
transactQueueEntryRef Transact m a
t) (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete Queue m
q HashMap (Queue m) (QueueEntry m)
m)
            forall (m :: * -> *) a. Monad m => a -> m a
return QueueEntry m
e

-- | Assign the transact value and return a new version of the same transact.
assignTransactValue :: Transact m a -> (a -> b) -> Transact m b
assignTransactValue :: forall (m :: * -> *) a b. Transact m a -> (a -> b) -> Transact m b
assignTransactValue Transact m a
t a -> b
f =
  let b :: b
b = a -> b
f (forall (m :: * -> *) a. Transact m a -> a
transactValue Transact m a
t)
  in Transact m a
t { transactValue :: b
transactValue = b
b }

-- | Assign the transact value and return a new version of the same transact.
assignTransactValueM :: Monad c => Transact m a -> (a -> c b) -> c (Transact m b)
{-# INLINABLE assignTransactValue #-}
assignTransactValueM :: forall (c :: * -> *) (m :: * -> *) a b.
Monad c =>
Transact m a -> (a -> c b) -> c (Transact m b)
assignTransactValueM Transact m a
t a -> c b
f =
  do b
b <- a -> c b
f (forall (m :: * -> *) a. Transact m a -> a
transactValue Transact m a
t)
     forall (m :: * -> *) a. Monad m => a -> m a
return Transact m a
t { transactValue :: b
transactValue = b
b }

-- | Assign the priority and return a new version of the same transact.
assignTransactPriority :: MonadDES m => Transact m a -> Int -> Process m (Transact m a)
{-# INLINABLE assignTransactPriority #-}
assignTransactPriority :: forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Int -> Process m (Transact m a)
assignTransactPriority Transact m a
t Int
priority =
  do forall (m :: * -> *). MonadDES m => Int -> Process m ()
processWithPriority Int
priority
     forall (m :: * -> *) a. Monad m => a -> m a
return Transact m a
t { transactPriority :: Int
transactPriority = Int
priority }

-- | Reactivate the transacts or transfer them to the specified computations.
reactivateTransacts :: MonadDES m => [(Transact m a, Maybe (Process m ()))] -> Event m ()
{-# INLINABLE reactivateTransacts #-}
reactivateTransacts :: forall (m :: * -> *) a.
MonadDES m =>
[(Transact m a, Maybe (Process m ()))] -> Event m ()
reactivateTransacts [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
reactivateTransacts ((Transact m a
t, Maybe (Process m ())
Nothing): [(Transact m a, Maybe (Process m ()))]
xs) =
  do ProcessId m
pid <- forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Event m (ProcessId m)
requireTransactProcessId Transact m a
t
     forall (m :: * -> *). MonadDES m => ProcessId m -> Event m ()
reactivateProcess ProcessId m
pid
     forall (m :: * -> *) a.
MonadDES m =>
[(Transact m a, Maybe (Process m ()))] -> Event m ()
reactivateTransacts [(Transact m a, Maybe (Process m ()))]
xs
reactivateTransacts ((Transact m a
t, Just Process m ()
transfer): [(Transact m a, Maybe (Process m ()))]
xs) =
  do forall (m :: * -> *) a.
MonadDES m =>
Transact m a -> Process m () -> Event m ()
transferTransact Transact m a
t Process m ()
transfer
     forall (m :: * -> *) a.
MonadDES m =>
[(Transact m a, Maybe (Process m ()))] -> Event m ()
reactivateTransacts [(Transact m a, Maybe (Process m ()))]
xs