{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE CPP #-}
module Test.Sandwich.Hedgehog (
introduceHedgehog
, introduceHedgehog'
, introduceHedgehog''
, prop
, HedgehogParams
, defaultHedgehogParams
, hedgehogDiscardLimit
, hedgehogShrinkLimit
, hedgehogShrinkRetries
, hedgehogTerminationCriteria
#if MIN_VERSION_hedgehog(1,2,0)
, hedgehogSkip
#endif
, hedgehogSize
, hedgehogSeed
, introduceHedgehogCommandLineOptions
, introduceHedgehogCommandLineOptions'
, introduceHedgehogCommandLineOptions''
, addCommandLineOptions
, modifyArgs
, modifyDiscardLimit
, modifyShrinkLimit
, modifyShrinkRetries
, modifyTerminationCriteria
#if MIN_VERSION_hedgehog(1,2,0)
, modifySkip
#endif
, modifySize
, modifySeed
, HasHedgehogContext
) where
import Control.Applicative
import Control.Monad.Catch (MonadCatch)
import Control.Monad.Free
import Control.Monad.IO.Class
import Data.Maybe
import Data.String.Interpolate
import GHC.Stack
import Hedgehog as H
import Hedgehog.Internal.Config (UseColor (..))
import Hedgehog.Internal.Property (PropertyConfig(..), TerminationCriteria, defaultConfig)
import Hedgehog.Internal.Report (Report(..), Result(..), ppResult, renderProgress, renderResult)
import Hedgehog.Internal.Runner (checkReport)
import Hedgehog.Internal.Seed (random)
import Test.Sandwich
import Test.Sandwich.Internal
import UnliftIO.Exception
#ifndef mingw32_HOST_OS
import Test.Sandwich.Hedgehog.Render
#endif
data HedgehogParams = HedgehogParams {
HedgehogParams -> Maybe Seed
hedgehogSeed :: Maybe Seed
, HedgehogParams -> Maybe Size
hedgehogSize :: Maybe Size
, HedgehogParams -> Maybe DiscardLimit
hedgehogDiscardLimit :: Maybe DiscardLimit
, HedgehogParams -> Maybe ShrinkLimit
hedgehogShrinkLimit :: Maybe ShrinkLimit
, HedgehogParams -> Maybe ShrinkRetries
hedgehogShrinkRetries :: Maybe ShrinkRetries
, HedgehogParams -> Maybe TerminationCriteria
hedgehogTerminationCriteria :: Maybe TerminationCriteria
#if MIN_VERSION_hedgehog(1,2,0)
, HedgehogParams -> Maybe Skip
hedgehogSkip :: Maybe Skip
#endif
} deriving (Int -> HedgehogParams -> ShowS
[HedgehogParams] -> ShowS
HedgehogParams -> String
(Int -> HedgehogParams -> ShowS)
-> (HedgehogParams -> String)
-> ([HedgehogParams] -> ShowS)
-> Show HedgehogParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HedgehogParams -> ShowS
showsPrec :: Int -> HedgehogParams -> ShowS
$cshow :: HedgehogParams -> String
show :: HedgehogParams -> String
$cshowList :: [HedgehogParams] -> ShowS
showList :: [HedgehogParams] -> ShowS
Show)
defaultHedgehogParams :: HedgehogParams
defaultHedgehogParams :: HedgehogParams
defaultHedgehogParams = HedgehogParams {
hedgehogSize :: Maybe Size
hedgehogSize = Maybe Size
forall a. Maybe a
Nothing
, hedgehogSeed :: Maybe Seed
hedgehogSeed = Maybe Seed
forall a. Maybe a
Nothing
, hedgehogDiscardLimit :: Maybe DiscardLimit
hedgehogDiscardLimit = Maybe DiscardLimit
forall a. Maybe a
Nothing
, hedgehogShrinkLimit :: Maybe ShrinkLimit
hedgehogShrinkLimit = Maybe ShrinkLimit
forall a. Maybe a
Nothing
, hedgehogShrinkRetries :: Maybe ShrinkRetries
hedgehogShrinkRetries = Maybe ShrinkRetries
forall a. Maybe a
Nothing
, hedgehogTerminationCriteria :: Maybe TerminationCriteria
hedgehogTerminationCriteria = Maybe TerminationCriteria
forall a. Maybe a
Nothing
#if MIN_VERSION_hedgehog(1,2,0)
, hedgehogSkip :: Maybe Skip
hedgehogSkip = Maybe Skip
forall a. Maybe a
Nothing
#endif
}
newtype HedgehogContext = HedgehogContext HedgehogParams
deriving Int -> HedgehogContext -> ShowS
[HedgehogContext] -> ShowS
HedgehogContext -> String
(Int -> HedgehogContext -> ShowS)
-> (HedgehogContext -> String)
-> ([HedgehogContext] -> ShowS)
-> Show HedgehogContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HedgehogContext -> ShowS
showsPrec :: Int -> HedgehogContext -> ShowS
$cshow :: HedgehogContext -> String
show :: HedgehogContext -> String
$cshowList :: [HedgehogContext] -> ShowS
showList :: [HedgehogContext] -> ShowS
Show
hedgehogContext :: Label "hedgehogContext" HedgehogContext
hedgehogContext :: Label "hedgehogContext" HedgehogContext
hedgehogContext = Label "hedgehogContext" HedgehogContext
forall {k} (l :: Symbol) (a :: k). Label l a
Label
type HasHedgehogContext context = HasLabel context "hedgehogContext" HedgehogContext
introduceHedgehog :: (MonadIO m)
=> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
introduceHedgehog :: forall (m :: * -> *) context.
MonadIO m =>
SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
introduceHedgehog = String
-> HedgehogParams
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall (m :: * -> *) context.
MonadIO m =>
String
-> HedgehogParams
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
introduceHedgehog'' String
"Introduce Hedgehog context" HedgehogParams
defaultHedgehogParams
introduceHedgehog' :: (MonadIO m)
=> HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
introduceHedgehog' :: forall (m :: * -> *) context.
MonadIO m =>
HedgehogParams
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
introduceHedgehog' = String
-> HedgehogParams
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall (m :: * -> *) context.
MonadIO m =>
String
-> HedgehogParams
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
introduceHedgehog'' String
"Introduce Hedgehog context"
introduceHedgehog'' :: (MonadIO m)
=> String -> HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
introduceHedgehog'' :: forall (m :: * -> *) context.
MonadIO m =>
String
-> HedgehogParams
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
introduceHedgehog'' String
msg HedgehogParams
params = String
-> Label "hedgehogContext" HedgehogContext
-> ExampleT context m HedgehogContext
-> (HedgehogContext -> ExampleT context m ())
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall intro (l :: Symbol) context (m :: * -> *).
(HasCallStack, Typeable intro) =>
String
-> Label l intro
-> ExampleT context m intro
-> (intro -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduce String
msg Label "hedgehogContext" HedgehogContext
hedgehogContext (HedgehogContext -> ExampleT context m HedgehogContext
forall a. a -> ExampleT context m a
forall (m :: * -> *) a. Monad m => a -> m a
return (HedgehogContext -> ExampleT context m HedgehogContext)
-> HedgehogContext -> ExampleT context m HedgehogContext
forall a b. (a -> b) -> a -> b
$ HedgehogParams -> HedgehogContext
HedgehogContext HedgehogParams
params) (ExampleT context m () -> HedgehogContext -> ExampleT context m ()
forall a b. a -> b -> a
const (ExampleT context m () -> HedgehogContext -> ExampleT context m ())
-> ExampleT context m ()
-> HedgehogContext
-> ExampleT context m ()
forall a b. (a -> b) -> a -> b
$ () -> ExampleT context m ()
forall a. a -> ExampleT context m a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
introduceHedgehogCommandLineOptions :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a))
=> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
introduceHedgehogCommandLineOptions :: forall a (m :: * -> *) context.
(MonadIO m,
HasLabel context "commandLineOptions" (CommandLineOptions a)) =>
SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
introduceHedgehogCommandLineOptions = forall a (m :: * -> *) context.
(MonadIO m,
HasLabel context "commandLineOptions" (CommandLineOptions a)) =>
String
-> HedgehogParams
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
introduceHedgehogCommandLineOptions'' @a String
"Introduce Hedgehog context with command line options" HedgehogParams
defaultHedgehogParams
introduceHedgehogCommandLineOptions' :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a))
=> HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
introduceHedgehogCommandLineOptions' :: forall a (m :: * -> *) context.
(MonadIO m,
HasLabel context "commandLineOptions" (CommandLineOptions a)) =>
HedgehogParams
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
introduceHedgehogCommandLineOptions' = forall a (m :: * -> *) context.
(MonadIO m,
HasLabel context "commandLineOptions" (CommandLineOptions a)) =>
String
-> HedgehogParams
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
introduceHedgehogCommandLineOptions'' @a String
"Introduce Hedgehog context with command line options"
introduceHedgehogCommandLineOptions'' :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a))
=> String -> HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
introduceHedgehogCommandLineOptions'' :: forall a (m :: * -> *) context.
(MonadIO m,
HasLabel context "commandLineOptions" (CommandLineOptions a)) =>
String
-> HedgehogParams
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
introduceHedgehogCommandLineOptions'' String
msg HedgehogParams
args = String
-> Label "hedgehogContext" HedgehogContext
-> ExampleT context m HedgehogContext
-> (HedgehogContext -> ExampleT context m ())
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall intro (l :: Symbol) context (m :: * -> *).
(HasCallStack, Typeable intro) =>
String
-> Label l intro
-> ExampleT context m intro
-> (intro -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduce String
msg Label "hedgehogContext" HedgehogContext
hedgehogContext ExampleT context m HedgehogContext
getContext' (ExampleT context m () -> HedgehogContext -> ExampleT context m ()
forall a b. a -> b -> a
const (ExampleT context m () -> HedgehogContext -> ExampleT context m ())
-> ExampleT context m ()
-> HedgehogContext
-> ExampleT context m ()
forall a b. (a -> b) -> a -> b
$ () -> ExampleT context m ()
forall a. a -> ExampleT context m a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
where
getContext' :: ExampleT context m HedgehogContext
getContext' = do
CommandLineOptions a
clo <- forall a context (m :: * -> *).
(HasCommandLineOptions context a, MonadReader context m,
MonadIO m) =>
m (CommandLineOptions a)
getCommandLineOptions @a
HedgehogContext -> ExampleT context m HedgehogContext
forall a. a -> ExampleT context m a
forall (m :: * -> *) a. Monad m => a -> m a
return (HedgehogContext -> ExampleT context m HedgehogContext)
-> HedgehogContext -> ExampleT context m HedgehogContext
forall a b. (a -> b) -> a -> b
$ HedgehogParams -> HedgehogContext
HedgehogContext (HedgehogParams -> HedgehogContext)
-> HedgehogParams -> HedgehogContext
forall a b. (a -> b) -> a -> b
$ CommandLineOptions a -> HedgehogParams -> HedgehogParams
forall a. CommandLineOptions a -> HedgehogParams -> HedgehogParams
addCommandLineOptions CommandLineOptions a
clo HedgehogParams
args
prop :: (HasCallStack, HasHedgehogContext context, MonadIO m, MonadCatch m) => String -> PropertyT (ExampleT context m) () -> Free (SpecCommand context m) ()
prop :: forall context (m :: * -> *).
(HasCallStack, HasHedgehogContext context, MonadIO m,
MonadCatch m) =>
String
-> PropertyT (ExampleT context m) ()
-> Free (SpecCommand context m) ()
prop String
msg PropertyT (ExampleT context m) ()
p = String -> ExampleT context m () -> Free (SpecCommand context m) ()
forall context (m :: * -> *).
HasCallStack =>
String -> ExampleT context m () -> Free (SpecCommand context m) ()
it String
msg (ExampleT context m () -> Free (SpecCommand context m) ())
-> ExampleT context m () -> Free (SpecCommand context m) ()
forall a b. (a -> b) -> a -> b
$ do
HedgehogContext (HedgehogParams {Maybe Size
Maybe Seed
Maybe TerminationCriteria
Maybe ShrinkRetries
Maybe Skip
Maybe ShrinkLimit
Maybe DiscardLimit
hedgehogDiscardLimit :: HedgehogParams -> Maybe DiscardLimit
hedgehogShrinkLimit :: HedgehogParams -> Maybe ShrinkLimit
hedgehogShrinkRetries :: HedgehogParams -> Maybe ShrinkRetries
hedgehogTerminationCriteria :: HedgehogParams -> Maybe TerminationCriteria
hedgehogSkip :: HedgehogParams -> Maybe Skip
hedgehogSize :: HedgehogParams -> Maybe Size
hedgehogSeed :: HedgehogParams -> Maybe Seed
hedgehogSeed :: Maybe Seed
hedgehogSize :: Maybe Size
hedgehogDiscardLimit :: Maybe DiscardLimit
hedgehogShrinkLimit :: Maybe ShrinkLimit
hedgehogShrinkRetries :: Maybe ShrinkRetries
hedgehogTerminationCriteria :: Maybe TerminationCriteria
hedgehogSkip :: Maybe Skip
..}) <- Label "hedgehogContext" HedgehogContext
-> ExampleT context m HedgehogContext
forall (m :: * -> *) context (l :: Symbol) a.
(Monad m, HasLabel context l a, HasCallStack,
MonadReader context m) =>
Label l a -> m a
getContext Label "hedgehogContext" HedgehogContext
hedgehogContext
let config :: PropertyConfig
config = PropertyConfig {
propertyDiscardLimit :: DiscardLimit
propertyDiscardLimit = DiscardLimit -> Maybe DiscardLimit -> DiscardLimit
forall a. a -> Maybe a -> a
fromMaybe (PropertyConfig -> DiscardLimit
propertyDiscardLimit PropertyConfig
defaultConfig) Maybe DiscardLimit
hedgehogDiscardLimit
, propertyShrinkLimit :: ShrinkLimit
propertyShrinkLimit = ShrinkLimit -> Maybe ShrinkLimit -> ShrinkLimit
forall a. a -> Maybe a -> a
fromMaybe (PropertyConfig -> ShrinkLimit
propertyShrinkLimit PropertyConfig
defaultConfig) Maybe ShrinkLimit
hedgehogShrinkLimit
, propertyShrinkRetries :: ShrinkRetries
propertyShrinkRetries = ShrinkRetries -> Maybe ShrinkRetries -> ShrinkRetries
forall a. a -> Maybe a -> a
fromMaybe (PropertyConfig -> ShrinkRetries
propertyShrinkRetries PropertyConfig
defaultConfig) Maybe ShrinkRetries
hedgehogShrinkRetries
, propertyTerminationCriteria :: TerminationCriteria
propertyTerminationCriteria = TerminationCriteria
-> Maybe TerminationCriteria -> TerminationCriteria
forall a. a -> Maybe a -> a
fromMaybe (PropertyConfig -> TerminationCriteria
propertyTerminationCriteria PropertyConfig
defaultConfig) Maybe TerminationCriteria
hedgehogTerminationCriteria
#if MIN_VERSION_hedgehog(1,2,0)
, propertySkip :: Maybe Skip
propertySkip = Maybe Skip
hedgehogSkip Maybe Skip -> Maybe Skip -> Maybe Skip
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PropertyConfig -> Maybe Skip
propertySkip PropertyConfig
defaultConfig
#endif
}
let size :: Size
size = Size -> Maybe Size -> Size
forall a. a -> Maybe a -> a
fromMaybe Size
0 Maybe Size
hedgehogSize
Seed
seed <- ExampleT context m Seed
-> (Seed -> ExampleT context m Seed)
-> Maybe Seed
-> ExampleT context m Seed
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExampleT context m Seed
forall (m :: * -> *). MonadIO m => m Seed
random Seed -> ExampleT context m Seed
forall a. a -> ExampleT context m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Seed
hedgehogSeed
Report Result
finalReport <- PropertyConfig
-> Size
-> Seed
-> PropertyT (ExampleT context m) ()
-> (Report Progress -> ExampleT context m ())
-> ExampleT context m (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 (ExampleT context m) ()
p ((Report Progress -> ExampleT context m ())
-> ExampleT context m (Report Result))
-> (Report Progress -> ExampleT context m ())
-> ExampleT context m (Report Result)
forall a b. (a -> b) -> a -> b
$ \progressReport :: Report Progress
progressReport@(Report {}) -> do
String
progress <- UseColor
-> Maybe PropertyName
-> Report Progress
-> ExampleT context m String
forall (m :: * -> *).
MonadIO m =>
UseColor -> Maybe PropertyName -> Report Progress -> m String
renderProgress UseColor
DisableColor Maybe PropertyName
forall a. Maybe a
Nothing Report Progress
progressReport
Text -> ExampleT context m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|#{progress}|]
#ifdef mingw32_HOST_OS
result <- renderResult EnableColor Nothing finalReport
case reportStatus finalReport of
Failed fr -> throwIO $ Reason (Just callStack) result
GaveUp -> throwIO $ Reason (Just callStack) result
OK -> info [i|#{result}|]
#else
Image
image <- (Image -> ExampleT context m Image
forall a. a -> ExampleT context m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Image -> ExampleT context m Image)
-> (Doc Markup -> Image) -> Doc Markup -> ExampleT context m Image
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Markup -> Image
renderHedgehogToImage) (Doc Markup -> ExampleT context m Image)
-> ExampleT context m (Doc Markup) -> ExampleT context m Image
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe PropertyName
-> Report Result -> ExampleT context m (Doc Markup)
forall (m :: * -> *).
MonadIO m =>
Maybe PropertyName -> Report Result -> m (Doc Markup)
ppResult Maybe PropertyName
forall a. Maybe a
Nothing Report Result
finalReport
String
resultText <- Int -> ShowS
dedent Int
2 ShowS -> ExampleT context m String -> ExampleT context m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UseColor
-> Maybe PropertyName -> Report Result -> ExampleT context m String
forall (m :: * -> *).
MonadIO m =>
UseColor -> Maybe PropertyName -> Report Result -> m String
renderResult UseColor
EnableColor Maybe PropertyName
forall a. Maybe a
Nothing Report Result
finalReport
case Report Result -> Result
forall a. Report a -> a
reportStatus Report Result
finalReport of
Failed FailureReport
_ -> FailureReason -> ExampleT context m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FailureReason -> ExampleT context m ())
-> FailureReason -> ExampleT context m ()
forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> String -> Image -> FailureReason
RawImage (CallStack -> Maybe CallStack
forall a. a -> Maybe a
Just CallStack
HasCallStack => CallStack
callStack) String
resultText Image
image
Result
GaveUp -> FailureReason -> ExampleT context m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FailureReason -> ExampleT context m ())
-> FailureReason -> ExampleT context m ()
forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> String -> Image -> FailureReason
RawImage (CallStack -> Maybe CallStack
forall a. a -> Maybe a
Just CallStack
HasCallStack => CallStack
callStack) String
resultText Image
image
Result
OK -> Text -> ExampleT context m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
info [i|#{resultText}|]
#endif
modifyArgs :: (
HasHedgehogContext context, Monad m
) => (HedgehogParams -> HedgehogParams) -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
modifyArgs :: forall context (m :: * -> *).
(HasHedgehogContext context, Monad m) =>
(HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
modifyArgs HedgehogParams -> HedgehogParams
f = String
-> Label "hedgehogContext" HedgehogContext
-> ExampleT context m HedgehogContext
-> (HedgehogContext -> ExampleT context m ())
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall intro (l :: Symbol) context (m :: * -> *).
(HasCallStack, Typeable intro) =>
String
-> Label l intro
-> ExampleT context m intro
-> (intro -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduce String
"Modified Hedgehog context" Label "hedgehogContext" HedgehogContext
hedgehogContext ExampleT context m HedgehogContext
acquire (ExampleT context m () -> HedgehogContext -> ExampleT context m ()
forall a b. a -> b -> a
const (ExampleT context m () -> HedgehogContext -> ExampleT context m ())
-> ExampleT context m ()
-> HedgehogContext
-> ExampleT context m ()
forall a b. (a -> b) -> a -> b
$ () -> ExampleT context m ()
forall a. a -> ExampleT context m a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
where
acquire :: ExampleT context m HedgehogContext
acquire = do
HedgehogContext HedgehogParams
params <- Label "hedgehogContext" HedgehogContext
-> ExampleT context m HedgehogContext
forall (m :: * -> *) context (l :: Symbol) a.
(Monad m, HasLabel context l a, HasCallStack,
MonadReader context m) =>
Label l a -> m a
getContext Label "hedgehogContext" HedgehogContext
hedgehogContext
HedgehogContext -> ExampleT context m HedgehogContext
forall a. a -> ExampleT context m a
forall (m :: * -> *) a. Monad m => a -> m a
return (HedgehogContext -> ExampleT context m HedgehogContext)
-> HedgehogContext -> ExampleT context m HedgehogContext
forall a b. (a -> b) -> a -> b
$ HedgehogParams -> HedgehogContext
HedgehogContext (HedgehogParams -> HedgehogParams
f HedgehogParams
params)
type HedgehogContextLabel context = LabelValue "hedgehogContext" HedgehogContext :> context
modifySeed :: (
HasHedgehogContext context, Monad m
) => (Maybe Seed -> Maybe Seed) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()
modifySeed :: forall context (m :: * -> *).
(HasHedgehogContext context, Monad m) =>
(Maybe Seed -> Maybe Seed)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
modifySeed Maybe Seed -> Maybe Seed
f = (HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall context (m :: * -> *).
(HasHedgehogContext context, Monad m) =>
(HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
modifyArgs ((HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ())
-> (HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \HedgehogParams
args -> HedgehogParams
args { hedgehogSeed = f (hedgehogSeed args) }
modifySize :: (
HasHedgehogContext context, Monad m
) => (Maybe Size -> Maybe Size) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()
modifySize :: forall context (m :: * -> *).
(HasHedgehogContext context, Monad m) =>
(Maybe Size -> Maybe Size)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
modifySize Maybe Size -> Maybe Size
f = (HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall context (m :: * -> *).
(HasHedgehogContext context, Monad m) =>
(HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
modifyArgs ((HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ())
-> (HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \HedgehogParams
args -> HedgehogParams
args { hedgehogSize = f (hedgehogSize args) }
modifyDiscardLimit :: (
HasHedgehogContext context, Monad m
) => (Maybe DiscardLimit -> Maybe DiscardLimit) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()
modifyDiscardLimit :: forall context (m :: * -> *).
(HasHedgehogContext context, Monad m) =>
(Maybe DiscardLimit -> Maybe DiscardLimit)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
modifyDiscardLimit Maybe DiscardLimit -> Maybe DiscardLimit
f = (HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall context (m :: * -> *).
(HasHedgehogContext context, Monad m) =>
(HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
modifyArgs ((HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ())
-> (HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \HedgehogParams
args -> HedgehogParams
args { hedgehogDiscardLimit = f (hedgehogDiscardLimit args) }
modifyShrinkLimit :: (
HasHedgehogContext context, Monad m
) => (Maybe ShrinkLimit -> Maybe ShrinkLimit) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()
modifyShrinkLimit :: forall context (m :: * -> *).
(HasHedgehogContext context, Monad m) =>
(Maybe ShrinkLimit -> Maybe ShrinkLimit)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
modifyShrinkLimit Maybe ShrinkLimit -> Maybe ShrinkLimit
f = (HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall context (m :: * -> *).
(HasHedgehogContext context, Monad m) =>
(HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
modifyArgs ((HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ())
-> (HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \HedgehogParams
args -> HedgehogParams
args { hedgehogShrinkLimit = f (hedgehogShrinkLimit args) }
modifyShrinkRetries :: (
HasHedgehogContext context, Monad m
) => (Maybe ShrinkRetries -> Maybe ShrinkRetries) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()
modifyShrinkRetries :: forall context (m :: * -> *).
(HasHedgehogContext context, Monad m) =>
(Maybe ShrinkRetries -> Maybe ShrinkRetries)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
modifyShrinkRetries Maybe ShrinkRetries -> Maybe ShrinkRetries
f = (HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall context (m :: * -> *).
(HasHedgehogContext context, Monad m) =>
(HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
modifyArgs ((HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ())
-> (HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \HedgehogParams
args -> HedgehogParams
args { hedgehogShrinkRetries = f (hedgehogShrinkRetries args) }
modifyTerminationCriteria :: (
HasHedgehogContext context, Monad m
) => (Maybe TerminationCriteria -> Maybe TerminationCriteria) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()
modifyTerminationCriteria :: forall context (m :: * -> *).
(HasHedgehogContext context, Monad m) =>
(Maybe TerminationCriteria -> Maybe TerminationCriteria)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
modifyTerminationCriteria Maybe TerminationCriteria -> Maybe TerminationCriteria
f = (HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall context (m :: * -> *).
(HasHedgehogContext context, Monad m) =>
(HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
modifyArgs ((HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ())
-> (HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \HedgehogParams
args -> HedgehogParams
args { hedgehogTerminationCriteria = f (hedgehogTerminationCriteria args) }
#if MIN_VERSION_hedgehog(1,2,0)
modifySkip :: (
HasHedgehogContext context, Monad m
) => (Maybe Skip -> Maybe Skip) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()
modifySkip :: forall context (m :: * -> *).
(HasHedgehogContext context, Monad m) =>
(Maybe Skip -> Maybe Skip)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
modifySkip Maybe Skip -> Maybe Skip
f = (HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall context (m :: * -> *).
(HasHedgehogContext context, Monad m) =>
(HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
modifyArgs ((HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ())
-> (HedgehogParams -> HedgehogParams)
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \HedgehogParams
args -> HedgehogParams
args { hedgehogSkip = f (hedgehogSkip args) }
#endif
addCommandLineOptions :: CommandLineOptions a -> HedgehogParams -> HedgehogParams
addCommandLineOptions :: forall a. CommandLineOptions a -> HedgehogParams -> HedgehogParams
addCommandLineOptions (CommandLineOptions {optHedgehogOptions :: forall a. CommandLineOptions a -> CommandLineHedgehogOptions
optHedgehogOptions=(CommandLineHedgehogOptions {Maybe Int
Maybe Integer
Maybe String
optHedgehogSeed :: Maybe String
optHedgehogSize :: Maybe Int
optHedgehogDiscardLimit :: Maybe Integer
optHedgehogShrinkLimit :: Maybe Integer
optHedgehogShrinkRetries :: Maybe Integer
optHedgehogSeed :: CommandLineHedgehogOptions -> Maybe String
optHedgehogSize :: CommandLineHedgehogOptions -> Maybe Int
optHedgehogDiscardLimit :: CommandLineHedgehogOptions -> Maybe Integer
optHedgehogShrinkLimit :: CommandLineHedgehogOptions -> Maybe Integer
optHedgehogShrinkRetries :: CommandLineHedgehogOptions -> Maybe Integer
..})}) baseHedgehogParams :: HedgehogParams
baseHedgehogParams@(HedgehogParams {Maybe Size
Maybe Seed
Maybe TerminationCriteria
Maybe ShrinkRetries
Maybe Skip
Maybe ShrinkLimit
Maybe DiscardLimit
hedgehogDiscardLimit :: HedgehogParams -> Maybe DiscardLimit
hedgehogShrinkLimit :: HedgehogParams -> Maybe ShrinkLimit
hedgehogShrinkRetries :: HedgehogParams -> Maybe ShrinkRetries
hedgehogTerminationCriteria :: HedgehogParams -> Maybe TerminationCriteria
hedgehogSkip :: HedgehogParams -> Maybe Skip
hedgehogSize :: HedgehogParams -> Maybe Size
hedgehogSeed :: HedgehogParams -> Maybe Seed
hedgehogSeed :: Maybe Seed
hedgehogSize :: Maybe Size
hedgehogDiscardLimit :: Maybe DiscardLimit
hedgehogShrinkLimit :: Maybe ShrinkLimit
hedgehogShrinkRetries :: Maybe ShrinkRetries
hedgehogTerminationCriteria :: Maybe TerminationCriteria
hedgehogSkip :: Maybe Skip
..}) = HedgehogParams
baseHedgehogParams {
hedgehogSeed = (read <$> optHedgehogSeed) <|> hedgehogSeed
, hedgehogSize = (fromIntegral <$> optHedgehogSize) <|> hedgehogSize
, hedgehogDiscardLimit = (fromIntegral <$> optHedgehogDiscardLimit) <|> hedgehogDiscardLimit
, hedgehogShrinkLimit = (fromIntegral <$> optHedgehogShrinkLimit) <|> hedgehogShrinkLimit
, hedgehogShrinkRetries = (fromIntegral <$> optHedgehogShrinkRetries) <|> hedgehogShrinkRetries
}