Merge #3647

3647: IOSim MonadFix instance r=coot a=coot



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

Author: iohk-bors[bot]

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

@@ -5,7 +5,10 @@
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE TypeFamilyDependencies     #-}
@@ -16,6 +19,8 @@ module Control.Monad.Class.MonadSTM
   ( MonadSTM (..)
   , MonadLabelledSTM (..)
   , MonadInspectSTM (..)
+  , TraceValue (TraceValue, TraceDynamic, TraceString, DontTrace, traceDynamic,
+                traceString)
   , MonadTraceSTM (..)
   , LazyTVar
   , LazyTMVar
@@ -263,106 +268,128 @@ instance MonadInspectSTM IO where
     inspectTMVar _ = atomically . tryReadTMVar
 
 
+-- | A GADT which instructs how to trace the value.  The 'traceDynamic' will
+-- use dynamic tracing, e.g. 'Control.Monad.IOSim.traceM'; while 'traceString'
+-- will be traced with 'EventSay'.
+--
+data TraceValue where
+    TraceValue :: forall tr. Typeable tr
+               => { traceDynamic :: Maybe tr
+                  , traceString  :: Maybe String
+                  }
+               -> TraceValue
+
+
+-- | Use only dynamic tracer.
+--
+pattern TraceDynamic :: () => forall tr. Typeable tr => tr -> TraceValue
+pattern TraceDynamic tr <- TraceValue { traceDynamic = Just tr }
+  where
+    TraceDynamic tr = TraceValue { traceDynamic = Just tr, traceString = Nothing }
+
+-- | Use only string tracing.
+--
+pattern TraceString :: String -> TraceValue
+pattern TraceString tr <- TraceValue { traceString = Just tr }
+  where
+    TraceString tr = TraceValue { traceDynamic = (Nothing :: Maybe ())
+                                , traceString  = Just tr
+                                }
+
+-- | Do not trace the value.
+--
+pattern DontTrace :: TraceValue
+pattern DontTrace <- TraceValue Nothing Nothing
+  where
+    DontTrace = TraceValue (Nothing :: Maybe ()) Nothing
+
 -- | 'MonadTraceSTM' allows to trace values of stm variables when stm
--- transaction is commited.  This allows to verify invariants when a variable
--- is commited.
+-- transaction is committed.  This allows to verify invariants when a variable
+-- is committed.
 --
 class MonadInspectSTM m
    => MonadTraceSTM m where
   -- | Construct a trace out of previous & new value of a 'TVar'.  The callback
   -- is called whenever an stm transaction which modifies the 'TVar' is
-  -- commited.
+  -- committed.
   --
   -- This is supported by 'IOSim' and 'IOSimPOR'; 'IO' has a trivial instance.
   --
   {-# MINIMAL traceTVar, traceTQueue, traceTBQueue #-}
 
-  traceTVar    :: Typeable tr
-               => proxy m
+  traceTVar    :: proxy m
                -> TVar m a
-               -> (Maybe a -> a -> InspectMonad m tr)
+               -> (Maybe a -> a -> InspectMonad m TraceValue)
                -- ^ callback which receives initial value or 'Nothing' (if it
-               -- is a newly created 'TVar'), and the commited value.
+               -- is a newly created 'TVar'), and the committed value.
                -> STM m ()
 
 
-  traceTMVar   :: Typeable tr
-               => proxy m
+  traceTMVar   :: proxy m
                -> TMVar m a
-               -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m tr)
+               -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
                -> STM m ()
 
-  traceTQueue  :: Typeable tr
-               => proxy m
+  traceTQueue  :: proxy m
                -> TQueue m a
-               -> (Maybe [a] -> [a] -> InspectMonad m tr)
+               -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
                -> STM m ()
 
-  traceTBQueue :: Typeable tr
-               => proxy m
+  traceTBQueue :: proxy m
                -> TBQueue m a
-               -> (Maybe [a] -> [a] -> InspectMonad m tr)
+               -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
                -> STM m ()
 
   default traceTMVar :: ( TMVar m a ~ TMVarDefault m a
-                        , Typeable tr
                         )
                      => proxy m
                      -> TMVar m a
-                     -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m tr)
+                     -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
                      -> STM m ()
   traceTMVar = traceTMVarDefault
 
 
-  traceTVarIO    :: Typeable tr
-                 => proxy m
+  traceTVarIO    :: proxy m
                  -> TVar m a
-                 -> (Maybe a -> a -> InspectMonad m tr)
+                 -> (Maybe a -> a -> InspectMonad m TraceValue)
                  -> m ()
 
-  traceTMVarIO   :: Typeable tr
-                 => proxy m
+  traceTMVarIO   :: proxy m
                  -> TMVar m a
-                 -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m tr)
+                 -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
                  -> m ()
 
-  traceTQueueIO  :: Typeable tr
-                 => proxy m
+  traceTQueueIO  :: proxy m
                  -> TQueue m a
-                 -> (Maybe [a] -> [a] -> InspectMonad m tr)
+                 -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
                  -> m ()
 
-  traceTBQueueIO :: Typeable tr
-                 => proxy m
+  traceTBQueueIO :: proxy m
                  -> TBQueue m a
-                 -> (Maybe [a] -> [a] -> InspectMonad m tr)
+                 -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
                  -> m ()
 
