{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
-- | A Read-Append-Write (RAW) lock
--
-- Intended for qualified import
module Ouroboros.Consensus.Util.MonadSTM.RAWLock (
    -- * Public API
    RAWLock
  , new
  , poison
  , read
  , withAppendAccess
  , withReadAccess
  , withWriteAccess
    -- * Exposed internals: non-bracketed acquire & release
  , unsafeAcquireAppendAccess
  , unsafeAcquireReadAccess
  , unsafeAcquireWriteAccess
  , unsafeReleaseAppendAccess
  , unsafeReleaseReadAccess
  , unsafeReleaseWriteAccess
  ) where

import           Prelude hiding (read)

import           Control.Monad.Except
import           Data.Functor (($>))
import           GHC.Generics (Generic)
import           GHC.Stack (CallStack, HasCallStack, callStack)
import           NoThunks.Class (AllowThunk (..))

import           Ouroboros.Consensus.Util.IOLike

{-------------------------------------------------------------------------------
  Public API
-------------------------------------------------------------------------------}

-- | A Read-Append-Write (RAW) lock
--
-- A RAW lock allows multiple concurrent readers, at most one appender, which
-- is allowed to run concurrently with the readers, and at most one writer,
-- which has exclusive access to the lock.
--
-- The following table summarises which roles are allowed to concurrently
-- access the RAW lock:
--
-- >          │ Reader │ Appender │ Writer │
-- > ─────────┼────────┼──────────┼────────┤
-- > Reader   │   V    │     V    │    X   │
-- > Appender │░░░░░░░░│     X    │    X   │
-- > Writer   │░░░░░░░░│░░░░░░░░░░│    X   │
--
-- It is important to realise that a RAW lock is intended to control access to
-- a piece of in-memory state that should remain in sync with some other state
-- that can only be modified using side-effects, e.g., the file system. If,
-- for example, you're only maintaining a counter shared by threads, then
-- simply use a 'TVar' or an 'MVar'.
--
-- = Example use case: log files
--
-- A RAW lock is useful, for example, to maintain an in-memory index of log
-- files stored on disk.
--
-- * To read data from a log file, you need \"read\" access to the index to
--   find out the file and offset where the requested piece of data is stored.
--   While holding the RAW lock as a reader, you can perform the IO operation
--   to read the data from the right log file. This can safely happen
--   concurrently with other read operations.
--
-- * To append data to the current log file, you need \"append\" access to the
--   index so you can append an entry to the index and even to add a new log
--   file to the index when necessary. While holding the RAW lock as an
--   appender, you can perform the IO operation to append the piece of data to
--   the current log file and, if necessary start a new log file. Only one
--   append can happen concurrently. However, reads can safely happen
--   concurrently with appends. Note that the in-memory index is only updated
--   /after/ writing to disk.
--
-- * To remove the oldest log files, you need \"write\" access to the index,
--   so you can remove files from the index. While holding the RAW lock as a
--   writer, you can perform the IO operations to delete the oldest log files.
--   No other operations can run concurrently with this operation: concurrent
--   reads might try to read from deleted files and a concurrent append could
--   try to append to a deleted file.
--
-- = Analogy: Chicken coop
--
-- Think of readers as chickens, the appender as the rooster, and the writer
-- as the fox. All of them want access to the chicken coop, i.e., the state
-- protected by the RAW lock.
--
-- We can allow multiple chickens (readers) together in the chicken coop, they
-- get along (reasonably) fine. We can also let one rooster (appender) in, but
-- not more than one, otherwise he would start fighting with the other rooster
-- (conflict with the other appender). We can only let the fox in when all
-- chickens and the rooster (if present) have left the chicken coop, otherwise
-- the fox would eat them (conflict with the appender and invalidate the
-- results of readers, e.g, closing resources readers try to access).
--
-- = Usage
--
-- To use the lock, use any of the three following operations:
--
-- * 'withReadAccess'
-- * 'withAppendAccess'
-- * 'withWriteAccess'
--
-- If the standard bracketing the above three operations use doesn't suffice,
-- use the following three acquire-release pairs:
--
-- * 'unsafeAcquireReadAccess'   & 'unsafeReleaseReadAccess'
-- * 'unsafeAcquireAppendAccess' & 'unsafeReleaseAppendAccess'
-- * 'unsafeAcquireWriteAccess'  & 'unsafeReleaseWriteAccess'
--
-- NOTE: an acquire __must__ be followed by the corresponding release,
-- otherwise the correctness of the lock is not guaranteed and a dead-lock can
-- happen.
--
-- NOTE: nested locking of the same lock is not allowed, as you might be
-- blocked on yourself.
--
-- = Notes
--
-- * Only use a RAW lock when it is safe to concurrently read and append.
--
-- * We do not guarantee fairness for appenders and writers. They will race
--   for access each time the RAW lock changes.
--
-- * When you have many writers and/or very frequent writes, readers and
--   appenders will starve. You could say we have \"unfairness\", as writers
--   win over readers and appenders. A RAW lock will not be the best fit in
--   such a scenario.
--
-- * When you have no writers and you only need a read-append lock, consider
--   using a @StrictMVar@ instead. The \"stale\" state can be used by the
--   readers.
--
-- * The state @st@ is always evaluated to WHNF and is subject to the
--   'NoThunks' check when enabled.
--
-- * All public functions are exception-safe.
--
newtype RAWLock m st = RAWLock (StrictTVar m (RAWState st))

-- | Create a new 'RAWLock'
new :: (IOLike m, NoThunks st) => st -> m (RAWLock m st)
new :: st -> m (RAWLock m st)
new st
st = StrictTVar m (RAWState st) -> RAWLock m st
forall (m :: * -> *) st. StrictTVar m (RAWState st) -> RAWLock m st
RAWLock (StrictTVar m (RAWState st) -> RAWLock m st)
-> m (StrictTVar m (RAWState st)) -> m (RAWLock m st)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RAWState st -> m (StrictTVar m (RAWState st))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (st -> RAWState st
forall st. st -> RAWState st
emptyRAWState st
st)

-- | Access the state stored in the 'RAWLock' as a reader.
--
-- Will block when there is a writer or when a writer is waiting to take the
-- lock.
withReadAccess :: forall m st a. IOLike m => RAWLock m st -> (st -> m a) -> m a
withReadAccess :: RAWLock m st -> (st -> m a) -> m a
withReadAccess RAWLock m st
rawLock =
    m st -> (st -> m ()) -> (st -> m a) -> m a
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
      (STM m st -> m st
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m st -> m st) -> STM m st -> m st
forall a b. (a -> b) -> a -> b
$ RAWLock m st -> STM m st
forall (m :: * -> *) st. IOLike m => RAWLock m st -> STM m st
unsafeAcquireReadAccess RAWLock m st
rawLock)
      (m () -> st -> m ()
forall a b. a -> b -> a
const (STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ RAWLock m st -> STM m ()
forall (m :: * -> *) st. IOLike m => RAWLock m st -> STM m ()
unsafeReleaseReadAccess RAWLock m st
rawLock))

