{-# OPTIONS_HADDOCK hide #-}
-- | Combinators for constructing properties.
{-# LANGUAGE CPP #-}
#ifndef NO_TYPEABLE
{-# LANGUAGE DeriveDataTypeable #-}
#endif
#ifndef NO_SAFE_HASKELL
{-# LANGUAGE Safe #-}
#endif
module Test.QuickCheck.Property where

--------------------------------------------------------------------------
-- imports

import Test.QuickCheck.Gen
import Test.QuickCheck.Gen.Unsafe
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Text( isOneLine, putLine )
import Test.QuickCheck.Exception
import Test.QuickCheck.State( State(terminal), Confidence(..) )

#ifndef NO_TIMEOUT
import System.Timeout(timeout)
#endif
import Data.Maybe
import Control.Applicative
import Control.Monad
import qualified Data.Map as Map
import Data.Map(Map)
import qualified Data.Set as Set
import Data.Set(Set)
#ifndef NO_DEEPSEQ
import Control.DeepSeq
#endif
#ifndef NO_TYPEABLE
import Data.Typeable (Typeable)
#endif
import Data.Maybe

--------------------------------------------------------------------------
-- fixities

infixr 0 ==>
infixr 1 .&.
infixr 1 .&&.
infixr 1 .||.

-- The story for exception handling:
--
-- To avoid insanity, we have rules about which terms can throw
-- exceptions when we evaluate them:
--   * A rose tree must evaluate to WHNF without throwing an exception
--   * The 'ok' component of a Result must evaluate to Just True or
--     Just False or Nothing rather than raise an exception
--   * IORose _ must never throw an exception when executed
--
-- Both rose trees and Results may loop when we evaluate them, though,
-- so we have to be careful not to force them unnecessarily.
--
-- We also have to be careful when we use fmap or >>= in the Rose
-- monad that the function we supply is total, or else use
-- protectResults afterwards to install exception handlers. The
-- mapResult function on Properties installs an exception handler for
-- us, though.
--
-- Of course, the user is free to write "error "ha ha" :: Result" if
-- they feel like it. We have to make sure that any user-supplied Rose
-- Results or Results get wrapped in exception handlers, which we do by:
--   * Making the 'property' function install an exception handler
--     round its argument. This function always gets called in the
--     right places, because all our Property-accepting functions are
--     actually polymorphic over the Testable class so they have to
--     call 'property'.
--   * Installing an exception handler round a Result before we put it
--     in a rose tree (the only place Results can end up).

--------------------------------------------------------------------------
-- * Property and Testable types

-- | The type of properties.
newtype Property = MkProperty { Property -> Gen Prop
unProperty :: Gen Prop }
#ifndef NO_TYPEABLE
  deriving (Typeable)
#endif

-- | The class of properties, i.e., types which QuickCheck knows how to test.
-- Typically a property will be a function returning 'Bool' or 'Property'.
--
-- If a property does no quantification, i.e. has no
-- parameters and doesn't use 'forAll', it will only be tested once.
-- This may not be what you want if your property is an @IO Bool@.
-- You can change this behaviour using the 'again' combinator.
class Testable prop where
  -- | Convert the thing to a property.
  property :: prop -> Property

  -- | Optional; used internally in order to improve shrinking.
  -- Tests a property but also quantifies over an extra value
  -- (with a custom shrink and show function).
  -- The 'Testable' instance for functions defines
  -- @propertyForAllShrinkShow@ in a way that improves shrinking.
  propertyForAllShrinkShow :: Gen a -> (a -> [a]) -> (a -> [String]) -> (a -> prop) -> Property
  propertyForAllShrinkShow Gen a
gen a -> [a]
shr a -> [String]
shw a -> prop
f =
    Gen a -> (a -> [a]) -> (a -> Property) -> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrinkBlind Gen a
gen a -> [a]
shr ((a -> Property) -> Property) -> (a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
      \a
x -> (String -> Property -> Property)
-> Property -> [String] -> Property
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (prop -> Property
forall prop. Testable prop => prop -> Property
property (a -> prop
f a
x)) (a -> [String]
shw a
x)

-- | If a property returns 'Discard', the current test case is discarded,
-- the same as if a precondition was false.
--
-- An example is the definition of '==>':
--
-- > (==>) :: Testable prop => Bool -> prop -> Property
-- > False ==> _ = property Discard
-- > True  ==> p = property p
data Discard = Discard

instance Testable Discard where
  property :: Discard -> Property
property Discard
_ = Result -> Property
forall prop. Testable prop => prop -> Property
property Result
rejected

-- This instance is here to make it easier to turn IO () into a Property.
instance Testable () where
  property :: () -> Property
property = Result -> Property
forall prop. Testable prop => prop -> Property
property (Result -> Property) -> (() -> Result) -> () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Result
liftUnit
    where
      -- N.B. the unit gets forced only inside 'property',
      -- so that we turn exceptions into test failures
      liftUnit :: () -> Result
liftUnit () = Result
succeeded

instance Testable prop => Testable (Maybe prop) where
  property :: Maybe prop -> Property
property = Property -> Property
forall prop. Testable prop => prop -> Property
property (Property -> Property)
-> (Maybe prop -> Property) -> Maybe prop -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe prop -> Property
forall prop. Testable prop => Maybe prop -> Property
liftMaybe
    where
      -- See comment for liftUnit above
      liftMaybe :: Maybe prop -> Property
liftMaybe Maybe prop
Nothing = Discard -> Property
forall prop. Testable prop => prop -> Property
property Discard
Discard
      liftMaybe (Just prop
prop) = prop -> Property
forall prop. Testable prop => prop -> Property
property prop
prop

instance Testable Bool where
  property :: Bool -> Property
property = Result -> Property
forall prop. Testable prop => prop -> Property
property (Result -> Property) -> (Bool -> Result) -> Bool -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Result
liftBool

instance Testable Result where
  property :: Result -> Property
property = Gen Prop -> Property
MkProperty (Gen Prop -> Property)
-> (Result -> Gen Prop) -> Result -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prop -> Gen Prop
forall (m :: * -> *) a. Monad m => a -> m a
return (Prop -> Gen Prop) -> (Result -> Prop) -> Result -> Gen Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rose Result -> Prop
MkProp (Rose Result -> Prop) -> (Result -> Rose Result) -> Result -> Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rose Result -> Rose Result
protectResults (Rose Result -> Rose Result)
-> (Result -> Rose Result) -> Result -> Rose Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Rose Result
forall (m :: * -> *) a. Monad m => a -> m a
return

instance Testable Prop where
  property :: Prop -> Property
property Prop
p = Gen Prop -> Property
MkProperty (Gen Prop -> Property) -> (Prop -> Gen Prop) -> Prop -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prop -> Gen Prop
forall (m :: * -> *) a. Monad m => a -> m a
return (Prop -> Gen Prop) -> (Prop -> Prop) -> Prop -> Gen Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prop -> Prop
protectProp (Prop -> Property) -> Prop -> Property
forall a b. (a -> b) -> a -> b
$ Prop
p

instance Testable prop => Testable (Gen prop) where
  property :: Gen prop -> Property
property Gen prop
mp = Gen Prop -> Property
MkProperty (Gen Prop -> Property) -> Gen Prop -> Property
forall a b. (a -> b) -> a -> b
$ do prop
p <- Gen prop
mp; Property -> Gen Prop
unProperty (prop -> Property
forall prop. Testable prop => prop -> Property
again prop
p)

instance Testable Property where
  property :: Property -> Property
property (MkProperty Gen Prop
mp) = Gen Prop -> Property
MkProperty ((Prop -> Prop) -> Gen Prop -> Gen Prop
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Prop -> Prop
protectProp Gen Prop
mp)

-- | Do I/O inside a property.
{-# DEPRECATED morallyDubiousIOProperty "Use 'ioProperty' instead" #-}
morallyDubiousIOProperty :: Testable prop => IO prop -> Property
morallyDubiousIOProperty :: IO prop -> Property
morallyDubiousIOProperty = IO prop -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty

-- | Do I/O inside a property.
--
-- Warning: any random values generated inside of the argument to @ioProperty@
-- will not currently be shrunk. For best results, generate all random values
-- before calling @ioProperty@, or use 'idempotentIOProperty' if that is safe.
--
-- Note: if your property does no quantification, it will only be tested once.
-- To test it repeatedly, use 'again'.
ioProperty :: Testable prop => IO prop -> Property
ioProperty :: IO prop -> Property
ioProperty IO prop
prop = IO Property -> Property
forall prop. Testable prop => IO prop -> Property
idempotentIOProperty ((prop -> Property) -> IO prop -> IO Property
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap prop -> Property
forall prop. Testable prop => prop -> Property
noShrinking IO prop
prop)

-- | Do I/O inside a property.
--
-- Warning: during shrinking, the I/O may not always be re-executed.
-- Instead, the I/O may be executed once and then its result retained.
-- If this is not acceptable, use 'ioProperty' instead.
idempotentIOProperty :: Testable prop => IO prop -> Property
idempotentIOProperty :: IO prop -> Property
idempotentIOProperty =
  Gen Prop -> Property
MkProperty (Gen Prop -> Property)
-> (IO prop -> Gen Prop) -> IO prop -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO Prop -> Prop) -> Gen (IO Prop) -> Gen Prop
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rose Result -> Prop
MkProp (Rose Result -> Prop)
-> (IO Prop -> Rose Result) -> IO Prop -> Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Rose Result) -> Rose Result
ioRose (IO (Rose Result) -> Rose Result)
-> (IO Prop -> IO (Rose Result)) -> IO Prop -> Rose Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Prop -> Rose Result) -> IO Prop -> IO (Rose Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Prop -> Rose Result
unProp) (Gen (IO Prop) -> Gen Prop)
-> (IO prop -> Gen (IO Prop)) -> IO prop -> Gen Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  IO (Gen Prop) -> Gen (IO Prop)
forall (m :: * -> *) a. Monad m => m (Gen a) -> Gen (m a)
promote (IO (Gen Prop) -> Gen (IO Prop))
-> (IO prop -> IO (Gen Prop)) -> IO prop -> Gen (IO Prop)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (prop -> Gen Prop) -> IO prop -> IO (Gen Prop)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Property -> Gen Prop
unProperty (Property -> Gen Prop) -> (prop -> Property) -> prop -> Gen Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. prop -> Property
forall prop. Testable prop => prop -> Property
property)

instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where
  property :: (a -> prop) -> Property
property a -> prop
f =
    Gen a -> (a -> [a]) -> (a -> [String]) -> (a -> prop) -> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> [String]) -> (a -> prop) -> Property
propertyForAllShrinkShow Gen a
forall a. Arbitrary a => Gen a
arbitrary a -> [a]
forall a. Arbitrary a => a -> [a]
shrink (String -> [String]
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [String]) -> (a -> String) -> a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show) a -> prop
f
  propertyForAllShrinkShow :: Gen a
