-- |
-- Module      : Control.Concurrent.Classy.STM.TQueue
-- Copyright   : (c) 2016 Michael Walker
-- License     : MIT
-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
-- Stability   : stable
-- Portability : portable
--
-- A 'TQueue' is like a 'TChan', with two important differences:
--
--  * it has faster throughput than both 'TChan' and 'Chan' (although
--    the costs are amortised, so the cost of individual operations
--    can vary a lot).
--
--  * it does /not/ provide equivalents of the 'dupTChan' and
--    'cloneTChan' operations.
--
-- 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:__ @TQueue@ as defined here does not have an @Eq@
-- instance, this is because the @MonadSTM@ @TVar@ type does not have
-- an @Eq@ constraint. Furthermore, the @newTQueueIO@ function is not
-- provided.
module Control.Concurrent.Classy.STM.TQueue
  ( -- * TQueue
    TQueue
  , newTQueue
  , readTQueue
  , tryReadTQueue
  , flushTQueue
  , peekTQueue
  , tryPeekTQueue
  , writeTQueue
  , unGetTQueue
  , isEmptyTQueue
  ) where

import           Control.Monad           (unless)
import           Control.Monad.STM.Class

-- | 'TQueue' is an abstract type representing an unbounded FIFO channel.
--
-- @since 1.0.0.0
data TQueue stm a = TQueue (TVar stm [a])
                           (TVar stm [a])

-- | Build and returns a new instance of 'TQueue'
--
-- @since 1.0.0.0
newTQueue :: MonadSTM stm => stm (TQueue stm a)
newTQueue :: forall (stm :: * -> *) a. MonadSTM stm => stm (TQueue stm a)
newTQueue = 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 []
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (stm :: * -> *) a.
TVar stm [a] -> TVar stm [a] -> TQueue stm a
TQueue TVar stm [a]
readT TVar stm [a]
writeT)

-- | Write a value to a 'TQueue'.
--
-- @since 1.0.0.0
writeTQueue :: MonadSTM stm => TQueue stm a -> a -> stm ()
writeTQueue :: forall (stm :: * -> *) a.
MonadSTM stm =>
TQueue stm a -> a -> stm ()
writeTQueue (TQueue TVar stm [a]
_ TVar stm [a]
writeT) a
a = do
  [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 'TQueue'.
--
-- @since 1.0.0.0
readTQueue :: MonadSTM stm => TQueue stm a -> stm a
readTQueue :: forall (stm :: * -> *) a. MonadSTM stm => TQueue stm a -> stm a
readTQueue (TQueue TVar stm [a]
readT TVar stm [a]
writeT) = 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]
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 -- 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]
zs
          forall (f :: * -> *) a. Applicative f => a -> f a
pure a
z

-- | A version of 'readTQueue' which does not retry. Instead it
-- returns @Nothing@ if no value is available.
--
-- @since 1.0.0.0
tryReadTQueue :: MonadSTM stm => TQueue stm a -> stm (Maybe a)
tryReadTQueue :: forall (stm :: * -> *) a.
MonadSTM stm =>
TQueue stm a -> stm (Maybe a)
tryReadTQueue TQueue 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 => TQueue stm a -> stm a
readTQueue TQueue 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 'TQueue' into a list. This
-- function never retries.
--
-- @since 1.6.1.0
flushTQueue :: MonadSTM stm => TQueue stm a -> stm [a]
flushTQueue :: forall (stm :: * -> *) a. MonadSTM stm => TQueue stm a -> stm [a]
flushTQueue (TQueue TVar stm [a]
r TVar stm [a]
w) = 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
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs) forall a b. (a -> b) -> a -> b
$ forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
r []
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ys) forall a b. (a -> b) -> a -> b
$ forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
w []
  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 @TQueue@ without removing it,
-- retrying if the channel is empty.
--
-- @since 1.0.0.0
peekTQueue :: MonadSTM stm => TQueue stm a -> stm a
peekTQueue :: forall (stm :: * -> *) a. MonadSTM stm => TQueue stm a -> stm a
peekTQueue (TQueue TVar stm [a]
readT TVar stm [a]
writeT) = 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 'peekTQueue' which does not retry. Instead it
-- returns @Nothing@ if no value is available.
--
-- @since 1.0.0.0
tryPeekTQueue :: MonadSTM stm => TQueue stm a -> stm (Maybe a)
tryPeekTQueue :: forall (stm :: * -> *) a.
MonadSTM stm =>
TQueue stm a -> stm (Maybe a)
tryPeekTQueue TQueue stm a
c = do
  Maybe a
m <- forall (stm :: * -> *) a.
MonadSTM stm =>
TQueue stm a -> stm (Maybe a)
tryReadTQueue TQueue 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 =>
TQueue stm a -> a -> stm ()
unGetTQueue TQueue 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.
--
-- @since 1.0.0.0
unGetTQueue :: MonadSTM stm => TQueue stm a -> a -> stm ()
unGetTQueue :: forall (stm :: * -> *) a.
MonadSTM stm =>
TQueue stm a -> a -> stm ()
unGetTQueue (TQueue TVar stm [a]
readT TVar stm [a]
_) a
a = do
  [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)

-- |Returns 'True' if the supplied 'TQueue' is empty.
--
-- @since 1.0.0.0
isEmptyTQueue :: MonadSTM stm => TQueue stm a -> stm Bool
isEmptyTQueue :: forall (stm :: * -> *) a. MonadSTM stm => TQueue stm a -> stm Bool
isEmptyTQueue (TQueue TVar stm [a]
readT TVar stm [a]
writeT) = 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