{-# LANGUAGE DeriveDataTypeable #-}
-- | 
-- Module      :  Control.Concurrent.MSem
-- Copyright   :  (c) Chris Kuklewicz 2011
-- License     :  3 clause BSD-style (see the file LICENSE)
-- 
-- Maintainer  :  haskell@list.mightyreason.com
-- Stability   :  experimental
-- Portability :  non-portable (concurrency)
--
-- A semaphore in which operations may 'wait' for or 'signal' single units of value.  This modules
-- is intended to improve on "Control.Concurrent.QSem".
-- 
-- This semaphore gracefully handles threads which die while blocked waiting.  The fairness
-- guarantee is that blocked threads are FIFO.
--
-- If 'with' is used to guard a critical section then no quantity of the semaphore will be lost if
-- the activity throws an exception. 'new' can initialize the semaphore to negative, zero, or
-- positive quantity. 'wait' always leaves the 'MSem' with non-negative quantity.
module Control.Concurrent.MSem
    (MSem
    ,new
    ,with
    ,wait
    ,signal
    ,peekAvail
    ) where

import Control.Concurrent.MVar(MVar,withMVar,modifyMVar,modifyMVar_,newMVar,newEmptyMVar,putMVar,takeMVar,tryTakeMVar,tryPutMVar)
import Control.Exception(bracket_,uninterruptibleMask_,evaluate,mask_)
import Data.Typeable(Typeable)

{- design notes are in MSemN.hs -}

data MS = MS { avail :: !Integer     -- ^ This is the quantity available to be taken from the semaphore. Often updated.
             , headWait :: MVar ()   -- ^ The head of the waiter queue blocks on headWait. Never updated.
             }
  deriving (Eq,Typeable)

-- | A 'MSem' is a semaphore in which the available quantity can be added and removed in single
--  units, and which can start with positive, zero, or negative value.
data MSem = MSem { mSem :: !(MVar MS)      -- ^ Used to lock access to state of semaphore quantity. Never updated.
                 , queueWait :: !(MVar ()) -- ^ Used as FIFO queue for waiter, held by head of queue.  Never updated.
                 }
  deriving (Eq,Typeable)

-- |'new' allows positive, zero, and negative initial values.  The initial value is forced here to
-- better localize errors.
new :: Integer -> IO MSem
new initial = do
  newHeadWait <- newEmptyMVar
  newQueueWait <- newMVar ()
  newMS <- newMVar $! (MS { avail = initial
                          , headWait = newHeadWait })
  return (MSem { mSem = newMS
               , queueWait = newQueueWait })

-- | 'with' takes a unit of value from the semaphore to hold while performing the provided
-- operation.  'with' ensures the quantity of the sempahore cannot be lost if there are exceptions.
--
-- 'with' uses 'bracket_' to ensure 'wait' and 'signal' get called correctly.
with :: MSem -> IO a -> IO a
with m = bracket_ (wait m)  (signal m)

-- |'wait' will take one unit of value from the sempahore, but will block if the quantity available
-- is not positive.
--
-- If 'wait' returns without interruption then it left the 'MSem' with a remaining quantity that was
-- greater than or equal to zero.  If 'wait' is interrupted then no quantity is lost.  If 'wait'
-- returns without interruption then it is known that each earlier waiter has definitely either been
-- interrupted or has retured without interruption.
wait :: MSem -> IO ()
wait (MSem sem advance) = mask_ $ withMVar advance $ \ () -> do
  todo <- mask_ $ modifyMVar sem $ \ m -> do
    mayGrab <- tryTakeMVar (headWait m)
    case mayGrab of
      Just () -> return (m,Nothing)
      Nothing -> if 1 <= avail m
                   then do
                     m' <- evaluate $ m { avail = avail m - 1 }
                     return (m', Nothing)
                   else do
                     return (m, Just (headWait m))
  -- mask_ is needed above because we may have just decremented 'avail' and we must finished 'wait'
  -- without being interrupted so that a 'bracket' can ensure a matching 'signal' can be ensured.
  case todo of
    Nothing -> return ()
    Just hw -> takeMVar hw -- actually may or may not block, a 'signal' could have already arrived.

-- | 'signal' adds one unit to the sempahore.
--
-- 'signal' may block, but it cannot be interrupted, which allows it to dependably restore value to
-- the 'MSem'.  All 'signal', 'peekAvail', and the head waiter may momentarily block in a fair FIFO
-- manner.
signal :: MSem -> IO ()
signal (MSem sem _) = uninterruptibleMask_ $ modifyMVar_ sem $ \ m -> do
  -- mask_ might be as good as uninterruptibleMask_ since nothing below can block
  if avail m < 0
    then evaluate m { avail = avail m + 1 }
    else do
      didPlace <- tryPutMVar (headWait m) ()
      if didPlace
        then return m
        else evaluate m { avail = avail m + 1 }

-- | 'peekAvail' skips the queue of any blocked 'wait' threads, but may momentarily block on
-- 'signal', other 'peekAvail', and the head waiter. This returns the amount of value available to
-- be taken.  Using this value without producing unwanted race conditions is left up to the
-- programmer.
--
-- Note that "Control.Concurrent.MSemN" offers a more powerful API for making decisions based on the available amount.
peekAvail :: MSem -> IO Integer
peekAvail (MSem sem _) = mask_ $ withMVar sem $  \ m -> do
  extraFlag <- tryTakeMVar (headWait m)
  case extraFlag of
    Nothing -> return (avail m)
    Just () -> do putMVar (headWait m) () -- cannot block
                  return (1 + avail m)