{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
{-# LANGUAGE CPP, DeriveDataTypeable #-}

#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
----------------------------------------------------------------
--                                                    2021.10.17
-- |
-- Module      :  Control.Concurrent.STM.TBChan
-- Copyright   :  Copyright (c) 2011--2021 wren gayle romano
-- License     :  BSD
-- Maintainer  :  wren@cpan.org
-- Stability   :  provisional
-- Portability :  non-portable (GHC STM, DeriveDataTypeable)
--
-- A version of "Control.Concurrent.STM.TChan" where the queue is
-- bounded in length. This variant incorporates ideas from Thomas
-- M. DuBuisson's @bounded-tchan@ package in order to reduce
-- contention between readers and writers.
----------------------------------------------------------------
module Control.Concurrent.STM.TBChan
    (
    -- * The TBChan type
      TBChan()
    -- ** Creating TBChans
    , newTBChan
    , newTBChanIO
    -- I don't know how to define dupTBChan with the correct semantics
    -- ** Reading from TBChans
    , readTBChan
    , tryReadTBChan
    , peekTBChan
    , tryPeekTBChan
    -- ** Writing to TBChans
    , writeTBChan
    , tryWriteTBChan
    , unGetTBChan
    -- ** Predicates
    , isEmptyTBChan
    , isFullTBChan
    -- ** Other functionality
    , estimateFreeSlotsTBChan
    , freeSlotsTBChan
    ) where

import Prelude           hiding (reads)
import Data.Typeable     (Typeable)
import Control.Monad.STM (STM, retry)
import Control.Concurrent.STM.TVar
import Control.Concurrent.STM.TChan -- N.B., GHC only
----------------------------------------------------------------

-- | @TBChan@ is an abstract type representing a bounded FIFO
-- channel.
data TBChan a = TBChan
    {-# UNPACK #-} !(TVar Int)
    {-# UNPACK #-} !(TVar Int)
    {-# UNPACK #-} !(TChan a)
    deriving (Typeable)
-- The components are:
-- * How many free slots we /know/ we have available.
-- * How many slots have been freed up by successful reads since
--   the last time the slot count was synchronized by 'isFullTBChan'.
-- * The underlying TChan.


-- | Build and returns a new instance of @TBChan@ with the given
-- capacity. /N.B./, we do not verify the capacity is positive, but
-- if it is non-positive then 'writeTBChan' will always retry and
-- 'isFullTBChan' will always be true.
newTBChan :: Int -> STM (TBChan a)
newTBChan :: Int -> STM (TBChan a)
newTBChan Int
n = do
    TVar Int
slots <- Int -> STM (TVar Int)
forall a. a -> STM (TVar a)
newTVar Int
n
    TVar Int
reads <- Int -> STM (TVar Int)
forall a. a -> STM (TVar a)
newTVar Int
0
    TChan a
chan  <- STM (TChan a)
forall a. STM (TChan a)
newTChan
    TBChan a -> STM (TBChan a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar Int -> TVar Int -> TChan a -> TBChan a
forall a. TVar Int -> TVar Int -> TChan a -> TBChan a
TBChan TVar Int
slots TVar Int
reads TChan a
chan)


-- | @IO@ version of 'newTBChan'. This is useful for creating
-- top-level @TBChan@s using 'System.IO.Unsafe.unsafePerformIO',
-- because using 'Control.Monad.STM.atomically' inside
-- 'System.IO.Unsafe.unsafePerformIO' isn't possible.
newTBChanIO :: Int -> IO (TBChan a)
newTBChanIO :: Int -> IO (TBChan a)
newTBChanIO Int
n = do
    TVar Int
slots <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
n
    TVar Int
reads <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0
    TChan a
chan  <- IO (TChan a)
forall a. IO (TChan a)
newTChanIO
    TBChan a -> IO (TBChan a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar Int -> TVar Int -> TChan a -> TBChan a
forall a. TVar Int -> TVar Int -> TChan a -> TBChan a
TBChan TVar Int
slots TVar Int
reads TChan a
chan)


-- | Read the next value from the @TBChan@, retrying if the channel
-- is empty.
readTBChan :: TBChan a -> STM a
readTBChan :: TBChan a -> STM a
readTBChan (TBChan TVar Int
_slots TVar Int
reads TChan a
chan) = do
    a
x <- TChan a -> STM a
forall a. TChan a -> STM a
readTChan TChan a
chan
    TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
reads (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+)
    a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x


-- | A version of 'readTBChan' which does not retry. Instead it
-- returns @Nothing@ if no value is available.
tryReadTBChan :: TBChan a -> STM (Maybe a)
tryReadTBChan :: TBChan a -> STM (Maybe a)
tryReadTBChan (TBChan TVar Int
_slots TVar Int
reads TChan a
chan) = do
    Maybe a
mx <- TChan a -> STM (Maybe a)
forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan a
chan
    case Maybe a
mx of
        Maybe a
Nothing -> Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        Just a
_x -> do
            TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
reads (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+)
            Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mx


-- | Get the next value from the @TBChan@ without removing it,
-- retrying if the channel is empty.
peekTBChan :: TBChan a -> STM a
peekTBChan :: TBChan a -> STM a
peekTBChan (TBChan TVar Int
_slots TVar Int
_reads TChan a
chan) =
    TChan a -> STM a
forall a. TChan a -> STM a
peekTChan TChan a
chan


-- | A version of 'peekTBChan' which does not retry. Instead it
-- returns @Nothing@ if no value is available.
tryPeekTBChan :: TBChan a -> STM (Maybe a)
tryPeekTBChan :: TBChan a -> STM (Maybe a)
tryPeekTBChan (TBChan TVar Int
_slots TVar Int
_reads TChan a
chan) =
    TChan a -> STM (Maybe a)
forall a. TChan a -> STM (Maybe a)
tryPeekTChan TChan a
chan


-- | Write a value to a @TBChan@, retrying if the channel is full.
writeTBChan :: TBChan a -> a -> STM ()
writeTBChan :: TBChan a -> a -> STM ()
writeTBChan self :: TBChan a
self@(TBChan TVar Int
slots TVar Int
_reads TChan a
chan) a
x = do
    Int
n <- TBChan a -> STM Int
forall a. TBChan a -> STM Int
estimateFreeSlotsTBChan TBChan a
self
    if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
        then STM ()
forall a. STM a
retry
        else do
            TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
slots (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$! Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
            TChan a -> a -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan a
chan a
x
{-
-- The above comparison is unnecessary on one of the n>0 branches
-- coming from estimateFreeSlotsTBChan. But for some reason, trying
-- to remove it can cause BlockedIndefinatelyOnSTM exceptions.

-- The above saves one @readTVar slots@ compared to:
writeTBChan self@(TBChan slots _reads chan) x = do
    b <- isFullTBChan self
    if b
        then retry
        else do
            modifyTVar' slots (subtract 1)
            writeTChan chan x
-}


-- | A version of 'writeTBChan' which does not retry. Returns @True@
-- if the value was successfully written, and @False@ otherwise.
tryWriteTBChan :: TBChan a -> a -> STM Bool
tryWriteTBChan :: TBChan a -> a -> STM Bool
tryWriteTBChan self :: TBChan a
self@(TBChan TVar Int
slots TVar Int
_reads TChan a
chan) a
x = do
    Int
n <- TBChan a -> STM Int
forall a. TBChan a -> STM Int
estimateFreeSlotsTBChan TBChan a
self
    if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
        then Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        else do
            TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
slots (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$! Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
            TChan a -> a -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan a
chan a
x
            Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
{-
-- The above comparison is unnecessary on one of the n>0 branches
-- coming from estimateFreeSlotsTBChan. But for some reason, trying
-- to remove it can cause BlockedIndefinatelyOnSTM exceptions.

-- The above saves one @readTVar slots@ compared to:
tryWriteTBChan self@(TBChan slots _reads chan) x = do
    b <- isFullTBChan self
    if b
        then return False
        else do
            modifyTVar' slots (subtract 1)
            writeTChan chan x
            return True
-}


-- | Put a data item back onto a channel, where it will be the next
-- item read. /N.B./, this could allow the channel to temporarily
-- become longer than the specified limit, which is necessary to
-- ensure that the item is indeed the next one read.
unGetTBChan :: TBChan a -> a -> STM ()
unGetTBChan :: TBChan a -> a -> STM ()
unGetTBChan (TBChan TVar Int
slots TVar Int
_reads TChan a
chan) a
x = do
    TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
slots (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1)
    TChan a -> a -> STM ()
forall a. TChan a -> a -> STM ()
unGetTChan TChan a
chan a
x


-- | Returns @True@ if the supplied @TBChan@ is empty (i.e., has
-- no elements). /N.B./, a @TBChan@ can be both \"empty\" and
-- \"full\" at the same time, if the initial limit was non-positive.
isEmptyTBChan :: TBChan a -> STM Bool
isEmptyTBChan :: TBChan a -> STM Bool
isEmptyTBChan (TBChan TVar Int
_slots TVar Int
_reads TChan a
chan) =
    TChan a -> STM Bool
forall a. TChan a -> STM Bool
isEmptyTChan TChan a
chan


-- | Returns @True@ if the supplied @TBChan@ is full (i.e., is over
-- its limit). /N.B./, a @TBChan@ can be both \"empty\" and \"full\"
-- at the same time, if the initial limit was non-positive. /N.B./,
-- a @TBChan@ may still be full after reading, if 'unGetTBChan' was
-- used to go over the initial limit.
--
-- This is equivalent to: @liftM (<= 0) estimateFreeSlotsTBMChan@
isFullTBChan :: TBChan a -> STM Bool
isFullTBChan :: TBChan a -> STM Bool
isFullTBChan (TBChan TVar Int
slots TVar Int
reads TChan a
_chan) = do
    Int
n <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
slots
    if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
        then do
            Int
m <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
reads
            let n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m
            TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
slots (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$! Int
n'
            TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
reads Int
0
            Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> STM Bool) -> Bool -> STM Bool
forall a b. (a -> b) -> a -> b
$! Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
        else Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
{-
-- The above saves an extraneous comparison of n\/n' against 0
-- compared to the more obvious:
isFullTBChan self = do
    n <- estimateFreeSlotsTBChan self
    return $! n <= 0
-}


-- | Estimate the number of free slots. If the result is positive,
-- then it's a minimum bound; if it's non-positive then it's exact.
-- It will only be negative if the initial limit was negative or
-- if 'unGetTBChan' was used to go over the initial limit.
--
-- This function always contends with writers, but only contends
-- with readers when it has to; compare against 'freeSlotsTBChan'.
estimateFreeSlotsTBChan :: TBChan a -> STM Int
estimateFreeSlotsTBChan :: TBChan a -> STM Int
estimateFreeSlotsTBChan (TBChan TVar Int
slots TVar Int
reads TChan a
_chan) = do
    Int
n <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
slots
    if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
        then Int -> STM Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
        else do
            Int
m <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
reads
            let n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m
            TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
slots (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$! Int
n'
            TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
reads Int
0
            Int -> STM Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n'


-- | Return the exact number of free slots. The result can be
-- negative if the initial limit was negative or if 'unGetTBChan'
-- was used to go over the initial limit.
--
-- This function always contends with both readers and writers;
-- compare against 'estimateFreeSlotsTBChan'.
freeSlotsTBChan :: TBChan a -> STM Int
freeSlotsTBChan :: TBChan a -> STM Int
freeSlotsTBChan (TBChan TVar Int
slots TVar Int
reads TChan a
_chan) = do
    Int
n <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
slots
    Int
m <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
reads
    let n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m
    TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
slots (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$! Int
n'
    TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
reads Int
0
    Int -> STM Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n'

----------------------------------------------------------------
----------------------------------------------------------- fin.