io-sim(-por): added ppSimEventType

Author: coot

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE DerivingVia                #-}
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
@@ -9,12 +10,16 @@
 --
 module Control.Monad.IOSim.CommonTypes
   ( IOSimThreadId (..)
+  , ppIOSimThreadId
+  , StepId
+  , ppStepId
   , childThreadId
   , setRacyThread
   , TVarId (..)
   , TimeoutId (..)
   , ClockId (..)
   , VectorClock (..)
+  , ppVectorClock
   , unTimeoutId
   , ThreadLabel
   , TVarLabel
@@ -23,6 +28,8 @@ module Control.Monad.IOSim.CommonTypes
   , Deschedule (..)
   , ThreadStatus (..)
   , BlockedReason (..)
+    -- * Utils
+  , ppList
   ) where
 
 import           Control.DeepSeq (NFData (..))
@@ -31,10 +38,13 @@ import           Control.Monad.ST.Lazy
 
 import           NoThunks.Class
 
+import           Data.List (intercalate, intersperse)
 import           Data.Map (Map)
+import qualified Data.Map as Map
 import           Data.STRef.Lazy
 import           Data.Set (Set)
 import           GHC.Generics
+import           Quiet
 
 
 -- | A thread id.
@@ -44,12 +54,20 @@ import           GHC.Generics
 -- `Control.Monad.Class.MonadTest.exploreRaces` was
 -- executed in it or it's a thread forked by a racy thread.
 --
-data IOSimThreadId = RacyThreadId [Int]
-                   | ThreadId     [Int]    -- non racy threads have higher priority
+data IOSimThreadId =
+    -- | A racy thread (`IOSimPOR` only), shown in the trace with curly braces,
+    -- e.g. `Thread {2,3}`.
+    RacyThreadId [Int]
+    -- | A non racy thread.  They have higher priority than racy threads in
+    -- `IOSimPOR` scheduler.
+  | ThreadId     [Int]
   deriving stock    (Eq, Ord, Show, Generic)
   deriving anyclass NFData
   deriving anyclass NoThunks
 
+ppIOSimThreadId :: IOSimThreadId -> String
+ppIOSimThreadId (RacyThreadId as) = "Thread {"++ intercalate "," (map show as) ++"}"
+ppIOSimThreadId     (ThreadId as) = "Thread " ++ show as
 
 childThreadId :: IOSimThreadId -> Int -> IOSimThreadId
 childThreadId (RacyThreadId is) i = RacyThreadId (is ++ [i])
@@ -59,12 +77,26 @@ setRacyThread :: IOSimThreadId -> IOSimThreadId
 setRacyThread (ThreadId is)      = RacyThreadId is
 setRacyThread tid@RacyThreadId{} = tid
 
+-- | Execution step in `IOSimPOR` is identified by the thread id and
+-- a monotonically increasing number (thread specific).
+--
+type StepId = (IOSimThreadId, Int)
+
+ppStepId :: (IOSimThreadId, Int) -> String
+ppStepId (tid, step) | step < 0
+                     = concat [ppIOSimThreadId tid, ".-"]
+ppStepId (tid, step) = concat [ppIOSimThreadId tid, ".", show step]
+
 
 newtype TVarId      = TVarId    Int   deriving (Eq, Ord, Enum, Show)
 newtype TimeoutId   = TimeoutId Int   deriving (Eq, Ord, Enum, Show)
 newtype ClockId     = ClockId   [Int] deriving (Eq, Ord, Show)
 newtype VectorClock = VectorClock { getVectorClock :: Map IOSimThreadId Int }
-  deriving Show
+  deriving Generic
+  deriving Show via Quiet VectorClock
+
+ppVectorClock :: VectorClock -> String
+ppVectorClock (VectorClock m) = "VectorClock " ++ "[" ++ concat (intersperse ", " (ppStepId <$> Map.toList m)) ++ "]"
 
 unTimeoutId :: TimeoutId -> Int
 unTimeoutId (TimeoutId a) = a
@@ -129,3 +161,10 @@ data BlockedReason = BlockedOnSTM
                    | BlockedOnDelay
                    | BlockedOnThrowTo
   deriving (Eq, Show)
+
+--
+-- Utils
+--
+
+ppList :: (a -> String) -> [a] -> String
+ppList pp as = "[" ++ concat (intersperse ", " (map pp as)) ++ "]"

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

