module Sq.Transactional
   ( Transactional
   , embed
   , transactionalRetry
   , one
   , maybe
   , zero
   , some
   , list
   , fold
   , foldM
   , Ref
   , Retry (..)
   , retry
   , orElse
   ) where

import Control.Applicative hiding (some)
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.Int
import Data.IntMap.Strict (IntMap)
import Data.IntMap.Strict qualified as IntMap
import Data.Kind
import Data.List.NonEmpty (NonEmpty)
import Prelude hiding (Read, maybe, read)

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
   :: forall o z i t s g r
    . (SubMode t s)
   => F.FoldM (Transactional g r t) o z
   -> Statement s i o
   -> i
   -> Transactional g r t z
foldM :: forall {k} o z i (t :: Mode) (s :: Mode) (g :: k) (r :: Retry).
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 o z i (t :: Mode) (s :: Mode) (m :: * -> *).
(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"

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

-- | Executes a 'Statement' expected to return __zero or one__ rows.
--
-- * Throws 'ErrRows_TooMany' if more than one row.
maybe
   :: forall o i t s g r
    . (SubMode t s)
   => Statement s i o
   -> i
   -> Transactional g r t (Maybe o)
maybe :: forall {k} o i (t :: Mode) (s :: Mode) (g :: k) (r :: Retry).
SubMode t s =>
Statement s i o -> i -> Transactional g r t (Maybe o)
maybe = FoldM (Transactional g r t) o (Maybe o)
-> Statement s i o -> i -> Transactional g r t (Maybe o)
forall {k} o z i (t :: Mode) (s :: Mode) (g :: k) (r :: Retry).
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 (Maybe o)
 -> Statement s i o -> i -> Transactional g r t (Maybe o))
-> FoldM (Transactional g r t) o (Maybe o)
-> Statement s i o
-> i
-> Transactional g r t (Maybe o)
forall a b. (a -> b) -> a -> b
$ ErrRows -> FoldM (Transactional g r t) o (Maybe o)
forall (m :: * -> *) e o.
(MonadThrow m, Exception e) =>
e -> FoldM m o (Maybe o)
foldMaybeM ErrRows
ErrRows_TooMany
{-# INLINE maybe #-}

-- | Executes a 'Statement' expected to return exactly __one__ row.
--
-- * Throws 'ErrRows_TooFew' if zero rows, 'ErrRows_TooMany' if more than one row.
one
   :: forall o i t s g r
    . (SubMode t s)
   => Statement s i o
   -> i
   -> Transactional g r t o
one :: forall {k} o i (t :: Mode) (s :: Mode) (g :: k) (r :: Retry).
SubMode t s =>
Statement s i o -> i -> Transactional g r t o
one = FoldM (Transactional g r t) o o
-> Statement s i o -> i -> Transactional g r t o
forall {k} o z i (t :: Mode) (s :: Mode) (g :: k) (r :: Retry).
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 o
 -> Statement s i o -> i -> Transactional g r t o)
-> FoldM (Transactional g r t) o o
-> Statement s i o
-> i
-> Transactional g r t o
forall a b. (a -> b) -> a -> b
$ ErrRows -> ErrRows -> FoldM (Transactional g r t) o o
forall (m :: * -> *) e o.
(MonadThrow m, Exception e) =>
e -> e -> FoldM m o o
foldOneM ErrRows
ErrRows_TooFew ErrRows
ErrRows_TooMany
{-# INLINE one #-}

-- | Executes a 'Statement' expected to return exactly __zero__ rows.
--
-- * Throws 'ErrRows_TooMany' if more than zero rows.
zero
   :: forall o i t s g r
    . (SubMode t s)
   => Statement s i o
   -> i
   -> Transactional g r t ()
zero :: forall {k} o i (t :: Mode) (s :: Mode) (g :: k) (r :: Retry).
SubMode t s =>
Statement s i o -> i -> Transactional g r t ()
zero = FoldM (Transactional g r t) o ()
-> Statement s i o -> i -> Transactional g r t ()
forall {k} o z i (t :: Mode) (s :: Mode) (g :: k) (r :: Retry).
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 ()
 -> Statement s i o -> i -> Transactional g r t ())
