module Simulation.Aivika.Dynamics.Internal.Cont
(Cont(..),
ContParams,
runCont,
catchCont,
finallyCont,
throwCont,
resumeContByParams,
contParamsCanceled) where
import Data.IORef
import qualified Control.Exception as C
import Control.Exception (IOException, throw)
import Control.Monad
import Control.Monad.Trans
import Simulation.Aivika.Dynamics.Internal.Simulation
import Simulation.Aivika.Dynamics.Internal.Dynamics
newtype Cont a = Cont (ContParams a -> Dynamics ())
data ContParams a =
ContParams { contCont :: a -> Dynamics (),
contAux :: ContParamsAux }
data ContParamsAux =
ContParamsAux { contECont :: IOException -> Dynamics (),
contCCont :: () -> Dynamics (),
contCancelRef :: IORef Bool,
contCatchFlag :: Bool }
instance Monad Cont where
return = returnC
m >>= k = bindC m k
instance SimulationLift Cont where
liftSimulation = liftSC
instance DynamicsLift Cont where
liftDynamics = liftDC
instance Functor Cont where
fmap = liftM
instance MonadIO Cont where
liftIO = liftIOC
invokeC :: Cont a -> ContParams a -> Dynamics ()
invokeC (Cont m) = m
invokeD :: Point -> Dynamics a -> IO a
invokeD p (Dynamics m) = m p
cancelD :: Point -> ContParams a -> IO ()
cancelD p c =
do writeIORef (contCancelRef . contAux $ c) False
invokeD p $ (contCCont . contAux $ c) ()
returnC :: a -> Cont a
returnC a =
Cont $ \c ->
Dynamics $ \p ->
do z <- readIORef $ (contCancelRef . contAux) c
if z
then cancelD p c
else invokeD p $ contCont c a
bindC :: Cont a -> (a -> Cont b) -> Cont b
bindC m k =
Cont $ bindWithoutCatch m k
bindWithoutCatch :: Cont a -> (a -> Cont b) -> ContParams b -> Dynamics ()
bindWithoutCatch (Cont m) k c =
Dynamics $ \p ->
do z <- readIORef $ (contCancelRef . contAux) c
if z
then cancelD p c
else invokeD p $ m $
let cont a = invokeC (k a) c
in c { contCont = cont }
bindWithCatch :: Cont a -> (a -> Cont b) -> ContParams b -> Dynamics ()
bindWithCatch (Cont m) k c =
Dynamics $ \p ->
do z <- readIORef $ (contCancelRef . contAux) c
if z
then cancelD p c
else invokeD p $ m $
let cont a = catchDynamics
(invokeC (k a) c)
(contECont . contAux $ c)
in c { contCont = cont }
callWithoutCatch :: (a -> Cont b) -> a -> ContParams b -> Dynamics ()
callWithoutCatch k a c =
Dynamics $ \p ->
do z <- readIORef $ (contCancelRef . contAux) c
if z
then cancelD p c
else invokeD p $ invokeC (k a) c
callWithCatch :: (a -> Cont b) -> a -> ContParams b -> Dynamics ()
callWithCatch k a c =
Dynamics $ \p ->
do z <- readIORef $ (contCancelRef . contAux) c
if z
then cancelD p c
else invokeD p $ catchDynamics
(invokeC (k a) c)
(contECont . contAux $ c)
catchCont :: Cont a -> (IOException -> Cont a) -> Cont a
catchCont m h =
Cont $ \c ->
if contCatchFlag . contAux $ c
then catchWithCatch m h c
else error $
"To catch exceptions, the process must be created " ++
"with help of newProcessIDWithCatch: catchCont."
catchWithCatch :: Cont a -> (IOException -> Cont a) -> ContParams a -> Dynamics ()
catchWithCatch (Cont m) h c =
Dynamics $ \p ->
do z <- readIORef $ (contCancelRef . contAux) c
if z
then cancelD p c
else invokeD p $ m $
let econt e = callWithoutCatch h e c
in c { contAux = (contAux c) { contECont = econt } }
finallyCont :: Cont a -> Cont b -> Cont a
finallyCont m m' =
Cont $ \c ->
if contCatchFlag . contAux $ c
then finallyWithCatch m m' c
else error $
"To finalize computation, the process must be created " ++
"with help of newProcessIDWithCatch: finallyCont."
finallyWithCatch :: Cont a -> Cont b -> ContParams a -> Dynamics ()
finallyWithCatch (Cont m) (Cont m') c =
Dynamics $ \p ->
do z <- readIORef $ (contCancelRef . contAux) c
if z
then cancelD p c
else invokeD p $ m $
let cont a =
Dynamics $ \p ->
invokeD p $ m' $
let cont b = contCont c a
in c { contCont = cont }
econt e =
Dynamics $ \p ->
invokeD p $ m' $
let cont b = (contECont . contAux $ c) e
in c { contCont = cont }
ccont () =
Dynamics $ \p ->
invokeD p $ m' $
let cont b = (contCCont . contAux $ c) ()
econt e = (contCCont . contAux $ c) ()
in c { contCont = cont,
contAux = (contAux c) { contECont = econt } }
in c { contCont = cont,
contAux = (contAux c) { contECont = econt,
contCCont = ccont } }
throwCont :: IOException -> Cont a
throwCont e = liftIO $ throw e
runCont :: Cont a ->
(a -> Dynamics ()) ->
(IOError -> Dynamics ()) ->
(() -> Dynamics ()) ->
IORef Bool ->
Bool ->
Dynamics ()
runCont (Cont m) cont econt ccont cancelToken catchFlag =
m ContParams { contCont = cont,
contAux =
ContParamsAux { contECont = econt,
contCCont = ccont,
contCancelRef = cancelToken,
contCatchFlag = catchFlag } }
liftSC :: Simulation a -> Cont a
liftSC (Simulation m) =
Cont $ \c ->
Dynamics $ \p ->
if contCatchFlag . contAux $ c
then liftIOWithCatch (m $ pointRun p) p c
else liftIOWithoutCatch (m $ pointRun p) p c
liftDC :: Dynamics a -> Cont a
liftDC (Dynamics m) =
Cont $ \c ->
Dynamics $ \p ->
if contCatchFlag . contAux $ c
then liftIOWithCatch (m p) p c
else liftIOWithoutCatch (m p) p c
liftIOC :: IO a -> Cont a
liftIOC m =
Cont $ \c ->
Dynamics $ \p ->
if contCatchFlag . contAux $ c
then liftIOWithCatch m p c
else liftIOWithoutCatch m p c
liftIOWithoutCatch :: IO a -> Point -> ContParams a -> IO ()
liftIOWithoutCatch m p c =
do z <- readIORef $ (contCancelRef . contAux) c
if z
then cancelD p c
else do a <- m
invokeD p $ contCont c a
liftIOWithCatch :: IO a -> Point -> ContParams a -> IO ()
liftIOWithCatch m p c =
do z <- readIORef $ (contCancelRef . contAux) c
if z
then cancelD p c
else do aref <- newIORef undefined
eref <- newIORef Nothing
C.catch (m >>= writeIORef aref)
(writeIORef eref . Just)
e <- readIORef eref
case e of
Nothing ->
do a <- readIORef aref
invokeD p $ contCont c a
Just e ->
invokeD p $ (contECont . contAux) c e
resumeContByParams :: ContParams a -> a -> Dynamics ()
resumeContByParams c a =
Dynamics $ \p ->
do z <- readIORef $ (contCancelRef . contAux) c
if z
then cancelD p c
else invokeD p $ contCont c a
contParamsCanceled :: ContParams a -> IO Bool
contParamsCanceled c =
readIORef $ (contCancelRef . contAux) c