├── cabal.haskell-ci ├── .gitignore ├── README.md ├── cabal.project ├── cabal.project.ci ├── demo ├── template │ └── Main.hs ├── demo │ ├── Main.hs │ └── Demo │ │ ├── Functions.hs │ │ ├── TestShrinking.hs │ │ ├── Distribution.hs │ │ ├── TestOptions.hs │ │ └── Blogpost.hs ├── LICENSE └── demo.cabal ├── lib ├── test │ ├── TestSuite │ │ ├── Util │ │ │ ├── List.hs │ │ │ └── Tree.hs │ │ ├── Sanity │ │ │ ├── Predicate.hs │ │ │ ├── Range.hs │ │ │ └── Selective.hs │ │ ├── Prop │ │ │ └── Generator │ │ │ │ ├── Precision.hs │ │ │ │ ├── Marking.hs │ │ │ │ ├── Selective.hs │ │ │ │ ├── Shrinking.hs │ │ │ │ ├── Function.hs │ │ │ │ ├── Simple.hs │ │ │ │ ├── Compound.hs │ │ │ │ └── Prim.hs │ │ └── GenDefault.hs │ └── Main.hs ├── src │ ├── Test │ │ ├── Falsify │ │ │ ├── Property.hs │ │ │ ├── Internal │ │ │ │ ├── Generator.hs │ │ │ │ ├── Driver │ │ │ │ │ ├── ReplaySeed.hs │ │ │ │ │ └── Tasty.hs │ │ │ │ ├── Range.hs │ │ │ │ ├── Search.hs │ │ │ │ ├── Generator │ │ │ │ │ ├── Shrinking.hs │ │ │ │ │ └── Definition.hs │ │ │ │ └── SampleTree.hs │ │ │ ├── Reexported │ │ │ │ └── Generator │ │ │ │ │ ├── Simple.hs │ │ │ │ │ ├── Precision.hs │ │ │ │ │ ├── Shrinking.hs │ │ │ │ │ └── Function.hs │ │ │ ├── GenDefault │ │ │ │ └── Std.hs │ │ │ ├── Generator.hs │ │ │ ├── Interactive.hs │ │ │ ├── GenDefault.hs │ │ │ └── Range.hs │ │ └── Tasty │ │ │ └── Falsify.hs │ └── Data │ │ └── Falsify │ │ ├── Marked.hs │ │ ├── Integer.hs │ │ ├── List.hs │ │ └── Tree.hs ├── CHANGELOG.md ├── LICENSE └── falsify.cabal └── .github └── workflows └── haskell-ci.yml /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | cabal-check: False 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | unversioned 2 | dist-newstyle 3 | .envrc 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # `falsify`—internal shrinking reimagined for Haskell 2 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: lib, demo 2 | 3 | allow-newer: sop-core:base 4 | 5 | package falsify 6 | tests: true 7 | -------------------------------------------------------------------------------- /cabal.project.ci: -------------------------------------------------------------------------------- 1 | packages: lib, demo 2 | 3 | allow-newer: sop-core:base 4 | 5 | package falsify 6 | tests: true 7 | ghc-options: -Werror 8 | -------------------------------------------------------------------------------- /demo/template/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.Tasty 4 | import Test.Tasty.Falsify 5 | 6 | main :: IO () 7 | main = defaultMain $ testGroup "MyTestSuite" [ 8 | testProperty "myFirstProperty" prop_myFirstProperty 9 | ] 10 | 11 | prop_myFirstProperty :: Property () 12 | prop_myFirstProperty = return () 13 | -------------------------------------------------------------------------------- /lib/test/TestSuite/Util/List.hs: -------------------------------------------------------------------------------- 1 | module TestSuite.Util.List ( 2 | -- * Predicates 3 | pairwiseAll 4 | ) where 5 | 6 | {------------------------------------------------------------------------------- 7 | Predicates 8 | -------------------------------------------------------------------------------} 9 | 10 | pairwiseAll :: forall a. (a -> a -> Bool) -> [a] -> Bool 11 | pairwiseAll p = go 12 | where 13 | go :: [a] -> Bool 14 | go [] = True 15 | go [_] = True 16 | go (x:y:zs) = p x y && go (y:zs) 17 | -------------------------------------------------------------------------------- /demo/demo/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.Tasty 4 | 5 | import qualified Demo.Blogpost 6 | import qualified Demo.Distribution 7 | import qualified Demo.Functions 8 | import qualified Demo.HowToSpecifyIt 9 | import qualified Demo.TestOptions 10 | import qualified Demo.TestShrinking 11 | 12 | main :: IO () 13 | main = defaultMain $ testGroup "demo" [ 14 | Demo.TestOptions.tests 15 | , Demo.Functions.tests 16 | , Demo.TestShrinking.tests 17 | , Demo.Distribution.tests 18 | , Demo.HowToSpecifyIt.tests 19 | , Demo.Blogpost.tests 20 | ] 21 | -------------------------------------------------------------------------------- /lib/src/Test/Falsify/Property.hs: -------------------------------------------------------------------------------- 1 | -- | Properties 2 | -- 3 | -- Intended for unqualified import. 4 | -- 5 | -- Most users will probably use "Test.Tasty.Falsify" instead of this module. 6 | module Test.Falsify.Property ( 7 | Property' -- opaque 8 | , Property 9 | -- * Run generators 10 | , gen 11 | , genWith 12 | -- * 'Property' features 13 | , testFailed 14 | , assert 15 | , info 16 | , discard 17 | , label 18 | , collect 19 | -- * Testing shrinking 20 | , testShrinking 21 | , testMinimum 22 | -- * Testing generators 23 | , testGen 24 | , testShrinkingOfGen 25 | ) where 26 | 27 | import Test.Falsify.Internal.Property 28 | 29 | -- | Property that uses strings as errors 30 | type Property = Property' String -------------------------------------------------------------------------------- /lib/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for falsify 2 | 3 | ## 0.2.1 -- 2023-12-xx 4 | 5 | * Relax upper bound of `optparse-applicative` 6 | 7 | ## 0.2.0 -- 2023-11-08 8 | 9 | * Avoid use of `Expr` in `at` (#48) 10 | * Add `oneof` (#54; Simon Kohlmeyer) 11 | * Generalize `Range`, so that it can be used for types like `Char` (#51). 12 | As a consequence, `Gen.integral` and `Gen.enum` are now deprecated, and 13 | superseded by `Gen.inRange`. 14 | * Add `GenDefault` class and `DerivingVia` helpers to derive generators 15 | (Eric Conlon; #61, #64). 16 | 17 | ## 0.1.1 -- 2023-04-07 18 | 19 | * Better verbose mode for test failures 20 | * New predicates: `split` and `pairwise`. 21 | * Shrink towards the _second_ half of the range in `withOrigin` 22 | 23 | ## 0.1.0 -- 2023-04-05 24 | 25 | * First release 26 | -------------------------------------------------------------------------------- /lib/src/Test/Falsify/Internal/Generator.hs: -------------------------------------------------------------------------------- 1 | -- | Export the public API of the generator, hiding implementation details. 2 | -- 3 | -- This is the only module that should import from 4 | -- @Test.Falsify.Internal.Generator.*@. 5 | -- 6 | -- Intended for unqualified import. 7 | module Test.Falsify.Internal.Generator ( 8 | Gen -- opaque 9 | , bindWithoutShortcut 10 | -- * Execution 11 | , runGen 12 | , shrinkFrom 13 | , minimalValue 14 | -- * Primitive generators 15 | , prim 16 | , primWith 17 | , exhaustive 18 | , captureLocalTree 19 | -- * Generator independence 20 | , bindIntegral 21 | , perturb 22 | -- * Combinators 23 | , withoutShrinking 24 | ) where 25 | 26 | import Test.Falsify.Internal.Generator.Definition 27 | import Test.Falsify.Internal.Generator.Shrinking 28 | -------------------------------------------------------------------------------- /lib/src/Test/Tasty/Falsify.hs: -------------------------------------------------------------------------------- 1 | -- | Support for @falsify@ in the @tasty@ framework 2 | -- 3 | -- As is customary, this also re-exports parts of the @falsify@ API, but not 4 | -- modules such as "Test.Falsify.Range" that are intended to be imported 5 | -- qualified. 6 | module Test.Tasty.Falsify ( 7 | -- * Test property 8 | testProperty 9 | -- * Configure test behaviour 10 | , TestOptions(..) 11 | , Verbose(..) 12 | , ExpectFailure(..) 13 | , testPropertyWith 14 | -- * Re-exports 15 | , module Test.Falsify.Property 16 | -- ** Generators 17 | , Gen 18 | -- ** Functions 19 | , pattern Gen.Fn 20 | , pattern Gen.Fn2 21 | , pattern Gen.Fn3 22 | ) where 23 | 24 | import Test.Falsify.Generator (Gen) 25 | import Test.Falsify.Internal.Driver.Tasty 26 | import Test.Falsify.Property 27 | 28 | import qualified Test.Falsify.Reexported.Generator.Function as Gen 29 | -------------------------------------------------------------------------------- /demo/demo/Demo/Functions.hs: -------------------------------------------------------------------------------- 1 | module Demo.Functions (tests) where 2 | 3 | import Data.Default 4 | import Data.Word 5 | import Test.Tasty 6 | import Test.Tasty.Falsify 7 | 8 | import Test.Falsify.Predicate ((.$)) 9 | 10 | import qualified Test.Falsify.Generator as Gen 11 | import qualified Test.Falsify.Predicate as P 12 | 13 | tests :: TestTree 14 | tests = testGroup "Demo.Functions" [ 15 | testPropertyWith expectFailure "listToBool" prop_listToBool 16 | ] 17 | where 18 | expectFailure :: TestOptions 19 | expectFailure = def { 20 | expectFailure = ExpectFailure 21 | , overrideVerbose = Just Verbose 22 | } 23 | 24 | prop_listToBool :: Property () 25 | prop_listToBool = do 26 | Fn (f :: [Word8] -> Bool) <- gen $ Gen.fun (Gen.bool False) 27 | assert $ P.eq .$ ("lhs", f [3, 1, 4, 2]) 28 | .$ ("rhs", f [1, 6, 1, 8]) 29 | 30 | 31 | -------------------------------------------------------------------------------- /lib/test/TestSuite/Sanity/Predicate.hs: -------------------------------------------------------------------------------- 1 | module TestSuite.Sanity.Predicate (tests) where 2 | 3 | import Test.Tasty 4 | import Test.Tasty.HUnit 5 | import Test.Falsify.Predicate (Predicate, (.$)) 6 | import qualified Test.Falsify.Predicate as P 7 | import Data.Char 8 | 9 | tests :: TestTree 10 | tests = testGroup "TestSuite.Sanity.Predicate" [ 11 | testCase "on" test_on 12 | ] 13 | 14 | test_on :: Assertion 15 | test_on = do 16 | assertEqual "ok" (Right ()) $ P.eval $ p1 .$ ("x", 'a') .$ ("y", 'a') 17 | assertEqual "err1" (Left err1) $ P.eval $ p1 .$ ("x", 'a') .$ ("y", 'b') 18 | assertEqual "err2" (Left err2) $ P.eval $ p2 .$ ("x", 'a') .$ ("y", 'b') 19 | where 20 | p1, p2 :: Predicate '[Char, Char] 21 | p1 = P.eq `P.on` P.fn ("ord", ord) 22 | p2 = P.eq `P.on` P.transparent ord 23 | 24 | err1, err2 :: String 25 | err1 = unlines [ 26 | "(ord x) /= (ord y)" 27 | , "x : 'a'" 28 | , "y : 'b'" 29 | , "ord x: 97" 30 | , "ord y: 98" 31 | ] 32 | err2 = unlines [ 33 | "x /= y" 34 | , "x: 'a'" 35 | , "y: 'b'" 36 | ] -------------------------------------------------------------------------------- /demo/demo/Demo/TestShrinking.hs: -------------------------------------------------------------------------------- 1 | module Demo.TestShrinking (tests) where 2 | 3 | import Data.Default 4 | import Test.Tasty 5 | import Test.Tasty.Falsify 6 | 7 | import qualified Test.Falsify.Generator as Gen 8 | import qualified Test.Falsify.Predicate as P 9 | 10 | tests :: TestTree 11 | tests = testGroup "Demo.TestShrinking" [ 12 | testProperty "prim" prop_prim 13 | , testPropertyWith expectFailure "mod1" prop_mod1 14 | , testProperty "mod2" prop_mod2 15 | ] 16 | where 17 | expectFailure :: TestOptions 18 | expectFailure = def { expectFailure = ExpectFailure } 19 | 20 | prop_prim :: Property () 21 | prop_prim = 22 | testShrinkingOfGen P.ge $ 23 | Gen.prim 24 | 25 | prop_mod1 :: Property () 26 | prop_mod1 = 27 | testShrinkingOfGen P.ge $ 28 | (`mod` 100) <$> Gen.prim 29 | 30 | -- The test will result in a test failure 31 | -- 32 | -- We should see in the log both the value generated by @Gen.prim@, as well as 33 | -- the result. Note that the fmap is on the /outside/ now. 34 | prop_mod2 :: Property () 35 | prop_mod2 = 36 | testShrinking P.ge $ do 37 | x <- (`mod` 100) <$> gen Gen.prim 38 | testFailed x 39 | 40 | 41 | -------------------------------------------------------------------------------- /lib/test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.Tasty 4 | 5 | import qualified TestSuite.GenDefault 6 | 7 | import qualified TestSuite.Sanity.Predicate 8 | import qualified TestSuite.Sanity.Range 9 | import qualified TestSuite.Sanity.Selective 10 | 11 | import qualified TestSuite.Prop.Generator.Compound 12 | import qualified TestSuite.Prop.Generator.Function 13 | import qualified TestSuite.Prop.Generator.Marking 14 | import qualified TestSuite.Prop.Generator.Precision 15 | import qualified TestSuite.Prop.Generator.Prim 16 | import qualified TestSuite.Prop.Generator.Selective 17 | import qualified TestSuite.Prop.Generator.Shrinking 18 | import qualified TestSuite.Prop.Generator.Simple 19 | 20 | main :: IO () 21 | main = defaultMain $ testGroup "falsify" [ 22 | testGroup "Sanity" [ 23 | TestSuite.Sanity.Range.tests 24 | , TestSuite.Sanity.Selective.tests 25 | , TestSuite.Sanity.Predicate.tests 26 | ] 27 | , testGroup "Prop" [ 28 | TestSuite.Prop.Generator.Prim.tests 29 | , TestSuite.Prop.Generator.Selective.tests 30 | , TestSuite.Prop.Generator.Marking.tests 31 | , TestSuite.Prop.Generator.Precision.tests 32 | , TestSuite.Prop.Generator.Simple.tests 33 | , TestSuite.Prop.Generator.Shrinking.tests 34 | , TestSuite.Prop.Generator.Compound.tests 35 | , TestSuite.Prop.Generator.Function.tests 36 | ] 37 | , TestSuite.GenDefault.tests 38 | ] 39 | -------------------------------------------------------------------------------- /lib/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2023, Well-Typed LLP 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Well-Typed LLP nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /demo/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2023, Edsko de Vries 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Edsko de Vries nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /lib/src/Data/Falsify/Marked.hs: -------------------------------------------------------------------------------- 1 | -- | Marked elements 2 | -- 3 | -- Intended for unqualified import. 4 | module Data.Falsify.Marked ( 5 | Mark(..) 6 | , Marked(..) 7 | -- * Generation 8 | , selectAllKept 9 | -- * Queries 10 | , countKept 11 | , shouldKeep 12 | ) where 13 | 14 | import Control.Selective 15 | import Data.Foldable (toList) 16 | import Data.Maybe (mapMaybe) 17 | 18 | {------------------------------------------------------------------------------- 19 | Definition 20 | -------------------------------------------------------------------------------} 21 | 22 | data Mark = Keep | Drop 23 | deriving stock (Show, Eq, Ord) 24 | 25 | data Marked f a = Marked { 26 | getMark :: Mark 27 | , unmark :: f a 28 | } 29 | deriving stock (Show, Eq, Ord) 30 | 31 | {------------------------------------------------------------------------------- 32 | Generation 33 | -------------------------------------------------------------------------------} 34 | 35 | selectKept :: Selective f => Marked f a -> f (Maybe a) 36 | selectKept (Marked mark gen) = 37 | ifS (pure $ mark == Keep) 38 | (Just <$> gen) 39 | (pure Nothing) 40 | 41 | -- | Traverse the argument, generating all values marked 'Keep', and replacing 42 | -- all values marked 'Drop' by 'Nothing' 43 | selectAllKept :: 44 | (Traversable t, Selective f) 45 | => t (Marked f a) -> f (t (Maybe a)) 46 | selectAllKept = traverse selectKept 47 | 48 | {------------------------------------------------------------------------------- 49 | Queries 50 | -------------------------------------------------------------------------------} 51 | 52 | countKept :: Foldable t => t (Marked f a) -> Word 53 | countKept = fromIntegral . length . mapMaybe shouldKeep . toList 54 | 55 | shouldKeep :: Marked f a -> Maybe (f a) 56 | shouldKeep (Marked Keep x) = Just x 57 | shouldKeep (Marked Drop _) = Nothing 58 | -------------------------------------------------------------------------------- /demo/demo.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: demo 3 | version: 0.1.0 4 | license: BSD-3-Clause 5 | license-file: LICENSE 6 | author: Edsko de Vries 7 | maintainer: edsko@well-typed.com 8 | category: Testing 9 | build-type: Simple 10 | tested-with: GHC==8.10.7 11 | , GHC==9.0.2 12 | , GHC==9.2.8 13 | , GHC==9.4.8 14 | , GHC==9.6.7 15 | , GHC==9.8.4 16 | , GHC==9.10.1 17 | , GHC==9.12.2 18 | 19 | common lang 20 | ghc-options: 21 | -Wall 22 | -Wredundant-constraints 23 | -Widentities 24 | build-depends: 25 | base 26 | default-language: 27 | Haskell2010 28 | default-extensions: 29 | DataKinds 30 | DeriveGeneric 31 | DerivingStrategies 32 | DisambiguateRecordFields 33 | GeneralizedNewtypeDeriving 34 | LambdaCase 35 | MultiWayIf 36 | NamedFieldPuns 37 | NumericUnderscores 38 | ScopedTypeVariables 39 | 40 | executable demo 41 | import: 42 | lang 43 | hs-source-dirs: 44 | demo 45 | main-is: 46 | Main.hs 47 | other-modules: 48 | Demo.Blogpost 49 | Demo.Distribution 50 | Demo.Functions 51 | Demo.HowToSpecifyIt 52 | Demo.TestOptions 53 | Demo.TestShrinking 54 | build-depends: 55 | , containers 56 | , data-default 57 | , falsify 58 | , mtl 59 | , selective 60 | , splitmix 61 | , tasty 62 | , tasty-hunit 63 | , vector 64 | 65 | executable template 66 | -- intentionally no import of lang 67 | hs-source-dirs: 68 | template 69 | main-is: 70 | Main.hs 71 | ghc-options: 72 | -Wall 73 | default-language: 74 | Haskell2010 75 | build-depends: 76 | base 77 | , tasty 78 | , falsify 79 | -------------------------------------------------------------------------------- /lib/src/Data/Falsify/Integer.hs: -------------------------------------------------------------------------------- 1 | module Data.Falsify.Integer ( 2 | -- * Encoding 3 | Bit(..) 4 | , encIntegerEliasG 5 | ) where 6 | 7 | import Data.Bits 8 | import Numeric.Natural 9 | 10 | {------------------------------------------------------------------------------- 11 | Binary encoding 12 | -------------------------------------------------------------------------------} 13 | 14 | data Bit = I | O 15 | deriving (Show, Eq, Ord) 16 | 17 | -- | Binary encoding (most significant bit first) 18 | natToBits :: Natural -> [Bit] 19 | natToBits = \n -> if 20 | | n < 0 -> error "toBits: negative input" 21 | | n == 0 -> [] 22 | | otherwise -> reverse $ go n 23 | where 24 | go :: Natural -> [Bit] 25 | go 0 = [] 26 | go n = (if testBit n 0 then I else O) : go (shiftR n 1) 27 | 28 | {------------------------------------------------------------------------------- 29 | Elias γ code 30 | -------------------------------------------------------------------------------} 31 | 32 | -- | Elias γ code 33 | -- 34 | -- Precondition: input @x >= 1@. 35 | -- 36 | -- See . 37 | encEliasG :: Natural -> [Bit] 38 | encEliasG x 39 | | x == 0 = error "eliasG: zero" 40 | | otherwise = zeroes x 41 | where 42 | zeroes :: Natural -> [Bit] 43 | zeroes n 44 | | n <= 1 = natToBits x 45 | | otherwise = O : zeroes (shiftR n 1) 46 | 47 | -- | Extension of Elias γ coding to signed integers 48 | -- 49 | -- This is adapted from @integerVariant@ in @Test.QuickCheck.Random@. The first 50 | -- bit encs whether @x >= 1@ or not (this will result in @0@ and @1@ having 51 | -- short codes). 52 | encIntegerEliasG :: Integer -> [Bit] 53 | encIntegerEliasG = \x -> 54 | if x >= 1 55 | then O : encEliasG (fromInteger $ x) 56 | else I : encEliasG (fromInteger . mangle $ x) 57 | where 58 | mangle :: Integer -> Integer 59 | mangle x = 1 - x 60 | -------------------------------------------------------------------------------- /lib/src/Test/Falsify/Reexported/Generator/Simple.hs: -------------------------------------------------------------------------------- 1 | -- | Simple (i.e., non-compound) generators 2 | module Test.Falsify.Reexported.Generator.Simple ( 3 | bool 4 | , inRange 5 | , integral 6 | , enum 7 | , int 8 | ) where 9 | 10 | import Prelude hiding (properFraction) 11 | 12 | import Data.Bits 13 | import Data.Word 14 | 15 | import Test.Falsify.Internal.Generator 16 | import Test.Falsify.Internal.Range 17 | import Test.Falsify.Internal.SampleTree (Sample(..), sampleValue) 18 | import Test.Falsify.Reexported.Generator.Precision 19 | 20 | import qualified Test.Falsify.Range as Range 21 | 22 | {------------------------------------------------------------------------------- 23 | Simple generators 24 | -------------------------------------------------------------------------------} 25 | 26 | -- | Generate random bool, shrink towards the given value 27 | -- 28 | -- Chooses with equal probability between 'True' and 'False'. 29 | bool :: Bool -> Gen Bool 30 | bool target = aux . sampleValue <$> primWith shrinker 31 | where 32 | aux :: Word64 -> Bool 33 | aux x | msbSet x = not target 34 | | otherwise = target 35 | 36 | msbSet :: forall a. FiniteBits a => a -> Bool 37 | msbSet x = testBit x (finiteBitSize (undefined :: a) - 1) 38 | 39 | shrinker :: Sample -> [Word64] 40 | shrinker (Shrunk 0) = [] 41 | shrinker _ = [0] 42 | 43 | {------------------------------------------------------------------------------- 44 | Integral ranges 45 | -------------------------------------------------------------------------------} 46 | 47 | -- | Generate value in the specified range 48 | inRange :: Range a -> Gen a 49 | inRange r = Range.eval properFraction r 50 | 51 | -- | Deprecated alias for 'inRange' 52 | integral :: Range a -> Gen a 53 | {-# DEPRECATED integral "Use inRange instead" #-} 54 | integral = inRange 55 | 56 | -- | Deprecated alias for 'inRange' 57 | enum :: Range a -> Gen a 58 | {-# DEPRECATED enum "Use inRange instead" #-} 59 | enum = inRange 60 | 61 | -- | Type-specialization of 'inRange' 62 | int :: Range Int -> Gen Int 63 | int = inRange 64 | 65 | -------------------------------------------------------------------------------- /lib/src/Test/Falsify/GenDefault/Std.hs: -------------------------------------------------------------------------------- 1 | module Test.Falsify.GenDefault.Std 2 | ( Std 3 | ) where 4 | 5 | import Test.Falsify.GenDefault (ViaIntegral (..), GenDefault, ViaEnum (..), ViaGeneric (..)) 6 | import Data.Int (Int8, Int16, Int32, Int64) 7 | import Data.Word (Word8, Word16, Word32, Word64) 8 | 9 | -- | Type tag for these "standard" default generators. 10 | -- You can use this tag directly or choose type-by-type with 'ViaTag'. 11 | data Std 12 | 13 | deriving via (ViaEnum ()) instance GenDefault Std () 14 | deriving via (ViaEnum Bool) instance GenDefault Std Bool 15 | deriving via (ViaEnum Char) instance GenDefault Std Char 16 | 17 | deriving via (ViaIntegral Int) instance GenDefault Std Int 18 | deriving via (ViaIntegral Int8) instance GenDefault Std Int8 19 | deriving via (ViaIntegral Int16) instance GenDefault Std Int16 20 | deriving via (ViaIntegral Int32) instance GenDefault Std Int32 21 | deriving via (ViaIntegral Int64) instance GenDefault Std Int64 22 | 23 | deriving via (ViaIntegral Word) instance GenDefault Std Word 24 | deriving via (ViaIntegral Word8) instance GenDefault Std Word8 25 | deriving via (ViaIntegral Word16) instance GenDefault Std Word16 26 | deriving via (ViaIntegral Word32) instance GenDefault Std Word32 27 | deriving via (ViaIntegral Word64) instance GenDefault Std Word64 28 | 29 | deriving via (ViaGeneric Std (Maybe a)) 30 | instance GenDefault Std a => GenDefault Std (Maybe a) 31 | 32 | deriving via (ViaGeneric Std (Either a b)) 33 | instance (GenDefault Std a, GenDefault Std b) => GenDefault Std (Either a b) 34 | 35 | deriving via 36 | (ViaGeneric Std (a, b)) 37 | instance 38 | (GenDefault Std a, GenDefault Std b) 39 | => GenDefault Std (a, b) 40 | 41 | deriving via 42 | (ViaGeneric Std (a, b, c)) 43 | instance 44 | (GenDefault Std a, GenDefault Std b, GenDefault Std c) 45 | => GenDefault Std (a, b, c) 46 | 47 | deriving via 48 | (ViaGeneric Std (a, b, c, d)) 49 | instance 50 | (GenDefault Std a, GenDefault Std b, GenDefault Std c, GenDefault Std d) 51 | => GenDefault Std (a, b, c, d) 52 | 53 | deriving via 54 | (ViaGeneric Std (a, b, c, d, e)) 55 | instance 56 | (GenDefault Std a, GenDefault Std b, GenDefault Std c, GenDefault Std d, GenDefault Std e) 57 | => GenDefault Std (a, b, c, d, e) 58 | -------------------------------------------------------------------------------- /demo/demo/Demo/Distribution.hs: -------------------------------------------------------------------------------- 1 | module Demo.Distribution (tests) where 2 | 3 | import Data.List (intercalate) 4 | import Data.Word 5 | import Test.Tasty 6 | import Test.Tasty.Falsify 7 | 8 | import Test.Falsify.Range (Precision(..)) 9 | 10 | import qualified Test.Falsify.Generator as Gen 11 | import qualified Test.Falsify.Range as Range 12 | 13 | tests :: TestTree 14 | tests = testGroup "Demo.Distribution" [ 15 | testGroup "prim" [ 16 | testProperty (show total) $ prop_prim total 17 | | total <- [2, 3, 6, 10] 18 | ] 19 | , testGroup "fraction" [ 20 | testProperty (show p) $ prop_fraction p 21 | | p <- [2, 3, 4] 22 | ] 23 | , testGroup "inRange" [ 24 | testProperty (show total) $ prop_integral total 25 | | total <- [2, 3, 6, 10] 26 | ] 27 | , testGroup "frequency" [ 28 | testProperty (intercalate "_" $ [show a, show b, show c]) $ 29 | prop_frequency a b c 30 | | (a, b, c) <- [(1, 1, 1), (1, 2, 3), (0, 1, 1), (1, 1, 8)] 31 | ] 32 | ] 33 | 34 | prop_prim :: Word -> Property () 35 | prop_prim total = do 36 | x <- gen $ Gen.prim 37 | collect "bucket" [bucket bucketSize x] 38 | where 39 | bucketSize :: Word64 40 | bucketSize = maxBound `div` fromIntegral total 41 | 42 | prop_fraction :: Precision -> Property () 43 | prop_fraction p = do 44 | x <- gen $ Gen.properFraction p 45 | collect "x" [x] 46 | 47 | prop_integral :: Word -> Property () 48 | prop_integral total = do 49 | x <- gen $ Gen.inRange (Range.between (0, total - 1)) 50 | collect "x" [x] 51 | 52 | prop_frequency :: Word -> Word -> Word -> Property () 53 | prop_frequency a b c = do 54 | x <- gen $ Gen.frequency [ 55 | (a, pure 'a') 56 | , (b, pure 'b') 57 | , (c, pure 'c') 58 | ] 59 | collect "x" [x] 60 | 61 | {------------------------------------------------------------------------------- 62 | Auxiliary 63 | -------------------------------------------------------------------------------} 64 | 65 | bucket :: forall a. (Ord a, Num a) => a -> a -> Word 66 | bucket bucketSize = go 0 67 | where 68 | go :: Word -> a -> Word 69 | go b value 70 | | value <= bucketSize = b 71 | | otherwise = go (succ b) (value - bucketSize) 72 | 73 | -------------------------------------------------------------------------------- /lib/src/Test/Falsify/Generator.hs: -------------------------------------------------------------------------------- 1 | -- | Generator 2 | -- 3 | -- Intended for qualified import. 4 | -- 5 | -- > import Test.Falsify.Generator (Gen) 6 | -- > import qualified Test.Falsify.Generator qualified as Gen 7 | module Test.Falsify.Generator ( 8 | -- * Definition 9 | Gen -- opaque 10 | -- * Simple (non-compound) generators 11 | , bool 12 | , inRange 13 | , integral 14 | , enum 15 | , int 16 | -- * Compound generators 17 | -- ** Taking advantage of 'Selective' 18 | , choose 19 | , oneof 20 | -- ** Lists 21 | , list 22 | , elem 23 | , pick 24 | , pickBiased 25 | , shuffle 26 | -- ** Permutations 27 | , Permutation 28 | , applyPermutation 29 | , permutation 30 | -- ** Tweak test data distribution 31 | , frequency 32 | -- ** Trees 33 | , Tree(Leaf, Branch) 34 | , drawTree 35 | -- *** Binary trees 36 | , tree 37 | , bst 38 | -- *** Shrink trees 39 | , ShrinkTree 40 | , IsValidShrink(..) 41 | , path 42 | , pathAny 43 | -- ** Marking 44 | , Marked(..) 45 | , Mark(..) 46 | , selectAllKept 47 | , mark 48 | -- * Functions 49 | -- ** Generation 50 | , Fun 51 | , applyFun 52 | , pattern Fn 53 | , pattern Fn2 54 | , pattern Fn3 55 | , fun 56 | -- ** Construction 57 | , Function(..) 58 | , (:->) -- opaque 59 | , functionMap 60 | -- * Reducing precision 61 | , WordN(..) 62 | , wordN 63 | , properFraction 64 | -- * Overriding shrinking 65 | , withoutShrinking 66 | , shrinkToOneOf 67 | , firstThen 68 | , shrinkWith 69 | , shrinkToNothing 70 | -- * Shrink trees 71 | , fromShrinkTree 72 | , toShrinkTree 73 | -- * Generator independence 74 | , bindIntegral 75 | , perturb 76 | -- * Low-level 77 | , prim 78 | , primWith 79 | , exhaustive 80 | , captureLocalTree 81 | , bindWithoutShortcut 82 | , minimalValue 83 | ) where 84 | 85 | import Prelude hiding (either, elem, properFraction) 86 | 87 | import Data.Falsify.List 88 | import Data.Falsify.Marked 89 | import Test.Falsify.Internal.Generator 90 | import Test.Falsify.Reexported.Generator.Compound 91 | import Test.Falsify.Reexported.Generator.Function 92 | import Test.Falsify.Reexported.Generator.Precision 93 | import Test.Falsify.Reexported.Generator.Shrinking 94 | import Test.Falsify.Reexported.Generator.Simple 95 | import Data.Falsify.Tree 96 | -------------------------------------------------------------------------------- /lib/src/Test/Falsify/Internal/Driver/ReplaySeed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | Replay seeds 4 | -- 5 | -- We need a seed/gamma pair to initialize a splitmix PRNG. This is however a 6 | -- pretty low level implementation detail that I'd prefer not be be directly 7 | -- visible. We therefore provide a thin layer on top, which provides an 8 | -- "encoded" replay seed. This has the additional benefits that the length of 9 | -- the replay seed is always the same (unlike just writing a 'Word64'), and we 10 | -- could in principle at some point support other kinds of PRNGs. 11 | module Test.Falsify.Internal.Driver.ReplaySeed ( 12 | ReplaySeed(..) 13 | , parseReplaySeed 14 | , safeReadReplaySeed 15 | , splitmixReplaySeed 16 | ) where 17 | 18 | import Data.String 19 | import Data.Word 20 | import Data.Binary 21 | import System.Random.SplitMix 22 | 23 | import qualified Data.ByteString.Base16.Lazy as Lazy.Base16 24 | import qualified Data.ByteString.Lazy.Char8 as Lazy.Char8 25 | 26 | data ReplaySeed = 27 | ReplaySplitmix Word64 Word64 28 | 29 | splitmixReplaySeed :: SMGen -> ReplaySeed 30 | splitmixReplaySeed = uncurry ReplaySplitmix . unseedSMGen 31 | 32 | instance Binary ReplaySeed where 33 | put (ReplaySplitmix seed gamma) = do 34 | putWord8 1 35 | put seed 36 | put gamma 37 | 38 | get = do 39 | tag <- getWord8 40 | case tag of 41 | 1 -> do seed <- get 42 | gamma <- get 43 | if odd gamma 44 | then return $ ReplaySplitmix seed gamma 45 | else fail $ "ReplaySeed: expected odd gamma for splitmix" 46 | n -> fail $ "ReplaySeed: invalid tag: " ++ show n 47 | 48 | instance Show ReplaySeed where 49 | show = Lazy.Char8.unpack . Lazy.Base16.encode . encode 50 | 51 | instance IsString ReplaySeed where 52 | fromString = aux . safeReadReplaySeed 53 | where 54 | aux :: Maybe ReplaySeed -> ReplaySeed 55 | aux Nothing = error "ReplaySeed: invalid seed" 56 | aux (Just s) = s 57 | 58 | safeReadReplaySeed :: String -> Maybe ReplaySeed 59 | safeReadReplaySeed = parseReplaySeed 60 | 61 | #if MIN_VERSION_base(4,13,0) 62 | parseReplaySeed :: forall m. MonadFail m => String -> m ReplaySeed 63 | #else 64 | parseReplaySeed :: forall m. Monad m => String -> m ReplaySeed 65 | #endif 66 | 67 | parseReplaySeed str = do 68 | raw <- case Lazy.Base16.decode (Lazy.Char8.pack str) of 69 | Left err -> fail err 70 | Right x -> return x 71 | case decodeOrFail raw of 72 | Left (_, _, err) -> fail err 73 | Right (_, _, x) -> return x 74 | -------------------------------------------------------------------------------- /lib/test/TestSuite/Prop/Generator/Precision.hs: -------------------------------------------------------------------------------- 1 | module TestSuite.Prop.Generator.Precision (tests) where 2 | 3 | import Control.Monad 4 | import Test.Tasty 5 | import Test.Tasty.Falsify 6 | 7 | import Test.Falsify.Generator (WordN(..)) 8 | import Test.Falsify.Range (Precision(..), ProperFraction(..)) 9 | 10 | import qualified Test.Falsify.Generator as Gen 11 | import qualified Test.Falsify.Predicate as P 12 | 13 | tests :: TestTree 14 | tests = testGroup "TestSuite.Prop.Generator.Precision" [ 15 | testGroup "wordN" [ 16 | testGroup (show p) [ 17 | testProperty "shrinking" $ prop_wordN_shrinking p 18 | , testProperty "minimum" $ prop_wordN_minimum p 19 | ] 20 | | p <- map Precision [0, 1, 2, 3, 63, 64] 21 | ] 22 | , testGroup "fraction" [ 23 | testGroup (show p) [ 24 | testProperty "shrinking" $ prop_fraction_shrinking (Precision p) 25 | , testProperty "minimum" $ prop_fraction_minimum (Precision p) target expected 26 | ] 27 | | (p, target, expected) <- [ 28 | -- The higher the precision, the closer we can get to the target 29 | (2 , 50, 75) 30 | , (3 , 50, 62) 31 | , (4 , 50, 56) 32 | , (5 , 50, 53) 33 | , (63 , 50, 51) 34 | , (64 , 50, 51) 35 | ] 36 | ] 37 | ] 38 | 39 | {------------------------------------------------------------------------------- 40 | wordN 41 | -------------------------------------------------------------------------------} 42 | 43 | prop_wordN_shrinking :: Precision -> Property () 44 | prop_wordN_shrinking p = 45 | testShrinkingOfGen P.ge $ Gen.wordN p 46 | 47 | prop_wordN_minimum :: Precision -> Property () 48 | prop_wordN_minimum p = 49 | testMinimum (P.expect $ WordN p 0) $ do 50 | x <- gen $ Gen.wordN p 51 | testFailed x 52 | 53 | {------------------------------------------------------------------------------- 54 | fraction 55 | -------------------------------------------------------------------------------} 56 | 57 | prop_fraction_shrinking :: Precision -> Property () 58 | prop_fraction_shrinking p = 59 | testShrinkingOfGen P.ge $ Gen.properFraction p 60 | 61 | prop_fraction_minimum :: Precision -> Word -> Word -> Property () 62 | prop_fraction_minimum p target expected = 63 | testMinimum ((P.expect expected) `P.dot` P.fn ("pct", pct)) $ do 64 | x <- gen $ Gen.properFraction p 65 | unless (pct x <= target) $ testFailed x 66 | where 67 | pct :: ProperFraction -> Word 68 | pct (ProperFraction f) = round (f * 100) 69 | 70 | -------------------------------------------------------------------------------- /lib/src/Test/Falsify/Internal/Range.hs: -------------------------------------------------------------------------------- 1 | -- | Internal 'Range' API 2 | module Test.Falsify.Internal.Range ( 3 | -- * Definition 4 | Range(..) 5 | , ProperFraction(ProperFraction) 6 | , Precision(..) 7 | ) where 8 | 9 | import Data.List.NonEmpty (NonEmpty) 10 | import Data.Word 11 | import GHC.Show 12 | import GHC.Stack 13 | 14 | {------------------------------------------------------------------------------- 15 | Proper fractions 16 | -------------------------------------------------------------------------------} 17 | 18 | -- | Value @x@ such that @0 <= x < 1@ 19 | newtype ProperFraction = UnsafeProperFraction { getProperFraction :: Double } 20 | deriving stock (Eq, Ord) 21 | deriving newtype (Num, Fractional) 22 | 23 | -- | Show instance relies on the 'ProperFraction' pattern synonym 24 | instance Show ProperFraction where 25 | showsPrec p (UnsafeProperFraction f) = showParen (p >= appPrec1) $ 26 | showString "ProperFraction " 27 | . showsPrec appPrec1 f 28 | 29 | mkProperFraction :: HasCallStack => Double -> ProperFraction 30 | mkProperFraction f 31 | | 0 <= f && f < 1 = UnsafeProperFraction f 32 | | otherwise = error $ "mkProperFraction: not a proper fraction: " ++ show f 33 | 34 | pattern ProperFraction :: Double -> ProperFraction 35 | pattern ProperFraction f <- (getProperFraction -> f) 36 | where 37 | ProperFraction = mkProperFraction 38 | 39 | {-# COMPLETE ProperFraction #-} 40 | 41 | {------------------------------------------------------------------------------- 42 | Precision 43 | -------------------------------------------------------------------------------} 44 | 45 | -- | Precision (in bits) 46 | newtype Precision = Precision Word8 47 | deriving stock (Show, Eq, Ord) 48 | deriving newtype (Num, Enum) 49 | 50 | {------------------------------------------------------------------------------- 51 | Range 52 | -------------------------------------------------------------------------------} 53 | 54 | -- | Range of values 55 | data Range a where 56 | -- | Constant (point) range 57 | Constant :: a -> Range a 58 | 59 | -- | Construct values in the range from a 'ProperFraction' 60 | -- 61 | -- This is the main constructor for 'Range'. 62 | FromProperFraction :: Precision -> (ProperFraction -> a) -> Range a 63 | 64 | -- | Evaluate each range and choose the \"smallest\" 65 | -- 66 | -- Each value in the range is annotated with some distance metric; for 67 | -- example, this could be the distance to some predefined point (e.g. as in 68 | -- 'Test.Falsify.Range.towards') 69 | Smallest :: Ord b => NonEmpty (Range (a, b)) -> Range a 70 | 71 | deriving stock instance Functor Range 72 | -------------------------------------------------------------------------------- /lib/test/TestSuite/Util/Tree.hs: -------------------------------------------------------------------------------- 1 | module TestSuite.Util.Tree ( 2 | -- * Stats 3 | size 4 | , weight 5 | , height 6 | -- * Balancing 7 | , isWeightBalanced 8 | , isHeightBalanced 9 | ) where 10 | 11 | import Test.Falsify.Generator (Tree(..)) 12 | 13 | {------------------------------------------------------------------------------- 14 | Tree stats 15 | -------------------------------------------------------------------------------} 16 | 17 | -- | Size of the tree 18 | size :: Tree a -> Word 19 | size Leaf = 0 20 | size (Branch _ l r) = 1 + size l + size r 21 | 22 | -- | Weight of the tree 23 | -- 24 | -- The weight of a tree is simply its size plus one. 25 | -- 26 | -- @O(1)@ 27 | weight :: Tree a -> Word 28 | weight = succ . size 29 | 30 | -- | Height of the tree 31 | -- 32 | -- The height of a tree is the maximum length from the root to any of the leafs. 33 | -- 34 | -- @O(1)@ 35 | height :: Tree a -> Word 36 | height Leaf = 0 37 | height (Branch _ l r) = 1 + max (height l) (height r) 38 | 39 | {------------------------------------------------------------------------------- 40 | Balancing 41 | -------------------------------------------------------------------------------} 42 | 43 | -- | Check if the tree is weight-balanced 44 | -- 45 | -- A tree is weight-balanced if the weights of the subtrees does not differ 46 | -- by more than a factor 3. 47 | -- 48 | -- See "Balancing weight-balanced trees", Hirai and Yamamoto, JFP 21(3), 2011. 49 | isWeightBalanced :: Tree a -> Bool 50 | isWeightBalanced = checkBalanceCondition isBalanced 51 | where 52 | delta :: Word 53 | delta = 3 54 | 55 | isBalanced :: Tree a -> Tree a -> Bool 56 | isBalanced a b = and [ 57 | delta * weight a >= weight b 58 | , delta * weight b >= weight a 59 | ] 60 | 61 | -- | Check if a tree is height-balanced 62 | -- 63 | -- A tree is height balanced if the heights of its subtrees do not differ 64 | -- by more than one. 65 | isHeightBalanced :: Tree a -> Bool 66 | isHeightBalanced = checkBalanceCondition isBalanced 67 | where 68 | isBalanced :: Tree a -> Tree a -> Bool 69 | isBalanced a b = or [ 70 | (height a <= height b) && (height b - height a <= 1) 71 | , (height b <= height a) && (height a - height b <= 1) 72 | ] 73 | 74 | -- | Internal auxiliary: check given tree balance condition 75 | -- 76 | -- Property @p l r@ will be checked at every branch in the tree. 77 | checkBalanceCondition :: forall a. (Tree a -> Tree a -> Bool) -> Tree a -> Bool 78 | checkBalanceCondition p = go 79 | where 80 | go :: Tree a -> Bool 81 | go Leaf = True 82 | go (Branch _ l r) = and [p l r, go l, go r] 83 | 84 | -------------------------------------------------------------------------------- /lib/src/Test/Falsify/Interactive.hs: -------------------------------------------------------------------------------- 1 | -- | Utilities for interaction with falsify in ghci 2 | module Test.Falsify.Interactive ( 3 | falsify 4 | , falsify' 5 | , sample 6 | , shrink 7 | , shrink' 8 | -- * Re-exports 9 | , module Test.Falsify.Property 10 | -- ** Functions 11 | , pattern Gen.Fn 12 | , pattern Gen.Fn2 13 | , pattern Gen.Fn3 14 | ) where 15 | 16 | import Data.Bifunctor 17 | import Data.Default 18 | import Data.List.NonEmpty (NonEmpty(..)) 19 | import System.Random.SplitMix 20 | 21 | import qualified Data.List.NonEmpty as NE 22 | 23 | import Test.Falsify.Internal.Driver.ReplaySeed 24 | import Test.Falsify.Internal.Generator 25 | import Test.Falsify.Internal.Generator.Shrinking 26 | import Test.Falsify.Internal.Property 27 | import Test.Falsify.Property 28 | 29 | import qualified Test.Falsify.Generator as Gen 30 | import qualified Test.Falsify.Internal.Driver as Driver 31 | import qualified Test.Falsify.Internal.SampleTree as SampleTree 32 | 33 | -- | Sample generator 34 | sample :: Gen a -> IO a 35 | sample g = do 36 | prng <- initSMGen 37 | let (x, _shrunk) = runGen g (SampleTree.fromPRNG prng) 38 | return x 39 | 40 | -- | Shrink counter-example 41 | -- 42 | -- This will run the generator repeatedly until it finds a counter-example to 43 | -- the given property, and will then shrink it. 44 | -- 45 | -- Returns 'Nothing' if no counter-example could be found. 46 | shrink :: forall a. (a -> Bool) -> Gen a -> IO (Maybe a) 47 | shrink p g = falsify $ testGen' (\x -> aux x $ p x) g 48 | where 49 | aux :: a -> Bool -> Either a () 50 | aux _ True = Right () 51 | aux x False = Left x 52 | 53 | -- | Generalization of 'shrink'. Returns the full shrink history. 54 | shrink' :: forall e a. (a -> Maybe e) -> Gen a -> IO (Maybe (NonEmpty e)) 55 | shrink' p g = falsify' $ testGen' (aux . p) g 56 | where 57 | aux :: Maybe e -> Either e () 58 | aux Nothing = Right () 59 | aux (Just x) = Left x 60 | 61 | -- | Try to falsify the given property 62 | -- 63 | -- Reports the counter-example, if we find any. 64 | falsify :: forall e a. Property' e a -> IO (Maybe e) 65 | falsify = fmap (fmap NE.last) . falsify' 66 | 67 | -- | Generalization of 'falsify' that reports the full shrink history 68 | falsify' :: forall e a. Property' e a -> IO (Maybe (NonEmpty e)) 69 | falsify' = fmap aux . Driver.falsify def 70 | where 71 | aux :: 72 | ( ReplaySeed 73 | , [Driver.Success a] 74 | , Driver.TotalDiscarded 75 | , Maybe (Driver.Failure e) 76 | ) 77 | -> Maybe (NonEmpty e) 78 | aux (_seed, _successes, _discarded, failure) = 79 | case failure of 80 | Nothing -> Nothing 81 | Just f -> Just $ shrinkHistory $ first fst $ Driver.failureRun f -------------------------------------------------------------------------------- /lib/src/Data/Falsify/List.hs: -------------------------------------------------------------------------------- 1 | module Data.Falsify.List ( 2 | -- * Splitting 3 | chunksOfNonEmpty 4 | -- * Permutations 5 | , Permutation 6 | , applyPermutation 7 | -- * Dealing with marks 8 | , keepAtLeast 9 | ) where 10 | 11 | import Control.Monad 12 | import Control.Monad.ST 13 | import Data.Foldable (toList) 14 | import Data.List.NonEmpty (NonEmpty(..)) 15 | 16 | import qualified Data.Vector as V 17 | import qualified Data.Vector.Mutable as VM 18 | 19 | import Data.Falsify.Marked 20 | 21 | {------------------------------------------------------------------------------- 22 | Splitting 23 | -------------------------------------------------------------------------------} 24 | 25 | -- | Take chunks of a non-empty list 26 | -- 27 | -- This is lazy: 28 | -- 29 | -- > NE.take 4 $ chunksOfNonEmpty 3 (0 :| [1..]) 30 | -- > == [ 0 :| [1,2] 31 | -- > , 3 :| [4,5] 32 | -- > , 6 :| [7,8] 33 | -- > , 9 :| [10,11] 34 | -- > ] 35 | chunksOfNonEmpty :: Word -> NonEmpty a -> NonEmpty (NonEmpty a) 36 | chunksOfNonEmpty 0 _ = error "chunksOfNonEmpty: zero chunk size" 37 | chunksOfNonEmpty n (x :| xs) = 38 | let (chunk, rest) = splitAt (fromIntegral n) (x : xs) 39 | in case (chunk, rest) of 40 | ([] , _) -> error "impossible" 41 | (c:cs , []) -> (c :| cs) :| [] 42 | (c:cs , r:rs) -> (c :| cs) :| toList (chunksOfNonEmpty n (r :| rs)) 43 | 44 | {------------------------------------------------------------------------------- 45 | Permutations 46 | -------------------------------------------------------------------------------} 47 | 48 | -- | Permutation is a sequence of swaps 49 | type Permutation = [(Word, Word)] 50 | 51 | applyPermutation :: Permutation -> [a] -> [a] 52 | applyPermutation p xs = 53 | V.toList $ V.modify (forM_ (map conv p) . swap) (V.fromList xs) 54 | where 55 | swap :: V.MVector s a -> (Int, Int) -> ST s () 56 | swap vec (i, j) = do 57 | x <- VM.read vec i 58 | y <- VM.read vec j 59 | VM.write vec i y 60 | VM.write vec j x 61 | 62 | conv :: (Word, Word) -> (Int, Int) 63 | conv (i, j) = (fromIntegral i, fromIntegral j) 64 | 65 | {------------------------------------------------------------------------------- 66 | Dealing with marks 67 | -------------------------------------------------------------------------------} 68 | 69 | keepAtLeast :: Word -> [Marked f a] -> [Marked f a] 70 | keepAtLeast = \n xs -> 71 | let kept = countKept xs 72 | in if kept >= n 73 | then xs 74 | else go (n - kept) xs 75 | where 76 | go :: Word -> [Marked f a] -> [Marked f a] 77 | go _ [] = [] 78 | go 0 xs = xs 79 | go n (Marked Keep x:xs) = Marked Keep x : go n xs 80 | go n (Marked Drop x:xs) = Marked Keep x : go (n - 1) xs 81 | -------------------------------------------------------------------------------- /lib/test/TestSuite/GenDefault.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | -- | We test the 'GenDefault' machinery by defining a tag, deriving some 'GenDefault' 5 | -- instances, and asserting that the derived generators yield more than one distinct 6 | -- value. 7 | module TestSuite.GenDefault (tests) where 8 | 9 | import Data.Proxy (Proxy (..)) 10 | import qualified Data.Set as Set 11 | import GHC.Exts (IsList, IsString) 12 | import GHC.Generics (Generic) 13 | import qualified Test.Falsify.GenDefault as FD 14 | import qualified Test.Falsify.GenDefault.Std as FDS 15 | import qualified Test.Falsify.Generator as FG 16 | import qualified Test.Falsify.Interactive as FI 17 | import Test.Tasty (TestTree, testGroup) 18 | import Test.Tasty.HUnit (assertBool, testCase) 19 | import Control.Monad (replicateM) 20 | 21 | data Tag 22 | 23 | -- Exercise ViaTag 24 | 25 | deriving via (FD.ViaTag FDS.Std Int) instance FD.GenDefault Tag Int 26 | deriving via (FD.ViaTag FDS.Std Char) instance FD.GenDefault Tag Char 27 | 28 | -- Exercise ViaList 29 | 30 | newtype AList a = AList [a] 31 | deriving newtype (Eq, Ord, Show, IsList) 32 | 33 | deriving via (FD.ViaList (AList a) 0 2) instance FD.GenDefault Tag a => FD.GenDefault Tag (AList a) 34 | 35 | -- Exercise ViaString 36 | 37 | newtype AString = AString String 38 | deriving newtype (Eq, Ord, Show, IsString) 39 | deriving (FD.GenDefault Tag) via (FD.ViaString AString 0 2) 40 | 41 | -- Exercise ViaEnum 42 | 43 | data Choice = ChoiceA | ChoiceB 44 | deriving stock (Eq, Ord, Show, Enum, Bounded) 45 | deriving (FD.GenDefault Tag) via (FD.ViaEnum Choice) 46 | 47 | -- Exercise ViaGeneric 48 | 49 | deriving via (FD.ViaGeneric Tag (Maybe a)) instance FD.GenDefault Tag a => FD.GenDefault Tag (Maybe a) 50 | 51 | data Record = Record !Int !(Maybe Record) 52 | deriving stock (Eq, Ord, Show, Generic) 53 | deriving (FD.GenDefault Tag) via (FD.ViaGeneric Tag Record) 54 | 55 | data GenCase where 56 | GenCase :: Ord a => String -> FG.Gen a -> GenCase 57 | 58 | genDefaultByProxy :: FD.GenDefault Tag a => Proxy a -> FG.Gen a 59 | genDefaultByProxy _ = FD.genDefault (Proxy @Tag) 60 | 61 | mkGenCase :: (Ord a, FD.GenDefault Tag a) => String -> Proxy a -> GenCase 62 | mkGenCase name = GenCase name . genDefaultByProxy 63 | 64 | genCases :: [GenCase] 65 | genCases = 66 | [ mkGenCase "Int" (Proxy @Int) 67 | , mkGenCase "Char" (Proxy @Char) 68 | , mkGenCase "Choice" (Proxy @Choice) 69 | , mkGenCase "AList" (Proxy @(AList Char)) 70 | , mkGenCase "AString" (Proxy @AString) 71 | , mkGenCase "Record" (Proxy @Record) 72 | ] 73 | 74 | testGenCase :: GenCase -> TestTree 75 | testGenCase (GenCase name gen) = testCase name $ do 76 | xs <- fmap Set.fromList (replicateM 10 (FI.sample gen)) 77 | assertBool "generates more than one value" (Set.size xs > 1) 78 | 79 | tests :: TestTree 80 | tests = testGroup "TestSuite.GenDefault" (fmap testGenCase genCases) 81 | -------------------------------------------------------------------------------- /lib/test/TestSuite/Sanity/Range.hs: -------------------------------------------------------------------------------- 1 | module TestSuite.Sanity.Range (tests) where 2 | 3 | import Control.Monad 4 | import Data.Bifunctor 5 | import Data.Map (Map) 6 | import Data.Maybe (fromMaybe) 7 | import Test.Tasty 8 | import Test.Tasty.HUnit 9 | import Text.Printf 10 | 11 | import qualified Data.Map as Map 12 | 13 | import Test.Falsify.Range (Range, Precision(..), ProperFraction(..)) 14 | 15 | import qualified Test.Falsify.Range as Range 16 | 17 | tests :: TestTree 18 | tests = testGroup "TestSuite.Sanity.Range" [ 19 | testGroup "between" [ 20 | testCase (show size) $ test_between size 21 | | size <- [2, 3, 4, 10, 100, 1000, 10_000] 22 | ] 23 | ] 24 | 25 | test_between :: Word -> Assertion 26 | test_between size = do 27 | assertEqual "domain" [0 .. size - 1] $ 28 | map fst $ stats r 29 | 30 | forM_ (map snd $ stats r) $ \(Percentage pct _) -> 31 | unless (abs (pct - expected) < tolerance) $ 32 | assertFailure $ concat [ 33 | "Percentage " 34 | , show pct 35 | , ". Expected " 36 | , show expected 37 | , " (tolerance " 38 | , show tolerance 39 | , ")" 40 | ] 41 | where 42 | r :: Range Word 43 | r = Range.between (0, size - 1) 44 | 45 | expected, tolerance :: Double 46 | expected = 1 / fromIntegral size 47 | tolerance = 0.01 48 | 49 | {------------------------------------------------------------------------------- 50 | Auxiliary 51 | -------------------------------------------------------------------------------} 52 | 53 | data Percentage = Percentage Double Bool 54 | 55 | instance Show Percentage where 56 | show (Percentage pct isZero) = 57 | printf "%8.4f%% (%s)" pct (if isZero then "zero" else "non-zero") 58 | 59 | -- | Compute statistics about the given range 60 | -- 61 | -- Whenever the 'Range' asks for a fraction with a certain precision, we give 62 | -- it /all/ possible fractions with that precision. We then count how often 63 | -- each value in the range is produced. 64 | stats :: forall a. Ord a => Range a -> [(a, Percentage)] 65 | stats r = 66 | count Map.empty $ Range.eval genFraction r 67 | where 68 | genFraction :: Precision -> [ProperFraction] 69 | genFraction (Precision p) 70 | | p >= 16 = error $ "stats: precision " ++ show p ++ " too high" 71 | | otherwise = [ 72 | ProperFraction $ fromIntegral x / fromIntegral ((2 :: Word) ^ p) 73 | | x <- [0 .. (2 :: Word) ^ p - 1] 74 | ] 75 | 76 | count :: Map a Word -> [a] -> [(a, Percentage)] 77 | count acc (x:xs) = count (Map.alter (Just . (+1) . fromMaybe 0) x acc) xs 78 | count acc [] = map (second asPct) $ Map.toList acc 79 | where 80 | total :: Word 81 | total = sum $ Map.elems acc 82 | 83 | asPct :: Word -> Percentage 84 | asPct c = Percentage (fromIntegral c / fromIntegral total) (c == 0) 85 | 86 | 87 | -------------------------------------------------------------------------------- /demo/demo/Demo/TestOptions.hs: -------------------------------------------------------------------------------- 1 | module Demo.TestOptions (tests) where 2 | 3 | import Control.Monad 4 | import Data.Default 5 | import Test.Tasty 6 | import Test.Tasty.Falsify 7 | 8 | import Test.Falsify.Predicate ((.$)) 9 | 10 | import qualified Test.Falsify.Generator as Gen 11 | import qualified Test.Falsify.Range as Range 12 | import qualified Test.Falsify.Predicate as P 13 | 14 | tests :: TestTree 15 | tests = testGroup "Demo.Simple" [ 16 | testGroup "Valid" [ 17 | testPropertyWith def 18 | "def" prop_inRange 19 | , testPropertyWith (def { overrideVerbose = Just Verbose }) 20 | "verbose" prop_inRange 21 | , testPropertyWith (def { expectFailure = ExpectFailure }) 22 | "expectFailure" prop_inRange 23 | , testPropertyWith (def { overrideVerbose = Just Verbose 24 | , expectFailure = ExpectFailure }) 25 | "verboseExpectFailure" prop_inRange 26 | ] 27 | , testGroup "Invalid" [ 28 | testPropertyWith def 29 | "def" prop_even 30 | , testPropertyWith (def { overrideVerbose = Just Verbose }) 31 | "verbose" prop_even 32 | , testPropertyWith (def { expectFailure = ExpectFailure }) 33 | "expectFailure" prop_even 34 | , testPropertyWith (def { overrideVerbose = Just Verbose 35 | , expectFailure = ExpectFailure }) 36 | "verboseExpectFailure" prop_even 37 | ] 38 | , testGroup "Discard" [ 39 | testPropertyWith def 40 | "def" prop_even_discard 41 | , testPropertyWith (def { overrideVerbose = Just Verbose }) 42 | "verbose" prop_even_discard 43 | , testPropertyWith (def { expectFailure = ExpectFailure }) 44 | "expectFailure" prop_even_discard 45 | , testPropertyWith (def { overrideVerbose = Just Verbose 46 | , expectFailure = ExpectFailure }) 47 | "verboseExpectFailure" prop_even_discard 48 | ] 49 | ] 50 | 51 | -- | Valid property (property that holds) 52 | -- 53 | -- "Every value between 0 and 100 is between 0 and 100" 54 | prop_inRange :: Property () 55 | prop_inRange = do 56 | x :: Word <- gen $ Gen.inRange $ Range.between (0, 100) 57 | assert $ P.between 0 100 .$ ("x", x) 58 | 59 | -- | Invalid property (property that does not hold) 60 | -- 61 | -- "Every value between 0 and 100 is even" 62 | prop_even :: Property () 63 | prop_even = do 64 | x :: Word <- gen $ Gen.inRange $ Range.between (0, 100) 65 | assert $ P.even .$ ("x", x) 66 | 67 | -- | Like 'prop_even', but discarding tests that fail. 68 | prop_even_discard :: Property () 69 | prop_even_discard = do 70 | x :: Word <- gen $ Gen.inRange $ Range.between (0, 100) 71 | when (odd x) discard 72 | assert $ P.even .$ ("x", x) 73 | 74 | -------------------------------------------------------------------------------- /lib/test/TestSuite/Prop/Generator/Marking.hs: -------------------------------------------------------------------------------- 1 | module TestSuite.Prop.Generator.Marking (tests) where 2 | 3 | import Control.Monad 4 | import Data.Map (Map) 5 | import Data.Maybe (catMaybes) 6 | import Data.Word 7 | import Test.Tasty 8 | import Test.Tasty.Falsify 9 | 10 | import qualified Data.Map as Map 11 | import qualified Data.Set as Set 12 | 13 | import Test.Falsify.Generator (Marked(..), Mark(..)) 14 | 15 | import qualified Test.Falsify.Generator as Gen hiding (mark) 16 | import qualified Test.Falsify.Predicate as P 17 | 18 | import TestSuite.Util.List 19 | 20 | tests :: TestTree 21 | tests = testGroup "TestSuite.Prop.Generator.Marking" [ 22 | testGroup "list" [ 23 | testProperty "shrinking" prop_list_shrinking 24 | , testProperty "minimum" prop_list_minimum 25 | ] 26 | ] 27 | 28 | {------------------------------------------------------------------------------- 29 | Marking 30 | -------------------------------------------------------------------------------} 31 | 32 | -- | Mark an element 33 | -- 34 | -- Marks as 'Drop' with 50% probability. 35 | -- 36 | -- We avoid using 'Gen.mark' here, which depends on @shrinkTo@. This version 37 | -- uses only 'Gen.prim'; the difference in behaviour is that this version of 38 | -- @mark@ can produce elements that are marked as drop from the get-go. 39 | mark :: Gen a -> Gen (Marked Gen a) 40 | mark x = flip Marked x <$> (aux <$> Gen.prim) 41 | where 42 | aux :: Word64 -> Mark 43 | aux n = if n >= maxBound `div` 2 then Keep else Drop 44 | 45 | {------------------------------------------------------------------------------- 46 | List 47 | -------------------------------------------------------------------------------} 48 | 49 | genMarkedList :: Gen [(Word, Word64)] 50 | genMarkedList = do 51 | xs <- forM [0 .. 9] (\i -> mark ((i, ) <$> Gen.prim)) 52 | catMaybes <$> Gen.selectAllKept xs 53 | 54 | prop_list_shrinking :: Property () 55 | prop_list_shrinking = 56 | testShrinkingOfGen 57 | ( mconcat [ 58 | P.flip (P.relatedBy ("isSubsetOf", Set.isSubsetOf)) 59 | `P.on` P.fn ("keysSet", Map.keysSet) 60 | , P.relatedBy ("shrunkCod", shrunkCod) 61 | ] 62 | `P.on` P.transparent Map.fromList 63 | ) 64 | genMarkedList 65 | where 66 | shrunkCod :: Map Word Word64 -> Map Word Word64 -> Bool 67 | shrunkCod orig shrunk = and [ 68 | -- The 'shrunkDom' check justifies the use of @(!)@ here 69 | orig Map.! k >= v 70 | | (k, v) <- Map.toList shrunk 71 | ] 72 | 73 | prop_list_minimum :: Property () 74 | prop_list_minimum = 75 | testMinimum (P.satisfies ("expected", expected)) $ do 76 | xs <- gen $ genMarkedList 77 | case xs of 78 | (0, _):_ -> discard 79 | _otherwise -> return () 80 | unless (pairwiseAll (==) $ map snd xs) $ testFailed xs 81 | where 82 | expected :: [(Word, Word64)] -> Bool 83 | expected [(i, 0), (j, 1)] | i < j = True 84 | expected _otherwise = False 85 | -------------------------------------------------------------------------------- /lib/src/Test/Falsify/Reexported/Generator/Precision.hs: -------------------------------------------------------------------------------- 1 | -- | Fixed precision generators 2 | module Test.Falsify.Reexported.Generator.Precision ( 3 | -- * @n@-bit words 4 | WordN(..) 5 | , wordN 6 | -- ** Fractions 7 | , properFraction 8 | ) where 9 | 10 | import Prelude hiding (properFraction) 11 | 12 | import Data.Bits 13 | import Data.Word 14 | import GHC.Stack 15 | 16 | import Test.Falsify.Internal.Generator 17 | import Test.Falsify.Internal.Range 18 | import Test.Falsify.Internal.SampleTree (sampleValue) 19 | import Test.Falsify.Internal.Search 20 | 21 | {------------------------------------------------------------------------------- 22 | @n@-bit word 23 | -------------------------------------------------------------------------------} 24 | 25 | -- | @n@-bit word 26 | data WordN = WordN Precision Word64 27 | deriving (Show, Eq, Ord) 28 | 29 | forgetPrecision :: WordN -> Word64 30 | forgetPrecision (WordN _ x) = x 31 | 32 | -- | Make @n@-bit word (@n <= 64@) 33 | -- 34 | -- Bits outside the requested precision will be zeroed. 35 | -- 36 | -- We use this to generate random @n@-bit words from random 64-bit words. 37 | -- It is important that we /truncate/ rather than /cap/ the value: capping the 38 | -- value (limiting it to a certain maximum) would result in a strong bias 39 | -- towards that maximum value. 40 | -- 41 | -- Of course, /shrinking/ of a Word64 bit does not translate automatically to 42 | -- shrinking of the lower @n@ bits of that word (a decrease in the larger 43 | -- 'Word64' may very well be an /increase/ in the lower @n@ bits), so this must 44 | -- be taken into account. 45 | truncateAt :: Precision -> Word64 -> WordN 46 | truncateAt desiredPrecision x = 47 | WordN actualPrecision (x .&. mask actualPrecision) 48 | where 49 | maximumPrecision, actualPrecision :: Precision 50 | maximumPrecision = Precision 64 51 | actualPrecision = min desiredPrecision maximumPrecision 52 | 53 | -- Maximum possible value 54 | -- 55 | -- If @n == 64@ then @2 ^ n@ will overflow, but it will overflow to @0@, and 56 | -- @(-1) :: Word64 == maxBound@; so no need to treat this case separately. 57 | mask :: Precision -> Word64 58 | mask (Precision n) = 2 ^ n - 1 59 | 60 | -- | Uniform selection of @n@-bit word of given precision, shrinking towards 0 61 | wordN :: Precision -> Gen WordN 62 | wordN p = 63 | fmap (truncateAt p . sampleValue) . primWith $ 64 | binarySearch 65 | . forgetPrecision 66 | . truncateAt p 67 | . sampleValue 68 | 69 | {------------------------------------------------------------------------------- 70 | Fractions 71 | -------------------------------------------------------------------------------} 72 | 73 | -- | Compute fraction from @n@-bit word 74 | mkFraction :: WordN -> ProperFraction 75 | mkFraction (WordN (Precision p) x) = 76 | ProperFraction $ (fromIntegral x) / (2 ^ p) 77 | 78 | -- | Uniform selection of fraction, shrinking towards 0 79 | -- 80 | -- Precondition: precision must be at least 1 bit (a zero-bit number is constant 81 | -- 0; it is meaningless to have a fraction in a point range). 82 | properFraction :: HasCallStack => Precision -> Gen ProperFraction 83 | properFraction (Precision 0) = error "fraction: 0 precision" 84 | properFraction p = mkFraction <$> wordN p 85 | -------------------------------------------------------------------------------- /lib/src/Test/Falsify/GenDefault.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | -- | This module defines something similar to QuickCheck's Arbitrary class along with 4 | -- some DerivingVia helpers. Our version, 'GenDefault', allows one to choose between 5 | -- sets of default generators with a user-defined tag. See 'Test.Falsify.GenDefault.Std' for 6 | -- the standard tag with a few useful instances. 7 | module Test.Falsify.GenDefault 8 | ( GenDefault (..) 9 | , ViaTag (..) 10 | , ViaIntegral (..) 11 | , ViaEnum (..) 12 | , ViaList (..) 13 | , ViaString (..) 14 | , ViaGeneric (..) 15 | ) where 16 | 17 | import Control.Applicative (liftA2) 18 | import Data.Proxy (Proxy (..)) 19 | import GHC.Generics (Generic (..), K1 (..), M1 (..), U1 (..), (:+:) (..), (:*:) (..)) 20 | import Test.Falsify.Generator (Gen) 21 | import qualified Test.Falsify.Generator as Gen 22 | import qualified Test.Falsify.Range as Range 23 | import Data.Bits (FiniteBits) 24 | import GHC.Exts (IsList (..), IsString (..)) 25 | import GHC.TypeLits (KnownNat, natVal, Nat) 26 | 27 | class GenDefault tag a where 28 | -- | Default generator for @a@ 29 | -- 30 | -- The type-level @tag@ allows types @a@ to have multiple defaults. 31 | genDefault :: Proxy tag -> Gen a 32 | 33 | -- | DerivingVia wrapper for types with default instances under other tags 34 | newtype ViaTag tag' a = ViaTag {unViaTag :: a} 35 | 36 | instance GenDefault tag' a => GenDefault tag (ViaTag tag' a) where 37 | genDefault _ = fmap ViaTag (genDefault @tag' Proxy) 38 | 39 | -- | DerivingVia wrapper for Integral types 40 | newtype ViaIntegral a = ViaIntegral {unViaIntegral :: a} 41 | 42 | instance (Integral a, FiniteBits a, Bounded a) => GenDefault tag (ViaIntegral a) where 43 | genDefault _ = fmap ViaIntegral (Gen.inRange (Range.between (minBound, maxBound))) 44 | 45 | -- | DerivingVia wrapper for Enum types 46 | newtype ViaEnum a = ViaEnum {unViaEnum :: a} 47 | 48 | instance (Enum a, Bounded a) => GenDefault tag (ViaEnum a) where 49 | genDefault _ = fmap ViaEnum (Gen.inRange (Range.enum (minBound, maxBound))) 50 | 51 | -- | DerivingVia wrapper for FromList types 52 | newtype ViaList l (mn :: Nat) (mx :: Nat) = ViaList {unViaList :: l} 53 | 54 | instance (IsList l, GenDefault tag (Item l), KnownNat mn, KnownNat mx) => GenDefault tag (ViaList l mn mx) where 55 | genDefault p = 56 | let bn = fromInteger (natVal (Proxy @mn)) 57 | bx = fromInteger (natVal (Proxy @mx)) 58 | in fmap (ViaList . fromList) (Gen.list (Range.between (bn, bx)) (genDefault p)) 59 | 60 | -- | DerivingVia wrapper for FromString types 61 | newtype ViaString s (mn :: Nat) (mx :: Nat) = ViaString {unViaString :: s} 62 | 63 | instance (IsString s, GenDefault tag Char, KnownNat mn, KnownNat mx) => GenDefault tag (ViaString s mn mx) where 64 | genDefault p = 65 | let bn = fromInteger (natVal (Proxy @mn)) 66 | bx = fromInteger (natVal (Proxy @mx)) 67 | in fmap (ViaString . fromString) (Gen.list (Range.between (bn, bx)) (genDefault p)) 68 | 69 | class GGenDefault tag f where 70 | ggenDefault :: Proxy tag -> Gen (f a) 71 | 72 | instance GGenDefault tag U1 where 73 | ggenDefault _ = pure U1 74 | 75 | instance GGenDefault tag a => GGenDefault tag (M1 i c a) where 76 | ggenDefault = fmap M1 . ggenDefault 77 | 78 | instance (GGenDefault tag a, GGenDefault tag b) => GGenDefault tag (a :*: b) where 79 | ggenDefault p = liftA2 (:*:) (ggenDefault p) (ggenDefault p) 80 | 81 | instance (GGenDefault tag a, GGenDefault tag b) => GGenDefault tag (a :+: b) where 82 | ggenDefault p = Gen.choose (fmap L1 (ggenDefault p)) (fmap R1 (ggenDefault p)) 83 | 84 | instance GenDefault tag a => GGenDefault tag (K1 i a) where 85 | ggenDefault = fmap K1 . genDefault 86 | 87 | -- | DerivingVia wrapper for Generic types 88 | newtype ViaGeneric tag a = ViaGeneric {unViaGeneric :: a} 89 | 90 | instance (Generic t, GGenDefault tag (Rep t)) => GenDefault tag (ViaGeneric tag t) where 91 | genDefault = fmap (ViaGeneric . to) . ggenDefault -------------------------------------------------------------------------------- /lib/test/TestSuite/Prop/Generator/Selective.hs: -------------------------------------------------------------------------------- 1 | module TestSuite.Prop.Generator.Selective (tests) where 2 | 3 | import Control.Monad 4 | import Control.Selective 5 | import Data.Default 6 | import Data.Word 7 | import Test.Tasty 8 | import Test.Tasty.Falsify 9 | 10 | import qualified Test.Falsify.Generator as Gen 11 | import qualified Test.Falsify.Predicate as P 12 | 13 | tests :: TestTree 14 | tests = testGroup "TestSuite.Prop.Generator.Selective" [ 15 | testGroup "pair" [ 16 | testProperty "ifM" $ prop_pair ifM 17 | , testPropertyWith expectFailure "ifS" $ prop_pair ifS 18 | , testProperty "ifThenElse" $ prop_pair_ifThenElse 19 | ] 20 | ] 21 | where 22 | expectFailure :: TestOptions 23 | expectFailure = def { 24 | expectFailure = ExpectFailure 25 | , overrideNumTests = Just 10_000 26 | } 27 | 28 | {------------------------------------------------------------------------------- 29 | Either 30 | 31 | We only only primitive generators here (avoiding generators like 32 | 'Test.Falsify.Reexported.Generator.Simple.bool') to avoid getting distracted 33 | by specific implementation details of derived generators. 34 | -------------------------------------------------------------------------------} 35 | 36 | -- If we use monadic bind, the seed for the Right value is reused when 37 | -- when we shrink it to Left: they are not independent. 38 | -- 39 | -- Here this is still somewhat reasonable, but in general this means we 40 | -- will reuse a seed reduced in one context in a completely different 41 | -- context, which may not make any sense at all. 42 | propEither :: 43 | (Word64, Either Word64 Word64) 44 | -> (Word64, Either Word64 Word64) 45 | -> Bool 46 | propEither _ (_, Left 0) = True -- Can always shrink to 'Minimal' 47 | propEither (_, Right x) (_, Left y) = x == y 48 | propEither _ _ = True 49 | 50 | genPair :: 51 | (forall a. Gen Bool -> Gen a -> Gen a -> Gen a) 52 | -> Gen (Word64, Either Word64 Word64) 53 | genPair if_ = 54 | (,) <$> Gen.prim 55 | <*> if_ ((== 0) <$> Gen.prim) 56 | (Left <$> Gen.exhaustive 100) 57 | (Right <$> Gen.exhaustive 100) 58 | 59 | prop_pair :: (forall a. Gen Bool -> Gen a -> Gen a -> Gen a) -> Property () 60 | prop_pair if_ = 61 | testShrinkingOfGen (P.relatedBy ("propEither", propEither)) $ 62 | genPair if_ 63 | 64 | prop_pair_ifThenElse :: Property () 65 | prop_pair_ifThenElse = 66 | testShrinking (P.relatedBy ("stayRight", stayRight)) $ do 67 | pair <- gen $ genPair ifBoth 68 | when (prop pair) $ testFailed pair 69 | where 70 | prop :: (Word64, Either Word64 Word64) -> Bool 71 | prop (x, Right y) = x < 10 || y > x 72 | prop (x, Left y) = x < 1 || y < x 73 | 74 | -- Since we are generating the left value before the right value, if we 75 | -- /start/ with a right value, we will then shrink the left value first even 76 | -- though it is not used: indeed, this /must/ always succeed precisely 77 | -- /because/ that left value is not used. At that point we can no longer 78 | -- reduce the Right to a Left, because @Left 0@ is not a counterexample. 79 | stayRight :: 80 | (Word64, Either Word64 Word64) 81 | -> (Word64, Either Word64 Word64) 82 | -> Bool 83 | stayRight _ (_, Left 0) = True -- Can always shrink to 'Minimal' 84 | stayRight (_, Right _) (_, Left _) = False 85 | stayRight _ _ = True 86 | 87 | {------------------------------------------------------------------------------- 88 | Generic auxiliary 89 | -------------------------------------------------------------------------------} 90 | 91 | ifM :: Gen Bool -> Gen a -> Gen a -> Gen a 92 | ifM cond t f = cond `Gen.bindWithoutShortcut` \b -> if b then t else f 93 | 94 | ifBoth :: Gen Bool -> Gen a -> Gen a -> Gen a 95 | ifBoth cond t f = 96 | t `Gen.bindWithoutShortcut` \x -> 97 | f `Gen.bindWithoutShortcut` \y -> 98 | cond `Gen.bindWithoutShortcut` \b -> 99 | return $ if b then x else y -------------------------------------------------------------------------------- /lib/src/Test/Falsify/Internal/Search.hs: -------------------------------------------------------------------------------- 1 | module Test.Falsify.Internal.Search ( 2 | -- * Binary search 3 | binarySearch 4 | , binarySearchNoParityBias 5 | ) where 6 | 7 | import Data.Bits 8 | import Data.List (nub) 9 | import Data.Word 10 | 11 | {------------------------------------------------------------------------------- 12 | Binary search 13 | -------------------------------------------------------------------------------} 14 | 15 | -- | Binary search 16 | -- 17 | -- Compute one step of a binary search algorithm. 18 | -- 19 | -- Examples: 20 | -- 21 | -- > binarySearch 0 == [] 22 | -- > binarySearch 1 == [0] 23 | -- > binarySearch 2 == [0,1] 24 | -- > binarySearch 3 == [0,2] 25 | -- > binarySearch 4 == [0,2,3] 26 | -- > binarySearch 5 == [0,3,4] 27 | -- > binarySearch 6 == [0,3,5] 28 | -- > binarySearch 7 == [0,4,6] 29 | -- > binarySearch 8 == [0,4,6,7] 30 | -- > binarySearch 9 == [0,5,7,8] 31 | -- > binarySearch 10 == [0,5,8,9] 32 | -- > binarySearch 16 == [0,8,12,14,15] 33 | -- > binarySearch 127 == [0,64,96,112,120,124,126] 34 | -- > binarySearch 128 == [0,64,96,112,120,124,126,127] 35 | -- 36 | -- The gap between each successive number halves at each step. 37 | -- 38 | -- NOTE: 'binarySearch' introduces a bias for even numbers: when shrinking 39 | -- succeeds with the first (non-zero) option, the number is basically halved 40 | -- each at step; since halving an even number results in another even number, 41 | -- and halving an odd number /also/ results in an even number, this results in a 42 | -- strong bias towards even numbers. See also 'binarySearchNoParityBias'. 43 | binarySearch :: Word64 -> [Word64] 44 | binarySearch = go 0 . deltas 45 | where 46 | go :: Word64 -> [Word64] -> [Word64] 47 | go _ [] = [] 48 | go n (d:ds) = n : go (n + d) ds 49 | 50 | -- | Binary search without parity bias 51 | -- 52 | -- For some cases the parity (even or odd) of a number is very important, and 53 | -- unfotunately standard binary search is not very good at allowing search to 54 | -- flip between even and odd. For example, if we start with 'maxBound', 55 | -- /every/ possibly shrink value computed by 'binarySearch' is even. The 56 | -- situation is less extreme for other numbers, but it's nonetheless something 57 | -- we need to take into account. 58 | -- 59 | -- In this function we pair each possible shrunk value with the corresponding 60 | -- value of opposite parity, ordered in such a way that we try to shrink to 61 | -- opposite parity first. 62 | -- 63 | -- Examples: 64 | -- 65 | -- > binarySearchNoParityBias 0 == [] 66 | -- > binarySearchNoParityBias 1 == [0] 67 | -- > binarySearchNoParityBias 2 == [1,0] 68 | -- > binarySearchNoParityBias 3 == [0,1,2] 69 | -- > binarySearchNoParityBias 4 == [1,0,3,2] 70 | -- > binarySearchNoParityBias 5 == [0,1,2,3,4] 71 | -- > binarySearchNoParityBias 6 == [1,0,3,2,5,4] 72 | -- > binarySearchNoParityBias 7 == [0,1,4,5,6] 73 | -- > binarySearchNoParityBias 8 == [1,0,5,4,7,6] 74 | -- > binarySearchNoParityBias 9 == [0,1,4,5,6,7,8] 75 | -- > binarySearchNoParityBias 10 == [1,0,5,4,9,8] 76 | -- > binarySearchNoParityBias 16 == [1,0,9,8,13,12,15,14] 77 | -- > binarySearchNoParityBias 127 == [0,1,64,65,96,97,112,113,120,121,124,125,126] 78 | -- > binarySearchNoParityBias 128 == [1,0,65,64,97,96,113,112,121,120,125,124,127,126] 79 | binarySearchNoParityBias :: Word64 -> [Word64] 80 | binarySearchNoParityBias y = 81 | filter (< y) . nub . concatMap pairWithOpposite $ 82 | binarySearch y 83 | where 84 | pairWithOpposite :: Word64 -> [Word64] 85 | pairWithOpposite x 86 | | even x == even y = [x `xor` 1, x] 87 | | otherwise = [x, x `xor` 1] 88 | 89 | -- | Auxiliary to 'binarySearch' 90 | -- 91 | -- Given a number @n@, compute a set of steps @n1, n2, ..@ such that 92 | -- @sum [n1, n2, ..] == n@, the distance between each subsequent step 93 | -- is halved, and all steps are non-zero. For example: 94 | -- 95 | -- > deltas 200 == [100,50,25,12,6,3,2,1,1] 96 | deltas :: Word64 -> [Word64] 97 | deltas 0 = [] 98 | deltas 1 = [1] 99 | deltas n 100 | | even n = mid : deltas mid 101 | | otherwise = mid + 1 : deltas mid 102 | where 103 | mid = n `div` 2 104 | -------------------------------------------------------------------------------- /lib/test/TestSuite/Sanity/Selective.hs: -------------------------------------------------------------------------------- 1 | module TestSuite.Sanity.Selective (tests) where 2 | 3 | import Control.Selective 4 | import Data.Word 5 | import System.Timeout 6 | import Test.Tasty 7 | import Test.Tasty.HUnit 8 | 9 | import Test.Falsify.Generator (Gen, Tree(..)) 10 | import Test.Falsify.Interactive (sample, shrink') 11 | 12 | import qualified Test.Falsify.Generator as Gen 13 | 14 | tests :: TestTree 15 | tests = testGroup "TestSuite.Sanity.Selective" [ 16 | testGroup "tree" [ 17 | testCaseInfo "ifBoth" test_tree_ifBoth 18 | , testGroup "ifS" [ 19 | testCase "10" $ test_tree_ifS 10 20 | , testCase "20" $ test_tree_ifS 20 21 | , testCase "30" $ test_tree_ifS 30 22 | , testCase "40" $ test_tree_ifS 40 23 | , testCase "50" $ test_tree_ifS 50 24 | , testCase "60" $ test_tree_ifS 60 25 | , testCase "70" $ test_tree_ifS 70 26 | , testCase "80" $ test_tree_ifS 80 27 | , testCase "90" $ test_tree_ifS 90 28 | , testCase "100" $ test_tree_ifS 100 29 | ] 30 | ] 31 | ] 32 | 33 | {------------------------------------------------------------------------------- 34 | Tree 35 | 36 | In this test we construct a "biased tree" (aka list) using a generator for a 37 | /complete/ tree but then only using part of the result. Clearly, if we 38 | /actually/ used the entire complete tree, this would have exponential 39 | complexity, so that's not an option. 40 | 41 | The problem is not in /generation/, which is sufficiently lazy, but in 42 | shrinking. With the monadic interface, there are two non-solutions: 43 | 44 | - With the shrinking shortcut in place (reducing entire prats of the tree 45 | to 'Minimal'), then shrinking isn't all that interesting: the part of the 46 | tree we're not using will be set to all zeroes immediately (this is what 47 | the @either@ examples were demonstrating) 48 | - Without the shrinking shortcut in place, the /generator/ might not look 49 | at the full complete tree, but the /shrinker/ will, and so shrinking will 50 | have abysmal performance. This is demonstrated in 'test_tree_ifBoth'. 51 | 52 | With the selective interface, however, everything works just fine. 53 | -------------------------------------------------------------------------------} 54 | 55 | test_tree_ifBoth :: IO String 56 | test_tree_ifBoth = do 57 | let depth = 15 58 | -- Verify that we /don't/ get a timeout during generation 59 | sampled <- sample (tree ifBoth depth) 60 | assertBool "initial" $ isBiased sampled 61 | -- But we /do/ get a timeout during shrinking 62 | didTimeout <- timeout 10_000_000 $ do 63 | Just history <- shrink' Just (tree ifBoth depth) 64 | assertBool "shrunk" $ all isBiased history 65 | return history 66 | case didTimeout of 67 | Nothing -> return "Timed out as expected" 68 | Just history -> assertFailure $ unlines [ 69 | "Expected timeout, but did not get it. " 70 | , "Shrink history: " ++ show history 71 | ] 72 | 73 | test_tree_ifS :: Word64 -> Assertion 74 | test_tree_ifS depth = do 75 | sampled <- sample (tree ifS depth) 76 | assertBool "initial" $ isBiased sampled 77 | Just shrunk <- shrink' Just (tree ifS depth) 78 | assertBool "shrunk" $ all isBiased shrunk 79 | 80 | isBiased :: Tree a -> Bool 81 | isBiased Leaf = True 82 | isBiased (Branch _ Leaf t ) = isBiased t 83 | isBiased (Branch _ t Leaf ) = isBiased t 84 | isBiased (Branch _ Branch{} Branch{}) = False 85 | 86 | tree :: 87 | (forall a. Gen Bool -> Gen a -> Gen a -> Gen a) 88 | -> Word64 -> Gen (Tree Word64) 89 | tree if_ = go 90 | where 91 | go :: Word64 -> Gen (Tree Word64) 92 | go 0 = pure Leaf 93 | go d = 94 | Gen.prim `Gen.bindWithoutShortcut` \x -> 95 | if_ ((== 0) <$> Gen.prim) 96 | ((\t -> Branch x t Leaf) <$> go (d - 1)) 97 | ((\t -> Branch x Leaf t) <$> go (d - 1)) 98 | 99 | {------------------------------------------------------------------------------- 100 | Generic auxiliary 101 | -------------------------------------------------------------------------------} 102 | 103 | ifBoth :: Gen Bool -> Gen a -> Gen a -> Gen a 104 | ifBoth cond t f = 105 | t `Gen.bindWithoutShortcut` \x -> 106 | f `Gen.bindWithoutShortcut` \y -> 107 | cond `Gen.bindWithoutShortcut` \b -> 108 | return $ if b then x else y -------------------------------------------------------------------------------- /lib/test/TestSuite/Prop/Generator/Shrinking.hs: -------------------------------------------------------------------------------- 1 | module TestSuite.Prop.Generator.Shrinking (tests) where 2 | 3 | import Control.Monad 4 | import Data.Default 5 | import Data.Word 6 | import Test.Tasty 7 | import Test.Tasty.Falsify 8 | 9 | import qualified Test.QuickCheck as QuickCheck 10 | 11 | import qualified Test.Falsify.Generator as Gen 12 | import qualified Test.Falsify.Predicate as P 13 | 14 | import TestSuite.Util.List 15 | 16 | tests :: TestTree 17 | tests = testGroup "TestSuite.Prop.Generator.Shrinking" [ 18 | testGroup "prim" [ 19 | testPropertyWith expectFailure "prim" prop_prim_minimum 20 | ] 21 | , testGroup "shrinkTo" [ 22 | testProperty "shrinking" prop_shrinkTo_shrinking 23 | , testProperty "minimum" prop_shrinkTo_minimum 24 | ] 25 | , testGroup "firstThen" [ 26 | testProperty "shrinking" prop_firstThen_shrinking 27 | , testProperty "minimum" prop_firstThen_minimum 28 | ] 29 | , testGroup "shrinkWith" [ 30 | testGroup "minimum" [ 31 | testProperty "minimum" prop_shrinkWith_minimum_word 32 | , testGroup "list" [ 33 | testProperty (show i) $ prop_shrinkWith_minimum_list i 34 | | i <- [20, 40, 60, 80, 100, 120, 140, 160, 180] 35 | ] 36 | ] 37 | ] 38 | ] 39 | where 40 | expectFailure :: TestOptions 41 | expectFailure = def { 42 | expectFailure = ExpectFailure 43 | , overrideNumTests = Just 10_000 44 | } 45 | 46 | {------------------------------------------------------------------------------- 47 | prim 48 | -------------------------------------------------------------------------------} 49 | 50 | -- Binary search is not guaranteed to always find the minimum value. For 51 | -- example, if we are looking for counter-examples to the property that "all 52 | -- numbers are even", and we start with 3, then binary search will only try 0 53 | -- and 2, both of which are even, and hence conclude that 3 is the minimum 54 | -- counter-example. This is true in QuickCheck, also. 55 | prop_prim_minimum :: Property () 56 | prop_prim_minimum = 57 | testMinimum (P.expect 1) $ do 58 | x <- gen Gen.prim 59 | unless (even x) $ testFailed x 60 | 61 | {------------------------------------------------------------------------------- 62 | shrinkTo 63 | -------------------------------------------------------------------------------} 64 | 65 | prop_shrinkTo_shrinking :: Property () 66 | prop_shrinkTo_shrinking = 67 | testShrinkingOfGen (P.relatedBy ("validShrink", validShrink)) $ 68 | Gen.shrinkToOneOf 3 [0 :: Word .. 2] 69 | where 70 | -- 'shrinkToOneOf' only shrinks /once/, so the original (pre-shrink) value 71 | -- /must/ be 3. 72 | validShrink :: Word -> Word -> Bool 73 | validShrink 3 0 = True 74 | validShrink 3 1 = True 75 | validShrink 3 2 = True 76 | validShrink _ _ = False 77 | 78 | prop_shrinkTo_minimum :: Property () 79 | prop_shrinkTo_minimum = 80 | testMinimum (P.expect 1) $ do 81 | x <- gen $ Gen.shrinkToOneOf 3 [0 :: Word .. 2] 82 | unless (even x) $ testFailed x 83 | 84 | {------------------------------------------------------------------------------- 85 | firstThen 86 | -------------------------------------------------------------------------------} 87 | 88 | prop_firstThen_shrinking :: Property () 89 | prop_firstThen_shrinking = 90 | testShrinkingOfGen (P.relatedBy ("validShrink", validShrink)) $ 91 | Gen.firstThen True False 92 | where 93 | validShrink :: Bool -> Bool -> Bool 94 | validShrink True False = True 95 | validShrink _ _ = False 96 | 97 | prop_firstThen_minimum :: Property () 98 | prop_firstThen_minimum = 99 | testMinimum (P.expect False) $ do 100 | x <- gen $ Gen.firstThen True False 101 | testFailed x 102 | 103 | {------------------------------------------------------------------------------- 104 | shrinkWith 105 | -------------------------------------------------------------------------------} 106 | 107 | -- This is obviously not a valid general-purpose shrinking function for 108 | -- 'Word64', but that is not important here. 109 | shrinkWord :: Word64 -> [Word64] 110 | shrinkWord n = takeWhile (< n) [0 .. 100] 111 | 112 | prop_shrinkWith_minimum_word :: Property () 113 | prop_shrinkWith_minimum_word = 114 | testMinimum (P.expect 1) $ do 115 | x <- gen $ Gen.shrinkWith shrinkWord Gen.prim 116 | unless (even x) $ testFailed x 117 | 118 | -- | Test performance of 'shrinkWith' 119 | -- 120 | -- We test this for lists of increasing size, to verify that this is not growing 121 | -- exponentially with the size of the list (and thereby verifying that we are 122 | -- not exploring the full shrink tree of those lists, because they certainly 123 | -- /are/ exponential in size). 124 | prop_shrinkWith_minimum_list :: Int -> Property () 125 | prop_shrinkWith_minimum_list listLength = 126 | testMinimum (P.expect [1,0]) $ do 127 | xs <- gen $ Gen.shrinkWith (QuickCheck.shrinkList shrinkWord) $ 128 | replicateM listLength Gen.prim 129 | unless (pairwiseAll (<=) xs) $ testFailed xs 130 | 131 | 132 | 133 | -------------------------------------------------------------------------------- /lib/src/Test/Falsify/Reexported/Generator/Shrinking.hs: -------------------------------------------------------------------------------- 1 | module Test.Falsify.Reexported.Generator.Shrinking ( 2 | -- * User-specified shrinking 3 | shrinkToOneOf 4 | , firstThen 5 | , shrinkWith 6 | -- * Support for shrink trees 7 | , fromShrinkTree 8 | , toShrinkTree 9 | ) where 10 | 11 | import Prelude hiding (properFraction) 12 | 13 | import Data.Word 14 | 15 | import qualified Data.Tree as Rose 16 | 17 | import Test.Falsify.Internal.Generator 18 | import Test.Falsify.Internal.SampleTree (Sample(..), SampleTree) 19 | 20 | {------------------------------------------------------------------------------- 21 | Specialized shrinking behaviour 22 | -------------------------------------------------------------------------------} 23 | 24 | -- | Start with @x@, then shrink to one of the @xs@ 25 | -- 26 | -- Once shrunk, will not shrink again. 27 | -- 28 | -- Minimal value is the first shrunk value, if it exists, and the original 29 | -- otherwise. 30 | shrinkToOneOf :: forall a. a -> [a] -> Gen a 31 | shrinkToOneOf x xs = 32 | aux <$> primWith shrinker 33 | where 34 | aux :: Sample -> a 35 | aux (NotShrunk _) = x 36 | aux (Shrunk i) = index i xs 37 | 38 | -- When we shrink, we will try a bunch of new sample trees; we must ensure 39 | -- that we can try /any/ of the possible shrunk values. 40 | -- 41 | -- We use this to implement 'fromShrinkTree'. Here, we explore a rose tree 42 | -- of possibilities; at every level in the tree, once we make a choice, 43 | -- we should commit to that choice and not consider it over and over again. 44 | -- Thus, once shrunk, we should not shrink any further. 45 | shrinker :: Sample -> [Word64] 46 | shrinker (Shrunk _) = [] 47 | shrinker (NotShrunk _) = zipWith const [0..] xs 48 | 49 | -- Index the list of possible shrunk values. This is a bit like @(!!)@ from 50 | -- the prelude, but with some edge cases. 51 | -- 52 | -- - If the list is empty, we return the unshrunk value. 53 | -- - Otherwise, if the index exceeds the bounds, we return the last element. 54 | -- 55 | -- These two special cases can arise in one of two circumstances: 56 | -- 57 | -- - When we run the generator against the 'Minimal' tree. This will give us 58 | -- a @Shrunk 0@ value, independent of what the specified shrinking 59 | -- function does, and it is important that we produce the right value. 60 | -- - When the generator is run against a sample tree that was shrunk wrt to 61 | -- a /different/ generator. In this case the value could be anything; 62 | -- we return the final ("least preferred") element, and then rely on 63 | -- later shrinking to replace this with a more preferred element. 64 | index :: Word64 -> [a] -> a 65 | index _ [] = x 66 | index _ [y] = y 67 | index 0 (y:_) = y 68 | index n (_:ys) = index (n - 1) ys 69 | 70 | -- | Generator that always produces @x@ as initial value, and shrinks to @y@ 71 | firstThen :: forall a. a -> a -> Gen a 72 | firstThen x y = x `shrinkToOneOf` [y] 73 | 74 | -- | Shrink with provided shrinker 75 | -- 76 | -- This provides compatibility with QuickCheck-style manual shrinking. 77 | -- 78 | -- Defined in terms of 'fromShrinkTree'; see discussion there for some 79 | -- notes on performance. 80 | shrinkWith :: forall a. (a -> [a]) -> Gen a -> Gen a 81 | shrinkWith f gen = do 82 | -- It is critical that we do not apply normal shrinking of the 'SampleTree' 83 | -- here (not even to 'Minimal'). If we did, then the resulting shrink tree 84 | -- would change, and we would be unable to iteratively construct a path 85 | -- through the shrink tree. 86 | -- 87 | -- Of course, it can still happen that the generator gets reapplied in a 88 | -- different context; we must take this case into account in 89 | -- 'shrinkToOneOf'. 90 | x <- withoutShrinking gen 91 | fromShrinkTree $ Rose.unfoldTree (\x' -> (x', f x')) x 92 | 93 | {------------------------------------------------------------------------------- 94 | Shrink trees 95 | -------------------------------------------------------------------------------} 96 | 97 | -- | Construct generator from shrink tree 98 | -- 99 | -- This provides compatibility with Hedgehog-style integrated shrinking. 100 | -- 101 | -- This is O(n^2) in the number of shrink steps: as this shrinks, the generator 102 | -- is growing a path of indices which locates a particular value in the shrink 103 | -- tree (resulting from unfolding the provided shrinking function). At each 104 | -- step during the shrinking process the shrink tree is re-evaluated and the 105 | -- next value in the tree is located; since this path throws linearly, the 106 | -- overall cost is O(n^2). 107 | -- 108 | -- The O(n^2) cost is only incurred on /locating/ the next element to be tested; 109 | -- the property is not reevaluated at already-shrunk values. 110 | fromShrinkTree :: forall a. Rose.Tree a -> Gen a 111 | fromShrinkTree = go 112 | where 113 | go :: Rose.Tree a -> Gen a 114 | go (Rose.Node x xs) = do 115 | next <- Nothing `shrinkToOneOf` map Just xs 116 | case next of 117 | Nothing -> return x 118 | Just x' -> go x' 119 | 120 | -- | Expose the full shrink tree of a generator 121 | -- 122 | -- This generator does not shrink. 123 | toShrinkTree :: forall a. Gen a -> Gen (Rose.Tree a) 124 | toShrinkTree gen = 125 | Rose.unfoldTree aux . runGen gen <$> captureLocalTree 126 | where 127 | aux :: (a, [SampleTree]) -> (a,[(a, [SampleTree])]) 128 | aux (x, shrunk) = (x, map (runGen gen) shrunk) 129 | -------------------------------------------------------------------------------- /lib/test/TestSuite/Prop/Generator/Function.hs: -------------------------------------------------------------------------------- 1 | module TestSuite.Prop.Generator.Function (tests) where 2 | 3 | import Control.Monad 4 | import Data.Default 5 | import Data.Word 6 | import Test.Tasty 7 | import Test.Tasty.Falsify 8 | 9 | import qualified Data.Set as Set 10 | 11 | import Test.Falsify.Generator (Fun) 12 | 13 | import qualified Test.Falsify.Generator as Gen 14 | import qualified Test.Falsify.Predicate as P 15 | import qualified Test.Falsify.Range as Range 16 | 17 | tests :: TestTree 18 | tests = testGroup "TestSuite.Prop.Generator.Function" [ 19 | testGroup "BoolToBool" [ 20 | testProperty "notConstant" prop_BoolToBool_notConstant 21 | , testProperty "constant" prop_BoolToBool_constant 22 | ] 23 | , testProperty "Word8ToBool" prop_Word8ToBool 24 | , testPropertyWith fewerTests "IntegerToBool" prop_IntegerToBool 25 | , testProperty "IntToInt" prop_IntToInt 26 | , testPropertyWith fewerTests "StringToBool" prop_StringToBool 27 | ] 28 | where 29 | -- These tests are pretty slow 30 | fewerTests :: TestOptions 31 | fewerTests = def { 32 | overrideNumTests = Just 10 33 | } 34 | 35 | {------------------------------------------------------------------------------- 36 | Functions @Bool -> Bool@ 37 | 38 | TODO: Should we define these in terms of the concrete functions instead? 39 | -------------------------------------------------------------------------------} 40 | 41 | prop_BoolToBool_notConstant :: Property () 42 | prop_BoolToBool_notConstant = 43 | testMinimum (P.satisfies ("isConstant", isConstant)) $ do 44 | fn <- gen $ Gen.fun (Gen.bool False) 45 | let Fn f = fn 46 | -- "No function Bool -> Bool can be constant" 47 | unless (f False /= f True) $ testFailed fn 48 | where 49 | isConstant :: Fun Bool Bool -> Bool 50 | isConstant fn = show fn == "{_->False}" 51 | 52 | prop_BoolToBool_constant :: Property () 53 | prop_BoolToBool_constant = do 54 | testMinimum (P.satisfies ("notConstant", notConstant)) $ do 55 | fn <- gen $ Gen.fun (Gen.bool False) 56 | let Fn f = fn 57 | -- "Every function Bool -> Bool is constant" 58 | unless (f False == f True) $ testFailed fn 59 | where 60 | notConstant :: Fun Bool Bool -> Bool 61 | notConstant fn = or [ 62 | show fn == "{True->True, _->False}" 63 | , show fn == "{False->True, _->False}" 64 | ] 65 | 66 | {------------------------------------------------------------------------------- 67 | Functions @Word8 -> Bool@ 68 | -------------------------------------------------------------------------------} 69 | 70 | prop_Word8ToBool :: Property () 71 | prop_Word8ToBool = do 72 | testMinimum (P.satisfies ("notConstant", notConstant)) $ do 73 | fn <- gen $ Gen.fun (Gen.bool False) 74 | -- "Every function Word8 -> Bool is constant" 75 | unless (isConstant fn) $ testFailed fn 76 | where 77 | notConstant :: Fun Word8 Bool -> Bool 78 | notConstant fn = any aux [0 .. 255] 79 | where 80 | aux :: Word8 -> Bool 81 | aux n = show fn == "{" ++ show n ++ "->True, _->False}" 82 | 83 | isConstant :: Fun Word8 Bool -> Bool 84 | isConstant (Fn f) = 85 | (\s -> Set.size s == 1) $ 86 | Set.fromList (map f [minBound .. maxBound]) 87 | 88 | {------------------------------------------------------------------------------- 89 | Functions @Integer -> Bool@ 90 | 91 | This is the first test where the input domain is infinite. 92 | -------------------------------------------------------------------------------} 93 | 94 | prop_IntegerToBool :: Property () 95 | prop_IntegerToBool = 96 | testMinimum (P.satisfies ("expected", expected)) $ do 97 | fn <- gen $ Gen.fun (Gen.bool False) 98 | let Fn f = fn 99 | -- "Every fn from Integer to Bool must give the same result for π and φ" 100 | unless (f 3142 == f 1618) $ testFailed fn 101 | where 102 | expected :: Fun Integer Bool -> Bool 103 | expected fn = or [ 104 | show fn == "{1618->True, _->False}" 105 | , show fn == "{3142->True, _->False}" 106 | ] 107 | 108 | {------------------------------------------------------------------------------- 109 | Functions @Int -> Int@ 110 | -------------------------------------------------------------------------------} 111 | 112 | prop_IntToInt :: Property () 113 | prop_IntToInt = 114 | testMinimum (P.satisfies ("expected", expected)) $ do 115 | fn <- gen $ Gen.fun (Gen.inRange $ Range.between (0, 100)) 116 | let Fn f = fn 117 | unless (f 0 == 0 && f 1 == 0) $ testFailed fn 118 | where 119 | expected :: Fun Int Int -> Bool 120 | expected fn = or [ 121 | show fn == "{1->1, _->0}" 122 | , show fn == "{0->1, _->0}" 123 | ] 124 | 125 | {------------------------------------------------------------------------------- 126 | Functions @String -> Bool@ 127 | 128 | This example (as well as 'test_IntToInt_mapFilter') is adapted from 129 | Koen Claessen's presentation "Shrinking and showing functions" 130 | at Haskell Symposium 2012 . 131 | 132 | TODO: His example uses longer strings, which does work, it's just expensive. 133 | We can definitely use some performance optimization here. 134 | -------------------------------------------------------------------------------} 135 | 136 | prop_StringToBool :: Property () 137 | prop_StringToBool = 138 | testMinimum (P.satisfies ("expected", expected)) $ do 139 | fn <- gen $ Gen.fun (Gen.bool False) 140 | let Fn p = fn 141 | unless (p "abc" `implies` p "def") $ testFailed fn 142 | where 143 | -- TODO: Actually, the second case doesn't seem to get triggered. Not sure 144 | -- why; maybe it's just unlikely..? 145 | expected :: Fun String Bool -> Bool 146 | expected fn = or [ 147 | show fn == "{\"abc\"->True, _->False}" 148 | , show fn == "{\"def\"->True, _->False}" 149 | ] 150 | 151 | implies :: Bool -> Bool -> Bool 152 | implies False _ = True 153 | implies True b = b 154 | -------------------------------------------------------------------------------- /lib/falsify.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: falsify 3 | version: 0.2.1 4 | synopsis: Property-based testing with internal integrated shrinking 5 | description: This library provides property based testing with support 6 | for internal integrated shrinking: integrated in the sense 7 | of Hedgehog, meaning that there is no need to write a 8 | separate shrinker and generator; and internal in the sense 9 | of Hypothesis, meaning that this works well even across 10 | monadic bind. However, the actual techniques that power 11 | @falsify@ are quite different from both of these two 12 | libraries. 13 | 14 | Most users will probably want to use the integration with 15 | @@, 16 | and use "Test.Tasty.Falsify" as their main entrypoint 17 | into the library. The "Test.Falsify.Interactive" module 18 | can be used to experiment with the library in @ghci@. 19 | 20 | license: BSD-3-Clause 21 | license-file: LICENSE 22 | author: Edsko de Vries 23 | maintainer: edsko@well-typed.com 24 | copyright: Well-Typed LLP 25 | category: Testing 26 | build-type: Simple 27 | extra-doc-files: CHANGELOG.md 28 | tested-with: GHC==8.10.7 29 | , GHC==9.0.2 30 | , GHC==9.2.8 31 | , GHC==9.4.8 32 | , GHC==9.6.7 33 | , GHC==9.8.4 34 | , GHC==9.10.1 35 | , GHC==9.12.2 36 | 37 | source-repository head 38 | type: git 39 | location: https://github.com/well-typed/falsify 40 | 41 | common lang 42 | ghc-options: 43 | -Wall 44 | -Wredundant-constraints 45 | -Widentities 46 | build-depends: 47 | base >= 4.12 && < 4.22 48 | default-language: 49 | Haskell2010 50 | default-extensions: 51 | BangPatterns 52 | DataKinds 53 | DefaultSignatures 54 | DeriveAnyClass 55 | DeriveFoldable 56 | DeriveFunctor 57 | DeriveGeneric 58 | DeriveTraversable 59 | DerivingStrategies 60 | DerivingVia 61 | DisambiguateRecordFields 62 | FlexibleContexts 63 | FlexibleInstances 64 | GADTs 65 | GeneralizedNewtypeDeriving 66 | InstanceSigs 67 | KindSignatures 68 | LambdaCase 69 | MultiParamTypeClasses 70 | MultiWayIf 71 | NamedFieldPuns 72 | NumericUnderscores 73 | PatternSynonyms 74 | QuantifiedConstraints 75 | RankNTypes 76 | ScopedTypeVariables 77 | StandaloneDeriving 78 | TupleSections 79 | TypeApplications 80 | TypeOperators 81 | ViewPatterns 82 | 83 | library 84 | import: 85 | lang 86 | exposed-modules: 87 | Test.Falsify.GenDefault 88 | Test.Falsify.GenDefault.Std 89 | Test.Falsify.Generator 90 | Test.Falsify.Interactive 91 | Test.Falsify.Predicate 92 | Test.Falsify.Property 93 | Test.Falsify.Range 94 | 95 | -- For consistency with the other tasty runners, we places these modules 96 | -- in the @Test.Tasty.*@ hiearchy instead of @Test.Falsify.*@. 97 | Test.Tasty.Falsify 98 | other-modules: 99 | Test.Falsify.Internal.Driver 100 | Test.Falsify.Internal.Driver.ReplaySeed 101 | Test.Falsify.Internal.Driver.Tasty 102 | Test.Falsify.Internal.Generator 103 | Test.Falsify.Internal.Generator.Definition 104 | Test.Falsify.Internal.Generator.Shrinking 105 | Test.Falsify.Internal.Property 106 | Test.Falsify.Internal.Range 107 | Test.Falsify.Internal.SampleTree 108 | Test.Falsify.Internal.Search 109 | Test.Falsify.Reexported.Generator.Compound 110 | Test.Falsify.Reexported.Generator.Function 111 | Test.Falsify.Reexported.Generator.Precision 112 | Test.Falsify.Reexported.Generator.Shrinking 113 | Test.Falsify.Reexported.Generator.Simple 114 | 115 | Data.Falsify.Integer 116 | Data.Falsify.List 117 | Data.Falsify.Marked 118 | Data.Falsify.Tree 119 | hs-source-dirs: 120 | src 121 | build-depends: 122 | , base16-bytestring >= 1.0 && < 1.1 123 | , binary >= 0.8 && < 0.9 124 | , bytestring >= 0.10 && < 0.13 125 | , containers >= 0.6 && < 0.8 126 | , data-default >= 0.7 && < 0.9 127 | , mtl >= 2.2 && < 2.4 128 | , optics-core >= 0.3 && < 0.5 129 | , optparse-applicative >= 0.16 && < 0.19 130 | , selective >= 0.4 && < 0.8 131 | , sop-core >= 0.5 && < 0.6 132 | , splitmix >= 0.1 && < 0.2 133 | , tagged >= 0.8 && < 0.9 134 | , tasty >= 1.3 && < 1.6 135 | , transformers >= 0.5 && < 0.7 136 | , vector >= 0.12 && < 0.14 137 | other-extensions: 138 | CPP 139 | 140 | test-suite test-falsify 141 | import: 142 | lang 143 | type: 144 | exitcode-stdio-1.0 145 | hs-source-dirs: 146 | test 147 | main-is: 148 | Main.hs 149 | other-modules: 150 | TestSuite.GenDefault 151 | TestSuite.Sanity.Predicate 152 | TestSuite.Sanity.Range 153 | TestSuite.Sanity.Selective 154 | TestSuite.Prop.Generator.Compound 155 | TestSuite.Prop.Generator.Function 156 | TestSuite.Prop.Generator.Marking 157 | TestSuite.Prop.Generator.Precision 158 | TestSuite.Prop.Generator.Prim 159 | TestSuite.Prop.Generator.Selective 160 | TestSuite.Prop.Generator.Shrinking 161 | TestSuite.Prop.Generator.Simple 162 | TestSuite.Util.List 163 | TestSuite.Util.Tree 164 | build-depends: 165 | , QuickCheck >= 2.14 && < 2.16 166 | , tasty-hunit >= 0.10 && < 0.11 167 | 168 | -- Inherit bounds from the main library 169 | , containers 170 | , data-default 171 | , falsify 172 | , selective 173 | , tasty 174 | 175 | -------------------------------------------------------------------------------- /lib/src/Test/Falsify/Internal/Generator/Shrinking.hs: -------------------------------------------------------------------------------- 1 | module Test.Falsify.Internal.Generator.Shrinking ( 2 | -- * Shrinking 3 | shrinkFrom 4 | -- * With full history 5 | , ShrinkExplanation(..) 6 | , ShrinkHistory(..) 7 | , IsValidShrink(..) 8 | , limitShrinkSteps 9 | , shrinkHistory 10 | , shrinkOutcome 11 | ) where 12 | 13 | import Data.Bifunctor 14 | import Data.Either 15 | import Data.List.NonEmpty (NonEmpty((:|))) 16 | 17 | import Test.Falsify.Internal.Generator.Definition 18 | import Test.Falsify.Internal.SampleTree (SampleTree(..)) 19 | 20 | {------------------------------------------------------------------------------- 21 | Explanation 22 | -------------------------------------------------------------------------------} 23 | 24 | -- | Shrink explanation 25 | -- 26 | -- @p@ is the type of \"positive\" elements that satisfied the predicate (i.e., 27 | -- valid shrinks), and @n@ is the type of \"negative\" which didn't. 28 | data ShrinkExplanation p n = ShrinkExplanation { 29 | -- | The value we started, before shrinking 30 | initial :: p 31 | 32 | -- | The full shrink history 33 | , history :: ShrinkHistory p n 34 | } 35 | deriving (Show) 36 | 37 | -- | Shrink explanation 38 | data ShrinkHistory p n = 39 | -- | We successfully executed a single shrink step 40 | ShrunkTo p (ShrinkHistory p n) 41 | 42 | -- | We could no shrink any further 43 | -- 44 | -- We also record all rejected next steps. This is occasionally useful when 45 | -- trying to figure out why a value didn't shrink any further (what did it 46 | -- try to shrink to?) 47 | | ShrinkingDone [n] 48 | 49 | -- | We stopped shrinking early 50 | -- 51 | -- This is used when the number of shrink steps is limited. 52 | | ShrinkingStopped 53 | deriving (Show) 54 | 55 | limitShrinkSteps :: Maybe Word -> ShrinkExplanation p n -> ShrinkExplanation p n 56 | limitShrinkSteps Nothing = id 57 | limitShrinkSteps (Just limit) = \case 58 | ShrinkExplanation{initial, history} -> 59 | ShrinkExplanation{ 60 | initial 61 | , history = go limit history 62 | } 63 | where 64 | go :: Word -> ShrinkHistory p n -> ShrinkHistory p n 65 | go 0 (ShrunkTo _ _) = ShrinkingStopped 66 | go n (ShrunkTo x xs) = ShrunkTo x (go (pred n) xs) 67 | go _ (ShrinkingDone rej) = ShrinkingDone rej 68 | go _ ShrinkingStopped = ShrinkingStopped 69 | 70 | -- | Simplify the shrink explanation to keep only the shrink history 71 | shrinkHistory :: ShrinkExplanation p n -> NonEmpty p 72 | shrinkHistory = \(ShrinkExplanation unshrunk shrunk) -> 73 | unshrunk :| go shrunk 74 | where 75 | go :: ShrinkHistory p n -> [p] 76 | go (ShrunkTo x xs) = x : go xs 77 | go (ShrinkingDone _) = [] 78 | go ShrinkingStopped = [] 79 | 80 | -- | The final shrunk value, as well as all rejected /next/ shrunk steps 81 | -- 82 | -- The list of rejected next steps is 83 | -- 84 | -- * @Nothing@ if shrinking was terminated early ('limitShrinkSteps') 85 | -- * @Just []@ if the final value truly is minimal (typically, it is only 86 | -- minimal wrt to a particular properly, but not the minimal value that a 87 | -- generator can produce). 88 | shrinkOutcome :: forall p n. ShrinkExplanation p n -> (p, Maybe [n]) 89 | shrinkOutcome = \ShrinkExplanation{initial, history} -> 90 | go initial history 91 | where 92 | go :: p -> ShrinkHistory p n -> (p, Maybe [n]) 93 | go _ (ShrunkTo p h) = go p h 94 | go p (ShrinkingDone ns) = (p, Just ns) 95 | go p ShrinkingStopped = (p, Nothing) 96 | 97 | {------------------------------------------------------------------------------- 98 | Mapping 99 | -------------------------------------------------------------------------------} 100 | 101 | instance Functor (ShrinkExplanation p) where 102 | fmap = second 103 | 104 | instance Functor (ShrinkHistory p) where 105 | fmap = second 106 | 107 | instance Bifunctor ShrinkExplanation where 108 | bimap f g ShrinkExplanation{initial, history} = ShrinkExplanation{ 109 | initial = f initial 110 | , history = bimap f g history 111 | } 112 | 113 | instance Bifunctor ShrinkHistory where 114 | bimap f g = \case 115 | ShrunkTo truncated history -> 116 | ShrunkTo (f truncated) (bimap f g history) 117 | ShrinkingDone rejected -> 118 | ShrinkingDone (map g rejected) 119 | ShrinkingStopped -> 120 | ShrinkingStopped 121 | 122 | {------------------------------------------------------------------------------- 123 | Shrinking 124 | -------------------------------------------------------------------------------} 125 | 126 | -- | Does a given shrunk value represent a valid shrink step? 127 | data IsValidShrink p n = 128 | ValidShrink p 129 | | InvalidShrink n 130 | deriving stock (Show) 131 | 132 | -- | Find smallest value that the generator can produce and still satisfies 133 | -- the predicate. 134 | -- 135 | -- Returns the full shrink history. 136 | -- 137 | -- To avoid boolean blindness, we use different types for values that satisfy 138 | -- the property and values that do not. 139 | -- 140 | -- This is lazy in the shrink history; see 'limitShrinkSteps' to limit the 141 | -- number of shrinking steps. 142 | shrinkFrom :: forall a p n. 143 | (a -> IsValidShrink p n) 144 | -> Gen a 145 | -> (p, [SampleTree]) -- ^ Initial result of the generator 146 | -> ShrinkExplanation p n 147 | shrinkFrom prop gen = \(p, shrunk) -> 148 | ShrinkExplanation p $ go shrunk 149 | where 150 | go :: [SampleTree] -> ShrinkHistory p n 151 | go shrunk = 152 | -- Shrinking is a greedy algorithm: we go with the first candidate that 153 | -- works, and discard the others. 154 | -- 155 | -- NOTE: 'partitionEithers' is lazy enough: 156 | -- 157 | -- > head . fst $ partitionEithers [Left True, undefined] == True 158 | case partitionEithers candidates of 159 | ([], rejected) -> ShrinkingDone rejected 160 | ((p, shrunk'):_, _) -> ShrunkTo p $ go shrunk' 161 | where 162 | candidates :: [Either (p, [SampleTree]) n] 163 | candidates = map consider $ map (runGen gen) shrunk 164 | 165 | consider :: (a, [SampleTree]) -> Either (p, [SampleTree]) n 166 | consider (a, shrunk) = 167 | case prop a of 168 | ValidShrink p -> Left (p, shrunk) 169 | InvalidShrink n -> Right n -------------------------------------------------------------------------------- /lib/src/Test/Falsify/Internal/SampleTree.hs: -------------------------------------------------------------------------------- 1 | -- | Sample tree 2 | -- 3 | -- Intended for qualified import. 4 | -- 5 | -- import Test.Falsify.Internal.SampleTree (SampleTree(..)) 6 | -- import qualified Test.Falsify.Internal.SampleTree as SampleTree 7 | module Test.Falsify.Internal.SampleTree ( 8 | -- * Definition 9 | SampleTree(..) 10 | , Sample(..) 11 | , pattern Inf 12 | , sampleValue 13 | -- * Lenses 14 | , next 15 | , left 16 | , right 17 | -- * Construction 18 | , fromPRNG 19 | , fromSeed 20 | , minimal 21 | , constant 22 | -- * Combinators 23 | , map 24 | , mod 25 | ) where 26 | 27 | import Prelude hiding (map, mod) 28 | import qualified Prelude 29 | 30 | import Data.Word 31 | import Optics.Core (Lens') 32 | import System.Random.SplitMix 33 | 34 | import qualified Optics.Core as Optics 35 | 36 | {------------------------------------------------------------------------------- 37 | Definition 38 | -------------------------------------------------------------------------------} 39 | 40 | -- | Sample tree 41 | -- 42 | -- A sample tree is a (conceptually and sometimes actually) infinite tree 43 | -- representing drawing values from and splitting a PRNG. 44 | data SampleTree = 45 | -- | Default constructor 46 | -- 47 | -- The type of ST is really 48 | -- 49 | -- > ST :: Word64 & (SampleTree * SampleTree) -> SampleTree 50 | -- 51 | -- where `(&)` is the additive conjunction from linear logic. In other 52 | -- words, the intention is that /either/ the @Word64@ is used, /or/ 53 | -- the pair of subtrees; put another way, we /either/ draw a value from the 54 | -- PRNG, /or/ split it into two new PRNGs. See 'next' and 'split'. 55 | SampleTree Sample SampleTree SampleTree 56 | 57 | -- | Minimal tree (0 everywhere) 58 | -- 59 | -- This constructor allows us to represent an infinite tree in a finite way 60 | -- and, importantly, /recognize/ a tree that is minimal everywhere. This is 61 | -- necessary when shrinking in the context of generators that generate 62 | -- infinitely large values. 63 | | Minimal 64 | deriving (Show) 65 | 66 | {------------------------------------------------------------------------------- 67 | Samples 68 | -------------------------------------------------------------------------------} 69 | 70 | -- | Sample 71 | -- 72 | -- The samples in the 'SampleTree' record if they were the originally produced 73 | -- sample, or whether they have been shrunk. 74 | data Sample = 75 | NotShrunk Word64 76 | | Shrunk Word64 77 | deriving (Show, Eq, Ord) 78 | 79 | sampleValue :: Sample -> Word64 80 | sampleValue (NotShrunk s) = s 81 | sampleValue (Shrunk s) = s 82 | 83 | {------------------------------------------------------------------------------- 84 | Views 85 | -------------------------------------------------------------------------------} 86 | 87 | view :: SampleTree -> (Sample, SampleTree, SampleTree) 88 | view Minimal = (Shrunk 0, Minimal, Minimal) 89 | view (SampleTree s l r) = (s, l, r) 90 | 91 | -- | Pattern synonym for treating the sample tree as infinite 92 | pattern Inf :: Sample -> SampleTree -> SampleTree -> SampleTree 93 | pattern Inf s l r <- (view -> (s, l, r)) 94 | 95 | {-# COMPLETE Inf #-} 96 | 97 | {------------------------------------------------------------------------------- 98 | Lenses 99 | 100 | NOTE: The setter part of these lenses leaves 'Minimal' sample tree unchanged. 101 | -------------------------------------------------------------------------------} 102 | 103 | next :: Lens' SampleTree Sample 104 | next = Optics.lens getter setter 105 | where 106 | getter :: SampleTree -> Sample 107 | getter (Inf s _ _) = s 108 | 109 | setter :: SampleTree -> Sample -> SampleTree 110 | setter Minimal _ = Minimal 111 | setter (SampleTree _ l r) s = SampleTree s l r 112 | 113 | left :: Lens' SampleTree SampleTree 114 | left = Optics.lens getter setter 115 | where 116 | getter :: SampleTree -> SampleTree 117 | getter (Inf _ l _) = l 118 | 119 | setter :: SampleTree -> SampleTree -> SampleTree 120 | setter Minimal _ = Minimal 121 | setter (SampleTree s _ r) l = SampleTree s l r 122 | 123 | right :: Lens' SampleTree SampleTree 124 | right = Optics.lens getter setter 125 | where 126 | getter :: SampleTree -> SampleTree 127 | getter (Inf _ _ r) = r 128 | 129 | setter :: SampleTree -> SampleTree -> SampleTree 130 | setter Minimal _ = Minimal 131 | setter (SampleTree s l _) r = SampleTree s l r 132 | 133 | {------------------------------------------------------------------------------- 134 | Construction 135 | -------------------------------------------------------------------------------} 136 | 137 | fromPRNG :: SMGen -> SampleTree 138 | fromPRNG = go 139 | where 140 | go :: SMGen -> SampleTree 141 | go g = 142 | let (n, _) = nextWord64 g 143 | (l, r) = splitSMGen g 144 | in SampleTree (NotShrunk n) (go l) (go r) 145 | 146 | fromSeed :: Word64 -> SampleTree 147 | fromSeed = fromPRNG . mkSMGen 148 | 149 | -- | Minimal sample tree 150 | -- 151 | -- Generators should produce the \"simplest\" value when given this tree, 152 | -- for some suitable application-specific definition of \"simple\". 153 | minimal :: SampleTree 154 | minimal = Minimal 155 | 156 | -- | Sample tree that is the given value everywhere 157 | -- 158 | -- This is primarily useful for debugging. 159 | constant :: Word64 -> SampleTree 160 | constant s = go 161 | where 162 | go :: SampleTree 163 | go = SampleTree (NotShrunk s) go go 164 | 165 | {------------------------------------------------------------------------------- 166 | Combinators 167 | -------------------------------------------------------------------------------} 168 | 169 | -- | Map function over all random samples in the tree 170 | -- 171 | -- Precondition: the function must preserve zeros: 172 | -- 173 | -- > f 0 == 0 174 | -- 175 | -- This means that we have 176 | -- 177 | -- > map f M == M 178 | -- 179 | -- This is primarily useful for debugging. 180 | map :: (Word64 -> Word64) -> SampleTree -> SampleTree 181 | map f = go 182 | where 183 | go :: SampleTree -> SampleTree 184 | go (SampleTree s l r) = SampleTree (mapSample s) (go l) (go r) 185 | go Minimal = Minimal 186 | 187 | mapSample :: Sample -> Sample 188 | mapSample (NotShrunk s) = NotShrunk (f s) 189 | mapSample (Shrunk s) = Shrunk (f s) 190 | 191 | -- | Apply @mod m@ at every sample in the tree 192 | -- 193 | -- This is primarily useful for debugging. 194 | mod :: Word64 -> SampleTree -> SampleTree 195 | mod m = map (\s -> s `Prelude.mod` m) 196 | 197 | -------------------------------------------------------------------------------- /lib/src/Test/Falsify/Internal/Driver/Tasty.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | -- | Tasty integration 3 | -- 4 | -- This are the internal guts of the integration. Publicly visible API lives in 5 | -- "Test.Tasty.Falsify". 6 | module Test.Falsify.Internal.Driver.Tasty ( 7 | -- * Test property 8 | testProperty 9 | -- * Configure test behaviour 10 | , TestOptions(..) 11 | , Verbose(..) 12 | , ExpectFailure(..) 13 | , testPropertyWith 14 | ) where 15 | 16 | import Prelude hiding (log) 17 | 18 | import Data.Default 19 | import Data.Maybe 20 | import Data.Proxy 21 | import Data.Tagged 22 | import Test.Tasty 23 | import Test.Tasty.Options (IsOption(..), OptionSet) 24 | import Test.Tasty.Providers (IsTest(..)) 25 | 26 | import qualified Test.Tasty.Options as Tasty 27 | 28 | import Test.Falsify.Internal.Driver 29 | import Test.Falsify.Internal.Driver.ReplaySeed 30 | import Test.Falsify.Internal.Property 31 | 32 | import qualified Options.Applicative as Opts 33 | import qualified Test.Tasty.Providers as Tasty 34 | 35 | {------------------------------------------------------------------------------- 36 | Tasty integration 37 | -------------------------------------------------------------------------------} 38 | 39 | data Test = Test TestOptions (Property' String ()) 40 | 41 | data TestOptions = TestOptions { 42 | -- | Do we expect this test to fail? 43 | expectFailure :: ExpectFailure 44 | 45 | -- | Override verbose mode for this test 46 | , overrideVerbose :: Maybe Verbose 47 | 48 | -- | Override the maximum number of shrink steps for this test 49 | , overrideMaxShrinks :: Maybe Word 50 | 51 | -- | Override the number of tests 52 | , overrideNumTests :: Maybe Word 53 | 54 | -- | Override how many tests can be discarded per successful test 55 | , overrideMaxRatio :: Maybe Word 56 | } 57 | 58 | instance Default TestOptions where 59 | def = TestOptions { 60 | expectFailure = DontExpectFailure 61 | , overrideVerbose = Nothing 62 | , overrideMaxShrinks = Nothing 63 | , overrideNumTests = Nothing 64 | , overrideMaxRatio = Nothing 65 | } 66 | 67 | instance IsTest Test where 68 | -- @tasty@ docs (1.4.3) explicitly say to ignore the @reportProgress@ argument 69 | run opts (Test testOpts prop) _reportProgress = 70 | toTastyResult . renderTestResult verbose (expectFailure testOpts) <$> 71 | falsify driverOpts prop 72 | where 73 | verbose :: Verbose 74 | verbose = fromMaybe (Tasty.lookupOption opts) (overrideVerbose testOpts) 75 | 76 | driverOpts :: Options 77 | driverOpts = 78 | maybe id 79 | (\x o -> o{maxShrinks = Just x}) 80 | (overrideMaxShrinks testOpts) 81 | $ maybe id 82 | (\x o -> o{tests = x}) 83 | (overrideNumTests testOpts) 84 | $ maybe id 85 | (\x o -> o{maxRatio = x}) 86 | (overrideMaxRatio testOpts) 87 | $ driverOptions opts 88 | 89 | testOptions = Tagged [ 90 | Tasty.Option $ Proxy @Verbose 91 | , Tasty.Option $ Proxy @Tests 92 | , Tasty.Option $ Proxy @MaxShrinks 93 | , Tasty.Option $ Proxy @Replay 94 | , Tasty.Option $ Proxy @MaxRatio 95 | ] 96 | 97 | toTastyResult :: RenderedTestResult -> Tasty.Result 98 | toTastyResult RenderedTestResult{testPassed, testOutput} 99 | | testPassed = Tasty.testPassed testOutput 100 | | otherwise = Tasty.testFailed testOutput 101 | 102 | {------------------------------------------------------------------------------- 103 | User API 104 | -------------------------------------------------------------------------------} 105 | 106 | -- | Generalization of 'testPropertyWith' using default options 107 | testProperty :: TestName -> Property' String () -> TestTree 108 | testProperty = testPropertyWith def 109 | 110 | testPropertyWith :: TestOptions -> TestName -> Property' String () -> TestTree 111 | testPropertyWith testOpts name = Tasty.singleTest name . Test testOpts 112 | 113 | {------------------------------------------------------------------------------- 114 | Options specific to the tasty test runner 115 | 116 | Not all of these options are command line options; some are set on a 117 | test-by-test basis, such as 'ExpectFailure'. 118 | -------------------------------------------------------------------------------} 119 | 120 | instance IsOption Verbose where 121 | defaultValue = NotVerbose 122 | parseValue = fmap (\b -> if b then Verbose else NotVerbose) 123 | . Tasty.safeReadBool 124 | optionName = Tagged $ "falsify-verbose" 125 | optionHelp = Tagged $ "Show the generated test cases" 126 | optionCLParser = Tasty.mkFlagCLParser mempty Verbose 127 | 128 | {------------------------------------------------------------------------------- 129 | Options 130 | 131 | NOTE: If we add another option here, we must also add it in 'testOptions'. 132 | -------------------------------------------------------------------------------} 133 | 134 | newtype Tests = Tests { getTests :: Word } 135 | newtype MaxShrinks = MaxShrinks { getMaxShrinks :: Maybe Word } 136 | newtype Replay = Replay { getReplay :: Maybe ReplaySeed } 137 | newtype MaxRatio = MaxRatio { getMaxRatio :: Word } 138 | 139 | instance IsOption Tests where 140 | defaultValue = Tests (tests def) 141 | parseValue = fmap Tests . Tasty.safeRead . filter (/= '_') 142 | optionName = Tagged "falsify-tests" 143 | optionHelp = Tagged "Number of test cases to generate" 144 | 145 | instance IsOption MaxShrinks where 146 | defaultValue = MaxShrinks (maxShrinks def) 147 | parseValue = fmap (MaxShrinks . Just) . Tasty.safeRead 148 | optionName = Tagged "falsify-shrinks" 149 | optionHelp = Tagged "Random seed to use for replaying a previous test run" 150 | 151 | instance IsOption Replay where 152 | defaultValue = Replay (replay def) 153 | parseValue = fmap (Replay . Just) . safeReadReplaySeed 154 | optionName = Tagged "falsify-replay" 155 | optionHelp = Tagged "Random seed to use for replaying test" 156 | optionCLParser = Opts.option readReplaySeed $ mconcat [ 157 | Opts.long $ untag $ optionName @Replay 158 | , Opts.help $ untag $ optionHelp @Replay 159 | ] 160 | where 161 | readReplaySeed :: Opts.ReadM Replay 162 | readReplaySeed = Opts.str >>= fmap (Replay . Just) . parseReplaySeed 163 | 164 | instance IsOption MaxRatio where 165 | defaultValue = MaxRatio (maxRatio def) 166 | parseValue = fmap MaxRatio . Tasty.safeRead . filter (/= '_') 167 | optionName = Tagged "falsify-max-ratio" 168 | optionHelp = Tagged "Maximum number of discarded tests per successful test" 169 | 170 | driverOptions :: OptionSet -> Options 171 | driverOptions opts = Options { 172 | tests = getTests $ Tasty.lookupOption opts 173 | , maxShrinks = getMaxShrinks $ Tasty.lookupOption opts 174 | , replay = getReplay $ Tasty.lookupOption opts 175 | , maxRatio = getMaxRatio $ Tasty.lookupOption opts 176 | } 177 | -------------------------------------------------------------------------------- /lib/src/Data/Falsify/Tree.hs: -------------------------------------------------------------------------------- 1 | module Data.Falsify.Tree ( 2 | Tree(Leaf, Branch) 3 | -- * Dealing with marks 4 | , propagate 5 | , genKept 6 | , keepAtLeast 7 | -- * Binary search trees 8 | , Interval(..) 9 | , Endpoint(..) 10 | , inclusiveBounds 11 | , lookup 12 | -- * Debugging 13 | , drawTree 14 | ) where 15 | 16 | import Prelude hiding (drop, lookup) 17 | 18 | import Control.Selective (Selective, ifS) 19 | import Control.Monad.State 20 | import GHC.Show 21 | 22 | import qualified Data.Tree as Rose 23 | 24 | import Data.Falsify.Marked 25 | 26 | {------------------------------------------------------------------------------- 27 | Definition 28 | -------------------------------------------------------------------------------} 29 | 30 | data Tree a = 31 | Leaf 32 | 33 | -- 'Branch_' caches the size of the tree 34 | | Branch_ {-# UNPACK #-} !Word a (Tree a) (Tree a) 35 | deriving stock (Eq, Functor, Foldable, Traversable) 36 | 37 | {------------------------------------------------------------------------------- 38 | Tree stats 39 | -------------------------------------------------------------------------------} 40 | 41 | -- | Size of the tree 42 | -- 43 | -- @O(1)@ 44 | size :: Tree a -> Word 45 | size Leaf = 0 46 | size (Branch_ s _ _ _) = s 47 | 48 | {------------------------------------------------------------------------------- 49 | Pattern synonyms that hide the size argument 50 | -------------------------------------------------------------------------------} 51 | 52 | viewBranch :: Tree a -> Maybe (a, Tree a, Tree a) 53 | viewBranch Leaf = Nothing 54 | viewBranch (Branch_ _ x l r) = Just (x, l, r) 55 | 56 | branch :: a -> Tree a -> Tree a -> Tree a 57 | branch x l r = Branch_ (1 + size l + size r) x l r 58 | 59 | pattern Branch :: a -> Tree a -> Tree a -> Tree a 60 | pattern Branch x l r <- (viewBranch -> Just (x, l, r)) 61 | where 62 | Branch = branch 63 | 64 | {-# COMPLETE Leaf, Branch #-} 65 | 66 | {------------------------------------------------------------------------------- 67 | 'Show' instance that depends on the pattern synonyms 68 | -------------------------------------------------------------------------------} 69 | 70 | instance Show a => Show (Tree a) where 71 | showsPrec _ Leaf = showString "Leaf" 72 | showsPrec a (Branch x l r) = showParen (a > appPrec) $ 73 | showString "Branch " 74 | . showsPrec appPrec1 x 75 | . showSpace 76 | . showsPrec appPrec1 l 77 | . showSpace 78 | . showsPrec appPrec1 r 79 | 80 | {------------------------------------------------------------------------------- 81 | Dealing with marks 82 | -------------------------------------------------------------------------------} 83 | 84 | -- | Propagate 'Drop' marker down the tree 85 | -- 86 | -- This is useful in conjunction with 'genKept', which truncates entire 87 | -- subtrees. 88 | propagate :: Tree (Marked f a) -> Tree (Marked f a) 89 | propagate = keep 90 | where 91 | keep :: Tree (Marked f a) -> Tree (Marked f a) 92 | keep Leaf = Leaf 93 | keep (Branch (Marked Keep x) l r) = Branch (Marked Keep x) (keep l) (keep r) 94 | keep (Branch (Marked Drop x) l r) = Branch (Marked Drop x) (drop l) (drop r) 95 | 96 | drop :: Tree (Marked f a) -> Tree (Marked f a) 97 | drop = fmap $ \(Marked _ x) -> Marked Drop x 98 | 99 | -- | Generate those values we want to keep 100 | -- 101 | -- Whenever we meet an element marked 'Drop', that entire subtree is dropped. 102 | genKept :: forall f a. Selective f => Tree (Marked f a) -> f (Tree a) 103 | genKept = go 104 | where 105 | go :: Tree (Marked f a) -> f (Tree a) 106 | go Leaf = pure Leaf 107 | go (Branch (Marked m g) l r) = ifS (pure $ m == Keep) 108 | (Branch <$> g <*> go l <*> go r) 109 | (pure Leaf) 110 | 111 | -- | Change enough nodes currently marked as 'Drop' to 'Keep' to ensure at 112 | -- least @n@ nodes are marked 'Keep'. 113 | -- 114 | -- Precondition: any 'Drop' marks must have been propagated; see 'propagate'. 115 | -- Postcondition: this property is preserved. 116 | keepAtLeast :: Word -> Tree (Marked f a) -> Tree (Marked f a) 117 | keepAtLeast = \n t -> 118 | let kept = countKept t 119 | in if kept >= n 120 | then t 121 | else evalState (go t) (n - kept) 122 | where 123 | go :: Tree (Marked f a) -> State Word (Tree (Marked f a)) 124 | go Leaf = return Leaf 125 | go (Branch (Marked Keep x) l r) = Branch (Marked Keep x) <$> go l <*> go r 126 | go t@(Branch (Marked Drop x) l r) = get >>= \case 127 | 0 -> 128 | -- Nothing left to drop 129 | return t 130 | n | size t <= n -> do 131 | -- We can keep the entire subtree 132 | put $ n - size t 133 | return $ fmap (Marked Keep . unmark) t 134 | n -> do 135 | -- We cannot delete the entire subtree. In order to preserve the 136 | -- "drop property", we /must/ mark this node as 'Keep' 137 | put $ n - 1 138 | Branch (Marked Keep x) <$> go l <*> go r 139 | 140 | {------------------------------------------------------------------------------- 141 | BST 142 | -------------------------------------------------------------------------------} 143 | 144 | data Endpoint a = Inclusive a | Exclusive a 145 | data Interval a = Interval (Endpoint a) (Endpoint a) 146 | 147 | -- | Compute interval with inclusive bounds, without exceeding range 148 | -- 149 | -- Returns 'Nothing' if the interval is empty, and @Just@ the inclusive 150 | -- lower and upper bound otherwise. 151 | inclusiveBounds :: forall a. (Ord a, Enum a) => Interval a -> Maybe (a, a) 152 | inclusiveBounds = \(Interval lo hi) -> go lo hi 153 | where 154 | -- The inequality checks in @go@ justify the use of @pred@ or @succ@ 155 | go :: Endpoint a -> Endpoint a -> Maybe (a, a) 156 | go (Inclusive lo) (Inclusive hi) 157 | | lo <= hi = Just (lo, hi) 158 | | otherwise = Nothing 159 | go (Exclusive lo) (Inclusive hi) 160 | | lo < hi = Just (succ lo, hi) 161 | | otherwise = Nothing 162 | go (Inclusive lo) (Exclusive hi) 163 | | lo < hi = Just (lo, pred hi) 164 | | otherwise = Nothing 165 | go (Exclusive lo) (Exclusive hi) 166 | | lo < hi = if succ lo > pred hi 167 | then Nothing 168 | else Just (succ lo, pred hi) 169 | | otherwise = Nothing 170 | 171 | 172 | -- | Look value up in BST 173 | -- 174 | -- NOTE: The 'Tree' datatype itself does /NOT/ guarantee that the tree is in 175 | -- fact a BST. It is the responsibility of the caller to ensure this. 176 | lookup :: Ord a => a -> Tree (a, b) -> Maybe b 177 | lookup a' (Branch (a, b) l r) 178 | | a' < a = lookup a' l 179 | | a' > a = lookup a' r 180 | | otherwise = Just b 181 | lookup _ Leaf = Nothing 182 | 183 | {------------------------------------------------------------------------------- 184 | Debugging 185 | -------------------------------------------------------------------------------} 186 | 187 | drawTree :: Tree String -> String 188 | drawTree = Rose.drawTree . conv 189 | where 190 | conv :: Tree String -> Rose.Tree String 191 | conv Leaf = Rose.Node "*" [] 192 | conv (Branch x l r) = Rose.Node x [conv l, conv r] 193 | -------------------------------------------------------------------------------- /lib/test/TestSuite/Prop/Generator/Simple.hs: -------------------------------------------------------------------------------- 1 | module TestSuite.Prop.Generator.Simple (tests) where 2 | 3 | import Control.Monad (unless) 4 | import Data.List (intercalate) 5 | import Data.Word 6 | import Test.Tasty 7 | import Test.Tasty.Falsify 8 | 9 | import Test.Falsify.Predicate ((.$)) 10 | 11 | import qualified Test.Falsify.Generator as Gen 12 | import qualified Test.Falsify.Predicate as P 13 | import qualified Test.Falsify.Range as Range 14 | import Data.Bits 15 | import Data.Proxy 16 | import Data.Typeable 17 | 18 | tests :: TestTree 19 | tests = testGroup "TestSuite.Prop.Generator.Simple" [ 20 | testGroup "prim" [ 21 | testProperty "shrinking" prop_prim_shrinking 22 | , testGroup "minimum" [ 23 | testProperty (show target) $ prop_prim_minimum target 24 | | target <- [0 .. 4] 25 | ] 26 | ] 27 | , testGroup "bool" [ 28 | testGroup "towardsFalse" [ 29 | testProperty "shrinking" $ prop_bool_shrinking False 30 | , testProperty "minimum" $ prop_bool_minimum False 31 | ] 32 | , testGroup "towardsTrue" [ 33 | testProperty "shrinking" $ prop_bool_shrinking True 34 | , testProperty "minimum" $ prop_bool_minimum True 35 | ] 36 | ] 37 | , testGroup "int" [ 38 | testGroup "between" [ 39 | testGroup (intercalate "_" [show x, show y]) [ 40 | testProperty "shrinking" $ prop_int_between_shrinking (x, y) 41 | , testGroup "minimum" [ 42 | testProperty (show target) $ 43 | prop_int_between_minimum (x, y) target 44 | | target <- [0, 1, 99, 100] 45 | ] 46 | ] 47 | | (x, y) <- [ 48 | ( 0, 0) 49 | , ( 0, 10) 50 | , ( 0, 100) 51 | , ( 10, 0) 52 | , ( 10, 10) 53 | , ( 10, 100) 54 | , (100, 0) 55 | , (100, 10) 56 | , (100, 100) 57 | ] 58 | ] 59 | , let test_int_withOrigin :: forall a. 60 | (Typeable a, Show a, Integral a, FiniteBits a) 61 | => Proxy a -> TestTree 62 | test_int_withOrigin p = testGroup (show $ typeRep p) [ 63 | testGroup (intercalate "_" [show x, show y, show o]) [ 64 | testProperty "shrinking" $ 65 | prop_integral_withOrigin_shrinking @a (x, y) o 66 | , testGroup "minimum" [ 67 | testProperty (show target) $ 68 | prop_integral_withOrigin_minimum (x, y) o target 69 | | target <- [0, 1, 49, 50, 51, 99, 100] 70 | ] 71 | ] 72 | | ((x, y), o) <- [ 73 | ((0, 10), 0) 74 | , ((0, 10), 10) 75 | , ((0, 10), 5) 76 | , ((0, 100), 0) 77 | , ((0, 100), 100) 78 | , ((0, 100), 50) 79 | ] 80 | ] 81 | in testGroup "withOrigin" [ 82 | test_int_withOrigin (Proxy @Int) 83 | , test_int_withOrigin (Proxy @Word) 84 | ] 85 | ] 86 | , testGroup "char" [ 87 | testGroup "enum" [ 88 | testProperty "shrinking" $ prop_char_enum_shrinking ('a', 'z') 89 | ] 90 | ] 91 | ] 92 | 93 | 94 | {------------------------------------------------------------------------------- 95 | Prim 96 | -------------------------------------------------------------------------------} 97 | 98 | -- Gen.prime is the only generator where we a /strict/ inequality 99 | prop_prim_shrinking :: Property () 100 | prop_prim_shrinking = testShrinkingOfGen P.gt $ Gen.prim 101 | 102 | -- The minimum is always 0, unless 0 is not a counter-example 103 | prop_prim_minimum :: Word64 -> Property () 104 | prop_prim_minimum target = do 105 | testMinimum (P.expect $ if target == 0 then 1 else 0) $ do 106 | x <- gen $ Gen.prim 107 | unless (x == target) $ testFailed x 108 | 109 | {------------------------------------------------------------------------------- 110 | Bool 111 | -------------------------------------------------------------------------------} 112 | 113 | prop_bool_shrinking :: Bool -> Property () 114 | prop_bool_shrinking False = testShrinkingOfGen P.ge $ Gen.bool False 115 | prop_bool_shrinking True = testShrinkingOfGen P.le $ Gen.bool True 116 | 117 | prop_bool_minimum :: Bool -> Property () 118 | prop_bool_minimum target = 119 | testMinimum (P.expect target) $ do 120 | b <- gen $ Gen.bool target 121 | testFailed b 122 | 123 | {------------------------------------------------------------------------------- 124 | Range: 'between' 125 | 126 | This implicitly tests generation of fractions as well as determining 127 | precision. 128 | -------------------------------------------------------------------------------} 129 | 130 | prop_int_between_shrinking :: (Int, Int) -> Property () 131 | prop_int_between_shrinking (x, y) 132 | | x <= y = testShrinkingOfGen P.ge $ Gen.inRange $ Range.between (x, y) 133 | | otherwise = testShrinkingOfGen P.le $ Gen.inRange $ Range.between (x, y) 134 | 135 | prop_int_between_minimum :: (Int, Int) -> Int -> Property () 136 | prop_int_between_minimum (x, y) _target | x == y = 137 | testMinimum (P.expect x) $ do 138 | n <- gen $ Gen.inRange $ Range.between (x, y) 139 | -- The only value we can produce here is @x@, so no point looking for 140 | -- anything these (that would just result in all tests being discarded) 141 | testFailed n 142 | prop_int_between_minimum (x, y) target = 143 | testMinimum (P.expect expected) $ do 144 | n <- gen $ Gen.inRange $ Range.between (x, y) 145 | unless (n == target) $ testFailed n 146 | where 147 | expected :: Int 148 | expected 149 | | x < y = if target == x then x + 1 else x 150 | | otherwise = if target == x then x - 1 else x 151 | 152 | {------------------------------------------------------------------------------- 153 | Range: 'withOrigin' 154 | -------------------------------------------------------------------------------} 155 | 156 | prop_integral_withOrigin_shrinking :: 157 | (Show a, Integral a, FiniteBits a) 158 | => (a, a) -> a -> Property () 159 | prop_integral_withOrigin_shrinking (x, y) o = 160 | testShrinkingOfGen (P.towards o) $ 161 | Gen.inRange $ Range.withOrigin (x, y) o 162 | 163 | prop_integral_withOrigin_minimum :: forall a. 164 | (Show a, Integral a, FiniteBits a) 165 | => (a, a) -> a -> a -> Property () 166 | prop_integral_withOrigin_minimum (x, y) o _target | x == y = 167 | testMinimum (P.expect x) $ do 168 | -- See discussion in 'prop_int_between_minimum' 169 | n <- gen $ Gen.inRange $ Range.withOrigin (x, y) o 170 | testFailed n 171 | prop_integral_withOrigin_minimum (x, y) o target = 172 | testMinimum (P.elem .$ ("expected", expected)) $ do 173 | n <- gen $ Gen.inRange $ Range.withOrigin (x, y) o 174 | unless (n == target) $ testFailed n 175 | where 176 | expected :: [a] 177 | expected 178 | | target == o = [o + 1, o - 1] 179 | | otherwise = [o] 180 | 181 | {------------------------------------------------------------------------------- 182 | Range: 'enum' 183 | -------------------------------------------------------------------------------} 184 | 185 | prop_char_enum_shrinking :: (Char, Char) -> Property () 186 | prop_char_enum_shrinking (x, y) 187 | | x <= y = testShrinkingOfGen P.ge $ Gen.inRange $ Range.enum (x, y) 188 | | otherwise = testShrinkingOfGen P.le $ Gen.inRange $ Range.enum (x, y) 189 | 190 | -------------------------------------------------------------------------------- /lib/src/Test/Falsify/Internal/Generator/Definition.hs: -------------------------------------------------------------------------------- 1 | module Test.Falsify.Internal.Generator.Definition ( 2 | -- * Definition 3 | Gen(..) 4 | , bindWithoutShortcut 5 | , minimalValue 6 | -- * Primitive generators 7 | , prim 8 | , primWith 9 | , exhaustive 10 | , captureLocalTree 11 | -- * Generator independence 12 | , bindIntegral 13 | , perturb 14 | -- * Combinators 15 | , withoutShrinking 16 | ) where 17 | 18 | import Control.Monad 19 | import Control.Selective 20 | import Data.List.NonEmpty (NonEmpty((:|))) 21 | import Data.Word 22 | import Optics.Core (Lens', (%)) 23 | 24 | import qualified Optics.Core as Optics 25 | 26 | import Data.Falsify.Integer (Bit(..), encIntegerEliasG) 27 | import Test.Falsify.Internal.SampleTree (SampleTree(..), Sample (..), pattern Inf) 28 | import Test.Falsify.Internal.Search 29 | 30 | import qualified Test.Falsify.Internal.SampleTree as SampleTree 31 | 32 | {------------------------------------------------------------------------------- 33 | Definition 34 | -------------------------------------------------------------------------------} 35 | 36 | -- | Generator of a random value 37 | -- 38 | -- Generators can be combined through their 'Functor', 'Applicative' and 'Monad' 39 | -- interfaces. The primitive generator is 'prim', but most users will probably 40 | -- want to construct their generators using the predefined from 41 | -- "Test.Falsify.Generator" as building blocks. 42 | -- 43 | -- Generators support \"internal integrated shrinking\". Shrinking is 44 | -- /integrated/ in the sense of Hedgehog, meaning that we don't write a separate 45 | -- shrinker at all, but the shrink behaviour is implied by the generator. For 46 | -- example, if you have a generator @genList@ for a list of numbers, then 47 | -- 48 | -- > filter even <$> genList 49 | -- 50 | -- will only generate even numbers, and that property is automatically preserved 51 | -- during shrinking. Shrinking is /internal/ in the sense of Hypothesis, meaning 52 | -- that unlike in Hedgehog, shrinking works correctly even in the context of 53 | -- monadic bind. For example, if you do 54 | -- 55 | -- > do n <- genListLength 56 | -- > replicateM n someOtherGen 57 | -- 58 | -- then we can shrink @n@ and the results from @someOtherGen@ in any order (that 59 | -- said, users may prefer to use the dedicated 60 | -- 'Test.Falsify.Generator.Compound.list' generator for this purpose, which 61 | -- improves on this in a few ways). 62 | -- 63 | -- NOTE: 'Gen' is /NOT/ an instance of 'Alternative'; this would not be 64 | -- compatible with the generation of infinite data structures. For the same 65 | -- reason, we do not have a monad transformer version of Gen either. 66 | newtype Gen a = Gen { runGen :: SampleTree -> (a, [SampleTree]) } 67 | deriving stock (Functor) 68 | 69 | instance Applicative Gen where 70 | pure x = Gen $ \_st -> (x, []) 71 | (<*>) = ap 72 | 73 | instance Monad Gen where 74 | return = pure 75 | x >>= f = Gen $ \(Inf s l r) -> 76 | let (a, ls) = runGen x l 77 | (b, rs) = runGen (f a) r 78 | in (b, combineShrunk s (l :| ls) (r :| rs)) 79 | 80 | instance Selective Gen where 81 | select e f = Gen $ \(Inf s l r) -> do 82 | let (ma, ls) = runGen e l 83 | case ma of 84 | Left a -> 85 | let (f', rs) = runGen f r 86 | in (f' a, combineShrunk s (l :| ls) (r :| rs)) 87 | Right b -> 88 | (b, combineShrunk s (l :| ls) (r :| [])) 89 | 90 | -- | Combine shrunk left and right sample trees 91 | -- 92 | -- This is an internal function only. 93 | combineShrunk :: 94 | Sample 95 | -> NonEmpty SampleTree -- ^ Original and shrunk left trees 96 | -> NonEmpty SampleTree -- ^ Original and shrunk right trees 97 | -> [SampleTree] 98 | combineShrunk s (l :| ls) (r :| rs) = shortcut $ concat [ 99 | [SampleTree s l' r | l' <- unlessMinimal l ls] 100 | , [SampleTree s l r' | r' <- unlessMinimal r rs] 101 | ] 102 | where 103 | -- We must be careful not to force @ls@/@rs@ if the tree is already minimal. 104 | unlessMinimal :: SampleTree -> [a] -> [a] 105 | unlessMinimal Minimal _ = [] 106 | unlessMinimal _ xs = xs 107 | 108 | shortcut :: [SampleTree] -> [SampleTree] 109 | shortcut [] = [] 110 | shortcut ts = Minimal : ts 111 | 112 | -- | Varation on @(>>=)@ that doesn't apply the shortcut to 'Minimal' 113 | -- 114 | -- This function is primarily useful for debugging @falsify@ itself; users 115 | -- will probably never need it. 116 | bindWithoutShortcut :: Gen a -> (a -> Gen b) -> Gen b 117 | bindWithoutShortcut x f = Gen $ \(Inf s l r) -> 118 | let (a, ls) = runGen x l 119 | (b, rs) = runGen (f a) r 120 | in (b, combine s (l :| ls) (r :| rs)) 121 | where 122 | -- Variation on 'combineShrunk' that doesn't apply the shortcut 123 | combine :: 124 | Sample 125 | -> NonEmpty SampleTree -- ^ Original and shrunk left trees 126 | -> NonEmpty SampleTree -- ^ Original and shrunk right trees 127 | -> [SampleTree] 128 | combine s (l :| ls) (r :| rs) = concat [ 129 | [SampleTree s l' r | l' <- ls] 130 | , [SampleTree s l r' | r' <- rs] 131 | ] 132 | 133 | -- | Get the value produced by the generator on the minimal sample tree. 134 | -- 135 | -- Having `Gen a` is a proof that `a` is inhabited, so this function 136 | -- gives access to a witness. 137 | minimalValue :: Gen a -> a 138 | minimalValue g = fst (runGen g Minimal) 139 | 140 | {------------------------------------------------------------------------------- 141 | Generator independence 142 | -------------------------------------------------------------------------------} 143 | 144 | -- | Selective bind 145 | -- 146 | -- Unlike monadic bind, the RHS is generated and shrunk completely independently 147 | -- for each different value of @a@ produced by the LHS. 148 | -- 149 | -- This is a generalization of 'bindS' to arbitrary integral values; it is also 150 | -- much more efficient than 'bindS'. 151 | -- 152 | -- NOTE: This is only one way to make a generator independent. See 'perturb' 153 | -- for more primitive combinator. 154 | bindIntegral :: Integral a => Gen a -> (a -> Gen b) -> Gen b 155 | bindIntegral x f = x >>= \a -> perturb a (f a) 156 | 157 | -- | Run generator on different part of the sample tree depending on @a@ 158 | perturb :: Integral a => a -> Gen b -> Gen b 159 | perturb a g = Gen $ \st -> 160 | let (b, shrunk) = runGen g (Optics.view lens st) 161 | in (b, map (\st' -> Optics.set lens st' st) shrunk) 162 | where 163 | lens :: Lens' SampleTree SampleTree 164 | lens = computeLens (encIntegerEliasG $ fromIntegral a) 165 | 166 | computeLens :: [Bit] -> Lens' SampleTree SampleTree 167 | computeLens [] = Optics.castOptic Optics.simple 168 | computeLens (O : bs) = SampleTree.left % computeLens bs 169 | computeLens (I : bs) = SampleTree.right % computeLens bs 170 | 171 | {------------------------------------------------------------------------------- 172 | Primitive generators 173 | -------------------------------------------------------------------------------} 174 | 175 | -- | Uniform selection of 'Word64', shrinking towards 0, using binary search 176 | -- 177 | -- This is a primitive generator; most users will probably not want to use this 178 | -- generator directly. 179 | prim :: Gen Word64 180 | prim = 181 | SampleTree.sampleValue <$> 182 | primWith (binarySearch . SampleTree.sampleValue) 183 | 184 | -- | Generalization of 'prim' that allows to override the shrink behaviour 185 | -- 186 | -- This is only required in rare circumstances. Most users will probably never 187 | -- need to use this generator. 188 | primWith :: (Sample -> [Word64]) -> Gen Sample 189 | primWith f = Gen $ \(Inf s l r) -> ( 190 | s 191 | , (\s' -> SampleTree (Shrunk s') l r) <$> f s 192 | ) 193 | 194 | -- | Generate arbitrary value @x <= n@ 195 | -- 196 | -- Unlike 'prim', 'exhaustive' does not execute binary search. Instead, /all/ 197 | -- smaller values are considered. This is potentially very expensive; the 198 | -- primary use case for this generator is testing shrinking behaviour, where 199 | -- binary search can lead to some unpredicatable results. 200 | -- 201 | -- This does /NOT/ do uniform selection: for small @n@, the generator will with 202 | -- overwhelming probability produce @n@ itself as initial value. 203 | -- 204 | -- This is a primitive generator; most users will probably not want to use this 205 | -- generator directly. 206 | exhaustive :: Word64 -> Gen Word64 207 | exhaustive n = 208 | min n . SampleTree.sampleValue <$> 209 | primWith (completeSearch . SampleTree.sampleValue) 210 | where 211 | completeSearch :: Word64 -> [Word64] 212 | completeSearch 0 = [] 213 | completeSearch x = takeWhile (<= n) [0 .. pred x] 214 | 215 | -- | Capture the local sample tree 216 | -- 217 | -- This generator does not shrink. 218 | captureLocalTree :: Gen SampleTree 219 | captureLocalTree = Gen $ \st -> (st, []) 220 | 221 | {------------------------------------------------------------------------------- 222 | Shrinking combinators 223 | -------------------------------------------------------------------------------} 224 | 225 | -- | Disable shrinking in the given generator 226 | -- 227 | -- Due to the nature of internal shrinking, it is always possible that a 228 | -- generator gets reapplied to samples that were shrunk wrt to a /different/ 229 | -- generator. In this sense, 'withoutShrinking' should be considered to be a 230 | -- hint only. 231 | -- 232 | -- This function is only occassionally necessary; most users will probably not 233 | -- need to use it. 234 | withoutShrinking :: Gen a -> Gen a 235 | withoutShrinking (Gen g) = Gen $ aux . g 236 | where 237 | aux :: (a, [SampleTree]) -> (a, [SampleTree]) 238 | aux (outcome, _) = (outcome, []) 239 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project.ci' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250315 12 | # 13 | # REGENDATA ("0.19.20250315",["github","cabal.project.ci"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-24.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.12.2 32 | compilerKind: ghc 33 | compilerVersion: 9.12.2 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.10.1 37 | compilerKind: ghc 38 | compilerVersion: 9.10.1 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.8.4 42 | compilerKind: ghc 43 | compilerVersion: 9.8.4 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.6.7 47 | compilerKind: ghc 48 | compilerVersion: 9.6.7 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.4.8 52 | compilerKind: ghc 53 | compilerVersion: 9.4.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-9.2.8 57 | compilerKind: ghc 58 | compilerVersion: 9.2.8 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-9.0.2 62 | compilerKind: ghc 63 | compilerVersion: 9.0.2 64 | setup-method: ghcup 65 | allow-failure: false 66 | - compiler: ghc-8.10.7 67 | compilerKind: ghc 68 | compilerVersion: 8.10.7 69 | setup-method: ghcup 70 | allow-failure: false 71 | fail-fast: false 72 | steps: 73 | - name: apt-get install 74 | run: | 75 | apt-get update 76 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 77 | - name: Install GHCup 78 | run: | 79 | mkdir -p "$HOME/.ghcup/bin" 80 | curl -sL https://downloads.haskell.org/ghcup/0.1.40.0/x86_64-linux-ghcup-0.1.40.0 > "$HOME/.ghcup/bin/ghcup" 81 | chmod a+x "$HOME/.ghcup/bin/ghcup" 82 | - name: Install cabal-install 83 | run: | 84 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 85 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 86 | - name: Install GHC (GHCup) 87 | if: matrix.setup-method == 'ghcup' 88 | run: | 89 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 90 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 91 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 92 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 93 | echo "HC=$HC" >> "$GITHUB_ENV" 94 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 95 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 96 | env: 97 | HCKIND: ${{ matrix.compilerKind }} 98 | HCNAME: ${{ matrix.compiler }} 99 | HCVER: ${{ matrix.compilerVersion }} 100 | - name: Set PATH and environment variables 101 | run: | 102 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 103 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 104 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 105 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 106 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 107 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 108 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 109 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 110 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 111 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 112 | env: 113 | HCKIND: ${{ matrix.compilerKind }} 114 | HCNAME: ${{ matrix.compiler }} 115 | HCVER: ${{ matrix.compilerVersion }} 116 | - name: env 117 | run: | 118 | env 119 | - name: write cabal config 120 | run: | 121 | mkdir -p $CABAL_DIR 122 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 155 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 156 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 157 | rm -f cabal-plan.xz 158 | chmod a+x $HOME/.cabal/bin/cabal-plan 159 | cabal-plan --version 160 | - name: checkout 161 | uses: actions/checkout@v4 162 | with: 163 | path: source 164 | - name: initial cabal.project for sdist 165 | run: | 166 | touch cabal.project 167 | echo "packages: $GITHUB_WORKSPACE/source/lib" >> cabal.project 168 | echo "packages: $GITHUB_WORKSPACE/source/demo" >> cabal.project 169 | cat cabal.project 170 | - name: sdist 171 | run: | 172 | mkdir -p sdist 173 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 174 | - name: unpack 175 | run: | 176 | mkdir -p unpacked 177 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 178 | - name: generate cabal.project 179 | run: | 180 | PKGDIR_falsify="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/falsify-[0-9.]*')" 181 | echo "PKGDIR_falsify=${PKGDIR_falsify}" >> "$GITHUB_ENV" 182 | PKGDIR_demo="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/demo-[0-9.]*')" 183 | echo "PKGDIR_demo=${PKGDIR_demo}" >> "$GITHUB_ENV" 184 | rm -f cabal.project cabal.project.local 185 | touch cabal.project 186 | touch cabal.project.local 187 | echo "packages: ${PKGDIR_falsify}" >> cabal.project 188 | echo "packages: ${PKGDIR_demo}" >> cabal.project 189 | echo "package falsify" >> cabal.project 190 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 191 | echo "package demo" >> cabal.project 192 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 193 | cat >> cabal.project <> cabal.project.local 197 | cat cabal.project 198 | cat cabal.project.local 199 | - name: dump install plan 200 | run: | 201 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 202 | cabal-plan 203 | - name: restore cache 204 | uses: actions/cache/restore@v4 205 | with: 206 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 207 | path: ~/.cabal/store 208 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 209 | - name: install dependencies 210 | run: | 211 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 212 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 213 | - name: build w/o tests 214 | run: | 215 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 216 | - name: build 217 | run: | 218 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 219 | - name: tests 220 | run: | 221 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 222 | - name: haddock 223 | run: | 224 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 225 | - name: unconstrained build 226 | run: | 227 | rm -f cabal.project.local 228 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 229 | - name: save cache 230 | if: always() 231 | uses: actions/cache/save@v4 232 | with: 233 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 234 | path: ~/.cabal/store 235 | -------------------------------------------------------------------------------- /lib/src/Test/Falsify/Range.hs: -------------------------------------------------------------------------------- 1 | -- | Numerical ranges 2 | module Test.Falsify.Range ( 3 | Range -- opaque 4 | -- * Constructors 5 | -- ** Linear 6 | , between 7 | , enum 8 | , withOrigin 9 | -- ** Non-linear 10 | , skewedBy 11 | -- * Queries 12 | , origin 13 | -- * Primitive constructors 14 | , ProperFraction(..) 15 | , Precision(..) 16 | , constant 17 | , fromProperFraction 18 | , towards 19 | -- * Evalation 20 | , eval 21 | ) where 22 | 23 | import Data.Bits 24 | import Data.List.NonEmpty (NonEmpty(..)) 25 | import Data.Ord 26 | 27 | import qualified Data.List.NonEmpty as NE 28 | 29 | import Test.Falsify.Internal.Range 30 | import Data.Functor.Identity 31 | 32 | {------------------------------------------------------------------------------- 33 | Primitive ranges 34 | -------------------------------------------------------------------------------} 35 | 36 | -- | Range that is @x@ everywhere 37 | constant :: a -> Range a 38 | constant = Constant 39 | 40 | -- | Construct @a@ given a fraction 41 | -- 42 | -- Precondition: @f@ must be monotonically increasing or decreasing; i.e. 43 | -- 44 | -- * for all @x <= y@, @f x <= f y@, /or/ 45 | -- * for all @x <= y@, @f y <= f x@ 46 | fromProperFraction :: Precision -> (ProperFraction -> a) -> Range a 47 | fromProperFraction = FromProperFraction 48 | 49 | -- | Generate value in any of the specified ranges, then choose the one 50 | -- that is closest to the specified origin 51 | -- 52 | -- Precondition: the target must be within the bounds of all ranges. 53 | towards :: forall a. (Ord a, Num a) => a -> [Range a] -> Range a 54 | towards o [] = Constant o 55 | towards o (r:rs) = Smallest $ fmap aux (r :| rs) 56 | where 57 | aux :: Range a -> Range (a, a) 58 | aux = fmap $ \x -> (x, distanceToOrigin x) 59 | 60 | distanceToOrigin :: a -> a 61 | distanceToOrigin x 62 | | x >= o = x - o 63 | | otherwise = o - x 64 | 65 | {------------------------------------------------------------------------------- 66 | Constructing ranges 67 | -------------------------------------------------------------------------------} 68 | 69 | -- | Uniform selection between the given bounds, shrinking towards first bound 70 | between :: forall a. (Integral a, FiniteBits a) => (a, a) -> Range a 71 | between = skewedBy 0 72 | 73 | -- | Variation on 'between' for types that are 'Enum' but not 'Integral' 74 | -- 75 | -- This is useful for types such as 'Char'. However, since this relies on 76 | -- 'Enum', it's limited by the precision of 'Int'. 77 | enum :: Enum a => (a, a) -> Range a 78 | enum (x, y) = toEnum <$> between (fromEnum x, fromEnum y) 79 | 80 | -- | Selection within the given bounds, shrinking towards the specified origin 81 | -- 82 | -- All else being equal, prefers values in the /second/ half of the range 83 | -- (in the common case of say @withOrigin (-100, 100) 0@, this means we prefer 84 | -- positive values). 85 | withOrigin :: (Integral a, FiniteBits a) => (a, a) -> a -> Range a 86 | withOrigin (x, y) o 87 | | not originInBounds 88 | = error "withOrigin: origin not within bounds" 89 | 90 | -- Since origin must be within bounds, we must have x == o == y here 91 | | x == y 92 | = Constant x 93 | 94 | | o == x 95 | = between (x, y) 96 | 97 | | o == y 98 | = between (y, x) 99 | 100 | -- Split the range into two halves. We are careful to do this only when needed: 101 | -- if we didn't (i.e., if the origin /equals/ one of the endpoints), that would 102 | -- result in a singleton range, and since that singleton range (by definition) 103 | -- would be at the origin, we would only ever produce that one value. 104 | | otherwise = 105 | towards o [ 106 | between (o, y) 107 | , between (o, x) 108 | ] 109 | where 110 | originInBounds :: Bool 111 | originInBounds 112 | | x <= o && o <= y = True 113 | | y <= o && o <= x = True 114 | | otherwise = False 115 | 116 | {------------------------------------------------------------------------------- 117 | Skew 118 | 119 | To introduce skew, we want something that is reasonably simply to implement 120 | but also has some reasonal properties. Suppose a skew of @s@ means that we 121 | generate value from the lower 20% of the range 60% of the time. Then: 122 | 123 | - Symmetry around the antidiagonal: we will generate a value from the 124 | upper 60% of the range 20% of the time. 125 | 126 | - Symmetry around the diagonal: a skew of @-s@ will mean we generate a value 127 | from the /upper/ 20% of the range 60% of the time. 128 | 129 | To derive the formula we use, suppose we start with a circle with radius 1, 130 | centered at the origin: 131 | 132 | > x^2 + y^2 == 1 133 | > y^2 == 1 - x^2 134 | > y == (1 - x^2) ^ (1/2) 135 | 136 | In the interval [0, 1] this gives us the upper right quadrant of the circle, 137 | but we want the lower right: 138 | 139 | > y == 1 - ((1 - x^2) ^ (1/2)) 140 | 141 | We can now vary that power. 142 | 143 | > y == 1 - ((1 - x^3) ^ (1/3)) 144 | > y == 1 - ((1 - x^4) ^ (1/4)) 145 | > .. 146 | 147 | If the power is 1, we get no skew: 148 | 149 | > y == 1 - ((1 - x^1) ^ (1/1)) 150 | > == 1 - (1 - x) 151 | > == x 152 | 153 | We want a skew of 0 to mean no skew, so in terms of s: 154 | 155 | > y == 1 - ((1 - x^(s+1)) ^ (1/(s+1))) 156 | 157 | For negative values of @s@, we flip this around the diagonal: 158 | 159 | > y == 1 - (1 - ((1 - (1-x)^(s+1)) ^ (1/(s+1)))) 160 | > == (1 - (1-x)^(s+1)) ^ (1/(s+1)) 161 | 162 | giving us 163 | 164 | > (1 - (1 - x)^2)^(1/2) for s == -1 165 | > (1 - (1 - x)^3)^(1/3) for s == -2 166 | > etc. 167 | -------------------------------------------------------------------------------} 168 | 169 | -- | Introduce skew (non-uniform selection) 170 | -- 171 | -- A skew of @s == 0@ means no skew: uniform selection. 172 | -- 173 | -- A positive skew @(s > 0)@ introduces a bias towards smaller values (this is 174 | -- the typical use case). As example, for a skew of @s == 1@: 175 | -- 176 | -- * We will generate a value from the lower 20% of the range 60% of the time. 177 | -- * We will generate a value from the upper 60% of the range 20% of the time. 178 | -- 179 | -- A negative skew @(s < 0)@ introduces a bias towards larger values. For a 180 | -- skew of @s == 1@: 181 | -- 182 | -- * We will generate a value from the upper 20% of the range 60% of the time. 183 | -- * We will generate a value from the lower 60% of the range 20% of the time. 184 | -- 185 | -- The table below lists values for the percentage of the range used, given a 186 | -- percentage of the time (a value of 0 means a single value from the range): 187 | -- 188 | -- > | time% 189 | -- > s | 50% | 90% 190 | -- > -------------- 191 | -- > 0 | 50 | 90 192 | -- > 1 | 13 | 56 193 | -- > 2 | 4 | 35 194 | -- > 3 | 1 | 23 195 | -- > 4 | 0 | 16 196 | -- > 5 | 0 | 11 197 | -- > 6 | 0 | 8 198 | -- > 7 | 0 | 6 199 | -- > 8 | 0 | 5 200 | -- > 9 | 0 | 4 201 | -- > 10 | 0 | 3 202 | -- 203 | -- Will shrink towards @x@, independent of skew. 204 | -- 205 | -- NOTE: The implementation currently uses something similar to μ-law encoding. 206 | -- As a consequence, the generator gets increased precision near the end of the 207 | -- range we skew towards, and less precision near the other end. This means that 208 | -- not all values in the range can be produced. 209 | skewedBy :: forall a. (FiniteBits a, Integral a) => Double -> (a, a) -> Range a 210 | skewedBy s (x, y) 211 | | x == y = constant x 212 | | x < y = let p = precisionRequiredToRepresent (y - x) 213 | in fromProperFraction p $ \(ProperFraction f) -> roundDown f 214 | | otherwise = let p = precisionRequiredToRepresent (x - y) 215 | in fromProperFraction p $ \(ProperFraction f) -> roundUp f 216 | where 217 | x', y' :: Double 218 | x' = fromIntegral x 219 | y' = fromIntegral y 220 | 221 | -- We have to be careful here. Perhaps the more obvious way to express this 222 | -- calculation is 223 | -- 224 | -- > round $ x' + skew f * (y' - x') 225 | -- 226 | -- However, this leads to a bad distribution of test data. Suppose we are 227 | -- generating values in the range [0 .. 2]. Then that call to 'round' 228 | -- would result in something like this: 229 | -- 230 | -- > 0..............1..............2 231 | -- > [ /\ /\ ] 232 | -- > ^^^^^^^^ ^^^^^^^^^^^^ ^^^^^^ 233 | -- > 0 1 2 234 | -- 235 | -- To avoid this heavy bias, we instead do this: 236 | -- 237 | -- > 0..............1..............2..............3 238 | -- > [ /\ /\ ] 239 | -- > ^^^^^^^^^^^^^^ ^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^ 240 | -- > 0 1 2 241 | -- 242 | -- By insisting that the fraction is a /proper/ fraction (i.e., not equal to 243 | -- 1), we avoid generating @3@ (which would be outside the range). 244 | roundDown, roundUp :: Double -> a 245 | roundDown f = floor $ x' + skew f * (y' - x' + 1) 246 | roundUp f = ceiling $ x' - skew f * (x' - y' + 1) 247 | 248 | pos, neg :: Double -> Double 249 | pos f = 1 - ((1 - f ** (s + 1)) ** (1 / ( s + 1))) 250 | neg f = (1 - (1 - f) ** (s + 1)) ** (1 / (abs s + 1)) 251 | 252 | skew :: Double -> Double 253 | skew | s == 0 = id 254 | | s >= 0 = pos 255 | | otherwise = neg 256 | 257 | {------------------------------------------------------------------------------- 258 | Precision 259 | -------------------------------------------------------------------------------} 260 | 261 | -- | Precision required to be able to choose within the given range 262 | -- 263 | -- In order to avoid rounding errors, we set a lower bound on the precision. 264 | -- This lower bound is verified in "TestSuite.Sanity.Range", which verifies that 265 | -- for small ranges, the expected distribution is never off by more than 1% 266 | -- from the actual distribution. 267 | precisionRequiredToRepresent :: forall a. FiniteBits a => a -> Precision 268 | precisionRequiredToRepresent x = fromIntegral $ 269 | 7 `max` (finiteBitSize (undefined :: a) - countLeadingZeros x) 270 | 271 | {------------------------------------------------------------------------------- 272 | Queries 273 | -------------------------------------------------------------------------------} 274 | 275 | -- | Origin of the range (value we shrink towards) 276 | origin :: Range a -> a 277 | origin = runIdentity . eval (\_precision -> Identity $ ProperFraction 0) 278 | 279 | {------------------------------------------------------------------------------- 280 | Evaluation 281 | -------------------------------------------------------------------------------} 282 | 283 | -- | Evaluate a range, given an action to generate fractions 284 | -- 285 | -- Most users will probably never need to call this function. 286 | eval :: forall f a. 287 | Applicative f 288 | => (Precision -> f ProperFraction) -> Range a -> f a 289 | eval genFraction = go 290 | where 291 | go :: forall x. Range x -> f x 292 | go r = 293 | case r of 294 | Constant x -> pure x 295 | FromProperFraction p f -> f <$> genFraction p 296 | Smallest rs -> smallest <$> sequenceA (fmap go rs) 297 | 298 | smallest :: Ord b => NonEmpty (x, b) -> x 299 | smallest = fst . NE.head . NE.sortBy (comparing snd) 300 | -------------------------------------------------------------------------------- /demo/demo/Demo/Blogpost.hs: -------------------------------------------------------------------------------- 1 | module Demo.Blogpost where 2 | 3 | import Control.Monad 4 | import Control.Monad.State 5 | import Control.Selective 6 | import Data.Bifunctor 7 | import Data.Default 8 | import Data.Word 9 | import System.Random.SplitMix (SMGen) 10 | import Test.Tasty 11 | import Test.Tasty.Falsify 12 | import Test.Tasty.HUnit (Assertion, testCase, assertFailure) 13 | 14 | import qualified System.Random.SplitMix as SplitMix 15 | 16 | import Test.Falsify.Predicate ((.$)) 17 | import Test.Falsify.Range (Range) 18 | 19 | import qualified Test.Falsify.Generator as Gen 20 | import qualified Test.Falsify.Predicate as P 21 | import qualified Test.Falsify.Range as Range 22 | 23 | tests :: TestTree 24 | tests = testGroup "Demo.Blogpost" [ 25 | testProperty "motivation" prop_list 26 | , testGroup "Background" [ 27 | testGroup "UnitVsPBT" [ 28 | testCase "unit" $ 29 | unit_structure 30 | even 31 | (3 :: Word) 32 | False 33 | , testProperty "property" $ 34 | prop_structure 35 | (reverse . reverse) 36 | (Gen.list (Range.between (0, 100)) (Gen.bool False)) 37 | (==) 38 | ] 39 | ] 40 | , testGroup "ImportanceOfShrinking" [ 41 | testPropertyWith (def { overrideMaxShrinks = Just 0 }) 42 | "shrinking_disabled" prop_shrinking 43 | , testProperty 44 | "shrinking_enabled" prop_shrinking 45 | ] 46 | , testGroup "Tutorial" [ 47 | testProperty "multiply2_even" prop_multiply2_even 48 | , testProperty "multiply3_even" prop_multiply3_even 49 | , testProperty "multiply3_even_pred" prop_multiply3_even_pred 50 | , testGroup "skew" [ 51 | testProperty "0" $ prop_skew 0 52 | , testProperty "5" $ prop_skew 5 53 | ] 54 | , testProperty "fn1" prop_fn 55 | , testProperty "mapFilter" prop_mapFilter 56 | , testProperty "below_shrinking" prop_below_shrinking 57 | , testProperty "naiveList_minimum" prop_naiveList_minimum 58 | , testProperty "list_minimum" prop_list_minimum 59 | ] 60 | ] 61 | 62 | {------------------------------------------------------------------------------- 63 | Motivating example 64 | -------------------------------------------------------------------------------} 65 | 66 | -- | Example of interesting shrinking across monadic bind 67 | -- 68 | -- Run with this seed for a good example: 69 | -- 70 | -- > cabal run demo -- \ 71 | -- > -p Blogpost.motivation \ 72 | -- > --falsify-verbose \ 73 | -- > --falsify-replay=012f1ef548663a9b73ceaebf948d9f87a7 74 | prop_list :: Property () 75 | prop_list = do 76 | n <- gen $ Gen.inRange $ Range.between (0, 10) 77 | xs <- gen $ replicateM n $ Gen.int $ Range.between (0, 1) 78 | assert $ P.pairwise P.eq .$ ("xs", xs) 79 | 80 | {------------------------------------------------------------------------------- 81 | Background: unit testing versus PBT 82 | -------------------------------------------------------------------------------} 83 | 84 | unit_structure :: Eq b => (a -> b) -> a -> b -> Assertion 85 | unit_structure f input expected = 86 | unless (f input == expected) $ 87 | assertFailure "not equal" 88 | 89 | prop_structure :: Show a => (a -> b) -> Gen a -> (a -> b -> Bool) -> Property () 90 | prop_structure f genInput prop = do 91 | input <- gen $ genInput 92 | unless (prop input (f input)) $ 93 | testFailed "property not satisfied" 94 | 95 | {------------------------------------------------------------------------------- 96 | Background: importance of shrinking 97 | -------------------------------------------------------------------------------} 98 | 99 | prop_shrinking :: Property () 100 | prop_shrinking = do 101 | x <- gen $ Gen.int $ Range.between (0, 99) 102 | y <- gen $ Gen.int $ Range.between (0, 99) 103 | unless (x - y == y - x) $ 104 | testFailed "property not satisfied" 105 | 106 | {------------------------------------------------------------------------------- 107 | Parsing versus generation 108 | -------------------------------------------------------------------------------} 109 | 110 | type PRNG = SMGen 111 | 112 | next :: PRNG -> (Word, PRNG) 113 | next = first fromIntegral . SplitMix.nextWord64 114 | 115 | newtype LinearGen a = LinearGen (State PRNG a) 116 | deriving newtype (Functor, Applicative, Monad) 117 | 118 | runLinearGen :: LinearGen a -> PRNG -> (a, PRNG) 119 | runLinearGen (LinearGen g) = runState g 120 | 121 | unfoldLinear :: PRNG -> [Word] 122 | unfoldLinear prng = 123 | let (s, prng') = next prng 124 | in s : unfoldLinear prng' 125 | 126 | newtype LinearParser a = LinearParser (State [Word] a) 127 | deriving newtype (Functor, Applicative, Monad) 128 | 129 | runLinearParser :: LinearParser a -> [Word] -> (a, [Word]) 130 | runLinearParser (LinearParser g) = runState g 131 | 132 | parseBool :: LinearParser Bool 133 | parseBool = LinearParser $ state $ \case 134 | [] -> error "parseBool: no more samples" 135 | (s:ss) -> ( 136 | if s >= maxBound `div` 2 then True else False 137 | , ss 138 | ) 139 | 140 | {------------------------------------------------------------------------------- 141 | QuickCheck 142 | -------------------------------------------------------------------------------} 143 | 144 | newtype QcGen a = QcGen (PRNG -> a) 145 | deriving (Functor) 146 | 147 | split :: PRNG -> (PRNG, PRNG) 148 | split = SplitMix.splitSMGen 149 | 150 | bothQc :: QcGen a -> QcGen b -> QcGen (a, b) 151 | bothQc (QcGen g1) (QcGen g2) = QcGen $ \prng -> 152 | let (l, r) = split prng 153 | in (g1 l, g2 r) 154 | 155 | instance Applicative QcGen where 156 | pure x = QcGen $ \_ -> x 157 | f <*> x = uncurry ($) <$> bothQc f x 158 | 159 | {------------------------------------------------------------------------------- 160 | Falsify 161 | -------------------------------------------------------------------------------} 162 | 163 | data STree = STree Word STree STree 164 | 165 | unfoldTree :: PRNG -> STree 166 | unfoldTree prng = 167 | let (s, _) = next prng 168 | (l, r) = split prng 169 | in STree s (unfoldTree l) (unfoldTree r) 170 | 171 | newtype FalsifyGen a = FalsifyGen (STree -> (a, [STree])) 172 | 173 | bothFalsify :: FalsifyGen a -> FalsifyGen b -> FalsifyGen (a, b) 174 | bothFalsify (FalsifyGen g1) (FalsifyGen g2) = FalsifyGen $ \(STree s l r) -> 175 | let (a, ls) = g1 l 176 | (b, rs) = g2 r 177 | in ( (a, b) 178 | , [STree s l' r | l' <- ls] 179 | ++ [STree s l r' | r' <- rs] 180 | ) 181 | 182 | {------------------------------------------------------------------------------- 183 | Consequences of using sample trees 184 | -------------------------------------------------------------------------------} 185 | 186 | incomparableTrees :: (STree, STree) 187 | incomparableTrees = ( 188 | STree undefined 189 | (STree 1 undefined undefined) 190 | (STree 4 undefined undefined) 191 | 192 | , STree undefined 193 | (STree 2 undefined undefined) 194 | (STree 3 undefined undefined) 195 | ) 196 | 197 | {------------------------------------------------------------------------------- 198 | Predictability 199 | -------------------------------------------------------------------------------} 200 | 201 | listThenNum :: Gen ([Bool], Int) 202 | listThenNum = do 203 | xs <- Gen.list (Range.between (0, 100)) $ Gen.bool False 204 | n <- Gen.int (Range.between (0, 100)) 205 | return (xs, n) 206 | 207 | {------------------------------------------------------------------------------- 208 | Selective functors 209 | -------------------------------------------------------------------------------} 210 | 211 | chooseSuboptimal :: Gen a -> Gen a -> Gen a 212 | chooseSuboptimal g g' = do 213 | b <- Gen.bool True 214 | if b then g else g' 215 | 216 | chooseBad :: Gen a -> Gen a -> Gen a 217 | chooseBad g g' = do 218 | x <- g 219 | y <- g' 220 | b <- Gen.bool True 221 | return $ if b then x else y 222 | 223 | choose :: Gen a -> Gen a -> Gen a 224 | choose = ifS $ Gen.bool True 225 | 226 | {------------------------------------------------------------------------------- 227 | Tutorial 228 | -------------------------------------------------------------------------------} 229 | 230 | prop_multiply2_even :: Property () 231 | prop_multiply2_even = do 232 | x <- gen $ Gen.int $ Range.withOrigin (-100, 100) 0 233 | unless (even (x * 2)) $ testFailed "not even" 234 | 235 | prop_multiply3_even :: Property () 236 | prop_multiply3_even = do 237 | x <- gen $ Gen.int $ Range.withOrigin (-100, 100) 0 238 | unless (even (x * 3)) $ testFailed "not even" 239 | 240 | prop_multiply3_even_pred :: Property () 241 | prop_multiply3_even_pred = do 242 | x <- gen $ Gen.int $ Range.withOrigin (-100, 100) 0 243 | assert $ P.even `P.dot` P.fn ("multiply3", (* 3)) .$ ("x", x) 244 | 245 | prop_skew :: Double -> Property () 246 | prop_skew skew = do 247 | xs <- gen $ Gen.list rangeListLen $ Gen.inRange rangeValues 248 | x <- gen $ Gen.inRange rangeValues 249 | collect "elem" [x `elem` xs] 250 | where 251 | rangeListLen, rangeValues :: Range Word 252 | rangeListLen = Range.between (0, 10) 253 | rangeValues = Range.skewedBy skew (0, 100) 254 | 255 | prop_fn :: Property () 256 | prop_fn = do 257 | Fn (f :: [Int] -> Bool) <- gen $ Gen.fun $ Gen.bool False 258 | assert $ 259 | P.eq 260 | `P.on` P.fn ("f", f) 261 | .$ ("x", [1, 2, 3]) 262 | .$ ("y", [4, 5, 6]) 263 | 264 | prop_mapFilter :: Property () 265 | prop_mapFilter = do 266 | Fn (f :: Int -> Int) <- gen $ Gen.fun genInt 267 | Fn (p :: Int -> Bool) <- gen $ Gen.fun genBool 268 | xs :: [Int] <- gen $ Gen.list (Range.between (0, 100)) genInt 269 | assert $ 270 | P.eq 271 | `P.split` (P.fn ("map f", map f), P.fn ("filter p", filter p)) 272 | `P.split` (P.fn ("filter p", filter p), P.fn ("map f", map f)) 273 | .$ ("xs", xs) 274 | .$ ("xs", xs) 275 | where 276 | genInt :: Gen Int 277 | genInt = Gen.int $ Range.between (0, 100) 278 | 279 | genBool :: Gen Bool 280 | genBool = Gen.bool False 281 | 282 | {------------------------------------------------------------------------------- 283 | Testing shrinking 284 | -------------------------------------------------------------------------------} 285 | 286 | below :: Word64 -> Gen Word64 287 | below n = (`mod` n) <$> Gen.prim 288 | 289 | prop_below_shrinking :: Property () 290 | prop_below_shrinking = do 291 | n <- gen $ Gen.inRange $ Range.between (1, 1_000) 292 | testShrinkingOfGen P.ge $ below n 293 | 294 | naiveList :: Range Int -> Gen a -> Gen [a] 295 | naiveList r g = do 296 | n <- Gen.inRange r 297 | replicateM n g 298 | 299 | prop_naiveList_minimum :: Property () 300 | prop_naiveList_minimum = 301 | testMinimum (P.elem .$ ("expected", [[0,1], [1,0]])) $ do 302 | xs <- gen $ naiveList 303 | (Range.between (0, 10)) 304 | (Gen.int (Range.between (0, 1))) 305 | case P.eval $ P.pairwise P.eq .$ ("xs", xs) of 306 | Left _ -> testFailed xs 307 | Right () -> return () 308 | 309 | prop_list_minimum :: Property () 310 | prop_list_minimum = 311 | testMinimum (P.elem .$ ("expected", [[0,1], [1,0]])) $ do 312 | xs <- gen $ Gen.list 313 | (Range.between (0, 10)) 314 | (Gen.int (Range.between (0, 1))) 315 | case P.eval $ P.pairwise P.eq .$ ("xs", xs) of 316 | Left _ -> testFailed xs 317 | Right () -> return () -------------------------------------------------------------------------------- /lib/src/Test/Falsify/Reexported/Generator/Function.hs: -------------------------------------------------------------------------------- 1 | module Test.Falsify.Reexported.Generator.Function ( 2 | Fun -- opaque 3 | , applyFun 4 | , pattern Fn 5 | , pattern Fn2 6 | , pattern Fn3 7 | -- * Generation 8 | , fun 9 | -- * Construction 10 | , Function(..) 11 | , (:->) -- opaque 12 | , functionMap 13 | ) where 14 | 15 | import Prelude hiding (sum) 16 | 17 | import Control.Monad 18 | import Data.Bifunctor 19 | import Data.Char 20 | import Data.Foldable (toList) 21 | import Data.Int 22 | import Data.Kind 23 | import Data.List (intercalate) 24 | import Data.Maybe (fromMaybe, mapMaybe) 25 | import Data.Ratio (Ratio) 26 | import Data.Void (Void) 27 | import Data.Word 28 | import GHC.Generics 29 | import Numeric.Natural 30 | 31 | import qualified Data.Ratio as Ratio 32 | 33 | import Data.Falsify.Tree (Tree, Interval(..), Endpoint(..)) 34 | import Test.Falsify.Internal.Generator (Gen) 35 | import Test.Falsify.Reexported.Generator.Shrinking 36 | import Test.Falsify.Reexported.Generator.Compound 37 | 38 | import qualified Data.Falsify.Tree as Tree 39 | 40 | {------------------------------------------------------------------------------- 41 | Functions that can be shrunk and shown 42 | -------------------------------------------------------------------------------} 43 | 44 | -- | Function @a -> b@ which can be shown, generated, and shrunk 45 | data Fun a b = Fun { 46 | concrete :: a :-> b 47 | , defaultValue :: b 48 | 49 | -- Since functions are typically infinite, they can only safely be shown 50 | -- once they are fully shrunk: after all, once a function has been fully 51 | -- shrunk, we /know/ it must be finite, because in any given property, a 52 | -- function will only ever be applied a finite number of times. 53 | , isFullyShrunk :: Bool 54 | } 55 | deriving (Functor) 56 | 57 | -- | Generate function @a -> b@ given a generator for @b@ 58 | fun :: Function a => Gen b -> Gen (Fun a b) 59 | fun gen = do 60 | -- Generate value first, so that we try to shrink that first 61 | defaultValue <- gen 62 | concrete <- function gen 63 | isFullyShrunk <- firstThen False True 64 | return Fun{concrete, defaultValue, isFullyShrunk} 65 | 66 | {------------------------------------------------------------------------------- 67 | Concrete functions 68 | 69 | NOTE: @Nil@ is useful as a separate constructor, since it does not have an 70 | @Eq@ constraint. 71 | -------------------------------------------------------------------------------} 72 | 73 | data (:->) :: Type -> Type -> Type where 74 | Nil :: a :-> b 75 | Unit :: a -> () :-> a 76 | Table :: Ord a => Tree (a, Maybe b) -> a :-> b 77 | Sum :: (a :-> c) -> (b :-> c) -> (Either a b :-> c) 78 | Prod :: (a :-> (b :-> c)) -> (a, b) :-> c 79 | Map :: (b -> a) -> (a -> b) -> (a :-> c) -> (b :-> c) 80 | 81 | instance Functor ((:->) a) where 82 | fmap _ Nil = Nil 83 | fmap f (Unit x) = Unit (f x) 84 | fmap f (Table xs) = Table (fmap (second (fmap f)) xs) 85 | fmap f (Sum x y) = Sum (fmap f x) (fmap f y) 86 | fmap f (Prod x) = Prod (fmap (fmap f) x) 87 | fmap f (Map ab ba x) = Map ab ba (fmap f x) 88 | 89 | -- | The basic building block for 'Function' instances 90 | -- 91 | -- Provides a 'Function' instance by mapping to and from a type that 92 | -- already has a 'Function' instance. 93 | functionMap :: (b -> a) -> (a -> b) -> (a :-> c) -> b :-> c 94 | functionMap = Map 95 | 96 | -- | Apply concrete function 97 | abstract :: (a :-> b) -> b -> (a -> b) 98 | abstract Nil d _ = d 99 | abstract (Unit x) _ _ = x 100 | abstract (Prod p) d (x,y) = abstract (fmap (\q -> abstract q d y) p) d x 101 | abstract (Sum p q) d exy = either (abstract p d) (abstract q d) exy 102 | abstract (Table xys) d x = fromMaybe d . join $ Tree.lookup x xys 103 | abstract (Map g _ p) d x = abstract p d (g x) 104 | 105 | {------------------------------------------------------------------------------- 106 | Patterns 107 | 108 | These are analogue to their counterparts in QuickCheck. 109 | -------------------------------------------------------------------------------} 110 | 111 | -- | Pattern synonym useful when generating functions of one argument 112 | pattern Fn :: (a -> b) -> Fun a b 113 | pattern Fn f <- (applyFun -> f) 114 | 115 | -- | Pattern synonym useful when generating functions of two arguments 116 | pattern Fn2 :: (a -> b -> c) -> Fun (a, b) c 117 | pattern Fn2 f <- (applyFun2 -> f) 118 | 119 | -- | Pattern synonym useful when generating functions of three arguments 120 | pattern Fn3 :: (a -> b -> c -> d) -> Fun (a, b, c) d 121 | pattern Fn3 f <- (applyFun3 -> f) 122 | 123 | -- | Apply function to argument 124 | -- 125 | -- See also the 'Fn', 'Fn2', and 'Fn3' patter synonyms. 126 | applyFun :: Fun a b -> a -> b 127 | applyFun Fun{concrete, defaultValue} = abstract concrete defaultValue 128 | 129 | applyFun2 :: Fun (a, b) c -> (a -> b -> c) 130 | applyFun2 f a b = applyFun f (a, b) 131 | 132 | applyFun3 :: Fun (a, b, c) d -> (a -> b -> c -> d) 133 | applyFun3 f a b c = applyFun f (a, b, c) 134 | 135 | {-# COMPLETE Fn #-} 136 | {-# COMPLETE Fn2 #-} 137 | {-# COMPLETE Fn3 #-} 138 | 139 | {------------------------------------------------------------------------------- 140 | Constructing concrete functions 141 | -------------------------------------------------------------------------------} 142 | 143 | shrinkToNil :: Gen (a :-> b) -> Gen (a :-> b) 144 | shrinkToNil gen = fromMaybe Nil <$> shrinkToNothing gen 145 | 146 | table :: forall a b. (Integral a, Bounded a) => Gen b -> Gen (a :-> b) 147 | table gen = Table <$> bst (\_a -> shrinkToNothing gen) i 148 | where 149 | i :: Interval a 150 | i = Interval (Inclusive minBound) (Inclusive maxBound) 151 | 152 | unit :: Gen c -> Gen (() :-> c) 153 | unit gen = shrinkToNil (Unit <$> gen) 154 | 155 | sum :: 156 | (Gen c -> Gen ( a :-> c)) 157 | -> (Gen c -> Gen ( b :-> c)) 158 | -> (Gen c -> Gen (Either a b :-> c)) 159 | sum f g gen = Sum <$> shrinkToNil (f gen) <*> shrinkToNil (g gen) 160 | 161 | prod :: 162 | (forall c. Gen c -> Gen ( a :-> c)) 163 | -> (forall c. Gen c -> Gen ( b :-> c)) 164 | -> (forall c. Gen c -> Gen ((a, b) :-> c)) 165 | prod f g = fmap Prod . f . g 166 | 167 | {------------------------------------------------------------------------------- 168 | Show functions 169 | -------------------------------------------------------------------------------} 170 | 171 | instance (Show a, Show b) => Show (Fun a b) where 172 | show Fun{concrete, defaultValue, isFullyShrunk} 173 | | isFullyShrunk = showFunction concrete defaultValue 174 | | otherwise = "" 175 | 176 | -- | Show concrete function 177 | -- 178 | -- Only use this on finite functions. 179 | showFunction :: (Show a, Show b) => (a :-> b) -> b -> String 180 | showFunction p d = concat [ 181 | "{" 182 | , intercalate ", " $ concat [ 183 | [ show x ++ "->" ++ show c 184 | | (x,c) <- toTable p 185 | ] 186 | , ["_->" ++ show d] 187 | ] 188 | , "}" 189 | ] 190 | 191 | -- | Generating a table from a concrete function 192 | -- 193 | -- This is only used in the 'Show' instance. 194 | toTable :: (a :-> b) -> [(a, b)] 195 | toTable Nil = [] 196 | toTable (Unit x) = [((), x)] 197 | toTable (Prod p) = [ ((x,y),c) | (x,q) <- toTable p, (y,c) <- toTable q ] 198 | toTable (Sum p q) = [ (Left x, c) | (x,c) <- toTable p ] 199 | ++ [ (Right y,c) | (y,c) <- toTable q ] 200 | toTable (Table xys) = mapMaybe (\(a, b) -> (a,) <$> b) $ toList xys 201 | toTable (Map _ h p) = [ (h x, c) | (x,c) <- toTable p ] 202 | 203 | {------------------------------------------------------------------------------- 204 | Class to construct functions 205 | -------------------------------------------------------------------------------} 206 | 207 | -- | Generating functions 208 | class Function a where 209 | -- | Build reified function 210 | -- 211 | -- '(:->)' is an abstract type; if you need to add additional 'Function' 212 | -- instances, you need to use 'functionMap', or rely on the default 213 | -- implementation in terms of generics. 214 | function :: Gen b -> Gen (a :-> b) 215 | 216 | default function :: (Generic a, GFunction (Rep a)) => Gen b -> Gen (a :-> b) 217 | function gen = functionMap from to <$> gFunction gen 218 | 219 | instance Function Word8 where function = table 220 | instance Function Int8 where function = table 221 | 222 | instance Function Int where function = integral 223 | instance Function Int16 where function = integral 224 | instance Function Int32 where function = integral 225 | instance Function Int64 where function = integral 226 | instance Function Word where function = integral 227 | instance Function Word16 where function = integral 228 | instance Function Word32 where function = integral 229 | instance Function Word64 where function = integral 230 | instance Function Integer where function = integral 231 | instance Function Natural where function = integral 232 | 233 | instance Function Float where function = realFrac 234 | instance Function Double where function = realFrac 235 | 236 | instance (Integral a, Function a) => Function (Ratio a) where 237 | function = fmap (functionMap toPair fromPair) . function 238 | where 239 | toPair :: Ratio a -> (a, a) 240 | toPair r = (Ratio.numerator r, Ratio.denominator r) 241 | 242 | fromPair :: (a, a) -> Ratio a 243 | fromPair (n, d) = n Ratio.% d 244 | 245 | instance Function Char where 246 | function = fmap (functionMap ord chr) . function 247 | 248 | -- instances that depend on generics 249 | 250 | instance Function () 251 | instance Function Bool 252 | instance Function Void 253 | 254 | instance (Function a, Function b) => Function (Either a b) 255 | 256 | instance Function a => Function [a] 257 | instance Function a => Function (Maybe a) 258 | 259 | -- Tuples (these are also using generics) 260 | 261 | -- 2 262 | instance 263 | ( Function a 264 | , Function b 265 | ) 266 | => Function (a, b) 267 | 268 | -- 3 269 | instance 270 | ( Function a 271 | , Function b 272 | , Function c 273 | ) 274 | => Function (a, b, c) 275 | 276 | -- 4 277 | instance 278 | ( Function a 279 | , Function b 280 | , Function c 281 | , Function d 282 | ) 283 | => Function (a, b, c, d) 284 | 285 | -- 5 286 | instance 287 | ( Function a 288 | , Function b 289 | , Function c 290 | , Function d 291 | , Function e 292 | ) 293 | => Function (a, b, c, d, e) 294 | 295 | -- 6 296 | instance 297 | ( Function a 298 | , Function b 299 | , Function c 300 | , Function d 301 | , Function e 302 | , Function f 303 | ) 304 | => Function (a, b, c, d, e, f) 305 | 306 | -- 7 307 | instance 308 | ( Function a 309 | , Function b 310 | , Function c 311 | , Function d 312 | , Function e 313 | , Function f 314 | , Function g 315 | ) 316 | => Function (a, b, c, d, e, f, g) 317 | 318 | {------------------------------------------------------------------------------- 319 | Support for numbers 320 | -------------------------------------------------------------------------------} 321 | 322 | integral :: Integral a => Gen b -> Gen (a :-> b) 323 | integral = 324 | fmap (functionMap 325 | (fmap bytes . toSignedNatural . toInteger) 326 | (fromInteger . fromSignedNatural . fmap unbytes) 327 | ) 328 | . function 329 | where 330 | bytes :: Natural -> [Word8] 331 | bytes 0 = [] 332 | bytes n = fromIntegral (n `mod` 256) : bytes (n `div` 256) 333 | 334 | unbytes :: [Word8] -> Natural 335 | unbytes [] = 0 336 | unbytes (w:ws) = fromIntegral w + 256 * unbytes ws 337 | 338 | realFrac :: RealFrac a => Gen b -> Gen (a :-> b) 339 | realFrac = fmap (functionMap toRational fromRational) . function 340 | 341 | data Signed a = Pos a | Neg a 342 | deriving stock (Show, Functor, Generic) 343 | deriving anyclass (Function) 344 | 345 | toSignedNatural :: Integer -> Signed Natural 346 | toSignedNatural n 347 | | n < 0 = Neg (fromInteger (abs n - 1)) 348 | | otherwise = Pos (fromInteger n) 349 | 350 | fromSignedNatural :: Signed Natural -> Integer 351 | fromSignedNatural (Neg n) = negate (toInteger n + 1) 352 | fromSignedNatural (Pos n) = toInteger n 353 | 354 | {------------------------------------------------------------------------------- 355 | Generic support for 'Function' 356 | -------------------------------------------------------------------------------} 357 | 358 | class GFunction f where 359 | gFunction :: Gen b -> Gen (f p :-> b) 360 | 361 | instance GFunction f => GFunction (M1 i c f) where 362 | gFunction = fmap (functionMap unM1 M1) . gFunction @f 363 | 364 | instance GFunction V1 where 365 | gFunction _ = pure Nil 366 | 367 | instance GFunction U1 where 368 | gFunction = fmap (functionMap unwrap wrap) . unit 369 | where 370 | unwrap :: U1 p -> () 371 | unwrap _ = () 372 | 373 | wrap :: () -> U1 p 374 | wrap _ = U1 375 | 376 | instance (GFunction f, GFunction g) => GFunction (f :*: g) where 377 | gFunction = fmap (functionMap unwrap wrap) . prod (gFunction @f) (gFunction @g) 378 | where 379 | unwrap :: (f :*: g) p -> (f p, g p) 380 | unwrap (x :*: y) = (x, y) 381 | 382 | wrap :: (f p, g p) -> (f :*: g) p 383 | wrap (x, y) = x :*: y 384 | 385 | instance (GFunction f, GFunction g) => GFunction (f :+: g) where 386 | gFunction = 387 | fmap (functionMap unwrap wrap) . sum (gFunction @f) (gFunction @g) 388 | where 389 | unwrap :: (f :+: g) p -> Either (f p) (g p) 390 | unwrap (L1 x) = Left x 391 | unwrap (R1 y) = Right y 392 | 393 | wrap :: Either (f p) (g p) -> (f :+: g) p 394 | wrap (Left x) = L1 x 395 | wrap (Right y) = R1 y 396 | 397 | instance Function a => GFunction (K1 i a) where 398 | gFunction = fmap (functionMap unK1 K1) . function @a 399 | -------------------------------------------------------------------------------- /lib/test/TestSuite/Prop/Generator/Compound.hs: -------------------------------------------------------------------------------- 1 | module TestSuite.Prop.Generator.Compound (tests) where 2 | 3 | import Control.Monad 4 | import Data.Default 5 | import Data.Foldable (toList) 6 | import Data.Word 7 | import Test.Tasty 8 | import Test.Tasty.Falsify 9 | 10 | import qualified Data.Tree as Rose 11 | 12 | import Test.Falsify.Predicate (Predicate, (.$)) 13 | import Test.Falsify.Generator (ShrinkTree, Permutation, Tree(..)) 14 | 15 | import qualified Test.Falsify.Generator as Gen 16 | import qualified Test.Falsify.Predicate as P 17 | import qualified Test.Falsify.Range as Range 18 | 19 | import TestSuite.Util.List 20 | 21 | import qualified TestSuite.Util.Tree as Tree 22 | 23 | tests :: TestTree 24 | tests = testGroup "TestSuite.Prop.Generator.Compound" [ 25 | testGroup "list" [ 26 | testGroup "towardsShorter" [ 27 | testProperty "shrinking" prop_list_towardsShorter_shrinking 28 | , testProperty "minimum" prop_list_towardsShorter_minimum 29 | ] 30 | , testGroup "towardsShorterEven" [ 31 | testPropertyWith expectFailure "shrinking" prop_list_towardsShorterEven_shrinking_wrong 32 | , testProperty "minimum" prop_list_towardsShorterEven_minimum 33 | ] 34 | , testGroup "towardsLonger" [ 35 | testProperty "shrinking" prop_list_towardsLonger_shrinking 36 | , testProperty "minimum" prop_list_towardsLonger_minimum 37 | ] 38 | , testGroup "towardsOrigin" [ 39 | testProperty "minimum" prop_list_towardsOrigin_minimum 40 | ] 41 | ] 42 | , testGroup "perm" [ 43 | testProperty "shrinking" prop_perm_shrinking 44 | , testGroup "minimum" [ 45 | testPropertyWith def{overrideMaxRatio = Just 1000} 46 | (show n) $ prop_perm_minimum n 47 | | n <- [0 .. 9] 48 | ] 49 | ] 50 | , testGroup "tree" [ 51 | testProperty "towardsSmaller1" prop_tree_towardsSmaller1 52 | , testProperty "towardsSmaller2" prop_tree_towardsSmaller2 53 | , testProperty "towardsOrigin1" prop_tree_towardsOrigin1 54 | , testProperty "towardsOrigin2" prop_tree_towardsOrigin2 55 | ] 56 | , testGroup "shrinkTree" [ 57 | testProperty "pathAny" prop_pathAny 58 | , testProperty "toShrinkTree" prop_toShrinkTree 59 | ] 60 | , testGroup "frequency" [ 61 | testProperty "shrinking" prop_frequency_shrinking 62 | , testPropertyWith expectFailure 63 | "shrinking_wrong" prop_frequency_shrinking_wrong 64 | , testProperty "replicateM" prop_replicateM_shrinking 65 | ] 66 | ] 67 | where 68 | expectFailure :: TestOptions 69 | expectFailure = def { 70 | expectFailure = ExpectFailure 71 | , overrideNumTests = Just 10_000 72 | } 73 | 74 | {------------------------------------------------------------------------------- 75 | Lists 76 | 77 | Here and elsewhere, for the 'testMinimum' tests, we don't /always/ fail, but 78 | check some property. This ensures that the minimum value isn't just always the 79 | one produced by the @Minimal@ sample tree. 80 | -------------------------------------------------------------------------------} 81 | 82 | prop_list_towardsShorter_shrinking :: Property () 83 | prop_list_towardsShorter_shrinking = 84 | testShrinkingOfGen (P.ge `P.on` P.fn ("length", length)) $ 85 | Gen.list (Range.between (10, 20)) $ 86 | Gen.int $ Range.between (0, 1) 87 | 88 | prop_list_towardsShorter_minimum :: Property () 89 | prop_list_towardsShorter_minimum = 90 | testMinimum (P.satisfies ("expectedLength", (== 10) . length)) $ do 91 | xs <- gen $ Gen.list (Range.between (10, 20)) $ 92 | Gen.int $ Range.between (0, 1) 93 | unless (pairwiseAll (<=) xs) $ testFailed xs 94 | 95 | -- In principle the filtered list can /grow/ in size during shrinking (if 96 | -- a previously odd number is shrunk to be even). 97 | prop_list_towardsShorterEven_shrinking_wrong :: Property () 98 | prop_list_towardsShorterEven_shrinking_wrong = 99 | testShrinkingOfGen (P.ge `P.on` P.fn ("length", length)) $ 100 | fmap (filter even) $ 101 | Gen.list (Range.between (10, 20)) $ 102 | Gen.int $ Range.withOrigin (0, 10) 5 103 | 104 | -- Although [6,4] is the perfect counter-example here, we don't always get it, 105 | -- due to binary search 106 | prop_list_towardsShorterEven_minimum :: Property () 107 | prop_list_towardsShorterEven_minimum = 108 | testMinimum (P.elem .$ ("expected", [[6,4],[8,6]])) $ do 109 | xs <- gen $ fmap (filter even) $ 110 | Gen.list (Range.between (10, 20)) $ 111 | Gen.int $ Range.withOrigin (0, 10) 5 112 | unless (pairwiseAll (<=) xs) $ testFailed xs 113 | 114 | prop_list_towardsLonger_shrinking :: Property () 115 | prop_list_towardsLonger_shrinking = 116 | testShrinkingOfGen (P.le `P.on` P.fn ("length", length)) $ 117 | Gen.list (Range.between (10, 0)) $ 118 | Gen.int $ Range.between (0, 1) 119 | 120 | prop_list_towardsLonger_minimum :: Property () 121 | prop_list_towardsLonger_minimum = 122 | testMinimum (P.satisfies ("expectedLength", (== 10) . length)) $ do 123 | xs <- gen $ Gen.list (Range.between (10, 0)) $ 124 | Gen.int $ Range.between (0, 1) 125 | unless (pairwiseAll (<=) xs) $ testFailed xs 126 | 127 | prop_list_towardsOrigin_minimum :: Property () 128 | prop_list_towardsOrigin_minimum = 129 | testMinimum (P.satisfies ("expectedLength", (== 5) . length)) $ do 130 | xs <- gen $ Gen.list (Range.withOrigin (0, 10) 5) $ 131 | Gen.int $ Range.between (0, 1) 132 | unless (pairwiseAll (<=) xs) $ testFailed xs 133 | 134 | {------------------------------------------------------------------------------- 135 | Permutations (and shuffling) 136 | -------------------------------------------------------------------------------} 137 | 138 | validPermShrink :: Predicate [Permutation, Permutation] 139 | validPermShrink = mconcat [ 140 | P.ge `P.on` P.fn ("numSwaps", length ) 141 | , P.ge `P.on` P.fn ("distance", distance) 142 | ] 143 | where 144 | distance :: Permutation -> Word 145 | distance = sum . map weighted 146 | 147 | weighted :: (Word, Word) -> Word 148 | weighted (i, j) 149 | | i < j = error "unexpected swap" 150 | | otherwise = (10 ^ i) * (i - j) 151 | 152 | prop_perm_shrinking :: Property () 153 | prop_perm_shrinking = 154 | testShrinkingOfGen validPermShrink $ 155 | Gen.permutation 10 156 | 157 | prop_perm_minimum :: Word -> Property () 158 | prop_perm_minimum n = 159 | testMinimum (P.satisfies ("suffixIsUnchanged", suffixIsUnchanged)) $ do 160 | perm <- gen $ Gen.permutation 10 161 | let shuffled = Gen.applyPermutation perm [0 .. 9] 162 | when (shuffled !! fromIntegral n /= n) $ testFailed perm 163 | where 164 | suffixIsUnchanged :: Permutation -> Bool 165 | suffixIsUnchanged perm = 166 | case perm of 167 | [(i, j)] -> i == j + 1 && (i == n || j == n) 168 | _otherwise -> False 169 | 170 | {------------------------------------------------------------------------------- 171 | Tree 172 | 173 | TODO: We're currently only testing minimums here. 174 | TODO: These are discarding a lot of tests; is it expected that a randomly 175 | generated tree is so often weight or heigh balanced..? 176 | -------------------------------------------------------------------------------} 177 | 178 | prop_tree_towardsSmaller1 :: Property () 179 | prop_tree_towardsSmaller1 = 180 | testMinimum (P.satisfies ("expected", expected)) $ do 181 | t <- gen $ Gen.tree (Range.between (0, 100)) $ 182 | Gen.int $ Range.between (0, 1) 183 | -- "Every tree is height balanced" 184 | unless (Tree.isHeightBalanced t) $ testFailed t 185 | where 186 | expected :: Tree Int -> Bool 187 | expected t = or [ 188 | t == Branch 0 (Branch 0 Leaf (Branch 0 Leaf Leaf)) Leaf 189 | , t == Branch 0 Leaf (Branch 0 Leaf (Branch 0 Leaf Leaf)) 190 | ] 191 | 192 | prop_tree_towardsSmaller2 :: Property () 193 | prop_tree_towardsSmaller2 = 194 | testMinimum (P.elem .$ ("expected", expected)) $ do 195 | t <- gen $ Gen.tree (Range.between (0, 100)) $ 196 | Gen.int $ Range.between (0, 1) 197 | -- "Every tree is weight balanced" 198 | unless (Tree.isWeightBalanced t) $ testFailed t 199 | where 200 | -- For a minimal tree that is not weight-balanced, we need three elements in 201 | -- one subtree and none in the other: the weight of the empty tree is 1, 202 | -- the weight of the tree with three elements is 4, and 4 > Δ * 1, for Δ=3. 203 | expected :: [Tree Int] 204 | expected = [ 205 | Branch 0 (Branch 0 (Branch 0 Leaf Leaf) (Branch 0 Leaf Leaf)) Leaf 206 | , Branch 0 (Branch 0 Leaf (Branch 0 Leaf (Branch 0 Leaf Leaf))) Leaf 207 | , Branch 0 Leaf (Branch 0 (Branch 0 Leaf Leaf) (Branch 0 Leaf Leaf)) 208 | , Branch 0 Leaf (Branch 0 Leaf (Branch 0 Leaf (Branch 0 Leaf Leaf))) 209 | ] 210 | 211 | prop_tree_towardsOrigin1 :: Property () 212 | prop_tree_towardsOrigin1 = 213 | testMinimum ( P.satisfies ("expected", expected) 214 | `P.dot` P.fn ("size", Tree.size) 215 | ) $ do 216 | t <- gen $ Gen.tree (Range.withOrigin (0, 100) 10) $ pure () 217 | unless (Tree.isHeightBalanced t) $ testFailed t 218 | where 219 | -- We can always find a non-balanced tree of roughly the specified size 220 | -- (The /exact/ size might not always be reachable with single shrink steps) 221 | expected :: Word -> Bool 222 | expected sz = 8 <= sz && sz <= 10 223 | 224 | prop_tree_towardsOrigin2 :: Property () 225 | prop_tree_towardsOrigin2 = 226 | testMinimum ( P.satisfies ("expected", expected) 227 | `P.dot` P.fn ("size", Tree.size) 228 | ) $ do 229 | t <- gen $ Gen.tree (Range.withOrigin (0, 100) 10) $ pure () 230 | unless (Tree.isWeightBalanced t) $ testFailed t 231 | where 232 | expected :: Word -> Bool 233 | expected sz = 8 <= sz && sz <= 10 234 | 235 | {------------------------------------------------------------------------------- 236 | Shrink trees 237 | -------------------------------------------------------------------------------} 238 | 239 | prop_pathAny :: Property () 240 | prop_pathAny = 241 | testMinimum (P.expect ["", "a", "aa"]) $ do 242 | xs <- gen $ toList <$> Gen.pathAny st 243 | unless (length xs < 3) $ testFailed xs 244 | where 245 | -- Infinite ShrinkTree containing all strings containing lowercase letters 246 | st :: ShrinkTree String 247 | st = Rose.unfoldTree (\xs -> (xs, map (:xs) ['a' .. 'z'])) "" 248 | 249 | prop_toShrinkTree :: Property () 250 | prop_toShrinkTree = 251 | testMinimum (P.satisfies ("expected", expected)) $ do 252 | xs <- gen $ Gen.toShrinkTree genToTest >>= fmap toList . Gen.pathAny 253 | unless (pairwiseAll (>) xs) $ testFailed xs 254 | where 255 | -- Should be any kind of path in which the last two pairs of numbers are 256 | -- NOT decreasing. 257 | expected :: [Word64] -> Bool 258 | expected xs = 259 | case reverse xs of 260 | x : y : _ -> x >= y 261 | _otherwise -> False 262 | 263 | genToTest :: Gen Word64 264 | genToTest = (`mod` 100) <$> Gen.prim 265 | 266 | 267 | {------------------------------------------------------------------------------- 268 | Tweak test data distribution 269 | -------------------------------------------------------------------------------} 270 | 271 | propShrinkingList1 :: [Word] -> [Word] -> Bool 272 | propShrinkingList1 = aux 273 | where 274 | aux [_, _, _] [_, _] = True 275 | aux [_, _, _] [_] = True 276 | aux [_, _] [_] = True 277 | aux [x] [x'] = x >= x' 278 | aux [x, y] [x', y'] = x >= x' && y >= y' 279 | aux [x, y, z] [x', y', z'] = x >= x' && y >= y' && z >= z' 280 | aux _ _ = error "impossible" 281 | 282 | propShrinkingList2 :: [Word] -> [Word] -> Bool 283 | propShrinkingList2 = aux 284 | where 285 | aux :: [Word] -> [Word] -> Bool 286 | aux [x, y, _] [x', y'] = x >= x' && y >= y' 287 | aux [x, _, _] [x'] = x >= x' 288 | aux [x, _] [x'] = x >= x' 289 | aux [x] [x'] = x >= x' 290 | aux [x, y] [x', y'] = x >= x' && y >= y' 291 | aux [x, y, z] [x', y', z'] = x >= x' && y >= y' && z >= z' 292 | aux _ _ = error "impossible" 293 | 294 | genListFrequency :: Gen [Word] 295 | genListFrequency = 296 | Gen.frequency [ 297 | (1, replicateM 1 $ Gen.inRange $ Range.between (0, 10)) 298 | , (2, replicateM 2 $ Gen.inRange $ Range.between (0, 10)) 299 | , (3, replicateM 3 $ Gen.inRange $ Range.between (0, 10)) 300 | ] 301 | 302 | genListMonad :: Gen [Word] 303 | genListMonad = do 304 | n <- Gen.inRange $ Range.between (1, 3) 305 | replicateM n $ Gen.inRange $ Range.between (0, 10) 306 | 307 | prop_frequency_shrinking :: Property () 308 | prop_frequency_shrinking = 309 | testShrinkingOfGen 310 | (P.relatedBy ("propShrinkingList1", propShrinkingList1)) 311 | genListFrequency 312 | 313 | -- 'propShrinkingList2' does /not/ hold for 'genListFrequency' because the 314 | -- generators are independent 315 | prop_frequency_shrinking_wrong :: Property () 316 | prop_frequency_shrinking_wrong = 317 | testShrinkingOfGen 318 | (P.relatedBy ("propShrinkingList2", propShrinkingList2)) 319 | genListFrequency 320 | 321 | -- 'propShrinkingList2' /does/ hold if we simply use 'replicateM'. 322 | prop_replicateM_shrinking :: Property () 323 | prop_replicateM_shrinking = 324 | testShrinkingOfGen 325 | (P.relatedBy ("propShrinkingList2", propShrinkingList2)) 326 | genListMonad 327 | -------------------------------------------------------------------------------- /lib/test/TestSuite/Prop/Generator/Prim.hs: -------------------------------------------------------------------------------- 1 | module TestSuite.Prop.Generator.Prim (tests) where 2 | 3 | import Prelude hiding (pred) 4 | 5 | import Control.Monad 6 | import Control.Selective 7 | import Data.Default 8 | import Data.Word 9 | import Test.Tasty 10 | import Test.Tasty.Falsify 11 | 12 | import qualified Test.Falsify.Generator as Gen 13 | import qualified Test.Falsify.Predicate as P 14 | 15 | import TestSuite.Util.List 16 | 17 | tests :: TestTree 18 | tests = testGroup "TestSuite.Prop.Generator.Prim" [ 19 | testGroup "prim" [ 20 | testProperty "shrinking" prop_prim_shrinking 21 | , testGroup "minimum" [ 22 | testProperty (show target) $ prop_prim_minimum target 23 | | target <- [0 .. 4] 24 | ] 25 | , testPropertyWith (def { expectFailure = ExpectFailure }) 26 | "prim_minimum_wrong" prop_prim_minimum_wrong 27 | ] 28 | , testGroup "applicative" [ 29 | testGroup "pair" [ 30 | testProperty "shrinking" prop_applicative_pair_shrinking 31 | , testProperty "minimum1" prop_applicative_pair_minimum1 32 | , testProperty "minimum2" prop_applicative_pair_minimum2 33 | ] 34 | , testGroup "replicateM" [ 35 | testProperty "shrinking" prop_applicative_replicateM_shrinking 36 | , testProperty "minimum" prop_applicative_replicateM_minimum 37 | ] 38 | ] 39 | , testGroup "monad" [ 40 | testGroup "maybe" [ 41 | testGroup "towardsNothing" [ 42 | testProperty "shrinking" prop_monad_maybe_towardsNothing_shrinking 43 | , testProperty "minimum" prop_monad_maybe_towardsNothing_minimum 44 | , testPropertyWith expectFailure 45 | "shrinking_wrong" prop_monad_maybe_towardsNothing_shrinking_wrong 46 | ] 47 | , testGroup "towardsJust" [ 48 | testProperty "shrinking" prop_monad_maybe_towardsJust_shrinking 49 | , testProperty "minimum" prop_monad_maybe_towardsJust_minimum 50 | , testPropertyWith expectFailure 51 | "minimum_wrong" prop_monad_maybe_towardsJust_minimum_wrong 52 | ] 53 | ] 54 | , testGroup "either" [ 55 | testProperty "shrinking" prop_monad_either_shrinking 56 | ] 57 | ] 58 | , testGroup "selective" [ 59 | testGroup "either" [ 60 | testPropertyWith expectFailure 61 | "shrinking" prop_selective_either_shrinking_wrong 62 | ] 63 | ] 64 | , testGroup "captureLocalTree" [ 65 | testProperty "shrinking1" prop_captureLocalTree_shrinking1 66 | , testProperty "shrinking2" prop_captureLocalTree_shrinking2 67 | ] 68 | , testGroup "stream" [ 69 | testProperty "shrinking1" prop_stream_shrinking1 70 | , testProperty "shrinking2" prop_stream_shrinking2 71 | , testProperty "minimum" prop_stream_minimum 72 | ] 73 | ] 74 | where 75 | expectFailure :: TestOptions 76 | expectFailure = def { 77 | expectFailure = ExpectFailure 78 | , overrideNumTests = Just 100_000 79 | } 80 | 81 | {------------------------------------------------------------------------------- 82 | Prim 83 | -------------------------------------------------------------------------------} 84 | 85 | -- Gen.prime is the only generator where we a /strict/ inequality 86 | prop_prim_shrinking :: Property () 87 | prop_prim_shrinking = testShrinkingOfGen P.gt $ Gen.prim 88 | 89 | -- The minimum is always 0, unless 0 is not a counter-example 90 | prop_prim_minimum :: Word64 -> Property () 91 | prop_prim_minimum target = do 92 | testMinimum (P.expect $ if target == 0 then 1 else 0) $ do 93 | x <- gen $ Gen.prim 94 | unless (x == target) $ testFailed x 95 | 96 | -- | Just to verify that we if we specify the /wrong/ minimum, we get a failure 97 | prop_prim_minimum_wrong :: Property () 98 | prop_prim_minimum_wrong = 99 | testMinimum (P.expect 1) $ do 100 | x <- gen $ Gen.prim 101 | testFailed x 102 | 103 | {------------------------------------------------------------------------------- 104 | Applicative: pairs 105 | -------------------------------------------------------------------------------} 106 | 107 | prop_applicative_pair_shrinking :: Property () 108 | prop_applicative_pair_shrinking = 109 | testShrinkingOfGen (P.relatedBy ("validShrink", validShrink)) $ 110 | (,) <$> Gen.prim <*> Gen.prim 111 | where 112 | validShrink :: (Word64, Word64) -> (Word64, Word64) -> Bool 113 | validShrink (x, y) (x', y') = x >= x' && y >= y' 114 | 115 | prop_applicative_pair_minimum1 :: Property () 116 | prop_applicative_pair_minimum1 = 117 | testMinimum (P.expect (1, 0)) $ do 118 | (x, y) <- gen $ (,) <$> Gen.prim <*> Gen.prim 119 | unless (x == 0 || x < y) $ testFailed (x, y) 120 | 121 | prop_applicative_pair_minimum2 :: Property () 122 | prop_applicative_pair_minimum2 = 123 | testMinimum (P.expect (1, 1)) $ do 124 | (x, y) <- gen $ (,) <$> Gen.prim <*> Gen.prim 125 | unless (x == 0 || x > y) $ testFailed (x, y) 126 | 127 | {------------------------------------------------------------------------------- 128 | Applicative: replicateM 129 | -------------------------------------------------------------------------------} 130 | 131 | genList :: Gen [Word64] 132 | genList = do 133 | n <- (`min` 10) <$> Gen.prim 134 | replicateM (fromIntegral n) Gen.prim 135 | 136 | prop_applicative_replicateM_shrinking :: Property () 137 | prop_applicative_replicateM_shrinking = 138 | testShrinkingOfGen (P.relatedBy ("validShrink", validShrink)) genList 139 | where 140 | validShrink :: [Word64] -> [Word64] -> Bool 141 | validShrink [] [] = True 142 | validShrink [] (_:_) = False 143 | validShrink (_:_) [] = True 144 | validShrink (x:xs) (y:ys) = x >= y && validShrink xs ys 145 | 146 | prop_applicative_replicateM_minimum :: Property () 147 | prop_applicative_replicateM_minimum = 148 | testMinimum (P.expect [0,1]) $ do 149 | xs <- gen $ genList 150 | unless (pairwiseAll (==) xs) $ testFailed xs 151 | 152 | {------------------------------------------------------------------------------- 153 | Monad: Maybe (towards 'Nothing') 154 | -------------------------------------------------------------------------------} 155 | 156 | genSmall :: Gen Word64 157 | genSmall = do 158 | startWithEven <- Gen.prim 159 | if startWithEven >= maxBound `div` 2 160 | then Gen.exhaustive 100 161 | else Gen.exhaustive 99 -- smaller bound, to ensure shrinking 162 | 163 | genTowardsNothing :: Gen (Maybe Word64, Word64) 164 | genTowardsNothing = do 165 | genNothing <- (== 0) <$> Gen.prim 166 | if genNothing 167 | then (\ y -> (Nothing, y)) <$> genSmall 168 | else (\x y -> (Just x, y)) <$> genSmall <*> genSmall 169 | 170 | prop_monad_maybe_towardsNothing_shrinking :: Property () 171 | prop_monad_maybe_towardsNothing_shrinking = 172 | testShrinkingOfGen 173 | (P.relatedBy ("validShrink", validShrink)) 174 | genTowardsNothing 175 | where 176 | validShrink :: (Maybe Word64, Word64) -> (Maybe Word64, Word64) -> Bool 177 | validShrink (Nothing , y) (Nothing , y') = y >= y' 178 | validShrink (Just _ , _) (Nothing , _ ) = True -- See @.._wrong@ property 179 | validShrink (Nothing , _) (Just _ , _ ) = False 180 | validShrink (Just x , y) (Just x' , y') = x >= x' && y >= y' 181 | 182 | prop_monad_maybe_towardsNothing_minimum :: Property () 183 | prop_monad_maybe_towardsNothing_minimum = 184 | testMinimum (P.expect expected) $ do 185 | (x, y) <- gen $ genTowardsNothing 186 | unless (even y) $ testFailed (x, y) 187 | where 188 | -- We are using different generators, a switch from 'Just' to 'Nothing' 189 | -- might temporarily because @y@ to increase (see @.._wrong@), but we will 190 | -- then continue to shrink that value. 191 | expected :: (Maybe Word64, Word64) 192 | expected = (Nothing, 1) 193 | 194 | prop_monad_maybe_towardsNothing_shrinking_wrong :: Property () 195 | prop_monad_maybe_towardsNothing_shrinking_wrong = 196 | testShrinkingOfGen 197 | (P.relatedBy ("validShrink", validShrink)) 198 | genTowardsNothing 199 | where 200 | -- This property is wrong: the two generators on the RHS have a different 201 | -- structure, and therefore shrink independently. When we switch the 202 | -- LHS from Just to Nothing, we run a /different/ generator. 203 | validShrink :: (Maybe Word64, Word64) -> (Maybe Word64, Word64) -> Bool 204 | validShrink (Nothing , y) (Nothing , y') = y >= y' 205 | validShrink (Just _ , y) (Nothing , y') = y >= y' 206 | validShrink (Nothing , _) (Just _ , _) = False 207 | validShrink (Just x , y) (Just x' , y') = x >= x' && y >= y' 208 | 209 | {------------------------------------------------------------------------------- 210 | Monad: Maybe (towards 'Just') 211 | 212 | Unlike hypothesis, we are always dealing with infinite sample tree; if a 213 | "simpler" test case needs more samples, then they are available. 214 | -------------------------------------------------------------------------------} 215 | 216 | genTowardsJust :: Gen (Maybe Word64, Word64) 217 | genTowardsJust = do 218 | genJust <- (== 0) <$> Gen.prim 219 | if genJust 220 | then (\x y -> (Just x, y)) <$> genSmall <*> genSmall 221 | else (\ y -> (Nothing, y)) <$> genSmall 222 | 223 | prop_monad_maybe_towardsJust_shrinking :: Property () 224 | prop_monad_maybe_towardsJust_shrinking = 225 | testShrinkingOfGen 226 | (P.relatedBy ("validShrink", validShrink)) 227 | genTowardsJust 228 | where 229 | validShrink :: (Maybe Word64, Word64) -> (Maybe Word64, Word64) -> Bool 230 | validShrink (Nothing , y) (Nothing , y') = y >= y' 231 | validShrink (Just _ , _) (Nothing , _ ) = False 232 | validShrink (Nothing , _) (Just _ , _ ) = True 233 | validShrink (Just x , y) (Just x' , y') = x >= x' && y >= y' 234 | 235 | prop_monad_maybe_towardsJust_minimum :: Property () 236 | prop_monad_maybe_towardsJust_minimum = 237 | testMinimum (P.satisfies ("expected", expected)) $ do 238 | (x, y) <- gen $ genTowardsJust 239 | unless (even y) $ testFailed (x, y) 240 | where 241 | expected :: (Maybe Word64, Word64) -> Bool 242 | expected (Just _ , y) = y == 1 243 | expected (Nothing , _) = True 244 | 245 | prop_monad_maybe_towardsJust_minimum_wrong :: Property () 246 | prop_monad_maybe_towardsJust_minimum_wrong = 247 | testMinimum (P.expect expected) $ do 248 | (x, y) <- gen $ genTowardsJust 249 | unless (even y) $ testFailed (x, y) 250 | where 251 | -- We might not always be able to shrink from 'Nothing' to 'Just', because 252 | -- the /value/ of that 'Just' might not be a counter-example; we would need 253 | -- to take two shrink steps at once (switch from 'Just' to 'Nothing' /and/ 254 | -- reduce the value of the 'Just'). 255 | -- 256 | -- 'Selective' does not help either (it also would need to take two steps); 257 | -- we /could/ try to solve the problem by generating /both/ values always, 258 | -- and using only one, but as we know, that is not an effective strategy: 259 | -- generated-by-not-used values will always be shrunk to their minimal 260 | -- value, independent of the property. 261 | expected :: (Maybe Word64, Word64) 262 | expected = (Just 0, 1) 263 | 264 | {------------------------------------------------------------------------------- 265 | Monad: Either 266 | -------------------------------------------------------------------------------} 267 | 268 | genMonadEither :: Gen (Either Word64 Word64) 269 | genMonadEither = do 270 | genLeft <- (== 0) <$> Gen.prim -- shrink towards left 271 | if genLeft 272 | then Left <$> Gen.prim 273 | else Right <$> Gen.prim 274 | 275 | prop_monad_either_shrinking :: Property () 276 | prop_monad_either_shrinking = 277 | testShrinkingOfGen 278 | (P.relatedBy ("validShrink", validShrink)) 279 | genMonadEither 280 | where 281 | -- The 'Left' and 'Right' case use the /same/ part of the sample tree, so 282 | -- that if we shrink from one to the other, we /must/ get the same value. 283 | validShrink :: Either Word64 Word64 -> Either Word64 Word64 -> Bool 284 | validShrink _ (Left 0) = True -- We can always shrink to 'Minimal' 285 | validShrink (Left x) (Left x') = x >= x' 286 | validShrink (Left _) (Right _) = False 287 | validShrink (Right x) (Left x') = x == x' 288 | validShrink (Right x) (Right x') = x >= x' 289 | 290 | {------------------------------------------------------------------------------- 291 | Selective: either 292 | -------------------------------------------------------------------------------} 293 | 294 | genSelectiveEither :: Gen (Either Word64 Word64) 295 | genSelectiveEither = 296 | ifS ((== 0) <$> Gen.prim) 297 | (Left <$> Gen.prim) 298 | (Right <$> Gen.prim) 299 | 300 | prop_selective_either_shrinking_wrong :: Property () 301 | prop_selective_either_shrinking_wrong = 302 | testShrinkingOfGen 303 | (P.relatedBy ("validShrink", validShrink)) 304 | genSelectiveEither 305 | where 306 | -- Like in 'prop_monad_either_shrinking', here the two generators are 307 | -- independent, and so it's entirely possible we might shrink from @Right x@ 308 | -- to @Left y@ for @x /= y@. 309 | validShrink :: Either Word64 Word64 -> Either Word64 Word64 -> Bool 310 | validShrink _ (Left 0) = True -- We can always shrink to 'Minimal' 311 | validShrink (Left x) (Left x') = x >= x' 312 | validShrink (Left _) (Right _) = False 313 | validShrink (Right x) (Left x') = x == x' 314 | validShrink (Right x) (Right x') = x >= x' 315 | 316 | {------------------------------------------------------------------------------- 317 | captureLocalTree 318 | -------------------------------------------------------------------------------} 319 | 320 | prop_captureLocalTree_shrinking1 :: Property () 321 | prop_captureLocalTree_shrinking1 = 322 | testShrinkingOfGen P.alwaysFail $ 323 | Gen.captureLocalTree 324 | 325 | -- Check that we /still/ cannot shrink (i.e., monadic bind is not 326 | -- introducing a bug somewhere) 327 | prop_captureLocalTree_shrinking2 :: Property () 328 | prop_captureLocalTree_shrinking2 = 329 | testShrinkingOfGen P.alwaysFail $ do 330 | t1 <- Gen.captureLocalTree 331 | t2 <- Gen.captureLocalTree 332 | return (t1, t2) 333 | 334 | {------------------------------------------------------------------------------- 335 | Stream 336 | 337 | The purpose of this test is to test generation (and shrinking) of infinite 338 | data structures. The function generation tests will verify that also, but they 339 | are much more complicated. 340 | -------------------------------------------------------------------------------} 341 | 342 | -- | Infinite stream of values 343 | -- 344 | -- Intentionally does not have a 'Show' instance! 345 | data Stream a = Stream a (Stream a) 346 | 347 | prefix :: Stream a -> Word64 -> [a] 348 | prefix _ 0 = [] 349 | prefix (Stream x xs) n = x : prefix xs (n - 1) 350 | 351 | genStream :: Gen (Stream Word64) 352 | genStream = Stream <$> Gen.exhaustive 10 <*> genStream 353 | 354 | genStreamPrefix :: Gen [Word64] 355 | genStreamPrefix = prefix <$> genStream <*> Gen.exhaustive 10 356 | 357 | -- | Check that we can test shrinking of infinite structures /at all/ 358 | prop_stream_shrinking1 :: Property () 359 | prop_stream_shrinking1 = 360 | testShrinkingOfGen P.alwaysPass $ 361 | genStreamPrefix 362 | 363 | -- | Check that we shrink in the way we expect 364 | prop_stream_shrinking2 :: Property () 365 | prop_stream_shrinking2 = 366 | testShrinkingOfGen pred $ 367 | genStreamPrefix 368 | where 369 | pred :: P.Predicate '[[Word64], [Word64]] 370 | pred = mconcat [ 371 | P.ge `P.on` P.fn ("length", length) 372 | , P.relatedBy ("elemsRelated", elemsRelated) 373 | ] 374 | 375 | elemsRelated :: [Word64] -> [Word64] -> Bool 376 | elemsRelated orig shrunk = and $ zipWith (>=) orig shrunk 377 | 378 | prop_stream_minimum :: Property () 379 | prop_stream_minimum = 380 | testMinimum (P.expect [0, 0]) $ do 381 | xs <- gen genStreamPrefix 382 | unless (pairwiseAll (<) xs) $ testFailed xs 383 | 384 | --------------------------------------------------------------------------------