From decb1e80a3e6f1b26fcd676f29a3d6ff02bab7f9 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Tue, 30 Nov 2021 22:17:42 +0100
Subject: [PATCH] Add newUniqueSTM to prelude
---
src/Quasar/PreludeExtras.hs | 6 ++++++
src/Quasar/ResourceManager.hs | 5 ++---
2 files changed, 8 insertions(+), 3 deletions(-)
diff --git a/src/Quasar/PreludeExtras.hs b/src/Quasar/PreludeExtras.hs
index b91d717..c229dd6 100644
--- a/src/Quasar/PreludeExtras.hs
+++ b/src/Quasar/PreludeExtras.hs
@@ -8,6 +8,7 @@ import Prelude
import Control.Applicative (liftA2)
import Control.Concurrent (threadDelay)
+import Control.Concurrent.STM
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.State.Lazy as State
import Data.Char qualified as Char
@@ -16,6 +17,8 @@ import Data.HashSet qualified as HS
import Data.Hashable qualified as Hashable
import Data.List qualified as List
import Data.Maybe qualified as Maybe
+import Data.Unique (Unique, newUnique)
+import GHC.Conc (unsafeIOToSTM)
import GHC.Stack.Types qualified
import Quasar.Utils.ExtraT
@@ -129,3 +132,6 @@ unlessM :: Monad m => m Bool -> m () -> m ()
unlessM condM acc = do
cond <- condM
unless cond acc
+
+newUniqueSTM :: STM Unique
+newUniqueSTM = unsafeIOToSTM newUnique
diff --git a/src/Quasar/ResourceManager.hs b/src/Quasar/ResourceManager.hs
index 4445a8d..e04d66f 100644
--- a/src/Quasar/ResourceManager.hs
+++ b/src/Quasar/ResourceManager.hs
@@ -49,7 +49,6 @@ import Data.HashMap.Strict qualified as HM
import Data.List.NonEmpty (NonEmpty(..), (<|), nonEmpty)
import Data.Sequence (Seq(..), (|>))
import Data.Sequence qualified as Seq
-import GHC.Conc (unsafeIOToSTM)
import Quasar.Async.Unmanaged
import Quasar.Awaitable
import Quasar.Disposable
@@ -330,7 +329,7 @@ instance IsResourceManager DefaultResourceManager where
attachDisposable self disposable = liftIO $ atomically $ attachDisposableSTM self disposable
attachDisposableSTM DefaultResourceManager{stateVar, disposablesVar} disposable = do
- key <- unsafeIOToSTM newUnique
+ key <- newUniqueSTM
state <- readTVar stateVar
case state of
ResourceManagerNormal -> do
@@ -462,7 +461,7 @@ defaultResourceManagerDisposeResult DefaultResourceManager{resourceManagerKey, r
-- to implement the root resource manager.
newUnmanagedDefaultResourceManagerInternal :: ResourceManager -> STM DefaultResourceManager
newUnmanagedDefaultResourceManagerInternal parentResourceManager = do
- resourceManagerKey <- unsafeIOToSTM newUnique
+ resourceManagerKey <- newUniqueSTM
stateVar <- newTVar ResourceManagerNormal
disposablesVar <- newTMVar HM.empty
lockVar <- newTVar 0
--
GitLab