{-# 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 State
st <- MVar State -> IO State
forall a. MVar a -> IO a
takeMVar MVar State
state
                   case State
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
  State
st <- MVar State -> IO State
forall a. MVar a -> IO a
takeMVar MVar State
state
  case State
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
  State
st <- MVar State -> IO State
forall a. MVar a -> IO a
takeMVar MVar State
state
  case State
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
  Bool
acquired <- RWLock -> IO Bool
tryAcquireRead RWLock
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` RWLock -> IO ()
releaseRead RWLock
l
            RWLock -> IO ()
releaseRead RWLock
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 \"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 State
st <- MVar State -> IO State
forall a. MVar a -> IO a
takeMVar MVar State
state
                    case State
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
  State
st <- MVar State -> IO State
forall a. MVar a -> IO a
takeMVar MVar State
state
  case State
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
  State
st <- MVar State -> IO State
forall a. MVar a -> IO a
takeMVar MVar State
state
  case State
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
  Bool
acquired <- RWLock -> IO Bool
tryAcquireWrite RWLock
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` RWLock -> IO ()
releaseWrite RWLock
l
            RWLock -> IO ()
releaseWrite RWLock
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 \"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"