-- | Access the state stored in the 'RAWLock' as an appender.
--
-- NOTE: it must be safe to run the given append action concurrently with
-- readers.
--
-- Will block when there is another appender, a writer, or when a writer is
-- waiting to take the lock.
withAppendAccess
  :: forall m st a. IOLike m => RAWLock m st -> (st -> m (st, a)) -> m a
withAppendAccess :: RAWLock m st -> (st -> m (st, a)) -> m a
withAppendAccess RAWLock m st
rawLock st -> m (st, a)
k = (st, a) -> a
forall a b. (a, b) -> b
snd ((st, a) -> a) -> (((st, a), ()) -> (st, a)) -> ((st, a), ()) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((st, a), ()) -> (st, a)
forall a b. (a, b) -> a
fst (((st, a), ()) -> a) -> m ((st, a), ()) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    m st
-> (st -> ExitCase (st, a) -> m ())
-> (st -> m (st, a))
-> m ((st, a), ())
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
      (STM m st -> m st
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m st -> m st) -> STM m st -> m st
forall a b. (a -> b) -> a -> b
$ RAWLock m st -> STM m st
forall (m :: * -> *) st. IOLike m => RAWLock m st -> STM m st
unsafeAcquireAppendAccess RAWLock m st
rawLock)
      (\st
acquiredSt ExitCase (st, a)
exitCase ->
        STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ RAWLock m st -> st -> STM m ()
forall (m :: * -> *) st. IOLike m => RAWLock m st -> st -> STM m ()
unsafeReleaseAppendAccess
          RAWLock m st
rawLock
          (st -> ExitCase (st, a) -> st
forall st a. st -> ExitCase (st, a) -> st
stateToPutBack st
acquiredSt ExitCase (st, a)
exitCase))
      st -> m (st, a)
k

-- | Access the state stored in the 'RAWLock' as a writer.
--
-- Will block when there is another writer or while there are readers and/or
-- an appender.
withWriteAccess
  :: forall m st a. IOLike m => RAWLock m st -> (st -> m (st, a)) -> m a
withWriteAccess :: RAWLock m st -> (st -> m (st, a)) -> m a
withWriteAccess RAWLock m st
rawLock st -> m (st, a)
k = (st, a) -> a
forall a b. (a, b) -> b
snd ((st, a) -> a) -> (((st, a), ()) -> (st, a)) -> ((st, a), ()) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((st, a), ()) -> (st, a)
forall a b. (a, b) -> a
fst (((st, a), ()) -> a) -> m ((st, a), ()) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    m st
-> (st -> ExitCase (st, a) -> m ())
-> (st -> m (st, a))
-> m ((st, a), ())
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
      (RAWLock m st -> m st
forall (m :: * -> *) st. IOLike m => RAWLock m st -> m st
unsafeAcquireWriteAccess RAWLock m st
rawLock)
      (\st
acquiredSt ExitCase (st, a)
exitCase ->
        RAWLock m st -> st -> m ()
forall (m :: * -> *) st. IOLike m => RAWLock m st -> st -> m ()
unsafeReleaseWriteAccess
          RAWLock m st
rawLock
          (st -> ExitCase (st, a) -> st
forall st a. st -> ExitCase (st, a) -> st
stateToPutBack st
acquiredSt ExitCase (st, a)
exitCase))
      st -> m (st, a)
k

-- | Internal helper
stateToPutBack
  :: st  -- ^ Acquired state
  -> ExitCase (st, a)
     -- ^ Result of 'generalBracket', containing the modified state in case of
     -- success
  -> st
stateToPutBack :: st -> ExitCase (st, a) -> st
stateToPutBack st
acquiredSt = \case
    ExitCaseSuccess (st
modifiedSt, a
_a) -> st
modifiedSt
    ExitCaseException SomeException
_ex            -> st
acquiredSt
    ExitCase (st, a)
ExitCaseAbort                    -> st
acquiredSt

-- | Read the contents of the 'RAWLock' in an STM transaction.
--
-- Will retry when there is a writer.
--
-- In contrast to 'withReadAccess', this transaction will succeed when there
-- is a writer waiting to write, as there is no IO-operation during which the
-- lock must be held.
read :: IOLike m => RAWLock m st -> STM m st
read :: RAWLock m st -> STM m st
read (RAWLock StrictTVar m (RAWState st)
var) = StrictTVar m (RAWState st) -> STM m (RAWState st)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (RAWState st)
var STM m (RAWState st) -> (RAWState st -> STM m st) -> STM m st
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ReadAppend     Readers
_readers Appender
_appender st
st -> st -> STM m st
forall (m :: * -> *) a. Monad m => a -> m a
return st
st
    WaitingToWrite Readers
