{-# LANGUAGE RecursiveDo, TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances, RankNTypes #-}

-- |
-- Module     : Simulation.Aivika.Trans.Internal.Simulation
-- Copyright  : Copyright (c) 2009-2017, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 8.0.1
--
-- The module defines the 'Simulation' monad transformer that represents a computation
-- within the simulation run.
-- 
module Simulation.Aivika.Trans.Internal.Simulation
       (-- * Simulation
        Simulation(..),
        SimulationLift(..),
        invokeSimulation,
        runSimulation,
        runSimulations,
        runSimulationByIndex,
        -- * Error Handling
        catchSimulation,
        finallySimulation,
        throwSimulation,
        -- * Exceptions
        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 (>>=) #-}
  (Simulation Run m -> m a
m) >>= :: forall a b.
Simulation m a -> (a -> Simulation m b) -> Simulation m b
>>= a -> Simulation m b
k =
    forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation 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

-- | Run the simulation using the specified specs.
runSimulation :: MonadDES m => Simulation m a -> Specs m -> m a
{-# INLINABLE runSimulation #-}
runSimulation :: forall (m :: * -> *) a.
MonadDES m =>
Simulation m a -> Specs m -> m a
runSimulation (Simulation Run m -> m a
m) Specs m
sc =
  do EventQueue m
q <- forall (m :: * -> *).
EventQueueing m =>
Specs m -> m (EventQueue m)
newEventQueue Specs m
sc
     Generator m
g <- forall (m :: * -> *).
MonadGenerator m =>
GeneratorType m -> m (Generator m)
newGenerator forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Specs m -> GeneratorType m
spcGeneratorType Specs m
sc
     Run m -> m a
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 }

-- | Run the simulation by the specified specs and run index in series.
runSimulationByIndex :: MonadDES m
                        => Simulation m a
                        -- ^ the simulation model
                        -> Specs m
                        -- ^ the simulation specs
                        -> Int
                        -- ^ the number of runs in series
                        -> Int
                        -- ^ the index of the current run (started from 1)
                        -> m a
{-# INLINABLE runSimulationByIndex #-}
runSimulationByIndex :: forall (m :: * -> *) a.
MonadDES m =>
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 <- forall (m :: * -> *).
EventQueueing m =>
Specs m -> m (EventQueue m)
newEventQueue Specs m
sc
     Generator m
g <- forall (m :: * -> *).
MonadGenerator m =>
GeneratorType m -> m (Generator m)
newGenerator forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Specs m -> GeneratorType m
spcGeneratorType Specs m
sc
     Run m -> m a
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 }

-- | Run the given number of simulations using the specified specs, 
--   where each simulation is distinguished by its index 'simulationIndex'.
runSimulations :: MonadDES m => Simulation m a -> Specs m -> Int -> [m a]
{-# INLINABLE runSimulations #-}
runSimulations :: forall (m :: * -> *) a.
MonadDES m =>
Simulation m a -> Specs m -> Int -> [m a]
runSimulations (Simulation Run m -> m a
m) Specs m
sc Int
runs = 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 <- forall (m :: * -> *).
EventQueueing m =>
Specs m -> m (EventQueue m)
newEventQueue Specs m
sc
                 Generator m
g <- forall (m :: * -> *).
MonadGenerator m =>
GeneratorType m -> m (Generator m)
newGenerator forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Specs m -> GeneratorType m
spcGeneratorType Specs m
sc
                 Run m -> m a
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 :: forall a b. (a -> b) -> Simulation m a -> Simulation m b
fmap a -> b
f (Simulation Run m -> m a
x) = forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall a b. (a -> b) -> a -> b
$ \Run m
r -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f 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 :: forall a. a -> Simulation m a
pure = forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  
  {-# INLINE (<*>) #-}
  (Simulation Run m -> m (a -> b)
x) <*> :: forall a b.
Simulation m (a -> b) -> Simulation m a -> Simulation m b
<*> (Simulation Run m -> m a
y) = forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall a b. (a -> b) -> a -> b
$ \Run m
r -> Run m -> m (a -> b)
x Run m
r 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 :: forall a. String -> Simulation m a
fail = forall a. HasCallStack => String -> a
error

liftMS :: Monad m => (a -> b) -> Simulation m a -> Simulation m b
{-# INLINE liftMS #-}
liftMS :: forall (m :: * -> *) a b.
Monad m =>
(a -> b) -> Simulation m a -> Simulation m b
liftMS a -> b
f (Simulation Run m -> m a
x) =
  forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall a b. (a -> b) -> a -> b
$ \Run m
r -> do { a
a <- Run m -> m a
x Run m
r; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ a -> b
f a
a }

instance MonadTrans Simulation where

  {-# INLINE lift #-}
  lift :: forall (m :: * -> *) a. Monad m => m a -> Simulation m a
lift = forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

instance Monad m => MonadCompTrans Simulation m where

  {-# INLINE liftComp #-}
  liftComp :: forall a. m a -> Simulation m a
liftComp = forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

instance MonadIO m => MonadIO (Simulation m) where
  
  {-# INLINE liftIO #-}
  liftIO :: forall a. IO a -> Simulation m a
liftIO = forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | A type class to lift the simulation computations into other computations.
class SimulationLift t m where
  
  -- | Lift the specified 'Simulation' computation into another computation.
  liftSimulation :: Simulation m a -> t m a

instance Monad m => SimulationLift Simulation m where
  
  {-# INLINE liftSimulation #-}
  liftSimulation :: forall a. Simulation m a -> Simulation m a
liftSimulation = forall a. a -> a
id

instance Monad m => ParameterLift Simulation m where

  {-# INLINE liftParameter #-}
  liftParameter :: forall a. Parameter m a -> Simulation m a
liftParameter (Parameter Run m -> m a
x) = forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation Run m -> m a
x
    
-- | Exception handling within 'Simulation' computations.
catchSimulation :: (MonadException m, Exception e) => Simulation m a -> (e -> Simulation m a) -> Simulation m a
{-# INLINABLE catchSimulation #-}
catchSimulation :: forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
Simulation m a -> (e -> Simulation m a) -> Simulation m a
catchSimulation (Simulation Run m -> m a
m) e -> Simulation m a
h =
  forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall a b. (a -> b) -> a -> b
$ \Run m
r -> 
  forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
m a -> (e -> m a) -> m a
catchComp (Run m -> m a
m Run m
r) 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
                           
-- | A computation with finalization part like the 'finally' function.
finallySimulation :: MonadException m => Simulation m a -> Simulation m b -> Simulation m a
{-# INLINABLE finallySimulation #-}
finallySimulation :: forall (m :: * -> *) a b.
MonadException m =>
Simulation m a -> Simulation m b -> Simulation m a
finallySimulation (Simulation Run m -> m a
m) (Simulation Run m -> m b
m') =
  forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall a b. (a -> b) -> a -> b
$ \Run m
r ->
  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)

-- | Like the standard 'throw' function.
throwSimulation :: (MonadException m, Exception e) => e -> Simulation m a
{-# INLINABLE throwSimulation #-}
throwSimulation :: forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> Simulation m a
throwSimulation e
e =
  forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall a b. (a -> b) -> a -> b
$ \Run m
r ->
  forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> m a
throwComp e
e

-- | Runs an action with asynchronous exceptions disabled.
maskSimulation :: MC.MonadMask m => ((forall a. Simulation m a -> Simulation m a) -> Simulation m b) -> Simulation m b
{-# INLINABLE maskSimulation #-}
maskSimulation :: forall (m :: * -> *) b.
MonadMask m =>
((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 =
  forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall a b. (a -> b) -> a -> b
$ \Run m
r ->
  forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MC.mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
u ->
  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 b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a} {a}.
(m a -> m a) -> Simulation m a -> Simulation m a
q 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) = forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation (m a -> m a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run m -> m a
b)

-- | Like 'maskSimulation', but the masked computation is not interruptible.
uninterruptibleMaskSimulation :: MC.MonadMask m => ((forall a. Simulation m a -> Simulation m a) -> Simulation m b) -> Simulation m b
{-# INLINABLE uninterruptibleMaskSimulation #-}
uninterruptibleMaskSimulation :: forall (m :: * -> *) b.
MonadMask m =>
((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 =
  forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall a b. (a -> b) -> a -> b
$ \Run m
r ->
  forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MC.uninterruptibleMask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
u ->
  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 b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a} {a}.
(m a -> m a) -> Simulation m a -> Simulation m a
q 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) = forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation (m a -> m a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run m -> m a
b)

-- | An implementation of 'generalBracket'.
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 :: 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 Simulation m a
acquire a -> ExitCase b -> Simulation m c
release a -> Simulation m b
use =
  forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall a b. (a -> b) -> a -> b
$ \Run m
r -> do
    forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
MC.generalBracket
      (forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r Simulation m a
acquire)
      (\a
resource ExitCase b
e -> forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r forall a b. (a -> b) -> a -> b
$ a -> ExitCase b -> Simulation m c
release a
resource ExitCase b
e)
      (\a
resource -> forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r forall a b. (a -> b) -> a -> b
$ a -> Simulation m b
use a
resource)

instance MonadFix m => MonadFix (Simulation m) where

  {-# INLINE mfix #-}
  mfix :: forall a. (a -> Simulation m a) -> Simulation m a
mfix a -> Simulation m a
f = 
    forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall a b. (a -> b) -> a -> b
$ \Run m
r ->
    do { rec { a
a <- forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run m
r (a -> Simulation m a
f a
a) }; forall (m :: * -> *) a. Monad m => a -> m a
return a
a }

instance MonadException m => MC.MonadThrow (Simulation m) where

  {-# INLINE throwM #-}
  throwM :: forall e a. Exception e => e -> Simulation m a
throwM = forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> Simulation m a
throwSimulation

instance MonadException m => MC.MonadCatch (Simulation m) where

  {-# INLINE catch #-}
  catch :: forall e a.
Exception e =>
Simulation m a -> (e -> Simulation m a) -> Simulation m a
catch = 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 b.
((forall a. Simulation m a -> Simulation m a) -> Simulation m b)
-> Simulation m b
mask = forall (m :: * -> *) b.
MonadMask m =>
((forall a. Simulation m a -> Simulation m a) -> Simulation m b)
-> Simulation m b
maskSimulation
  
  {-# INLINE uninterruptibleMask #-}
  uninterruptibleMask :: forall b.
((forall a. Simulation m a -> Simulation m a) -> Simulation m b)
-> Simulation m b
uninterruptibleMask = forall (m :: * -> *) b.
MonadMask m =>
((forall a. Simulation m a -> Simulation m a) -> Simulation m b)
-> Simulation m b
uninterruptibleMaskSimulation
  
  {-# INLINE generalBracket #-}
  generalBracket :: forall a b c.
Simulation m a
-> (a -> ExitCase b -> Simulation m c)
-> (a -> Simulation m b)
-> Simulation m (b, c)
generalBracket = 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