HQSem.hs

{- |
Module      :  <File name or $Header$ to be replaced automatically>
Description :  This module implements a quantity semaphores with handles
Maintainer  :  willig@ki.informatik.uni-frankfurt.de
Stability   :  experimental
Portability :  non-portable (requires Futures)

This module implements a quantity semaphore using handles that block on
futures.
A HQSem equals to QSemN in Control.Concurrent.
A Buffer euqals to QSem in Control.Concurrent.
Warning: All operations on quantity semaphores should only be used within the 
global wrapper function 'Futures.withFuturesDo'!
-}
module Control.Concurrent.Futures.HQSem (
            HQSem,
			newHQSem,
			upHQSem,
			downHQSem
) where

import qualified Control.Concurrent
import System.IO.Unsafe		( unsafeInterleaveIO )
import Control.Concurrent.Futures.Futures as Futures
import Control.Concurrent.Futures.Buffer

-- | A handled quantity semaphores contains of a capacity and a waiting queue containing 
-- handles.
type HQSem = Buffer (Int, [Bool -> IO ()])

-- | Creates a new quantity semaphore of capacity cnt.
newHQSem :: Int -> IO (HQSem)
newHQSem cnt = do
 b <- newBuf
 putBuf b (cnt,[])
 return b
  

-- | Increments the semaphore's value, if there are no waiters.
-- 'up' reads out of the waiting queue and binds a waiting handle to True.
-- Note: This operation equals to signalQSemN in Control.Concurrent.QSemN.
upHQSem :: HQSem -> IO ()
upHQSem qsem = do
 b <- getBuf qsem
 case b of
   (cnt,ls) -> case ls of
     [] -> do putBuf qsem (cnt+1,ls)
     x:xs -> do
       x True
       putBuf qsem (cnt,ls)

-- | Decrements the semaphore's value. If the value has already reached 0, then 
-- 'down' creates a new handle that is being added to the semaphore's waiting queue.
-- It blocks until the handle assigns a value to its future by a 'up'.
-- Note: This operation equals to waitQSemN in Control.Concurrent.QSemN.
downHQSem :: HQSem -> IO (Bool)
downHQSem qsem = do
 b <-getBuf qsem
 case b of
     (cnt,ls) -> case (cnt==0) of
	    True -> do
	      (h,f) <- Futures.newhandled
	      putBuf qsem (cnt,h:ls)
	      (wait f)
	    False -> do
	      putBuf qsem (cnt-1,ls)
	      return True

-- | Waits its argument to become true.
wait :: Bool -> IO Bool
wait x = do
 case x of
  True -> return x
  otherwise -> return x