_readers Appender
_appender st
st -> st -> STM m st
forall (m :: * -> *) a. Monad m => a -> m a
return st
st
    RAWState st
Writing                              -> STM m st
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
    Poisoned       (AllowThunk SomeException
ex)       -> SomeException -> STM m st
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM SomeException
ex

-- | Poison the lock with the given exception. All subsequent access to the
-- lock will result in the given exception being thrown.
--
-- Unless the lock has already been poisoned, in which case the original
-- exception with which the lock was poisoned will be thrown.
poison
  :: (IOLike m, Exception e, HasCallStack)
  => RAWLock m st -> (CallStack -> e) -> m (Maybe st)
poison :: RAWLock m st -> (CallStack -> e) -> m (Maybe st)
poison (RAWLock StrictTVar m (RAWState st)
var) CallStack -> e
mkEx = STM m (Maybe st) -> m (Maybe st)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe st) -> m (Maybe st))
-> STM m (Maybe st) -> m (Maybe st)
forall a b. (a -> b) -> a -> b
$ do
    RAWState st
rawSt <- StrictTVar m (RAWState st) -> STM m (RAWState st)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (RAWState st)
var
    (RAWState st
rawSt', Maybe st
mbSt) <-
      Except SomeException (RAWState st, Maybe st)
-> STM m (RAWState st, Maybe st)
forall (m :: * -> *) a.
MonadThrow m =>
Except SomeException a -> m a
withPoisoned (SomeException
-> RAWState st -> Except SomeException (RAWState st, Maybe st)
forall st.
SomeException
-> RAWState st -> Except SomeException (RAWState st, Maybe st)
poisonPure (e -> SomeException
forall e. Exception e => e -> SomeException
toException (CallStack -> e
mkEx CallStack
HasCallStack => CallStack
callStack)) RAWState st
rawSt)
    StrictTVar m (RAWState st) -> RAWState st -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (RAWState st)
var RAWState st
rawSt'
    Maybe st -> STM m (Maybe st)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe st
mbSt

{-------------------------------------------------------------------------------
  Exposed internals: non-bracketed acquire & release
-------------------------------------------------------------------------------}

withPoisoned :: MonadThrow m => Except SomeException a -> m a
withPoisoned :: Except SomeException a -> m a
withPoisoned = (SomeException -> m a)
-> (a -> m a) -> Either SomeException a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException a -> m a)
-> (Except SomeException a -> Either SomeException a)
-> Except SomeException a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except SomeException a -> Either SomeException a
forall e a. Except e a -> Either e a
runExcept

-- | Acquire the 'RAWLock' as a reader.
--
-- Will block when there is a writer or when a writer is waiting to take the
-- lock.
--
-- Composable with other 'STM' transactions.
--
-- NOTE: __must__ be followed by a call to 'unsafeReleaseReadAccess'.
unsafeAcquireReadAccess :: IOLike m => RAWLock m st -> STM m st
unsafeAcquireReadAccess :: RAWLock m st -> STM m st
unsafeAcquireReadAccess (RAWLock StrictTVar m (RAWState st)
var) = do
    RAWState st
rawSt <- StrictTVar m (RAWState st) -> STM m (RAWState st)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (RAWState st)
var
    Except SomeException (Maybe (RAWState st, st))
-> STM m (Maybe (RAWState st, st))
forall (m :: * -> *) a.
MonadThrow m =>
Except SomeException a -> m a
withPoisoned (RAWState st -> Except SomeException (Maybe (RAWState st, st))
forall st.
RAWState st -> Except SomeException (Maybe (RAWState st, st))
acquireReadAccessPure RAWState st
rawSt) STM m (Maybe (RAWState st, st))
-> (Maybe (RAWState st, st) -> STM m st) -> STM m st
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (RAWState st, st)
Nothing           -> STM m st
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
      Just (RAWState st
rawSt', st
st) -> StrictTVar m (RAWState st) -> RAWState st -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (RAWState st)
var RAWState st
rawSt' STM m () -> st -> STM m st
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> st
st

-- | Release the 'RAWLock' as a reader.
--
-- Doesn't block.
--
-- Composable with other 'STM' transactions.
--
-- NOTE: __must__ be preceded by a call to 'unsafeAcquireReadAccess'.
unsafeReleaseReadAccess :: IOLike m => RAWLock m st -> STM m ()
unsafeReleaseReadAccess :: RAWLock m st -> STM m ()
unsafeReleaseReadAccess (RAWLock StrictTVar m (RAWState st)
var) = do
    RAWState st
rawSt <- StrictTVar m (RAWState st) -> STM m (RAWState st)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (RAWState st)
var
    Except SomeException (RAWState st) -> STM m (RAWState st)
forall (m :: * -> *) a.
MonadThrow m =>
Except SomeException a -> m a
withPoisoned (RAWState st -> Except SomeException (RAWState st)
forall st. RAWState st -> Except SomeException (RAWState st)
releaseReadAccessPure RAWState st
rawSt) STM m (RAWState st) -> (RAWState st -> STM m ()) -> STM m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StrictTVar m (RAWState st) -> RAWState st -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (RAWState st)
var

-- | Access the state stored in the 'RAWLock' as an appender.
--
-- Will block when there is another appender, a writer, or when a writer is
-- waiting to take the lock.
--
-- Composable with other 'STM' transactions.
--
-- NOTE: __must__ be followed by a call to 'unsafeReleaseAppendAccess'.
unsafeAcquireAppendAccess :: IOLike m => RAWLock m st -> STM m st
unsafeAcquireAppendAccess :: RAWLock m st -> STM m st
unsafeAcquireAppendAccess (RAWLock StrictTVar m (RAWState st)
var) = do
    RAWState st
