{-# LANGUAGE RecursiveDo, ExistentialQuantification, DeriveDataTypeable, RankNTypes #-}

-- |
-- Module     : Simulation.Aivika.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
--
-- This is an internal implementation module that should never be used directly.
--
-- The module defines the 'Simulation' monad that represents a computation within
-- the simulation run.
-- 
module Simulation.Aivika.Internal.Simulation
       (-- * Simulation
        Simulation(..),
        SimulationLift(..),
        invokeSimulation,
        runSimulation,
        runSimulations,
        runSimulationByIndex,
        -- * Error Handling
        catchSimulation,
        finallySimulation,
        throwSimulation,
        -- * Utilities
        simulationEventQueue,
        -- * Memoization
        memoSimulation,
        -- * 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 Data.IORef
import Data.Typeable

import Simulation.Aivika.Generator
import Simulation.Aivika.Internal.Specs
import Simulation.Aivika.Internal.Parameter

-- | A value in the 'Simulation' monad represents a computation
-- within the simulation run.
newtype Simulation a = Simulation (Run -> IO a)

instance Monad Simulation where
  Simulation a
m >>= :: forall a b. Simulation a -> (a -> Simulation b) -> Simulation b
>>= a -> Simulation b
k = forall a b. Simulation a -> (a -> Simulation b) -> Simulation b
bindS Simulation a
m a -> Simulation b
k

returnS :: a -> Simulation a
{-# INLINE returnS #-}
returnS :: forall a. a -> Simulation a
returnS a
a = forall a. (Run -> IO a) -> Simulation a
Simulation (\Run
r -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a)

bindS :: Simulation a -> (a -> Simulation b) -> Simulation b
{-# INLINE bindS #-}
bindS :: forall a b. Simulation a -> (a -> Simulation b) -> Simulation b
bindS (Simulation Run -> IO a
m) a -> Simulation b
k = 
  forall a. (Run -> IO a) -> Simulation a
Simulation forall a b. (a -> b) -> a -> b
$ \Run
r -> 
  do a
a <- Run -> IO a
m Run
r
     let Simulation Run -> IO b
m' = a -> Simulation b
k a
a
     Run -> IO b
m' Run
r

-- | Run the simulation using the specified specs.
runSimulation :: Simulation a -> Specs -> IO a
runSimulation :: forall a. Simulation a -> Specs -> IO a
runSimulation (Simulation Run -> IO a
m) Specs
sc =
  do EventQueue
q <- Specs -> IO EventQueue
newEventQueue Specs
sc
     Generator
g <- GeneratorType -> IO Generator
newGenerator forall a b. (a -> b) -> a -> b
$ Specs -> GeneratorType
spcGeneratorType Specs
sc
     Run -> IO a
m Run { runSpecs :: Specs
runSpecs = Specs
sc,
             runIndex :: Int
runIndex = Int
1,
             runCount :: Int
runCount = Int
1,
             runEventQueue :: EventQueue
runEventQueue = EventQueue
q,
             runGenerator :: Generator
runGenerator = Generator
g }

-- | Run the simulation by the specified specs and run index in series.
runSimulationByIndex :: Simulation a
                        -- ^ the simulation model
                        -> Specs
                        -- ^ the simulation specs
                        -> Int
                        -- ^ the number of runs in series
                        -> Int
                        -- ^ the index of the current run (started from 1)
                        -> IO a
runSimulationByIndex :: forall a. Simulation a -> Specs -> Int -> Int -> IO a
runSimulationByIndex (Simulation Run -> IO a
m) Specs
sc Int
runs Int
index =
  do EventQueue
q <- Specs -> IO EventQueue
newEventQueue Specs
sc
     Generator
g <- GeneratorType -> IO Generator
newGenerator forall a b. (a -> b) -> a -> b
$ Specs -> GeneratorType
spcGeneratorType Specs
sc
     Run -> IO a
m Run { runSpecs :: Specs
runSpecs = Specs
sc,
             runIndex :: Int
runIndex = Int
index,
             runCount :: Int
runCount = Int
runs,
             runEventQueue :: EventQueue
runEventQueue = EventQueue
q,
             runGenerator :: Generator
runGenerator = Generator
g }

-- | Run the given number of simulations using the specified specs, 
--   where each simulation is distinguished by its index 'simulationIndex'.
runSimulations :: Simulation a -> Specs -> Int -> [IO a]
runSimulations :: forall a. Simulation a -> Specs -> Int -> [IO a]
runSimulations (Simulation Run -> IO a
m) Specs
sc Int
runs = forall a b. (a -> b) -> [a] -> [b]
map Int -> IO a
f [Int
1 .. Int
runs]
  where f :: Int -> IO a
f Int
i = do EventQueue
q <- Specs -> IO EventQueue
newEventQueue Specs
sc
                 Generator
g <- GeneratorType -> IO Generator
newGenerator forall a b. (a -> b) -> a -> b
$ Specs -> GeneratorType
spcGeneratorType Specs
sc
                 Run -> IO a
m Run { runSpecs :: Specs
runSpecs = Specs
sc,
                         runIndex :: Int
runIndex = Int
i,
                         runCount :: Int
runCount = Int
runs,
                         runEventQueue :: EventQueue
runEventQueue = EventQueue
q,
                         runGenerator :: Generator
runGenerator = Generator
g }

-- | Return the event queue.
simulationEventQueue :: Simulation EventQueue
simulationEventQueue :: Simulation EventQueue
simulationEventQueue = forall a. (Run -> IO a) -> Simulation a
Simulation forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> EventQueue
runEventQueue

instance Functor Simulation where
  fmap :: forall a b. (a -> b) -> Simulation a -> Simulation b
fmap = forall a b. (a -> b) -> Simulation a -> Simulation b
liftMS

instance Applicative Simulation where
  pure :: forall a. a -> Simulation a
pure = forall a. a -> Simulation a
returnS
  <*> :: forall a b. Simulation (a -> b) -> Simulation a -> Simulation b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance MonadFail Simulation where
  fail :: forall a. String -> Simulation a
fail = forall a. HasCallStack => String -> a
error

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

instance MonadIO Simulation where
  liftIO :: forall a. IO a -> Simulation a
liftIO IO a
m = forall a. (Run -> IO a) -> Simulation a
Simulation forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const IO a
m

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

instance SimulationLift Simulation where
  liftSimulation :: forall a. Simulation a -> Simulation a
liftSimulation = forall a. a -> a
id

instance ParameterLift Simulation where
  liftParameter :: forall a. Parameter a -> Simulation a
liftParameter = forall a. Parameter a -> Simulation a
liftPS

liftPS :: Parameter a -> Simulation a
{-# INLINE liftPS #-}
liftPS :: forall a. Parameter a -> Simulation a
liftPS (Parameter Run -> IO a
x) =
  forall a. (Run -> IO a) -> Simulation a
Simulation Run -> IO a
x
    
-- | Exception handling within 'Simulation' computations.
catchSimulation :: Exception e => Simulation a -> (e -> Simulation a) -> Simulation a
catchSimulation :: forall e a.
Exception e =>
Simulation a -> (e -> Simulation a) -> Simulation a
catchSimulation (Simulation Run -> IO a
m) e -> Simulation a
h =
  forall a. (Run -> IO a) -> Simulation a
Simulation forall a b. (a -> b) -> a -> b
$ \Run
r -> 
  forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Run -> IO a
m Run
r) forall a b. (a -> b) -> a -> b
$ \e
e ->
  let Simulation Run -> IO a
m' = e -> Simulation a
h e
e in Run -> IO a
m' Run
r
                           
-- | A computation with finalization part like the 'finally' function.
finallySimulation :: Simulation a -> Simulation b -> Simulation a
finallySimulation :: forall a b. Simulation a -> Simulation b -> Simulation a
finallySimulation (Simulation Run -> IO a
m) (Simulation Run -> IO b
m') =
  forall a. (Run -> IO a) -> Simulation a
Simulation forall a b. (a -> b) -> a -> b
$ \Run
r ->
  forall a b. IO a -> IO b -> IO a
finally (Run -> IO a
m Run
r) (Run -> IO b
m' Run
r)

-- | Like the standard 'throw' function.
throwSimulation :: Exception e => e -> Simulation a
throwSimulation :: forall e a. Exception e => e -> Simulation a
throwSimulation = forall a e. Exception e => e -> a
throw

-- | Runs an action with asynchronous exceptions disabled.
maskSimulation :: ((forall a. Simulation a -> Simulation a) -> Simulation b) -> Simulation b
maskSimulation :: forall b.
((forall a. Simulation a -> Simulation a) -> Simulation b)
-> Simulation b
maskSimulation (forall a. Simulation a -> Simulation a) -> Simulation b
a =
  forall a. (Run -> IO a) -> Simulation a
Simulation forall a b. (a -> b) -> a -> b
$ \Run
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. IO a -> IO a
u ->
  forall a. Run -> Simulation a -> IO a
invokeSimulation Run
r ((forall a. Simulation a -> Simulation a) -> Simulation b
a forall a b. (a -> b) -> a -> b
$ forall {a} {a}. (IO a -> IO a) -> Simulation a -> Simulation a
q forall a. IO a -> IO a
u)
  where q :: (IO a -> IO a) -> Simulation a -> Simulation a
q IO a -> IO a
u (Simulation Run -> IO a
b) = forall a. (Run -> IO a) -> Simulation a
Simulation (IO a -> IO a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> IO a
b)

-- | Like 'maskSimulation', but the masked computation is not interruptible.
uninterruptibleMaskSimulation :: ((forall a. Simulation a -> Simulation a) -> Simulation b) -> Simulation b
uninterruptibleMaskSimulation :: forall b.
((forall a. Simulation a -> Simulation a) -> Simulation b)
-> Simulation b
uninterruptibleMaskSimulation (forall a. Simulation a -> Simulation a) -> Simulation b
a =
  forall a. (Run -> IO a) -> Simulation a
Simulation forall a b. (a -> b) -> a -> b
$ \Run
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. IO a -> IO a
u ->
  forall a. Run -> Simulation a -> IO a
invokeSimulation Run
r ((forall a. Simulation a -> Simulation a) -> Simulation b
a forall a b. (a -> b) -> a -> b
$ forall {a} {a}. (IO a -> IO a) -> Simulation a -> Simulation a
q forall a. IO a -> IO a
u)
  where q :: (IO a -> IO a) -> Simulation a -> Simulation a
q IO a -> IO a
u (Simulation Run -> IO a
b) = forall a. (Run -> IO a) -> Simulation a
Simulation (IO a -> IO a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> IO a
b)

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

-- | Invoke the 'Simulation' computation.
invokeSimulation :: Run -> Simulation a -> IO a
{-# INLINE invokeSimulation #-}
invokeSimulation :: forall a. Run -> Simulation a -> IO a
invokeSimulation Run
r (Simulation Run -> IO a
m) = Run -> IO a
m Run
r

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

instance MC.MonadThrow Simulation where
  throwM :: forall e a. Exception e => e -> Simulation a
throwM = forall e a. Exception e => e -> Simulation a
throwSimulation

instance MC.MonadCatch Simulation where
  catch :: forall e a.
Exception e =>
Simulation a -> (e -> Simulation a) -> Simulation a
catch = forall e a.
Exception e =>
Simulation a -> (e -> Simulation a) -> Simulation a
catchSimulation

instance MC.MonadMask Simulation where
  mask :: forall b.
((forall a. Simulation a -> Simulation a) -> Simulation b)
-> Simulation b
mask = forall b.
((forall a. Simulation a -> Simulation a) -> Simulation b)
-> Simulation b
maskSimulation
  uninterruptibleMask :: forall b.
((forall a. Simulation a -> Simulation a) -> Simulation b)
-> Simulation b
uninterruptibleMask = forall b.
((forall a. Simulation a -> Simulation a) -> Simulation b)
-> Simulation b
uninterruptibleMaskSimulation
  generalBracket :: forall a b c.
Simulation a
-> (a -> ExitCase b -> Simulation c)
-> (a -> Simulation b)
-> Simulation (b, c)
generalBracket = forall a b c.
Simulation a
-> (a -> ExitCase b -> Simulation c)
-> (a -> Simulation b)
-> Simulation (b, c)
generalBracketSimulation

-- | Memoize the 'Simulation' computation, always returning the same value
-- within a simulation run.
memoSimulation :: Simulation a -> Simulation (Simulation a)
memoSimulation :: forall a. Simulation a -> Simulation (Simulation a)
memoSimulation Simulation a
m =
  do IORef (Maybe a)
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (Run -> IO a) -> Simulation a
Simulation forall a b. (a -> b) -> a -> b
$ \Run
r ->
       do Maybe a
x <- forall a. IORef a -> IO a
readIORef IORef (Maybe a)
ref
          case Maybe a
x of
            Just a
v -> forall (m :: * -> *) a. Monad m => a -> m a
return a
v
            Maybe a
Nothing ->
              do a
v <- forall a. Run -> Simulation a -> IO a
invokeSimulation Run
r Simulation a
m
                 forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe a)
ref (forall a. a -> Maybe a
Just a
v)
                 forall (m :: * -> *) a. Monad m => a -> m a
return a
v

-- | The root of simulation exceptions.
data SimulationException = forall e . Exception e => SimulationException e
                           -- ^ A particular simulation exception.
                         deriving Typeable

instance Show SimulationException where
  show :: SimulationException -> String
show (SimulationException e
e) = forall a. Show a => a -> String
show e
e

instance Exception SimulationException

-- | An exception that signals of aborting the simulation.
data SimulationAbort = SimulationAbort String
                       -- ^ The exception to abort the simulation.
                     deriving (Int -> SimulationAbort -> ShowS
[SimulationAbort] -> ShowS
SimulationAbort -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SimulationAbort] -> ShowS
$cshowList :: [SimulationAbort] -> ShowS
show :: SimulationAbort -> String
$cshow :: SimulationAbort -> String
showsPrec :: Int -> SimulationAbort -> ShowS
$cshowsPrec :: Int -> SimulationAbort -> ShowS
Show, Typeable)

-- | An exception that signals that the current computation should be retried
-- as possible, which feature may be supported by the simulation engine or not.
data SimulationRetry = SimulationRetry String
                       -- ^ The exception to retry the computation.
                     deriving (Int -> SimulationRetry -> ShowS
[SimulationRetry] -> ShowS
SimulationRetry -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SimulationRetry] -> ShowS
$cshowList :: [SimulationRetry] -> ShowS
show :: SimulationRetry -> String
$cshow :: SimulationRetry -> String
showsPrec :: Int -> SimulationRetry -> ShowS
$cshowsPrec :: Int -> SimulationRetry -> ShowS
Show, Typeable)

instance Exception SimulationAbort where
  
  toException :: SimulationAbort -> SomeException
toException = forall e. Exception e => e -> SomeException
toException forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> SimulationException
SimulationException
  fromException :: SomeException -> Maybe SimulationAbort
fromException SomeException
x = do { SimulationException e
a <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x; forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
a }

instance Exception SimulationRetry where
  
  toException :: SimulationRetry -> SomeException
toException = forall e. Exception e => e -> SomeException
toException forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> SimulationException
SimulationException
  fromException :: SomeException -> Maybe SimulationRetry
fromException SomeException
x = do { SimulationException e
a <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x; forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
a }