{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GADTs #-}
{- |
Module: Control.Concurrent.Actor
Description: A basic actor model in Haskell
Copyright: (c) Samuel Schlesinger 2020
License: MIT
Maintainer: sgschlesinger@gmail.com
Stability: experimental
Portability: POSIX, Windows
-}
module Control.Concurrent.Actor
( ActionT
, Actor
, send
, addAfterEffect
, threadId
, livenessCheck
, withLivenessCheck
, Liveness(..)
, ActorDead(..)
, actFinally
, act
, receiveSTM
, receive
, hoistActionT
, link
, linkSTM
, LinkKill(..)
, self
, murder
, MurderKill(..)
) where

-- This list was generated by compiling with the -ddump-minimal-imports flag.
import Control.Concurrent
    ( forkFinally, myThreadId, throwTo, ThreadId )
import Control.Monad.IO.Class ( MonadIO(..) )
import Control.Monad.IO.Unlift ( MonadUnliftIO(..) )
import Control.Monad.Trans ( MonadTrans(..) )
import Control.Monad.Reader
    ( MonadReader(local, ask), ReaderT(ReaderT) )
import Control.Monad.State.Class ( MonadState )
import Control.Monad.Reader.Class ()
import Control.Monad.Writer.Class ( MonadWriter )
import Control.Monad.RWS.Class ( MonadRWS )
import Control.Monad.Error.Class ( MonadError )
import Control.Monad.Cont.Class ( MonadCont )
import Control.Concurrent.STM
    ( STM, atomically, newTVar, newTVarIO, readTVar, modifyTVar, writeTVar, TVar, throwSTM )
import Control.Exception ( SomeException, Exception )
import Data.Functor.Contravariant ( Contravariant(contramap) )
import Data.Queue ( dequeue, enqueue, newQueue, Queue )

-- | A type that contains the actions that 'Actor's will do.
newtype ActionT message m a = ActionT
  { ActionT message m a -> ActorContext message -> m a
runActionT
    :: ActorContext message
    -> m a
  }

deriving via ReaderT (ActorContext message) m instance Functor m => Functor (ActionT message m)
deriving via ReaderT (ActorContext message) m instance Applicative m => Applicative (ActionT message m)
deriving via ReaderT (ActorContext message) m instance Monad m => Monad (ActionT message m)
deriving via ReaderT (ActorContext message) m instance MonadIO m => MonadIO (ActionT message m)
deriving via ReaderT (ActorContext message) instance MonadTrans (ActionT message)
deriving via ReaderT (ActorContext message) m instance MonadError e m => MonadError e (ActionT message m)
deriving via ReaderT (ActorContext message) m instance MonadWriter w m => MonadWriter w (ActionT message m)
deriving via ReaderT (ActorContext message) m instance MonadState s m => MonadState s (ActionT message m)
deriving via ReaderT (ActorContext message) m instance MonadCont m => MonadCont (ActionT message m)
deriving via ReaderT (ActorContext message) m instance MonadUnliftIO m => MonadUnliftIO (ActionT message m)

instance MonadReader r m => MonadReader r (ActionT message m) where
  ask :: ActionT message m r
ask = (ActorContext message -> m r) -> ActionT message m r
forall message (m :: * -> *) a.
(ActorContext message -> m a) -> ActionT message m a
ActionT (m r -> ActorContext message -> m r
forall a b. a -> b -> a
const m r
forall r (m :: * -> *). MonadReader r m => m r
ask)
  local :: (r -> r) -> ActionT message m a -> ActionT message m a
local r -> r
f (ActionT ActorContext message -> m a
ma) = (ActorContext message -> m a) -> ActionT message m a
forall message (m :: * -> *) a.
(ActorContext message -> m a) -> ActionT message m a
ActionT ((m a -> m a)
-> (ActorContext message -> m a) -> ActorContext message -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((r -> r) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f) ActorContext message -> m a
ma)

instance (MonadWriter w m, MonadReader r m, MonadState s m) => MonadRWS r w s (ActionT message m)

data ActorContext message = ActorContext
  { ActorContext message -> Queue message
messageQueue :: Queue message
  , ActorContext message -> Actor message
actorHandle :: Actor message
  }

-- | A handle to do things to actors, like sending them messages, fiddling
-- with their threads, or adding an effect that will occur after they've
-- finished executing.
data Actor message = Actor
  { Actor message -> (Maybe SomeException -> IO ()) -> STM ()
addAfterEffect' :: (Maybe SomeException -> IO ()) -> STM ()
  , Actor message -> ThreadId
threadId' :: ThreadId
  , Actor message -> message -> STM ()
send' :: message -> STM ()
  , Actor message -> TVar (Maybe (Maybe SomeException))
status :: TVar (Maybe (Maybe SomeException))
  }

-- | The liveness state of a particular 'Actor'.
data Liveness = Alive | Completed | ThrewException SomeException
  deriving Int -> Liveness -> ShowS
[Liveness] -> ShowS
Liveness -> String
(Int -> Liveness -> ShowS)
-> (Liveness -> String) -> ([Liveness] -> ShowS) -> Show Liveness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Liveness] -> ShowS
$cshowList :: [Liveness] -> ShowS
show :: Liveness -> String
$cshow :: Liveness -> String
showsPrec :: Int -> Liveness -> ShowS
$cshowsPrec :: Int -> Liveness -> ShowS
Show

