io-sim: added pretty printers

Pretty print 'Trace' and list of events (as returned by 'traceEvents').

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE ExplicitNamespaces  #-}
+{-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -22,6 +23,9 @@ module Control.Monad.IOSim (
   -- * Simulation trace
   type SimTrace,
   Trace (Cons, Nil, Trace, SimTrace, TraceMainReturn, TraceMainException, TraceDeadlock),
+  ppTrace,
+  ppTrace_,
+  ppEvents,
   SimResult(..),
   SimEvent(..),
   SimEventType(..),
@@ -57,7 +61,7 @@ import           Data.List (intercalate)
 import           Data.Bifoldable
 import           Data.Typeable (Typeable)
 
-import           Data.List.Trace
+import           Data.List.Trace (Trace (..))
 
 import           Control.Exception (throw)
 
@@ -243,6 +247,19 @@ 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.

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

@@ -44,25 +44,32 @@ module Control.Monad.IOSim.Internal (
   SimResult (..),
   SimEventType (..),
   TraceEvent,
+  ppTrace,
+  ppTrace_,
+  ppSimEvent,
   liftST,
   execReadTVar
 
   ) where
 
 import           Prelude hiding (read)
 
+import           Data.Bifoldable
+import           Data.Bifunctor
 import           Data.Dynamic (Dynamic, toDyn)
 import           Data.Foldable (traverse_)
 import qualified Data.List as List
 import qualified Data.List.Trace as Trace
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
+import           Data.Maybe (fromMaybe)
 import           Data.OrdPSQ (OrdPSQ)
 import qualified Data.OrdPSQ as PSQ
 import           Data.Set (Set)
 import qualified Data.Set as Set
 import           Data.Time (UTCTime (..), fromGregorian)
 import           Data.Typeable (Typeable)
+import           Text.Printf
 import           Quiet (Quiet (..))
 import           GHC.Generics (Generic)
 
@@ -600,6 +607,21 @@ data SimEvent = SimEvent {
     seThreadLabel :: !(Maybe ThreadLabel),
     seType        :: !SimEventType
   }
+  deriving Generic
+  deriving Show via Quiet SimEvent
+
+ppSimEvent :: Int -- ^ width of thread label
+           -> SimEvent
+           -> String
+ppSimEvent d SimEvent {seTime, seThreadId, seThreadLabel, seType} =
+    printf "%-24s - %-13s %-*s - %s"
+           (show seTime)
+           (show seThreadId)
+           d
+           threadLabel
+           (show seType)
+  where
+    threadLabel = fromMaybe "" seThreadLabel
 
 data SimResult a
     = MainReturn    !Time a             ![Labelled ThreadId]
@@ -610,6 +632,22 @@ data SimResult a
 
 type SimTrace a = Trace.Trace (SimResult a) SimEvent
 
+-- | Pretty print simulation trace.
+--
+ppTrace :: Show a => SimTrace a -> String
+ppTrace tr = Trace.ppTrace
+               show
+               (ppSimEvent (bimaximum (bimap (const 0) (maybe 0 length . seThreadLabel) tr)))
+               tr
+
+-- | Like 'ppTrace' but does not show the result value.
+--
+ppTrace_ :: SimTrace a -> String
+ppTrace_ tr = Trace.ppTrace
+                (const "")
+                (ppSimEvent (bimaximum (bimap (const 0) (maybe 0 length . seThreadLabel) tr)))
+                tr
+
 pattern Trace :: Time -> ThreadId -> Maybe ThreadLabel -> SimEventType -> SimTrace a
               -> SimTrace a
 pattern Trace time threadId threadLabel traceEvent trace =

io-sim/src/Data/List/Trace.hs

@@ -2,6 +2,7 @@
 
 module Data.List.Trace
   ( Trace (..)
+  , ppTrace
   , toList
   , fromList
   , head
@@ -57,6 +58,12 @@ toList = bifoldr (\_ bs -> bs) (:) []
 fromList :: a -> [b] -> Trace a b
 fromList a = foldr Cons (Nil a)
 
+-- | Pretty print an 'Trace'.
+--
+ppTrace :: (a -> String) -> (b -> String) -> Trace a b -> String
+ppTrace sa  sb (Cons b bs) = sb b ++ "\n" ++ ppTrace sa sb bs
+ppTrace sa _sb (Nil a)     = sa a
+
 instance Bifunctor Trace where
     bimap f g (Cons b bs) = Cons (g b) (bimap f g bs)
     bimap f _ (Nil a)     = Nil (f a)