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

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

-- | Used as the @r@ type-parameter in @'Transactional' g r t a@.
--
-- * If the 'Transactional' uses any 'Alternative' or 'MonadPlus' feature, then
-- @r@ must be 'Retry', and the 'Transactional' can only be executed through
-- 'Sq.read', 'Sq.commit' or 'Sq.rollback'.
--
-- * Otherwise, @r@ can be 'NoRetry'. In that case, 'embed' can
-- also be used to execute the 'Transactional'.
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
   -- ^ Next unique 'Int' within the 'Transactional' to be used as key in 'refs'
   , forall k (g :: k) (r :: Retry) (t :: Mode).
Env g r t -> TVar (IntMap (SomeRef g))
refs :: TVar (IntMap (SomeRef g))
   -- ^ Currently valid 'Ref's. We keep track of them in order to implement
   -- 'catch'. The 'IntMap' is just for fast diffing purposes.
   , forall k (g :: k) (r :: Retry) (t :: Mode).
Env g r t -> Transaction t
tx :: Transaction t
   -- ^ Current transaction.
   }

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))
..}

-- | @'Transactional' g r t a@ groups together multiple interactions with a same
-- @'Transaction' t@ that finally produce a value of type @a@. Think of
-- 'Transactional' as if it was 'STM'.
--
-- * @g@ is an ephemeral tag for the whole inteaction group that prevents
-- 'Ref's and 'stream's from escaping its intended scope (like 'Data.STRef.ST'
-- does it). Just ignore it, it will always be polymorphic.
--
-- * @r@ says whether the 'Transactional' could potentially be retried from
-- scratch in order to observe a new snapshot of the database (like 'STM' does
-- it).  Learn more about this in 'Retry'.
--
-- * @t@ says whether the 'Transactional' could potentially perform 'Write'
-- or 'Read'-only operations.
--
-- * @a@ is the Haskell value finally produced by a successfu execution of
-- the 'Transactional'.
--
-- __To execute a 'Transactional'__ you will normally use one of 'Sq.read' or
-- 'Sq.commit' (or 'Sq.rollback' or 'Sq.embed', but those are less common).
--
-- @
-- /-- We are using 'Sq.commit' to execute the 'Transactional'. This means/
-- /-- that the 'Transactional' will have read and 'Write' capabilities, that/
-- /-- it can 'retry', and that ultimately, unless there are unhandled/
-- /-- exceptions, the changes will be commited to the database./
-- __"Sq".'Sq.commit' pool do__
--
--    /-- We can execute 'Write' 'Statement's:/
--    __userId1 <- "Sq".'Sq.one' /insertUser/ \"haskell\@example.com\"__
--
--    /-- And 'Read' 'Statement's:/
--    __userId2 \<- "Sq".'Sq.one' /getUserIdByEmail/ \"haskell\@example.com\"__
--
--    /-- We have 'MonadFail' too:/
--    __'when' (userId1 /= userId2) do__
--        __'fail' \"Something unexpected happened!\"__
--
--    /-- We also have 'Ref's, which work just like 'TVar's:/
--    __ref \<- 'newRef' (0 :: 'Int')__
--
--    /-- 'Ex.catch' behaves like 'catchSTM', undoing changes to 'Ref's/
--    /-- and to the database itself when the original action fails:/
--    __userId3 \<- 'Ex.catch'__
--        /-- Something will fail .../
--        __(do 'modifyRef' ref (+ 1)__
--            __\_ \<- "Sq".'Sq.one' /insertUser/ \"sqlite\@example.com\"__
--            __'Ex.throwM' FakeException123)__
--        /-- ... but there is a catch!/
--        __(\\FakeException123 -> do__
--            /-- The observable universe has been reset to what it/
--            /-- was before the 'Ex.catch':/
--            __"Sq".'Sq.zero' /getUserIdByEmail/ \"sqlite\@example.com\"__
--            __'modifyRef' ref (+ 10))__
--
--    /-- Only the effects from the exception handling function were preserved:/
--    __"Sq".'Sq.zero' /getUserIdByEmail/ \"sqlite\@example.com\"__
--    __10 <- 'readRef' ref__
--
--    /-- 'retry' and its synonyms 'mzero' and 'empty' not only discard changes as/
--    /-- 'Ex.catch' does, but they also cause the ongoing 'Transaction' to be/
--    /-- discarded, and the entire 'Transactional' to be executed again on a/
--    /-- brand new 'Transaction' observing a new snapshot of the database. For/
--    /-- example, the following code will keep retrying the whole 'Transactional'/
--    /-- until the user with the specified email exists./
--    __userId4 \<- "Sq".'maybe' /getUserIdByEmail/ \"nix@example.com\" >>= \\case__
--        __'Just' x -> 'pure' x__
--        __'Nothing' -> 'retry'__
--
--    /-- Presumably, this example was waiting for a concurrent connection to/
--    /-- insert said user. If we got here, it is because that happened./
--
--    /-- As usual, 'mzero' and 'empty' can be handled by means of '<|>' and 'mplus',/
--    /-- or its synonym 'orElse'./
--    __'False' \<- 'mplus' ('writeRef' ref 8 >> 'mzero' >> 'pure' 'True')__
--                   __('pure' 'False')__
--
--    /-- The recent 'writeRef' to 8 on the 'retry'ied 'Transactional' was discarded:/
--    __10 <- 'readRef' ref__
--
--    __'pure' ()__
-- @
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))

