-- |
-- Module     : Simulation.Aivika.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.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.IORef
import qualified Data.HashMap.Lazy as HM

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

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

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

instance Eq (Transact a) where
  Transact a
x == :: Transact a -> Transact a -> Bool
== Transact a
y = (Transact a -> IORef (Maybe ProcessId)
forall a. Transact a -> IORef (Maybe ProcessId)
transactProcessIdRef Transact a
x) IORef (Maybe ProcessId) -> IORef (Maybe ProcessId) -> Bool
forall a. Eq a => a -> a -> Bool
== (Transact a -> IORef (Maybe ProcessId)
forall a. Transact a -> IORef (Maybe ProcessId)
transactProcessIdRef Transact a
y)

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

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

-- | Return the transact assembly set.
transactAssemblySet :: Transact a -> Event AssemblySet
transactAssemblySet :: Transact a -> Event AssemblySet
transactAssemblySet Transact a
t =
  (Point -> IO AssemblySet) -> Event AssemblySet
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO AssemblySet) -> Event AssemblySet)
-> (Point -> IO AssemblySet) -> Event AssemblySet
forall a b. (a -> b) -> a -> b
$ \Point
p ->
  do let r :: Run
r = Point -> Run
pointRun Point
p
     Maybe AssemblySet
x <- IORef (Maybe AssemblySet) -> IO (Maybe AssemblySet)
forall a. IORef a -> IO a
readIORef (Transact a -> IORef (Maybe AssemblySet)
forall a. Transact a -> IORef (Maybe AssemblySet)
transactAssemblySetRef Transact a
t)
     case Maybe AssemblySet
x of
       Just AssemblySet
a  -> AssemblySet -> IO AssemblySet
forall (m :: * -> *) a. Monad m => a -> m a
return AssemblySet
a
       Maybe AssemblySet
Nothing ->
         do AssemblySet
a <- Run -> Simulation AssemblySet -> IO AssemblySet
forall a. Run -> Simulation a -> IO a
invokeSimulation Run
r Simulation AssemblySet
newAssemblySet
            IORef (Maybe AssemblySet) -> Maybe AssemblySet -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Transact a -> IORef (Maybe AssemblySet)
forall a. Transact a -> IORef (Maybe AssemblySet)
transactAssemblySetRef Transact a
t) (AssemblySet -> Maybe AssemblySet
forall a. a -> Maybe a
Just AssemblySet
a)
            AssemblySet -> IO AssemblySet
forall (m :: * -> *) a. Monad m => a -> m a
return AssemblySet
a

-- | Take the transact.
takeTransact :: Transact a -> Process ()
takeTransact :: Transact a -> Process ()
takeTransact Transact a
t =
  (ProcessId -> Cont ()) -> Process ()
forall a. (ProcessId -> Cont a) -> Process a
Process ((ProcessId -> Cont ()) -> Process ())
-> (ProcessId -> Cont ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ \ProcessId
pid ->
  (ContParams () -> Event ()) -> Cont ()
forall a. (ContParams a -> Event ()) -> Cont a
Cont ((ContParams () -> Event ()) -> Cont ())
-> (ContParams () -> Event ()) -> Cont ()
forall a b. (a -> b) -> a -> b
$ \ContParams ()
c ->
  (Point -> IO ()) -> Event ()
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO ()) -> Event ()) -> (Point -> IO ()) -> Event ()
forall a b. (a -> b) -> a -> b
$ \Point
p ->
  do Maybe ProcessId
pid0 <- IORef (Maybe ProcessId) -> IO (Maybe ProcessId)
forall a. IORef a -> IO a
readIORef (Transact a -> IORef (Maybe ProcessId)
forall a. Transact a -> IORef (Maybe ProcessId)
transactProcessIdRef Transact a
t)
     case Maybe ProcessId
pid0 of
       Just ProcessId
pid0 ->
         SimulationRetry -> IO ()
