{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Test.Tasty.Hedgehog (
testProperty
, fromGroup
, HedgehogReplay(..)
, HedgehogShowReplay(..)
, HedgehogTestLimit(..)
, HedgehogDiscardLimit(..)
, HedgehogShrinkLimit(..)
, HedgehogShrinkRetries(..)
) where
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
deriving (Typeable)
testProperty :: T.TestName -> Property -> T.TestTree
testProperty :: TestName -> Property -> TestTree
testProperty TestName
name Property
prop = TestName -> HP -> TestTree
forall t. IsTest t => TestName -> t -> TestTree
T.singleTest TestName
name (TestName -> Property -> HP
HP TestName
name Property
prop)
fromGroup :: Group -> T.TestTree
fromGroup :: Group -> TestTree
fromGroup Group
group =
TestName -> [TestTree] -> TestTree
T.testGroup (GroupName -> TestName
unGroupName (GroupName -> TestName) -> GroupName -> TestName
forall a b. (a -> b) -> a -> b
$ Group -> GroupName
groupName Group
group) ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$
((PropertyName, Property) -> TestTree)
-> [(PropertyName, Property)] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
map (PropertyName, Property) -> TestTree
mkTestTree (Group -> [(PropertyName, Property)]
groupProperties Group
group)
where
mkTestTree :: (PropertyName, Property) -> T.TestTree
mkTestTree :: (PropertyName, Property) -> TestTree
mkTestTree (PropertyName
propName, Property
prop) = TestName -> Property -> TestTree
testProperty (PropertyName -> TestName
unPropertyName PropertyName
propName) Property
prop
newtype HedgehogReplay = HedgehogReplay (Maybe (Size, Seed))
deriving (Typeable)
instance IsOption HedgehogReplay where
defaultValue :: HedgehogReplay
defaultValue = Maybe (Size, Seed) -> HedgehogReplay
HedgehogReplay Maybe (Size, Seed)
forall a. Maybe a
Nothing
parseValue :: TestName -> Maybe HedgehogReplay
parseValue TestName
v = Maybe (Size, Seed) -> HedgehogReplay
HedgehogReplay (Maybe (Size, Seed) -> HedgehogReplay)
-> ((Size, Seed) -> Maybe (Size, Seed))
-> (Size, Seed)
-> HedgehogReplay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Size, Seed) -> Maybe (Size, Seed)
forall a. a -> Maybe a
Just ((Size, Seed) -> HedgehogReplay)
-> Maybe (Size, Seed) -> Maybe HedgehogReplay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Size, Seed)
replay
where replay :: Maybe (Size, Seed)
replay = (,) (Size -> Seed -> (Size, Seed))
-> Maybe Size -> Maybe (Seed -> (Size, Seed))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestName -> Maybe Size
forall a. Read a => TestName -> Maybe a
safeRead ([TestName] -> TestName
unwords [TestName]
size) Maybe (Seed -> (Size, Seed)) -> Maybe Seed -> Maybe (Size, Seed)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TestName -> Maybe Seed
forall a. Read a => TestName -> Maybe a
safeRead ([TestName] -> TestName
unwords [TestName]
seed)
([TestName]
size, [TestName]
seed) = Int -> [TestName] -> ([TestName], [TestName])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
2 ([TestName] -> ([TestName], [TestName]))
-> [TestName] -> ([TestName], [TestName])
forall a b. (a -> b) -> a -> b
$ TestName -> [TestName]
words TestName
v
optionName :: Tagged HedgehogReplay TestName
optionName = TestName -> Tagged HedgehogReplay TestName
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"hedgehog-replay"
optionHelp :: Tagged HedgehogReplay TestName
optionHelp = TestName -> Tagged HedgehogReplay TestName
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"Replay token to use for replaying a previous test run"
newtype HedgehogShowReplay = HedgehogShowReplay Bool
deriving (Typeable)
instance IsOption HedgehogShowReplay where
defaultValue :: HedgehogShowReplay
defaultValue = Bool -> HedgehogShowReplay
HedgehogShowReplay Bool
True
parseValue :: TestName -> Maybe HedgehogShowReplay
parseValue = (Bool -> HedgehogShowReplay)
-> Maybe Bool -> Maybe HedgehogShowReplay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> HedgehogShowReplay
HedgehogShowReplay (Maybe Bool -> Maybe HedgehogShowReplay)
-> (TestName -> Maybe Bool) -> TestName -> Maybe HedgehogShowReplay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Maybe Bool
forall a. Read a => TestName -> Maybe a
safeRead
optionName :: Tagged HedgehogShowReplay TestName
optionName = TestName -> Tagged HedgehogShowReplay TestName
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"hedgehog-show-replay"
optionHelp :: Tagged HedgehogShowReplay TestName
optionHelp = TestName -> Tagged HedgehogShowReplay TestName
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"Show a replay token for replaying tests"
newtype HedgehogTestLimit = HedgehogTestLimit (Maybe TestLimit)
deriving (HedgehogTestLimit -> HedgehogTestLimit -> Bool
(HedgehogTestLimit -> HedgehogTestLimit -> Bool)
-> (HedgehogTestLimit -> HedgehogTestLimit -> Bool)
-> Eq HedgehogTestLimit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HedgehogTestLimit -> HedgehogTestLimit -> Bool
$c/= :: HedgehogTestLimit -> HedgehogTestLimit -> Bool
== :: HedgehogTestLimit -> HedgehogTestLimit -> Bool
$c== :: HedgehogTestLimit -> HedgehogTestLimit -> Bool
Eq, Eq HedgehogTestLimit
Eq HedgehogTestLimit
-> (HedgehogTestLimit -> HedgehogTestLimit -> Ordering)
-> (HedgehogTestLimit -> HedgehogTestLimit -> Bool)
-> (HedgehogTestLimit -> HedgehogTestLimit -> Bool)
-> (HedgehogTestLimit -> HedgehogTestLimit -> Bool)
-> (HedgehogTestLimit -> HedgehogTestLimit -> Bool)
-> (HedgehogTestLimit -> HedgehogTestLimit -> HedgehogTestLimit)
-> (HedgehogTestLimit -> HedgehogTestLimit -> HedgehogTestLimit)
-> Ord HedgehogTestLimit
HedgehogTestLimit -> HedgehogTestLimit -> Bool
HedgehogTestLimit -> HedgehogTestLimit -> Ordering
HedgehogTestLimit -> HedgehogTestLimit -> HedgehogTestLimit
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HedgehogTestLimit -> HedgehogTestLimit -> HedgehogTestLimit
$cmin :: HedgehogTestLimit -> HedgehogTestLimit -> HedgehogTestLimit
max :: HedgehogTestLimit -> HedgehogTestLimit -> HedgehogTestLimit
$cmax :: HedgehogTestLimit -> HedgehogTestLimit -> HedgehogTestLimit
>= :: HedgehogTestLimit -> HedgehogTestLimit -> Bool
$c>= :: HedgehogTestLimit -> HedgehogTestLimit -> Bool
> :: HedgehogTestLimit -> HedgehogTestLimit -> Bool
$c> :: HedgehogTestLimit -> HedgehogTestLimit -> Bool
<= :: HedgehogTestLimit -> HedgehogTestLimit -> Bool
$c<= :: HedgehogTestLimit -> HedgehogTestLimit -> Bool
< :: HedgehogTestLimit -> HedgehogTestLimit -> Bool
$c< :: HedgehogTestLimit -> HedgehogTestLimit -> Bool
compare :: HedgehogTestLimit -> HedgehogTestLimit -> Ordering
$ccompare :: HedgehogTestLimit -> HedgehogTestLimit -> Ordering
$cp1Ord :: Eq HedgehogTestLimit
Ord, Int -> HedgehogTestLimit -> ShowS
[HedgehogTestLimit] -> ShowS
HedgehogTestLimit -> TestName
(Int -> HedgehogTestLimit -> ShowS)
-> (HedgehogTestLimit -> TestName)
-> ([HedgehogTestLimit] -> ShowS)
-> Show HedgehogTestLimit
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
showList :: [HedgehogTestLimit] -> ShowS
$cshowList :: [HedgehogTestLimit] -> ShowS
show :: HedgehogTestLimit -> TestName
$cshow :: HedgehogTestLimit -> TestName
showsPrec :: Int -> HedgehogTestLimit -> ShowS
$cshowsPrec :: Int -> HedgehogTestLimit -> ShowS
Show, Typeable)
instance IsOption HedgehogTestLimit where
defaultValue :: HedgehogTestLimit
defaultValue = Maybe TestLimit -> HedgehogTestLimit
HedgehogTestLimit Maybe TestLimit
forall a. Maybe a
Nothing
parseValue :: TestName -> Maybe HedgehogTestLimit
parseValue = (Int -> HedgehogTestLimit) -> Maybe Int -> Maybe HedgehogTestLimit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe TestLimit -> HedgehogTestLimit
HedgehogTestLimit (Maybe TestLimit -> HedgehogTestLimit)
-> (Int -> Maybe TestLimit) -> Int -> HedgehogTestLimit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestLimit -> Maybe TestLimit
forall a. a -> Maybe a
Just (TestLimit -> Maybe TestLimit)
-> (Int -> TestLimit) -> Int -> Maybe TestLimit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TestLimit
TestLimit) (Maybe Int -> Maybe HedgehogTestLimit)
-> (TestName -> Maybe Int) -> TestName -> Maybe HedgehogTestLimit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Maybe Int
forall a. Read a => TestName -> Maybe a
safeRead
optionName :: Tagged HedgehogTestLimit TestName
optionName = TestName -> Tagged HedgehogTestLimit TestName
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"hedgehog-tests"
optionHelp :: Tagged HedgehogTestLimit TestName
optionHelp = TestName -> Tagged HedgehogTestLimit TestName
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"Number of successful test cases required before Hedgehog will pass a test"
newtype HedgehogDiscardLimit = HedgehogDiscardLimit (Maybe DiscardLimit)
deriving (HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool
(HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool)
-> (HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool)
-> Eq HedgehogDiscardLimit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool
$c/= :: HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool
== :: HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool
$c== :: HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool
Eq, Eq HedgehogDiscardLimit
Eq HedgehogDiscardLimit
-> (HedgehogDiscardLimit -> HedgehogDiscardLimit -> Ordering)
-> (HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool)
-> (HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool)
-> (HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool)
-> (HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool)
-> (HedgehogDiscardLimit
-> HedgehogDiscardLimit -> HedgehogDiscardLimit)
-> (HedgehogDiscardLimit
-> HedgehogDiscardLimit -> HedgehogDiscardLimit)
-> Ord HedgehogDiscardLimit
HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool
HedgehogDiscardLimit -> HedgehogDiscardLimit -> Ordering
HedgehogDiscardLimit
-> HedgehogDiscardLimit -> HedgehogDiscardLimit
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HedgehogDiscardLimit
-> HedgehogDiscardLimit -> HedgehogDiscardLimit
$cmin :: HedgehogDiscardLimit
-> HedgehogDiscardLimit -> HedgehogDiscardLimit
max :: HedgehogDiscardLimit
-> HedgehogDiscardLimit -> HedgehogDiscardLimit
$cmax :: HedgehogDiscardLimit
-> HedgehogDiscardLimit -> HedgehogDiscardLimit
>= :: HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool
$c>= :: HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool
> :: HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool
$c> :: HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool
<= :: HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool
$c<= :: HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool
< :: HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool
$c< :: HedgehogDiscardLimit -> HedgehogDiscardLimit -> Bool
compare :: HedgehogDiscardLimit -> HedgehogDiscardLimit -> Ordering
$ccompare :: HedgehogDiscardLimit -> HedgehogDiscardLimit -> Ordering
$cp1Ord :: Eq HedgehogDiscardLimit
Ord, Int -> HedgehogDiscardLimit -> ShowS
[HedgehogDiscardLimit] -> ShowS
HedgehogDiscardLimit -> TestName
(Int -> HedgehogDiscardLimit -> ShowS)
-> (HedgehogDiscardLimit -> TestName)
-> ([HedgehogDiscardLimit] -> ShowS)
-> Show HedgehogDiscardLimit
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
showList :: [HedgehogDiscardLimit] -> ShowS
$cshowList :: [HedgehogDiscardLimit] -> ShowS
show :: HedgehogDiscardLimit -> TestName
$cshow :: HedgehogDiscardLimit -> TestName
showsPrec :: Int -> HedgehogDiscardLimit -> ShowS
$cshowsPrec :: Int -> HedgehogDiscardLimit -> ShowS
Show, Typeable)
instance IsOption HedgehogDiscardLimit where
defaultValue :: HedgehogDiscardLimit
defaultValue = Maybe DiscardLimit -> HedgehogDiscardLimit
HedgehogDiscardLimit Maybe DiscardLimit
forall a. Maybe a
Nothing
parseValue :: TestName -> Maybe HedgehogDiscardLimit
parseValue = (Int -> HedgehogDiscardLimit)
-> Maybe Int -> Maybe HedgehogDiscardLimit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe DiscardLimit -> HedgehogDiscardLimit
HedgehogDiscardLimit (Maybe DiscardLimit -> HedgehogDiscardLimit)
-> (Int -> Maybe DiscardLimit) -> Int -> HedgehogDiscardLimit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiscardLimit -> Maybe DiscardLimit
forall a. a -> Maybe a
Just (DiscardLimit -> Maybe DiscardLimit)
-> (Int -> DiscardLimit) -> Int -> Maybe DiscardLimit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DiscardLimit
DiscardLimit) (Maybe Int -> Maybe HedgehogDiscardLimit)
-> (TestName -> Maybe Int)
-> TestName
-> Maybe HedgehogDiscardLimit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Maybe Int
forall a. Read a => TestName -> Maybe a
safeRead
optionName :: Tagged HedgehogDiscardLimit TestName
optionName = TestName -> Tagged HedgehogDiscardLimit TestName
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"hedgehog-discards"
optionHelp :: Tagged HedgehogDiscardLimit TestName
optionHelp = TestName -> Tagged HedgehogDiscardLimit TestName
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"Number of discarded cases allowed before Hedgehog will fail a test"
newtype HedgehogShrinkLimit = HedgehogShrinkLimit (Maybe ShrinkLimit)
deriving (HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool
(HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool)
-> (HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool)
-> Eq HedgehogShrinkLimit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool
$c/= :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool
== :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool
$c== :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool
Eq, Eq HedgehogShrinkLimit
Eq HedgehogShrinkLimit
-> (HedgehogShrinkLimit -> HedgehogShrinkLimit -> Ordering)
-> (HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool)
-> (HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool)
-> (HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool)
-> (HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool)
-> (HedgehogShrinkLimit
-> HedgehogShrinkLimit -> HedgehogShrinkLimit)
-> (HedgehogShrinkLimit
-> HedgehogShrinkLimit -> HedgehogShrinkLimit)
-> Ord HedgehogShrinkLimit
HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool
HedgehogShrinkLimit -> HedgehogShrinkLimit -> Ordering
HedgehogShrinkLimit -> HedgehogShrinkLimit -> HedgehogShrinkLimit
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> HedgehogShrinkLimit
$cmin :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> HedgehogShrinkLimit
max :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> HedgehogShrinkLimit
$cmax :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> HedgehogShrinkLimit
>= :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool
$c>= :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool
> :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool
$c> :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool
<= :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool
$c<= :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool
< :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool
$c< :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> Bool
compare :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> Ordering
$ccompare :: HedgehogShrinkLimit -> HedgehogShrinkLimit -> Ordering
$cp1Ord :: Eq HedgehogShrinkLimit
Ord, Int -> HedgehogShrinkLimit -> ShowS
[HedgehogShrinkLimit] -> ShowS
HedgehogShrinkLimit -> TestName
(Int -> HedgehogShrinkLimit -> ShowS)
-> (HedgehogShrinkLimit -> TestName)
-> ([HedgehogShrinkLimit] -> ShowS)
-> Show HedgehogShrinkLimit
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
showList :: [HedgehogShrinkLimit] -> ShowS
$cshowList :: [HedgehogShrinkLimit] -> ShowS
show :: HedgehogShrinkLimit -> TestName
$cshow :: HedgehogShrinkLimit -> TestName
showsPrec :: Int -> HedgehogShrinkLimit -> ShowS
$cshowsPrec :: Int -> HedgehogShrinkLimit -> ShowS
Show, Typeable)
instance IsOption HedgehogShrinkLimit where
defaultValue :: HedgehogShrinkLimit
defaultValue = Maybe ShrinkLimit -> HedgehogShrinkLimit
HedgehogShrinkLimit Maybe ShrinkLimit
forall a. Maybe a
Nothing
parseValue :: TestName -> Maybe HedgehogShrinkLimit
parseValue = (Int -> HedgehogShrinkLimit)
-> Maybe Int -> Maybe HedgehogShrinkLimit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe ShrinkLimit -> HedgehogShrinkLimit
HedgehogShrinkLimit (Maybe ShrinkLimit -> HedgehogShrinkLimit)
-> (Int -> Maybe ShrinkLimit) -> Int -> HedgehogShrinkLimit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShrinkLimit -> Maybe ShrinkLimit
forall a. a -> Maybe a
Just (ShrinkLimit -> Maybe ShrinkLimit)
-> (Int -> ShrinkLimit) -> Int -> Maybe ShrinkLimit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShrinkLimit
ShrinkLimit) (Maybe Int -> Maybe HedgehogShrinkLimit)
-> (TestName -> Maybe Int) -> TestName -> Maybe HedgehogShrinkLimit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Maybe Int
forall a. Read a => TestName -> Maybe a
safeRead
optionName :: Tagged HedgehogShrinkLimit TestName
optionName = TestName -> Tagged HedgehogShrinkLimit TestName
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"hedgehog-shrinks"
optionHelp :: Tagged HedgehogShrinkLimit TestName
optionHelp = TestName -> Tagged HedgehogShrinkLimit TestName
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"Number of shrinks allowed before Hedgehog will fail a test"
newtype HedgehogShrinkRetries = HedgehogShrinkRetries (Maybe ShrinkRetries)
deriving (HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool
(HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool)
-> (HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool)
-> Eq HedgehogShrinkRetries
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool
$c/= :: HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool
== :: HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool
$c== :: HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool
Eq, Eq HedgehogShrinkRetries
Eq HedgehogShrinkRetries
-> (HedgehogShrinkRetries -> HedgehogShrinkRetries -> Ordering)
-> (HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool)
-> (HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool)
-> (HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool)
-> (HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool)
-> (HedgehogShrinkRetries
-> HedgehogShrinkRetries -> HedgehogShrinkRetries)
-> (HedgehogShrinkRetries
-> HedgehogShrinkRetries -> HedgehogShrinkRetries)
-> Ord HedgehogShrinkRetries
HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool
HedgehogShrinkRetries -> HedgehogShrinkRetries -> Ordering
HedgehogShrinkRetries
-> HedgehogShrinkRetries -> HedgehogShrinkRetries
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HedgehogShrinkRetries
-> HedgehogShrinkRetries -> HedgehogShrinkRetries
$cmin :: HedgehogShrinkRetries
-> HedgehogShrinkRetries -> HedgehogShrinkRetries
max :: HedgehogShrinkRetries
-> HedgehogShrinkRetries -> HedgehogShrinkRetries
$cmax :: HedgehogShrinkRetries
-> HedgehogShrinkRetries -> HedgehogShrinkRetries
>= :: HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool
$c>= :: HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool
> :: HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool
$c> :: HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool
<= :: HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool
$c<= :: HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool
< :: HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool
$c< :: HedgehogShrinkRetries -> HedgehogShrinkRetries -> Bool
compare :: HedgehogShrinkRetries -> HedgehogShrinkRetries -> Ordering
$ccompare :: HedgehogShrinkRetries -> HedgehogShrinkRetries -> Ordering
$cp1Ord :: Eq HedgehogShrinkRetries
Ord, Int -> HedgehogShrinkRetries -> ShowS
[HedgehogShrinkRetries] -> ShowS
HedgehogShrinkRetries -> TestName
(Int -> HedgehogShrinkRetries -> ShowS)
-> (HedgehogShrinkRetries -> TestName)
-> ([HedgehogShrinkRetries] -> ShowS)
-> Show HedgehogShrinkRetries
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
showList :: [HedgehogShrinkRetries] -> ShowS
$cshowList :: [HedgehogShrinkRetries] -> ShowS
show :: HedgehogShrinkRetries -> TestName
$cshow :: HedgehogShrinkRetries -> TestName
showsPrec :: Int -> HedgehogShrinkRetries -> ShowS
$cshowsPrec :: Int -> HedgehogShrinkRetries -> ShowS
Show, Typeable)
instance IsOption HedgehogShrinkRetries where
defaultValue :: HedgehogShrinkRetries
defaultValue = Maybe ShrinkRetries -> HedgehogShrinkRetries
HedgehogShrinkRetries Maybe ShrinkRetries
forall a. Maybe a
Nothing
parseValue :: TestName -> Maybe HedgehogShrinkRetries
parseValue = (Int -> HedgehogShrinkRetries)
-> Maybe Int -> Maybe HedgehogShrinkRetries
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe ShrinkRetries -> HedgehogShrinkRetries
HedgehogShrinkRetries (Maybe ShrinkRetries -> HedgehogShrinkRetries)
-> (Int -> Maybe ShrinkRetries) -> Int -> HedgehogShrinkRetries
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShrinkRetries -> Maybe ShrinkRetries
forall a. a -> Maybe a
Just (ShrinkRetries -> Maybe ShrinkRetries)
-> (Int -> ShrinkRetries) -> Int -> Maybe ShrinkRetries
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShrinkRetries
ShrinkRetries) (Maybe Int -> Maybe HedgehogShrinkRetries)
-> (TestName -> Maybe Int)
-> TestName
-> Maybe HedgehogShrinkRetries
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Maybe Int
forall a. Read a => TestName -> Maybe a
safeRead
optionName :: Tagged HedgehogShrinkRetries TestName
optionName = TestName -> Tagged HedgehogShrinkRetries TestName
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"hedgehog-retries"
optionHelp :: Tagged HedgehogShrinkRetries TestName
optionHelp = TestName -> Tagged HedgehogShrinkRetries TestName
forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"Number of times to re-run a test during shrinking"
propertyTestLimit :: PropertyConfig -> TestLimit
propertyTestLimit :: PropertyConfig -> TestLimit
propertyTestLimit =
let
getTestLimit :: TerminationCriteria -> TestLimit
getTestLimit (EarlyTermination Confidence
_ TestLimit
tests) = TestLimit
tests
getTestLimit (NoEarlyTermination Confidence
_ TestLimit
tests) = TestLimit
tests
getTestLimit (NoConfidenceTermination TestLimit
tests) = TestLimit
tests
in
TerminationCriteria -> TestLimit
getTestLimit (TerminationCriteria -> TestLimit)
-> (PropertyConfig -> TerminationCriteria)
-> PropertyConfig
-> TestLimit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyConfig -> TerminationCriteria
propertyTerminationCriteria
reportToProgress :: PropertyConfig
-> Report Progress
-> T.Progress
reportToProgress :: PropertyConfig -> Report Progress -> Progress
reportToProgress PropertyConfig
config (Report TestCount
testsDone DiscardCount
_ Coverage CoverCount
_ Progress
status) =
let
TestLimit Int
testLimit = PropertyConfig -> TestLimit
propertyTestLimit PropertyConfig
config
ShrinkLimit Int
shrinkLimit = PropertyConfig -> ShrinkLimit
propertyShrinkLimit PropertyConfig
config
ratio :: a -> a -> a
ratio a
x a
y = a
1.0 a -> a -> a
forall a. Num a => a -> a -> a
* a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x a -> a -> a
forall a. Fractional a => a -> a -> a
/ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
y
in
case Progress
status of
Progress
Running ->
TestName -> Float -> Progress
T.Progress TestName
"Running" (TestCount -> Int -> Float
forall a a a. (Fractional a, Integral a, Integral a) => a -> a -> a
ratio TestCount
testsDone Int
testLimit)
Shrinking FailureReport
fr ->
TestName -> Float -> Progress
T.Progress TestName
"Shrinking" (ShrinkCount -> Int -> Float
forall a a a. (Fractional a, Integral a, Integral a) => a -> a -> a
ratio (FailureReport -> ShrinkCount
failureShrinks FailureReport
fr) Int
shrinkLimit)
reportOutput :: Bool
-> UseColor
-> String
-> Report Result
-> IO String
reportOutput :: Bool -> UseColor -> TestName -> Report Result -> IO TestName
reportOutput Bool
showReplay UseColor
useColor TestName
name Report Result
report = do
TestName
s <- UseColor -> Maybe PropertyName -> Report Result -> IO TestName
forall (m :: * -> *).
MonadIO m =>
UseColor -> Maybe PropertyName -> Report Result -> m TestName
renderResult UseColor
useColor (PropertyName -> Maybe PropertyName
forall a. a -> Maybe a
Just (TestName -> PropertyName
PropertyName TestName
name)) Report Result
report
TestName -> IO TestName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestName -> IO TestName) -> TestName -> IO TestName
forall a b. (a -> b) -> a -> b
$ case Report Result -> Result
forall a. Report a -> a
reportStatus Report Result
report of
Failed FailureReport
fr ->
let
size :: Size
size = FailureReport -> Size
failureSize FailureReport
fr
seed :: Seed
seed = FailureReport -> Seed
failureSeed FailureReport
fr
replayStr :: TestName
replayStr =
if Bool
showReplay
then
TestName
"\nUse '--hedgehog-replay \"" TestName -> ShowS
forall a. [a] -> [a] -> [a]
++
Size -> TestName
forall a. Show a => a -> TestName
show Size
size TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
" " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Seed -> TestName
forall a. Show a => a -> TestName
show Seed
seed TestName -> ShowS
forall a. [a] -> [a] -> [a]
++
TestName
"\"' to reproduce."
else TestName
""
in
TestName
s TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
replayStr TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
"\n"
Result
_ -> TestName
s
instance T.IsTest HP where
testOptions :: Tagged HP [OptionDescription]
testOptions =
[OptionDescription] -> Tagged HP [OptionDescription]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Proxy HedgehogReplay -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy HedgehogReplay
forall k (t :: k). Proxy t
Proxy :: Proxy HedgehogReplay)
, Proxy HedgehogShowReplay -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy HedgehogShowReplay
forall k (t :: k). Proxy t
Proxy :: Proxy HedgehogShowReplay)
, Proxy HedgehogTestLimit -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy HedgehogTestLimit
forall k (t :: k). Proxy t
Proxy :: Proxy HedgehogTestLimit)
, Proxy HedgehogDiscardLimit -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy HedgehogDiscardLimit
forall k (t :: k). Proxy t
Proxy :: Proxy HedgehogDiscardLimit)
, Proxy HedgehogShrinkLimit -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy HedgehogShrinkLimit
forall k (t :: k). Proxy t
Proxy :: Proxy HedgehogShrinkLimit)
, Proxy HedgehogShrinkRetries -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy HedgehogShrinkRetries
forall k (t :: k). Proxy t
Proxy :: Proxy HedgehogShrinkRetries)
]
run :: OptionSet -> HP -> (Progress -> IO ()) -> IO Result
run OptionSet
opts (HP TestName
name (Property PropertyConfig
pConfig PropertyT IO ()
pTest)) Progress -> IO ()
yieldProgress = do
UseColor
useColor <- IO UseColor
forall (m :: * -> *). MonadIO m => m UseColor
detectColor
let
HedgehogReplay Maybe (Size, Seed)
replay = OptionSet -> HedgehogReplay
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
HedgehogShowReplay Bool
showReplay = OptionSet -> HedgehogShowReplay
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
HedgehogTestLimit Maybe TestLimit
mTests = OptionSet -> HedgehogTestLimit
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
HedgehogDiscardLimit Maybe DiscardLimit
mDiscards = OptionSet -> HedgehogDiscardLimit
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
HedgehogShrinkLimit Maybe ShrinkLimit
mShrinks = OptionSet -> HedgehogShrinkLimit
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
HedgehogShrinkRetries Maybe ShrinkRetries
mRetries = OptionSet -> HedgehogShrinkRetries
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
config :: PropertyConfig
config =
DiscardLimit
-> ShrinkLimit
-> ShrinkRetries
-> TerminationCriteria
-> PropertyConfig
PropertyConfig
(DiscardLimit -> Maybe DiscardLimit -> DiscardLimit
forall a. a -> Maybe a -> a
fromMaybe (PropertyConfig -> DiscardLimit
propertyDiscardLimit PropertyConfig
pConfig) Maybe DiscardLimit
mDiscards)
(ShrinkLimit -> Maybe ShrinkLimit -> ShrinkLimit
forall a. a -> Maybe a -> a
fromMaybe (PropertyConfig -> ShrinkLimit
propertyShrinkLimit PropertyConfig
pConfig) Maybe ShrinkLimit
mShrinks)
(ShrinkRetries -> Maybe ShrinkRetries -> ShrinkRetries
forall a. a -> Maybe a -> a
fromMaybe (PropertyConfig -> ShrinkRetries
propertyShrinkRetries PropertyConfig
pConfig) Maybe ShrinkRetries
mRetries)
(TestLimit -> TerminationCriteria
NoConfidenceTermination (TestLimit -> TerminationCriteria)
-> TestLimit -> TerminationCriteria
forall a b. (a -> b) -> a -> b
$ TestLimit -> Maybe TestLimit -> TestLimit
forall a. a -> Maybe a -> a
fromMaybe (PropertyConfig -> TestLimit
propertyTestLimit PropertyConfig
pConfig) Maybe TestLimit
mTests)
Seed
randSeed <- IO Seed
forall (m :: * -> *). MonadIO m => m Seed
Seed.random
let
size :: Size
size = Size -> ((Size, Seed) -> Size) -> Maybe (Size, Seed) -> Size
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Size
0 (Size, Seed) -> Size
forall a b. (a, b) -> a
fst Maybe (Size, Seed)
replay
seed :: Seed
seed = Seed -> ((Size, Seed) -> Seed) -> Maybe (Size, Seed) -> Seed
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Seed
randSeed (Size, Seed) -> Seed
forall a b. (a, b) -> b
snd Maybe (Size, Seed)
replay
Report Result
report <- PropertyConfig
-> Size
-> Seed
-> PropertyT IO ()
-> (Report Progress -> IO ())
-> IO (Report Result)
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
PropertyConfig
-> Size
-> Seed
-> PropertyT m ()
-> (Report Progress -> m ())
-> m (Report Result)
checkReport PropertyConfig
config Size
size Seed
seed PropertyT IO ()
pTest (Progress -> IO ()
yieldProgress (Progress -> IO ())
-> (Report Progress -> Progress) -> Report Progress -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyConfig -> Report Progress -> Progress
reportToProgress PropertyConfig
config)
let
resultFn :: TestName -> Result
resultFn = if Report Result -> Result
forall a. Report a -> a
reportStatus Report Result
report Result -> Result -> Bool
forall a. Eq a => a -> a -> Bool
== Result
OK
then TestName -> Result
T.testPassed
else TestName -> Result
T.testFailed
TestName
out <- Bool -> UseColor -> TestName -> Report Result -> IO TestName
reportOutput Bool
showReplay UseColor
useColor TestName
name Report Result
report
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ TestName -> Result
resultFn TestName
out