Add missing Control.Concurrent.Classy.STM.TSem module

Closes #287

concurrency/CHANGELOG.rst

@@ -10,6 +10,11 @@ standard Haskell versioning scheme.
 unreleased
 ----------
 
+Added
+~~~~~
+
+* (:issue:`287`) The ``Control.Concurrent.Classy.STM.TSem`` module.
+
 Miscellaneous
 ~~~~~~~~~~~~~
 

concurrency/Control/Concurrent/Classy/STM.hs

@@ -15,6 +15,7 @@ module Control.Concurrent.Classy.STM
   , module Control.Concurrent.Classy.STM.TQueue
   , module Control.Concurrent.Classy.STM.TBQueue
   , module Control.Concurrent.Classy.STM.TArray
+  , module Control.Concurrent.Classy.STM.TSem
   ) where
 
 import           Control.Concurrent.Classy.STM.TArray
@@ -22,5 +23,6 @@ import           Control.Concurrent.Classy.STM.TBQueue
 import           Control.Concurrent.Classy.STM.TChan
 import           Control.Concurrent.Classy.STM.TMVar
 import           Control.Concurrent.Classy.STM.TQueue
+import           Control.Concurrent.Classy.STM.TSem
 import           Control.Concurrent.Classy.STM.TVar
 import           Control.Monad.STM.Class

concurrency/Control/Concurrent/Classy/STM/TSem.hs

@@ -0,0 +1,90 @@
+-- |
+-- Module      : Control.Concurrent.Classy.STM.TSem
+-- Copyright   : (c) 2018 Michael Walker
+-- License     : MIT
+-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
+-- Stability   : stable
+-- Portability : portable
+--
+-- 'TSem': transactional semaphores.
+--
+-- __Deviations:__ There is no @Eq@ instance for @TSem@ type.
+module Control.Concurrent.Classy.STM.TSem
+  ( TSem
+  , newTSem
+  , waitTSem
+  , signalTSem
+  , signalTSemN
+  ) where
+
+import           Control.Monad           (when)
+import           Control.Monad.STM.Class
+import           Numeric.Natural         (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 unreleased
+newtype TSem stm = TSem (TVar stm Integer)
+
+-- | 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 unreleased
+newTSem :: MonadSTM stm => Integer -> stm (TSem stm)
+newTSem i = fmap TSem (newTVar $! i)
+
+-- | 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 :: MonadSTM stm => TSem stm -> stm ()
+waitTSem (TSem t) = do
+  i <- readTVar t
+  when (i <= 0) retry
+  writeTVar t $! (i-1)
+
+-- | Signal a 'TSem' (aka __V__ operation).
+--
+-- This operation adds\/releases a unit back to the semaphore
+-- (i.e. increments the internal counter).
+--
+-- @since unreleased
+signalTSem :: MonadSTM stm => TSem stm -> stm ()
+signalTSem (TSem t) = do
+  i <- readTVar t
+  writeTVar t $! i+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 unreleased
+signalTSemN :: MonadSTM stm => Natural -> TSem stm -> stm ()
+signalTSemN 0 _ = pure ()
+signalTSemN 1 s = signalTSem s
+signalTSemN n (TSem t) = do
+  i <- readTVar t
+  writeTVar t $! i + toInteger n

concurrency/concurrency.cabal

@@ -53,6 +53,7 @@ library
                      , Control.Concurrent.Classy.STM.TQueue
                      , Control.Concurrent.Classy.STM.TBQueue
                      , Control.Concurrent.Classy.STM.TArray
+                     , Control.Concurrent.Classy.STM.TSem
 
   -- other-modules:       
   -- other-extensions: