module TestSuite.Prop.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 qualified Test.Falsify.Generator as Gen import qualified Test.Falsify.Predicate as P import TestSuite.Util.List tests :: TestTree tests = testGroup "TestSuite.Prop.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.alwaysFail $ 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.alwaysFail $ 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.alwaysPass $ 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