-  default traceTVarIO :: Typeable tr
-                      => proxy m
+  default traceTVarIO :: proxy m
                       -> TVar m a
-                      -> (Maybe a -> a -> InspectMonad m tr)
+                      -> (Maybe a -> a -> InspectMonad m TraceValue)
                       -> m ()
   traceTVarIO = \p v f -> atomically (traceTVar p v f)
 
-  default traceTMVarIO :: Typeable tr
-                       => proxy m
+  default traceTMVarIO :: proxy m
                        -> TMVar m a
-                       -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m tr)
+                       -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
                        -> m ()
   traceTMVarIO = \p v f -> atomically (traceTMVar p v f)
 
-  default traceTQueueIO :: Typeable tr
-                        => proxy m
+  default traceTQueueIO :: proxy m
                         -> TQueue m a
-                        -> (Maybe [a] -> [a] -> InspectMonad m tr)
+                        -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
                         -> m ()
   traceTQueueIO = \p v f -> atomically (traceTQueue p v f)
 
-  default traceTBQueueIO :: Typeable tr
-                         => proxy m
+  default traceTBQueueIO :: proxy m
                          -> TBQueue m a
-                         -> (Maybe [a] -> [a] -> InspectMonad m tr)
+                         -> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
                          -> m ()
   traceTBQueueIO = \p v f -> atomically (traceTBQueue p v f)
 
@@ -480,10 +507,10 @@ labelTMVarDefault
 labelTMVarDefault (TMVar tvar) = labelTVar tvar
 
 traceTMVarDefault
-  :: (MonadTraceSTM m, Typeable tr)
+  :: MonadTraceSTM m
   => proxy m
   -> TMVarDefault m a
-  -> (Maybe (Maybe a) -> Maybe a -> InspectMonad m tr)
+  -> (Maybe (Maybe a) -> Maybe a -> InspectMonad m TraceValue)
   -> STM m ()
 traceTMVarDefault p (TMVar t) f = traceTVar p t f
 
@@ -764,7 +791,7 @@ throwSTM :: (MonadSTM m, MonadThrow.MonadThrow (STM m), Exception e)
 throwSTM = MonadThrow.throwIO
 
 
--- | 'catch' speclialized for an @stm@ monad.
+-- | 'catch' specialized for an @stm@ monad.
 --
 catchSTM :: (MonadSTM m, MonadThrow.MonadCatch (STM m), Exception e)
          => STM m a -> (e -> STM m a) -> STM m a
@@ -797,8 +824,8 @@ deriving instance MonadSTM m => MonadPlus   (WrappedSTM t r m)
 -- extension because it violates 3rd Paterson condition, however `STM m` will
 -- resolve to a concrete type of kind (Type -> Type), and thus no larger than
 -- `m` itself, e.g. for `m ~ ReaderT r f`, `STM m ~ WrappedSTM Reader r f`.
--- Instance resolution will termniate as soon as the monad transformer stack
--- depth is exhousted.
+-- Instance resolution will terminate as soon as the monad transformer stack
+-- depth is exhausted.
 instance ( MonadSTM m
          , MonadThrow.MonadThrow (STM m)
          , MonadThrow.MonadCatch (STM m)

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

@@ -333,15 +333,23 @@ ppEvents :: [(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
          -> String
 ppEvents events =
     intercalate "\n"
-      [ ppSimEvent width
+      [ ppSimEvent timeWidth tidWidth width
                    SimEvent {seTime, seThreadId, seThreadLabel, seType }
       | (seTime, seThreadId, seThreadLabel, seType) <- events
       ]
   where
-    width = maximum
-              [ maybe 0 length threadLabel
-              | (_, _, threadLabel, _) <- events
-              ]
+    timeWidth = maximum
+                [ length (show t)
+                | (t, _, _, _) <- events
+                ]
+    tidWidth  = maximum
+                [ length (show tid)
+                | (_, tid, _, _) <- events
+                ]
+    width     = maximum
+                [ maybe 0 length threadLabel
+                | (_, _, threadLabel, _) <- events
+                ]
 
 
 -- | See 'runSimTraceST' below.

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

@@ -7,13 +7,13 @@
 --
 module Control.Monad.IOSim.CommonTypes where
 
+import           Control.Monad.Class.MonadSTM (TraceValue)
 import           Control.Monad.ST.Lazy
 
 import           Data.Function (on)
 import           Data.Map (Map)
 import           Data.Set (Set)
 import           Data.STRef.Lazy
-import           Data.Typeable (Typeable)
 
 data ThreadId = RacyThreadId [Int]
               | ThreadId     [Int]    -- non racy threads have higher priority
@@ -72,16 +72,12 @@ data TVar s a = TVar {
 
        -- | Callback to construct a trace which will be attached to the dynamic
        -- trace.
-       tvarTrace  :: !(STRef s (Maybe (MkTVarTrace s a)))
+       tvarTrace  :: !(STRef s (Maybe (Maybe a -> a -> ST s TraceValue)))
      }
 
 instance Eq (TVar s a) where
     (==) = on (==) tvarId
 
-data MkTVarTrace s a where
-    MkTVarTrace :: forall s a tr. Typeable tr => (Maybe a -> a -> ST s tr)
-                -> MkTVarTrace s a
-
 data SomeTVar s where
   SomeTVar :: !(TVar s a) -> SomeTVar s