{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

-- | 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. Once the lock is released, all waiting
--    actors will race for the access.
--
--  * The state @st@ is always evaluated to WHNF and is subject to the
--    'NoThunks' check when enabled.
--
--  * All public functions are exception-safe.
module Control.RAWLock (
    -- * API
    RAWLock
  , new
  , poison
  , read
  , withAppendAccess
  , withReadAccess
  , withWriteAccess
    -- * Unsafe API
    -- $unsafe-api
  , unsafeAcquireAppendAccess
  , unsafeAcquireReadAccess
  , unsafeAcquireWriteAccess
  , unsafeReleaseAppendAccess
  , unsafeReleaseReadAccess
  , unsafeReleaseWriteAccess
  ) where

import Control.Concurrent.Class.MonadMVar.Strict
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad.Class.MonadThrow
import GHC.Generics
import GHC.Stack (CallStack, HasCallStack, callStack)
import NoThunks.Class
import Prelude hiding (read)

-- | 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
$c== :: Readers -> Readers -> Bool
== :: Readers -> Readers -> Bool
$c/= :: Readers -> Readers -> Bool
/= :: 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
$ccompare :: Readers -> Readers -> Ordering
compare :: Readers -> Readers -> Ordering
$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
>= :: Readers -> Readers -> Bool
$cmax :: Readers -> Readers -> Readers
max :: Readers -> Readers -> Readers
$cmin :: Readers -> Readers -> Readers
min :: Readers -> Readers -> 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
$csucc :: Readers -> Readers
succ :: Readers -> Readers
$cpred :: Readers -> Readers
pred :: Readers -> Readers
$ctoEnum :: Int -> Readers
toEnum :: Int -> Readers
$cfromEnum :: Readers -> Int
fromEnum :: Readers -> Int
$cenumFrom :: Readers -> [Readers]
enumFrom :: Readers -> [Readers]
$cenumFromThen :: Readers -> Readers -> [Readers]
enumFromThen :: Readers -> Readers -> [Readers]
$cenumFromTo :: Readers -> Readers -> [Readers]
enumFromTo :: Readers -> Readers -> [Readers]
$cenumFromThenTo :: Readers -> Readers -> Readers -> [Readers]
enumFromThenTo :: Readers -> Readers -> 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
$c+ :: Readers -> Readers -> Readers
+ :: Readers -> Readers -> Readers
$c- :: Readers -> Readers -> Readers
- :: Readers -> Readers -> Readers
$c* :: Readers -> Readers -> Readers
* :: Readers -> Readers -> Readers
$cnegate :: Readers -> Readers
negate :: Readers -> Readers
$cabs :: Readers -> Readers
abs :: Readers -> Readers
$csignum :: Readers -> Readers
signum :: Readers -> Readers
$cfromInteger :: Integer -> Readers
fromInteger :: Integer -> 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
$cnoThunks :: Context -> Readers -> IO (Maybe ThunkInfo)
noThunks :: Context -> Readers -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Readers -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Readers -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Readers -> String
showTypeOf :: Proxy Readers -> String
NoThunks)
  deriving stock (Int -> Readers -> ShowS
[Readers] -> ShowS
Readers -> String
(Int -> Readers -> ShowS)
-> (Readers -> String) -> ([Readers] -> ShowS) -> Show Readers
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Readers -> ShowS
showsPrec :: Int -> Readers -> ShowS
$cshow :: Readers -> String
show :: Readers -> String
$cshowList :: [Readers] -> ShowS
showList :: [Readers] -> ShowS
Show)

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

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

data RAWState = RAWState {
    RAWState -> Readers
waitingReaders   :: !Readers
  , RAWState -> Appenders
waitingAppenders :: !Appenders
  , RAWState -> Writers
waitingWriters   :: !Writers
  } deriving Int -> RAWState -> ShowS
[RAWState] -> ShowS
RAWState -> String
(Int -> RAWState -> ShowS)
-> (RAWState -> String) -> ([RAWState] -> ShowS) -> Show RAWState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RAWState -> ShowS
showsPrec :: Int -> RAWState -> ShowS
$cshow :: RAWState -> String
show :: RAWState -> String
$cshowList :: [RAWState] -> ShowS
showList :: [RAWState] -> ShowS
Show

