minor pretty printing

Author: UlfNorell

quickcheck-dynamic/src/Test/QuickCheck/StateModel.hs

@@ -211,7 +211,7 @@ instance {-# OVERLAPPING #-} IsPerformResult Void a where
 instance {-# OVERLAPPABLE #-} (EitherIsh e a ~ Either e a) => IsPerformResult e a where
   performResultToEither = id
 
-class (forall a. Show (Action state a), Monad m) => RunModel state m where
+class (forall a. Show (Action state a), Show (Error state m), Monad m) => RunModel state m where
   -- | The type of errors that actions can throw. If this is defined as anything
   -- other than `Void` `perform` is required to return `Either (Error state) a`
   -- instead of `a`.
@@ -377,7 +377,7 @@ instance StateModel state => Show (Actions state) where
 showWithUsed :: StateModel state => VarContext -> Actions state -> String
 showWithUsed ctx (Actions as) =
     let as' = WithUsedVars (combineContexts ctx $ usedVariables (Actions as)) <$> as
-     in intercalate "\n" $ zipWith (++) ("do " : repeat "   ") (map show as' ++ ["pure ()"])
+     in intercalate "\n" $ zipWith (++) ("do " : repeat "   ") (map show as' ++ ["pure ()" | null as'])
 
 usedVariables :: forall state. StateModel state => Actions state -> VarContext
 usedVariables (Actions as) = go initialAnnotatedState as
@@ -683,11 +683,11 @@ commonActions ParallelActions{linearActions = Actions steps, ..} =
 
 threadAActions :: ParallelActions state -> [Step state]
 threadAActions ParallelActions{linearActions = Actions steps, ..} =
-  [ step | step@(v := _) <- steps, elem (unsafeVarIndex v) threadATags ]
+  [ v := s{polarity = PosPolarity} | v := s <- steps, elem (unsafeVarIndex v) threadATags ]
 
 threadBActions :: ParallelActions state -> [Step state]
 threadBActions ParallelActions{linearActions = Actions steps, ..} =
-  [ step | step@(v := _) <- steps, elem (unsafeVarIndex v) threadBTags ]
+  [ v := s{polarity = PosPolarity} | v := s <- steps, elem (unsafeVarIndex v) threadBTags ]
 
 instance StateModel state => Show (ParallelActions state) where
   show pas =
@@ -793,12 +793,13 @@ runParActions :: ( StateModel state
                  , ForkYou m
                  ) => ParallelActions state -> PropertyM m ()
 runParActions pas = do
-  monitor $ counterexample "-- Monitoring main thread"
   (trC, env) <- run $ runTracing mempty $ commonActions pas
   joinA <- run $ forkThread $ runTracing env (threadAActions pas)
   joinB <- run $ forkThread $ runTracing env (threadBActions pas)
   (trA, _) <- run joinA
   (trB, _) <- run joinB
+  monitor $ counterexample "-- Monitoring main thread"
+  monitorTrace mempty trC
   monitor $ counterexample "-- Monitoring thread A"
   monitorTrace env trA
   monitor $ counterexample "-- Monitoring thread B"
@@ -811,8 +812,11 @@ runParActions pas = do
 monitorTrace :: forall state m. (StateModel state, RunModelPar state m)
              => Env -> Trace state m -> PropertyM m ()
 monitorTrace _env [] = pure ()
-monitorTrace env (TraceStep r v step : tr) = do
-  monitor $ monitoringPar @state @m (polarAction step) (lookUpVar env) r
+monitorTrace env (TraceStep r v act : tr) = do
+  let showR (Right x) = show x
+      showR (Left err) = "fail " ++ showsPrec 10 err ""
+  monitor $ counterexample (showR r ++ " <- " ++ show (polarAction act))
+  monitor $ monitoringPar @state @m (polarAction act) (lookUpVar env) r
   monitorTrace env' tr
   where
     env' | Right val <- r = (v :== val) : env

quickcheck-dynamic/test/Spec/DynamicLogic/RegistryModel.hs

@@ -109,17 +109,17 @@ instance StateModel RegState where
 type RegM = ReaderT Registry IO
 
 instance RunModel RegState RegM where
-  type Error RegState RegM = SomeException
+  type Error RegState RegM = String
 
   perform _ Spawn _ = do
     tid <- lift $ forkIO (threadDelay 10000000)
     pure $ Right tid
   perform _ (Register name tid) env = do
     reg <- ask
-    lift $ try $ register reg name (env tid)
+    lift $ fmap (either (Left . displayException . toException @SomeException) Right) $ try $ register reg name (env tid)
   perform _ (Unregister name) _ = do
     reg <- ask
-    lift $ try $ unregister reg name
+    lift $ fmap (either (Left . displayException . toException @SomeException) Right) $ try $ unregister reg name
   perform _ (WhereIs name) _ = do
     reg <- ask
     res <- lift $ whereis reg name
@@ -158,9 +158,6 @@ instance RunModelPar RegState RegM where
     pure $ isLeft res
   postconditionOnFailurePar _ _ _ _ = pure True
 
-  monitoringPar act@(showDictAction -> ShowDict) _ res =
-    QC.counterexample (show res ++ " <- " ++ show act)
-
 data ShowDict a where
   ShowDict :: Show a => ShowDict a