{-# LANGUAGE MagicHash #-}

-- | Provides classes for 'STM'.
--
-- @since 0.1
module Effects.Concurrent.STM
  ( -- * Effect
    STM,
    MonadAtomic (..),

    -- * TVar
    TVar,

    -- ** Strict
    newTVar',
    readTVar',
    writeTVar',
    TVar.modifyTVar',

    -- *** Atomic
    newTVarA',
    readTVarA',
    writeTVarA',
    modifyTVarA',

    -- ** Lazy
    TVar.newTVar,
    TVar.readTVar,
    TVar.writeTVar,
    TVar.modifyTVar,

    -- *** Atomic
    newTVarA,
    readTVarA,
    writeTVarA,
    modifyTVarA,

    -- * TBQueue
    TBQueue,

    -- ** Strict
    readTBQueue',
    tryReadTBQueue',
    writeTBQueue',
    flushTBQueue',

    -- *** Atomic
    readTBQueueA',
    tryReadTBQueueA',
    writeTBQueueA',
    flushTBQueueA',

    -- ** Lazy
    TBQueue.newTBQueue,
    TBQueue.readTBQueue,
    TBQueue.tryReadTBQueue,
    TBQueue.writeTBQueue,
    TBQueue.flushTBQueue,

    -- *** Atomic
    newTBQueueA,
    readTBQueueA,
    tryReadTBQueueA,
    writeTBQueueA,
    flushTBQueueA,

    -- * Reexports
    Natural,
  )
where

import Control.Concurrent.STM qualified as STM
import Control.Concurrent.STM.TBQueue (TBQueue)
import Control.Concurrent.STM.TBQueue qualified as TBQueue
import Control.Concurrent.STM.TVar (TVar)
import Control.Concurrent.STM.TVar qualified as TVar
import Control.Monad ((>=>))
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Reader (ReaderT)
import GHC.Conc (STM (STM))
import GHC.Exts (seq#)
import GHC.Stack (HasCallStack)
import Numeric.Natural (Natural)

-- | Effect for atomically lifting 'STM' actions. Note that this classes is
-- intended for "IO-like" monads /not/ "STM-like" monads -- hence has no STM
-- instance -- as the semantics for "STM-like" and "can lift STM atomically"
-- are different.
--
-- @since 0.1
class (Monad m) => MonadAtomic m where
  -- | Lifted 'STM.atomically'.
  --
  -- @since 0.1
  atomically :: (HasCallStack) => STM a -> m a

-- | @since 0.1
instance MonadAtomic IO where
  atomically :: forall a. HasCallStack => STM a -> IO a
atomically = STM a -> IO a
forall a. STM a -> IO a
STM.atomically
  {-# INLINEABLE atomically #-}

-- | @since 0.1
instance (MonadAtomic m) => MonadAtomic (ReaderT e m) where
  atomically :: forall a. HasCallStack => STM a -> ReaderT e m a
atomically = m a -> ReaderT e m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT e m a) -> (STM a -> m a) -> STM a -> ReaderT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM a -> m a
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically
  {-# INLINEABLE atomically #-}

-- | Evaluates the input to 'TVar.newTVar' to WHNF.
--
-- @since 0.1
newTVar' :: a -> STM (TVar a)
newTVar' :: forall a. a -> STM (TVar a)
newTVar' = a -> STM a
forall a. a -> STM a
evaluateSTM (a -> STM a) -> (a -> STM (TVar a)) -> a -> STM (TVar a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> STM (TVar a)
forall a. a -> STM (TVar a)
TVar.newTVar

-- | Create a new 'TVar' holding a value supplied and lifts the result via
-- 'atomically'.
--
-- @since 0.1
newTVarA :: (HasCallStack, MonadAtomic m) => a -> m (TVar a)
newTVarA :: forall (m :: * -> *) a.
(HasCallStack, MonadAtomic m) =>
a -> m (TVar a)
newTVarA = STM (TVar a) -> m (TVar a)
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM (TVar a) -> m (TVar a))
-> (a -> STM (TVar a)) -> a -> m (TVar a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> STM (TVar a)
forall a. a -> STM (TVar a)
TVar.newTVar
{-# INLINEABLE newTVarA #-}

-- | Atomic 'newTVar''.
--
-- @since 0.1
newTVarA' :: (HasCallStack, MonadAtomic m) => a -> m (TVar a)
newTVarA' :: forall (m :: * -> *) a.
(HasCallStack, MonadAtomic m) =>
a -> m (TVar a)
newTVarA' = STM (TVar a) -> m (TVar a)
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM (TVar a) -> m (TVar a))
-> (a -> STM (TVar a)) -> a -> m (TVar a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> STM (TVar a)
forall a. a -> STM (TVar a)
newTVar'
{-# INLINEABLE newTVarA' #-}

-- | Evaluates the output from 'TVar.readTVar' to WHNF.
--
-- @since 0.1
readTVar' :: TVar a -> STM a
readTVar' :: forall a. TVar a -> STM a
readTVar' = TVar a -> STM a
forall a. TVar a -> STM a
TVar.readTVar (TVar a -> STM a) -> (a -> STM a) -> TVar a -> STM a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> STM a
forall a. a -> STM a
evaluateSTM

-- | Return the current value stored in a 'TVar' and lifts the result via
-- 'atomically'.
--
-- @since 0.1
readTVarA :: (HasCallStack, MonadAtomic m) => TVar a -> m a
readTVarA :: forall (m :: * -> *) a.
(HasCallStack, MonadAtomic m) =>
TVar a -> m a
readTVarA = STM a -> m a
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM a -> m a) -> (TVar a -> STM a) -> TVar a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar a -> STM a
forall a. TVar a -> STM a
TVar.readTVar
{-# INLINEABLE readTVarA #-}

-- | Atomic 'readTVarA''.
--
-- @since 0.1
readTVarA' :: (HasCallStack, MonadAtomic m) => TVar a -> m a
readTVarA' :: forall (m :: * -> *) a.
(HasCallStack, MonadAtomic m) =>
TVar a -> m a
readTVarA' = STM a -> m a
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM a -> m a) -> (TVar a -> STM a) -> TVar a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar a -> STM a
forall a. TVar a -> STM a
readTVar'
{-# INLINEABLE readTVarA' #-}

-- | Evaluates the input to 'TVar.writeTVar' to WHNF.
--
-- @since 0.1
writeTVar' :: TVar a -> a -> STM ()
writeTVar' :: forall a. TVar a -> a -> STM ()
writeTVar' TVar a
var = a -> STM a
forall a. a -> STM a
evaluateSTM (a -> STM a) -> (a -> STM ()) -> a -> STM ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
TVar.writeTVar TVar a
var

-- | Write the supplied value into a 'TVar' and lifts the action via
-- 'atomically'.
--
-- @since 0.1
writeTVarA :: (HasCallStack, MonadAtomic m) => TVar a -> a -> m ()
writeTVarA :: forall (m :: * -> *) a.
(HasCallStack, MonadAtomic m) =>
TVar a -> a -> m ()
writeTVarA TVar a
r = STM () -> m ()
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM () -> m ()) -> (a -> STM ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
TVar.writeTVar TVar a
r
{-# INLINEABLE writeTVarA #-}

-- | Atomic 'writeTVarA''.
--
-- @since 0.1
writeTVarA' :: (HasCallStack, MonadAtomic m) => TVar a -> a -> m ()
writeTVarA' :: forall (m :: * -> *) a.
(HasCallStack, MonadAtomic m) =>
TVar a -> a -> m ()
writeTVarA' TVar a
r = STM () -> m ()
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM () -> m ()) -> (a -> STM ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar' TVar a
r
{-# INLINEABLE writeTVarA' #-}

-- | Atomic 'TVar.modifyTVar'.
--
-- @since 0.1
modifyTVarA :: (HasCallStack, MonadAtomic m) => TVar a -> (a -> a) -> m ()
modifyTVarA :: forall (m :: * -> *) a.
(HasCallStack, MonadAtomic m) =>
TVar a -> (a -> a) -> m ()
modifyTVarA TVar a
r = STM () -> m ()
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM () -> m ()) -> ((a -> a) -> STM ()) -> (a -> a) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar a -> (a -> a) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
TVar.modifyTVar TVar a
r
{-# INLINEABLE modifyTVarA #-}

-- | Atomic 'TVar.modifyTVar''.
--
-- @since 0.1
modifyTVarA' :: (HasCallStack, MonadAtomic m) => TVar a -> (a -> a) -> m ()
modifyTVarA' :: forall (m :: * -> *) a.
(HasCallStack, MonadAtomic m) =>
TVar a -> (a -> a) -> m ()
modifyTVarA' TVar a
r = STM () -> m ()
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM () -> m ()) -> ((a -> a) -> STM ()) -> (a -> a) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar a -> (a -> a) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
TVar.modifyTVar' TVar a
r
{-# INLINEABLE modifyTVarA' #-}

-- | Builds and returns a new instance of 'TBQueue', lifting via 'atomically'.
--
-- @since 0.1
newTBQueueA ::
  (HasCallStack, MonadAtomic m) =>
  -- | maximum number of elements the queue can hold
  Natural ->
  m (TBQueue a)
newTBQueueA :: forall (m :: * -> *) a.
(HasCallStack, MonadAtomic m) =>
Natural -> m (TBQueue a)
newTBQueueA = STM (TBQueue a) -> m (TBQueue a)
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM (TBQueue a) -> m (TBQueue a))
-> (Natural -> STM (TBQueue a)) -> Natural -> m (TBQueue a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> STM (TBQueue a)
forall a. Natural -> STM (TBQueue a)
TBQueue.newTBQueue
{-# INLINEABLE newTBQueueA #-}

-- | Evaluates the output from 'TBQueue.readTBQueue' to WHNF.
--
-- @since 0.1
readTBQueue' :: TBQueue a -> STM a
readTBQueue' :: forall a. TBQueue a -> STM a
readTBQueue' = TBQueue a -> STM a
forall a. TBQueue a -> STM a
TBQueue.readTBQueue (TBQueue a -> STM a) -> (a -> STM a) -> TBQueue a -> STM a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> STM a
forall a. a -> STM a
evaluateSTM
{-# INLINEABLE readTBQueue' #-}

-- | Read the next value from the 'TBQueue', lifting via 'atomically'.
--
-- @since 0.1
readTBQueueA :: (HasCallStack, MonadAtomic m) => TBQueue a -> m a
readTBQueueA :: forall (m :: * -> *) a.
(HasCallStack, MonadAtomic m) =>
TBQueue a -> m a
readTBQueueA = STM a -> m a
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM a -> m a) -> (TBQueue a -> STM a) -> TBQueue a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue a -> STM a
forall a. TBQueue a -> STM a
TBQueue.readTBQueue
{-# INLINEABLE readTBQueueA #-}

-- | Atomic 'readTBQueue''.
--
-- @since 0.1
readTBQueueA' :: (HasCallStack, MonadAtomic m) => TBQueue a -> m a
readTBQueueA' :: forall (m :: * -> *) a.
(HasCallStack, MonadAtomic m) =>
TBQueue a -> m a
readTBQueueA' = STM a -> m a
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM a -> m a) -> (TBQueue a -> STM a) -> TBQueue a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue a -> STM a
forall a. TBQueue a -> STM a
readTBQueue'
{-# INLINEABLE readTBQueueA' #-}

-- | Evaluates the output from 'TBQueue.tryReadTBQueue' to Nothing or
-- @Just a@, where @a@ is in WHNF.
--
-- @since 0.1
tryReadTBQueue' :: TBQueue a -> STM (Maybe a)
tryReadTBQueue' :: forall a. TBQueue a -> STM (Maybe a)
tryReadTBQueue' =
  TBQueue a -> STM (Maybe a)
forall a. TBQueue a -> STM (Maybe a)
TBQueue.tryReadTBQueue (TBQueue a -> STM (Maybe a))
-> (Maybe a -> STM (Maybe a)) -> TBQueue a -> STM (Maybe a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
    Maybe a
Nothing -> Maybe a -> STM (Maybe a)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    Just a
x -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> STM a -> STM (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> STM a
forall a. a -> STM a
evaluateSTM a
x
{-# INLINEABLE tryReadTBQueue' #-}

-- | A version of 'TBQueue.readTBQueue' which does not retry. Instead it
-- returns @Nothing@ if no value is available. Lifts via 'atomically'.
--
-- @since 0.1
tryReadTBQueueA :: (HasCallStack, MonadAtomic m) => TBQueue a -> m (Maybe a)
tryReadTBQueueA :: forall (m :: * -> *) a.
(HasCallStack, MonadAtomic m) =>
TBQueue a -> m (Maybe a)
tryReadTBQueueA = STM (Maybe a) -> m (Maybe a)
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM (Maybe a) -> m (Maybe a))
-> (TBQueue a -> STM (Maybe a)) -> TBQueue a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue a -> STM (Maybe a)
forall a. TBQueue a -> STM (Maybe a)
TBQueue.tryReadTBQueue
{-# INLINEABLE tryReadTBQueueA #-}

-- | Atomic 'tryReadTBQueue''.
--
-- @since 0.1
tryReadTBQueueA' :: (HasCallStack, MonadAtomic m) => TBQueue a -> m (Maybe a)
tryReadTBQueueA' :: forall (m :: * -> *) a.
(HasCallStack, MonadAtomic m) =>
TBQueue a -> m (Maybe a)
tryReadTBQueueA' = STM (Maybe a) -> m (Maybe a)
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM (Maybe a) -> m (Maybe a))
-> (TBQueue a -> STM (Maybe a)) -> TBQueue a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue a -> STM (Maybe a)
forall a. TBQueue a -> STM (Maybe a)
tryReadTBQueue'
{-# INLINEABLE tryReadTBQueueA' #-}

-- | Evaluates the input to 'TBQueue.writeTBQueue' to WHNF.
--
-- @since 0.1
writeTBQueue' :: TBQueue a -> a -> STM ()
writeTBQueue' :: forall a. TBQueue a -> a -> STM ()
writeTBQueue' TBQueue a
q = a -> STM a
forall a. a -> STM a
evaluateSTM (a -> STM a) -> (a -> STM ()) -> a -> STM ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> TBQueue a -> a -> STM ()
forall a. TBQueue a -> a -> STM ()
TBQueue.writeTBQueue TBQueue a
q

-- | Write a value to a 'TBQueue'; blocks if the queue is full. Lifts via
-- 'atomically'.
--
-- @since 0.1
writeTBQueueA :: (HasCallStack, MonadAtomic m) => TBQueue a -> a -> m ()
writeTBQueueA :: forall (m :: * -> *) a.
(HasCallStack, MonadAtomic m) =>
TBQueue a -> a -> m ()
writeTBQueueA TBQueue a
q = STM () -> m ()
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM () -> m ()) -> (a -> STM ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue a -> a -> STM ()
forall a. TBQueue a -> a -> STM ()
TBQueue.writeTBQueue TBQueue a
q
{-# INLINEABLE writeTBQueueA #-}

-- | Atomic 'writeTBQueue''.
--
-- @since 0.1
writeTBQueueA' :: (HasCallStack, MonadAtomic m) => TBQueue a -> a -> m ()
writeTBQueueA' :: forall (m :: * -> *) a.
(HasCallStack, MonadAtomic m) =>
TBQueue a -> a -> m ()
writeTBQueueA' TBQueue a
q = STM () -> m ()
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM () -> m ()) -> (a -> STM ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue a -> a -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue' TBQueue a
q
{-# INLINEABLE writeTBQueueA' #-}

-- | Evaluates the output from 'TBQueue.flushTBQueue' to WHNF.
--
-- @since 0.1
flushTBQueue' :: TBQueue a -> STM [a]
flushTBQueue' :: forall a. TBQueue a -> STM [a]
flushTBQueue' = TBQueue a -> STM [a]
forall a. TBQueue a -> STM [a]
TBQueue.flushTBQueue (TBQueue a -> STM [a]) -> ([a] -> STM [a]) -> TBQueue a -> STM [a]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [a] -> STM [a]
forall a. a -> STM a
evaluateSTM

-- | Efficiently read the entire contents of a 'TBQueue' into a list. This
-- function never retries. Lifts via 'atomically'.
--
-- @since 0.1
flushTBQueueA :: (HasCallStack, MonadAtomic m) => TBQueue a -> m [a]
flushTBQueueA :: forall (m :: * -> *) a.
(HasCallStack, MonadAtomic m) =>
TBQueue a -> m [a]
flushTBQueueA = STM [a] -> m [a]
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM [a] -> m [a]) -> (TBQueue a -> STM [a]) -> TBQueue a -> m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue a -> STM [a]
forall a. TBQueue a -> STM [a]
TBQueue.flushTBQueue
{-# INLINEABLE flushTBQueueA #-}

-- | Atomic 'flushTBQueue''.
--
-- @since 0.1
flushTBQueueA' :: (HasCallStack, MonadAtomic m) => TBQueue a -> m [a]
flushTBQueueA' :: forall (m :: * -> *) a.
(HasCallStack, MonadAtomic m) =>
TBQueue a -> m [a]
flushTBQueueA' = STM [a] -> m [a]
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM [a] -> m [a]) -> (TBQueue a -> STM [a]) -> TBQueue a -> m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue a -> STM [a]
forall a. TBQueue a -> STM [a]
flushTBQueue'
{-# INLINEABLE flushTBQueueA' #-}

-- | Like 'Control.Exception.evaluate', but for 'STM'.
--
-- @since 0.1
evaluateSTM :: a -> STM a
evaluateSTM :: forall a. a -> STM a
evaluateSTM a
a = (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ((State# RealWorld -> (# State# RealWorld, a #)) -> STM a)
-> (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> a -> State# RealWorld -> (# State# RealWorld, a #)
forall a s. a -> State# s -> (# State# s, a #)
seq# a
a State# RealWorld
s