From ba4fc48facd3816366b9ee76ebf129990487843f Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Sun, 2 Oct 2022 21:33:13 +0200
Subject: [PATCH] Add atomically'
Co-authored-by: Jan Beinke <git@janbeinke.com>
---
stm-ltd/src/Control/Concurrent/STM/Class.hs | 8 ++++++++
1 file changed, 8 insertions(+)
diff --git a/stm-ltd/src/Control/Concurrent/STM/Class.hs b/stm-ltd/src/Control/Concurrent/STM/Class.hs
index 11ee3a8..e829b20 100644
--- a/stm-ltd/src/Control/Concurrent/STM/Class.hs
+++ b/stm-ltd/src/Control/Concurrent/STM/Class.hs
@@ -15,6 +15,8 @@ module Control.Concurrent.STM.Class (
-- ** STM'
STM',
runSTM',
+ atomically',
+
-- *** Capabilities
RetryMode(..),
CanRetry,
@@ -132,6 +134,7 @@ import Control.Concurrent.STM (STM)
import Control.Concurrent.STM qualified as STM
import Control.Concurrent.STM.Class.TH
import Control.Monad.Catch
+import Control.Monad.IO.Class
import Control.Monad.Fix (MonadFix)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.RWS (RWST)
@@ -235,6 +238,11 @@ runSTM' :: MonadSTM m => STM' r t a -> m a
runSTM' (STM' f) = liftSTM f
{-# INLINABLE runSTM' #-}
+atomically' :: MonadIO m => STM' CanRetry CanThrow a -> m a
+atomically' = liftIO . STM.atomically . runSTM'
+{-# INLINABLE atomically' #-}
+
+
noRetry :: MonadSTM' r t m => STM' NoRetry t a -> m a
noRetry = unsafeLimitSTM . runSTM'
{-# INLINABLE noRetry #-}
--
GitLab