{-# LANGUAGE OverloadedStrings #-}

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

import Prelude hiding (log)

import Control.Monad
import Control.Monad.Reader
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

import Data.Falsify.ProperFraction (ProperFraction(..))
import Test.Falsify.Context (Context(Context))
import Test.Falsify.Internal.Generator
import Test.Falsify.Internal.Shrinking
import Test.Falsify.Predicate (Predicate, (.$))

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

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

data TestRun = TestRun {
      -- | Any 'info' messages generated during the run
      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
(Int -> TestRun -> ShowS)
-> (TestRun -> String) -> ([TestRun] -> ShowS) -> Show TestRun
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestRun -> ShowS
showsPrec :: Int -> TestRun -> ShowS
$cshow :: TestRun -> String
show :: TestRun -> String
$cshowList :: [TestRun] -> ShowS
showList :: [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
(Int -> LogEntry -> ShowS)
-> (LogEntry -> String) -> ([LogEntry] -> ShowS) -> Show LogEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogEntry -> ShowS
showsPrec :: Int -> LogEntry -> ShowS
$cshow :: LogEntry -> String
show :: LogEntry -> String
$cshowList :: [LogEntry] -> ShowS
showList :: [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
(Int -> Log -> ShowS)
-> (Log -> String) -> ([Log] -> ShowS) -> Show Log
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Log -> ShowS
showsPrec :: Int -> Log -> ShowS
$cshow :: Log -> String
show :: Log -> String
$cshowList :: [Log] -> ShowS
showList :: [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        = Map String (Set String)
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') = (Context -> TestRun -> Gen (TestResult e (), TestRun))
-> Property' e ()
forall e a.
(Context -> TestRun -> Gen (TestResult e a, TestRun))
-> Property' e a
mkProperty ((Context -> TestRun -> Gen (TestResult e (), TestRun))
 -> Property' e ())
-> (Context -> TestRun -> Gen (TestResult e (), TestRun))
-> Property' e ()
forall a b. (a -> b) -> a -> b
$ \Context
_ctx run :: TestRun
run@TestRun{runLog :: TestRun -> Log
runLog = Log [LogEntry]
log} -> (TestResult e (), TestRun) -> Gen (TestResult e (), TestRun)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (
      () -> TestResult e ()
forall e a. a -> TestResult e a
TestPassed ()
    , TestRun
run{runLog = Log $ log' ++ 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
[TestResult e a] -> ShowS
TestResult e a -> String
(Int -> TestResult e a -> ShowS)
-> (TestResult e a -> String)
-> ([TestResult e a] -> ShowS)
-> Show (TestResult e a)
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
$cshowsPrec :: forall e a. (Show a, Show e) => Int -> TestResult e a -> ShowS
showsPrec :: Int -> TestResult e a -> ShowS
$cshow :: forall e a. (Show a, Show e) => TestResult e a -> String
show :: TestResult e a -> String
$cshowList :: forall e a. (Show a, Show e) => [TestResult e a] -> ShowS
showList :: [TestResult e a] -> ShowS
Show, (forall a b. (a -> b) -> TestResult e a -> TestResult e b)
-> (forall a b. a -> TestResult e b -> TestResult e a)
-> Functor (TestResult e)
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
$cfmap :: forall e a b. (a -> b) -> TestResult e a -> TestResult e b
fmap :: forall a b. (a -> b) -> TestResult e a -> TestResult e b
$c<$ :: forall e a b. a -> TestResult e b -> TestResult e a
<$ :: forall a b. a -> TestResult e b -> TestResult e a
Functor)

data Counterexample e = Counterexample{
      forall e. Counterexample e -> Execution
counterexampleContext :: Context.Execution
    , forall e. Counterexample e -> e
counterexampleError   :: e
    , forall e. Counterexample e -> TestRun
counterexampleRun     :: TestRun
    }
  deriving (Int -> Counterexample e -> ShowS
[Counterexample e] -> ShowS
Counterexample e -> String
(Int -> Counterexample e -> ShowS)
-> (Counterexample e -> String)
-> ([Counterexample e] -> ShowS)
-> Show (Counterexample e)
forall e. Show e => Int -> Counterexample e -> ShowS
forall e. Show e => [Counterexample e] -> ShowS
forall e. Show e => Counterexample e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall e. Show e => Int -> Counterexample e -> ShowS
showsPrec :: Int -> Counterexample e -> ShowS
$cshow :: forall e. Show e => Counterexample e -> String
show :: Counterexample e -> String
$cshowList :: forall e. Show e => [Counterexample e] -> ShowS
showList :: [Counterexample e] -> ShowS
Show)

resultIsValidShrink ::
     Context.Execution
  -> (TestResult e a, TestRun)
  -> IsValidShrink (Counterexample e) (Maybe a, TestRun)
resultIsValidShrink :: forall e a.
Execution
-> (TestResult e a, TestRun)
-> IsValidShrink (Counterexample e) (Maybe a, TestRun)
resultIsValidShrink Execution
ctxt (TestResult e a
result, TestRun
run) =
    case TestResult e a
result of
      TestFailed e
e  -> Counterexample e
-> IsValidShrink (Counterexample e) (Maybe a, TestRun)
forall p n. p -> IsValidShrink p n
ValidShrink (Counterexample e
 -> IsValidShrink (Counterexample e) (Maybe a, TestRun))
-> Counterexample e
-> IsValidShrink (Counterexample e) (Maybe a, TestRun)
forall a b. (a -> b) -> a -> b
$ Execution -> e -> TestRun -> Counterexample e
forall e. Execution -> e -> TestRun -> Counterexample e
Counterexample Execution
ctxt e
e TestRun
run
      TestResult e a
TestDiscarded -> (Maybe a, TestRun)
-> IsValidShrink (Counterexample e) (Maybe a, TestRun)
forall p n. n -> IsValidShrink p n
InvalidShrink (Maybe a
forall a. Maybe a
Nothing, TestRun
run)
      TestPassed a
a  -> (Maybe a, TestRun)
-> IsValidShrink (Counterexample e) (Maybe a, TestRun)
forall p n. n -> IsValidShrink p n
InvalidShrink (a -> Maybe a
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 -> b) -> TestResultT e m a -> TestResultT e m b)
-> (forall a b. a -> TestResultT e m b -> TestResultT e m a)
-> Functor (TestResultT e m)
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
$cfmap :: forall e (m :: * -> *) a b.
Functor m =>
(a -> b) -> TestResultT e m a -> TestResultT e m b
fmap :: forall a b. (a -> b) -> TestResultT e m a -> TestResultT e m b
$c<$ :: forall e (m :: * -> *) a b.
Functor m =>
a -> TestResultT e m b -> TestResultT e m a
<$ :: forall a b. a -> TestResultT e m b -> TestResultT e m a
Functor)

instance Monad m => Applicative (TestResultT e m) where
  pure :: forall a. a -> TestResultT e m a
pure a
x = m (TestResult e a) -> TestResultT e m a
forall e (m :: * -> *) a. m (TestResult e a) -> TestResultT e m a
TestResultT (m (TestResult e a) -> TestResultT e m a)
-> m (TestResult e a) -> TestResultT e m a
forall a b. (a -> b) -> a -> b
$ TestResult e a -> m (TestResult e a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> TestResult e a
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
(<*>)  = 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  = a -> TestResultT e m a
forall a. a -> TestResultT e m a
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 = m (TestResult e b) -> TestResultT e m b
forall e (m :: * -> *) a. m (TestResult e a) -> TestResultT e m a
TestResultT (m (TestResult e b) -> TestResultT e m b)
-> m (TestResult e b) -> TestResultT e m b
forall a b. (a -> b) -> a -> b
$ TestResultT e m a -> m (TestResult e a)
forall e (m :: * -> *) a. TestResultT e m a -> m (TestResult e a)
runTestResultT TestResultT e m a
x m (TestResult e a)
-> (TestResult e a -> m (TestResult e b)) -> m (TestResult e b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              TestPassed a
a  -> TestResultT e m b -> m (TestResult e b)
forall e (m :: * -> *) a. TestResultT e m a -> m (TestResult e a)
runTestResultT (a -> TestResultT e m b
f a
a)
              TestFailed e
e  -> TestResult e b -> m (TestResult e b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestResult e b -> m (TestResult e b))
-> TestResult e b -> m (TestResult e b)
forall a b. (a -> b) -> a -> b
$ e -> TestResult e b
forall e a. e -> TestResult e a
TestFailed e
e
              TestResult e a
TestDiscarded -> TestResult e b -> m (TestResult e b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestResult e b -> m (TestResult e b))
-> TestResult e b -> m (TestResult e b)
forall a b. (a -> b) -> a -> b
$ TestResult e 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 'Property'
-- instead, which fixes @e@ at 'String'.
newtype Property' e a = WrapProperty {
      forall e a.
Property' e a
-> TestResultT e (ReaderT Context (StateT TestRun Gen)) a
unwrapProperty :: TestResultT e (ReaderT Context (StateT TestRun Gen)) a
    }
  deriving newtype ((forall a b. (a -> b) -> Property' e a -> Property' e b)
-> (forall a b. a -> Property' e b -> Property' e a)
-> Functor (Property' e)
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
$cfmap :: forall e a b. (a -> b) -> Property' e a -> Property' e b
fmap :: forall a b. (a -> b) -> Property' e a -> Property' e b
$c<$ :: forall e a b. a -> Property' e b -> Property' e a
<$ :: forall a b. a -> Property' e b -> Property' e a
Functor, Functor (Property' e)
Functor (Property' e) =>
(forall a. a -> Property' e a)
-> (forall 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 a b. Property' e a -> Property' e b -> Property' e b)
-> (forall a b. Property' e a -> Property' e b -> Property' e a)
-> Applicative (Property' e)
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
$cpure :: forall e a. a -> Property' e a
pure :: forall a. a -> Property' e a
$c<*> :: forall e a b.
Property' e (a -> b) -> Property' e a -> Property' e b
<*> :: forall a b. Property' e (a -> b) -> Property' e a -> Property' e b
$cliftA2 :: forall e a b c.
(a -> b -> c) -> Property' e a -> Property' e b -> Property' e c
liftA2 :: forall a b c.
(a -> b -> c) -> Property' e a -> Property' e b -> Property' e c
$c*> :: forall e a b. Property' e a -> Property' e b -> Property' e b
*> :: 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 a
<* :: forall a b. Property' e a -> Property' e b -> Property' e a
Applicative, Applicative (Property' e)
Applicative (Property' e) =>
(forall a b.
 Property' e a -> (a -> Property' e b) -> Property' e b)
-> (forall a b. Property' e a -> Property' e b -> Property' e b)
-> (forall a. a -> Property' e a)
-> Monad (Property' e)
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
$c>>= :: forall e a b.
Property' e a -> (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 -> Property' e b -> Property' e b
>> :: forall a b. Property' e a -> Property' e b -> Property' e b
$creturn :: forall e a. a -> Property' e a
return :: forall a. a -> Property' e a
Monad)

-- | Property that uses strings as errors
--
-- Most of @falsify@'s internal functions work with 'Property'', but most
-- user-facing functions use 'Property' instead.
type Property = Property' String

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

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

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

-- | Test failure
testFailed :: e -> Property' e a
testFailed :: forall e a. e -> Property' e a
testFailed e
err = (Context -> TestRun -> Gen (TestResult e a, TestRun))
-> Property' e a
forall e a.
(Context -> TestRun -> Gen (TestResult e a, TestRun))
-> Property' e a
mkProperty ((Context -> TestRun -> Gen (TestResult e a, TestRun))
 -> Property' e a)
-> (Context -> TestRun -> Gen (TestResult e a, TestRun))
-> Property' e a
forall a b. (a -> b) -> a -> b
$ \Context
_ctx TestRun
run -> (TestResult e a, TestRun) -> Gen (TestResult e a, TestRun)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> TestResult e a
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 = (Context -> TestRun -> Gen (TestResult e a, TestRun))
-> Property' e a
forall e a.
(Context -> TestRun -> Gen (TestResult e a, TestRun))
-> Property' e a
mkProperty ((Context -> TestRun -> Gen (TestResult e a, TestRun))
 -> Property' e a)
-> (Context -> TestRun -> Gen (TestResult e a, TestRun))
-> Property' e a
forall a b. (a -> b) -> a -> b
$ \Context
_ctx TestRun
run -> (TestResult e a, TestRun) -> Gen (TestResult e a, TestRun)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (TestResult e a
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 =
    (Context -> TestRun -> Gen (TestResult e (), TestRun))
-> Property' e ()
forall e a.
(Context -> TestRun -> Gen (TestResult e a, TestRun))
-> Property' e a
mkProperty ((Context -> TestRun -> Gen (TestResult e (), TestRun))
 -> Property' e ())
-> (Context -> TestRun -> Gen (TestResult e (), TestRun))
-> Property' e ()
forall a b. (a -> b) -> a -> b
$ \Context
_ctx run :: TestRun
run@TestRun{runLog :: TestRun -> Log
runLog = Log [LogEntry]
log} -> (TestResult e (), TestRun) -> Gen (TestResult e (), TestRun)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (
        () -> TestResult e ()
forall e a. a -> TestResult e a
TestPassed ()
      , TestRun
run{runLog = Log $ Info msg : 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 -> String -> Property' String ()
forall e a. e -> Property' e a
testFailed String
err
      Right () -> () -> Property' String ()
forall a. a -> Property' String a
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 =
    (Context -> TestRun -> Gen (TestResult e (), TestRun))
-> Property' e ()
forall e a.
(Context -> TestRun -> Gen (TestResult e a, TestRun))
-> Property' e a
mkProperty ((Context -> TestRun -> Gen (TestResult e (), TestRun))
 -> Property' e ())
-> (Context -> TestRun -> Gen (TestResult e (), TestRun))
-> Property' e ()
forall a b. (a -> b) -> a -> b
$ \Context
_ctx run :: TestRun
run@TestRun{Map String (Set String)
runLabels :: TestRun -> Map String (Set String)
runLabels :: Map String (Set String)
runLabels} -> (TestResult e (), TestRun) -> Gen (TestResult e (), TestRun)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (
        () -> TestResult e ()
forall e a. a -> TestResult e a
TestPassed ()
      , TestRun
run{runLabels = Map.alter addValues lbl runLabels}
      )
  where
    addValues :: Maybe (Set String) -> Maybe (Set String)
    addValues :: Maybe (Set String) -> Maybe (Set String)
addValues = Set String -> Maybe (Set String)
forall a. a -> Maybe a
Just (Set String -> Maybe (Set String))
-> (Maybe (Set String) -> Set String)
-> Maybe (Set String)
-> Maybe (Set String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
vals) (Set String -> Set String)
-> (Maybe (Set String) -> Set String)
-> Maybe (Set String)
-> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set String -> Maybe (Set String) -> Set String
forall a. a -> Maybe a -> a
fromMaybe Set String
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 = String -> [String] -> Property' e ()
forall e. String -> [String] -> Property' e ()
label String
l ([String] -> Property' e ())
-> ([a] -> [String]) -> [a] -> Property' e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show

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


-- | Get the context for the current test run
getContext :: Property' e Context
getContext :: forall e. Property' e Context
getContext = (Context -> TestRun -> Gen (TestResult e Context, TestRun))
-> Property' e Context
forall e a.
(Context -> TestRun -> Gen (TestResult e a, TestRun))
-> Property' e a
mkProperty ((Context -> TestRun -> Gen (TestResult e Context, TestRun))
 -> Property' e Context)
-> (Context -> TestRun -> Gen (TestResult e Context, TestRun))
-> Property' e Context
forall a b. (a -> b) -> a -> b
$ \Context
ctx TestRun
run -> (TestResult e Context, TestRun)
-> Gen (TestResult e Context, TestRun)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> TestResult e Context
forall e a. a -> TestResult e a
TestPassed Context
ctx, TestRun
run)

-- | Generate value depending on the test iteration
--
-- Rough analogue to QuickCheck's @sized@ function: for test iteration @i@ out
-- of a total of @n@ tests, the callback is passed @i / n@. This can be used for
-- example to define a t'Test.Falsify.Range.Range' that starts small and gets
-- larger in successive tests.
--
-- Note that this is just a convenience function around 'getContext'; if you
-- want to define ranges that depend on the test iteration @i@ in a different
-- way, use 'getContext' instead.
sized :: forall e a. (ProperFraction -> a) -> Property' e a
sized :: forall e a. (ProperFraction -> a) -> Property' e a
sized ProperFraction -> a
f =
    Context -> a
aux (Context -> a) -> Property' e Context -> Property' e a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Property' e Context
forall e. Property' e Context
getContext
  where
    aux :: Context -> a
    aux :: Context -> a
aux Context
ctxt =
        ProperFraction -> a
f (ProperFraction -> a) -> ProperFraction -> a
forall a b. (a -> b) -> a -> b
$ Double -> ProperFraction
ProperFraction (Double -> ProperFraction) -> Double -> ProperFraction
forall a b. (a -> b) -> a -> b
$ Double
thisTest Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
numTests
      where
        thisTest, numTests :: Double
        thisTest :: Double
thisTest = Word -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Double) -> (Context -> Word) -> Context -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iteration -> Word
Context.thisTest (Iteration -> Word) -> (Context -> Iteration) -> Context -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Iteration
Context.iteration (Context -> Double) -> Context -> Double
forall a b. (a -> b) -> a -> b
$ Context
ctxt
        numTests :: Double
numTests = Word -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Double) -> (Context -> Word) -> Context -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Static -> Word
Context.tests    (Static -> Word) -> (Context -> Static) -> Context -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Static
Context.static    (Context -> Double) -> Context -> Double
forall a b. (a -> b) -> a -> b
$ Context
ctxt

{-------------------------------------------------------------------------------
  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 = (Context -> TestRun -> Gen (TestResult e a, TestRun))
-> Property' e a
forall e a.
(Context -> TestRun -> Gen (TestResult e a, TestRun))
-> Property' e a
mkProperty ((Context -> TestRun -> Gen (TestResult e a, TestRun))
 -> Property' e a)
-> (Context -> TestRun -> Gen (TestResult e a, TestRun))
-> Property' e a
forall a b. (a -> b) -> a -> b
$ \Context
_ctx TestRun
run -> TestRun -> a -> (TestResult e a, TestRun)
aux TestRun
run (a -> (TestResult e a, TestRun))
-> Gen a -> Gen (TestResult e a, TestRun)
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 = (
          a -> TestResult e a
forall e a. a -> TestResult e a
TestPassed a
x
        , TestRun
run{ runLog = Log $ case f x of
                 Just String
entry -> CallStack -> String -> LogEntry
Generated CallStack
stack String
entry LogEntry -> [LogEntry] -> [LogEntry]
forall a. a -> [a] -> [a]
: [LogEntry]
log
                 Maybe String
Nothing    -> [LogEntry]
log
             , runDeterministic = 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 = CallStack -> (a -> Maybe String) -> Gen a -> Property' e a
forall e a.
CallStack -> (a -> Maybe String) -> Gen a -> Property' e a
genWithCallStack CallStack
HasCallStack => CallStack
callStack (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> (a -> String) -> a -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
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 = CallStack -> (a -> Maybe String) -> Gen a -> Property' e a
forall e a.
CallStack -> (a -> Maybe String) -> Gen a -> Property' e a
genWithCallStack CallStack
HasCallStack => CallStack
callStack

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

-- | Construct random path through the property's shrink tree
--
-- The repeated 'Context.Final' step is /not/ included.
genShrinkPath ::
     Context.Iteration -- ^ See 'testShrinking' for detailed discussion
  -> Property' e ()
  -> Property' e' [Counterexample e]
genShrinkPath :: forall e e'.
Iteration -> Property' e () -> Property' e' [Counterexample e]
genShrinkPath Iteration
iteration Property' e ()
prop = do
    Static
static <- Context -> Static
Context.static (Context -> Static) -> Property' e' Context -> Property' e' Static
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Property' e' Context
forall e. Property' e Context
getContext

    let ctx :: Context.Execution -> Context
        ctx :: Execution -> Context
ctx = Static -> Iteration -> Execution -> Context
Context Static
static Iteration
iteration

    ShrinkTree (Execution, (TestResult e (), TestRun))
st    <- (ShrinkTree (Execution, (TestResult e (), TestRun))
 -> Maybe String)
-> Gen (ShrinkTree (Execution, (TestResult e (), TestRun)))
-> Property'
     e' (ShrinkTree (Execution, (TestResult e (), TestRun)))
forall a e.
HasCallStack =>
(a -> Maybe String) -> Gen a -> Property' e a
genWith (Maybe String
-> ShrinkTree (Execution, (TestResult e (), TestRun))
-> Maybe String
forall a b. a -> b -> a
const Maybe String
forall a. Maybe a
Nothing) (Gen (ShrinkTree (Execution, (TestResult e (), TestRun)))
 -> Property'
      e' (ShrinkTree (Execution, (TestResult e (), TestRun))))
-> Gen (ShrinkTree (Execution, (TestResult e (), TestRun)))
-> Property'
     e' (ShrinkTree (Execution, (TestResult e (), TestRun)))
forall a b. (a -> b) -> a -> b
$
               Bool
-> (Execution -> Gen (TestResult e (), TestRun))
-> Gen (ShrinkTree (Execution, (TestResult e (), TestRun)))
forall a.
Bool -> (Execution -> Gen a) -> Gen (ShrinkTree (Execution, a))
Gen.toShrinkTreeWithContext Bool
False (Property' e () -> Context -> Gen (TestResult e (), TestRun)
forall e a.
Property' e a -> Context -> Gen (TestResult e a, TestRun)
runProperty Property' e ()
prop (Context -> Gen (TestResult e (), TestRun))
-> (Execution -> Context)
-> Execution
-> Gen (TestResult e (), TestRun)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Execution -> Context
ctx)
    Either (Maybe (), TestRun) (NonEmpty (Counterexample e))
mPath <- (Either (Maybe (), TestRun) (NonEmpty (Counterexample e))
 -> Maybe String)
-> Gen (Either (Maybe (), TestRun) (NonEmpty (Counterexample e)))
-> Property'
     e' (Either (Maybe (), TestRun) (NonEmpty (Counterexample e)))
forall a e.
HasCallStack =>
(a -> Maybe String) -> Gen a -> Property' e a
genWith (Maybe String
-> Either (Maybe (), TestRun) (NonEmpty (Counterexample e))
-> Maybe String
forall a b. a -> b -> a
const Maybe String
forall a. Maybe a
Nothing) (Gen (Either (Maybe (), TestRun) (NonEmpty (Counterexample e)))
 -> Property'
      e' (Either (Maybe (), TestRun) (NonEmpty (Counterexample e))))
-> Gen (Either (Maybe (), TestRun) (NonEmpty (Counterexample e)))
-> Property'
     e' (Either (Maybe (), TestRun) (NonEmpty (Counterexample e)))
forall a b. (a -> b) -> a -> b
$
               ((Execution, (TestResult e (), TestRun))
 -> Either (Maybe (), TestRun) (Counterexample e))
-> ShrinkTree (Execution, (TestResult e (), TestRun))
-> Gen (Either (Maybe (), TestRun) (NonEmpty (Counterexample e)))
forall a p n.
(a -> Either n p) -> ShrinkTree a -> Gen (Either n (NonEmpty p))
Gen.path
                 ( \(Execution
exe, (TestResult e ()
result, TestRun
run)) ->
                      IsValidShrink (Counterexample e) (Maybe (), TestRun)
-> Either (Maybe (), TestRun) (Counterexample e)
forall p n. IsValidShrink p n -> Either n p
isValidShrink (IsValidShrink (Counterexample e) (Maybe (), TestRun)
 -> Either (Maybe (), TestRun) (Counterexample e))
-> IsValidShrink (Counterexample e) (Maybe (), TestRun)
-> Either (Maybe (), TestRun) (Counterexample e)
forall a b. (a -> b) -> a -> b
$ Execution
-> (TestResult e (), TestRun)
-> IsValidShrink (Counterexample e) (Maybe (), TestRun)
forall e a.
Execution
-> (TestResult e a, TestRun)
-> IsValidShrink (Counterexample e) (Maybe a, TestRun)
resultIsValidShrink Execution
exe (TestResult e ()
result, TestRun
run)
                 )
                 ShrinkTree (Execution, (TestResult e (), TestRun))
st
    Either (Maybe (), TestRun) (NonEmpty (Counterexample e))
-> Property' e' [Counterexample e]
forall e e'.
Either (Maybe (), TestRun) (NonEmpty (Counterexample e))
-> Property' e' [Counterexample e]
aux Either (Maybe (), TestRun) (NonEmpty (Counterexample e))
mPath
  where
    aux ::
         Either (Maybe (), TestRun) (NonEmpty (Counterexample e))
      -> Property' e' [Counterexample e]
    aux :: forall e e'.
Either (Maybe (), TestRun) (NonEmpty (Counterexample e))
-> Property' e' [Counterexample e]
aux (Left (Just (), TestRun
_)) = [Counterexample e] -> Property' e' [Counterexample e]
forall a. a -> Property' e' a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    aux (Left (Maybe ()
Nothing, TestRun
_)) = Property' e' [Counterexample e]
forall e a. Property' e a
discard
    aux (Right NonEmpty (Counterexample e)
es)          = [Counterexample e] -> Property' e' [Counterexample e]
forall a. a -> Property' e' a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Counterexample e] -> Property' e' [Counterexample e])
-> [Counterexample e] -> Property' e' [Counterexample e]
forall a b. (a -> b) -> a -> b
$ NonEmpty (Counterexample e) -> [Counterexample e]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Counterexample e)
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.
--
-- See also 'testShrinkingForIteration'.
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 = Iteration
-> Predicate '[e, e] -> Property' e () -> Property' String ()
forall e.
Show e =>
Iteration
-> Predicate '[e, e] -> Property' e () -> Property' String ()
testShrinkingForIteration (Iteration
 -> Predicate '[e, e] -> Property' e () -> Property' String ())
-> Iteration
-> Predicate '[e, e]
-> Property' e ()
-> Property' String ()
forall a b. (a -> b) -> a -> b
$ Context.Iteration{
      thisTest :: Word
thisTest = String -> Word
forall a. HasCallStack => String -> a
error (String -> Word) -> String -> Word
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
          String
"thisTest is undefined. "
        , String
"Use testShrinkingForIteration "
        , String
"instead of testShrinking."
        ]
    }

-- | Generalization of 'testShrinking' for an arbitrary t'Test.Falsify.Context.Iteration'
--
-- Some properties may behave quite differently given a different iteration
-- context, in which case it is important to be explicit about this.
--
-- The /shrinking/ context is constructed so that it accurately reflects the
-- path: 'Context.Initial' for the root of the tree, and then
-- 'Context.Shrinking' as we follow edges downwards. There is /no/ repeated
-- 'Context.Final' step: 'testShrinkingForIteration' and 'testShrinking' are
-- typically used to verify that successive shrink steps result in values that
-- are closer to the generator's origin, which is trivially violated by that
-- repeated final step.
--
-- The /static/ context is inherited from the parent property.
testShrinkingForIteration :: forall e.
     Show e
  => Context.Iteration
  -> Predicate [e, e] -> Property' e () -> Property' String ()
testShrinkingForIteration :: forall e.
Show e =>
Iteration
-> Predicate '[e, e] -> Property' e () -> Property' String ()
testShrinkingForIteration Iteration
iteration Predicate '[e, e]
p Property' e ()
prop = do
    [Counterexample e]
path <- Iteration -> Property' e () -> Property' String [Counterexample e]
forall e e'.
Iteration -> Property' e () -> Property' e' [Counterexample e]
genShrinkPath Iteration
iteration Property' e ()
prop
    case [Counterexample e] -> Maybe (String, Log, Log)
findCounterExample ([Counterexample e] -> [Counterexample e]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [Counterexample e]
path) of
      Maybe (String, Log, Log)
Nothing ->
        () -> Property' String ()
forall a. a -> Property' String a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just (String
err, Log
logBefore, Log
logAfter) -> do
        String -> Property' String ()
forall e. String -> Property' e ()
info String
"Before shrinking:"
        Log -> Property' String ()
forall e. Log -> Property' e ()
appendLog Log
logBefore
        String -> Property' String ()
forall e. String -> Property' e ()
info String
"After shrinking:"
        Log -> Property' String ()
forall e. Log -> Property' e ()
appendLog Log
logAfter
        String -> Property' String ()
forall e a. e -> Property' e a
testFailed String
err
  where
    findCounterExample :: [Counterexample e] -> Maybe (String, Log, Log)
    findCounterExample :: [Counterexample e] -> Maybe (String, Log, Log)
findCounterExample = \case
        []  -> Maybe (String, Log, Log)
forall a. Maybe a
Nothing
        [Counterexample e
_] -> Maybe (String, Log, Log)
forall a. Maybe a
Nothing
        (Counterexample e
x : rest :: [Counterexample e]
rest@(Counterexample e
y : [Counterexample e]
_)) ->
          case Predicate '[] -> Either String ()
P.eval (Predicate '[] -> Either String ())
-> Predicate '[] -> Either String ()
forall a b. (a -> b) -> a -> b
$
                 Predicate '[e, e]
p Predicate '[e, e] -> (VarName, e) -> Predicate '[e]
forall x (xs :: [*]).
Show x =>
Predicate (x : xs) -> (VarName, x) -> Predicate xs
.$ (VarName
"original" , Counterexample e -> e
forall e. Counterexample e -> e
counterexampleError Counterexample e
x)
                   Predicate '[e] -> (VarName, e) -> Predicate '[]
forall x (xs :: [*]).
Show x =>
Predicate (x : xs) -> (VarName, x) -> Predicate xs
.$ (VarName
"shrunk"   , Counterexample e -> e
forall e. Counterexample e -> e
counterexampleError Counterexample e
y) of
            Right () -> [Counterexample e] -> Maybe (String, Log, Log)
findCounterExample [Counterexample e]
rest
            Left String
err -> (String, Log, Log) -> Maybe (String, Log, Log)
forall a. a -> Maybe a
Just (
                String
err
              , TestRun -> Log
runLog (Counterexample e -> TestRun
forall e. Counterexample e -> TestRun
counterexampleRun Counterexample e
x)
              , TestRun -> Log
runLog (Counterexample e -> TestRun
forall e. Counterexample e -> TestRun
counterexampleRun Counterexample e
y)
              )

-- | 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.
--
-- See also 'testMinimumForIteration'.
testMinimum :: Show e => Predicate '[e] -> Property' e () -> Property' String ()
testMinimum :: forall e.
Show e =>
Predicate '[e] -> Property' e () -> Property' String ()
testMinimum = Iteration
-> Predicate '[e] -> Property' e () -> Property' String ()
forall e.
Show e =>
Iteration
-> Predicate '[e] -> Property' e () -> Property' String ()
testMinimumForIteration (Iteration
 -> Predicate '[e] -> Property' e () -> Property' String ())
-> Iteration
-> Predicate '[e]
-> Property' e ()
-> Property' String ()
forall a b. (a -> b) -> a -> b
$ Context.Iteration{
          thisTest :: Word
thisTest = String -> Word
forall a. HasCallStack => String -> a
error (String -> Word) -> String -> Word
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
              String
"thisTest is undefined. "
            , String
"Use testMinimumForIteration "
            , String
"instead of testMinimum."
            ]
        }

-- | Generalization of 'testMinimum'
--
-- See 'testShrinkingForIteration' for detailed discussion of the context.
testMinimumForIteration :: forall e.
     Show e
  => Context.Iteration
  -> Predicate '[e] -> Property' e () -> Property' String ()
testMinimumForIteration :: forall e.
Show e =>
Iteration
-> Predicate '[e] -> Property' e () -> Property' String ()
testMinimumForIteration Iteration
iteration Predicate '[e]
p Property' e ()
prop = do
    Static
static <- Context -> Static
Context.static (Context -> Static)
-> Property' String Context -> Property' String Static
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Property' String Context
forall e. Property' e Context
getContext

    let initContext :: Context
        initContext :: Context
initContext = Static -> Iteration -> Execution -> Context
Context Static
static Iteration
iteration Execution
Context.Initial

    SampleTree
st <- (SampleTree -> Maybe String)
-> Gen SampleTree -> Property' String SampleTree
forall a e.
HasCallStack =>
(a -> Maybe String) -> Gen a -> Property' e a
genWith (Maybe String -> SampleTree -> Maybe String
forall a b. a -> b -> a
const Maybe String
forall a. Maybe a
Nothing) (Gen SampleTree -> Property' String SampleTree)
-> Gen SampleTree -> Property' String SampleTree
forall a b. (a -> b) -> a -> b
$ Gen SampleTree
Gen.captureLocalTree
    case Gen (TestResult e (), TestRun)
-> SampleTree -> ((TestResult e (), TestRun), [SampleTree])
forall a. Gen a -> SampleTree -> (a, [SampleTree])
runGen (Property' e () -> Context -> Gen (TestResult e (), TestRun)
forall e a.
Property' e a -> Context -> Gen (TestResult e a, TestRun)
runProperty Property' e ()
prop Context
initContext) SampleTree
st of
      ((TestPassed (), TestRun
_run), [SampleTree]
_shrunk) ->
        -- The property passed; nothing to test
        Property' String ()
forall e a. Property' e a
discard
      ((TestResult e ()
TestDiscarded, TestRun
_run), [SampleTree]
_shrunk) ->
        -- The property needs to be discarded; discard this one, too
        Property' String ()
forall e a. Property' e a
discard
      ((TestFailed e
initErr, TestRun
initRun), [SampleTree]
shrunk) -> do
        let explanation :: ShrinkExplanation (Counterexample e) (Maybe (), TestRun)
            explanation :: ShrinkExplanation (Counterexample e) (Maybe (), TestRun)
explanation =
                Static
-> Iteration
-> (Context
    -> Gen (IsValidShrink (Counterexample e) (Maybe (), TestRun)))
-> SampleTree
-> (Counterexample e, [SampleTree])
-> ShrinkExplanation (Counterexample e) (Maybe (), TestRun)
forall p n.
Static
-> Iteration
-> (Context -> Gen (IsValidShrink p n))
-> SampleTree
-> (p, [SampleTree])
-> ShrinkExplanation p n
shrinkFrom
                  Static
static
                  Iteration
iteration
                  (\Context
ctx -> Execution
-> (TestResult e (), TestRun)
-> IsValidShrink (Counterexample e) (Maybe (), TestRun)
forall e a.
Execution
-> (TestResult e a, TestRun)
-> IsValidShrink (Counterexample e) (Maybe a, TestRun)
resultIsValidShrink (Context -> Execution
Context.execution Context
ctx) ((TestResult e (), TestRun)
 -> IsValidShrink (Counterexample e) (Maybe (), TestRun))
-> Gen (TestResult e (), TestRun)
-> Gen (IsValidShrink (Counterexample e) (Maybe (), TestRun))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                             Property' e () -> Context -> Gen (TestResult e (), TestRun)
forall e a.
Property' e a -> Context -> Gen (TestResult e a, TestRun)
runProperty Property' e ()
prop Context
ctx)
                  SampleTree
st
                  (Execution -> e -> TestRun -> Counterexample e
forall e. Execution -> e -> TestRun -> Counterexample e
Counterexample Execution
Context.Initial e
initErr TestRun
initRun, [SampleTree]
shrunk)

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

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

        case Predicate '[] -> Either String ()
P.eval (Predicate '[] -> Either String ())
-> Predicate '[] -> Either String ()
forall a b. (a -> b) -> a -> b
$ Predicate '[e]
p Predicate '[e] -> (VarName, e) -> Predicate '[]
forall x (xs :: [*]).
Show x =>
Predicate (x : xs) -> (VarName, x) -> Predicate xs
.$ (VarName
"minimum", Counterexample e -> e
forall e. Counterexample e -> e
counterexampleError Counterexample e
minExample) 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.
            String -> Property' String ()
forall e. String -> Property' e ()
info String
"Shrink history:"
            NonEmpty (Counterexample e)
-> (Counterexample e -> Property' String ()) -> Property' String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ShrinkExplanation (Counterexample e) (Maybe (), TestRun)
-> NonEmpty (Counterexample e)
forall p n. ShrinkExplanation p n -> NonEmpty p
shrinkHistory ShrinkExplanation (Counterexample e) (Maybe (), TestRun)
explanation) ((Counterexample e -> Property' String ()) -> Property' String ())
-> (Counterexample e -> Property' String ()) -> Property' String ()
forall a b. (a -> b) -> a -> b
$ \Counterexample e
example ->
              String -> Property' String ()
forall e. String -> Property' e ()
info (String -> Property' String ()) -> String -> Property' String ()
forall a b. (a -> b) -> a -> b
$ e -> String
forall a. Show a => a -> String
show (Counterexample e -> e
forall e. Counterexample e -> e
counterexampleError Counterexample e
example)
          Left String
err -> do
            Log -> Property' String ()
forall e. Log -> Property' e ()
appendLog (TestRun -> Log
runLog (TestRun -> Log) -> TestRun -> Log
forall a b. (a -> b) -> a -> b
$ Counterexample e -> TestRun
forall e. Counterexample e -> TestRun
counterexampleRun Counterexample e
minExample)
            Bool -> Property' String () -> Property' String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TestRun] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestRun]
rejected) (Property' String () -> Property' String ())
-> Property' String () -> Property' String ()
forall a b. (a -> b) -> a -> b
$ do
              String -> Property' String ()
forall e. String -> Property' e ()
info String
"\nLogs for rejected potential next shrinks:"
              [(Word, TestRun)]
-> ((Word, TestRun) -> Property' String ()) -> Property' String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Word] -> [TestRun] -> [(Word, TestRun)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word
0 :: Word ..] [TestRun]
rejected) (((Word, TestRun) -> Property' String ()) -> Property' String ())
-> ((Word, TestRun) -> Property' String ()) -> Property' String ()
forall a b. (a -> b) -> a -> b
$ \(Word
i, TestRun
rej) -> do
                String -> Property' String ()
forall e. String -> Property' e ()
info (String -> Property' String ()) -> String -> Property' String ()
forall a b. (a -> b) -> a -> b
$ String
"\n** Rejected run " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
i
                Log -> Property' String ()
forall e. Log -> Property' e ()
appendLog (Log -> Property' String ()) -> Log -> Property' String ()
forall a b. (a -> b) -> a -> b
$ TestRun -> Log
runLog TestRun
rej
            String -> Property' String ()
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 = (a -> Either String ()) -> Gen a -> Property' String ()
forall e a b. (a -> Either e b) -> Gen a -> Property' e b
testGen' ((a -> Either String ()) -> Gen a -> Property' String ())
-> (a -> Either String ()) -> Gen a -> Property' String ()
forall a b. (a -> b) -> a -> b
$ \a
a -> Predicate '[] -> Either String ()
P.eval (Predicate '[] -> Either String ())
-> Predicate '[] -> Either String ()
forall a b. (a -> b) -> a -> b
$ Predicate '[a]
p Predicate '[a] -> (VarName, a) -> Predicate '[]
forall x (xs :: [*]).
Show x =>
Predicate (x : xs) -> (VarName, x) -> Predicate xs
.$ (VarName
"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 = TestResultT e (ReaderT Context (StateT TestRun Gen)) b
-> Property' e b
forall e a.
TestResultT e (ReaderT Context (StateT TestRun Gen)) a
-> Property' e a
WrapProperty (TestResultT e (ReaderT Context (StateT TestRun Gen)) b
 -> Property' e b)
-> TestResultT e (ReaderT Context (StateT TestRun Gen)) b
-> Property' e b
forall a b. (a -> b) -> a -> b
$ ReaderT Context (StateT TestRun Gen) (TestResult e b)
-> TestResultT e (ReaderT Context (StateT TestRun Gen)) b
forall e (m :: * -> *) a. m (TestResult e a) -> TestResultT e m a
TestResultT (ReaderT Context (StateT TestRun Gen) (TestResult e b)
 -> TestResultT e (ReaderT Context (StateT TestRun Gen)) b)
-> ReaderT Context (StateT TestRun Gen) (TestResult e b)
-> TestResultT e (ReaderT Context (StateT TestRun Gen)) b
forall a b. (a -> b) -> a -> b
$ (Context -> StateT TestRun Gen (TestResult e b))
-> ReaderT Context (StateT TestRun Gen) (TestResult e b)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((Context -> StateT TestRun Gen (TestResult e b))
 -> ReaderT Context (StateT TestRun Gen) (TestResult e b))
-> (Context -> StateT TestRun Gen (TestResult e b))
-> ReaderT Context (StateT TestRun Gen) (TestResult e b)
forall a b. (a -> b) -> a -> b
$ \Context
_ctx -> (TestRun -> Gen (TestResult e b, TestRun))
-> StateT TestRun Gen (TestResult e b)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((TestRun -> Gen (TestResult e b, TestRun))
 -> StateT TestRun Gen (TestResult e b))
-> (TestRun -> Gen (TestResult e b, TestRun))
-> StateT TestRun Gen (TestResult e b)
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 (a -> (TestResult e b, TestRun))
-> Gen a -> Gen (TestResult e b, TestRun)
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 -> e -> TestResult e b
forall e a. e -> TestResult e a
TestFailed e
e
            Right b
b -> b -> TestResult e b
forall e a. a -> TestResult e a
TestPassed b
b
        , TestRun
run{runDeterministic = False}
        )

-- | Test shrinking of a generator
--
-- We check /any/ shrink step that the generator can make (independent of any
-- property).
--
-- See also 'testShrinkingOfGenForIteration'.
testShrinkingOfGen :: Show a => Predicate [a, a] -> Gen a -> Property' String ()
testShrinkingOfGen :: forall a.
Show a =>
Predicate '[a, a] -> Gen a -> Property' String ()
testShrinkingOfGen =
    Iteration -> Predicate '[a, a] -> Gen a -> Property' String ()
forall a.
Show a =>
Iteration -> Predicate '[a, a] -> Gen a -> Property' String ()
testShrinkingOfGenForIteration (Iteration -> Predicate '[a, a] -> Gen a -> Property' String ())
-> Iteration -> Predicate '[a, a] -> Gen a -> Property' String ()
forall a b. (a -> b) -> a -> b
$ Context.Iteration{
          thisTest :: Word
thisTest = String -> Word
forall a. HasCallStack => String -> a
error (String -> Word) -> String -> Word
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
              String
"thisTest is undefined. "
            , String
"Use testShrinkingOfGenForIteration "
            , String
"instead of testShrinkingOfGen."
            ]
        }

-- | Generalization of 'testShrinkingOfGen'
--
-- See 'testShrinkingForIteration' for detailed discussion of the context.
testShrinkingOfGenForIteration ::
     Show a
  => Context.Iteration
  -> Predicate [a, a] -> Gen a -> Property' String ()
testShrinkingOfGenForIteration :: forall a.
Show a =>
Iteration -> Predicate '[a, a] -> Gen a -> Property' String ()
testShrinkingOfGenForIteration Iteration
iteration Predicate '[a, a]
p =
    Iteration
-> Predicate '[a, a] -> Property' a () -> Property' String ()
forall e.
Show e =>
Iteration
-> Predicate '[e, e] -> Property' e () -> Property' String ()
testShrinkingForIteration Iteration
iteration Predicate '[a, a]
p (Property' a () -> Property' String ())
-> (Gen a -> Property' a ()) -> Gen a -> Property' String ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Either a ()) -> Gen a -> Property' a ()
forall e a b. (a -> Either e b) -> Gen a -> Property' e b
testGen' a -> Either a ()
forall a b. a -> Either a b
Left