-- | Functions for introducing Hedgehog tests into a Sandwich test tree. Modelled after Hspec's version.
--
-- Documentation can be found <https://codedownio.github.io/sandwich/docs/extensions/sandwich-hedgehog here>.

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}

module Test.Sandwich.Hedgehog (
  -- * Introducing a Hedgehog context
  -- Any tests that use Hedgehog should be wrapped in one of these.
  introduceHedgehog
  , introduceHedgehog'
  , introduceHedgehog''

  -- * Prop
  , prop

  -- * Params
  , HedgehogParams
  , defaultHedgehogParams
  , hedgehogDiscardLimit
  , hedgehogShrinkLimit
  , hedgehogShrinkRetries
  , hedgehogTerminationCriteria
  , hedgehogSize
  , hedgehogSeed

  -- * Versions that can be configured with built-in command line arguments.
  -- Pass --print-hedgehog-flags to list them.
  , introduceHedgehogCommandLineOptions
  , introduceHedgehogCommandLineOptions'
  , introduceHedgehogCommandLineOptions''
  , addCommandLineOptions

  -- * Modifying Hedgehog args
  , modifyArgs
  , modifyDiscardLimit
  , modifyShrinkLimit
  , modifyShrinkRetries
  , modifyTerminationCriteria
  , modifySize
  , modifySeed

  -- * Misc
  , 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 {
  -- | Random number generator seed.
  HedgehogParams -> Maybe Seed
hedgehogSeed :: Maybe Seed
  -- | Size of the randomly-generated data.
  , HedgehogParams -> Maybe Size
hedgehogSize :: Maybe Size
  -- | The number of times a property is allowed to discard before the test runner gives up.
  , HedgehogParams -> Maybe DiscardLimit
hedgehogDiscardLimit :: Maybe DiscardLimit
  -- | The number of times a property is allowed to shrink before the test runner gives up and prints the counterexample.
  , HedgehogParams -> Maybe ShrinkLimit
hedgehogShrinkLimit :: Maybe ShrinkLimit
  -- | The number of times to re-run a test during shrinking.
  , HedgehogParams -> Maybe ShrinkRetries
hedgehogShrinkRetries :: Maybe ShrinkRetries
  -- | Control when the test runner should terminate.
  , 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

-- | Same as 'introduceHedgehog'' but with default 'HedgehogParams'.
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

-- | Same as 'introduceHedgehog''' but with a default message.
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"

-- | Introduce 'HedgehogParams' with configurable message.
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 ())


-- | Same as 'introduceHedgehogCommandLineOptions'' but with default 'HedgehogParams'.
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

-- | Same as 'introduceHedgehogCommandLineOptions''' but with a default message.
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"

-- | Introduce 'HedgehogParams' with configurable message, overriding those parameters with any command line options passed.
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


-- | Similar to 'it'. Runs the given propery with Hedgehog using the currently introduced 'HedgehogParams'. Throws an appropriate exception on failure.
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
    -- image <- (return . renderHedgehogToImage) =<< ppProgress Nothing progressReport

    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

  -- Hedgehog naturally indents everything by 2. Remove this for the fallback text.
  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}|]

-- | Modify the 'HedgehogParams' for the given spec.
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

-- | Modify the 'Seed' for the given spec.
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) }

-- | Modify the 'Size' for the given spec.
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) }

-- | Modify the 'DiscardLimit' for the given spec.
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) }

-- | Modify the 'ShrinkLimit' for the given spec.
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) }

-- | Modify the 'ShrinkRetries' for the given spec.
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) }

-- | Modify the 'TerminationCriteria' for the given spec.
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
  }