{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE NoFieldSelectors #-}

module TheatreDev.StmBased.StmStructures.Runner
  ( Runner,
    start,
    tell,
    kill,
    wait,
    receiveSingle,
    receiveMultiple,
    releaseWithException,
  )
where

import Control.Concurrent.STM.TBQueue
import Control.Concurrent.STM.TMVar
import qualified TheatreDev.ExtrasFor.List as List
import TheatreDev.ExtrasFor.TBQueue
import TheatreDev.Prelude

data Runner a = Runner
  { forall a. Runner a -> TBQueue (Maybe a)
queue :: TBQueue (Maybe a),
    forall a. Runner a -> TVar Bool
aliveVar :: TVar Bool,
    forall a. Runner a -> TMVar (Maybe SomeException)
resVar :: TMVar (Maybe SomeException)
  }

start :: STM (Runner a)
start :: forall a. STM (Runner a)
start =
  do
    TBQueue (Maybe a)
queue <- forall a. Natural -> STM (TBQueue a)
newTBQueue Natural
1000
    TVar Bool
aliveVar <- forall a. a -> STM (TVar a)
newTVar Bool
True
    TMVar (Maybe SomeException)
resVar <- forall a. STM (TMVar a)
newEmptyTMVar @(Maybe SomeException)
    return Runner {TVar Bool
TBQueue (Maybe a)
TMVar (Maybe SomeException)
resVar :: TMVar (Maybe SomeException)
aliveVar :: TVar Bool
queue :: TBQueue (Maybe a)
$sel:resVar:Runner :: TMVar (Maybe SomeException)
$sel:aliveVar:Runner :: TVar Bool
$sel:queue:Runner :: TBQueue (Maybe a)
..}

tell :: Runner a -> a -> STM ()
tell :: forall a. Runner a -> a -> STM ()
tell Runner {TVar Bool
TBQueue (Maybe a)
TMVar (Maybe SomeException)
resVar :: TMVar (Maybe SomeException)
aliveVar :: TVar Bool
queue :: TBQueue (Maybe a)
$sel:resVar:Runner :: forall a. Runner a -> TMVar (Maybe SomeException)
$sel:aliveVar:Runner :: forall a. Runner a -> TVar Bool
$sel:queue:Runner :: forall a. Runner a -> TBQueue (Maybe a)
..} a
message =
  do
    Bool
alive <- forall a. TVar a -> STM a
readTVar TVar Bool
aliveVar
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
alive do
      forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (Maybe a)
queue forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
message

kill :: Runner a -> STM ()
kill :: forall a. Runner a -> STM ()
kill Runner {TVar Bool
TBQueue (Maybe a)
TMVar (Maybe SomeException)
resVar :: TMVar (Maybe SomeException)
aliveVar :: TVar Bool
queue :: TBQueue (Maybe a)
$sel:resVar:Runner :: forall a. Runner a -> TMVar (Maybe SomeException)
$sel:aliveVar:Runner :: forall a. Runner a -> TVar Bool
$sel:queue:Runner :: forall a. Runner a -> TBQueue (Maybe a)
..} =
  do
    Bool
alive <- forall a. TVar a -> STM a
readTVar TVar Bool
aliveVar
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
alive do
      forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (Maybe a)
queue forall a. Maybe a
Nothing

wait :: Runner a -> STM (Maybe SomeException)
wait :: forall a. Runner a -> STM (Maybe SomeException)
wait Runner {TVar Bool
TBQueue (Maybe a)
TMVar (Maybe SomeException)
resVar :: TMVar (Maybe SomeException)
aliveVar :: TVar Bool
queue :: TBQueue (Maybe a)
$sel:resVar:Runner :: forall a. Runner a -> TMVar (Maybe SomeException)
$sel:aliveVar:Runner :: forall a. Runner a -> TVar Bool
$sel:queue:Runner :: forall a. Runner a -> TBQueue (Maybe a)
..} =
  forall a. TMVar a -> STM a
readTMVar TMVar (Maybe SomeException)
resVar

receiveSingle ::
  Runner a ->
  -- | Action producing a message or nothing, after it's killed.
  STM (Maybe a)
receiveSingle :: forall a. Runner a -> STM (Maybe a)
receiveSingle Runner {TVar Bool
TBQueue (Maybe a)
TMVar (Maybe SomeException)
resVar :: TMVar (Maybe SomeException)
aliveVar :: TVar Bool
queue :: TBQueue (Maybe a)
$sel:resVar:Runner :: forall a. Runner a -> TMVar (Maybe SomeException)
$sel:aliveVar:Runner :: forall a. Runner a -> TVar Bool
$sel:queue:Runner :: forall a. Runner a -> TBQueue (Maybe a)
..} =
  do
    Maybe a
message <- forall a. TBQueue a -> STM a
readTBQueue TBQueue (Maybe a)
queue
    case Maybe a
message of
      Just a
message -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
message)
      Maybe a
