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

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

    -------------------------------------------------------------------------------
    -- |
    -- Module     : Control.Concurrent.ReadWriteLock
    -- 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>
    --
    -- Multiple-reader, single-writer locks. Used to protect shared resources which
    -- may be concurrently read, but only sequentially written.
    --
    -- All functions are /exception safe/. Throwing asynchronous exceptions will not
    -- compromise the internal state of an 'RWLock'. This means it is perfectly safe
    -- to kill a thread that is blocking on, for example, 'acquireRead'.
    --
    -- See also Java's version:
    -- <http://java.sun.com/javase/7/docs/api/java/util/concurrent/locks/ReadWriteLock.html>
    --
    -- This module is designed to be imported qualified. We suggest importing it
    -- like:
    --
    -- @
    -- import           Control.Concurrent.ReadWriteLock        ( RWLock )
    -- import qualified Control.Concurrent.ReadWriteLock as RWL ( ... )
    -- @
    --
    -------------------------------------------------------------------------------

    module Control.Concurrent.ReadWriteLock
      ( RWLock

        -- *Creating Read-Write Locks
      , new
      , newAcquiredRead
      , newAcquiredWrite

        -- *Read access
        -- **Blocking
      , acquireRead
      , releaseRead
      , withRead
      , waitRead
        -- **Non-blocking
      , tryAcquireRead
      , tryWithRead

        -- *Write access
        -- **Blocking
      , acquireWrite
      , releaseWrite
      , withWrite
      , waitWrite
        -- **Non-blocking
      , tryAcquireWrite
      , tryWithWrite
      ) where

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

    -- from base:
    import Control.Applicative     ( liftA2, liftA3 )
    import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar )
    import Control.Exception       ( bracket_, onException )
    import Control.Monad           ( return, (>>) )
    import Data.Bool               ( Bool(False, True) )
    import Data.Eq                 ( Eq, (==) )
    import Data.Function           ( ($), (.), on )
    import Data.Int                ( Int )
    import Data.Maybe              ( Maybe(Nothing, Just) )
    import Data.List               ( (++))
    import Data.Typeable           ( Typeable )
    import Prelude                 ( String, ($!), succ, pred, error )
    import System.IO               ( IO )

    #if __GLASGOW_HASKELL__ < 700
    import Prelude                 ( fromInteger )
    import Control.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_ )

    -------------------------------------------------------------------------------
    -- Read Write Lock
    -------------------------------------------------------------------------------

    {-|
    Multiple-reader, single-writer lock. Is in one of three states:

    * \"Free\": Read or write access can be acquired without blocking.

    * \"Read\": One or more threads have acquired read access. Blocks write access.

    * \"Write\": A single thread has acquired write access. Blocks other threads
    from acquiring both read and write access.
    -}
    data RWLock = RWLock { RWLock -> MVar State
    state     :: MVar State
                         , RWLock -> Lock
    readLock  :: Lock
                         , RWLock -> Lock
    writeLock :: Lock
                         } deriving Typeable

    instance Eq RWLock where
        == :: RWLock -> RWLock -> Bool
    (==) = MVar State -> MVar State -> Bool
    forall a. Eq a => a -> a -> Bool
    (==) (MVar State -> MVar State -> Bool)
    -> (RWLock -> MVar State) -> RWLock -> RWLock -> Bool
    forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
    `on` RWLock -> MVar State
    state

    -- | Internal state of the 'RWLock'.
    data State = Free | Read Int | Write

    -------------------------------------------------------------------------------
    -- * Creating Read-Write Locks
    -------------------------------------------------------------------------------

    -- | Create a new 'RWLock' in the \"free\" state; either read or write access
    -- can be acquired without blocking.
    new :: IO RWLock
    new :: IO RWLock
    new = (MVar State -> Lock -> Lock -> RWLock)
    -> IO (MVar State) -> IO Lock -> IO Lock -> IO RWLock
    forall (f :: * -> *) a b c d.
    Applicative f =>
    (a -> b -> c -> d) -> f a -> f b -> f c -> f d
    liftA3 MVar State -> Lock -> Lock -> RWLock
    RWLock (State -> IO (MVar State)
    forall a. a -> IO (MVar a)
    newMVar State
    Free)
                        IO Lock
    Lock.new
                        IO Lock
    Lock.new

    -- | Create a new 'RWLock' in the \"read\" state; only read can be acquired
    -- without blocking.
    newAcquiredRead :: IO RWLock
    newAcquiredRead :: IO RWLock
    newAcquiredRead = (MVar State -> Lock -> Lock -> RWLock)
    -> IO (MVar State) -> IO Lock -> IO Lock -> IO RWLock
    forall (f :: * -> *) a b c d.
    Applicative f =>
    (a -> b -> c -> d) -> f a -> f b -> f c -> f d
    liftA3 MVar State -> Lock -> Lock -> RWLock
    RWLock (State -> IO (MVar State)
    forall a. a -> IO (MVar a)
    newMVar (State -> IO (MVar State)) -> State -> IO (MVar State)
    forall a b. (a -> b) -> a -> b
    $ Int -> State
    Read Int
    1)
                                    IO Lock
    Lock.newAcquired
                                    IO Lock
    Lock.new

    -- | Create a new 'RWLock' in the \"write\" state; either acquiring read or
    -- write will block.
    newAcquiredWrite :: IO RWLock
    newAcquiredWrite :: IO RWLock
    newAcquiredWrite = (MVar State -> Lock -> Lock -> RWLock)
    -> IO (MVar State) -> IO Lock -> IO Lock -> IO RWLock
    forall (f :: * -> *) a b c d.
    Applicative f =>
    (a -> b -> c -> d) -> f a -> f b -> f c -> f d
    liftA3 MVar State -> Lock -> Lock -> RWLock
    RWLock (State -> IO (MVar State)
    forall a. a -> IO (MVar a)
    newMVar State
    Write)
                                     IO Lock
    Lock.new
                                     IO Lock
    Lock.newAcquired

    -------------------------------------------------------------------------------
    -- * Read access
    -------------------------------------------------------------------------------

    {-|
    Acquire the read lock.

    Blocks if another thread has acquired write access. If @acquireRead@ terminates
    without throwing an exception the state of the 'RWLock' will be \"read\".

    Implementation note: Throws an exception when more than (maxBound :: Int)
    simultaneous threads acquire the read lock. But that is unlikely.
    -}
    acquireRead :: RWLock -> IO ()
    acquireRead :: RWLock -> IO ()
    acquireRead (RWLock {MVar State
    state :: RWLock -> MVar State
    state :: MVar State
    state, Lock
    readLock :: RWLock -> Lock
    readLock :: Lock
    readLock, Lock
    writeLock :: RWLock -> Lock
    writeLock :: Lock
    writeLock}) = IO () -> IO ()
    forall a. IO a -> IO a
    mask_ IO ()
    acqRead
        where
          acqRead :: IO ()
    acqRead = do st <- MVar State -> IO State
    forall a. MVar a -> IO a
    takeMVar MVar State
    state
                       case st of
                         State
    Free   -> do Lock -> IO ()
    Lock.acquire Lock
    readLock
                                      MVar State -> State -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar State
    state (State -> IO ()) -> State -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Int -> State
    Read Int
    1
                         Read Int
    n -> MVar State -> State -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar State
    state (State -> IO ()) -> (Int -> State) -> Int -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> State
    Read (Int -> IO ()) -> Int -> IO ()
    forall a b. (a -> b) -> a -> b
    $! Int -> Int
    forall a. Enum a => a -> a
    succ Int
    n
                         State
    Write  -> do MVar State -> State -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar State
    state State
    st
                                      Lock -> IO ()
    Lock.wait Lock
    writeLock
                                      IO ()
    acqRead

    {-|
    Try to acquire the read lock; non blocking.

    Like 'acquireRead', but doesn't block. Returns 'True' if the resulting state is
    \"read\", 'False' otherwise.
    -}
    tryAcquireRead :: RWLock -> IO Bool
    tryAcquireRead :: RWLock -> IO Bool
    tryAcquireRead (RWLock {MVar State
    state :: RWLock -> MVar State
    state :: MVar State
    state, Lock
    readLock :: RWLock -> Lock
    readLock :: Lock
    readLock}) = 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
      st <- MVar State -> IO State
    forall a. MVar a -> IO a
    takeMVar MVar State
    state
      case st of
        State
    Free   -> do Lock -> IO ()
    Lock.acquire Lock
    readLock
                     MVar State -> State -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar State
    state (State -> IO ()) -> State -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Int -> State
    Read Int
    1
                     Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
        Read Int
    n -> do MVar State -> State -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar State
    state (State -> IO ()) -> (Int -> State) -> Int -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> State
    Read (Int -> IO ()) -> Int -> IO ()
    forall a b. (a -> b) -> a -> b
    $! Int -> Int
    forall a. Enum a => a -> a
    succ Int
    n
                     Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
        State
    Write  -> do MVar State -> State -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar State
    state State
    st
                     Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False

    {-|
    Release the read lock.

    If the calling thread was the last one to relinquish read access the state will
    revert to \"free\".

    It is an error to release read access to an 'RWLock' which is not in the
    \"read\" state.
    -}
    releaseRead :: RWLock -> IO ()
    releaseRead :: RWLock -> IO ()
    releaseRead (RWLock {MVar State
    state :: RWLock -> MVar State
    state :: MVar State
    state, Lock
    readLock :: RWLock -> Lock
    readLock :: Lock
    readLock}) = IO () -> IO ()
    forall a. IO a -> IO a
    mask_ (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
      st <- MVar State -> IO State
    forall a. MVar a -> IO a
    takeMVar MVar State
    state
      case st of
        Read Int
    1 -> do Lock -> IO ()
    Lock.release Lock
    readLock
                     MVar State -> State -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar State
    state State
    Free
        Read Int
    n -> MVar State -> State -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar State
    state (State -> IO ()) -> (Int -> State) -> Int -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> State
    Read (Int -> IO ()) -> Int -> IO ()
    forall a b. (a -> b) -> a -> b
    $! Int -> Int
    forall a. Enum a => a -> a
    pred Int
    n
        State
    _ -> do MVar State -> State -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar State
    state State
    st
                [Char] -> IO ()
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> IO ()) -> [Char] -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [Char]
    moduleName [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    ".releaseRead: already released"

    {-|
    A convenience function wich first acquires read access and then performs the
    computation. When the computation terminates, whether normally or by raising an
    exception, the read lock is released.
    -}
    withRead :: RWLock -> IO a -> IO a
    withRead :: forall a. RWLock -> IO a -> IO a
    withRead = (IO () -> IO () -> IO a -> IO a)
    -> (RWLock -> IO ()) -> (RWLock -> IO ()) -> RWLock -> IO a -> IO a
    forall a b c.
    (a -> b -> c) -> (RWLock -> a) -> (RWLock -> b) -> RWLock -> 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_ RWLock -> IO ()
    acquireRead RWLock -> IO ()
    releaseRead

    {-|
    A non-blocking 'withRead'. 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.
    -}
    tryWithRead :: RWLock -> IO a -> IO (Maybe a)
    tryWithRead :: forall a. RWLock -> IO a -> IO (Maybe a)
    tryWithRead RWLock
    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 <- RWLock -> IO Bool
    tryAcquireRead RWLock
    l
      if acquired
        then do r <- restore a `onException` releaseRead l
                releaseRead l
                return $ Just r
        else return Nothing

    {-|
    * When the state is \"write\", @waitRead@ /blocks/ until a call to
    'releaseWrite' in another thread changes the state to \"free\".

    * When the state is \"free\" or \"read\" @waitRead@ returns immediately.

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

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

    @waitRead l = 'mask_' '$' 'acquireRead' l '>>' 'releaseRead' l@
    -}
    waitRead :: RWLock -> IO ()
    waitRead :: RWLock -> IO ()
    waitRead RWLock
    l = IO () -> IO ()
    forall a. IO a -> IO a
    mask_ (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ RWLock -> IO ()
    acquireRead RWLock
    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
    >> RWLock -> IO ()
    releaseRead RWLock
    l

    -------------------------------------------------------------------------------
    -- *Write access
    -------------------------------------------------------------------------------

    {-|
    Acquire the write lock.

    Blocks if another thread has acquired either read or write access. If
    @acquireWrite@ terminates without throwing an exception the state of the
    'RWLock' will be \"write\".
    -}
    acquireWrite :: RWLock -> IO ()
    acquireWrite :: RWLock -> IO ()
    acquireWrite (RWLock {MVar State
    state :: RWLock -> MVar State
    state :: MVar State
    state, Lock
    readLock :: RWLock -> Lock
    readLock :: Lock
    readLock, Lock
    writeLock :: RWLock -> Lock
    writeLock :: Lock
    writeLock}) = IO () -> IO ()
    forall a. IO a -> IO a
    mask_ IO ()
    acqWrite
        where
          acqWrite :: IO ()
    acqWrite = do st <- MVar State -> IO State
    forall a. MVar a -> IO a
    takeMVar MVar State
    state
                        case st of
                          State
    Free   -> do Lock -> IO ()
    Lock.acquire Lock
    writeLock
                                       MVar State -> State -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar State
    state State
    Write
                          Read Int
    _ -> do MVar State -> State -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar State
    state State
    st
                                       Lock -> IO ()
    Lock.wait Lock
    readLock
                                       IO ()
    acqWrite
                          State
    Write  -> do MVar State -> State -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar State
    state State
    st
                                       Lock -> IO ()
    Lock.wait Lock
    writeLock
                                       IO ()
    acqWrite

    {-|
    Try to acquire the write lock; non blocking.

    Like 'acquireWrite', but doesn't block. Returns 'True' if the resulting state is
    \"write\", 'False' otherwise.
    -}
    tryAcquireWrite :: RWLock -> IO Bool
    tryAcquireWrite :: RWLock -> IO Bool
    tryAcquireWrite (RWLock {MVar State
    state :: RWLock -> MVar State
    state :: MVar State
    state, Lock
    writeLock :: RWLock -> Lock
    writeLock :: Lock
    writeLock}) = 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
      st <- MVar State -> IO State
    forall a. MVar a -> IO a
    takeMVar MVar State
    state
      case st of
        State
    Free   -> do Lock -> IO ()
    Lock.acquire Lock
    writeLock
                     MVar State -> State -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar State
    state State
    Write
                     Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
        State
    _      -> do MVar State -> State -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar State
    state State
    st
                     Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False

    {-|
    Release the write lock.

    If @releaseWrite@ terminates without throwing an exception the state will be
    \"free\".

    It is an error to release write access to an 'RWLock' which is not in the
    \"write\" state.
    -}
    releaseWrite :: RWLock -> IO ()
    releaseWrite :: RWLock -> IO ()
    releaseWrite (RWLock {MVar State
    state :: RWLock -> MVar State
    state :: MVar State
    state, Lock
    writeLock :: RWLock -> Lock
    writeLock :: Lock
    writeLock}) = IO () -> IO ()
    forall a. IO a -> IO a
    mask_ (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
      st <- MVar State -> IO State
    forall a. MVar a -> IO a
    takeMVar MVar State
    state
      case st of
        State
    Write -> do Lock -> IO ()
    Lock.release Lock
    writeLock
                    MVar State -> State -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar State
    state State
    Free
        State
    _ -> do MVar State -> State -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar State
    state State
    st
                [Char] -> IO ()
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> IO ()) -> [Char] -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [Char]
    moduleName [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    ".releaseWrite: already released"

    {-|
    A convenience function wich first acquires write access and then performs
    the computation. When the computation terminates, whether normally or by raising
    an exception, the write lock is released.
    -}
    withWrite :: RWLock -> IO a -> IO a
    withWrite :: forall a. RWLock -> IO a -> IO a
    withWrite = (IO () -> IO () -> IO a -> IO a)
    -> (RWLock -> IO ()) -> (RWLock -> IO ()) -> RWLock -> IO a -> IO a
    forall a b c.
    (a -> b -> c) -> (RWLock -> a) -> (RWLock -> b) -> RWLock -> 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_ RWLock -> IO ()
    acquireWrite RWLock -> IO ()
    releaseWrite

    {-|
    A non-blocking 'withWrite'. 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.
    -}
    tryWithWrite :: RWLock -> IO a -> IO (Maybe a)
    tryWithWrite :: forall a. RWLock -> IO a -> IO (Maybe a)
    tryWithWrite RWLock
    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 <- RWLock -> IO Bool
    tryAcquireWrite RWLock
    l
      if acquired
        then do r <- restore a `onException` releaseWrite l
                releaseWrite l
                return $ Just r
        else return Nothing

    {-|
    * When the state is \"write\" or \"read\" @waitWrite@ /blocks/ until a call to
    'releaseWrite' or 'releaseRead' in another thread changes the state to \"free\".

    * When the state is \"free\" @waitWrite@ returns immediately.

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

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

    @waitWrite l = 'mask_' '$' 'acquireWrite' l '>>' 'releaseWrite' l@
    -}
    waitWrite :: RWLock -> IO ()
    waitWrite :: RWLock -> IO ()
    waitWrite RWLock
    l = IO () -> IO ()
    forall a. IO a -> IO a
    mask_ (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ RWLock -> IO ()
    acquireWrite RWLock
    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
    >> RWLock -> IO ()
    releaseWrite RWLock
    l

    moduleName :: String
    moduleName :: [Char]
    moduleName = [Char]
    "Control.Concurrent.ReadWriteLock"