-> (a -> [a]) -> (a -> [String]) -> (a -> a -> prop) -> Property
propertyForAllShrinkShow Gen a
gen a -> [a]
shr a -> [String]
shw a -> a -> prop
f =
    -- gen :: Gen b, shr :: b -> [b], f :: b -> a -> prop
    -- Idea: Generate and shrink (b, a) as a pair
    Gen (a, a)
-> ((a, a) -> [(a, a)])
-> ((a, a) -> [String])
-> ((a, a) -> prop)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> [String]) -> (a -> prop) -> Property
propertyForAllShrinkShow
      ((a -> a -> (a, a)) -> Gen a -> Gen a -> Gen (a, a)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) Gen a
gen Gen a
forall a. Arbitrary a => Gen a
arbitrary)
      ((a -> [a]) -> (a -> [a]) -> (a, a) -> [(a, a)]
forall (f :: * -> * -> *) a b.
Arbitrary2 f =>
(a -> [a]) -> (b -> [b]) -> f a b -> [f a b]
liftShrink2 a -> [a]
shr a -> [a]
forall a. Arbitrary a => a -> [a]
shrink)
      (\(a
x, a
y) -> a -> [String]
shw a
x [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [a -> String
forall a. Show a => a -> String
show a
y])
      ((a -> a -> prop) -> (a, a) -> prop
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> a -> prop
f)

-- ** Exception handling
protect :: (AnException -> a) -> IO a -> IO a
protect :: (AnException -> a) -> IO a -> IO a
protect AnException -> a
f IO a
x = (AnException -> a) -> (a -> a) -> Either AnException a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either AnException -> a
f a -> a
forall a. a -> a
id (Either AnException a -> a) -> IO (Either AnException a) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO a -> IO (Either AnException a)
forall a. IO a -> IO (Either AnException a)
tryEvaluateIO IO a
x

--------------------------------------------------------------------------
-- ** Type Prop

newtype Prop = MkProp{ Prop -> Rose Result
unProp :: Rose Result }

-- ** type Rose

data Rose a = MkRose a [Rose a] | IORose (IO (Rose a))
-- Only use IORose if you know that the argument is not going to throw an exception!
-- Otherwise, try ioRose.
ioRose :: IO (Rose Result) -> Rose Result
ioRose :: IO (Rose Result) -> Rose Result
ioRose = IO (Rose Result) -> Rose Result
forall a. IO (Rose a) -> Rose a
IORose (IO (Rose Result) -> Rose Result)
-> (IO (Rose Result) -> IO (Rose Result))
-> IO (Rose Result)
-> Rose Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Rose Result) -> IO (Rose Result)
protectRose

joinRose :: Rose (Rose a) -> Rose a
joinRose :: Rose (Rose a) -> Rose a
joinRose (IORose IO (Rose (Rose a))
rs) = IO (Rose a) -> Rose a
forall a. IO (Rose a) -> Rose a
IORose ((Rose (Rose a) -> Rose a) -> IO (Rose (Rose a)) -> IO (Rose a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rose (Rose a) -> Rose a
forall a. Rose (Rose a) -> Rose a
joinRose IO (Rose (Rose a))
rs)
joinRose (MkRose (IORose IO (Rose a)
rm) [Rose (Rose a)]
rs) = IO (Rose a) -> Rose a
forall a. IO (Rose a) -> Rose a
IORose (IO (Rose a) -> Rose a) -> IO (Rose a) -> Rose a
forall a b. (a -> b) -> a -> b
$ do Rose a
r <- IO (Rose a)
rm; Rose a -> IO (Rose a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Rose (Rose a) -> Rose a
forall a. Rose (Rose a) -> Rose a
joinRose (Rose a -> [Rose (Rose a)] -> Rose (Rose a)
forall a. a -> [Rose a] -> Rose a
MkRose Rose a
r [Rose (Rose a)]
rs))
joinRose (MkRose (MkRose a
x [Rose a]
ts) [Rose (Rose a)]
tts) =
  -- first shrinks outer quantification; makes most sense
  a -> [Rose a] -> Rose a
forall a. a -> [Rose a] -> Rose a
MkRose a
x ((Rose (Rose a) -> Rose a) -> [Rose (Rose a)] -> [Rose a]
forall a b. (a -> b) -> [a] -> [b]
map Rose (Rose a) -> Rose a
forall a. Rose (Rose a) -> Rose a
joinRose [Rose (Rose a)]
tts [Rose a] -> [Rose a] -> [Rose a]
forall a. [a] -> [a] -> [a]
++ [Rose a]
ts)
  -- first shrinks inner quantification: terrible
  --MkRose x (ts ++ map joinRose tts)

instance Functor Rose where
  -- f must be total
  fmap :: (a -> b) -> Rose a -> Rose b
fmap a -> b
f (IORose IO (Rose a)
rs)   = IO (Rose b) -> Rose b
forall a. IO (Rose a) -> Rose a
IORose ((Rose a -> Rose b) -> IO (Rose a) -> IO (Rose b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Rose a -> Rose b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) IO (Rose a)
rs)
  fmap a -> b
f (MkRose a
x [Rose a]
rs) = b -> [Rose b] -> Rose b
forall a. a -> [Rose a] -> Rose a
MkRose (a -> b
f a
x) [ (a -> b) -> Rose a -> Rose b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Rose a
r | Rose a
r <- [Rose a]
rs ]

instance Applicative Rose where
  pure :: a -> Rose a
pure = a -> Rose a
forall (m :: * -> *) a. Monad m => a -> m a
return
  -- f must be total
  <*> :: Rose (a -> b) -> Rose a -> Rose b
(<*>) = ((a -> b) -> a -> b) -> Rose (a -> b) -> Rose a -> Rose b
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($)

instance Monad Rose where
  return :: a -> Rose a
return a
x = a -> [Rose a] -> Rose a
forall a. a -> [Rose a] -> Rose a
MkRose a
x []
  -- k must be total
  Rose a
m >>= :: Rose a -> (a -> Rose b) -> Rose b
>>= a -> Rose b
k  = Rose (Rose b) -> Rose b
forall a. Rose (Rose a) -> Rose a
joinRose ((a -> Rose b) -> Rose a -> Rose (Rose b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Rose b
k Rose a
m)

-- | Execute the "IORose" bits of a rose tree, returning a tree
-- constructed by MkRose.
reduceRose :: Rose Result -> IO (Rose Result)
reduceRose :: Rose Result -> IO (Rose Result)
reduceRose r :: Rose Result
r@(MkRose Result
_ [Rose Result]
_) = Rose Result -> IO (Rose Result)
forall (m :: * -> *) a. Monad m => a -> m a
return Rose Result
r
reduceRose (IORose IO (Rose Result)
m) = IO (Rose Result)
m IO (Rose Result)
-> (Rose Result -> IO (Rose Result)) -> IO (Rose Result)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Rose Result -> IO (Rose Result)
reduceRose

-- | Apply a function to the outermost MkRose constructor of a rose tree.
-- The function must be total!
onRose :: (a -> [Rose a] -> Rose a) -> Rose a -> Rose a
onRose :: (a -> [Rose a] -> Rose a) -> Rose a -> Rose a
onRose a -> [Rose a] -> Rose a
f (MkRose a
x [Rose a]
rs) = a -> [Rose a] -> Rose a
f a
x [Rose a]
rs
onRose a -> [Rose a] -> Rose a
f (IORose IO (Rose a)
m) = IO (Rose a) -> Rose a
forall a. IO (Rose a) -> Rose a
IORose ((Rose a -> Rose a) -> IO (Rose a) -> IO (Rose a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> [Rose a] -> Rose a) -> Rose a -> Rose a
forall a. (a -> [Rose a] -> Rose a) -> Rose a -> Rose a
onRose a -> [Rose a] -> Rose a
f) IO (Rose a)
m)

-- | Wrap a rose tree in an exception handler.
protectRose :: IO (Rose Result) -> IO (Rose Result)
protectRose :: IO (Rose Result) -> IO (Rose Result)
protectRose = (AnException -> Rose Result)
-> IO (Rose Result) -> IO (Rose Result)
forall a. (AnException -> a) -> IO a -> IO a
protect (Result -> Rose Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> Rose Result)
-> (AnException -> Result) -> AnException -> Rose Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AnException -> Result
exception String
"Exception")

