module Sq.Transactional
( Transactional
, embed
, transactionalRetry
, foldM
, Ref
, Retry (..)
, retry
, orElse
) where
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM hiding (orElse, retry)
import Control.Exception.Safe qualified as Ex
import Control.Foldl qualified as F
import Control.Monad hiding (foldM)
import Control.Monad.Catch qualified as Cx
import Control.Monad.IO.Class
import Control.Monad.Ref hiding (Ref)
import Control.Monad.Ref qualified
import Control.Monad.Trans.Reader (ReaderT (ReaderT))
import Control.Monad.Trans.Resource qualified as R
import Control.Monad.Trans.Resource.Extra qualified as R hiding (runResourceT)
import Data.Acquire qualified as A
import Data.Coerce
import Data.IntMap.Strict (IntMap)
import Data.IntMap.Strict qualified as IntMap
import Data.Kind
import Sq.Connection
import Sq.Mode
import Sq.Statement
import Sq.Support
data Retry = NoRetry | Retry
deriving (Retry -> Retry -> Bool
(Retry -> Retry -> Bool) -> (Retry -> Retry -> Bool) -> Eq Retry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Retry -> Retry -> Bool
== :: Retry -> Retry -> Bool
$c/= :: Retry -> Retry -> Bool
/= :: Retry -> Retry -> Bool
Eq, Eq Retry
Eq Retry =>
(Retry -> Retry -> Ordering)
-> (Retry -> Retry -> Bool)
-> (Retry -> Retry -> Bool)
-> (Retry -> Retry -> Bool)
-> (Retry -> Retry -> Bool)
-> (Retry -> Retry -> Retry)
-> (Retry -> Retry -> Retry)
-> Ord Retry
Retry -> Retry -> Bool
Retry -> Retry -> Ordering
Retry -> Retry -> Retry
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 :: Retry -> Retry -> Ordering
compare :: Retry -> Retry -> Ordering
$c< :: Retry -> Retry -> Bool
< :: Retry -> Retry -> Bool
$c<= :: Retry -> Retry -> Bool
<= :: Retry -> Retry -> Bool
$c> :: Retry -> Retry -> Bool
> :: Retry -> Retry -> Bool
$c>= :: Retry -> Retry -> Bool
>= :: Retry -> Retry -> Bool
$cmax :: Retry -> Retry -> Retry
max :: Retry -> Retry -> Retry
$cmin :: Retry -> Retry -> Retry
min :: Retry -> Retry -> Retry
Ord, Int -> Retry -> ShowS
[Retry] -> ShowS
Retry -> String
(Int -> Retry -> ShowS)
-> (Retry -> String) -> ([Retry] -> ShowS) -> Show Retry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Retry -> ShowS
showsPrec :: Int -> Retry -> ShowS
$cshow :: Retry -> String
show :: Retry -> String
$cshowList :: [Retry] -> ShowS
showList :: [Retry] -> ShowS
Show)
data Env (g :: k) (r :: Retry) (t :: Mode) = Env
{ forall k (g :: k) (r :: Retry) (t :: Mode). Env g r t -> STM Int
unique :: STM Int
, forall k (g :: k) (r :: Retry) (t :: Mode).
Env g r t -> TVar (IntMap (SomeRef g))
refs :: TVar (IntMap (SomeRef g))
, forall k (g :: k) (r :: Retry) (t :: Mode).
Env g r t -> Transaction t
tx :: Transaction t
}
acquireEnv :: Transaction t -> A.Acquire (Env g r t)
acquireEnv :: forall {k} (t :: Mode) (g :: k) (r :: Retry).
Transaction t -> Acquire (Env g r t)
acquireEnv Transaction t
tx = do
STM Int
unique :: STM Int <- IO (STM Int) -> Acquire (STM Int)
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
TVar Int
tv <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0
STM Int -> IO (STM Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (STM Int -> IO (STM Int)) -> STM Int -> IO (STM Int)
forall a b. (a -> b) -> a -> b
$ Ref STM Int -> (Int -> (Int, Int)) -> STM Int
forall a b. Ref STM a -> (a -> (a, b)) -> STM b
forall (m :: * -> *) a b.
MonadAtomicRef m =>
Ref m a -> (a -> (a, b)) -> m b
atomicModifyRef' TVar Int
Ref STM Int
tv \Int
i -> (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
i)
TVar (IntMap (SomeRef g))
refs :: TVar (IntMap (SomeRef g)) <-
IO (TVar (IntMap (SomeRef g)))
-> (TVar (IntMap (SomeRef g)) -> IO ())
-> Acquire (TVar (IntMap (SomeRef g)))
forall a. IO a -> (a -> IO ()) -> Acquire a
R.mkAcquire1 (IntMap (SomeRef g) -> IO (TVar (IntMap (SomeRef g)))
forall a. a -> IO (TVar a)
newTVarIO IntMap (SomeRef g)
forall a. Monoid a => a
mempty) \TVar (IntMap (SomeRef g))
tvsrs ->
STM () -> IO ()
forall a. STM a -> IO a
atomically do
IntMap (SomeRef g)
srs <- TVar (IntMap (SomeRef g))
-> IntMap (SomeRef g) -> STM (IntMap (SomeRef g))
forall a. TVar a -> a -> STM a
swapTVar TVar (IntMap (SomeRef g))
tvsrs IntMap (SomeRef g)
forall a. Monoid a => a
mempty
IntMap (SomeRef g) -> (SomeRef g -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ IntMap (SomeRef g)
srs \(SomeRef (Ref TVar (Maybe a)
tv)) ->
TVar (Maybe a) -> Maybe a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe a)
tv Maybe a
forall a. Maybe a
Nothing
Env g r t -> Acquire (Env g r t)
forall a. a -> Acquire a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env{TVar (IntMap (SomeRef g))
STM Int
Transaction t
unique :: STM Int
refs :: TVar (IntMap (SomeRef g))
tx :: Transaction t
tx :: Transaction t
unique :: STM Int
refs :: TVar (IntMap (SomeRef g))
..}
newtype Transactional (g :: k) (r :: Retry) (t :: Mode) (a :: Type)
= Transactional (Env g r t -> R.ResourceT IO a)
deriving
( (forall a b.
(a -> b) -> Transactional g r t a -> Transactional g r t b)
-> (forall a b.
a -> Transactional g r t b -> Transactional g r t a)
-> Functor (Transactional g r t)
forall k (g :: k) (r :: Retry) (t :: Mode) a b.
a -> Transactional g r t b -> Transactional g r t a
forall k (g :: k) (r :: Retry) (t :: Mode) a b.
(a -> b) -> Transactional g r t a -> Transactional g r t b
forall a b. a -> Transactional g r t b -> Transactional g r t a
forall a b.
(a -> b) -> Transactional g r t a -> Transactional g r t b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall k (g :: k) (r :: Retry) (t :: Mode) a b.
(a -> b) -> Transactional g r t a -> Transactional g r t b
fmap :: forall a b.
(a -> b) -> Transactional g r t a -> Transactional g r t b
$c<$ :: forall k (g :: k) (r :: Retry) (t :: Mode) a b.
a -> Transactional g r t b -> Transactional g r t a
<$ :: forall a b. a -> Transactional g r t b -> Transactional g r t a
Functor
, Functor (Transactional g r t)
Functor (Transactional g r t) =>
(forall a. a -> Transactional g r t a)
-> (forall a b.
Transactional g r t (a -> b)
-> Transactional g r t a -> Transactional g r t b)
-> (forall a b c.
(a -> b -> c)
-> Transactional g r t a
-> Transactional g r t b
-> Transactional g r t c)
-> (forall a b.
Transactional g r t a
-> Transactional g r t b -> Transactional g r t b)
-> (forall a b.
Transactional g r t a
-> Transactional g r t b -> Transactional g r t a)
-> Applicative (Transactional g r t)
forall a. a -> Transactional g r t a
forall k (g :: k) (r :: Retry) (t :: Mode).
Functor (Transactional g r t)
forall k (g :: k) (r :: Retry) (t :: Mode) a.
a -> Transactional g r t a
forall k (g :: k) (r :: Retry) (t :: Mode) a b.
Transactional g r t a
-> Transactional g r t b -> Transactional g r t a
forall k (g :: k) (r :: Retry) (t :: Mode) a b.
Transactional g r t a
-> Transactional g r t b -> Transactional g r t b
forall k (g :: k) (r :: Retry) (t :: Mode) a b.
Transactional g r t (a -> b)
-> Transactional g r t a -> Transactional g r t b
forall k (g :: k) (r :: Retry) (t :: Mode) a b c.
(a -> b -> c)
-> Transactional g r t a
-> Transactional g r t b
-> Transactional g r t c
forall a b.
Transactional g r t a
-> Transactional g r t b -> Transactional g r t a
forall a b.
Transactional g r t a
-> Transactional g r t b -> Transactional g r t b
forall a b.
Transactional g r t (a -> b)
-> Transactional g r t a -> Transactional g r t b
forall a b c.
(a -> b -> c)
-> Transactional g r t a
-> Transactional g r t b
-> Transactional g r t c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall k (g :: k) (r :: Retry) (t :: Mode) a.
a -> Transactional g r t a
pure :: forall a. a -> Transactional g r t a
$c<*> :: forall k (g :: k) (r :: Retry) (t :: Mode) a b.
Transactional g r t (a -> b)
-> Transactional g r t a -> Transactional g r t b
<*> :: forall a b.
Transactional g r t (a -> b)
-> Transactional g r t a -> Transactional g r t b
$cliftA2 :: forall k (g :: k) (r :: Retry) (t :: Mode) a b c.
(a -> b -> c)
-> Transactional g r t a
-> Transactional g r t b
-> Transactional g r t c
liftA2 :: forall a b c.
(a -> b -> c)
-> Transactional g r t a
-> Transactional g r t b
-> Transactional g r t c
$c*> :: forall k (g :: k) (r :: Retry) (t :: Mode) a b.
Transactional g r t a
-> Transactional g r t b -> Transactional g r t b
*> :: forall a b.
Transactional g r t a
-> Transactional g r t b -> Transactional g r t b
$c<* :: forall k (g :: k) (r :: Retry) (t :: Mode) a b.
Transactional g r t a
-> Transactional g r t b -> Transactional g r t a
<* :: forall a b.
Transactional g r t a
-> Transactional g r t b -> Transactional g r t a
Applicative
, Applicative (Transactional g r t)
Applicative (Transactional g r t) =>
(forall a b.
Transactional g r t a
-> (a -> Transactional g r t b) -> Transactional g r t b)
-> (forall a b.
Transactional g r t a
-> Transactional g r t b -> Transactional g r t b)
-> (forall a. a -> Transactional g r t a)
-> Monad (Transactional g r t)
forall a. a -> Transactional g r t a
forall k (g :: k) (r :: Retry) (t :: Mode).
Applicative (Transactional g r t)
forall k (g :: k) (r :: Retry) (t :: Mode) a.
a -> Transactional g r t a
forall k (g :: k) (r :: Retry) (t :: Mode) a b.
Transactional g r t a
-> Transactional g r t b -> Transactional g r t b
forall k (g :: k) (r :: Retry) (t :: Mode) a b.
Transactional g r t a
-> (a -> Transactional g r t b) -> Transactional g r t b
forall a b.
Transactional g r t a
-> Transactional g r t b -> Transactional g r t b
forall a b.
Transactional g r t a
-> (a -> Transactional g r t b) -> Transactional g r t b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall k (g :: k) (r :: Retry) (t :: Mode) a b.
Transactional g r t a
-> (a -> Transactional g r t b) -> Transactional g r t b
>>= :: forall a b.
Transactional g r t a
-> (a -> Transactional g r t b) -> Transactional g r t b
$c>> :: forall k (g :: k) (r :: Retry) (t :: Mode) a b.
Transactional g r t a
-> Transactional g r t b -> Transactional g r t b
>> :: forall a b.
Transactional g r t a
-> Transactional g r t b -> Transactional g r t b
$creturn :: forall k (g :: k) (r :: Retry) (t :: Mode) a.
a -> Transactional g r t a
return :: forall a. a -> Transactional g r t a
Monad
, Monad (Transactional g r t)
Monad (Transactional g r t) =>
(forall e a.
(HasCallStack, Exception e) =>
e -> Transactional g r t a)
-> MonadThrow (Transactional g r t)
forall k (g :: k) (r :: Retry) (t :: Mode).
Monad (Transactional g r t)
forall k (g :: k) (r :: Retry) (t :: Mode) e a.
(HasCallStack, Exception e) =>
e -> Transactional g r t a
forall e a.
(HasCallStack, Exception e) =>
e -> Transactional g r t a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall k (g :: k) (r :: Retry) (t :: Mode) e a.
(HasCallStack, Exception e) =>
e -> Transactional g r t a
throwM :: forall e a.
(HasCallStack, Exception e) =>
e -> Transactional g r t a
Cx.MonadThrow
, MonadCatch (Transactional g r t)
MonadCatch (Transactional g r t) =>
(forall b.
HasCallStack =>
((forall a. Transactional g r t a -> Transactional g r t a)
-> Transactional g r t b)
-> Transactional g r t b)
-> (forall b.
HasCallStack =>
((forall a. Transactional g r t a -> Transactional g r t a)
-> Transactional g r t b)
-> Transactional g r t b)
-> (forall a b c.
HasCallStack =>
Transactional g r t a
-> (a -> ExitCase b -> Transactional g r t c)
-> (a -> Transactional g r t b)
-> Transactional g r t (b, c))
-> MonadMask (Transactional g r t)
forall b.
HasCallStack =>
((forall a. Transactional g r t a -> Transactional g r t a)
-> Transactional g r t b)
-> Transactional g r t b
forall k (g :: k) (r :: Retry) (t :: Mode).
MonadCatch (Transactional g r t)
forall k (g :: k) (r :: Retry) (t :: Mode) b.
HasCallStack =>
((forall a. Transactional g r t a -> Transactional g r t a)
-> Transactional g r t b)
-> Transactional g r t b
forall k (g :: k) (r :: Retry) (t :: Mode) a b c.
HasCallStack =>
Transactional g r t a
-> (a -> ExitCase b -> Transactional g r t c)
-> (a -> Transactional g r t b)
-> Transactional g r t (b, c)
forall a b c.
HasCallStack =>
Transactional g r t a
-> (a -> ExitCase b -> Transactional g r t c)
-> (a -> Transactional g r t b)
-> Transactional g r t (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
HasCallStack =>
((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
HasCallStack =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall k (g :: k) (r :: Retry) (t :: Mode) b.
HasCallStack =>
((forall a. Transactional g r t a -> Transactional g r t a)
-> Transactional g r t b)
-> Transactional g r t b
mask :: forall b.
HasCallStack =>
((forall a. Transactional g r t a -> Transactional g r t a)
-> Transactional g r t b)
-> Transactional g r t b
$cuninterruptibleMask :: forall k (g :: k) (r :: Retry) (t :: Mode) b.
HasCallStack =>
((forall a. Transactional g r t a -> Transactional g r t a)
-> Transactional g r t b)
-> Transactional g r t b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. Transactional g r t a -> Transactional g r t a)
-> Transactional g r t b)
-> Transactional g r t b
$cgeneralBracket :: forall k (g :: k) (r :: Retry) (t :: Mode) a b c.
HasCallStack =>
Transactional g r t a
-> (a -> ExitCase b -> Transactional g r t c)
-> (a -> Transactional g r t b)
-> Transactional g r t (b, c)
generalBracket :: forall a b c.
HasCallStack =>
Transactional g r t a
-> (a -> ExitCase b -> Transactional g r t c)
-> (a -> Transactional g r t b)
-> Transactional g r t (b, c)
Cx.MonadMask
, Monad (Transactional g r t)
Monad (Transactional g r t) =>
(forall a. String -> Transactional g r t a)
-> MonadFail (Transactional g r t)
forall a. String -> Transactional g r t a
forall k (g :: k) (r :: Retry) (t :: Mode).
Monad (Transactional g r t)
forall k (g :: k) (r :: Retry) (t :: Mode) a.
String -> Transactional g r t a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall k (g :: k) (r :: Retry) (t :: Mode) a.
String -> Transactional g r t a
fail :: forall a. String -> Transactional g r t a
MonadFail
)
via (ReaderT (Env g r t) (R.ResourceT IO))
un :: Transactional g r t a -> Env g r t -> R.ResourceT IO a
un :: forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
Transactional g r t a -> Env g r t -> ResourceT IO a
un = Transactional g r t a -> Env g r t -> ResourceT IO a
forall a b. Coercible a b => a -> b
coerce
{-# INLINE un #-}
mk :: (Env g r t -> R.ResourceT IO a) -> Transactional g r t a
mk :: forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
(Env g r t -> ResourceT IO a) -> Transactional g r t a
mk = (Env g r t -> ResourceT IO a) -> Transactional g r t a
forall a b. Coercible a b => a -> b
coerce
{-# INLINE mk #-}
transactionalRetry
:: forall m r t a
. (MonadIO m)
=> A.Acquire (Transaction t)
-> (forall g. Transactional g r t a)
-> m a
transactionalRetry :: forall {k} (m :: * -> *) (r :: Retry) (t :: Mode) a.
MonadIO m =>
Acquire (Transaction t)
-> (forall (g :: k). Transactional g r t a) -> m a
transactionalRetry Acquire (Transaction t)
atx forall (g :: k). Transactional g r t a
ta = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Word -> IO a
go Word
0)
where
go :: Word -> IO a
go :: Word -> IO a
go !Word
n = IO a -> (ErrRetry -> IO a) -> IO a
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Ex.catch IO a
once \ErrRetry
ErrRetry -> do
let ms :: Double
ms = Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
2 (Word -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Word -> Word
forall a. Ord a => a -> a -> a
max Word
1 Word
n) :: Double)
Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Double
1_000 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ms)
Word -> IO a
go (Word
n Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1)
once :: IO a
once :: IO a
once = ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
R.runResourceT do
(ReleaseKey
_, Env Any r t
env) <- Acquire (Env Any r t) -> ResourceT IO (ReleaseKey, Env Any r t)
forall (m :: * -> *) a.
MonadResource m =>
Acquire a -> m (ReleaseKey, a)
A.allocateAcquire (Acquire (Env Any r t) -> ResourceT IO (ReleaseKey, Env Any r t))
-> Acquire (Env Any r t) -> ResourceT IO (ReleaseKey, Env Any r t)
forall a b. (a -> b) -> a -> b
$ Transaction t -> Acquire (Env Any r t)
forall {k} (t :: Mode) (g :: k) (r :: Retry).
Transaction t -> Acquire (Env g r t)
acquireEnv (Transaction t -> Acquire (Env Any r t))
-> Acquire (Transaction t) -> Acquire (Env Any r t)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Acquire (Transaction t)
atx
Transactional Any r t a -> Env Any r t -> ResourceT IO a
forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
Transactional g r t a -> Env g r t -> ResourceT IO a
un Transactional Any r t a
forall (g :: k). Transactional g r t a
ta Env Any r t
env
embed
:: forall m t a
. (MonadIO m)
=> Transaction t
-> (forall g. Transactional g 'NoRetry t a)
-> m a
embed :: forall {k} (m :: * -> *) (t :: Mode) a.
MonadIO m =>
Transaction t
-> (forall (g :: k). Transactional g 'NoRetry t a) -> m a
embed Transaction t
tx forall (g :: k). Transactional g 'NoRetry t a
ta =
IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
R.runResourceT do
(ReleaseKey
_, Env Any 'NoRetry t
env) <- Acquire (Env Any 'NoRetry t)
-> ResourceT IO (ReleaseKey, Env Any 'NoRetry t)
forall (m :: * -> *) a.
MonadResource m =>
Acquire a -> m (ReleaseKey, a)
A.allocateAcquire (Acquire (Env Any 'NoRetry t)
-> ResourceT IO (ReleaseKey, Env Any 'NoRetry t))
-> Acquire (Env Any 'NoRetry t)
-> ResourceT IO (ReleaseKey, Env Any 'NoRetry t)
forall a b. (a -> b) -> a -> b
$ Transaction t -> Acquire (Env Any 'NoRetry t)
forall {k} (t :: Mode) (g :: k) (r :: Retry).
Transaction t -> Acquire (Env g r t)
acquireEnv Transaction t
tx
Transactional Any 'NoRetry t a
-> Env Any 'NoRetry t -> ResourceT IO a
forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
Transactional g r t a -> Env g r t -> ResourceT IO a
un Transactional Any 'NoRetry t a
forall (g :: k). Transactional g 'NoRetry t a
ta Env Any 'NoRetry t
env
foldM
:: (SubMode t s)
=> F.FoldM (Transactional g r t) o z
-> Statement s i o
-> i
-> Transactional g r t z
foldM :: forall {k} (t :: Mode) (s :: Mode) (g :: k) (r :: Retry) o z i.
SubMode t s =>
FoldM (Transactional g r t) o z
-> Statement s i o -> i -> Transactional g r t z
foldM FoldM (Transactional g r t) o z
f Statement s i o
st i
i = (Env g r t -> ResourceT IO z) -> Transactional g r t z
forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
(Env g r t -> ResourceT IO a) -> Transactional g r t a
mk \Env g r t
env ->
FoldM (ResourceT IO) o z
-> Acquire (Transaction t)
-> Statement s i o
-> i
-> ResourceT IO z
forall (m :: * -> *) (t :: Mode) (s :: Mode) o z i.
(MonadIO m, MonadMask m, SubMode t s) =>
FoldM m o z
-> Acquire (Transaction t) -> Statement s i o -> i -> m z
foldIO ((forall x. Transactional g r t x -> ResourceT IO x)
-> FoldM (Transactional g r t) o z -> FoldM (ResourceT IO) o z
forall (m :: * -> *) (n :: * -> *) a b.
(forall x. m x -> n x) -> FoldM m a b -> FoldM n a b
F.hoists ((Transactional g r t x -> Env g r t -> ResourceT IO x)
-> Env g r t -> Transactional g r t x -> ResourceT IO x
forall a b c. (a -> b -> c) -> b -> a -> c
flip Transactional g r t x -> Env g r t -> ResourceT IO x
forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
Transactional g r t a -> Env g r t -> ResourceT IO a
un Env g r t
env) FoldM (Transactional g r t) o z
f) (Transaction t -> Acquire (Transaction t)
forall a. a -> Acquire a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env g r t
env.tx) Statement s i o
st i
i
instance Ex.MonadCatch (Transactional g r t) where
catch :: forall e a.
(HasCallStack, Exception e) =>
Transactional g r t a
-> (e -> Transactional g r t a) -> Transactional g r t a
catch Transactional g r t a
act e -> Transactional g r t a
f = (Env g r t -> ResourceT IO a) -> Transactional g r t a
forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
(Env g r t -> ResourceT IO a) -> Transactional g r t a
mk \Env g r t
env -> do
STM ()
refsRollback <- IO (STM ()) -> ResourceT IO (STM ())
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (STM ()) -> ResourceT IO (STM ()))
-> IO (STM ()) -> ResourceT IO (STM ())
forall a b. (a -> b) -> a -> b
$ STM (STM ()) -> IO (STM ())
forall a. STM a -> IO a
atomically (STM (STM ()) -> IO (STM ())) -> STM (STM ()) -> IO (STM ())
forall a b. (a -> b) -> a -> b
$ TVar (IntMap (SomeRef g)) -> STM (STM ())
forall {k} (g :: k). TVar (IntMap (SomeRef g)) -> STM (STM ())
saveSomeRefs Env g r t
env.refs
case Env g r t
env.tx.smode of
SMode t
SRead ->
ResourceT IO a
-> (SomeException -> ResourceT IO a) -> ResourceT IO a
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Ex.catchAsync (Transactional g r t a -> Env g r t -> ResourceT IO a
forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
Transactional g r t a -> Env g r t -> ResourceT IO a
un Transactional g r t a
act Env g r t
env) \SomeException
se -> do
IO () -> ResourceT IO ()
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ResourceT IO ()) -> IO () -> ResourceT IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically STM ()
refsRollback
case SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
Ex.fromException SomeException
se of
Maybe e
Nothing -> SomeException -> ResourceT IO a
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
Ex.throwM SomeException
se
Just e
e -> Transactional g r t a -> Env g r t -> ResourceT IO a
forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
Transactional g r t a -> Env g r t -> ResourceT IO a
un (e -> Transactional g r t a
f e
e) Env g r t
env
SMode t
SWrite -> ((forall a. ResourceT IO a -> ResourceT IO a) -> ResourceT IO a)
-> ResourceT IO a
forall b.
HasCallStack =>
((forall a. ResourceT IO a -> ResourceT IO a) -> ResourceT IO b)
-> ResourceT IO b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
Ex.mask \forall a. ResourceT IO a -> ResourceT IO a
restore -> do
Savepoint
sp <- Transaction 'Write -> ResourceT IO Savepoint
forall (m :: * -> *).
MonadIO m =>
Transaction 'Write -> m Savepoint
savepoint Env g r t
env.tx
ResourceT IO a -> ResourceT IO (Either SomeException a)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
Ex.tryAsync (ResourceT IO a -> ResourceT IO a
forall a. ResourceT IO a -> ResourceT IO a
restore (Transactional g r t a -> Env g r t -> ResourceT IO a
forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
Transactional g r t a -> Env g r t -> ResourceT IO a
un Transactional g r t a
act Env g r t
env)) ResourceT IO (Either SomeException a)
-> (Either SomeException a -> ResourceT IO a) -> ResourceT IO a
forall a b.
ResourceT IO a -> (a -> ResourceT IO b) -> ResourceT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right a
a -> do
ResourceT IO (Either SomeException ()) -> ResourceT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ResourceT IO (Either SomeException ()) -> ResourceT IO ())
-> ResourceT IO (Either SomeException ()) -> ResourceT IO ()
forall a b. (a -> b) -> a -> b
$ ResourceT IO () -> ResourceT IO (Either SomeException ())
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
Ex.tryAny (ResourceT IO () -> ResourceT IO (Either SomeException ()))
-> ResourceT IO () -> ResourceT IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ Savepoint -> ResourceT IO ()
forall (m :: * -> *). MonadIO m => Savepoint -> m ()
savepointRelease Savepoint
sp
a -> ResourceT IO a
forall a. a -> ResourceT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left SomeException
se -> do
IO () -> ResourceT IO ()
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ResourceT IO ()) -> IO () -> ResourceT IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically STM ()
refsRollback
Savepoint -> ResourceT IO ()
forall (m :: * -> *). MonadIO m => Savepoint -> m ()
savepointRollback Savepoint
sp
ResourceT IO (Either SomeException ()) -> ResourceT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ResourceT IO (Either SomeException ()) -> ResourceT IO ())
-> ResourceT IO (Either SomeException ()) -> ResourceT IO ()
forall a b. (a -> b) -> a -> b
$ ResourceT IO () -> ResourceT IO (Either SomeException ())
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
Ex.tryAny (ResourceT IO () -> ResourceT IO (Either SomeException ()))
-> ResourceT IO () -> ResourceT IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ Savepoint -> ResourceT IO ()
forall (m :: * -> *). MonadIO m => Savepoint -> m ()
savepointRelease Savepoint
sp
case SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
Ex.fromException SomeException
se of
Maybe e
Nothing -> SomeException -> ResourceT IO a
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
Ex.throwM SomeException
se
Just e
e -> ResourceT IO a -> ResourceT IO a
forall a. ResourceT IO a -> ResourceT IO a
restore (ResourceT IO a -> ResourceT IO a)
-> ResourceT IO a -> ResourceT IO a
forall a b. (a -> b) -> a -> b
$ Transactional g r t a -> Env g r t -> ResourceT IO a
forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
Transactional g r t a -> Env g r t -> ResourceT IO a
un (e -> Transactional g r t a
f e
e) Env g r t
env
data ErrRetry = ErrRetry
deriving stock (Int -> ErrRetry -> ShowS
[ErrRetry] -> ShowS
ErrRetry -> String
(Int -> ErrRetry -> ShowS)
-> (ErrRetry -> String) -> ([ErrRetry] -> ShowS) -> Show ErrRetry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrRetry -> ShowS
showsPrec :: Int -> ErrRetry -> ShowS
$cshow :: ErrRetry -> String
show :: ErrRetry -> String
$cshowList :: [ErrRetry] -> ShowS
showList :: [ErrRetry] -> ShowS
Show)
deriving anyclass (Show ErrRetry
Typeable ErrRetry
(Typeable ErrRetry, Show ErrRetry) =>
(ErrRetry -> SomeException)
-> (SomeException -> Maybe ErrRetry)
-> (ErrRetry -> String)
-> Exception ErrRetry
SomeException -> Maybe ErrRetry
ErrRetry -> String
ErrRetry -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: ErrRetry -> SomeException
toException :: ErrRetry -> SomeException
$cfromException :: SomeException -> Maybe ErrRetry
fromException :: SomeException -> Maybe ErrRetry
$cdisplayException :: ErrRetry -> String
displayException :: ErrRetry -> String
Ex.Exception)
retry :: Transactional g 'Retry t a
retry :: forall {k} (g :: k) (t :: Mode) a. Transactional g 'Retry t a
retry = ErrRetry -> Transactional g 'Retry t a
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
Ex.throwM ErrRetry
ErrRetry
{-# INLINE retry #-}
orElse
:: Transactional g r t a
-> Transactional g r t a
-> Transactional g r t a
orElse :: forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
Transactional g r t a
-> Transactional g r t a -> Transactional g r t a
orElse Transactional g r t a
tl Transactional g r t a
tr = Transactional g r t a
-> (ErrRetry -> Transactional g r t a) -> Transactional g r t a
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Ex.catch Transactional g r t a
tl \ErrRetry
ErrRetry -> Transactional g r t a
tr
instance Alternative (Transactional g 'Retry t) where
empty :: forall a. Transactional g 'Retry t a
empty = Transactional g 'Retry t a
forall {k} (g :: k) (t :: Mode) a. Transactional g 'Retry t a
retry
{-# INLINE empty #-}
<|> :: forall a.
Transactional g 'Retry t a
-> Transactional g 'Retry t a -> Transactional g 'Retry t a
(<|>) = Transactional g 'Retry t a
-> Transactional g 'Retry t a -> Transactional g 'Retry t a
forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
Transactional g r t a
-> Transactional g r t a -> Transactional g r t a
orElse
{-# INLINE (<|>) #-}
instance MonadPlus (Transactional g 'Retry t) where
mzero :: forall a. Transactional g 'Retry t a
mzero = Transactional g 'Retry t a
forall {k} (g :: k) (t :: Mode) a. Transactional g 'Retry t a
retry
{-# INLINE mzero #-}
mplus :: forall a.
Transactional g 'Retry t a
-> Transactional g 'Retry t a -> Transactional g 'Retry t a
mplus = Transactional g 'Retry t a
-> Transactional g 'Retry t a -> Transactional g 'Retry t a
forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
Transactional g r t a
-> Transactional g r t a -> Transactional g r t a
orElse
{-# INLINE mplus #-}
data SomeRef g where
SomeRef :: Ref g a -> SomeRef g
saveSomeRefs :: TVar (IntMap (SomeRef g)) -> STM (STM ())
saveSomeRefs :: forall {k} (g :: k). TVar (IntMap (SomeRef g)) -> STM (STM ())
saveSomeRefs TVar (IntMap (SomeRef g))
tvsrs = do
IntMap (SomeRef g)
srs0 <- TVar (IntMap (SomeRef g)) -> STM (IntMap (SomeRef g))
forall a. TVar a -> STM a
readTVar TVar (IntMap (SomeRef g))
tvsrs
IntMap (STM ())
rollbacks <- IntMap (SomeRef g)
-> (SomeRef g -> STM (STM ())) -> STM (IntMap (STM ()))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM IntMap (SomeRef g)
srs0 \(SomeRef (Ref TVar (Maybe a)
tv)) ->
TVar (Maybe a) -> Maybe a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe a)
tv (Maybe a -> STM ()) -> STM (Maybe a) -> STM (STM ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Maybe a) -> STM (Maybe a)
forall a. TVar a -> STM a
readTVar TVar (Maybe a)
tv
STM () -> STM (STM ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure do
IntMap (SomeRef g)
srs1 <- TVar (IntMap (SomeRef g))
-> IntMap (SomeRef g) -> STM (IntMap (SomeRef g))
forall a. TVar a -> a -> STM a
swapTVar TVar (IntMap (SomeRef g))
tvsrs IntMap (SomeRef g)
srs0
IntMap (SomeRef g) -> (SomeRef g -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntMap (SomeRef g) -> IntMap (SomeRef g) -> IntMap (SomeRef g)
forall a b. IntMap a -> IntMap b -> IntMap a
IntMap.difference IntMap (SomeRef g)
srs1 IntMap (SomeRef g)
srs0) \(SomeRef (Ref TVar (Maybe a)
tv)) ->
TVar (Maybe a) -> Maybe a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe a)
tv Maybe a
forall a. Maybe a
Nothing
IntMap (STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ IntMap (STM ())
rollbacks
newtype Ref g a = Ref (TVar (Maybe a))
deriving newtype
( Ref g a -> Ref g a -> Bool
(Ref g a -> Ref g a -> Bool)
-> (Ref g a -> Ref g a -> Bool) -> Eq (Ref g a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (g :: k) a. Ref g a -> Ref g a -> Bool
$c== :: forall k (g :: k) a. Ref g a -> Ref g a -> Bool
== :: Ref g a -> Ref g a -> Bool
$c/= :: forall k (g :: k) a. Ref g a -> Ref g a -> Bool
/= :: Ref g a -> Ref g a -> Bool
Eq
)
instance MonadRef (Transactional g r t) where
type Ref (Transactional g r t) = Sq.Transactional.Ref g
newRef :: forall a. a -> Transactional g r t (Ref (Transactional g r t) a)
newRef a
a = (Env g r t -> ResourceT IO (Ref g a))
-> Transactional g r t (Ref g a)
forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
(Env g r t -> ResourceT IO a) -> Transactional g r t a
mk \Env g r t
env -> IO (Ref g a) -> ResourceT IO (Ref g a)
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ref g a) -> ResourceT IO (Ref g a))
-> IO (Ref g a) -> ResourceT IO (Ref g a)
forall a b. (a -> b) -> a -> b
$ STM (Ref g a) -> IO (Ref g a)
forall a. STM a -> IO a
atomically do
Int
i <- Env g r t
env.unique
TVar (Maybe a)
tv <- Maybe a -> STM (TVar (Maybe a))
forall a. a -> STM (TVar a)
newTVar (Maybe a -> STM (TVar (Maybe a)))
-> Maybe a -> STM (TVar (Maybe a))
forall a b. (a -> b) -> a -> b
$! a -> Maybe a
forall a. a -> Maybe a
Just a
a
let ref :: Ref g a
ref = TVar (Maybe a) -> Ref g a
forall {k} (g :: k) a. TVar (Maybe a) -> Ref g a
Ref TVar (Maybe a)
tv
TVar (IntMap (SomeRef g))
-> (IntMap (SomeRef g) -> IntMap (SomeRef g)) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' Env g r t
env.refs ((IntMap (SomeRef g) -> IntMap (SomeRef g)) -> STM ())
-> (IntMap (SomeRef g) -> IntMap (SomeRef g)) -> STM ()
forall a b. (a -> b) -> a -> b
$ Int -> SomeRef g -> IntMap (SomeRef g) -> IntMap (SomeRef g)
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
i (SomeRef g -> IntMap (SomeRef g) -> IntMap (SomeRef g))
-> SomeRef g -> IntMap (SomeRef g) -> IntMap (SomeRef g)
forall a b. (a -> b) -> a -> b
$! Ref g a -> SomeRef g
forall {k} (g :: k) a. Ref g a -> SomeRef g
SomeRef Ref g a
ref
Ref g a -> STM (Ref g a)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ref g a
ref
readRef :: forall a. Ref (Transactional g r t) a -> Transactional g r t a
readRef (Ref TVar (Maybe a)
tv) = (Env g r t -> ResourceT IO a) -> Transactional g r t a
forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
(Env g r t -> ResourceT IO a) -> Transactional g r t a
mk \Env g r t
_ -> IO a -> ResourceT IO a
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ResourceT IO a) -> IO a -> ResourceT IO a
forall a b. (a -> b) -> a -> b
$ STM a -> IO a
forall a. STM a -> IO a
atomically do
TVar (Maybe a) -> STM (Maybe a)
forall a. TVar a -> STM a
readTVar TVar (Maybe a)
tv STM (Maybe a) -> (Maybe a -> STM a) -> STM a
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just a
a -> a -> STM a
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Maybe a
Nothing -> IOError -> STM a
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
Ex.throwM (IOError -> STM a) -> IOError -> STM a
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> IOError
String -> IOError
resourceVanishedWithCallStack String
"Ref"
writeRef :: forall a.
Ref (Transactional g r t) a -> a -> Transactional g r t ()
writeRef Ref (Transactional g r t) a
r a
a = Ref (Transactional g r t) a
-> (a -> (a, ())) -> Transactional g r t ()
forall a b.
Ref (Transactional g r t) a
-> (a -> (a, b)) -> Transactional g r t b
forall (m :: * -> *) a b.
MonadAtomicRef m =>
Ref m a -> (a -> (a, b)) -> m b
atomicModifyRef Ref (Transactional g r t) a
r \a
_ -> (a
a, ())
modifyRef :: forall a.
Ref (Transactional g r t) a -> (a -> a) -> Transactional g r t ()
modifyRef Ref (Transactional g r t) a
r a -> a
f = Ref (Transactional g r t) a
-> (a -> (a, ())) -> Transactional g r t ()
forall a b.
Ref (Transactional g r t) a
-> (a -> (a, b)) -> Transactional g r t b
forall (m :: * -> *) a b.
MonadAtomicRef m =>
Ref m a -> (a -> (a, b)) -> m b
atomicModifyRef Ref (Transactional g r t) a
r \a
a -> (a -> a
f a
a, ())
modifyRef' :: forall a.
Ref (Transactional g r t) a -> (a -> a) -> Transactional g r t ()
modifyRef' Ref (Transactional g r t) a
r a -> a
f = Ref (Transactional g r t) a
-> (a -> (a, ())) -> Transactional g r t ()
forall a b.
Ref (Transactional g r t) a
-> (a -> (a, b)) -> Transactional g r t b
forall (m :: * -> *) a b.
MonadAtomicRef m =>
Ref m a -> (a -> (a, b)) -> m b
atomicModifyRef' Ref (Transactional g r t) a
r \a
a -> (a -> a
f a
a, ())
instance MonadAtomicRef (Transactional g r t) where
atomicModifyRef :: forall a b.
Ref (Transactional g r t) a
-> (a -> (a, b)) -> Transactional g r t b
atomicModifyRef (Ref TVar (Maybe a)
tv) a -> (a, b)
f =
(Env g r t -> ResourceT IO b) -> Transactional g r t b
forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
(Env g r t -> ResourceT IO a) -> Transactional g r t a
mk \Env g r t
_ -> IO b -> ResourceT IO b
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> ResourceT IO b) -> IO b -> ResourceT IO b
forall a b. (a -> b) -> a -> b
$ STM b -> IO b
forall a. STM a -> IO a
atomically do
TVar (Maybe a) -> STM (Maybe a)
forall a. TVar a -> STM a
readTVar TVar (Maybe a)
tv STM (Maybe a) -> (Maybe a -> STM b) -> STM b
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just a
a0 | (a
a1, b
b) <- a -> (a, b)
f a
a0 -> do
TVar (Maybe a) -> Maybe a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe a)
tv (Maybe a -> STM ()) -> Maybe a -> STM ()
forall a b. (a -> b) -> a -> b
$! a -> Maybe a
forall a. a -> Maybe a
Just a
a1
b -> STM b
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b
Maybe a
Nothing -> IOError -> STM b
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
Ex.throwM (IOError -> STM b) -> IOError -> STM b
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> IOError
String -> IOError
resourceVanishedWithCallStack String
"Ref"
atomicModifyRef' :: forall a b.
Ref (Transactional g r t) a
-> (a -> (a, b)) -> Transactional g r t b
atomicModifyRef' (Ref TVar (Maybe a)
tv) a -> (a, b)
f =
(Env g r t -> ResourceT IO b) -> Transactional g r t b
forall {k} (g :: k) (r :: Retry) (t :: Mode) a.
(Env g r t -> ResourceT IO a) -> Transactional g r t a
mk \Env g r t
_ -> IO b -> ResourceT IO b
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> ResourceT IO b) -> IO b -> ResourceT IO b
forall a b. (a -> b) -> a -> b
$ STM b -> IO b
forall a. STM a -> IO a
atomically do
TVar (Maybe a) -> STM (Maybe a)
forall a. TVar a -> STM a
readTVar TVar (Maybe a)
tv STM (Maybe a) -> (Maybe a -> STM b) -> STM b
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just a
a0 | (!a
a1, !b
b) <- a -> (a, b)
f a
a0 -> do
TVar (Maybe a) -> Maybe a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe a)
tv (Maybe a -> STM ()) -> Maybe a -> STM ()
forall a b. (a -> b) -> a -> b
$! a -> Maybe a
forall a. a -> Maybe a
Just a
a1
b -> STM b
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b
Maybe a
Nothing -> IOError -> STM b
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
Ex.throwM (IOError -> STM b) -> IOError -> STM b
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> IOError
String -> IOError
resourceVanishedWithCallStack String
"Ref"