--------------------------------------------------------------------------------

-- Copyright © 2010-2012 Bas van Dijk & Roel van Dijk
-- Copyright © 2018 DFINITY Stiftung
--
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--     * Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
--
--     * Redistributions in binary form must reproduce the above
--       copyright notice, this list of conditions and the following
--       disclaimer in the documentation and/or other materials provided
--       with the distribution.
--
--     * The names of Bas van Dijk, Roel van Dijk and the names of
--       contributors may NOT be used to endorse or promote products
--       derived from this software without specific prior written
--       permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

-------------------------------------------------------------------------------

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE UndecidableInstances #-}

-------------------------------------------------------------------------------

-- |
-- Module     : Control.Concurrent.Classy.RWLock
-- Copyright  : © 2010-2011 Bas van Dijk & Roel van Dijk
--            , © 2018 DFINITY Stiftung
-- Maintainer : DFINITY USA Research <team@dfinity.org>
--
-- 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'.

-------------------------------------------------------------------------------

module Control.Concurrent.Classy.RWLock
  ( -- * @RWLock@
    RWLock

    -- * Creating locks
  , newRWLock
  , 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

-------------------------------------------------------------------------------

import           Control.Applicative            (pure, (<*>))
import           Control.Monad                  (Monad, (>>))
import           Data.Bool                      (Bool(False, True))
import           Data.Eq                        (Eq, (==))
import           Data.Function                  (on, ($))
import           Data.Functor                   ((<$>))
import           Data.Int                       (Int)
import           Data.List                      ((++))
import           Data.Maybe                     (Maybe(Just, Nothing))
import           Data.Ord                       (Ord)
import           Data.Typeable                  (Typeable)
import           Prelude                        (String, error, pred, succ)
import           Text.Read                      (Read)
import           Text.Show                      (Show)

import qualified Control.Concurrent.Classy.MVar as MVar
import           Control.Monad.Catch            (bracket_, mask, mask_,
                                                 onException)
import           Control.Monad.Conc.Class       (MonadConc(MVar))

import           Control.Concurrent.Classy.Lock (Lock)
import qualified Control.Concurrent.Classy.Lock as 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.
--
-- @since 1.6.2.0
data RWLock m
  = RWLock
    { forall (m :: * -> *). RWLock m -> MVar m State
_state     :: MVar m State
    , forall (m :: * -> *). RWLock m -> Lock m
_readLock  :: Lock m
    , forall (m :: * -> *). RWLock m -> Lock m
_writeLock :: Lock m
    }
  deriving (Typeable)

-- TODO: could the fields of RWLock be strict / unpacked?

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

-------------------------------------------------------------------------------

-- |
-- Internal state of the 'RWLock'.
data State
  = Free
  | Read !Int
  | Write
  deriving (State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: State -> State -> Bool
== :: State -> State -> Bool
$c/= :: State -> State -> Bool
/= :: State -> State -> Bool
Eq, Eq State
Eq State =>
(State -> State -> Ordering)
-> (State -> State -> Bool)
-> (State -> State -> Bool)
-> (State -> State -> Bool)
-> (State -> State -> Bool)
-> (State -> State -> State)
-> (State -> State -> State)
-> Ord State
State -> State -> Bool
State -> State -> Ordering
State -> State -> State
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: State -> State -> Ordering
compare :: State -> State -> Ordering
$c< :: State -> State -> Bool
< :: State -> State -> Bool
$c<= :: State -> State -> Bool
<= :: State -> State -> Bool
$c> :: State -> State -> Bool
> :: State -> State -> Bool
$c>= :: State -> State -> Bool
>= :: State -> State -> Bool
$cmax :: State -> State -> State
max :: State -> State -> State
$cmin :: State -> State -> State
min :: State -> State -> State
Ord, Int -> State -> ShowS
[State] -> ShowS
State -> String
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> State -> ShowS
showsPrec :: Int -> State -> ShowS
$cshow :: State -> String
show :: State -> String
$cshowList :: [State] -> ShowS
showList :: [State] -> ShowS
Show, ReadPrec [State]
ReadPrec State
Int -> ReadS State
ReadS [State]
(Int -> ReadS State)
-> ReadS [State]
-> ReadPrec State
-> ReadPrec [State]
-> Read State
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS State
readsPrec :: Int -> ReadS State
$creadList :: ReadS [State]
readList :: ReadS [State]
$creadPrec :: ReadPrec State
readPrec :: ReadPrec State
$creadListPrec :: ReadPrec [State]
readListPrec :: ReadPrec [State]
Read)

-------------------------------------------------------------------------------

-- |
-- Create a new 'RWLock' in the \"free\" state; either read or write access
-- can be acquired without blocking.
--
-- @since 1.6.2.0
newRWLock :: (MonadConc m) => m (RWLock m)
newRWLock :: forall (m :: * -> *). MonadConc m => m (RWLock m)
newRWLock = do
  MVar m State
state <- State -> m (MVar m State)
forall (m :: * -> *) a. MonadConc m => a -> m (MVar m a)
MVar.newMVar State
Free
  Lock m
rlock <- m (Lock m)
forall (m :: * -> *). MonadConc m => m (Lock m)
Lock.newLock
  MVar m State -> Lock m -> Lock m -> RWLock m
forall (m :: * -> *). MVar m State -> Lock m -> Lock m -> RWLock m
RWLock MVar m State
state Lock m
rlock (Lock m -> RWLock m) -> m (Lock m) -> m (RWLock m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Lock m)
forall (m :: * -> *). MonadConc m => m (Lock m)
Lock.newLock

-- |
-- Create a new 'RWLock' in the \"read\" state; only read can be acquired
-- without blocking.
--
-- @since 1.6.2.0
newAcquiredRead :: (MonadConc m) => m (RWLock m)
newAcquiredRead :: forall (m :: * -> *). MonadConc m => m (RWLock m)
newAcquiredRead = do
  MVar m State
state <- State -> m (MVar m State)
forall (m :: * -> *) a. MonadConc m => a -> m (MVar m a)
MVar.newMVar (Int -> State
Read Int
1)
  Lock m
rlock <- m (Lock m)
forall (m :: * -> *). MonadConc m => m (Lock m)
Lock.newAcquired
  MVar m State -> Lock m -> Lock m -> RWLock m
forall (m :: * -> *). MVar m State -> Lock m -> Lock m -> RWLock m
RWLock MVar m State
state Lock m
rlock (Lock m -> RWLock m) -> m (Lock m) -> m (RWLock m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Lock m)
forall (m :: * -> *). MonadConc m => m (Lock m)
Lock.newLock

-- |
-- Create a new 'RWLock' in the \"write\" state; either acquiring read or
-- write will block.
--
-- @since 1.6.2.0
newAcquiredWrite :: (MonadConc m) => m (RWLock m)
newAcquiredWrite :: forall (m :: * -> *). MonadConc m => m (RWLock m)
newAcquiredWrite = do
  MVar m State
state <- State -> m (MVar m State)
forall (m :: * -> *) a. MonadConc m => a -> m (MVar m a)
MVar.newMVar State
Write
  Lock m
rlock <- m (Lock m)
forall (m :: * -> *). MonadConc m => m (Lock m)
Lock.newLock
  MVar m State -> Lock m -> Lock m -> RWLock m
forall (m :: * -> *). MVar m State -> Lock m -> Lock m -> RWLock m
RWLock MVar m State
state Lock m
rlock (Lock m -> RWLock m) -> m (Lock m) -> m (RWLock m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Lock m)
forall (m :: * -> *). MonadConc m => m (Lock m)
Lock.newAcquired

-------------------------------------------------------------------------------

-- |
-- 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.
--
-- @since 1.6.2.0
acquireRead :: (MonadConc m) => RWLock m -> m ()
acquireRead :: forall (m :: * -> *). MonadConc m => RWLock m -> m ()
acquireRead RWLock { MVar m State
_state :: forall (m :: * -> *). RWLock m -> MVar m State
_state :: MVar m State
_state, Lock m
_readLock :: forall (m :: * -> *). RWLock m -> Lock m
_readLock :: Lock m
_readLock, Lock m
_writeLock :: forall (m :: * -> *). RWLock m -> Lock m
_writeLock :: Lock m
_writeLock } = m () -> m ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ m ()
go
  where
    go :: m ()
go = do
      State
st <- MVar m State -> m State
forall a. MVar m a -> m a
forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
MVar.takeMVar MVar m State
_state
      case State
st of
        State
Free     -> do Lock m -> m ()
forall (m :: * -> *). MonadConc m => Lock m -> m ()
Lock.acquire Lock m
_readLock
                       MVar m State -> State -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
MVar.putMVar MVar m State
_state (State -> m ()) -> State -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> State
Read Int
1
        (Read Int
n) ->    MVar m State -> State -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
MVar.putMVar MVar m State
_state (State -> m ()) -> State -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> State
Read (Int -> Int
forall a. Enum a => a -> a
succ Int
n)
        State
Write    -> do MVar m State -> State -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
MVar.putMVar MVar m State
_state State
st
                       Lock m -> m ()
forall (m :: * -> *). MonadConc m => Lock m -> m ()
Lock.wait Lock m
_writeLock
                       m ()
go

-- |
-- Try to acquire the read lock; non blocking.
--
-- Like 'acquireRead', but doesn't block. Returns 'True' if the resulting
-- state is \"read\", 'False' otherwise.
--
-- @since 1.6.2.0
tryAcquireRead :: (MonadConc m) => RWLock m -> m Bool
tryAcquireRead :: forall (m :: * -> *). MonadConc m => RWLock m -> m Bool
tryAcquireRead RWLock { MVar m State
_state :: forall (m :: * -> *). RWLock m -> MVar m State
_state :: MVar m State
_state, Lock m
_readLock :: forall (m :: * -> *). RWLock m -> Lock m
_readLock :: Lock m
_readLock } = m Bool -> m Bool
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (m Bool -> m Bool) -> m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
  State
st <- MVar m State -> m State
forall a. MVar m a -> m a
forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
MVar.takeMVar MVar m State
_state
  case State
st of
    State
Free   -> do Lock m -> m ()
forall (m :: * -> *). MonadConc m => Lock m -> m ()
Lock.acquire Lock m
_readLock
                 MVar m State -> State -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
MVar.putMVar MVar m State
_state (State -> m ()) -> State -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> State
Read Int
1
                 Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Read Int
n -> do MVar m State -> State -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
MVar.putMVar MVar m State
_state (State -> m ()) -> State -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> State
Read (Int -> Int
forall a. Enum a => a -> a
succ Int
n)
                 Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    State
Write  -> do MVar m State -> State -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
MVar.putMVar MVar m State
_state State
st
                 Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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.
--
-- @since 1.6.2.0
releaseRead :: (MonadConc m) => RWLock m -> m ()
releaseRead :: forall (m :: * -> *). MonadConc m => RWLock m -> m ()
releaseRead RWLock { MVar m State
_state :: forall (m :: * -> *). RWLock m -> MVar m State
_state :: MVar m State
_state, Lock m
_readLock :: forall (m :: * -> *). RWLock m -> Lock m
_readLock :: Lock m
_readLock } = m () -> m ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  State
st <- MVar m State -> m State
forall a. MVar m a -> m a
forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
MVar.takeMVar MVar m State
_state
  case State
st of
    Read Int
1 -> do Lock m -> m ()
forall (m :: * -> *). MonadConc m => Lock m -> m ()
Lock.release Lock m
_readLock
                 MVar m State -> State -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
MVar.putMVar MVar m State
_state State
Free
    Read Int
n ->    MVar m State -> State -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
MVar.putMVar MVar m State
_state (State -> m ()) -> State -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> State
Read (Int -> Int
forall a. Enum a => a -> a
pred Int
n)
    State
_      -> do MVar m State -> State -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
MVar.putMVar MVar m State
_state State
st
                 String -> String -> m ()
forall (m :: * -> *) a. Monad m => String -> String -> m a
throw String
"releaseRead" String
"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.
--
-- @since 1.6.2.0
withRead :: (MonadConc m) => RWLock m -> m a -> m a
withRead :: forall (m :: * -> *) a. MonadConc m => RWLock m -> m a -> m a
withRead = m () -> m () -> m a -> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ (m () -> m () -> m a -> m a)
-> (RWLock m -> m ()) -> RWLock m -> m () -> m a -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWLock m -> m ()
forall (m :: * -> *). MonadConc m => RWLock m -> m ()
acquireRead (RWLock m -> m () -> m a -> m a)
-> (RWLock m -> m ()) -> RWLock m -> m a -> m a
forall a b.
(RWLock m -> a -> b) -> (RWLock m -> a) -> RWLock m -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RWLock m -> m ()
forall (m :: * -> *). MonadConc m => RWLock m -> m ()
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.
--
-- @since 1.6.2.0
tryWithRead :: (MonadConc m) => RWLock m -> m a -> m (Maybe a)
tryWithRead :: forall (m :: * -> *) a.
MonadConc m =>
RWLock m -> m a -> m (Maybe a)
tryWithRead RWLock m
l m a
a = ((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a)
forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a))
-> ((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
  Bool
acquired <- RWLock m -> m Bool
forall (m :: * -> *). MonadConc m => RWLock m -> m Bool
tryAcquireRead RWLock m
l
  if Bool
acquired
    then do a
r <- m a -> m a
forall a. m a -> m a
restore m a
a m a -> m () -> m a
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
`onException` RWLock m -> m ()
forall (m :: * -> *). MonadConc m => RWLock m -> m ()
releaseRead RWLock m
l
            RWLock m -> m ()
forall (m :: * -> *). MonadConc m => RWLock m -> m ()
releaseRead RWLock m
l
            Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
r
    else Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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@
--
-- @since 1.6.2.0
waitRead :: (MonadConc m) => RWLock m -> m ()
waitRead :: forall (m :: * -> *). MonadConc m => RWLock m -> m ()
waitRead RWLock m
l = m () -> m ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (RWLock m -> m ()
forall (m :: * -> *). MonadConc m => RWLock m -> m ()
acquireRead RWLock m
l m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RWLock m -> m ()
forall (m :: * -> *). MonadConc m => RWLock m -> m ()
releaseRead RWLock m
l)

-------------------------------------------------------------------------------

-- |
-- 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\".
--
-- @since 1.6.2.0
acquireWrite :: (MonadConc m) => RWLock m -> m ()
acquireWrite :: forall (m :: * -> *). MonadConc m => RWLock m -> m ()
acquireWrite RWLock { MVar m State
_state :: forall (m :: * -> *). RWLock m -> MVar m State
_state :: MVar m State
_state, Lock m
_readLock :: forall (m :: * -> *). RWLock m -> Lock m
_readLock :: Lock m
_readLock, Lock m
_writeLock :: forall (m :: * -> *). RWLock m -> Lock m
_writeLock :: Lock m
_writeLock } = m () -> m ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ m ()
go'
  where
    go' :: m ()
go' = do
      State
st <- MVar m State -> m State
forall a. MVar m a -> m a
forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
MVar.takeMVar MVar m State
_state
      case State
st of
        State
Free   -> do Lock m -> m ()
forall (m :: * -> *). MonadConc m => Lock m -> m ()
Lock.acquire Lock m
_writeLock
                     MVar m State -> State -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
MVar.putMVar MVar m State
_state State
Write
        Read Int
_ -> do MVar m State -> State -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
MVar.putMVar MVar m State
_state State
st
                     Lock m -> m ()
forall (m :: * -> *). MonadConc m => Lock m -> m ()
Lock.wait Lock m
_readLock
                     m ()
go'
        State
Write  -> do MVar m State -> State -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
MVar.putMVar MVar m State
_state State
st
                     Lock m -> m ()
forall (m :: * -> *). MonadConc m => Lock m -> m ()
Lock.wait Lock m
_writeLock
                     m ()
go'

-- |
-- Try to acquire the write lock; non blocking.
--
-- Like 'acquireWrite', but doesn't block.
-- Returns 'True' if the resulting state is \"write\", 'False' otherwise.
--
-- @since 1.6.2.0
tryAcquireWrite :: (MonadConc m) => RWLock m -> m Bool
tryAcquireWrite :: forall (m :: * -> *). MonadConc m => RWLock m -> m Bool
tryAcquireWrite RWLock { MVar m State
_state :: forall (m :: * -> *). RWLock m -> MVar m State
_state :: MVar m State
_state, Lock m
_writeLock :: forall (m :: * -> *). RWLock m -> Lock m
_writeLock :: Lock m
_writeLock } = m Bool -> m Bool
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (m Bool -> m Bool) -> m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
  State
st <- MVar m State -> m State
forall a. MVar m a -> m a
forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
MVar.takeMVar MVar m State
_state
  case State
st of
    State
Free -> do Lock m -> m ()
forall (m :: * -> *). MonadConc m => Lock m -> m ()
Lock.acquire Lock m
_writeLock
               MVar m State -> State -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
MVar.putMVar MVar m State
_state State
Write
               Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    State
_    -> do MVar m State -> State -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
MVar.putMVar MVar m State
_state State
st
               Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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.
--
-- @since 1.6.2.0
releaseWrite :: (MonadConc m) => RWLock m -> m ()
releaseWrite :: forall (m :: * -> *). MonadConc m => RWLock m -> m ()
releaseWrite RWLock { MVar m State
_state :: forall (m :: * -> *). RWLock m -> MVar m State
_state :: MVar m State
_state, Lock m
_writeLock :: forall (m :: * -> *). RWLock m -> Lock m
_writeLock :: Lock m
_writeLock } = m () -> m ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  State
st <- MVar m State -> m State
forall a. MVar m a -> m a
forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
MVar.takeMVar MVar m State
_state
  case State
st of
    State
Write -> do Lock m -> m ()
forall (m :: * -> *). MonadConc m => Lock m -> m ()
Lock.release Lock m
_writeLock
                MVar m State -> State -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
MVar.putMVar MVar m State
_state State
Free
    State
_     -> do MVar m State -> State -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
MVar.putMVar MVar m State
_state State
st
                String -> String -> m ()
forall (m :: * -> *) a. Monad m => String -> String -> m a
throw String
"releaseWrite" String
"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.
--
-- @since 1.6.2.0
withWrite :: (MonadConc m) => RWLock m -> m a -> m a
withWrite :: forall (m :: * -> *) a. MonadConc m => RWLock m -> m a -> m a
withWrite = m () -> m () -> m a -> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ (m () -> m () -> m a -> m a)
-> (RWLock m -> m ()) -> RWLock m -> m () -> m a -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWLock m -> m ()
forall (m :: * -> *). MonadConc m => RWLock m -> m ()
acquireWrite (RWLock m -> m () -> m a -> m a)
-> (RWLock m -> m ()) -> RWLock m -> m a -> m a
forall a b.
(RWLock m -> a -> b) -> (RWLock m -> a) -> RWLock m -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RWLock m -> m ()
forall (m :: * -> *). MonadConc m => RWLock m -> m ()
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.
--
-- @since 1.6.2.0
tryWithWrite :: (MonadConc m) => RWLock m -> m a -> m (Maybe a)
tryWithWrite :: forall (m :: * -> *) a.
MonadConc m =>
RWLock m -> m a -> m (Maybe a)
tryWithWrite RWLock m
l m a
a = ((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a)
forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a))
-> ((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
  Bool
acquired <- RWLock m -> m Bool
forall (m :: * -> *). MonadConc m => RWLock m -> m Bool
tryAcquireWrite RWLock m
l
  if Bool
acquired
    then do a
r <- m a -> m a
forall a. m a -> m a
restore m a
a m a -> m () -> m a
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
`onException` RWLock m -> m ()
forall (m :: * -> *). MonadConc m => RWLock m -> m ()
releaseWrite RWLock m
l
            RWLock m -> m ()
forall (m :: * -> *). MonadConc m => RWLock m -> m ()
releaseWrite RWLock m
l
            Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
r
    else Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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@
--
-- @since 1.6.2.0
waitWrite :: (MonadConc m) => RWLock m -> m ()
waitWrite :: forall (m :: * -> *). MonadConc m => RWLock m -> m ()
waitWrite RWLock m
l = m () -> m ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (RWLock m -> m ()
forall (m :: * -> *). MonadConc m => RWLock m -> m ()
acquireWrite RWLock m
l m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RWLock m -> m ()
forall (m :: * -> *). MonadConc m => RWLock m -> m ()
releaseWrite RWLock m
l)

--------------------------------------------------------------------------------

throw :: (Monad m) => String -> String -> m a
throw :: forall (m :: * -> *) a. Monad m => String -> String -> m a
throw String
func String
msg
  = String -> m a
forall a. HasCallStack => String -> a
error (String
"Control.Concurrent.Classy.RWLock." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
func String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg)

--------------------------------------------------------------------------------