diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Revision history for falsify + +## 0.1.0 -- 2026-07-01 + +* First release. + Prior to `falsify-0.4.0`, `tasty` integration was provided by the main package + itself. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023-2026, Well-Typed LLP + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Well-Typed LLP nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src/Test/Tasty/Falsify.hs b/src/Test/Tasty/Falsify.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Falsify.hs @@ -0,0 +1,38 @@ +-- | Support for @falsify@ in the @tasty@ framework +module Test.Tasty.Falsify ( + testProperty + -- * Override options + , testPropertyWith + , TestOptions(..) + , Falsify.ExpectFailure(..) + , Falsify.Verbose(..) + ) where + +import Test.Tasty.Falsify.Options +import Data.Default + +import qualified Test.Falsify as Falsify +import qualified Test.Falsify.Driver as Falsify +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.Providers as Tasty + +import Test.Tasty.Falsify.Test + +{------------------------------------------------------------------------------- + User API +-------------------------------------------------------------------------------} + +-- | Specialization of 'testPropertyWith' using default options +testProperty :: + Tasty.TestName + -> Falsify.Property () + -> Tasty.TestTree +testProperty = testPropertyWith def + +-- | Test @falsify@ 'Falsify.Property' as part of a @tasty@ 'Tasty.TestTree' +testPropertyWith :: + TestOptions + -> Tasty.TestName + -> Falsify.Property () + -> Tasty.TestTree +testPropertyWith testOpts name = Tasty.singleTest name . Test testOpts diff --git a/src/Test/Tasty/Falsify/CLI.hs b/src/Test/Tasty/Falsify/CLI.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Falsify/CLI.hs @@ -0,0 +1,105 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Command line flags +module Test.Tasty.Falsify.CLI ( + Tests(..) + , MaxShrinks(..) + , Replay(..) + , MaxRatio(..) + , extractFalsifyCliFlags + , allFalsifyCliFlags + ) where + +import Data.Default +import Data.Tagged +import Test.Tasty.Options (IsOption(..)) +import Data.Proxy + +import qualified Options.Applicative as Opts +import qualified Test.Tasty.Options as Tasty + +import Test.Falsify.Driver (ReplaySeed, parseReplaySeed) +import qualified Test.Falsify.Driver as Falsify + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +newtype Tests = Tests { getTests :: Word } +newtype MaxShrinks = MaxShrinks { getMaxShrinks :: Maybe Word } +newtype Replay = Replay { getReplay :: Maybe ReplaySeed } +newtype MaxRatio = MaxRatio { getMaxRatio :: Word } + +-- | Extract CLI options +extractFalsifyCliFlags :: Tasty.OptionSet -> (Falsify.Verbose, Falsify.Options) +extractFalsifyCliFlags optionSet = ( + Tasty.lookupOption optionSet + , Falsify.Options { + tests = getTests $ Tasty.lookupOption optionSet + , maxShrinks = getMaxShrinks $ Tasty.lookupOption optionSet + , replay = getReplay $ Tasty.lookupOption optionSet + , maxRatio = getMaxRatio $ Tasty.lookupOption optionSet + } + ) + +-- | Make @tasty@ aware of the @falsify@ specific CLI flags +allFalsifyCliFlags :: [Tasty.OptionDescription] +allFalsifyCliFlags = [ + Tasty.Option $ Proxy @Falsify.Verbose + , Tasty.Option $ Proxy @Tests + , Tasty.Option $ Proxy @MaxShrinks + , Tasty.Option $ Proxy @Replay + , Tasty.Option $ Proxy @MaxRatio + ] + +{------------------------------------------------------------------------------- + 'IsOption' instances +-------------------------------------------------------------------------------} + +instance IsOption Tests where + defaultValue = Tests (Falsify.tests def) + parseValue = fmap Tests . Tasty.safeRead . filter (/= '_') + optionName = Tagged "falsify-tests" + optionHelp = Tagged "Number of test cases to generate" + +instance IsOption MaxShrinks where + defaultValue = MaxShrinks (Falsify.maxShrinks def) + parseValue = fmap (MaxShrinks . Just) . Tasty.safeRead + optionName = Tagged "falsify-shrinks" + optionHelp = Tagged "Random seed to use for replaying a previous test run" + +instance IsOption Replay where + defaultValue = Replay (Falsify.replay def) + parseValue = aux . parseReplaySeed + where + -- Slightly confusing here: the /outer/ 'Maybe' corresponds to test + -- failure, the /inner/ 'Maybe' to the fact that the seed is optional. + aux :: Either String ReplaySeed -> Maybe Replay + aux (Left _err) = Nothing + aux (Right seed) = Just $ Replay (Just seed) + optionName = Tagged "falsify-replay" + optionHelp = Tagged "Random seed to use for replaying test" + optionCLParser = Opts.option (Opts.str >>= aux . parseReplaySeed) $ mconcat [ + Opts.long $ untag $ optionName @Replay + , Opts.help $ untag $ optionHelp @Replay + ] + where + aux :: Either String ReplaySeed -> Opts.ReadM Replay + aux (Left err) = fail err + aux (Right seed) = return $ Replay (Just seed) + +instance IsOption MaxRatio where + defaultValue = MaxRatio (Falsify.maxRatio def) + parseValue = fmap MaxRatio . Tasty.safeRead . filter (/= '_') + optionName = Tagged "falsify-max-ratio" + optionHelp = Tagged "Maximum number of discarded tests per successful test" + +instance IsOption Falsify.Verbose where + defaultValue = Falsify.NotVerbose + parseValue = fmap ( \b -> if b then Falsify.Verbose + else Falsify.NotVerbose + ) + . Tasty.safeReadBool + optionName = Tagged $ "falsify-verbose" + optionHelp = Tagged $ "Show the generated test cases" + optionCLParser = Tasty.mkFlagCLParser mempty Falsify.Verbose diff --git a/src/Test/Tasty/Falsify/Options.hs b/src/Test/Tasty/Falsify/Options.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Falsify/Options.hs @@ -0,0 +1,71 @@ +-- | Test options +module Test.Tasty.Falsify.Options ( + TestOptions(..) + , assembleFalsifyOptions + ) where + +import Data.Default +import Data.Maybe (fromMaybe) + +import qualified Test.Tasty.Options as Tasty +import qualified Test.Falsify.Driver as Falsify + +import Test.Tasty.Falsify.CLI + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | Tasty test options +-- +-- Most all of these are command line options, but not all; some are set on a +-- test-by-test basis, such as 'Falsify.ExpectFailure'. +data TestOptions = TestOptions { + -- | Do we expect this test to fail? + expectFailure :: Falsify.ExpectFailure + + -- | Override verbose mode for this test + , overrideVerbose :: Maybe Falsify.Verbose + + -- | Override the maximum number of shrink steps for this test + , overrideMaxShrinks :: Maybe Word + + -- | Override the number of tests + , overrideNumTests :: Maybe Word + + -- | Override how many tests can be discarded per successful test + , overrideMaxRatio :: Maybe Word + } + +instance Default TestOptions where + def = TestOptions { + expectFailure = Falsify.DontExpectFailure + , overrideVerbose = Nothing + , overrideMaxShrinks = Nothing + , overrideNumTests = Nothing + , overrideMaxRatio = Nothing + } + +{------------------------------------------------------------------------------- + Construct @falsify@ 'Options' +-------------------------------------------------------------------------------} + +assembleFalsifyOptions :: + Tasty.OptionSet -- ^ CLI flags + -> TestOptions -- ^ User specified test options + -> (Falsify.Verbose, Falsify.Options) +assembleFalsifyOptions optionSet testOpts = ( + fromMaybe cliVerbosity (overrideVerbose testOpts) + , maybe id + (\x o -> o{Falsify.maxShrinks = Just x}) + (overrideMaxShrinks testOpts) + $ maybe id + (\x o -> o{Falsify.tests = x}) + (overrideNumTests testOpts) + $ maybe id + (\x o -> o{Falsify.maxRatio = x}) + (overrideMaxRatio testOpts) + $ cliOptions + ) + where + (cliVerbosity, cliOptions) = extractFalsifyCliFlags optionSet diff --git a/src/Test/Tasty/Falsify/Test.hs b/src/Test/Tasty/Falsify/Test.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Falsify/Test.hs @@ -0,0 +1,40 @@ +-- | Main @tasty@ 'Tasty.IsTest' instance +module Test.Tasty.Falsify.Test (Test(..)) where + +import Data.Tagged + +import qualified Test.Tasty.Providers as Tasty + +import Test.Falsify +import Test.Falsify.Driver + +import Test.Tasty.Falsify.CLI +import Test.Tasty.Falsify.Options + +{------------------------------------------------------------------------------- + Definition + + TODO: older versions of tasty explicitly say to ignore the @reportProgress@ + argument, but this is no longer true as of tasty 1.5. + +-------------------------------------------------------------------------------} + +data Test = Test TestOptions (Property' String ()) + +instance Tasty.IsTest Test where + run optionSet (Test testOpts prop) _reportProgress = + toTastyResult . renderTestOutcome verbose (expectFailure testOpts) <$> + falsify options prop + where + (verbose, options) = assembleFalsifyOptions optionSet testOpts + + testOptions = Tagged allFalsifyCliFlags + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +toTastyResult :: RenderedTestOutcome -> Tasty.Result +toTastyResult RenderedTestOutcome{testPassed, testOutput} + | testPassed = Tasty.testPassed testOutput + | otherwise = Tasty.testFailed testOutput diff --git a/tasty-falsify.cabal b/tasty-falsify.cabal new file mode 100644 --- /dev/null +++ b/tasty-falsify.cabal @@ -0,0 +1,124 @@ +cabal-version: 3.0 +name: tasty-falsify +version: 0.1.0 +synopsis: Integration of @falsify@ with the @tasty@ test framework +description: Typically @falsify@ properties are run as part of a larger + test suite; this package provides the necessary + infrastructure for checking @falsify@ properties in a + @tasty@ test suite. + +license: BSD-3-Clause +license-file: LICENSE +author: Edsko de Vries +maintainer: edsko@well-typed.com +copyright: Well-Typed LLP +category: Testing +build-type: Simple +extra-doc-files: CHANGELOG.md +tested-with: GHC==8.10.7 + , GHC==9.0.2 + , GHC==9.2.8 + , GHC==9.4.8 + , GHC==9.6.7 + , GHC==9.8.4 + , GHC==9.10.3 + , GHC==9.12.4 + , GHC==9.14.1 + +source-repository head + type: git + location: https://github.com/well-typed/falsify + +common lang + ghc-options: + -Wall + -Wredundant-constraints + -Widentities + build-depends: + base >= 4.12 && < 4.23 + default-language: + Haskell2010 + default-extensions: + BangPatterns + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DisambiguateRecordFields + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NumericUnderscores + PatternSynonyms + QuantifiedConstraints + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeOperators + ViewPatterns + + if impl(ghc >= 9.2) + ghc-options: -Wunused-packages + +library + import: + lang + exposed-modules: + Test.Tasty.Falsify + other-modules: + Test.Tasty.Falsify.CLI + Test.Tasty.Falsify.Options + Test.Tasty.Falsify.Test + hs-source-dirs: + src + build-depends: + , data-default >= 0.7 && < 0.9 + , falsify >= 0.4 && < 0.5 + , optparse-applicative >= 0.16 && < 0.20 + , tagged >= 0.8 && < 0.9 + , tasty >= 1.3 && < 1.6 + +test-suite test-tasty-falsify + import: + lang + type: + exitcode-stdio-1.0 + hs-source-dirs: + test + main-is: + Main.hs + other-modules: + TestSuite.Generator.Compound + TestSuite.Generator.Context + TestSuite.Generator.Function + TestSuite.Generator.Marking + TestSuite.Generator.Precision + TestSuite.Generator.Prim + TestSuite.Generator.Selective + TestSuite.Generator.Shrinking + TestSuite.Generator.Simple + TestSuite.Util.List + build-depends: + -- Inherited bounds from the main library + , data-default + , falsify + , tasty + , tasty-falsify + build-depends: + , containers >= 0.6 && < 0.9 + , QuickCheck >= 2.14 && < 2.19 + , selective >= 0.4 && < 0.8 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,28 @@ +module Main (main) where + +import Test.Tasty + +import qualified TestSuite.Generator.Compound +import qualified TestSuite.Generator.Context +import qualified TestSuite.Generator.Function +import qualified TestSuite.Generator.Marking +import qualified TestSuite.Generator.Precision +import qualified TestSuite.Generator.Prim +import qualified TestSuite.Generator.Selective +import qualified TestSuite.Generator.Shrinking +import qualified TestSuite.Generator.Simple + +main :: IO () +main = defaultMain $ testGroup "falsify" [ + testGroup "Generator" [ + TestSuite.Generator.Prim.tests + , TestSuite.Generator.Context.tests + , TestSuite.Generator.Selective.tests + , TestSuite.Generator.Marking.tests + , TestSuite.Generator.Precision.tests + , TestSuite.Generator.Simple.tests + , TestSuite.Generator.Shrinking.tests + , TestSuite.Generator.Compound.tests + , TestSuite.Generator.Function.tests + ] + ] diff --git a/test/TestSuite/Generator/Compound.hs b/test/TestSuite/Generator/Compound.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Generator/Compound.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TestSuite.Generator.Compound (tests) where + +import Control.Monad +import Data.Default +import Data.Foldable (toList) +import Data.Word +import Test.Tasty +import Test.Tasty.Falsify + +import Data.Falsify.Permutation (Permutation) +import Data.Falsify.Tree (Tree(..)) + +import Test.Falsify + +import qualified Data.Falsify.Permutation as Permutation +import qualified Data.Falsify.Tree as Tree +import qualified Test.Falsify.Generator as Gen +import qualified Test.Falsify.Predicate as P +import qualified Test.Falsify.Range as Range +import qualified Test.Falsify.ShrinkTree as ShrinkTree + +import TestSuite.Util.List + +{------------------------------------------------------------------------------- + List of tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "TestSuite.Generator.Compound" [ + testGroup "list" [ + testGroup "towardsShorter" [ + testProperty "shrinking" prop_list_towardsShorter_shrinking + , testProperty "minimum" prop_list_towardsShorter_minimum + ] + , testGroup "towardsShorterEven" [ + testPropertyWith expectFailure "shrinking" prop_list_towardsShorterEven_shrinking_wrong + , testProperty "minimum" prop_list_towardsShorterEven_minimum + ] + , testGroup "towardsLonger" [ + testProperty "shrinking" prop_list_towardsLonger_shrinking + , testProperty "minimum" prop_list_towardsLonger_minimum + ] + , testGroup "towardsOrigin" [ + testProperty "minimum" prop_list_towardsOrigin_minimum + ] + ] + , testGroup "perm" [ + testProperty "invariant" prop_perm_invariant + , testProperty "shrinking" prop_perm_shrinking + , testGroup "minimum" [ + testPropertyWith def{overrideMaxRatio = Just 1000} + (show n) $ prop_perm_minimum n + | n <- [0 .. 9] + ] + ] + , testGroup "tree" [ + testProperty "towardsSmaller1" prop_tree_towardsSmaller1 + , testProperty "towardsSmaller2" prop_tree_towardsSmaller2 + , testProperty "towardsOrigin1" prop_tree_towardsOrigin1 + , testProperty "towardsOrigin2" prop_tree_towardsOrigin2 + ] + , testGroup "shrinkTree" [ + testProperty "pathAny" prop_pathAny + , testProperty "toShrinkTree" prop_toShrinkTree + ] + , testGroup "frequency" [ + testProperty "shrinking" prop_frequency_shrinking + , testPropertyWith expectFailure + "shrinking_wrong" prop_frequency_shrinking_wrong + , testProperty "replicateM" prop_replicateM_shrinking + ] + ] + where + expectFailure :: TestOptions + expectFailure = def { + expectFailure = ExpectFailure + , overrideNumTests = Just 10_000 + } + +{------------------------------------------------------------------------------- + Lists + + Here and elsewhere, for the 'testMinimum' tests, we don't /always/ fail, but + check some property. This ensures that the minimum value isn't just always the + one produced by the @Minimal@ sample tree. +-------------------------------------------------------------------------------} + +prop_list_towardsShorter_shrinking :: Property () +prop_list_towardsShorter_shrinking = + testShrinkingOfGen (P.ge `P.on` P.fn ("length", length)) $ + Gen.list (Range.inclusive (10, 20)) $ + Gen.int $ Range.inclusive (0, 1) + +prop_list_towardsShorter_minimum :: Property () +prop_list_towardsShorter_minimum = + testMinimum (P.satisfies ("expectedLength", (== 10) . length)) $ do + xs <- gen $ Gen.list (Range.inclusive (10, 20)) $ + Gen.int $ Range.inclusive (0, 1) + unless (pairwiseAll (<=) xs) $ testFailed xs + +-- In principle the filtered list can /grow/ in size during shrinking (if +-- a previously odd number is shrunk to be even). +prop_list_towardsShorterEven_shrinking_wrong :: Property () +prop_list_towardsShorterEven_shrinking_wrong = + testShrinkingOfGen (P.ge `P.on` P.fn ("length", length)) $ + fmap (filter even) $ + Gen.list (Range.inclusive (10, 20)) $ + Gen.int $ Range.withOrigin (0, 10) 5 + +-- Although [6,4] is the perfect counter-example here, we don't always get it, +-- due to binary search +prop_list_towardsShorterEven_minimum :: Property () +prop_list_towardsShorterEven_minimum = + testMinimum (P.elem .$ ("expected", [[6,4],[8,6]])) $ do + xs <- gen $ fmap (filter even) $ + Gen.list (Range.inclusive (10, 20)) $ + Gen.int $ Range.withOrigin (0, 10) 5 + unless (pairwiseAll (<=) xs) $ testFailed xs + +prop_list_towardsLonger_shrinking :: Property () +prop_list_towardsLonger_shrinking = + testShrinkingOfGen (P.le `P.on` P.fn ("length", length)) $ + Gen.list (Range.inclusive (10, 0)) $ + Gen.int $ Range.inclusive (0, 1) + +prop_list_towardsLonger_minimum :: Property () +prop_list_towardsLonger_minimum = + testMinimum (P.satisfies ("expectedLength", (== 10) . length)) $ do + xs <- gen $ Gen.list (Range.inclusive (10, 0)) $ + Gen.int $ Range.inclusive (0, 1) + unless (pairwiseAll (<=) xs) $ testFailed xs + +prop_list_towardsOrigin_minimum :: Property () +prop_list_towardsOrigin_minimum = + testMinimum (P.satisfies ("expectedLength", (== 5) . length)) $ do + xs <- gen $ Gen.list (Range.withOrigin (0, 10) 5) $ + Gen.int $ Range.inclusive (0, 1) + unless (pairwiseAll (<=) xs) $ testFailed xs + +{------------------------------------------------------------------------------- + Permutations (and shuffling) +-------------------------------------------------------------------------------} + +validPermShrink :: Predicate [Permutation, Permutation] +validPermShrink = mconcat [ + P.ge `P.on` P.fn ("numSwaps", Permutation.size ) + , P.ge `P.on` P.fn ("distance", distance) + ] + where + distance :: Permutation -> Word + distance = sum . map weighted . Permutation.toSwaps + + -- This base 10 is justified only because we are generating permutations + -- for lists of length 10. + weighted :: (Word, Word) -> Word + weighted (i, j) + | i < j = error "unexpected swap" + | otherwise = (10 ^ i) * (i - j) + +prop_perm_invariant :: Property () +prop_perm_invariant = do + perm <- gen $ Gen.permutation 10 + assert $ + P.satisfies ("invariant", Permutation.invariant) + .$ ("perm", perm) + +prop_perm_shrinking :: Property () +prop_perm_shrinking = + testShrinkingOfGen validPermShrink $ + Gen.permutation 10 + +prop_perm_minimum :: Word -> Property () +prop_perm_minimum n = + testMinimum (P.satisfies ("suffixIsUnchanged", suffixIsUnchanged)) $ do + perm <- gen $ Gen.permutation 10 + let shuffled = Permutation.apply perm [0 .. 9] + when (shuffled !! fromIntegral n /= n) $ testFailed perm + where + suffixIsUnchanged :: Permutation -> Bool + suffixIsUnchanged perm = + case Permutation.toSwaps perm of + [(i, j)] -> i == j + 1 && (i == n || j == n) + _otherwise -> False + +{------------------------------------------------------------------------------- + Tree + + TODO: We're currently only testing minimums here. + TODO: These are discarding a lot of tests; is it expected that a randomly + generated tree is so often weight or heigh balanced..? +-------------------------------------------------------------------------------} + +prop_tree_towardsSmaller1 :: Property () +prop_tree_towardsSmaller1 = + testMinimum (P.satisfies ("expected", expected)) $ do + t <- gen $ Gen.tree (Range.inclusive (0, 100)) $ + Gen.int $ Range.inclusive (0, 1) + -- "Every tree is height balanced" + unless (Tree.isHeightBalanced t) $ testFailed t + where + expected :: Tree Int -> Bool + expected t = or [ + t == Branch 0 (Branch 0 Leaf (Branch 0 Leaf Leaf)) Leaf + , t == Branch 0 Leaf (Branch 0 Leaf (Branch 0 Leaf Leaf)) + ] + +prop_tree_towardsSmaller2 :: Property () +prop_tree_towardsSmaller2 = + testMinimum (P.elem .$ ("expected", expected)) $ do + t <- gen $ Gen.tree (Range.inclusive (0, 100)) $ + Gen.int $ Range.inclusive (0, 1) + -- "Every tree is weight balanced" + unless (Tree.isWeightBalanced t) $ testFailed t + where + -- For a minimal tree that is not weight-balanced, we need three elements in + -- one subtree and none in the other: the weight of the empty tree is 1, + -- the weight of the tree with three elements is 4, and 4 > Δ * 1, for Δ=3. + expected :: [Tree Int] + expected = [ + Branch 0 (Branch 0 (Branch 0 Leaf Leaf) (Branch 0 Leaf Leaf)) Leaf + , Branch 0 (Branch 0 Leaf (Branch 0 Leaf (Branch 0 Leaf Leaf))) Leaf + , Branch 0 Leaf (Branch 0 (Branch 0 Leaf Leaf) (Branch 0 Leaf Leaf)) + , Branch 0 Leaf (Branch 0 Leaf (Branch 0 Leaf (Branch 0 Leaf Leaf))) + ] + +prop_tree_towardsOrigin1 :: Property () +prop_tree_towardsOrigin1 = + testMinimum ( P.satisfies ("expected", expected) + `P.dot` P.fn ("size", Tree.size) + ) $ do + t <- gen $ Gen.tree (Range.withOrigin (0, 100) 10) $ pure () + unless (Tree.isHeightBalanced t) $ testFailed t + where + -- We can always find a non-balanced tree of roughly the specified size + -- (The /exact/ size might not always be reachable with single shrink steps) + expected :: Word -> Bool + expected sz = 8 <= sz && sz <= 10 + +prop_tree_towardsOrigin2 :: Property () +prop_tree_towardsOrigin2 = + testMinimum ( P.satisfies ("expected", expected) + `P.dot` P.fn ("size", Tree.size) + ) $ do + t <- gen $ Gen.tree (Range.withOrigin (0, 100) 10) $ pure () + unless (Tree.isWeightBalanced t) $ testFailed t + where + expected :: Word -> Bool + expected sz = 8 <= sz && sz <= 10 + +{------------------------------------------------------------------------------- + Shrink trees +-------------------------------------------------------------------------------} + +prop_pathAny :: Property () +prop_pathAny = + testMinimum (P.expect ["", "a", "aa"]) $ do + xs <- gen $ toList <$> Gen.pathAny st + unless (length xs < 3) $ testFailed xs + where + -- Infinite ShrinkTree containing all strings containing lowercase letters + st :: ShrinkTree String + st = ShrinkTree.unfold "" (\xs -> map (:xs) ['a' .. 'z']) + +prop_toShrinkTree :: Property () +prop_toShrinkTree = + testMinimum (P.satisfies ("expected", expected)) $ do + xs <- gen $ Gen.toShrinkTree genToTest >>= fmap toList . Gen.pathAny + unless (pairwiseAll (>) xs) $ testFailed xs + where + -- Should be any kind of path in which the last two pairs of numbers are + -- NOT decreasing. + expected :: [Word64] -> Bool + expected xs = + case reverse xs of + x : y : _ -> x >= y + _otherwise -> False + + genToTest :: Gen Word64 + genToTest = (`mod` 100) <$> Gen.prim + +{------------------------------------------------------------------------------- + Tweak test data distribution +-------------------------------------------------------------------------------} + +propShrinkingList1 :: [Word] -> [Word] -> Bool +propShrinkingList1 = aux + where + aux [_, _, _] [_, _] = True + aux [_, _, _] [_] = True + aux [_, _] [_] = True + aux [x] [x'] = x >= x' + aux [x, y] [x', y'] = x >= x' && y >= y' + aux [x, y, z] [x', y', z'] = x >= x' && y >= y' && z >= z' + aux _ _ = error "impossible" + +propShrinkingList2 :: [Word] -> [Word] -> Bool +propShrinkingList2 = aux + where + aux :: [Word] -> [Word] -> Bool + aux [x, y, _] [x', y'] = x >= x' && y >= y' + aux [x, _, _] [x'] = x >= x' + aux [x, _] [x'] = x >= x' + aux [x] [x'] = x >= x' + aux [x, y] [x', y'] = x >= x' && y >= y' + aux [x, y, z] [x', y', z'] = x >= x' && y >= y' && z >= z' + aux _ _ = error "impossible" + +genListFrequency :: Gen [Word] +genListFrequency = + Gen.frequency [ + (1, replicateM 1 $ Gen.inRange $ Range.inclusive (0, 10)) + , (2, replicateM 2 $ Gen.inRange $ Range.inclusive (0, 10)) + , (3, replicateM 3 $ Gen.inRange $ Range.inclusive (0, 10)) + ] + +genListMonad :: Gen [Word] +genListMonad = do + n <- Gen.inRange $ Range.inclusive (1, 3) + replicateM n $ Gen.inRange $ Range.inclusive (0, 10) + +prop_frequency_shrinking :: Property () +prop_frequency_shrinking = + testShrinkingOfGen + (P.relatedBy ("propShrinkingList1", propShrinkingList1)) + genListFrequency + +-- 'propShrinkingList2' does /not/ hold for 'genListFrequency' because the +-- generators are independent +prop_frequency_shrinking_wrong :: Property () +prop_frequency_shrinking_wrong = + testShrinkingOfGen + (P.relatedBy ("propShrinkingList2", propShrinkingList2)) + genListFrequency + +-- 'propShrinkingList2' /does/ hold if we simply use 'replicateM'. +prop_replicateM_shrinking :: Property () +prop_replicateM_shrinking = + testShrinkingOfGen + (P.relatedBy ("propShrinkingList2", propShrinkingList2)) + genListMonad diff --git a/test/TestSuite/Generator/Context.hs b/test/TestSuite/Generator/Context.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Generator/Context.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TestSuite.Generator.Context (tests) where + +import Test.Tasty +import Test.Tasty.Falsify + +import qualified Data.Tree as Rose + +import Test.Falsify +import Test.Falsify.SampleTree (Sample(..)) + +import qualified Test.Falsify.Context as Context +import qualified Test.Falsify.Generator as Gen +import qualified Test.Falsify.Predicate as P +import Data.Bifunctor + +{------------------------------------------------------------------------------- + List of tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "TestSuite.Generator.Context" [ + testGroup "Sanity" [ + testProperty "toShrinkTree1" sanity_toShrinkTree1 + , testProperty "toShrinkTree2" sanity_toShrinkTree2 + ] + ] + +{------------------------------------------------------------------------------- + 'toShrinkTree' +-------------------------------------------------------------------------------} + +sanity_toShrinkTree1 :: Property () +sanity_toShrinkTree1 = do + shrinkTree <- gen $ Gen.toShrinkTreeWithContext True (const g) + assert $ + P.expect expected `P.dot` P.transparent hideNotShrunk + .$ ("shrinkTree", shrinkTree) + where + g :: Gen Sample + g = Gen.primWith (\case + NotShrunk _ -> [0..2] + Shrunk 0 -> [] + Shrunk 1 -> [0] + Shrunk x -> [0, x - 1] + ) + + expected :: ShrinkTree (Context.Execution, Sample) + expected = WrapShrinkTree $ + Rose.Node (Context.Initial, NotShrunk 0) [ + Rose.Node (Context.Shrinking 0, Shrunk 0) [ + Rose.Node (Context.Final 1, Shrunk 0) [] + ] + , Rose.Node (Context.Shrinking 0, Shrunk 1) [ + Rose.Node (Context.Shrinking 1, Shrunk 0) [ + Rose.Node (Context.Final 2, Shrunk 0) [] + ] + ] + , Rose.Node (Context.Shrinking 0, Shrunk 2) [ + Rose.Node (Context.Shrinking 1, Shrunk 0) [ + Rose.Node (Context.Final 2, Shrunk 0) [] + ] + , Rose.Node (Context.Shrinking 1, Shrunk 1) [ + Rose.Node (Context.Shrinking 2, Shrunk 0) [ + Rose.Node (Context.Final 3,Shrunk 0) [] + ] + ] + ] + ] + +sanity_toShrinkTree2 :: Property () +sanity_toShrinkTree2 = do + shrinkTree <- gen $ Gen.toShrinkTreeWithContext True (const g) + assert $ + P.expect expected `P.dot` P.transparent hideNotShrunk + .$ ("shrinkTree", shrinkTree) + where + g :: Gen Sample + g = Gen.primWith (const []) + + expected :: ShrinkTree (Context.Execution, Sample) + expected = WrapShrinkTree $ + Rose.Node (Context.Initial, NotShrunk 0) [ + Rose.Node (Context.Final 0, NotShrunk 0) [] + ] + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +-- | \"Hide\" unshrunk samples, so that we have deterministic output +hideNotShrunk :: ShrinkTree (ctxt, Sample) -> ShrinkTree (ctxt, Sample) +hideNotShrunk = fmap . second $ \case + NotShrunk _ -> NotShrunk 0 + Shrunk x -> Shrunk x diff --git a/test/TestSuite/Generator/Function.hs b/test/TestSuite/Generator/Function.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Generator/Function.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TestSuite.Generator.Function (tests) where + +import Control.Monad +import Data.Default +import Data.Word +import Test.Tasty +import Test.Tasty.Falsify + +import qualified Data.Set as Set + +import Test.Falsify +import qualified Test.Falsify.Generator as Gen +import qualified Test.Falsify.Predicate as P +import qualified Test.Falsify.Range as Range + +{------------------------------------------------------------------------------- + List of tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "TestSuite.Generator.Function" [ + testGroup "BoolToBool" [ + testProperty "notConstant" prop_BoolToBool_notConstant + , testProperty "constant" prop_BoolToBool_constant + ] + , testProperty "Word8ToBool" prop_Word8ToBool + , testPropertyWith fewerTests "IntegerToBool" prop_IntegerToBool + , testProperty "IntToInt" prop_IntToInt + , testPropertyWith fewerTests "StringToBool" prop_StringToBool + ] + where + -- These tests are pretty slow + fewerTests :: TestOptions + fewerTests = def { + overrideNumTests = Just 10 + } + +{------------------------------------------------------------------------------- + Functions @Bool -> Bool@ + + TODO: Should we define these in terms of the concrete functions instead? +-------------------------------------------------------------------------------} + +prop_BoolToBool_notConstant :: Property () +prop_BoolToBool_notConstant = + testMinimum (P.satisfies ("isConstant", isConstant)) $ do + fn <- gen $ Gen.fun (Gen.bool False) + let Fn f = fn + -- "No function Bool -> Bool can be constant" + unless (f False /= f True) $ testFailed fn + where + isConstant :: Fun Bool Bool -> Bool + isConstant fn = show fn == "{_->False}" + +prop_BoolToBool_constant :: Property () +prop_BoolToBool_constant = do + testMinimum (P.satisfies ("notConstant", notConstant)) $ do + fn <- gen $ Gen.fun (Gen.bool False) + let Fn f = fn + -- "Every function Bool -> Bool is constant" + unless (f False == f True) $ testFailed fn + where + notConstant :: Fun Bool Bool -> Bool + notConstant fn = or [ + show fn == "{True->True, _->False}" + , show fn == "{False->True, _->False}" + ] + +{------------------------------------------------------------------------------- + Functions @Word8 -> Bool@ +-------------------------------------------------------------------------------} + +prop_Word8ToBool :: Property () +prop_Word8ToBool = do + testMinimum (P.satisfies ("notConstant", notConstant)) $ do + fn <- gen $ Gen.fun (Gen.bool False) + -- "Every function Word8 -> Bool is constant" + unless (isConstant fn) $ testFailed fn + where + notConstant :: Fun Word8 Bool -> Bool + notConstant fn = any aux [0 .. 255] + where + aux :: Word8 -> Bool + aux n = show fn == "{" ++ show n ++ "->True, _->False}" + + isConstant :: Fun Word8 Bool -> Bool + isConstant (Fn f) = + (\s -> Set.size s == 1) $ + Set.fromList (map f [minBound .. maxBound]) + +{------------------------------------------------------------------------------- + Functions @Integer -> Bool@ + + This is the first test where the input domain is infinite. +-------------------------------------------------------------------------------} + +prop_IntegerToBool :: Property () +prop_IntegerToBool = + testMinimum (P.satisfies ("expected", expected)) $ do + fn <- gen $ Gen.fun (Gen.bool False) + let Fn f = fn + -- "Every fn from Integer to Bool must give the same result for π and φ" + unless (f 3142 == f 1618) $ testFailed fn + where + expected :: Fun Integer Bool -> Bool + expected fn = or [ + show fn == "{1618->True, _->False}" + , show fn == "{3142->True, _->False}" + ] + +{------------------------------------------------------------------------------- + Functions @Int -> Int@ +-------------------------------------------------------------------------------} + +prop_IntToInt :: Property () +prop_IntToInt = + testMinimum (P.satisfies ("expected", expected)) $ do + fn <- gen $ Gen.fun (Gen.inRange $ Range.inclusive (0, 100)) + let Fn f = fn + unless (f 0 == 0 && f 1 == 0) $ testFailed fn + where + expected :: Fun Int Int -> Bool + expected fn = or [ + show fn == "{1->1, _->0}" + , show fn == "{0->1, _->0}" + ] + +{------------------------------------------------------------------------------- + Functions @String -> Bool@ + + This example (as well as 'test_IntToInt_mapFilter') is adapted from + Koen Claessen's presentation "Shrinking and showing functions" + at Haskell Symposium 2012 . + + TODO: His example uses longer strings, which does work, it's just expensive. + We can definitely use some performance optimization here. +-------------------------------------------------------------------------------} + +prop_StringToBool :: Property () +prop_StringToBool = + testMinimum (P.satisfies ("expected", expected)) $ do + fn <- gen $ Gen.fun (Gen.bool False) + let Fn p = fn + unless (p "abc" `implies` p "def") $ testFailed fn + where + -- TODO: Actually, the second case doesn't seem to get triggered. Not sure + -- why; maybe it's just unlikely..? + expected :: Fun String Bool -> Bool + expected fn = or [ + show fn == "{\"abc\"->True, _->False}" + , show fn == "{\"def\"->True, _->False}" + ] + + implies :: Bool -> Bool -> Bool + implies False _ = True + implies True b = b diff --git a/test/TestSuite/Generator/Marking.hs b/test/TestSuite/Generator/Marking.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Generator/Marking.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TestSuite.Generator.Marking (tests) where + +import Control.Monad +import Data.Map (Map) +import Data.Maybe (catMaybes) +import Data.Word +import Test.Tasty +import Test.Tasty.Falsify + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Test.Falsify +import qualified Test.Falsify.Generator as Gen hiding (mark) +import qualified Test.Falsify.Marked as Marked +import qualified Test.Falsify.Predicate as P + +import TestSuite.Util.List + +{------------------------------------------------------------------------------- + List of tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "TestSuite.Generator.Marking" [ + testGroup "list" [ + testProperty "shrinking" prop_list_shrinking + , testProperty "minimum" prop_list_minimum + ] + ] + +{------------------------------------------------------------------------------- + Marking +-------------------------------------------------------------------------------} + +-- | Mark an element +-- +-- Marks as 'Drop' with 50% probability. +-- +-- We avoid using 'Gen.mark' here, which depends on @shrinkTo@. This version +-- uses only 'Gen.prim'; the difference in behaviour is that this version of +-- @mark@ can produce elements that are marked as drop from the get-go. +mark :: Gen a -> Gen (Marked Gen a) +mark x = flip Marked x <$> (aux <$> Gen.prim) + where + aux :: Word64 -> Mark + aux n = if n >= maxBound `div` 2 then Keep else Drop + +{------------------------------------------------------------------------------- + List +-------------------------------------------------------------------------------} + +genMarkedList :: Gen [(Word, Word64)] +genMarkedList = do + xs <- forM [0 .. 9] (\i -> mark ((i, ) <$> Gen.prim)) + catMaybes <$> Marked.selectAllKept xs + +prop_list_shrinking :: Property () +prop_list_shrinking = + testShrinkingOfGen + ( mconcat [ + P.flip (P.relatedBy ("isSubsetOf", Set.isSubsetOf)) + `P.on` P.fn ("keysSet", Map.keysSet) + , P.relatedBy ("shrunkCod", shrunkCod) + ] + `P.on` P.transparent Map.fromList + ) + genMarkedList + where + shrunkCod :: Map Word Word64 -> Map Word Word64 -> Bool + shrunkCod orig shrunk = and [ + -- The 'shrunkDom' check justifies the use of @(!)@ here + orig Map.! k >= v + | (k, v) <- Map.toList shrunk + ] + +prop_list_minimum :: Property () +prop_list_minimum = + testMinimum (P.satisfies ("expected", expected)) $ do + xs <- gen $ genMarkedList + case xs of + (0, _):_ -> discard + _otherwise -> return () + unless (pairwiseAll (==) $ map snd xs) $ testFailed xs + where + expected :: [(Word, Word64)] -> Bool + expected [(i, 0), (j, 1)] | i < j = True + expected _otherwise = False diff --git a/test/TestSuite/Generator/Precision.hs b/test/TestSuite/Generator/Precision.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Generator/Precision.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TestSuite.Generator.Precision (tests) where + +import Control.Monad + +import Data.Falsify.ProperFraction (ProperFraction(..)) +import Test.Tasty +import Test.Tasty.Falsify + +import Test.Falsify +import qualified Data.Falsify.WordN as WordN +import qualified Test.Falsify.Generator as Gen +import qualified Test.Falsify.Predicate as P + +{------------------------------------------------------------------------------- + List of tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "TestSuite.Generator.Precision" [ + testGroup "wordN" [ + testGroup (show p) [ + testProperty "shrinking" $ prop_wordN_shrinking p + , testProperty "minimum" $ prop_wordN_minimum p + ] + | p <- map WordN.Precision [0, 1, 2, 3, 63, 64] + ] + , testGroup "fraction" [ + testGroup (show p) [ + testProperty "shrinking" $ + prop_fraction_shrinking (WordN.Precision p) + , testProperty "minimum" $ + prop_fraction_minimum (WordN.Precision p) target expected + ] + | (p, target, expected) <- [ + -- The higher the precision, the closer we can get to the target + (2 , 50, 75) + , (3 , 50, 62) + , (4 , 50, 56) + , (5 , 50, 53) + , (63 , 50, 51) + , (64 , 50, 51) + ] + ] + ] + +{------------------------------------------------------------------------------- + wordN +-------------------------------------------------------------------------------} + +prop_wordN_shrinking :: WordN.Precision -> Property () +prop_wordN_shrinking p = + testShrinkingOfGen P.ge $ Gen.wordN p + +prop_wordN_minimum :: WordN.Precision -> Property () +prop_wordN_minimum p = + testMinimum (P.expect $ WordN.zero p) $ do + x <- gen $ Gen.wordN p + testFailed x + +{------------------------------------------------------------------------------- + fraction +-------------------------------------------------------------------------------} + +prop_fraction_shrinking :: WordN.Precision -> Property () +prop_fraction_shrinking p = + testShrinkingOfGen P.ge $ Gen.properFraction p + +prop_fraction_minimum :: WordN.Precision -> Word -> Word -> Property () +prop_fraction_minimum p target expected = + testMinimum ((P.expect expected) `P.dot` P.fn ("pct", pct)) $ do + x <- gen $ Gen.properFraction p + unless (pct x <= target) $ testFailed x + where + pct :: ProperFraction -> Word + pct (ProperFraction f) = round (f * 100) diff --git a/test/TestSuite/Generator/Prim.hs b/test/TestSuite/Generator/Prim.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Generator/Prim.hs @@ -0,0 +1,389 @@ +{-# 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 diff --git a/test/TestSuite/Generator/Selective.hs b/test/TestSuite/Generator/Selective.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Generator/Selective.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TestSuite.Generator.Selective (tests) where + +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 + +{------------------------------------------------------------------------------- + List of tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "TestSuite.Generator.Selective" [ + testGroup "pair" [ + testProperty "ifM" $ prop_pair ifM + , testPropertyWith expectFailure "ifS" $ prop_pair ifS + , testProperty "ifThenElse" $ prop_pair_ifThenElse + ] + ] + where + expectFailure :: TestOptions + expectFailure = def { + expectFailure = ExpectFailure + , overrideNumTests = Just 10_000 + } + + +{------------------------------------------------------------------------------- + Either + + We only only primitive generators here (avoiding generators like + 'Test.Falsify.Reexported.Generator.Simple.bool') to avoid getting distracted + by specific implementation details of derived generators. +-------------------------------------------------------------------------------} + +-- If we use monadic bind, the seed for the Right value is reused when +-- when we shrink it to Left: they are not independent. +-- +-- Here this is still somewhat reasonable, but in general this means we +-- will reuse a seed reduced in one context in a completely different +-- context, which may not make any sense at all. +propEither :: + (Word64, Either Word64 Word64) + -> (Word64, Either Word64 Word64) + -> Bool +propEither _ (_, Left 0) = True -- Can always shrink to 'Minimal' +propEither (_, Right x) (_, Left y) = x == y +propEither _ _ = True + +genPair :: + (forall a. Gen Bool -> Gen a -> Gen a -> Gen a) + -> Gen (Word64, Either Word64 Word64) +genPair if_ = + (,) <$> Gen.prim + <*> if_ ((== 0) <$> Gen.prim) + (Left <$> Gen.exhaustive 100) + (Right <$> Gen.exhaustive 100) + +prop_pair :: (forall a. Gen Bool -> Gen a -> Gen a -> Gen a) -> Property () +prop_pair if_ = + testShrinkingOfGen (P.relatedBy ("propEither", propEither)) $ + genPair if_ + +prop_pair_ifThenElse :: Property () +prop_pair_ifThenElse = + testShrinking (P.relatedBy ("stayRight", stayRight)) $ do + pair <- gen $ genPair ifBoth + when (prop pair) $ testFailed pair + where + prop :: (Word64, Either Word64 Word64) -> Bool + prop (x, Right y) = x < 10 || y > x + prop (x, Left y) = x < 1 || y < x + + -- Since we are generating the left value before the right value, if we + -- /start/ with a right value, we will then shrink the left value first even + -- though it is not used: indeed, this /must/ always succeed precisely + -- /because/ that left value is not used. At that point we can no longer + -- reduce the Right to a Left, because @Left 0@ is not a counterexample. + stayRight :: + (Word64, Either Word64 Word64) + -> (Word64, Either Word64 Word64) + -> Bool + stayRight _ (_, Left 0) = True -- Can always shrink to 'Minimal' + stayRight (_, Right _) (_, Left _) = False + stayRight _ _ = True + +{------------------------------------------------------------------------------- + Generic auxiliary +-------------------------------------------------------------------------------} + +ifM :: Gen Bool -> Gen a -> Gen a -> Gen a +ifM cond t f = cond `Gen.bindWithoutShortcut` \b -> if b then t else f + +ifBoth :: Gen Bool -> Gen a -> Gen a -> Gen a +ifBoth cond t f = + t `Gen.bindWithoutShortcut` \x -> + f `Gen.bindWithoutShortcut` \y -> + cond `Gen.bindWithoutShortcut` \b -> + return $ if b then x else y diff --git a/test/TestSuite/Generator/Shrinking.hs b/test/TestSuite/Generator/Shrinking.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Generator/Shrinking.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TestSuite.Generator.Shrinking (tests) where + +import Control.Monad +import Data.Bits +import Data.Default +import Data.Int +import Data.Proxy +import Data.Word +import Test.Tasty +import Test.Tasty.Falsify + +import qualified Test.QuickCheck as QuickCheck + +import Test.Falsify +import qualified Test.Falsify.Generator as Gen +import qualified Test.Falsify.Predicate as P +import qualified Test.Falsify.Range as Range + +import TestSuite.Util.List + +{------------------------------------------------------------------------------- + List of tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "TestSuite.Generator.Shrinking" [ + testGroup "prim" [ + testPropertyWith expectFailure "prim" prop_prim_minimum + ] + , testGroup "uniform" [ + testProperty "Word8" $ prop_uniform (Proxy @Word8) + , testProperty "Word16" $ prop_uniform (Proxy @Word16) + , testProperty "Word32" $ prop_uniform (Proxy @Word32) + , testProperty "Word64" $ prop_uniform (Proxy @Word64) + , testProperty "Word" $ prop_uniform (Proxy @Word) + , testProperty "Int8" $ prop_uniform (Proxy @Int8) + , testProperty "Int16" $ prop_uniform (Proxy @Int16) + , testProperty "Int32" $ prop_uniform (Proxy @Int32) + , testProperty "Int64" $ prop_uniform (Proxy @Int64) + , testProperty "Int" $ prop_uniform (Proxy @Int) + ] + , testGroup "shrinkTo" [ + testProperty "shrinking" prop_shrinkTo_shrinking + , testProperty "minimum" prop_shrinkTo_minimum + ] + , testGroup "firstThen" [ + testProperty "shrinking" prop_firstThen_shrinking + , testProperty "minimum" prop_firstThen_minimum + ] + , testGroup "shrinkWith" [ + testGroup "minimum" [ + testProperty "minimum" prop_shrinkWith_minimum_word + , testGroup "list" [ + testProperty (show i) $ prop_shrinkWith_minimum_list i + | i <- [20, 40, 60, 80, 100, 120, 140, 160, 180] + ] + ] + ] + ] + where + expectFailure :: TestOptions + expectFailure = def { + expectFailure = ExpectFailure + , overrideNumTests = Just 10_000 + } + +{------------------------------------------------------------------------------- + prim +-------------------------------------------------------------------------------} + +-- Binary search is not guaranteed to always find the minimum value. For +-- example, if we are looking for counter-examples to the property that "all +-- numbers are even", and we start with 3, then binary search will only try 0 +-- and 2, both of which are even, and hence conclude that 3 is the minimum +-- counter-example. This is true in QuickCheck, also. +prop_prim_minimum :: Property () +prop_prim_minimum = + testMinimum (P.expect 1) $ do + x <- gen Gen.prim + unless (even x) $ testFailed x + +{------------------------------------------------------------------------------- + uniform +-------------------------------------------------------------------------------} + +prop_uniform :: forall a. + (Show a, FiniteBits a, Integral a, Bounded a) + => Proxy a -> Property () +prop_uniform _ = + testShrinkingOfGen (P.relatedBy ("validShrink", validShrink)) $ + Gen.inRange Range.uniform + where + -- We must be getting closer to 0 + validShrink :: a -> a -> Bool + validShrink orig shrunk + | orig >= 0 = shrunk < orig + | otherwise = shrunk > orig + +{------------------------------------------------------------------------------- + shrinkTo +-------------------------------------------------------------------------------} + +prop_shrinkTo_shrinking :: Property () +prop_shrinkTo_shrinking = + testShrinkingOfGen (P.relatedBy ("validShrink", validShrink)) $ + Gen.shrinkToOneOf 3 [0 :: Word .. 2] + where + -- 'shrinkToOneOf' only shrinks /once/, so the original (pre-shrink) value + -- /must/ be 3. + validShrink :: Word -> Word -> Bool + validShrink 3 0 = True + validShrink 3 1 = True + validShrink 3 2 = True + validShrink _ _ = False + +prop_shrinkTo_minimum :: Property () +prop_shrinkTo_minimum = + testMinimum (P.expect 1) $ do + x <- gen $ Gen.shrinkToOneOf 3 [0 :: Word .. 2] + unless (even x) $ testFailed x + +{------------------------------------------------------------------------------- + firstThen +-------------------------------------------------------------------------------} + +prop_firstThen_shrinking :: Property () +prop_firstThen_shrinking = + testShrinkingOfGen (P.relatedBy ("validShrink", validShrink)) $ + Gen.firstThen True False + where + validShrink :: Bool -> Bool -> Bool + validShrink True False = True + validShrink _ _ = False + +prop_firstThen_minimum :: Property () +prop_firstThen_minimum = + testMinimum (P.expect False) $ do + x <- gen $ Gen.firstThen True False + testFailed x + +{------------------------------------------------------------------------------- + shrinkWith +-------------------------------------------------------------------------------} + +-- This is obviously not a valid general-purpose shrinking function for +-- 'Word64', but that is not important here. +shrinkWord :: Word64 -> [Word64] +shrinkWord n = takeWhile (< n) [0 .. 100] + +prop_shrinkWith_minimum_word :: Property () +prop_shrinkWith_minimum_word = + testMinimum (P.expect 1) $ do + x <- gen $ Gen.shrinkWith shrinkWord Gen.prim + unless (even x) $ testFailed x + +-- | Test performance of 'shrinkWith' +-- +-- We test this for lists of increasing size, to verify that this is not growing +-- exponentially with the size of the list (and thereby verifying that we are +-- not exploring the full shrink tree of those lists, because they certainly +-- /are/ exponential in size). +prop_shrinkWith_minimum_list :: Int -> Property () +prop_shrinkWith_minimum_list listLength = + testMinimum (P.expect [1,0]) $ do + xs <- gen $ Gen.shrinkWith (QuickCheck.shrinkList shrinkWord) $ + replicateM listLength Gen.prim + unless (pairwiseAll (<=) xs) $ testFailed xs diff --git a/test/TestSuite/Generator/Simple.hs b/test/TestSuite/Generator/Simple.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Generator/Simple.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TestSuite.Generator.Simple (tests) where + +import Control.Monad (unless) +import Data.Bits +import Data.List (intercalate) +import Data.Proxy +import Data.Typeable +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 qualified Test.Falsify.Range as Range + +{------------------------------------------------------------------------------- + List of tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "TestSuite.Generator.Simple" [ + testGroup "prim" [ + testProperty "shrinking" prop_prim_shrinking + , testGroup "minimum" [ + testProperty (show target) $ prop_prim_minimum target + | target <- [0 .. 4] + ] + ] + , testGroup "bool" [ + testGroup "towardsFalse" [ + testProperty "shrinking" $ prop_bool_shrinking False + , testProperty "minimum" $ prop_bool_minimum False + ] + , testGroup "towardsTrue" [ + testProperty "shrinking" $ prop_bool_shrinking True + , testProperty "minimum" $ prop_bool_minimum True + ] + ] + , testGroup "int" [ + testGroup "between" [ + testGroup (intercalate "_" [show x, show y]) [ + testProperty "shrinking" $ prop_int_between_shrinking (x, y) + , testGroup "minimum" [ + testProperty (show target) $ + prop_int_between_minimum (x, y) target + | target <- [0, 1, 99, 100] + ] + ] + | (x, y) <- [ + ( 0, 0) + , ( 0, 10) + , ( 0, 100) + , ( 10, 0) + , ( 10, 10) + , ( 10, 100) + , (100, 0) + , (100, 10) + , (100, 100) + ] + ] + , let test_int_withOrigin :: forall a. + (Typeable a, Show a, Integral a, FiniteBits a) + => Proxy a -> TestTree + test_int_withOrigin p = testGroup (show $ typeRep p) [ + testGroup (intercalate "_" [show x, show y, show o]) [ + testProperty "shrinking" $ + prop_integral_withOrigin_shrinking @a (x, y) o + , testGroup "minimum" [ + testProperty (show target) $ + prop_integral_withOrigin_minimum (x, y) o target + | target <- [0, 1, 49, 50, 51, 99, 100] + ] + ] + | ((x, y), o) <- [ + ((0, 10), 0) + , ((0, 10), 10) + , ((0, 10), 5) + , ((0, 100), 0) + , ((0, 100), 100) + , ((0, 100), 50) + ] + ] + in testGroup "withOrigin" [ + test_int_withOrigin (Proxy @Int) + , test_int_withOrigin (Proxy @Word) + ] + ] + , testGroup "char" [ + testGroup "enum" [ + testProperty "shrinking" $ prop_char_enum_shrinking ('a', 'z') + ] + ] + ] + + +{------------------------------------------------------------------------------- + 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 + +{------------------------------------------------------------------------------- + Bool +-------------------------------------------------------------------------------} + +prop_bool_shrinking :: Bool -> Property () +prop_bool_shrinking False = testShrinkingOfGen P.ge $ Gen.bool False +prop_bool_shrinking True = testShrinkingOfGen P.le $ Gen.bool True + +prop_bool_minimum :: Bool -> Property () +prop_bool_minimum target = + testMinimum (P.expect target) $ do + b <- gen $ Gen.bool target + testFailed b + +{------------------------------------------------------------------------------- + Range: 'between' + + This implicitly tests generation of fractions as well as determining + precision. +-------------------------------------------------------------------------------} + +prop_int_between_shrinking :: (Int, Int) -> Property () +prop_int_between_shrinking (x, y) + | x <= y = testShrinkingOfGen P.ge $ Gen.inRange $ Range.inclusive (x, y) + | otherwise = testShrinkingOfGen P.le $ Gen.inRange $ Range.inclusive (x, y) + +prop_int_between_minimum :: (Int, Int) -> Int -> Property () +prop_int_between_minimum (x, y) _target | x == y = + testMinimum (P.expect x) $ do + n <- gen $ Gen.inRange $ Range.inclusive (x, y) + -- The only value we can produce here is @x@, so no point looking for + -- anything these (that would just result in all tests being discarded) + testFailed n +prop_int_between_minimum (x, y) target = + testMinimum (P.expect expected) $ do + n <- gen $ Gen.inRange $ Range.inclusive (x, y) + unless (n == target) $ testFailed n + where + expected :: Int + expected + | x < y = if target == x then x + 1 else x + | otherwise = if target == x then x - 1 else x + +{------------------------------------------------------------------------------- + Range: 'withOrigin' +-------------------------------------------------------------------------------} + +prop_integral_withOrigin_shrinking :: + (Show a, Integral a, FiniteBits a) + => (a, a) -> a -> Property () +prop_integral_withOrigin_shrinking (x, y) o = + testShrinkingOfGen (P.towards o) $ + Gen.inRange $ Range.withOrigin (x, y) o + +prop_integral_withOrigin_minimum :: forall a. + (Show a, Integral a, FiniteBits a) + => (a, a) -> a -> a -> Property () +prop_integral_withOrigin_minimum (x, y) o _target | x == y = + testMinimum (P.expect x) $ do + -- See discussion in 'prop_int_between_minimum' + n <- gen $ Gen.inRange $ Range.withOrigin (x, y) o + testFailed n +prop_integral_withOrigin_minimum (x, y) o target = + testMinimum (P.elem .$ ("expected", expected)) $ do + n <- gen $ Gen.inRange $ Range.withOrigin (x, y) o + unless (n == target) $ testFailed n + where + expected :: [a] + expected + | target == o = [o + 1, o - 1] + | otherwise = [o] + +{------------------------------------------------------------------------------- + Range: 'enum' +-------------------------------------------------------------------------------} + +prop_char_enum_shrinking :: (Char, Char) -> Property () +prop_char_enum_shrinking (x, y) + | x <= y = testShrinkingOfGen P.ge $ Gen.inRange $ Range.enum (x, y) + | otherwise = testShrinkingOfGen P.le $ Gen.inRange $ Range.enum (x, y) diff --git a/test/TestSuite/Util/List.hs b/test/TestSuite/Util/List.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Util/List.hs @@ -0,0 +1,16 @@ +module TestSuite.Util.List ( + -- * Predicates + pairwiseAll + ) where + +{------------------------------------------------------------------------------- + Predicates +-------------------------------------------------------------------------------} + +pairwiseAll :: forall a. (a -> a -> Bool) -> [a] -> Bool +pairwiseAll p = go + where + go :: [a] -> Bool + go [] = True + go [_] = True + go (x:y:zs) = p x y && go (y:zs)