{-# LANGUAGE CPP #-}

-- | Properties
--
-- Intended for unqualified import.
module Test.Falsify.Internal.Property (
    -- * Property
    Property' -- opaque
  , runProperty
    -- * Test results
  , TestResult(..)
  , resultIsValidShrink
    -- * State
  , TestRun(..)
  , Log(..)
  , LogEntry(..)
    -- * Running generators
  , gen
  , genWith
    -- * 'Property' features
  , testFailed
  , info
  , assert
  , discard
  , label
  , collect
    -- * Testing shrinking
  , testShrinking
  , testMinimum
    -- * Testing generators
  , testGen
  , testGen'
  , testShrinkingOfGen
  ) where

import Prelude hiding (log)

import Control.Monad
import Control.Monad.State
import Data.Foldable (toList)
import Data.List.NonEmpty (NonEmpty)
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import GHC.Stack

import qualified Data.Map as Map
import qualified Data.Set as Set

#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail(..))
#endif

import Test.Falsify.Generator (Gen)
import Test.Falsify.Internal.Generator.Shrinking
import Test.Falsify.Predicate (Predicate, (.$))

import qualified Test.Falsify.Generator          as Gen
import qualified Test.Falsify.Internal.Generator as Gen
import qualified Test.Falsify.Predicate          as P

{-------------------------------------------------------------------------------
  Information about a test run
-------------------------------------------------------------------------------}

data TestRun = TestRun {
      TestRun -> Log
runLog :: Log

      -- | Did we generate any values in this test run?
      --
      -- If not, there is no point running the test more than once (with
      -- different seeds), since the test is deterministic.
    , TestRun -> Bool
runDeterministic :: Bool

      -- | Labels
    , TestRun -> Map String (Set String)
runLabels :: Map String (Set String)
    }
  deriving (Int -> TestRun -> ShowS
[TestRun] -> ShowS
TestRun -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestRun] -> ShowS
$cshowList :: [TestRun] -> ShowS
show :: TestRun -> String
$cshow :: TestRun -> String
showsPrec :: Int -> TestRun -> ShowS
$cshowsPrec :: Int -> TestRun -> ShowS
Show)

data LogEntry =
    -- | Generated a value
    --
    -- We record the value that was generated as well as /where/ we generated it
    Generated CallStack String

    -- | Some additional information
  | Info String
  deriving (Int -> LogEntry -> ShowS
[LogEntry] -> ShowS
LogEntry -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogEntry] -> ShowS
$cshowList :: [LogEntry] -> ShowS
show :: LogEntry -> String
$cshow :: LogEntry -> String
showsPrec :: Int -> LogEntry -> ShowS
$cshowsPrec :: Int -> LogEntry -> ShowS
Show)

-- | Log of the events happened during a test run
--
-- The events are recorded in reverse chronological order
newtype Log = Log [LogEntry]
  deriving (Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> String
$cshow :: Log -> String
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> Log -> ShowS
Show)

initTestRun :: TestRun
initTestRun :: TestRun
initTestRun = TestRun {
      runLog :: Log
runLog           = [LogEntry] -> Log
Log []
    , runDeterministic :: Bool
runDeterministic = Bool
True
    , runLabels :: Map String (Set String)
runLabels        = forall k a. Map k a
Map.empty
    }

