{-# LANGUAGE CPP
, BangPatterns
, DeriveDataTypeable
, NoImplicitPrelude
#-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#endif
module Control.Concurrent.RLock
( RLock
, new
, newAcquired
, acquire
, tryAcquire
, release
, with
, tryWith
, wait
, State
, state
) where
import Control.Applicative ( liftA2 )
import Control.Concurrent ( ThreadId, myThreadId )
import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, readMVar, putMVar )
import Control.Exception ( bracket_, onException )
import Control.Monad ( return, (>>) )
import Data.Bool ( Bool(False, True), otherwise )
import Data.Eq ( Eq, (==) )
import Data.Function ( ($), (.) )
import Data.Functor ( fmap, (<$>) )
import Data.Maybe ( Maybe(Nothing, Just) )
import Data.List ( (++) )
import Data.Tuple ( fst )
import Data.Typeable ( Typeable )
import Prelude ( Integer, succ, pred, error )
import System.IO ( IO )
#if __GLASGOW_HASKELL__ < 700
import Prelude ( fromInteger )
import Control.Monad ( Monad, fail, (>>=) )
#endif
import Control.Concurrent.Lock ( Lock )
import qualified Control.Concurrent.Lock as Lock
( new, newAcquired, acquire, release, wait )
import Utils ( mask, mask_ )
newtype RLock = RLock {RLock -> MVar (State, Lock)
un :: MVar (State, Lock)}
deriving (RLock -> RLock -> Bool
(RLock -> RLock -> Bool) -> (RLock -> RLock -> Bool) -> Eq RLock
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RLock -> RLock -> Bool
== :: RLock -> RLock -> Bool
$c/= :: RLock -> RLock -> Bool
/= :: RLock -> RLock -> Bool
Eq, Typeable)
type State = Maybe (ThreadId, Integer)
new :: IO RLock
new :: IO RLock
new = do Lock
lock <- IO Lock
Lock.new
MVar (State, Lock) -> RLock
RLock (MVar (State, Lock) -> RLock)
-> IO (MVar (State, Lock)) -> IO RLock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (State, Lock) -> IO (MVar (State, Lock))
forall a. a -> IO (MVar a)
newMVar (State
forall a. Maybe a
Nothing, Lock
lock)
newAcquired :: IO RLock
newAcquired :: IO RLock
newAcquired = do ThreadId
myTID <- IO ThreadId
myThreadId
Lock
lock <- IO Lock
Lock.newAcquired
MVar (State, Lock) -> RLock
RLock (MVar (State, Lock) -> RLock)
-> IO (MVar (State, Lock)) -> IO RLock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (State, Lock) -> IO (MVar (State, Lock))
forall a. a -> IO (MVar a)
newMVar ((ThreadId, Integer) -> State
forall a. a -> Maybe a
Just (ThreadId
myTID, Integer
1), Lock
lock)
acquire :: RLock -> IO ()
acquire :: RLock -> IO ()
acquire (RLock MVar (State, Lock)
mv) = do
ThreadId
myTID <- IO ThreadId
myThreadId
IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ let acq :: IO ()
acq = do t :: (State, Lock)
t@(State
mb, Lock
lock) <- MVar (State, Lock) -> IO (State, Lock)
forall a. MVar a -> IO a
takeMVar MVar (State, Lock)
mv
case State
mb of
State
Nothing -> do Lock -> IO ()
Lock.acquire Lock
lock
MVar (State, Lock) -> (State, Lock) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv ((ThreadId, Integer) -> State
forall a. a -> Maybe a
Just (ThreadId
myTID, Integer
1), Lock
lock)
Just (ThreadId
tid, Integer
n)
| ThreadId
myTID ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadId
tid -> let !sn :: Integer
sn = Integer -> Integer
forall a. Enum a => a -> a
succ Integer
n
in MVar (State, Lock) -> (State, Lock) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv ((ThreadId, Integer) -> State
forall a. a -> Maybe a
Just (ThreadId
tid, Integer
sn), Lock
lock)
| Bool
otherwise -> do MVar (State, Lock) -> (State, Lock) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (State, Lock)
t
Lock -> IO ()
Lock.wait Lock
lock
IO ()
acq
in IO ()
acq
tryAcquire :: RLock -> IO Bool
tryAcquire :: RLock -> IO Bool
tryAcquire (RLock MVar (State, Lock)
mv) = do
ThreadId
myTID <- IO ThreadId
myThreadId
IO Bool -> IO Bool
forall a. IO a -> IO a
mask_ (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
t :: (State, Lock)
t@(State
mb, Lock
lock) <- MVar (State, Lock) -> IO (State, Lock)
forall a. MVar a -> IO a
takeMVar MVar (State, Lock)
mv
case State
mb of
State
Nothing -> do Lock -> IO ()
Lock.acquire Lock
lock
MVar (State, Lock) -> (State, Lock) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv ((ThreadId, Integer) -> State
forall a. a -> Maybe a
Just (ThreadId
myTID, Integer
1), Lock
lock)
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Just (ThreadId
tid, Integer
n)
| ThreadId
myTID ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadId
tid -> do let !sn :: Integer
sn = Integer -> Integer
forall a. Enum a => a -> a
succ Integer
n
MVar (State, Lock) -> (State, Lock) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv ((ThreadId, Integer) -> State
forall a. a -> Maybe a
Just (ThreadId
tid, Integer
sn), Lock
lock)
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
| Bool
otherwise -> do MVar (State, Lock) -> (State, Lock) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (State, Lock)
t
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
release :: RLock -> IO ()
release :: RLock -> IO ()
release (RLock MVar (State, Lock)
mv) = do
ThreadId
myTID <- IO ThreadId
myThreadId
IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
t :: (State, Lock)
t@(State
mb, Lock
lock) <- MVar (State, Lock) -> IO (State, Lock)
forall a. MVar a -> IO a
takeMVar MVar (State, Lock)
mv
let err :: [Char] -> IO b
err [Char]
msg = do MVar (State, Lock) -> (State, Lock) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (State, Lock)
t
[Char] -> IO b
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO b) -> [Char] -> IO b
forall a b. (a -> b) -> a -> b
$ [Char]
"Control.Concurrent.RLock.release: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
msg
case State
mb of
State
Nothing -> [Char] -> IO ()
forall {b}. [Char] -> IO b
err [Char]
"Can't release an unacquired RLock!"
Just (ThreadId
tid, Integer
n)
| ThreadId
myTID ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadId
tid -> if Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1
then do Lock -> IO ()
Lock.release Lock
lock
MVar (State, Lock) -> (State, Lock) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (State
forall a. Maybe a
Nothing, Lock
lock)
else let !pn :: Integer
pn = Integer -> Integer
forall a. Enum a => a -> a
pred Integer
n
in MVar (State, Lock) -> (State, Lock) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv ((ThreadId, Integer) -> State
forall a. a -> Maybe a
Just (ThreadId
tid, Integer
pn), Lock
lock)
| Bool
otherwise -> [Char] -> IO ()
forall {b}. [Char] -> IO b
err [Char]
"Calling thread does not own the RLock!"
with :: RLock -> IO a -> IO a
with :: forall a. RLock -> IO a -> IO a
with = (IO () -> IO () -> IO a -> IO a)
-> (RLock -> IO ()) -> (RLock -> IO ()) -> RLock -> IO a -> IO a
forall a b c.
(a -> b -> c) -> (RLock -> a) -> (RLock -> b) -> RLock -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ RLock -> IO ()
acquire RLock -> IO ()
release
tryWith :: RLock -> IO a -> IO (Maybe a)
tryWith :: forall a. RLock -> IO a -> IO (Maybe a)
tryWith RLock
l IO a
a = ((forall a. IO a -> IO a) -> IO (Maybe a)) -> IO (Maybe a)
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO (Maybe a)) -> IO (Maybe a))
-> ((forall a. IO a -> IO a) -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
Bool
acquired <- RLock -> IO Bool
tryAcquire RLock
l
if Bool
acquired
then do a
r <- IO a -> IO a
forall a. IO a -> IO a
restore IO a
a IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`onException` RLock -> IO ()
release RLock
l
RLock -> IO ()
release RLock
l
Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
r
else Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
wait :: RLock -> IO ()
wait :: RLock -> IO ()
wait RLock
l = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ RLock -> IO ()
acquire RLock
l IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RLock -> IO ()
release RLock
l
state :: RLock -> IO State
state :: RLock -> IO State
state = ((State, Lock) -> State) -> IO (State, Lock) -> IO State
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (State, Lock) -> State
forall a b. (a, b) -> a
fst (IO (State, Lock) -> IO State)
-> (RLock -> IO (State, Lock)) -> RLock -> IO State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar (State, Lock) -> IO (State, Lock)
forall a. MVar a -> IO a
readMVar (MVar (State, Lock) -> IO (State, Lock))
-> (RLock -> MVar (State, Lock)) -> RLock -> IO (State, Lock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RLock -> MVar (State, Lock)
un