{-# LANGUAGE RecursiveDo, ExistentialQuantification, DeriveDataTypeable, RankNTypes #-}
module Simulation.Aivika.Internal.Simulation
(
Simulation(..),
SimulationLift(..),
invokeSimulation,
runSimulation,
runSimulations,
runSimulationByIndex,
catchSimulation,
finallySimulation,
throwSimulation,
simulationEventQueue,
memoSimulation,
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
newtype Simulation a = Simulation (Run -> IO a)
instance Monad Simulation where
return :: a -> Simulation a
return = a -> Simulation a
forall a. a -> Simulation a
returnS
Simulation a
m >>= :: Simulation a -> (a -> Simulation b) -> Simulation b
>>= a -> Simulation b
k = Simulation a -> (a -> Simulation b) -> Simulation b
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 :: a -> Simulation a
returnS a
a = (Run -> IO a) -> Simulation a
forall a. (Run -> IO a) -> Simulation a
Simulation (\Run
r -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a)
bindS :: Simulation a -> (a -> Simulation b) -> Simulation b
{-# INLINE bindS #-}
bindS :: Simulation a -> (a -> Simulation b) -> Simulation b
bindS (Simulation Run -> IO a
m) a -> Simulation b
k =
(Run -> IO b) -> Simulation b
forall a. (Run -> IO a) -> Simulation a
Simulation ((Run -> IO b) -> Simulation b) -> (Run -> IO b) -> Simulation b
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
runSimulation :: Simulation a -> Specs -> IO a
runSimulation :: 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 (GeneratorType -> IO Generator) -> GeneratorType -> IO Generator
forall a b. (a -> b) -> a -> b
$ Specs -> GeneratorType
spcGeneratorType Specs
sc
Run -> IO a
m Run :: Specs -> Int -> Int -> EventQueue -> Generator -> Run
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 }
runSimulationByIndex :: Simulation a
-> Specs
-> Int
-> Int
-> IO a
runSimulationByIndex :: 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 (GeneratorType -> IO Generator) -> GeneratorType -> IO Generator
forall a b. (a -> b) -> a -> b
$ Specs -> GeneratorType
spcGeneratorType Specs
sc
Run -> IO a
m Run :: Specs -> Int -> Int -> EventQueue -> Generator -> Run
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 }
runSimulations :: Simulation a -> Specs -> Int -> [IO a]
runSimulations :: Simulation a -> Specs -> Int -> [IO a]
runSimulations (Simulation Run -> IO a
m) Specs
sc Int
runs = (Int -> IO a) -> [Int] -> [IO a]
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 (GeneratorType -> IO Generator) -> GeneratorType -> IO Generator
forall a b. (a -> b) -> a -> b
$ Specs -> GeneratorType
spcGeneratorType Specs
sc
Run -> IO a
m Run :: Specs -> Int -> Int -> EventQueue -> Generator -> Run
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 }
simulationEventQueue :: Simulation EventQueue
simulationEventQueue :: Simulation EventQueue
simulationEventQueue = (Run -> IO EventQueue) -> Simulation EventQueue
forall a. (Run -> IO a) -> Simulation a
Simulation ((Run -> IO EventQueue) -> Simulation EventQueue)
-> (Run -> IO EventQueue) -> Simulation EventQueue
forall a b. (a -> b) -> a -> b
$ EventQueue -> IO EventQueue
forall (m :: * -> *) a. Monad m => a -> m a
return (EventQueue -> IO EventQueue)
-> (Run -> EventQueue) -> Run -> IO EventQueue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> EventQueue
runEventQueue
instance Functor Simulation where
fmap :: (a -> b) -> Simulation a -> Simulation b
fmap = (a -> b) -> Simulation a -> Simulation b
forall a b. (a -> b) -> Simulation a -> Simulation b
liftMS
instance Applicative Simulation where
pure :: a -> Simulation a
pure = a -> Simulation a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: Simulation (a -> b) -> Simulation a -> Simulation 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 :: String -> Simulation a
fail = String -> Simulation a
forall a. HasCallStack => String -> a
error
liftMS :: (a -> b) -> Simulation a -> Simulation b
{-# INLINE liftMS #-}
liftMS :: (a -> b) -> Simulation a -> Simulation b
liftMS a -> b
f (Simulation Run -> IO a
x) =
(Run -> IO b) -> Simulation b
forall a. (Run -> IO a) -> Simulation a
Simulation ((Run -> IO b) -> Simulation b) -> (Run -> IO b) -> Simulation b
forall a b. (a -> b) -> a -> b
$ \Run
r -> do { a
a <- Run -> IO a
x Run
r; b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> IO b) -> b -> IO b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a }
instance MonadIO Simulation where
liftIO :: IO a -> Simulation a
liftIO IO a
m = (Run -> IO a) -> Simulation a
forall a. (Run -> IO a) -> Simulation a
Simulation ((Run -> IO a) -> Simulation a) -> (Run -> IO a) -> Simulation a
forall a b. (a -> b) -> a -> b
$ IO a -> Run -> IO a
forall a b. a -> b -> a
const IO a
m
class SimulationLift m where
liftSimulation :: Simulation a -> m a
instance SimulationLift Simulation where
liftSimulation :: Simulation a -> Simulation a
liftSimulation = Simulation a -> Simulation a
forall a. a -> a
id
instance ParameterLift Simulation where
liftParameter :: Parameter a -> Simulation a
liftParameter = Parameter a -> Simulation a
forall a. Parameter a -> Simulation a
liftPS
liftPS :: Parameter a -> Simulation a
{-# INLINE liftPS #-}
liftPS :: Parameter a -> Simulation a
liftPS (Parameter Run -> IO a
x) =
(Run -> IO a) -> Simulation a
forall a. (Run -> IO a) -> Simulation a
Simulation Run -> IO a
x
catchSimulation :: Exception e => Simulation a -> (e -> Simulation a) -> Simulation a
catchSimulation :: Simulation a -> (e -> Simulation a) -> Simulation a
catchSimulation (Simulation Run -> IO a
m) e -> Simulation a
h =
(Run -> IO a) -> Simulation a
forall a. (Run -> IO a) -> Simulation a
Simulation ((Run -> IO a) -> Simulation a) -> (Run -> IO a) -> Simulation a
forall a b. (a -> b) -> a -> b
$ \Run
r ->
IO a -> (e -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Run -> IO a
m Run
r) ((e -> IO a) -> IO a) -> (e -> IO a) -> IO a
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
finallySimulation :: Simulation a -> Simulation b -> Simulation a
finallySimulation :: Simulation a -> Simulation b -> Simulation a
finallySimulation (Simulation Run -> IO a
m) (Simulation Run -> IO b
m') =
(Run -> IO a) -> Simulation a
forall a. (Run -> IO a) -> Simulation a
Simulation ((Run -> IO a) -> Simulation a) -> (Run -> IO a) -> Simulation a
forall a b. (a -> b) -> a -> b
$ \Run
r ->
IO a -> IO b -> IO a
forall a b. IO a -> IO b -> IO a
finally (Run -> IO a
m Run
r) (Run -> IO b
m' Run
r)
throwSimulation :: Exception e => e -> Simulation a
throwSimulation :: e -> Simulation a
throwSimulation = e -> Simulation a
forall a e. Exception e => e -> a
throw
maskSimulation :: ((forall a. Simulation a -> Simulation a) -> Simulation b) -> Simulation b
maskSimulation :: ((forall a. Simulation a -> Simulation a) -> Simulation b)
-> Simulation b
maskSimulation (forall a. Simulation a -> Simulation a) -> Simulation b
a =
(Run -> IO b) -> Simulation b
forall a. (Run -> IO a) -> Simulation a
Simulation ((Run -> IO b) -> Simulation b) -> (Run -> IO b) -> Simulation b
forall a b. (a -> b) -> a -> b
$ \Run
r ->
((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MC.mask (((forall a. IO a -> IO a) -> IO b) -> IO b)
-> ((forall a. IO a -> IO a) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
u ->
Run -> Simulation b -> IO b
forall a. Run -> Simulation a -> IO a
invokeSimulation Run
r ((forall a. Simulation a -> Simulation a) -> Simulation b
a ((forall a. Simulation a -> Simulation a) -> Simulation b)
-> (forall a. Simulation a -> Simulation a) -> Simulation b
forall a b. (a -> b) -> a -> b
$ (IO a -> IO a) -> Simulation a -> Simulation a
forall a a. (IO a -> IO a) -> Simulation a -> Simulation a
q IO a -> IO a
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) = (Run -> IO a) -> Simulation a
forall a. (Run -> IO a) -> Simulation a
Simulation (IO a -> IO a
u (IO a -> IO a) -> (Run -> IO a) -> Run -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> IO a
b)
uninterruptibleMaskSimulation :: ((forall a. Simulation a -> Simulation a) -> Simulation b) -> Simulation b
uninterruptibleMaskSimulation :: ((forall a. Simulation a -> Simulation a) -> Simulation b)
-> Simulation b
uninterruptibleMaskSimulation (forall a. Simulation a -> Simulation a) -> Simulation b
a =
(Run -> IO b) -> Simulation b
forall a. (Run -> IO a) -> Simulation a
Simulation ((Run -> IO b) -> Simulation b) -> (Run -> IO b) -> Simulation b
forall a b. (a -> b) -> a -> b
$ \Run
r ->
((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MC.uninterruptibleMask (((forall a. IO a -> IO a) -> IO b) -> IO b)
-> ((forall a. IO a -> IO a) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
u ->
Run -> Simulation b -> IO b
forall a. Run -> Simulation a -> IO a
invokeSimulation Run
r ((forall a. Simulation a -> Simulation a) -> Simulation b
a ((forall a. Simulation a -> Simulation a) -> Simulation b)
-> (forall a. Simulation a -> Simulation a) -> Simulation b
forall a b. (a -> b) -> a -> b
$ (IO a -> IO a) -> Simulation a -> Simulation a
forall a a. (IO a -> IO a) -> Simulation a -> Simulation a
q IO a -> IO a
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) = (Run -> IO a) -> Simulation a
forall a. (Run -> IO a) -> Simulation a
Simulation (IO a -> IO a
u (IO a -> IO a) -> (Run -> IO a) -> Run -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Run -> IO a
b)
generalBracketSimulation :: Simulation a
-> (a -> MC.ExitCase b -> Simulation c)
-> (a -> Simulation b)
-> Simulation (b, c)
generalBracketSimulation :: 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 =
(Run -> IO (b, c)) -> Simulation (b, c)
forall a. (Run -> IO a) -> Simulation a
Simulation ((Run -> IO (b, c)) -> Simulation (b, c))
-> (Run -> IO (b, c)) -> Simulation (b, c)
forall a b. (a -> b) -> a -> b
$ \Run
r -> do
IO a -> (a -> ExitCase b -> IO c) -> (a -> IO b) -> IO (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 -> Simulation a -> IO a
forall a. Run -> Simulation a -> IO a
invokeSimulation Run
r Simulation a
acquire)
(\a
resource ExitCase b
e -> Run -> Simulation c -> IO c
forall a. Run -> Simulation a -> IO a
invokeSimulation Run
r (Simulation c -> IO c) -> Simulation c -> IO c
forall a b. (a -> b) -> a -> b
$ a -> ExitCase b -> Simulation c
release a
resource ExitCase b
e)
(\a
resource -> Run -> Simulation b -> IO b
forall a. Run -> Simulation a -> IO a
invokeSimulation Run
r (Simulation b -> IO b) -> Simulation b -> IO b
forall a b. (a -> b) -> a -> b
$ a -> Simulation b
use a
resource)
invokeSimulation :: Run -> Simulation a -> IO a
{-# INLINE invokeSimulation #-}
invokeSimulation :: Run -> Simulation a -> IO a
invokeSimulation Run
r (Simulation Run -> IO a
m) = Run -> IO a
m Run
r
instance MonadFix Simulation where
mfix :: (a -> Simulation a) -> Simulation a
mfix a -> Simulation a
f =
(Run -> IO a) -> Simulation a
forall a. (Run -> IO a) -> Simulation a
Simulation ((Run -> IO a) -> Simulation a) -> (Run -> IO a) -> Simulation a
forall a b. (a -> b) -> a -> b
$ \Run
r ->
do { rec { a
a <- Run -> Simulation a -> IO a
forall a. Run -> Simulation a -> IO a
invokeSimulation Run
r (a -> Simulation a
f a
a) }; a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a }
instance MC.MonadThrow Simulation where
throwM :: e -> Simulation a
throwM = e -> Simulation a
forall e a. Exception e => e -> Simulation a
throwSimulation
instance MC.MonadCatch Simulation where
catch :: Simulation a -> (e -> Simulation a) -> Simulation a
catch = Simulation a -> (e -> Simulation a) -> Simulation a
forall e a.
Exception e =>
Simulation a -> (e -> Simulation a) -> Simulation a
catchSimulation
instance MC.MonadMask Simulation where
mask :: ((forall a. Simulation a -> Simulation a) -> Simulation b)
-> Simulation b
mask = ((forall a. Simulation a -> Simulation a) -> Simulation b)
-> Simulation b
forall b.
((forall a. Simulation a -> Simulation a) -> Simulation b)
-> Simulation b
maskSimulation
uninterruptibleMask :: ((forall a. Simulation a -> Simulation a) -> Simulation b)
-> Simulation b
uninterruptibleMask = ((forall a. Simulation a -> Simulation a) -> Simulation b)
-> Simulation b
forall b.
((forall a. Simulation a -> Simulation a) -> Simulation b)
-> Simulation b
uninterruptibleMaskSimulation
generalBracket :: Simulation a
-> (a -> ExitCase b -> Simulation c)
-> (a -> Simulation b)
-> Simulation (b, c)
generalBracket = Simulation a
-> (a -> ExitCase b -> Simulation c)
-> (a -> Simulation b)
-> Simulation (b, c)
forall a b c.
Simulation a
-> (a -> ExitCase b -> Simulation c)
-> (a -> Simulation b)
-> Simulation (b, c)
generalBracketSimulation
memoSimulation :: Simulation a -> Simulation (Simulation a)
memoSimulation :: Simulation a -> Simulation (Simulation a)
memoSimulation Simulation a
m =
do IORef (Maybe a)
ref <- IO (IORef (Maybe a)) -> Simulation (IORef (Maybe a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Maybe a)) -> Simulation (IORef (Maybe a)))
-> IO (IORef (Maybe a)) -> Simulation (IORef (Maybe a))
forall a b. (a -> b) -> a -> b
$ Maybe a -> IO (IORef (Maybe a))
forall a. a -> IO (IORef a)
newIORef Maybe a
forall a. Maybe a
Nothing
Simulation a -> Simulation (Simulation a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Simulation a -> Simulation (Simulation a))
-> Simulation a -> Simulation (Simulation a)
forall a b. (a -> b) -> a -> b
$ (Run -> IO a) -> Simulation a
forall a. (Run -> IO a) -> Simulation a
Simulation ((Run -> IO a) -> Simulation a) -> (Run -> IO a) -> Simulation a
forall a b. (a -> b) -> a -> b
$ \Run
r ->
do Maybe a
x <- IORef (Maybe a) -> IO (Maybe a)
forall a. IORef a -> IO a
readIORef IORef (Maybe a)
ref
case Maybe a
x of
Just a
v -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
Maybe a
Nothing ->
do a
v <- Run -> Simulation a -> IO a
forall a. Run -> Simulation a -> IO a
invokeSimulation Run
r Simulation a
m
IORef (Maybe a) -> Maybe a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe a)
ref (a -> Maybe a
forall a. a -> Maybe a
Just a
v)
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
data SimulationException = forall e . Exception e => SimulationException e
deriving Typeable
instance Show SimulationException where
show :: SimulationException -> String
show (SimulationException e
e) = e -> String
forall a. Show a => a -> String
show e
e
instance Exception SimulationException
data SimulationAbort = SimulationAbort String
deriving (Int -> SimulationAbort -> ShowS
[SimulationAbort] -> ShowS
SimulationAbort -> String
(Int -> SimulationAbort -> ShowS)
-> (SimulationAbort -> String)
-> ([SimulationAbort] -> ShowS)
-> Show SimulationAbort
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)
data SimulationRetry = SimulationRetry String
deriving (Int -> SimulationRetry -> ShowS
[SimulationRetry] -> ShowS
SimulationRetry -> String
(Int -> SimulationRetry -> ShowS)
-> (SimulationRetry -> String)
-> ([SimulationRetry] -> ShowS)
-> Show SimulationRetry
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 = SimulationException -> SomeException
forall e. Exception e => e -> SomeException
toException (SimulationException -> SomeException)
-> (SimulationAbort -> SimulationException)
-> SimulationAbort
-> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimulationAbort -> SimulationException
forall e. Exception e => e -> SimulationException
SimulationException
fromException :: SomeException -> Maybe SimulationAbort
fromException SomeException
x = do { SimulationException e
a <- SomeException -> Maybe SimulationException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x; e -> Maybe SimulationAbort
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
a }
instance Exception SimulationRetry where
toException :: SimulationRetry -> SomeException
toException = SimulationException -> SomeException
forall e. Exception e => e -> SomeException
toException (SimulationException -> SomeException)
-> (SimulationRetry -> SimulationException)
-> SimulationRetry
-> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimulationRetry -> SimulationException
forall e. Exception e => e -> SimulationException
SimulationException
fromException :: SomeException -> Maybe SimulationRetry
fromException SomeException
x = do { SimulationException e
a <- SomeException -> Maybe SimulationException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x; e -> Maybe SimulationRetry
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
a }