MonadSTM: default implementations

Provide default implementations as part of `MonadSTM`,
`MonadLabelledSTM` classes.

Fixes IntersectMBO/ouroboros-network#3608

Author: coot

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

@@ -27,43 +27,10 @@ module Control.Monad.Class.MonadSTM
   , LazyTMVar
     -- * Default 'TMVar' implementation
   , TMVarDefault (..)
-  , labelTMVarDefault
-  , traceTMVarDefault
-  , newTMVarDefault
-  , newTMVarIODefault
-  , newEmptyTMVarDefault
-  , newEmptyTMVarIODefault
-  , takeTMVarDefault
-  , tryTakeTMVarDefault
-  , putTMVarDefault
-  , tryPutTMVarDefault
-  , readTMVarDefault
-  , tryReadTMVarDefault
-  , swapTMVarDefault
-  , isEmptyTMVarDefault
     -- * Default 'TBQueue' implementation
   , TQueueDefault (..)
-  , labelTQueueDefault
-  , newTQueueDefault
-  , readTQueueDefault
-  , tryReadTQueueDefault
-  , peekTQueueDefault
-  , tryPeekTQueueDefault
-  , writeTQueueDefault
-  , isEmptyTQueueDefault
     -- * Default 'TBQueue' implementation
   , TBQueueDefault (..)
-  , labelTBQueueDefault
-  , newTBQueueDefault
-  , readTBQueueDefault
-  , tryReadTBQueueDefault
-  , peekTBQueueDefault
-  , tryPeekTBQueueDefault
-  , writeTBQueueDefault
-  , isEmptyTBQueueDefault
-  , isFullTBQueueDefault
-  , lengthTBQueueDefault
-  , flushTBQueueDefault
     -- * MonadThrow aliases
   , throwSTM
   , catchSTM
@@ -73,7 +40,7 @@ module Control.Monad.Class.MonadSTM
   , newTMVarMDefault
   , newEmptyTMVarM
   , newEmptyTMVarMDefault
-    --
+    -- * Utils
   , WrappedSTM (..)
   ) where
 
