Simulation.hs

{-# 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
  return  = returnS
  m >>= k = bindS m k

returnS :: a -> Simulation a
{-# INLINE returnS #-}
returnS a = Simulation (\r -> return a)

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

-- | Run the simulation using the specified specs.
runSimulation :: Simulation a -> Specs -> IO a
runSimulation (Simulation m) sc =
  do q <- newEventQueue sc
     g <- newGenerator $ spcGeneratorType sc
     m Run { runSpecs = sc,
             runIndex = 1,
             runCount = 1,
             runEventQueue = q,
             runGenerator = 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 (Simulation m) sc runs index =
  do q <- newEventQueue sc
     g <- newGenerator $ spcGeneratorType sc
     m Run { runSpecs = sc,
             runIndex = index,
             runCount = runs,
             runEventQueue = q,
             runGenerator = 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 (Simulation m) sc runs = map f [1 .. runs]
  where f i = do q <- newEventQueue sc
                 g <- newGenerator $ spcGeneratorType sc
                 m Run { runSpecs = sc,
                         runIndex = i,
                         runCount = runs,
                         runEventQueue = q,
                         runGenerator = g }

-- | Return the event queue.
simulationEventQueue :: Simulation EventQueue
simulationEventQueue = Simulation $ return . runEventQueue

instance Functor Simulation where
  fmap = liftMS

instance Applicative Simulation where
  pure = return
  (<*>) = ap

instance MonadFail Simulation where
  fail = error

liftMS :: (a -> b) -> Simulation a -> Simulation b
{-# INLINE liftMS #-}
liftMS f (Simulation x) =
  Simulation $ \r -> do { a <- x r; return $ f a }

instance MonadIO Simulation where
  liftIO m = Simulation $ const 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 = id

instance ParameterLift Simulation where
  liftParameter = liftPS

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

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

-- | Runs an action with asynchronous exceptions disabled.
maskSimulation :: ((forall a. Simulation a -> Simulation a) -> Simulation b) -> Simulation b
maskSimulation a =
  Simulation $ \r ->
  MC.mask $ \u ->
  invokeSimulation r (a $ q u)
  where q u (Simulation b) = Simulation (u . b)

-- | Like 'maskSimulation', but the masked computation is not interruptible.
uninterruptibleMaskSimulation :: ((forall a. Simulation a -> Simulation a) -> Simulation b) -> Simulation b
uninterruptibleMaskSimulation a =
  Simulation $ \r ->
  MC.uninterruptibleMask $ \u ->
  invokeSimulation r (a $ q u)
  where q u (Simulation b) = Simulation (u . b)

-- | An implementation of 'generalBracket'.
generalBracketSimulation :: Simulation a
                            -> (a -> MC.ExitCase b -> Simulation c)
                            -> (a -> Simulation b)
                            -> Simulation (b, c)
generalBracketSimulation acquire release use =
  Simulation $ \r -> do
    MC.generalBracket
      (invokeSimulation r acquire)
      (\resource e -> invokeSimulation r $ release resource e)
      (\resource -> invokeSimulation r $ use resource)

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

instance MonadFix Simulation where
  mfix f = 
    Simulation $ \r ->
    do { rec { a <- invokeSimulation r (f a) }; return a }  

instance MC.MonadThrow Simulation where
  throwM = throwSimulation

instance MC.MonadCatch Simulation where
  catch = catchSimulation

instance MC.MonadMask Simulation where
  mask = maskSimulation
  uninterruptibleMask = uninterruptibleMaskSimulation
  generalBracket = generalBracketSimulation

-- | Memoize the 'Simulation' computation, always returning the same value
-- within a simulation run.
memoSimulation :: Simulation a -> Simulation (Simulation a)
memoSimulation m =
  do ref <- liftIO $ newIORef Nothing
     return $ Simulation $ \r ->
       do x <- readIORef ref
          case x of
            Just v -> return v
            Nothing ->
              do v <- invokeSimulation r m
                 writeIORef ref (Just v)
                 return 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 e) = show e

instance Exception SimulationException

-- | An exception that signals of aborting the simulation.
data SimulationAbort = SimulationAbort String
                       -- ^ The exception to abort the simulation.
                     deriving (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 (Show, Typeable)

instance Exception SimulationAbort where
  
  toException = toException . SimulationException
  fromException x = do { SimulationException a <- fromException x; cast a }

instance Exception SimulationRetry where
  
  toException = toException . SimulationException
  fromException x = do { SimulationException a <- fromException x; cast a }