{-# LANGUAGE RecursiveDo, TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances, RankNTypes #-}
module Simulation.Aivika.Trans.Internal.Simulation
(
Simulation(..),
SimulationLift(..),
invokeSimulation,
runSimulation,
runSimulations,
runSimulationByIndex,
catchSimulation,
finallySimulation,
throwSimulation,
SimulationException(..),
SimulationAbort(..),
SimulationRetry(..)) where
import Control.Exception
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Fix
import Control.Monad.Fail
import qualified Control.Monad.Catch as MC
import Control.Applicative
import Simulation.Aivika.Trans.Exception
import Simulation.Aivika.Trans.Generator
import Simulation.Aivika.Trans.Comp
import Simulation.Aivika.Trans.DES
import Simulation.Aivika.Trans.Internal.Types
import Simulation.Aivika.Trans.Internal.Specs
import Simulation.Aivika.Trans.Internal.Parameter
import Simulation.Aivika.Simulation (SimulationException(..), SimulationAbort(..), SimulationRetry(..))
instance Monad m => Monad (Simulation m) where
{-# INLINE return #-}
return :: a -> Simulation m a
return a
a = (Run m -> m a) -> Simulation m a
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run m -> m a) -> Simulation m a)
-> (Run m -> m a) -> Simulation m a
forall a b. (a -> b) -> a -> b
$ \Run m
r -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
{-# INLINE (>>=) #-}
(Simulation Run m -> m a
m) >>= :: Simulation m a -> (a -> Simulation m b) -> Simulation m b
>>= a -> Simulation m b
k =
(Run m -> m b) -> Simulation m b
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run m -> m b) -> Simulation m b)
-> (Run m -> m b) -> Simulation m b
forall a b. (a -> b) -> a -> b
$ \Run m
r ->
do a
a <- Run m -> m a
m Run m
r
let Simulation Run m -> m b
m' = a -> Simulation m b
k a
a
Run m -> m b
m' Run m
r
runSimulation :: MonadDES m => Simulation m a -> Specs m -> m a
{-# INLINABLE runSimulation #-}
runSimulation :: Simulation m a -> Specs m -> m a
runSimulation (Simulation Run m -> m a
m) Specs m
sc =
do EventQueue m
q <- Specs m -> m (EventQueue m)
forall (m :: * -> *).
EventQueueing m =>
Specs m -> m (EventQueue m)
newEventQueue Specs m
sc
Generator m
g <- GeneratorType m -> m (Generator m)
forall (m :: * -> *).
MonadGenerator m =>
GeneratorType m -> m (Generator m)
newGenerator (GeneratorType m -> m (Generator m))
-> GeneratorType m -> m (Generator m)
forall a b. (a -> b) -> a -> b
$ Specs m -> GeneratorType m
forall (m :: * -> *). Specs m -> GeneratorType m
spcGeneratorType Specs m
sc
Run m -> m a
m Run :: forall (m :: * -> *).
Specs m -> Int -> Int -> EventQueue m -> Generator m -> Run m
Run { runSpecs :: Specs m
runSpecs = Specs m
sc,
runIndex :: Int
runIndex = Int
1,
runCount :: Int
runCount = Int
1,
runEventQueue :: EventQueue m
runEventQueue = EventQueue m
q,
runGenerator :: Generator m
runGenerator = Generator m
g }
runSimulationByIndex :: MonadDES m
=> Simulation m a
-> Specs m
-> Int
-> Int
-> m a
{-# INLINABLE runSimulationByIndex #-}
runSimulationByIndex :: Simulation m a -> Specs m -> Int -> Int -> m a
runSimulationByIndex (Simulation Run m -> m a
m) Specs m
sc Int
runs Int
index =
do EventQueue m
q <- Specs m -> m (EventQueue m)
forall (m :: * -> *).
EventQueueing m =>
Specs m -> m (EventQueue m)
newEventQueue Specs m
sc
Generator m
g <- GeneratorType m -> m (Generator m)
forall (m :: * -> *).
MonadGenerator m =>
GeneratorType m -> m (Generator m)
newGenerator (GeneratorType m -> m (Generator m))
-> GeneratorType m -> m (Generator m)
forall a b. (a -> b) -> a -> b
$ Specs m -> GeneratorType m
forall (m :: * -> *). Specs m -> GeneratorType m
spcGeneratorType Specs m
sc
Run m -> m a
m Run :: forall (m :: * -> *).
Specs m -> Int -> Int -> EventQueue m -> Generator m -> Run m
Run { runSpecs :: Specs m
runSpecs = Specs m
sc,
runIndex :: Int
runIndex = Int
index,
runCount :: Int
runCount = Int
runs,
runEventQueue :: EventQueue m
runEventQueue = EventQueue m
q,
runGenerator :: Generator m
runGenerator = Generator m
g }
runSimulations :: MonadDES m => Simulation m a -> Specs m -> Int -> [m a]
{-# INLINABLE runSimulations #-}
runSimulations :: Simulation m a -> Specs m -> Int -> [m a]
runSimulations (Simulation Run m -> m a
m) Specs m
sc Int
runs = (Int -> m a) -> [Int] -> [m a]
forall a b. (a -> b) -> [a] -> [b]
map Int -> m a
f [Int
1 .. Int
runs]
where f :: Int -> m a
f Int
i = do EventQueue m
q <- Specs m -> m (EventQueue m)
forall (m :: * -> *).
EventQueueing m =>
Specs m -> m (EventQueue m)
newEventQueue Specs m
sc
Generator m
g <- GeneratorType m -> m (Generator m)
forall (m :: * -> *).
MonadGenerator m =>
GeneratorType m -> m (Generator m)
newGenerator (GeneratorType m -> m (Generator m))
-> GeneratorType m -> m (Generator m)
forall a b. (a -> b) -> a -> b
$ Specs m -> GeneratorType m
forall (m :: * -> *). Specs m -> GeneratorType m
spcGeneratorType Specs m
sc
Run m -> m a
m Run :: forall (m :: * -> *).
Specs m -> Int -> Int -> EventQueue m -> Generator m -> Run m
Run { runSpecs :: Specs m
runSpecs = Specs m
sc,
runIndex :: Int
runIndex = Int
i,
runCount :: Int
runCount = Int
runs,
runEventQueue :: EventQueue m
runEventQueue = EventQueue m
q,
runGenerator :: Generator m
runGenerator = Generator m
g }
instance Functor m => Functor (Simulation m) where
{-# INLINE fmap #-}
fmap :: (a -> b) -> Simulation m a -> Simulation m b
fmap a -> b
f (Simulation Run m -> m a
x) = (Run m -> m b) -> Simulation m b
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run m -> m b) -> Simulation m b)
-> (Run m -> m b) -> Simulation m b
forall a b. (a -> b) -> a -> b
$ \Run m
r -> (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (m a -> m b) -> m a -> m b
forall a b. (a -> b) -> a -> b
$ Run m -> m a
x Run m
r
instance Applicative m => Applicative (Simulation m) where
{-# INLINE pure #-}
pure :: a -> Simulation m a
pure = (Run m -> m a) -> Simulation m a
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run m -> m a) -> Simulation m a)
-> (a -> Run m -> m a) -> a -> Simulation m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> Run m -> m a
forall a b. a -> b -> a
const (m a -> Run m -> m a) -> (a -> m a) -> a -> Run m -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE (<*>) #-}
(Simulation Run m -> m (a -> b)
x) <*> :: Simulation m (a -> b) -> Simulation m a -> Simulation m b
<*> (Simulation Run m -> m a
y) = (Run m -> m b) -> Simulation m b
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run m -> m b) -> Simulation m b)
-> (Run m -> m b) -> Simulation m b
forall a b. (a -> b) -> a -> b
$ \Run m
r -> Run m -> m (a -> b)
x Run m
r m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Run m -> m a
y Run m
r
instance Monad m => MonadFail (Simulation m) where
{-# INLINE fail #-}
fail :: String -> Simulation m a
fail = String -> Simulation m a
forall a. HasCallStack => String -> a
error
liftMS :: Monad m => (a -> b) -> Simulation m a -> Simulation m b
{-# INLINE liftMS #-}
liftMS :: (a -> b) -> Simulation m a -> Simulation m b
liftMS a -> b
f (Simulation Run m -> m a
x) =
(Run m -> m b) -> Simulation m b
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run m -> m b) -> Simulation m b)
-> (Run m -> m b) -> Simulation m b
forall a b. (a -> b) -> a -> b
$ \Run m
r -> do { a
a <- Run m -> m a
x Run m
r; b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> m b) -> b -> m b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a }
instance MonadTrans Simulation where
{-# INLINE lift #-}
lift :: m a -> Simulation m a
lift = (Run m -> m a) -> Simulation m a
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run m -> m a) -> Simulation m a)
-> (m a -> Run m -> m a) -> m a -> Simulation m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> Run m -> m a
forall a b. a -> b -> a
const
instance Monad m => MonadCompTrans Simulation m where
{-# INLINE liftComp #-}
liftComp :: m a -> Simulation m a
liftComp = (Run m -> m a) -> Simulation m a
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run m -> m a) -> Simulation m a)
-> (m a -> Run m -> m a) -> m a -> Simulation m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> Run m -> m a
forall a b. a -> b -> a
const
instance MonadIO m => MonadIO (Simulation m) where
{-# INLINE liftIO #-}
liftIO :: IO a -> Simulation m a
liftIO = (Run m -> m a) -> Simulation m a
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run m -> m a) -> Simulation m a)
-> (IO a -> Run m -> m a) -> IO a -> Simulation m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> Run m -> m a
forall a b. a -> b -> a
const (m a -> Run m -> m a) -> (IO a -> m a) -> IO a -> Run m -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
class SimulationLift t m where
liftSimulation :: Simulation m a -> t m a
instance Monad m => SimulationLift Simulation m where
{-# INLINE liftSimulation #-}
liftSimulation :: Simulation m a -> Simulation m a
liftSimulation = Simulation m a -> Simulation m a
forall a. a -> a
id
instance Monad m => ParameterLift Simulation m where
{-# INLINE liftParameter #-}
liftParameter :: Parameter m a -> Simulation m a
liftParameter (Parameter Run m -> m a
x) = (Run m -> m a) -> Simulation m a
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation Run m -> m a
x
catchSimulation :: (MonadException m, Exception e) => Simulation m a -> (e -> Simulation m a) -> Simulation m a
{-# INLINABLE catchSimulation #-}
catchSimulation :: Simulation m a -> (e -> Simulation m a) -> Simulation m a
catchSimulation (Simulation Run m -> m a
m) e -> Simulation m a
h =
(Run m -> m a) -> Simulation m a
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run m -> m a) -> Simulation m a)
-> (Run m -> m a) -> Simulation m a
forall a b. (a -> b) -> a -> b
$ \Run m
r ->
m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
m a -> (e -> m a) -> m a
catchComp (Run m -> m a
m Run m
r) ((e -> m a) -> m a) -> (e -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \e
e ->
let Simulation Run m -> m a
m' = e -> Simulation m a
h e
e in Run m -> m a
m' Run m
r
finallySimulation :: MonadException m => Simulation m a -> Simulation m b -> Simulation m a
{-# INLINABLE finallySimulation #-}
finallySimulation :: Simulation m a -> Simulation m b -> Simulation m a
finallySimulation (Simulation Run m -> m a
m) (Simulation Run m -> m b
m') =
(Run m -> m a) -> Simulation m a
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run m -> m a) -> Simulation m a)
-> (Run m -> m a) -> Simulation m a
forall a b. (a -> b) -> a -> b
$ \Run m
r ->
m a -> m b -> m a
forall (m :: * -> *) a b. MonadException m => m a -> m b -> m a
finallyComp (Run m -> m a
m Run m
r) (Run m -> m b
m' Run m
r)
throwSimulation :: (MonadException m, Exception e) => e -> Simulation m a
{-# INLINABLE throwSimulation #-}
throwSimulation :: e -> Simulation m a
throwSimulation e
e =
(Run m -> m a) -> Simulation m a
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run m -> m a) -> Simulation m a)
-> (Run m -> m a) -> Simulation m a
forall a b. (a -> b) -> a -> b
$ \Run m
r ->
e -> m a
forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> m a
throwComp e
e
maskSimulation :: MC.MonadMask m => ((forall a. Simulation m a -> Simulation m a) -> Simulation m b) -> Simulation m b
{-# INLINABLE maskSimulation #-}
maskSimulation :: ((forall a. Simulation m a -> Simulation m a) -> Simulation m b)
-> Simulation m b
maskSimulation (forall a. Simulation m a -> Simulation m a) -> Simulation m b
a =
(Run m -> m b) -> Simulation m b
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run m -> m b) -> Simulation m b)
-> (Run m -> m b) -> Simulation m b
forall a b. (a -> b) -> a -> b
$ \Run m
r ->
((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MC.mask (((forall a. m a -> m a) -> m b) -> m b)
-> ((forall a. m a -> m a) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
u ->
Run m -> Simulation m b -> m b
forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r ((forall a. Simulation m a -> Simulation m a) -> Simulation m b
a ((forall a. Simulation m a -> Simulation m a) -> Simulation m b)
-> (forall a. Simulation m a -> Simulation m a) -> Simulation m b
forall a b. (a -> b) -> a -> b
$ (m a -> m a) -> Simulation m a -> Simulation m a
forall (m :: * -> *) a a.
(m a -> m a) -> Simulation m a -> Simulation m a
q m a -> m a
forall a. m a -> m a
u)
where q :: (m a -> m a) -> Simulation m a -> Simulation m a
q m a -> m a
u (Simulation Run m -> m a
b) = (Run m -> m a) -> Simulation m a
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation (m a -> m a
u (m a -> m a) -> (Run m -> m a) -> Run m -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run m -> m a
b)
uninterruptibleMaskSimulation :: MC.MonadMask m => ((forall a. Simulation m a -> Simulation m a) -> Simulation m b) -> Simulation m b
{-# INLINABLE uninterruptibleMaskSimulation #-}
uninterruptibleMaskSimulation :: ((forall a. Simulation m a -> Simulation m a) -> Simulation m b)
-> Simulation m b
uninterruptibleMaskSimulation (forall a. Simulation m a -> Simulation m a) -> Simulation m b
a =
(Run m -> m b) -> Simulation m b
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run m -> m b) -> Simulation m b)
-> (Run m -> m b) -> Simulation m b
forall a b. (a -> b) -> a -> b
$ \Run m
r ->
((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MC.uninterruptibleMask (((forall a. m a -> m a) -> m b) -> m b)
-> ((forall a. m a -> m a) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
u ->
Run m -> Simulation m b -> m b
forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r ((forall a. Simulation m a -> Simulation m a) -> Simulation m b
a ((forall a. Simulation m a -> Simulation m a) -> Simulation m b)
-> (forall a. Simulation m a -> Simulation m a) -> Simulation m b
forall a b. (a -> b) -> a -> b
$ (m a -> m a) -> Simulation m a -> Simulation m a
forall (m :: * -> *) a a.
(m a -> m a) -> Simulation m a -> Simulation m a
q m a -> m a
forall a. m a -> m a
u)
where q :: (m a -> m a) -> Simulation m a -> Simulation m a
q m a -> m a
u (Simulation Run m -> m a
b) = (Run m -> m a) -> Simulation m a
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation (m a -> m a
u (m a -> m a) -> (Run m -> m a) -> Run m -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run m -> m a
b)
generalBracketSimulation :: MC.MonadMask m
=> Simulation m a
-> (a -> MC.ExitCase b -> Simulation m c)
-> (a -> Simulation m b)
-> Simulation m (b, c)
{-# INLINABLE generalBracketSimulation #-}
generalBracketSimulation :: Simulation m a
-> (a -> ExitCase b -> Simulation m c)
-> (a -> Simulation m b)
-> Simulation m (b, c)
generalBracketSimulation Simulation m a
acquire a -> ExitCase b -> Simulation m c
release a -> Simulation m b
use =
(Run m -> m (b, c)) -> Simulation m (b, c)
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run m -> m (b, c)) -> Simulation m (b, c))
-> (Run m -> m (b, c)) -> Simulation m (b, c)
forall a b. (a -> b) -> a -> b
$ \Run m
r -> do
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
MC.generalBracket
(Run m -> Simulation m a -> m a
forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r Simulation m a
acquire)
(\a
resource ExitCase b
e -> Run m -> Simulation m c -> m c
forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r (Simulation m c -> m c) -> Simulation m c -> m c
forall a b. (a -> b) -> a -> b
$ a -> ExitCase b -> Simulation m c
release a
resource ExitCase b
e)
(\a
resource -> Run m -> Simulation m b -> m b
forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r (Simulation m b -> m b) -> Simulation m b -> m b
forall a b. (a -> b) -> a -> b
$ a -> Simulation m b
use a
resource)
instance MonadFix m => MonadFix (Simulation m) where
{-# INLINE mfix #-}
mfix :: (a -> Simulation m a) -> Simulation m a
mfix a -> Simulation m a
f =
(Run m -> m a) -> Simulation m a
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run m -> m a) -> Simulation m a)
-> (Run m -> m a) -> Simulation m a
forall a b. (a -> b) -> a -> b
$ \Run m
r ->
do { rec { a
a <- Run m -> Simulation m a -> m a
forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r (a -> Simulation m a
f a
a) }; a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a }
instance MonadException m => MC.MonadThrow (Simulation m) where
{-# INLINE throwM #-}
throwM :: e -> Simulation m a
throwM = e -> Simulation m a
forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> Simulation m a
throwSimulation
instance MonadException m => MC.MonadCatch (Simulation m) where
{-# INLINE catch #-}
catch :: Simulation m a -> (e -> Simulation m a) -> Simulation m a
catch = Simulation m a -> (e -> Simulation m a) -> Simulation m a
forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
Simulation m a -> (e -> Simulation m a) -> Simulation m a
catchSimulation
instance (MonadException m, MC.MonadMask m) => MC.MonadMask (Simulation m) where
{-# INLINE mask #-}
mask :: ((forall a. Simulation m a -> Simulation m a) -> Simulation m b)
-> Simulation m b
mask = ((forall a. Simulation m a -> Simulation m a) -> Simulation m b)
-> Simulation m b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. Simulation m a -> Simulation m a) -> Simulation m b)
-> Simulation m b
maskSimulation
{-# INLINE uninterruptibleMask #-}
uninterruptibleMask :: ((forall a. Simulation m a -> Simulation m a) -> Simulation m b)
-> Simulation m b
uninterruptibleMask = ((forall a. Simulation m a -> Simulation m a) -> Simulation m b)
-> Simulation m b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. Simulation m a -> Simulation m a) -> Simulation m b)
-> Simulation m b
uninterruptibleMaskSimulation
{-# INLINE generalBracket #-}
generalBracket :: Simulation m a
-> (a -> ExitCase b -> Simulation m c)
-> (a -> Simulation m b)
-> Simulation m (b, c)
generalBracket = Simulation m a
-> (a -> ExitCase b -> Simulation m c)
-> (a -> Simulation m b)
-> Simulation m (b, c)
forall (m :: * -> *) a b c.
MonadMask m =>
Simulation m a
-> (a -> ExitCase b -> Simulation m c)
-> (a -> Simulation m b)
-> Simulation m (b, c)
generalBracketSimulation