noWriters :: Poisonable RAWState -> Bool
noWriters :: Poisonable RAWState -> Bool
noWriters (Healthy (RAWState Readers
_ Appenders
_ Writers
w)) = Writers
w Writers -> Writers -> Bool
forall a. Eq a => a -> a -> Bool
== Writers
0
noWriters Poisonable RAWState
_                          = Bool
True

onlyWriters :: Poisonable RAWState -> Bool
onlyWriters :: Poisonable RAWState -> Bool
onlyWriters (Healthy (RAWState Readers
r Appenders
a Writers
_)) = Readers
r Readers -> Readers -> Bool
forall a. Eq a => a -> a -> Bool
== Readers
0 Bool -> Bool -> Bool
&& Appenders
a Appenders -> Appenders -> Bool
forall a. Eq a => a -> a -> Bool
== Appenders
0
onlyWriters Poisonable RAWState
_                          = Bool
True

pushReader :: Poisonable RAWState -> Poisonable RAWState
pushReader :: Poisonable RAWState -> Poisonable RAWState
pushReader = (RAWState -> RAWState)
-> Poisonable RAWState -> Poisonable RAWState
forall a b. (a -> b) -> Poisonable a -> Poisonable b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(RAWState Readers
r Appenders
a Writers
w) -> Readers -> Appenders -> Writers -> RAWState
RAWState (Readers
r Readers -> Readers -> Readers
forall a. Num a => a -> a -> a
+ Readers
1) Appenders
a Writers
w)

pushAppender :: Poisonable RAWState -> Poisonable RAWState
pushAppender :: Poisonable RAWState -> Poisonable RAWState
pushAppender = (RAWState -> RAWState)
-> Poisonable RAWState -> Poisonable RAWState
forall a b. (a -> b) -> Poisonable a -> Poisonable b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(RAWState Readers
r Appenders
a Writers
w) -> Readers -> Appenders -> Writers -> RAWState
RAWState Readers
r (Appenders
a Appenders -> Appenders -> Appenders
forall a. Num a => a -> a -> a
+ Appenders
1) Writers
w)

pushWriter :: Poisonable RAWState -> Poisonable RAWState
pushWriter :: Poisonable RAWState -> Poisonable RAWState
pushWriter = (RAWState -> RAWState)
-> Poisonable RAWState -> Poisonable RAWState
forall a b. (a -> b) -> Poisonable a -> Poisonable b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(RAWState Readers
r Appenders
a Writers
w) -> Readers -> Appenders -> Writers -> RAWState
RAWState Readers
r Appenders
a (Writers
w Writers -> Writers -> Writers
forall a. Num a => a -> a -> a
+ Writers
1))

popReader :: Poisonable RAWState -> Poisonable RAWState
popReader :: Poisonable RAWState -> Poisonable RAWState
popReader = (RAWState -> RAWState)
-> Poisonable RAWState -> Poisonable RAWState
forall a b. (a -> b) -> Poisonable a -> Poisonable b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(RAWState Readers
r Appenders
a Writers
w) -> Readers -> Appenders -> Writers -> RAWState
RAWState (Readers
r Readers -> Readers -> Readers
forall a. Num a => a -> a -> a
- Readers
1) Appenders
a Writers
w)

popAppender :: Poisonable RAWState -> Poisonable RAWState
popAppender :: Poisonable RAWState -> Poisonable RAWState
popAppender = (RAWState -> RAWState)
-> Poisonable RAWState -> Poisonable RAWState
forall a b. (a -> b) -> Poisonable a -> Poisonable b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(RAWState Readers
r Appenders
a Writers
w) -> Readers -> Appenders -> Writers -> RAWState
RAWState Readers
r (Appenders
a Appenders -> Appenders -> Appenders
forall a. Num a => a -> a -> a
- Appenders
1) Writers
w)

popWriter :: Poisonable RAWState -> Poisonable RAWState
popWriter :: Poisonable RAWState -> Poisonable RAWState
popWriter = (RAWState -> RAWState)
-> Poisonable RAWState -> Poisonable RAWState
forall a b. (a -> b) -> Poisonable a -> Poisonable b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(RAWState Readers
r Appenders
a Writers
w) -> Readers -> Appenders -> Writers -> RAWState
RAWState Readers
r Appenders
a (Writers
w Writers -> Writers -> Writers
forall a. Num a => a -> a -> a
- Writers
1))

