-----------------------------------------------------------------------------

module Control.Concurrent.ResourceTable
where

import           Control.Concurrent.MVar

import qualified Data.Map                 	as M
import           Data.Maybe

-----------------------------------------------------------------------------

type ResourceTable a	= MVar (M.Map a ResourceLock)
type ResourceLock	= (MVar (), Int)

-----------------------------------------------------------------------------

requestResource		:: (Ord a) => ResourceTable a -> a -> IO ()
requestResource theLocks r
			= do
			  rt <- takeMVar theLocks
			  (lk, cnt) <- case M.lookup r rt of
				       Nothing		-> do
							   lk' <- newMVar ()
							   return (lk', 0)
				       Just l		-> return l
			  putMVar theLocks $ M.insert r (lk, cnt + 1) rt
			  takeMVar lk

releaseResource		:: (Ord a) => ResourceTable a -> a -> IO ()
releaseResource theLocks r
			= do
			  rt <- takeMVar theLocks
			  let (lk, cnt) = fromJust . M.lookup r $ rt
                          putMVar theLocks $ if cnt == 1
				             then M.delete r rt
					     else M.insert r (lk, cnt - 1) rt
                          putMVar lk ()

newResourceTable	:: IO (ResourceTable a)
newResourceTable	= newMVar M.empty

-----------------------------------------------------------------------------