io-sim: Fix flushTQueue implementation

io-classes/CHANGELOG.md

@@ -8,6 +8,8 @@
 
 ### Non-breaking changes
 
+* Fixed some module haddock typos.
+
 ## 1.3.1.0
 
 ### Non-breaking changes

io-classes/src/Control/Concurrent/Class/MonadSTM/TQueue.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE ExplicitNamespaces #-}
 
--- | This module corresponds to `Control.Concurrnet.STM.TVar` in "stm" package
+-- | This module corresponds to `Control.Concurrent.STM.TQueue` in "stm" package
 --
 module Control.Concurrent.Class.MonadSTM.TQueue
   ( -- * MonadSTM

io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs

@@ -48,7 +48,7 @@ module Control.Monad.Class.MonadSTM.Internal
   , isEmptyTMVarDefault
   , labelTMVarDefault
   , traceTMVarDefault
-    -- ** Default 'TBQueue' implementation
+    -- ** Default 'TQueue' implementation
   , TQueueDefault (..)
   , newTQueueDefault
   , writeTQueueDefault

io-sim/CHANGELOG.md

@@ -9,6 +9,7 @@
 ### Non-breaking changes
 
 * `Alternative` & `MonadPlus` instances for `IOSim`.
+* Fixed `flushTQueue` implemetation.
 
 ## 1.3.1.0
 

io-sim/src/Control/Monad/IOSim/STM.hs

@@ -95,7 +95,10 @@ tryPeekTQueueDefault (TQueue queue) = do
       []   -> Nothing
 
 flushTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m [a]
-flushTQueueDefault (TQueue queue) = uncurry (++) <$> readTVar queue
+flushTQueueDefault (TQueue queue) = do
+  (xs, ys) <- readTVar queue
+  writeTVar queue ([], [])
+  pure (xs <> reverse ys)
 
 unGetTQueueDefault :: MonadSTM m => TQueueDefault m a -> a -> STM m ()
 unGetTQueueDefault (TQueue queue) a = do

io-sim/test/Test/Control/Monad/IOSim.hs

@@ -176,6 +176,12 @@ tests =
     , testProperty "registerDelayCancellable (IO impl)"
         prop_registerDelayCancellable_IO
     ]
+  , testGroup "MonadSTM"
+    [ testGroup "flushTQueue"
+      [ testProperty "empties the queue" prop_flushTQueueEmpties
+      , testProperty "maintains FIFO order" prop_flushTQueueOrder
+      ]
+    ]
   ]
 
 --
@@ -1348,6 +1354,33 @@ prop_registerDelayCancellable_IO =
         cancelTimeout
         awaitTimeout
 
+-- | Test that 'flushTQueue' empties the queue.
+prop_flushTQueueEmpties :: Property
+prop_flushTQueueEmpties =
+  ioProperty emptyQueueAfterFlush
+  .&&. runSimOrThrow emptyQueueAfterFlush
+
+emptyQueueAfterFlush :: MonadSTM m => m Bool
+emptyQueueAfterFlush = do
+  q <- newTQueueIO
+  atomically $ do
+    writeTQueue q (1 :: Int)
+    _ <- flushTQueue q
+    isEmptyTQueue q
+
+-- | Test that 'flushTQueue' returns values in FIFO order.
+prop_flushTQueueOrder :: [Int] -> Property
+prop_flushTQueueOrder entries =
+  ioProperty (writeAndFlushQueue entries >>= \actual -> pure $ actual === entries)
+  .&&. runSimOrThrow (writeAndFlushQueue entries) === entries
+
+writeAndFlushQueue :: MonadSTM m => [Int] -> m [Int]
+writeAndFlushQueue entries =
+  atomically $ do
+    q <- newTQueue
+    forM_ entries $ writeTQueue q
+    flushTQueue q
+
 --
 -- Utils
 --