-- | Wrap the top level of a 'Prop' in an exception handler.
protectProp :: Prop -> Prop
protectProp :: Prop -> Prop
protectProp (MkProp Rose Result
r) = Rose Result -> Prop
MkProp (IO (Rose Result) -> Rose Result
forall a. IO (Rose a) -> Rose a
IORose (IO (Rose Result) -> Rose Result)
-> (Rose Result -> IO (Rose Result)) -> Rose Result -> Rose Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Rose Result) -> IO (Rose Result)
protectRose (IO (Rose Result) -> IO (Rose Result))
-> (Rose Result -> IO (Rose Result))
-> Rose Result
-> IO (Rose Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rose Result -> IO (Rose Result)
forall (m :: * -> *) a. Monad m => a -> m a
return (Rose Result -> Rose Result) -> Rose Result -> Rose Result
forall a b. (a -> b) -> a -> b
$ Rose Result
r)

-- | Wrap all the Results in a rose tree in exception handlers.
protectResults :: Rose Result -> Rose Result
protectResults :: Rose Result -> Rose Result
protectResults = (Result -> [Rose Result] -> Rose Result)
-> Rose Result -> Rose Result
forall a. (a -> [Rose a] -> Rose a) -> Rose a -> Rose a
onRose ((Result -> [Rose Result] -> Rose Result)
 -> Rose Result -> Rose Result)
-> (Result -> [Rose Result] -> Rose Result)
-> Rose Result
-> Rose Result
forall a b. (a -> b) -> a -> b
$ \Result
x [Rose Result]
rs ->
  IO (Rose Result) -> Rose Result
forall a. IO (Rose a) -> Rose a
IORose (IO (Rose Result) -> Rose Result)
-> IO (Rose Result) -> Rose Result
forall a b. (a -> b) -> a -> b
$ do
    Result
y <- IO Result -> IO Result
protectResult (Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
x)
    Rose Result -> IO (Rose Result)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> [Rose Result] -> Rose Result
forall a. a -> [Rose a] -> Rose a
MkRose Result
y ((Rose Result -> Rose Result) -> [Rose Result] -> [Rose Result]
forall a b. (a -> b) -> [a] -> [b]
map Rose Result -> Rose Result
protectResults [Rose Result]
rs))

-- ** Result type

-- | Different kinds of callbacks
data Callback
  = PostTest CallbackKind (State -> Result -> IO ())         -- ^ Called just after a test
  | PostFinalFailure CallbackKind (State -> Result -> IO ()) -- ^ Called with the final failing test-case
data CallbackKind = Counterexample    -- ^ Affected by the 'verbose' combinator
                  | NotCounterexample -- ^ Not affected by the 'verbose' combinator

-- | The result of a single test.
data Result
  = MkResult
  { Result -> Maybe Bool
ok                 :: Maybe Bool
    -- ^ result of the test case; Nothing = discard
  , Result -> Bool
expect             :: Bool
    -- ^ indicates what the expected result of the property is
  , Result -> String
reason             :: String
    -- ^ a message indicating what went wrong
  , Result -> Maybe AnException
theException       :: Maybe AnException
    -- ^ the exception thrown, if any
  , Result -> Bool
abort              :: Bool
    -- ^ if True, the test should not be repeated
  , Result -> Maybe Int
maybeNumTests      :: Maybe Int
    -- ^ stop after this many tests
  , Result -> Maybe Confidence
maybeCheckCoverage :: Maybe Confidence
    -- ^ required coverage confidence
  , Result -> [String]
labels             :: [String]
    -- ^ test case labels
  , Result -> [String]
classes            :: [String]
    -- ^ test case classes
  , Result -> [(String, String)]
tables             :: [(String, String)]
    -- ^ test case tables
  , Result -> [(Maybe String, String, Double)]
requiredCoverage   :: [(Maybe String, String, Double)]
    -- ^ required coverage
  , Result -> [Callback]
callbacks          :: [Callback]
    -- ^ the callbacks for this test case
  , Result -> [String]
testCase           :: [String]
    -- ^ the generated test case
  }

exception :: String -> AnException -> Result
exception :: String -> AnException -> Result
exception String
msg AnException
err
  | AnException -> Bool
isDiscard AnException
err = Result
rejected
  | Bool
otherwise = Result
failed{ reason :: String
reason = String -> AnException -> String
formatException String
msg AnException
err,
                        theException :: Maybe AnException
theException = AnException -> Maybe AnException
forall a. a -> Maybe a
Just AnException
err }

formatException :: String -> AnException -> String
formatException :: String -> AnException -> String
formatException String
msg AnException
err = String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
format (AnException -> String
forall a. Show a => a -> String
show AnException
err)
  where format :: String -> String
format String
xs | String -> Bool
isOneLine String
xs = String
" '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
xs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
                  | Bool
otherwise = String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines [ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l | String
l <- String -> [String]
lines String
xs ]

protectResult :: IO Result -> IO Result
protectResult :: IO Result -> IO Result
protectResult = (AnException -> Result) -> IO Result -> IO Result
forall a. (AnException -> a) -> IO a -> IO a
protect (String -> AnException -> Result
exception String
"Exception")

succeeded, failed, rejected :: Result
(Result
succeeded, Result
failed, Result
rejected) =
  (Result
result{ ok :: Maybe Bool
ok = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True },
   Result
result{ ok :: Maybe Bool
ok = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False },
   Result
result{ ok :: Maybe Bool
ok = Maybe Bool
forall a. Maybe a
Nothing })
  where
    result :: Result
result =
      MkResult :: Maybe Bool
-> Bool
-> String
-> Maybe AnException
-> Bool
-> Maybe Int
-> Maybe Confidence
-> [String]
-> [String]
-> [(String, String)]
-> [(Maybe String, String, Double)]
-> [Callback]
-> [String]
-> Result
MkResult
      { ok :: Maybe Bool
ok                 = Maybe Bool
forall a. HasCallStack => a
undefined
      , expect :: Bool
expect             = Bool
True
      , reason :: String
reason             = String
""
      , theException :: Maybe AnException
theException       = Maybe AnException
forall a. Maybe a
Nothing
      , abort :: Bool
abort              = Bool
True
      , maybeNumTests :: Maybe Int
maybeNumTests      = Maybe Int
forall a. Maybe a
Nothing
      , maybeCheckCoverage :: Maybe Confidence
maybeCheckCoverage = Maybe Confidence
forall a. Maybe a
Nothing
      , labels :: [String]
labels             = []
      , classes :: [String]
classes            = []
      , tables :: [(String, String)]
tables             = []
      , requiredCoverage :: [(Maybe String, String, Double)]
requiredCoverage   = []
      , callbacks :: [Callback]
callbacks          = []
      , testCase :: [String]
testCase           = []
      }

--------------------------------------------------------------------------
-- ** Lifting and mapping functions

liftBool :: Bool -> Result
liftBool :: Bool -> Result
liftBool Bool
True = Result
succeeded
liftBool Bool
False = Result
failed { reason :: String
reason = String
"Falsified" }

mapResult :: Testable prop => (Result -> Result) -> prop -> Property
mapResult :: (Result -> Result) -> prop -> Property
mapResult Result -> Result
f = (Rose Result -> Rose Result) -> prop -> Property
forall prop.
Testable prop =>
(Rose Result -> Rose Result) -> prop -> Property
mapRoseResult (Rose Result -> Rose Result
protectResults (Rose Result -> Rose Result)
-> (Rose Result -> Rose Result) -> Rose Result -> Rose Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Result -> Result) -> Rose Result -> Rose Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result -> Result
f)

mapTotalResult :: Testable prop => (Result -> Result) -> prop -> Property
mapTotalResult :: (Result -> Result) -> prop -> Property
mapTotalResult Result -> Result
f = (Rose Result -> Rose Result) -> prop -> Property
forall prop.
Testable prop =>
(Rose Result -> Rose Result) -> prop -> Property
mapRoseResult ((Result -> Result) -> Rose Result -> Rose Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result -> Result
f)

-- f here mustn't throw an exception (rose tree invariant).
mapRoseResult :: Testable prop => (Rose Result -> Rose Result) -> prop -> Property
mapRoseResult :: (Rose Result -> Rose Result) -> prop -> Property
mapRoseResult Rose Result -> Rose Result
f = (Prop -> Prop) -> prop -> Property
forall prop. Testable prop => (Prop -> Prop) -> prop -> Property
mapProp (\(MkProp Rose Result
t) -> Rose Result -> Prop
MkProp (Rose Result -> Rose Result
f Rose Result
t))

mapProp :: Testable prop => (Prop -> Prop) -> prop -> Property
mapProp :: (Prop -> Prop) -> prop -> Property
mapProp Prop -> Prop
f = Gen Prop -> Property
MkProperty (Gen Prop -> Property) -> (prop -> Gen Prop) -> prop -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Prop -> Prop) -> Gen Prop -> Gen Prop
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Prop -> Prop
f (Gen Prop -> Gen Prop) -> (prop -> Gen Prop) -> prop -> Gen Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Gen Prop
unProperty (Property -> Gen Prop) -> (prop -> Property) -> prop -> Gen Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. prop -> Property
forall prop. Testable prop => prop -> Property
property

