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

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

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

    -- * Reexports
    Natural,
  )
where

import Control.Concurrent.STM (STM)
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.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Reader (ReaderT)
import GHC.Stack (HasCallStack)
import Numeric.Natural (Natural)

-- | 'STM' effect. Note that this class is for monads that can lift entire
-- STM transactions (i.e. atomically). It is not intended for "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) => MonadSTM m where
  -- | Lifted 'STM.atomically'.
  --
  -- @since 0.1
  atomically :: (HasCallStack) => STM a -> m a

-- | @since 0.1
instance MonadSTM 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 (MonadSTM m) => MonadSTM (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. (MonadSTM m, HasCallStack) => STM a -> m a
atomically
  {-# INLINEABLE atomically #-}

-- | Create a new 'TVar' holding a value supplied and lifts the result via
-- 'atomically'.
--
-- @since 0.1
newTVarA :: (HasCallStack, MonadSTM m) => a -> m (TVar a)
newTVarA :: forall (m :: * -> *) a.
(HasCallStack, MonadSTM m) =>
a -> m (TVar a)
newTVarA = STM (TVar a) -> m (TVar a)
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a. (MonadSTM 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 #-}

-- | Return the current value stored in a 'TVar' and lifts the result via
-- 'atomically'.
--
-- @since 0.1
readTVarA :: (HasCallStack, MonadSTM m) => TVar a -> m a
readTVarA :: forall (m :: * -> *) a. (HasCallStack, MonadSTM m) => TVar a -> m a
readTVarA = STM a -> m a
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a. (MonadSTM 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 #-}

-- | Write the supplied value into a 'TVar' and lifts the action via
-- 'atomically'.
--
-- @since 0.1
writeTVarA :: (HasCallStack, MonadSTM m) => TVar a -> a -> m ()
writeTVarA :: forall (m :: * -> *) a.
(HasCallStack, MonadSTM m) =>
TVar a -> a -> m ()
writeTVarA TVar a
r = STM () -> m ()
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a. (MonadSTM 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 #-}

-- | Strict version of 'TVar.modifyTVar', lifting the action via
-- 'atomically'.
--
-- @since 0.1
modifyTVarA' :: (HasCallStack, MonadSTM m) => TVar a -> (a -> a) -> m ()
modifyTVarA' :: forall (m :: * -> *) a.
(HasCallStack, MonadSTM m) =>
TVar a -> (a -> a) -> m ()
modifyTVarA' TVar a
r = STM () -> m ()
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a. (MonadSTM 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, MonadSTM m) =>
  -- | maximum number of elements the queue can hold
  Natural ->
  m (TBQueue a)
newTBQueueA :: forall (m :: * -> *) a.
(HasCallStack, MonadSTM m) =>
Natural -> m (TBQueue a)
newTBQueueA = STM (TBQueue a) -> m (TBQueue a)
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a. (MonadSTM 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 #-}

-- | Read the next value from the 'TBQueue', lifting via 'atomically'.
--
-- @since 0.1
readTBQueueA :: (HasCallStack, MonadSTM m) => TBQueue a -> m a
readTBQueueA :: forall (m :: * -> *) a.
(HasCallStack, MonadSTM m) =>
TBQueue a -> m a
readTBQueueA = STM a -> m a
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a. (MonadSTM 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 #-}

-- | 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, MonadSTM m) => TBQueue a -> m (Maybe a)
tryReadTBQueueA :: forall (m :: * -> *) a.
(HasCallStack, MonadSTM m) =>
TBQueue a -> m (Maybe a)
tryReadTBQueueA = STM (Maybe a) -> m (Maybe a)
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a. (MonadSTM 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 #-}

-- | Write a value to a 'TBQueue'; blocks if the queue is full. Lifts via
-- 'atomically'.
--
-- @since 0.1
writeTBQueueA :: (HasCallStack, MonadSTM m) => TBQueue a -> a -> m ()
writeTBQueueA :: forall (m :: * -> *) a.
(HasCallStack, MonadSTM m) =>
TBQueue a -> a -> m ()
writeTBQueueA TBQueue a
q = STM () -> m ()
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a. (MonadSTM 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 #-}

-- | Efficiently read the entire contents of a 'TBQueue' into a list. This
-- function never retries. Lifts via 'atomically'.
--
-- @since 0.1
flushTBQueueA :: (HasCallStack, MonadSTM m) => TBQueue a -> m [a]
flushTBQueueA :: forall (m :: * -> *) a.
(HasCallStack, MonadSTM m) =>
TBQueue a -> m [a]
flushTBQueueA = STM [a] -> m [a]
forall a. HasCallStack => STM a -> m a
forall (m :: * -> *) a. (MonadSTM 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 #-}