Skip to content

Commit 892ddb4

Browse files
cootcoot
committed
io-sim: pretty printers
* ppSimEventType: print `Races` without duplicating `Races` twice. * ppEffect: avoid printing dangling commas. * ppSimResult: added * MainReturn, MainException: include `Labeled IOSimThreadId`, this is a cosmetic change which makes the final message of simulation fit into the same style as other messages.
1 parent 745083d commit 892ddb4

File tree

5 files changed

+79
-35
lines changed

5 files changed

+79
-35
lines changed

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

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -131,9 +131,9 @@ selectTraceEvents
131131
selectTraceEvents fn =
132132
bifoldr ( \ v _
133133
-> case v of
134-
MainException _ e _ -> throw (FailureException e)
134+
MainException _ _ e _ -> throw (FailureException e)
135135
Deadlock _ threads -> throw (FailureDeadlock threads)
136-
MainReturn _ _ _ -> []
136+
MainReturn _ _ _ _ -> []
137137
Loop -> error "Impossible: selectTraceEvents _ TraceLoop{}"
138138
InternalError msg -> throw (FailureInternal msg)
139139
)
@@ -430,10 +430,10 @@ traceResult strict = unsafePerformIO . eval
430430
go (SimTrace _ _ _ _ t) = eval t
431431
go (SimPORTrace _ _ _ _ _ t) = eval t
432432
go (TraceRacesFound _ t) = eval t
433-
go (TraceMainReturn _ _ tids@(_:_))
433+
go (TraceMainReturn _ _ _ tids@(_:_))
434434
| strict = pure $ Left (FailureSloppyShutdown tids)
435-
go (TraceMainReturn _ x _) = pure $ Right x
436-
go (TraceMainException _ e _) = pure $ Left (FailureException e)
435+
go (TraceMainReturn _ _ x _) = pure $ Right x
436+
go (TraceMainException _ _ e _) = pure $ Left (FailureException e)
437437
go (TraceDeadlock _ threads) = pure $ Left (FailureDeadlock threads)
438438
go TraceLoop{} = error "Impossible: traceResult TraceLoop{}"
439439
go (TraceInternalError msg) = pure $ Left (FailureInternal msg)

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -211,7 +211,7 @@ schedule !thread@Thread{
211211
-- the main thread is done, so we're done
212212
-- even if other threads are still running
213213
return $ SimTrace time tid tlbl EventThreadFinished
214-
$ TraceMainReturn time x (labelledThreads threads)
214+
$ TraceMainReturn time (Labelled tid tlbl) x (labelledThreads threads)
215215

216216
ForkFrame -> do
217217
-- this thread is done
@@ -278,7 +278,7 @@ schedule !thread@Thread{
278278
-- An unhandled exception in the main thread terminates the program
279279
return (SimTrace time tid tlbl (EventThrow e) $
280280
SimTrace time tid tlbl (EventThreadUnhandled e) $
281-
TraceMainException time e (labelledThreads threads))
281+
TraceMainException time (Labelled tid tlbl) e (labelledThreads threads))
282282

283283
| otherwise -> do
284284
-- An unhandled exception in any other thread terminates the thread

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

Lines changed: 58 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -133,6 +133,7 @@ import Control.Monad.IOSimPOR.Types
133133

134134

135135
import qualified System.IO.Error as IO.Error (userError)
136+
import Data.List (intercalate)
136137

137138
{-# ANN module "HLint: ignore Use readTVarIO" #-}
138139
newtype IOSim s a = IOSim { unIOSim :: forall r. (a -> SimA s r) -> SimA s r }
@@ -807,9 +808,9 @@ ppSimEvent _ _ _ (SimRacesFound controls) =
807808

808809
-- | A result type of a simulation.
809810
data SimResult a
810-
= MainReturn !Time a ![Labelled IOSimThreadId]
811+
= MainReturn !Time !(Labelled IOSimThreadId) a ![Labelled IOSimThreadId]
811812
-- ^ Return value of the main thread.
812-
| MainException !Time SomeException ![Labelled IOSimThreadId]
813+
| MainException !Time !(Labelled IOSimThreadId) SomeException ![Labelled IOSimThreadId]
813814
-- ^ Exception thrown by the main thread.
814815
| Deadlock !Time ![Labelled IOSimThreadId]
815816
-- ^ Deadlock discovered in the simulation. Deadlocks are discovered if
@@ -821,6 +822,47 @@ data SimResult a
821822
| InternalError String
822823
deriving (Show, Functor)
823824

825+
ppSimResult :: Show a
826+
=> Int
827+
-> Int
828+
-> Int
829+
-> SimResult a
830+
-> String
831+
ppSimResult timeWidth tidWidth thLabelWidth r = case r of
832+
MainReturn (Time time) tid a tids ->
833+
printf "%-*s - %-*s %-*s - %s %s"
834+
timeWidth
835+
(show time)
836+
tidWidth
837+
(ppIOSimThreadId (l_labelled tid))
838+
thLabelWidth
839+
(fromMaybe "" $ l_label tid)
840+
("MainReturn " ++ show a)
841+
("[" ++ intercalate "," (ppLabelled ppIOSimThreadId `map` tids) ++ "]")
842+
MainException (Time time) tid e tids ->
843+
printf "%-*s - %-*s %-*s - %s %s"
844+
timeWidth
845+
(show time)
846+
tidWidth
847+
(ppIOSimThreadId (l_labelled tid))
848+
thLabelWidth
849+
(fromMaybe "" $ l_label tid)
850+
("MainException " ++ show e)
851+
("[" ++ intercalate "," (ppLabelled ppIOSimThreadId `map` tids) ++ "]")
852+
Deadlock (Time time) tids ->
853+
printf "%-*s - %-*s %-*s - %s %s"
854+
timeWidth
855+
(show time)
856+
tidWidth
857+
""
858+
thLabelWidth
859+
""
860+
"Deadlock"
861+
("[" ++ intercalate "," (ppLabelled ppIOSimThreadId `map` tids) ++ "]")
862+
Loop -> "<<io-sim-por: step execution exceded explorationStepTimelimit>>"
863+
InternalError e -> "<<io-sim internal error: " ++ show e ++ ">>"
864+
865+
824866
-- | A type alias for 'IOSim' simulation trace. It comes with useful pattern
825867
-- synonyms.
826868
--
@@ -830,21 +872,21 @@ type SimTrace a = Trace.Trace (SimResult a) SimEvent
830872
--
831873
ppTrace :: Show a => SimTrace a -> String
832874
ppTrace tr = Trace.ppTrace
833-
show
834-
(ppSimEvent timeWidth tidWith labelWidth)
875+
(ppSimResult timeWidth tidWidth labelWidth)
876+
(ppSimEvent timeWidth tidWidth labelWidth)
835877
tr
836878
where
837-
(Max timeWidth, Max tidWith, Max labelWidth) =
879+
(Max timeWidth, Max tidWidth, Max labelWidth) =
838880
bimaximum
839881
. bimap (const (Max 0, Max 0, Max 0))
840882
(\a -> case a of
841-
SimEvent {seTime, seThreadId, seThreadLabel} ->
842-
( Max (length (show seTime))
883+
SimEvent {seTime = Time time, seThreadId, seThreadLabel} ->
884+
( Max (length (show time))
843885
, Max (length (show (seThreadId)))
844886
, Max (length seThreadLabel)
845887
)
846-
SimPOREvent {seTime, seThreadId, seThreadLabel} ->
847-
( Max (length (show seTime))
888+
SimPOREvent {seTime = Time time, seThreadId, seThreadLabel} ->
889+
( Max (length (show time))
848890
, Max (length (show (seThreadId)))
849891
, Max (length seThreadLabel)
850892
)
@@ -859,10 +901,10 @@ ppTrace tr = Trace.ppTrace
859901
ppTrace_ :: SimTrace a -> String
860902
ppTrace_ tr = Trace.ppTrace
861903
(const "")
862-
(ppSimEvent timeWidth tidWith labelWidth)
904+
(ppSimEvent timeWidth tidWidth labelWidth)
863905
tr
864906
where
865-
(Max timeWidth, Max tidWith, Max labelWidth) =
907+
(Max timeWidth, Max tidWidth, Max labelWidth) =
866908
bimaximum
867909
. bimap (const (Max 0, Max 0, Max 0))
868910
(\a -> case a of
@@ -910,13 +952,13 @@ pattern TraceRacesFound controls trace =
910952
Trace.Cons (SimRacesFound controls)
911953
trace
912954

913-
pattern TraceMainReturn :: Time -> a -> [Labelled IOSimThreadId]
955+
pattern TraceMainReturn :: Time -> Labelled IOSimThreadId -> a -> [Labelled IOSimThreadId]
914956
-> SimTrace a
915-
pattern TraceMainReturn time a threads = Trace.Nil (MainReturn time a threads)
957+
pattern TraceMainReturn time tid a threads = Trace.Nil (MainReturn time tid a threads)
916958

917-
pattern TraceMainException :: Time -> SomeException -> [Labelled IOSimThreadId]
959+
pattern TraceMainException :: Time -> Labelled IOSimThreadId -> SomeException -> [Labelled IOSimThreadId]
918960
-> SimTrace a
919-
pattern TraceMainException time err threads = Trace.Nil (MainException time err threads)
961+
pattern TraceMainException time tid err threads = Trace.Nil (MainException time tid err threads)
920962

921963
pattern TraceDeadlock :: Time -> [Labelled IOSimThreadId]
922964
-> SimTrace a
@@ -1132,7 +1174,7 @@ ppSimEventType = \case
11321174
concat [ "Effect ",
11331175
ppVectorClock clock, " ",
11341176
ppEffect eff ]
1135-
EventRaces a -> "Races " ++ show a
1177+
EventRaces a -> show a
11361178

11371179
-- | A labelled value.
11381180
--

‎io-sim/src/Control/Monad/IOSimPOR/Internal.hs

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -314,10 +314,11 @@ schedule thread@Thread{
314314
-- even if other threads are still running
315315
return $ SimPORTrace time tid tstep tlbl EventThreadFinished
316316
$ traceFinalRacesFound simstate
317-
$ TraceMainReturn time x ( labelledThreads
318-
. Map.filter (not . isThreadDone)
319-
$ threads
320-
)
317+
$ TraceMainReturn time (Labelled tid tlbl) x
318+
( labelledThreads
319+
. Map.filter (not . isThreadDone)
320+
$ threads
321+
)
321322

322323
ForkFrame -> do
323324
-- this thread is done
@@ -397,7 +398,7 @@ schedule thread@Thread{
397398
return (SimPORTrace time tid tstep tlbl (EventThrow e) $
398399
SimPORTrace time tid tstep tlbl (EventThreadUnhandled e) $
399400
traceFinalRacesFound simstate { threads = Map.insert tid thread' threads } $
400-
TraceMainException time e (labelledThreads threads))
401+
TraceMainException time (Labelled tid tlbl) e (labelledThreads threads))
401402

402403
| otherwise -> do
403404
-- An unhandled exception in any other thread terminates the thread

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

Lines changed: 8 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -48,13 +48,14 @@ data Effect = Effect {
4848

4949
ppEffect :: Effect -> String
5050
ppEffect Effect { effectReads, effectWrites, effectForks, effectThrows, effectWakeup } =
51-
concat $ [ "Effect { " ]
52-
++ [ "reads = " ++ show effectReads ++ ", " | not (null effectReads) ]
53-
++ [ "writes = " ++ show effectWrites ++ ", " | not (null effectWrites) ]
54-
++ [ "forks = " ++ ppList ppIOSimThreadId (Set.toList effectForks) ++ ", " | not (null effectForks) ]
55-
++ [ "throws = " ++ ppList ppIOSimThreadId effectThrows ++ ", " | not (null effectThrows) ]
56-
++ [ "wakeup = " ++ ppList ppIOSimThreadId (Set.toList effectWakeup) ++ ", " | not (null effectWakeup) ]
57-
++ [ "}" ]
51+
"Effect { " ++
52+
concat (List.intersperse ", " $
53+
[ "reads = " ++ show effectReads | not (null effectReads) ]
54+
++ [ "writes = " ++ show effectWrites | not (null effectWrites) ]
55+
++ [ "forks = " ++ ppList ppIOSimThreadId (Set.toList effectForks) | not (null effectForks) ]
56+
++ [ "throws = " ++ ppList ppIOSimThreadId effectThrows | not (null effectThrows) ]
57+
++ [ "wakeup = " ++ ppList ppIOSimThreadId (Set.toList effectWakeup) | not (null effectWakeup) ])
58+
++ " }"
5859

5960

6061
instance Semigroup Effect where

0 commit comments

Comments
 (0)