    {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
    {-# LANGUAGE CPP                #-}
    {-# LANGUAGE DeriveDataTypeable #-}

    #if __GLASGOW_HASKELL__ >= 701
    {-# LANGUAGE Trustworthy        #-}
    #endif

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Control.Concurrent.STM.TBQueue
    -- Copyright   :  (c) The University of Glasgow 2012
    -- License     :  BSD-style (see the file libraries/base/LICENSE)
    --
    -- Maintainer  :  libraries@haskell.org
    -- Stability   :  experimental
    -- Portability :  non-portable (requires STM)
    --
    -- '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.
    --
    -- @since 2.4
    -----------------------------------------------------------------------------

    module Control.Concurrent.STM.TBQueue (
            -- * TBQueue
            TBQueue,
            newTBQueue,
            newTBQueueIO,
            readTBQueue,
            tryReadTBQueue,
            flushTBQueue,
            peekTBQueue,
            tryPeekTBQueue,
            writeTBQueue,
            unGetTBQueue,
            lengthTBQueue,
            isEmptyTBQueue,
            isFullTBQueue,
      ) where

    import           Control.Monad   (unless)
    import           Data.Typeable   (Typeable)
    import           GHC.Conc        (STM, TVar, newTVar, newTVarIO, orElse,
                                      readTVar, retry, writeTVar)
    import           Numeric.Natural (Natural)
    import           Prelude         hiding (read)

    -- | 'TBQueue' is an abstract type representing a bounded FIFO channel.
    --
    -- @since 2.4
    data TBQueue a
       = TBQueue {-# UNPACK #-} !(TVar Natural) -- CR:  read capacity
                 {-# UNPACK #-} !(TVar [a])     -- R:   elements waiting to be read
                 {-# UNPACK #-} !(TVar Natural) -- CW:  write capacity
                 {-# UNPACK #-} !(TVar [a])     -- W:   elements written (head is most recent)
                                !(Natural)      -- CAP: initial capacity
      deriving Typeable

    instance Eq (TBQueue a) where
      TBQueue TVar Natural
    a TVar [a]
    _ TVar Natural
    _ TVar [a]
    _ Natural
    _ == :: TBQueue a -> TBQueue a -> Bool
    == TBQueue TVar Natural
    b TVar [a]
    _ TVar Natural
    _ TVar [a]
    _ Natural
    _ = TVar Natural
    a TVar Natural -> TVar Natural -> Bool
    forall a. Eq a => a -> a -> Bool
    == TVar Natural
    b

    -- Total channel capacity remaining is CR + CW. Reads only need to
    -- access CR, writes usually need to access only CW but sometimes need
    -- CR.  So in the common case we avoid contention between CR and CW.
    --
    --   - when removing an element from R:
    --     CR := CR + 1
    --
    --   - when adding an element to W:
    --     if CW is non-zero
    --         then CW := CW - 1
    --         then if CR is non-zero
    --                 then CW := CR - 1; CR := 0
    --                 else **FULL**

    -- | Builds and returns a new instance of 'TBQueue'.
    newTBQueue :: Natural   -- ^ maximum number of elements the queue can hold
               -> STM (TBQueue a)
    newTBQueue :: forall a. Natural -> STM (TBQueue a)
    newTBQueue Natural
    size = do
      TVar [a]
    read  <- [a] -> STM (TVar [a])
    forall a. a -> STM (TVar a)
    newTVar []
      TVar [a]
    write <- [a] -> STM (TVar [a])
    forall a. a -> STM (TVar a)
    newTVar []
      TVar Natural
    rsize <- Natural -> STM (TVar Natural)
    forall a. a -> STM (TVar a)
    newTVar Natural
    0
      TVar Natural
    wsize <- Natural -> STM (TVar Natural)
    forall a. a -> STM (TVar a)
    newTVar Natural
    size
      TBQueue a -> STM (TBQueue a)
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TVar Natural
    -> TVar [a] -> TVar Natural -> TVar [a] -> Natural -> TBQueue a
    forall a.
    TVar Natural
    -> TVar [a] -> TVar Natural -> TVar [a] -> Natural -> TBQueue a
    TBQueue TVar Natural
    rsize TVar [a]
    read TVar Natural
    wsize TVar [a]
    write Natural
    size)

    -- |@IO@ version of 'newTBQueue'.  This is useful for creating top-level
    -- 'TBQueue's using 'System.IO.Unsafe.unsafePerformIO', because using
    -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
    -- possible.
    newTBQueueIO :: Natural -> IO (TBQueue a)
    newTBQueueIO :: forall a. Natural -> IO (TBQueue a)
    newTBQueueIO Natural
    size = do
      TVar [a]
    read  <- [a] -> IO (TVar [a])
    forall a. a -> IO (TVar a)
    newTVarIO []
      TVar [a]
    write <- [a] -> IO (TVar [a])
    forall a. a -> IO (TVar a)
    newTVarIO []
      TVar Natural
    rsize <- Natural -> IO (TVar Natural)
    forall a. a -> IO (TVar a)
    newTVarIO Natural
    0
      TVar Natural
    wsize <- Natural -> IO (TVar Natural)
    forall a. a -> IO (TVar a)
    newTVarIO Natural
    size
      TBQueue a -> IO (TBQueue a)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TVar Natural
    -> TVar [a] -> TVar Natural -> TVar [a] -> Natural -> TBQueue a
    forall a.
    TVar Natural
    -> TVar [a] -> TVar Natural -> TVar [a] -> Natural -> TBQueue a
    TBQueue TVar Natural
    rsize TVar [a]
    read TVar Natural
    wsize TVar [a]
    write Natural
    size)

    -- |Write a value to a 'TBQueue'; blocks if the queue is full.
    writeTBQueue :: TBQueue a -> a -> STM ()
    writeTBQueue :: forall a. TBQueue a -> a -> STM ()
    writeTBQueue (TBQueue TVar Natural
    rsize TVar [a]
    _read TVar Natural
    wsize TVar [a]
    write Natural
    _size) a
    a = do
      Natural
    w <- TVar Natural -> STM Natural
    forall a. TVar a -> STM a
    readTVar TVar Natural
    wsize
      if (Natural
    w Natural -> Natural -> Bool
    forall a. Ord a => a -> a -> Bool
    > Natural
    0)
         then do TVar Natural -> Natural -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar 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 Natural -> STM Natural
    forall a. TVar a -> STM a
    readTVar TVar Natural
    rsize
              if (Natural
    r Natural -> Natural -> Bool
    forall a. Ord a => a -> a -> Bool
    > Natural
    0)
                 then do TVar Natural -> Natural -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar Natural
    rsize Natural
    0
                         TVar Natural -> Natural -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar 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 a. STM a
    retry
      [a]
    listend <- TVar [a] -> STM [a]
    forall a. TVar a -> STM a
    readTVar TVar [a]
    write
      TVar [a] -> [a] -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar [a]
    write (a
    aa -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    listend)

    -- |Read the next value from the 'TBQueue'.
    readTBQueue :: TBQueue a -> STM a
    readTBQueue :: forall a. TBQueue a -> STM a
    readTBQueue (TBQueue TVar Natural
    rsize TVar [a]
    read TVar Natural
    _wsize TVar [a]
    write Natural
    _size) = do
      [a]
    xs <- TVar [a] -> STM [a]
    forall a. TVar a -> STM a
    readTVar TVar [a]
    read
      Natural
    r <- TVar Natural -> STM Natural
    forall a. TVar a -> STM a
    readTVar TVar Natural
    rsize
      TVar Natural -> Natural -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar 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 [a] -> [a] -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar [a]
    read [a]
    xs'
          a -> STM a
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    x
        [] -> do
          [a]
    ys <- TVar [a] -> STM [a]
    forall a. TVar a -> STM a
    readTVar TVar [a]
    write
          case [a]
    ys of
            [] -> STM a
    forall a. STM a
    retry
            [a]
    _  -> do
              -- NB. lazy: we want the transaction to be
              -- short, otherwise it will conflict
              let ~(a
    z,[a]
    zs) = case [a] -> [a]
    forall a. [a] -> [a]
    reverse [a]
    ys of
                              a
    z':[a]
    zs' -> (a
    z',[a]
    zs')
                              [a]
    _      -> [Char] -> (a, [a])
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "readTBQueue: impossible"
              TVar [a] -> [a] -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar [a]
    write []
              TVar [a] -> [a] -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar [a]
    read [a]
    zs
              a -> STM a
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    z

    -- | A version of 'readTBQueue' which does not retry. Instead it
    -- returns @Nothing@ if no value is available.
    tryReadTBQueue :: TBQueue a -> STM (Maybe a)
    tryReadTBQueue :: forall a. TBQueue a -> STM (Maybe a)
    tryReadTBQueue TBQueue a
    c = (a -> Maybe a) -> STM a -> STM (Maybe a)
    forall a b. (a -> b) -> STM a -> STM b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap a -> Maybe a
    forall a. a -> Maybe a
    Just (TBQueue a -> STM a
    forall a. TBQueue a -> STM a
    readTBQueue TBQueue a
    c) STM (Maybe a) -> STM (Maybe a) -> STM (Maybe a)
    forall a. STM a -> STM a -> STM a
    `orElse` Maybe a -> STM (Maybe a)
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe a
    forall a. Maybe a
    Nothing

    -- | Efficiently read the entire contents of a 'TBQueue' into a list. This
    -- function never retries.
    --
    -- @since 2.4.5
    flushTBQueue :: TBQueue a -> STM [a]
    flushTBQueue :: forall a. TBQueue a -> STM [a]
    flushTBQueue (TBQueue TVar Natural
    rsize TVar [a]
    read TVar Natural
    wsize TVar [a]
    write Natural
    size) = do
      [a]
    xs <- TVar [a] -> STM [a]
    forall a. TVar a -> STM a
    readTVar TVar [a]
    read
      [a]
    ys <- TVar [a] -> STM [a]
    forall a. TVar a -> STM a
    readTVar TVar [a]
    write
      if [a] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [a]
    xs Bool -> Bool -> Bool
    && [a] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [a]
    ys
        then [a] -> STM [a]
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
        else do
          Bool -> STM () -> STM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless ([a] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [a]
    xs) (STM () -> STM ()) -> STM () -> STM ()
    forall a b. (a -> b) -> a -> b
    $ TVar [a] -> [a] -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar [a]
    read []
          Bool -> STM () -> STM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless ([a] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [a]
    ys) (STM () -> STM ()) -> STM () -> STM ()
    forall a b. (a -> b) -> a -> b
    $ TVar [a] -> [a] -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar [a]
    write []
          TVar Natural -> Natural -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar Natural
    rsize Natural
    0
          TVar Natural -> Natural -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar Natural
    wsize Natural
    size
          [a] -> STM [a]
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([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.
    peekTBQueue :: TBQueue a -> STM a
    peekTBQueue :: forall a. TBQueue a -> STM a
    peekTBQueue (TBQueue TVar Natural
    _ TVar [a]
    read TVar Natural
    _ TVar [a]
    write Natural
    _) = do
      [a]
    xs <- TVar [a] -> STM [a]
    forall a. TVar a -> STM a
    readTVar TVar [a]
    read
      case [a]
    xs of
        (a
    x:[a]
    _) -> a -> STM a
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    x
        [] -> do
          [a]
    ys <- TVar [a] -> STM [a]
    forall a. TVar a -> STM a
    readTVar TVar [a]
    write
          case [a]
    ys of
            [] -> STM a
    forall a. 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 [a] -> [a] -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar [a]
    write []
              TVar [a] -> [a] -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar [a]
    read (a
    za -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    zs)
              a -> STM a
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    z

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

    -- |Put a data item back onto a channel, where it will be the next item read.
    -- Blocks if the queue is full.
    unGetTBQueue :: TBQueue a -> a -> STM ()
    unGetTBQueue :: forall a. TBQueue a -> a -> STM ()
    unGetTBQueue (TBQueue TVar Natural
    rsize TVar [a]
    read TVar Natural
    wsize TVar [a]
    _write Natural
    _size) a
    a = do
      Natural
    r <- TVar Natural -> STM Natural
    forall a. TVar a -> STM a
    readTVar TVar Natural
    rsize
      if (Natural
    r Natural -> Natural -> Bool
    forall a. Ord a => a -> a -> Bool
    > Natural
    0)
         then do TVar Natural -> Natural -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar 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 Natural -> STM Natural
    forall a. TVar a -> STM a
    readTVar TVar Natural
    wsize
              if (Natural
    w Natural -> Natural -> Bool
    forall a. Ord a => a -> a -> Bool
    > Natural
    0)
                 then TVar Natural -> Natural -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar 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 a. STM a
    retry
      [a]
    xs <- TVar [a] -> STM [a]
    forall a. TVar a -> STM a
    readTVar TVar [a]
    read
      TVar [a] -> [a] -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar [a]
    read (a
    aa -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    xs)

    -- |Return the length of a 'TBQueue'.
    --
    -- @since 2.5.0.0
    lengthTBQueue :: TBQueue a -> STM Natural
    lengthTBQueue :: forall a. TBQueue a -> STM Natural
    lengthTBQueue (TBQueue TVar Natural
    rsize TVar [a]
    _read TVar Natural
    wsize TVar [a]
    _write Natural
    size) = do
      Natural
    r <- TVar Natural -> STM Natural
    forall a. TVar a -> STM a
    readTVar TVar Natural
    rsize
      Natural
    w <- TVar Natural -> STM Natural
    forall a. TVar a -> STM a
    readTVar TVar Natural
    wsize
      Natural -> STM Natural
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (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.
    isEmptyTBQueue :: TBQueue a -> STM Bool
    isEmptyTBQueue :: forall a. TBQueue a -> STM Bool
    isEmptyTBQueue (TBQueue TVar Natural
    _rsize TVar [a]
    read TVar Natural
    _wsize TVar [a]
    write Natural
    _size) = do
      [a]
    xs <- TVar [a] -> STM [a]
    forall a. TVar a -> STM a
    readTVar TVar [a]
    read
      case [a]
    xs of
        (a
    _:[a]
    _) -> Bool -> STM Bool
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
        [] -> do [a]
    ys <- TVar [a] -> STM [a]
    forall a. TVar a -> STM a
    readTVar TVar [a]
    write
                 case [a]
    ys of
                   [] -> Bool -> STM Bool
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
                   [a]
    _  -> Bool -> STM Bool
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False

    -- |Returns 'True' if the supplied 'TBQueue' is full.
    --
    -- @since 2.4.3
    isFullTBQueue :: TBQueue a -> STM Bool
    isFullTBQueue :: forall a. TBQueue a -> STM Bool
    isFullTBQueue (TBQueue TVar Natural
    rsize TVar [a]
    _read TVar Natural
    wsize TVar [a]
    _write Natural
    _size) = do
      Natural
    w <- TVar Natural -> STM Natural
    forall a. TVar a -> STM a
    readTVar TVar Natural
    wsize
      if (Natural
    w Natural -> Natural -> Bool
    forall a. Ord a => a -> a -> Bool
    > Natural
    0)
         then Bool -> STM Bool
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
         else do
             Natural
    r <- TVar Natural -> STM Natural
    forall a. TVar a -> STM a
    readTVar TVar Natural
    rsize
             if (Natural
    r Natural -> Natural -> Bool
    forall a. Ord a => a -> a -> Bool
    > Natural
    0)
                then Bool -> STM Bool
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
                else Bool -> STM Bool
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True