-- | Data that can be replaced with an exception that should be thrown when
-- found.
data Poisonable st =
    Healthy !st
  | Poisoned !(AllowThunk SomeException)
  deriving ((forall x. Poisonable st -> Rep (Poisonable st) x)
-> (forall x. Rep (Poisonable st) x -> Poisonable st)
-> Generic (Poisonable st)
forall x. Rep (Poisonable st) x -> Poisonable st
forall x. Poisonable st -> Rep (Poisonable st) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall st x. Rep (Poisonable st) x -> Poisonable st
forall st x. Poisonable st -> Rep (Poisonable st) x
$cfrom :: forall st x. Poisonable st -> Rep (Poisonable st) x
from :: forall x. Poisonable st -> Rep (Poisonable st) x
$cto :: forall st x. Rep (Poisonable st) x -> Poisonable st
to :: forall x. Rep (Poisonable st) x -> Poisonable st
Generic, Context -> Poisonable st -> IO (Maybe ThunkInfo)
Proxy (Poisonable st) -> String
(Context -> Poisonable st -> IO (Maybe ThunkInfo))
-> (Context -> Poisonable st -> IO (Maybe ThunkInfo))
-> (Proxy (Poisonable st) -> String)
-> NoThunks (Poisonable st)
forall st.
NoThunks st =>
Context -> Poisonable st -> IO (Maybe ThunkInfo)
forall st. NoThunks st => Proxy (Poisonable st) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall st.
NoThunks st =>
Context -> Poisonable st -> IO (Maybe ThunkInfo)
noThunks :: Context -> Poisonable st -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall st.
NoThunks st =>
Context -> Poisonable st -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Poisonable st -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall st. NoThunks st => Proxy (Poisonable st) -> String
showTypeOf :: Proxy (Poisonable st) -> String
NoThunks, (forall a b. (a -> b) -> Poisonable a -> Poisonable b)
-> (forall a b. a -> Poisonable b -> Poisonable a)
-> Functor Poisonable
forall a b. a -> Poisonable b -> Poisonable a
forall a b. (a -> b) -> Poisonable a -> Poisonable b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Poisonable a -> Poisonable b
fmap :: forall a b. (a -> b) -> Poisonable a -> Poisonable b
$c<$ :: forall a b. a -> Poisonable b -> Poisonable a
<$ :: forall a b. a -> Poisonable b -> Poisonable a
Functor)

data RAWLock m st = RAWLock {
    forall (m :: * -> *) st.
RAWLock m st -> StrictTMVar m (Poisonable st)
resource :: !(StrictTMVar m (Poisonable st))
  , forall (m :: * -> *) st. RAWLock m st -> StrictMVar m ()
appender :: !(StrictMVar m ())
  , forall (m :: * -> *) st.
RAWLock m st -> StrictTVar m (Poisonable RAWState)
queues   :: !(StrictTVar m (Poisonable RAWState))
  } deriving ((forall x. RAWLock m st -> Rep (RAWLock m st) x)
-> (forall x. Rep (RAWLock m st) x -> RAWLock m st)
-> Generic (RAWLock m st)
forall x. Rep (RAWLock m st) x -> RAWLock m st
forall x. RAWLock m st -> Rep (RAWLock m st) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) st x. Rep (RAWLock m st) x -> RAWLock m st
forall (m :: * -> *) st x. RAWLock m st -> Rep (RAWLock m st) x
$cfrom :: forall (m :: * -> *) st x. RAWLock m st -> Rep (RAWLock m st) x
from :: forall x. RAWLock m st -> Rep (RAWLock m st) x
$cto :: forall (m :: * -> *) st x. Rep (RAWLock m st) x -> RAWLock m st
to :: forall x. Rep (RAWLock m st) x -> RAWLock m st
Generic)

deriving instance ( NoThunks (StrictTMVar m (Poisonable st))
                  , NoThunks (StrictMVar m ())
                  , NoThunks (StrictTVar m (Poisonable RAWState))
                  ) => NoThunks (RAWLock m st)

new ::
     ( MonadMVar m
     , MonadLabelledSTM m
     )
  => st
  -> m (RAWLock m st)
new :: forall (m :: * -> *) st.
(MonadMVar m, MonadLabelledSTM m) =>
st -> m (RAWLock m st)
new !st
st = do
  StrictTMVar m (Poisonable st)
s <- Poisonable st -> m (StrictTMVar m (Poisonable st))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTMVar m a)
newTMVarIO (st -> Poisonable st
forall st. st -> Poisonable st
Healthy st
st)
  STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
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
$ StrictTMVar m (Poisonable st) -> String -> STM m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
StrictTMVar m a -> String -> STM m ()
labelTMVar StrictTMVar m (Poisonable st)
s String
"state"
  StrictMVar m ()