-- | Append log from another test run to the current test run
--
-- This is an internal function, used when testing shrinking to include the runs
-- from an unshrunk test and a shrunk test.
appendLog :: Log -> Property' e ()
appendLog :: forall e. Log -> Property' e ()
appendLog (Log [LogEntry]
log') = forall e a.
(TestRun -> Gen (TestResult e a, TestRun)) -> Property' e a
mkProperty forall a b. (a -> b) -> a -> b
$ \run :: TestRun
run@TestRun{runLog :: TestRun -> Log
runLog = Log [LogEntry]
log} -> forall (m :: * -> *) a. Monad m => a -> m a
return (
      forall e a. a -> TestResult e a
TestPassed ()
    , TestRun
run{runLog :: Log
runLog = [LogEntry] -> Log
Log forall a b. (a -> b) -> a -> b
$ [LogEntry]
log' forall a. [a] -> [a] -> [a]
++ [LogEntry]
log}
    )

{-------------------------------------------------------------------------------
  Test result
-------------------------------------------------------------------------------}

-- | Test result
data TestResult e a =
    -- | Test was successful
    --
    -- Under normal circumstances @a@ will be @()@.
    TestPassed a

    -- | Test failed
  | TestFailed e

    -- | Test was discarded
    --
    -- This is neither a failure nor a success, but instead is a request to
    -- discard this PRNG seed and try a new one.
  | TestDiscarded
  deriving stock (Int -> TestResult e a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall e a. (Show a, Show e) => Int -> TestResult e a -> ShowS
forall e a. (Show a, Show e) => [TestResult e a] -> ShowS
forall e a. (Show a, Show e) => TestResult e a -> String
showList :: [TestResult e a] -> ShowS
$cshowList :: forall e a. (Show a, Show e) => [TestResult e a] -> ShowS
show :: TestResult e a -> String
$cshow :: forall e a. (Show a, Show e) => TestResult e a -> String
showsPrec :: Int -> TestResult e a -> ShowS
$cshowsPrec :: forall e a. (Show a, Show e) => Int -> TestResult e a -> ShowS
Show, forall a b. a -> TestResult e b -> TestResult e a
forall a b. (a -> b) -> TestResult e a -> TestResult e b
forall e a b. a -> TestResult e b -> TestResult e a
forall e a b. (a -> b) -> TestResult e a -> TestResult e b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> TestResult e b -> TestResult e a
$c<$ :: forall e a b. a -> TestResult e b -> TestResult e a
fmap :: forall a b. (a -> b) -> TestResult e a -> TestResult e b
$cfmap :: forall e a b. (a -> b) -> TestResult e a -> TestResult e b
Functor)

-- | A test result is a valid shrink step if the test still fails
resultIsValidShrink ::
     (TestResult e a, TestRun)
  -> IsValidShrink (e, TestRun) (Maybe a, TestRun)
resultIsValidShrink :: forall e a.
(TestResult e a, TestRun)
-> IsValidShrink (e, TestRun) (Maybe a, TestRun)
resultIsValidShrink (TestResult e a
result, TestRun
run) =
    case TestResult e a
result of
      TestFailed e
e  -> forall p n. p -> IsValidShrink p n
ValidShrink   (e
e       , TestRun
run)
      TestResult e a
TestDiscarded -> forall p n. n -> IsValidShrink p n
InvalidShrink (forall a. Maybe a
Nothing , TestRun
run)
      TestPassed a
a  -> forall p n. n -> IsValidShrink p n
InvalidShrink (forall a. a -> Maybe a
Just a
a  , TestRun
run)

{-------------------------------------------------------------------------------
  Monad-transformer version of 'TestResult'
-------------------------------------------------------------------------------}

newtype TestResultT e m a = TestResultT {
      forall e (m :: * -> *) a. TestResultT e m a -> m (TestResult e a)
runTestResultT :: m (TestResult e a)
    }
  deriving (forall a b. a -> TestResultT e m b -> TestResultT e m a
forall a b. (a -> b) -> TestResultT e m a -> TestResultT e m b
forall e (m :: * -> *) a b.
Functor m =>
a -> TestResultT e m b -> TestResultT e m a
forall e (m :: * -> *) a b.
Functor m =>
(a -> b) -> TestResultT e m a -> TestResultT e m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> TestResultT e m b -> TestResultT e m a
$c<$ :: forall e (m :: * -> *) a b.
Functor m =>
a -> TestResultT e m b -> TestResultT e m a
fmap :: forall a b. (a -> b) -> TestResultT e m a -> TestResultT e m b
$cfmap :: forall e (m :: * -> *) a b.
Functor m =>
(a -> b) -> TestResultT e m a -> TestResultT e m b
Functor)

instance Monad m => Applicative (TestResultT e m) where
  pure :: forall a. a -> TestResultT e m a
pure a
x = forall e (m :: * -> *) a. m (TestResult e a) -> TestResultT e m a
TestResultT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall e a. a -> TestResult e a
TestPassed a
x)
  <*> :: forall a b.
TestResultT e m (a -> b) -> TestResultT e m a -> TestResultT e m b
(<*>)  = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad m => Monad (TestResultT e m) where
  return :: forall a. a -> TestResultT e m a
