Sem.hs

module Sem where

import Control.Concurrent hiding(QSem)    

data Sem = Sem (MVar (Bool, [MVar ()]))

-- Create Semaphore
new :: IO Sem
new = do m <- newMVar (True, [])
         return (Sem m)

-- "P"
wait :: Sem -> IO ()
wait (Sem sem) = do
   (avail, blocked) <- takeMVar sem 
   if avail then
     putMVar sem (False, [])
    else do
     block <- newEmptyMVar
     putMVar sem (False, blocked++ [block])
     takeMVar block

-- "V"
signal :: Sem -> IO ()
signal (Sem sem) = do
   (_, blocked) <- takeMVar sem
   case blocked of
     [] -> putMVar sem (True, [])
     block:blocked' -> do
           putMVar sem (False, blocked')
           putMVar block ()