rawSt <- StrictTVar m (RAWState st) -> STM m (RAWState st)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (RAWState st)
var
    Except SomeException (Maybe (RAWState st, st))
-> STM m (Maybe (RAWState st, st))
forall (m :: * -> *) a.
MonadThrow m =>
Except SomeException a -> m a
withPoisoned (RAWState st -> Except SomeException (Maybe (RAWState st, st))
forall st.
RAWState st -> Except SomeException (Maybe (RAWState st, st))
acquireAppendAccessPure RAWState st
rawSt) STM m (Maybe (RAWState st, st))
-> (Maybe (RAWState st, st) -> STM m st) -> STM m st
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (RAWState st, st)
Nothing           -> STM m st
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
      Just (RAWState st
rawSt', st
st) -> StrictTVar m (RAWState st) -> RAWState st -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (RAWState st)
var RAWState st
rawSt' STM m () -> st -> STM m st
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> st
st

-- | Release the 'RAWLock' as an appender.
--
-- Doesn't block.
--
-- Composable with other 'STM' transactions.
--
-- NOTE: __must__ be preceded by a call to 'unsafeAcquireAppendAccess'.
unsafeReleaseAppendAccess
  :: IOLike m
  => RAWLock m st
  -> st  -- ^ State to store in the lock
  -> STM m ()
unsafeReleaseAppendAccess :: RAWLock m st -> st -> STM m ()
unsafeReleaseAppendAccess (RAWLock StrictTVar m (RAWState st)
var) st
st = do
    RAWState st
rawSt <- StrictTVar m (RAWState st) -> STM m (RAWState st)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (RAWState st)
var
    Except SomeException (RAWState st) -> STM m (RAWState st)
forall (m :: * -> *) a.
MonadThrow m =>
Except SomeException a -> m a
withPoisoned (st -> RAWState st -> Except SomeException (RAWState st)
forall st. st -> RAWState st -> Except SomeException (RAWState st)
releaseAppendAccessPure st
st RAWState st
rawSt) STM m (RAWState st) -> (RAWState st -> STM m ()) -> STM m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StrictTVar m (RAWState st) -> RAWState st -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (RAWState st)
var

-- | Access the state stored in the 'RAWLock' as a writer.
--
-- Will block when there is another writer or while there are readers and\/or
-- an appender.
--
-- Does /not/ compose with other 'STM' transactions.
--
-- NOTE: __must__ be followed by a call to 'unsafeReleaseWriteAccess'.
unsafeAcquireWriteAccess :: IOLike m => RAWLock m st -> m st
unsafeAcquireWriteAccess :: RAWLock m st -> m st
unsafeAcquireWriteAccess rawLock :: RAWLock m st
rawLock@(RAWLock StrictTVar m (RAWState st)
var) = m (m st) -> m st
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m st) -> m st) -> m (m st) -> m st
forall a b. (a -> b) -> a -> b
$ STM m (m st) -> m (m st)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (m st) -> m (m st)) -> STM m (m st) -> m (m st)
forall a b. (a -> b) -> a -> b
$ do
    RAWState st
rawSt <- StrictTVar m (RAWState st) -> STM m (RAWState st)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (RAWState st)
var
    Except SomeException (Maybe (RAWState st, Maybe st))
-> STM m (Maybe (RAWState st, Maybe st))
forall (m :: * -> *) a.
MonadThrow m =>
Except SomeException a -> m a
withPoisoned (RAWState st -> Except SomeException (Maybe (RAWState st, Maybe st))
forall st.
RAWState st -> Except SomeException (Maybe (RAWState st, Maybe st))
acquireWriteAccessPure RAWState st
rawSt) STM m (Maybe (RAWState st, Maybe st))
-> (Maybe (RAWState st, Maybe st) -> STM m (m st)) -> STM m (m st)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (RAWState st, Maybe st)
Nothing             -> STM m (m st)
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
      Just (RAWState st
rawSt', Maybe st
mbSt) -> do
        StrictTVar m (RAWState st) -> RAWState st -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (RAWState st)
var RAWState st
rawSt'
        -- We must update the value in the var, but we may or may not have
        -- obtained the @st@ in it. We must commit the write either way.
        case Maybe st
mbSt of
          Just st
st -> m st -> STM m (m st)
forall (m :: * -> *) a. Monad m => a -> m a
return (m st -> STM m (m st)) -> m st -> STM m (m st)
forall a b. (a -> b) -> a -> b
$ st -> m st
forall (m :: * -> *) a. Monad m => a -> m a
return st
st
          -- Return a continuation that tries to acquire again
          Maybe st
Nothing -> m st -> STM m (m st)
forall (m :: * -> *) a. Monad m => a -> m a
return (m st -> STM m (m st)) -> m st -> STM m (m st)
forall a b. (a -> b) -> a -> b
$ RAWLock m st -> m st
forall (m :: * -> *) st. IOLike m => RAWLock m st -> m st
unsafeAcquireWriteAccess RAWLock m st
rawLock

-- | Release the 'RAWLock' as a writer.
--
-- Doesn't block.
--
-- Does /not/ compose with other 'STM' transactions.
--
-- NOTE: __must__ be preceded by a call to 'unsafeAcquireWriteAccess'.
unsafeReleaseWriteAccess
  :: IOLike m
  => RAWLock m st
  -> st  -- ^ State to store in the lock
  -> m ()
