renderResultWith: Allow to disable the recheckAt-message

hedgehogqa · May 4, 2024 · 0f342a7 · 0f342a7
1 parent c89ffd3
commit 0f342a7
Showing 1 changed file with 26 additions and 15 deletions.
diff --git a/hedgehog/src/Hedgehog/Internal/Report.hs b/hedgehog/src/Hedgehog/Internal/Report.hs
@@ -22,6 +22,8 @@ module Hedgehog.Internal.Report (
   , Style(..)
   , Markup(..)
 
+  , Config(..)
+  , defaultConfig
   , Context(..)
   , Lines
 
@@ -679,8 +681,8 @@ ppTextLines :: String -> [Doc Markup]
 ppTextLines =
   fmap WL.text . List.lines
 
-ppFailureReport :: MonadIO m => Context -> Maybe PropertyName -> TestCount -> DiscardCount -> Seed -> FailureReport -> m [Doc Markup]
-ppFailureReport context name tests discards seed (FailureReport _ shrinkPath mcoverage inputs0 mlocation0 msg mdiff msgs0) = do
+ppFailureReport :: MonadIO m => Config -> Maybe PropertyName -> TestCount -> DiscardCount -> Seed -> FailureReport -> m [Doc Markup]
+ppFailureReport config name tests discards seed (FailureReport _ shrinkPath mcoverage inputs0 mlocation0 msg mdiff msgs0) = do
   let
     basic =
       -- Move the failure message to the end section if we have
@@ -751,11 +753,11 @@ ppFailureReport context name tests discards seed (FailureReport _ shrinkPath mco
       else
         f xs
 
-    bottom =
-      maybe
+    bottom = case mcoverage of
+      Nothing | configPrintReproduceMessage config ->
         [ppReproduce name seed (SkipToShrink tests discards shrinkPath)]
-        (const [])
-        mcoverage
+      _ ->
+        []
 
   pure .
     whenSome (mempty :) .
@@ -768,7 +770,7 @@ ppFailureReport context name tests discards seed (FailureReport _ shrinkPath mco
       with args $
         WL.punctuate WL.line
     , with decls $
-        WL.punctuate WL.line . fmap (ppDeclaration . applyContext context)
+        WL.punctuate WL.line . fmap (ppDeclaration . applyContext (configContext config))
     , with msgs1 $
         id
     , with bottom $
@@ -806,13 +808,13 @@ ppProgress name (Report tests discards coverage _ status) =
         "(shrinking)"
 
 ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup)
-ppResult = ppResultWith FullContext
+ppResult = ppResultWith defaultConfig
 
-ppResultWith :: MonadIO m => Context -> Maybe PropertyName -> Report Result -> m (Doc Markup)
-ppResultWith context name (Report tests discards coverage seed result) = do
+ppResultWith :: MonadIO m => Config -> Maybe PropertyName -> Report Result -> m (Doc Markup)
+ppResultWith config name (Report tests discards coverage seed result) = do
   case result of
     Failed failure -> do
-      pfailure <- ppFailureReport context name tests discards seed failure
+      pfailure <- ppFailureReport config name tests discards seed failure
       pure . WL.vsep $ [
           icon FailedIcon '✗' . WL.align . WL.annotate FailedText $
             ppName name <+>
@@ -1284,11 +1286,20 @@ renderProgress color name x =
   renderDoc color =<< ppProgress name x
 
 renderResult :: MonadIO m => UseColor -> Maybe PropertyName -> Report Result -> m String
-renderResult = renderResultWith FullContext
+renderResult = renderResultWith defaultConfig
+
+data Config =
+  Config {
+      configContext :: Context
+    , configPrintReproduceMessage :: Bool
+    }
+
+defaultConfig :: Config
+defaultConfig = Config FullContext True
 
-renderResultWith :: MonadIO m => Context -> UseColor -> Maybe PropertyName -> Report Result -> m String
-renderResultWith context color name x =
-  renderDoc color =<< ppResultWith context name x
+renderResultWith :: MonadIO m => Config -> UseColor -> Maybe PropertyName -> Report Result -> m String
+renderResultWith config color name x =
+  renderDoc color =<< ppResultWith config name x
 
 renderSummary :: MonadIO m => UseColor -> Summary -> m String
 renderSummary color x =