diff --git a/io-sim/src/Control/Monad/IOSim/STM.hs b/io-sim/src/Control/Monad/IOSim/STM.hs index 6a3cadc8..9528553e 100644 --- a/io-sim/src/Control/Monad/IOSim/STM.hs +++ b/io-sim/src/Control/Monad/IOSim/STM.hs @@ -96,9 +96,9 @@ tryPeekTQueueDefault (TQueue queue) = do flushTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m [a] flushTQueueDefault (TQueue queue) = do - xs <- uncurry (++) <$> readTVar queue + (xs, ys) <- readTVar queue writeTVar queue ([], []) - pure xs + pure (xs <> reverse ys) unGetTQueueDefault :: MonadSTM m => TQueueDefault m a -> a -> STM m () unGetTQueueDefault (TQueue queue) a = do diff --git a/io-sim/test/Test/Control/Monad/IOSim.hs b/io-sim/test/Test/Control/Monad/IOSim.hs index b1bc2b03..37957507 100644 --- a/io-sim/test/Test/Control/Monad/IOSim.hs +++ b/io-sim/test/Test/Control/Monad/IOSim.hs @@ -177,7 +177,11 @@ tests = prop_registerDelayCancellable_IO ] , testGroup "MonadSTM" - [ testProperty "flushTQueue empties the queue" prop_flushTQueue ] + [ testGroup "flushTQueue" + [ testProperty "empties the queue" prop_flushTQueueEmpties + , testProperty "maintains FIFO order" prop_flushTQueueOrder + ] + ] ] -- @@ -1350,8 +1354,9 @@ prop_registerDelayCancellable_IO = cancelTimeout awaitTimeout -prop_flushTQueue :: Property -prop_flushTQueue = +-- | Test that 'flushTQueue' empties the queue. +prop_flushTQueueEmpties :: Property +prop_flushTQueueEmpties = ioProperty emptyQueueAfterFlush .&&. runSimOrThrow emptyQueueAfterFlush @@ -1363,6 +1368,19 @@ emptyQueueAfterFlush = do _ <- 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 --