module Mutex where

import Control.Concurrent
import Control.Concurrent.QSem
import Random


class Synchronize v where
   synchronize :: v -> IO a -> IO a    

instance Synchronize QSem where
  synchronize s a = do waitQSem s
                       r<- a
                       signalQSem s
                       return r

data Mutex = Mutex (MVar (Maybe (ThreadId,Int), 
                          [(ThreadId, MVar ())]))

acquire :: Mutex -> IO ()
acquire (Mutex mvar) = 
   do st <- takeMVar mvar
      current <- myThreadId
      case st of
         (Nothing,[]) -> putMVar mvar (Just (current,1),[])
         (Just (holder,n),pnd) -> 
            if current == holder 
              then putMVar mvar (Just (holder,n+1),pnd)
              else do bsem <- newEmptyMVar
                      putMVar mvar (Just (holder,n),
                                    (current,bsem):pnd)
                      takeMVar bsem

release :: Mutex -> IO ()
release (Mutex mvar) = 
   do st <- takeMVar mvar
      current <- myThreadId
      case st of
         (Just (h,n),pnd) | current == h -> 
            release' mvar h n pnd
         _ -> do putMVar mvar st
                 error "Illegal lock release"
       where
       release' mvar _ 1 [] = putMVar mvar (Nothing,[])
       release' mvar _ 1 pnd = 
         do ((h', sem), pnd') <- pick pnd
            putMVar mvar (Just (h',1),pnd')
            putMVar sem ()
       release' mvar h n pnd = putMVar mvar (Just (h,n-1), pnd)

pick :: [a] -> IO (a, [a])
pick l  = do n<- randomRIO (0, length l) 
             let (h, t)= splitAt n l
             return (head t, h++(tail t))

instance Synchronize Mutex where
  synchronize m a = 
    do acquire m
       r<- a
       release m
       return r