Remove vendored tasty-hedgehog

This commit is contained in:
Michael Walker 2023-06-17 22:41:09 +01:00
parent 3406fd3fdb
commit 42fa864e39
No known key found for this signature in database
4 changed files with 43 additions and 330 deletions

View File

@ -45,7 +45,6 @@ library
, Common
, QSemN
, Test.Tasty.Hedgehog
build-depends: base
, abstract-deque
@ -62,6 +61,7 @@ library
, tasty
, tasty-expected-failure
, tasty-dejafu
, tasty-hedgehog
, tasty-hunit
, vector
hs-source-dirs: lib

View File

@ -1,7 +1,6 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Examples where
import Data.Maybe (fromJust)
import Data.Proxy (Proxy(..))
import Test.Tasty (askOption, localOption)
import Test.Tasty.Hedgehog (HedgehogDiscardLimit(..),
@ -9,7 +8,6 @@ import Test.Tasty.Hedgehog (HedgehogDiscardLimit(..),
HedgehogShrinkRetries(..),
HedgehogTestLimit)
import Test.Tasty.Options (IsOption(..), OptionDescription(..))
import Text.Read (readMaybe)
import qualified Examples.AutoUpdate as A
import qualified Examples.ClassLaws as C
@ -45,48 +43,42 @@ options =
-- Hedgehog options
-- | The number of successful test cases required before Hedgehog will pass a test
newtype ExampleHedgehogTestLimit = ExampleHedgehogTestLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
newtype ExampleHedgehogTestLimit = ExampleHedgehogTestLimit HedgehogTestLimit
deriving (Eq, Ord, Show)
instance IsOption ExampleHedgehogTestLimit where
defaultValue = 25
parseValue = fmap ExampleHedgehogTestLimit . readMaybe
defaultValue = ExampleHedgehogTestLimit . fromJust $ parseValue "25"
parseValue = fmap ExampleHedgehogTestLimit . parseValue
optionName = pure "example-hedgehog-tests"
optionHelp = pure "hedgehog-tests for the example tests"
-- | The number of discarded cases allowed before Hedgehog will fail a test
newtype ExampleHedgehogDiscardLimit = ExampleHedgehogDiscardLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
newtype ExampleHedgehogDiscardLimit = ExampleHedgehogDiscardLimit HedgehogDiscardLimit
deriving (Eq, Ord, Show)
instance IsOption ExampleHedgehogDiscardLimit where
defaultValue =
let HedgehogDiscardLimit d = defaultValue
in fromIntegral d
parseValue = fmap ExampleHedgehogDiscardLimit . readMaybe
defaultValue = ExampleHedgehogDiscardLimit defaultValue
parseValue = fmap ExampleHedgehogDiscardLimit . parseValue
optionName = pure "example-hedgehog-discards"
optionHelp = pure "hedgehog-discards for the example tests"
-- | The number of shrinks allowed before Hedgehog will fail a test
newtype ExampleHedgehogShrinkLimit = ExampleHedgehogShrinkLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
newtype ExampleHedgehogShrinkLimit = ExampleHedgehogShrinkLimit HedgehogShrinkLimit
deriving (Eq, Ord, Show)
instance IsOption ExampleHedgehogShrinkLimit where
defaultValue =
let HedgehogShrinkLimit d = defaultValue
in fromIntegral d
parseValue = fmap ExampleHedgehogShrinkLimit . readMaybe
defaultValue = ExampleHedgehogShrinkLimit defaultValue
parseValue = fmap ExampleHedgehogShrinkLimit . parseValue
optionName = pure "example-hedgehog-shrinks"
optionHelp = pure "hedgehog-shrinks for the example tests"
-- | The number of times to re-run a test during shrinking
newtype ExampleHedgehogShrinkRetries = ExampleHedgehogShrinkRetries Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
newtype ExampleHedgehogShrinkRetries = ExampleHedgehogShrinkRetries HedgehogShrinkRetries
deriving (Eq, Ord, Show)
instance IsOption ExampleHedgehogShrinkRetries where
defaultValue =
let HedgehogShrinkRetries d = defaultValue
in fromIntegral d
parseValue = fmap ExampleHedgehogShrinkRetries . readMaybe
defaultValue = ExampleHedgehogShrinkRetries defaultValue
parseValue = fmap ExampleHedgehogShrinkRetries . parseValue
optionName = pure "example-hedgehog-retries"
optionHelp = pure "hedgehog-retries for the example tests"
@ -97,7 +89,7 @@ applyHedgehogOptions tt0 =
askOption $ \(ExampleHedgehogDiscardLimit dl) ->
askOption $ \(ExampleHedgehogShrinkLimit sl) ->
askOption $ \(ExampleHedgehogShrinkRetries sr) ->
localOption (fromIntegral tl :: HedgehogTestLimit) $
localOption (fromIntegral dl :: HedgehogDiscardLimit) $
localOption (fromIntegral sl :: HedgehogShrinkLimit) $
localOption (fromIntegral sr :: HedgehogShrinkRetries) tt0
localOption tl $
localOption dl $
localOption sl $
localOption sr tt0

View File

@ -1,273 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-
The tasty-hedgehog package:
http://hackage.haskell.org/package/tasty-hedgehog
This is the verbatim contents of tasty-hedgehog, as of version
0.1.0.2. The original code is available under the 3-clause BSD
license, which is reproduced below.
- - - - -
Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation
(CSIRO) ABN 41 687 119 230.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of QFPL nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-}
-- | This package lets you test Hedgehog properties with tasty.
--
-- Typical usage would look like this:
--
-- @
-- testGroup "tasty-hedgehog tests" [
-- testProperty "reverse involutive" prop_reverse_involutive
-- , testProperty "sort idempotent" prop_sort_idempotent
-- ]
-- @
--
module Test.Tasty.Hedgehog (
testProperty
-- * Options you can pass in via tasty
, HedgehogReplay(..)
, HedgehogShowReplay(..)
, HedgehogVerbose(..)
, HedgehogTestLimit(..)
, HedgehogDiscardLimit(..)
, HedgehogShrinkLimit(..)
, HedgehogShrinkRetries(..)
) where
import Control.Monad.IO.Class (MonadIO)
import Data.Typeable
import Test.Tasty.Options
import qualified Test.Tasty.Providers as T
import Hedgehog
import Hedgehog.Internal.Config (UseColor(EnableColor))
import Hedgehog.Internal.Property
import Hedgehog.Internal.Report
import Hedgehog.Internal.Runner as H
import Hedgehog.Internal.Seed as Seed
data HP = HP T.TestName Property
deriving (Typeable)
-- | Create a 'Test' from a Hedgehog property
testProperty :: T.TestName -> Property -> T.TestTree
testProperty name prop = T.singleTest name (HP name prop)
-- | The replay token to use for replaying a previous test run
newtype HedgehogReplay = HedgehogReplay (Maybe (Size, 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
optionName = pure "hedgehog-replay"
optionHelp = pure "Replay token to use for replaying a previous test run"
-- | If a test case fails, show a replay token for replaying tests
newtype HedgehogShowReplay = HedgehogShowReplay Bool
deriving (Typeable)
instance IsOption HedgehogShowReplay where
defaultValue = HedgehogShowReplay True
parseValue = fmap HedgehogShowReplay . safeRead
optionName = pure "hedgehog-show-replay"
optionHelp = pure "Show a replay token for replaying tests"
-- | Show the generated Hedgehog test cases
newtype HedgehogVerbose = HedgehogVerbose Bool
deriving (Typeable)
instance IsOption HedgehogVerbose where
defaultValue = HedgehogVerbose False
parseValue = fmap HedgehogVerbose . safeRead
optionName = pure "hedgehog-verbose"
optionHelp = pure "Show the generated Hedgehog test cases"
optionCLParser = flagCLParser Nothing (HedgehogVerbose True)
-- | The number of successful test cases required before Hedgehog will pass a test
newtype HedgehogTestLimit = HedgehogTestLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Typeable)
instance IsOption HedgehogTestLimit where
defaultValue = 100
parseValue = fmap HedgehogTestLimit . safeRead
optionName = pure "hedgehog-tests"
optionHelp = pure "Number of successful test cases required before Hedgehog will pass a test"
-- | The number of discarded cases allowed before Hedgehog will fail a test
newtype HedgehogDiscardLimit = HedgehogDiscardLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Typeable)
instance IsOption HedgehogDiscardLimit where
defaultValue = 100
parseValue = fmap HedgehogDiscardLimit . safeRead
optionName = pure "hedgehog-discards"
optionHelp = pure "Number of discarded cases allowed before Hedgehog will fail a test"
-- | The number of shrinks allowed before Hedgehog will fail a test
newtype HedgehogShrinkLimit = HedgehogShrinkLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Typeable)
instance IsOption HedgehogShrinkLimit where
defaultValue = 100
parseValue = fmap HedgehogShrinkLimit . safeRead
optionName = pure "hedgehog-shrinks"
optionHelp = pure "Number of shrinks allowed before Hedgehog will fail a test"
-- | The number of times to re-run a test during shrinking
newtype HedgehogShrinkRetries = HedgehogShrinkRetries Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Typeable)
instance IsOption HedgehogShrinkRetries where
defaultValue = 10
parseValue = fmap HedgehogShrinkRetries . safeRead
optionName = pure "hedgehog-retries"
optionHelp = pure "Number of times to re-run a test during shrinking"
getReport :: Report a -> (TestCount, a)
#if MIN_VERSION_hedgehog(1,0,0)
getReport r = (reportTests r, reportStatus r)
#else
getReport (Report testCount _ status) = (testCount, status)
#endif
reportToProgress :: Int
-> Int
-> Int
-> Report Progress
-> T.Progress
reportToProgress testLimit _ shrinkLimit report =
let
(testsDone, status) = getReport report
ratio x y = 1.0 * fromIntegral x / fromIntegral y
in
-- TODO add details for tests run / discarded / shrunk
case status of
Running ->
T.Progress "Running" (ratio testsDone testLimit)
Shrinking fr ->
T.Progress "Shrinking" (ratio (failureShrinks fr) shrinkLimit)
renderResult' :: MonadIO m => Maybe PropertyName -> Report Result -> m String
#if MIN_VERSION_hedgehog(1,0,2)
renderResult' = renderResult EnableColor
#else
renderResult' = renderResult (Just EnableColor)
#endif
reportOutput :: Bool
-> Bool
-> String
-> Report Result
-> IO String
reportOutput _ _ name report = do
let (_, status) = getReport report
s <- renderResult' (Just (PropertyName name)) report
pure $ case status of
Failed _ -> s
GaveUp -> "Gave up"
OK -> "OK"
propertyConfig' :: TestLimit -> DiscardLimit -> ShrinkLimit -> ShrinkRetries -> PropertyConfig
#if MIN_VERSION_hedgehog(1,2,0)
propertyConfig' testLimit discardLimit shrinkLimit shrinkRetries = PropertyConfig
{ propertyDiscardLimit = discardLimit
, propertyShrinkLimit = shrinkLimit
, propertyShrinkRetries = shrinkRetries
, propertyTerminationCriteria = NoConfidenceTermination testLimit
, propertySkip = Nothing
}
#elif MIN_VERSION_hedgehog(1,0,2)
propertyConfig' testLimit discardLimit shrinkLimit shrinkRetries = PropertyConfig
{ propertyDiscardLimit = discardLimit
, propertyShrinkLimit = shrinkLimit
, propertyShrinkRetries = shrinkRetries
, propertyTerminationCriteria = NoConfidenceTermination testLimit
}
#else
propertyConfig' testLimit discardLimit shrinkLimit shrinkRetries = PropertyConfig
{ propertyDiscardLimit = discardLimit
, propertyShrinkLimit = shrinkLimit
, propertyShrinkRetries = shrinkRetries
, propertyTestLimit = testLimit
}
#endif
instance T.IsTest HP where
testOptions =
pure [ Option (Proxy :: Proxy HedgehogReplay)
, Option (Proxy :: Proxy HedgehogShowReplay)
, Option (Proxy :: Proxy HedgehogVerbose)
, Option (Proxy :: Proxy HedgehogTestLimit)
, Option (Proxy :: Proxy HedgehogDiscardLimit)
, Option (Proxy :: Proxy HedgehogShrinkLimit)
, Option (Proxy :: Proxy HedgehogShrinkRetries)
]
run opts (HP name (Property _ pTest)) yieldProgress = do
let
HedgehogReplay replay = lookupOption opts
HedgehogShowReplay showReplay = lookupOption opts
HedgehogVerbose verbose = lookupOption opts
HedgehogTestLimit tests = lookupOption opts
HedgehogDiscardLimit discards = lookupOption opts
HedgehogShrinkLimit shrinks = lookupOption opts
HedgehogShrinkRetries retries = lookupOption opts
config = propertyConfig'
(TestLimit tests)
(DiscardLimit discards)
(ShrinkLimit shrinks)
(ShrinkRetries retries)
randSeed <- Seed.random
let
size = maybe 0 fst replay
seed = maybe randSeed snd replay
report <- checkReport config size seed pTest (yieldProgress . reportToProgress tests discards shrinks)
let
resultFn = if reportStatus report == OK
then T.testPassed
else T.testFailed
out <- reportOutput verbose showReplay name report
pure $ resultFn out

