{-# LANGUAGE Safe #-}

-- | Bounded quantity semaphores.
module Control.Concurrent.BQSem
  ( BQSem
  , newBQSem
  , waitBQSem
  , signalBQSem
  , getBQSemQuantity
    ) where

import Control.Concurrent.QSem
import Control.Concurrent.MVar
import Control.Exception (mask, onException)
import Control.Monad (unless)

-- | Bounded quantity semaphore in which the resource is acquired and released in units of one,
--   but with a maximum amount of units available at any given time.
data BQSem = BQSem
  { -- | Underlying unbounded quantity semaphore.
    BQSem -> QSem
unboundedQSem :: QSem
    -- | Maximum number of units.
  , BQSem -> Int
bqsemBound :: Int
    -- | Counter of current units.
  , BQSem -> MVar Int
bqsemCounter :: MVar Int
    }

-- | Build a new 'BQSem' with supplied initial and maximum supply.
--   An exception is thrown in any of the following cases:
--
--   * Initial supply is negative.
--   * Maximum supply is less than 1.
--   * Initial supply exceeds maximum.
--
newBQSem
  :: Int -- ^ Initial unit supply.
  -> Int -- ^ Maximum unit supply.
  -> IO BQSem
newBQSem :: Int -> Int -> IO BQSem
newBQSem Int
n0 Int
m = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n0 forall a. Ord a => a -> a -> Bool
<= Int
m) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"newBQSem: Initial quantity must be less or equal than maximum."
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
m forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"newBQSem: Maximum quantity must be at least 1."
  QSem
qsem <- Int -> IO QSem
newQSem Int
n0
  MVar Int
counter <- forall a. a -> IO (MVar a)
newMVar Int
n0
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ BQSem
    { unboundedQSem :: QSem
unboundedQSem = QSem
qsem
    , bqsemBound :: Int
bqsemBound = Int
m
    , bqsemCounter :: MVar Int
bqsemCounter = MVar Int
counter
      }

-- | Wait for a unit to become available.
waitBQSem :: BQSem -> IO ()
waitBQSem :: BQSem -> IO ()
waitBQSem BQSem
bqsem =
  forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ QSem -> IO ()
waitQSem forall a b. (a -> b) -> a -> b
$ BQSem -> QSem
unboundedQSem BQSem
bqsem
    let counter :: MVar Int
counter = BQSem -> MVar Int
bqsemCounter BQSem
bqsem
    forall a. MVar a -> IO a
takeMVar MVar Int
counter forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      \Int
n -> forall a. MVar a -> a -> IO ()
putMVar MVar Int
counter forall a b. (a -> b) -> a -> b
$! Int
n forall a. Num a => a -> a -> a
- Int
1

-- | Make a new unit available, unless the maximum number of units has been reached,
--   in which case it does nothing (it doesn't block).
signalBQSem :: BQSem -> IO ()
signalBQSem :: BQSem -> IO ()
signalBQSem BQSem
bqsem =
  forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    let counter :: MVar Int
counter = BQSem -> MVar Int
bqsemCounter BQSem
bqsem
    Int
n <- forall a. MVar a -> IO a
takeMVar MVar Int
counter
    if Int
n forall a. Eq a => a -> a -> Bool
== BQSem -> Int
bqsemBound BQSem
bqsem
       then forall a. MVar a -> a -> IO ()
putMVar MVar Int
counter Int
n
       else do forall a. IO a -> IO a
restore (QSem -> IO ()
signalQSem forall a b. (a -> b) -> a -> b
$ BQSem -> QSem
unboundedQSem BQSem
bqsem) forall a b. IO a -> IO b -> IO a
`onException` forall a. MVar a -> a -> IO ()
putMVar MVar Int
counter Int
n
               forall a. MVar a -> a -> IO ()
putMVar MVar Int
counter forall a b. (a -> b) -> a -> b
$! Int
n forall a. Num a => a -> a -> a
+ Int
1

-- | Get current supply quantity.
getBQSemQuantity :: BQSem -> IO Int
getBQSemQuantity :: BQSem -> IO Int
getBQSemQuantity = forall a. MVar a -> IO a
readMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. BQSem -> MVar Int
bqsemCounter