-- | Checks the 'Liveness' of a particular 'Actor'
livenessCheck :: Actor message -> STM Liveness
livenessCheck :: Actor message -> STM Liveness
livenessCheck Actor message
actor = do
  TVar (Maybe (Maybe SomeException))
-> STM (Maybe (Maybe SomeException))
forall a. TVar a -> STM a
readTVar (Actor message -> TVar (Maybe (Maybe SomeException))
forall message. Actor message -> TVar (Maybe (Maybe SomeException))
status Actor message
actor) STM (Maybe (Maybe SomeException))
-> (Maybe (Maybe SomeException) -> STM Liveness) -> STM Liveness
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (Maybe SomeException)
Nothing -> Liveness -> STM Liveness
forall (f :: * -> *) a. Applicative f => a -> f a
pure Liveness
Alive
    Just Maybe SomeException
completion -> Liveness -> STM Liveness
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Liveness
-> (SomeException -> Liveness) -> Maybe SomeException -> Liveness
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Liveness
Completed SomeException -> Liveness
ThrewException Maybe SomeException
completion)

-- | The exception thrown when we run an action wrapped in
-- 'withLivenessCheck' on an 'Actor' which has died.
data ActorDead = ActorDead (Maybe SomeException)
  deriving Int -> ActorDead -> ShowS
[ActorDead] -> ShowS
ActorDead -> String
(Int -> ActorDead -> ShowS)
-> (ActorDead -> String)
-> ([ActorDead] -> ShowS)
-> Show ActorDead
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ActorDead] -> ShowS
$cshowList :: [ActorDead] -> ShowS
show :: ActorDead -> String
$cshow :: ActorDead -> String
showsPrec :: Int -> ActorDead -> ShowS
$cshowsPrec :: Int -> ActorDead -> ShowS
Show

instance Exception ActorDead

-- | Allows us to wrap 'addAfterEffect', 'send', and any other custom
-- combinators in a liveness check. This causes contention on the
-- underlying 'TVar' that contains the status report of the 'Actor', and
-- thus should be avoided where possible. That being said, it is also
-- useful to avoid sending messages or add after effects to dead actors,
-- which will certainly be lost forever. If the 'Actor' is 'Completed' or
-- 'ThrewException', then we throw an 'ActorDead' exception with 'Nothing'
-- or 'Just' the exception, respectively.
withLivenessCheck :: (Actor message -> x -> STM ()) -> Actor message -> x -> STM ()
withLivenessCheck :: (Actor message -> x -> STM ()) -> Actor message -> x -> STM ()
withLivenessCheck Actor message -> x -> STM ()
f Actor message
actorHandle x
x = TVar (Maybe (Maybe SomeException))
-> STM (Maybe (Maybe SomeException))
forall a. TVar a -> STM a
readTVar (Actor message -> TVar (Maybe (Maybe SomeException))
forall message. Actor message -> TVar (Maybe (Maybe SomeException))
status Actor message
actorHandle) STM (Maybe (Maybe SomeException))
-> (Maybe (Maybe SomeException) -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM ()
-> (Maybe SomeException -> STM ())
-> Maybe (Maybe SomeException)
-> STM ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Actor message -> x -> STM ()
f Actor message
actorHandle x
x) (ActorDead -> STM ()
forall e a. Exception e => e -> STM a
throwSTM (ActorDead -> STM ())
-> (Maybe SomeException -> ActorDead)
-> Maybe SomeException
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SomeException -> ActorDead
ActorDead)

