{-# OPTIONS_GHC -fno-warn-tabs #-}
{-|
Module      : Test.QuickCheck.Variant
Description : Variant class
Copyright   : (c) Jorge Santiago Alvarez Cuadros, 2015
License     : GPL-3
Maintainer  : sanjorgek@ciencias.unam.mx
Stability   : experimental
Portability : portable

To get random "invalid" and "valid" data
-}
module Test.QuickCheck.Variant where
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Exception
import Test.QuickCheck.Gen
import Test.QuickCheck.Property
import Test.QuickCheck.State
import Test.QuickCheck.Text

{-|
You can define

>>> instance (Variant a) => Arbitrary a where {arbitrary = oneof [valid, invalid]}
-}
class Variant a where
  -- |Get a generator of valid random data type
  valid   :: Gen a
  -- |Get a generator of invalid random data type
  invalid :: Gen a

{-|
The class of things wich can be tested with invalid or valid input.
-}
class VarTestable prop where
  -- |Property for valid input
  propertyValid::prop -> Property
  -- |Property for invalid input
  propertyInvalid::prop -> Property

{-|
Same as Testeable
-}
instance VarTestable Bool where
  propertyValid :: Bool -> Property
propertyValid = Bool -> Property
forall prop. Testable prop => prop -> Property
property
  propertyInvalid :: Bool -> Property
propertyInvalid = Bool -> Property
forall prop. Testable prop => prop -> Property
property

mapTotalResultValid :: VarTestable prop => (Result -> Result) -> prop -> Property
mapTotalResultValid :: (Result -> Result) -> prop -> Property
mapTotalResultValid Result -> Result
f = (Rose Result -> Rose Result) -> prop -> Property
forall prop.
VarTestable prop =>
(Rose Result -> Rose Result) -> prop -> Property
mapRoseResultValid ((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).
mapRoseResultValid :: VarTestable prop => (Rose Result -> Rose Result) -> prop -> Property
mapRoseResultValid :: (Rose Result -> Rose Result) -> prop -> Property
mapRoseResultValid Rose Result -> Rose Result
f = (Prop -> Prop) -> prop -> Property
forall prop. VarTestable prop => (Prop -> Prop) -> prop -> Property
mapPropValid (\(MkProp Rose Result
t) -> Rose Result -> Prop
MkProp (Rose Result -> Rose Result
f Rose Result
t))

mapPropValid :: VarTestable prop => (Prop -> Prop) -> prop -> Property
mapPropValid :: (Prop -> Prop) -> prop -> Property
mapPropValid 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. VarTestable prop => prop -> Property
propertyValid

-- | Adds a callback
callbackValid :: VarTestable prop => Callback -> prop -> Property
callbackValid :: Callback -> prop -> Property
callbackValid Callback
cb = (Result -> Result) -> prop -> Property
forall prop.
VarTestable prop =>
(Result -> Result) -> prop -> Property
mapTotalResultValid (\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.
counterexampleValid :: VarTestable prop => String -> prop -> Property
counterexampleValid :: String -> prop -> Property
counterexampleValid 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. VarTestable prop => Callback -> prop -> Property
callbackValid (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
showCounterexampleValid String
s
    Terminal -> String -> IO ()
putLine (State -> Terminal
terminal State
st) String
s)

showCounterexampleValid :: String -> IO String
showCounterexampleValid :: String -> IO String
showCounterexampleValid 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

-- | Like 'forAll', but tries to shrink the argument for failing test cases.
forAllShrinkValid :: (Show a, VarTestable prop)
             => Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrinkValid :: Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrinkValid 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 -> Property) -> Property
forall prop a.
Testable prop =>
(a -> [a]) -> a -> (a -> prop) -> Property
shrinking a -> [a]
shrinker a
x ((a -> Property) -> Property) -> (a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \a
x' ->
      String -> prop -> Property
forall prop. VarTestable prop => String -> prop -> Property
counterexampleValid (a -> String
forall a. Show a => a -> String
show a
x') (a -> prop
pf a
x')

mapTotalResultInvalid :: VarTestable prop => (Result -> Result) -> prop -> Property
mapTotalResultInvalid :: (Result -> Result) -> prop -> Property
mapTotalResultInvalid Result -> Result
f = (Rose Result -> Rose Result) -> prop -> Property
forall prop.
VarTestable prop =>
(Rose Result -> Rose Result) -> prop -> Property
mapRoseResultInvalid ((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).
mapRoseResultInvalid :: VarTestable prop => (Rose Result -> Rose Result) -> prop -> Property
mapRoseResultInvalid :: (Rose Result -> Rose Result) -> prop -> Property
mapRoseResultInvalid Rose Result -> Rose Result
f = (Prop -> Prop) -> prop -> Property
forall prop. VarTestable prop => (Prop -> Prop) -> prop -> Property
mapPropInvalid (\(MkProp Rose Result
t) -> Rose Result -> Prop
MkProp (Rose Result -> Rose Result
f Rose Result
t))

mapPropInvalid :: VarTestable prop => (Prop -> Prop) -> prop -> Property
mapPropInvalid :: (Prop -> Prop) -> prop -> Property
mapPropInvalid 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. VarTestable prop => prop -> Property
propertyInvalid

-- | Adds a callback
callbackInvalid :: VarTestable prop => Callback -> prop -> Property
callbackInvalid :: Callback -> prop -> Property
callbackInvalid Callback
cb = (Result -> Result) -> prop -> Property
forall prop.
VarTestable prop =>
(Result -> Result) -> prop -> Property
mapTotalResultInvalid (\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.
counterexampleInvalid :: VarTestable prop => String -> prop -> Property
counterexampleInvalid :: String -> prop -> Property
counterexampleInvalid 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. VarTestable prop => Callback -> prop -> Property
callbackInvalid (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
showCounterexampleInvalid String
s
    Terminal -> String -> IO ()
putLine (State -> Terminal
terminal State
st) String
s)

showCounterexampleInvalid :: String -> IO String
showCounterexampleInvalid :: String -> IO String
showCounterexampleInvalid 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

-- | Like 'forAll', but tries to shrink the argument for failing test cases.
forAllShrinkInvalid :: (Show a, VarTestable prop)
             => Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrinkInvalid :: Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrinkInvalid 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 -> Property) -> Property
forall prop a.
Testable prop =>
(a -> [a]) -> a -> (a -> prop) -> Property
shrinking a -> [a]
shrinker a
x ((a -> Property) -> Property) -> (a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \a
x' ->
      String -> prop -> Property
forall prop. VarTestable prop => String -> prop -> Property
counterexampleInvalid (a -> String
forall a. Show a => a -> String
show a
x') (a -> prop
pf a
x')

{-|
Instead of variant we use valid or invalid generators
-}
instance (Arbitrary a, Variant a, Show a, VarTestable prop) => VarTestable (a->prop) where
  propertyValid :: (a -> prop) -> Property
propertyValid = Gen a -> (a -> [a]) -> (a -> prop) -> Property
forall a prop.
(Show a, VarTestable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrinkValid Gen a
forall a. Variant a => Gen a
valid a -> [a]
forall a. Arbitrary a => a -> [a]
shrink
  propertyInvalid :: (a -> prop) -> Property
propertyInvalid = Gen a -> (a -> [a]) -> (a -> prop) -> Property
forall a prop.
(Show a, VarTestable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrinkInvalid Gen a
forall a. Variant a => Gen a
invalid a -> [a]
forall a. Arbitrary a => a -> [a]
shrink