return  = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  TestResultT e m a
x >>= :: forall a b.
TestResultT e m a -> (a -> TestResultT e m b) -> TestResultT e m b
>>= a -> TestResultT e m b
f = forall e (m :: * -> *) a. m (TestResult e a) -> TestResultT e m a
TestResultT forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. TestResultT e m a -> m (TestResult e a)
runTestResultT TestResultT e m a
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              TestPassed a
a  -> forall e (m :: * -> *) a. TestResultT e m a -> m (TestResult e a)
runTestResultT (a -> TestResultT e m b
f a
a)
              TestFailed e
e  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall e a. e -> TestResult e a
TestFailed e
e
              TestResult e a
TestDiscarded -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall e a. TestResult e a
TestDiscarded

{-------------------------------------------------------------------------------
  Definition

  The @Property@ type synonym for properties that use strings are errors is
  defined in "Test.Falsify.Property". We do not define it here, so that we
  cannot by mistake make a function less polymorphic than it should be.
-------------------------------------------------------------------------------}

-- | Property
--
-- A 'Property' is a generator that can fail and keeps a track of some
-- information about the test run.
--
-- In most cases, you will probably want to use 'Test.Falsify.Property.Property'
-- instead, which fixes @e@ at 'String'.
newtype Property' e a = WrapProperty {
      forall e a. Property' e a -> TestResultT e (StateT TestRun Gen) a
unwrapProperty :: TestResultT e (StateT TestRun Gen) a
    }
  deriving newtype (forall a b. a -> Property' e b -> Property' e a
forall a b. (a -> b) -> Property' e a -> Property' e b
forall e a b. a -> Property' e b -> Property' e a
forall e a b. (a -> b) -> Property' e a -> Property' e b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Property' e b -> Property' e a
$c<$ :: forall e a b. a -> Property' e b -> Property' e a
fmap :: forall a b. (a -> b) -> Property' e a -> Property' e b
$cfmap :: forall e a b. (a -> b) -> Property' e a -> Property' e b
Functor, forall e. Functor (Property' e)
forall a. a -> Property' e a
forall e a. a -> Property' e a
forall a b. Property' e a -> Property' e b -> Property' e a
forall a b. Property' e a -> Property' e b -> Property' e b
forall a b. Property' e (a -> b) -> Property' e a -> Property' e b
forall e a b. Property' e a -> Property' e b -> Property' e a
forall e a b. Property' e a -> Property' e b -> Property' e b
forall e a b.
Property' e (a -> b) -> Property' e a -> Property' e b
forall a b c.
(a -> b -> c) -> Property' e a -> Property' e b -> Property' e c
forall e a b c.
(a -> b -> c) -> Property' e a -> Property' e b -> Property' e c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Property' e a -> Property' e b -> Property' e a
$c<* :: forall e a b. Property' e a -> Property' e b -> Property' e a
*> :: forall a b. Property' e a -> Property' e b -> Property' e b
$c*> :: forall e a b. Property' e a -> Property' e b -> Property' e b
liftA2 :: forall a b c.
(a -> b -> c) -> Property' e a -> Property' e b -> Property' e c
$cliftA2 :: forall e a b c.
(a -> b -> c) -> Property' e a -> Property' e b -> Property' e c
<*> :: forall a b. Property' e (a -> b) -> Property' e a -> Property' e b
$c<*> :: forall e a b.
Property' e (a -> b) -> Property' e a -> Property' e b
pure :: forall a. a -> Property' e a
$cpure :: forall e a. a -> Property' e a
Applicative, forall e. Applicative (Property' e)
forall a. a -> Property' e a
forall e a. a -> Property' e a
forall a b. Property' e a -> Property' e b -> Property' e b
forall a b. Property' e a -> (a -> Property' e b) -> Property' e b
forall e a b. Property' e a -> Property' e b -> Property' e b
forall e a b.
Property' e a -> (a -> Property' e b) -> Property' e b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Property' e a
$creturn :: forall e a. a -> Property' e a
>> :: forall a b. Property' e a -> Property' e b -> Property' e b
$c>> :: forall e a b. Property' e a -> Property' e b -> Property' e b
>>= :: forall a b. Property' e a -> (a -> Property' e b) -> Property' e b
$c>>= :: forall e a b.
Property' e a -> (a -> Property' e b) -> Property' e b
Monad)

