Remove wrong implementation of TQueue in io-sim

Fixes #133 by using the default implementation of MonadSTM.
input-output-hk · Jan 30, 2024 · 419679b · 419679b
1 parent 432005c
commit 419679b
Show file tree

Hide file tree

Showing 6 changed files with 23 additions and 4 deletions.
diff --git 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
@@ -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
@@ -9,6 +9,7 @@
 ### Non-breaking changes
 
 * `Alternative` & `MonadPlus` instances for `IOSim`.
+* Fixed `flushTQueue` implemetation.
 
 ## 1.3.1.0
 

diff --git a/io-sim/io-sim.cabal b/io-sim/io-sim.cabal
@@ -1,6 +1,6 @@
 cabal-version:       3.0
 name:                io-sim
-version:             1.3.1.0
+version:             1.3.1.1
 synopsis:            A pure simulator for monadic concurrency with STM.
 description:
   A pure simulator monad with support of concurency (base, async), stm,

diff --git a/io-sim/src/Control/Monad/IOSim/STM.hs b/io-sim/src/Control/Monad/IOSim/STM.hs
@@ -96,7 +96,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
@@ -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
 --