Fix flushTBQueue and provide a test

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.

testsuite/src/Issue76.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE CPP #-}
+
+-- See https://github.com/haskell/stm/pull/76.
+--
+-- Test-case contributed by Nikita Volkov <[email protected]>.
+--
+-- This bug is observable in version `stm-2.5.2.1`.
+
+module Issue76 (main) where
+
+import Control.Concurrent.STM
+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

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

testsuite/testsuite.cabal

@@ -20,6 +20,7 @@ test-suite stm
   main-is: Main.hs
   other-modules:
     Issue9
+    Issue76
     Stm052
     Stm064
     Stm065