forall e a. Exception e => e -> IO a
throwIO (SimulationRetry -> IO ()) -> SimulationRetry -> IO ()
forall a b. (a -> b) -> a -> b
$
         String -> SimulationRetry
SimulationRetry
         String
"The transact is acquired by another process: takeTransact"
       Maybe ProcessId
Nothing   ->
         do IORef (Maybe ProcessId) -> Maybe ProcessId -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Transact a -> IORef (Maybe ProcessId)
forall a. Transact a -> IORef (Maybe ProcessId)
transactProcessIdRef Transact a
t) (ProcessId -> Maybe ProcessId
forall a. a -> Maybe a
Just ProcessId
pid)
            Int
n <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (Transact a -> IORef Int
forall a. Transact a -> IORef Int
transactPreemptionCountRef Transact a
t)
            if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
              then Point -> Event () -> IO ()
forall a. Point -> Event a -> IO a
invokeEvent Point
p (Event () -> IO ()) -> Event () -> IO ()
forall a b. (a -> b) -> a -> b
$ ContParams () -> () -> Event ()
forall a. ContParams a -> a -> Event ()
resumeCont ContParams ()
c ()
              else do FrozenCont ()
c <- Point -> Event (FrozenCont ()) -> IO (FrozenCont ())
forall a. Point -> Event a -> IO a
invokeEvent Point
p (Event (FrozenCont ()) -> IO (FrozenCont ()))
-> Event (FrozenCont ()) -> IO (FrozenCont ())
forall a b. (a -> b) -> a -> b
$
                           ContParams () -> () -> Event () -> Event (FrozenCont ())
forall a. ContParams a -> a -> Event () -> Event (FrozenCont a)
freezeContReentering ContParams ()
c () (Event () -> Event (FrozenCont ()))
-> Event () -> Event (FrozenCont ())
forall a b. (a -> b) -> a -> b
$
                           ContParams () -> Cont () -> Event ()
forall a. ContParams a -> Cont a -> Event ()
invokeCont ContParams ()
c (Cont () -> Event ()) -> Cont () -> Event ()
forall a b. (a -> b) -> a -> b
$
                           ProcessId -> Process () -> Cont ()
forall a. ProcessId -> Process a -> Cont a
invokeProcess ProcessId
pid (Process () -> Cont ()) -> Process () -> Cont ()
forall a b. (a -> b) -> a -> b
$
                           Transact a -> Process ()
forall a. Transact a -> Process ()
takeTransact Transact a
t
                      IORef (Maybe (FrozenCont ())) -> Maybe (FrozenCont ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Transact a -> IORef (Maybe (FrozenCont ()))
forall a. Transact a -> IORef (Maybe (FrozenCont ()))
transactProcessContRef Transact a
t) (FrozenCont () -> Maybe (FrozenCont ())
forall a. a -> Maybe a
Just FrozenCont ()
c)
                      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
n] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
_ ->
                        Point -> Event () -> IO ()
forall a. Point -> Event a -> IO a
invokeEvent Point
p (Event () -> IO ()) -> Event () -> IO ()
forall a b. (a -> b) -> a -> b
$
                        ProcessId -> Event ()
processPreemptionBegin ProcessId
pid

-- | Release the transact.
releaseTransact :: Transact a -> Process ()
releaseTransact :: Transact a -> Process ()
releaseTransact Transact a
t =
  (ProcessId -> Cont ()) -> Process ()
forall a. (ProcessId -> Cont a) -> Process a
Process ((ProcessId -> Cont ()) -> Process ())
-> (ProcessId -> Cont ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ \ProcessId
pid ->
  (ContParams () -> Event ()) -> Cont ()
forall a. (ContParams a -> Event ()) -> Cont a
Cont ((ContParams () -> Event ()) -> Cont ())
-> (ContParams () -> Event ()) -> Cont ()
forall a b. (a -> b) -> a -> b
$ \ContParams ()
c ->
  (Point -> IO ()) -> Event ()
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO ()) -> Event ()) -> (Point -> IO ()) -> Event ()
forall a b. (a -> b) -> a -> b
$ \Point
p ->
  do Maybe ProcessId