View File

@ -1,7 +1,6 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Unit where
import Data.Maybe (fromJust)
import Data.Proxy (Proxy(..))
import Test.Tasty (askOption, localOption)
import Test.Tasty.Hedgehog (HedgehogDiscardLimit(..),
@ -9,7 +8,6 @@ import Test.Tasty.Hedgehog (HedgehogDiscardLimit(..),
HedgehogShrinkRetries(..),
HedgehogTestLimit)
import Test.Tasty.Options (IsOption(..), OptionDescription(..))
import Text.Read (readMaybe)
import qualified Unit.Predicates as PE
import qualified Unit.Properties as PO
@ -37,46 +35,42 @@ options =
-- Hedgehog options
-- | The number of successful test cases required before Hedgehog will pass a test
newtype UnitHedgehogTestLimit = UnitHedgehogTestLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
newtype UnitHedgehogTestLimit = UnitHedgehogTestLimit HedgehogTestLimit
deriving (Eq, Ord, Show)
instance IsOption UnitHedgehogTestLimit where
defaultValue = 1500
parseValue = fmap UnitHedgehogTestLimit . readMaybe
defaultValue = UnitHedgehogTestLimit . fromJust $ parseValue "1500"
parseValue = fmap UnitHedgehogTestLimit . parseValue
optionName = pure "unit-hedgehog-tests"
optionHelp = pure "hedgehog-tests for the unit tests"
-- | The number of discarded cases allowed before Hedgehog will fail a test
newtype UnitHedgehogDiscardLimit = UnitHedgehogDiscardLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
newtype UnitHedgehogDiscardLimit = UnitHedgehogDiscardLimit HedgehogDiscardLimit
deriving (Eq, Ord, Show)
instance IsOption UnitHedgehogDiscardLimit where
defaultValue = 1000
parseValue = fmap UnitHedgehogDiscardLimit . readMaybe
defaultValue = UnitHedgehogDiscardLimit . fromJust $ parseValue "1000"
parseValue = fmap UnitHedgehogDiscardLimit . parseValue
optionName = pure "unit-hedgehog-discards"
optionHelp = pure "hedgehog-discards for the unit tests"
-- | The number of shrinks allowed before Hedgehog will fail a test
newtype UnitHedgehogShrinkLimit = UnitHedgehogShrinkLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
newtype UnitHedgehogShrinkLimit = UnitHedgehogShrinkLimit HedgehogShrinkLimit
deriving (Eq, Ord, Show)
instance IsOption UnitHedgehogShrinkLimit where
defaultValue =
let HedgehogShrinkLimit d = defaultValue
in fromIntegral d
parseValue = fmap UnitHedgehogShrinkLimit . readMaybe
defaultValue = UnitHedgehogShrinkLimit defaultValue
parseValue = fmap UnitHedgehogShrinkLimit . parseValue
optionName = pure "unit-hedgehog-shrinks"
optionHelp = pure "hedgehog-shrinks for the unit tests"
-- | The number of times to re-run a test during shrinking
newtype UnitHedgehogShrinkRetries = UnitHedgehogShrinkRetries Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
newtype UnitHedgehogShrinkRetries = UnitHedgehogShrinkRetries HedgehogShrinkRetries
deriving (Eq, Ord, Show)
instance IsOption UnitHedgehogShrinkRetries where
defaultValue =
let HedgehogShrinkRetries d = defaultValue
in fromIntegral d
parseValue = fmap UnitHedgehogShrinkRetries . readMaybe
defaultValue = UnitHedgehogShrinkRetries defaultValue
parseValue = fmap UnitHedgehogShrinkRetries . parseValue
optionName = pure "unit-hedgehog-retries"
optionHelp = pure "hedgehog-retries for the unit tests"
@ -87,7 +81,7 @@ applyHedgehogOptions tt0 =
askOption $ \(UnitHedgehogDiscardLimit dl) ->
askOption $ \(UnitHedgehogShrinkLimit sl) ->
askOption $ \(UnitHedgehogShrinkRetries sr) ->
localOption (fromIntegral tl :: HedgehogTestLimit) $
localOption (fromIntegral dl :: HedgehogDiscardLimit) $
localOption (fromIntegral sl :: HedgehogShrinkLimit) $
localOption (fromIntegral sr :: HedgehogShrinkRetries) tt0
localOption tl $
localOption dl $
localOption sl $
localOption sr tt0