unsafeReleaseWriteAccess :: RAWLock m st -> st -> m ()
unsafeReleaseWriteAccess (RAWLock StrictTVar m (RAWState st)
var) st
st = STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    RAWState st
rawSt <- StrictTVar m (RAWState st) -> STM m (RAWState st)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (RAWState st)
var
    Except SomeException (RAWState st) -> STM m (RAWState st)
forall (m :: * -> *) a.
MonadThrow m =>
Except SomeException a -> m a
withPoisoned (st -> RAWState st -> Except SomeException (RAWState st)
forall st. st -> RAWState st -> Except SomeException (RAWState st)
releaseWriteAccessPure st
st RAWState st
rawSt) STM m (RAWState st) -> (RAWState st -> STM m ()) -> STM m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StrictTVar m (RAWState st) -> RAWState st -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (RAWState st)
var

{-------------------------------------------------------------------------------
  Pure internals
-------------------------------------------------------------------------------}

-- | Any non-negative number of readers
newtype Readers = Readers Word
  deriving newtype (Readers -> Readers -> Bool
(Readers -> Readers -> Bool)
-> (Readers -> Readers -> Bool) -> Eq Readers
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Readers -> Readers -> Bool
$c/= :: Readers -> Readers -> Bool
== :: Readers -> Readers -> Bool
$c== :: Readers -> Readers -> Bool
Eq, Eq Readers
Eq Readers
-> (Readers -> Readers -> Ordering)
-> (Readers -> Readers -> Bool)
-> (Readers -> Readers -> Bool)
-> (Readers -> Readers -> Bool)
-> (Readers -> Readers -> Bool)
-> (Readers -> Readers -> Readers)
-> (Readers -> Readers -> Readers)
-> Ord Readers
Readers -> Readers -> Bool
Readers -> Readers -> Ordering
Readers -> Readers -> Readers
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
min :: Readers -> Readers -> Readers
$cmin :: Readers -> Readers -> Readers
max :: Readers -> Readers -> Readers
$cmax :: Readers -> Readers -> Readers
>= :: Readers -> Readers -> Bool
$c>= :: Readers -> Readers -> Bool
> :: Readers -> Readers -> Bool
$c> :: Readers -> Readers -> Bool
<= :: Readers -> Readers -> Bool
$c<= :: Readers -> Readers -> Bool
< :: Readers -> Readers -> Bool
$c< :: Readers -> Readers -> Bool
compare :: Readers -> Readers -> Ordering
$ccompare :: Readers -> Readers -> Ordering
$cp1Ord :: Eq Readers
Ord, Int -> Readers
Readers -> Int
Readers -> [Readers]
Readers -> Readers
Readers -> Readers -> [Readers]
Readers -> Readers -> Readers -> [Readers]
(Readers -> Readers)
-> (Readers -> Readers)
-> (Int -> Readers)
-> (Readers -> Int)
-> (Readers -> [Readers])
-> (Readers -> Readers -> [Readers])
-> (Readers -> Readers -> [Readers])
-> (Readers -> Readers -> Readers -> [Readers])
-> Enum Readers
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Readers -> Readers -> Readers -> [Readers]
$cenumFromThenTo :: Readers -> Readers -> Readers -> [Readers]
enumFromTo :: Readers -> Readers -> [Readers]
$cenumFromTo :: Readers -> Readers -> [Readers]
enumFromThen :: Readers -> Readers -> [Readers]
$cenumFromThen :: Readers -> Readers -> [Readers]
enumFrom :: Readers -> [Readers]
$cenumFrom :: Readers -> [Readers]
fromEnum :: Readers -> Int
$cfromEnum :: Readers -> Int
toEnum :: Int -> Readers
$ctoEnum :: Int -> Readers
pred :: Readers -> Readers
$cpred :: Readers -> Readers
succ :: Readers -> Readers
$csucc :: Readers -> Readers
Enum, Integer -> Readers
Readers -> Readers
Readers -> Readers -> Readers
(Readers -> Readers -> Readers)
-> (Readers -> Readers -> Readers)
-> (Readers -> Readers -> Readers)
-> (Readers -> Readers)
-> (Readers -> Readers)
-> (Readers -> Readers)
-> (Integer -> Readers)
-> Num Readers
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Readers
$cfromInteger :: Integer -> Readers
signum :: Readers -> Readers
$csignum :: Readers -> Readers
abs :: Readers -> Readers
$cabs :: Readers -> Readers
negate :: Readers -> Readers
$cnegate :: Readers -> Readers
* :: Readers -> Readers -> Readers
$c* :: Readers -> Readers -> Readers
- :: Readers -> Readers -> Readers
$c- :: Readers -> Readers -> Readers
+ :: Readers -> Readers -> Readers
$c+ :: Readers -> Readers -> Readers
Num, Context -> Readers -> IO (Maybe ThunkInfo)
Proxy Readers -> String
(Context -> Readers -> IO (Maybe ThunkInfo))
-> (Context -> Readers -> IO (Maybe ThunkInfo))
-> (Proxy Readers -> String)
-> NoThunks Readers
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy Readers -> String
$cshowTypeOf :: Proxy Readers -> String
wNoThunks :: Context -> Readers -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Readers -> IO (Maybe ThunkInfo)
noThunks :: Context -> Readers -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> Readers -> IO (Maybe ThunkInfo)
NoThunks)

-- | At most one appender
data Appender = NoAppender | Appender
  deriving ((forall x. Appender -> Rep Appender x)
-> (forall x. Rep Appender x -> Appender) -> Generic Appender
forall x. Rep Appender x -> Appender
forall x. Appender -> Rep Appender x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Appender x -> Appender
$cfrom :: forall x. Appender -> Rep Appender x
Generic, Context -> Appender -> IO (Maybe ThunkInfo)
Proxy Appender -> String
(Context -> Appender -> IO (Maybe ThunkInfo))
-> (Context -> Appender -> IO (Maybe ThunkInfo))
-> (Proxy Appender -> String)
-> NoThunks Appender
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy Appender -> String
$cshowTypeOf :: Proxy Appender -> String
wNoThunks :: Context -> Appender -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Appender -> IO (Maybe ThunkInfo)
noThunks :: Context -> Appender -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> Appender -> IO (Maybe ThunkInfo)
NoThunks)