a <- () -> m (StrictMVar m ())
forall (m :: * -> *) a. MonadMVar m => a -> m (StrictMVar m a)
newMVar ()
  StrictTVar m (Poisonable RAWState)
q <- Poisonable RAWState -> m (StrictTVar m (Poisonable RAWState))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO (RAWState -> Poisonable RAWState
forall st. st -> Poisonable st
Healthy RAWState
emptyRAWState)
  STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
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
$ StrictTVar m (Poisonable RAWState) -> String -> STM m ()
forall (m :: * -> *) a.
MonadLabelledSTM m =>
StrictTVar m a -> String -> STM m ()
labelTVar StrictTVar m (Poisonable RAWState)
q String
"queues"
  RAWLock m st -> m (RAWLock m st)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RAWLock m st -> m (RAWLock m st))
-> RAWLock m st -> m (RAWLock m st)
forall a b. (a -> b) -> a -> b
$ StrictTMVar m (Poisonable st)
-> StrictMVar m ()
-> StrictTVar m (Poisonable RAWState)
-> RAWLock m st
forall (m :: * -> *) st.
StrictTMVar m (Poisonable st)
-> StrictMVar m ()
-> StrictTVar m (Poisonable RAWState)
-> RAWLock m st
RAWLock StrictTMVar m (Poisonable st)
s StrictMVar m ()
a StrictTVar m (Poisonable RAWState)
q

read :: (MonadSTM m, MonadThrow (STM m)) => RAWLock m st -> STM m st
read :: forall (m :: * -> *) st.
(MonadSTM m, MonadThrow (STM m)) =>
RAWLock m st -> STM m st
read (RAWLock StrictTMVar m (Poisonable st)
var StrictMVar m ()
_ StrictTVar m (Poisonable RAWState)
_) = StrictTMVar m (Poisonable st) -> STM m (Poisonable st)
forall (m :: * -> *) a. MonadSTM m => StrictTMVar m a -> STM m a
readTMVar StrictTMVar m (Poisonable st)
var STM m (Poisonable st) -> (Poisonable st -> STM m st) -> STM m st
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Poisonable st -> STM m st
forall (m :: * -> *) st. MonadThrow m => Poisonable st -> m st
throwPoisoned

-- | When a lock is poisoned all subsequent access to it is overridden by the
-- poison. This means that the current actor that holds the lock will free it,
-- and any other concurrent actors will be able to release their access,
-- possibly rising the poison exception in the process.
--
-- There is no need (although it is harmless) to release again the current
-- actor once it has poisoned the lock.
poison ::
     (Exception e, MonadMVar m, MonadSTM m, MonadThrow (STM m), HasCallStack)
  => RAWLock m st
  -> (CallStack -> e)
  -> m (Maybe st)
poison :: forall e (m :: * -> *) st.
(Exception e, MonadMVar m, MonadSTM m, MonadThrow (STM m),
 HasCallStack) =>
RAWLock m st -> (CallStack -> e) -> m (Maybe st)
poison (RAWLock StrictTMVar m (Poisonable st)
var StrictMVar m ()
apm StrictTVar m (Poisonable RAWState)
q) CallStack -> e
mkExc = do
  Maybe st
st <- STM m (Maybe st) -> m (Maybe st)
forall a. HasCallStack => STM m a -> m a
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
$
    StrictTMVar m (Poisonable st) -> STM m (Maybe (Poisonable st))
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> STM m (Maybe a)
tryReadTMVar StrictTMVar m (Poisonable st)
var STM m (Maybe (Poisonable st))
-> (Maybe (Poisonable st) -> STM m (Maybe st)) -> STM m (Maybe st)
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- Keep original exception
      Just (Poisoned (AllowThunk SomeException
exc)) -> SomeException -> STM m (Maybe st)
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
exc
      Just (Healthy st
st) -> do
        StrictTMVar m (Poisonable st) -> Poisonable st -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m ()
writeTMVar StrictTMVar m (Poisonable st)
var (AllowThunk SomeException -> Poisonable st
forall st. AllowThunk SomeException -> Poisonable st
Poisoned (SomeException -> AllowThunk SomeException
forall a. a -> AllowThunk a
AllowThunk (e -> SomeException
forall e. Exception e => e -> SomeException
toException (CallStack -> e
mkExc CallStack
HasCallStack => CallStack
callStack))))
        StrictTVar m (Poisonable RAWState)