-- | Construct property
--
-- This is a low-level function for internal use only.
mkProperty :: (TestRun -> Gen (TestResult e a, TestRun)) -> Property' e a
mkProperty :: forall e a.
(TestRun -> Gen (TestResult e a, TestRun)) -> Property' e a
mkProperty = forall e a. TestResultT e (StateT TestRun Gen) a -> Property' e a
WrapProperty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. m (TestResult e a) -> TestResultT e m a
TestResultT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT

-- | Run property
runProperty :: Property' e a -> Gen (TestResult e a, TestRun)
runProperty :: forall e a. Property' e a -> Gen (TestResult e a, TestRun)
runProperty = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT TestRun
initTestRun forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. TestResultT e m a -> m (TestResult e a)
runTestResultT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Property' e a -> TestResultT e (StateT TestRun Gen) a
unwrapProperty

{-------------------------------------------------------------------------------
  'Property' features
-------------------------------------------------------------------------------}

-- | Test failure
testFailed :: e -> Property' e a
testFailed :: forall e a. e -> Property' e a
testFailed e
err = forall e a.
(TestRun -> Gen (TestResult e a, TestRun)) -> Property' e a
mkProperty forall a b. (a -> b) -> a -> b
$ \TestRun
run -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall e a. e -> TestResult e a
TestFailed e
err, TestRun
run)

-- | Discard this test
discard :: Property' e a
discard :: forall e a. Property' e a
discard = forall e a.
(TestRun -> Gen (TestResult e a, TestRun)) -> Property' e a
mkProperty forall a b. (a -> b) -> a -> b
$ \TestRun
run -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall e a. TestResult e a
TestDiscarded, TestRun
run)

-- | Log some additional information about the test
--
-- This will be shown in verbose mode.
info :: String -> Property' e ()
info :: forall e. String -> Property' e ()
info String
msg =
    forall e a.
(TestRun -> Gen (TestResult e a, TestRun)) -> Property' e a
mkProperty forall a b. (a -> b) -> a -> b
$ \run :: TestRun
run@TestRun{runLog :: TestRun -> Log
runLog = Log [LogEntry]
log} -> forall (m :: * -> *) a. Monad m => a -> m a
return (
        forall e a. a -> TestResult e a
TestPassed ()
      , TestRun
run{runLog :: Log
runLog = [LogEntry] -> Log
Log forall a b. (a -> b) -> a -> b
$ String -> LogEntry
Info String
msg forall a. a -> [a] -> [a]
: [LogEntry]
log}
      )

-- | Fail the test if the predicate does not hold
assert :: Predicate '[] -> Property' String ()
assert :: Predicate '[] -> Property' String ()
assert Predicate '[]
p =
    case Predicate '[] -> Either String ()
P.eval Predicate '[]
p of
      Left String
err -> forall e a. e -> Property' e a
testFailed String
err
      Right () -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Variation on 'collect' that does not rely on 'Show'
--
-- See 'collect' for detailed discussion.
label :: String -> [String] -> Property' e ()
label :: forall e. String -> [String] -> Property' e ()
label String
lbl [String]
vals =
    forall e a.
(TestRun -> Gen (TestResult e a, TestRun)) -> Property' e a
mkProperty forall a b. (a -> b) -> a -> b
$ \run :: TestRun
run@TestRun{Map String (Set String)
runLabels :: Map String (Set String)
runLabels :: TestRun -> Map String (Set String)
runLabels} -> forall (m :: * -> *) a. Monad m => a -> m a
return (
        forall e a. a -> TestResult e a
TestPassed ()
      , TestRun
run{runLabels :: Map String (Set String)
runLabels = forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe (Set String) -> Maybe (Set String)
addValues String
lbl Map String (Set String)
runLabels}
      )
  where
    addValues :: Maybe (Set String) -> Maybe (Set String)
    addValues :: Maybe (Set String) -> Maybe (Set String)
addValues = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => Set a -> Set a -> Set a
Set.union (forall a. Ord a => [a] -> Set a
Set.fromList [String]
vals) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe forall a. Set a
Set.empty