Nothing -> do
        forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
aliveVar Bool
False
        forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Maybe SomeException)
resVar forall a. Maybe a
Nothing
        return forall a. Maybe a
Nothing

receiveMultiple ::
  Runner a ->
  STM (Maybe (NonEmpty a))
receiveMultiple :: forall a. Runner a -> STM (Maybe (NonEmpty a))
receiveMultiple Runner {TVar Bool
TBQueue (Maybe a)
TMVar (Maybe SomeException)
resVar :: TMVar (Maybe SomeException)
aliveVar :: TVar Bool
queue :: TBQueue (Maybe a)
$sel:resVar:Runner :: forall a. Runner a -> TMVar (Maybe SomeException)
$sel:aliveVar:Runner :: forall a. Runner a -> TVar Bool
$sel:queue:Runner :: forall a. Runner a -> TBQueue (Maybe a)
..} =
  do
    ([a]
messages, [Maybe a]
remainingCommands) <- do
      Natural
queueLength <- forall a. TBQueue a -> STM Natural
lengthTBQueue TBQueue (Maybe a)
queue
      Maybe a
head <- forall a. TBQueue a -> STM a
readTBQueue TBQueue (Maybe a)
queue
      [Maybe a]
tail <- forall a. TBQueue a -> STM [a]
simplerFlushTBQueue TBQueue (Maybe a)
queue
      return $ forall a. [Maybe a] -> ([a], [Maybe a])
List.splitWhileJust forall a b. (a -> b) -> a -> b
$ Maybe a
head forall a. a -> [a] -> [a]
: [Maybe a]
tail
    case [a]
messages of
      -- Implies that the tail is not empty,
      -- because we have at least one element.
      -- And that it starts with a Nothing.
      [] -> do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Maybe a]
remainingCommands forall a b. (a -> b) -> a -> b
$ forall a. TBQueue a -> a -> STM ()
unGetTBQueue TBQueue (Maybe a)
queue
        forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
aliveVar Bool
False
        forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Maybe SomeException)
resVar forall a. Maybe a
Nothing
        return forall a. Maybe a
Nothing
      a
messagesHead : [a]
messagesTail -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Maybe a]
remainingCommands) do
          forall a. TBQueue a -> a -> STM ()
unGetTBQueue TBQueue (Maybe a)
queue forall a. Maybe a
Nothing
        return $ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ a
messagesHead forall a. a -> [a] -> NonEmpty a
:| [a]
messagesTail

releaseWithException :: Runner a -> SomeException -> STM ()
releaseWithException :: forall a. Runner a -> SomeException -> STM ()
releaseWithException Runner {TVar Bool
TBQueue (Maybe a)
TMVar (Maybe SomeException)
resVar :: TMVar (Maybe SomeException)
aliveVar :: TVar Bool
queue :: TBQueue (Maybe a)
$sel:resVar:Runner :: forall a. Runner a -> TMVar (Maybe SomeException)
$sel:aliveVar:Runner :: forall a. Runner a -> TVar Bool
$sel:queue:Runner :: forall a. Runner a -> TBQueue (Maybe a)
..} SomeException
exception =
  do
    forall a. TBQueue a -> STM [a]
simplerFlushTBQueue TBQueue (Maybe a)
queue
    forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
aliveVar Bool
False
    forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Maybe SomeException)
resVar (forall a. a -> Maybe a
Just SomeException
exception)