diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,9 +1,56 @@ # Revision history for tasty-hedgehog +## 1.4.0.2 -- 2023-08-07 + +* Support hedgehog 1.4 + +## 1.4.0.1 -- 2023-03-15 + +* Support base 4.18 (GHC 9.6) +* Improve suggested test replay command + +## 1.4.0.0 -- 2022-10-12 + +* 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)) + +## 1.3.1.0 -- 2022-10-03 + +* 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)) + +## 1.3.0.0 -- 2022-08-22 + +* 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`. + +## 1.2.0.0 -- 2022-03-07 + +* Add `testPropertyNamed` function and deprecate `testProperty`. + +## 1.1.0.0 -- 2021-04-03 + +* Add fromGroup function + +## 1.0.1.0 -- 2021-01-25 + +* Automatically enable or disable colour, based on the same criteria + that hedgehog itself checks. + +## 1.0.0.2 -- 2020-01-16 + +* Upgrade to `hedgehog-1.0.2` + +## 1.0.0.1 -- 2019-05-22 + +* Fixed test result reporting to made plain hedgehog's messages (fixes #30) + +## 1.0.0.0 -- 2019-05-17 + +* Removed support for GHC < 8 +* Upgrade to `hedgehog-1` + ## 0.2.0.0 -- 2018-03-13 * Removes the verbosity option, which was unsupported -* Fixes a bug in configuration option handling, which +* Fixes a bug in configuration option handling, which was overwriting use configuration with the defaults. ## 0.1.0.2 -- 2018-01-22 diff --git a/src/Test/Tasty/Hedgehog.hs b/src/Test/Tasty/Hedgehog.hs --- a/src/Test/Tasty/Hedgehog.hs +++ b/src/Test/Tasty/Hedgehog.hs @@ -4,14 +4,16 @@ -- -- @ -- testGroup "tasty-hedgehog tests" [ --- testProperty "reverse involutive" prop_reverse_involutive --- , testProperty "sort idempotent" prop_sort_idempotent +-- testPropertyNamed "reverse involutive" "prop_reverse_involutive" prop_reverse_involutive +-- , testPropertyNamed "sort idempotent" "prop_sort_idempotent" prop_sort_idempotent -- ] -- @ -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.Tasty.Hedgehog ( testProperty + , testPropertyNamed + , fromGroup -- * Options you can pass in via tasty , HedgehogReplay(..) , HedgehogShowReplay(..) @@ -24,32 +26,62 @@ import Data.Maybe (fromMaybe) import Data.Typeable +import qualified Test.Tasty as T import qualified Test.Tasty.Providers as T import Test.Tasty.Options import Hedgehog +import Hedgehog.Internal.Config (UseColor, detectColor) import Hedgehog.Internal.Property import Hedgehog.Internal.Runner as H import Hedgehog.Internal.Report import Hedgehog.Internal.Seed as Seed -data HP = HP T.TestName Property +data HP = HP T.TestName (Maybe PropertyName) Property deriving (Typeable) --- | Create a 'Test' from a Hedgehog property +-- | Create a 'T.TestTree' from a Hedgehog 'Property'. testProperty :: T.TestName -> Property -> T.TestTree -testProperty name prop = T.singleTest name (HP name prop) +testProperty name prop = T.singleTest name (HP name Nothing prop) +-- | `testPropertyNamed` @testName propertyName property@ creates a +-- 'T.TestTree' from @property@ using @testName@ as the displayed +-- description for the property. The @propertyName@ is used by Hedgehog +-- when a failure occurs to provide instructions for how to re-run +-- the property and should normally be set to a string representation +-- of the @property@ argument. +-- +-- @ +-- testPropertyNamed +-- "reverse is involutive" +-- "prop_reverse_involutive" +-- prop_reverse_involutive +-- @ +-- +-- @since 1.2.0.0 +testPropertyNamed :: T.TestName -> PropertyName -> Property -> T.TestTree +testPropertyNamed name propName prop = + T.singleTest name (HP name (Just propName) prop) + +-- | Create a 'T.TestTree' from a Hedgehog 'Group'. +fromGroup :: Group -> T.TestTree +fromGroup group = + T.testGroup (unGroupName $ groupName group) $ + map mkTestTree (groupProperties group) + where + mkTestTree :: (PropertyName, Property) -> T.TestTree + mkTestTree (propName, prop) = testProperty (unPropertyName propName) prop + -- | The replay token to use for replaying a previous test run -newtype HedgehogReplay = HedgehogReplay (Maybe (Size, Seed)) +newtype HedgehogReplay = HedgehogReplay (Maybe (Skip, Seed)) deriving (Typeable) instance IsOption HedgehogReplay where defaultValue = HedgehogReplay Nothing parseValue v = HedgehogReplay . Just <$> replay - -- Reads a replay token in the form "{size} {seed}" - where replay = (,) <$> safeRead (unwords size) <*> safeRead (unwords seed) - (size, seed) = splitAt 2 $ words v + -- Reads a replay token in the form "{skip} {seed}" + where replay = (,) <$> skipDecompress (unwords skip) <*> safeRead (unwords seed) + (skip, seed) = splitAt 1 $ words v optionName = return "hedgehog-replay" optionHelp = return "Replay token to use for replaying a previous test run" @@ -103,10 +135,22 @@ optionName = return "hedgehog-retries" optionHelp = return "Number of times to re-run a test during shrinking" +propertyTestLimit :: PropertyConfig -> TestLimit +propertyTestLimit = + let + getTestLimit (EarlyTermination _ tests) = tests + getTestLimit (NoEarlyTermination _ tests) = tests + getTestLimit (NoConfidenceTermination tests) = tests + in + getTestLimit . propertyTerminationCriteria + reportToProgress :: PropertyConfig -> Report Progress -> T.Progress -reportToProgress config (Report testsDone _ status) = +reportToProgress config Report{ + reportTests = testsDone, + reportStatus = status + } = let TestLimit testLimit = propertyTestLimit config ShrinkLimit shrinkLimit = propertyShrinkLimit config @@ -120,24 +164,34 @@ T.Progress "Shrinking" (ratio (failureShrinks fr) shrinkLimit) reportOutput :: Bool - -> String + -> UseColor + -> T.TestName + -> Maybe PropertyName -> Report Result -> IO String -reportOutput showReplay name report@(Report _ _ status) = do - -- TODO add details for tests run / discarded / shrunk - s <- renderResult Nothing (Just (PropertyName name)) report - pure $ case status of - Failed fr -> do +reportOutput showReplay useColor testName name report = do + s <- renderResult useColor name report + pure $ case reportStatus report of + Failed fr -> let - size = failureSize fr - seed = failureSeed fr + count = reportTests report + seed = reportSeed report + discards = reportDiscards report + shrinkPath = failureShrinkPath fr replayStr = if showReplay - then "\nUse '--hedgehog-replay \"" ++ show size ++ " " ++ show seed ++ "\"' to reproduce." + then + "\nUse \"--pattern \'$NF ~ /" ++ + testName ++ + "/\' --hedgehog-replay \'" ++ + skipCompress (SkipToShrink count discards shrinkPath) ++ + " " ++ + show seed ++ + "\'\" to reproduce from the command-line." else "" - s ++ replayStr - GaveUp -> "Gave up" - OK -> "OK" + in + s ++ replayStr ++ "\n" + _ -> s instance T.IsTest HP where testOptions = @@ -149,7 +203,8 @@ , Option (Proxy :: Proxy HedgehogShrinkRetries) ] - run opts (HP name (Property pConfig pTest)) yieldProgress = do + run opts (HP testName name (Property pConfig pTest)) yieldProgress = do + useColor <- detectColor let HedgehogReplay replay = lookupOption opts HedgehogShowReplay showReplay = lookupOption opts @@ -159,22 +214,21 @@ HedgehogShrinkRetries mRetries = lookupOption opts config = PropertyConfig - (fromMaybe (propertyTestLimit pConfig) mTests) (fromMaybe (propertyDiscardLimit pConfig) mDiscards) (fromMaybe (propertyShrinkLimit pConfig) mShrinks) (fromMaybe (propertyShrinkRetries pConfig) mRetries) + (NoConfidenceTermination $ fromMaybe (propertyTestLimit pConfig) mTests) + (maybe Nothing (Just . fst) replay) randSeed <- Seed.random - let - size = maybe 0 fst replay - seed = maybe randSeed snd replay + let seed = maybe randSeed snd replay - report <- checkReport config size seed pTest (yieldProgress . reportToProgress config) + report <- checkReport config 0 seed pTest (yieldProgress . reportToProgress config) let resultFn = if reportStatus report == OK then T.testPassed else T.testFailed - out <- reportOutput showReplay name report + out <- reportOutput showReplay useColor testName name report return $ resultFn out diff --git a/tasty-hedgehog.cabal b/tasty-hedgehog.cabal --- a/tasty-hedgehog.cabal +++ b/tasty-hedgehog.cabal @@ -1,18 +1,19 @@ name: tasty-hedgehog -version: 0.2.0.0 +version: 1.4.0.2 license: BSD3 license-file: LICENCE author: Dave Laing maintainer: dave.laing.80@gmail.com copyright: Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. -description: Integrates the hedgehog testing library with the tasty testing framework. +description: Integrates the with the . category: Testing synopsis: Integration for tasty and hedgehog. -homepage: https://github.com/qfpl/tasty-hedghog +homepage: https://github.com/qfpl/tasty-hedgehog bug-reports: https://github.com/qfpl/tasty-hedgehog/issues build-type: Simple extra-source-files: changelog.md cabal-version: >=1.10 +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 source-repository head type: git @@ -20,10 +21,10 @@ library exposed-modules: Test.Tasty.Hedgehog - build-depends: base >= 4.8 && <4.11 + build-depends: base >= 4.8 && <4.19 , tagged >= 0.8 && < 0.9 - , tasty >= 0.11 && < 1.1 - , hedgehog >= 0.5 && < 0.6 + , tasty >= 0.11 && < 1.5 + , hedgehog >= 1.4 && < 1.5 hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010 @@ -32,10 +33,10 @@ type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: test - build-depends: base >= 4.8 && <4.11 - , tasty >= 0.11 && < 1.1 - , tasty-expected-failure >= 0.11 && < 0.12 - , hedgehog >= 0.5 && < 0.6 + build-depends: base >= 4.8 && <4.19 + , tasty >= 0.11 && < 1.5 + , tasty-expected-failure >= 0.11 && < 0.13 + , hedgehog >= 1.4 && < 1.5 , tasty-hedgehog ghc-options: -Wall default-language: Haskell2010 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,3 +1,4 @@ +{-# language OverloadedStrings #-} module Main where import Hedgehog @@ -19,12 +20,15 @@ prop_reverse_involutive = property $ do xs <- forAll genAlphaList + classify "empty" $ length xs == 0 + classify "small" $ length xs < 10 + classify "large" $ length xs >= 10 test_involutive reverse xs badReverse :: [a] -> [a] badReverse [] = [] badReverse [_] = [] -badReverse as = reverse as +badReverse (x : xs) = badReverse xs ++ [x] prop_badReverse_involutive :: Property prop_badReverse_involutive = @@ -41,5 +45,13 @@ prop_reverse_involutive , expectFail $ testProperty "badReverse involutive fails" - prop_badReverse_involutive + prop_badReverse_involutive + , testPropertyNamed + "reverse involutive" + "prop_reverse_involutive" + prop_reverse_involutive + , expectFail $ testPropertyNamed + "badReverse involutive fails" + "prop_badReverse_involutive" + prop_badReverse_involutive ]