-- | Label this test
--
-- See also 'label', which does not rely on 'Show'.
--
-- === Motivation
--
-- Labelling is instrumental in understanding the distribution of test data. For
-- example, consider testing a binary tree type, and we want to test some
-- properties of an @insert@ operation (example from "How to specify it!" by
-- John Hughes):
--
-- > prop_insert_insert :: Property ()
-- > prop_insert_insert = do
-- >   tree     <- gen $ ..
-- >   (k1, v1) <- gen $ ..
-- >   (k2, v2) <- gen $ ..
-- >   assert $ .. (insert k1 v1 $ insert k2 v2 $ tree) ..
--
-- We might want to know in what percentage of tests @k1 == k2@:
--
-- > collect "sameKey" [k1 == k2]
--
-- When we do, @falsify@ will report in which percentage of tests the key
-- are the same, and in which percentage of tests they are not.
--
-- === Labels with multiple values
--
-- In general, a particular label can have multiple values in any given test
-- run. Given a test of @n@ test runs, for each value @v@ reported, @falsify@
-- will report what percentage of the @n@ runs are labelled with @v@. That means
-- that these percentages /may/ not add up to 100%; indeed, if we had
--
-- > collect "sameKey" [True]
-- > ..
-- > collect "sameKey" [False]
--
-- or, equivalently,
--
-- > collect "sameKey" [True, False]
--
-- then /every/ test would have been reported as labelled with @True@ (100%@)
-- /as well as/ with @False@ (also 100%). Of course, if we do (like above)
--
-- > collect "sameKey" [k1 == k2]
--
-- each test will be labelled with /either/ @True@ /or/ @False@, and the
-- percentages /will/ add up to 100%.
--
-- === Difference from QuickCheck
--
-- Since you can call @collect@ anywhere in a property, it is natural that the
-- same label can have /multiple/ values in any given test run. In this regard,
-- @collect@ is closer to QuickCheck's @tabulate@. However, the statistics of
-- @tabulate@ can be difficult to interpret; QuickCheck reports the frequency of
-- a value as a percentage of the /total number of values collected/; the
-- frequency reported by @falsify@ here is always in terms of number of test
-- runs, like @collect@ does in QuickCheck. We therefore opted to use the name
-- @collect@ rather than @tabulate@.
collect :: Show a => String -> [a] -> Property' e ()
collect :: forall a e. Show a => String -> [a] -> Property' e ()
collect String
l = forall e. String -> [String] -> Property' e ()
label String
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show

