tasty-falsify-0.1.0: test/TestSuite/Generator/Prim.hs
{-# LANGUAGE OverloadedStrings #-}
module TestSuite.Generator.Prim (tests) where
import Prelude hiding (pred)
import Control.Monad
import Control.Selective
import Data.Default
import Data.Word
import Test.Tasty
import Test.Tasty.Falsify
import Test.Falsify
import qualified Test.Falsify.Generator as Gen
import qualified Test.Falsify.Predicate as P
import TestSuite.Util.List
{-------------------------------------------------------------------------------
List of tests
-------------------------------------------------------------------------------}
tests :: TestTree
tests = testGroup "TestSuit.Generator.Prim" [
testGroup "prim" [
testProperty "shrinking" prop_prim_shrinking
, testGroup "minimum" [
testProperty (show target) $ prop_prim_minimum target
| target <- [0 .. 4]
]
, testPropertyWith (def { expectFailure = ExpectFailure })
"prim_minimum_wrong" prop_prim_minimum_wrong
]
, testGroup "applicative" [
testGroup "pair" [
testProperty "shrinking" prop_applicative_pair_shrinking
, testProperty "minimum1" prop_applicative_pair_minimum1
, testProperty "minimum2" prop_applicative_pair_minimum2
]
, testGroup "replicateM" [
testProperty "shrinking" prop_applicative_replicateM_shrinking
, testProperty "minimum" prop_applicative_replicateM_minimum
]
]
, testGroup "monad" [
testGroup "maybe" [
testGroup "towardsNothing" [
testProperty "shrinking" prop_monad_maybe_towardsNothing_shrinking
, testProperty "minimum" prop_monad_maybe_towardsNothing_minimum
, testPropertyWith expectFailure
"shrinking_wrong" prop_monad_maybe_towardsNothing_shrinking_wrong
]
, testGroup "towardsJust" [
testProperty "shrinking" prop_monad_maybe_towardsJust_shrinking
, testProperty "minimum" prop_monad_maybe_towardsJust_minimum
, testPropertyWith expectFailure
"minimum_wrong" prop_monad_maybe_towardsJust_minimum_wrong
]
]
, testGroup "either" [
testProperty "shrinking" prop_monad_either_shrinking
]
]
, testGroup "selective" [
testGroup "either" [
testPropertyWith expectFailure
"shrinking" prop_selective_either_shrinking_wrong
]
]
, testGroup "captureLocalTree" [
testProperty "shrinking1" prop_captureLocalTree_shrinking1
, testProperty "shrinking2" prop_captureLocalTree_shrinking2
]
, testGroup "stream" [
testProperty "shrinking1" prop_stream_shrinking1
, testProperty "shrinking2" prop_stream_shrinking2
, testProperty "minimum" prop_stream_minimum
]
]
where
expectFailure :: TestOptions
expectFailure = def {
expectFailure = ExpectFailure
, overrideNumTests = Just 100_000
}
{-------------------------------------------------------------------------------
Prim
-------------------------------------------------------------------------------}
-- Gen.prime is the only generator where we a /strict/ inequality
prop_prim_shrinking :: Property ()
prop_prim_shrinking = testShrinkingOfGen P.gt $ Gen.prim
-- The minimum is always 0, unless 0 is not a counter-example
prop_prim_minimum :: Word64 -> Property ()
prop_prim_minimum target = do
testMinimum (P.expect $ if target == 0 then 1 else 0) $ do
x <- gen $ Gen.prim
unless (x == target) $ testFailed x
-- | Just to verify that we if we specify the /wrong/ minimum, we get a failure
prop_prim_minimum_wrong :: Property ()
prop_prim_minimum_wrong =
testMinimum (P.expect 1) $ do
x <- gen $ Gen.prim
testFailed x
{-------------------------------------------------------------------------------
Applicative: pairs
-------------------------------------------------------------------------------}
prop_applicative_pair_shrinking :: Property ()
prop_applicative_pair_shrinking =
testShrinkingOfGen (P.relatedBy ("validShrink", validShrink)) $
(,) <$> Gen.prim <*> Gen.prim
where
validShrink :: (Word64, Word64) -> (Word64, Word64) -> Bool
validShrink (x, y) (x', y') = x >= x' && y >= y'
prop_applicative_pair_minimum1 :: Property ()
prop_applicative_pair_minimum1 =
testMinimum (P.expect (1, 0)) $ do
(x, y) <- gen $ (,) <$> Gen.prim <*> Gen.prim
unless (x == 0 || x < y) $ testFailed (x, y)
prop_applicative_pair_minimum2 :: Property ()
prop_applicative_pair_minimum2 =
testMinimum (P.expect (1, 1)) $ do
(x, y) <- gen $ (,) <$> Gen.prim <*> Gen.prim
unless (x == 0 || x > y) $ testFailed (x, y)
{-------------------------------------------------------------------------------
Applicative: replicateM
-------------------------------------------------------------------------------}
genList :: Gen [Word64]
genList = do
n <- (`min` 10) <$> Gen.prim
replicateM (fromIntegral n) Gen.prim
prop_applicative_replicateM_shrinking :: Property ()
prop_applicative_replicateM_shrinking =
testShrinkingOfGen (P.relatedBy ("validShrink", validShrink)) genList
where
validShrink :: [Word64] -> [Word64] -> Bool
validShrink [] [] = True
validShrink [] (_:_) = False
validShrink (_:_) [] = True
validShrink (x:xs) (y:ys) = x >= y && validShrink xs ys
prop_applicative_replicateM_minimum :: Property ()
prop_applicative_replicateM_minimum =
testMinimum (P.expect [0,1]) $ do
xs <- gen $ genList
unless (pairwiseAll (==) xs) $ testFailed xs
{-------------------------------------------------------------------------------
Monad: Maybe (towards 'Nothing')
-------------------------------------------------------------------------------}
genSmall :: Gen Word64
genSmall = do
startWithEven <- Gen.prim
if startWithEven >= maxBound `div` 2
then Gen.exhaustive 100
else Gen.exhaustive 99 -- smaller bound, to ensure shrinking
genTowardsNothing :: Gen (Maybe Word64, Word64)
genTowardsNothing = do
genNothing <- (== 0) <$> Gen.prim
if genNothing
then (\ y -> (Nothing, y)) <$> genSmall
else (\x y -> (Just x, y)) <$> genSmall <*> genSmall
prop_monad_maybe_towardsNothing_shrinking :: Property ()
prop_monad_maybe_towardsNothing_shrinking =
testShrinkingOfGen
(P.relatedBy ("validShrink", validShrink))
genTowardsNothing
where
validShrink :: (Maybe Word64, Word64) -> (Maybe Word64, Word64) -> Bool
validShrink (Nothing , y) (Nothing , y') = y >= y'
validShrink (Just _ , _) (Nothing , _ ) = True -- See @.._wrong@ property
validShrink (Nothing , _) (Just _ , _ ) = False
validShrink (Just x , y) (Just x' , y') = x >= x' && y >= y'
prop_monad_maybe_towardsNothing_minimum :: Property ()
prop_monad_maybe_towardsNothing_minimum =
testMinimum (P.expect expected) $ do
(x, y) <- gen $ genTowardsNothing
unless (even y) $ testFailed (x, y)
where
-- We are using different generators, a switch from 'Just' to 'Nothing'
-- might temporarily because @y@ to increase (see @.._wrong@), but we will
-- then continue to shrink that value.
expected :: (Maybe Word64, Word64)
expected = (Nothing, 1)
prop_monad_maybe_towardsNothing_shrinking_wrong :: Property ()
prop_monad_maybe_towardsNothing_shrinking_wrong =
testShrinkingOfGen
(P.relatedBy ("validShrink", validShrink))
genTowardsNothing
where
-- This property is wrong: the two generators on the RHS have a different
-- structure, and therefore shrink independently. When we switch the
-- LHS from Just to Nothing, we run a /different/ generator.
validShrink :: (Maybe Word64, Word64) -> (Maybe Word64, Word64) -> Bool
validShrink (Nothing , y) (Nothing , y') = y >= y'
validShrink (Just _ , y) (Nothing , y') = y >= y'
validShrink (Nothing , _) (Just _ , _) = False
validShrink (Just x , y) (Just x' , y') = x >= x' && y >= y'
{-------------------------------------------------------------------------------
Monad: Maybe (towards 'Just')
Unlike hypothesis, we are always dealing with infinite sample tree; if a
"simpler" test case needs more samples, then they are available.
-------------------------------------------------------------------------------}
genTowardsJust :: Gen (Maybe Word64, Word64)
genTowardsJust = do
genJust <- (== 0) <$> Gen.prim
if genJust
then (\x y -> (Just x, y)) <$> genSmall <*> genSmall
else (\ y -> (Nothing, y)) <$> genSmall
prop_monad_maybe_towardsJust_shrinking :: Property ()
prop_monad_maybe_towardsJust_shrinking =
testShrinkingOfGen
(P.relatedBy ("validShrink", validShrink))
genTowardsJust
where
validShrink :: (Maybe Word64, Word64) -> (Maybe Word64, Word64) -> Bool
validShrink (Nothing , y) (Nothing , y') = y >= y'
validShrink (Just _ , _) (Nothing , _ ) = False
validShrink (Nothing , _) (Just _ , _ ) = True
validShrink (Just x , y) (Just x' , y') = x >= x' && y >= y'
prop_monad_maybe_towardsJust_minimum :: Property ()
prop_monad_maybe_towardsJust_minimum =
testMinimum (P.satisfies ("expected", expected)) $ do
(x, y) <- gen $ genTowardsJust
unless (even y) $ testFailed (x, y)
where
expected :: (Maybe Word64, Word64) -> Bool
expected (Just _ , y) = y == 1
expected (Nothing , _) = True
prop_monad_maybe_towardsJust_minimum_wrong :: Property ()
prop_monad_maybe_towardsJust_minimum_wrong =
testMinimum (P.expect expected) $ do
(x, y) <- gen $ genTowardsJust
unless (even y) $ testFailed (x, y)
where
-- We might not always be able to shrink from 'Nothing' to 'Just', because
-- the /value/ of that 'Just' might not be a counter-example; we would need
-- to take two shrink steps at once (switch from 'Just' to 'Nothing' /and/
-- reduce the value of the 'Just').
--
-- 'Selective' does not help either (it also would need to take two steps);
-- we /could/ try to solve the problem by generating /both/ values always,
-- and using only one, but as we know, that is not an effective strategy:
-- generated-by-not-used values will always be shrunk to their minimal
-- value, independent of the property.
expected :: (Maybe Word64, Word64)
expected = (Just 0, 1)
{-------------------------------------------------------------------------------
Monad: Either
-------------------------------------------------------------------------------}
genMonadEither :: Gen (Either Word64 Word64)
genMonadEither = do
genLeft <- (== 0) <$> Gen.prim -- shrink towards left
if genLeft
then Left <$> Gen.prim
else Right <$> Gen.prim
prop_monad_either_shrinking :: Property ()
prop_monad_either_shrinking =
testShrinkingOfGen
(P.relatedBy ("validShrink", validShrink))
genMonadEither
where
-- The 'Left' and 'Right' case use the /same/ part of the sample tree, so
-- that if we shrink from one to the other, we /must/ get the same value.
validShrink :: Either Word64 Word64 -> Either Word64 Word64 -> Bool
validShrink _ (Left 0) = True -- We can always shrink to 'Minimal'
validShrink (Left x) (Left x') = x >= x'
validShrink (Left _) (Right _) = False
validShrink (Right x) (Left x') = x == x'
validShrink (Right x) (Right x') = x >= x'
{-------------------------------------------------------------------------------
Selective: either
-------------------------------------------------------------------------------}
genSelectiveEither :: Gen (Either Word64 Word64)
genSelectiveEither =
ifS ((== 0) <$> Gen.prim)
(Left <$> Gen.prim)
(Right <$> Gen.prim)
prop_selective_either_shrinking_wrong :: Property ()
prop_selective_either_shrinking_wrong =
testShrinkingOfGen
(P.relatedBy ("validShrink", validShrink))
genSelectiveEither
where
-- Like in 'prop_monad_either_shrinking', here the two generators are
-- independent, and so it's entirely possible we might shrink from @Right x@
-- to @Left y@ for @x /= y@.
validShrink :: Either Word64 Word64 -> Either Word64 Word64 -> Bool
validShrink _ (Left 0) = True -- We can always shrink to 'Minimal'
validShrink (Left x) (Left x') = x >= x'
validShrink (Left _) (Right _) = False
validShrink (Right x) (Left x') = x == x'
validShrink (Right x) (Right x') = x >= x'
{-------------------------------------------------------------------------------
captureLocalTree
-------------------------------------------------------------------------------}
prop_captureLocalTree_shrinking1 :: Property ()
prop_captureLocalTree_shrinking1 =
testShrinkingOfGen (P.fail "Fail") $
Gen.captureLocalTree
-- Check that we /still/ cannot shrink (i.e., monadic bind is not
-- introducing a bug somewhere)
prop_captureLocalTree_shrinking2 :: Property ()
prop_captureLocalTree_shrinking2 =
testShrinkingOfGen (P.fail "Fail") $ do
t1 <- Gen.captureLocalTree
t2 <- Gen.captureLocalTree
return (t1, t2)
{-------------------------------------------------------------------------------
Stream
The purpose of this test is to test generation (and shrinking) of infinite
data structures. The function generation tests will verify that also, but they
are much more complicated.
-------------------------------------------------------------------------------}
-- | Infinite stream of values
--
-- Intentionally does not have a 'Show' instance!
data Stream a = Stream a (Stream a)
prefix :: Stream a -> Word64 -> [a]
prefix _ 0 = []
prefix (Stream x xs) n = x : prefix xs (n - 1)
genStream :: Gen (Stream Word64)
genStream = Stream <$> Gen.exhaustive 10 <*> genStream
genStreamPrefix :: Gen [Word64]
genStreamPrefix = prefix <$> genStream <*> Gen.exhaustive 10
-- | Check that we can test shrinking of infinite structures /at all/
prop_stream_shrinking1 :: Property ()
prop_stream_shrinking1 =
testShrinkingOfGen P.pass $
genStreamPrefix
-- | Check that we shrink in the way we expect
prop_stream_shrinking2 :: Property ()
prop_stream_shrinking2 =
testShrinkingOfGen pred $
genStreamPrefix
where
pred :: P.Predicate '[[Word64], [Word64]]
pred = mconcat [
P.ge `P.on` P.fn ("length", length)
, P.relatedBy ("elemsRelated", elemsRelated)
]
elemsRelated :: [Word64] -> [Word64] -> Bool
elemsRelated orig shrunk = and $ zipWith (>=) orig shrunk
prop_stream_minimum :: Property ()
prop_stream_minimum =
testMinimum (P.expect [0, 0]) $ do
xs <- gen genStreamPrefix
unless (pairwiseAll (<) xs) $ testFailed xs