@@ -5,6 +5,7 @@
 {-# LANGUAGE ExistentialQuantification  #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GADTSyntax                 #-}
+{-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE NamedFieldPuns             #-}
 {-# LANGUAGE NumericUnderscores         #-}
@@ -22,7 +23,6 @@ module Control.Monad.IOSim.Types
   , traceSTM
   , liftST
   , SimA (..)
-  , StepId
   , STMSim
   , STM (..)
   , runSTM
@@ -46,6 +46,7 @@ module Control.Monad.IOSim.Types
   , EventlogEvent (..)
   , EventlogMarker (..)
   , SimEventType (..)
+  , ppSimEventType
   , SimEvent (..)
   , SimResult (..)
   , SimTrace
@@ -767,31 +768,35 @@ ppSimEvent :: Int -- ^ width of the time
            -> Int -- ^ width of thread label
            -> SimEvent
            -> String
-ppSimEvent timeWidth tidWidth tLabelWidth SimEvent {seTime, seThreadId, seThreadLabel, seType} =
+
+ppSimEvent timeWidth tidWidth tLabelWidth SimEvent {seTime = Time time, seThreadId, seThreadLabel, seType} =
     printf "%-*s - %-*s %-*s - %s"
            timeWidth
-           (show seTime)
+           (show time)
            tidWidth
-           (show seThreadId)
+           (ppIOSimThreadId seThreadId)
            tLabelWidth
            threadLabel
-           (show seType)
+           (ppSimEventType seType)
   where
     threadLabel = fromMaybe "" seThreadLabel
-ppSimEvent timeWidth tidWidth tLableWidth SimPOREvent {seTime, seThreadId, seStep, seThreadLabel, seType} =
+
+ppSimEvent timeWidth tidWidth tLableWidth SimPOREvent {seTime = Time time, seThreadId, seStep, seThreadLabel, seType} =
     printf "%-*s - %-*s %-*s - %s"
            timeWidth
-           (show seTime)
+           (show time)
            tidWidth
-           (show (seThreadId, seStep))
+           (ppStepId (seThreadId, seStep))
            tLableWidth
            threadLabel
-           (show seType)
+           (ppSimEventType seType)
   where
     threadLabel = fromMaybe "" seThreadLabel
+
 ppSimEvent _ _ _ (SimRacesFound controls) =
     "RacesFound "++show controls
 
+
 -- | A result type of a simulation.
 data SimResult a
     = MainReturn    !Time a             ![Labelled IOSimThreadId]
@@ -805,6 +810,7 @@ data SimResult a
     | Loop
     -- ^ Only returned by /IOSimPOR/ when a step execution took longer than
     -- 'explorationStepTimelimit` was exceeded.
+    | InternalError String
     deriving (Show, Functor)
 
 -- | A type alias for 'IOSim' simulation trace.  It comes with useful pattern
@@ -867,6 +873,8 @@ ppTrace_ tr = Trace.ppTrace
               )
       $ tr
 
+
+
 -- | Trace each event using 'Debug.trace'; this is useful when a trace ends with
 -- a pure error, e.g. an assertion.
 --
@@ -1029,6 +1037,91 @@ data SimEventType
   -- a simulation.  Useful for debugging IOSimPOR.
   deriving Show
 
+ppSimEventType :: SimEventType -> String
+ppSimEventType = \case
+  EventSay a -> "Say " ++ a
+  EventLog a -> "Dynamic " ++ show a
+  EventMask a -> "Mask " ++ show a
+  EventThrow a -> "Throw " ++ show a
+  EventThrowTo err tid ->
+    concat [ "ThrowTo (",
+              show err, ") ",
+              ppIOSimThreadId tid ]
+  EventThrowToBlocked -> "ThrowToBlocked"
+  EventThrowToWakeup -> "ThrowToWakeup"
+  EventThrowToUnmasked a ->
+    "ThrowToUnmasked " ++ ppLabelled ppIOSimThreadId a
+  EventThreadForked a ->
+    "ThreadForked " ++ ppIOSimThreadId a
+  EventThreadFinished -> "ThreadFinished"
+  EventThreadUnhandled a ->
+    "ThreadUnhandled " ++ show a
+  EventTxCommitted written created mbEff ->
+    concat [ "TxCommitted ",
+             ppList (ppLabelled show) written, " ",
+             ppList (ppLabelled show) created,
+             maybe "" ((' ' :) . ppEffect) mbEff ]
+
+  EventTxAborted mbEff ->
+    concat [ "TxAborted",
+             maybe "" ((' ' :) . ppEffect) mbEff ]
+  EventTxBlocked blocked mbEff ->
+   concat [ "TxBlocked ",
+             ppList (ppLabelled show) blocked,
+             maybe "" ((' ' :) . ppEffect) mbEff ]
+  EventTxWakeup changed ->
+    "TxWakeup " ++ ppList (ppLabelled show) changed
+  EventUnblocked unblocked ->
+    "Unblocked " ++ ppList ppIOSimThreadId unblocked
+  EventThreadDelay tid t ->
+    concat [ "ThreadDelay ",
+             show tid, " ",
+             show t ]
+  EventThreadDelayFired  tid -> "ThreadDelayFired " ++ show tid
+  EventTimeoutCreated timer tid t ->
+    concat [ "TimeoutCreated ",
+             show timer, " ",
+             ppIOSimThreadId tid, " ",
+             show t ]
+  EventTimeoutFired timer ->
+    "TimeoutFired " ++ show timer
+  EventRegisterDelayCreated timer tvarId t ->
+    concat [ "RegisterDelayCreated ",
+             show timer, " ",
+             show tvarId, " ",
+             show t ]
+  EventRegisterDelayFired timer -> "RegisterDelayFired " ++ show timer
+  EventTimerCreated timer tvarId t ->
+    concat [ "TimerCreated ",
+              show timer, " ",
+              show tvarId, " ",
+              show t ]
+  EventTimerUpdated timer t ->
+    concat [ "TimerUpdated ",
+             show timer, " ",
+             show t ]
+  EventTimerCancelled timer -> "TimerCancelled " ++ show timer
+  EventTimerFired timer -> "TimerFired " ++ show timer
+  EventThreadStatus  tid tid' ->
+    concat [ "ThreadStatus ",
+             ppIOSimThreadId tid, " ",
+             ppIOSimThreadId tid' ]
+  EventSimStart a -> "SimStart " ++ show a
+  EventThreadSleep -> "ThreadSleep"
+  EventThreadWake -> "ThreadWake"
+  EventDeschedule a -> "Deschedule " ++ show a
+  EventFollowControl a -> "FollowControl " ++ show a
+  EventAwaitControl s a ->
+    concat [ "AwaitControl ",
+             ppStepId s, " ",
+             show a ]
+  EventPerformAction a -> "PerformAction " ++ ppStepId a
+  EventReschedule a -> "Reschedule " ++ show a
+  EventEffect clock eff ->
+    concat [ "Effect ",
+             ppVectorClock clock, " ",
+             ppEffect eff ]
+  EventRaces a -> "Races " ++ show a
 
 -- | A labelled value.
 --
@@ -1041,6 +1134,10 @@ data Labelled a = Labelled {
   deriving (Eq, Ord, Generic)
   deriving Show via Quiet (Labelled a)
 
+ppLabelled :: (a -> String) -> Labelled a -> String
+ppLabelled pp Labelled { l_labelled = a, l_label = Nothing  } = pp a
+ppLabelled pp Labelled { l_labelled = a, l_label = Just lbl } = concat ["Labelled ", pp a, " ", lbl]
+
 --
 -- Executing STM Transactions
 --

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

@@ -9,12 +9,14 @@ module Control.Monad.IOSimPOR.Types
   , wakeupEffects
   , onlyReadEffect
   , racingEffects
+  , ppEffect
     -- * Schedules
   , ScheduleControl (..)
   , isDefaultSchedule
   , ScheduleMod (..)
     -- * Steps
   , StepId
+  , ppStepId
   , Step (..)
   , StepInfo (..)
     -- * Races
@@ -42,17 +44,17 @@ data Effect = Effect {
     effectThrows :: ![IOSimThreadId],
     effectWakeup :: !(Set IOSimThreadId)
   }
-  deriving Eq
+  deriving (Show, Eq)
 
-instance Show Effect where
-    show Effect { effectReads, effectWrites, effectForks, effectThrows, effectWakeup } =
-      concat $ [ "Effect { " ]
-            ++ [ "reads = " ++ show effectReads ++ ", "   | not (null effectReads) ]
-            ++ [ "writes = " ++ show effectWrites ++ ", " | not (null effectWrites) ]
-            ++ [ "forks = " ++ show effectForks ++ ", "   | not (null effectForks)]
-            ++ [ "throws = " ++ show effectThrows ++ ", " | not (null effectThrows) ]
-            ++ [ "wakeup = " ++ show effectWakeup ++ ", " | not (null effectWakeup) ]
-            ++ [ "}" ]
+ppEffect :: Effect -> String
+ppEffect Effect { effectReads, effectWrites, effectForks, effectThrows, effectWakeup } =
+  concat $ [ "Effect { " ]
+        ++ [ "reads = "  ++ show effectReads  ++ ", " | not (null effectReads)  ]
+        ++ [ "writes = " ++ show effectWrites ++ ", " | not (null effectWrites) ]
+        ++ [ "forks = "  ++ ppList ppIOSimThreadId (Set.toList effectForks)  ++ ", " | not (null effectForks)  ]
+        ++ [ "throws = " ++ ppList ppIOSimThreadId             effectThrows  ++ ", " | not (null effectThrows) ]
+        ++ [ "wakeup = " ++ ppList ppIOSimThreadId (Set.toList effectWakeup) ++ ", " | not (null effectWakeup) ]
+        ++ [ "}" ]
 
 
 instance Semigroup Effect where
@@ -164,11 +166,6 @@ data ScheduleMod = ScheduleMod{
   deriving (Eq, Ord)
 
 
--- | Execution step is identified by the thread id and a monotonically
--- increasing number (thread specific).
---
-type StepId = (IOSimThreadId, Int)
-
 instance Show ScheduleMod where
   showsPrec d (ScheduleMod tgt ctrl insertion) =
     showParen (d>10) $