From 419679b0229be05b28fe378d1087b101a7a9bd4c Mon Sep 17 00:00:00 2001
From: Sebastian Nagel <sebastian.nagel@ncoding.at>
Date: Tue, 30 Jan 2024 12:19:26 +0100
Subject: [PATCH] Remove wrong implementation of TQueue in io-sim

Fixes #133 by using the default implementation of MonadSTM.
---
 .../Control/Concurrent/Class/MonadSTM/TQueue.hs   |  2 +-
 .../src/Control/Monad/Class/MonadSTM/Internal.hs  |  2 +-
 io-sim/CHANGELOG.md                               |  1 +
 io-sim/io-sim.cabal                               |  2 +-
 io-sim/src/Control/Monad/IOSim/STM.hs             |  5 ++++-
 io-sim/test/Test/Control/Monad/IOSim.hs           | 15 +++++++++++++++
 6 files changed, 23 insertions(+), 4 deletions(-)

diff --git a/io-classes/src/Control/Concurrent/Class/MonadSTM/TQueue.hs b/io-classes/src/Control/Concurrent/Class/MonadSTM/TQueue.hs
index a3d0682f..f2cbc5c6 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 b5ada17b..861e9bc0 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/io-sim.cabal b/io-sim/io-sim.cabal
index 0c1965c5..13117d25 100644
--- 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
index 681cf4dd..302d986b 100644
--- 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
index 7cd0bec2..e783da50 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
 --