-- |
-- Module      : Control.Concurrent.Classy.STM.TBQueue
-- Copyright   : (c) 2016 Michael Walker
-- License     : MIT
-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
-- Stability   : stable
-- Portability : portable
--
-- 'TBQueue' is a bounded version of 'TQueue'. The queue has a maximum
-- capacity set when it is created.  If the queue already contains the
-- maximum number of elements, then 'writeTBQueue' blocks until an
-- element is removed from the queue.
--
-- The implementation is based on the traditional purely-functional
-- queue representation that uses two lists to obtain amortised /O(1)/
-- enqueue and dequeue operations.
--
-- __Deviations:__ @TBQueue@ as defined here does not have an @Eq@
-- instance, this is because the @MonadSTM@ @TVar@ type does not have
-- an @Eq@ constraint. Furthermore, the @newTBQueueIO@ function is not
-- provided.
module Control.Concurrent.Classy.STM.TBQueue
  ( -- * TBQueue
    TBQueue
  , newTBQueue
  , readTBQueue
  , tryReadTBQueue
  , flushTBQueue
  , peekTBQueue
  , tryPeekTBQueue
  , writeTBQueue
  , unGetTBQueue
  , lengthTBQueue
  , isEmptyTBQueue
  , isFullTBQueue
  ) where

import           Control.Monad.STM.Class
import           Numeric.Natural

-- | 'TBQueue' is an abstract type representing a bounded FIFO
-- channel.
--
-- @since 1.9.0.0
data TBQueue stm a
   = TBQueue (TVar stm Natural)
             (TVar stm [a])
             (TVar stm Natural)
             (TVar stm [a])
             !Natural

-- | Builds and returns a new instance of 'TBQueue'
--
-- @since 1.9.0.0
newTBQueue :: MonadSTM stm
  => Natural -- ^ maximum number of elements the queue can hold
  -> stm (TBQueue stm a)
newTBQueue :: Natural -> stm (TBQueue stm a)
newTBQueue Natural
size = do
  TVar stm [a]
readT  <- [a] -> stm (TVar stm [a])
forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar []
  TVar stm [a]
writeT <- [a] -> stm (TVar stm [a])
forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar []
  TVar stm Natural
rsize <- Natural -> stm (TVar stm Natural)
forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar Natural
0
  TVar stm Natural
wsize <- Natural -> stm (TVar stm Natural)
forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar Natural
size
  TBQueue stm a -> stm (TBQueue stm a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TVar stm Natural
-> TVar stm [a]
-> TVar stm Natural
-> TVar stm [a]
-> Natural
-> TBQueue stm a
forall (stm :: * -> *) a.
TVar stm Natural
-> TVar stm [a]
-> TVar stm Natural
-> TVar stm [a]
-> Natural
-> TBQueue stm a
TBQueue TVar stm Natural
rsize TVar stm [a]
readT TVar stm Natural
wsize TVar stm [a]
writeT Natural
size)

-- | Write a value to a 'TBQueue'; retries if the queue is full.
--
-- @since 1.0.0.0
writeTBQueue :: MonadSTM stm => TBQueue stm a -> a -> stm ()
writeTBQueue :: TBQueue stm a -> a -> stm ()
writeTBQueue (TBQueue TVar stm Natural
rsize TVar stm [a]
_ TVar stm Natural
wsize TVar stm [a]
writeT Natural
_) a
a = do
  Natural
w <- TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
wsize
  if Natural
w Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0
  then TVar stm Natural -> Natural -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
wsize (Natural -> stm ()) -> Natural -> stm ()
forall a b. (a -> b) -> a -> b
$! Natural
w Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1
  else do
    Natural
r <- TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
rsize
    if Natural
r Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0
    then do
      TVar stm Natural -> Natural -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
rsize Natural
0
      TVar stm Natural -> Natural -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
wsize (Natural -> stm ()) -> Natural -> stm ()
forall a b. (a -> b) -> a -> b
$! Natural
r Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1
    else stm ()