-- | The lock is implemented by a single 'StrictTVar', which stores a
-- 'RAWState'.
data RAWState st =
    -- | Reading and/or appending is happening.
    ReadAppend     !Readers !Appender !st

    -- | A writer (or more than one) has arrived. No new readers or a new
    -- appender are allowed, they can only release, not acquire.
    --
    -- When the number of readers is 0 and there is no more appender, a writer
    -- (multiple writers can race for this) will be able to get exclusive
    -- access and will change the state to 'Writing'.
  | WaitingToWrite !Readers !Appender !st

    -- | No (more) readers or appender, the writer has exclusive access.
  | Writing

    -- | The lock has been poisoned: all subsequent acquires or releases will
    -- throw the stored exception.
  | Poisoned       !(AllowThunk SomeException)
  deriving ((forall x. RAWState st -> Rep (RAWState st) x)
-> (forall x. Rep (RAWState st) x -> RAWState st)
-> Generic (RAWState st)
forall x. Rep (RAWState st) x -> RAWState st
forall x. RAWState st -> Rep (RAWState st) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall st x. Rep (RAWState st) x -> RAWState st
forall st x. RAWState st -> Rep (RAWState st) x
$cto :: forall st x. Rep (RAWState st) x -> RAWState st
$cfrom :: forall st x. RAWState st -> Rep (RAWState st) x
Generic, Context -> RAWState st -> IO (Maybe ThunkInfo)
Proxy (RAWState st) -> String
(Context -> RAWState st -> IO (Maybe ThunkInfo))
-> (Context -> RAWState st -> IO (Maybe ThunkInfo))
-> (Proxy (RAWState st) -> String)
-> NoThunks (RAWState st)
forall st.
NoThunks st =>
Context -> RAWState st -> IO (Maybe ThunkInfo)
forall st. NoThunks st => Proxy (RAWState st) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (RAWState st) -> String
$cshowTypeOf :: forall st. NoThunks st => Proxy (RAWState st) -> String
wNoThunks :: Context -> RAWState st -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall st.
NoThunks st =>
Context -> RAWState st -> IO (Maybe ThunkInfo)
noThunks :: Context -> RAWState st -> IO (Maybe ThunkInfo)
$cnoThunks :: forall st.
NoThunks st =>
Context -> RAWState st -> IO (Maybe ThunkInfo)
NoThunks)

-- | Create an initial, empty, unlocked 'RAWState': no readers, no appender,
-- no writer (waiting).
emptyRAWState :: st -> RAWState st
emptyRAWState :: st -> RAWState st
emptyRAWState = Readers -> Appender -> st -> RAWState st
forall st. Readers -> Appender -> st -> RAWState st
ReadAppend (Word -> Readers
Readers Word
0) Appender
NoAppender

{-------------------------------------------------------------------------------
  Pure internals: transitions between the 'RAWState's
-------------------------------------------------------------------------------}

acquireReadAccessPure
  :: RAWState st -> Except SomeException (Maybe (RAWState st, st))
acquireReadAccessPure :: RAWState st -> Except SomeException (Maybe (RAWState st, st))
acquireReadAccessPure = \case
    ReadAppend Readers
readers Appender
appender st
st
      -> Maybe (RAWState st, st)
-> Except SomeException (Maybe (RAWState st, st))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (RAWState st, st)
 -> Except SomeException (Maybe (RAWState st, st)))
-> Maybe (RAWState st, st)
-> Except SomeException (Maybe (RAWState st, st))
forall a b. (a -> b) -> a -> b
$ (RAWState st, st) -> Maybe (RAWState st, st)
forall a. a -> Maybe a
Just (Readers -> Appender -> st -> RAWState st
forall st. Readers -> Appender -> st -> RAWState st
ReadAppend (Readers -> Readers
forall a. Enum a => a -> a
succ Readers
readers) Appender
appender st
st, st
st)
    WaitingToWrite {}
      -> Maybe (RAWState st, st)
-> Except SomeException (Maybe (RAWState st, st))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RAWState st, st)
forall a. Maybe a
Nothing
    RAWState st
Writing
      -> Maybe (RAWState st, st)
-> Except SomeException (Maybe (RAWState st, st))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RAWState st, st)
forall a. Maybe a
Nothing
    Poisoned (AllowThunk SomeException
ex)
      -> SomeException -> Except SomeException (Maybe (RAWState st, st))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SomeException
ex

releaseReadAccessPure
  :: RAWState st -> Except SomeException (RAWState st)
releaseReadAccessPure :: RAWState st -> Except SomeException (RAWState st)
releaseReadAccessPure = \case
    ReadAppend Readers
readers Appender
appender st
st
      | Readers
0 <- Readers
readers
      -> String -> Except SomeException (RAWState st)
forall a. HasCallStack => String -> a
error String
"releasing a reader without outstanding readers in ReadAppend"
      | Bool
otherwise
      -> RAWState st -> Except SomeException (RAWState st)
forall (m :: * -> *) a. Monad m => a -> m a
return (RAWState st -> Except SomeException (RAWState st))
-> RAWState st -> Except SomeException (RAWState st)
forall a b. (a -> b) -> a -> b
$ Readers -> Appender -> st -> RAWState st
forall st. Readers -> Appender -> st -> RAWState st
ReadAppend (Readers -> Readers
forall a. Enum a => a -> a
pred Readers
readers) Appender
appender st
st
    WaitingToWrite Readers