-> Poisonable RAWState -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Poisonable RAWState)
q (AllowThunk SomeException -> Poisonable RAWState
forall st. AllowThunk SomeException -> Poisonable st
Poisoned (SomeException -> AllowThunk SomeException
forall a. a -> AllowThunk a
AllowThunk (e -> SomeException
forall e. Exception e => e -> SomeException
toException (CallStack -> e
mkExc CallStack
HasCallStack => CallStack
callStack))))
        Maybe st -> STM m (Maybe st)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (st -> Maybe st
forall a. a -> Maybe a
Just st
st)
      Maybe (Poisonable st)
Nothing -> do
        StrictTMVar m (Poisonable st) -> Poisonable st -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m ()
writeTMVar StrictTMVar m (Poisonable st)
var (AllowThunk SomeException -> Poisonable st
forall st. AllowThunk SomeException -> Poisonable st
Poisoned (SomeException -> AllowThunk SomeException
forall a. a -> AllowThunk a
AllowThunk (e -> SomeException
forall e. Exception e => e -> SomeException
toException (CallStack -> e
mkExc CallStack
HasCallStack => CallStack
callStack))))
        StrictTVar m (Poisonable RAWState)
-> Poisonable RAWState -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Poisonable RAWState)
q (AllowThunk SomeException -> Poisonable RAWState
forall st. AllowThunk SomeException -> Poisonable st
Poisoned (SomeException -> AllowThunk SomeException
forall a. a -> AllowThunk a
AllowThunk (e -> SomeException
forall e. Exception e => e -> SomeException
toException (CallStack -> e
mkExc CallStack
HasCallStack => CallStack
callStack))))
        Maybe st -> STM m (Maybe st)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe st
forall a. Maybe a
Nothing
  Bool
_ <- StrictMVar m () -> () -> m Bool
forall (m :: * -> *) a.
MonadMVar m =>
StrictMVar m a -> a -> m Bool
tryPutMVar StrictMVar m ()
apm ()
  Maybe st -> m (Maybe st)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe st
st

-- | Create an initial, empty, unlocked 'RAWState': no readers, no appender,
-- no writer (waiting).
emptyRAWState :: RAWState
emptyRAWState :: RAWState
emptyRAWState = Readers -> Appenders -> Writers -> RAWState
RAWState Readers
0 Appenders
0 Writers
0

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

-- | Acquire the 'RAWLock' as a writer.
--
-- Will block when there is another writer, readers or appenders.
withWriteAccess ::
     (MonadSTM m, MonadCatch m, MonadThrow (STM m))
  => RAWLock m st
  -> (st -> m (a, st))
  -> m a
withWriteAccess :: forall (m :: * -> *) st a.
(MonadSTM m, MonadCatch m, MonadThrow (STM m)) =>
RAWLock m st -> (st -> m (a, st)) -> m a
withWriteAccess RAWLock m st
lock st -> m (a, st)
f =
  (a, st) -> a
forall a b. (a, b) -> a
fst ((a, st) -> a) -> (((a, st), ()) -> (a, st)) -> ((a, st), ()) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, st), ()) -> (a, st)
forall a b. (a, b) -> a
fst (((a, st), ()) -> a) -> m ((a, st), ()) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m st
-> (st -> ExitCase (a, st) -> m ())
-> (st -> m (a, st))
-> m ((a, st), ())
forall a b c.
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
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.
(MonadThrow (STM m), MonadCatch m, MonadSTM m) =>
RAWLock m st -> m st
unsafeAcquireWriteAccess RAWLock m st
lock)
   (\st
orig -> \case
       ExitCaseSuccess (a
_, st
st) -> RAWLock m st -> st -> m ()
forall (m :: * -> *) st.
(MonadThrow (STM m), MonadSTM m) =>
RAWLock m st -> st -> m ()
unsafeReleaseWriteAccess RAWLock m st
lock st
st
       ExitCase (a, st)
_ -> RAWLock m st -> st -> m ()
forall (m :: * -> *) st.
(MonadThrow (STM m), MonadSTM m) =>
RAWLock m st -> st -> m ()
unsafeReleaseWriteAccess RAWLock m st
lock st
orig
   )
   st -> m (a, st)
f

