{-# 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 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

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 }