├── Setup.hs ├── images ├── failure.png └── success.png ├── .github ├── dependabot.yml └── workflows │ └── build.yml ├── .gitignore ├── LICENCE ├── test └── Main.hs ├── tasty-hedgehog.cabal ├── changelog.md ├── README.md └── src └── Test └── Tasty └── Hedgehog.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /images/failure.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/qfpl/tasty-hedgehog/HEAD/images/failure.png -------------------------------------------------------------------------------- /images/success.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/qfpl/tasty-hedgehog/HEAD/images/success.png -------------------------------------------------------------------------------- /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | - package-ecosystem: "github-actions" 4 | directory: "/" 5 | schedule: 6 | interval: "daily" 7 | assignees: 8 | - "mbg" 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *#* 3 | *.swp 4 | .ghc.environment* 5 | 6 | /dist 7 | /dist-newstyle 8 | /cabal-dev 9 | /.cabal-sandbox 10 | /cabal.sandbox.config 11 | /cabal.project.local 12 | result 13 | 14 | .stack-work/ 15 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | paths: 8 | - ".github/**" 9 | - "src/**" 10 | - "test/**" 11 | - "*.cabal" 12 | pull_request: 13 | 14 | jobs: 15 | build: 16 | runs-on: ubuntu-latest 17 | 18 | strategy: 19 | fail-fast: false 20 | matrix: 21 | ghc-version: 22 | - "8.0.2" 23 | - "8.2.2" 24 | - "8.4.4" 25 | - "8.6.5" 26 | - "8.8.3" 27 | - "8.10.7" 28 | - "9.0.2" 29 | - "9.2.8" 30 | - "9.4.7" 31 | - "9.6.5" 32 | - "9.8.2" 33 | - "9.10.1" 34 | - "9.12.2" 35 | 36 | steps: 37 | - name: Clone repository 38 | uses: actions/checkout@v6 39 | 40 | - name: Install ghc-${{ matrix.ghc-version }} 41 | id: setup-haskell 42 | uses: haskell-actions/setup@v2 43 | with: 44 | ghc-version: ${{ matrix.ghc-version }} 45 | 46 | - name: Cache dependencies 47 | uses: actions/cache@v5 48 | with: 49 | path: | 50 | ${{ steps.setup-haskell.outputs.cabal-store }} 51 | ./dist-newstyle 52 | key: ${{ runner.os }}-${{ matrix.ghc-version }}-${{ hashFiles('tasty-hedgehog.cabal') }} 53 | restore-keys: | 54 | ${{ runner.os }}-${{ matrix.ghc-version }}- 55 | ${{ runner.os }}- 56 | 57 | - name: Update package list 58 | run: cabal update 59 | 60 | - name: Build 61 | run: cabal build 62 | 63 | - name: Run tests 64 | run: cabal test 65 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation 2 | (CSIRO) ABN 41 687 119 230. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * Neither the name of QFPL nor the names of other 18 | contributors may be used to endorse or promote products derived 19 | from this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# language OverloadedStrings #-} 2 | module Main where 3 | 4 | import Hedgehog 5 | import qualified Hedgehog.Gen as Gen 6 | import qualified Hedgehog.Range as Range 7 | import Test.Tasty 8 | import Test.Tasty.ExpectedFailure 9 | import Test.Tasty.Hedgehog 10 | 11 | genAlphaList :: Gen String 12 | genAlphaList = 13 | Gen.list (Range.linear 0 100) Gen.alpha 14 | 15 | test_involutive :: (MonadTest m, Eq a, Show a) => (a -> a) -> a -> m () 16 | test_involutive f x = 17 | f (f x) === x 18 | 19 | prop_reverse_involutive :: Property 20 | prop_reverse_involutive = 21 | property $ do 22 | xs <- forAll genAlphaList 23 | classify "empty" $ length xs == 0 24 | classify "small" $ length xs < 10 25 | classify "large" $ length xs >= 10 26 | test_involutive reverse xs 27 | 28 | badReverse :: [a] -> [a] 29 | badReverse [] = [] 30 | badReverse [_] = [] 31 | badReverse (x : xs) = badReverse xs ++ [x] 32 | 33 | prop_badReverse_involutive :: Property 34 | prop_badReverse_involutive = 35 | property $ do 36 | xs <- forAll genAlphaList 37 | test_involutive badReverse xs 38 | 39 | main :: IO () 40 | main = 41 | defaultMain $ 42 | testGroup "tasty-hedgehog tests" 43 | [ testProperty 44 | "reverse involutive" 45 | prop_reverse_involutive 46 | , expectFail $ testProperty 47 | "badReverse involutive fails" 48 | prop_badReverse_involutive 49 | , testPropertyNamed 50 | "reverse involutive" 51 | "prop_reverse_involutive" 52 | prop_reverse_involutive 53 | , expectFail $ testPropertyNamed 54 | "badReverse involutive fails" 55 | "prop_badReverse_involutive" 56 | prop_badReverse_involutive 57 | ] 58 | -------------------------------------------------------------------------------- /tasty-hedgehog.cabal: -------------------------------------------------------------------------------- 1 | name: tasty-hedgehog 2 | version: 1.4.1.0 3 | license: BSD3 4 | license-file: LICENCE 5 | author: Dave Laing 6 | maintainer: dave.laing.80@gmail.com 7 | copyright: Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. 8 | description: Integrates the with the . 9 | category: Testing 10 | synopsis: Integration for tasty and hedgehog. 11 | homepage: https://github.com/qfpl/tasty-hedgehog 12 | bug-reports: https://github.com/qfpl/tasty-hedgehog/issues 13 | build-type: Simple 14 | extra-source-files: changelog.md 15 | cabal-version: >=1.10 16 | tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1 17 | GHC == 9.0.2 18 | GHC == 9.2.8 19 | GHC == 9.4.7 20 | GHC == 9.6.5 21 | GHC == 9.8.2 22 | GHC == 9.10.1 23 | GHC == 9.12.2 24 | 25 | source-repository head 26 | type: git 27 | location: git@github.com:qfpl/tasty-hedgehog.git 28 | 29 | library 30 | exposed-modules: Test.Tasty.Hedgehog 31 | build-depends: base >= 4.8 && <4.22 32 | , tagged >= 0.8 && < 0.9 33 | , tasty >= 0.11 && < 1.6 34 | , hedgehog >= 1.4 && < 1.8 35 | hs-source-dirs: src 36 | ghc-options: -Wall 37 | default-language: Haskell2010 38 | 39 | test-suite tasty-hedgehog-tests 40 | type: exitcode-stdio-1.0 41 | main-is: Main.hs 42 | hs-source-dirs: test 43 | build-depends: base >= 4.8 && <4.22 44 | , tasty >= 0.11 && < 1.6 45 | , tasty-expected-failure >= 0.11 && < 0.13 46 | , hedgehog >= 1.4 && < 1.8 47 | , tasty-hedgehog 48 | ghc-options: -Wall 49 | default-language: Haskell2010 50 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | # Revision history for tasty-hedgehog 2 | 3 | ## 1.4.1.0 -- TBD 4 | 5 | * Support hedgehog 1.6 and 1.7, GHC 9.12 6 | 7 | ## 1.4.0.2 -- 2023-08-07 8 | 9 | * Support hedgehog 1.4 10 | 11 | ## 1.4.0.1 -- 2023-03-15 12 | 13 | * Support base 4.18 (GHC 9.6) 14 | * Improve suggested test replay command 15 | 16 | ## 1.4.0.0 -- 2022-10-12 17 | 18 | * Support `hedgehog-1.2`. This is a breaking change due to `hedgehog`'s [new mechanism for skipping to a particular test and shrink result](https://github.com/hedgehogqa/haskell-hedgehog/pull/454). The `--hedgehog-replay` option now expects a `Skip` value and a `Seed`, for example: `stack test --test-arguments='--pattern "$NF ~ /badReverse involutive fails/" --hedgehog-replay "3:b2 Seed 10332913068362713902 1302058653756691475"'` ([#63](https://github.com/qfpl/tasty-hedgehog/pull/63)) 19 | 20 | ## 1.3.1.0 -- 2022-10-03 21 | 22 | * The instructions for reproducing test failures are now more clearly distinguished from `hedgehog`'s own instructions and include a pattern in the example to limit which tests are re-run. ([#62](https://github.com/qfpl/tasty-hedgehog/pull/62)) 23 | 24 | ## 1.3.0.0 -- 2022-08-22 25 | 26 | * The `testProperty` function has been undeprecated. Its behaviour differs from that in version `1.1.0.0` and below in that it now passes no `PropertyName` to Hedgehog. Therefore, Hedgehog will render the text `` in its instructions for reproducing test failures, as opposed to whatever description is provided for `testProperty`. 27 | 28 | ## 1.2.0.0 -- 2022-03-07 29 | 30 | * Add `testPropertyNamed` function and deprecate `testProperty`. 31 | 32 | ## 1.1.0.0 -- 2021-04-03 33 | 34 | * Add fromGroup function 35 | 36 | ## 1.0.1.0 -- 2021-01-25 37 | 38 | * Automatically enable or disable colour, based on the same criteria 39 | that hedgehog itself checks. 40 | 41 | ## 1.0.0.2 -- 2020-01-16 42 | 43 | * Upgrade to `hedgehog-1.0.2` 44 | 45 | ## 1.0.0.1 -- 2019-05-22 46 | 47 | * Fixed test result reporting to made plain hedgehog's messages (fixes #30) 48 | 49 | ## 1.0.0.0 -- 2019-05-17 50 | 51 | * Removed support for GHC < 8 52 | * Upgrade to `hedgehog-1` 53 | 54 | ## 0.2.0.0 -- 2018-03-13 55 | 56 | * Removes the verbosity option, which was unsupported 57 | * Fixes a bug in configuration option handling, which 58 | was overwriting use configuration with the defaults. 59 | 60 | ## 0.1.0.2 -- 2018-01-22 61 | 62 | * Ease bounds to allow for `tasty` 1.0. 63 | 64 | ## 0.1.0.1 -- 2018-08-24 65 | 66 | * Exposed the various tasty options. 67 | 68 | ## 0.1.0.0 -- 2017-08-24 69 | 70 | * First version. Released on an unsuspecting world. 71 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://github.com/qfpl/tasty-hedgehog/actions/workflows/build.yml/badge.svg)](https://github.com/qfpl/tasty-hedgehog/actions/workflows/build.yml) 2 | [![tasty-discover-nightly](http://stackage.org/package/tasty-hedgehog/badge/nightly)](http://stackage.org/nightly/package/tasty-hedgehog) 3 | [![tasty-discover-lts](http://stackage.org/package/tasty-hedgehog/badge/lts)](http://stackage.org/lts/package/tasty-hedgehog) 4 | [![Hackage Status](https://img.shields.io/hackage/v/tasty-hedgehog.svg)](http://hackage.haskell.org/package/tasty-hedgehog) 5 | 6 | # `tasty-hedgehog` 7 | 8 | This provides [`tasty`]( https://hackage.haskell.org/package/tasty) integration for [`hedgehog`]( https://hackage.haskell.org/package/hedgehog). 9 | 10 | ## An example of usage 11 | 12 | We're going to need some toy examples to show how this is meant to work. 13 | 14 | (If you want to look at the whole file that this example comes from, which includes all of the necessary imports, it is [here](https://github.com/qfpl/tasty-hedgehog/blob/master/test/Main.hs)) 15 | 16 | We're going to use the simplest example of a property that we can find: if you reverse a list, and then reverse it again, you end up with the list that you started with. 17 | 18 | If were to use the formal term for that, we would say that the `reverse` function is _involutive_. 19 | 20 | To test this, we'll need a random list generated by `hedgehog`: 21 | ```haskell 22 | genAlphaList :: Gen String 23 | genAlphaList = 24 | Gen.list (Range.linear 0 100) Gen.alpha 25 | ``` 26 | 27 | We'll also need something to test that a function is involutive, which might sound scarier than the implementation: 28 | ```haskell 29 | test_involutive :: (MonadTest m, Eq a, Show a) => (a -> a) -> a -> m () 30 | test_involutive f x = 31 | f (f x) === x 32 | ``` 33 | 34 | Thus armed, we write a property to test that the reverse function is actually involutive: 35 | ```haskell 36 | prop_reverse_involutive :: Property 37 | prop_reverse_involutive = 38 | property $ do 39 | xs <- forAll genAlphaList 40 | -- hedgehog-1.0 introduced a classification feature 41 | -- it's optional, but we use it here for fun :) 42 | classify "empty" $ length xs == 0 43 | classify "small" $ length xs < 10 44 | classify "large" $ length xs >= 10 45 | test_involutive reverse xs 46 | ``` 47 | 48 | (We're only testing with lists of `Char`, but the type signature of `reverse` lets us know that the type of the elements of the list can't effect how the function works, via _parametricity_) 49 | 50 | We can now use `tasty` to run the `hedgehog` tests for that property in a test executable: 51 | ```haskell 52 | main :: IO () 53 | main = 54 | defaultMain $ 55 | testGroup "tasty-hedgehog tests" 56 | [ testProperty 57 | "reverse involutive" 58 | "prop_reverse_involutive" 59 | prop_reverse_involutive 60 | ] 61 | ``` 62 | 63 | We then add this as a test suite in our `.cabal` file: 64 | ``` 65 | test-suite tasty-hedgehog-tests 66 | type: exitcode-stdio-1.0 67 | main-is: Main.hs 68 | hs-source-dirs: test 69 | build-depends: base >= 4.8 && < 4.18 70 | , tasty >= 0.11 && < 1.5 71 | , tasty-expected-failure >= 0.11 && < 0.13 72 | , hedgehog >= 1.2 && < 1.3 73 | , tasty-hedgehog >= 1.4 && < 1.5 74 | ghc-options: -Wall 75 | default-language: Haskell2010 76 | ``` 77 | and we should be good to go. 78 | 79 | Running the tests will give you something like this: 80 | 81 | ![success example](./images/success.png) 82 | 83 | We're already leaning on parametricity in our test of `reverse`. 84 | Maybe a _free theorem_ pops out of the type of `reverse` that guarantees that anything with that type signature is involutive automatically. 85 | 86 | Because we're too lazy to check that ourselves, we'll come up with a counter-example: 87 | ```haskell 88 | badReverse :: [a] -> [a] 89 | badReverse [] = [] 90 | badReverse [_] = [] 91 | badReverse as = reverse as 92 | ``` 93 | and test it with a property: 94 | ```haskell 95 | prop_badReverse_involutive :: Property 96 | prop_badReverse_involutive = 97 | property $ do 98 | xs <- forAll genAlphaList 99 | test_involutive badReverse xs 100 | ``` 101 | 102 | We can plug this into our test-suite - remembering to mark the test as an expected failure - 103 | ```haskell 104 | main :: IO () 105 | main = 106 | defaultMain $ 107 | testGroup "tasty-hedgehog tests" 108 | [ testProperty 109 | "reverse involutive" 110 | "prop_reverse_involutive" 111 | prop_reverse_involutive 112 | , expectFail $ testProperty 113 | "badReverse involutive fails" 114 | "prop_badReverse_involutive" 115 | prop_badReverse_involutive 116 | ] 117 | ``` 118 | and now running the tests will give you something like this: 119 | 120 | ![success and failure example](./images/failure.png) 121 | -------------------------------------------------------------------------------- /src/Test/Tasty/Hedgehog.hs: -------------------------------------------------------------------------------- 1 | -- | This package lets you test Hedgehog properties with tasty. 2 | -- 3 | -- Typical usage would look like this: 4 | -- 5 | -- @ 6 | -- testGroup "tasty-hedgehog tests" [ 7 | -- testPropertyNamed "reverse involutive" "prop_reverse_involutive" prop_reverse_involutive 8 | -- , testPropertyNamed "sort idempotent" "prop_sort_idempotent" prop_sort_idempotent 9 | -- ] 10 | -- @ 11 | -- 12 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 13 | module Test.Tasty.Hedgehog ( 14 | testProperty 15 | , testPropertyNamed 16 | , fromGroup 17 | -- * Options you can pass in via tasty 18 | , HedgehogReplay(..) 19 | , HedgehogShowReplay(..) 20 | , HedgehogTestLimit(..) 21 | , HedgehogDiscardLimit(..) 22 | , HedgehogShrinkLimit(..) 23 | , HedgehogShrinkRetries(..) 24 | ) where 25 | 26 | import Data.Maybe (fromMaybe) 27 | import Data.Typeable 28 | 29 | import qualified Test.Tasty as T 30 | import qualified Test.Tasty.Providers as T 31 | import Test.Tasty.Options 32 | 33 | import Hedgehog 34 | import Hedgehog.Internal.Config (UseColor, detectColor) 35 | import Hedgehog.Internal.Property 36 | import Hedgehog.Internal.Runner as H 37 | import Hedgehog.Internal.Report 38 | import Hedgehog.Internal.Seed as Seed 39 | 40 | data HP = HP T.TestName (Maybe PropertyName) Property 41 | deriving (Typeable) 42 | 43 | -- | Create a 'T.TestTree' from a Hedgehog 'Property'. 44 | testProperty :: T.TestName -> Property -> T.TestTree 45 | testProperty name prop = T.singleTest name (HP name Nothing prop) 46 | 47 | -- | `testPropertyNamed` @testName propertyName property@ creates a 48 | -- 'T.TestTree' from @property@ using @testName@ as the displayed 49 | -- description for the property. The @propertyName@ is used by Hedgehog 50 | -- when a failure occurs to provide instructions for how to re-run 51 | -- the property and should normally be set to a string representation 52 | -- of the @property@ argument. 53 | -- 54 | -- @ 55 | -- testPropertyNamed 56 | -- "reverse is involutive" 57 | -- "prop_reverse_involutive" 58 | -- prop_reverse_involutive 59 | -- @ 60 | -- 61 | -- @since 1.2.0.0 62 | testPropertyNamed :: T.TestName -> PropertyName -> Property -> T.TestTree 63 | testPropertyNamed name propName prop = 64 | T.singleTest name (HP name (Just propName) prop) 65 | 66 | -- | Create a 'T.TestTree' from a Hedgehog 'Group'. 67 | fromGroup :: Group -> T.TestTree 68 | fromGroup group = 69 | T.testGroup (unGroupName $ groupName group) $ 70 | map mkTestTree (groupProperties group) 71 | where 72 | mkTestTree :: (PropertyName, Property) -> T.TestTree 73 | mkTestTree (propName, prop) = testProperty (unPropertyName propName) prop 74 | 75 | -- | The replay token to use for replaying a previous test run 76 | newtype HedgehogReplay = HedgehogReplay (Maybe (Skip, Seed)) 77 | deriving (Typeable) 78 | 79 | instance IsOption HedgehogReplay where 80 | defaultValue = HedgehogReplay Nothing 81 | parseValue v = HedgehogReplay . Just <$> replay 82 | -- Reads a replay token in the form "{skip} {seed}" 83 | where replay = (,) <$> skipDecompress (unwords skip) <*> safeRead (unwords seed) 84 | (skip, seed) = splitAt 1 $ words v 85 | optionName = return "hedgehog-replay" 86 | optionHelp = return "Replay token to use for replaying a previous test run" 87 | 88 | -- | If a test case fails, show a replay token for replaying tests 89 | newtype HedgehogShowReplay = HedgehogShowReplay Bool 90 | deriving (Typeable) 91 | 92 | instance IsOption HedgehogShowReplay where 93 | defaultValue = HedgehogShowReplay True 94 | parseValue = fmap HedgehogShowReplay . safeRead 95 | optionName = return "hedgehog-show-replay" 96 | optionHelp = return "Show a replay token for replaying tests" 97 | 98 | -- | The number of successful test cases required before Hedgehog will pass a test 99 | newtype HedgehogTestLimit = HedgehogTestLimit (Maybe TestLimit) 100 | deriving (Eq, Ord, Show, Typeable) 101 | 102 | instance IsOption HedgehogTestLimit where 103 | defaultValue = HedgehogTestLimit Nothing 104 | parseValue = fmap (HedgehogTestLimit . Just . TestLimit) . safeRead 105 | optionName = return "hedgehog-tests" 106 | optionHelp = return "Number of successful test cases required before Hedgehog will pass a test" 107 | 108 | -- | The number of discarded cases allowed before Hedgehog will fail a test 109 | newtype HedgehogDiscardLimit = HedgehogDiscardLimit (Maybe DiscardLimit) 110 | deriving (Eq, Ord, Show, Typeable) 111 | 112 | instance IsOption HedgehogDiscardLimit where 113 | defaultValue = HedgehogDiscardLimit Nothing 114 | parseValue = fmap (HedgehogDiscardLimit . Just . DiscardLimit) . safeRead 115 | optionName = return "hedgehog-discards" 116 | optionHelp = return "Number of discarded cases allowed before Hedgehog will fail a test" 117 | 118 | -- | The number of shrinks allowed before Hedgehog will fail a test 119 | newtype HedgehogShrinkLimit = HedgehogShrinkLimit (Maybe ShrinkLimit) 120 | deriving (Eq, Ord, Show, Typeable) 121 | 122 | instance IsOption HedgehogShrinkLimit where 123 | defaultValue = HedgehogShrinkLimit Nothing 124 | parseValue = fmap (HedgehogShrinkLimit . Just . ShrinkLimit) . safeRead 125 | optionName = return "hedgehog-shrinks" 126 | optionHelp = return "Number of shrinks allowed before Hedgehog will fail a test" 127 | 128 | -- | The number of times to re-run a test during shrinking 129 | newtype HedgehogShrinkRetries = HedgehogShrinkRetries (Maybe ShrinkRetries) 130 | deriving (Eq, Ord, Show, Typeable) 131 | 132 | instance IsOption HedgehogShrinkRetries where 133 | defaultValue = HedgehogShrinkRetries Nothing 134 | parseValue = fmap (HedgehogShrinkRetries . Just . ShrinkRetries) . safeRead 135 | optionName = return "hedgehog-retries" 136 | optionHelp = return "Number of times to re-run a test during shrinking" 137 | 138 | propertyTestLimit :: PropertyConfig -> TestLimit 139 | propertyTestLimit = 140 | let 141 | getTestLimit (EarlyTermination _ tests) = tests 142 | getTestLimit (NoEarlyTermination _ tests) = tests 143 | getTestLimit (NoConfidenceTermination tests) = tests 144 | in 145 | getTestLimit . propertyTerminationCriteria 146 | 147 | reportToProgress :: PropertyConfig 148 | -> Report Progress 149 | -> T.Progress 150 | reportToProgress config Report{ 151 | reportTests = testsDone, 152 | reportStatus = status 153 | } = 154 | let 155 | TestLimit testLimit = propertyTestLimit config 156 | ShrinkLimit shrinkLimit = propertyShrinkLimit config 157 | ratio x y = 1.0 * fromIntegral x / fromIntegral y 158 | in 159 | -- TODO add details for tests run / discarded / shrunk 160 | case status of 161 | Running -> 162 | T.Progress "Running" (ratio testsDone testLimit) 163 | Shrinking fr -> 164 | T.Progress "Shrinking" (ratio (failureShrinks fr) shrinkLimit) 165 | 166 | reportOutput :: Bool 167 | -> UseColor 168 | -> T.TestName 169 | -> Maybe PropertyName 170 | -> Report Result 171 | -> IO String 172 | reportOutput showReplay useColor testName name report = do 173 | s <- renderResult useColor name report 174 | pure $ case reportStatus report of 175 | Failed fr -> 176 | let 177 | count = reportTests report 178 | seed = reportSeed report 179 | discards = reportDiscards report 180 | shrinkPath = failureShrinkPath fr 181 | replayStr = 182 | if showReplay 183 | then 184 | "\nUse \"--pattern \'$NF ~ /" ++ 185 | testName ++ 186 | "/\' --hedgehog-replay \'" ++ 187 | skipCompress (SkipToShrink count discards shrinkPath) ++ 188 | " " ++ 189 | show seed ++ 190 | "\'\" to reproduce from the command-line." 191 | else "" 192 | in 193 | s ++ replayStr ++ "\n" 194 | _ -> s 195 | 196 | instance T.IsTest HP where 197 | testOptions = 198 | return [ Option (Proxy :: Proxy HedgehogReplay) 199 | , Option (Proxy :: Proxy HedgehogShowReplay) 200 | , Option (Proxy :: Proxy HedgehogTestLimit) 201 | , Option (Proxy :: Proxy HedgehogDiscardLimit) 202 | , Option (Proxy :: Proxy HedgehogShrinkLimit) 203 | , Option (Proxy :: Proxy HedgehogShrinkRetries) 204 | ] 205 | 206 | run opts (HP testName name (Property pConfig pTest)) yieldProgress = do 207 | useColor <- detectColor 208 | let 209 | HedgehogReplay replay = lookupOption opts 210 | HedgehogShowReplay showReplay = lookupOption opts 211 | HedgehogTestLimit mTests = lookupOption opts 212 | HedgehogDiscardLimit mDiscards = lookupOption opts 213 | HedgehogShrinkLimit mShrinks = lookupOption opts 214 | HedgehogShrinkRetries mRetries = lookupOption opts 215 | config = 216 | PropertyConfig 217 | (fromMaybe (propertyDiscardLimit pConfig) mDiscards) 218 | (fromMaybe (propertyShrinkLimit pConfig) mShrinks) 219 | (fromMaybe (propertyShrinkRetries pConfig) mRetries) 220 | (NoConfidenceTermination $ fromMaybe (propertyTestLimit pConfig) mTests) 221 | (maybe Nothing (Just . fst) replay) 222 | 223 | randSeed <- Seed.random 224 | let seed = maybe randSeed snd replay 225 | 226 | report <- checkReport config 0 seed pTest (yieldProgress . reportToProgress config) 227 | 228 | let 229 | resultFn = if reportStatus report == OK 230 | then T.testPassed 231 | else T.testFailed 232 | 233 | out <- reportOutput showReplay useColor testName name report 234 | return $ resultFn out 235 | --------------------------------------------------------------------------------