{-# LANGUAGE CPP
           , BangPatterns
           , DeriveDataTypeable
           , NoImplicitPrelude
  #-}

#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#endif

--------------------------------------------------------------------------------
-- |
-- Module     : Control.Concurrent.RLock
-- Copyright  : (c) 2010-2011 Bas van Dijk & Roel van Dijk
-- License    : BSD3 (see the file LICENSE)
-- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>
--            , Roel van Dijk <vandijk.roel@gmail.com>
--
-- This module provides the 'RLock' synchronisation mechanism. It was inspired
-- by the Python @RLock@ and Java @ReentrantLock@ objects and should behave in a
-- similar way. See:
--
-- <http://docs.python.org/3.1/library/threading.html#rlock-objects>
--
-- and:
--
-- <http://java.sun.com/javase/7/docs/api/java/util/concurrent/locks/ReentrantLock.html>
--
-- All functions are /exception safe/. Throwing asynchronous exceptions will not
-- compromise the internal state of an 'RLock'.
--
-- This module is intended to be imported qualified. We suggest importing it like:
--
-- @
-- import           Control.Concurrent.RLock          ( RLock )
-- import qualified Control.Concurrent.RLock as RLock ( ... )
-- @
--
--------------------------------------------------------------------------------

module Control.Concurrent.RLock
    ( RLock

      -- * Creating reentrant locks
    , new
    , newAcquired

      -- * Locking and unlocking
    , acquire
    , tryAcquire
    , release

      -- * Convenience functions
    , with
    , tryWith
    , wait

      -- * Querying reentrant locks
    , State
    , state
    ) where


--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------

-- from base:
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

-- from concurrent-extra (this package):
import           Control.Concurrent.Lock ( Lock )
import qualified Control.Concurrent.Lock as Lock
    ( new, newAcquired, acquire, release, wait )

import Utils ( mask, mask_ )


--------------------------------------------------------------------------------
-- Reentrant locks
--------------------------------------------------------------------------------

{-| A reentrant lock is in one of two states: \"locked\" or \"unlocked\". When
the lock is in the \"locked\" state it has two additional properties:

* Its /owner/: the thread that acquired the lock.

* Its /acquired count/: how many times its owner acquired the lock.
-}
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)

{-| The state of an 'RLock'.

* 'Nothing' indicates an \"unlocked\" state.

* @'Just' (tid, n)@ indicates a \"locked\" state where the thread identified by
@tid@ acquired the lock @n@ times.
-}
type State = Maybe (ThreadId, Integer)


--------------------------------------------------------------------------------
-- * Creating reentrant locks
--------------------------------------------------------------------------------

-- | Create a reentrant lock in the \"unlocked\" state.
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)

{-|
Create a reentrant lock in the \"locked\" state (with the current thread as
owner and an acquired count of 1).
-}
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)


--------------------------------------------------------------------------------
-- * Locking and unlocking
--------------------------------------------------------------------------------

{-|
Acquires the 'RLock'. Blocks if another thread has acquired the 'RLock'.

@acquire@ behaves as follows:

* When the state is \"unlocked\", @acquire@ changes the state to \"locked\"
with the current thread as owner and an acquired count of 1.

* When the state is \"locked\" and the current thread owns the lock @acquire@
only increments the acquired count.

* When the state is \"locked\" and the current thread does not own the lock
@acquire@ /blocks/ until the owner releases the lock. If the thread that called
@acquire@ is woken upon release of the lock it will take ownership and change
the state to \"locked\" with an acquired count of 1.

There are two further important properties of @acquire@:

* @acquire@ is single-wakeup. That is, if there are multiple threads blocked on
@acquire@, and the lock is released, only one thread will be woken up. The
runtime guarantees that the woken thread completes its @acquire@ operation.

* When multiple threads are blocked on @acquire@ they are woken up in FIFO
order. This is useful for providing fairness properties of abstractions built
using locks. (Note that this differs from the Python implementation where the
wake-up order is undefined.)
-}
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

{-|
A non-blocking 'acquire'.

* When the state is \"unlocked\" @tryAcquire@ changes the state to \"locked\"
(with the current thread as owner and an acquired count of 1) and returns
'True'.

* When the state is \"locked\" @tryAcquire@ leaves the state unchanged and
returns 'False'.
-}
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@ decrements the acquired count. When a lock is released with an
acquired count of 1 its state is changed to \"unlocked\".

Note that it is both an error to release a lock in the \"unlocked\" state and to
release a lock that is not owned by the current thread.

If there are any threads blocked on 'acquire' the thread that first called
@acquire@ will be woken up.
-}
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!"


--------------------------------------------------------------------------------
-- * Convenience functions
--------------------------------------------------------------------------------

{-| A convenience function which first acquires the lock and then
performs the computation. When the computation terminates, whether
normally or by raising an exception, the lock is released.

Note that: @with = 'liftA2' 'bracket_' 'acquire' 'release'@.
-}
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

{-|
A non-blocking 'with'. @tryWith@ is a convenience function which first tries to
acquire the lock. If that fails, 'Nothing' is returned. If it succeeds, the
computation is performed. When the computation terminates, whether normally or
by raising an exception, the lock is released and 'Just' the result of the
computation is returned.
-}
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

{-|
* When the state is \"locked\" @wait@ /blocks/ until a call to 'release' in
another thread changes it to \"unlocked\".

* When the state is \"unlocked\" @wait@ returns immediately.

@wait@ does not alter the state of the lock.

Note that @wait@ is just a convenience function defined as:

@wait l = 'block' '$' 'acquire' l '>>' 'release' l@
-}
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


--------------------------------------------------------------------------------
-- * Querying reentrant locks
--------------------------------------------------------------------------------

{-|
Determine the state of the reentrant lock.

Note that this is only a snapshot of the state. By the time a program reacts on
its result it may already be out of date.
-}
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