--------------------------------------------------------------------------
-- ** Property combinators

-- | Adjust the test case size for a property, by transforming it with the given
-- function.
mapSize :: Testable prop => (Int -> Int) -> prop -> Property
mapSize :: (Int -> Int) -> prop -> Property
mapSize Int -> Int
f = Gen Prop -> Property
forall prop. Testable prop => prop -> Property
property (Gen Prop -> Property) -> (prop -> Gen Prop) -> prop -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int) -> Gen Prop -> Gen Prop
forall a. (Int -> Int) -> Gen a -> Gen a
scale Int -> Int
f (Gen Prop -> Gen Prop) -> (prop -> Gen Prop) -> prop -> Gen Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Gen Prop
unProperty (Property -> Gen Prop) -> (prop -> Property) -> prop -> Gen Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. prop -> Property
forall prop. Testable prop => prop -> Property
property

-- | Shrinks the argument to a property if it fails. Shrinking is done
-- automatically for most types. This function is only needed when you want to
-- override the default behavior.
shrinking :: Testable prop =>
             (a -> [a])  -- ^ 'shrink'-like function.
          -> a           -- ^ The original argument
          -> (a -> prop) -> Property
shrinking :: (a -> [a]) -> a -> (a -> prop) -> Property
shrinking a -> [a]
shrinker a
x0 a -> prop
pf = Gen Prop -> Property
MkProperty ((Rose Prop -> Prop) -> Gen (Rose Prop) -> Gen Prop
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rose Result -> Prop
MkProp (Rose Result -> Prop)
-> (Rose Prop -> Rose Result) -> Rose Prop -> Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rose (Rose Result) -> Rose Result
forall a. Rose (Rose a) -> Rose a
joinRose (Rose (Rose Result) -> Rose Result)
-> (Rose Prop -> Rose (Rose Result)) -> Rose Prop -> Rose Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Prop -> Rose Result) -> Rose Prop -> Rose (Rose Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Prop -> Rose Result
unProp) (Rose (Gen Prop) -> Gen (Rose Prop)
forall (m :: * -> *) a. Monad m => m (Gen a) -> Gen (m a)
promote (a -> Rose (Gen Prop)
props a
x0)))
 where
  props :: a -> Rose (Gen Prop)
props a
x =
    Gen Prop -> [Rose (Gen Prop)] -> Rose (Gen Prop)
forall a. a -> [Rose a] -> Rose a
MkRose (Property -> Gen Prop
unProperty (prop -> Property
forall prop. Testable prop => prop -> Property
property (a -> prop
pf a
x))) [ a -> Rose (Gen Prop)
props a
x' | a
x' <- a -> [a]
shrinker a
x ]

-- | Disables shrinking for a property altogether.
-- Only quantification /inside/ the call to 'noShrinking' is affected.
noShrinking :: Testable prop => prop -> Property
noShrinking :: prop -> Property
noShrinking = (Rose Result -> Rose Result) -> prop -> Property
forall prop.
Testable prop =>
(Rose Result -> Rose Result) -> prop -> Property
mapRoseResult ((Result -> [Rose Result] -> Rose Result)
-> Rose Result -> Rose Result
forall a. (a -> [Rose a] -> Rose a) -> Rose a -> Rose a
onRose (\Result
res [Rose Result]
_ -> Result -> [Rose Result] -> Rose Result
forall a. a -> [Rose a] -> Rose a
MkRose Result
res []))

-- | Adds a callback
callback :: Testable prop => Callback -> prop -> Property
callback :: Callback -> prop -> Property
callback Callback
cb = (Result -> Result) -> prop -> Property
forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult (\Result
res -> Result
res{ callbacks :: [Callback]
callbacks = Callback
cb Callback -> [Callback] -> [Callback]
forall a. a -> [a] -> [a]
: Result -> [Callback]
callbacks Result
res })

-- | Adds the given string to the counterexample if the property fails.
counterexample :: Testable prop => String -> prop -> Property
counterexample :: String -> prop -> Property
counterexample String
s =
  (Result -> Result) -> Property -> Property
forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult (\Result
res -> Result
res{ testCase :: [String]
testCase = String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:Result -> [String]
testCase Result
res }) (Property -> Property) -> (prop -> Property) -> prop -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Callback -> prop -> Property
forall prop. Testable prop => Callback -> prop -> Property
callback (CallbackKind -> (State -> Result -> IO ()) -> Callback
PostFinalFailure CallbackKind
Counterexample ((State -> Result -> IO ()) -> Callback)
-> (State -> Result -> IO ()) -> Callback
forall a b. (a -> b) -> a -> b
$ \State
st Result
_res -> do
    String
s <- String -> IO String
showCounterexample String
s
    Terminal -> String -> IO ()
putLine (State -> Terminal
terminal State
st) String
s)

showCounterexample :: String -> IO String
showCounterexample :: String -> IO String
showCounterexample String
s = do
  let force :: [a] -> m ()
force [] = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      force (a
x:[a]
xs) = a
x a -> m () -> m ()
`seq` [a] -> m ()
force [a]
xs
  Either AnException ()
res <- IO () -> IO (Either AnException ())
forall a. IO a -> IO (Either AnException a)
tryEvaluateIO (String -> IO ()
forall (m :: * -> *) a. Monad m => [a] -> m ()
force String
s)
  String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$
    case Either AnException ()
res of
      Left AnException
err ->
        String -> AnException -> String
formatException String
"Exception thrown while showing test case" AnException
err
      Right () ->
        String
s