-- | INTERNAL only. This doesn't deal with @g@.
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 #-}

-- | INTERNAL. Used to implement 'Sq.read', 'Sq.commit' and 'Sq.rollback'.
--
-- Run all the actions in a 'Transactional' as part of a single 'Transaction'.
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
      -- TODO: Wait with `sqlite3_commit_hook` instead of just retrying.
      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

-- | Embeds all the actions in a 'Transactional' as part of an ongoing
-- 'Transaction'.
--
-- * __NOTICE__ Contrary to 'Sq.read', 'Sq.commit' or 'Sq.rollback',
-- this 'Transactional' cannot 'retry', as doing so would require
-- cancelling the ongoing 'Transaction'.
embed
   :: forall m t a
    . (MonadIO m)
   => Transaction t
   -- ^ Ongoing transaction.
   -> (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

-- | __Impurely fold__ the output rows.
--
-- * For a non-'Transactional' version of this function, see 'Sq.foldIO'.
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

-- | 'Ex.catch' behaves like "STM"'s 'catchSTM'.
--
-- In @'Ex.catch' ma f@, if an exception is thrown by @ma@, then any
-- database or 'Ref' changes made by @ma@ will be discarded. Furthermore, if
-- @f@ can handle said exception, then the action resulting from applying @f@
-- will be executed. Otherwise, if @f@ can't handle the exception, it will
-- bubble up.
--
-- Note: This instance's 'Cx.catch' catches async exceptions because that's
-- what 'Cx.MonadCatch' instances normaly do. As a user of this instance, you
-- probably want to use "Control.Exceptions.Safe" to make sure you don't catch
-- async exceptions unless you really want to.
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
                  -- savepointRelease is not critical.
                  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
                  -- savepointRelease is not critical. Just making sure we
                  -- don't accumulate many savepoints in case there is some
                  -- recursion going on.
                  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

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

-- | INTERNAL.
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' behaves like 'STM'\'s 'Control.Concurrent.STM.retry'. It causes
-- the current 'Transaction' to be cancelled so that a new one can take its
-- place and the entire 'Transactional' is executed again. This allows the
-- 'Transactional' to observe a new snapshot of the database.
--
-- * 'retry', 'empty' and 'mzero' all do fundamentally the same thing,
-- however 'retry' leads to better type inferrence because it forces the
-- @r@ type-parameter to be 'Retry'.
--
-- * __NOTICE__ You only need to use 'mzero' if you need access to a newer
-- database snapshot. If all you want to do is undo some 'Ref' transformation
-- effects, or undo database changes, then use 'catch' which doesn't abandon
-- the 'Transaction'.
--
-- * __WARNING__ If we keep 'retry'ing and the database never changes, then
-- we will be stuck in a loop forever. To mitigate this, when executing the
-- 'Transactional' through 'Sq.read', 'Sq.commit' or 'Sq.rollback', you may
-- want to use 'System.Timeout.timeout' to abort at some point in the future.
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' ma mb@ behaves like 'STM'\'s @'Control.Concurrent.STM.orElse' ma
-- mb@.  If @ma@ completes without executing 'retry', then that constitutes the
-- entirety of @'orElse' ma mb@. Otherwise, if @ma@ executed 'retry', then all
-- the effects from @ma@ are discared and @mb@ is tried in its place.
--
-- * 'orElse', '<|>' and 'mplus' all do the same thing, but 'orElse' has a more
-- general type because it doesn't force the @r@ type-parameter to be '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

-- | @
-- 'empty' = 'retry'
-- '(<|>)' = 'orElse'
-- @
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 (<|>) #-}

-- | @
-- 'mzero' = 'retry'
-- 'mplus' = 'orElse'
-- @
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

-- | Creates a “savepoint” with the current state of the given 'SomeRef's.
-- The produced 'STM' action can be used to rollback the 'SomeRef's current
-- state in the future.
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

-- | Like 'TVar', but you can use it inside 'Transactional' through the
-- 'MonadRef' and 'MonadAtomicRef' vocabulary.
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
        -- ^ Pointer equality
      )

-- | All operations are atomic.
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
      -- Note: We only explicitly remove things from the IntMap through
      -- saveSomeRefs, or when exiting Transactional. Maybe some day we
      -- optimize this.
      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"