{-# 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RLock -> RLock -> Bool
$c/= :: RLock -> RLock -> Bool
== :: RLock -> RLock -> Bool
$c== :: 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (MVar a)
newMVar (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (MVar a)
newMVar (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
  forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ let acq :: IO ()
acq = do t :: (State, Lock)
t@(State
mb, Lock
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
                                                forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (forall a. a -> Maybe a
Just (ThreadId
myTID, Integer
1), Lock
lock)
                         Just (ThreadId
tid, Integer
n)
                           | ThreadId
myTID forall a. Eq a => a -> a -> Bool
== ThreadId
tid -> let !sn :: Integer
sn = forall a. Enum a => a -> a
succ Integer
n
                                             in forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (forall a. a -> Maybe a
Just (ThreadId
tid, Integer
sn), Lock
lock)
                           | Bool
otherwise    -> do 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
  forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
    t :: (State, Lock)
t@(State
mb, Lock
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
                             forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (forall a. a -> Maybe a
Just (ThreadId
myTID, Integer
1), Lock
lock)
                             forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      Just (ThreadId
tid, Integer
n)
        | ThreadId
myTID forall a. Eq a => a -> a -> Bool
== ThreadId
tid -> do let !sn :: Integer
sn = forall a. Enum a => a -> a
succ Integer
n
                             forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (forall a. a -> Maybe a
Just (ThreadId
tid, Integer
sn), Lock
lock)
                             forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

        | Bool
otherwise    -> do forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (State, Lock)
t
                             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
  forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
    t :: (State, Lock)
t@(State
mb, Lock
lock) <- forall a. MVar a -> IO a
takeMVar MVar (State, Lock)
mv
    let err :: [Char] -> IO b
err [Char]
msg = do forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (State, Lock)
t
                     forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Control.Concurrent.RLock.release: " forall a. [a] -> [a] -> [a]
++ [Char]
msg
    case State
mb of
      State
Nothing -> forall {b}. [Char] -> IO b
err [Char]
"Can't release an unacquired RLock!"
      Just (ThreadId
tid, Integer
n)
        | ThreadId
myTID forall a. Eq a => a -> a -> Bool
== ThreadId
tid -> if Integer
n forall a. Eq a => a -> a -> Bool
== Integer
1
                          then do Lock -> IO ()
Lock.release Lock
lock
                                  forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (forall a. Maybe a
Nothing, Lock
lock)
                          else let !pn :: Integer
pn = forall a. Enum a => a -> a
pred Integer
n
                               in forall a. MVar a -> a -> IO ()
putMVar MVar (State, Lock)
mv (forall a. a -> Maybe a
Just (ThreadId
tid, Integer
pn), Lock
lock)
        | Bool
otherwise -> 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 = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 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 b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask 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 <- forall a. IO a -> IO a
restore IO a
a forall a b. IO a -> IO b -> IO a
`onException` RLock -> IO ()
release RLock
l
            RLock -> IO ()
release RLock
l
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
r
    else forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ RLock -> IO ()
acquire RLock
l 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> IO a
readMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. RLock -> MVar (State, Lock)
un