Skip to content

Commit

Permalink
renderResultWith: Allow to disable the recheckAt-message
Browse files Browse the repository at this point in the history
  • Loading branch information
sol authored and moodmosaic committed May 4, 2024
1 parent c89ffd3 commit 0f342a7
Showing 1 changed file with 26 additions and 15 deletions.
41 changes: 26 additions & 15 deletions hedgehog/src/Hedgehog/Internal/Report.hs
Original file line number Diff line number Diff line change
Expand Up @@ -22,6 +22,8 @@ module Hedgehog.Internal.Report (
, Style(..)
, Markup(..)

, Config(..)
, defaultConfig
, Context(..)
, Lines

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 :) .
Expand All @@ -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 $
Expand Down Expand Up @@ -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 <+>
Expand Down Expand Up @@ -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 =
Expand Down

0 comments on commit 0f342a7

Please sign in to comment.