readers Appender
appender st
st
      | Readers
0 <- Readers
readers
      -> String -> Except SomeException (RAWState st)
forall a. HasCallStack => String -> a
error String
"releasing a reader without outstanding readers in WaitingToWrite"
      | Bool
otherwise
      -> RAWState st -> Except SomeException (RAWState st)
forall (m :: * -> *) a. Monad m => a -> m a
return (RAWState st -> Except SomeException (RAWState st))
-> RAWState st -> Except SomeException (RAWState st)
forall a b. (a -> b) -> a -> b
$ Readers -> Appender -> st -> RAWState st
forall st. Readers -> Appender -> st -> RAWState st
WaitingToWrite (Readers -> Readers
forall a. Enum a => a -> a
pred Readers
readers) Appender
appender st
st
    RAWState st
Writing
      -> String -> Except SomeException (RAWState st)
forall a. HasCallStack => String -> a
error String
"releasing a reader without outstanding readers in Writing"
    Poisoned (AllowThunk SomeException
ex)
      -> SomeException -> Except SomeException (RAWState st)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SomeException
ex

acquireAppendAccessPure
  :: RAWState st -> Except SomeException (Maybe (RAWState st, st))
acquireAppendAccessPure :: RAWState st -> Except SomeException (Maybe (RAWState st, st))
acquireAppendAccessPure = \case
    ReadAppend Readers
readers Appender
appender st
st
      | Appender
NoAppender <- Appender
appender
      -> Maybe (RAWState st, st)
-> Except SomeException (Maybe (RAWState st, st))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (RAWState st, st)
 -> Except SomeException (Maybe (RAWState st, st)))
-> Maybe (RAWState st, st)
-> Except SomeException (Maybe (RAWState st, st))
forall a b. (a -> b) -> a -> b
$ (RAWState st, st) -> Maybe (RAWState st, st)
forall a. a -> Maybe a
Just (Readers -> Appender -> st -> RAWState st
forall st. Readers -> Appender -> st -> RAWState st
ReadAppend Readers
readers Appender
Appender st
st, st
st)
      | Bool
otherwise
      -> Maybe (RAWState st, st)
-> Except SomeException (Maybe (RAWState st, st))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RAWState st, st)
forall a. Maybe a
Nothing
    WaitingToWrite {}
      -> Maybe (RAWState st, st)
-> Except SomeException (Maybe (RAWState st, st))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RAWState st, st)
forall a. Maybe a
Nothing
    RAWState st
Writing
      -> Maybe (RAWState st, st)
-> Except SomeException (Maybe (RAWState st, st))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RAWState st, st)
forall a. Maybe a
Nothing
    Poisoned (AllowThunk SomeException
ex)
      -> SomeException -> Except SomeException (Maybe (RAWState st, st))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SomeException
ex

releaseAppendAccessPure
  :: st -> RAWState st -> Except SomeException (RAWState st)
releaseAppendAccessPure :: st -> RAWState st -> Except SomeException (RAWState st)
releaseAppendAccessPure st
st' = \case
    ReadAppend Readers
readers Appender
appender st
_st
      | Appender
NoAppender <- Appender
appender
      -> String -> Except SomeException (RAWState st)
forall a. HasCallStack => String -> a
error String
"releasing an appender without an outstanding appender in ReadAppend"
      | Bool
otherwise
      -> RAWState st -> Except SomeException (RAWState st)
forall (m :: * -> *) a. Monad m => a -> m a
return (RAWState st -> Except SomeException (RAWState st))
-> RAWState st -> Except SomeException (RAWState st)
forall a b. (a -> b) -> a -> b
$ Readers -> Appender -> st -> RAWState st
forall st. Readers -> Appender -> st -> RAWState st
ReadAppend Readers
readers Appender
NoAppender st
st'
    WaitingToWrite Readers
readers Appender
appender st
_st
      | Appender
NoAppender <- Appender
appender
      -> String -> Except SomeException (RAWState st)
forall a. HasCallStack => String -> a
error String
"releasing an appender without an outstanding appender in WaitingToWrite"
      | Bool
otherwise
      -> RAWState st -> Except SomeException (RAWState st)
forall (m :: * -> *) a. Monad m => a -> m a
return (RAWState st -> Except SomeException (RAWState st))
-> RAWState st -> Except SomeException (RAWState st)
forall a b. (a -> b) -> a -> b
$ Readers -> Appender -> st -> RAWState st
forall st. Readers -> Appender -> st -> RAWState st
WaitingToWrite Readers
readers Appender
NoAppender st
st'
    RAWState st
Writing
      -> String -> Except SomeException (RAWState st)
forall a. HasCallStack => String -> a
error String
"releasing an appender without an outstanding appender in Writing"
    Poisoned (AllowThunk SomeException
ex)
      -> SomeException -> Except SomeException (RAWState st)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SomeException
ex

acquireWriteAccessPure
  :: RAWState st -> Except SomeException (Maybe (RAWState st, Maybe st))
acquireWriteAccessPure :: RAWState st -> Except SomeException (Maybe (RAWState st, Maybe st))
acquireWriteAccessPure = \case
    -- When there are no readers or appender in the 'ReadAppend' we can
    -- directly go to the 'Writing' state, if not, we'll go to the
    -- intermediary 'WaitingToWrite' state until they have all released.
    ReadAppend Readers
readers Appender
appender st
st
      | Readers
0 <- Readers
readers
      , Appender
NoAppender <- Appender
appender
      -> Maybe (RAWState st, Maybe st)
-> Except SomeException (Maybe (RAWState st, Maybe st))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (RAWState st, Maybe st)
 -> Except SomeException (Maybe (RAWState st, Maybe st)))