-- | Adds the given string to the counterexample if the property fails.
{-# DEPRECATED printTestCase "Use counterexample instead" #-}
printTestCase :: Testable prop => String -> prop -> Property
printTestCase :: String -> prop -> Property
printTestCase = String -> prop -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample

-- | Performs an 'IO' action after the last failure of a property.
whenFail :: Testable prop => IO () -> prop -> Property
whenFail :: IO () -> prop -> Property
whenFail IO ()
m =
  Callback -> prop -> Property
forall prop. Testable prop => Callback -> prop -> Property
callback (Callback -> prop -> Property) -> Callback -> prop -> Property
forall a b. (a -> b) -> a -> b
$ CallbackKind -> (State -> Result -> IO ()) -> Callback
PostFinalFailure CallbackKind
NotCounterexample ((State -> Result -> IO ()) -> Callback)
-> (State -> Result -> IO ()) -> Callback
forall a b. (a -> b) -> a -> b
$ \State
_st Result
_res ->
    IO ()
m

-- | Performs an 'IO' action every time a property fails. Thus,
-- if shrinking is done, this can be used to keep track of the
-- failures along the way.
whenFail' :: Testable prop => IO () -> prop -> Property
whenFail' :: IO () -> prop -> Property
whenFail' IO ()
m =
  Callback -> prop -> Property
forall prop. Testable prop => Callback -> prop -> Property
callback (Callback -> prop -> Property) -> Callback -> prop -> Property
forall a b. (a -> b) -> a -> b
$ CallbackKind -> (State -> Result -> IO ()) -> Callback
PostTest CallbackKind
NotCounterexample ((State -> Result -> IO ()) -> Callback)
-> (State -> Result -> IO ()) -> Callback
forall a b. (a -> b) -> a -> b
$ \State
_st Result
res ->
    if Result -> Maybe Bool
ok Result
res Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
      then IO ()
m
      else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Prints out the generated test case every time the property is tested.
-- Only variables quantified over /inside/ the 'verbose' are printed.
--
-- Note: for technical reasons, the test case is printed out /after/
-- the property is tested. To debug a property that goes into an
-- infinite loop, use 'within' to add a timeout instead.
verbose :: Testable prop => prop -> Property
verbose :: prop -> Property
verbose = (Result -> Result) -> prop -> Property
forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapResult (\Result
res -> Result
res { callbacks :: [Callback]
callbacks = [Callback] -> Callback
newCallback (Result -> [Callback]
callbacks Result
res)Callback -> [Callback] -> [Callback]
forall a. a -> [a] -> [a]
:Result -> [Callback]
callbacks Result
res })
  where newCallback :: [Callback] -> Callback
newCallback [Callback]
cbs =
          CallbackKind -> (State -> Result -> IO ()) -> Callback
PostTest CallbackKind
Counterexample ((State -> Result -> IO ()) -> Callback)
-> (State -> Result -> IO ()) -> Callback
forall a b. (a -> b) -> a -> b
$ \State
st Result
res -> do
            Terminal -> String -> IO ()
putLine (State -> Terminal
terminal State
st) (Result -> String
status Result
res String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":")
            [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ State -> Result -> IO ()
f State
st Result
res | PostFinalFailure CallbackKind
Counterexample State -> Result -> IO ()
f <- [Callback]
cbs ]
            Terminal -> String -> IO ()
putLine (State -> Terminal
terminal State
st) String
""
        status :: Result -> String
status MkResult{ok :: Result -> Maybe Bool
ok = Just Bool
True} = String
"Passed"
        status MkResult{ok :: Result -> Maybe Bool
ok = Just Bool
False} = String
"Failed"
        status MkResult{ok :: Result -> Maybe Bool
ok = Maybe Bool
Nothing} = String
"Skipped (precondition false)"

-- | Prints out the generated test case every time the property fails, including during shrinking.
-- Only variables quantified over /inside/ the 'verboseShrinking' are printed.
--
-- Note: for technical reasons, the test case is printed out /after/
-- the property is tested. To debug a property that goes into an
-- infinite loop, use 'within' to add a timeout instead.
verboseShrinking :: Testable prop => prop -> Property
verboseShrinking :: prop -> Property
verboseShrinking = (Result -> Result) -> prop -> Property
forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapResult (\Result
res -> Result
res { callbacks :: [Callback]
callbacks = [Callback] -> Callback
newCallback (Result -> [Callback]
callbacks Result
res)Callback -> [Callback] -> [Callback]
forall a. a -> [a] -> [a]
:Result -> [Callback]
callbacks Result
res })
  where newCallback :: [Callback] -> Callback
newCallback [Callback]
cbs =
          CallbackKind -> (State -> Result -> IO ()) -> Callback
PostTest CallbackKind
Counterexample ((State -> Result -> IO ()) -> Callback)
-> (State -> Result -> IO ()) -> Callback
forall a b. (a -> b) -> a -> b
$ \State
st Result
res ->
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Result -> Maybe Bool
ok Result
res Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              Terminal -> String -> IO ()
putLine (State -> Terminal
terminal State
st) String
"Failed:"
              [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ State -> Result -> IO ()
f State
st Result
res | PostFinalFailure CallbackKind
Counterexample State -> Result -> IO ()
f <- [Callback]
cbs ]
              Terminal -> String -> IO ()
putLine (State -> Terminal
terminal State
st) String
""

-- | Indicates that a property is supposed to fail.
-- QuickCheck will report an error if it does not fail.
expectFailure :: Testable prop => prop -> Property
expectFailure :: prop -> Property
expectFailure = (Result -> Result) -> prop -> Property
forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult (\Result
res -> Result
res{ expect :: Bool
expect = Bool
False })

-- | Modifies a property so that it only will be tested once.
-- Opposite of 'again'.
once :: Testable prop => prop -> Property
once :: prop -> Property
once = (Result -> Result) -> prop -> Property
forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult (\Result
res -> Result
res{ abort :: Bool
abort = Bool
True })

-- | Modifies a property so that it will be tested repeatedly.
-- Opposite of 'once'.
again :: Testable prop => prop -> Property
again :: prop -> Property
again = (Result -> Result) -> prop -> Property
forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult (\Result
res -> Result
res{ abort :: Bool
abort = Bool
False })

-- | Configures how many times a property will be tested.
--
-- For example,
--
-- > quickCheck (withMaxSuccess 1000 p)
--
-- will test @p@ up to 1000 times.
withMaxSuccess :: Testable prop => Int -> prop -> Property
withMaxSuccess :: Int -> prop -> Property
withMaxSuccess Int
n = Int
n Int -> (prop -> Property) -> prop -> Property
`seq` (Result -> Result) -> prop -> Property
forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult (\Result
res -> Result
res{ maybeNumTests :: Maybe Int
maybeNumTests = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n })

-- | Check that all coverage requirements defined by 'cover' and 'coverTable'
-- are met, using a statistically sound test, and fail if they are not met.
--
-- Ordinarily, a failed coverage check does not cause the property to fail.
-- This is because the coverage requirement is not tested in a statistically
-- sound way. If you use 'cover' to express that a certain value must appear 20%
-- of the time, QuickCheck will warn you if the value only appears in 19 out of
-- 100 test cases - but since the coverage varies randomly, you may have just
-- been unlucky, and there may not be any real problem with your test
-- generation.
--
-- When you use 'checkCoverage', QuickCheck uses a statistical test to account
-- for the role of luck in coverage failures. It will run as many tests as
-- needed until it is sure about whether the coverage requirements are met. If a
-- coverage requirement is not met, the property fails.
--
-- Example:
--
-- > quickCheck (checkCoverage prop_foo)
checkCoverage :: Testable prop => prop -> Property
checkCoverage :: prop -> Property
checkCoverage = Confidence -> prop -> Property
forall prop. Testable prop => Confidence -> prop -> Property
checkCoverageWith Confidence
stdConfidence

-- | Check coverage requirements using a custom confidence level.
-- See 'stdConfidence'.
--
-- An example of making the statistical test less stringent in order to improve
-- performance:
--
-- > quickCheck (checkCoverageWith stdConfidence{certainty = 10^6} prop_foo)
checkCoverageWith :: Testable prop => Confidence -> prop -> Property
checkCoverageWith :: Confidence -> prop -> Property
checkCoverageWith Confidence
confidence =
  Confidence -> Integer
certainty Confidence
confidence Integer -> (prop -> Property) -> prop -> Property
`seq`
  Confidence -> Double
tolerance Confidence
confidence Double -> (prop -> Property) -> prop -> Property
`seq`
  (Result -> Result) -> prop -> Property
forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult (\Result
res -> Result
res{ maybeCheckCoverage :: Maybe Confidence
maybeCheckCoverage = Confidence -> Maybe Confidence
forall a. a -> Maybe a
Just Confidence
confidence })

-- | The standard parameters used by 'checkCoverage': @certainty = 10^9@,
-- @tolerance = 0.9@. See 'Confidence' for the meaning of the parameters.
stdConfidence :: Confidence
stdConfidence :: Confidence
stdConfidence =
  Confidence :: Integer -> Double -> Confidence
Confidence {
    certainty :: Integer
certainty = Integer
10Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
9,
    tolerance :: Double
tolerance = Double
0.9 }

-- | Attaches a label to a test case. This is used for reporting
-- test case distribution.
--
-- For example:
--
-- > prop_reverse_reverse :: [Int] -> Property
-- > prop_reverse_reverse xs =
-- >   label ("length of input is " ++ show (length xs)) $
-- >     reverse (reverse xs) === xs
--
-- >>> quickCheck prop_reverse_reverse
-- +++ OK, passed 100 tests:
-- 7% length of input is 7
-- 6% length of input is 3
-- 5% length of input is 4
-- 4% length of input is 6
-- ...
--
-- Each use of 'label' in your property results in a separate
-- table of test case distribution in the output. If this is
-- not what you want, use 'tabulate'.
label :: Testable prop => String -> prop -> Property
label :: String -> prop -> Property
label String
s =
#ifndef NO_DEEPSEQ
  String
s String
-> ((Result -> Result) -> prop -> Property)
-> (Result -> Result)
-> prop
-> Property
forall a b. NFData a => a -> b -> b
`deepseq`
#endif
  (Result -> Result) -> prop -> Property
forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult ((Result -> Result) -> prop -> Property)
-> (Result -> Result) -> prop -> Property
forall a b. (a -> b) -> a -> b
$
    \Result
res -> Result
res { labels :: [String]
labels = String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:Result -> [String]
labels Result
res }

-- | Attaches a label to a test case. This is used for reporting
-- test case distribution.
--
-- > collect x = label (show x)
--
-- For example:
--
-- > prop_reverse_reverse :: [Int] -> Property
-- > prop_reverse_reverse xs =
-- >   collect (length xs) $
-- >     reverse (reverse xs) === xs
--
-- >>> quickCheck prop_reverse_reverse
-- +++ OK, passed 100 tests:
-- 7% 7
-- 6% 3
-- 5% 4
-- 4% 6
-- ...
--
-- Each use of 'collect' in your property results in a separate
-- table of test case distribution in the output. If this is
-- not what you want, use 'tabulate'.
collect :: (Show a, Testable prop) => a -> prop -> Property
collect :: a -> prop -> Property
collect a
x = String -> prop -> Property
forall prop. Testable prop => String -> prop -> Property
label (a -> String
forall a. Show a => a -> String
show a
x)

-- | Reports how many test cases satisfy a given condition.
--
-- For example:
--
-- > prop_sorted_sort :: [Int] -> Property
-- > prop_sorted_sort xs =
-- >   sorted xs ==>
-- >   classify (length xs > 1) "non-trivial" $
-- >   sort xs === xs
--
-- >>> quickCheck prop_sorted_sort
-- +++ OK, passed 100 tests (22% non-trivial).
classify :: Testable prop =>
            Bool    -- ^ @True@ if the test case should be labelled.
         -> String  -- ^ Label.
         -> prop -> Property
classify :: Bool -> String -> prop -> Property
classify Bool
False String
_ = prop -> Property
forall prop. Testable prop => prop -> Property
property
classify Bool
True String
s =
#ifndef NO_DEEPSEQ
  String
s String
-> ((Result -> Result) -> prop -> Property)
-> (Result -> Result)
-> prop
-> Property
forall a b. NFData a => a -> b -> b
`deepseq`
#endif
  (Result -> Result) -> prop -> Property
forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult ((Result -> Result) -> prop -> Property)
-> (Result -> Result) -> prop -> Property
forall a b. (a -> b) -> a -> b
$
    \Result
res -> Result
res { classes :: [String]
classes = String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:Result -> [String]
classes Result
res }

-- | Checks that at least the given proportion of /successful/ test
-- cases belong to the given class. Discarded tests (i.e. ones
-- with a false precondition) do not affect coverage.
--
-- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but
-- the property does /not/ fail. To make the property fail, use 'checkCoverage'.
--
-- For example:
--
-- > prop_sorted_sort :: [Int] -> Property
-- > prop_sorted_sort xs =
-- >   sorted xs ==>
-- >   cover 50 (length xs > 1) "non-trivial" $
-- >   sort xs === xs
--
-- >>> quickCheck prop_sorted_sort
-- +++ OK, passed 100 tests; 135 discarded (26% non-trivial).
-- <BLANKLINE>
-- Only 26% non-trivial, but expected 50%
cover :: Testable prop =>
         Double -- ^ The required percentage (0-100) of test cases.
      -> Bool   -- ^ @True@ if the test case belongs to the class.
      -> String -- ^ Label for the test case class.
      -> prop -> Property
cover :: Double -> Bool -> String -> prop -> Property
cover Double
p Bool
x String
s = (Result -> Result) -> Property -> Property
forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult Result -> Result
f (Property -> Property) -> (prop -> Property) -> prop -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String -> prop -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify Bool
x String
s
  where
    f :: Result -> Result
f Result
res = Result
res { requiredCoverage :: [(Maybe String, String, Double)]
requiredCoverage = (Maybe String
forall a. Maybe a
Nothing, String
s, Double
pDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
100)(Maybe String, String, Double)
-> [(Maybe String, String, Double)]
-> [(Maybe String, String, Double)]
forall a. a -> [a] -> [a]
:Result -> [(Maybe String, String, Double)]
requiredCoverage Result
res }

-- | Collects information about test case distribution into a table.
-- The arguments to 'tabulate' are the table's name and a list of values
-- associated with the current test case. After testing, QuickCheck prints the
-- frequency of all collected values. The frequencies are expressed as a
-- percentage of the total number of values collected.
--
-- You should prefer 'tabulate' to 'label' when each test case is associated
-- with a varying number of values. Here is a (not terribly useful) example,
-- where the test data is a list of integers and we record all values that
-- occur in the list:
--
-- > prop_sorted_sort :: [Int] -> Property
-- > prop_sorted_sort xs =
-- >   sorted xs ==>
-- >   tabulate "List elements" (map show xs) $
-- >   sort xs === xs
--
-- >>> quickCheck prop_sorted_sort
-- +++ OK, passed 100 tests; 1684 discarded.
-- <BLANKLINE>
-- List elements (109 in total):
--  3.7% 0
--  3.7% 17
--  3.7% 2
--  3.7% 6
--  2.8% -6
--  2.8% -7
--
-- Here is a more useful example. We are testing a chatroom, where the user can
-- log in, log out, or send a message:
--
-- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show)
-- > instance Arbitrary Command where ...
--
-- There are some restrictions on command sequences; for example, the user must
-- log in before doing anything else. The function @valid :: [Command] -> Bool@
-- checks that a command sequence is allowed. Our property then has the form:
--
-- > prop_chatroom :: [Command] -> Property
-- > prop_chatroom cmds =
-- >   valid cmds ==>
-- >     ...
--
-- The use of '==>' may skew test case distribution. We use 'collect' to see the
-- length of the command sequences, and 'tabulate' to get the frequencies of the
-- individual commands:
--
-- > prop_chatroom :: [Command] -> Property
-- > prop_chatroom cmds =
-- >   wellFormed cmds LoggedOut ==>
-- >   'collect' (length cmds) $
-- >   'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $
-- >     ...
--
-- >>> quickCheckWith stdArgs{maxDiscardRatio = 1000} prop_chatroom
-- +++ OK, passed 100 tests; 2775 discarded:
-- 60% 0
-- 20% 1
-- 15% 2
--  3% 3
--  1% 4
--  1% 5
-- <BLANKLINE>
-- Commands (68 in total):
-- 62% LogIn
-- 22% SendMessage
-- 16% LogOut
tabulate :: Testable prop => String -> [String] -> prop -> Property
tabulate :: String -> [String] -> prop -> Property
tabulate String
key [String]
values =
#ifndef NO_DEEPSEQ
  String
