module Simulation.Aivika.Internal.Cont
(Cont(..),
ContParams,
invokeCont,
runCont,
catchCont,
finallyCont,
throwCont,
resumeCont,
contCanceled) 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.Internal.Specs
import Simulation.Aivika.Internal.Simulation
import Simulation.Aivika.Internal.Dynamics
import Simulation.Aivika.Internal.Event
newtype Cont a = Cont (ContParams a -> Event ())
data ContParams a =
ContParams { contCont :: a -> Event (),
contAux :: ContParamsAux }
data ContParamsAux =
ContParamsAux { contECont :: IOException -> Event (),
contCCont :: () -> Event (),
contCancelToken :: 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 EventLift Cont where
liftEvent = liftEC
instance Functor Cont where
fmap = liftM
instance MonadIO Cont where
liftIO = liftIOC
invokeCont :: ContParams a -> Cont a -> Event ()
invokeCont p (Cont m) = m p
cancelCont :: Point -> ContParams a -> IO ()
cancelCont p c =
do writeIORef (contCancelToken $ contAux c) False
invokeEvent p $ (contCCont $ contAux c) ()
returnC :: a -> Cont a
returnC a =
Cont $ \c ->
Event $ \p ->
do z <- contCanceled c
if z
then cancelCont p c
else invokeEvent 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 -> Event ()
bindWithoutCatch (Cont m) k c =
Event $ \p ->
do z <- contCanceled c
if z
then cancelCont p c
else invokeEvent p $ m $
let cont a = invokeCont c (k a)
in c { contCont = cont }
bindWithCatch :: Cont a -> (a -> Cont b) -> ContParams b -> Event ()
bindWithCatch (Cont m) k c =
Event $ \p ->
do z <- contCanceled c
if z
then cancelCont p c
else invokeEvent p $ m $
let cont a = catchEvent
(invokeCont c (k a))
(contECont $ contAux c)
in c { contCont = cont }
callWithoutCatch :: (a -> Cont b) -> a -> ContParams b -> Event ()
callWithoutCatch k a c =
Event $ \p ->
do z <- contCanceled c
if z
then cancelCont p c
else invokeEvent p $ invokeCont c (k a)
callWithCatch :: (a -> Cont b) -> a -> ContParams b -> Event ()
callWithCatch k a c =
Event $ \p ->
do z <- contCanceled c
if z
then cancelCont p c
else invokeEvent p $ catchEvent
(invokeCont c (k a))
(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 -> Event ()
catchWithCatch (Cont m) h c =
Event $ \p ->
do z <- contCanceled c
if z
then cancelCont p c
else invokeEvent 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 -> Event ()
finallyWithCatch (Cont m) (Cont m') c =
Event $ \p ->
do z <- contCanceled c
if z
then cancelCont p c
else invokeEvent p $ m $
let cont a =
Event $ \p ->
invokeEvent p $ m' $
let cont b = contCont c a
in c { contCont = cont }
econt e =
Event $ \p ->
invokeEvent p $ m' $
let cont b = (contECont . contAux $ c) e
in c { contCont = cont }
ccont () =
Event $ \p ->
invokeEvent 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 -> Event ())
-> (IOError -> Event ())
-> (() -> Event ())
-> IORef Bool
-> Bool
-> Event ()
runCont (Cont m) cont econt ccont cancelToken catchFlag =
m ContParams { contCont = cont,
contAux =
ContParamsAux { contECont = econt,
contCCont = ccont,
contCancelToken = cancelToken,
contCatchFlag = catchFlag } }
liftSC :: Simulation a -> Cont a
liftSC (Simulation m) =
Cont $ \c ->
Event $ \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 ->
Event $ \p ->
if contCatchFlag . contAux $ c
then liftIOWithCatch (m p) p c
else liftIOWithoutCatch (m p) p c
liftEC :: Event a -> Cont a
liftEC (Event m) =
Cont $ \c ->
Event $ \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 ->
Event $ \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 <- contCanceled c
if z
then cancelCont p c
else do a <- m
invokeEvent p $ contCont c a
liftIOWithCatch :: IO a -> Point -> ContParams a -> IO ()
liftIOWithCatch m p c =
do z <- contCanceled c
if z
then cancelCont 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
invokeEvent p $ contCont c a
Just e ->
invokeEvent p $ (contECont . contAux) c e
resumeCont :: ContParams a -> a -> Event ()
resumeCont c a =
Event $ \p ->
do z <- contCanceled c
if z
then cancelCont p c
else invokeEvent p $ contCont c a
contCanceled :: ContParams a -> IO Bool
contCanceled c = readIORef $ contCancelToken $ contAux c