-> FoldM (Transactional g r t) o ()
-> Statement s i o
-> i
-> Transactional g r t ()
forall a b. (a -> b) -> a -> b
$ ErrRows -> FoldM (Transactional g r t) o ()
forall (m :: * -> *) e o.
(MonadThrow m, Exception e) =>
e -> FoldM m o ()
foldZeroM ErrRows
ErrRows_TooMany
{-# INLINE zero #-}

-- | Executes a 'Statement' expected to return __one or more__ rows.
--
-- * Returns the length of the 'NonEmpty' list, too.
--
-- * Throws 'ErrRows_TooFew' if zero rows.
some
   :: forall o i t s g r
    . (SubMode t s)
   => Statement s i o
   -> i
   -> Transactional g r t (Int64, NonEmpty o)
some :: forall {k} o i (t :: Mode) (s :: Mode) (g :: k) (r :: Retry).
SubMode t s =>
Statement s i o -> i -> Transactional g r t (Int64, NonEmpty o)
some = FoldM (Transactional g r t) o (Int64, NonEmpty o)
-> Statement s i o -> i -> Transactional g r t (Int64, NonEmpty o)
forall {k} o z i (t :: Mode) (s :: Mode) (g :: k) (r :: Retry).
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 (Int64, NonEmpty o)
 -> Statement s i o -> i -> Transactional g r t (Int64, NonEmpty o))
-> FoldM (Transactional g r t) o (Int64, NonEmpty o)
-> Statement s i o
-> i
-> Transactional g r t (Int64, NonEmpty o)
forall a b. (a -> b) -> a -> b
$ ErrRows -> FoldM (Transactional g r t) o (Int64, NonEmpty o)
forall (m :: * -> *) e o.
(MonadThrow m, Exception e) =>
e -> FoldM m o (Int64, NonEmpty o)
foldNonEmptyM ErrRows
ErrRows_TooFew
{-# INLINE some #-}

-- | Executes a 'Statement' expected to return __zero or more__ rows.
--
-- * Returns the length of the list, too.
list
   :: forall o i t s g r
    . (SubMode t s)
   => Statement s i o
   -> i
   -> Transactional g r t (Int64, [o])
list :: forall {k} o i (t :: Mode) (s :: Mode) (g :: k) (r :: Retry).
SubMode t s =>
Statement s i o -> i -> Transactional g r t (Int64, [o])
list = Fold o (Int64, [o])
-> Statement s i o -> i -> Transactional g r t (Int64, [o])
forall {k} o z i (t :: Mode) (s :: Mode) (g :: k) (r :: Retry).
SubMode t s =>
Fold o z -> Statement s i o -> i -> Transactional g r t z
fold Fold o (Int64, [o])
forall o. Fold o (Int64, [o])
foldList
{-# INLINE list #-}

-- | __Purely fold__ all the output rows.
fold
   :: forall o z i t s g r
    . (SubMode t s)
   => F.Fold o z
   -> Statement s i o
   -> i
   -> Transactional g r t z
fold :: forall {k} o z i (t :: Mode) (s :: Mode) (g :: k) (r :: Retry).
SubMode t s =>
Fold o z -> Statement s i o -> i -> Transactional g r t z
fold = FoldM (Transactional g r t) o z
-> Statement s i o -> i -> Transactional g r t z
forall {k} o z i (t :: Mode) (s :: Mode) (g :: k) (r :: Retry).
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
 -> Statement s i o -> i -> Transactional g r t z)
-> (Fold o z -> FoldM (Transactional g r t) o z)
-> Fold o z
-> Statement s i o
-> i
-> Transactional g r t z
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fold o z -> FoldM (Transactional g r t) o z
forall (m :: * -> *) a b. Monad m => Fold a b -> FoldM m a b
F.generalize
{-# INLINE fold #-}