-- | Acquire the 'RAWLock' as an appender.
--
-- Will block when there is a writer or when there is another appender.
withAppendAccess ::
     (MonadThrow (STM m), MonadSTM m, MonadCatch m, MonadMVar m)
  => RAWLock m st
  -> (st -> m (a, st))
  -> m a
withAppendAccess :: forall (m :: * -> *) st a.
(MonadThrow (STM m), MonadSTM m, MonadCatch m, MonadMVar m) =>
RAWLock m st -> (st -> m (a, st)) -> m a
withAppendAccess RAWLock m st
lock st -> m (a, st)
f = do
  (a, st) -> a
forall a b. (a, b) -> a
fst ((a, st) -> a) -> (((a, st), ()) -> (a, st)) -> ((a, st), ()) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, st), ()) -> (a, st)
forall a b. (a, b) -> a
fst (((a, st), ()) -> a) -> m ((a, st), ()) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m st
-> (st -> ExitCase (a, st) -> m ())
-> (st -> m (a, st))
-> m ((a, st), ())
forall a b c.
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
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.
(MonadThrow (STM m), MonadCatch m, MonadMVar m, MonadSTM m) =>
RAWLock m st -> m st
unsafeAcquireAppendAccess RAWLock m st
lock)
   (\st
orig -> \case
       ExitCaseSuccess (a
_, st
st) -> RAWLock m st -> st -> m ()
forall (m :: * -> *) st.
(MonadThrow (STM m), MonadMVar m, MonadSTM m) =>
RAWLock m st -> st -> m ()
unsafeReleaseAppendAccess RAWLock m st
lock st
st
       ExitCase (a, st)
_ -> RAWLock m st -> st -> m ()
forall (m :: * -> *) st.
(MonadThrow (STM m), MonadMVar m, MonadSTM m) =>
RAWLock m st -> st -> m ()
unsafeReleaseAppendAccess RAWLock m st
lock st
orig
   )
   st -> m (a, st)
f

{-------------------------------------------------------------------------------
  Unsafe API
-------------------------------------------------------------------------------}

throwPoisoned :: MonadThrow m => Poisonable st -> m st
throwPoisoned :: forall (m :: * -> *) st. MonadThrow m => Poisonable st -> m st
throwPoisoned (Healthy st
st)                = st -> m st
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure st
st
throwPoisoned (Poisoned (AllowThunk SomeException
exc)) = SomeException -> m st
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
exc

-- $unsafe-api
--
-- These functions are unsafe in the sense that they do not guard against
-- exceptions, meaning that if you don't take care and ensure exception safety,
-- you might make the RAWLock unusable.
--
-- To be safe, you should ensure that every @unsafeAcquireXAccess@ is paired with
-- @unsafeReleaseXAccess@, __even in the presence of exceptions__.
--
-- Note that for writing and appending, you should restore the original value in
-- presence of an exception!

unsafeAcquireReadAccess ::
     (MonadThrow (STM m), MonadSTM m)
  => RAWLock m st
  -> STM m st
unsafeAcquireReadAccess :: forall (m :: * -> *) st.
(MonadThrow (STM m), MonadSTM m) =>
RAWLock m st -> STM m st
unsafeAcquireReadAccess (RAWLock StrictTMVar m (Poisonable st)
var StrictMVar m ()
_ StrictTVar m (Poisonable RAWState)
qs) = do
  -- wait until there are no writers
  StrictTVar m (Poisonable RAWState) -> STM m (Poisonable RAWState)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Poisonable RAWState)
qs STM m (Poisonable RAWState)
-> (Poisonable RAWState -> STM m ()) -> STM m ()
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (Bool -> STM m ())
-> (Poisonable RAWState -> Bool) -> Poisonable RAWState -> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Poisonable RAWState -> Bool
noWriters
  -- queue myself
  StrictTVar m (Poisonable RAWState)
-> (Poisonable RAWState -> Poisonable RAWState) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Poisonable RAWState)
qs Poisonable RAWState -> Poisonable RAWState
pushReader
  -- read the state
  Poisonable st -> STM m st
forall (m :: * -> *) st. MonadThrow m => Poisonable st -> m st
throwPoisoned (Poisonable st -> STM m st) -> STM m (Poisonable st) -> STM m st
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StrictTMVar m (Poisonable st) -> STM m (Poisonable st)
forall (m :: * -> *) a. MonadSTM m => StrictTMVar m a -> STM m a
readTMVar StrictTMVar m (Poisonable st)
var

