-- | 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 #-}
{-# LANGUAGE CPP #-}

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
#if MIN_VERSION_hedgehog(1,2,0)
  , hedgehogSkip
#endif
  , 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
#if MIN_VERSION_hedgehog(1,2,0)
  , modifySkip
#endif
  , modifySize
  , modifySeed

  -- * Misc
  , 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 {
  -- | 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
  -- | Control where to start running a property's tests
#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

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

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

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


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

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

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


-- | 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 :: 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
    -- 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}|]

#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

  -- 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
    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

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

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

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

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

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

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

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