Merge #3196

3196: io-sim-classes: missing api r=coot a=coot

Fixes issue #3189.

- io-sim-classes: newTBQueueIO for IO and ReaderT instances
- io-sim-classes: added missing api


Co-authored-by: Marcin Szamotulski <[email protected]>

Author: iohk-bors[bot]

io-sim-classes/src/Control/Monad/Class/MonadSTM.hs

@@ -114,6 +114,9 @@ class ( Monad stm
   stateTVar    :: TVar_ stm s -> (s -> (a, s)) -> stm a
   stateTVar    = stateTVarDefault
 
+  swapTVar     :: TVar_ stm a -> a -> stm a
+  swapTVar     = swapTVarDefault
+
   check        :: Bool -> stm ()
   check True = return ()
   check _    = retry
@@ -161,6 +164,11 @@ stateTVarDefault var f = do
    writeTVar var s'
    return a
 
+swapTVarDefault :: MonadSTMTx stm => TVar_ stm a -> a -> stm a
+swapTVarDefault var new = do
+    old <- readTVar var
+    writeTVar var new
+    return old
 
 type TVar    m = TVar_    (STM m)
 type TMVar   m = TMVar_   (STM m)
@@ -176,13 +184,17 @@ class (Monad m, MonadSTMTx (STM m)) => MonadSTM m where
   -- Helpful derived functions with default implementations
 
   newTVarIO        :: a -> m (TVar  m a)
+  readTVarIO       :: TVar m a -> m a
   newTMVarIO       :: a -> m (TMVar m a)
   newEmptyTMVarIO  ::      m (TMVar m a)
+  newTQueueIO      :: m (TQueue m a)
   newTBQueueIO     :: Natural -> m (TBQueue m a)
 
   newTVarIO       = atomically . newTVar
+  readTVarIO      = atomically . readTVar
   newTMVarIO      = atomically . newTMVar
   newEmptyTMVarIO = atomically   newEmptyTMVar
+  newTQueueIO     = atomically newTQueue
   newTBQueueIO    = atomically . newTBQueue
 
 
@@ -247,6 +259,7 @@ instance MonadSTMTx STM.STM where
   modifyTVar     = STM.modifyTVar
   modifyTVar'    = STM.modifyTVar'
   stateTVar      = STM.stateTVar
+  swapTVar       = STM.swapTVar
   check          = STM.check
   newTMVar       = STM.newTMVar
   newEmptyTMVar  = STM.newEmptyTMVar
@@ -283,8 +296,11 @@ instance MonadSTM IO where
   atomically = wrapBlockedIndefinitely . STM.atomically
 
   newTVarIO       = STM.newTVarIO
+  readTVarIO      = STM.readTVarIO
   newTMVarIO      = STM.newTMVarIO
   newEmptyTMVarIO = STM.newEmptyTMVarIO
+  newTQueueIO     = STM.newTQueueIO
+  newTBQueueIO    = STM.newTBQueueIO
 
 -- | noop instance
 --
@@ -326,8 +342,11 @@ instance MonadSTM m => MonadSTM (ReaderT r m) where
   type STM (ReaderT r m) = STM m
   atomically      = lift . atomically
   newTVarIO       = lift . newTVarM
+  readTVarIO      = lift . readTVarIO
   newTMVarIO      = lift . newTMVarM
   newEmptyTMVarIO = lift   newEmptyTMVarM
+  newTQueueIO     = lift   newTQueueIO
+  newTBQueueIO    = lift . newTBQueueIO
 
 --
 -- Default TMVar implementation in terms of TVars (used by sim)

io-sim-classes/src/Control/Monad/Class/MonadSTM/Strict.hs

@@ -22,9 +22,11 @@ module Control.Monad.Class.MonadSTM.Strict
   , newTVarIO
   , newTVarWithInvariantIO
   , readTVar
+  , readTVarIO
   , writeTVar
   , modifyTVar
   , stateTVar
+  , swapTVar
     -- * 'StrictTMVar'
   , StrictTMVar
   , labelTMVar
@@ -57,8 +59,9 @@ import           Control.Monad.Class.MonadSTM as X hiding (LazyTMVar, LazyTVar,
                      labelTMVar, labelTMVarIO, modifyTVar, newEmptyTMVar,
                      newEmptyTMVarIO, newEmptyTMVarM, newTMVar, newTMVarIO,
                      newTMVarM, newTVar, newTVarIO, newTVarM, putTMVar,
-                     readTMVar, readTVar, stateTVar, swapTMVar, takeTMVar,
-                     tryPutTMVar, tryReadTMVar, tryTakeTMVar, writeTVar)
+                     readTMVar, readTVarIO, readTVar, stateTVar, swapTVar,
+                     swapTMVar, takeTMVar, tryPutTMVar, tryReadTMVar,
+                     tryTakeTMVar, writeTVar)
 import qualified Control.Monad.Class.MonadSTM as Lazy
 import           GHC.Stack
 
@@ -98,6 +101,7 @@ toLazyTVar StrictTVar { tvar } = tvar
 
 newTVar :: MonadSTM m => a -> STM m (StrictTVar m a)
 newTVar !a = StrictTVar (const Nothing) <$> Lazy.newTVar a
+
 newTVarIO :: MonadSTM m => a -> m (StrictTVar m a)
 newTVarIO = newTVarWithInvariantIO (const Nothing)
 
@@ -123,6 +127,9 @@ newTVarWithInvariantM = newTVarWithInvariantIO
 readTVar :: MonadSTM m => StrictTVar m a -> STM m a
 readTVar StrictTVar { tvar } = Lazy.readTVar tvar
 
+readTVarIO :: MonadSTM m => StrictTVar m a -> m a
+readTVarIO StrictTVar { tvar } = Lazy.readTVarIO tvar
+
 writeTVar :: (MonadSTM m, HasCallStack) => StrictTVar m a -> a -> STM m ()
 writeTVar StrictTVar { tvar, invariant } !a =
     checkInvariant (invariant a) $
@@ -138,6 +145,13 @@ stateTVar v f = do
     writeTVar v a'
     return b
 
+swapTVar :: MonadSTM m => StrictTVar m a -> a -> STM m a
+swapTVar v a' = do
+    a <- readTVar v
+    writeTVar v a'
+    return a
+
+
 updateTVar :: MonadSTM m => StrictTVar m a -> (a -> (a, b)) -> STM m b
 updateTVar = stateTVar
 {-# DEPRECATED updateTVar "Use stateTVar" #-}