hedgehog 1.4 → 1.5
raw patch · 5 files changed
+255/−78 lines, 5 filesdep ~containersdep ~randomdep ~template-haskell
Dependency ranges changed: containers, random, template-haskell
Files
- CHANGELOG.md +65/−3
- hedgehog.cabal +12/−12
- src/Hedgehog/Internal/Property.hs +9/−5
- src/Hedgehog/Internal/Report.hs +168/−57
- src/Hedgehog/Internal/Runner.hs +1/−1
CHANGELOG.md view
@@ -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]:
hedgehog.cabal view
@@ -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:
src/Hedgehog/Internal/Property.hs view
@@ -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
src/Hedgehog/Internal/Report.hs view
@@ -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 ->- "<interactive>"+ "<interactive>" <> 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 =
src/Hedgehog/Internal/Runner.hs view
@@ -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