A sketch of a reverse semaphore for Haskell

QSemR.hs

module Control.Concurrent.QSemR
    ( newQSemR
    , bracketQSemR
    , whenEmptyQSemR
    ) where

import Control.Exception (bracket)
import Control.Concurrent.MVar

type QSemR = (MVar (), MVar Int)

newQSemR :: IO QSemR
newQSemR = do
    mvarStop <- newMVar ()
    mvarCount <- newMVar 0
    return $! (mvarStop, mvarCount)

enterQSemR :: QSemR -> IO ()
enterQSemR (mvarStop, mvarCount) = do
    tryTakeMVar mvarStop
    modifyMVar_ mvarCount (return . (+1))

leaveQSemR :: QSemR -> IO ()
leaveQSemR (mvarStop, mvarCount) =
    takeMVar mvarCount >>= actOn >>= putMVar mvarCount
  where actOn count
            -- One may wish to better define error state here
            | count <= 0 = return 0
            | count == 1 = do
                putMVar mvarStop ()
                return 0
            | otherwise = return $ count - 1

bracketQSemR :: QSemR -> IO a -> IO a
bracketQSemR qSemR = bracket 
    (enterQSemR qSemR)
    (const $ leaveQSemR qSemR)
    . const

whenEmptyQSemR :: QSemR -> IO a -> IO a
whenEmptyQSemR (mvarStop, mvarCount) = bracket acquire release . const
  where acquire = do
            takeMVar mvarStop
            takeMVar mvarCount
        release _ = do
            putMVar mvarStop ()
            putMVar mvarCount 0