@@ -188,13 +155,123 @@ class ( Monad m
   newTQueueIO      :: m (TQueue m a)
   newTBQueueIO     :: Natural -> m (TBQueue m a)
 
+  --
+  -- default implementations
+  --
+
+  default newTMVar :: TMVar m ~ TMVarDefault m
+                   => a -> STM m (TMVar m a)
+  newTMVar = newTMVarDefault
+
+  default newEmptyTMVar :: TMVar m ~ TMVarDefault m
+                        => STM m (TMVar m a)
+  newEmptyTMVar = newEmptyTMVarDefault
+
   newTVarIO       = atomically . newTVar
   readTVarIO      = atomically . readTVar
   newTMVarIO      = atomically . newTMVar
   newEmptyTMVarIO = atomically   newEmptyTMVar
   newTQueueIO     = atomically newTQueue
   newTBQueueIO    = atomically . newTBQueue
 
+  default takeTMVar :: TMVar m ~ TMVarDefault m
+                    => TMVar m a -> STM m a
+  takeTMVar = takeTMVarDefault
+
+  default tryTakeTMVar :: TMVar m ~ TMVarDefault m
+                       => TMVar m a -> STM m (Maybe a)
+  tryTakeTMVar = tryTakeTMVarDefault
+
+  default putTMVar :: TMVar m ~ TMVarDefault m => TMVar m a -> a -> STM m ()
+  putTMVar = putTMVarDefault
+
+  default tryPutTMVar :: TMVar m ~ TMVarDefault m => TMVar m a -> a -> STM m Bool
+  tryPutTMVar = tryPutTMVarDefault
+
+  default readTMVar :: TMVar m ~ TMVarDefault m
+                    => TMVar m a -> STM m a
+  readTMVar = readTMVarDefault
+
+  default tryReadTMVar :: TMVar m ~ TMVarDefault m
+                    => TMVar m a -> STM m (Maybe a)
+  tryReadTMVar = tryReadTMVarDefault
+
+  default swapTMVar :: TMVar m ~ TMVarDefault m
+                    => TMVar m a -> a -> STM m a
+  swapTMVar = swapTMVarDefault
+
+  default isEmptyTMVar :: TMVar m ~ TMVarDefault m
+                       => TMVar m a -> STM m Bool
+  isEmptyTMVar = isEmptyTMVarDefault
+
+  default newTQueue :: TQueue m ~ TQueueDefault m
+                    => STM m (TQueue m a)
+  newTQueue = newTQueueDefault
+
+  default writeTQueue :: TQueue m ~ TQueueDefault m
+                      => TQueue m a -> a -> STM m ()
+  writeTQueue = writeTQueueDefault
+
+  default readTQueue :: TQueue m ~ TQueueDefault m
+                     => TQueue m a -> STM m a
+  readTQueue = readTQueueDefault
+
+  default tryReadTQueue :: TQueue m ~ TQueueDefault m
+                         => TQueue m a -> STM m (Maybe a)
+  tryReadTQueue = tryReadTQueueDefault
+
+  default isEmptyTQueue :: TQueue m ~ TQueueDefault m
+                        => TQueue m a -> STM m Bool
+  isEmptyTQueue = isEmptyTQueueDefault
+
+  default peekTQueue :: TQueue m ~ TQueueDefault m
+                     => TQueue m a -> STM m a
+  peekTQueue = peekTQueueDefault
+
+  default tryPeekTQueue :: TQueue m ~ TQueueDefault m
+                        => TQueue m a -> STM m (Maybe a)
+  tryPeekTQueue = tryPeekTQueueDefault
+
+  default newTBQueue :: TBQueue m ~ TBQueueDefault m
+                     => Natural -> STM m (TBQueue m a)
+  newTBQueue = newTBQueueDefault
+
+  default writeTBQueue :: TBQueue m ~ TBQueueDefault m
+                       => TBQueue m a -> a -> STM m ()
+  writeTBQueue = writeTBQueueDefault
+
+  default readTBQueue :: TBQueue m ~ TBQueueDefault m
+                      => TBQueue m a -> STM m a
+  readTBQueue = readTBQueueDefault
+
+  default tryReadTBQueue :: TBQueue m ~ TBQueueDefault m
+                          => TBQueue m a -> STM m (Maybe a)
+  tryReadTBQueue = tryReadTBQueueDefault
+
+  default isEmptyTBQueue :: TBQueue m ~ TBQueueDefault m
+                         => TBQueue m a -> STM m Bool
+  isEmptyTBQueue = isEmptyTBQueueDefault
+
+  default peekTBQueue :: TBQueue m ~ TBQueueDefault m
+                      => TBQueue m a -> STM m a
+  peekTBQueue = peekTBQueueDefault
+
+  default tryPeekTBQueue :: TBQueue m ~ TBQueueDefault m
+                         => TBQueue m a -> STM m (Maybe a)
+  tryPeekTBQueue = tryPeekTBQueueDefault
+
+  default isFullTBQueue :: TBQueue m ~ TBQueueDefault m
+                        => TBQueue m a -> STM m Bool
+  isFullTBQueue = isFullTBQueueDefault
+
+  default lengthTBQueue :: TBQueue m ~ TBQueueDefault m
+                        => TBQueue m a -> STM m Natural
+  lengthTBQueue = lengthTBQueueDefault
+
+  default flushTBQueue :: TBQueue m ~ TBQueueDefault m
+                       => TBQueue m a -> STM m [a]
+  flushTBQueue = flushTBQueueDefault
+
 
 stateTVarDefault :: MonadSTM m => TVar m s -> (s -> (a, s)) -> STM m a
 stateTVarDefault var f = do
@@ -237,6 +314,22 @@ class MonadSTM m
   labelTQueueIO  :: TQueue  m a -> String -> m ()
   labelTBQueueIO :: TBQueue m a -> String -> m ()
 
+  --
+  -- default implementations
+  --
+
+  default labelTMVar :: TMVar m ~ TMVarDefault m
+                     => TMVar m a -> String -> STM m ()
+  labelTMVar = labelTMVarDefault
+
+  default labelTQueue :: TQueue m ~ TQueueDefault m
+                      => TQueue m a -> String -> STM m ()
+  labelTQueue = labelTQueueDefault
+
+  default labelTBQueue :: TBQueue m ~ TBQueueDefault m
+                       => TBQueue m a -> String -> STM m ()
+  labelTBQueue = labelTBQueueDefault
+
   default labelTVarIO :: TVar m a -> String -> m ()
   labelTVarIO = \v l -> atomically (labelTVar v l)
 
@@ -524,6 +617,7 @@ newTMVarIODefault :: MonadSTM m => a -> m (TMVarDefault m a)
 newTMVarIODefault a = do
   t <- newTVarM (Just a)
   return (TMVar t)
+{-# DEPRECATED newTMVarIODefault "MonadSTM provides a default implementation" #-}
 
 newTMVarMDefault :: MonadSTM m => a -> m (TMVarDefault m a)
 newTMVarMDefault = newTMVarIODefault
@@ -538,6 +632,7 @@ newEmptyTMVarIODefault :: MonadSTM m => m (TMVarDefault m a)
 newEmptyTMVarIODefault = do
   t <- newTVarIO Nothing
   return (TMVar t)
+{-# DEPRECATED newEmptyTMVarIODefault "MonadSTM provides a default implementation" #-}
 
 newEmptyTMVarMDefault :: MonadSTM m => m (TMVarDefault m a)
 newEmptyTMVarMDefault = newEmptyTMVarIODefault

io-sim/src/Control/Monad/IOSim/STM.hs

@@ -14,7 +14,7 @@ import           Control.Monad.Class.MonadSTM (MonadInspectSTM (..),
 import           Numeric.Natural (Natural)
 
 --
--- Default TQueue implementation in terms of 'Seq' (used by sim)
+-- Default TQueue implementation in terms of a 'TVar' (used by sim)
 --
 
 newtype TQueueDefault m a = TQueue (TVar m ([a], [a]))

io-sim/src/Control/Monad/IOSim/Types.hs

@@ -382,7 +382,6 @@ instance MonadSay (STMSim s) where
 
 instance MonadLabelledSTM (IOSim s) where
   labelTVar tvar label = STM $ \k -> LabelTVar label tvar (k ())
-  labelTMVar   = MonadSTM.labelTMVarDefault
   labelTQueue  = labelTQueueDefault
   labelTBQueue = labelTBQueueDefault
 
@@ -401,17 +400,6 @@ instance MonadSTM (IOSim s) where
   retry             = STM $ oneShot $ \_ -> Retry
   orElse        a b = STM $ oneShot $ \k -> OrElse (runSTM a) (runSTM b) k
 
-  newTMVar          = MonadSTM.newTMVarDefault
-  newEmptyTMVar     = MonadSTM.newEmptyTMVarDefault
-  takeTMVar         = MonadSTM.takeTMVarDefault
-  tryTakeTMVar      = MonadSTM.tryTakeTMVarDefault
-  putTMVar          = MonadSTM.putTMVarDefault
-  tryPutTMVar       = MonadSTM.tryPutTMVarDefault
-  readTMVar         = MonadSTM.readTMVarDefault
-  tryReadTMVar      = MonadSTM.tryReadTMVarDefault
-  swapTMVar         = MonadSTM.swapTMVarDefault
-  isEmptyTMVar      = MonadSTM.isEmptyTMVarDefault
-
   newTQueue         = newTQueueDefault
   readTQueue        = readTQueueDefault
   tryReadTQueue     = tryReadTQueueDefault
@@ -431,9 +419,6 @@ instance MonadSTM (IOSim s) where
   isEmptyTBQueue    = isEmptyTBQueueDefault
   isFullTBQueue     = isFullTBQueueDefault
 
-  newTMVarIO        = MonadSTM.newTMVarIODefault
-  newEmptyTMVarIO   = MonadSTM.newEmptyTMVarIODefault
-
 instance MonadInspectSTM (IOSim s) where
   type InspectMonad (IOSim s) = ST s
   inspectTVar  _                 TVar { tvarCurrent }  = readSTRef tvarCurrent