{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Test.Tasty.HedgehogTest
( HedgehogTest (..),
HedgehogTestLimit (..),
HedgehogDiscardLimit (..),
HedgehogShrinkLimit (..),
HedgehogShrinkRetries (..),
HedgehogReplay (..),
HedgehogShowReplay (..),
ModuleName (..),
testProperty,
groupByModuleName,
getModuleName,
)
where
import Data.MultiMap hiding (foldr, size)
import GHC.Stack
import Hedgehog hiding (test, (===))
import Hedgehog.Internal.Config (UseColor, detectColor)
import Hedgehog.Internal.Property
import Hedgehog.Internal.Report as Hedgehog
import Hedgehog.Internal.Runner as Hedgehog
import Hedgehog.Internal.Seed as Seed
import Protolude as P hiding (empty, toList, unwords, words)
import qualified Protolude as P
import Test.Tasty as Tasty
import Test.Tasty.Options as Tasty
import Test.Tasty.Providers as Tasty
import Test.Tasty.Runners as Tasty
( TestTree (..),
foldSingle,
foldTestTree,
trivialFold,
)
import Prelude (String, unwords, words)
data HedgehogTest = HedgehogTest Tasty.TestName Property
deriving (Typeable)
testProperty :: Tasty.TestName -> Property -> Tasty.TestTree
testProperty :: TestName -> Property -> TestTree
testProperty TestName
name Property
prop = forall t. IsTest t => TestName -> t -> TestTree
singleTest TestName
name (TestName -> Property -> HedgehogTest
HedgehogTest TestName
name Property
prop)
instance Tasty.IsTest HedgehogTest where
testOptions :: Tagged HedgehogTest [OptionDescription]
testOptions =
forall (m :: * -> *) a. Monad m => a -> m a
return
[ forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy HedgehogReplay),
forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy HedgehogShowReplay),
forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy HedgehogTestLimit),
forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy HedgehogDiscardLimit),
forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy HedgehogShrinkLimit),
forall v. IsOption v => Proxy v -> OptionDescription
Tasty.Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy HedgehogShrinkRetries)
]
run :: OptionSet -> HedgehogTest -> (Progress -> IO ()) -> IO Result
run OptionSet
opts (HedgehogTest TestName
name (Property PropertyConfig
pConfig PropertyT IO ()
pTest)) Progress -> IO ()
yieldProgress = do
UseColor
useColor <- forall (m :: * -> *). MonadIO m => m UseColor
detectColor
let HedgehogReplay Maybe (Size, Seed)
replay = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
HedgehogTestLimit Maybe TestLimit
mTests = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
HedgehogDiscardLimit Maybe DiscardLimit
mDiscards = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
HedgehogShrinkLimit Maybe ShrinkLimit
mShrinks = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
HedgehogShrinkRetries Maybe ShrinkRetries
mRetries = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
showReplay :: HedgehogShowReplay
showReplay = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
config :: PropertyConfig
config =
DiscardLimit
-> ShrinkLimit
-> ShrinkRetries
-> TerminationCriteria
-> PropertyConfig
PropertyConfig
(forall a. a -> Maybe a -> a
fromMaybe (PropertyConfig -> DiscardLimit
propertyDiscardLimit PropertyConfig
pConfig) Maybe DiscardLimit
mDiscards)
(forall a. a -> Maybe a -> a
fromMaybe (PropertyConfig -> ShrinkLimit
propertyShrinkLimit PropertyConfig
pConfig) Maybe ShrinkLimit
mShrinks)
(forall a. a -> Maybe a -> a
fromMaybe (PropertyConfig -> ShrinkRetries
propertyShrinkRetries PropertyConfig
pConfig) Maybe ShrinkRetries
mRetries)
(TestLimit -> TerminationCriteria
NoConfidenceTermination forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (PropertyConfig -> TestLimit
propertyTestLimit PropertyConfig
pConfig) Maybe TestLimit
mTests)
Seed
randSeed <- forall (m :: * -> *). MonadIO m => m Seed
Seed.random
let minSize :: Size
minSize = if PropertyConfig -> TestLimit
propertyTestLimit PropertyConfig
config forall a. Eq a => a -> a -> Bool
== TestLimit
1 then Size
50 else Size
0
let size :: Size
size = forall b a. b -> (a -> b) -> Maybe a -> b
P.maybe Size
minSize forall a b. (a, b) -> a
fst Maybe (Size, Seed)
replay
seed :: Seed
seed = forall b a. b -> (a -> b) -> Maybe a -> b
P.maybe Seed
randSeed forall a b. (a, b) -> b
snd Maybe (Size, Seed)
replay
Report Result
report <- 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyConfig -> Report Progress -> Progress
reportToProgress PropertyConfig
config)
let resultFn :: TestName -> Result
resultFn =
if forall a. Report a -> a
reportStatus Report Result
report forall a. Eq a => a -> a -> Bool
== Result
OK
then TestName -> Result
testPassed
else TestName -> Result
testFailed
TestName
out <- HedgehogShowReplay
-> UseColor -> TestName -> Report Result -> IO TestName
reportOutput HedgehogShowReplay
showReplay UseColor
useColor TestName
name Report Result
report
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TestName -> Result
resultFn TestName
out
reportToProgress ::
PropertyConfig ->
Report Hedgehog.Progress ->
Tasty.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 forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x forall a. Fractional 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
Tasty.Progress TestName
"Running" (forall {a} {a} {a}.
(Fractional a, Integral a, Integral a) =>
a -> a -> a
ratio TestCount
testsDone Int
testLimit)
Shrinking FailureReport
fr ->
TestName -> Float -> Progress
Tasty.Progress TestName
"Shrinking" (forall {a} {a} {a}.
(Fractional a, Integral a, Integral a) =>
a -> a -> a
ratio (FailureReport -> ShrinkCount
failureShrinks FailureReport
fr) Int
shrinkLimit)
reportOutput ::
HedgehogShowReplay ->
UseColor ->
String ->
Report Hedgehog.Result ->
IO String
reportOutput :: HedgehogShowReplay
-> UseColor -> TestName -> Report Result -> IO TestName
reportOutput (HedgehogShowReplay Bool
showReplay) UseColor
useColor TestName
name Report Result
report = do
TestName
s <- forall (m :: * -> *).
MonadIO m =>
UseColor -> Maybe PropertyName -> Report Result -> m TestName
renderResult UseColor
useColor (forall a. a -> Maybe a
Just (TestName -> PropertyName
PropertyName TestName
name)) Report Result
report
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case 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
" --hedgehog-replay \""
forall a. [a] -> [a] -> [a]
++ forall a b. (Show a, StringConv TestName b) => a -> b
show Size
size
forall a. [a] -> [a] -> [a]
++ TestName
" "
forall a. [a] -> [a] -> [a]
++ forall a b. (Show a, StringConv TestName b) => a -> b
show Seed
seed
forall a. [a] -> [a] -> [a]
++ TestName
"\""
else TestName
""
in TestName
s forall a. [a] -> [a] -> [a]
++ TestName
replayStr forall a. [a] -> [a] -> [a]
++ TestName
"\n"
Result
GaveUp ->
TestName
s
Result
OK ->
if Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
P.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
P.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Coverage a -> Map LabelName (Label a)
coverageLabels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Report a -> Coverage CoverCount
reportCoverage forall a b. (a -> b) -> a -> b
$ Report Result
report
then TestName
s
else TestName
""
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyConfig -> TerminationCriteria
propertyTerminationCriteria
newtype HedgehogReplay = HedgehogReplay (Maybe (Size, Seed))
deriving (Typeable)
instance IsOption HedgehogReplay where
defaultValue :: HedgehogReplay
defaultValue = Maybe (Size, Seed) -> HedgehogReplay
HedgehogReplay forall a. Maybe a
Nothing
parseValue :: TestName -> Maybe HedgehogReplay
parseValue TestName
v = Maybe (Size, Seed) -> HedgehogReplay
HedgehogReplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Size, Seed)
replay
where
replay :: Maybe (Size, Seed)
replay = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Read a => TestName -> Maybe a
safeRead ([TestName] -> TestName
unwords [TestName]
size) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Read a => TestName -> Maybe a
safeRead ([TestName] -> TestName
unwords [TestName]
seed)
([TestName]
size, [TestName]
seed) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
2 forall a b. (a -> b) -> a -> b
$ TestName -> [TestName]
words TestName
v
optionName :: Tagged HedgehogReplay TestName
optionName = forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"hedgehog-replay"
optionHelp :: Tagged HedgehogReplay TestName
optionHelp = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> HedgehogShowReplay
HedgehogShowReplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => TestName -> Maybe a
safeRead
optionName :: Tagged HedgehogShowReplay TestName
optionName = forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"hedgehog-show-replay"
optionHelp :: Tagged HedgehogShowReplay TestName
optionHelp = 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
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
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
Ord, Int -> HedgehogTestLimit -> ShowS
[HedgehogTestLimit] -> ShowS
HedgehogTestLimit -> TestName
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 forall a. Maybe a
Nothing
parseValue :: TestName -> Maybe HedgehogTestLimit
parseValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe TestLimit -> HedgehogTestLimit
HedgehogTestLimit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TestLimit
TestLimit) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => TestName -> Maybe a
safeRead
optionName :: Tagged HedgehogTestLimit TestName
optionName = forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"hedgehog-tests"
optionHelp :: Tagged HedgehogTestLimit TestName
optionHelp = 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
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
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
Ord, Int -> HedgehogDiscardLimit -> ShowS
[HedgehogDiscardLimit] -> ShowS
HedgehogDiscardLimit -> TestName
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 forall a. Maybe a
Nothing
parseValue :: TestName -> Maybe HedgehogDiscardLimit
parseValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe DiscardLimit -> HedgehogDiscardLimit
HedgehogDiscardLimit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DiscardLimit
DiscardLimit) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => TestName -> Maybe a
safeRead
optionName :: Tagged HedgehogDiscardLimit TestName
optionName = forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"hedgehog-discards"
optionHelp :: Tagged HedgehogDiscardLimit TestName
optionHelp = 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
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
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
Ord, Int -> HedgehogShrinkLimit -> ShowS
[HedgehogShrinkLimit] -> ShowS
HedgehogShrinkLimit -> TestName
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 forall a. Maybe a
Nothing
parseValue :: TestName -> Maybe HedgehogShrinkLimit
parseValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe ShrinkLimit -> HedgehogShrinkLimit
HedgehogShrinkLimit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShrinkLimit
ShrinkLimit) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => TestName -> Maybe a
safeRead
optionName :: Tagged HedgehogShrinkLimit TestName
optionName = forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"hedgehog-shrinks"
optionHelp :: Tagged HedgehogShrinkLimit TestName
optionHelp = 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
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
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
Ord, Int -> HedgehogShrinkRetries -> ShowS
[HedgehogShrinkRetries] -> ShowS
HedgehogShrinkRetries -> TestName
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 forall a. Maybe a
Nothing
parseValue :: TestName -> Maybe HedgehogShrinkRetries
parseValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe ShrinkRetries -> HedgehogShrinkRetries
HedgehogShrinkRetries forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShrinkRetries
ShrinkRetries) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => TestName -> Maybe a
safeRead
optionName :: Tagged HedgehogShrinkRetries TestName
optionName = forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"hedgehog-retries"
optionHelp :: Tagged HedgehogShrinkRetries TestName
optionHelp = forall (m :: * -> *) a. Monad m => a -> m a
return TestName
"Number of times to re-run a test during shrinking"
groupByModuleName :: TestTree -> TestTree
groupByModuleName :: TestTree -> TestTree
groupByModuleName TestTree
testTree =
let grouped :: [(TestName, [TestTree])]
grouped =
forall k a. MultiMap k a -> [(k, [a])]
assocs forall a b. (a -> b) -> a -> b
$
forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree
( forall b. Monoid b => TreeFold b
trivialFold
{ foldSingle :: forall t.
IsTest t =>
OptionSet -> TestName -> t -> MultiMap TestName TestTree
foldSingle = \OptionSet
os TestName
n t
t ->
let (ModuleName Text
aModuleName) = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
os :: ModuleName
in forall k a. Ord k => k -> a -> MultiMap k a -> MultiMap k a
insert (forall a b. ConvertText a b => a -> b
toS Text
aModuleName) (OptionSet -> TestTree -> TestTree
setOptionSet OptionSet
os forall a b. (a -> b) -> a -> b
$ forall t. IsTest t => TestName -> t -> TestTree
singleTest TestName
n t
t) forall k a. MultiMap k a
empty
}
)
forall a. Monoid a => a
mempty
TestTree
testTree
in TestName -> [TestTree] -> TestTree
TestGroup TestName
"All" (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TestName -> [TestTree] -> TestTree
TestGroup forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TestName, [TestTree])]
grouped)
newtype ModuleName = ModuleName Text deriving (ModuleName -> ModuleName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleName -> ModuleName -> Bool
$c/= :: ModuleName -> ModuleName -> Bool
== :: ModuleName -> ModuleName -> Bool
$c== :: ModuleName -> ModuleName -> Bool
Eq, Int -> ModuleName -> ShowS
[ModuleName] -> ShowS
ModuleName -> TestName
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
showList :: [ModuleName] -> ShowS
$cshowList :: [ModuleName] -> ShowS
show :: ModuleName -> TestName
$cshow :: ModuleName -> TestName
showsPrec :: Int -> ModuleName -> ShowS
$cshowsPrec :: Int -> ModuleName -> ShowS
Show)
instance IsOption ModuleName where
defaultValue :: ModuleName
defaultValue = Text -> ModuleName
ModuleName Text
"root"
parseValue :: TestName -> Maybe ModuleName
parseValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ModuleName
ModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => TestName -> Maybe a
safeRead
optionName :: Tagged ModuleName TestName
optionName = forall (f :: * -> *) a. Applicative f => a -> f a
pure TestName
"module-name"
optionHelp :: Tagged ModuleName TestName
optionHelp = forall (f :: * -> *) a. Applicative f => a -> f a
pure TestName
"internal option used to group tests into the same module"
optionCLParser :: Parser ModuleName
optionCLParser = forall v. IsOption v => Mod FlagFields v -> v -> Parser v
mkFlagCLParser forall a. Monoid a => a
mempty (Text -> ModuleName
ModuleName Text
"root")
instance (Ord k) => Semigroup (MultiMap k v) where
<> :: MultiMap k v -> MultiMap k v -> MultiMap k v
(<>) MultiMap k v
m1 MultiMap k v
m2 = forall k a. Ord k => [(k, a)] -> MultiMap k a
fromList (forall k a. MultiMap k a -> [(k, a)]
toList MultiMap k v
m1 forall a. Semigroup a => a -> a -> a
<> forall k a. MultiMap k a -> [(k, a)]
toList MultiMap k v
m2)
instance (Ord k) => Monoid (MultiMap k v) where
mempty :: MultiMap k v
mempty = forall k a. MultiMap k a
empty
mappend :: MultiMap k v -> MultiMap k v -> MultiMap k v
mappend = forall a. Semigroup a => a -> a -> a
(<>)
setOptionSet :: OptionSet -> TestTree -> TestTree
setOptionSet :: OptionSet -> TestTree -> TestTree
setOptionSet OptionSet
os =
forall v. IsOption v => v -> TestTree -> TestTree
localOption (forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
os :: HedgehogTestLimit)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. IsOption v => v -> TestTree -> TestTree
localOption (forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
os :: HedgehogShrinkLimit)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. IsOption v => v -> TestTree -> TestTree
localOption (forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
os :: HedgehogReplay)
getModuleName :: HasCallStack => Prelude.String
getModuleName :: HasCallStack => TestName
getModuleName =
case CallStack -> [(TestName, SrcLoc)]
getCallStack HasCallStack => CallStack
callStack of
((TestName
_, SrcLoc
loc) : [(TestName, SrcLoc)]
_) -> SrcLoc -> TestName
srcLocModule SrcLoc
loc
[(TestName, SrcLoc)]
_ -> TestName
"root"