-> Maybe (RAWState st, Maybe st)
-> Except SomeException (Maybe (RAWState st, Maybe st))
forall a b. (a -> b) -> a -> b
$ (RAWState st, Maybe st) -> Maybe (RAWState st, Maybe st)
forall a. a -> Maybe a
Just (RAWState st
forall st. RAWState st
Writing, st -> Maybe st
forall a. a -> Maybe a
Just st
st)
      | Bool
otherwise
      -> Maybe (RAWState st, Maybe st)
-> Except SomeException (Maybe (RAWState st, Maybe st))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (RAWState st, Maybe st)
 -> Except SomeException (Maybe (RAWState st, Maybe st)))
-> Maybe (RAWState st, Maybe st)
-> Except SomeException (Maybe (RAWState st, Maybe st))
forall a b. (a -> b) -> a -> b
$ (RAWState st, Maybe st) -> Maybe (RAWState st, Maybe st)
forall a. a -> Maybe a
Just (Readers -> Appender -> st -> RAWState st
forall st. Readers -> Appender -> st -> RAWState st
WaitingToWrite Readers
readers Appender
appender st
st, Maybe st
forall a. Maybe a
Nothing)
    WaitingToWrite Readers
readers Appender
appender st
st
      | Readers
0 <- Readers
readers
      , Appender
NoAppender <- Appender
appender
      -> Maybe (RAWState st, Maybe st)
-> Except SomeException (Maybe (RAWState st, Maybe st))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (RAWState st, Maybe st)
 -> Except SomeException (Maybe (RAWState st, Maybe st)))
-> Maybe (RAWState st, Maybe st)
-> Except SomeException (Maybe (RAWState st, Maybe st))
forall a b. (a -> b) -> a -> b
$ (RAWState st, Maybe st) -> Maybe (RAWState st, Maybe st)
forall a. a -> Maybe a
Just (RAWState st
forall st. RAWState st
Writing, st -> Maybe st
forall a. a -> Maybe a
Just st
st)
      | Bool
otherwise
      -> Maybe (RAWState st, Maybe st)
-> Except SomeException (Maybe (RAWState st, Maybe st))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RAWState st, Maybe st)
forall a. Maybe a
Nothing
    RAWState st
Writing
      -> Maybe (RAWState st, Maybe st)
-> Except SomeException (Maybe (RAWState st, Maybe st))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RAWState st, Maybe st)
forall a. Maybe a
Nothing
    Poisoned (AllowThunk SomeException
ex)
      -> SomeException
-> Except SomeException (Maybe (RAWState st, Maybe st))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SomeException
ex

releaseWriteAccessPure
  :: st -> RAWState st -> Except SomeException (RAWState st)
releaseWriteAccessPure :: st -> RAWState st -> Except SomeException (RAWState st)
releaseWriteAccessPure st
st' = \case
    ReadAppend Readers
_readers Appender
_appender st
_st
      -> String -> Except SomeException (RAWState st)
forall a. HasCallStack => String -> a
error String
"releasing a writer in ReadAppend"
    WaitingToWrite Readers
_readers Appender
_appender st
_st
      -> String -> Except SomeException (RAWState st)
forall a. HasCallStack => String -> a
error String
"releasing a writer in WaitingToWrite"
    RAWState st
Writing
      -> RAWState st -> Except SomeException (RAWState st)
forall (m :: * -> *) a. Monad m => a -> m a
return (RAWState st -> Except SomeException (RAWState st))
-> RAWState st -> Except SomeException (RAWState st)
forall a b. (a -> b) -> a -> b
$ st -> RAWState st
forall st. st -> RAWState st
emptyRAWState st
st'
    Poisoned (AllowThunk SomeException
ex)
      -> SomeException -> Except SomeException (RAWState st)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SomeException
ex

poisonPure
  :: SomeException -> RAWState st -> Except SomeException (RAWState st, Maybe st)
poisonPure :: SomeException
-> RAWState st -> Except SomeException (RAWState st, Maybe st)
poisonPure SomeException
ex = \case
    ReadAppend Readers
_readers Appender
_appender st
st
      -> (RAWState st, Maybe st)
-> Except SomeException (RAWState st, Maybe st)
forall (m :: * -> *) a. Monad m => a -> m a
return (AllowThunk SomeException -> RAWState st
forall st. AllowThunk SomeException -> RAWState st
Poisoned (SomeException -> AllowThunk SomeException
forall a. a -> AllowThunk a
AllowThunk SomeException
ex), st -> Maybe st
forall a. a -> Maybe a
Just st
st)
    WaitingToWrite Readers
_readers Appender
_appender st
st
      -> (RAWState st, Maybe st)
-> Except SomeException (RAWState st, Maybe st)
forall (m :: * -> *) a. Monad m => a -> m a
return (AllowThunk SomeException -> RAWState st
forall st. AllowThunk SomeException -> RAWState st
Poisoned (SomeException -> AllowThunk SomeException
forall a. a -> AllowThunk a
AllowThunk SomeException
ex), st -> Maybe st
forall a. a -> Maybe a
Just st
st)
    RAWState st
Writing
      -> (RAWState st, Maybe st)
-> Except SomeException (RAWState st, Maybe st)
forall (m :: * -> *) a. Monad m => a -> m a
return (AllowThunk SomeException -> RAWState st
forall st. AllowThunk SomeException -> RAWState st
Poisoned (SomeException -> AllowThunk SomeException
forall a. a -> AllowThunk a
AllowThunk SomeException
ex), Maybe st
forall a. Maybe a
Nothing)
    Poisoned (AllowThunk SomeException
prevEx)
      -> SomeException -> Except SomeException (RAWState st, Maybe st)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SomeException
prevEx