unsafeReleaseReadAccess :: MonadSTM m => RAWLock m st -> STM m ()
unsafeReleaseReadAccess :: forall (m :: * -> *) st. MonadSTM m => RAWLock m st -> STM m ()
unsafeReleaseReadAccess (RAWLock StrictTMVar m (Poisonable st)
_ StrictMVar m ()
_ StrictTVar m (Poisonable RAWState)
qs) =
  -- unqueue myself
  StrictTVar m (Poisonable RAWState)
-> (Poisonable RAWState -> Poisonable RAWState) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Poisonable RAWState)
qs Poisonable RAWState -> Poisonable RAWState
popReader

unsafeAcquireWriteAccess ::
     (MonadThrow (STM m), MonadCatch m, MonadSTM m)
  => RAWLock m st
  -> m st
unsafeAcquireWriteAccess :: forall (m :: * -> *) st.
(MonadThrow (STM m), MonadCatch m, MonadSTM m) =>
RAWLock m st -> m st
unsafeAcquireWriteAccess (RAWLock StrictTMVar m (Poisonable st)
var StrictMVar m ()
_ StrictTVar m (Poisonable RAWState)
qs) = do
  -- queue myself if there are no other writers
  STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
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
    -- wait until there are no writers
    StrictTVar m (Poisonable RAWState) -> STM m (Poisonable RAWState)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Poisonable RAWState)
qs STM m (Poisonable RAWState)
-> (Poisonable RAWState -> STM m ()) -> STM m ()
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (Bool -> STM m ())
-> (Poisonable RAWState -> Bool) -> Poisonable RAWState -> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Poisonable RAWState -> Bool
noWriters
    -- queue myself
    StrictTVar m (Poisonable RAWState)
-> (Poisonable RAWState -> Poisonable RAWState) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Poisonable RAWState)
qs Poisonable RAWState -> Poisonable RAWState
pushWriter
  STM m st -> m st
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (do
    -- wait until there are no readers (and as I queued myself above, I'm the
    -- only waiting writer)
    StrictTVar m (Poisonable RAWState) -> STM m (Poisonable RAWState)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Poisonable RAWState)
qs STM m (Poisonable RAWState)
-> (Poisonable RAWState -> STM m ()) -> STM m ()
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (Bool -> STM m ())
-> (Poisonable RAWState -> Bool) -> Poisonable RAWState -> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Poisonable RAWState -> Bool
onlyWriters
    -- acquire the state
    Poisonable st -> STM m st
forall (m :: * -> *) st. MonadThrow m => Poisonable st -> m st
throwPoisoned (Poisonable st -> STM m st) -> STM m (Poisonable st) -> STM m st
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StrictTMVar m (Poisonable st) -> STM m (Poisonable st)
forall (m :: * -> *) a. MonadSTM m => StrictTMVar m a -> STM m a
takeTMVar StrictTMVar m (Poisonable st)
var) m st -> m () -> m st
forall a b. m a -> m b -> m a
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m (Poisonable RAWState)
-> (Poisonable RAWState -> Poisonable RAWState) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Poisonable RAWState)
qs Poisonable RAWState -> Poisonable RAWState
popWriter)

unsafeReleaseWriteAccess ::
     (MonadThrow (STM m), MonadSTM m)
  => RAWLock m st
  -> st
  -> m ()
unsafeReleaseWriteAccess :: forall (m :: * -> *) st.
(MonadThrow (STM m), MonadSTM m) =>
RAWLock m st -> st -> m ()
unsafeReleaseWriteAccess (RAWLock StrictTMVar m (Poisonable st)
var StrictMVar m ()
_ StrictTVar m (Poisonable RAWState)
qs) !st
st =
  STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
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
    -- write the new state
    StrictTMVar m (Poisonable st) -> STM m (Maybe (Poisonable st))
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> STM m (Maybe a)
tryReadTMVar StrictTMVar m (Poisonable st)
var STM m (Maybe (Poisonable st))
-> (Maybe (Poisonable st) -> STM m ()) -> STM m ()
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (Poisonable st)
Nothing -> StrictTMVar m (Poisonable st) -> Poisonable st -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m ()
putTMVar StrictTMVar m (Poisonable st)
var (st -> Poisonable st
forall st. st -> Poisonable st
Healthy st
st)
      Just (Poisoned (AllowThunk SomeException
exc)) -> SomeException -> STM m ()
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
exc
      Just Healthy{} -> String -> STM m ()
forall a. HasCallStack => String -> a
error String
"Double put"
    -- unqueue myself
    StrictTVar m (Poisonable RAWState)