-- | Once the 'Actor' dies, all of the effects that have been added via
-- this function will run. This is how you can implement your own functions
-- like 'link' or 'linkSTM'.
addAfterEffect :: Actor message -> (Maybe SomeException -> IO ()) -> STM ()
addAfterEffect :: Actor message -> (Maybe SomeException -> IO ()) -> STM ()
addAfterEffect = Actor message -> (Maybe SomeException -> IO ()) -> STM ()
forall message.
Actor message -> (Maybe SomeException -> IO ()) -> STM ()
addAfterEffect'

-- | Retrieve the 'ThreadId' associated with this 'Actor'.
threadId :: Actor message -> ThreadId
threadId :: Actor message -> ThreadId
threadId = Actor message -> ThreadId
forall message. Actor message -> ThreadId
threadId'

-- | Send a message to this 'Actor'.
send :: Actor message -> message -> STM ()
send :: Actor message -> message -> STM ()
send = Actor message -> message -> STM ()
forall message. Actor message -> message -> STM ()
send'

instance Eq (Actor message) where
  Actor (Maybe SomeException -> IO ()) -> STM ()
_ ThreadId
x message -> STM ()
_ TVar (Maybe (Maybe SomeException))
_ == :: Actor message -> Actor message -> Bool
== Actor (Maybe SomeException -> IO ()) -> STM ()
_ ThreadId
y message -> STM ()
_ TVar (Maybe (Maybe SomeException))
_ = ThreadId
x ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadId
y

instance Show (Actor message) where
  show :: Actor message -> String
show Actor{ThreadId
threadId' :: ThreadId
threadId' :: forall message. Actor message -> ThreadId
threadId'} = ThreadId -> String
forall a. Show a => a -> String
show ThreadId
threadId'

instance Contravariant Actor where
  contramap :: (a -> b) -> Actor b -> Actor a
contramap a -> b
f (Actor (Maybe SomeException -> IO ()) -> STM ()
addAfterEffect' ThreadId
threadId' (((b -> STM ()) -> (a -> b) -> a -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) -> a -> STM ()
send') TVar (Maybe (Maybe SomeException))
status) = Actor :: forall message.
((Maybe SomeException -> IO ()) -> STM ())
-> ThreadId
-> (message -> STM ())
-> TVar (Maybe (Maybe SomeException))
-> Actor message
Actor{ThreadId
TVar (Maybe (Maybe SomeException))
a -> STM ()
(Maybe SomeException -> IO ()) -> STM ()
status :: TVar (Maybe (Maybe SomeException))
send' :: a -> STM ()
threadId' :: ThreadId
addAfterEffect' :: (Maybe SomeException -> IO ()) -> STM ()
status :: TVar (Maybe (Maybe SomeException))
send' :: a -> STM ()
threadId' :: ThreadId
addAfterEffect' :: (Maybe SomeException -> IO ()) -> STM ()
..}

-- | Perform some 'ActionT' in a thread, with some cleanup afterwards.
actFinally :: (Either SomeException a -> IO ()) -> ActionT message IO a -> IO (Actor message)
actFinally :: (Either SomeException a -> IO ())
-> ActionT message IO a -> IO (Actor message)
actFinally Either SomeException a -> IO ()
errorHandler (ActionT ActorContext message -> IO a
actionT) = do
  TVar (Either SomeException a -> IO ())
onErrorTVar <- STM (TVar (Either SomeException a -> IO ()))
-> IO (TVar (Either SomeException a -> IO ()))
forall a. STM a -> IO a
atomically (STM (TVar (Either SomeException a -> IO ()))
 -> IO (TVar (Either SomeException a -> IO ())))
-> STM (TVar (Either SomeException a -> IO ()))
-> IO (TVar (Either SomeException a -> IO ()))
forall a b. (a -> b) -> a -> b
$ (Either SomeException a -> IO ())
-> STM (TVar (Either SomeException a -> IO ()))
forall a. a -> STM (TVar a)
newTVar Either SomeException a -> IO ()
errorHandler
  Queue message
messageQueue <- STM (Queue message) -> IO (Queue message)
forall a. STM a -> IO a
atomically STM (Queue message)
forall a. STM (Queue a)
newQueue
  TVar (Maybe (Maybe SomeException))
status <- Maybe (Maybe SomeException)
-> IO (TVar (Maybe (Maybe SomeException)))
forall a. a -> IO (TVar a)
newTVarIO Maybe (Maybe SomeException)
forall a. Maybe a
Nothing
  let addAfterEffect' :: (Maybe SomeException -> IO ()) -> STM ()
addAfterEffect' Maybe SomeException -> IO ()
afterEffect = TVar (Either SomeException a -> IO ())
-> ((Either SomeException a -> IO ())
    -> Either SomeException a -> IO ())
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Either SomeException a -> IO ())
onErrorTVar (\Either SomeException a -> IO ()
f Either SomeException a
x -> Either SomeException a -> IO ()
f Either SomeException a
x IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Maybe SomeException -> IO ()
afterEffect (Either SomeException a -> Maybe SomeException
forall a b. Either a b -> Maybe a
leftToMaybe Either SomeException a
x))
  let send' :: message -> STM ()
