Provide MonadTraceMVar

Author: bolt12

io-classes/src/Control/Concurrent/Class/MonadMVar.hs

@@ -7,6 +7,7 @@ module Control.Concurrent.Class.MonadMVar
   ( MonadMVar (..)
     -- * non-standard extensions
   , MonadInspectMVar (..)
+  , MonadTraceMVar (..)
   , MonadLabelledMVar (..)
   ) where
 
@@ -16,6 +17,7 @@ import Control.Monad.Class.MonadThrow
 import Control.Monad.Reader (ReaderT (..))
 import Control.Monad.Trans (lift)
 
+import Control.Concurrent.Class.MonadSTM (TraceValue)
 import Data.Kind (Type)
 
 
@@ -205,6 +207,15 @@ instance MonadInspectMVar IO where
   type InspectMVarMonad IO = IO
   inspectMVar _ = tryReadMVar
 
+class MonadTraceMVar m where
+  traceMVarIO :: proxy
+              -> MVar m a
+              -> (Maybe (Maybe a) -> Maybe a -> InspectMVarMonad m TraceValue)
+              -> m ()
+
+instance MonadTraceMVar IO where
+  traceMVarIO = \_ _ _ -> pure ()
+
 -- | Labelled `MVar`s
 --
 -- The `IO` instances is no-op, the `IOSim` instance enhances simulation trace.

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

@@ -615,6 +615,16 @@ instance MonadInspectMVar (IOSim s) where
         MVarEmpty _ _ -> pure Nothing
         MVarFull x _  -> pure (Just x)
 
+instance MonadTraceMVar (IOSim s) where
+  traceMVarIO _ (MVar mvar) f = traceTVarIO mvar traceMVarAsTVar
+    where
+      traceMVarAsTVar Nothing                (MVarEmpty _ _) = f Nothing         Nothing
+      traceMVarAsTVar Nothing                (MVarFull a _)  = f Nothing         (Just a)
+      traceMVarAsTVar (Just (MVarEmpty _ _)) (MVarEmpty _ _) = f (Just Nothing)  Nothing
+      traceMVarAsTVar (Just (MVarEmpty _ _)) (MVarFull a _)  = f (Just Nothing)  (Just a)
+      traceMVarAsTVar (Just (MVarFull a _))  (MVarEmpty _ _) = f (Just (Just a)) Nothing
+      traceMVarAsTVar (Just (MVarFull a _))  (MVarFull a' _) = f (Just (Just a)) (Just a')
+
 instance MonadLabelledMVar (IOSim s) where
   labelMVar = labelMVarDefault