Merge #3371

3371: CAD-3444 io-sim changes from p2p-master r=coot a=coot

- io-sim: selectTraceEvents' and friends
- io-sim: Octopus
- io-sim: added pretty printers
- io-sim: log EventMask
- io-sim: label Async's TVar


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

Author: iohk-bors[bot]

io-sim/io-sim.cabal

@@ -25,7 +25,8 @@ source-repository head
 
 library
   hs-source-dirs:      src
-  exposed-modules:     Control.Monad.IOSim
+  exposed-modules:     Data.List.Trace
+                     , Control.Monad.IOSim
   other-modules:       Control.Monad.IOSim.Internal
   default-language:    Haskell2010
   other-extensions:    BangPatterns,

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

@@ -1,3 +1,5 @@
+{-# LANGUAGE ExplicitNamespaces  #-}
+{-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -19,15 +21,27 @@ module Control.Monad.IOSim (
   setCurrentTime,
   unshareClock,
   -- * Simulation trace
-  Trace(..),
-  TraceEvent(..),
+  type SimTrace,
+  Trace (Cons, Nil, Trace, SimTrace, TraceMainReturn, TraceMainException, TraceDeadlock),
+  ppTrace,
+  ppTrace_,
+  ppEvents,
+  SimResult(..),
+  SimEvent(..),
+  SimEventType(..),
   ThreadLabel,
   Labelled (..),
   traceEvents,
   traceResult,
   selectTraceEvents,
+  selectTraceEvents',
   selectTraceEventsDynamic,
+  selectTraceEventsDynamic',
   selectTraceEventsSay,
+  selectTraceEventsSay',
+  traceSelectTraceEvents,
+  traceSelectTraceEventsDynamic,
+  traceSelectTraceEventsSay,
   printTraceEventsSay,
   -- * Eventlog
   EventlogEvent(..),
@@ -36,15 +50,19 @@ module Control.Monad.IOSim (
   execReadTVar,
   -- * Deprecated interfaces
   SimM,
-  SimSTM
+  SimSTM,
+  TraceEvent
   ) where
 
 import           Prelude
 
 import           Data.Dynamic (fromDynamic)
 import           Data.List (intercalate)
+import           Data.Bifoldable
 import           Data.Typeable (Typeable)
 
+import           Data.List.Trace (Trace (..))
+
 import           Control.Exception (throw)
 
 import           Control.Monad.ST.Lazy
@@ -56,48 +74,115 @@ import           Control.Monad.IOSim.Internal
 
 
 selectTraceEvents
-    :: (TraceEvent -> Maybe b)
-    -> Trace a
+    :: (SimEventType -> Maybe b)
+    -> SimTrace a
     -> [b]
-selectTraceEvents fn = go
-  where
-    go (Trace _ _ _ ev trace) = case fn ev of
-      Just x  -> x : go trace
-      Nothing ->     go trace
-    go (TraceMainException _ e _)       = throw (FailureException e)
-    go (TraceDeadlock      _   threads) = throw (FailureDeadlock threads)
-    go (TraceMainReturn    _ _ _)       = []
+selectTraceEvents fn =
+      bifoldr ( \ v _
+               -> case v of
+                    MainException _ e _       -> throw (FailureException e)
+                    Deadlock      _   threads -> throw (FailureDeadlock threads)
+                    MainReturn    _ _ _       -> []
+              )
+              ( \ b acc -> b : acc )
+              []
+    . traceSelectTraceEvents fn
+
+selectTraceEvents'
+    :: (SimEventType -> Maybe b)
+    -> SimTrace a
+    -> [b]
+selectTraceEvents' fn =
+      bifoldr ( \ _ _   -> []  )
+              ( \ b acc -> b : acc )
+              []
+    . traceSelectTraceEvents fn
 
 -- | Select all the traced values matching the expected type. This relies on
 -- the sim's dynamic trace facility.
 --
 -- For convenience, this throws exceptions for abnormal sim termination.
 --
-selectTraceEventsDynamic :: forall a b. Typeable b => Trace a -> [b]
+selectTraceEventsDynamic :: forall a b. Typeable b => SimTrace a -> [b]
 selectTraceEventsDynamic = selectTraceEvents fn
   where
-    fn :: TraceEvent -> Maybe b
+    fn :: SimEventType -> Maybe b
+    fn (EventLog dyn) = fromDynamic dyn
+    fn _              = Nothing
+
+-- | Like 'selectTraceEventsDynamic' but returns partial trace if an exception
+-- is found in it.
+--
+selectTraceEventsDynamic' :: forall a b. Typeable b => SimTrace a -> [b]
+selectTraceEventsDynamic' = selectTraceEvents' fn
+  where
+    fn :: SimEventType -> Maybe b
     fn (EventLog dyn) = fromDynamic dyn
     fn _              = Nothing
 
 -- | Get a trace of 'EventSay'.
 --
 -- For convenience, this throws exceptions for abnormal sim termination.
 --
-selectTraceEventsSay :: Trace a -> [String]
+selectTraceEventsSay :: SimTrace a -> [String]
 selectTraceEventsSay = selectTraceEvents fn
   where
-    fn :: TraceEvent -> Maybe String
+    fn :: SimEventType -> Maybe String
+    fn (EventSay s) = Just s
+    fn _            = Nothing
+
+-- | Like 'selectTraceEventsSay' but return partial trace if an exception is
+-- found in it.
+--
+selectTraceEventsSay' :: SimTrace a -> [String]
+selectTraceEventsSay' = selectTraceEvents' fn
+  where
+    fn :: SimEventType -> Maybe String
     fn (EventSay s) = Just s
     fn _            = Nothing
 
 -- | Print all 'EventSay' to the console.
 --
 -- For convenience, this throws exceptions for abnormal sim termination.
 --
-printTraceEventsSay :: Trace a -> IO ()
+printTraceEventsSay :: SimTrace a -> IO ()
 printTraceEventsSay = mapM_ print . selectTraceEventsSay
 
+
+-- | The most general select function.  It is a _total_ function.
+--
+traceSelectTraceEvents
+    :: (SimEventType -> Maybe b)
+    -> SimTrace a
+    -> Trace (SimResult a) b
+traceSelectTraceEvents fn = bifoldr ( \ v _acc -> Nil v )
+                                    ( \ eventCtx acc
+                                     -> case fn (seType eventCtx) of
+                                          Nothing -> acc
+                                          Just b  -> Cons b acc
+                                    )
+                                    undefined -- it is ignored
+
+-- | Select dynamic events.  It is a _total_ function.
+--
+traceSelectTraceEventsDynamic :: forall a b. Typeable b
+                              => SimTrace a -> Trace (SimResult a) b
+traceSelectTraceEventsDynamic = traceSelectTraceEvents fn
+  where
+    fn :: SimEventType -> Maybe b
+    fn (EventLog dyn) = fromDynamic dyn
+    fn _              = Nothing
+
+
+-- | Select say events.  It is a _total_ function.
+--
+traceSelectTraceEventsSay :: forall a.  SimTrace a -> Trace (SimResult a) String
+traceSelectTraceEventsSay = traceSelectTraceEvents fn
+  where
+    fn :: SimEventType -> Maybe String
+    fn (EventSay s) = Just s
+    fn _            = Nothing
+
 -- | Simulation termination with failure
 --
 data Failure =
@@ -147,24 +232,37 @@ runSimOrThrow mainAction =
 runSimStrictShutdown :: forall a. (forall s. IOSim s a) -> Either Failure a
 runSimStrictShutdown mainAction = traceResult True (runSimTrace mainAction)
 
-traceResult :: Bool -> Trace a -> Either Failure a
+traceResult :: Bool -> SimTrace a -> Either Failure a
 traceResult strict = go
   where
-    go (Trace _ _ _ _ t)                = go t
+    go (SimTrace _ _ _ _ t)             = go t
     go (TraceMainReturn _ _ tids@(_:_))
                                | strict = Left (FailureSloppyShutdown tids)
     go (TraceMainReturn _ x _)          = Right x
     go (TraceMainException _ e _)       = Left (FailureException e)
     go (TraceDeadlock   _   threads)    = Left (FailureDeadlock threads)
 
-traceEvents :: Trace a -> [(Time, ThreadId, Maybe ThreadLabel, TraceEvent)]
-traceEvents (Trace time tid tlbl event t) = (time, tid, tlbl, event)
-                                          : traceEvents t
-traceEvents _                             = []
+traceEvents :: SimTrace a -> [(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
+traceEvents (SimTrace time tid tlbl event t) = (time, tid, tlbl, event)
+                                             : traceEvents t
+traceEvents _                                = []
 
+ppEvents :: [(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
+         -> String
+ppEvents events =
+    intercalate "\n"
+      [ ppSimEvent width
+                   SimEvent {seTime, seThreadId, seThreadLabel, seType }
+      | (seTime, seThreadId, seThreadLabel, seType) <- events
+      ]
+  where
+    width = maximum
+              [ maybe 0 length threadLabel
+              | (_, _, threadLabel, _) <- events
+              ]
 
 
 -- | See 'runSimTraceST' below.
 --
-runSimTrace :: forall a. (forall s. IOSim s a) -> Trace a
+runSimTrace :: forall a. (forall s. IOSim s a) -> SimTrace a
 runSimTrace mainAction = runST (runSimTraceST mainAction)