From c3108b809fa6d1fb7b2db366475087f7a7aaeedd Mon Sep 17 00:00:00 2001
From: Thomas Winant <thomas@well-typed.com>
Date: Thu, 27 Feb 2020 10:20:49 +0100
Subject: [PATCH] Add lengthTBQueue

See `lengthTBQueueDefault` and `MonadSTMTxExtended` for more information.
---
 .../src/Control/Monad/Class/MonadSTM.hs         | 17 +++++++++++++++++
 io-sim/src/Control/Monad/IOSim.hs               |  3 +++
 2 files changed, 20 insertions(+)

diff --git a/io-sim-classes/src/Control/Monad/Class/MonadSTM.hs b/io-sim-classes/src/Control/Monad/Class/MonadSTM.hs
index 6bd900bf8d6..e7b6a42c5f3 100644
--- a/io-sim-classes/src/Control/Monad/Class/MonadSTM.hs
+++ b/io-sim-classes/src/Control/Monad/Class/MonadSTM.hs
@@ -44,6 +44,7 @@ module Control.Monad.Class.MonadSTM
   , writeTBQueueDefault
   , isEmptyTBQueueDefault
   , isFullTBQueueDefault
+  , lengthTBQueueDefault
   ) where
 
 import           Prelude hiding (read)
@@ -423,3 +424,19 @@ isFullTBQueueDefault (TBQueue rsize _read wsize _write _size) = do
          if (r > 0)
             then return False
             else return True
+
+-- 'lengthTBQueue' was added in stm-2.5.0.0, but since we support older
+-- versions of stm, we don't include it as a method in the type class. If we
+-- were to conditionally (@MIN_VERSION_stm(2,5,0)@) include the method in the
+-- type class, the IO simulator would have to conditionally include the
+-- method, requiring a dependency on the @stm@ package, which would be
+-- strange.
+--
+-- Nevertheless, we already provide a default implementation. Downstream
+-- packages that don't mind having a >= 2.5 constraint on stm can use this to
+-- implement 'lengthTBQueue' for the IO simulator.
+lengthTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m Natural
+lengthTBQueueDefault (TBQueue rsize _read wsize _write size) = do
+  r <- readTVar rsize
+  w <- readTVar wsize
+  return $! size - r - w
diff --git a/io-sim/src/Control/Monad/IOSim.hs b/io-sim/src/Control/Monad/IOSim.hs
index c0362a21f0e..e082c14e581 100644
--- a/io-sim/src/Control/Monad/IOSim.hs
+++ b/io-sim/src/Control/Monad/IOSim.hs
@@ -13,6 +13,7 @@
 module Control.Monad.IOSim (
   -- * Simulation monad
   SimM,
+  SimSTM,
   -- ** Run simulation
   runSim,
   runSimOrThrow,
@@ -140,6 +141,8 @@ data StmA s a where
   Retry        :: StmA s b
   OrElse       :: StmA s a -> StmA s a -> (a -> StmA s b) -> StmA s b
 
+-- Exported type
+type SimSTM = STM
 
 data MaskingState = Unmasked | MaskedInterruptible | MaskedUninterruptible
   deriving (Eq, Ord, Show)