hedgehog 1.4 → 1.7
raw patch · 8 files changed
Files
- CHANGELOG.md +93/−3
- README.md +3/−3
- hedgehog.cabal +26/−20
- src/Hedgehog/Internal/Gen.hs +37/−34
- src/Hedgehog/Internal/Property.hs +9/−5
- src/Hedgehog/Internal/Report.hs +168/−57
- src/Hedgehog/Internal/Runner.hs +1/−1
- src/Hedgehog/Internal/State.hs +29/−18
CHANGELOG.md view
@@ -1,3 +1,38 @@+## Version 1.7 (2025-09-22)++* Fix eta-reduction issues for GHC 9.0; add CI and cabal support for GHC 9.0.2 ([#557][557], [@tomjaguarpaw][tomjaguarpaw])+* Allow lifted-async 0.11 ([#556][556], [@felixonmars][felixonmars])+* Remove `fromJust` call by using a separate existential wrapper ([#554][554], [@HuwCampbell][HuwCampbell])++## Version 1.6 (2025-09-08)++* Fix GitHub CI URL ([#545][545], [@tmcgilchrist][tmcgilchrist])+* Bump upper bounds for containers and random ([#544][544], [@moodmosaic][moodmosaic])+* Support GHC 9.12 ([#540][540], [@erikd][erikd])+* Add callstacks to generators that can error ([#538][538], [@ChickenProp][ChickenProp])+* Drop support for GHC 8.0.2 ([#538][538], [@ChickenProp][ChickenProp])++## 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 +317,69 @@ 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+[tmcgilchrist]:+ https://github.com/tmcgilchrist +[557]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/557+[556]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/556+[554]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/554+[544]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/544+[540]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/540+[538]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/538+[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]:
README.md view
@@ -17,7 +17,7 @@ <div align="left"> -[Hedgehog](http://hedgehog.qa/) automatically generates a comprehensive array of test cases, exercising your software in ways human testers would never imagine.+[Hedgehog](https://hackage.haskell.org/package/hedgehog) automatically generates a comprehensive array of test cases, exercising your software in ways human testers would never imagine. Generate hundreds of test cases automatically, exposing even the most insidious of corner cases. Failures are automatically simplified, giving developers coherent, intelligible error messages. @@ -112,8 +112,8 @@ [hackage]: http://hackage.haskell.org/package/hedgehog [hackage-shield]: https://img.shields.io/hackage/v/hedgehog.svg?style=flat - [github-shield]: https://github.com/hedgehogqa/haskell-hedgehog/actions/workflows/ci.yaml/badge.svg- [github-ci]: https://github.com/hedgehogqa/haskell-hedgehog/actions/workflows/ci.yaml+ [github-shield]: https://github.com/hedgehogqa/haskell-hedgehog/actions/workflows/haskell-ci.yml/badge.svg+ [github-ci]: https://github.com/hedgehogqa/haskell-hedgehog/actions/workflows/haskell-ci.yml [haddock-hedgehog]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog.html [haddock-hedgehog-gen]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog-Gen.html
hedgehog.cabal view
@@ -1,4 +1,4 @@-version: 1.4+version: 1.7 name: hedgehog@@ -7,13 +7,13 @@ maintainer: Jacob Stanley <jacob@stanley.io> homepage:- https://hedgehog.qa+ http://github.com/hedgehogqa/haskell-hedgehog bug-reports: https://github.com/hedgehogqa/haskell-hedgehog/issues synopsis: Release with confidence. description:- <http://hedgehog.qa/ Hedgehog> automatically generates a comprehensive array+ <http://github.com/hedgehogqa/haskell-hedgehog/ Hedgehog> automatically generates a comprehensive array of test cases, exercising your software in ways human testers would never imagine. .@@ -33,48 +33,54 @@ build-type: Simple tested-with:- GHC == 8.0.2- , GHC == 8.2.2+ GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.3 , GHC == 8.10.1- , GHC == 9.2.1+ , GHC == 9.0.2+ , GHC == 9.2.7+ , GHC == 9.4.8+ , GHC == 9.6.6+ , GHC == 9.8.4+ , GHC == 9.10.1+ , GHC == 9.12.1+ extra-source-files: README.md CHANGELOG.md source-repository head type: git- location: git://github.com/hedgehogqa/haskell-hedgehog.git+ location: https://github.com/hedgehogqa/haskell-hedgehog library 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.9+ , deepseq >= 1.1.0.0 && < 1.6 , directory >= 1.2 && < 1.4 , erf >= 2.0 && < 2.1 , exceptions >= 0.7 && < 0.11- , lifted-async >= 0.7 && < 0.11+ , lifted-async >= 0.7 && < 0.12 , mmorph >= 1.0 && < 1.3 , monad-control >= 1.0 && < 1.1 , mtl >= 2.1 && < 2.4 , pretty-show >= 1.6 && < 1.11- , primitive >= 0.6 && < 0.9- , random >= 1.1 && < 1.3+ , primitive >= 0.6 && < 0.10+ , random >= 1.1 && < 1.4 , 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.24+ , 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 +150,11 @@ build-depends: hedgehog , base >= 3 && < 5- , containers >= 0.4 && < 0.7+ , containers >= 0.4 && < 0.9 , 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/Gen.hs view
@@ -231,6 +231,7 @@ import Hedgehog.Internal.Seed (Seed) import qualified Hedgehog.Internal.Seed as Seed import qualified Hedgehog.Internal.Shrink as Shrink+import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack) import Hedgehog.Internal.Tree (Tree, TreeT(..), NodeT(..)) import qualified Hedgehog.Internal.Tree as Tree import Hedgehog.Range (Size, Range)@@ -749,18 +750,19 @@ -- | Adjust the size parameter by transforming it with the given function. ---scale :: MonadGen m => (Size -> Size) -> m a -> m a+scale :: (HasCallStack, MonadGen m) => (Size -> Size) -> m a -> m a scale f =- withGenT $ \gen ->- GenT $ \size0 seed ->- let- size =- f size0- in- if size < 0 then- error "Hedgehog.Gen.scale: negative size"- else- runGenT size seed gen+ withFrozenCallStack $+ withGenT $ \gen ->+ GenT $ \size0 seed ->+ let+ size =+ f size0+ in+ if size < 0 then+ error "Hedgehog.Gen.scale: negative size"+ else+ runGenT size seed gen -- | Make a generator smaller by scaling its size parameter. --@@ -1191,8 +1193,8 @@ -- -- /The input list must be non-empty./ ---element :: (Foldable f, MonadGen m) => f a -> m a-element fa = case toList fa of+element :: (HasCallStack, Foldable f, MonadGen m) => f a -> m a+element fa = withFrozenCallStack $ case toList fa of [] -> error "Hedgehog.Gen.element: used with empty Foldable" xs -> do@@ -1205,8 +1207,8 @@ -- -- /The input list must be non-empty./ ---element_ :: MonadGen m => [a] -> m a-element_ = \case+element_ :: (HasCallStack, MonadGen m) => [a] -> m a+element_ l = withFrozenCallStack $ case l of [] -> error "Hedgehog.Gen.element: used with empty list" xs -> do@@ -1219,8 +1221,8 @@ -- -- /The input list must be non-empty./ ---choice :: MonadGen m => [m a] -> m a-choice = \case+choice :: (HasCallStack, MonadGen m) => [m a] -> m a+choice l = withFrozenCallStack $ case l of [] -> error "Hedgehog.Gen.choice: used with empty list" xs -> do@@ -1234,8 +1236,8 @@ -- -- /The input list must be non-empty./ ---frequency :: MonadGen m => [(Int, m a)] -> m a-frequency = \case+frequency :: (HasCallStack, MonadGen m) => [(Int, m a)] -> m a+frequency l = withFrozenCallStack $ case l of [] -> error "Hedgehog.Gen.frequency: used with empty list" xs0 -> do@@ -1815,22 +1817,23 @@ -- i <- Gen.int -- i /== 0 -- @-sample :: MonadIO m => Gen a -> m a+sample :: (HasCallStack, MonadIO m) => Gen a -> m a sample gen =- liftIO $- let- loop n =- if n <= 0 then- error "Hedgehog.Gen.sample: too many discards, could not generate a sample"- else do- seed <- Seed.random- case evalGen 30 seed gen of- Nothing ->- loop (n - 1)- Just x ->- pure $ Tree.treeValue x- in- loop (100 :: Int)+ withFrozenCallStack $+ liftIO $+ let+ loop n =+ if n <= 0 then+ error "Hedgehog.Gen.sample: too many discards, could not generate a sample"+ else do+ seed <- Seed.random+ case evalGen 30 seed gen of+ Nothing ->+ loop (n - 1)+ Just x ->+ pure $ Tree.treeValue x+ in+ loop (100 :: Int) -- | Run a generator with a random seed and print the outcome, and the first -- level of shrinks.
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
src/Hedgehog/Internal/State.hs view
@@ -35,7 +35,6 @@ -- * Commands , Command(..) , Callback(..)- , commandGenOK -- * Actions , Action(..)@@ -402,12 +401,27 @@ [Callback input output state] } --- | Checks that input for a command can be executed in the given state.++-- | An actionable command is a command that can generate an action given+-- the current symbolic state, that is, its @commandGen@ returns @Just@. ---commandGenOK :: Command gen m state -> state Symbolic -> Bool-commandGenOK (Command inputGen _ _) state =- Maybe.isJust (inputGen state)+-- This is an internal type required to hold on to the existential+-- types when building actions.+--+data Actionable gen m (state :: (Type -> Type) -> Type) =+ forall input output.+ (TraversableB input, Show (input Symbolic), Show output, Typeable output) =>+ Actionable {+ _actionableGen ::+ gen (input Symbolic) + , _actionableExecute ::+ input Concrete -> m output++ , _actionableCallbacks ::+ [Callback input output state]+ }+ -- | An instantiation of a 'Command' which can be executed, and its effect -- evaluated. --@@ -545,21 +559,19 @@ Gen.justT $ do Context state0 _ <- get - Command mgenInput exec callbacks <-- Gen.element_ $ filter (\c -> commandGenOK c state0) commands+ Actionable genInput exec callbacks <-+ Gen.element_+ [ Actionable gen exec callbacks+ | Command inputGen exec callbacks <- commands+ , Just gen <- [inputGen state0]+ ] -- If we shrink the input, we still want to use the same output. Otherwise -- any actions using this output as part of their input will be dropped. But -- the existing output is still in the context, so `contextNewVar` will -- create a new one. To avoid that, we generate the output before the input. output <- contextNewVar-- input <-- case mgenInput state0 of- Nothing ->- error "genCommand: internal error, tried to use generator with invalid state."- Just gen ->- hoist lift $ Gen.toGenT gen+ input <- hoist lift $ Gen.toGenT genInput if not $ callbackRequire callbacks state0 input then pure Nothing@@ -650,7 +662,7 @@ -> [Command gen m state] -> gen (Sequential m state) sequential range initial commands =- fmap (Sequential . fst) $+ Sequential . fst <$> genActions range commands (mkContext initial) -- | A sequential prefix of actions to execute, with two branches to execute in parallel.@@ -808,9 +820,8 @@ withFrozenCallStack $ let ok =- any successful .- fmap (checkActions initial) $- interleave branch1 branch2+ any (successful . checkActions initial) $+ interleave branch1 branch2 in if ok then pure ()