{-# LANGUAGE ImplicitParams #-}
module Control.Eff.Concurrent.Process
(
Process(..)
, ProcessId(..)
, fromProcessId
, ConsProcess
, ResumeProcess(..)
, SchedulerProxy(..)
, HasScheduler
, getSchedulerProxy
, withSchedulerProxy
, thisSchedulerProxy
, ProcessState(..)
, yieldProcess
, sendMessage
, sendAnyMessage
, sendShutdown
, sendInterrupt
, makeReference
, receiveMessage
, receiveSelectedMessage
, flushMessages
, receiveAnyMessage
, receiveLoop
, receiveSelectedLoop
, receiveAnyLoop
, MessageSelector(runMessageSelector)
, selectMessage
, selectMessageLazy
, selectMessageProxy
, selectMessageProxyLazy
, filterMessage
, filterMessageLazy
, selectMessageWith
, selectMessageWithLazy
, selectDynamicMessage
, selectDynamicMessageLazy
, selectAnyMessageLazy
, self
, isProcessAlive
, spawn
, spawn_
, spawnLink
, spawnRaw
, spawnRaw_
, exitBecause
, exitNormally
, exitWithError
, linkProcess
, unlinkProcess
, monitor
, demonitor
, ProcessDown(..)
, selectProcessDown
, becauseProcessIsDown
, MonitorReference(..)
, withMonitor
, receiveWithMonitor
, provideInterruptsShutdown
, handleInterrupts
, tryUninterrupted
, exitOnInterrupt
, logInterrupts
, provideInterrupts
, mergeEitherInterruptAndExitReason
, interrupt
, executeAndResume
, executeAndResumeOrExit
, executeAndResumeOrThrow
, ExitReason(..)
, ExitRecovery(..)
, InterruptReason
, Interrupts
, InterruptableProcess
, ExitSeverity(..)
, SomeExitReason(SomeExitReason)
, toExitRecovery
, isRecoverable
, toExitSeverity
, isBecauseDown
, isCrash
, toCrashReason
, fromSomeExitReason
, logProcessExit
)
where
import GHC.Generics ( Generic
, Generic1
)
import Control.DeepSeq
import Control.Eff
import Control.Eff.Exception
import Control.Eff.Extend
import Control.Eff.Log.Handler
import Control.Eff.Log.Message
import Control.Lens
import Control.Monad ( void
, (>=>)
)
import Data.Default
import Data.Dynamic
import Data.Kind
import GHC.Stack
import Data.Function
import Control.Applicative
import Data.Maybe
import qualified Control.Exception as Exc
data Process (r :: [Type -> Type]) b where
FlushMessages :: Process r (ResumeProcess [Dynamic])
YieldProcess :: Process r (ResumeProcess ())
SelfPid :: Process r (ResumeProcess ProcessId)
Spawn :: Eff (Process r ': r) () -> Process r (ResumeProcess ProcessId)
SpawnLink :: Eff (Process r ': r) () -> Process r (ResumeProcess ProcessId)
GetProcessState :: ProcessId -> Process r (ResumeProcess (Maybe ProcessState))
Shutdown :: ExitReason 'NoRecovery -> Process r a
SendShutdown :: ProcessId -> ExitReason 'NoRecovery -> Process r (ResumeProcess ())
SendInterrupt :: ProcessId -> InterruptReason -> Process r (ResumeProcess ())
SendMessage :: ProcessId -> Dynamic -> Process r (ResumeProcess ())
ReceiveSelectedMessage :: forall r a . MessageSelector a -> Process r (ResumeProcess a)
MakeReference :: Process r (ResumeProcess Int)
Monitor :: ProcessId -> Process r (ResumeProcess MonitorReference)
Demonitor :: MonitorReference -> Process r (ResumeProcess ())
Link :: ProcessId -> Process r (ResumeProcess ())
Unlink :: ProcessId -> Process r (ResumeProcess ())
instance Show (Process r b) where
showsPrec d = \case
FlushMessages -> showString "flush messages"
YieldProcess -> showString "yield process"
SelfPid -> showString "lookup the current process id"
Spawn _ -> showString "spawn a new process"
SpawnLink _ -> showString "spawn a new process and link to it"
Shutdown sr -> showParen (d >= 10) (showString "shutdown " . showsPrec 10 sr)
SendShutdown toPid sr -> showParen
(d >= 10)
( showString "shutting down "
. showsPrec 10 toPid
. showChar ' '
. showsPrec 10 sr
)
SendInterrupt toPid sr -> showParen
(d >= 10)
( showString "interrupting "
. showsPrec 10 toPid
. showChar ' '
. showsPrec 10 sr
)
SendMessage toPid sr -> showParen
(d >= 10)
( showString "sending to "
. showsPrec 10 toPid
. showChar ' '
. showsPrec 10 sr
)
ReceiveSelectedMessage _ -> showString "receive a message"
GetProcessState pid -> showString "get the process state of " . shows pid
MakeReference -> showString "generate a unique reference"
Monitor pid -> showString "monitor " . shows pid
Demonitor i -> showString "demonitor " . shows i
Link l -> showString "link " . shows l
Unlink l -> showString "unlink " . shows l
data ResumeProcess v where
Interrupted :: InterruptReason -> ResumeProcess v
ResumeWith :: a -> ResumeProcess a
deriving ( Typeable, Generic, Generic1, Show )
instance NFData a => NFData (ResumeProcess a)
instance NFData1 ResumeProcess
newtype MessageSelector a =
MessageSelector {runMessageSelector :: Dynamic -> Maybe a }
deriving (Semigroup, Monoid, Functor)
instance Applicative MessageSelector where
pure = MessageSelector . pure . pure
(MessageSelector f) <*> (MessageSelector x) =
MessageSelector (\dyn -> f dyn <*> x dyn)
instance Alternative MessageSelector where
empty = MessageSelector (const empty)
(MessageSelector l) <|> (MessageSelector r) =
MessageSelector (\dyn -> l dyn <|> r dyn)
selectMessage :: (NFData t, Typeable t) => MessageSelector t
selectMessage = selectDynamicMessage fromDynamic
selectMessageLazy :: Typeable t => MessageSelector t
selectMessageLazy = selectDynamicMessageLazy fromDynamic
filterMessage :: (Typeable a, NFData a) => (a -> Bool) -> MessageSelector a
filterMessage predicate = selectDynamicMessage
(\d -> case fromDynamic d of
Just a | predicate a -> Just a
_ -> Nothing
)
filterMessageLazy :: Typeable a => (a -> Bool) -> MessageSelector a
filterMessageLazy predicate = selectDynamicMessageLazy
(\d -> case fromDynamic d of
Just a | predicate a -> Just a
_ -> Nothing
)
selectMessageWith
:: (Typeable a, NFData b) => (a -> Maybe b) -> MessageSelector b
selectMessageWith f = selectDynamicMessage (fromDynamic >=> f)
selectMessageWithLazy :: Typeable a => (a -> Maybe b) -> MessageSelector b
selectMessageWithLazy f = selectDynamicMessageLazy (fromDynamic >=> f)
selectDynamicMessage :: NFData a => (Dynamic -> Maybe a) -> MessageSelector a
selectDynamicMessage = MessageSelector . (force .)
selectDynamicMessageLazy :: (Dynamic -> Maybe a) -> MessageSelector a
selectDynamicMessageLazy = MessageSelector
selectAnyMessageLazy :: MessageSelector Dynamic
selectAnyMessageLazy = MessageSelector Just
selectMessageProxy
:: forall proxy t . (NFData t, Typeable t) => proxy t -> MessageSelector t
selectMessageProxy _ = selectDynamicMessage fromDynamic
selectMessageProxyLazy
:: forall proxy t . (Typeable t) => proxy t -> MessageSelector t
selectMessageProxyLazy _ = selectDynamicMessageLazy fromDynamic
data SchedulerProxy :: [Type -> Type] -> Type where
SchedulerProxy :: SchedulerProxy q
SP :: SchedulerProxy q
Scheduler :: SchedulerProxy q
type HasScheduler q = (?_schedulerProxy :: SchedulerProxy q)
getSchedulerProxy :: HasScheduler q => SchedulerProxy q
getSchedulerProxy = ?_schedulerProxy
withSchedulerProxy :: SchedulerProxy q -> (HasScheduler q => a) -> a
withSchedulerProxy px x = let ?_schedulerProxy = px in x
type ConsProcess r = Process r ': r
thisSchedulerProxy :: Eff (Process r ': r) (SchedulerProxy r)
thisSchedulerProxy = return SchedulerProxy
data ProcessState =
ProcessBooting
| ProcessIdle
| ProcessBusy
| ProcessBusySending
| ProcessBusySendingShutdown
| ProcessBusySendingInterrupt
| ProcessBusyReceiving
| ProcessBusyLinking
| ProcessBusyUnlinking
| ProcessBusyMonitoring
| ProcessBusyDemonitoring
| ProcessInterrupted
| ProcessShuttingDown
deriving (Read, Show, Ord, Eq, Enum, Generic)
instance NFData ProcessState
instance Default ProcessState where def = ProcessBooting
data ExitRecovery = Recoverable | NoRecovery
deriving (Typeable, Ord, Eq, Generic)
instance NFData ExitRecovery
instance Show ExitRecovery where
showsPrec d =
showParen (d>=10) .
(\case
Recoverable -> showString "recoverable"
NoRecovery -> showString "not recoverable")
toExitRecovery :: ExitReason r -> ExitRecovery
toExitRecovery = \case
ProcessFinished -> Recoverable
(ProcessNotRunning _) -> Recoverable
(LinkedProcessCrashed _) -> Recoverable
(ProcessError _) -> Recoverable
ExitNormally -> NoRecovery
(NotRecovered _ ) -> NoRecovery
(UnexpectedException _ _) -> NoRecovery
Killed -> NoRecovery
data ExitSeverity = NormalExit | Crash
deriving (Typeable, Ord, Eq, Generic)
instance Show ExitSeverity where
showsPrec d =
showParen (d>=10) .
(\case
NormalExit -> showString "exit success"
Crash -> showString "crash")
instance NFData ExitSeverity
toExitSeverity :: ExitReason e -> ExitSeverity
toExitSeverity = \case
ExitNormally -> NormalExit
ProcessFinished -> NormalExit
_ -> Crash
data ExitReason (t :: ExitRecovery) where
ProcessFinished
:: ExitReason 'Recoverable
ProcessNotRunning
:: ProcessId -> ExitReason 'Recoverable
LinkedProcessCrashed
:: ProcessId -> ExitReason 'Recoverable
ProcessError
:: String -> ExitReason 'Recoverable
ExitNormally
:: ExitReason 'NoRecovery
NotRecovered
:: (ExitReason 'Recoverable) -> ExitReason 'NoRecovery
UnexpectedException
:: String -> String -> ExitReason 'NoRecovery
Killed
:: ExitReason 'NoRecovery
deriving Typeable
instance Show (ExitReason x) where
showsPrec d =
showParen (d>=10) .
(\case
ProcessFinished -> showString "process finished"
ProcessNotRunning p -> showString "process not running: " . shows p
LinkedProcessCrashed m -> showString "linked process "
. shows m . showString " crashed"
ProcessError reason -> showString "error: " . showString reason
ExitNormally -> showString "exit normally"
NotRecovered e -> showString "not recovered from: " . shows e
UnexpectedException w m -> showString "unhandled runtime exception: "
. showString m
. showString " caught here: "
. showString w
Killed -> showString "killed"
)
instance Exc.Exception (ExitReason 'Recoverable)
instance Exc.Exception (ExitReason 'NoRecovery )
instance NFData (ExitReason x) where
rnf ProcessFinished = rnf ()
rnf (ProcessNotRunning !l) = rnf l
rnf (LinkedProcessCrashed !l) = rnf l
rnf (ProcessError !l) = rnf l
rnf ExitNormally = rnf ()
rnf (NotRecovered !l) = rnf l
rnf (UnexpectedException !l1 !l2) = rnf l1 `seq` rnf l2 `seq` ()
rnf Killed = rnf ()
instance Ord (ExitReason x) where
compare ProcessFinished ProcessFinished = EQ
compare ProcessFinished _ = LT
compare _ ProcessFinished = GT
compare (ProcessNotRunning l) (ProcessNotRunning r) = compare l r
compare (ProcessNotRunning _) _ = LT
compare _ (ProcessNotRunning _) = GT
compare (LinkedProcessCrashed l) (LinkedProcessCrashed r) = compare l r
compare (LinkedProcessCrashed _) _ = LT
compare _ (LinkedProcessCrashed _) = GT
compare (ProcessError l) (ProcessError r) = compare l r
compare ExitNormally ExitNormally = EQ
compare ExitNormally _ = LT
compare _ ExitNormally = GT
compare (NotRecovered l) (NotRecovered r) = compare l r
compare (NotRecovered _) _ = LT
compare _ (NotRecovered _) = GT
compare (UnexpectedException l1 l2) (UnexpectedException r1 r2) =
compare l1 r1 <> compare l2 r2
compare (UnexpectedException _ _) _ = LT
compare _ (UnexpectedException _ _) = GT
compare Killed Killed = EQ
instance Eq (ExitReason x) where
(==) ProcessFinished ProcessFinished = True
(==) (ProcessNotRunning l) (ProcessNotRunning r) = (==) l r
(==) ExitNormally ExitNormally = True
(==) (LinkedProcessCrashed l) (LinkedProcessCrashed r) = l == r
(==) (ProcessError l) (ProcessError r) = (==) l r
(==) (NotRecovered l) (NotRecovered r) = (==) l r
(==) (UnexpectedException l1 l2) (UnexpectedException r1 r2) =
(==) l1 r1 && (==) l2 r2
(==) Killed Killed = True
(==) _ _ = False
isBecauseDown :: Maybe ProcessId -> ExitReason r -> Bool
isBecauseDown mp = \case
ProcessFinished -> False
ProcessNotRunning _ -> False
LinkedProcessCrashed p -> maybe True (== p) mp
ProcessError _ -> False
ExitNormally -> False
NotRecovered e -> isBecauseDown mp e
UnexpectedException _ _ -> False
Killed -> False
type InterruptReason = ExitReason 'Recoverable
type Interrupts = Exc InterruptReason
type InterruptableProcess e = Interrupts ': ConsProcess e
provideInterruptsShutdown
:: forall e a . Eff (InterruptableProcess e) a -> Eff (ConsProcess e) a
provideInterruptsShutdown e = do
res <- provideInterrupts e
case res of
Left ex -> send (Shutdown @e (NotRecovered ex))
Right a -> return a
handleInterrupts
:: (HasCallStack, Member Interrupts r)
=> (InterruptReason -> Eff r a)
-> Eff r a
-> Eff r a
handleInterrupts = flip catchError
tryUninterrupted
:: (HasCallStack, Member Interrupts r)
=> Eff r a
-> Eff r (Either InterruptReason a)
tryUninterrupted = handleInterrupts (pure . Left) . fmap Right
logInterrupts
:: (HasCallStack, '[Interrupts, Logs LogMessage] <:: r)
=> Eff r ()
-> Eff r ()
logInterrupts = handleInterrupts logProcessExit
exitOnInterrupt
:: (HasCallStack, Member Interrupts r, SetMember Process (Process q) r)
=> SchedulerProxy q
-> Eff r a
-> Eff r a
exitOnInterrupt px = handleInterrupts (exitBecause px . NotRecovered)
provideInterrupts
:: HasCallStack => Eff (Interrupts ': r) a -> Eff r (Either InterruptReason a)
provideInterrupts = runError
mergeEitherInterruptAndExitReason
:: Either InterruptReason (ExitReason 'NoRecovery) -> ExitReason 'NoRecovery
mergeEitherInterruptAndExitReason = either NotRecovered id
interrupt :: (HasCallStack, Member Interrupts r) => InterruptReason -> Eff r a
interrupt = throwError
isCrash :: ExitReason x -> Bool
isCrash (NotRecovered !x) = isCrash x
isCrash ExitNormally = False
isCrash _ = True
isRecoverable :: ExitReason x -> Bool
isRecoverable (toExitRecovery -> Recoverable) = True
isRecoverable _ = False
data SomeExitReason where
SomeExitReason :: ExitReason x -> SomeExitReason
instance Ord SomeExitReason where
compare = compare `on` fromSomeExitReason
instance Eq SomeExitReason where
(==) = (==) `on` fromSomeExitReason
instance Show SomeExitReason where
show = show . fromSomeExitReason
instance NFData SomeExitReason where
rnf = rnf . fromSomeExitReason
fromSomeExitReason
:: SomeExitReason -> Either (ExitReason 'NoRecovery) InterruptReason
fromSomeExitReason (SomeExitReason e) = case e of
recoverable@ProcessFinished -> Right recoverable
recoverable@(ProcessNotRunning _) -> Right recoverable
recoverable@(LinkedProcessCrashed _) -> Right recoverable
recoverable@(ProcessError _) -> Right recoverable
noRecovery@ExitNormally -> Left noRecovery
noRecovery@(NotRecovered _ ) -> Left noRecovery
noRecovery@(UnexpectedException _ _) -> Left noRecovery
noRecovery@Killed -> Left noRecovery
toCrashReason :: ExitReason x -> Maybe String
toCrashReason e | isCrash e = Just (show e)
| otherwise = Nothing
logProcessExit
:: (HasCallStack, Member (Logs LogMessage) e) => ExitReason x -> Eff e ()
logProcessExit (toCrashReason -> Just ex) = withFrozenCallStack (logError ex)
logProcessExit ex = withFrozenCallStack (logDebug (show ex))
executeAndResume
:: forall q r v
. (SetMember Process (Process q) r, HasCallStack)
=> Process q (ResumeProcess v)
-> Eff r (Either (ExitReason 'Recoverable) v)
executeAndResume processAction = do
result <- send processAction
case result of
ResumeWith !value -> return (Right value)
Interrupted r -> return (Left r)
executeAndResumeOrExit
:: forall r q v
. (SetMember Process (Process q) r, HasCallStack)
=> Process q (ResumeProcess v)
-> Eff r v
executeAndResumeOrExit processAction = do
result <- send processAction
case result of
ResumeWith !value -> return value
Interrupted r -> send (Shutdown @q (NotRecovered r))
executeAndResumeOrThrow
:: forall q r v
. (SetMember Process (Process q) r, HasCallStack, Member Interrupts r)
=> Process q (ResumeProcess v)
-> Eff r v
executeAndResumeOrThrow processAction = do
result <- send processAction
case result of
ResumeWith !value -> return value
Interrupted r -> interrupt r
yieldProcess
:: forall r q
. (SetMember Process (Process q) r, HasCallStack, Member Interrupts r)
=> SchedulerProxy q
-> Eff r ()
yieldProcess _ = executeAndResumeOrThrow YieldProcess
sendMessage
:: forall r q o
. ( SetMember Process (Process q) r
, HasCallStack
, Member Interrupts r
, Typeable o
)
=> SchedulerProxy q
-> ProcessId
-> o
-> Eff r ()
sendMessage _ pid message =
executeAndResumeOrThrow (SendMessage pid $! toDyn $! message)
sendAnyMessage
:: forall r q
. (SetMember Process (Process q) r, HasCallStack, Member Interrupts r)
=> SchedulerProxy q
-> ProcessId
-> Dynamic
-> Eff r ()
sendAnyMessage _ pid message =
rnf pid `seq` executeAndResumeOrThrow (SendMessage pid $! message)
sendShutdown
:: forall r q
. (SetMember Process (Process q) r, HasCallStack, Member Interrupts r)
=> SchedulerProxy q
-> ProcessId
-> ExitReason 'NoRecovery
-> Eff r ()
sendShutdown _ pid s =
pid `deepseq` s `deepseq` executeAndResumeOrThrow (SendShutdown pid s)
sendInterrupt
:: forall r q
. (SetMember Process (Process q) r, HasCallStack, Member Interrupts r)
=> SchedulerProxy q
-> ProcessId
-> InterruptReason
-> Eff r ()
sendInterrupt _ pid s =
pid `deepseq` s `deepseq` executeAndResumeOrThrow (SendInterrupt pid s)
spawn
:: forall r q
. (HasCallStack, SetMember Process (Process q) r, Member Interrupts r)
=> Eff (InterruptableProcess q) ()
-> Eff r ProcessId
spawn child =
executeAndResumeOrThrow (Spawn @q (provideInterruptsShutdown child))
spawn_
:: forall r q
. (HasCallStack, SetMember Process (Process q) r, Member Interrupts r)
=> Eff (InterruptableProcess q) ()
-> Eff r ()
spawn_ child = void (spawn child)
spawnLink
:: forall r q
. (HasCallStack, SetMember Process (Process q) r, Member Interrupts r)
=> Eff (InterruptableProcess q) ()
-> Eff r ProcessId
spawnLink child =
executeAndResumeOrThrow (SpawnLink @q (provideInterruptsShutdown child))
spawnRaw
:: forall r q
. (HasCallStack, SetMember Process (Process q) r, Member Interrupts r)
=> Eff (ConsProcess q) ()
-> Eff r ProcessId
spawnRaw child = executeAndResumeOrThrow (Spawn @q child)
spawnRaw_
:: forall r q
. (HasCallStack, SetMember Process (Process q) r, Member Interrupts r)
=> Eff (ConsProcess q) ()
-> Eff r ()
spawnRaw_ = void . spawnRaw
isProcessAlive
:: forall r q
. (HasCallStack, SetMember Process (Process q) r, Member Interrupts r)
=> SchedulerProxy q
-> ProcessId
-> Eff r Bool
isProcessAlive _px pid =
isJust <$> executeAndResumeOrThrow (GetProcessState pid)
receiveAnyMessage
:: forall r q
. (HasCallStack, SetMember Process (Process q) r, Member Interrupts r)
=> SchedulerProxy q
-> Eff r Dynamic
receiveAnyMessage _ =
executeAndResumeOrThrow (ReceiveSelectedMessage selectAnyMessageLazy)
receiveSelectedMessage
:: forall r q a
. ( HasCallStack
, Show a
, SetMember Process (Process q) r
, Member Interrupts r
)
=> SchedulerProxy q
-> MessageSelector a
-> Eff r a
receiveSelectedMessage _ f = executeAndResumeOrThrow (ReceiveSelectedMessage f)
receiveMessage
:: forall a r q
. ( HasCallStack
, Typeable a
, Show a
, SetMember Process (Process q) r
, Member Interrupts r
)
=> SchedulerProxy q
-> Eff r a
receiveMessage px = receiveSelectedMessage px (MessageSelector fromDynamic)
flushMessages
:: forall r q
. ( HasCallStack
, SetMember Process (Process q) r
, Member Interrupts r
, HasScheduler q
)
=> Eff r [Dynamic]
flushMessages =
executeAndResumeOrThrow @q FlushMessages
receiveSelectedLoop
:: forall r q a endOfLoopResult
. (SetMember Process (Process q) r, HasCallStack)
=> SchedulerProxy q
-> MessageSelector a
-> (Either InterruptReason a -> Eff r (Maybe endOfLoopResult))
-> Eff r endOfLoopResult
receiveSelectedLoop px selectMesage handlers = do
mReq <- send (ReceiveSelectedMessage @q @a selectMesage)
mRes <- case mReq of
Interrupted reason -> handlers (Left reason)
ResumeWith message -> handlers (Right message)
maybe (receiveSelectedLoop px selectMesage handlers) return mRes
receiveAnyLoop
:: forall r q endOfLoopResult
. (SetMember Process (Process q) r, HasCallStack)
=> SchedulerProxy q
-> (Either InterruptReason Dynamic -> Eff r (Maybe endOfLoopResult))
-> Eff r endOfLoopResult
receiveAnyLoop px = receiveSelectedLoop px selectAnyMessageLazy
receiveLoop
:: forall r q a endOfLoopResult
. (SetMember Process (Process q) r, HasCallStack, Typeable a)
=> SchedulerProxy q
-> (Either InterruptReason a -> Eff r (Maybe endOfLoopResult))
-> Eff r endOfLoopResult
receiveLoop px = receiveSelectedLoop px selectMessageLazy
self
:: (HasCallStack, SetMember Process (Process q) r)
=> SchedulerProxy q
-> Eff r ProcessId
self _px = executeAndResumeOrExit SelfPid
makeReference
:: (HasCallStack, SetMember Process (Process q) r, Member Interrupts r)
=> SchedulerProxy q
-> Eff r Int
makeReference _px = executeAndResumeOrThrow MakeReference
data MonitorReference =
MonitorReference { monitorIndex :: Int
, monitoredProcess :: ProcessId
}
deriving (Read, Eq, Ord, Generic, Typeable)
instance NFData MonitorReference
instance Show MonitorReference where
showsPrec d m =
showParen (d>=10)
( showString "monitor: "
. shows (monitorIndex m)
. showChar ' '
. shows (monitoredProcess m))
monitor
:: forall r q
. (HasCallStack, SetMember Process (Process q) r, Member Interrupts r)
=> SchedulerProxy q
-> ProcessId
-> Eff r MonitorReference
monitor _px = executeAndResumeOrThrow . Monitor . force
demonitor
:: forall r q
. (HasCallStack, SetMember Process (Process q) r, Member Interrupts r)
=> SchedulerProxy q
-> MonitorReference
-> Eff r ()
demonitor _px = executeAndResumeOrThrow . Demonitor . force
withMonitor
:: ( HasCallStack
, Member Interrupts r
, SetMember Process (Process q) r
, Member Interrupts r
)
=> SchedulerProxy q
-> ProcessId
-> (MonitorReference -> Eff r a)
-> Eff r a
withMonitor px pid eff = monitor px pid >>= \ref -> eff ref <* demonitor px ref
receiveWithMonitor
:: ( HasCallStack
, Member Interrupts r
, SetMember Process (Process q) r
, Member Interrupts r
, Typeable a
, Show a
)
=> SchedulerProxy q
-> ProcessId
-> MessageSelector a
-> Eff r (Either ProcessDown a)
receiveWithMonitor px pid sel = withMonitor
px
pid
(\ref -> receiveSelectedMessage
px
(Left <$> selectProcessDown ref <|> Right <$> sel)
)
data ProcessDown =
ProcessDown
{ downReference :: !MonitorReference
, downReason :: !SomeExitReason
}
deriving (Typeable, Generic, Eq, Ord)
becauseProcessIsDown :: ProcessDown -> InterruptReason
becauseProcessIsDown = ProcessNotRunning . monitoredProcess . downReference
instance NFData ProcessDown
instance Show ProcessDown where
showsPrec d =
showParen
(d>=10)
. (\case
ProcessDown ref reason ->
showString "monitored process down "
. showsPrec 11 ref . showChar ' '
. showsPrec 11 reason
)
selectProcessDown :: MonitorReference -> MessageSelector ProcessDown
selectProcessDown ref0 =
filterMessageLazy (\(ProcessDown ref _reason) -> ref0 == ref)
linkProcess
:: forall r q
. (HasCallStack, SetMember Process (Process q) r, Member Interrupts r)
=> SchedulerProxy q
-> ProcessId
-> Eff r ()
linkProcess _px = executeAndResumeOrThrow . Link . force
unlinkProcess
:: forall r q
. (HasCallStack, SetMember Process (Process q) r, Member Interrupts r)
=> SchedulerProxy q
-> ProcessId
-> Eff r ()
unlinkProcess _px = executeAndResumeOrThrow . Unlink . force
exitBecause
:: forall r q a
. (HasCallStack, SetMember Process (Process q) r)
=> SchedulerProxy q
-> ExitReason 'NoRecovery
-> Eff r a
exitBecause _ = send . Shutdown @q . force
exitNormally
:: forall r q a
. (HasCallStack, SetMember Process (Process q) r)
=> SchedulerProxy q
-> Eff r a
exitNormally px = exitBecause px ExitNormally
exitWithError
:: forall r q a
. (HasCallStack, SetMember Process (Process q) r)
=> SchedulerProxy q
-> String
-> Eff r a
exitWithError px = exitBecause px . NotRecovered . ProcessError
newtype ProcessId = ProcessId { _fromProcessId :: Int }
deriving (Eq,Ord,Typeable,Bounded,Num, Enum, Integral, Real, NFData)
instance Read ProcessId where
readsPrec _ ('!':rest1) =
case reads rest1 of
[(c, rest2)] -> [(ProcessId c, rest2)]
_ -> []
readsPrec _ _ = []
instance Show ProcessId where
showsPrec _ (ProcessId !c) = showChar '!' . shows c
makeLenses ''ProcessId