pid0 <- IORef (Maybe ProcessId) -> IO (Maybe ProcessId)
forall a. IORef a -> IO a
readIORef (Transact a -> IORef (Maybe ProcessId)
forall a. Transact a -> IORef (Maybe ProcessId)
transactProcessIdRef Transact a
t)
     case Maybe ProcessId
pid0 of
       Maybe ProcessId
Nothing ->
         SimulationRetry -> IO ()
forall e a. Exception e => e -> IO a
throwIO (SimulationRetry -> IO ()) -> SimulationRetry -> IO ()
forall a b. (a -> b) -> a -> b
$
         String -> SimulationRetry
SimulationRetry
         String
"The transact is not acquired by any process: releaseTransact"
       Just ProcessId
pid0 | ProcessId
pid0 ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
/= ProcessId
pid ->
         SimulationRetry -> IO ()
forall e a. Exception e => e -> IO a
throwIO (SimulationRetry -> IO ()) -> SimulationRetry -> IO ()
forall a b. (a -> b) -> a -> b
$
         String -> SimulationRetry
SimulationRetry
         String
"The transact is acquired by another process: releaseTransact"
       Just ProcessId
pid0 ->
         do IORef (Maybe ProcessId) -> Maybe ProcessId -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Transact a -> IORef (Maybe ProcessId)
forall a. Transact a -> IORef (Maybe ProcessId)
transactProcessIdRef Transact a
t) Maybe ProcessId
forall a. Maybe a
Nothing
            IORef (Maybe (FrozenCont ())) -> Maybe (FrozenCont ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Transact a -> IORef (Maybe (FrozenCont ()))
forall a. Transact a -> IORef (Maybe (FrozenCont ()))
transactProcessContRef Transact a
t) Maybe (FrozenCont ())
forall a. Maybe a
Nothing
            Point -> Event () -> IO ()
forall a. Point -> Event a -> IO a
invokeEvent Point
p (Event () -> IO ()) -> Event () -> IO ()
forall a b. (a -> b) -> a -> b
$ ContParams () -> () -> Event ()
forall a. ContParams a -> a -> Event ()
resumeCont ContParams ()
c ()

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

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

-- | Require to return an identifier of the process associated with the transact.
requireTransactProcessId :: Transact a -> Event ProcessId
requireTransactProcessId :: Transact a -> Event ProcessId
requireTransactProcessId Transact a
t =
  (Point -> IO ProcessId) -> Event ProcessId
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO ProcessId) -> Event ProcessId)
-> (Point -> IO ProcessId) -> Event ProcessId
forall a b. (a -> b) -> a -> b
$ \Point
p ->
  do Maybe ProcessId
a <- IORef (Maybe ProcessId) -> IO (Maybe ProcessId)
forall a. IORef a -> IO a
readIORef (Transact a -> IORef (Maybe ProcessId)
forall a. Transact a -> IORef (Maybe ProcessId)
transactProcessIdRef Transact a
t)
     case Maybe ProcessId
a of
       Maybe ProcessId
Nothing ->
         SimulationRetry -> IO ProcessId
forall e a. Exception e => e -> IO a
throwIO (SimulationRetry -> IO ProcessId)
-> SimulationRetry -> IO ProcessId
forall a b. (a -> b) -> a -> b
$
         String -> SimulationRetry
SimulationRetry
         String
"The transact must be associated with any process: requireTransactProcessId"
       Just ProcessId
pid ->
         ProcessId -> IO ProcessId
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessId
pid

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

-- | Register the queue entry in the transact.
registerTransactQueueEntry :: Transact a -> QueueEntry -> Event ()
registerTransactQueueEntry :: Transact a -> QueueEntry -> Event ()
registerTransactQueueEntry Transact a
t QueueEntry
e =
  (Point -> IO ()) -> Event ()
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO ()) -> Event ()) -> (Point -> IO ()) -> Event ()
forall a b. (a -> b) -> a -> b
$ \Point
p ->
  do let q :: Queue