-> (Poisonable RAWState -> Poisonable RAWState) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Poisonable RAWState)
qs Poisonable RAWState -> Poisonable RAWState
popWriter

unsafeAcquireAppendAccess ::
     (MonadThrow (STM m), MonadCatch m, MonadMVar m, MonadSTM m)
  => RAWLock m st
  -> m st
unsafeAcquireAppendAccess :: forall (m :: * -> *) st.
(MonadThrow (STM m), MonadCatch m, MonadMVar m, MonadSTM m) =>
RAWLock m st -> m st
unsafeAcquireAppendAccess (RAWLock StrictTMVar m (Poisonable st)
var StrictMVar m ()
apm StrictTVar m (Poisonable RAWState)
qs) = do
  STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
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
    -- wait until there are no writers
    StrictTVar m (Poisonable RAWState) -> STM m (Poisonable RAWState)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Poisonable RAWState)
qs STM m (Poisonable RAWState)
-> (Poisonable RAWState -> STM m ()) -> STM m ()
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (Bool -> STM m ())
-> (Poisonable RAWState -> Bool) -> Poisonable RAWState -> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Poisonable RAWState -> Bool
noWriters
    -- queue myself
    StrictTVar m (Poisonable RAWState)
-> (Poisonable RAWState -> Poisonable RAWState) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Poisonable RAWState)
qs Poisonable RAWState -> Poisonable RAWState
pushAppender
  (do
      -- lock the append access
      StrictMVar m () -> m ()
forall (m :: * -> *) a. MonadMVar m => StrictMVar m a -> m a
takeMVar StrictMVar m ()
apm
      -- acquire the state
      STM m st -> m st
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTMVar m (Poisonable st) -> STM m (Poisonable st)
forall (m :: * -> *) a. MonadSTM m => StrictTMVar m a -> STM m a
readTMVar StrictTMVar m (Poisonable st)
var STM m (Poisonable st) -> (Poisonable st -> STM m st) -> STM m st
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Poisonable st -> STM m st
forall (m :: * -> *) st. MonadThrow m => Poisonable st -> m st
throwPoisoned) m st -> m () -> m st
forall a b. m a -> m b -> m a
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` StrictMVar m () -> () -> m ()
forall (m :: * -> *) a. MonadMVar m => StrictMVar m a -> a -> m ()
putMVar StrictMVar m ()
apm ()
    ) m st -> m () -> m st
forall a b. m a -> m b -> m a
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m (Poisonable RAWState)
-> (Poisonable RAWState -> Poisonable RAWState) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Poisonable RAWState)
qs Poisonable RAWState -> Poisonable RAWState
popAppender)

unsafeReleaseAppendAccess ::
     (MonadThrow (STM m), MonadMVar m, MonadSTM m)
  => RAWLock m st
  -> st
  -> m ()
unsafeReleaseAppendAccess :: forall (m :: * -> *) st.
(MonadThrow (STM m), MonadMVar m, MonadSTM m) =>
RAWLock m st -> st -> m ()
unsafeReleaseAppendAccess (RAWLock StrictTMVar m (Poisonable st)
var StrictMVar m ()
apm StrictTVar m (Poisonable RAWState)
qs) !st
st = do
  STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
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
    -- write the new state
    StrictTMVar m (Poisonable st) -> STM m (Maybe (Poisonable st))
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> STM m (Maybe a)
tryReadTMVar StrictTMVar m (Poisonable st)
var STM m (Maybe (Poisonable st))
-> (Maybe (Poisonable st) -> STM m ()) -> STM m ()
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just (Poisoned (AllowThunk SomeException
exc)) -> SomeException -> STM m ()
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
exc
      Maybe (Poisonable st)
_ -> StrictTMVar m (Poisonable st) -> Poisonable st -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m ()
writeTMVar StrictTMVar m (Poisonable st)
var (st -> Poisonable st
forall st. st -> Poisonable st
Healthy st
st)
    -- unqueue myself
    StrictTVar m (Poisonable RAWState)
-> (Poisonable RAWState -> Poisonable RAWState) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Poisonable RAWState)
qs Poisonable RAWState -> Poisonable RAWState
popAppender
  -- release the append access
  StrictMVar m () -> () -> m ()
forall (m :: * -> *) a. MonadMVar m => StrictMVar m a -> a -> m ()
putMVar StrictMVar m ()
apm ()