key String -> [String] -> [String]
forall a b. NFData a => a -> b -> b
`deepseq` [String]
values [String]
-> ((Result -> Result) -> prop -> Property)
-> (Result -> Result)
-> prop
-> Property
forall a b. NFData a => a -> b -> b
`deepseq`
#endif
  (Result -> Result) -> prop -> Property
forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult ((Result -> Result) -> prop -> Property)
-> (Result -> Result) -> prop -> Property
forall a b. (a -> b) -> a -> b
$
    \Result
res -> Result
res { tables :: [(String, String)]
tables = [(String
key, String
value) | String
value <- [String]
values] [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ Result -> [(String, String)]
tables Result
res }

-- | Checks that the values in a given 'table' appear a certain proportion of
-- the time. A call to 'coverTable' @table@ @[(x1, p1), ..., (xn, pn)]@ asserts
-- that of the values in @table@, @x1@ should appear at least @p1@ percent of
-- the time, @x2@ at least @p2@ percent of the time, and so on.
--
-- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but
-- the property does /not/ fail. To make the property fail, use 'checkCoverage'.
--
-- Continuing the example from the 'tabular' combinator...
--
-- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show)
-- > prop_chatroom :: [Command] -> Property
-- > prop_chatroom cmds =
-- >   wellFormed cmds LoggedOut ==>
-- >   'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $
-- >     ...
--
-- ...we can add a coverage requirement as follows, which checks that @LogIn@,
-- @LogOut@ and @SendMessage@ each occur at least 25% of the time:
--
-- > prop_chatroom :: [Command] -> Property
-- > prop_chatroom cmds =
-- >   wellFormed cmds LoggedOut ==>
-- >   coverTable "Commands" [("LogIn", 25), ("LogOut", 25), ("SendMessage", 25)] $
-- >   'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $
-- >     ... property goes here ...
--
-- >>> quickCheck prop_chatroom
-- +++ OK, passed 100 tests; 2909 discarded:
-- 56% 0
-- 17% 1
-- 10% 2
--  6% 3
--  5% 4
--  3% 5
--  3% 7
-- <BLANKLINE>
-- Commands (111 in total):
-- 51.4% LogIn
-- 30.6% SendMessage
-- 18.0% LogOut
-- <BLANKLINE>
-- Table 'Commands' had only 18.0% LogOut, but expected 25.0%
coverTable :: Testable prop =>
  String -> [(String, Double)] -> prop -> Property
coverTable :: String -> [(String, Double)] -> prop -> Property
coverTable String
table [(String, Double)]
xs =
#ifndef NO_DEEPSEQ
  String
table String -> [(String, Double)] -> [(String, Double)]
forall a b. NFData a => a -> b -> b
`deepseq` [(String, Double)]
xs [(String, Double)]
-> ((Result -> Result) -> prop -> Property)
-> (Result -> Result)
-> prop
-> Property
forall a b. NFData a => a -> b -> b
`deepseq`
#endif
  (Result -> Result) -> prop -> Property
forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult ((Result -> Result) -> prop -> Property)
-> (Result -> Result) -> prop -> Property
forall a b. (a -> b) -> a -> b
$
    \Result
res -> Result
res { requiredCoverage :: [(Maybe String, String, Double)]
requiredCoverage = [(Maybe String, String, Double)]
ys [(Maybe String, String, Double)]
-> [(Maybe String, String, Double)]
-> [(Maybe String, String, Double)]
forall a. [a] -> [a] -> [a]
++ Result -> [(Maybe String, String, Double)]
requiredCoverage Result
res }
  where
    ys :: [(Maybe String, String, Double)]
ys = [(String -> Maybe String
forall a. a -> Maybe a
Just String
table, String
x, Double
pDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
100) | (String
x, Double
p) <- [(String, Double)]
xs]

-- | Implication for properties: The resulting property holds if
-- the first argument is 'False' (in which case the test case is discarded),
-- or if the given property holds. Note that using implication carelessly can
-- severely skew test case distribution: consider using 'cover' to make sure
-- that your test data is still good quality.
(==>) :: Testable prop => Bool -> prop -> Property
Bool
False ==> :: Bool -> prop -> Property
==> prop
_ = Discard -> Property
forall prop. Testable prop => prop -> Property
property Discard
Discard
Bool
True  ==> prop
p = prop -> Property
forall prop. Testable prop => prop -> Property
property prop
p

-- | Considers a property failed if it does not complete within
-- the given number of microseconds.
--
-- Note: if the property times out, variables quantified inside the
-- `within` will not be printed. Therefore, you should use `within`
-- only in the body of your property.
--
-- Good: @prop_foo a b c = within 1000000 ...@
--
-- Bad: @prop_foo = within 1000000 $ \\a b c -> ...@
--
-- Bad: @prop_foo a b c = ...; main = quickCheck (within 1000000 prop_foo)@
within :: Testable prop => Int -> prop -> Property
within :: Int -> prop -> Property
within Int
n = (Rose Result -> Rose Result) -> prop -> Property
forall prop.
Testable prop =>
(Rose Result -> Rose Result) -> prop -> Property
mapRoseResult Rose Result -> Rose Result
f
  where
    f :: Rose Result -> Rose Result
f Rose Result
rose = IO (Rose Result) -> Rose Result
ioRose (IO (Rose Result) -> Rose Result)
-> IO (Rose Result) -> Rose Result
forall a b. (a -> b) -> a -> b
$ do
      let f (Maybe b)
m orError :: f (Maybe b) -> b -> f b
`orError` b
x = (Maybe b -> b) -> f (Maybe b) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> Maybe b -> b
forall a. a -> Maybe a -> a
fromMaybe b
x) f (Maybe b)
m
      MkRose Result
