From b1ff8fa9f83ee74d31708437260f6f2a5a7a59c9 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Tue, 30 Jan 2024 12:19:26 +0100 Subject: [PATCH 1/2] io-sim: Fix flushTQueue implementation Fixes #133 --- io-classes/CHANGELOG.md | 2 ++ .../Control/Concurrent/Class/MonadSTM/TQueue.hs | 2 +- .../src/Control/Monad/Class/MonadSTM/Internal.hs | 2 +- io-sim/CHANGELOG.md | 1 + io-sim/src/Control/Monad/IOSim/STM.hs | 5 ++++- io-sim/test/Test/Control/Monad/IOSim.hs | 15 +++++++++++++++ 6 files changed, 24 insertions(+), 3 deletions(-) diff --git a/io-classes/CHANGELOG.md b/io-classes/CHANGELOG.md index bc227f7f..0ea39d70 100644 --- a/io-classes/CHANGELOG.md +++ b/io-classes/CHANGELOG.md @@ -8,6 +8,8 @@ ### Non-breaking changes +* Fixed some module haddock typos. + ## 1.3.1.0 ### Non-breaking changes diff --git a/io-classes/src/Control/Concurrent/Class/MonadSTM/TQueue.hs b/io-classes/src/Control/Concurrent/Class/MonadSTM/TQueue.hs index 5f21f413..1423bbff 100644 --- a/io-classes/src/Control/Concurrent/Class/MonadSTM/TQueue.hs +++ b/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 diff --git a/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs b/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs index 46e34b02..258862df 100644 --- a/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs +++ b/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 diff --git a/io-sim/CHANGELOG.md b/io-sim/CHANGELOG.md index 7565b770..d1240e27 100644 --- a/io-sim/CHANGELOG.md +++ b/io-sim/CHANGELOG.md @@ -9,6 +9,7 @@ ### Non-breaking changes * `Alternative` & `MonadPlus` instances for `IOSim`. +* Fixed `flushTQueue` implemetation. ## 1.3.1.0 diff --git a/io-sim/src/Control/Monad/IOSim/STM.hs b/io-sim/src/Control/Monad/IOSim/STM.hs index dd57ae8a..6a3cadc8 100644 --- a/io-sim/src/Control/Monad/IOSim/STM.hs +++ b/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 <- uncurry (++) <$> readTVar queue + writeTVar queue ([], []) + pure xs 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 506ad0d5..b1bc2b03 100644 --- a/io-sim/test/Test/Control/Monad/IOSim.hs +++ b/io-sim/test/Test/Control/Monad/IOSim.hs @@ -176,6 +176,8 @@ tests = , testProperty "registerDelayCancellable (IO impl)" prop_registerDelayCancellable_IO ] + , testGroup "MonadSTM" + [ testProperty "flushTQueue empties the queue" prop_flushTQueue ] ] -- @@ -1348,6 +1350,19 @@ prop_registerDelayCancellable_IO = cancelTimeout awaitTimeout +prop_flushTQueue :: Property +prop_flushTQueue = + ioProperty emptyQueueAfterFlush + .&&. runSimOrThrow emptyQueueAfterFlush + +emptyQueueAfterFlush :: MonadSTM m => m Bool +emptyQueueAfterFlush = do + q <- newTQueueIO + atomically $ do + writeTQueue q (1 :: Int) + _ <- flushTQueue q + isEmptyTQueue q + -- -- Utils -- From 959ecec30c33500f27700e966b936d10c7f31202 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Wed, 31 Jan 2024 11:14:12 +0100 Subject: [PATCH 2/2] io-sim: Fix flushTQueue to maintain --- io-sim/src/Control/Monad/IOSim/STM.hs | 4 ++-- io-sim/test/Test/Control/Monad/IOSim.hs | 24 +++++++++++++++++++++--- 2 files changed, 23 insertions(+), 5 deletions(-) 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 --