send' = Queue message -> message -> STM ()
forall a. Queue a -> a -> STM ()
enqueue Queue message
messageQueue
  ThreadId
threadId' <- IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (do { ThreadId
threadId' <- IO ThreadId
myThreadId; ActorContext message -> IO a
actionT (Queue message -> Actor message -> ActorContext message
forall message.
Queue message -> Actor message -> ActorContext message
ActorContext Queue message
messageQueue Actor :: forall message.
((Maybe SomeException -> IO ()) -> STM ())
-> ThreadId
-> (message -> STM ())
-> TVar (Maybe (Maybe SomeException))
-> Actor message
Actor{ThreadId
TVar (Maybe (Maybe SomeException))
message -> STM ()
(Maybe SomeException -> IO ()) -> STM ()
threadId' :: ThreadId
send' :: message -> STM ()
addAfterEffect' :: (Maybe SomeException -> IO ()) -> STM ()
status :: TVar (Maybe (Maybe SomeException))
status :: TVar (Maybe (Maybe SomeException))
send' :: message -> STM ()
threadId' :: ThreadId
addAfterEffect' :: (Maybe SomeException -> IO ()) -> STM ()
..}) }) (\Either SomeException a
result -> STM (Either SomeException a -> IO ())
-> IO (Either SomeException a -> IO ())
forall a. STM a -> IO a
atomically (do { TVar (Maybe (Maybe SomeException))
-> Maybe (Maybe SomeException) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe (Maybe SomeException))
status (Maybe SomeException -> Maybe (Maybe SomeException)
forall a. a -> Maybe a
Just (Either SomeException a -> Maybe SomeException
forall a b. Either a b -> Maybe a
leftToMaybe Either SomeException a
result)); TVar (Either SomeException a -> IO ())
-> STM (Either SomeException a -> IO ())
forall a. TVar a -> STM a
readTVar TVar (Either SomeException a -> IO ())
onErrorTVar }) IO (Either SomeException a -> IO ())
-> ((Either SomeException a -> IO ()) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Either SomeException a -> IO ())
-> Either SomeException a -> IO ()
forall a b. (a -> b) -> a -> b
$ Either SomeException a
result))
  Actor message -> IO (Actor message)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Actor message -> IO (Actor message))
