    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Control.Concurrent.STM.TSem
    -- 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)
    --
    -- 'TSem': transactional semaphores.
    --
    -- @since 2.4.2
    -----------------------------------------------------------------------------

    {-# LANGUAGE DeriveDataTypeable #-}
    module Control.Concurrent.STM.TSem
      ( TSem
      , newTSem

      , waitTSem

      , signalTSem
      , signalTSemN
      ) where

    import Control.Concurrent.STM
    import Control.Monad
    import Data.Typeable
    import Numeric.Natural

    -- | 'TSem' is a transactional semaphore.  It holds a certain number
    -- of units, and units may be acquired or released by 'waitTSem' and
    -- 'signalTSem' respectively.  When the 'TSem' is empty, 'waitTSem'
    -- blocks.
    --
    -- Note that 'TSem' has no concept of fairness, and there is no
    -- guarantee that threads blocked in `waitTSem` will be unblocked in
    -- the same order; in fact they will all be unblocked at the same time
    -- and will fight over the 'TSem'.  Hence 'TSem' is not suitable if
    -- you expect there to be a high number of threads contending for the
    -- resource.  However, like other STM abstractions, 'TSem' is
    -- composable.
    --
    -- @since 2.4.2
    newtype TSem = TSem (TVar Integer)
      deriving (TSem -> TSem -> Bool
    (TSem -> TSem -> Bool) -> (TSem -> TSem -> Bool) -> Eq TSem
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: TSem -> TSem -> Bool
    == :: TSem -> TSem -> Bool
    $c/= :: TSem -> TSem -> Bool
    /= :: TSem -> TSem -> Bool
    Eq, Typeable)

    -- | Construct new 'TSem' with an initial counter value.
    --
    -- A positive initial counter value denotes availability of
    -- units 'waitTSem' can acquire.
    --
    -- The initial counter value can be negative which denotes a resource
    -- \"debt\" that requires a respective amount of 'signalTSem'
    -- operations to counter-balance.
    --
    -- @since 2.4.2
    newTSem :: Integer -> STM TSem
    newTSem :: Integer -> STM TSem
    newTSem Integer
    i = (TVar Integer -> TSem) -> STM (TVar Integer) -> STM TSem
    forall a b. (a -> b) -> STM a -> STM b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap TVar Integer -> TSem
    TSem (Integer -> STM (TVar Integer)
    forall a. a -> STM (TVar a)
    newTVar (Integer -> STM (TVar Integer)) -> Integer -> STM (TVar Integer)
    forall a b. (a -> b) -> a -> b
    $! Integer
    i)

    -- NOTE: we can't expose a good `TSem -> STM Int' operation as blocked
    -- 'waitTSem' aren't reliably reflected in a negative counter value.

    -- | Wait on 'TSem' (aka __P__ operation).
    --
    -- This operation acquires a unit from the semaphore (i.e. decreases
    -- the internal counter) and blocks (via 'retry') if no units are
    -- available (i.e. if the counter is /not/ positive).
    --
    -- @since 2.4.2
    waitTSem :: TSem -> STM ()
    waitTSem :: TSem -> STM ()
    waitTSem (TSem TVar Integer
    t) = do
      Integer
    i <- TVar Integer -> STM Integer
    forall a. TVar a -> STM a
    readTVar TVar Integer
    t
      Bool -> STM () -> STM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Integer
    i Integer -> Integer -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Integer
    0) STM ()
    forall a. STM a
    retry
      TVar Integer -> Integer -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar Integer
    t (Integer -> STM ()) -> Integer -> STM ()
    forall a b. (a -> b) -> a -> b
    $! (Integer
    iInteger -> Integer -> Integer
    forall a. Num a => a -> a -> a
    -Integer
    1)

    -- Alternatively, the implementation could block (via 'retry') when
    -- the next increment would overflow, i.e. testing for 'maxBound'

    -- | Signal a 'TSem' (aka __V__ operation).
    --
    -- This operation adds\/releases a unit back to the semaphore
    -- (i.e. increments the internal counter).
    --
    -- @since 2.4.2
    signalTSem :: TSem -> STM ()
    signalTSem :: TSem -> STM ()
    signalTSem (TSem TVar Integer
    t) = do
      Integer
    i <- TVar Integer -> STM Integer
    forall a. TVar a -> STM a
    readTVar TVar Integer
    t
      TVar Integer -> Integer -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar Integer
    t (Integer -> STM ()) -> Integer -> STM ()
    forall a b. (a -> b) -> a -> b
    $! Integer
    iInteger -> Integer -> Integer
    forall a. Num a => a -> a -> a
    +Integer
    1

    -- | Multi-signal a 'TSem'
    --
    -- This operation adds\/releases multiple units back to the semaphore
    -- (i.e. increments the internal counter).
    --
    -- > signalTSem == signalTSemN 1
    --
    -- @since 2.4.5
    signalTSemN :: Natural -> TSem -> STM ()
    signalTSemN :: Natural -> TSem -> STM ()
    signalTSemN Natural
    0 TSem
    _ = () -> STM ()
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    signalTSemN Natural
    1 TSem
    s = TSem -> STM ()
    signalTSem TSem
    s
    signalTSemN Natural
    n (TSem TVar Integer
    t) = do
      Integer
    i <- TVar Integer -> STM Integer
    forall a. TVar a -> STM a
    readTVar TVar Integer
    t
      TVar Integer -> Integer -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar Integer
    t (Integer -> STM ()) -> Integer -> STM ()
    forall a b. (a -> b) -> a -> b
    $! Integer
    iInteger -> Integer -> Integer
    forall a. Num a => a -> a -> a
    +(Natural -> Integer
    forall a. Integral a => a -> Integer
    toInteger Natural
    n)