q = QueueEntry -> Queue
entryQueue QueueEntry
e
     HashMap Queue QueueEntry
m <- IORef (HashMap Queue QueueEntry) -> IO (HashMap Queue QueueEntry)
forall a. IORef a -> IO a
readIORef (Transact a -> IORef (HashMap Queue QueueEntry)
forall a. Transact a -> IORef (HashMap Queue QueueEntry)
transactQueueEntryRef Transact a
t)
     case Queue -> HashMap Queue QueueEntry -> Maybe QueueEntry
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Queue
q HashMap Queue QueueEntry
m of
       Just QueueEntry
e0 ->
         SimulationRetry -> IO ()
forall e a. Exception e => e -> IO a
throwIO (SimulationRetry -> IO ()) -> SimulationRetry -> IO ()
forall a b. (a -> b) -> a -> b
$
         String -> SimulationRetry
SimulationRetry
         String
"There is already another queue entry for the specified queue: registerTransactQueueEntry"
       Maybe QueueEntry
Nothing ->
         IORef (HashMap Queue QueueEntry)
-> HashMap Queue QueueEntry -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Transact a -> IORef (HashMap Queue QueueEntry)
forall a. Transact a -> IORef (HashMap Queue QueueEntry)
transactQueueEntryRef Transact a
t) (Queue
-> QueueEntry
-> HashMap Queue QueueEntry
-> HashMap Queue QueueEntry
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Queue
q QueueEntry
e HashMap Queue QueueEntry
m)

-- | Unregister the queue entry from the transact.
unregisterTransactQueueEntry :: Transact a -> Queue -> Event QueueEntry
unregisterTransactQueueEntry :: Transact a -> Queue -> Event QueueEntry
unregisterTransactQueueEntry Transact a
t Queue
q =
  (Point -> IO QueueEntry) -> Event QueueEntry
forall a. (Point -> IO a) -> Event a
Event ((Point -> IO QueueEntry) -> Event QueueEntry)
-> (Point -> IO QueueEntry) -> Event QueueEntry
forall a b. (a -> b) -> a -> b
$ \Point
p ->
  do HashMap Queue QueueEntry
m <- IORef (HashMap Queue QueueEntry) -> IO (HashMap Queue QueueEntry)
forall a. IORef a -> IO a
readIORef (Transact a -> IORef (HashMap Queue QueueEntry)
forall a. Transact a -> IORef (HashMap Queue QueueEntry)
transactQueueEntryRef Transact a
t)
     case Queue -> HashMap Queue QueueEntry -> Maybe QueueEntry
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Queue
q HashMap Queue QueueEntry
m of
       Maybe QueueEntry
Nothing ->
         SimulationRetry -> IO QueueEntry
forall e a. Exception e => e -> IO a
throwIO (SimulationRetry -> IO QueueEntry)
-> SimulationRetry -> IO QueueEntry
forall a b. (a -> b) -> a -> b
$
         String -> SimulationRetry
SimulationRetry
         String
"There is no queue entry for the specified queue: unregisterTransactQueueEntry"
       Just QueueEntry
e  ->
         do IORef (HashMap Queue QueueEntry)
-> HashMap Queue QueueEntry -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Transact a -> IORef (HashMap Queue QueueEntry)
forall a. Transact a -> IORef (HashMap Queue QueueEntry)
transactQueueEntryRef Transact a
t) (Queue -> HashMap Queue QueueEntry -> HashMap Queue QueueEntry
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete Queue
q HashMap Queue QueueEntry
m)
            QueueEntry -> IO QueueEntry
forall (m :: * -> *) a. Monad m => a -> m a
return QueueEntry
e

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

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

-- | Assign the priority and return a new version of the same transact.
assignTransactPriority :: Transact a -> Int -> Transact a
assignTransactPriority :: Transact a -> Int -> Transact a
assignTransactPriority Transact a
t Int
priority =
  Transact a
t { transactPriority :: Int
transactPriority = Int
priority }

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