From a630bae16eedfe32e508d9c925b692f1d1d32018 Mon Sep 17 00:00:00 2001
From: Nikita Volkov <nikita.y.volkov@mail.ru>
Date: Thu, 19 Oct 2023 18:45:24 +0300
Subject: [PATCH 1/3] Reproduce the bug in flushTBQueue
---
testsuite/src/Issue76.hs | 28 ++++++++++++++++++++++++++++
testsuite/src/Main.hs | 2 ++
testsuite/testsuite.cabal | 1 +
3 files changed, 31 insertions(+)
create mode 100644 testsuite/src/Issue76.hs
diff --git a/testsuite/src/Issue76.hs b/testsuite/src/Issue76.hs
new file mode 100644
index 0000000..31b279d
--- /dev/null
+++ b/testsuite/src/Issue76.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE CPP #-}
+
+-- See https://github.com/haskell/stm/pull/76.
+--
+-- Test-case contributed by Nikita Volkov <nikita.y.volkov@mail.ru>.
+--
+-- This bug is observable in version `stm-2.5.2.1`.
+
+module Issue76 (main) where
+
+import Control.Concurrent.STM
+import Data.Foldable
+import Test.HUnit
+
+main :: IO ()
+#if MIN_VERSION_stm(2,4,5)
+main = do
+ queue <- newTBQueueIO 100 :: IO (TBQueue Int)
+ lengthAfterFlush <- atomically $ do
+ writeTBQueue queue 1
+ writeTBQueue queue 2
+ _ <- flushTBQueue queue
+ lengthTBQueue queue
+ assertEqual "" 0 lengthAfterFlush
+#else
+-- test-case not applicable; `flushTBQueue` was only added in 2.4.5.0
+main = return ()
+#endif
diff --git a/testsuite/src/Main.hs b/testsuite/src/Main.hs
index 8cbb8db..e7c8826 100644
--- a/testsuite/src/Main.hs
+++ b/testsuite/src/Main.hs
@@ -6,6 +6,7 @@ import Test.Framework (defaultMain, testGroup)
import Test.Framework.Providers.HUnit
import qualified Issue9
+import qualified Issue76
import qualified Stm052
import qualified Stm064
import qualified Stm065
@@ -18,6 +19,7 @@ main = do
tests = [
testGroup "regression"
[ testCase "issue #9" Issue9.main
+ , testCase "issue #76" Issue76.main
, testCase "stm052" Stm052.main
, testCase "stm064" Stm064.main
, testCase "stm065" Stm065.main
diff --git a/testsuite/testsuite.cabal b/testsuite/testsuite.cabal
index 863057f..0652418 100644
--- a/testsuite/testsuite.cabal
+++ b/testsuite/testsuite.cabal
@@ -20,6 +20,7 @@ test-suite stm
main-is: Main.hs
other-modules:
Issue9
+ Issue76
Stm052
Stm064
Stm065
From dce77da76a467f4739b0d42cb9e17df1317dd37d Mon Sep 17 00:00:00 2001
From: Nikita Volkov <nikita.y.volkov@mail.ru>
Date: Thu, 19 Oct 2023 18:50:04 +0300
Subject: [PATCH 2/3] Provide a quick fix of flushTBQueue
---
Control/Concurrent/STM/TBQueue.hs | 21 +++++++++------------
1 file changed, 9 insertions(+), 12 deletions(-)
diff --git a/Control/Concurrent/STM/TBQueue.hs b/Control/Concurrent/STM/TBQueue.hs
index d5ea578..58559f3 100644
--- a/Control/Concurrent/STM/TBQueue.hs
+++ b/Control/Concurrent/STM/TBQueue.hs
@@ -143,18 +143,15 @@ tryReadTBQueue q = fmap Just (readTBQueue q) `orElse` pure Nothing
--
-- @since 2.4.5
flushTBQueue :: forall a. TBQueue a -> STM [a]
-flushTBQueue (TBQueue _rindex windex elements cap) = do
- w <- readTVar windex
- go (decMod w cap) []
- where
- go :: Int -> [a] -> STM [a]
- go i acc = do
- ele <- unsafeRead elements i
- case ele of
- Nothing -> pure acc
- Just a -> do
- unsafeWrite elements i Nothing
- go (decMod i cap) (a : acc)
+flushTBQueue queue =
+ -- TODO: Optimize.
+ go []
+ where
+ go acc = do
+ tryReadResult <- tryReadTBQueue queue
+ case tryReadResult of
+ Just element -> go $ element : acc
+ Nothing -> return $ reverse acc
-- | Get the next value from the @TBQueue@ without removing it,
-- retrying if the queue is empty.
From 4532c745bf4791585ee25930e91cf699f3a1db58 Mon Sep 17 00:00:00 2001
From: Nikita Volkov <nikita.y.volkov@mail.ru>
Date: Thu, 19 Oct 2023 19:17:10 +0300
Subject: [PATCH 3/3] Clean up
---
testsuite/src/Issue76.hs | 1 -
1 file changed, 1 deletion(-)
diff --git a/testsuite/src/Issue76.hs b/testsuite/src/Issue76.hs
index 31b279d..21451d7 100644
--- a/testsuite/src/Issue76.hs
+++ b/testsuite/src/Issue76.hs
@@ -9,7 +9,6 @@
module Issue76 (main) where
import Control.Concurrent.STM
-import Data.Foldable
import Test.HUnit
main :: IO ()