diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,24 @@ +## Version 1.5 (2024-07-25) + +* Bump containers and filepath dependencies ([#533](533), [@erikd][erikd]) +* Hedgehog.Internal.Report: Add `configPrintShrinkPath` ([#531](531), [@sol][sol]) +* Allow GHC 9.10 ([#530](530), [@erikd][erikd]) +* hedgehog-{example,quickcheck,test-laws}: Raise QuickCheck bound ([#529](529), [@JackKelly-Bellroy][JackKelly-Bellroy]) +* Allow to omit icons at the start of important output lines ([#524](524), [@sol][sol]) +* Allow to omit source location from report ([#523](523), [@sol][sol]) +* Fix "insufficient coverage" message ([#521](521), [@sol][sol]) +* Support empty property names ([#520](520), [@sol][sol]) +* Allow to disable the `recheckAt`-message ([#519](519), [@sol][sol]) +* Remove redundant `Show` constraints: `evalMaybe`, `evalMaybeM` ([#516](516), [@endgame][endgame]) +* Relax upper bound on `ansi-terminal` ([#515](515), [@moodmosaic][moodmosaic]) +* Report.hs refactoring ([#514](514), [@sol][sol]) +* Relax time dependency to < 1.15 ([#513](513), [@tomjaguarpaw][tomjaguarpaw]) +* Bump barbies upper bound ([#510](510), [@jchia][jchia]) +* Support primitive 0.9 ([#509](509), [@Vekhir][Vekhir]) +* Show less context on failure ([#505](505), [@sol][sol]) +* Allow GHC 9.8 ([#504](504), [@tomjaguarpaw][tomjaguarpaw]) +* Wrap `evalMaybeM` and `evalEitherM` in `withFrozenCallStack` ([#499](499), [@ocharles][ocharles]) + ## Version 1.4 (2023-08-07) * Fix skipping to tests/shrinks when tests have been discarded ([#489][489], [@ChickenProp][ChickenProp]) @@ -282,14 +303,55 @@ https://github.com/mbg [jhrcek]: https://github.com/jhrcek - - [parsonsmatt]: https://github.com/parsonsmatt [shlevy]: https://github.com/shlevy - +[sol]: + https://github.com/sol +[JackKelly-Bellroy]: + https://github.com/JackKelly-Bellroy +[jchia]: + https://github.com/jchia +[Vekhir]: + https://github.com/Vekhir +[533]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/533 +[531]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/531 +[530]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/530 +[529]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/529 +[524]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/524 +[523]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/523 +[521]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/521 +[520]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/520 +[519]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/519 +[516]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/516 +[515]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/515 +[514]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/514 +[513]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/513 +[510]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/510 +[509]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/509 +[505]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/505 +[504]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/504 +[499]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/499 [491]: https://github.com/hedgehogqa/haskell-hedgehog/pull/491 [489]: diff --git a/hedgehog.cabal b/hedgehog.cabal --- a/hedgehog.cabal +++ b/hedgehog.cabal @@ -1,4 +1,4 @@ -version: 1.4 +version: 1.5 name: hedgehog @@ -52,13 +52,13 @@ build-depends: -- GHC 8.0.1 / base-4.9.0.0 (May 2016) base >= 4.9 && < 5 - , ansi-terminal >= 0.6 && < 1.1 + , ansi-terminal >= 0.6 && < 1.2 , async >= 2.0 && < 2.3 - , barbies >= 1.0 && < 2.1 - , bytestring >= 0.10 && < 0.12 + , barbies >= 1.0 && < 2.2 + , bytestring >= 0.10 && < 0.13 , concurrent-output >= 1.7 && < 1.11 - , containers >= 0.4 && < 0.7 - , deepseq >= 1.1.0.0 && < 1.5 + , containers >= 0.4 && < 0.8 + , deepseq >= 1.1.0.0 && < 1.6 , directory >= 1.2 && < 1.4 , erf >= 2.0 && < 2.1 , exceptions >= 0.7 && < 0.11 @@ -67,14 +67,14 @@ , monad-control >= 1.0 && < 1.1 , mtl >= 2.1 && < 2.4 , pretty-show >= 1.6 && < 1.11 - , primitive >= 0.6 && < 0.9 + , primitive >= 0.6 && < 0.10 , random >= 1.1 && < 1.3 , resourcet >= 1.1 && < 1.4 , safe-exceptions >= 0.1 && < 0.2 , stm >= 2.4 && < 2.6 - , template-haskell >= 2.10 && < 2.21 - , text >= 1.1 && < 2.1 - , time >= 1.4 && < 1.13 + , template-haskell >= 2.10 && < 2.23 + , text >= 1.1 && < 2.2 + , time >= 1.4 && < 1.15 , transformers >= 0.5 && < 0.7 , transformers-base >= 0.4.5.1 && < 0.5 , wl-pprint-annotated >= 0.0 && < 0.2 @@ -144,11 +144,11 @@ build-depends: hedgehog , base >= 3 && < 5 - , containers >= 0.4 && < 0.7 + , containers >= 0.4 && < 0.8 , mmorph >= 1.0 && < 1.3 , mtl >= 2.1 && < 2.4 , pretty-show >= 1.6 && < 1.11 - , text >= 1.1 && < 2.1 + , text >= 1.1 && < 2.2 , transformers >= 0.3 && < 0.7 default-language: diff --git a/src/Hedgehog/Internal/Property.hs b/src/Hedgehog/Internal/Property.hs --- a/src/Hedgehog/Internal/Property.hs +++ b/src/Hedgehog/Internal/Property.hs @@ -306,8 +306,12 @@ -- newtype TestCount = TestCount Int - deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift) + deriving (Eq, Ord, Num, Enum, Real, Integral, Lift) +instance Show TestCount where + showsPrec p (TestCount n) = + showsPrec p n + -- | The number of tests a property had to discard. -- newtype DiscardCount = @@ -1031,7 +1035,7 @@ -- evalEitherM :: (MonadTest m, Show x, MonadCatch m, HasCallStack) => m (Either x a) -> m a evalEitherM = - evalEither <=< evalM + withFrozenCallStack $ evalEither <=< evalM -- | Fails the test if the 'ExceptT' is 'Left', otherwise returns the value in -- the 'Right'. @@ -1043,7 +1047,7 @@ -- | Fails the test if the 'Maybe' is 'Nothing', otherwise returns the value in -- the 'Just'. -- -evalMaybe :: (MonadTest m, Show a, HasCallStack) => Maybe a -> m a +evalMaybe :: (MonadTest m, HasCallStack) => Maybe a -> m a evalMaybe = \case Nothing -> withFrozenCallStack $ failWith Nothing "the value was Nothing" @@ -1053,9 +1057,9 @@ -- | Fails the test if the action throws an exception, or if the -- 'Maybe' is 'Nothing', otherwise returns the value in the 'Just'. -- -evalMaybeM :: (MonadTest m, Show a, MonadCatch m, HasCallStack) => m (Maybe a) -> m a +evalMaybeM :: (MonadTest m, MonadCatch m, HasCallStack) => m (Maybe a) -> m a evalMaybeM = - evalMaybe <=< evalM + withFrozenCallStack $ evalMaybe <=< evalM ------------------------------------------------------------------------ -- PropertyT diff --git a/src/Hedgehog/Internal/Report.hs b/src/Hedgehog/Internal/Report.hs --- a/src/Hedgehog/Internal/Report.hs +++ b/src/Hedgehog/Internal/Report.hs @@ -22,13 +22,21 @@ , Style(..) , Markup(..) + , Config(..) + , defaultConfig + , Context(..) + , Lines + , PrintPrefixIcons(..) + , renderProgress , renderResult + , renderResultWith , renderSummary , renderDoc , ppProgress , ppResult + , ppResultWith , ppSummary , fromResult @@ -181,7 +189,7 @@ data Line a = Line { - _lineAnnotation :: !a + lineAnnotation :: !a , lineNumber :: !LineNo , _lineSource :: !String } deriving (Eq, Ord, Show, Functor) @@ -300,9 +308,10 @@ gutter m x = markup m ">" <+> x -icon :: Markup -> Char -> Doc Markup -> Doc Markup -icon m i x = - markup m (WL.char i) <+> x +icon :: PrintPrefixIcons -> Markup -> Char -> Doc Markup -> Doc Markup +icon p m i x = case p of + DisablePrefixIcons -> x + EnablePrefixIcons -> markup m (WL.char i) <+> x ppTestCount :: TestCount -> Doc a ppTestCount = \case @@ -553,9 +562,47 @@ pure $ mapSource (styleFailure . insertDoc) decl +type Annotation = (Style, [(Style, Doc Markup)]) + +newtype Lines = Lines Int + deriving (Eq, Num) + +instance Show Lines where + showsPrec p (Lines n) = showsPrec p n + +data Context = FullContext | Context Lines + deriving (Eq, Show) + +applyContext :: Context -> Declaration Annotation -> Declaration Annotation +applyContext context decl = case context of + FullContext -> decl + Context n -> decl { declarationSource = limitContextTo n (declarationSource decl) } + +limitContextTo :: Lines -> Map LineNo (Line Annotation) -> Map LineNo (Line Annotation) +limitContextTo (Lines context) = + let + skipBoring xs = case span isBoring xs of + (boring, []) -> take context boring + (boring, rest) -> takeEnd context boring <> keepInteresting rest + + keepInteresting xs = case break isBoring xs of + (interesting, rest) -> interesting <> take context rest <> skipBoring rest + + isBoring = isBoringAnnotation . lineAnnotation . snd + in + Map.fromList . skipBoring . Map.toList + +takeEnd :: Int -> [a] -> [a] +takeEnd n = reverse . take n . reverse + +isBoringAnnotation :: Annotation -> Bool +isBoringAnnotation = \ case + (StyleDefault, []) -> True + _ -> False + ppDeclaration :: Declaration (Style, [(Style, Doc Markup)]) -> Doc Markup -ppDeclaration decl = - case Map.maxView $ declarationSource decl of +ppDeclaration decl = let source = declarationSource decl in + case Map.maxView source of Nothing -> mempty Just (lastLine, _) -> @@ -572,21 +619,36 @@ ppLineNo = WL.text . printf ("%" <> show digits <> "d") . unLineNo + ppEmptyNo :: Doc a ppEmptyNo = WL.text $ replicate digits ' ' + ppSource :: Style -> LineNo -> String -> Doc Markup ppSource style n src = + (if isOmittedLine (pred n) then addVerticalEllipsis else id) $ markup (StyledLineNo style) (ppLineNo n) <+> markup (StyledBorder style) "┃" <+> markup (StyledSource style) (WL.text src) + addVerticalEllipsis = + (verticalEllipsis <#>) + + verticalEllipsis = + "\x22ee" + + isOmittedLine n = + n >= firstLine && Map.notMember n source + + firstLine = + fst $ Map.findMin source + ppAnnot (style, doc) = markup (StyledLineNo style) ppEmptyNo <+> markup (StyledBorder style) "┃" <+> doc ppLines = do - Line (style, xs) n src <- Map.elems $ declarationSource decl + Line (style, xs) n src <- Map.elems source ppSource style n src : fmap ppAnnot xs in WL.vsep (ppLocation : ppLines) @@ -622,8 +684,8 @@ ppTextLines = fmap WL.text . List.lines -ppFailureReport :: MonadIO m => Maybe PropertyName -> TestCount -> DiscardCount -> Seed -> FailureReport -> m [Doc Markup] -ppFailureReport 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 @@ -677,10 +739,10 @@ (args, idecls) <- fmap partitionEithers $ zipWithM ppFailedInput [0..] inputs0 let + decls :: [Declaration (Style, [(Style, Doc Markup)])] decls = - mergeDeclarations . - catMaybes $ - mlocation : coverageLocations <> fmap pure idecls + mergeDeclarations $ + catMaybes (mlocation : coverageLocations) <> idecls with xs f = if null xs then @@ -694,54 +756,63 @@ else f xs - bottom = - maybe + bottom = case mcoverage of + Nothing | configPrintReproduceMessage config -> [ppReproduce name seed (SkipToShrink tests discards shrinkPath)] - (const []) - mcoverage + _ -> + [] pure . whenSome (mempty :) . whenSome (++ [mempty]) . WL.punctuate WL.line . - fmap (WL.vsep . fmap (WL.indent 2)) . + fmap (WL.vsep . fmap (indentBy $ configPrintPrefixIcons config)) . fmap (id :: [Doc Markup] -> [Doc Markup]) . List.filter (not . null) $ concat [ with args $ WL.punctuate WL.line , with decls $ - WL.punctuate WL.line . fmap ppDeclaration + WL.punctuate WL.line . fmap (ppDeclaration . applyContext (configContext config)) , with msgs1 $ id , with bottom $ id ] +indentBy :: PrintPrefixIcons -> Doc a -> Doc a +indentBy = \case + DisablePrefixIcons -> + id + EnablePrefixIcons -> + WL.indent 2 + ppName :: Maybe PropertyName -> Doc a ppName = \case Nothing -> - "" + "" <> WL.space + Just "" -> + mempty Just (PropertyName name) -> - WL.text name + WL.text name <> WL.space ppProgress :: MonadIO m => Maybe PropertyName -> Report Progress -> m (Doc Markup) ppProgress name (Report tests discards coverage _ status) = case status of Running -> pure . WL.vsep $ [ - icon RunningIcon '●' . WL.annotate RunningHeader $ - ppName name <+> + icon EnablePrefixIcons RunningIcon '●' . WL.annotate RunningHeader $ + ppName name <> "passed" <+> ppTestCount tests <> ppWithDiscardCount discards <+> "(running)" ] ++ - ppCoverage tests coverage + ppCoverage EnablePrefixIcons tests coverage Shrinking failure -> - pure . icon ShrinkingIcon '↯' . WL.annotate ShrinkingHeader $ - ppName name <+> + pure . icon EnablePrefixIcons ShrinkingIcon '↯' . WL.annotate ShrinkingHeader $ + ppName name <> "failed" <+> ppFailedAtLocation (failureLocation failure) <#> "after" <+> ppTestCount tests <> @@ -749,45 +820,58 @@ "(shrinking)" ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup) -ppResult name (Report tests discards coverage seed result) = do +ppResult = ppResultWith defaultConfig + +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 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 <+> - "failed" <+> ppFailedAtLocation (failureLocation failure) <#> - "after" <+> + icon (configPrintPrefixIcons config) FailedIcon '✗' . WL.align . WL.annotate FailedText $ + ppName name <> + ( + if configPrintFailedAtLocation config then + "failed" <+> ppFailedAtLocation (failureLocation failure) <#> "after" + else + "failed after" + ) <+> ppTestCount tests <> ppShrinkDiscard (failureShrinks failure) discards <> - "." <#> - "shrink path:" <+> - ppSkip (SkipToShrink tests discards $ failureShrinkPath failure) + "." <> + ( + if configPrintShrinkPath config then + WL.line <> + "shrink path:" <+> + ppSkip (SkipToShrink tests discards $ failureShrinkPath failure) + else + mempty + ) ] ++ - ppCoverage tests coverage ++ + ppCoverage (configPrintPrefixIcons config) tests coverage ++ pfailure GaveUp -> pure . WL.vsep $ [ - icon GaveUpIcon '⚐' . WL.annotate GaveUpText $ - ppName name <+> + icon (configPrintPrefixIcons config) GaveUpIcon '⚐' . WL.annotate GaveUpText $ + ppName name <> "gave up after" <+> ppDiscardCount discards <> ", passed" <+> ppTestCount tests <> "." ] ++ - ppCoverage tests coverage + ppCoverage (configPrintPrefixIcons config) tests coverage OK -> pure . WL.vsep $ [ - icon SuccessIcon '✓' . WL.annotate SuccessText $ - ppName name <+> + icon (configPrintPrefixIcons config) SuccessIcon '✓' . WL.annotate SuccessText $ + ppName name <> "passed" <+> ppTestCount tests <> "." ] ++ - ppCoverage tests coverage + ppCoverage (configPrintPrefixIcons config) tests coverage ppFailedAtLocation :: Maybe Span -> Doc Markup ppFailedAtLocation = \case @@ -799,12 +883,12 @@ Nothing -> mempty -ppCoverage :: TestCount -> Coverage CoverCount -> [Doc Markup] -ppCoverage tests x = +ppCoverage :: PrintPrefixIcons -> TestCount -> Coverage CoverCount -> [Doc Markup] +ppCoverage icons tests x = if Map.null (coverageLabels x) then mempty else - fmap (ppLabel tests (coverageWidth tests x)) . + fmap (ppLabel icons tests (coverageWidth tests x)) . List.sortOn labelLocation $ Map.elems (coverageLabels x) @@ -876,8 +960,8 @@ in pad <> doc -ppLabel :: TestCount -> ColumnWidth -> Label CoverCount -> Doc Markup -ppLabel tests w x@(MkLabel name _ minimum_ count) = +ppLabel :: PrintPrefixIcons -> TestCount -> ColumnWidth -> Label CoverCount -> Doc Markup +ppLabel icons tests w x@(MkLabel name _ minimum_ count) = let covered = labelCovered tests x @@ -891,11 +975,14 @@ lborder = WL.annotate (StyledBorder StyleDefault) - licon = - if not covered then - WL.annotate CoverageText "⚠ " - else - " " + licon = case icons of + DisablePrefixIcons -> + mempty + EnablePrefixIcons -> + if not covered then + WL.annotate CoverageText "⚠ " + else + " " lname = WL.fill (widthName w) (ppLabelName name) @@ -1049,13 +1136,13 @@ annotateSummary :: Summary -> Doc Markup -> Doc Markup annotateSummary summary = if summaryFailed summary > 0 then - icon FailedIcon '✗' . WL.annotate FailedText + icon EnablePrefixIcons FailedIcon '✗' . WL.annotate FailedText else if summaryGaveUp summary > 0 then - icon GaveUpIcon '⚐' . WL.annotate GaveUpText + icon EnablePrefixIcons GaveUpIcon '⚐' . WL.annotate GaveUpText else if summaryWaiting summary > 0 || summaryRunning summary > 0 then - icon WaitingIcon '○' . WL.annotate WaitingHeader + icon EnablePrefixIcons WaitingIcon '○' . WL.annotate WaitingHeader else - icon SuccessIcon '✓' . WL.annotate SuccessText + icon EnablePrefixIcons SuccessIcon '✓' . WL.annotate SuccessText ppSummary :: MonadIO m => Summary -> m (Doc Markup) ppSummary summary = @@ -1224,8 +1311,32 @@ renderDoc color =<< ppProgress name x renderResult :: MonadIO m => UseColor -> Maybe PropertyName -> Report Result -> m String -renderResult color name x = - renderDoc color =<< ppResult name x +renderResult = renderResultWith defaultConfig + +data Config = + Config { + configContext :: Context + , configPrintFailedAtLocation :: Bool + , configPrintShrinkPath :: Bool + , configPrintReproduceMessage :: Bool + , configPrintPrefixIcons :: PrintPrefixIcons + } deriving (Eq, Show) + +-- | Whether to add icons to the start of important output lines or not. +-- +data PrintPrefixIcons = + DisablePrefixIcons + -- ^ Do not add icons to the start of important output lines. + | EnablePrefixIcons + -- ^ Add icons to the start of important output lines. + deriving (Eq, Show) + +defaultConfig :: Config +defaultConfig = Config FullContext True True True EnablePrefixIcons + +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 = diff --git a/src/Hedgehog/Internal/Runner.hs b/src/Hedgehog/Internal/Runner.hs --- a/src/Hedgehog/Internal/Runner.hs +++ b/src/Hedgehog/Internal/Runner.hs @@ -323,7 +323,7 @@ successReport else failureReport $ - "Labels not sufficently covered after " <> show tests <> " tests" + "Labels not sufficiently covered after " <> show tests <> " tests" else if discards >= fromIntegral (propertyDiscardLimit cfg) then -- we've hit the discard limit, give up