-> Actor message -> IO (Actor message)
forall a b. (a -> b) -> a -> b
$ Actor :: forall message.
((Maybe SomeException -> IO ()) -> STM ())
-> ThreadId
-> (message -> STM ())
-> TVar (Maybe (Maybe SomeException))
-> Actor message
Actor {ThreadId
TVar (Maybe (Maybe SomeException))
message -> STM ()
(Maybe SomeException -> IO ()) -> STM ()
threadId' :: ThreadId
send' :: message -> STM ()
addAfterEffect' :: (Maybe SomeException -> IO ()) -> STM ()
status :: TVar (Maybe (Maybe SomeException))
status :: TVar (Maybe (Maybe SomeException))
send' :: message -> STM ()
threadId' :: ThreadId
addAfterEffect' :: (Maybe SomeException -> IO ()) -> STM ()
..}
  where
    leftToMaybe :: Either a b -> Maybe a
leftToMaybe (Left a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
    leftToMaybe Either a b
_ = Maybe a
forall a. Maybe a
Nothing

-- | Perform some 'ActionT' in a thread.
act :: ActionT message IO a -> IO (Actor message)
act :: ActionT message IO a -> IO (Actor message)
act = (Either SomeException a -> IO ())
-> ActionT message IO a -> IO (Actor message)
forall a message.
(Either SomeException a -> IO ())
-> ActionT message IO a -> IO (Actor message)
actFinally (IO () -> Either SomeException a -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
 
-- | Receive a message and do some 'ActionT' with it.
receive :: MonadIO m => (message -> ActionT message m a) -> ActionT message m a
receive :: (message -> ActionT message m a) -> ActionT message m a
receive message -> ActionT message m a
f = (ActorContext message -> m a) -> ActionT message m a
forall message (m :: * -> *) a.
(ActorContext message -> m a) -> ActionT message m a
ActionT \ActorContext message
ctx -> do
  message
message <- IO message -> m message
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO message -> m message) -> IO message -> m message
forall a b. (a -> b) -> a -> b
$ STM message -> IO message
forall a. STM a -> IO a
atomically (STM message -> IO message) -> STM message -> IO message
forall a b. (a -> b) -> a -> b
$ Queue message -> STM message
forall a. Queue a -> STM a
dequeue (ActorContext message -> Queue message
forall message. ActorContext message -> Queue message
messageQueue ActorContext message
ctx)
  ActionT message m a -> ActorContext message -> m a
forall message (m :: * -> *) a.
ActionT message m a -> ActorContext message -> m a
runActionT (message -> ActionT message m a
f message
message) ActorContext message
ctx

-- | Receive a message and, in the same transaction, produce some result.
receiveSTM :: MonadIO m => (message -> STM a) -> ActionT message m a
receiveSTM :: (message -> STM a) -> ActionT message m a
receiveSTM message -> STM a
f = (ActorContext message -> m a) -> ActionT message m a
forall message (m :: * -> *) a.
(ActorContext message -> m a) -> ActionT message m a
ActionT \ActorContext message
ctx -> IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (STM a -> IO a
forall a. STM a -> IO a
atomically (Queue message -> STM message
forall a. Queue a -> STM a
dequeue (ActorContext message -> Queue message
forall message. ActorContext message -> Queue message
messageQueue ActorContext message
ctx) STM message -> (message -> STM a) -> STM a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= message -> STM a
f))

-- | Use a natural transformation to transform an 'ActionT' on one base
-- monad to another.
hoistActionT :: (forall x. m x -> n x) -> ActionT message m a -> ActionT message n a
hoistActionT :: (forall x. m x -> n x)
-> ActionT message m a -> ActionT message n a
hoistActionT forall x. m x -> n x
f (ActionT ActorContext message -> m a
actionT) = (ActorContext message -> n a) -> ActionT message n a
forall message (m :: * -> *) a.
(ActorContext message -> m a) -> ActionT message m a
ActionT ((m a -> n a)
-> (ActorContext message -> m a) -> ActorContext message -> n a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m a -> n a
forall x. m x -> n x
f ActorContext message -> m a
actionT)

-- | The exception thrown when an actor we've 'link'ed with has died.
data LinkKill = LinkKill ThreadId
  deriving Int -> LinkKill -> ShowS
[LinkKill] -> ShowS
LinkKill -> String
(Int -> LinkKill -> ShowS)
-> (LinkKill -> String) -> ([LinkKill] -> ShowS) -> Show LinkKill
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LinkKill] -> ShowS
$cshowList :: [LinkKill] -> ShowS
show :: LinkKill -> String
$cshow :: LinkKill -> String
showsPrec :: Int -> LinkKill -> ShowS
$cshowsPrec :: Int -> LinkKill -> ShowS
Show

