-- |
-- 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 :: forall (stm :: * -> *) a.
MonadSTM stm =>
Natural -> stm (TBQueue stm a)
newTBQueue Natural
size = do
  TVar stm [a]
readT  <- forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar []
  TVar stm [a]
writeT <- forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar []
  TVar stm Natural
rsize <- forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar Natural
0
  TVar stm Natural
wsize <- forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar Natural
size
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 :: forall (stm :: * -> *) a.
MonadSTM stm =>
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 <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
wsize
  if Natural
w forall a. Ord a => a -> a -> Bool
> Natural
0
  then forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
wsize forall a b. (a -> b) -> a -> b
$! Natural
w forall a. Num a => a -> a -> a
- Natural
1
  else do
    Natural
r <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
rsize
    if Natural
r forall a. Ord a => a -> a -> Bool
> Natural
0
    then do
      forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
rsize Natural
0
      forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
wsize forall a b. (a -> b) -> a -> b
$! Natural
r forall a. Num a => a -> a -> a
- Natural
1
    else forall (stm :: * -> *) a. MonadSTM stm => stm a
retry
  [a]
listend <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
writeT
  forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
writeT (a
aforall 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 :: forall (stm :: * -> *) a. MonadSTM stm => 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 <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
readT
  Natural
r  <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
rsize
  forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
rsize forall a b. (a -> b) -> a -> b
$! Natural
r forall a. Num a => a -> a -> a
+ Natural
1
  case [a]
xs of
    (a
x:[a]
xs') -> do
      forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
readT [a]
xs'
      forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    [] -> do
      [a]
ys <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
writeT
      case [a]
ys of
        [] -> forall (stm :: * -> *) a. MonadSTM stm => stm a
retry
        [a]
_  -> do
          let (a
z:[a]
zs) = forall a. [a] -> [a]
reverse [a]
ys
          forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
writeT []
          forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
readT [a]
zs
          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 :: forall (stm :: * -> *) a.
MonadSTM stm =>
TBQueue stm a -> stm (Maybe a)
tryReadTBQueue TBQueue stm a
c = (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (stm :: * -> *) a. MonadSTM stm => TBQueue stm a -> stm a
readTBQueue TBQueue stm a
c) forall (stm :: * -> *) a. MonadSTM stm => stm a -> stm a -> stm a
`orElse` forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: forall (stm :: * -> *) a. MonadSTM stm => 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 <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
r
  [a]
ys <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
w
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ys
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    else do
      forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
r []
      forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
w []
      forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
rsize Natural
0
      forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
wsize Natural
size
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
xs forall 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 :: forall (stm :: * -> *) a. MonadSTM stm => 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 <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
readT
  case [a]
xs of
    (a
x:[a]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    [] -> do
      [a]
ys <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
writeT
      case [a]
ys of
        [] -> forall (stm :: * -> *) a. MonadSTM stm => stm a
retry
        [a]
_  -> do
          let (a
z:[a]
zs) = forall a. [a] -> [a]
reverse [a]
ys -- NB. lazy: we want the transaction to be
                                  -- short, otherwise it will conflict
          forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
writeT []
          forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
readT (a
zforall a. a -> [a] -> [a]
:[a]
zs)
          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 :: forall (stm :: * -> *) a.
MonadSTM stm =>
TBQueue stm a -> stm (Maybe a)
tryPeekTBQueue TBQueue stm a
c = do
  Maybe a
m <- forall (stm :: * -> *) a.
MonadSTM stm =>
TBQueue stm a -> stm (Maybe a)
tryReadTBQueue TBQueue stm a
c
  case Maybe a
m of
    Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just a
x  -> do
      forall (stm :: * -> *) a.
MonadSTM stm =>
TBQueue stm a -> a -> stm ()
unGetTBQueue TBQueue stm a
c a
x
      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 :: forall (stm :: * -> *) a.
MonadSTM stm =>
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 <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
rsize
  if Natural
r forall a. Ord a => a -> a -> Bool
> Natural
0
  then forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
rsize forall a b. (a -> b) -> a -> b
$! Natural
r forall a. Num a => a -> a -> a
- Natural
1
  else do
    Natural
w <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
wsize
    if Natural
w forall a. Ord a => a -> a -> Bool
> Natural
0
    then forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
wsize forall a b. (a -> b) -> a -> b
$! Natural
w forall a. Num a => a -> a -> a
- Natural
1
    else forall (stm :: * -> *) a. MonadSTM stm => stm a
retry
  [a]
xs <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
readT
  forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
readT (a
aforall 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 :: forall (stm :: * -> *) a.
MonadSTM stm =>
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 <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
rsize
  Natural
w <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
wsize
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! Natural
size forall a. Num a => a -> a -> a
- Natural
r 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 :: forall (stm :: * -> *) a. MonadSTM stm => 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 <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
readT
  case [a]
xs of
    (a
_:[a]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    [] -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall (stm :: * -> *) a. MonadSTM stm => 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 <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
wsize
  if Natural
w forall a. Ord a => a -> a -> Bool
> Natural
0
  then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  else (forall a. Ord a => a -> a -> Bool
>Natural
0) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
rsize