module Simulation.Aivika.Dynamics.Internal.Process
(ProcessID,
Process(..),
processQueue,
newProcessID,
newProcessIDWithCatch,
holdProcess,
interruptProcess,
processInterrupted,
passivateProcess,
processPassive,
reactivateProcess,
processID,
cancelProcess,
processCanceled,
runProcess,
runProcessNow,
catchProcess,
finallyProcess,
throwProcess) where
import Data.Maybe
import Data.IORef
import Control.Exception (IOException, throw)
import Control.Monad
import Control.Monad.Trans
import Simulation.Aivika.Dynamics.Internal.Simulation
import Simulation.Aivika.Dynamics.Internal.Dynamics
import Simulation.Aivika.Dynamics.Internal.Cont
import Simulation.Aivika.Dynamics.EventQueue
data ProcessID =
ProcessID { processQueue :: EventQueue,
processStarted :: IORef Bool,
processCatchFlag :: Bool,
processReactCont :: IORef (Maybe (ContParams ())),
processCancelRef :: IORef Bool,
processCancelToken :: IORef Bool,
processInterruptRef :: IORef Bool,
processInterruptCont :: IORef (Maybe (ContParams ())),
processInterruptVersion :: IORef Int }
newtype Process a = Process (ProcessID -> Cont a)
holdProcess :: Double -> Process ()
holdProcess dt =
Process $ \pid ->
Cont $ \c ->
Dynamics $ \p ->
do let x = processInterruptCont pid
writeIORef x $ Just c
writeIORef (processInterruptRef pid) False
v <- readIORef (processInterruptVersion pid)
let Dynamics m =
enqueue (processQueue pid) (pointTime p + dt) $
Dynamics $ \p ->
do v' <- readIORef (processInterruptVersion pid)
when (v == v') $
do writeIORef x Nothing
let Dynamics m = resumeContByParams c ()
m p
m p
interruptProcess :: ProcessID -> Dynamics ()
interruptProcess pid =
Dynamics $ \p ->
do let x = processInterruptCont pid
a <- readIORef x
case a of
Nothing -> return ()
Just c ->
do writeIORef x Nothing
writeIORef (processInterruptRef pid) True
modifyIORef (processInterruptVersion pid) $ (+) 1
let Dynamics m =
enqueue (processQueue pid) (pointTime p) $
resumeContByParams c ()
m p
processInterrupted :: ProcessID -> Dynamics Bool
processInterrupted pid =
Dynamics $ \p ->
readIORef (processInterruptRef pid)
passivateProcess :: Process ()
passivateProcess =
Process $ \pid ->
Cont $ \c ->
Dynamics $ \p ->
do let x = processReactCont pid
a <- readIORef x
case a of
Nothing -> writeIORef x $ Just c
Just _ -> error "Cannot passivate the process twice: passivate"
processPassive :: ProcessID -> Dynamics Bool
processPassive pid =
Dynamics $ \p ->
do let Dynamics m = runQueueSync $ processQueue pid
m p
let x = processReactCont pid
a <- readIORef x
return $ isJust a
reactivateProcess :: ProcessID -> Dynamics ()
reactivateProcess pid =
Dynamics $ \p ->
do let Dynamics m = runQueueSync $ processQueue pid
m p
let x = processReactCont pid
a <- readIORef x
case a of
Nothing ->
return ()
Just c ->
do writeIORef x Nothing
let Dynamics m = enqueue (processQueue pid) (pointTime p) $
resumeContByParams c ()
m p
runProcess :: Process () -> ProcessID -> Double -> Dynamics ()
runProcess (Process p) pid t =
runCont m cont econt ccont (processCancelToken pid) (processCatchFlag pid)
where cont = return
econt = throw
ccont = return
m = do y <- liftIO $ readIORef (processStarted pid)
if y
then error $
"A process with such ID " ++
"has been started already: runProc"
else liftIO $ writeIORef (processStarted pid) True
Cont $ \c -> enqueue (processQueue pid) t $
resumeContByParams c ()
p pid
runProcessNow :: Process () -> ProcessID -> Dynamics ()
runProcessNow process pid =
Dynamics $ \p ->
do let Dynamics m = runProcess process pid (pointTime p)
m p
processID :: Process ProcessID
processID = Process $ \pid -> return pid
newProcessID :: EventQueue -> Simulation ProcessID
newProcessID q =
do x <- liftIO $ newIORef Nothing
y <- liftIO $ newIORef False
c <- liftIO $ newIORef False
t <- liftIO $ newIORef False
i <- liftIO $ newIORef False
z <- liftIO $ newIORef Nothing
v <- liftIO $ newIORef 0
return ProcessID { processQueue = q,
processStarted = y,
processCatchFlag = False,
processReactCont = x,
processCancelRef = c,
processCancelToken = t,
processInterruptRef = i,
processInterruptCont = z,
processInterruptVersion = v }
newProcessIDWithCatch :: EventQueue -> Simulation ProcessID
newProcessIDWithCatch q =
do x <- liftIO $ newIORef Nothing
y <- liftIO $ newIORef False
c <- liftIO $ newIORef False
t <- liftIO $ newIORef False
i <- liftIO $ newIORef False
z <- liftIO $ newIORef Nothing
v <- liftIO $ newIORef 0
return ProcessID { processQueue = q,
processStarted = y,
processCatchFlag = True,
processReactCont = x,
processCancelRef = c,
processCancelToken = t,
processInterruptRef = i,
processInterruptCont = z,
processInterruptVersion = v }
cancelProcess :: ProcessID -> Dynamics ()
cancelProcess pid =
Dynamics $ \p ->
do z <- readIORef (processCancelRef pid)
unless z $
do writeIORef (processCancelRef pid) True
writeIORef (processCancelToken pid) True
processCanceled :: ProcessID -> Dynamics Bool
processCanceled pid =
Dynamics $ \p ->
readIORef (processCancelRef pid)
instance Eq ProcessID where
x == y = processReactCont x == processReactCont y
instance Monad Process where
return = returnP
m >>= k = bindP m k
instance Functor Process where
fmap = liftM
instance SimulationLift Process where
liftSimulation = liftSP
instance DynamicsLift Process where
liftDynamics = liftDP
instance MonadIO Process where
liftIO = liftIOP
returnP :: a -> Process a
returnP a = Process $ \pid -> return a
bindP :: Process a -> (a -> Process b) -> Process b
bindP (Process m) k =
Process $ \pid ->
do a <- m pid
let Process m' = k a
m' pid
liftSP :: Simulation a -> Process a
liftSP m = Process $ \pid -> liftSimulation m
liftDP :: Dynamics a -> Process a
liftDP m = Process $ \pid -> liftDynamics m
liftIOP :: IO a -> Process a
liftIOP m = Process $ \pid -> liftIO m
catchProcess :: Process a -> (IOException -> Process a) -> Process a
catchProcess (Process m) h =
Process $ \pid ->
catchCont (m pid) $ \e ->
let Process m' = h e in m' pid
finallyProcess :: Process a -> Process b -> Process a
finallyProcess (Process m) (Process m') =
Process $ \pid ->
finallyCont (m pid) (m' pid)
throwProcess :: IOException -> Process a
throwProcess = liftIO . throw