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

    -- HACK: in GHC 7.10, Haddock complains about Control.Monad.STM and
    -- System.IO.Unsafe being imported but unused. However, if we use
    -- CPP to avoid including them under Haddock, then it will fail to
    -- compile!
    #ifdef __HADDOCK__
    {-# OPTIONS_GHC -fno-warn-unused-imports #-}
    #endif

    #if __GLASGOW_HASKELL__ >= 701
    #  ifdef __HADDOCK__
    {-# LANGUAGE Trustworthy #-}
    #  else
    {-# LANGUAGE Safe #-}
    #  endif
    #endif
    ----------------------------------------------------------------
    --                                                    2015.03.29
    -- |
    -- Module      :  Control.Concurrent.STM.TBChan
    -- Copyright   :  Copyright (c) 2011--2015 wren gayle romano
    -- License     :  BSD
    -- Maintainer  :  wren@community.haskell.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

    -- N.B., we need a Custom cabal build-type for this to work.
    #ifdef __HADDOCK__
    import Control.Monad.STM (atomically)
    import System.IO.Unsafe  (unsafePerformIO)
    #endif
    ----------------------------------------------------------------

    -- | @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 n :: 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 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 'unsafePerformIO', because using
    -- 'atomically' inside 'unsafePerformIO' isn't possible.
    newTBChanIO :: Int -> IO (TBChan a)
    newTBChanIO :: Int -> IO (TBChan a)
    newTBChanIO n :: 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 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 _slots :: TVar Int
    _slots reads :: TVar Int
    reads chan :: 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 (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 _slots :: TVar Int
    _slots reads :: TVar Int
    reads chan :: 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
            Nothing -> Maybe a -> STM (Maybe a)
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe a
    forall a. Maybe a
    Nothing
            Just _x :: a
    _x -> do
                TVar Int -> (Int -> Int) -> STM ()
    forall a. TVar a -> (a -> a) -> STM ()
    modifyTVar' TVar Int
    reads (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 _slots :: TVar Int
    _slots _reads :: TVar Int
    _reads chan :: 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 _slots :: TVar Int
    _slots _reads :: TVar Int
    _reads chan :: 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 slots :: TVar Int
    slots _reads :: TVar Int
    _reads chan :: TChan a
    chan) x :: 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
    <= 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
    - 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 slots :: TVar Int
    slots _reads :: TVar Int
    _reads chan :: TChan a
    chan) x :: 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
    <= 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
    - 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 slots :: TVar Int
    slots _reads :: TVar Int
    _reads chan :: TChan a
    chan) x :: 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 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 _slots :: TVar Int
    _slots _reads :: TVar Int
    _reads chan :: 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 slots :: TVar Int
    slots reads :: TVar Int
    reads _chan :: 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
    <= 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 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
    <= 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 slots :: TVar Int
    slots reads :: TVar Int
    reads _chan :: 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
    > 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 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 slots :: TVar Int
    slots reads :: TVar Int
    reads _chan :: 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 0
        Int -> STM Int
    forall (m :: * -> *) a. Monad m => a -> m a
    return Int
    n'

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