module Simulation.Aivika.Internal.Process
(ProcessId,
Process(..),
invokeProcess,
runProcess,
runProcessInStartTime,
runProcessInStopTime,
enqueueProcess,
enqueueProcessWithStartTime,
enqueueProcessWithStopTime,
newProcessId,
newProcessIdWithCatch,
holdProcess,
interruptProcess,
processInterrupted,
passivateProcess,
processPassive,
reactivateProcess,
processId,
cancelProcess,
processCanceled,
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.Internal.Specs
import Simulation.Aivika.Internal.Simulation
import Simulation.Aivika.Internal.Dynamics
import Simulation.Aivika.Internal.Event
import Simulation.Aivika.Internal.Cont
data ProcessId =
ProcessId { 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)
invokeProcess :: ProcessId -> Process a -> Cont a
invokeProcess pid (Process m) = m pid
holdProcess :: Double -> Process ()
holdProcess dt =
Process $ \pid ->
Cont $ \c ->
Event $ \p ->
do let x = processInterruptCont pid
writeIORef x $ Just c
writeIORef (processInterruptRef pid) False
v <- readIORef (processInterruptVersion pid)
invokeEvent p $
enqueueEvent (pointTime p + dt) $
Event $ \p ->
do v' <- readIORef (processInterruptVersion pid)
when (v == v') $
do writeIORef x Nothing
invokeEvent p $ resumeCont c ()
interruptProcess :: ProcessId -> Event ()
interruptProcess pid =
Event $ \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
invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c ()
processInterrupted :: ProcessId -> Event Bool
processInterrupted pid =
Event $ \p ->
readIORef (processInterruptRef pid)
passivateProcess :: Process ()
passivateProcess =
Process $ \pid ->
Cont $ \c ->
Event $ \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 -> Event Bool
processPassive pid =
Event $ \p ->
do let x = processReactCont pid
a <- readIORef x
return $ isJust a
reactivateProcess :: ProcessId -> Event ()
reactivateProcess pid =
Event $ \p ->
do let x = processReactCont pid
a <- readIORef x
case a of
Nothing ->
return ()
Just c ->
do writeIORef x Nothing
invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c ()
runProcess :: ProcessId -> Process () -> Event ()
runProcess pid p =
runCont m cont econt ccont (processCancelToken pid) (processCatchFlag pid)
where cont = return
econt = throwEvent
ccont = return
m = do y <- liftIO $ readIORef (processStarted pid)
if y
then error $
"Another process with this identifier " ++
"has been started already: runProcess"
else liftIO $ writeIORef (processStarted pid) True
invokeProcess pid p
runProcessInStartTime :: EventProcessing -> ProcessId -> Process () -> Simulation ()
runProcessInStartTime processing pid p =
runEventInStartTime processing $ runProcess pid p
runProcessInStopTime :: EventProcessing -> ProcessId -> Process () -> Simulation ()
runProcessInStopTime processing pid p =
runEventInStopTime processing $ runProcess pid p
enqueueProcess :: Double -> ProcessId -> Process () -> Event ()
enqueueProcess t pid p =
enqueueEvent t $ runProcess pid p
enqueueProcessWithStartTime :: ProcessId -> Process () -> Event ()
enqueueProcessWithStartTime pid p =
enqueueEventWithStartTime $ runProcess pid p
enqueueProcessWithStopTime :: ProcessId -> Process () -> Event ()
enqueueProcessWithStopTime pid p =
enqueueEventWithStopTime $ runProcess pid p
processId :: Process ProcessId
processId = Process return
newProcessId :: Simulation ProcessId
newProcessId =
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 { processStarted = y,
processCatchFlag = False,
processReactCont = x,
processCancelRef = c,
processCancelToken = t,
processInterruptRef = i,
processInterruptCont = z,
processInterruptVersion = v }
newProcessIdWithCatch :: Simulation ProcessId
newProcessIdWithCatch =
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 { processStarted = y,
processCatchFlag = True,
processReactCont = x,
processCancelRef = c,
processCancelToken = t,
processInterruptRef = i,
processInterruptCont = z,
processInterruptVersion = v }
cancelProcess :: ProcessId -> Event ()
cancelProcess pid =
Event $ \p ->
do z <- readIORef (processCancelRef pid)
unless z $
do writeIORef (processCancelRef pid) True
writeIORef (processCancelToken pid) True
processCanceled :: ProcessId -> Event Bool
processCanceled pid =
Event $ \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 EventLift Process where
liftEvent = liftEP
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
liftEP :: Event a -> Process a
liftEP m = Process $ \pid -> liftEvent 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