module TheatreDev.Perpetual
( Actor,
spawnStateless,
spawnStateful,
tell,
)
where
import qualified Control.Concurrent.Chan.Unagi as Unagi
import TheatreDev.Prelude
newtype Actor msg
= Actor (msg -> IO ())
instance Semigroup (Actor msg) where
Actor msg -> IO ()
lTell <> :: Actor msg -> Actor msg -> Actor msg
<> Actor msg -> IO ()
rTell =
forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ \msg
msg -> msg -> IO ()
lTell msg
msg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> msg -> IO ()
rTell msg
msg
sconcat :: NonEmpty (Actor msg) -> Actor msg
sconcat NonEmpty (Actor msg)
actors = forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ \msg
msg -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty (Actor msg)
actors forall a b. (a -> b) -> a -> b
$ \(Actor msg -> IO ()
tell) -> msg -> IO ()
tell msg
msg
stimes :: forall b. Integral b => b -> Actor msg -> Actor msg
stimes b
n (Actor msg -> IO ()
tell) = forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ \msg
msg -> forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (forall a b. (Integral a, Num b) => a -> b
fromIntegral b
n) forall a b. (a -> b) -> a -> b
$ msg -> IO ()
tell msg
msg
instance Monoid (Actor msg) where
mempty :: Actor msg
mempty = forall msg. (msg -> IO ()) -> Actor msg
Actor (forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ()))
mconcat :: [Actor msg] -> Actor msg
mconcat [Actor msg]
actors = forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ \msg
msg -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Actor msg]
actors forall a b. (a -> b) -> a -> b
$ \(Actor msg -> IO ()
tell) -> msg -> IO ()
tell msg
msg
instance Contravariant Actor where
contramap :: forall a' a. (a' -> a) -> Actor a -> Actor a'
contramap a' -> a
fn (Actor a -> IO ()
tell) =
forall msg. (msg -> IO ()) -> Actor msg
Actor (a -> IO ()
tell forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a' -> a
fn)
instance Divisible Actor where
conquer :: forall msg. Actor msg
conquer =
forall a. Monoid a => a
mempty
divide :: forall a b c. (a -> (b, c)) -> Actor b -> Actor c -> Actor a
divide a -> (b, c)
divisor (Actor b -> IO ()
lTell) (Actor c -> IO ()
rTell) =
forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ \a
msg -> case a -> (b, c)
divisor a
msg of
(b
lMsg, c
rMsg) -> b -> IO ()
lTell b
lMsg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> c -> IO ()
rTell c
rMsg
instance Decidable Actor where
lose :: forall a. (a -> Void) -> Actor a
lose a -> Void
_ =
forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
choose :: forall a b c. (a -> Either b c) -> Actor b -> Actor c -> Actor a
choose a -> Either b c
decider (Actor b -> IO ()
lTell) (Actor c -> IO ()
rTell) =
forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> IO ()
lTell c -> IO ()
rTell forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Either b c
decider
spawnStateless ::
(msg -> IO ()) ->
IO (Actor msg)
spawnStateless :: forall msg. (msg -> IO ()) -> IO (Actor msg)
spawnStateless msg -> IO ()
process = do
(InChan msg
inChan, OutChan msg
outChan) <- forall a. IO (InChan a, OutChan a)
Unagi.newChan
IO () -> IO ThreadId
forkIO
forall a b. (a -> b) -> a -> b
$ let loop :: IO ()
loop = do
msg
msg <- forall a. OutChan a -> IO a
Unagi.readChan OutChan msg
outChan
msg -> IO ()
process msg
msg
IO ()
loop
in IO ()
loop
return $ forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ forall a. InChan a -> a -> IO ()
Unagi.writeChan InChan msg
inChan
spawnStateful ::
state ->
(state -> msg -> IO state) ->
IO (Actor msg)
spawnStateful :: forall state msg.
state -> (state -> msg -> IO state) -> IO (Actor msg)
spawnStateful state
state state -> msg -> IO state
process = do
(InChan msg
inChan, OutChan msg
outChan) <- forall a. IO (InChan a, OutChan a)
Unagi.newChan
IO () -> IO ThreadId
forkIO
forall a b. (a -> b) -> a -> b
$ let loop :: state -> IO ()
loop !state
state = do
msg
msg <- forall a. OutChan a -> IO a
Unagi.readChan OutChan msg
outChan
state
state <- state -> msg -> IO state
process state
state msg
msg
state -> IO ()
loop state
state
in state -> IO ()
loop state
state
return $ forall msg. (msg -> IO ()) -> Actor msg
Actor forall a b. (a -> b) -> a -> b
$ forall a. InChan a -> a -> IO ()
Unagi.writeChan InChan msg
inChan
tell :: Actor msg -> msg -> IO ()
tell :: forall msg. Actor msg -> msg -> IO ()
tell = coerce :: forall a b. Coercible a b => a -> b
coerce