res [Rose Result]
roses <- Int -> IO (Rose Result) -> IO (Maybe (Rose Result))
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
n (Rose Result -> IO (Rose Result)
reduceRose Rose Result
rose) IO (Maybe (Rose Result)) -> Rose Result -> IO (Rose Result)
forall (f :: * -> *) b. Functor f => f (Maybe b) -> b -> f b
`orError`
        Result -> Rose Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
timeoutResult
      Result
res' <- Int -> IO Result -> IO (Maybe Result)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
n (IO Result -> IO Result
protectResult (Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
res)) IO (Maybe Result) -> Result -> IO Result
forall (f :: * -> *) b. Functor f => f (Maybe b) -> b -> f b
`orError`
        Result
timeoutResult
      Rose Result -> IO (Rose Result)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> [Rose Result] -> Rose Result
forall a. a -> [Rose a] -> Rose a
MkRose Result
res' ((Rose Result -> Rose Result) -> [Rose Result] -> [Rose Result]
forall a b. (a -> b) -> [a] -> [b]
map Rose Result -> Rose Result
f [Rose Result]
roses))

    timeoutResult :: Result
timeoutResult = Result
failed { reason :: String
reason = String
"Timeout of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" microseconds exceeded." }
#ifdef NO_TIMEOUT
    timeout _ = fmap Just
#endif

-- | Explicit universal quantification: uses an explicitly given
-- test case generator.
forAll :: (Show a, Testable prop)
       => Gen a -> (a -> prop) -> Property
forAll :: Gen a -> (a -> prop) -> Property
forAll Gen a
gen a -> prop
pf = Gen a -> (a -> [a]) -> (a -> prop) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen a
gen (\a
_ -> []) a -> prop
pf

-- | Like 'forAll', but with an explicitly given show function.
forAllShow :: Testable prop
           => Gen a -> (a -> String) -> (a -> prop) -> Property
forAllShow :: Gen a -> (a -> String) -> (a -> prop) -> Property
forAllShow Gen a
gen a -> String
shower a -> prop
pf = Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property
forAllShrinkShow Gen a
gen (\a
_ -> []) a -> String
shower a -> prop
pf

-- | Like 'forAll', but without printing the generated value.
forAllBlind :: Testable prop
           => Gen a -> (a -> prop) -> Property
forAllBlind :: Gen a -> (a -> prop) -> Property
forAllBlind Gen a
gen a -> prop
pf = Gen a -> (a -> [a]) -> (a -> prop) -> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrinkBlind Gen a
gen (\a
_ -> []) a -> prop
pf

-- | Like 'forAll', but tries to shrink the argument for failing test cases.
forAllShrink :: (Show a, Testable prop)
             => Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink :: Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen a
gen a -> [a]
shrinker = Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property
forAllShrinkShow Gen a
gen a -> [a]
shrinker a -> String
forall a. Show a => a -> String
show

-- | Like 'forAllShrink', but with an explicitly given show function.
forAllShrinkShow
  :: Testable prop
  => Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property
forAllShrinkShow :: Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property
forAllShrinkShow Gen a
gen a -> [a]
shrinker a -> String
shower a -> prop
pf =
  Gen a -> (a -> [a]) -> (a -> Property) -> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrinkBlind Gen a
gen a -> [a]
shrinker (\a
x -> String -> prop -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (a -> String
shower a
x) (a -> prop
pf a
x))

-- | Like 'forAllShrink', but without printing the generated value.
forAllShrinkBlind
  :: Testable prop
  => Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrinkBlind :: Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrinkBlind Gen a
gen a -> [a]
shrinker a -> prop
pf =
  Property -> Property
forall prop. Testable prop => prop -> Property
again (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
  Gen Prop -> Property
MkProperty (Gen Prop -> Property) -> Gen Prop -> Property
forall a b. (a -> b) -> a -> b
$
  Gen a
gen Gen a -> (a -> Gen Prop) -> Gen Prop
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x ->
    Property -> Gen Prop
unProperty (Property -> Gen Prop) -> Property -> Gen Prop
forall a b. (a -> b) -> a -> b
$
    (a -> [a]) -> a -> (a -> prop) -> Property
forall prop a.
Testable prop =>
(a -> [a]) -> a -> (a -> prop) -> Property
shrinking a -> [a]
shrinker a
x a -> prop
pf

-- | Nondeterministic choice: 'p1' '.&.' 'p2' picks randomly one of
-- 'p1' and 'p2' to test. If you test the property 100 times it
-- makes 100 random choices.
(.&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property
prop1
p1 .&. :: prop1 -> prop2 -> Property
.&. prop2
p2 =
  Property -> Property
forall prop. Testable prop => prop -> Property
again (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
  Gen Prop -> Property
MkProperty (Gen Prop -> Property) -> Gen Prop -> Property
forall a b. (a -> b) -> a -> b
$
  Gen Bool
forall a. Arbitrary a => Gen a
arbitrary Gen Bool -> (Bool -> Gen Prop) -> Gen Prop
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b ->
    Property -> Gen Prop
unProperty (Property -> Gen Prop) -> Property -> Gen Prop
forall a b. (a -> b) -> a -> b
$
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (if Bool
b then String
"LHS" else String
"RHS") (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      if Bool
b then prop1 -> Property
forall prop. Testable prop => prop -> Property
property prop1
p1 else prop2 -> Property
forall prop. Testable prop => prop -> Property
property prop2
p2

-- | Conjunction: 'p1' '.&&.' 'p2' passes if both 'p1' and 'p2' pass.
(.&&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property
prop1
p1 .&&. :: prop1 -> prop2 -> Property
.&&. prop2
p2 = [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin [prop1 -> Property
forall prop. Testable prop => prop -> Property
property prop1
p1, prop2 -> Property
forall prop. Testable prop => prop -> Property
property prop2
p2]

-- | Take the conjunction of several properties.
conjoin :: Testable prop => [prop] -> Property
conjoin :: [prop] -> Property
conjoin [prop]
ps =
  Property -> Property
forall prop. Testable prop => prop -> Property
again (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
  Gen Prop -> Property
MkProperty (Gen Prop -> Property) -> Gen Prop -> Property
forall a b. (a -> b) -> a -> b
$
  do [Rose Result]
roses <- (prop -> Gen (Rose Result)) -> [prop] -> Gen [Rose Result]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Prop -> Rose Result) -> Gen Prop -> Gen (Rose Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Prop -> Rose Result
unProp (Gen Prop -> Gen (Rose Result))
-> (prop -> Gen Prop) -> prop -> Gen (Rose Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Gen Prop
unProperty (Property -> Gen Prop) -> (prop -> Property) -> prop -> Gen Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. prop -> Property
forall prop. Testable prop => prop -> Property
property) [prop]
ps
     Prop -> Gen Prop
forall (m :: * -> *) a. Monad m => a -> m a
return (Rose Result -> Prop
MkProp ((Result -> Result) -> [Rose Result] -> Rose Result
conj Result -> Result
forall a. a -> a
id [Rose Result]
roses))
 where
  conj :: (Result -> Result) -> [Rose Result] -> Rose Result
conj Result -> Result
k [] =
    Result -> [Rose Result] -> Rose Result
forall a. a -> [Rose a] -> Rose a
MkRose (Result -> Result
k Result
succeeded) []

  conj Result -> Result
k (Rose Result
p : [Rose Result]
ps) = IO (Rose Result) -> Rose Result
forall a. IO (Rose a) -> Rose a
IORose (IO (Rose Result) -> Rose Result)
-> IO (Rose Result) -> Rose Result
forall a b. (a -> b) -> a -> b
$ do
    rose :: Rose Result
rose@(MkRose Result
result [Rose Result]
_) <- Rose Result -> IO (Rose Result)
reduceRose Rose Result
p
    case Result -> Maybe Bool
ok Result
result of
      Maybe Bool
_ | Bool -> Bool
not (Result -> Bool
expect Result
result) ->
        Rose Result -> IO (Rose Result)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> Rose Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
failed { reason :: String
reason = String
"expectFailure may not occur inside a conjunction" })
      Just Bool
True -> Rose Result -> IO (Rose Result)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Result -> Result) -> [Rose Result] -> Rose Result
conj (Result -> Result -> Result
addLabels Result
result (Result -> Result) -> (Result -> Result) -> Result -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Result -> Result
addCallbacksAndCoverage Result
result (Result -> Result) -> (Result -> Result) -> Result -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Result
k) [Rose Result]
ps)
      Just Bool
False -> Rose Result -> IO (Rose Result)
forall (m :: * -> *) a. Monad m => a -> m a
return Rose Result
rose
      Maybe Bool
Nothing -> do
        rose2 :: Rose Result
rose2@(MkRose Result
result2 [Rose Result]
_) <- Rose Result -> IO (Rose Result)
reduceRose ((Result -> Result) -> [Rose Result] -> Rose Result
conj (Result -> Result -> Result
addCallbacksAndCoverage Result
result (Result -> Result) -> (Result -> Result) -> Result -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Result
k) [Rose Result]
ps)
        Rose Result -> IO (Rose Result)
forall (m :: * -> *) a. Monad m => a -> m a
return (Rose Result -> IO (Rose Result))
-> Rose Result -> IO (Rose Result)
forall a b. (a -> b) -> a -> b
$
          -- Nasty work to make sure we use the right callbacks
          case Result -> Maybe Bool
ok Result
result2 of
            Just Bool
True -> Result -> [Rose Result] -> Rose Result
forall a. a -> [Rose a] -> Rose a
MkRose (Result
result2 { ok :: Maybe Bool
ok = Maybe Bool
forall a. Maybe a
Nothing }) []
            Just Bool
False -> Rose Result
rose2
            Maybe Bool
Nothing -> Rose Result
rose2

  addCallbacksAndCoverage :: Result -> Result -> Result
addCallbacksAndCoverage Result
result Result
r =
    Result
r { callbacks :: [Callback]
callbacks = Result -> [Callback]
callbacks Result
result [Callback] -> [Callback] -> [Callback]
forall a. [a] -> [a] -> [a]
++ Result -> [Callback]
callbacks Result
r,
        requiredCoverage :: [(Maybe String, String, Double)]
requiredCoverage = Result -> [(Maybe String, String, Double)]
requiredCoverage Result
result [(Maybe String, String, Double)]
-> [(Maybe String, String, Double)]
-> [(Maybe String, String, Double)]
forall a. [a] -> [a] -> [a]
++ Result -> [(Maybe String, String, Double)]
requiredCoverage Result
r }
  addLabels :: Result -> Result -> Result
addLabels Result
result Result
r =
    Result
r { labels :: [String]
labels = Result -> [String]
labels Result
result [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Result -> [String]
labels Result
r,
        classes :: [String]
classes = Result -> [String]
classes Result
result [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Result -> [String]
classes Result
r,
        tables :: [(String, String)]
tables = Result -> [(String, String)]
tables Result
result [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ Result -> [(String, String)]
tables Result
r }

-- | Disjunction: 'p1' '.||.' 'p2' passes unless 'p1' and 'p2' simultaneously fail.
(.||.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property
prop1
p1 .||. :: prop1 -> prop2 -> Property
.||. prop2
p2 = [Property] -> Property
forall prop. Testable prop => [prop] -> Property
disjoin [prop1 -> Property
forall prop. Testable prop => prop -> Property
property prop1
p1, prop2 -> Property
forall prop. Testable prop => prop -> Property
property prop2
p2]

-- | Take the disjunction of several properties.
disjoin :: Testable prop => [prop] -> Property
disjoin :: [prop] -> Property
disjoin [prop]
ps =
  Property -> Property
forall prop. Testable prop => prop -> Property
again (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
  Gen Prop -> Property
MkProperty (Gen Prop -> Property) -> Gen Prop -> Property
forall a b. (a -> b) -> a -> b
$
  do [Rose Result]
roses <- (prop -> Gen (Rose Result)) -> [prop] -> Gen [Rose Result]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Prop -> Rose Result) -> Gen Prop -> Gen (Rose Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Prop -> Rose Result
unProp (Gen Prop -> Gen (Rose Result))
-> (prop -> Gen Prop) -> prop -> Gen (Rose Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Gen Prop
unProperty (Property -> Gen Prop) -> (prop -> Property) -> prop -> Gen Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. prop -> Property
forall prop. Testable prop => prop -> Property
property) [prop]
ps
     Prop -> Gen Prop
forall (m :: * -> *) a. Monad m => a -> m a
return (Rose Result -> Prop
MkProp ((Rose Result -> Rose Result -> Rose Result)
-> Rose Result -> [Rose Result] -> Rose Result
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Rose Result -> Rose Result -> Rose Result
disj (Result -> [Rose Result] -> Rose Result
forall a. a -> [Rose a] -> Rose a
MkRose Result
failed []) [Rose Result]
roses))
 where
  disj :: Rose Result -> Rose Result -> Rose Result
  disj :: Rose Result -> Rose Result -> Rose Result
disj Rose Result
p Rose Result
q =
    do Result
result1 <- Rose Result
p
       case Result -> Maybe Bool
ok Result
result1 of
         Maybe Bool
_ | Bool -> Bool
not (Result -> Bool
expect Result
result1) -> Result -> Rose Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
expectFailureError
         Just Bool
False -> do
           Result
result2 <- Rose Result
q
           Result -> Rose Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> Rose Result) -> Result -> Rose Result
forall a b. (a -> b) -> a -> b
$
             case Result -> Maybe Bool
ok Result
result2 of
               Maybe Bool
_ | Bool -> Bool
not (Result -> Bool
expect Result
result2) -> Result
expectFailureError
               Just Bool
True -> Result -> Result -> Result
addCoverage Result
result1 Result
result2
               Just Bool
False ->
                 MkResult :: Maybe Bool
-> Bool
-> String
-> Maybe AnException
-> Bool
-> Maybe Int
-> Maybe Confidence
-> [String]
-> [String]
-> [(String, String)]
-> [(Maybe String, String, Double)]
-> [Callback]
-> [String]
-> Result
MkResult {
                   ok :: Maybe Bool
ok = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False,
                   expect :: Bool
expect = Bool
True,
                   reason :: String
reason = String -> String -> String
sep (Result -> String
reason Result
result1) (Result -> String
reason Result
result2),
                   theException :: Maybe AnException
theException = Result -> Maybe AnException
theException Result
result1 Maybe AnException -> Maybe AnException -> Maybe AnException
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Result -> Maybe AnException
theException Result
result2,
                   -- The following few fields are not important because the
                   -- test case has failed anyway
                   abort :: Bool
abort = Bool
False,
                   maybeNumTests :: Maybe Int
maybeNumTests = Maybe Int
forall a. Maybe a
Nothing,
                   maybeCheckCoverage :: Maybe Confidence
maybeCheckCoverage = Maybe Confidence
forall a. Maybe a
Nothing,
                   labels :: [String]
labels = [],
                   classes :: [String]
classes = [],
                   tables :: [(String, String)]
tables = [],
                   requiredCoverage :: [(Maybe String, String, Double)]
requiredCoverage = [],
                   callbacks :: [Callback]
callbacks =
                     Result -> [Callback]
callbacks Result
result1 [Callback] -> [Callback] -> [Callback]
forall a. [a] -> [a] -> [a]
++
                     [CallbackKind -> (State -> Result -> IO ()) -> Callback
PostFinalFailure CallbackKind
Counterexample ((State -> Result -> IO ()) -> Callback)
-> (State -> Result -> IO ()) -> Callback
forall a b. (a -> b) -> a -> b
$ \State
st Result
_res -> Terminal -> String -> IO ()
putLine (State -> Terminal
terminal State
st) String
""] [Callback] -> [Callback] -> [Callback]
forall a. [a] -> [a] -> [a]
++
                     Result -> [Callback]
callbacks Result
result2,
                   testCase :: [String]
testCase =
                     Result -> [String]
testCase Result
result1 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                     Result -> [String]
testCase Result
result2 }
               Maybe Bool
Nothing -> Result
result2
         -- The "obvious" semantics of .||. has:
         --   discard .||. true = true
         --   discard .||. discard = discard
         -- but this implementation gives discard .||. true = discard.
         -- This is reasonable because evaluating result2 in the case
         -- that result1 discards is just busy-work - it won't ever
         -- cause the property to fail. On the other hand, discarding
         -- instead of returning true causes us to execute one more
         -- test case - but assuming that preconditions are cheap to
         -- evaluate, this is no more work than evaluating result2
         -- would be, while (unlike evaluating result2) it might catch
         -- a bug.
         Maybe Bool
_ -> Result -> Rose Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
result1

  expectFailureError :: Result
expectFailureError = Result
failed { reason :: String
reason = String
"expectFailure may not occur inside a disjunction" }
  sep :: String -> String -> String
sep [] String
s = String
s
  sep String
s [] = String
s
  sep String
s String
s' = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s'

  addCoverage :: Result -> Result -> Result
addCoverage Result
result Result
r =
    Result
r { requiredCoverage :: [(Maybe String, String, Double)]
requiredCoverage = Result -> [(Maybe String, String, Double)]
requiredCoverage Result
result [(Maybe String, String, Double)]
-> [(Maybe String, String, Double)]
-> [(Maybe String, String, Double)]
forall a. [a] -> [a] -> [a]
++ Result -> [(Maybe String, String, Double)]
requiredCoverage Result
r }

-- | Like '==', but prints a counterexample when it fails.
infix 4 ===
(===) :: (Eq a, Show a) => a -> a -> Property
a
x === :: a -> a -> Property
=== a
y =
  String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (a -> String
forall a. Show a => a -> String
show a
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
interpret Bool
res String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
y) Bool
res
  where
    res :: Bool
res = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
    interpret :: Bool -> String
interpret Bool
True  = String
" == "
    interpret Bool
False = String
" /= "

-- | Like '/=', but prints a counterexample when it fails.
infix 4 =/=
(=/=) :: (Eq a, Show a) => a -> a -> Property
a
x =/= :: a -> a -> Property
=/= a
y =
  String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (a -> String
forall a. Show a => a -> String
show a
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
interpret Bool
res String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
y) Bool
res
  where
    res :: Bool
res = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
y
    interpret :: Bool -> String
interpret Bool
True  = String
" /= "
    interpret Bool
False = String
" == "

#ifndef NO_DEEPSEQ
-- | Checks that a value is total, i.e., doesn't crash when evaluated.
total :: NFData a => a -> Property
total :: a -> Property
total a
x = () -> Property
forall prop. Testable prop => prop -> Property
property (a -> ()
forall a. NFData a => a -> ()
rnf a
x)
#endif

--------------------------------------------------------------------------
-- the end.