forall (stm :: * -> *) a. MonadSTM stm => stm a
retry
  [a]
listend <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
writeT
  TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
writeT (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
listend)

-- | Read the next value from the 'TBQueue'.
--
-- @since 1.0.0.0
readTBQueue :: MonadSTM stm => TBQueue stm a -> stm a
readTBQueue :: TBQueue stm a -> stm a
readTBQueue (TBQueue TVar stm Natural
rsize TVar stm [a]
readT TVar stm Natural
_ TVar stm [a]
writeT Natural
_) = do
  [a]
xs <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
readT
  Natural
r  <- TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
rsize
  TVar stm Natural -> Natural -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
rsize (Natural -> stm ()) -> Natural -> stm ()
forall a b. (a -> b) -> a -> b
$! Natural
r Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1
  case [a]
xs of
    (a
x:[a]
xs') -> do
      TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
readT [a]
xs'
      a -> stm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    [] -> do
      [a]
ys <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
writeT
      case [a]
ys of
        [] -> stm a
forall (stm :: * -> *) a. MonadSTM stm => stm a
retry
        [a]
_  -> do
          let (a
z:[a]
zs) = [a] -> [a]
forall a. [a] -> [a]
reverse [a]
ys
          TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
writeT []
          TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
readT [a]
zs
          a -> stm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
z

-- | A version of 'readTBQueue' which does not retry. Instead it
-- returns @Nothing@ if no value is available.
--
-- @since 1.0.0.0
tryReadTBQueue :: MonadSTM stm => TBQueue stm a -> stm (Maybe a)
tryReadTBQueue :: TBQueue stm a -> stm (Maybe a)
tryReadTBQueue TBQueue stm a
c = (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
<$> TBQueue stm a -> stm a
forall (stm :: * -> *) a. MonadSTM stm => TBQueue stm a -> stm a
readTBQueue TBQueue stm a
c) stm (Maybe a) -> stm (Maybe a) -> stm (Maybe a)
forall (stm :: * -> *) a. MonadSTM stm => stm a -> stm a -> stm a
`orElse` Maybe a -> stm (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

-- | Efficiently read the entire contents of a 'TBQueue' into a list. This
-- function never retries.
--
-- @since 1.6.1.0
flushTBQueue :: MonadSTM stm => TBQueue stm a -> stm [a]
flushTBQueue :: TBQueue stm a -> stm [a]
flushTBQueue (TBQueue TVar stm Natural
rsize TVar stm [a]
r TVar stm Natural
wsize TVar stm [a]
w Natural
size) = do
  [a]
xs <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
r
  [a]
ys <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
w
  if [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs Bool -> Bool -> Bool
&& [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ys
    then [a] -> stm [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    else do
      TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
r []
      TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
w []
      TVar stm Natural -> Natural -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
rsize Natural
0
      TVar stm Natural -> Natural -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
wsize Natural
size
      [a] -> stm [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
ys)

-- | Get the next value from the @TBQueue@ without removing it,
-- retrying if the channel is empty.
--
-- @since 1.0.0.0
peekTBQueue :: MonadSTM stm => TBQueue stm a -> stm a
peekTBQueue :: TBQueue stm a -> stm a
peekTBQueue (TBQueue TVar stm Natural
_ TVar stm [a]
readT TVar stm Natural
_ TVar stm [a]
writeT Natural
_) = do
  [a]
xs <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
readT
  case [a]
xs of
    (a
x:[a]
_) -> a -> stm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    [] -> do
      [a]
ys <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
writeT
      case [a]
ys of
        [] -> stm a
forall (stm :: * -> *) a. MonadSTM stm => stm a
retry
        [a]
_  -> do
          let (a
z:[a]
zs) = [a] -> [a]
forall a. [a] -> [a]
reverse [a]
ys -- NB. lazy: we want the transaction to be
                                  -- short, otherwise it will conflict
          TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
writeT []
          TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
readT (a
za -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
zs)
          a -> stm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
z

-- | A version of 'peekTBQueue' which does not retry. Instead it
-- returns @Nothing@ if no value is available.
--
-- @since 1.0.0.0
tryPeekTBQueue :: MonadSTM stm => TBQueue stm a -> stm (Maybe a)
tryPeekTBQueue :: TBQueue stm a -> stm (Maybe a)
tryPeekTBQueue TBQueue stm a
c = do
  Maybe a
m <- TBQueue stm a -> stm (Maybe a)
forall (stm :: * -> *) a.
MonadSTM stm =>
TBQueue stm a -> stm (Maybe a)
tryReadTBQueue TBQueue stm a
c
  case Maybe a
m of
    Maybe a
Nothing -> Maybe a -> stm (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    Just a
x  -> do
      TBQueue stm a -> a -> stm ()
forall (stm :: * -> *) a.
MonadSTM stm =>
TBQueue stm a -> a -> stm ()
unGetTBQueue TBQueue stm a
c a
x
      Maybe a -> stm (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
m

-- | Put a data item back onto a channel, where it will be the next item read.
-- Retries if the queue is full.
--
-- @since 1.0.0.0
unGetTBQueue :: MonadSTM stm => TBQueue stm a -> a -> stm ()
unGetTBQueue :: TBQueue stm a -> a -> stm ()
unGetTBQueue (TBQueue TVar stm Natural
rsize TVar stm [a]
readT TVar stm Natural
wsize TVar stm [a]
_ Natural
_) a
a = do
  Natural
r <- TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
rsize
  if Natural
r Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0
  then TVar stm Natural -> Natural -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
rsize (Natural -> stm ()) -> Natural -> stm ()
forall a b. (a -> b) -> a -> b
$! Natural
r Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1
  else do
    Natural
w <- TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
wsize
    if Natural
w Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0
    then TVar stm Natural -> Natural -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
wsize (Natural -> stm ()) -> Natural -> stm ()
forall a b. (a -> b) -> a -> b
$! Natural
w Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1
    else stm ()
forall (stm :: * -> *) a. MonadSTM stm => stm a
retry
  [a]
xs <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
readT
  TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
readT (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)

-- |Return the length of a 'TBQueue'.
--
-- @since 1.9.0.0
lengthTBQueue :: MonadSTM stm => TBQueue stm a -> stm Natural
lengthTBQueue :: TBQueue stm a -> stm Natural
lengthTBQueue (TBQueue TVar stm Natural
rsize TVar stm [a]
_ TVar stm Natural
wsize TVar stm [a]
_ Natural
size) = do
  Natural
r <- TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
rsize
  Natural
w <- TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
wsize
  Natural -> stm Natural
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural -> stm Natural) -> Natural -> stm Natural
forall a b. (a -> b) -> a -> b
$! Natural
size Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
r Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
w

-- | Returns 'True' if the supplied 'TBQueue' is empty.
--
-- @since 1.0.0.0
isEmptyTBQueue :: MonadSTM stm => TBQueue stm a -> stm Bool
isEmptyTBQueue :: TBQueue stm a -> stm Bool
isEmptyTBQueue (TBQueue TVar stm Natural
_ TVar stm [a]
readT TVar stm Natural
_ TVar stm [a]
writeT Natural
_) = do
  [a]
xs <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
readT
  case [a]
xs of
    (a
_:[a]
_) -> Bool -> stm Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    [] -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> stm [a] -> stm Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
writeT

-- | Returns 'True' if the supplied 'TBQueue' is full.
--
-- @since 1.0.0.0
isFullTBQueue :: MonadSTM stm => TBQueue stm a -> stm Bool
isFullTBQueue :: TBQueue stm a -> stm Bool
isFullTBQueue (TBQueue TVar stm Natural
rsize TVar stm [a]
_ TVar stm Natural
wsize TVar stm [a]
_ Natural
_) = do
  Natural
w <- TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
wsize
  if Natural
w Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0
  then Bool -> stm Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  else (Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>Natural
0) (Natural -> Bool) -> stm Natural -> stm Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
rsize