-----------------------------------------------------------------------------
-- |
-- 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)