instance MonadFail (Property' String) where
  fail :: forall a. String -> Property' String a
fail = forall e a. e -> Property' e a
testFailed

{-------------------------------------------------------------------------------
  Running generators
-------------------------------------------------------------------------------}

-- | Internal auxiliary
genWithCallStack :: forall e a.
     CallStack           -- ^ Explicit argument to avoid irrelevant entries
                         -- (users don't care that 'gen' uses 'genWith').
  -> (a -> Maybe String) -- ^ Entry to add to the log (if any)
  -> Gen a -> Property' e a
genWithCallStack :: forall e a.
CallStack -> (a -> Maybe String) -> Gen a -> Property' e a
genWithCallStack CallStack
stack a -> Maybe String
f Gen a
g = forall e a.
(TestRun -> Gen (TestResult e a, TestRun)) -> Property' e a
mkProperty forall a b. (a -> b) -> a -> b
$ \TestRun
run -> TestRun -> a -> (TestResult e a, TestRun)
aux TestRun
run forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
g
  where
    aux :: TestRun -> a -> (TestResult e a, TestRun)
    aux :: TestRun -> a -> (TestResult e a, TestRun)
aux run :: TestRun
run@TestRun{runLog :: TestRun -> Log
runLog = Log [LogEntry]
log} a
x = (
          forall e a. a -> TestResult e a
TestPassed a
x
        , TestRun
run{ runLog :: Log
runLog = [LogEntry] -> Log
Log forall a b. (a -> b) -> a -> b
$ case a -> Maybe String
f a
x of
                 Just String
entry -> CallStack -> String -> LogEntry
Generated CallStack
stack String
entry forall a. a -> [a] -> [a]
: [LogEntry]
log
                 Maybe String
Nothing    -> [LogEntry]
log
             , runDeterministic :: Bool
runDeterministic = Bool
False
             }
        )

-- | Generate value and add it to the log
gen :: (HasCallStack, Show a) => Gen a -> Property' e a
gen :: forall a e. (HasCallStack, Show a) => Gen a -> Property' e a
gen = forall e a.
CallStack -> (a -> Maybe String) -> Gen a -> Property' e a
genWithCallStack HasCallStack => CallStack
callStack (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show)

-- | Generalization of 'gen' that doesn't depend on a 'Show' instance
--
-- No log entry is added if 'Nothing'.
genWith :: HasCallStack => (a -> Maybe String) -> Gen a -> Property' e a
genWith :: forall a e.
HasCallStack =>
(a -> Maybe String) -> Gen a -> Property' e a
genWith = forall e a.
CallStack -> (a -> Maybe String) -> Gen a -> Property' e a
genWithCallStack HasCallStack => CallStack
callStack

{-------------------------------------------------------------------------------
  Internal auxiliary: testing shrinking
-------------------------------------------------------------------------------}

-- | Construct random path through the property's shrink tree
genShrinkPath :: Property' e () -> Property' e' [(e, TestRun)]
genShrinkPath :: forall e e'. Property' e () -> Property' e' [(e, TestRun)]
genShrinkPath Property' e ()
prop = do
    Tree (TestResult e (), TestRun)
st    <- forall a e.
HasCallStack =>
(a -> Maybe String) -> Gen a -> Property' e a
genWith (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ forall a. Gen a -> Gen (Tree a)
Gen.toShrinkTree (forall e a. Property' e a -> Gen (TestResult e a, TestRun)
runProperty Property' e ()
prop)
    Either (Maybe (), TestRun) (NonEmpty (e, TestRun))
mPath <- forall a e.
HasCallStack =>
(a -> Maybe String) -> Gen a -> Property' e a
genWith (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ forall a p n.
(a -> IsValidShrink p n)
-> ShrinkTree a -> Gen (Either n (NonEmpty p))
Gen.path forall e a.
(TestResult e a, TestRun)
-> IsValidShrink (e, TestRun) (Maybe a, TestRun)
resultIsValidShrink Tree (TestResult e (), TestRun)
st
    forall e e'.
Either (Maybe (), TestRun) (NonEmpty (e, TestRun))
-> Property' e' [(e, TestRun)]
aux Either (Maybe (), TestRun) (NonEmpty (e, TestRun))
mPath
  where
    aux ::
         Either (Maybe (), TestRun) (NonEmpty (e, TestRun))
      -> Property' e' [(e, TestRun)]
    aux :: forall e e'.
Either (Maybe (), TestRun) (NonEmpty (e, TestRun))
-> Property' e' [(e, TestRun)]
aux (Left (Just (), TestRun
_)) = forall (m :: * -> *) a. Monad m => a -> m a
return []
    aux (Left (Maybe ()
Nothing, TestRun
_)) = forall e a. Property' e a
discard
    aux (Right NonEmpty (e, TestRun)
es)          = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (e, TestRun)
es

{-------------------------------------------------------------------------------
  Test shrinking
-------------------------------------------------------------------------------}

-- | Test shrinking of a property
--
-- A property is normally only shrunk when it /fails/. We do the same here:
-- if the property succeeds, we discard the test and try again.
--
-- If the given property itself discards immediately, then this generator will
-- discard also; otherwise, only shrink steps are considered that do not lead
-- to a discard.
testShrinking :: forall e.
     Show e
  => Predicate [e, e] -> Property' e () -> Property' String ()
testShrinking :: forall e.
Show e =>
Predicate '[e, e] -> Property' e () -> Property' String ()
testShrinking Predicate '[e, e]
p Property' e ()
prop = do
    [(e, TestRun)]
path <- forall e e'. Property' e () -> Property' e' [(e, TestRun)]
genShrinkPath Property' e ()
prop
    case [(e, TestRun)] -> Maybe (String, Log, Log)
findCounterExample (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [(e, TestRun)]
path) of
      Maybe (String, Log, Log)
Nothing ->
        forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just (String
err, Log
logBefore, Log
logAfter) -> do
        forall e. String -> Property' e ()
info String
"Before shrinking:"
        forall e. Log -> Property' e ()
appendLog Log
logBefore
        forall e. String -> Property' e ()
info String
"After shrinking:"
        forall e. Log -> Property' e ()
appendLog Log
logAfter
        forall e a. e -> Property' e a
testFailed String
err
  where
    findCounterExample :: [(e, TestRun)] -> Maybe (String, Log, Log)
    findCounterExample :: [(e, TestRun)] -> Maybe (String, Log, Log)
findCounterExample = \case
        []  -> forall a. Maybe a
Nothing
        [(e, TestRun)
_] -> forall a. Maybe a
Nothing
        ((e
x, TestRun
runX) : rest :: [(e, TestRun)]
rest@((e
y, TestRun
runY) : [(e, TestRun)]
_)) ->
          case Predicate '[] -> Either String ()
P.eval forall a b. (a -> b) -> a -> b
$ Predicate '[e, e]
p forall x (xs :: [*]).
Show x =>
Predicate (x : xs) -> (String, x) -> Predicate xs
.$ (String
"original", e
x) forall x (xs :: [*]).
Show x =>
Predicate (x : xs) -> (String, x) -> Predicate xs
.$ (String
"shrunk", e
y) of
            Left String
err -> forall a. a -> Maybe a
Just (String
err, TestRun -> Log
runLog TestRun
runX, TestRun -> Log
runLog TestRun
runY)
            Right () -> [(e, TestRun)] -> Maybe (String, Log, Log)
findCounterExample [(e, TestRun)]
rest

-- | Test the minimum error thrown by the property
--
-- If the given property passes, we will discard this test (in that case, there
-- is nothing to test); this test is also discarded if the given property
-- discards.
--
-- NOTE: When testing a particular generator, you might still want to test with
-- some particular property in mind. Otherwise, the minimum value will always
-- simply be the value that the generator produces when given the @Minimal@
-- sample tree.
testMinimum :: forall e.
     Show e
  => Predicate '[e]
  -> Property' e ()
  -> Property' String ()
testMinimum :: forall e.
Show e =>
Predicate '[e] -> Property' e () -> Property' String ()
testMinimum Predicate '[e]
p Property' e ()
prop = do
    SampleTree
st <- forall a e.
HasCallStack =>
(a -> Maybe String) -> Gen a -> Property' e a
genWith (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ Gen SampleTree
Gen.captureLocalTree
    case forall a. Gen a -> SampleTree -> (a, [SampleTree])
Gen.runGen (forall e a. Property' e a -> Gen (TestResult e a, TestRun)
runProperty Property' e ()
prop) SampleTree
st of
      ((TestPassed (), TestRun
_run), [SampleTree]
_shrunk) ->
        -- The property passed; nothing to test
        forall e a. Property' e a
discard
      ((TestResult e ()
TestDiscarded, TestRun
_run), [SampleTree]
_shrunk) ->
        -- The property needs to be discarded; discard this one, too
        forall e a. Property' e a
discard
      ((TestFailed e
initErr, TestRun
initRun), [SampleTree]
shrunk) -> do
        let explanation :: ShrinkExplanation (e, TestRun) (Maybe (), TestRun)
            explanation :: ShrinkExplanation (e, TestRun) (Maybe (), TestRun)
explanation = forall a p n.
(a -> IsValidShrink p n)
-> Gen a -> (p, [SampleTree]) -> ShrinkExplanation p n
shrinkFrom
                            forall e a.
(TestResult e a, TestRun)
-> IsValidShrink (e, TestRun) (Maybe a, TestRun)
resultIsValidShrink
                            (forall e a. Property' e a -> Gen (TestResult e a, TestRun)
runProperty Property' e ()
prop)
                            ((e
initErr, TestRun
initRun), [SampleTree]
shrunk)

            minErr    :: e
            minRun    :: TestRun
            mRejected :: Maybe [(Maybe (), TestRun)]
            ((e
minErr, TestRun
minRun), Maybe [(Maybe (), TestRun)]
mRejected) = forall p n. ShrinkExplanation p n -> (p, Maybe [n])
shrinkOutcome ShrinkExplanation (e, TestRun) (Maybe (), TestRun)
explanation

            rejected :: [TestRun]
            rejected :: [TestRun]
rejected  = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) Maybe [(Maybe (), TestRun)]
mRejected

        case Predicate '[] -> Either String ()
P.eval forall a b. (a -> b) -> a -> b
$ Predicate '[e]
p forall x (xs :: [*]).
Show x =>
Predicate (x : xs) -> (String, x) -> Predicate xs
.$ (String
"minimum", e
minErr) of
          Right () -> do
            -- For a successful test, we add the full shrink history as info
            -- This means that users can use verbose mode to see precisely
            -- how the minimum value is reached, if they wish.
            forall e. String -> Property' e ()
info String
"Shrink history:"
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall p n. ShrinkExplanation p n -> NonEmpty p
shrinkHistory ShrinkExplanation (e, TestRun) (Maybe (), TestRun)
explanation) forall a b. (a -> b) -> a -> b
$ \(e
e, TestRun
_run) ->
              forall e. String -> Property' e ()
info forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show e
e
          Left String
err -> do
            forall e. Log -> Property' e ()
appendLog (TestRun -> Log
runLog TestRun
minRun)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestRun]
rejected) forall a b. (a -> b) -> a -> b
$ do
              forall e. String -> Property' e ()
info String
"\nLogs for rejected potential next shrinks:"
              forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Word
0 :: Word ..] [TestRun]
rejected) forall a b. (a -> b) -> a -> b
$ \(Word
i, TestRun
rej) -> do
                forall e. String -> Property' e ()
