{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
module Test.Sandwich.Hedgehog (
introduceHedgehog
, introduceHedgehog'
, introduceHedgehog''
, prop
, HedgehogParams
, defaultHedgehogParams
, hedgehogDiscardLimit
, hedgehogShrinkLimit
, hedgehogShrinkRetries
, hedgehogTerminationCriteria
, hedgehogSize
, hedgehogSeed
, introduceHedgehogCommandLineOptions
, introduceHedgehogCommandLineOptions'
, introduceHedgehogCommandLineOptions''
, addCommandLineOptions
, modifyArgs
, modifyDiscardLimit
, modifyShrinkLimit
, modifyShrinkRetries
, modifyTerminationCriteria
, modifySize
, modifySeed
, HasHedgehogContext
) where
import Control.Applicative
import Control.Exception.Safe
import Control.Monad.Free
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Maybe
import Data.String.Interpolate
import GHC.Stack
import Hedgehog as H
import Hedgehog.Internal.Config (UseColor (..))
import Hedgehog.Internal.Property hiding (Label)
import Hedgehog.Internal.Report as H
import Hedgehog.Internal.Runner as HR
import Hedgehog.Internal.Seed as Seed
import Test.Sandwich
import Test.Sandwich.Hedgehog.Render
import Test.Sandwich.Internal
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
} 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
showList :: [HedgehogParams] -> ShowS
$cshowList :: [HedgehogParams] -> ShowS
show :: HedgehogParams -> String
$cshow :: HedgehogParams -> String
showsPrec :: Int -> HedgehogParams -> ShowS
$cshowsPrec :: Int -> HedgehogParams -> ShowS
Show)
defaultHedgehogParams :: HedgehogParams
defaultHedgehogParams = HedgehogParams :: Maybe Seed
-> Maybe Size
-> Maybe DiscardLimit
-> Maybe ShrinkLimit
-> Maybe ShrinkRetries
-> Maybe TerminationCriteria
-> HedgehogParams
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
}
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
showList :: [HedgehogContext] -> ShowS
$cshowList :: [HedgehogContext] -> ShowS
show :: HedgehogContext -> String
$cshow :: HedgehogContext -> String
showsPrec :: Int -> HedgehogContext -> ShowS
$cshowsPrec :: Int -> HedgehogContext -> ShowS
Show
hedgehogContext :: Label "hedgehogContext" HedgehogContext
hedgehogContext = Label "hedgehogContext" HedgehogContext
forall k (l :: Symbol) (a :: k). Label l a
Label :: Label "hedgehogContext" HedgehogContext
type HasHedgehogContext context = HasLabel context "hedgehogContext" HedgehogContext
introduceHedgehog :: (MonadIO m, MonadBaseControl IO m)
=> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
introduceHedgehog :: 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, MonadBaseControl IO m) =>
String
-> HedgehogParams
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
introduceHedgehog'' String
"Introduce Hedgehog context" HedgehogParams
defaultHedgehogParams
introduceHedgehog' :: (MonadIO m, MonadBaseControl IO m)
=> HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
introduceHedgehog' :: 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, MonadBaseControl IO m) =>
String
-> HedgehogParams
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
introduceHedgehog'' String
"Introduce Hedgehog context"
introduceHedgehog'' :: (MonadIO m, MonadBaseControl IO m)
=> String -> HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
introduceHedgehog'' :: 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 (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 (m :: * -> *) a. Monad m => a -> m a
return ())
introduceHedgehogCommandLineOptions :: forall a m context. (MonadIO m, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m)
=> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
introduceHedgehogCommandLineOptions :: SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
introduceHedgehogCommandLineOptions = String
-> HedgehogParams
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall a (m :: * -> *) context.
(MonadIO m, MonadBaseControl IO m,
HasLabel context "commandLineOptions" (CommandLineOptions a),
MonadReader context m) =>
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, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m)
=> HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
introduceHedgehogCommandLineOptions' :: HedgehogParams
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
introduceHedgehogCommandLineOptions' = String
-> HedgehogParams
-> SpecFree
(LabelValue "hedgehogContext" HedgehogContext :> context) m ()
-> SpecFree context m ()
forall a (m :: * -> *) context.
(MonadIO m, MonadBaseControl IO m,
HasLabel context "commandLineOptions" (CommandLineOptions a),
MonadReader context m) =>
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, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m)
=> String -> HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m ()
introduceHedgehogCommandLineOptions'' :: 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 (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)
forall context (m :: * -> *).
(HasCommandLineOptions context a, MonadReader context m,
MonadIO m) =>
m (CommandLineOptions a)
getCommandLineOptions @a
HedgehogContext -> ExampleT context m HedgehogContext
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 :: 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 DiscardLimit
Maybe ShrinkLimit
Maybe ShrinkRetries
Maybe TerminationCriteria
Maybe Seed
Maybe Size
hedgehogTerminationCriteria :: Maybe TerminationCriteria
hedgehogShrinkRetries :: Maybe ShrinkRetries
hedgehogShrinkLimit :: Maybe ShrinkLimit
hedgehogDiscardLimit :: Maybe DiscardLimit
hedgehogSize :: Maybe Size
hedgehogSeed :: Maybe Seed
hedgehogSeed :: HedgehogParams -> Maybe Seed
hedgehogSize :: HedgehogParams -> Maybe Size
hedgehogTerminationCriteria :: HedgehogParams -> Maybe TerminationCriteria
hedgehogShrinkRetries :: HedgehogParams -> Maybe ShrinkRetries
hedgehogShrinkLimit :: HedgehogParams -> Maybe ShrinkLimit
hedgehogDiscardLimit :: HedgehogParams -> Maybe DiscardLimit
..}) <- 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 :: DiscardLimit
-> ShrinkLimit
-> ShrinkRetries
-> TerminationCriteria
-> PropertyConfig
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
}
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
Seed.random Seed -> ExampleT context m Seed
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 {Progress
TestCount
DiscardCount
Coverage CoverCount
reportTests :: forall a. Report a -> TestCount
reportDiscards :: forall a. Report a -> DiscardCount
reportCoverage :: forall a. Report a -> Coverage CoverCount
reportStatus :: forall a. Report a -> a
reportStatus :: Progress
reportCoverage :: Coverage CoverCount
reportDiscards :: DiscardCount
reportTests :: TestCount
..}) -> 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}|]
Image
image <- (Image -> ExampleT context m Image
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
H.Failed FailureReport
_ -> FailureReason -> ExampleT context m ()
forall (m :: * -> *) e a. (MonadThrow 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
H.GaveUp -> FailureReason -> ExampleT context m ()
forall (m :: * -> *) e a. (MonadThrow 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
H.OK -> Text -> ExampleT context m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
info [i|#{resultText}|]
modifyArgs :: (
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 ()
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 (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 (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 :: (Maybe Seed -> Maybe Seed)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
modifySeed Maybe Seed -> Maybe Seed
f = (HedgehogParams -> HedgehogParams)
-> SpecFree (HedgehogContextLabel 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 (HedgehogContextLabel context) m ()
-> SpecFree context m ())
-> (HedgehogParams -> HedgehogParams)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \HedgehogParams
args -> HedgehogParams
args { hedgehogSeed :: Maybe Seed
hedgehogSeed = Maybe Seed -> Maybe Seed
f (HedgehogParams -> Maybe Seed
hedgehogSeed HedgehogParams
args) }
modifySize :: (HasHedgehogContext context, Monad m) => (Maybe Size -> Maybe Size) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()
modifySize :: (Maybe Size -> Maybe Size)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
modifySize Maybe Size -> Maybe Size
f = (HedgehogParams -> HedgehogParams)
-> SpecFree (HedgehogContextLabel 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 (HedgehogContextLabel context) m ()
-> SpecFree context m ())
-> (HedgehogParams -> HedgehogParams)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \HedgehogParams
args -> HedgehogParams
args { hedgehogSize :: Maybe Size
hedgehogSize = Maybe Size -> Maybe Size
f (HedgehogParams -> Maybe Size
hedgehogSize HedgehogParams
args) }
modifyDiscardLimit :: (HasHedgehogContext context, Monad m) => (Maybe DiscardLimit -> Maybe DiscardLimit) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()
modifyDiscardLimit :: (Maybe DiscardLimit -> Maybe DiscardLimit)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
modifyDiscardLimit Maybe DiscardLimit -> Maybe DiscardLimit
f = (HedgehogParams -> HedgehogParams)
-> SpecFree (HedgehogContextLabel 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 (HedgehogContextLabel context) m ()
-> SpecFree context m ())
-> (HedgehogParams -> HedgehogParams)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \HedgehogParams
args -> HedgehogParams
args { hedgehogDiscardLimit :: Maybe DiscardLimit
hedgehogDiscardLimit = Maybe DiscardLimit -> Maybe DiscardLimit
f (HedgehogParams -> Maybe DiscardLimit
hedgehogDiscardLimit HedgehogParams
args) }
modifyShrinkLimit :: (HasHedgehogContext context, Monad m) => (Maybe ShrinkLimit -> Maybe ShrinkLimit) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()
modifyShrinkLimit :: (Maybe ShrinkLimit -> Maybe ShrinkLimit)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
modifyShrinkLimit Maybe ShrinkLimit -> Maybe ShrinkLimit
f = (HedgehogParams -> HedgehogParams)
-> SpecFree (HedgehogContextLabel 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 (HedgehogContextLabel context) m ()
-> SpecFree context m ())
-> (HedgehogParams -> HedgehogParams)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \HedgehogParams
args -> HedgehogParams
args { hedgehogShrinkLimit :: Maybe ShrinkLimit
hedgehogShrinkLimit = Maybe ShrinkLimit -> Maybe ShrinkLimit
f (HedgehogParams -> Maybe ShrinkLimit
hedgehogShrinkLimit HedgehogParams
args) }
modifyShrinkRetries :: (HasHedgehogContext context, Monad m) => (Maybe ShrinkRetries -> Maybe ShrinkRetries) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()
modifyShrinkRetries :: (Maybe ShrinkRetries -> Maybe ShrinkRetries)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
modifyShrinkRetries Maybe ShrinkRetries -> Maybe ShrinkRetries
f = (HedgehogParams -> HedgehogParams)
-> SpecFree (HedgehogContextLabel 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 (HedgehogContextLabel context) m ()
-> SpecFree context m ())
-> (HedgehogParams -> HedgehogParams)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \HedgehogParams
args -> HedgehogParams
args { hedgehogShrinkRetries :: Maybe ShrinkRetries
hedgehogShrinkRetries = Maybe ShrinkRetries -> Maybe ShrinkRetries
f (HedgehogParams -> Maybe ShrinkRetries
hedgehogShrinkRetries HedgehogParams
args) }
modifyTerminationCriteria :: (HasHedgehogContext context, Monad m) => (Maybe TerminationCriteria -> Maybe TerminationCriteria) -> SpecFree (HedgehogContextLabel context) m () -> SpecFree context m ()
modifyTerminationCriteria :: (Maybe TerminationCriteria -> Maybe TerminationCriteria)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
modifyTerminationCriteria Maybe TerminationCriteria -> Maybe TerminationCriteria
f = (HedgehogParams -> HedgehogParams)
-> SpecFree (HedgehogContextLabel 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 (HedgehogContextLabel context) m ()
-> SpecFree context m ())
-> (HedgehogParams -> HedgehogParams)
-> SpecFree (HedgehogContextLabel context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \HedgehogParams
args -> HedgehogParams
args { hedgehogTerminationCriteria :: Maybe TerminationCriteria
hedgehogTerminationCriteria = Maybe TerminationCriteria -> Maybe TerminationCriteria
f (HedgehogParams -> Maybe TerminationCriteria
hedgehogTerminationCriteria HedgehogParams
args) }
addCommandLineOptions :: CommandLineOptions a -> HedgehogParams -> HedgehogParams
addCommandLineOptions :: CommandLineOptions a -> HedgehogParams -> HedgehogParams
addCommandLineOptions (CommandLineOptions {optHedgehogOptions :: forall a. CommandLineOptions a -> CommandLineHedgehogOptions
optHedgehogOptions=(CommandLineHedgehogOptions {Maybe Int
Maybe Integer
Maybe String
optHedgehogSeed :: CommandLineHedgehogOptions -> Maybe String
optHedgehogSize :: CommandLineHedgehogOptions -> Maybe Int
optHedgehogDiscardLimit :: CommandLineHedgehogOptions -> Maybe Integer
optHedgehogShrinkLimit :: CommandLineHedgehogOptions -> Maybe Integer
optHedgehogShrinkRetries :: CommandLineHedgehogOptions -> Maybe Integer
optHedgehogShrinkRetries :: Maybe Integer
optHedgehogShrinkLimit :: Maybe Integer
optHedgehogDiscardLimit :: Maybe Integer
optHedgehogSize :: Maybe Int
optHedgehogSeed :: Maybe String
..})}) baseHedgehogParams :: HedgehogParams
baseHedgehogParams@(HedgehogParams {Maybe DiscardLimit
Maybe ShrinkLimit
Maybe ShrinkRetries
Maybe TerminationCriteria
Maybe Seed
Maybe Size
hedgehogTerminationCriteria :: Maybe TerminationCriteria
hedgehogShrinkRetries :: Maybe ShrinkRetries
hedgehogShrinkLimit :: Maybe ShrinkLimit
hedgehogDiscardLimit :: Maybe DiscardLimit
hedgehogSize :: Maybe Size
hedgehogSeed :: Maybe Seed
hedgehogSeed :: HedgehogParams -> Maybe Seed
hedgehogSize :: HedgehogParams -> Maybe Size
hedgehogTerminationCriteria :: HedgehogParams -> Maybe TerminationCriteria
hedgehogShrinkRetries :: HedgehogParams -> Maybe ShrinkRetries
hedgehogShrinkLimit :: HedgehogParams -> Maybe ShrinkLimit
hedgehogDiscardLimit :: HedgehogParams -> Maybe DiscardLimit
..}) = HedgehogParams
baseHedgehogParams {
hedgehogSeed :: Maybe Seed
hedgehogSeed = (String -> Seed
forall a. Read a => String -> a
read (String -> Seed) -> Maybe String -> Maybe Seed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
optHedgehogSeed) Maybe Seed -> Maybe Seed -> Maybe Seed
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Seed
hedgehogSeed
, hedgehogSize :: Maybe Size
hedgehogSize = (Int -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Size) -> Maybe Int -> Maybe Size
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
optHedgehogSize) Maybe Size -> Maybe Size -> Maybe Size
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Size
hedgehogSize
, hedgehogDiscardLimit :: Maybe DiscardLimit
hedgehogDiscardLimit = (Integer -> DiscardLimit
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> DiscardLimit) -> Maybe Integer -> Maybe DiscardLimit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
optHedgehogDiscardLimit) Maybe DiscardLimit -> Maybe DiscardLimit -> Maybe DiscardLimit
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe DiscardLimit
hedgehogDiscardLimit
, hedgehogShrinkLimit :: Maybe ShrinkLimit
hedgehogShrinkLimit = (Integer -> ShrinkLimit
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> ShrinkLimit) -> Maybe Integer -> Maybe ShrinkLimit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
optHedgehogShrinkLimit) Maybe ShrinkLimit -> Maybe ShrinkLimit -> Maybe ShrinkLimit
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ShrinkLimit
hedgehogShrinkLimit
, hedgehogShrinkRetries :: Maybe ShrinkRetries
hedgehogShrinkRetries = (Integer -> ShrinkRetries
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> ShrinkRetries) -> Maybe Integer -> Maybe ShrinkRetries
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
optHedgehogShrinkRetries) Maybe ShrinkRetries -> Maybe ShrinkRetries -> Maybe ShrinkRetries
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ShrinkRetries
hedgehogShrinkRetries
}