{-# 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 =
    forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrinkBlind Gen a
gen a -> [a]
shr forall a b. (a -> b) -> a -> b
$
      \a
x -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall prop. Testable prop => String -> prop -> Property
counterexample (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
_ = 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 = forall prop. Testable prop => prop -> Property
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 = forall prop. Testable prop => prop -> Property
property forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall prop. Testable prop => Maybe prop -> Property
liftMaybe
    where
      -- See comment for liftUnit above
      liftMaybe :: Maybe prop -> Property
liftMaybe Maybe prop
Nothing = forall prop. Testable prop => prop -> Property
property Discard
Discard
      liftMaybe (Just prop
prop) = forall prop. Testable prop => prop -> Property
property prop
prop

instance Testable Bool where
  property :: Bool -> Property
property = forall prop. Testable prop => prop -> Property
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rose Result -> Prop
MkProp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rose Result -> Rose Result
protectResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return

instance Testable Prop where
  property :: Prop -> Property
property Prop
p = Gen Prop -> Property
MkProperty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prop -> Prop
protectProp 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 forall a b. (a -> b) -> a -> b
$ do prop
p <- Gen prop
mp; Property -> Gen Prop
unProperty (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 (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 :: forall prop. Testable prop => IO prop -> Property
morallyDubiousIOProperty = 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 :: forall prop. Testable prop => IO prop -> Property
ioProperty IO prop
prop = forall prop. Testable prop => IO prop -> Property
idempotentIOProperty (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 :: forall prop. Testable prop => IO prop -> Property
idempotentIOProperty =
  Gen Prop -> Property
MkProperty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rose Result -> Prop
MkProp forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Rose Result) -> Rose Result
ioRose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Prop -> Rose Result
unProp) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (m :: * -> *) a. Monad m => m (Gen a) -> Gen (m a)
promote forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Property -> Gen Prop
unProperty forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
    forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> [String]) -> (a -> prop) -> Property
propertyForAllShrinkShow forall a. Arbitrary a => Gen a
arbitrary forall a. Arbitrary a => a -> [a]
shrink (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) a -> prop
f
  propertyForAllShrinkShow :: forall a.
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
    forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> [String]) -> (a -> prop) -> Property
propertyForAllShrinkShow
      (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) Gen a
gen forall a. Arbitrary a => Gen a
arbitrary)
      (forall (f :: * -> * -> *) a b.
Arbitrary2 f =>
(a -> [a]) -> (b -> [b]) -> f a b -> [f a b]
liftShrink2 a -> [a]
shr forall a. Arbitrary a => a -> [a]
shrink)
      (\(a
x, a
y) -> a -> [String]
shw a
x forall a. [a] -> [a] -> [a]
++ [forall a. Show a => a -> String
show a
y])
      (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 :: forall a. (AnException -> a) -> IO a -> IO a
protect AnException -> a
f IO a
x = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either AnException -> a
f forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` 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 = forall a. IO (Rose a) -> Rose a
IORose forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Rose Result) -> IO (Rose Result)
protectRose

joinRose :: Rose (Rose a) -> Rose a
joinRose :: forall a. Rose (Rose a) -> Rose a
joinRose (IORose IO (Rose (Rose a))
rs) = forall a. IO (Rose a) -> Rose a
IORose (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Rose (Rose a) -> Rose a
joinRose IO (Rose (Rose a))
rs)
joinRose (MkRose (IORose IO (Rose a)
rm) [Rose (Rose a)]
rs) = forall a. IO (Rose a) -> Rose a
IORose forall a b. (a -> b) -> a -> b
$ do Rose a
r <- IO (Rose a)
rm; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Rose (Rose a) -> Rose a
joinRose (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
  forall a. a -> [Rose a] -> Rose a
MkRose a
x (forall a b. (a -> b) -> [a] -> [b]
map forall a. Rose (Rose a) -> Rose a
joinRose [Rose (Rose a)]
tts 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 :: forall a b. (a -> b) -> Rose a -> Rose b
fmap a -> b
f (IORose IO (Rose a)
rs)   = forall a. IO (Rose a) -> Rose a
IORose (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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) = forall a. a -> [Rose a] -> Rose a
MkRose (a -> b
f a
x) [ 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 :: forall a. a -> Rose a
pure a
x = forall a. a -> [Rose a] -> Rose a
MkRose a
x []
  -- f must be total
  <*> :: forall 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 forall a b. (a -> b) -> a -> b
($)

instance Monad Rose where
  return :: forall a. a -> Rose a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  -- k must be total
  Rose a
m >>= :: forall a b. Rose a -> (a -> Rose b) -> Rose b
>>= a -> Rose b
k  = forall a. Rose (Rose a) -> Rose a
joinRose (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]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Rose Result
r
reduceRose (IORose IO (Rose Result)
m) = IO (Rose Result)
m 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 :: forall a. (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) = forall a. IO (Rose a) -> Rose a
IORose (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 = forall a. (AnException -> a) -> IO a -> IO a
protect (forall (m :: * -> *) a. Monad m => a -> m a
return 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 (forall a. IO (Rose a) -> Rose a
IORose forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Rose Result) -> IO (Rose Result)
protectRose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a. (a -> [Rose a] -> Rose a) -> Rose a -> Rose a
onRose forall a b. (a -> b) -> a -> b
$ \Result
x [Rose Result]
rs ->
  forall a. IO (Rose a) -> Rose a
IORose forall a b. (a -> b) -> a -> b
$ do
    Result
y <- IO Result -> IO Result
protectResult (forall (m :: * -> *) a. Monad m => a -> m a
return Result
x)
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> [Rose a] -> Rose a
MkRose Result
y (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 = forall a. a -> Maybe a
Just AnException
err }

formatException :: String -> AnException -> String
formatException :: String -> AnException -> String
formatException String
msg AnException
err = String
msg forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ String -> String
format (forall a. Show a => a -> String
show AnException
err)
  where format :: String -> String
format String
xs | String -> Bool
isOneLine String
xs = String
" '" forall a. [a] -> [a] -> [a]
++ String
xs forall a. [a] -> [a] -> [a]
++ String
"'"
                  | Bool
otherwise = String
"\n" forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines [ 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 = 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 = forall a. a -> Maybe a
Just Bool
True },
   Result
result{ ok :: Maybe Bool
ok = forall a. a -> Maybe a
Just Bool
False },
   Result
result{ ok :: Maybe Bool
ok = forall a. Maybe a
Nothing })
  where
    result :: Result
result =
      MkResult
      { ok :: Maybe Bool
ok                 = forall a. HasCallStack => a
undefined
      , expect :: Bool
expect             = Bool
True
      , reason :: String
reason             = String
""
      , theException :: Maybe AnException
theException       = forall a. Maybe a
Nothing
      , abort :: Bool
abort              = Bool
True
      , maybeNumTests :: Maybe Int
maybeNumTests      = forall a. Maybe a
Nothing
      , maybeCheckCoverage :: Maybe Confidence
maybeCheckCoverage = 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 :: forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapResult Result -> Result
f = forall prop.
Testable prop =>
(Rose Result -> Rose Result) -> prop -> Property
mapRoseResult (Rose Result -> Rose Result
protectResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result -> Result
f)

mapTotalResult :: Testable prop => (Result -> Result) -> prop -> Property
mapTotalResult :: forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult Result -> Result
f = forall prop.
Testable prop =>
(Rose Result -> Rose Result) -> prop -> Property
mapRoseResult (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 :: forall prop.
Testable prop =>
(Rose Result -> Rose Result) -> prop -> Property
mapRoseResult Rose Result -> Rose Result
f = 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 :: forall prop. Testable prop => (Prop -> Prop) -> prop -> Property
mapProp Prop -> Prop
f = Gen Prop -> Property
MkProperty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Prop -> Prop
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Gen Prop
unProperty forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall prop. Testable prop => (Int -> Int) -> prop -> Property
mapSize Int -> Int
f = forall prop. Testable prop => prop -> Property
property forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Int -> Int) -> Gen a -> Gen a
scale Int -> Int
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Gen Prop
unProperty forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall prop a.
Testable prop =>
(a -> [a]) -> a -> (a -> prop) -> Property
shrinking a -> [a]
shrinker a
x0 a -> prop
pf = Gen Prop -> Property
MkProperty (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rose Result -> Prop
MkProp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Rose (Rose a) -> Rose a
joinRose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Prop -> Rose Result
unProp) (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 =
    forall a. a -> [Rose a] -> Rose a
MkRose (Property -> Gen Prop
unProperty (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 :: forall prop. Testable prop => prop -> Property
noShrinking = forall prop.
Testable prop =>
(Rose Result -> Rose Result) -> prop -> Property
mapRoseResult (forall a. (a -> [Rose a] -> Rose a) -> Rose a -> Rose a
onRose (\Result
res [Rose Result]
_ -> forall a. a -> [Rose a] -> Rose a
MkRose Result
res []))

-- | Adds a callback
callback :: Testable prop => Callback -> prop -> Property
callback :: forall prop. Testable prop => Callback -> prop -> Property
callback Callback
cb = forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult (\Result
res -> Result
res{ callbacks :: [Callback]
callbacks = Callback
cb 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 :: forall prop. Testable prop => String -> prop -> Property
counterexample String
s =
  forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult (\Result
res -> Result
res{ testCase :: [String]
testCase = String
sforall a. a -> [a] -> [a]
:Result -> [String]
testCase Result
res }) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall prop. Testable prop => Callback -> prop -> Property
callback (CallbackKind -> (State -> Result -> IO ()) -> Callback
PostFinalFailure CallbackKind
Counterexample 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 [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
      force (a
x:[a]
xs) = a
x seq :: forall a b. a -> b -> b
`seq` [a] -> m ()
force [a]
xs
  Either AnException ()
res <- forall a. IO a -> IO (Either AnException a)
tryEvaluateIO (forall {m :: * -> *} {a}. Monad m => [a] -> m ()
force String
s)
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall prop. Testable prop => String -> prop -> Property
printTestCase = 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 :: forall prop. Testable prop => IO () -> prop -> Property
whenFail IO ()
m =
  forall prop. Testable prop => Callback -> prop -> Property
callback forall a b. (a -> b) -> a -> b
$ CallbackKind -> (State -> Result -> IO ()) -> Callback
PostFinalFailure CallbackKind
NotCounterexample 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' :: forall prop. Testable prop => IO () -> prop -> Property
whenFail' IO ()
m =
  forall prop. Testable prop => Callback -> prop -> Property
callback forall a b. (a -> b) -> a -> b
$ CallbackKind -> (State -> Result -> IO ()) -> Callback
PostTest CallbackKind
NotCounterexample forall a b. (a -> b) -> a -> b
$ \State
_st Result
res ->
    if Result -> Maybe Bool
ok Result
res forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
False
      then IO ()
m
      else 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 :: forall prop. Testable prop => prop -> Property
verbose = forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapResult (\Result
res -> Result
res { callbacks :: [Callback]
callbacks = [Callback] -> Callback
newCallback (Result -> [Callback]
callbacks Result
res)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 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 forall a. [a] -> [a] -> [a]
++ String
":")
            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 :: forall prop. Testable prop => prop -> Property
verboseShrinking = forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapResult (\Result
res -> Result
res { callbacks :: [Callback]
callbacks = [Callback] -> Callback
newCallback (Result -> [Callback]
callbacks Result
res)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 forall a b. (a -> b) -> a -> b
$ \State
st Result
res ->
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Result -> Maybe Bool
ok Result
res forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
False) forall a b. (a -> b) -> a -> b
$ do
              Terminal -> String -> IO ()
putLine (State -> Terminal
terminal State
st) String
"Failed:"
              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 :: forall prop. Testable prop => prop -> Property
expectFailure = 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 :: forall prop. Testable prop => prop -> Property
once = 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 :: forall prop. Testable prop => prop -> Property
again = 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 :: forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
n = Int
n seq :: forall a b. a -> b -> b
`seq` forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult (\Result
res -> Result
res{ maybeNumTests :: Maybe Int
maybeNumTests = 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 :: forall prop. Testable prop => prop -> Property
checkCoverage = 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 :: forall prop. Testable prop => Confidence -> prop -> Property
checkCoverageWith Confidence
confidence =
  Confidence -> Integer
certainty Confidence
confidence seq :: forall a b. a -> b -> b
`seq`
  Confidence -> Double
tolerance Confidence
confidence seq :: forall a b. a -> b -> b
`seq`
  forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult (\Result
res -> Result
res{ maybeCheckCoverage :: Maybe Confidence
maybeCheckCoverage = 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 {
    certainty :: Integer
certainty = Integer
10forall 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 :: forall prop. Testable prop => String -> prop -> Property
label String
s =
#ifndef NO_DEEPSEQ
  String
s forall a b. NFData a => a -> b -> b
`deepseq`
#endif
  forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult forall a b. (a -> b) -> a -> b
$
    \Result
res -> Result
res { labels :: [String]
labels = String
sforall 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 :: forall a prop. (Show a, Testable prop) => a -> prop -> Property
collect a
x = forall prop. Testable prop => String -> prop -> Property
label (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 :: forall prop. Testable prop => Bool -> String -> prop -> Property
classify Bool
False String
_ = forall prop. Testable prop => prop -> Property
property
classify Bool
True String
s =
#ifndef NO_DEEPSEQ
  String
s forall a b. NFData a => a -> b -> b
`deepseq`
#endif
  forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult forall a b. (a -> b) -> a -> b
$
    \Result
res -> Result
res { classes :: [String]
classes = String
sforall 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 :: forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
p Bool
x String
s = forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult Result -> Result
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = (forall a. Maybe a
Nothing, String
s, Double
pforall a. Fractional a => a -> a -> a
/Double
100)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 :: forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
key [String]
values =
#ifndef NO_DEEPSEQ
  String
key forall a b. NFData a => a -> b -> b
`deepseq` [String]
values forall a b. NFData a => a -> b -> b
`deepseq`
#endif
  forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult forall a b. (a -> b) -> a -> b
$
    \Result
res -> Result
res { tables :: [(String, String)]
tables = [(String
key, String
value) | String
value <- [String]
values] 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 :: forall prop.
Testable prop =>
String -> [(String, Double)] -> prop -> Property
coverTable String
table [(String, Double)]
xs =
#ifndef NO_DEEPSEQ
  String
table forall a b. NFData a => a -> b -> b
`deepseq` [(String, Double)]
xs forall a b. NFData a => a -> b -> b
`deepseq`
#endif
  forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapTotalResult forall a b. (a -> b) -> a -> b
$
    \Result
res -> Result
res { requiredCoverage :: [(Maybe String, String, Double)]
requiredCoverage = [(Maybe String, String, Double)]
ys forall a. [a] -> [a] -> [a]
++ Result -> [(Maybe String, String, Double)]
requiredCoverage Result
res }
  where
    ys :: [(Maybe String, String, Double)]
ys = [(forall a. a -> Maybe a
Just String
table, String
x, Double
pforall 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 ==> :: forall prop. Testable prop => Bool -> prop -> Property
==> prop
_ = forall prop. Testable prop => prop -> Property
property Discard
Discard
Bool
True  ==> prop
p = 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 :: forall prop. Testable prop => Int -> prop -> Property
within Int
n = forall prop. Testable prop => Result -> Int -> prop -> Property
onTimeout
   (Result
failed { reason :: String
reason = String
"Timeout of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
" microseconds exceeded." })
   Int
n

-- | Discards the test case if it does not complete within the given
-- number of microseconds. This can be useful when testing algorithms
-- that have pathological cases where they run extremely slowly.
discardAfter :: Testable prop => Int -> prop -> Property
discardAfter :: forall prop. Testable prop => Int -> prop -> Property
discardAfter Int
n = forall prop. Testable prop => Result -> Int -> prop -> Property
onTimeout
   (Result
rejected { reason :: String
reason = String
"Timeout of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
" microseconds exceeded." })
   Int
n

onTimeout :: Testable prop => Result -> Int -> prop -> Property
onTimeout :: forall prop. Testable prop => Result -> Int -> prop -> Property
onTimeout Result
timeoutResult Int
n = 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 forall a b. (a -> b) -> a -> b
$ do
      let f (Maybe b)
m orError :: f (Maybe b) -> b -> f b
`orError` b
x = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe b
x) f (Maybe b)
m
      MkRose Result
res [Rose Result]
roses <- forall a. Int -> IO a -> IO (Maybe a)
timeout Int
n (Rose Result -> IO (Rose Result)
reduceRose Rose Result
rose) forall {f :: * -> *} {b}. Functor f => f (Maybe b) -> b -> f b
`orError`
        forall (m :: * -> *) a. Monad m => a -> m a
return Result
timeoutResult
      Result
res' <- forall a. Int -> IO a -> IO (Maybe a)
timeout Int
n (IO Result -> IO Result
protectResult (forall (m :: * -> *) a. Monad m => a -> m a
return Result
res)) forall {f :: * -> *} {b}. Functor f => f (Maybe b) -> b -> f b
`orError`
        Result
timeoutResult
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> [Rose a] -> Rose a
MkRose Result
res' (forall a b. (a -> b) -> [a] -> [b]
map Rose Result -> Rose Result
f [Rose Result]
roses))
#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 :: forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen a
gen a -> prop
pf = 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 :: forall prop a.
Testable prop =>
Gen a -> (a -> String) -> (a -> prop) -> Property
forAllShow Gen a
gen a -> String
shower a -> prop
pf = 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 :: forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen a
gen a -> prop
pf = 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 :: forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen a
gen a -> [a]
shrinker = forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property
forAllShrinkShow Gen a
gen a -> [a]
shrinker 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 :: forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property
forAllShrinkShow Gen a
gen a -> [a]
shrinker a -> String
shower a -> prop
pf =
  forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrinkBlind Gen a
gen a -> [a]
shrinker (\a
x -> 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 :: forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrinkBlind Gen a
gen a -> [a]
shrinker a -> prop
pf =
  forall prop. Testable prop => prop -> Property
again forall a b. (a -> b) -> a -> b
$
  Gen Prop -> Property
MkProperty forall a b. (a -> b) -> a -> b
$
  Gen a
gen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x ->
    Property -> Gen Prop
unProperty forall a b. (a -> b) -> a -> b
$
    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 .&. :: forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&. prop2
p2 =
  forall prop. Testable prop => prop -> Property
again forall a b. (a -> b) -> a -> b
$
  Gen Prop -> Property
MkProperty forall a b. (a -> b) -> a -> b
$
  forall a. Arbitrary a => Gen a
arbitrary forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b ->
    Property -> Gen Prop
unProperty forall a b. (a -> b) -> a -> b
$
    forall prop. Testable prop => String -> prop -> Property
counterexample (if Bool
b then String
"LHS" else String
"RHS") forall a b. (a -> b) -> a -> b
$
      if Bool
b then forall prop. Testable prop => prop -> Property
property prop1
p1 else 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 .&&. :: forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. prop2
p2 = forall prop. Testable prop => [prop] -> Property
conjoin [forall prop. Testable prop => prop -> Property
property prop1
p1, forall prop. Testable prop => prop -> Property
property prop2
p2]

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

  conj Result -> Result
k (Rose Result
p : [Rose Result]
ps) = forall a. IO (Rose a) -> Rose a
IORose 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) ->
        forall (m :: * -> *) a. Monad m => a -> m a
return (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ((Result -> Result) -> [Rose Result] -> Rose Result
conj (Result -> Result -> Result
addLabels Result
result forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Result -> Result
addCallbacksAndCoverage Result
result forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Result
k) [Rose Result]
ps)
      Just Bool
False -> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Result
k) [Rose Result]
ps)
        forall (m :: * -> *) a. Monad m => a -> m a
return 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 -> forall a. a -> [Rose a] -> Rose a
MkRose (Result
result2 { ok :: Maybe Bool
ok = 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 forall a. [a] -> [a] -> [a]
++ Result -> [Callback]
callbacks Result
r,
        requiredCoverage :: [(Maybe String, String, Double)]
requiredCoverage = Result -> [(Maybe String, String, Double)]
requiredCoverage Result
result 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 forall a. [a] -> [a] -> [a]
++ Result -> [String]
labels Result
r,
        classes :: [String]
classes = Result -> [String]
classes Result
result forall a. [a] -> [a] -> [a]
++ Result -> [String]
classes Result
r,
        tables :: [(String, String)]
tables = Result -> [(String, String)]
tables Result
result 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 .||. :: forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.||. prop2
p2 = forall prop. Testable prop => [prop] -> Property
disjoin [forall prop. Testable prop => prop -> Property
property prop1
p1, forall prop. Testable prop => prop -> Property
property prop2
p2]

-- | Take the disjunction of several properties.
disjoin :: Testable prop => [prop] -> Property
disjoin :: forall prop. Testable prop => [prop] -> Property
disjoin [prop]
ps =
  forall prop. Testable prop => prop -> Property
again forall a b. (a -> b) -> a -> b
$
  Gen Prop -> Property
MkProperty forall a b. (a -> b) -> a -> b
$
  do [Rose Result]
roses <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Prop -> Rose Result
unProp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Gen Prop
unProperty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall prop. Testable prop => prop -> Property
property) [prop]
ps
     forall (m :: * -> *) a. Monad m => a -> m a
return (Rose Result -> Prop
MkProp (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Rose Result -> Rose Result -> Rose Result
disj (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) -> forall (m :: * -> *) a. Monad m => a -> m a
return Result
expectFailureError
         Just Bool
False -> do
           Result
result2 <- Rose Result
q
           forall (m :: * -> *) a. Monad m => a -> m a
return 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 {
                   ok :: Maybe Bool
ok = 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 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 = forall a. Maybe a
Nothing,
                   maybeCheckCoverage :: Maybe Confidence
maybeCheckCoverage = 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 forall a. [a] -> [a] -> [a]
++
                     [CallbackKind -> (State -> Result -> IO ()) -> Callback
PostFinalFailure CallbackKind
Counterexample forall a b. (a -> b) -> a -> b
$ \State
st Result
_res -> Terminal -> String -> IO ()
putLine (State -> Terminal
terminal State
st) String
""] forall a. [a] -> [a] -> [a]
++
                     Result -> [Callback]
callbacks Result
result2,
                   testCase :: [String]
testCase =
                     Result -> [String]
testCase Result
result1 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
_ -> 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 forall a. [a] -> [a] -> [a]
++ 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 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 === :: forall a. (Eq a, Show a) => a -> a -> Property
=== a
y =
  forall prop. Testable prop => String -> prop -> Property
counterexample (forall a. Show a => a -> String
show a
x forall a. [a] -> [a] -> [a]
++ Bool -> String
interpret Bool
res forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
y) Bool
res
  where
    res :: Bool
res = a
x 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 =/= :: forall a. (Eq a, Show a) => a -> a -> Property
=/= a
y =
  forall prop. Testable prop => String -> prop -> Property
counterexample (forall a. Show a => a -> String
show a
x forall a. [a] -> [a] -> [a]
++ Bool -> String
interpret Bool
res forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
y) Bool
res
  where
    res :: Bool
res = a
x 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 :: forall a. NFData a => a -> Property
total a
x = forall prop. Testable prop => prop -> Property
property (forall a. NFData a => a -> ()
rnf a
x)
#endif

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