instance Exception LinkKill

-- | Link the lifetime of the given actor to this one. If the given actor
-- dies, it will throw a 'LinkKill' exception to us with its 'ThreadId'
-- attached to it.
link :: MonadIO m => Actor message -> ActionT message' m ()
link :: Actor message -> ActionT message' m ()
link Actor message
you = do
  Actor message'
me <- ActionT message' m (Actor message')
forall (m :: * -> *) message.
Applicative m =>
ActionT message m (Actor message)
self
  IO () -> ActionT message' m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionT message' m ())
-> (STM () -> IO ()) -> STM () -> ActionT message' m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> ActionT message' m ())
-> STM () -> ActionT message' m ()
forall a b. (a -> b) -> a -> b
$ Actor message' -> Actor message -> STM ()
forall message message'. Actor message -> Actor message' -> STM ()
linkSTM Actor message'
me Actor message
you

-- | Links the lifetime of the first actor to the second. If the second
-- actor's thread dies, it will throw a 'LinkKill' exception to the first
-- with its 'ThreadId' attached to it.
linkSTM :: Actor message -> Actor message' -> STM ()
linkSTM :: Actor message -> Actor message' -> STM ()
linkSTM Actor message
alice Actor message'
bob = do
  Actor message' -> (Maybe SomeException -> IO ()) -> STM ()
forall message.
Actor message -> (Maybe SomeException -> IO ()) -> STM ()
addAfterEffect Actor message'
bob (IO () -> Maybe SomeException -> IO ()
forall a b. a -> b -> a
const (IO () -> Maybe SomeException -> IO ())
-> IO () -> Maybe SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> LinkKill -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo (Actor message -> ThreadId
forall message. Actor message -> ThreadId
threadId Actor message
alice) (ThreadId -> LinkKill
LinkKill (Actor message' -> ThreadId
forall message. Actor message -> ThreadId
threadId Actor message'
bob)))

-- | Returns the 'Actor' handle of the actor executing this action.
self :: Applicative m => ActionT message m (Actor message)
self :: ActionT message m (Actor message)
self = (ActorContext message -> m (Actor message))
-> ActionT message m (Actor message)
forall message (m :: * -> *) a.
(ActorContext message -> m a) -> ActionT message m a
ActionT \(ActorContext{Actor message
actorHandle :: Actor message
actorHandle :: forall message. ActorContext message -> Actor message
actorHandle}) -> Actor message -> m (Actor message)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Actor message
actorHandle

-- | The exception thrown when we 'murder' an 'Actor'.
data MurderKill = MurderKill ThreadId
  deriving Int -> MurderKill -> ShowS
[MurderKill] -> ShowS
MurderKill -> String
(Int -> MurderKill -> ShowS)
-> (MurderKill -> String)
-> ([MurderKill] -> ShowS)
-> Show MurderKill
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MurderKill] -> ShowS
$cshowList :: [MurderKill] -> ShowS
show :: MurderKill -> String
$cshow :: MurderKill -> String
showsPrec :: Int -> MurderKill -> ShowS
$cshowsPrec :: Int -> MurderKill -> ShowS
Show

instance Exception MurderKill

-- | Throws a 'MurderKill' exception to the given 'Actor'.
murder :: MonadIO m => Actor message -> m ()
murder :: Actor message -> m ()
murder Actor{ThreadId
threadId' :: ThreadId
threadId' :: forall message. Actor message -> ThreadId
threadId'} = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO ThreadId
myThreadId IO ThreadId -> (ThreadId -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ThreadId -> MurderKill -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
threadId' (MurderKill -> IO ())
-> (ThreadId -> MurderKill) -> ThreadId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> MurderKill
MurderKill