{-# 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
( ActionT
, Actor
, send
, addAfterEffect
, threadId
, livenessCheck
, withLivenessCheck
, Liveness(..)
, ActorDead(..)
, actFinally
, act
, receiveSTM
, receive
, hoistActionT
, link
, linkSTM
, LinkKill(..)
, self
, murder
, MurderKill(..)
) where
import Control.Applicative
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 )
newtype ActionT message m a = ActionT
{ forall message (m :: * -> *) a.
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)
deriving via ReaderT (ActorContext message) m instance Alternative m => Alternative (ActionT message m)
instance MonadReader r m => MonadReader r (ActionT message m) where
ask :: ActionT message m r
ask = forall message (m :: * -> *) a.
(ActorContext message -> m a) -> ActionT message m a
ActionT (forall a b. a -> b -> a
const forall r (m :: * -> *). MonadReader r m => m r
ask)
local :: forall a. (r -> r) -> ActionT message m a -> ActionT message m a
local r -> r
f (ActionT ActorContext message -> m a
ma) = forall message (m :: * -> *) a.
(ActorContext message -> m a) -> ActionT message m a
ActionT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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
{ forall message. ActorContext message -> Queue message
messageQueue :: Queue message
, forall message. ActorContext message -> Actor message
actorHandle :: Actor message
}
data Actor message = Actor
{ forall message.
Actor message -> (Maybe SomeException -> IO ()) -> STM ()
addAfterEffect' :: (Maybe SomeException -> IO ()) -> STM ()
, forall message. Actor message -> ThreadId
threadId' :: ThreadId
, forall message. Actor message -> message -> STM ()
send' :: message -> STM ()
, forall message. Actor message -> TVar (Maybe (Maybe SomeException))
status :: TVar (Maybe (Maybe SomeException))
}
data Liveness = Alive | Completed | ThrewException SomeException
deriving Int -> Liveness -> ShowS
[Liveness] -> ShowS
Liveness -> String
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
livenessCheck :: Actor message -> STM Liveness
livenessCheck :: forall message. Actor message -> STM Liveness
livenessCheck Actor message
actor = do
forall a. TVar a -> STM a
readTVar (forall message. Actor message -> TVar (Maybe (Maybe SomeException))
status Actor message
actor) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Maybe SomeException)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Liveness
Alive
Just Maybe SomeException
completion -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Liveness
Completed SomeException -> Liveness
ThrewException Maybe SomeException
completion)
data ActorDead = ActorDead (Maybe SomeException)
deriving Int -> ActorDead -> ShowS
[ActorDead] -> ShowS
ActorDead -> String
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
withLivenessCheck :: (Actor message -> x -> STM ()) -> Actor message -> x -> STM ()
withLivenessCheck :: forall message x.
(Actor message -> x -> STM ()) -> Actor message -> x -> STM ()
withLivenessCheck Actor message -> x -> STM ()
f Actor message
actorHandle x
x = forall a. TVar a -> STM a
readTVar (forall message. Actor message -> TVar (Maybe (Maybe SomeException))
status Actor message
actorHandle) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Actor message -> x -> STM ()
f Actor message
actorHandle x
x) (forall e a. Exception e => e -> STM a
throwSTM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SomeException -> ActorDead
ActorDead)
addAfterEffect :: Actor message -> (Maybe SomeException -> IO ()) -> STM ()
addAfterEffect :: forall message.
Actor message -> (Maybe SomeException -> IO ()) -> STM ()
addAfterEffect = forall message.
Actor message -> (Maybe SomeException -> IO ()) -> STM ()
addAfterEffect'
threadId :: Actor message -> ThreadId
threadId :: forall message. Actor message -> ThreadId
threadId = forall message. Actor message -> ThreadId
threadId'
send :: Actor message -> message -> STM ()
send :: forall message. Actor message -> message -> STM ()
send = 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 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'} = forall a. Show a => a -> String
show ThreadId
threadId'
instance Contravariant Actor where
contramap :: forall a' a. (a' -> a) -> Actor a -> Actor a'
contramap a' -> a
f (Actor (Maybe SomeException -> IO ()) -> STM ()
addAfterEffect' ThreadId
threadId' ((forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f) -> a' -> STM ()
send') TVar (Maybe (Maybe SomeException))
status) = 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 ()
..}
actFinally :: (Either SomeException a -> IO ()) -> ActionT message IO a -> IO (Actor message)
actFinally :: forall a message.
(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 <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. a -> STM (TVar a)
newTVar Either SomeException a -> IO ()
errorHandler
Queue message
messageQueue <- forall a. STM a -> IO a
atomically forall a. STM (Queue a)
newQueue
TVar (Maybe (Maybe SomeException))
status <- forall a. a -> IO (TVar a)
newTVarIO forall a. Maybe a
Nothing
let addAfterEffect' :: (Maybe SomeException -> IO ()) -> STM ()
addAfterEffect' Maybe SomeException -> IO ()
afterEffect = 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 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Maybe SomeException -> IO ()
afterEffect (forall {a} {b}. Either a b -> Maybe a
leftToMaybe Either SomeException a
x))
let send' :: message -> STM ()
send' = forall a. Queue a -> a -> STM ()
enqueue Queue message
messageQueue
ThreadId
threadId' <- forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (do { ThreadId
threadId' <- IO ThreadId
myThreadId; ActorContext message -> IO a
actionT (forall message.
Queue message -> Actor message -> ActorContext message
ActorContext Queue message
messageQueue 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 -> forall a. STM a -> IO a
atomically (do { forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe (Maybe SomeException))
status (forall a. a -> Maybe a
Just (forall {a} {b}. Either a b -> Maybe a
leftToMaybe Either SomeException a
result)); forall a. TVar a -> STM a
readTVar TVar (Either SomeException a -> IO ())
onErrorTVar }) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a b. (a -> b) -> a -> b
$ Either SomeException a
result))
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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) = forall a. a -> Maybe a
Just a
x
leftToMaybe Either a b
_ = forall a. Maybe a
Nothing
act :: ActionT message IO a -> IO (Actor message)
act :: forall message a. ActionT message IO a -> IO (Actor message)
act = forall a message.
(Either SomeException a -> IO ())
-> ActionT message IO a -> IO (Actor message)
actFinally (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
receive :: MonadIO m => (message -> ActionT message m a) -> ActionT message m a
receive :: forall (m :: * -> *) message a.
MonadIO m =>
(message -> ActionT message m a) -> ActionT message m a
receive message -> ActionT message m a
f = forall message (m :: * -> *) a.
(ActorContext message -> m a) -> ActionT message m a
ActionT \ActorContext message
ctx -> do
message
message <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. Queue a -> STM a
dequeue (forall message. ActorContext message -> Queue message
messageQueue ActorContext message
ctx)
forall message (m :: * -> *) a.
ActionT message m a -> ActorContext message -> m a
runActionT (message -> ActionT message m a
f message
message) ActorContext message
ctx
receiveSTM :: MonadIO m => (message -> STM a) -> ActionT message m a
receiveSTM :: forall (m :: * -> *) message a.
MonadIO m =>
(message -> STM a) -> ActionT message m a
receiveSTM message -> STM a
f = forall message (m :: * -> *) a.
(ActorContext message -> m a) -> ActionT message m a
ActionT \ActorContext message
ctx -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. STM a -> IO a
atomically (forall a. Queue a -> STM a
dequeue (forall message. ActorContext message -> Queue message
messageQueue ActorContext message
ctx) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= message -> STM a
f))
hoistActionT :: (forall x. m x -> n x) -> ActionT message m a -> ActionT message n a
hoistActionT :: forall (m :: * -> *) (n :: * -> *) message a.
(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) = forall message (m :: * -> *) a.
(ActorContext message -> m a) -> ActionT message m a
ActionT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall x. m x -> n x
f ActorContext message -> m a
actionT)
data LinkKill = LinkKill ThreadId
deriving Int -> LinkKill -> ShowS
[LinkKill] -> ShowS
LinkKill -> String
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 :: MonadIO m => Actor message -> ActionT message' m ()
link :: forall (m :: * -> *) message message'.
MonadIO m =>
Actor message -> ActionT message' m ()
link Actor message
you = do
Actor message'
me <- forall (m :: * -> *) message.
Applicative m =>
ActionT message m (Actor message)
self
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall message message'. Actor message -> Actor message' -> STM ()
linkSTM Actor message'
me Actor message
you
linkSTM :: Actor message -> Actor message' -> STM ()
linkSTM :: forall message message'. Actor message -> Actor message' -> STM ()
linkSTM Actor message
alice Actor message'
bob = do
forall message.
Actor message -> (Maybe SomeException -> IO ()) -> STM ()
addAfterEffect Actor message'
bob (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall e. Exception e => ThreadId -> e -> IO ()
throwTo (forall message. Actor message -> ThreadId
threadId Actor message
alice) (ThreadId -> LinkKill
LinkKill (forall message. Actor message -> ThreadId
threadId Actor message'
bob)))
self :: Applicative m => ActionT message m (Actor message)
self :: forall (m :: * -> *) message.
Applicative m =>
ActionT message m (Actor message)
self = 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}) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Actor message
actorHandle
data MurderKill = MurderKill ThreadId
deriving Int -> MurderKill -> ShowS
[MurderKill] -> ShowS
MurderKill -> String
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
murder :: MonadIO m => Actor message -> m ()
murder :: forall (m :: * -> *) message. MonadIO m => Actor message -> m ()
murder Actor{ThreadId
threadId' :: ThreadId
threadId' :: forall message. Actor message -> ThreadId
threadId'} = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do { ThreadId
tid <- IO ThreadId
myThreadId; forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
threadId' (ThreadId -> MurderKill
MurderKill ThreadId
tid) }