    {-# 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 <- IO Lock
    Lock.new
             RLock <$> newMVar (Nothing, 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 myTID <- IO ThreadId
    myThreadId
                     lock <- Lock.newAcquired
                     RLock <$> newMVar (Just (myTID, 1), 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
      myTID <- IO ThreadId
    myThreadId
      mask_ $ let acq = do t@(mb, lock) <- MVar (State, Lock) -> IO (State, Lock)
    forall a. MVar a -> IO a
    takeMVar MVar (State, Lock)
    mv
                           case 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 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
      myTID <- IO ThreadId
    myThreadId
      mask_ $ do
        t@(mb, lock) <- takeMVar mv
        case 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
      myTID <- IO ThreadId
    myThreadId
      mask_ $ do
        t@(mb, lock) <- takeMVar mv
        let 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 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
      acquired <- RLock -> IO Bool
    tryAcquire RLock
    l
      if acquired
        then do r <- restore a `onException` release l
                release l
                return $ Just r
        else return 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