info forall a b. (a -> b) -> a -> b
$ String
"\n** Rejected run " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word
i
                forall e. Log -> Property' e ()
appendLog forall a b. (a -> b) -> a -> b
$ TestRun -> Log
runLog TestRun
rej
            forall e a. e -> Property' e a
testFailed String
err

{-------------------------------------------------------------------------------
  Testing generators
-------------------------------------------------------------------------------}

-- | Test output of the generator
testGen :: forall a. Show a => Predicate '[a] -> Gen a -> Property' String ()
testGen :: forall a. Show a => Predicate '[a] -> Gen a -> Property' String ()
testGen Predicate '[a]
p = forall e a b. (a -> Either e b) -> Gen a -> Property' e b
testGen' forall a b. (a -> b) -> a -> b
$ \a
a -> Predicate '[] -> Either String ()
P.eval forall a b. (a -> b) -> a -> b
$ Predicate '[a]
p forall x (xs :: [*]).
Show x =>
Predicate (x : xs) -> (String, x) -> Predicate xs
.$ (String
"generated", a
a)

-- | Generalization of 'testGen'
testGen' :: forall e a b. (a -> Either e b) -> Gen a -> Property' e b
testGen' :: forall e a b. (a -> Either e b) -> Gen a -> Property' e b
testGen' a -> Either e b
p Gen a
g = forall e a. TestResultT e (StateT TestRun Gen) a -> Property' e a
WrapProperty forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. m (TestResult e a) -> TestResultT e m a
TestResultT forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT forall a b. (a -> b) -> a -> b
$ \TestRun
run ->
    -- We do not use bind here to avoid introducing new shrinking shortcuts
    TestRun -> a -> (TestResult e b, TestRun)
aux TestRun
run forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
g
  where
    aux :: TestRun -> a -> (TestResult e b, TestRun)
    aux :: TestRun -> a -> (TestResult e b, TestRun)
aux TestRun
run a
a = (
          case a -> Either e b
p a
a of
            Left  e
e -> forall e a. e -> TestResult e a
TestFailed e
e
            Right b
b -> forall e a. a -> TestResult e a
TestPassed b
b
        , TestRun
run{runDeterministic :: Bool
runDeterministic = Bool
False}
        )

-- | Test shrinking of a generator
--
-- We check /any/ shrink step that the generator can make (independent of any
-- property).
testShrinkingOfGen :: Show a => Predicate [a, a] -> Gen a -> Property' String ()
testShrinkingOfGen :: forall a.
Show a =>
Predicate '[a, a] -> Gen a -> Property' String ()
testShrinkingOfGen Predicate '[a, a]
p = forall e.
Show e =>
Predicate '[e, e] -> Property' e () -> Property' String ()
testShrinking Predicate '[a, a]
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a b. (a -> Either e b) -> Gen a -> Property' e b
testGen' forall a b. a -> Either a b
Left