Fix windex not being updated in flushTBQueue

haskell · Nov 17, 2023 · 533a145 · 533a145
1 parent 3671291
commit 533a145
Show file tree

Hide file tree

Showing 2 changed files with 15 additions and 2 deletions.
diff --git a/Control/Concurrent/STM/TBQueue.hs b/Control/Concurrent/STM/TBQueue.hs
@@ -143,9 +143,11 @@ 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
+flushTBQueue (TBQueue rindex windex elements cap) = do
   w <- readTVar windex
-  go (decMod w cap) []
+  res <- go (decMod w cap) []
+  writeTVar windex =<< readTVar rindex
+  pure res
  where
   go :: Int -> [a] -> STM [a]
   go i acc = do

diff --git a/testsuite/src/Main.hs b/testsuite/src/Main.hs
@@ -4,6 +4,9 @@ module Main where
 
 import           Test.Framework                 (defaultMain, testGroup)
 import           Test.Framework.Providers.HUnit
+import           Test.HUnit
+
+import Control.Concurrent.STM
 
 import qualified Issue9
 import qualified Stm052
@@ -21,6 +24,14 @@ main = do
         , testCase "stm052" Stm052.main
         , testCase "stm064" Stm064.main
         , testCase "stm065" Stm065.main
+        , testCase "issue #76" $ do
+            queue <- newTBQueueIO 100
+            len <- atomically $ do
+              writeTBQueue queue (1 :: Int)
+              writeTBQueue queue 2
+              _ <- flushTBQueue queue
+              lengthTBQueue queue
+            len @?= 0
         ]
       ]