diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,111 @@ # Revision history for falsify +## 0.4.0 -- 2026-07-01 + +This release is a major cleanup release, and backwards incompatible with 0.3 in +various ways. Below we provide a list of changes as well as a migration guide. + +### New features + +* `Test.Falsify.Interactive` now offers a pure function `sampleUsing` (#65), + using `ReplaySeed` to initialize the PRNG. `ReplaySeed` is no longer opaque. +* `Property` now offers `getContext`, which allows properties to vary their + behaviour across different test iterations; for example, tests might want to + start with generating values from small ranges and then slowly increase that + range. There is also a derived function `sized` for that specific application. + (#102, together with Peter Lebbing and Martijn Bastiaan from QBayLogic) + +### Package split: `falsify` vs `tasty-falsify` + +* The main `falsify` package no longer provides `tasty` integration (indeed, + it does not depend on `tasty` at all anymore); instead, `tasty` integration + is provided by a new `tasty-falsify` package (#80). + +* Module `Test.Tasty.Falsify` now lives in `tasty-falsify`, and it _only_ + provides the functionality required for the use of `falsify` with `tasty`; it + no longer re-exports anything from `falsify`. + +* `Test.Falsify.Driver` now provides the "official" API for use in driver + integration. + +### Module hierarchy + +The module hierarchy has been improved. + +* There is a new top-level module `Test.Falsify`, which is intended to provide + all definitions that are meant for unqualified import. A typical `falsify` + test suite will therefore start with + + ```hs + import Test.Falsify + import qualified Test.Falsify.Generator as Gen + import qualified Test.Falsify.Predicate as P + import qualified Test.Falsify.Range as Range + ``` + +* `Test.Falsify.Generator` now really only provides generators + (it was previously an awkward mix of generators and custom datatypes) + +* `Data.Falsify.*` is a new public module hierarchy providing some general + purpose data structures and utilities: + - `Data.Falsify.Concrete` + - `Data.Falsify.Permutation` + - `Data.Falsify.ProperFraction` + - `Data.Falsify.Tree` + - `Data.Falsify.WordN` + +* Some testing specific data structures now have dedicated modules: + - `Test.Falsify.Fun` + - `Test.Falsify.Marked` + - `Test.Falsify.SampleTree` + - `Test.Falsify.ShrinkTree` + +The internal (private) module hierarchy has been simplified as well; the +`Reexported.*` module hierarchy is no longer used (the distinction had lost its +purpose). + +### Newtypes + +A number of type aliases have been replaced by newtypes. + +* In `Test.Falsify.Predicate`, `VarName` is now a newtype rather than a type + alias, and we now also have `FnName` alongside `VarName`. Both of these have + `IsString` instances, so code that uses `OverloadedStrings` should not be + affected + +* `ShrinkTree` is now a newtype rather than a type alias, and is moved to + `Test.Falsify.ShrinkTree` + +### Other changes + +* The signature of `path` has been simplified: it no longer uses `IsValidShrink` + (which is now internal API) +* Simplified signature of `bst`, which now only accepts inclusive bounds (#91) +* Remove deprecated functions `integral` and `enum` +* Rename `Test.Falsify.Range.between` to `uniform` (#92). + This avoid confusion with `Test.Falsify.Predicate.between` (since the values + produced by the former do not necessarily satisfy the latter!). Also improved + documentation. +* Predicates `alwaysPass` and `alwaysFail` have been renamed to `pass` and + `fail` respectively, and `fail` now takes an error messages. The new names + are a more natural fit when used together with `lam` to construct predicates + of arbitrary arity. To consider the old `alwaysFail`, use `Fail "Fail"`. +* Predicate documentation has been significantly improved. +* Dropped support for GHC < 8.10.7 + +## 0.3.0 -- 2026-03-05 + +* Introduce new `Range` constructor called `between`, which can be used for + better uniform selection of large bit-size `Integral` types. + [#81, reported by Andrea Vezzosi] +* Support generating functions from empty types [#84, Sjoerd Visscher] +* Add `minimalValue` function [#86, Sjoerd Visscher] +* Fix overflow in `Fun Int8` [#89, reported by Jake McArthur] +* The primitive `Range` constructor is now based on `WordN` rather than + `ProperFraction`. Most users will not notice this difference, but the + signature of the primitive `eval` function has changed. +* Relax package bounds and test with ghc 9.14.1 + ## 0.2.0 -- 2023-11-08 * Avoid use of `Expr` in `at` (#48) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2023, Well-Typed LLP +Copyright (c) 2023-2026, Well-Typed LLP All rights reserved. diff --git a/falsify.cabal b/falsify.cabal --- a/falsify.cabal +++ b/falsify.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: falsify -version: 0.2.0 +version: 0.4.0 synopsis: Property-based testing with internal integrated shrinking description: This library provides property based testing with support for internal integrated shrinking: integrated in the sense @@ -13,9 +13,10 @@ Most users will probably want to use the integration with @@, - and use "Test.Tasty.Falsify" as their main entrypoint - into the library. The "Test.Falsify.Interactive" module - can be used to experiment with the library in @ghci@. + and use "Test.Tasty.Falsify" from the @tasty-falsify@ + package as their main entrypoint into the library. + The "Test.Falsify.Interactive" module can be used to + experiment with the library in @ghci@. license: BSD-3-Clause license-file: LICENSE @@ -28,8 +29,12 @@ tested-with: GHC==8.10.7 , GHC==9.0.2 , GHC==9.2.8 - , GHC==9.4.7 - , GHC==9.6.3 + , GHC==9.4.8 + , GHC==9.6.7 + , GHC==9.8.4 + , GHC==9.10.3 + , GHC==9.12.4 + , GHC==9.14.1 source-repository head type: git @@ -41,7 +46,7 @@ -Wredundant-constraints -Widentities build-depends: - base >= 4.12 && < 4.19 + base >= 4.12 && < 4.23 default-language: Haskell2010 default-extensions: @@ -77,63 +82,68 @@ TypeOperators ViewPatterns + if impl(ghc >= 9.2) + ghc-options: -Wunused-packages + library import: lang exposed-modules: + Test.Falsify + Test.Falsify.Context + Test.Falsify.Driver Test.Falsify.GenDefault Test.Falsify.GenDefault.Std Test.Falsify.Generator Test.Falsify.Interactive + Test.Falsify.Marked Test.Falsify.Predicate - Test.Falsify.Property Test.Falsify.Range + Test.Falsify.SampleTree + Test.Falsify.ShrinkTree - -- For consistency with the other tasty runners, we places these modules - -- in the @Test.Tasty.*@ hiearchy instead of @Test.Falsify.*@. - Test.Tasty.Falsify + -- General purpose datatypes + Data.Falsify.ConcreteFun + Data.Falsify.Permutation + Data.Falsify.ProperFraction + Data.Falsify.Tree + Data.Falsify.WordN other-modules: Test.Falsify.Internal.Driver Test.Falsify.Internal.Driver.ReplaySeed - Test.Falsify.Internal.Driver.Tasty + Test.Falsify.Internal.Fun Test.Falsify.Internal.Generator - Test.Falsify.Internal.Generator.Definition + Test.Falsify.Internal.Generator.Compound + Test.Falsify.Internal.Generator.Function + Test.Falsify.Internal.Generator.Precision Test.Falsify.Internal.Generator.Shrinking + Test.Falsify.Internal.Generator.Simple + Test.Falsify.Internal.Marked.Tree Test.Falsify.Internal.Property Test.Falsify.Internal.Range Test.Falsify.Internal.SampleTree Test.Falsify.Internal.Search - Test.Falsify.Reexported.Generator.Compound - Test.Falsify.Reexported.Generator.Function - Test.Falsify.Reexported.Generator.Precision - Test.Falsify.Reexported.Generator.Shrinking - Test.Falsify.Reexported.Generator.Simple + Test.Falsify.Internal.Shrinking - Data.Falsify.Integer - Data.Falsify.List - Data.Falsify.Marked - Data.Falsify.Tree + Data.Falsify.Internal.Integer + Data.Falsify.Internal.List hs-source-dirs: src build-depends: - , base16-bytestring >= 1.0 && < 1.1 - , binary >= 0.8 && < 0.9 - , bytestring >= 0.10 && < 0.12 - , containers >= 0.6 && < 0.7 - , data-default >= 0.7 && < 0.8 - , mtl >= 2.2 && < 2.4 - , optics-core >= 0.3 && < 0.5 - , optparse-applicative >= 0.16 && < 0.18 - , selective >= 0.4 && < 0.8 - , sop-core >= 0.5 && < 0.6 - , splitmix >= 0.1 && < 0.2 - , tagged >= 0.8 && < 0.9 - , tasty >= 1.3 && < 1.5 - , transformers >= 0.5 && < 0.7 - , vector >= 0.12 && < 0.14 - other-extensions: - CPP + , base16-bytestring >= 1.0 && < 1.1 + , binary >= 0.8 && < 0.9 + , bytestring >= 0.10 && < 0.13 + , containers >= 0.6 && < 0.9 + , data-default >= 0.7 && < 0.9 + , mtl >= 2.2 && < 2.4 + , optics-core >= 0.3 && < 0.5 + , selective >= 0.4 && < 0.8 + , sop-core >= 0.5 && < 0.6 + , splitmix >= 0.1 && < 0.2 + , vector >= 0.12 && < 0.14 +-- NOTE: We test the /generators/ as part of the @tasty-falsify@ test suite, +-- since we need the @tasty@ integration. test-suite test-falsify import: lang @@ -145,27 +155,15 @@ Main.hs other-modules: TestSuite.GenDefault + TestSuite.Regression TestSuite.Sanity.Predicate TestSuite.Sanity.Range TestSuite.Sanity.Selective - TestSuite.Prop.Generator.Compound - TestSuite.Prop.Generator.Function - TestSuite.Prop.Generator.Marking - TestSuite.Prop.Generator.Precision - TestSuite.Prop.Generator.Prim - TestSuite.Prop.Generator.Selective - TestSuite.Prop.Generator.Shrinking - TestSuite.Prop.Generator.Simple - TestSuite.Util.List - TestSuite.Util.Tree build-depends: - , QuickCheck >= 2.14 && < 2.15 - , tasty-hunit >= 0.10 && < 0.11 - - -- Inherit bounds from the main library + -- Inherited bounds from the main library , containers - , data-default , falsify , selective - , tasty - + build-depends: + , tasty >= 1.3 && < 1.6 + , tasty-hunit >= 0.10 && < 0.11 diff --git a/src/Data/Falsify/ConcreteFun.hs b/src/Data/Falsify/ConcreteFun.hs new file mode 100644 --- /dev/null +++ b/src/Data/Falsify/ConcreteFun.hs @@ -0,0 +1,130 @@ +-- | Concrete functions +-- +-- Intended for qualified import. +-- +-- > import Data.Falsify.ConcreteFun ((:->)(..)) +-- > import qualified Data.Falsify.ConcreteFun as ConcreteFun +module Data.Falsify.ConcreteFun ( + (:->)(..) + -- * Construction + , map + -- * Application + , apply + -- * Rendering + , render + ) where + +import Prelude hiding (map) + +import Control.Monad +import Data.Bifunctor +import Data.Foldable (toList) +import Data.Kind +import Data.List (intercalate) +import Data.Maybe (fromMaybe, mapMaybe) + +import Data.Falsify.Tree (Tree(..)) + +import qualified Data.Falsify.Tree as Tree + +{------------------------------------------------------------------------------- + Definition + + NOTE: @Nil@ is useful as a separate constructor, since it does not have an + @Eq@ constraint. +-------------------------------------------------------------------------------} + +-- | Concrete function +-- +-- A concrete function is essentially a deep embedding: an explicit +-- representation of the ouput value of the function for every input value in +-- the function's domain. +-- +-- Concrete functions are the central building block for generating random +-- functions, as proposed by Koen Claessen in \"Shrinking and showing +-- functions\", Haskell Symposium 2012 +-- (). Koen's key insight is +-- that we can start with an infinite concrete function that is defined on every +-- value in the input domain, but since in any given test that function is only +-- applied to a finite number of inputs, we can then shrink the concrete +-- function, throwing away entire chunks of the input domain, until we are left +-- with a finite representation which can be printed as part of a test output. +-- +-- All of the cleverness for /generating/ concrete functions is about reducing +-- the explicitly represented /domain/ of the function. To shrink the /outputs/ +-- of the function nothing special is needed, and we can just rely on Haskell's +-- laziness and the fact that @falsify@ is carefully constructed so that it can +-- generate infinite data types. +data (:->) :: Type -> Type -> Type where + Nil :: a :-> b + Unit :: a -> () :-> a + Table :: Ord a => Tree (a, Maybe b) -> a :-> b + Sum :: (a :-> c) -> (b :-> c) -> (Either a b :-> c) + Prod :: (a :-> (b :-> c)) -> (a, b) :-> c + Map :: (b -> a) -> (a -> b) -> (a :-> c) -> (b :-> c) + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +instance Functor ((:->) a) where + fmap _ Nil = Nil + fmap f (Unit x) = Unit (f x) + fmap f (Table xs) = Table (fmap (second (fmap f)) xs) + fmap f (Sum x y) = Sum (fmap f x) (fmap f y) + fmap f (Prod x) = Prod (fmap (fmap f) x) + fmap f (Map ab ba x) = Map ab ba (fmap f x) + +-- | Change domain of concrete function +-- +-- This is the basic building block for constructing new concrete functions. +map :: (b -> a) -> (a -> b) -> (a :-> c) -> b :-> c +map = Map + +{------------------------------------------------------------------------------- + Application +-------------------------------------------------------------------------------} + +-- | Apply concrete function +apply :: (a :-> b) -> b -> (a -> b) +apply Nil d _ = d +apply (Unit x) _ _ = x +apply (Prod p) d (x,y) = apply (fmap (\q -> apply q d y) p) d x +apply (Sum p q) d exy = either (apply p d) (apply q d) exy +apply (Table xys) d x = fromMaybe d . join $ Tree.lookup x xys +apply (Map g _ p) d x = apply p d (g x) + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +-- | Show concrete function +-- +-- Only use this on finite functions! +render :: (Show a, Show b) => (a :-> b) -> b -> String +render p d = concat [ + "{" + , intercalate ", " $ concat [ + [ show x ++ "->" ++ show c + | (x,c) <- toTable p + ] + , ["_->" ++ show d] + ] + , "}" + ] + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +-- | Generating a table from a concrete function +-- +-- Used in 'render'. +toTable :: (a :-> b) -> [(a, b)] +toTable Nil = [] +toTable (Unit x) = [((), x)] +toTable (Prod p) = [ ((x,y),c) | (x,q) <- toTable p, (y,c) <- toTable q ] +toTable (Sum p q) = [ (Left x, c) | (x,c) <- toTable p ] + ++ [ (Right y,c) | (y,c) <- toTable q ] +toTable (Table xys) = mapMaybe (\(a, b) -> (a,) <$> b) $ toList xys +toTable (Map _ h p) = [ (h x, c) | (x,c) <- toTable p ] diff --git a/src/Data/Falsify/Integer.hs b/src/Data/Falsify/Integer.hs deleted file mode 100644 --- a/src/Data/Falsify/Integer.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Data.Falsify.Integer ( - -- * Encoding - Bit(..) - , encIntegerEliasG - ) where - -import Data.Bits -import Numeric.Natural - -{------------------------------------------------------------------------------- - Binary encoding --------------------------------------------------------------------------------} - -data Bit = I | O - deriving (Show, Eq, Ord) - --- | Binary encoding (most significant bit first) -natToBits :: Natural -> [Bit] -natToBits = \n -> if - | n < 0 -> error "toBits: negative input" - | n == 0 -> [] - | otherwise -> reverse $ go n - where - go :: Natural -> [Bit] - go 0 = [] - go n = (if testBit n 0 then I else O) : go (shiftR n 1) - -{------------------------------------------------------------------------------- - Elias γ code --------------------------------------------------------------------------------} - --- | Elias γ code --- --- Precondition: input @x >= 1@. --- --- See . -encEliasG :: Natural -> [Bit] -encEliasG x - | x == 0 = error "eliasG: zero" - | otherwise = zeroes x - where - zeroes :: Natural -> [Bit] - zeroes n - | n <= 1 = natToBits x - | otherwise = O : zeroes (shiftR n 1) - --- | Extension of Elias γ coding to signed integers --- --- This is adapted from @integerVariant@ in @Test.QuickCheck.Random@. The first --- bit encs whether @x >= 1@ or not (this will result in @0@ and @1@ having --- short codes). -encIntegerEliasG :: Integer -> [Bit] -encIntegerEliasG = \x -> - if x >= 1 - then O : encEliasG (fromInteger $ x) - else I : encEliasG (fromInteger . mangle $ x) - where - mangle :: Integer -> Integer - mangle x = 1 - x diff --git a/src/Data/Falsify/Internal/Integer.hs b/src/Data/Falsify/Internal/Integer.hs new file mode 100644 --- /dev/null +++ b/src/Data/Falsify/Internal/Integer.hs @@ -0,0 +1,59 @@ +module Data.Falsify.Internal.Integer ( + -- * Encoding + Bit(..) + , encIntegerEliasG + ) where + +import Data.Bits +import Numeric.Natural + +{------------------------------------------------------------------------------- + Binary encoding +-------------------------------------------------------------------------------} + +data Bit = I | O + deriving (Show, Eq, Ord) + +-- | Binary encoding (most significant bit first) +natToBits :: Natural -> [Bit] +natToBits = \n -> if + | n < 0 -> error "toBits: negative input" + | n == 0 -> [] + | otherwise -> reverse $ go n + where + go :: Natural -> [Bit] + go 0 = [] + go n = (if testBit n 0 then I else O) : go (shiftR n 1) + +{------------------------------------------------------------------------------- + Elias γ code +-------------------------------------------------------------------------------} + +-- | Elias γ code +-- +-- Precondition: input @x >= 1@. +-- +-- See . +encEliasG :: Natural -> [Bit] +encEliasG x + | x == 0 = error "eliasG: zero" + | otherwise = zeroes x + where + zeroes :: Natural -> [Bit] + zeroes n + | n <= 1 = natToBits x + | otherwise = O : zeroes (shiftR n 1) + +-- | Extension of Elias γ coding to signed integers +-- +-- This is adapted from @integerVariant@ in @Test.QuickCheck.Random@. The first +-- bit encs whether @x >= 1@ or not (this will result in @0@ and @1@ having +-- short codes). +encIntegerEliasG :: Integer -> [Bit] +encIntegerEliasG = \x -> + if x >= 1 + then O : encEliasG (fromInteger $ x) + else I : encEliasG (fromInteger . mangle $ x) + where + mangle :: Integer -> Integer + mangle x = 1 - x diff --git a/src/Data/Falsify/Internal/List.hs b/src/Data/Falsify/Internal/List.hs new file mode 100644 --- /dev/null +++ b/src/Data/Falsify/Internal/List.hs @@ -0,0 +1,52 @@ +module Data.Falsify.Internal.List ( + -- * Splitting + chunksOfNonEmpty + -- * Dealing with marks + , keepAtLeast + ) where + +import Data.Foldable (toList) +import Data.List.NonEmpty (NonEmpty(..)) + +import Test.Falsify.Marked (Mark(..), Marked(..)) +import qualified Test.Falsify.Marked as Marked + +{------------------------------------------------------------------------------- + Splitting +-------------------------------------------------------------------------------} + +-- | Take chunks of a non-empty list +-- +-- This is lazy: +-- +-- > NE.take 4 $ chunksOfNonEmpty 3 (0 :| [1..]) +-- > == [ 0 :| [1,2] +-- > , 3 :| [4,5] +-- > , 6 :| [7,8] +-- > , 9 :| [10,11] +-- > ] +chunksOfNonEmpty :: Word -> NonEmpty a -> NonEmpty (NonEmpty a) +chunksOfNonEmpty 0 _ = error "chunksOfNonEmpty: zero chunk size" +chunksOfNonEmpty n (x :| xs) = + let (chunk, rest) = splitAt (fromIntegral n) (x : xs) + in case (chunk, rest) of + ([] , _) -> error "impossible" + (c:cs , []) -> (c :| cs) :| [] + (c:cs , r:rs) -> (c :| cs) :| toList (chunksOfNonEmpty n (r :| rs)) + +{------------------------------------------------------------------------------- + Dealing with marks +-------------------------------------------------------------------------------} + +keepAtLeast :: Word -> [Marked f a] -> [Marked f a] +keepAtLeast = \n xs -> + let kept = Marked.countKept xs + in if kept >= n + then xs + else go (n - kept) xs + where + go :: Word -> [Marked f a] -> [Marked f a] + go _ [] = [] + go 0 xs = xs + go n (Marked Keep x:xs) = Marked Keep x : go n xs + go n (Marked Drop x:xs) = Marked Keep x : go (n - 1) xs diff --git a/src/Data/Falsify/List.hs b/src/Data/Falsify/List.hs deleted file mode 100644 --- a/src/Data/Falsify/List.hs +++ /dev/null @@ -1,80 +0,0 @@ -module Data.Falsify.List ( - -- * Splitting - chunksOfNonEmpty - -- * Permutations - , Permutation - , applyPermutation - -- * Dealing with marks - , keepAtLeast - ) where - -import Control.Monad -import Control.Monad.ST -import Data.Foldable (toList) -import Data.List.NonEmpty (NonEmpty(..)) - -import qualified Data.Vector as V -import qualified Data.Vector.Mutable as VM - -import Data.Falsify.Marked - -{------------------------------------------------------------------------------- - Splitting --------------------------------------------------------------------------------} - --- | Take chunks of a non-empty list --- --- This is lazy: --- --- > NE.take 4 $ chunksOfNonEmpty 3 (0 :| [1..]) --- > == [ 0 :| [1,2] --- > , 3 :| [4,5] --- > , 6 :| [7,8] --- > , 9 :| [10,11] --- > ] -chunksOfNonEmpty :: Word -> NonEmpty a -> NonEmpty (NonEmpty a) -chunksOfNonEmpty 0 _ = error "chunksOfNonEmpty: zero chunk size" -chunksOfNonEmpty n (x :| xs) = - let (chunk, rest) = splitAt (fromIntegral n) (x : xs) - in case (chunk, rest) of - ([] , _) -> error "impossible" - (c:cs , []) -> (c :| cs) :| [] - (c:cs , r:rs) -> (c :| cs) :| toList (chunksOfNonEmpty n (r :| rs)) - -{------------------------------------------------------------------------------- - Permutations --------------------------------------------------------------------------------} - --- | Permutation is a sequence of swaps -type Permutation = [(Word, Word)] - -applyPermutation :: Permutation -> [a] -> [a] -applyPermutation p xs = - V.toList $ V.modify (forM_ (map conv p) . swap) (V.fromList xs) - where - swap :: V.MVector s a -> (Int, Int) -> ST s () - swap vec (i, j) = do - x <- VM.read vec i - y <- VM.read vec j - VM.write vec i y - VM.write vec j x - - conv :: (Word, Word) -> (Int, Int) - conv (i, j) = (fromIntegral i, fromIntegral j) - -{------------------------------------------------------------------------------- - Dealing with marks --------------------------------------------------------------------------------} - -keepAtLeast :: Word -> [Marked f a] -> [Marked f a] -keepAtLeast = \n xs -> - let kept = countKept xs - in if kept >= n - then xs - else go (n - kept) xs - where - go :: Word -> [Marked f a] -> [Marked f a] - go _ [] = [] - go 0 xs = xs - go n (Marked Keep x:xs) = Marked Keep x : go n xs - go n (Marked Drop x:xs) = Marked Keep x : go (n - 1) xs diff --git a/src/Data/Falsify/Marked.hs b/src/Data/Falsify/Marked.hs deleted file mode 100644 --- a/src/Data/Falsify/Marked.hs +++ /dev/null @@ -1,57 +0,0 @@ --- | Marked elements --- --- Intended for unqualified import. -module Data.Falsify.Marked ( - Mark(..) - , Marked(..) - -- * Generation - , selectAllKept - -- * Queries - , countKept - , shouldKeep - ) where - -import Control.Selective -import Data.Foldable (toList) -import Data.Maybe (mapMaybe) - -{------------------------------------------------------------------------------- - Definition --------------------------------------------------------------------------------} - -data Mark = Keep | Drop - deriving stock (Show, Eq, Ord) - -data Marked f a = Marked { - getMark :: Mark - , unmark :: f a - } - deriving stock (Show, Eq, Ord) - -{------------------------------------------------------------------------------- - Generation --------------------------------------------------------------------------------} - -selectKept :: Selective f => Marked f a -> f (Maybe a) -selectKept (Marked mark gen) = - ifS (pure $ mark == Keep) - (Just <$> gen) - (pure Nothing) - --- | Traverse the argument, generating all values marked 'Keep', and replacing --- all values marked 'Drop' by 'Nothing' -selectAllKept :: - (Traversable t, Selective f) - => t (Marked f a) -> f (t (Maybe a)) -selectAllKept = traverse selectKept - -{------------------------------------------------------------------------------- - Queries --------------------------------------------------------------------------------} - -countKept :: Foldable t => t (Marked f a) -> Word -countKept = fromIntegral . length . mapMaybe shouldKeep . toList - -shouldKeep :: Marked f a -> Maybe (f a) -shouldKeep (Marked Keep x) = Just x -shouldKeep (Marked Drop _) = Nothing diff --git a/src/Data/Falsify/Permutation.hs b/src/Data/Falsify/Permutation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Falsify/Permutation.hs @@ -0,0 +1,85 @@ +-- | Permutations +-- +-- Intended for qualified import. +-- +-- > import Data.Falsify.Permutation (Permutation) +-- > import qualified Data.Falsify.Permutation as Permutation +module Data.Falsify.Permutation ( + Permutation -- opaque + , invariant + , toSwaps + -- * Construction + , identity + , fromSwaps + -- * Properties + , size + -- * Using permutations + , apply + ) where + +import Control.Monad +import Control.Monad.ST + +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as VM + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | Permutation is a sequence of swaps +newtype Permutation = Permutation { + -- | Individual swaps executed by this permutation + toSwaps :: [(Word, Word)] + } + deriving stock (Show) + +-- | Permutation invariant +-- +-- For every swap @(i, j)@ in the permutation we must have @i > j@. +invariant :: Permutation -> Bool +invariant = all checkSwap . toSwaps + where + checkSwap :: (Word, Word) -> Bool + checkSwap (i, j) = i > j + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +-- | Identity permutation +identity :: Permutation +identity = fromSwaps [] + +-- | From swaps +-- +-- Any identity swaps are filtered out. +fromSwaps :: [(Word, Word)] -> Permutation +fromSwaps = Permutation . filter (\(i, j) -> i /= j) + +{------------------------------------------------------------------------------- + Properties +-------------------------------------------------------------------------------} + +-- | Number of swaps +size :: Permutation -> Int +size = length . toSwaps + +{------------------------------------------------------------------------------- + Using permutations +-------------------------------------------------------------------------------} + +-- | Apply permutation +apply :: Permutation -> [a] -> [a] +apply (Permutation p) xs = + V.toList $ V.modify (forM_ (map conv p) . swap) (V.fromList xs) + where + swap :: V.MVector s a -> (Int, Int) -> ST s () + swap vec (i, j) = do + x <- VM.read vec i + y <- VM.read vec j + VM.write vec i y + VM.write vec j x + + conv :: (Word, Word) -> (Int, Int) + conv (i, j) = (fromIntegral i, fromIntegral j) diff --git a/src/Data/Falsify/ProperFraction.hs b/src/Data/Falsify/ProperFraction.hs new file mode 100644 --- /dev/null +++ b/src/Data/Falsify/ProperFraction.hs @@ -0,0 +1,55 @@ +-- | Proper fractions +-- +-- Intended for qualified import. +-- +-- > import Data.Falsify.ProperFraction (ProperFraction(..)) +-- > import qualified Data.Falsify.ProperFraction as ProperFraction +module Data.Falsify.ProperFraction ( + ProperFraction(ProperFraction) + -- * Use + , scaleIntegral + , scaleFractional + ) where + +import Prelude hiding (properFraction) + +import GHC.Show +import GHC.Stack + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | Value @x@ such that @0 <= x < 1@ +newtype ProperFraction = UnsafeProperFraction { getProperFraction :: Double } + deriving stock (Eq, Ord) + deriving newtype (Num, Fractional) + +-- | Show instance relies on the v'ProperFraction' pattern synonym +instance Show ProperFraction where + showsPrec p (UnsafeProperFraction f) = showParen (p >= appPrec1) $ + showString "ProperFraction " + . showsPrec appPrec1 f + +mkProperFraction :: HasCallStack => Double -> ProperFraction +mkProperFraction f + | 0 <= f && f < 1 = UnsafeProperFraction f + | otherwise = error $ "mkProperFraction: not a proper fraction: " ++ show f + +pattern ProperFraction :: Double -> ProperFraction +pattern ProperFraction f <- (getProperFraction -> f) + where + ProperFraction = mkProperFraction + +{-# COMPLETE ProperFraction #-} + +{------------------------------------------------------------------------------- + Use +-------------------------------------------------------------------------------} + +scaleIntegral :: Integral a => a -> ProperFraction -> a +scaleIntegral x (ProperFraction f) = round $ fromIntegral x * f + +scaleFractional :: Fractional a => a -> ProperFraction -> a +scaleFractional x (ProperFraction f) = x * realToFrac f + diff --git a/src/Data/Falsify/Tree.hs b/src/Data/Falsify/Tree.hs --- a/src/Data/Falsify/Tree.hs +++ b/src/Data/Falsify/Tree.hs @@ -1,32 +1,37 @@ +-- | Binary trees +-- +-- Intended for qualified import. +-- +-- > import Data.Falsify.Tree (Tree(..)) +-- > import qualified Data.Falsify.Tree as Tree module Data.Falsify.Tree ( Tree(Leaf, Branch) - -- * Dealing with marks - , propagate - , genKept - , keepAtLeast - -- * Binary search trees - , Interval(..) - , Endpoint(..) - , inclusiveBounds + -- * Properties + , size + , weight + , height + -- * BST , lookup + -- * Balancing + , isWeightBalanced + , isHeightBalanced -- * Debugging - , drawTree + , render ) where -import Prelude hiding (drop, lookup) +import Prelude hiding (lookup) -import Control.Selective (Selective, ifS) -import Control.Monad.State import GHC.Show import qualified Data.Tree as Rose -import Data.Falsify.Marked - {------------------------------------------------------------------------------- Definition -------------------------------------------------------------------------------} +-- | Binary tree +-- +-- Each branch caches the size of the subtree, so that 'size' can be @O(1)@. data Tree a = Leaf @@ -35,7 +40,7 @@ deriving stock (Eq, Functor, Foldable, Traversable) {------------------------------------------------------------------------------- - Tree stats + Properties -------------------------------------------------------------------------------} -- | Size of the tree @@ -45,6 +50,24 @@ size Leaf = 0 size (Branch_ s _ _ _) = s +-- | Weight of the tree +-- +-- The weight of a tree is simply its size plus one. +-- +-- @O(1)@ +weight :: Tree a -> Word +weight = succ . size + +-- | Height of the tree +-- +-- The height of a tree is the maximum length from the root to any of the leafs. +-- +-- @O(1)@ +height :: Tree a -> Word +height Leaf = 0 +height (Branch _ l r) = 1 + max (height l) (height r) + + {------------------------------------------------------------------------------- Pattern synonyms that hide the size argument -------------------------------------------------------------------------------} @@ -78,114 +101,74 @@ . showsPrec appPrec1 r {------------------------------------------------------------------------------- - Dealing with marks + BST -------------------------------------------------------------------------------} --- | Propagate 'Drop' marker down the tree +-- | Look value up in BST -- --- This is useful in conjunction with 'genKept', which truncates entire --- subtrees. -propagate :: Tree (Marked f a) -> Tree (Marked f a) -propagate = keep - where - keep :: Tree (Marked f a) -> Tree (Marked f a) - keep Leaf = Leaf - keep (Branch (Marked Keep x) l r) = Branch (Marked Keep x) (keep l) (keep r) - keep (Branch (Marked Drop x) l r) = Branch (Marked Drop x) (drop l) (drop r) +-- NOTE: The 'Tree' datatype itself does /NOT/ guarantee that the tree is in +-- fact a BST. It is the responsibility of the caller to ensure this. +lookup :: Ord a => a -> Tree (a, b) -> Maybe b +lookup a' (Branch (a, b) l r) + | a' < a = lookup a' l + | a' > a = lookup a' r + | otherwise = Just b +lookup _ Leaf = Nothing - drop :: Tree (Marked f a) -> Tree (Marked f a) - drop = fmap $ \(Marked _ x) -> Marked Drop x +{------------------------------------------------------------------------------- + Balancing +-------------------------------------------------------------------------------} --- | Generate those values we want to keep +-- | Check if the tree is weight-balanced -- --- Whenever we meet an element marked 'Drop', that entire subtree is dropped. -genKept :: forall f a. Selective f => Tree (Marked f a) -> f (Tree a) -genKept = go - where - go :: Tree (Marked f a) -> f (Tree a) - go Leaf = pure Leaf - go (Branch (Marked m g) l r) = ifS (pure $ m == Keep) - (Branch <$> g <*> go l <*> go r) - (pure Leaf) - --- | Change enough nodes currently marked as 'Drop' to 'Keep' to ensure at --- least @n@ nodes are marked 'Keep'. +-- A tree is weight-balanced if the weights of the subtrees does not differ +-- by more than a factor 3. -- --- Precondition: any 'Drop' marks must have been propagated; see 'propagate'. --- Postcondition: this property is preserved. -keepAtLeast :: Word -> Tree (Marked f a) -> Tree (Marked f a) -keepAtLeast = \n t -> - let kept = countKept t - in if kept >= n - then t - else evalState (go t) (n - kept) +-- See "Balancing weight-balanced trees", Hirai and Yamamoto, JFP 21(3), 2011. +isWeightBalanced :: Tree a -> Bool +isWeightBalanced = checkBalanceCondition isBalanced where - go :: Tree (Marked f a) -> State Word (Tree (Marked f a)) - go Leaf = return Leaf - go (Branch (Marked Keep x) l r) = Branch (Marked Keep x) <$> go l <*> go r - go t@(Branch (Marked Drop x) l r) = get >>= \case - 0 -> - -- Nothing left to drop - return t - n | size t <= n -> do - -- We can keep the entire subtree - put $ n - size t - return $ fmap (Marked Keep . unmark) t - n -> do - -- We cannot delete the entire subtree. In order to preserve the - -- "drop property", we /must/ mark this node as 'Keep' - put $ n - 1 - Branch (Marked Keep x) <$> go l <*> go r - -{------------------------------------------------------------------------------- - BST --------------------------------------------------------------------------------} + delta :: Word + delta = 3 -data Endpoint a = Inclusive a | Exclusive a -data Interval a = Interval (Endpoint a) (Endpoint a) + isBalanced :: Tree a -> Tree a -> Bool + isBalanced a b = and [ + delta * weight a >= weight b + , delta * weight b >= weight a + ] --- | Compute interval with inclusive bounds, without exceeding range +-- | Check if a tree is height-balanced -- --- Returns 'Nothing' if the interval is empty, and @Just@ the inclusive --- lower and upper bound otherwise. -inclusiveBounds :: forall a. (Ord a, Enum a) => Interval a -> Maybe (a, a) -inclusiveBounds = \(Interval lo hi) -> go lo hi +-- A tree is height balanced if the heights of its subtrees do not differ +-- by more than one. +isHeightBalanced :: Tree a -> Bool +isHeightBalanced = checkBalanceCondition isBalanced where - -- The inequality checks in @go@ justify the use of @pred@ or @succ@ - go :: Endpoint a -> Endpoint a -> Maybe (a, a) - go (Inclusive lo) (Inclusive hi) - | lo <= hi = Just (lo, hi) - | otherwise = Nothing - go (Exclusive lo) (Inclusive hi) - | lo < hi = Just (succ lo, hi) - | otherwise = Nothing - go (Inclusive lo) (Exclusive hi) - | lo < hi = Just (lo, pred hi) - | otherwise = Nothing - go (Exclusive lo) (Exclusive hi) - | lo < hi = if succ lo > pred hi - then Nothing - else Just (succ lo, pred hi) - | otherwise = Nothing - + isBalanced :: Tree a -> Tree a -> Bool + isBalanced a b = or [ + (height a <= height b) && (height b - height a <= 1) + , (height b <= height a) && (height a - height b <= 1) + ] --- | Look value up in BST +-- | Internal auxiliary: check given tree balance condition -- --- NOTE: The 'Tree' datatype itself does /NOT/ guarantee that the tree is in --- fact a BST. It is the responsibility of the caller to ensure this. -lookup :: Ord a => a -> Tree (a, b) -> Maybe b -lookup a' (Branch (a, b) l r) - | a' < a = lookup a' l - | a' > a = lookup a' r - | otherwise = Just b -lookup _ Leaf = Nothing +-- Property @p l r@ will be checked at every branch in the tree. +checkBalanceCondition :: forall a. (Tree a -> Tree a -> Bool) -> Tree a -> Bool +checkBalanceCondition p = go + where + go :: Tree a -> Bool + go Leaf = True + go (Branch _ l r) = and [p l r, go l, go r] {------------------------------------------------------------------------------- Debugging -------------------------------------------------------------------------------} -drawTree :: Tree String -> String -drawTree = Rose.drawTree . conv +-- | Render tree +-- +-- This is intended for debugging only. +render :: Tree String -> String +render = Rose.drawTree . conv where conv :: Tree String -> Rose.Tree String conv Leaf = Rose.Node "*" [] diff --git a/src/Data/Falsify/WordN.hs b/src/Data/Falsify/WordN.hs new file mode 100644 --- /dev/null +++ b/src/Data/Falsify/WordN.hs @@ -0,0 +1,90 @@ +-- | N-bit words +-- +-- Intended for qualified import. +-- +-- > import Data.Falsify.WordN (WordN) +-- > import qualified Data.Falsify.WordN as WordN +module Data.Falsify.WordN ( + WordN -- opaque + , Precision(..) + , forgetPrecision + -- * Construction + , zero + , truncateAt + , unsafeFromWord64 + -- * Using + , toProperFraction + ) where + +import Data.Bits +import Data.Word + +import Data.Falsify.ProperFraction (ProperFraction(..)) + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | Precision (in bits) +newtype Precision = Precision Word8 + deriving stock (Show, Eq, Ord) + deriving newtype (Num, Enum) + +-- | @n@-bit word +data WordN = WordN Precision Word64 + deriving (Show, Eq, Ord) + +-- | Forget the precision of the t'WordN' +forgetPrecision :: WordN -> Word64 +forgetPrecision (WordN _ x) = x + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +-- | Zero can be represented at every precision +zero :: Precision -> WordN +zero p = WordN p 0 + +-- | Make @n@-bit word (@n <= 64@) +-- +-- Bits outside the requested precision will be zeroed. +-- +-- We use this to generate random @n@-bit words from random 64-bit words. +-- It is important that we /truncate/ rather than /cap/ the value: capping the +-- value (limiting it to a certain maximum) would result in a strong bias +-- towards that maximum value. +-- +-- Of course, /shrinking/ of a Word64 bit does not translate automatically to +-- shrinking of the lower @n@ bits of that word (a decrease in the larger +-- 'Word64' may very well be an /increase/ in the lower @n@ bits), so this must +-- be taken into account. +truncateAt :: Precision -> Word64 -> WordN +truncateAt desiredPrecision x = + WordN actualPrecision (x .&. mask actualPrecision) + where + maximumPrecision, actualPrecision :: Precision + maximumPrecision = Precision 64 + actualPrecision = min desiredPrecision maximumPrecision + + -- Maximum possible value + -- + -- If @n == 64@ then @2 ^ n@ will overflow, but it will overflow to @0@, and + -- @(-1) :: Word64 == maxBound@; so no need to treat this case separately. + mask :: Precision -> Word64 + mask (Precision n) = 2 ^ n - 1 + +-- | Construct from 'Word64' +-- +-- It is the caller's responsibility to ensure that the 'Word64' is in range. +unsafeFromWord64 :: Precision -> Word64 -> WordN +unsafeFromWord64 = WordN + +{------------------------------------------------------------------------------- + Using +-------------------------------------------------------------------------------} + +-- | Compute fraction from @n@-bit word +toProperFraction :: WordN -> ProperFraction +toProperFraction (WordN (Precision p) x) = + ProperFraction $ (fromIntegral x) / (2 ^ p) diff --git a/src/Test/Falsify.hs b/src/Test/Falsify.hs new file mode 100644 --- /dev/null +++ b/src/Test/Falsify.hs @@ -0,0 +1,74 @@ +-- | Main entry point for @falsify@ +-- +-- This provides all common definitions required for writing @falsify@ tests +-- and are intended for unqualified import. Typical usage: +-- +-- > import Test.Falsify +-- > import qualified Test.Falsify.Generator as Gen +-- > import qualified Test.Falsify.Predicate as P +-- > import qualified Test.Falsify.Range as Range +-- +-- We do not export anything from the @Data.Falsify.*@ module hierarchy to +-- avoid name space pollution. +module Test.Falsify ( + -- * Property + Property' -- opaque + , Property + -- ** Generating values + , Gen -- opaque + , Range -- opaque + , Property.gen + , Property.genWith + -- ** Predicates + , Predicate -- opaque + , (.$) + , Property.assert + -- ** Other 'Property' features + , Property.testFailed + , Property.discard + , Property.label + , Property.collect + , Property.info + , Property.getContext + , Property.sized + -- ** Testing generators + , Property.testMinimum + , Property.testMinimumForIteration + , Property.testShrinking + , Property.testShrinkingForIteration + , Property.testShrinkingOfGen + , Property.testShrinkingOfGenForIteration + , Property.testGen + , Property.testGen' + -- ** Functions + , Fun -- opaque + -- *** Patterns + , Fun.applyFun + , Fun.applyFun2 + , Fun.applyFun3 + , pattern Fun.Fn + , pattern Fun.Fn2 + , pattern Fun.Fn3 + -- * Specialised data structures + -- ** Marking + , Marked(..) + , Mark(..) + -- ** Hedgehog and Quickcheck style shrinking + , ShrinkTree(..) + -- * Default generators + , GenDefault(..) + , Std + ) where + +import Test.Falsify.GenDefault +import Test.Falsify.GenDefault.Std +import Test.Falsify.Generator (Gen) +import Test.Falsify.Internal.Fun (Fun) +import Test.Falsify.Internal.Property (Property', Property) +import Test.Falsify.Internal.Range (Range) +import Test.Falsify.Marked (Mark(..), Marked(..)) +import Test.Falsify.Predicate (Predicate, (.$)) +import Test.Falsify.ShrinkTree (ShrinkTree(..)) + +import qualified Test.Falsify.Internal.Fun as Fun +import qualified Test.Falsify.Internal.Property as Property diff --git a/src/Test/Falsify/Context.hs b/src/Test/Falsify/Context.hs new file mode 100644 --- /dev/null +++ b/src/Test/Falsify/Context.hs @@ -0,0 +1,75 @@ +-- | Context +-- +-- Intended for qualified import. +-- +-- > import Test.Falsify +-- > import Test.Falsify.Context (Context) +-- > import qualified Test.Falsify.Context as Context +module Test.Falsify.Context ( + -- * Context + Context(..) + , Static(..) + , Iteration(..) + , Execution(..) + ) where + +-- | Contextual data for a single test case +-- +-- Properties can access contextual data pertaining to the current test case in +-- a test run. An example of its use is varying the range of generated values +-- depending on how many tests we have already done, generating a smaller range +-- in the beginning but widening the range later on. +data Context = Context{ + static :: Static + , iteration :: Iteration + , execution :: Execution + } + deriving stock (Show, Eq) + +-- | Static context +-- +-- The part of the context that does not change between test iterations. +data Static = Static{ + -- | Number of test cases to generate + tests :: Word + + -- | Number of shrinks allowed before failing a test + , maxShrinks :: Maybe Word + + -- | Maximum number of discarded tests per successful test + , maxRatio :: Word + } + deriving stock (Show, Eq) + +-- | Iteration context +-- +-- Information about the current test iteration specifically. +data Iteration = Iteration{ + -- | Number of current test case, 0-based + thisTest :: Word + } + deriving stock (Show, Eq) + +-- | Test execution context +-- +-- NOTE: This should not affect whether the test passes or fails; if it does, +-- you will get undefined shrinking behaviour. +data Execution = + -- | Initial test execution + Initial + + -- | Shrink step + -- + -- We record the index of the shrink step (0-based) + | Shrinking Word + + -- | Final test execution + -- + -- We always end a test execution with one more final run, which is a repeat + -- of the run that came just before it. + -- + -- We record how many shrink steps we took in between 'Initial' and 'Final'; + -- this may be zero, if the initial test happened to be minimal already or + -- shrinking is disabled. + | Final Word + deriving stock (Show, Eq) diff --git a/src/Test/Falsify/Driver.hs b/src/Test/Falsify/Driver.hs new file mode 100644 --- /dev/null +++ b/src/Test/Falsify/Driver.hs @@ -0,0 +1,78 @@ +-- | The main @falsify@ driver +-- +-- The main entrypoint into @falsify@ is the 'falsify' function, which attempts +-- to falsify the t'Test.Falsify.Property'' it is given. +-- However, most users don't need to use this module directly; it is primarily +-- intended for integration of @falsify@ in test frameworks such as @tasty@. +-- For the case of @tasty@ /specifically/, see the @tasty-falsify@ package. +module Test.Falsify.Driver ( + falsify + -- * Options + , Options(..) + , ReplaySeed(..) + , ExpectFailure(..) + , Verbose(..) + , parseReplaySeed + -- * Results + , TestOutcome -- opaque + , TestOutcome' + , RenderedTestOutcome(..) + , renderTestOutcome + -- ** Additional accessors + , successes + , discarded + , failure + , failure' + ) where + +import Data.Bifunctor +import Data.List.NonEmpty (NonEmpty) + +import qualified Data.List.NonEmpty as NE + +import Test.Falsify.Internal.Driver +import Test.Falsify.Internal.Driver.ReplaySeed +import Test.Falsify.Internal.Property +import Test.Falsify.Internal.Shrinking + +{------------------------------------------------------------------------------- + Additional public accessors for 'TestOutcome' + + 'TestOutcome' has quite a bit of @falsify@-internal detail; here we provide + some accessors that may be useful in user code, without having to expose all + of those internals. +-------------------------------------------------------------------------------} + +-- | Successful test outcomes +-- +-- NOTE: Normally the @a@ parameter for a top-level property is instantiated to +-- unit (@()@), in which case it's really only the /length/ of the list of +-- successes that is relevant. +successes :: forall e a. TestOutcome' e a -> [(ReplaySeed, a)] +successes TestOutcome{testSuccesses} = map aux testSuccesses + where + -- Drops the 'TestRun' + aux :: Success a -> (ReplaySeed, a) + aux Success{successSeed, successResult} = (successSeed, successResult) + +-- | Number of discarded test +discarded :: TestOutcome' e a -> Word +discarded TestOutcome{testDiscarded} = testDiscarded + +-- | Failing test, if any +-- +-- Returns the error after shrinking +failure :: TestOutcome' e a -> Maybe (ReplaySeed, e) +failure = fmap (second NE.last) . failure' + +-- | Generalization of 'failure' that returns the full shrinking history +failure' :: forall e a. TestOutcome' e a -> Maybe (ReplaySeed, NonEmpty e) +failure' TestOutcome{testFailure} = aux <$> testFailure + where + aux :: Failure e -> (ReplaySeed, NonEmpty e) + aux Failure{failureSeed, failureRun} = ( + failureSeed + , shrinkHistory + $ first counterexampleError + $ failureRun + ) diff --git a/src/Test/Falsify/GenDefault.hs b/src/Test/Falsify/GenDefault.hs --- a/src/Test/Falsify/GenDefault.hs +++ b/src/Test/Falsify/GenDefault.hs @@ -1,29 +1,43 @@ {-# LANGUAGE UndecidableInstances #-} --- | This module defines something similar to QuickCheck's Arbitrary class along with --- some DerivingVia helpers. Our version, 'GenDefault', allows one to choose between --- sets of default generators with a user-defined tag. See 'Test.Falsify.GenDefault.Std' for --- the standard tag with a few useful instances. -module Test.Falsify.GenDefault - ( GenDefault (..) - , ViaTag (..) - , ViaIntegral (..) - , ViaEnum (..) - , ViaList (..) - , ViaString (..) - , ViaGeneric (..) +-- | Default generators +-- +-- 'GenDefault' (as well as t'Test.Falsify.GenDefault.Std.Std') are exported from +-- "Test.Falsify", so you will only need to import this module if you want to +-- make use of the deriving-via support. +-- +-- Intended for unqualified import. +module Test.Falsify.GenDefault ( + GenDefault(..) + -- * Deriving-via support + , ViaTag(..) + , ViaIntegral(..) + , ViaEnum(..) + , ViaList(..) + , ViaString(..) + , ViaGeneric(..) + , GGenDefault -- opaque ) where -import Control.Applicative (liftA2) -import Data.Proxy (Proxy (..)) -import GHC.Generics (Generic (..), K1 (..), M1 (..), U1 (..), (:+:) (..), (:*:) (..)) -import Test.Falsify.Generator (Gen) -import qualified Test.Falsify.Generator as Gen -import qualified Test.Falsify.Range as Range import Data.Bits (FiniteBits) +import Data.Proxy import GHC.Exts (IsList (..), IsString (..)) +import GHC.Generics import GHC.TypeLits (KnownNat, natVal, Nat) +import qualified Control.Applicative as Ap + +import Test.Falsify.Generator (Gen) +import qualified Test.Falsify.Generator as Gen +import qualified Test.Falsify.Range as Range + +-- | Default generators +-- +-- 'GenDefault' is similar to QuickCheck's 'Test.QuickCheck.Arbitrary' class +-- along with some @deriving via@ helpers. Unlike @Arbitrary@, 'GenDefault' +-- allows one to choose between sets of default generators with user-defined +-- tags. See "Test.Falsify.GenDefault.Std" for the standard tag with a few +-- useful instances. class GenDefault tag a where -- | Default generator for @a@ -- @@ -36,11 +50,15 @@ instance GenDefault tag' a => GenDefault tag (ViaTag tag' a) where genDefault _ = fmap ViaTag (genDefault @tag' Proxy) +{------------------------------------------------------------------------------- + Deriving-via helpers for types of specific shape +-------------------------------------------------------------------------------} + -- | DerivingVia wrapper for Integral types newtype ViaIntegral a = ViaIntegral {unViaIntegral :: a} instance (Integral a, FiniteBits a, Bounded a) => GenDefault tag (ViaIntegral a) where - genDefault _ = fmap ViaIntegral (Gen.inRange (Range.between (minBound, maxBound))) + genDefault _ = fmap ViaIntegral (Gen.inRange Range.uniform) -- | DerivingVia wrapper for Enum types newtype ViaEnum a = ViaEnum {unViaEnum :: a} @@ -55,7 +73,7 @@ genDefault p = let bn = fromInteger (natVal (Proxy @mn)) bx = fromInteger (natVal (Proxy @mx)) - in fmap (ViaList . fromList) (Gen.list (Range.between (bn, bx)) (genDefault p)) + in fmap (ViaList . fromList) (Gen.list (Range.inclusive (bn, bx)) (genDefault p)) -- | DerivingVia wrapper for FromString types newtype ViaString s (mn :: Nat) (mx :: Nat) = ViaString {unViaString :: s} @@ -64,10 +82,19 @@ genDefault p = let bn = fromInteger (natVal (Proxy @mn)) bx = fromInteger (natVal (Proxy @mx)) - in fmap (ViaString . fromString) (Gen.list (Range.between (bn, bx)) (genDefault p)) + in fmap (ViaString . fromString) (Gen.list (Range.inclusive (bn, bx)) (genDefault p)) +{------------------------------------------------------------------------------- + Generics +-------------------------------------------------------------------------------} + +-- | Generic generator construction +-- +-- For use with t'ViaGeneric'. class GGenDefault tag f where + {-# MINIMAL #-} ggenDefault :: Proxy tag -> Gen (f a) + ggenDefault _ = error "ggenDefault not implemented" instance GGenDefault tag U1 where ggenDefault _ = pure U1 @@ -76,7 +103,7 @@ ggenDefault = fmap M1 . ggenDefault instance (GGenDefault tag a, GGenDefault tag b) => GGenDefault tag (a :*: b) where - ggenDefault p = liftA2 (:*:) (ggenDefault p) (ggenDefault p) + ggenDefault p = Ap.liftA2 (:*:) (ggenDefault p) (ggenDefault p) instance (GGenDefault tag a, GGenDefault tag b) => GGenDefault tag (a :+: b) where ggenDefault p = Gen.choose (fmap L1 (ggenDefault p)) (fmap R1 (ggenDefault p)) diff --git a/src/Test/Falsify/GenDefault/Std.hs b/src/Test/Falsify/GenDefault/Std.hs --- a/src/Test/Falsify/GenDefault/Std.hs +++ b/src/Test/Falsify/GenDefault/Std.hs @@ -1,13 +1,16 @@ +-- | \"Standard\" default generators module Test.Falsify.GenDefault.Std ( Std ) where -import Test.Falsify.GenDefault (ViaIntegral (..), GenDefault, ViaEnum (..), ViaGeneric (..)) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Word (Word8, Word16, Word32, Word64) +import Data.Int +import Data.Word +import Test.Falsify.GenDefault + -- | Type tag for these "standard" default generators. --- You can use this tag directly or choose type-by-type with 'ViaTag'. +-- +-- You can use this tag directly or choose type-by-type with t'ViaTag'. data Std deriving via (ViaEnum ()) instance GenDefault Std () diff --git a/src/Test/Falsify/Generator.hs b/src/Test/Falsify/Generator.hs --- a/src/Test/Falsify/Generator.hs +++ b/src/Test/Falsify/Generator.hs @@ -2,19 +2,16 @@ -- -- Intended for qualified import. -- --- > import Test.Falsify.Generator (Gen) --- > import qualified Test.Falsify.Generator qualified as Gen +-- > import Test.Falsify +-- > import qualified Test.Falsify.Generator as Gen module Test.Falsify.Generator ( - -- * Definition Gen -- opaque -- * Simple (non-compound) generators , bool , inRange - , integral - , enum , int -- * Compound generators - -- ** Taking advantage of 'Selective' + -- ** Taking advantage of 'Control.Selective.Selective' , choose , oneof -- ** Lists @@ -24,41 +21,22 @@ , pickBiased , shuffle -- ** Permutations - , Permutation - , applyPermutation , permutation -- ** Tweak test data distribution , frequency -- ** Trees - , Tree(Leaf, Branch) - , drawTree - -- *** Binary trees , tree , bst - -- *** Shrink trees - , ShrinkTree - , IsValidShrink(..) + -- ** Shrink trees , path , pathAny -- ** Marking - , Marked(..) - , Mark(..) - , selectAllKept , mark -- * Functions - -- ** Generation - , Fun - , applyFun - , pattern Fn - , pattern Fn2 - , pattern Fn3 , fun - -- ** Construction , Function(..) - , (:->) -- opaque - , functionMap + , GFunction -- opaque -- * Reducing precision - , WordN(..) , wordN , properFraction -- * Overriding shrinking @@ -70,6 +48,7 @@ -- * Shrink trees , fromShrinkTree , toShrinkTree + , toShrinkTreeWithContext -- * Generator independence , bindIntegral , perturb @@ -79,16 +58,14 @@ , exhaustive , captureLocalTree , bindWithoutShortcut + , minimalValue ) where import Prelude hiding (either, elem, properFraction) -import Data.Falsify.List -import Data.Falsify.Marked import Test.Falsify.Internal.Generator -import Test.Falsify.Reexported.Generator.Compound -import Test.Falsify.Reexported.Generator.Function -import Test.Falsify.Reexported.Generator.Precision -import Test.Falsify.Reexported.Generator.Shrinking -import Test.Falsify.Reexported.Generator.Simple -import Data.Falsify.Tree +import Test.Falsify.Internal.Generator.Compound +import Test.Falsify.Internal.Generator.Function +import Test.Falsify.Internal.Generator.Precision +import Test.Falsify.Internal.Generator.Shrinking +import Test.Falsify.Internal.Generator.Simple diff --git a/src/Test/Falsify/Interactive.hs b/src/Test/Falsify/Interactive.hs --- a/src/Test/Falsify/Interactive.hs +++ b/src/Test/Falsify/Interactive.hs @@ -1,42 +1,59 @@ -- | Utilities for interaction with falsify in ghci module Test.Falsify.Interactive ( + -- * Top-level driver falsify , falsify' + -- * Investigating generators , sample + , sampleUsing , shrink , shrink' -- * Re-exports - , module Test.Falsify.Property - -- ** Functions - , pattern Gen.Fn - , pattern Gen.Fn2 - , pattern Gen.Fn3 + , ReplaySeed(..) ) where -import Data.Bifunctor import Data.Default import Data.List.NonEmpty (NonEmpty(..)) import System.Random.SplitMix -import qualified Data.List.NonEmpty as NE - import Test.Falsify.Internal.Driver.ReplaySeed import Test.Falsify.Internal.Generator -import Test.Falsify.Internal.Generator.Shrinking import Test.Falsify.Internal.Property -import Test.Falsify.Property -import qualified Test.Falsify.Generator as Gen -import qualified Test.Falsify.Internal.Driver as Driver -import qualified Test.Falsify.Internal.SampleTree as SampleTree +import qualified Test.Falsify.Driver as Driver +import qualified Test.Falsify.SampleTree as SampleTree +{------------------------------------------------------------------------------- + Top-level driver +-------------------------------------------------------------------------------} + +-- | Try to falsify the given property +-- +-- Reports the counter-example, if we find any. +falsify :: forall e a. Property' e a -> IO (Maybe e) +falsify = fmap (fmap snd . Driver.failure) . Driver.falsify def + +-- | Generalization of 'falsify' that reports the full shrink history +falsify' :: forall e a. Property' e a -> IO (Maybe (NonEmpty e)) +falsify' = fmap (fmap snd . Driver.failure') . Driver.falsify def + +{------------------------------------------------------------------------------- + Investigating generators +-------------------------------------------------------------------------------} + -- | Sample generator sample :: Gen a -> IO a -sample g = do - prng <- initSMGen - let (x, _shrunk) = runGen g (SampleTree.fromPRNG prng) - return x +sample g = (flip sampleUsing' g) <$> initSMGen +-- | Sample generator using the specified seed +sampleUsing :: ReplaySeed -> Gen a -> a +sampleUsing ReplaySeed{replaySeed, replayGamma} = + sampleUsing' $ seedSMGen replaySeed replayGamma + +-- | Internal generalization of 'sample' and 'sampleUsing' +sampleUsing' :: SMGen -> Gen a -> a +sampleUsing' prng g = fst $ runGen g (SampleTree.fromPRNG prng) + -- | Shrink counter-example -- -- This will run the generator repeatedly until it finds a counter-example to @@ -57,25 +74,3 @@ aux :: Maybe e -> Either e () aux Nothing = Right () aux (Just x) = Left x - --- | Try to falsify the given property --- --- Reports the counter-example, if we find any. -falsify :: forall e a. Property' e a -> IO (Maybe e) -falsify = fmap (fmap NE.last) . falsify' - --- | Generalization of 'falsify' that reports the full shrink history -falsify' :: forall e a. Property' e a -> IO (Maybe (NonEmpty e)) -falsify' = fmap aux . Driver.falsify def - where - aux :: - ( ReplaySeed - , [Driver.Success a] - , Driver.TotalDiscarded - , Maybe (Driver.Failure e) - ) - -> Maybe (NonEmpty e) - aux (_seed, _successes, _discarded, failure) = - case failure of - Nothing -> Nothing - Just f -> Just $ shrinkHistory $ first fst $ Driver.failureRun f diff --git a/src/Test/Falsify/Internal/Driver.hs b/src/Test/Falsify/Internal/Driver.hs --- a/src/Test/Falsify/Internal/Driver.hs +++ b/src/Test/Falsify/Internal/Driver.hs @@ -10,14 +10,15 @@ -- * Results , Success(..) , Failure(..) - , TotalDiscarded(..) + , TestOutcome'(..) + , TestOutcome -- * Test driver , falsify -- * Process results , Verbose(..) , ExpectFailure(..) - , RenderedTestResult(..) - , renderTestResult + , RenderedTestOutcome(..) + , renderTestOutcome ) where import Prelude hiding (log) @@ -36,13 +37,15 @@ import qualified Data.Map as Map import qualified Data.Set as Set +import Test.Falsify.Context (Context(Context)) import Test.Falsify.Internal.Driver.ReplaySeed import Test.Falsify.Internal.Generator -import Test.Falsify.Internal.Generator.Shrinking import Test.Falsify.Internal.Property -import Test.Falsify.Internal.SampleTree (SampleTree) +import Test.Falsify.Internal.Shrinking +import Test.Falsify.SampleTree (SampleTree) -import qualified Test.Falsify.Internal.SampleTree as SampleTree +import qualified Test.Falsify.Context as Context +import qualified Test.Falsify.SampleTree as SampleTree {------------------------------------------------------------------------------- Options @@ -76,46 +79,77 @@ -------------------------------------------------------------------------------} data Success a = Success { - successResult :: a - , successSeed :: ReplaySeed - , successRun :: TestRun + successIteration :: Context.Iteration + , successResult :: a + , successSeed :: ReplaySeed + , successRun :: TestRun } deriving (Show) data Failure e = Failure { failureSeed :: ReplaySeed - , failureRun :: ShrinkExplanation (e, TestRun) TestRun + , failureRun :: ShrinkExplanation (Counterexample e) TestRun } deriving (Show) -newtype TotalDiscarded = TotalDiscarded Word - --- | Run a test: attempt to falsify the given property +-- | Result of running @falsify@ -- --- We return +-- This is an opaque type; see 'renderTestOutcome' and the additional accessors +-- provided in "Test.Falsify.Driver". +data TestOutcome' e a = TestOutcome{ + -- | Initial replay seed (each test also records its own seed) + testReplaySeed :: ReplaySeed + + -- | Successful tests + , testSuccesses :: [Success a] + + -- | Number of discarded tests + , testDiscarded :: Word + + -- | Failed test (if any) + , testFailure :: Maybe (Failure e) + } + +-- | t'TestOutcome' specialized to 'String' for errors -- --- * initial replay seed (each test also records its own seed) --- * successful tests --- * how many tests we discarded --- * the failed test (if any). -falsify :: forall e a. - Options - -> Property' e a - -> IO (ReplaySeed, [Success a], TotalDiscarded, Maybe (Failure e)) +-- This mimicks the 'Property'' vs 'Property' distinction. +type TestOutcome = TestOutcome' String + +-- | Run a test: attempt to falsify the given property +falsify :: forall e a. Options -> Property' e a -> IO (TestOutcome' e a) falsify opts prop = do acc <- initDriverState opts (successes, discarded, mFailure) <- go acc - return ( - splitmixReplaySeed (prng acc) - , successes - , TotalDiscarded discarded - , mFailure - ) + return TestOutcome{ + testReplaySeed = splitmixReplaySeed (prng acc) + , testSuccesses = successes + , testDiscarded = discarded + , testFailure = mFailure + } where + static :: Context.Static + static = Context.Static{ + tests = tests opts + , maxShrinks = maxShrinks opts + , maxRatio = maxRatio opts + } + go :: DriverState a -> IO ([Success a], Word, Maybe (Failure e)) - go acc | todo acc == 0 = return (successes acc, discardedTotal acc, Nothing) + go acc | thisTest acc > tests opts = return ( + reverse $ successes acc + , discardedTotal acc + , Nothing + ) go acc = do - let now, later :: SMGen + let iteration :: Context.Iteration + iteration = Context.Iteration{ + thisTest = thisTest acc + } + + initContext :: Context + initContext = Context static iteration Context.Initial + + now, later :: SMGen (now, later) = splitSMGen (prng acc) st :: SampleTree @@ -124,16 +158,17 @@ result :: TestResult e a run :: TestRun shrunk :: [SampleTree] - ((result, run), shrunk) = runGen (runProperty prop) st + ((result, run), shrunk) = runGen (runProperty prop initContext) st case result of -- Test passed TestPassed x -> do let success :: Success a success = Success { - successResult = x - , successSeed = splitmixReplaySeed now - , successRun = run + successIteration = iteration + , successResult = x + , successSeed = splitmixReplaySeed now + , successRun = run } if runDeterministic run then case (successes acc, discardedTotal acc) of @@ -147,13 +182,18 @@ -- We ignore the failure message here, because this is the failure -- message before shrinking, which we are typically not interested in. TestFailed e -> do - let explanation :: ShrinkExplanation (e, TestRun) TestRun + let explanation :: ShrinkExplanation (Counterexample e) TestRun explanation = - limitShrinkSteps (maxShrinks opts) . second snd $ + second snd $ shrinkFrom - resultIsValidShrink - (runProperty prop) - ((e, run), shrunk) + static + iteration + ( \ctx -> + resultIsValidShrink (Context.execution ctx) <$> + runProperty prop ctx + ) + st + (Counterexample Context.Initial e run, shrunk) -- We have to be careful here: if the user specifies a seed, we -- will first /split/ it to run the test (call to splitSMGen, @@ -186,48 +226,48 @@ -- | Accumulated successful tests , successes :: [Success a] - -- | Number of tests still to execute - , todo :: Word - -- | Number of tests we discarded so far (for this test) , discardedForTest :: Word -- | Number of tests we discarded (in total) , discardedTotal :: Word + + -- | Current test number + , thisTest :: Word } deriving (Show) initDriverState :: Options -> IO (DriverState a) initDriverState opts = do prng <- case replay opts of - Just (ReplaySplitmix seed gamma) -> - return $ seedSMGen seed gamma + Just ReplaySeed{replaySeed, replayGamma} -> + return $ seedSMGen replaySeed replayGamma Nothing -> initSMGen return $ DriverState { prng , successes = [] - , todo = tests opts , discardedForTest = 0 , discardedTotal = 0 + , thisTest = 1 } withSuccess :: SMGen -> Success a -> DriverState a -> DriverState a withSuccess next success acc = DriverState { prng = next , successes = success : successes acc - , todo = pred (todo acc) , discardedForTest = 0 -- reset for the next test , discardedTotal = discardedTotal acc + , thisTest = succ (thisTest acc) } withDiscard :: SMGen -> DriverState a -> DriverState a withDiscard next acc = DriverState { prng = next , successes = successes acc - , todo = todo acc , discardedForTest = succ $ discardedForTest acc , discardedTotal = succ $ discardedTotal acc + , thisTest = thisTest acc } {------------------------------------------------------------------------------- @@ -242,27 +282,38 @@ -- | Do we expect the property to fail? -- --- If 'ExpectFailure', the test will fail if the property does /not/ fail. +-- If v'ExpectFailure', the test will fail if the property does /not/ fail. -- Note that if we expect failure for a property, then we can stop at the first -- failed test; the number of tests to run for the property becomes a maximum -- rather than a goal. data ExpectFailure = ExpectFailure | DontExpectFailure --- | Test result as it should be shown to the user -data RenderedTestResult = RenderedTestResult { +-- | Test outcome as it should be shown to the user +-- +-- The rendered test outcome can usually be used directly in test framework +-- integration. For example, the @tasty@ integration uses +-- +-- > toTastyResult :: RenderedTestOutcome -> Tasty.Result +-- > toTastyResult RenderedTestOutcome{testPassed, testOutput} +-- > | testPassed = Tasty.testPassed testOutput +-- > | otherwise = Tasty.testFailed testOutput +data RenderedTestOutcome = RenderedTestOutcome { testPassed :: Bool , testOutput :: String } -renderTestResult :: +-- | Render test outcome +-- +-- See t'RenderedTestOutcome' for discussion. +renderTestOutcome :: Verbose -> ExpectFailure - -> (ReplaySeed, [Success ()], TotalDiscarded, Maybe (Failure String)) - -> RenderedTestResult -renderTestResult + -> TestOutcome () + -> RenderedTestOutcome +renderTestOutcome verbose expectFailure - (initSeed, successes, TotalDiscarded discarded, mFailure) = + (TestOutcome initSeed successes discarded mFailure) = case (verbose, expectFailure, mFailure) of -- @@ -272,7 +323,7 @@ -- discarded tests). -- - (_, DontExpectFailure, Nothing) | null successes -> RenderedTestResult { + (_, DontExpectFailure, Nothing) | null successes -> RenderedTestOutcome { testPassed = False , testOutput = unlines [ concat [ @@ -289,7 +340,7 @@ -- succeed. -- - (NotVerbose, DontExpectFailure, Nothing) -> RenderedTestResult { + (NotVerbose, DontExpectFailure, Nothing) -> RenderedTestOutcome { testPassed = True , testOutput = unlines [ concat [ @@ -300,7 +351,7 @@ ] } - (Verbose, DontExpectFailure, Nothing) -> RenderedTestResult { + (Verbose, DontExpectFailure, Nothing) -> RenderedTestOutcome { testPassed = True , testOutput = unlines [ concat [ @@ -310,11 +361,11 @@ , "" , "Logs for each test run below." , "" - , unlines $ map renderSuccess (zip [1..] successes) + , unlines $ map renderSuccess successes ] } - (NotVerbose, ExpectFailure, Nothing) -> RenderedTestResult { + (NotVerbose, ExpectFailure, Nothing) -> RenderedTestOutcome { testPassed = False , testOutput = unlines [ "Expected failure, but " ++ countAll ++ " passed" @@ -322,14 +373,14 @@ ] } - (Verbose, ExpectFailure, Nothing) -> RenderedTestResult { + (Verbose, ExpectFailure, Nothing) -> RenderedTestOutcome { testPassed = False , testOutput = unlines [ "Expected failure, but " ++ countAll ++ " passed" , "" , "Logs for each test run below." , "" - , intercalate "\n" $ map renderSuccess (zip [1..] successes) + , intercalate "\n" $ map renderSuccess successes , showSeed initSeed ] } @@ -343,7 +394,7 @@ -- logs independent of verbosity. -- - (NotVerbose, ExpectFailure, Just e) -> RenderedTestResult { + (NotVerbose, ExpectFailure, Just e) -> RenderedTestOutcome { testPassed = True , testOutput = unlines [ concat [ @@ -351,13 +402,13 @@ , countHistory history , countDiscarded ] - , fst $ NE.last history + , counterexampleError $ NE.last history ] } where history = shrinkHistory (failureRun e) - (Verbose, ExpectFailure, Just e) -> RenderedTestResult { + (Verbose, ExpectFailure, Just e) -> RenderedTestOutcome { testPassed = True , testOutput = unlines [ concat [ @@ -365,41 +416,41 @@ , countHistory history , countDiscarded ] - , fst $ NE.last history + , counterexampleError $ NE.last history , "Logs for failed test run:" - , renderLog . runLog . snd $ NE.last history + , renderLog . runLog . counterexampleRun $ NE.last history ] } where history = shrinkHistory (failureRun e) - (NotVerbose, DontExpectFailure, Just e) -> RenderedTestResult { + (NotVerbose, DontExpectFailure, Just e) -> RenderedTestOutcome { testPassed = False , testOutput = unlines [ "failed after " ++ countHistory history - , fst $ NE.last history + , counterexampleError $ NE.last history , "Logs for failed test run:" - , renderLog . runLog . snd $ NE.last history + , renderLog . runLog . counterexampleRun $ NE.last history , showSeed $ failureSeed e ] } where history = shrinkHistory (failureRun e) - (Verbose, DontExpectFailure, Just e) -> RenderedTestResult { + (Verbose, DontExpectFailure, Just e) -> RenderedTestOutcome { testPassed = False , testOutput = unlines [ "failed after " ++ countHistory history - , fst $ NE.last history + , counterexampleError $ NE.last history , "" , "Logs for complete shrink history:" , "" , intercalate "\n" $ [ intercalate "\n" [ - "Step " ++ show (step :: Word) - , renderLog (runLog run) + showStep (counterexampleContext example) + , renderLog (runLog $ counterexampleRun example) ] - | (step, (_result, run)) <- zip [1..] (NE.toList history) + | example <- NE.toList history ] , showSeed $ failureSeed e ] @@ -420,14 +471,28 @@ -- The history includes the original value, so the number of shrink steps -- is the length of the history minus 1. - countHistory :: NonEmpty (String, TestRun) -> [Char] + countHistory :: NonEmpty (Counterexample String) -> [Char] countHistory history = concat [ if | length successes == 0 -> "" | otherwise -> countSuccess ++ " and " - , if | length history == 2 -> "1 shrink" - | otherwise -> show (length history - 1) ++ " shrinks" + , if | numShrinks == 1 -> "1 shrink" + | otherwise -> show numShrinks ++ " shrinks" ] + where + numShrinks :: Word + numShrinks = + case counterexampleContext $ NE.last history of + Context.Final i -> + -- Under normal circumstances this is the only expected case + i + Context.Initial -> + -- No shrinking steps at all + 0 + Context.Shrinking i -> + -- @i@ here is the index of the step, not the number of steps + i + 1 + showSeed :: ReplaySeed -> String showSeed seed = "Use --falsify-replay=" ++ show seed ++ " to replay." @@ -481,10 +546,19 @@ . runLabels . successRun -renderSuccess :: (Int, Success ()) -> String -renderSuccess (ix, Success{successRun}) = + showStep :: Context.Execution -> [Char] + showStep = \case + Context.Initial -> + "Initial counter-example" + Context.Shrinking i -> + "Shrinking step " ++ show i + Context.Final i -> + "Final counter-example after " ++ show i ++ " shrink steps" + +renderSuccess :: Success () -> String +renderSuccess Success{successIteration, successRun} = intercalate "\n" . concat $ [ - ["Test " ++ show ix] + ["Test " ++ show (Context.thisTest successIteration)] , [renderLog $ runLog successRun] ] diff --git a/src/Test/Falsify/Internal/Driver/ReplaySeed.hs b/src/Test/Falsify/Internal/Driver/ReplaySeed.hs --- a/src/Test/Falsify/Internal/Driver/ReplaySeed.hs +++ b/src/Test/Falsify/Internal/Driver/ReplaySeed.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - -- | Replay seeds -- -- We need a seed/gamma pair to initialize a splitmix PRNG. This is however a @@ -11,7 +9,6 @@ module Test.Falsify.Internal.Driver.ReplaySeed ( ReplaySeed(..) , parseReplaySeed - , safeReadReplaySeed , splitmixReplaySeed ) where @@ -23,25 +20,37 @@ import qualified Data.ByteString.Base16.Lazy as Lazy.Base16 import qualified Data.ByteString.Lazy.Char8 as Lazy.Char8 -data ReplaySeed = - ReplaySplitmix Word64 Word64 +-- | Replay seed +-- +-- By default, when we falsify a property we start with a PRNG initialized using +-- a random seed (produced using the system entropy; this relies on +-- 'System.Random.SplitMix.initSMGen' in @splitmix@). When a property /fails/, +-- we will report the exact seed used, so that the user can re-run the exact +-- same test again, if desired. +-- +-- The definition of t'ReplaySeed' is part of @falsify's@ public API, to make it +-- possible to use custom drivers. +data ReplaySeed = ReplaySeed{ + replaySeed :: Word64 -- ^ Seed + , replayGamma :: Word64 -- ^ Gamma (must be odd) + } splitmixReplaySeed :: SMGen -> ReplaySeed -splitmixReplaySeed = uncurry ReplaySplitmix . unseedSMGen +splitmixReplaySeed = uncurry ReplaySeed . unseedSMGen instance Binary ReplaySeed where - put (ReplaySplitmix seed gamma) = do + put ReplaySeed{replaySeed, replayGamma} = do putWord8 1 - put seed - put gamma + put replaySeed + put replayGamma get = do tag <- getWord8 case tag of - 1 -> do seed <- get - gamma <- get - if odd gamma - then return $ ReplaySplitmix seed gamma + 1 -> do replaySeed <- get + replayGamma <- get + if odd replayGamma + then return $ ReplaySeed{replaySeed, replayGamma} else fail $ "ReplaySeed: expected odd gamma for splitmix" n -> fail $ "ReplaySeed: invalid tag: " ++ show n @@ -49,25 +58,20 @@ show = Lazy.Char8.unpack . Lazy.Base16.encode . encode instance IsString ReplaySeed where - fromString = aux . safeReadReplaySeed + fromString = aux . parseReplaySeed where - aux :: Maybe ReplaySeed -> ReplaySeed - aux Nothing = error "ReplaySeed: invalid seed" - aux (Just s) = s - -safeReadReplaySeed :: String -> Maybe ReplaySeed -safeReadReplaySeed = parseReplaySeed - -#if MIN_VERSION_base(4,13,0) -parseReplaySeed :: forall m. MonadFail m => String -> m ReplaySeed -#else -parseReplaySeed :: forall m. Monad m => String -> m ReplaySeed -#endif + aux :: Either String ReplaySeed -> ReplaySeed + aux (Left err) = error $ "ReplaySeed: invalid seed: " ++ err + aux (Right seed) = seed +-- | Parse t'ReplaySeed' +-- +-- Returns 'Left' an error message if parsing failed. +parseReplaySeed :: String -> Either String ReplaySeed parseReplaySeed str = do raw <- case Lazy.Base16.decode (Lazy.Char8.pack str) of - Left err -> fail err - Right x -> return x + Left err -> Left err + Right x -> Right x case decodeOrFail raw of - Left (_, _, err) -> fail err + Left (_, _, err) -> Left err Right (_, _, x) -> return x diff --git a/src/Test/Falsify/Internal/Driver/Tasty.hs b/src/Test/Falsify/Internal/Driver/Tasty.hs deleted file mode 100644 --- a/src/Test/Falsify/Internal/Driver/Tasty.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} --- | Tasty integration --- --- This are the internal guts of the integration. Publicly visible API lives in --- "Test.Tasty.Falsify". -module Test.Falsify.Internal.Driver.Tasty ( - -- * Test property - testProperty - -- * Configure test behaviour - , TestOptions(..) - , Verbose(..) - , ExpectFailure(..) - , testPropertyWith - ) where - -import Prelude hiding (log) - -import Data.Default -import Data.Maybe -import Data.Proxy -import Data.Tagged -import Test.Tasty -import Test.Tasty.Options (IsOption(..), OptionSet) -import Test.Tasty.Providers (IsTest(..)) - -import qualified Test.Tasty.Options as Tasty - -import Test.Falsify.Internal.Driver -import Test.Falsify.Internal.Driver.ReplaySeed -import Test.Falsify.Internal.Property - -import qualified Options.Applicative as Opts -import qualified Test.Tasty.Providers as Tasty - -{------------------------------------------------------------------------------- - Tasty integration --------------------------------------------------------------------------------} - -data Test = Test TestOptions (Property' String ()) - -data TestOptions = TestOptions { - -- | Do we expect this test to fail? - expectFailure :: ExpectFailure - - -- | Override verbose mode for this test - , overrideVerbose :: Maybe Verbose - - -- | Override the maximum number of shrink steps for this test - , overrideMaxShrinks :: Maybe Word - - -- | Override the number of tests - , overrideNumTests :: Maybe Word - - -- | Override how many tests can be discarded per successful test - , overrideMaxRatio :: Maybe Word - } - -instance Default TestOptions where - def = TestOptions { - expectFailure = DontExpectFailure - , overrideVerbose = Nothing - , overrideMaxShrinks = Nothing - , overrideNumTests = Nothing - , overrideMaxRatio = Nothing - } - -instance IsTest Test where - -- @tasty@ docs (1.4.3) explicitly say to ignore the @reportProgress@ argument - run opts (Test testOpts prop) _reportProgress = - toTastyResult . renderTestResult verbose (expectFailure testOpts) <$> - falsify driverOpts prop - where - verbose :: Verbose - verbose = fromMaybe (Tasty.lookupOption opts) (overrideVerbose testOpts) - - driverOpts :: Options - driverOpts = - maybe id - (\x o -> o{maxShrinks = Just x}) - (overrideMaxShrinks testOpts) - $ maybe id - (\x o -> o{tests = x}) - (overrideNumTests testOpts) - $ maybe id - (\x o -> o{maxRatio = x}) - (overrideMaxRatio testOpts) - $ driverOptions opts - - testOptions = Tagged [ - Tasty.Option $ Proxy @Verbose - , Tasty.Option $ Proxy @Tests - , Tasty.Option $ Proxy @MaxShrinks - , Tasty.Option $ Proxy @Replay - , Tasty.Option $ Proxy @MaxRatio - ] - -toTastyResult :: RenderedTestResult -> Tasty.Result -toTastyResult RenderedTestResult{testPassed, testOutput} - | testPassed = Tasty.testPassed testOutput - | otherwise = Tasty.testFailed testOutput - -{------------------------------------------------------------------------------- - User API --------------------------------------------------------------------------------} - --- | Generalization of 'testPropertyWith' using default options -testProperty :: TestName -> Property' String () -> TestTree -testProperty = testPropertyWith def - -testPropertyWith :: TestOptions -> TestName -> Property' String () -> TestTree -testPropertyWith testOpts name = Tasty.singleTest name . Test testOpts - -{------------------------------------------------------------------------------- - Options specific to the tasty test runner - - Not all of these options are command line options; some are set on a - test-by-test basis, such as 'ExpectFailure'. --------------------------------------------------------------------------------} - -instance IsOption Verbose where - defaultValue = NotVerbose - parseValue = fmap (\b -> if b then Verbose else NotVerbose) - . Tasty.safeReadBool - optionName = Tagged $ "falsify-verbose" - optionHelp = Tagged $ "Show the generated test cases" - optionCLParser = Tasty.mkFlagCLParser mempty Verbose - -{------------------------------------------------------------------------------- - Options - - NOTE: If we add another option here, we must also add it in 'testOptions'. --------------------------------------------------------------------------------} - -newtype Tests = Tests { getTests :: Word } -newtype MaxShrinks = MaxShrinks { getMaxShrinks :: Maybe Word } -newtype Replay = Replay { getReplay :: Maybe ReplaySeed } -newtype MaxRatio = MaxRatio { getMaxRatio :: Word } - -instance IsOption Tests where - defaultValue = Tests (tests def) - parseValue = fmap Tests . Tasty.safeRead . filter (/= '_') - optionName = Tagged "falsify-tests" - optionHelp = Tagged "Number of test cases to generate" - -instance IsOption MaxShrinks where - defaultValue = MaxShrinks (maxShrinks def) - parseValue = fmap (MaxShrinks . Just) . Tasty.safeRead - optionName = Tagged "falsify-shrinks" - optionHelp = Tagged "Random seed to use for replaying a previous test run" - -instance IsOption Replay where - defaultValue = Replay (replay def) - parseValue = fmap (Replay . Just) . safeReadReplaySeed - optionName = Tagged "falsify-replay" - optionHelp = Tagged "Random seed to use for replaying test" - optionCLParser = Opts.option readReplaySeed $ mconcat [ - Opts.long $ untag $ optionName @Replay - , Opts.help $ untag $ optionHelp @Replay - ] - where - readReplaySeed :: Opts.ReadM Replay - readReplaySeed = Opts.str >>= fmap (Replay . Just) . parseReplaySeed - -instance IsOption MaxRatio where - defaultValue = MaxRatio (maxRatio def) - parseValue = fmap MaxRatio . Tasty.safeRead . filter (/= '_') - optionName = Tagged "falsify-max-ratio" - optionHelp = Tagged "Maximum number of discarded tests per successful test" - -driverOptions :: OptionSet -> Options -driverOptions opts = Options { - tests = getTests $ Tasty.lookupOption opts - , maxShrinks = getMaxShrinks $ Tasty.lookupOption opts - , replay = getReplay $ Tasty.lookupOption opts - , maxRatio = getMaxRatio $ Tasty.lookupOption opts - } diff --git a/src/Test/Falsify/Internal/Fun.hs b/src/Test/Falsify/Internal/Fun.hs new file mode 100644 --- /dev/null +++ b/src/Test/Falsify/Internal/Fun.hs @@ -0,0 +1,78 @@ +-- | Generated functions +-- +-- Intended for unqualified import. +module Test.Falsify.Internal.Fun ( + Fun(..) + -- * Patterns + , applyFun + , applyFun2 + , applyFun3 + , pattern Fn + , pattern Fn2 + , pattern Fn3 + ) where + +import Data.Falsify.ConcreteFun ((:->)(..)) +import qualified Data.Falsify.ConcreteFun as ConcreteFun + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | Function @a -> b@ which can be shown, generated, and shrunk +data Fun a b = Fun { + concrete :: a :-> b + , defaultValue :: b + + -- Since functions are typically infinite, they can only safely be shown + -- once they are fully shrunk: after all, once a function has been fully + -- shrunk, we /know/ it must be finite, because in any given property, a + -- function will only ever be applied a finite number of times. + , isFullyShrunk :: Bool + } + deriving (Functor) + +{------------------------------------------------------------------------------- + Show functions +-------------------------------------------------------------------------------} + +instance (Show a, Show b) => Show (Fun a b) where + show Fun{concrete, defaultValue, isFullyShrunk} + | isFullyShrunk = ConcreteFun.render concrete defaultValue + | otherwise = "" + +{------------------------------------------------------------------------------- + Patterns + + These are analogue to their counterparts in QuickCheck. +-------------------------------------------------------------------------------} + +-- | Apply function to argument +-- +-- See also the 'Fn', 'Fn2', and 'Fn3' patter synonyms. +applyFun :: Fun a b -> a -> b +applyFun Fun{concrete, defaultValue} = ConcreteFun.apply concrete defaultValue + +-- | Like 'applyFun', but for binary functions +applyFun2 :: Fun (a, b) c -> (a -> b -> c) +applyFun2 f a b = applyFun f (a, b) + +-- | Like 'applyFun', but for ternary functions +applyFun3 :: Fun (a, b, c) d -> (a -> b -> c -> d) +applyFun3 f a b c = applyFun f (a, b, c) + +-- | Pattern synonym useful when generating functions of one argument +pattern Fn :: (a -> b) -> Fun a b +pattern Fn f <- (applyFun -> f) + +-- | Pattern synonym useful when generating functions of two arguments +pattern Fn2 :: (a -> b -> c) -> Fun (a, b) c +pattern Fn2 f <- (applyFun2 -> f) + +-- | Pattern synonym useful when generating functions of three arguments +pattern Fn3 :: (a -> b -> c -> d) -> Fun (a, b, c) d +pattern Fn3 f <- (applyFun3 -> f) + +{-# COMPLETE Fn #-} +{-# COMPLETE Fn2 #-} +{-# COMPLETE Fn3 #-} diff --git a/src/Test/Falsify/Internal/Generator.hs b/src/Test/Falsify/Internal/Generator.hs --- a/src/Test/Falsify/Internal/Generator.hs +++ b/src/Test/Falsify/Internal/Generator.hs @@ -1,15 +1,8 @@ --- | Export the public API of the generator, hiding implementation details. --- --- This is the only module that should import from --- @Test.Falsify.Internal.Generator.*@. --- --- Intended for unqualified import. module Test.Falsify.Internal.Generator ( - Gen -- opaque + -- * Definition + Gen(..) , bindWithoutShortcut - -- * Execution - , runGen - , shrinkFrom + , minimalValue -- * Primitive generators , prim , primWith @@ -22,5 +15,225 @@ , withoutShrinking ) where -import Test.Falsify.Internal.Generator.Definition -import Test.Falsify.Internal.Generator.Shrinking +import Control.Monad +import Control.Selective +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.Word +import Optics.Core (Lens', (%)) + +import qualified Optics.Core as Optics + +import Data.Falsify.Internal.Integer (Bit(..), encIntegerEliasG) +import Test.Falsify.Internal.Search +import Test.Falsify.SampleTree (SampleTree(..), pattern Inf, Sample(..)) + +import qualified Test.Falsify.SampleTree as SampleTree +import qualified Test.Falsify.Internal.SampleTree as SampleTree + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | Generator of a random value +-- +-- Generators can be combined through their 'Functor', 'Applicative' and 'Monad' +-- interfaces. The primitive generator is 'prim', but most users will probably +-- want to construct their generators using the predefined from +-- "Test.Falsify.Generator" as building blocks. +-- +-- Generators support \"internal integrated shrinking\". Shrinking is +-- /integrated/ in the sense of Hedgehog, meaning that we don't write a separate +-- shrinker at all, but the shrink behaviour is implied by the generator. For +-- example, if you have a generator @genList@ for a list of numbers, then +-- +-- > filter even <$> genList +-- +-- will only generate even numbers, and that property is automatically preserved +-- during shrinking. Shrinking is /internal/ in the sense of Hypothesis, meaning +-- that unlike in Hedgehog, shrinking works correctly even in the context of +-- monadic bind. For example, if you do +-- +-- > do n <- genListLength +-- > replicateM n someOtherGen +-- +-- then we can shrink @n@ and the results from @someOtherGen@ in any order (that +-- said, users may prefer to use the dedicated +-- 'Test.Falsify.Generator.Compound.list' generator for this purpose, which +-- improves on this in a few ways). +-- +-- NOTE: t'Gen' is /NOT/ an instance of 'Control.Applicative.Alternative'; this +-- would not be compatible with the generation of infinite data structures. For +-- the same reason, we do not have a monad transformer version of t'Gen' either. +newtype Gen a = Gen { runGen :: SampleTree -> (a, [SampleTree]) } + deriving stock (Functor) + +instance Applicative Gen where + pure x = Gen $ \_st -> (x, []) + (<*>) = ap + +instance Monad Gen where + return = pure + x >>= f = Gen $ \(Inf s l r) -> + let (a, ls) = runGen x l + (b, rs) = runGen (f a) r + in (b, combineShrunk s (l :| ls) (r :| rs)) + +instance Selective Gen where + select e f = Gen $ \(Inf s l r) -> do + let (ma, ls) = runGen e l + case ma of + Left a -> + let (f', rs) = runGen f r + in (f' a, combineShrunk s (l :| ls) (r :| rs)) + Right b -> + (b, combineShrunk s (l :| ls) (r :| [])) + +-- | Combine shrunk left and right sample trees +-- +-- This is an internal function only. +combineShrunk :: + Sample + -> NonEmpty SampleTree -- ^ Original and shrunk left trees + -> NonEmpty SampleTree -- ^ Original and shrunk right trees + -> [SampleTree] +combineShrunk s (l :| ls) (r :| rs) = shortcut $ concat [ + [SampleTree s l' r | l' <- unlessMinimal l ls] + , [SampleTree s l r' | r' <- unlessMinimal r rs] + ] + where + -- We must be careful not to force @ls@/@rs@ if the tree is already minimal. + unlessMinimal :: SampleTree -> [a] -> [a] + unlessMinimal Minimal _ = [] + unlessMinimal _ xs = xs + + shortcut :: [SampleTree] -> [SampleTree] + shortcut [] = [] + shortcut ts = Minimal : ts + +-- | Varation on @(>>=)@ that doesn't apply the shortcut to 'Minimal' +-- +-- This function is primarily useful for debugging @falsify@ itself; users +-- will probably never need it. +bindWithoutShortcut :: Gen a -> (a -> Gen b) -> Gen b +bindWithoutShortcut x f = Gen $ \(Inf s l r) -> + let (a, ls) = runGen x l + (b, rs) = runGen (f a) r + in (b, combine s (l :| ls) (r :| rs)) + where + -- Variation on 'combineShrunk' that doesn't apply the shortcut + combine :: + Sample + -> NonEmpty SampleTree -- ^ Original and shrunk left trees + -> NonEmpty SampleTree -- ^ Original and shrunk right trees + -> [SampleTree] + combine s (l :| ls) (r :| rs) = concat [ + [SampleTree s l' r | l' <- ls] + , [SampleTree s l r' | r' <- rs] + ] + +-- | Get the value produced by the generator on the minimal sample tree. +-- +-- Having @Gen a@ is a proof that @a@ is inhabited, so this function +-- gives access to a witness. +minimalValue :: Gen a -> a +minimalValue g = fst (runGen g Minimal) + +{------------------------------------------------------------------------------- + Generator independence +-------------------------------------------------------------------------------} + +-- | Selective bind +-- +-- Unlike monadic bind, the RHS is generated and shrunk completely independently +-- for each different value of @a@ produced by the LHS. +-- +-- This is a generalization of 'bindS' to arbitrary integral values; it is also +-- much more efficient than 'bindS'. +-- +-- NOTE: This is only one way to make a generator independent. See 'perturb' +-- for more primitive combinator. +bindIntegral :: Integral a => Gen a -> (a -> Gen b) -> Gen b +bindIntegral x f = x >>= \a -> perturb a (f a) + +-- | Run generator on different part of the sample tree depending on @a@ +perturb :: Integral a => a -> Gen b -> Gen b +perturb a g = Gen $ \st -> + let (b, shrunk) = runGen g (Optics.view lens st) + in (b, map (\st' -> Optics.set lens st' st) shrunk) + where + lens :: Lens' SampleTree SampleTree + lens = computeLens (encIntegerEliasG $ fromIntegral a) + + computeLens :: [Bit] -> Lens' SampleTree SampleTree + computeLens [] = Optics.castOptic Optics.simple + computeLens (O : bs) = SampleTree.left % computeLens bs + computeLens (I : bs) = SampleTree.right % computeLens bs + +{------------------------------------------------------------------------------- + Primitive generators +-------------------------------------------------------------------------------} + +-- | Uniform selection of 'Word64', shrinking towards 0, using binary search +-- +-- This is a primitive generator; most users will probably not want to use this +-- generator directly. +prim :: Gen Word64 +prim = + SampleTree.sampleValue <$> + primWith (binarySearch . SampleTree.sampleValue) + +-- | Generalization of 'prim' that allows to override the shrink behaviour +-- +-- This is only required in rare circumstances. Most users will probably never +-- need to use this generator. +primWith :: (Sample -> [Word64]) -> Gen Sample +primWith f = Gen $ \(Inf s l r) -> ( + s + , (\s' -> SampleTree (Shrunk s') l r) <$> f s + ) + +-- | Generate arbitrary value @x <= n@ +-- +-- Unlike 'prim', 'exhaustive' does not execute binary search. Instead, /all/ +-- smaller values are considered. This is potentially very expensive; the +-- primary use case for this generator is testing shrinking behaviour, where +-- binary search can lead to some unpredicatable results. +-- +-- This does /NOT/ do uniform selection: for small @n@, the generator will with +-- overwhelming probability produce @n@ itself as initial value. +-- +-- This is a primitive generator; most users will probably not want to use this +-- generator directly. +exhaustive :: Word64 -> Gen Word64 +exhaustive n = + min n . SampleTree.sampleValue <$> + primWith (completeSearch . SampleTree.sampleValue) + where + completeSearch :: Word64 -> [Word64] + completeSearch 0 = [] + completeSearch x = takeWhile (<= n) [0 .. pred x] + +-- | Capture the local sample tree +-- +-- This generator does not shrink. +captureLocalTree :: Gen SampleTree +captureLocalTree = Gen $ \st -> (st, []) + +{------------------------------------------------------------------------------- + Shrinking combinators +-------------------------------------------------------------------------------} + +-- | Disable shrinking in the given generator +-- +-- Due to the nature of internal shrinking, it is always possible that a +-- generator gets reapplied to samples that were shrunk wrt to a /different/ +-- generator. In this sense, 'withoutShrinking' should be considered to be a +-- hint only. +-- +-- This function is only occassionally necessary; most users will probably not +-- need to use it. +withoutShrinking :: Gen a -> Gen a +withoutShrinking (Gen g) = Gen $ aux . g + where + aux :: (a, [SampleTree]) -> (a, [SampleTree]) + aux (outcome, _) = (outcome, []) diff --git a/src/Test/Falsify/Internal/Generator/Compound.hs b/src/Test/Falsify/Internal/Generator/Compound.hs new file mode 100644 --- /dev/null +++ b/src/Test/Falsify/Internal/Generator/Compound.hs @@ -0,0 +1,461 @@ +-- | Compound generators +module Test.Falsify.Internal.Generator.Compound ( + -- * Taking advantage of 'Control.Selective.Selective' + choose + , oneof + -- * Lists + , list + , elem + , pick + , pickBiased + -- ** Shuffling + , shuffle + , permutation + -- * Tweak test data distribution + , frequency + -- * Trees + -- ** Binary trees + , tree + , bst + -- ** Shrink trees + , IsValidShrink(..) + , path + , pathAny + -- * Auxiliary + , shrinkToNothing + , mark + ) where + +import Prelude hiding (either, elem) + +import Control.Monad +import Control.Selective +import Data.Either (either) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (catMaybes) +import Data.Void + +import qualified Data.List.NonEmpty as NE +import qualified Data.Tree as Rose + +import Data.Falsify.Permutation (Permutation) +import Data.Falsify.Tree (Tree(..)) +import Test.Falsify.Internal.Generator +import Test.Falsify.Internal.Generator.Shrinking +import Test.Falsify.Internal.Generator.Simple +import Test.Falsify.Internal.Range +import Test.Falsify.Internal.Shrinking (IsValidShrink(..)) +import Test.Falsify.Marked (Mark(..), Marked(..)) +import Test.Falsify.ShrinkTree (ShrinkTree(..)) + +import qualified Data.Falsify.Internal.List as List +import qualified Data.Falsify.Permutation as Permutation +import qualified Test.Falsify.Internal.Marked.Tree as MarkedTree +import qualified Test.Falsify.Marked as Marked +import qualified Test.Falsify.Range as Range + +{------------------------------------------------------------------------------- + Taking advantage of 'Control.Selective.Selective' +-------------------------------------------------------------------------------} + +-- | Generate a value with one of two generators +-- +-- Shrinks towards the first generator;the two generators can shrink +-- independently from each other. +-- +-- === Background +-- +-- In the remainder of this docstring we give some background to this function, +-- which may be useful for general understanding of the @falsify@ library. +-- +-- The implementation takes advantage of the that t'Gen' is a selective functor +-- to ensure that the two generators can shrink independently: if the initial +-- value of the generator is some @y@ produced by the second generator, later +-- shrunk to some @y'@, then if the generator can shrink to @x@ at some point, +-- produced by the /first/ generator, then shrinking effectively "starts over": +-- the value of @x@ is independent of @y'@. +-- +-- That is different from doing this: +-- +-- > do b <- bool +-- > if b then l else r +-- +-- In this case, @l@ and @r@ will be generated from the /same/ sample tree, +-- and so cannot shrink independently. +-- +-- It is /also/ different from +-- +-- > do x <- l +-- > y <- r +-- > b <- bool +-- > return $ if b then x else y +-- +-- In this case, @l@ and @r@ are run against /different/ sample trees, like we +-- do here, /but/ in this case if the current value produced by the generator is +-- produced by the right generator, then the sample tree used for the left +-- generator will always shrink to 'Test.Falsify.SampleTree.Minimal' (this /must/ +-- be possible because we're not currently using it); this means that we would +-- then only be able to shrink to a value from the left generator if the +-- /minimal/ value produced by that generator happens to work. +-- +-- To rephrase that last point: generating values that are not actually used +-- will lead to poor shrinking, since those values can always be shrunk to their +-- minimal value, independently from whatever property is being tested: the +-- shrinker does not know that the value is not being used. The correct way to +-- conditionally use a value is to use the selective interface, as we do here. +choose :: Gen a -> Gen a -> Gen a +choose = ifS (bool True) + +-- | Generate a value with one of many generators +-- +-- Uniformly selects a generator and shrinks towards the first one. +oneof :: NonEmpty (Gen a) -> Gen a +oneof gens = frequency $ map (1,) $ NE.toList gens + +{------------------------------------------------------------------------------- + Auxiliary: marking elements +-------------------------------------------------------------------------------} + +-- | Start with @Just x@ for some @x@, then shrink to @Nothing@ +shrinkToNothing :: Gen a -> Gen (Maybe a) +shrinkToNothing g = firstThen Just (const Nothing) <*> g + +-- | Mark an element, shrinking towards 'Drop' +-- +-- This is similar to 'shrinkToNothing', except that t'Marked' still has a value +-- in the 'Drop' case: marks are merely hints, that we may or may not use. +mark :: Gen a -> Gen (Marked Gen a) +mark x = flip Marked x <$> firstThen Keep Drop + +{------------------------------------------------------------------------------- + Lists +-------------------------------------------------------------------------------} + +-- | Generate list of specified length +-- +-- Shrinking behaviour: +-- +-- * The length of the list will shrink as specified by the given range. +-- * We can drop random elements from the list, but prefer to drop them +-- from near the /end/ of the list. +-- +-- == Note on shrinking predictability +-- +-- The implementation of 'list' uses a combination of two principles to produce +-- a list of the desired length: +-- +-- * We generate a random list /length/ in the specified 'Range', and produce an +-- initial length of that length +-- * We then /drop/ elements from the resulting list, whilst still respecting the +-- specified 'Range'. +-- +-- This ensures that we will produce a list with a length that tends towards the +-- origin of the specified 'Range', but whilst still being able to drop elements +-- from anywhere within the list, rather than just shrinking towards a prefix +-- (or suffix) from the initial list. +-- +-- In the case that the specified 'Range' has an origin which is neither the +-- lower bound nor the upper bound (and only in that case), this combination can +-- have potentially confusing shrinking behaviour. For example, suppose we have +-- a range @(0, 10)@ with origin 5. Then we could start by generating an +-- intermediate list of length of 10 and then subsequently /drop/ 5 elements +-- from that, resulting in an optimal list length. However, we might now shrink +-- the /length/ from 10 to 2 (which is closer to 5, after all). Now we only have +-- 2 elements to work with, and hence the generated list will now drop from 5 +-- elements to 2, even though we were already at the ideal list length. This is +-- not necessarily a problem, because that length 2 can now subsequently shrink +-- further towards closer to the origin (5), but nonetheless it might result in +-- confusing intermediate shrinking steps. +list :: Range Word -> Gen a -> Gen [a] +list len gen = do + -- We do /NOT/ mark this call to 'inRange' as 'withoutShrinking': it could + -- shrink towards larger values, in which case we really need to generate + -- more elements. This doesn't really have any downsides: it merely means + -- that we would prefer to shrink towards a prefix of the list first, before + -- we try to drop random other elements from the list. + -- + -- If we have an expression such as @(,) <$> list .. <*> list@, the two + -- lists will be shrunk independently from each other due to the branching + -- point above them. Hence, it doesn't matter if first generator uses "fewer + -- samples" as it shrinks. + n <- inRange len + + -- Generate @n@ marks, indicating for each element if we want to keep that + -- element or not, so that we can drop elements from the middle of the list. + -- + -- Due to the left-biased nature of shrinking, this will shrink towards + -- dropped elements (@False@ values) near the start, but we want them near + -- the /end/, so we reverse the list. + marks <- fmap (List.keepAtLeast (Range.origin len) . reverse) $ + replicateM (fromIntegral n) $ mark gen + + -- Finally, generate the elements we want to keep + catMaybes <$> Marked.selectAllKept marks + +-- | Choose random element +-- +-- Shrinks towards earlier elements. +-- +-- NOTE: Does not work on infinite lists (it computes the length of the list). +elem :: NonEmpty a -> Gen a +elem = fmap (\(_before, x, _after) -> x) . pick + +-- | Generalization of 'elem' that additionally returns the parts of the list +-- before and after the element +pick :: NonEmpty a -> Gen ([a], a, [a]) +pick = \xs -> + aux [] (NE.toList xs) <$> + inRange (Range.inclusive (0, length xs - 1)) + where + aux :: [a] -> [a] -> Int -> ([a], a, [a]) + aux _ [] _ = error "pick: impossible" + aux prev (x:xs) 0 = (reverse prev, x, xs) + aux prev (x:xs) i = aux (x:prev) xs (i - 1) + +-- | Choose random element from a list +-- +-- This is different from 'elem': it avoids first computing the length of the +-- list, and is biased towards elements earlier in the list. The advantage is +-- that this works for infinite lists, too. +-- +-- Also returns the elements from the list before and after the chosen element. +pickBiased :: NonEmpty a -> Gen ([a], a, [a]) +pickBiased = \xs -> pickChunk [] (List.chunksOfNonEmpty chunkSize xs) + where + chunkSize :: Word + chunkSize = 1_000 + + -- We want to avoid computing the length of the list, but equally we don't + -- want to skew /too/ heavily towards the start of the list. Therefore we + -- chunk the list (this is lazy), then flip a coin for each chunk, and once + -- we find a chunk, do an unbiased choice within that chunk. + pickChunk :: [NonEmpty a] -> NonEmpty (NonEmpty a) -> Gen ([a], a, [a]) + pickChunk prev (chunk :| []) = do + -- No choice left: we must generate use this chunk + withChunk prev chunk [] + pickChunk prev (chunk :| next@(n:ns)) = do + useChunk <- bool True + if useChunk + then withChunk prev chunk next + else pickChunk (chunk:prev) (n :| ns) + + withChunk :: [NonEmpty a] -> NonEmpty a -> [NonEmpty a] -> Gen ([a], a, [a]) + withChunk prev chunk next = do + (chunkBefore, chunkElem, chunkAfter) <- pick chunk + return ( + concat $ reverse $ chunkBefore : map NE.toList prev + , chunkElem + , chunkAfter ++ concatMap NE.toList next + ) + +{------------------------------------------------------------------------------- + Tweak test data distribution +-------------------------------------------------------------------------------} + +-- | Choose generator with the given frequency +-- +-- For example, +-- +-- > frequency [ +-- > (1, genA) +-- > , (2, genB) +-- > ] +-- +-- will use @genA@ 1/3rd of the time, and @genB@ 2/3rds. +-- +-- Shrinks towards generators earlier in the list; the generators themselves +-- are independent from each other (shrinking of @genB@ does not affect +-- shrinking of @genA@). +-- +-- Precondition: there should at least one generator with non-zero frequency. +frequency :: forall a. [(Word, Gen a)] -> Gen a +frequency gens = + case filter ((/= 0) . fst) indexedGens of + [] -> error "frequency: no generators with non-zero frequency" + gens' -> do + let r :: Range Word + r = Range.inclusive (0, sum (map fst gens') - 1) + (gen, genIx) <- (\i -> frequencyLookup i gens') <$> inRange r + perturb genIx gen + where + -- We need to be careful: we don't want to perturb the generator by the + -- value generated by 'inRange', because many different values could + -- correspond to the /same/ generator. Instead, we assign each generator its + -- own index, and use that instead. + indexedGens :: [(Word, (Gen a, Word))] + indexedGens = zipWith (\(f, g) i -> (f, (g, i))) gens [0..] + +-- | Internal auxiliary to 'frequency' +frequencyLookup :: Word -> [(Word, x)] -> x +frequencyLookup = \i xs -> + case go i xs of + Just x -> x + Nothing -> + error $ concat [ + "frequencyLookup: index " + , show i + , " out of range of " + , show (map fst xs) + ] + where + go :: Word -> [(Word, x)] -> Maybe x + go _ [] = Nothing + go i ((n, x):xs) + | i < n = Just x + | otherwise = go (i - n) xs + +{------------------------------------------------------------------------------- + Shuffling +-------------------------------------------------------------------------------} + +-- | Shuffle list (construct a permutation) +-- +-- Shrinking behaviour: 'shuffle' is defined in terms of 'permutation', which +-- provides some guarantees: it shrinks towards making changes near the /start/ +-- of the list, and towards swapping /fewer/ elements of the list. +-- +-- It is difficult to define precisely how this affects the resulting list, but +-- we /can/ say that if for a particular counter-example it suffices if two +-- lists are different in /one/ element, then the shuffled list will in fact +-- only be different in /one/ place from the original, and that one element will +-- have been swapped with an immediate neighbour. +shuffle :: [a] -> Gen [a] +shuffle xs = + flip Permutation.apply xs <$> + permutation (fromIntegral $ length xs) + +-- | Generate permutation for a list of length @n@ +-- +-- This is essentially an implemention of Fisher-Yates, in that we generate a +-- series of swaps (i, j), with 1 <= i <= n - 1 and @0 <= j <= i@, except that +-- +-- * We can shrink a choice of @i@ (towards 1). +-- * We can drop arbitrary swaps. +-- +-- This ensures that we shrink towards making swaps nearer the /start/ of the +-- list, as well as towards /fewer/ swaps. +-- +-- We make no attempt to make the permutation canonical; doing so makes it +-- extremely difficult to get predicable shrinking behaviour. +permutation :: Word -> Gen Permutation +permutation 0 = return Permutation.identity +permutation 1 = return Permutation.identity +permutation n = do + swaps <- mapM (mark . genSwap) [n - 1, n - 2 .. 1] + Permutation.fromSwaps . catMaybes <$> Marked.selectAllKept swaps + where + genSwap :: Word -> Gen (Word, Word) + genSwap i = do + i' <- inRange $ Range.inclusive (1, i) + j <- inRange $ Range.inclusive (i, 0) + return (i', min i' j) + +{------------------------------------------------------------------------------- + Binary trees +-------------------------------------------------------------------------------} + +-- | Generate binary tree +tree :: forall a. Range Word -> Gen a -> Gen (Tree a) +tree size gen = do + n <- inRange size + t <- MarkedTree.keepAtLeast (Range.origin size) . MarkedTree.propagate <$> + go n + MarkedTree.apply t + where + go :: Word -> Gen (Tree (Marked Gen a)) + go 0 = return Leaf + go n = do + -- Generate element at the root + x <- mark gen + + -- Choose how many elements to put in the left subtree + -- + -- This ranges from none (right-biased) to all (left-biased), shrinking + -- towards half the number of elements: hence, towards a balanced tree. + inLeft <- inRange $ Range.withOrigin (0, n - 1) ((n - 1) `div` 2) + let inRight = (n - 1) - inLeft + Branch x <$> go inLeft <*> go inRight + +-- | Construct binary search tree +-- +-- Shrinks by replacing entire subtrees by the empty tree. +bst :: forall a b. + Integral a + => (a -> Gen b) -- ^ Generate value given a key + -> (a, a) -- ^ Inclusive range for the keys in the tree + -> Gen (Tree (a, b)) +bst gen = go >=> traverse (\a -> (a,) <$> gen a) + where + go :: (a, a) -> Gen (Tree a) + go (lo, hi) + | lo == hi = pure $ Branch lo Leaf Leaf + | lo > hi = pure Leaf + | otherwise = firstThen id (const Leaf) <*> go' lo hi + + -- inclusive bounds, lo <= hi + go' :: a -> a -> Gen (Tree a) + go' lo hi = + Branch mid + <$> go (lo, pred mid) + <*> go (succ mid, hi) + where + -- Go through 'Integer' to avoid overflow + mid' :: Integer + mid' = fromIntegral lo + ((fromIntegral hi - fromIntegral lo) `div` 2) + + mid :: a + mid = fromInteger mid' + +{------------------------------------------------------------------------------- + Shrink trees +-------------------------------------------------------------------------------} + +-- | Generate semi-random path through the tree +-- +-- Will only construct paths that satisfy the given predicate (typically, a +-- property that is being tested). +-- +-- Shrinks towards shorter paths, and towards paths that use subtrees that +-- appear earlier in the list of subtrees at any node in the tree. +-- +-- See also 'pathAny'. +path :: forall a p n. + (a -> Either n p) -- ^ Predicate + -> ShrinkTree a + -> Gen (Either n (NonEmpty p)) +path validShrink = \(WrapShrinkTree (Rose.Node a as)) -> + case validShrink a of + Left n -> pure $ Left n + Right p -> Right <$> go p as + where + -- We only want to pick a shrunk value that matches the predicate, but we + -- potentially waste a /lot/ of work if we first evaluate the predicate for + -- /all/ potential shrunk values and then choose. So, instead we choose + -- first, evaluate the predicate, and if it fails, choose again. + go :: p -> [Rose.Tree a] -> Gen (NonEmpty p) + go p [] = pure (p :| []) + go p (a:as) = do + (before, a', after) <- pickBiased (a :| as) + + case checkPred a' of + Nothing -> + -- Not a valid shrink step. Pick a different one. + go p (before ++ after) + Just (p', as') -> + -- Found a valid shrink step. + -- + -- We only call @choose@ once we found a valid shrink step, + -- otherwise we would skew very heavily towards shorter paths. + choose + (pure (p :| [])) + (NE.cons p <$> go p' as') + + checkPred :: Rose.Tree a -> Maybe (p, [Rose.Tree a]) + checkPred (Rose.Node a as) = + case validShrink a of + Left _ -> Nothing + Right b -> Just (b, as) + +-- | Variation on 'path' without a predicate. +pathAny :: ShrinkTree a -> Gen (NonEmpty a) +pathAny = fmap (either absurd id) . path Right diff --git a/src/Test/Falsify/Internal/Generator/Definition.hs b/src/Test/Falsify/Internal/Generator/Definition.hs deleted file mode 100644 --- a/src/Test/Falsify/Internal/Generator/Definition.hs +++ /dev/null @@ -1,230 +0,0 @@ -module Test.Falsify.Internal.Generator.Definition ( - -- * Definition - Gen(..) - , bindWithoutShortcut - -- * Primitive generators - , prim - , primWith - , exhaustive - , captureLocalTree - -- * Generator independence - , bindIntegral - , perturb - -- * Combinators - , withoutShrinking - ) where - -import Control.Monad -import Control.Selective -import Data.List.NonEmpty (NonEmpty((:|))) -import Data.Word -import Optics.Core (Lens', (%)) - -import qualified Optics.Core as Optics - -import Data.Falsify.Integer (Bit(..), encIntegerEliasG) -import Test.Falsify.Internal.SampleTree (SampleTree(..), Sample (..), pattern Inf) -import Test.Falsify.Internal.Search - -import qualified Test.Falsify.Internal.SampleTree as SampleTree - -{------------------------------------------------------------------------------- - Definition --------------------------------------------------------------------------------} - --- | Generator of a random value --- --- Generators can be combined through their 'Functor', 'Applicative' and 'Monad' --- interfaces. The primitive generator is 'prim', but most users will probably --- want to construct their generators using the predefined from --- "Test.Falsify.Generator" as building blocks. --- --- Generators support \"internal integrated shrinking\". Shrinking is --- /integrated/ in the sense of Hedgehog, meaning that we don't write a separate --- shrinker at all, but the shrink behaviour is implied by the generator. For --- example, if you have a generator @genList@ for a list of numbers, then --- --- > filter even <$> genList --- --- will only generate even numbers, and that property is automatically preserved --- during shrinking. Shrinking is /internal/ in the sense of Hypothesis, meaning --- that unlike in Hedgehog, shrinking works correctly even in the context of --- monadic bind. For example, if you do --- --- > do n <- genListLength --- > replicateM n someOtherGen --- --- then we can shrink @n@ and the results from @someOtherGen@ in any order (that --- said, users may prefer to use the dedicated --- 'Test.Falsify.Generator.Compound.list' generator for this purpose, which --- improves on this in a few ways). --- --- NOTE: 'Gen' is /NOT/ an instance of 'Alternative'; this would not be --- compatible with the generation of infinite data structures. For the same --- reason, we do not have a monad transformer version of Gen either. -newtype Gen a = Gen { runGen :: SampleTree -> (a, [SampleTree]) } - deriving stock (Functor) - -instance Applicative Gen where - pure x = Gen $ \_st -> (x, []) - (<*>) = ap - -instance Monad Gen where - return = pure - x >>= f = Gen $ \(Inf s l r) -> - let (a, ls) = runGen x l - (b, rs) = runGen (f a) r - in (b, combineShrunk s (l :| ls) (r :| rs)) - -instance Selective Gen where - select e f = Gen $ \(Inf s l r) -> do - let (ma, ls) = runGen e l - case ma of - Left a -> - let (f', rs) = runGen f r - in (f' a, combineShrunk s (l :| ls) (r :| rs)) - Right b -> - (b, combineShrunk s (l :| ls) (r :| [])) - --- | Combine shrunk left and right sample trees --- --- This is an internal function only. -combineShrunk :: - Sample - -> NonEmpty SampleTree -- ^ Original and shrunk left trees - -> NonEmpty SampleTree -- ^ Original and shrunk right trees - -> [SampleTree] -combineShrunk s (l :| ls) (r :| rs) = shortcut $ concat [ - [SampleTree s l' r | l' <- unlessMinimal l ls] - , [SampleTree s l r' | r' <- unlessMinimal r rs] - ] - where - -- We must be careful not to force @ls@/@rs@ if the tree is already minimal. - unlessMinimal :: SampleTree -> [a] -> [a] - unlessMinimal Minimal _ = [] - unlessMinimal _ xs = xs - - shortcut :: [SampleTree] -> [SampleTree] - shortcut [] = [] - shortcut ts = Minimal : ts - --- | Varation on @(>>=)@ that doesn't apply the shortcut to 'Minimal' --- --- This function is primarily useful for debugging @falsify@ itself; users --- will probably never need it. -bindWithoutShortcut :: Gen a -> (a -> Gen b) -> Gen b -bindWithoutShortcut x f = Gen $ \(Inf s l r) -> - let (a, ls) = runGen x l - (b, rs) = runGen (f a) r - in (b, combine s (l :| ls) (r :| rs)) - where - -- Variation on 'combineShrunk' that doesn't apply the shortcut - combine :: - Sample - -> NonEmpty SampleTree -- ^ Original and shrunk left trees - -> NonEmpty SampleTree -- ^ Original and shrunk right trees - -> [SampleTree] - combine s (l :| ls) (r :| rs) = concat [ - [SampleTree s l' r | l' <- ls] - , [SampleTree s l r' | r' <- rs] - ] - -{------------------------------------------------------------------------------- - Generator independence --------------------------------------------------------------------------------} - --- | Selective bind --- --- Unlike monadic bind, the RHS is generated and shrunk completely independently --- for each different value of @a@ produced by the LHS. --- --- This is a generalization of 'bindS' to arbitrary integral values; it is also --- much more efficient than 'bindS'. --- --- NOTE: This is only one way to make a generator independent. See 'perturb' --- for more primitive combinator. -bindIntegral :: Integral a => Gen a -> (a -> Gen b) -> Gen b -bindIntegral x f = x >>= \a -> perturb a (f a) - --- | Run generator on different part of the sample tree depending on @a@ -perturb :: Integral a => a -> Gen b -> Gen b -perturb a g = Gen $ \st -> - let (b, shrunk) = runGen g (Optics.view lens st) - in (b, map (\st' -> Optics.set lens st' st) shrunk) - where - lens :: Lens' SampleTree SampleTree - lens = computeLens (encIntegerEliasG $ fromIntegral a) - - computeLens :: [Bit] -> Lens' SampleTree SampleTree - computeLens [] = Optics.castOptic Optics.simple - computeLens (O : bs) = SampleTree.left % computeLens bs - computeLens (I : bs) = SampleTree.right % computeLens bs - -{------------------------------------------------------------------------------- - Primitive generators --------------------------------------------------------------------------------} - --- | Uniform selection of 'Word64', shrinking towards 0, using binary search --- --- This is a primitive generator; most users will probably not want to use this --- generator directly. -prim :: Gen Word64 -prim = - SampleTree.sampleValue <$> - primWith (binarySearch . SampleTree.sampleValue) - --- | Generalization of 'prim' that allows to override the shrink behaviour --- --- This is only required in rare circumstances. Most users will probably never --- need to use this generator. -primWith :: (Sample -> [Word64]) -> Gen Sample -primWith f = Gen $ \(Inf s l r) -> ( - s - , (\s' -> SampleTree (Shrunk s') l r) <$> f s - ) - --- | Generate arbitrary value @x <= n@ --- --- Unlike 'prim', 'exhaustive' does not execute binary search. Instead, /all/ --- smaller values are considered. This is potentially very expensive; the --- primary use case for this generator is testing shrinking behaviour, where --- binary search can lead to some unpredicatable results. --- --- This does /NOT/ do uniform selection: for small @n@, the generator will with --- overwhelming probability produce @n@ itself as initial value. --- --- This is a primitive generator; most users will probably not want to use this --- generator directly. -exhaustive :: Word64 -> Gen Word64 -exhaustive n = - min n . SampleTree.sampleValue <$> - primWith (completeSearch . SampleTree.sampleValue) - where - completeSearch :: Word64 -> [Word64] - completeSearch 0 = [] - completeSearch x = takeWhile (<= n) [0 .. pred x] - --- | Capture the local sample tree --- --- This generator does not shrink. -captureLocalTree :: Gen SampleTree -captureLocalTree = Gen $ \st -> (st, []) - -{------------------------------------------------------------------------------- - Shrinking combinators --------------------------------------------------------------------------------} - --- | Disable shrinking in the given generator --- --- Due to the nature of internal shrinking, it is always possible that a --- generator gets reapplied to samples that were shrunk wrt to a /different/ --- generator. In this sense, 'withoutShrinking' should be considered to be a --- hint only. --- --- This function is only occassionally necessary; most users will probably not --- need to use it. -withoutShrinking :: Gen a -> Gen a -withoutShrinking (Gen g) = Gen $ aux . g - where - aux :: (a, [SampleTree]) -> (a, [SampleTree]) - aux (outcome, _) = (outcome, []) diff --git a/src/Test/Falsify/Internal/Generator/Function.hs b/src/Test/Falsify/Internal/Generator/Function.hs new file mode 100644 --- /dev/null +++ b/src/Test/Falsify/Internal/Generator/Function.hs @@ -0,0 +1,266 @@ +module Test.Falsify.Internal.Generator.Function ( + fun + , Function(..) + , GFunction -- opaque + ) where + +import Prelude hiding (sum) + +import Data.Char +import Data.Int +import Data.Maybe (fromMaybe) +import Data.Ratio (Ratio) +import Data.Void (Void) +import Data.Word +import GHC.Generics +import Numeric.Natural + +import qualified Data.Ratio as Ratio + +import Data.Falsify.ConcreteFun ((:->)(..)) +import Test.Falsify.Internal.Fun +import Test.Falsify.Internal.Generator (Gen) +import Test.Falsify.Internal.Generator.Compound +import Test.Falsify.Internal.Generator.Shrinking + +import qualified Data.Falsify.ConcreteFun as ConcreteFun + +{------------------------------------------------------------------------------- + Functions that can be shrunk and shown +-------------------------------------------------------------------------------} + +-- | Generate function @a -> b@ given a generator for @b@ +fun :: Function a => Gen b -> Gen (Fun a b) +fun gen = do + -- Generate value first, so that we try to shrink that first + defaultValue <- gen + concrete <- function gen + isFullyShrunk <- firstThen False True + return Fun{concrete, defaultValue, isFullyShrunk} + +{------------------------------------------------------------------------------- + Constructing concrete functions +-------------------------------------------------------------------------------} + +shrinkToNil :: Gen (a :-> b) -> Gen (a :-> b) +shrinkToNil gen = fromMaybe Nil <$> shrinkToNothing gen + +table :: forall a b. (Integral a, Bounded a) => Gen b -> Gen (a :-> b) +table gen = Table <$> bst (\_a -> shrinkToNothing gen) (minBound, maxBound) + +unit :: Gen c -> Gen (() :-> c) +unit gen = shrinkToNil (Unit <$> gen) + +sum :: + (Gen c -> Gen ( a :-> c)) + -> (Gen c -> Gen ( b :-> c)) + -> (Gen c -> Gen (Either a b :-> c)) +sum f g gen = Sum <$> shrinkToNil (f gen) <*> shrinkToNil (g gen) + +prod :: + (forall c. Gen c -> Gen ( a :-> c)) + -> (forall c. Gen c -> Gen ( b :-> c)) + -> (forall c. Gen c -> Gen ((a, b) :-> c)) +prod f g = fmap Prod . f . g + +{------------------------------------------------------------------------------- + Class to construct functions +-------------------------------------------------------------------------------} + +-- | Generating functions +class Function a where + -- | Build reified function + -- + -- If you need to add additional 'Function' instances, you will typically + -- define them using 'Data.Falsify.Concrete.map', or rely on the default + -- implementation in terms of generics. + function :: Gen b -> Gen (a :-> b) + + default function :: (Generic a, GFunction (Rep a)) => Gen b -> Gen (a :-> b) + function gen = ConcreteFun.map from to <$> gFunction gen + +instance Function Word8 where function = table +instance Function Int8 where function = table + +instance Function Int where function = integral +instance Function Int16 where function = integral +instance Function Int32 where function = integral +instance Function Int64 where function = integral +instance Function Word where function = integral +instance Function Word16 where function = integral +instance Function Word32 where function = integral +instance Function Word64 where function = integral +instance Function Integer where function = integral +instance Function Natural where function = integral + +instance Function Float where function = realFrac +instance Function Double where function = realFrac + +instance (Integral a, Function a) => Function (Ratio a) where + function = fmap (ConcreteFun.map toPair fromPair) . function + where + toPair :: Ratio a -> (a, a) + toPair r = (Ratio.numerator r, Ratio.denominator r) + + fromPair :: (a, a) -> Ratio a + fromPair (n, d) = n Ratio.% d + +instance Function Char where + function = fmap (ConcreteFun.map ord chr) . function + +-- instances that depend on generics + +instance Function () +instance Function Bool +instance Function Void + +instance (Function a, Function b) => Function (Either a b) + +instance Function a => Function [a] +instance Function a => Function (Maybe a) + +-- Tuples (these are also using generics) + +-- 2 +instance + ( Function a + , Function b + ) + => Function (a, b) + +-- 3 +instance + ( Function a + , Function b + , Function c + ) + => Function (a, b, c) + +-- 4 +instance + ( Function a + , Function b + , Function c + , Function d + ) + => Function (a, b, c, d) + +-- 5 +instance + ( Function a + , Function b + , Function c + , Function d + , Function e + ) + => Function (a, b, c, d, e) + +-- 6 +instance + ( Function a + , Function b + , Function c + , Function d + , Function e + , Function f + ) + => Function (a, b, c, d, e, f) + +-- 7 +instance + ( Function a + , Function b + , Function c + , Function d + , Function e + , Function f + , Function g + ) + => Function (a, b, c, d, e, f, g) + +{------------------------------------------------------------------------------- + Support for numbers +-------------------------------------------------------------------------------} + +integral :: Integral a => Gen b -> Gen (a :-> b) +integral = + fmap (ConcreteFun.map + (fmap bytes . toSignedNatural . toInteger) + (fromInteger . fromSignedNatural . fmap unbytes) + ) + . function + where + bytes :: Natural -> [Word8] + bytes 0 = [] + bytes n = fromIntegral (n `mod` 256) : bytes (n `div` 256) + + unbytes :: [Word8] -> Natural + unbytes [] = 0 + unbytes (w:ws) = fromIntegral w + 256 * unbytes ws + +realFrac :: RealFrac a => Gen b -> Gen (a :-> b) +realFrac = fmap (ConcreteFun.map toRational fromRational) . function + +data Signed a = Pos a | Neg a + deriving stock (Show, Functor, Generic) + deriving anyclass (Function) + +toSignedNatural :: Integer -> Signed Natural +toSignedNatural n + | n < 0 = Neg (fromInteger (abs n - 1)) + | otherwise = Pos (fromInteger n) + +fromSignedNatural :: Signed Natural -> Integer +fromSignedNatural (Neg n) = negate (toInteger n + 1) +fromSignedNatural (Pos n) = toInteger n + +{------------------------------------------------------------------------------- + Generic support for 'Function' +-------------------------------------------------------------------------------} + +-- | Generic construction of concrete functions +-- +-- See 'Function' for discussion. +class GFunction f where + {-# MINIMAL #-} + gFunction :: Gen b -> Gen (f p :-> b) + gFunction = error "gFunction not implemented" + +instance GFunction f => GFunction (M1 i c f) where + gFunction = fmap (ConcreteFun.map unM1 M1) . gFunction @f + +instance GFunction V1 where + gFunction _ = pure Nil + +instance GFunction U1 where + gFunction = fmap (ConcreteFun.map unwrap wrap) . unit + where + unwrap :: U1 p -> () + unwrap _ = () + + wrap :: () -> U1 p + wrap _ = U1 + +instance (GFunction f, GFunction g) => GFunction (f :*: g) where + gFunction = fmap (ConcreteFun.map unwrap wrap) . prod (gFunction @f) (gFunction @g) + where + unwrap :: (f :*: g) p -> (f p, g p) + unwrap (x :*: y) = (x, y) + + wrap :: (f p, g p) -> (f :*: g) p + wrap (x, y) = x :*: y + +instance (GFunction f, GFunction g) => GFunction (f :+: g) where + gFunction = + fmap (ConcreteFun.map unwrap wrap) . sum (gFunction @f) (gFunction @g) + where + unwrap :: (f :+: g) p -> Either (f p) (g p) + unwrap (L1 x) = Left x + unwrap (R1 y) = Right y + + wrap :: Either (f p) (g p) -> (f :+: g) p + wrap (Left x) = L1 x + wrap (Right y) = R1 y + +instance Function a => GFunction (K1 i a) where + gFunction = fmap (ConcreteFun.map unK1 K1) . function @a diff --git a/src/Test/Falsify/Internal/Generator/Precision.hs b/src/Test/Falsify/Internal/Generator/Precision.hs new file mode 100644 --- /dev/null +++ b/src/Test/Falsify/Internal/Generator/Precision.hs @@ -0,0 +1,38 @@ +-- | Fixed precision generators +module Test.Falsify.Internal.Generator.Precision ( + wordN + , properFraction + ) where + +import Prelude hiding (properFraction) + +import GHC.Stack + +import Data.Falsify.ProperFraction (ProperFraction) +import Data.Falsify.WordN (WordN) +import Test.Falsify.Internal.Generator +import Test.Falsify.Internal.Search + +import qualified Data.Falsify.WordN as WordN +import qualified Test.Falsify.SampleTree as SampleTree + +{------------------------------------------------------------------------------- + Generation +-------------------------------------------------------------------------------} + +-- | Uniform selection of @n@-bit word of given precision, shrinking towards 0 +wordN :: WordN.Precision -> Gen WordN +wordN p = + fmap (WordN.truncateAt p . SampleTree.sampleValue) . primWith $ + binarySearch + . WordN.forgetPrecision + . WordN.truncateAt p + . SampleTree.sampleValue + +-- | Uniform selection of fraction, shrinking towards 0 +-- +-- Precondition: precision must be at least 1 bit (a zero-bit number is constant +-- 0; it is meaningless to have a fraction in a point range). +properFraction :: HasCallStack => WordN.Precision -> Gen ProperFraction +properFraction (WordN.Precision 0) = error "fraction: 0 precision" +properFraction p = WordN.toProperFraction <$> wordN p diff --git a/src/Test/Falsify/Internal/Generator/Shrinking.hs b/src/Test/Falsify/Internal/Generator/Shrinking.hs --- a/src/Test/Falsify/Internal/Generator/Shrinking.hs +++ b/src/Test/Falsify/Internal/Generator/Shrinking.hs @@ -1,169 +1,167 @@ module Test.Falsify.Internal.Generator.Shrinking ( - -- * Shrinking - shrinkFrom - -- * With full history - , ShrinkExplanation(..) - , ShrinkHistory(..) - , IsValidShrink(..) - , limitShrinkSteps - , shrinkHistory - , shrinkOutcome + -- * User-specified shrinking + shrinkToOneOf + , firstThen + , shrinkWith + -- * Support for shrink trees + , fromShrinkTree + , toShrinkTree + , toShrinkTreeWithContext ) where -import Data.Bifunctor -import Data.Either -import Data.List.NonEmpty (NonEmpty((:|))) +import Prelude hiding (properFraction) -import Test.Falsify.Internal.Generator.Definition -import Test.Falsify.Internal.SampleTree (SampleTree(..)) +import Data.Word +import qualified Data.Tree as Rose + +import Test.Falsify.Internal.Generator +import Test.Falsify.SampleTree (SampleTree(..), Sample(..)) +import Test.Falsify.ShrinkTree (ShrinkTree(..)) + +import qualified Test.Falsify.Context as Context +import qualified Test.Falsify.ShrinkTree as ShrinkTree + {------------------------------------------------------------------------------- - Explanation + Specialized shrinking behaviour -------------------------------------------------------------------------------} --- | Shrink explanation +-- | Start with @x@, then shrink to one of the @xs@ -- --- @p@ is the type of \"positive\" elements that satisfied the predicate (i.e., --- valid shrinks), and @n@ is the type of \"negative\" which didn't. -data ShrinkExplanation p n = ShrinkExplanation { - -- | The value we started, before shrinking - initial :: p - - -- | The full shrink history - , history :: ShrinkHistory p n - } - deriving (Show) - --- | Shrink explanation -data ShrinkHistory p n = - -- | We successfully executed a single shrink step - ShrunkTo p (ShrinkHistory p n) +-- Once shrunk, will not shrink again. +-- +-- Minimal value is the first shrunk value, if it exists, and the original +-- otherwise. +shrinkToOneOf :: forall a. a -> [a] -> Gen a +shrinkToOneOf x xs = + aux <$> primWith shrinker + where + aux :: Sample -> a + aux (NotShrunk _) = x + aux (Shrunk i) = index i xs - -- | We could no shrink any further + -- When we shrink, we will try a bunch of new sample trees; we must ensure + -- that we can try /any/ of the possible shrunk values. -- - -- We also record all rejected next steps. This is occasionally useful when - -- trying to figure out why a value didn't shrink any further (what did it - -- try to shrink to?) - | ShrinkingDone [n] + -- We use this to implement 'fromShrinkTree'. Here, we explore a rose tree + -- of possibilities; at every level in the tree, once we make a choice, + -- we should commit to that choice and not consider it over and over again. + -- Thus, once shrunk, we should not shrink any further. + shrinker :: Sample -> [Word64] + shrinker (Shrunk _) = [] + shrinker (NotShrunk _) = zipWith const [0..] xs - -- | We stopped shrinking early + -- Index the list of possible shrunk values. This is a bit like @(!!)@ from + -- the prelude, but with some edge cases. -- - -- This is used when the number of shrink steps is limited. - | ShrinkingStopped - deriving (Show) - -limitShrinkSteps :: Maybe Word -> ShrinkExplanation p n -> ShrinkExplanation p n -limitShrinkSteps Nothing = id -limitShrinkSteps (Just limit) = \case - ShrinkExplanation{initial, history} -> - ShrinkExplanation{ - initial - , history = go limit history - } - where - go :: Word -> ShrinkHistory p n -> ShrinkHistory p n - go 0 (ShrunkTo _ _) = ShrinkingStopped - go n (ShrunkTo x xs) = ShrunkTo x (go (pred n) xs) - go _ (ShrinkingDone rej) = ShrinkingDone rej - go _ ShrinkingStopped = ShrinkingStopped + -- - If the list is empty, we return the unshrunk value. + -- - Otherwise, if the index exceeds the bounds, we return the last element. + -- + -- These two special cases can arise in one of two circumstances: + -- + -- - When we run the generator against the 'Minimal' tree. This will give us + -- a @Shrunk 0@ value, independent of what the specified shrinking + -- function does, and it is important that we produce the right value. + -- - When the generator is run against a sample tree that was shrunk wrt to + -- a /different/ generator. In this case the value could be anything; + -- we return the final ("least preferred") element, and then rely on + -- later shrinking to replace this with a more preferred element. + index :: Word64 -> [a] -> a + index _ [] = x + index _ [y] = y + index 0 (y:_) = y + index n (_:ys) = index (n - 1) ys --- | Simplify the shrink explanation to keep only the shrink history -shrinkHistory :: ShrinkExplanation p n -> NonEmpty p -shrinkHistory = \(ShrinkExplanation unshrunk shrunk) -> - unshrunk :| go shrunk - where - go :: ShrinkHistory p n -> [p] - go (ShrunkTo x xs) = x : go xs - go (ShrinkingDone _) = [] - go ShrinkingStopped = [] +-- | Generator that always produces @x@ as initial value, and shrinks to @y@ +firstThen :: forall a. a -> a -> Gen a +firstThen x y = x `shrinkToOneOf` [y] --- | The final shrunk value, as well as all rejected /next/ shrunk steps +-- | Shrink with provided shrinker -- --- The list of rejected next steps is +-- This provides compatibility with QuickCheck-style manual shrinking. -- --- * @Nothing@ if shrinking was terminated early ('limitShrinkSteps') --- * @Just []@ if the final value truly is minimal (typically, it is only --- minimal wrt to a particular properly, but not the minimal value that a --- generator can produce). -shrinkOutcome :: forall p n. ShrinkExplanation p n -> (p, Maybe [n]) -shrinkOutcome = \ShrinkExplanation{initial, history} -> - go initial history - where - go :: p -> ShrinkHistory p n -> (p, Maybe [n]) - go _ (ShrunkTo p h) = go p h - go p (ShrinkingDone ns) = (p, Just ns) - go p ShrinkingStopped = (p, Nothing) - -{------------------------------------------------------------------------------- - Mapping --------------------------------------------------------------------------------} - -instance Functor (ShrinkExplanation p) where - fmap = second - -instance Functor (ShrinkHistory p) where - fmap = second - -instance Bifunctor ShrinkExplanation where - bimap f g ShrinkExplanation{initial, history} = ShrinkExplanation{ - initial = f initial - , history = bimap f g history - } - -instance Bifunctor ShrinkHistory where - bimap f g = \case - ShrunkTo truncated history -> - ShrunkTo (f truncated) (bimap f g history) - ShrinkingDone rejected -> - ShrinkingDone (map g rejected) - ShrinkingStopped -> - ShrinkingStopped +-- Defined in terms of 'fromShrinkTree'; see discussion there for some +-- notes on performance. +shrinkWith :: forall a. (a -> [a]) -> Gen a -> Gen a +shrinkWith f gen = do + -- It is critical that we do not apply normal shrinking of the 'SampleTree' + -- here (not even to 'Minimal'). If we did, then the resulting shrink tree + -- would change, and we would be unable to iteratively construct a path + -- through the shrink tree. + -- + -- Of course, it can still happen that the generator gets reapplied in a + -- different context; we must take this case into account in + -- 'shrinkToOneOf'. + x <- withoutShrinking gen + fromShrinkTree $ ShrinkTree.unfold x f {------------------------------------------------------------------------------- - Shrinking + Shrink trees -------------------------------------------------------------------------------} --- | Does a given shrunk value represent a valid shrink step? -data IsValidShrink p n = - ValidShrink p - | InvalidShrink n - deriving stock (Show) - --- | Find smallest value that the generator can produce and still satisfies --- the predicate. +-- | Construct generator from shrink tree -- --- Returns the full shrink history. +-- This provides compatibility with Hedgehog-style integrated shrinking. -- --- To avoid boolean blindness, we use different types for values that satisfy --- the property and values that do not. +-- This is O(n^2) in the number of shrink steps: as this shrinks, the generator +-- is growing a path of indices which locates a particular value in the shrink +-- tree (resulting from unfolding the provided shrinking function). At each +-- step during the shrinking process the shrink tree is re-evaluated and the +-- next value in the tree is located; since this path throws linearly, the +-- overall cost is O(n^2). -- --- This is lazy in the shrink history; see 'limitShrinkSteps' to limit the --- number of shrinking steps. -shrinkFrom :: forall a p n. - (a -> IsValidShrink p n) - -> Gen a - -> (p, [SampleTree]) -- ^ Initial result of the generator - -> ShrinkExplanation p n -shrinkFrom prop gen = \(p, shrunk) -> - ShrinkExplanation p $ go shrunk +-- The O(n^2) cost is only incurred on /locating/ the next element to be tested; +-- the property is not reevaluated at already-shrunk values. +fromShrinkTree :: forall a. ShrinkTree a -> Gen a +fromShrinkTree = go . unwrapShrinkTree where - go :: [SampleTree] -> ShrinkHistory p n - go shrunk = - -- Shrinking is a greedy algorithm: we go with the first candidate that - -- works, and discard the others. - -- - -- NOTE: 'partitionEithers' is lazy enough: - -- - -- > head . fst $ partitionEithers [Left True, undefined] == True - case partitionEithers candidates of - ([], rejected) -> ShrinkingDone rejected - ((p, shrunk'):_, _) -> ShrunkTo p $ go shrunk' - where - candidates :: [Either (p, [SampleTree]) n] - candidates = map consider $ map (runGen gen) shrunk + go :: Rose.Tree a -> Gen a + go (Rose.Node x xs) = do + next <- Nothing `shrinkToOneOf` map Just xs + case next of + Nothing -> return x + Just x' -> go x' - consider :: (a, [SampleTree]) -> Either (p, [SampleTree]) n - consider (a, shrunk) = - case prop a of - ValidShrink p -> Left (p, shrunk) - InvalidShrink n -> Right n +-- | Expose the full shrink tree of a generator +-- +-- The generator is passed 'Context.Initial' for the initial step, and then +-- 'Context.Shrinking' with the number of the shrink step after that. The +-- 'Test.Falsify.Context.Final' step is /not/ included. +-- +-- This generator does not shrink. +toShrinkTree :: forall a. Gen a -> Gen (ShrinkTree a) +toShrinkTree gen = fmap snd <$> toShrinkTreeWithContext False (const gen) + +-- | Generalization of 'toShrinkTree' +toShrinkTreeWithContext :: forall a. + Bool -- ^ Include 'Context.Final' step? + -> (Context.Execution -> Gen a) + -> Gen (ShrinkTree (Context.Execution, a)) +toShrinkTreeWithContext includeFinal gen = do + initSeed <- Seed Context.Initial <$> captureLocalTree + return $ WrapShrinkTree $ Rose.unfoldTree aux initSeed + where + aux :: Seed -> ((Context.Execution, a), [Seed]) + aux seed@Seed{seedContext, seedSampleTree} = + case runGen (gen seedContext) seedSampleTree of + (a, shrunk) -> ((seedContext, a), nextSeed seed shrunk) + + nextSeed :: Seed -> [SampleTree] -> [Seed] + nextSeed Seed{seedContext, seedSampleTree} shrunk = + case seedContext of + Context.Initial -> + case shrunk of + [] | includeFinal -> [Seed (Context.Final 0) seedSampleTree] + _ -> map (Seed $ Context.Shrinking 0) shrunk + Context.Shrinking i -> + case shrunk of + [] | includeFinal -> [Seed (Context.Final $ succ i) seedSampleTree] + _ -> map (Seed $ Context.Shrinking $ succ i) shrunk + Context.Final _ -> + [] + +-- | Internal: 'Rose.unfoldTree' seed, for constructing the shrink tree +data Seed = Seed{ + seedContext :: Context.Execution + , seedSampleTree :: SampleTree + } diff --git a/src/Test/Falsify/Internal/Generator/Simple.hs b/src/Test/Falsify/Internal/Generator/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Test/Falsify/Internal/Generator/Simple.hs @@ -0,0 +1,52 @@ +-- | Simple (i.e., non-compound) generators +module Test.Falsify.Internal.Generator.Simple ( + bool + , inRange + , int + ) where + +import Prelude hiding (properFraction) + +import Data.Bits +import Data.Word + +import Test.Falsify.Internal.Generator +import Test.Falsify.Internal.Generator.Precision +import Test.Falsify.Internal.Range +import Test.Falsify.SampleTree (Sample(..)) + +import qualified Test.Falsify.Range as Range +import qualified Test.Falsify.SampleTree as SampleTree + +{------------------------------------------------------------------------------- + Simple generators +-------------------------------------------------------------------------------} + +-- | Generate random bool, shrink towards the given value +-- +-- Chooses with equal probability between 'True' and 'False'. +bool :: Bool -> Gen Bool +bool target = aux . SampleTree.sampleValue <$> primWith shrinker + where + aux :: Word64 -> Bool + aux x | msbSet x = not target + | otherwise = target + + msbSet :: forall a. FiniteBits a => a -> Bool + msbSet x = testBit x (finiteBitSize (undefined :: a) - 1) + + shrinker :: Sample -> [Word64] + shrinker (Shrunk 0) = [] + shrinker _ = [0] + +{------------------------------------------------------------------------------- + Integral ranges +-------------------------------------------------------------------------------} + +-- | Generate value in the specified range +inRange :: Range a -> Gen a +inRange r = Range.eval wordN r + +-- | Type-specialization of 'inRange' +int :: Range Int -> Gen Int +int = inRange diff --git a/src/Test/Falsify/Internal/Marked/Tree.hs b/src/Test/Falsify/Internal/Marked/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Test/Falsify/Internal/Marked/Tree.hs @@ -0,0 +1,80 @@ +-- | Utilities for working with trees with marked elements +-- +-- Intended for qualified import. +-- +-- > import qualified Test.Falsify.Internal.Marked.Tree as MarkedTree +module Test.Falsify.Internal.Marked.Tree ( + propagate + , apply + , keepAtLeast + ) where + +import Prelude hiding (drop) + +import Control.Monad.State +import Control.Selective (Selective, ifS) + +import Data.Falsify.Tree (Tree(..)) +import Test.Falsify.Marked (Mark(..), Marked(..)) + +import qualified Test.Falsify.Marked as Marked +import qualified Data.Falsify.Tree as Tree + +{------------------------------------------------------------------------------- + Utilities for working with marked trees +-------------------------------------------------------------------------------} + +-- | Propagate 'Drop' marker down the tree +-- +-- This is useful in conjunction with 'apply', which truncates entire subtrees. +propagate :: Tree (Marked f a) -> Tree (Marked f a) +propagate = keep + where + keep :: Tree (Marked f a) -> Tree (Marked f a) + keep Leaf = Leaf + keep (Branch (Marked Keep x) l r) = Branch (Marked Keep x) (keep l) (keep r) + keep (Branch (Marked Drop x) l r) = Branch (Marked Drop x) (drop l) (drop r) + + drop :: Tree (Marked f a) -> Tree (Marked f a) + drop = fmap $ \(Marked _ x) -> Marked Drop x + +-- | Generate those values we want to keep +-- +-- Whenever we meet an element marked 'Drop', that entire subtree is dropped. +apply :: forall f a. Selective f => Tree (Marked f a) -> f (Tree a) +apply = go + where + go :: Tree (Marked f a) -> f (Tree a) + go Leaf = pure Leaf + go (Branch (Marked m g) l r) = ifS (pure $ m == Keep) + (Branch <$> g <*> go l <*> go r) + (pure Leaf) + +-- | Change enough nodes currently marked as 'Drop' to 'Keep' to ensure at +-- least @n@ nodes are marked 'Keep'. +-- +-- Precondition: any 'Drop' marks must have been propagated; see 'propagate'. +-- Postcondition: this property is preserved. +keepAtLeast :: Word -> Tree (Marked f a) -> Tree (Marked f a) +keepAtLeast = \n t -> + let kept = Marked.countKept t + in if kept >= n + then t + else evalState (go t) (n - kept) + where + go :: Tree (Marked f a) -> State Word (Tree (Marked f a)) + go Leaf = return Leaf + go (Branch (Marked Keep x) l r) = Branch (Marked Keep x) <$> go l <*> go r + go t@(Branch (Marked Drop x) l r) = get >>= \case + 0 -> + -- Nothing left to drop + return t + n | Tree.size t <= n -> do + -- We can keep the entire subtree + put $ n - Tree.size t + return $ fmap (Marked Keep . unmark) t + n -> do + -- We cannot delete the entire subtree. In order to preserve the + -- "drop property", we /must/ mark this node as 'Keep' + put $ n - 1 + Branch (Marked Keep x) <$> go l <*> go r diff --git a/src/Test/Falsify/Internal/Property.hs b/src/Test/Falsify/Internal/Property.hs --- a/src/Test/Falsify/Internal/Property.hs +++ b/src/Test/Falsify/Internal/Property.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} -- | Properties -- @@ -6,9 +6,11 @@ module Test.Falsify.Internal.Property ( -- * Property Property' -- opaque + , Property , runProperty -- * Test results , TestResult(..) + , Counterexample(..) , resultIsValidShrink -- * State , TestRun(..) @@ -17,25 +19,31 @@ -- * Running generators , gen , genWith - -- * 'Property' features + -- * 'Property'' features , testFailed , info , assert , discard , label , collect + , getContext + , sized -- * Testing shrinking , testShrinking + , testShrinkingForIteration , testMinimum + , testMinimumForIteration -- * Testing generators , testGen , testGen' , testShrinkingOfGen + , testShrinkingOfGenForIteration ) where import Prelude hiding (log) import Control.Monad +import Control.Monad.Reader import Control.Monad.State import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty) @@ -47,23 +55,22 @@ import qualified Data.Map as Map import qualified Data.Set as Set -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail (MonadFail(..)) -#endif - -import Test.Falsify.Generator (Gen) -import Test.Falsify.Internal.Generator.Shrinking +import Data.Falsify.ProperFraction (ProperFraction(..)) +import Test.Falsify.Context (Context(Context)) +import Test.Falsify.Internal.Generator +import Test.Falsify.Internal.Shrinking import Test.Falsify.Predicate (Predicate, (.$)) -import qualified Test.Falsify.Generator as Gen -import qualified Test.Falsify.Internal.Generator as Gen -import qualified Test.Falsify.Predicate as P +import qualified Test.Falsify.Context as Context +import qualified Test.Falsify.Generator as Gen +import qualified Test.Falsify.Predicate as P {------------------------------------------------------------------------------- Information about a test run -------------------------------------------------------------------------------} data TestRun = TestRun { + -- | Any 'info' messages generated during the run runLog :: Log -- | Did we generate any values in this test run? @@ -105,7 +112,7 @@ -- This is an internal function, used when testing shrinking to include the runs -- from an unshrunk test and a shrunk test. appendLog :: Log -> Property' e () -appendLog (Log log') = mkProperty $ \run@TestRun{runLog = Log log} -> return ( +appendLog (Log log') = mkProperty $ \_ctx run@TestRun{runLog = Log log} -> return ( TestPassed () , run{runLog = Log $ log' ++ log} ) @@ -131,15 +138,22 @@ | TestDiscarded deriving stock (Show, Functor) --- | A test result is a valid shrink step if the test still fails +data Counterexample e = Counterexample{ + counterexampleContext :: Context.Execution + , counterexampleError :: e + , counterexampleRun :: TestRun + } + deriving (Show) + resultIsValidShrink :: - (TestResult e a, TestRun) - -> IsValidShrink (e, TestRun) (Maybe a, TestRun) -resultIsValidShrink (result, run) = + Context.Execution + -> (TestResult e a, TestRun) + -> IsValidShrink (Counterexample e) (Maybe a, TestRun) +resultIsValidShrink ctxt (result, run) = case result of - TestFailed e -> ValidShrink (e , run) - TestDiscarded -> InvalidShrink (Nothing , run) - TestPassed a -> InvalidShrink (Just a , run) + TestFailed e -> ValidShrink $ Counterexample ctxt e run + TestDiscarded -> InvalidShrink (Nothing, run) + TestPassed a -> InvalidShrink (Just a , run) {------------------------------------------------------------------------------- Monad-transformer version of 'TestResult' @@ -171,25 +185,32 @@ -- | Property -- --- A 'Property' is a generator that can fail and keeps a track of some +-- A 'Property'' is a generator that can fail and keeps a track of some -- information about the test run. -- --- In most cases, you will probably want to use 'Test.Falsify.Property.Property' +-- In most cases, you will probably want to use 'Property' -- instead, which fixes @e@ at 'String'. newtype Property' e a = WrapProperty { - unwrapProperty :: TestResultT e (StateT TestRun Gen) a + unwrapProperty :: TestResultT e (ReaderT Context (StateT TestRun Gen)) a } deriving newtype (Functor, Applicative, Monad) +-- | Property that uses strings as errors +-- +-- Most of @falsify@'s internal functions work with 'Property'', but most +-- user-facing functions use 'Property' instead. +type Property = Property' String + -- | Construct property -- -- This is a low-level function for internal use only. -mkProperty :: (TestRun -> Gen (TestResult e a, TestRun)) -> Property' e a -mkProperty = WrapProperty . TestResultT . StateT +mkProperty :: (Context -> TestRun -> Gen (TestResult e a, TestRun)) -> Property' e a +mkProperty f = WrapProperty $ TestResultT $ ReaderT $ \ctx -> StateT (f ctx) -- | Run property -runProperty :: Property' e a -> Gen (TestResult e a, TestRun) -runProperty = flip runStateT initTestRun . runTestResultT . unwrapProperty +runProperty :: Property' e a -> Context -> Gen (TestResult e a, TestRun) +runProperty p ctx = + flip runStateT initTestRun $ flip runReaderT ctx $ runTestResultT $ unwrapProperty p {------------------------------------------------------------------------------- 'Property' features @@ -197,18 +218,18 @@ -- | Test failure testFailed :: e -> Property' e a -testFailed err = mkProperty $ \run -> return (TestFailed err, run) +testFailed err = mkProperty $ \_ctx run -> return (TestFailed err, run) -- | Discard this test discard :: Property' e a -discard = mkProperty $ \run -> return (TestDiscarded, run) +discard = mkProperty $ \_ctx run -> return (TestDiscarded, run) -- | Log some additional information about the test -- -- This will be shown in verbose mode. info :: String -> Property' e () info msg = - mkProperty $ \run@TestRun{runLog = Log log} -> return ( + mkProperty $ \_ctx run@TestRun{runLog = Log log} -> return ( TestPassed () , run{runLog = Log $ Info msg : log} ) @@ -225,7 +246,7 @@ -- See 'collect' for detailed discussion. label :: String -> [String] -> Property' e () label lbl vals = - mkProperty $ \run@TestRun{runLabels} -> return ( + mkProperty $ \_ctx run@TestRun{runLabels} -> return ( TestPassed () , run{runLabels = Map.alter addValues lbl runLabels} ) @@ -297,6 +318,33 @@ instance MonadFail (Property' String) where fail = testFailed + +-- | Get the context for the current test run +getContext :: Property' e Context +getContext = mkProperty $ \ctx run -> return (TestPassed ctx, run) + +-- | Generate value depending on the test iteration +-- +-- Rough analogue to QuickCheck's @sized@ function: for test iteration @i@ out +-- of a total of @n@ tests, the callback is passed @i / n@. This can be used for +-- example to define a t'Test.Falsify.Range.Range' that starts small and gets +-- larger in successive tests. +-- +-- Note that this is just a convenience function around 'getContext'; if you +-- want to define ranges that depend on the test iteration @i@ in a different +-- way, use 'getContext' instead. +sized :: forall e a. (ProperFraction -> a) -> Property' e a +sized f = + aux <$> getContext + where + aux :: Context -> a + aux ctxt = + f $ ProperFraction $ thisTest / numTests + where + thisTest, numTests :: Double + thisTest = fromIntegral . Context.thisTest . Context.iteration $ ctxt + numTests = fromIntegral . Context.tests . Context.static $ ctxt + {------------------------------------------------------------------------------- Running generators -------------------------------------------------------------------------------} @@ -307,7 +355,7 @@ -- (users don't care that 'gen' uses 'genWith'). -> (a -> Maybe String) -- ^ Entry to add to the log (if any) -> Gen a -> Property' e a -genWithCallStack stack f g = mkProperty $ \run -> aux run <$> g +genWithCallStack stack f g = mkProperty $ \_ctx run -> aux run <$> g where aux :: TestRun -> a -> (TestResult e a, TestRun) aux run@TestRun{runLog = Log log} x = ( @@ -334,15 +382,31 @@ -------------------------------------------------------------------------------} -- | Construct random path through the property's shrink tree -genShrinkPath :: Property' e () -> Property' e' [(e, TestRun)] -genShrinkPath prop = do - st <- genWith (const Nothing) $ Gen.toShrinkTree (runProperty prop) - mPath <- genWith (const Nothing) $ Gen.path resultIsValidShrink st +-- +-- The repeated 'Context.Final' step is /not/ included. +genShrinkPath :: + Context.Iteration -- ^ See 'testShrinking' for detailed discussion + -> Property' e () + -> Property' e' [Counterexample e] +genShrinkPath iteration prop = do + static <- Context.static <$> getContext + + let ctx :: Context.Execution -> Context + ctx = Context static iteration + + st <- genWith (const Nothing) $ + Gen.toShrinkTreeWithContext False (runProperty prop . ctx) + mPath <- genWith (const Nothing) $ + Gen.path + ( \(exe, (result, run)) -> + isValidShrink $ resultIsValidShrink exe (result, run) + ) + st aux mPath where aux :: - Either (Maybe (), TestRun) (NonEmpty (e, TestRun)) - -> Property' e' [(e, TestRun)] + Either (Maybe (), TestRun) (NonEmpty (Counterexample e)) + -> Property' e' [Counterexample e] aux (Left (Just (), _)) = return [] aux (Left (Nothing, _)) = discard aux (Right es) = return $ toList es @@ -359,11 +423,40 @@ -- If the given property itself discards immediately, then this generator will -- discard also; otherwise, only shrink steps are considered that do not lead -- to a discard. +-- +-- See also 'testShrinkingForIteration'. testShrinking :: forall e. Show e - => Predicate [e, e] -> Property' e () -> Property' String () -testShrinking p prop = do - path <- genShrinkPath prop + => Predicate [e, e] + -> Property' e () -> Property' String () +testShrinking = testShrinkingForIteration $ Context.Iteration{ + thisTest = error $ concat [ + "thisTest is undefined. " + , "Use testShrinkingForIteration " + , "instead of testShrinking." + ] + } + +-- | Generalization of 'testShrinking' for an arbitrary t'Test.Falsify.Context.Iteration' +-- +-- Some properties may behave quite differently given a different iteration +-- context, in which case it is important to be explicit about this. +-- +-- The /shrinking/ context is constructed so that it accurately reflects the +-- path: 'Context.Initial' for the root of the tree, and then +-- 'Context.Shrinking' as we follow edges downwards. There is /no/ repeated +-- 'Context.Final' step: 'testShrinkingForIteration' and 'testShrinking' are +-- typically used to verify that successive shrink steps result in values that +-- are closer to the generator's origin, which is trivially violated by that +-- repeated final step. +-- +-- The /static/ context is inherited from the parent property. +testShrinkingForIteration :: forall e. + Show e + => Context.Iteration + -> Predicate [e, e] -> Property' e () -> Property' String () +testShrinkingForIteration iteration p prop = do + path <- genShrinkPath iteration prop case findCounterExample (toList path) of Nothing -> return () @@ -374,14 +467,20 @@ appendLog logAfter testFailed err where - findCounterExample :: [(e, TestRun)] -> Maybe (String, Log, Log) + findCounterExample :: [Counterexample e] -> Maybe (String, Log, Log) findCounterExample = \case [] -> Nothing [_] -> Nothing - ((x, runX) : rest@((y, runY) : _)) -> - case P.eval $ p .$ ("original", x) .$ ("shrunk", y) of - Left err -> Just (err, runLog runX, runLog runY) + (x : rest@(y : _)) -> + case P.eval $ + p .$ ("original" , counterexampleError x) + .$ ("shrunk" , counterexampleError y) of Right () -> findCounterExample rest + Left err -> Just ( + err + , runLog (counterexampleRun x) + , runLog (counterexampleRun y) + ) -- | Test the minimum error thrown by the property -- @@ -393,14 +492,32 @@ -- some particular property in mind. Otherwise, the minimum value will always -- simply be the value that the generator produces when given the @Minimal@ -- sample tree. -testMinimum :: forall e. +-- +-- See also 'testMinimumForIteration'. +testMinimum :: Show e => Predicate '[e] -> Property' e () -> Property' String () +testMinimum = testMinimumForIteration $ Context.Iteration{ + thisTest = error $ concat [ + "thisTest is undefined. " + , "Use testMinimumForIteration " + , "instead of testMinimum." + ] + } + +-- | Generalization of 'testMinimum' +-- +-- See 'testShrinkingForIteration' for detailed discussion of the context. +testMinimumForIteration :: forall e. Show e - => Predicate '[e] - -> Property' e () - -> Property' String () -testMinimum p prop = do + => Context.Iteration + -> Predicate '[e] -> Property' e () -> Property' String () +testMinimumForIteration iteration p prop = do + static <- Context.static <$> getContext + + let initContext :: Context + initContext = Context static iteration Context.Initial + st <- genWith (const Nothing) $ Gen.captureLocalTree - case Gen.runGen (runProperty prop) st of + case runGen (runProperty prop initContext) st of ((TestPassed (), _run), _shrunk) -> -- The property passed; nothing to test discard @@ -408,30 +525,33 @@ -- The property needs to be discarded; discard this one, too discard ((TestFailed initErr, initRun), shrunk) -> do - let explanation :: ShrinkExplanation (e, TestRun) (Maybe (), TestRun) - explanation = shrinkFrom - resultIsValidShrink - (runProperty prop) - ((initErr, initRun), shrunk) + let explanation :: ShrinkExplanation (Counterexample e) (Maybe (), TestRun) + explanation = + shrinkFrom + static + iteration + (\ctx -> resultIsValidShrink (Context.execution ctx) <$> + runProperty prop ctx) + st + (Counterexample Context.Initial initErr initRun, shrunk) - minErr :: e - minRun :: TestRun - mRejected :: Maybe [(Maybe (), TestRun)] - ((minErr, minRun), mRejected) = shrinkOutcome explanation + minExample :: Counterexample e + mRejected :: Maybe [(Maybe (), TestRun)] + (minExample, mRejected) = shrinkOutcome explanation rejected :: [TestRun] rejected = maybe [] (map snd) mRejected - case P.eval $ p .$ ("minimum", minErr) of + case P.eval $ p .$ ("minimum", counterexampleError minExample) of Right () -> do -- For a successful test, we add the full shrink history as info -- This means that users can use verbose mode to see precisely -- how the minimum value is reached, if they wish. info "Shrink history:" - forM_ (shrinkHistory explanation) $ \(e, _run) -> - info $ show e + forM_ (shrinkHistory explanation) $ \example -> + info $ show (counterexampleError example) Left err -> do - appendLog (runLog minRun) + appendLog (runLog $ counterexampleRun minExample) unless (null rejected) $ do info "\nLogs for rejected potential next shrinks:" forM_ (zip [0 :: Word ..] rejected) $ \(i, rej) -> do @@ -449,7 +569,7 @@ -- | Generalization of 'testGen' testGen' :: forall e a b. (a -> Either e b) -> Gen a -> Property' e b -testGen' p g = WrapProperty $ TestResultT $ StateT $ \run -> +testGen' p g = WrapProperty $ TestResultT $ ReaderT $ \_ctx -> StateT $ \run -> -- We do not use bind here to avoid introducing new shrinking shortcuts aux run <$> g where @@ -465,6 +585,24 @@ -- -- We check /any/ shrink step that the generator can make (independent of any -- property). +-- +-- See also 'testShrinkingOfGenForIteration'. testShrinkingOfGen :: Show a => Predicate [a, a] -> Gen a -> Property' String () -testShrinkingOfGen p = testShrinking p . testGen' Left +testShrinkingOfGen = + testShrinkingOfGenForIteration $ Context.Iteration{ + thisTest = error $ concat [ + "thisTest is undefined. " + , "Use testShrinkingOfGenForIteration " + , "instead of testShrinkingOfGen." + ] + } +-- | Generalization of 'testShrinkingOfGen' +-- +-- See 'testShrinkingForIteration' for detailed discussion of the context. +testShrinkingOfGenForIteration :: + Show a + => Context.Iteration + -> Predicate [a, a] -> Gen a -> Property' String () +testShrinkingOfGenForIteration iteration p = + testShrinkingForIteration iteration p . testGen' Left diff --git a/src/Test/Falsify/Internal/Range.hs b/src/Test/Falsify/Internal/Range.hs --- a/src/Test/Falsify/Internal/Range.hs +++ b/src/Test/Falsify/Internal/Range.hs @@ -2,53 +2,16 @@ module Test.Falsify.Internal.Range ( -- * Definition Range(..) - , ProperFraction(ProperFraction) - , Precision(..) ) where import Data.List.NonEmpty (NonEmpty) -import Data.Word -import GHC.Show -import GHC.Stack -{------------------------------------------------------------------------------- - Proper fractions --------------------------------------------------------------------------------} - --- | Value @x@ such that @0 <= x < 1@ -newtype ProperFraction = UnsafeProperFraction { getProperFraction :: Double } - deriving stock (Eq, Ord) - deriving newtype (Num, Fractional) - --- | Show instance relies on the 'ProperFraction' pattern synonym -instance Show ProperFraction where - showsPrec p (UnsafeProperFraction f) = showParen (p >= appPrec1) $ - showString "ProperFraction " - . showsPrec appPrec1 f - -mkProperFraction :: HasCallStack => Double -> ProperFraction -mkProperFraction f - | 0 <= f && f < 1 = UnsafeProperFraction f - | otherwise = error $ "mkProperFraction: not a proper fraction: " ++ show f - -pattern ProperFraction :: Double -> ProperFraction -pattern ProperFraction f <- (getProperFraction -> f) - where - ProperFraction = mkProperFraction - -{-# COMPLETE ProperFraction #-} - -{------------------------------------------------------------------------------- - Precision --------------------------------------------------------------------------------} +import Data.Falsify.WordN (WordN) --- | Precision (in bits) -newtype Precision = Precision Word8 - deriving stock (Show, Eq, Ord) - deriving newtype (Num, Enum) +import qualified Data.Falsify.WordN as WordN {------------------------------------------------------------------------------- - Range + Definition -------------------------------------------------------------------------------} -- | Range of values @@ -56,10 +19,14 @@ -- | Constant (point) range Constant :: a -> Range a - -- | Construct values in the range from a 'ProperFraction' + -- | Construct value from t'WordN' of the given precision -- -- This is the main constructor for 'Range'. - FromProperFraction :: Precision -> (ProperFraction -> a) -> Range a + -- + -- Typically this t'WordN' is used to construct a fraction which is then used + -- to index the range (see 'Test.Falsify.Range.fromProperFraction'), though + -- some generators use the t'WordN' directly. + FromWordN :: WordN.Precision -> (WordN -> a) -> Range a -- | Evaluate each range and choose the \"smallest\" -- diff --git a/src/Test/Falsify/Internal/SampleTree.hs b/src/Test/Falsify/Internal/SampleTree.hs --- a/src/Test/Falsify/Internal/SampleTree.hs +++ b/src/Test/Falsify/Internal/SampleTree.hs @@ -1,98 +1,22 @@ --- | Sample tree +-- | Utilities for working with the sample tree -- -- Intended for qualified import. -- --- import Test.Falsify.Internal.SampleTree (SampleTree(..)) --- import qualified Test.Falsify.Internal.SampleTree as SampleTree +-- > import qualified Test.Falsify.Internal.SampleTree as SampleTree module Test.Falsify.Internal.SampleTree ( - -- * Definition - SampleTree(..) - , Sample(..) - , pattern Inf - , sampleValue -- * Lenses - , next + next , left , right - -- * Construction - , fromPRNG - , fromSeed - , minimal - , constant - -- * Combinators - , map - , mod ) where import Prelude hiding (map, mod) -import qualified Prelude -import Data.Word import Optics.Core (Lens') -import System.Random.SplitMix import qualified Optics.Core as Optics -{------------------------------------------------------------------------------- - Definition --------------------------------------------------------------------------------} - --- | Sample tree --- --- A sample tree is a (conceptually and sometimes actually) infinite tree --- representing drawing values from and splitting a PRNG. -data SampleTree = - -- | Default constructor - -- - -- The type of ST is really - -- - -- > ST :: Word64 & (SampleTree * SampleTree) -> SampleTree - -- - -- where `(&)` is the additive conjunction from linear logic. In other - -- words, the intention is that /either/ the @Word64@ is used, /or/ - -- the pair of subtrees; put another way, we /either/ draw a value from the - -- PRNG, /or/ split it into two new PRNGs. See 'next' and 'split'. - SampleTree Sample SampleTree SampleTree - - -- | Minimal tree (0 everywhere) - -- - -- This constructor allows us to represent an infinite tree in a finite way - -- and, importantly, /recognize/ a tree that is minimal everywhere. This is - -- necessary when shrinking in the context of generators that generate - -- infinitely large values. - | Minimal - deriving (Show) - -{------------------------------------------------------------------------------- - Samples --------------------------------------------------------------------------------} - --- | Sample --- --- The samples in the 'SampleTree' record if they were the originally produced --- sample, or whether they have been shrunk. -data Sample = - NotShrunk Word64 - | Shrunk Word64 - deriving (Show, Eq, Ord) - -sampleValue :: Sample -> Word64 -sampleValue (NotShrunk s) = s -sampleValue (Shrunk s) = s - -{------------------------------------------------------------------------------- - Views --------------------------------------------------------------------------------} - -view :: SampleTree -> (Sample, SampleTree, SampleTree) -view Minimal = (Shrunk 0, Minimal, Minimal) -view (SampleTree s l r) = (s, l, r) - --- | Pattern synonym for treating the sample tree as infinite -pattern Inf :: Sample -> SampleTree -> SampleTree -> SampleTree -pattern Inf s l r <- (view -> (s, l, r)) - -{-# COMPLETE Inf #-} +import Test.Falsify.SampleTree (SampleTree(..), pattern Inf, Sample(..)) {------------------------------------------------------------------------------- Lenses @@ -129,68 +53,3 @@ setter :: SampleTree -> SampleTree -> SampleTree setter Minimal _ = Minimal setter (SampleTree s l _) r = SampleTree s l r - -{------------------------------------------------------------------------------- - Construction --------------------------------------------------------------------------------} - -fromPRNG :: SMGen -> SampleTree -fromPRNG = go - where - go :: SMGen -> SampleTree - go g = - let (n, _) = nextWord64 g - (l, r) = splitSMGen g - in SampleTree (NotShrunk n) (go l) (go r) - -fromSeed :: Word64 -> SampleTree -fromSeed = fromPRNG . mkSMGen - --- | Minimal sample tree --- --- Generators should produce the \"simplest\" value when given this tree, --- for some suitable application-specific definition of \"simple\". -minimal :: SampleTree -minimal = Minimal - --- | Sample tree that is the given value everywhere --- --- This is primarily useful for debugging. -constant :: Word64 -> SampleTree -constant s = go - where - go :: SampleTree - go = SampleTree (NotShrunk s) go go - -{------------------------------------------------------------------------------- - Combinators --------------------------------------------------------------------------------} - --- | Map function over all random samples in the tree --- --- Precondition: the function must preserve zeros: --- --- > f 0 == 0 --- --- This means that we have --- --- > map f M == M --- --- This is primarily useful for debugging. -map :: (Word64 -> Word64) -> SampleTree -> SampleTree -map f = go - where - go :: SampleTree -> SampleTree - go (SampleTree s l r) = SampleTree (mapSample s) (go l) (go r) - go Minimal = Minimal - - mapSample :: Sample -> Sample - mapSample (NotShrunk s) = NotShrunk (f s) - mapSample (Shrunk s) = Shrunk (f s) - --- | Apply @mod m@ at every sample in the tree --- --- This is primarily useful for debugging. -mod :: Word64 -> SampleTree -> SampleTree -mod m = map (\s -> s `Prelude.mod` m) - diff --git a/src/Test/Falsify/Internal/Search.hs b/src/Test/Falsify/Internal/Search.hs --- a/src/Test/Falsify/Internal/Search.hs +++ b/src/Test/Falsify/Internal/Search.hs @@ -50,7 +50,7 @@ -- | Binary search without parity bias -- -- For some cases the parity (even or odd) of a number is very important, and --- unfotunately standard binary search is not very good at allowing search to +-- unfortunately standard binary search is not very good at allowing search to -- flip between even and odd. For example, if we start with 'maxBound', -- /every/ possibly shrink value computed by 'binarySearch' is even. The -- situation is less extreme for other numbers, but it's nonetheless something diff --git a/src/Test/Falsify/Internal/Shrinking.hs b/src/Test/Falsify/Internal/Shrinking.hs new file mode 100644 --- /dev/null +++ b/src/Test/Falsify/Internal/Shrinking.hs @@ -0,0 +1,205 @@ +module Test.Falsify.Internal.Shrinking ( + -- * Shrinking + shrinkFrom + -- * With full history + , ShrinkExplanation(..) + , ShrinkHistory(..) + , IsValidShrink(..) + , isValidShrink + , shrinkHistory + , shrinkOutcome + ) where + +import Data.Bifunctor +import Data.Either +import Data.List.NonEmpty (NonEmpty((:|))) + +import Test.Falsify.Context (Context(Context)) +import Test.Falsify.Internal.Generator +import Test.Falsify.SampleTree (SampleTree(..)) + +import qualified Test.Falsify.Context as Context + +{------------------------------------------------------------------------------- + Explanation +-------------------------------------------------------------------------------} + +-- | Shrink explanation +-- +-- @p@ is the type of \"positive\" elements that satisfied the predicate (i.e., +-- valid shrinks), and @n@ is the type of \"negative\" which didn't. +data ShrinkExplanation p n = ShrinkExplanation { + -- | The value we started, before shrinking + initial :: p + + -- | The full shrink history + , history :: ShrinkHistory p n + } + deriving (Show) + +-- | Shrink explanation +data ShrinkHistory p n = + -- | We successfully executed a single shrink step + ShrunkTo p (ShrinkHistory p n) + + -- | We could no shrink any further + -- + -- We record + -- + -- * All rejected next steps + -- * The outcome of the repeated 'Context.Final' step + -- + -- Recording the rejected next steps is occasionally useful when trying to + -- figure out why a value didn't shrink any further (what did it try to + -- shrink to?). + | ShrinkingDone [n] p + + -- | We stopped shrinking early + -- + -- This is used when the number of shrink steps is limited. + -- We record the outcome of the repeated 'Context.Final' step. + | ShrinkingStopped p + deriving (Show) + +-- | Simplify the shrink explanation to keep only the shrink history +shrinkHistory :: ShrinkExplanation p n -> NonEmpty p +shrinkHistory = \(ShrinkExplanation unshrunk shrunk) -> + unshrunk :| go shrunk + where + go :: ShrinkHistory p n -> [p] + go (ShrunkTo x xs) = x : go xs + go (ShrinkingDone _ns p) = [p] + go (ShrinkingStopped p) = [p] + +-- | The final shrunk value, as well as all rejected /next/ shrunk steps +-- +-- The list of rejected next steps is +-- +-- * @Nothing@ if shrinking was terminated early (e.g. 'Context.maxShrinks') +-- * @Just []@ if the final value truly is minimal (typically, it is only +-- minimal wrt to a particular properly, but not the minimal value that a +-- generator can produce). +shrinkOutcome :: forall p n. ShrinkExplanation p n -> (p, Maybe [n]) +shrinkOutcome = \ShrinkExplanation{history} -> + go history + where + go :: ShrinkHistory p n -> (p, Maybe [n]) + go (ShrunkTo _p h) = go h + go (ShrinkingDone ns p) = (p, Just ns) + go (ShrinkingStopped p) = (p, Nothing) + +{------------------------------------------------------------------------------- + Mapping +-------------------------------------------------------------------------------} + +instance Functor (ShrinkExplanation p) where + fmap = second + +instance Functor (ShrinkHistory p) where + fmap = second + +instance Bifunctor ShrinkExplanation where + bimap f g ShrinkExplanation{initial, history} = ShrinkExplanation{ + initial = f initial + , history = bimap f g history + } + +instance Bifunctor ShrinkHistory where + bimap f g = \case + ShrunkTo p h -> ShrunkTo (f p) (bimap f g h) + ShrinkingDone ns p -> ShrinkingDone (map g ns) (f p) + ShrinkingStopped p -> ShrinkingStopped (f p) + +{------------------------------------------------------------------------------- + Shrinking +-------------------------------------------------------------------------------} + +-- | Does a given shrunk value represent a valid shrink step? +data IsValidShrink p n = + ValidShrink p + | InvalidShrink n + deriving stock (Show) + +isValidShrink :: IsValidShrink p n -> Either n p +isValidShrink (ValidShrink p) = Right p +isValidShrink (InvalidShrink n) = Left n + +-- | Find smallest value that the generator can produce and still satisfies +-- the predicate. +-- +-- Returns the full shrink history. +-- +-- To avoid boolean blindness, we use different types for values that satisfy +-- the property and values that do not. +-- +-- This is lazy in the shrink history. +shrinkFrom :: forall p n. + Context.Static + -- ^ Static context + -- + -- Passed as-is to the property as part of the t'Context'. + -- Used to extract shrinking parameters. + -> Context.Iteration + -- ^ Iteration context + -- + -- Passsed as-is to the property as part of the t'Context'. + -- Not used otherwise. + -> (Context -> Gen (IsValidShrink p n)) + -- ^ The property we're shrinking + -> SampleTree + -- ^ The sample tree we started with + -> (p, [SampleTree]) + -- ^ The initial result of the generator + -> ShrinkExplanation p n +shrinkFrom static iteration prop = \st (p, shrunk) -> + ShrinkExplanation p $ go 0 st shrunk + where + go :: Word -> SampleTree -> [SampleTree] -> ShrinkHistory p n + go i = \st shrunk -> + -- NOTE: 'partitionEithers' is lazy enough: + -- + -- > head . fst $ partitionEithers [Left True, undefined] == True + let candidates :: [(SampleTree, p, [SampleTree])] + rejected :: [n] + (candidates, rejected) = partitionEithers $ map consider shrunk + + in case candidates of + [] -> + ShrinkingDone rejected $ runFinal i st + (st', p, shrunk'):_ | canContinue -> + ShrunkTo p $ go (succ i) st' shrunk' + _otherwise -> + ShrinkingStopped $ runFinal i st + where + ctx :: Context + ctx = Context static iteration $ Context.Shrinking i + + canContinue :: Bool + canContinue = + maybe + True + (\limit -> i < limit) + (Context.maxShrinks static) + + consider :: SampleTree -> Either (SampleTree, p, [SampleTree]) n + consider st = + case isValid of + ValidShrink p -> Left (st, p, shrunk') + InvalidShrink n -> Right n + where + isValid :: IsValidShrink p n + shrunk' :: [SampleTree] + (isValid, shrunk') = runGen (prop ctx) st + + -- Run the property one final time + -- + -- Precondition: must be run on a sample tree for which we know the + -- property fails. + runFinal :: Word -> SampleTree -> p + runFinal i st = + case fst $ runGen (prop ctx) st of + ValidShrink p -> p + InvalidShrink _ -> error "runFinal: precondition violated" + where + ctx :: Context + ctx = Context static iteration $ Context.Final i diff --git a/src/Test/Falsify/Marked.hs b/src/Test/Falsify/Marked.hs new file mode 100644 --- /dev/null +++ b/src/Test/Falsify/Marked.hs @@ -0,0 +1,79 @@ +-- | Marked elements +-- +-- Intended for qualified import. +-- +-- > import Test.Falsify +-- > import qualified Test.Falsify.Marked as Marked +module Test.Falsify.Marked ( + Mark(..) + , Marked(..) + -- * Generation + , selectAllKept + -- * Queries + , countKept + , shouldKeep + ) where + +import Control.Selective +import Data.Foldable (toList) +import Data.Maybe (mapMaybe) + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | Should an element in a container be kept or dropped? +-- +-- See also t'Marked'. +data Mark = Keep | Drop + deriving stock (Show, Eq, Ord) + +-- | Marked element in a container +-- +-- Marking elements can be a useful technique for dropping elements from a +-- container. +-- +-- * Locally marking elements to 'Drop' makes it possible to enforce some global +-- constraints about minimum number of required elements before /actually/ +-- dropping them (see 'selectAllKept'). +-- Example: 'Test.Falsify.Generator.list'. +-- +-- * For containers where we cannot remove random elements, the marks can be +-- used for \"outwards propagation\": if /this/ element is dropped, then +-- /those/ elements must also be dropped. +-- Example: 'Test.Falsify.Generator.tree'. +data Marked f a = Marked { + getMark :: Mark + , unmark :: f a + } + deriving stock (Show, Eq, Ord) + +{------------------------------------------------------------------------------- + Generation +-------------------------------------------------------------------------------} + +selectKept :: Selective f => Marked f a -> f (Maybe a) +selectKept (Marked mark gen) = + ifS (pure $ mark == Keep) + (Just <$> gen) + (pure Nothing) + +-- | Traverse the argument, generating all values marked 'Keep', and replacing +-- all values marked 'Drop' by 'Nothing' +selectAllKept :: + (Traversable t, Selective f) + => t (Marked f a) -> f (t (Maybe a)) +selectAllKept = traverse selectKept + +{------------------------------------------------------------------------------- + Queries +-------------------------------------------------------------------------------} + +-- | Count how many elements will be kept +countKept :: Foldable t => t (Marked f a) -> Word +countKept = fromIntegral . length . mapMaybe shouldKeep . toList + +-- | The element /if/ it should be kept +shouldKeep :: Marked f a -> Maybe (f a) +shouldKeep (Marked Keep x) = Just x +shouldKeep (Marked Drop _) = Nothing diff --git a/src/Test/Falsify/Predicate.hs b/src/Test/Falsify/Predicate.hs --- a/src/Test/Falsify/Predicate.hs +++ b/src/Test/Falsify/Predicate.hs @@ -1,22 +1,250 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | Predicates -- -- Intended for qualified import. - --- > import Test.Falsify.Predicate (Predicate, (.$)) +-- +-- > import Test.Falsify -- > import qualified Test.Falsify.Predicate as P +-- +-- = Motivation +-- +-- Testing libraries must have a way to assert and check intended-to-be-true +-- facts. For example, suppose we have +-- +-- > x, y :: Int +-- > x = 5 +-- > y = 10 +-- +-- and we want to assert that @x@ and @y@ are equal. The simplest form that this +-- might take is simply a boolean predicate; for example, @tasty-hunit@ offers +-- [@assertBool@](https://hackage-content.haskell.org/package/tasty-hunit-0.10.2/docs/Test-Tasty-HUnit.html#v:assertBool), +-- and in @QuickCheck@ we have a +-- [@Testable@](https://hackage-content.haskell.org/package/QuickCheck-2.18.0.0/docs/Test-QuickCheck.html#t:Testable) +-- instance for 'Bool'. This allows us to write +-- +-- > test_hunit_bool :: HUnit.Assertion +-- > test_hunit_bool = HUnit.assertBool "uhoh" $ x == y +-- > +-- > test_qc_bool :: QuickCheck.Property +-- > test_qc_bool = QuickCheck.property $ x == y +-- +-- However, when such a property fails we don't get very useful output; we are +-- merely told /that/ the property failed. Both @tasty-hunit@ and @QuickCheck@ +-- offer limited support for producing nicer test ouput; in the specific case of +-- equality, we can write +-- +-- > test_hunit_equal :: HUnit.Assertion +-- > test_hunit_equal = HUnit.assertEqual "uhoh" x y +-- > +-- > test_qc_equal :: QuickCheck.Property +-- > test_qc_equal = QuickCheck.property $ x QuickCheck.=== y +-- +-- instead, which would produce output +-- +-- > uhoh +-- > expected: 5 +-- > but got: 10 (expected failure) +-- +-- and +-- +-- > *** Failed! Falsified (after 1 test): +-- > 5 /= 10 +-- +-- respectively, where we are not only told that the property failed, but also +-- /how/; in this case, what the values of @x@ and @y@ are. /Predicates/ in +-- @falsify@ as a generalization of this concept. +-- +-- = Introduction to predicates +-- +-- Think of a predicate of type 'Predicate' @'[a, b, ..]@ as a function +-- @a -> b -> .. -> Bool@, which can additionally produce useful test output +-- when the predicate does not hold. In order be able to produce that output, a +-- predicate is equipped with a function to generate a description of the +-- failure, given a description of the inputs; those inputs are described by +-- /expressions/ ('Expr'). For example, here is a very simple way in which we +-- might define a predicate to check that its argument is 'even': +-- +-- > even1 :: Integral a => Predicate '[a] +-- > even1 = P.unary even $ \a -> "not even: " ++ P.prettyExpr a +-- +-- When a predicate is applied to an argument, it must be told how to /name/ +-- that argument, how to /render/ the argument, and the /value/ of the argument. +-- For example, +-- +-- > test_even1 :: Property () +-- > test_even1 = assert $ even1 `P.at` ("x", show x, x) +-- +-- will result in +-- +-- > even1: FAIL +-- > failed after 0 shrinks +-- > not even: x +-- > x: 5 +-- +-- Typically we will use 'show' to render the argument, in which case we can +-- use '.$': +-- +-- > test_even2 :: Property () +-- > test_even2 = assert $ even1 .$ ("x", x) +-- +-- This scales nicely to any number of arguments; for example, to come back the +-- equality example from the previous section: +-- +-- > test_equal :: Property () +-- > test_equal = assert $ +-- > P.eq .$ ("x", x) +-- > .$ ("y", y) +-- +-- will produce +-- +-- > equal: FAIL +-- > failed after 0 shrinks +-- > x /= y +-- > x: 5 +-- > y: 10 +-- +-- = Compositionality +-- +-- Suppose that we want to verify that @x@ and @y@ have the same polarity (both +-- are even or both are odd). We /could/ use 'eq' again: +-- +-- > test_samePolarity1 :: Property () +-- > test_samePolarity1 = assert $ +-- > P.eq .$ ("even x", even x) +-- > .$ ("even y", even y) +-- +-- but if we run that, we get +-- +-- > samePolarity1: FAIL +-- > failed after 0 shrinks +-- > even x /= even y +-- > even x: False +-- > even y: True +-- +-- In order to debug the problem, we might like to the value of @x@ and @y@, not +-- just whether they are even or not. We could instead define a custom predicate +-- specifically for this purpose: +-- +-- > samePolarity :: Integral a => Predicate '[a, a] +-- > samePolarity = +-- > P.binary +-- > (\a b -> even a == even b) +-- > (\a b -> P.prettyExpr a ++ " and " ++ P.prettyExpr b ++ " have different polarity") +-- > +-- > test_samePolarity2 :: Property () +-- > test_samePolarity2 = assert $ samePolarity .$ ("x", x) .$ ("y", y) +-- +-- which would produce +-- +-- > samePolarity2: FAIL +-- > failed after 0 shrinks +-- > x and y have different polarity +-- > x: 5 +-- > y: 10 +-- +-- but now we have the opposite problem: we see the values of @x@ and @y@, but +-- not their polarity. Fortunately, we can take advantage of the +-- compositionality of predicates, and state very directly that the function +-- 'even', applied 'on' both arguments, must produce the same result: +-- +-- > samePolarity' :: Integral a => Predicate '[a, a] +-- > samePolarity' = P.eq `P.on` P.fn ("even", even) +-- > +-- > test_samePolarity3 :: Property () +-- > test_samePolarity3 = assert $ +-- > samePolarity' +-- > .$ ("x", x) +-- > .$ ("y", y) +-- +-- produces +-- +-- > samePolarity3: FAIL +-- > failed after 0 shrinks +-- > (even x) /= (even y) +-- > x : 5 +-- > y : 10 +-- > even x: False +-- > even y: True +-- +-- Occassionally it is useful to suppress the results of functions applications; +-- for example, suppose we have +-- +-- > newtype T = WrapT Int +-- > deriving stock (Show) +-- > +-- > unwrapT :: T -> Int +-- > unwrapT (WrapT a) = a +-- +-- and we want to check whether @X 5@ and @X 10@ have the same polarity; in this +-- case, there isn't much point explicitly including the output of @unwrapT@, +-- so we can suppress it with 'transparent': +-- +-- > test_samePolarity4 :: Property () +-- > test_samePolarity4 = assert $ +-- > samePolarity' `P.on` P.transparent unwrapT +-- > .$ ("x", WrapT 5) +-- > .$ ("y", WrapT 10) +-- +-- = N-ary predicates +-- +-- Most predicates are either 'unary' or 'binary'; these can usually easily be +-- defined using 'satisfies' and 'relatedBy' respectively, which will take care +-- of producing a nice error message. In the general case you can construct +-- predicates of arbitrary arity using 'lam', 'pass' and 'fail', though in that +-- case you will be responsible for constructing your own error messages. +-- +-- For example, suppose we have a "real" implementation of some kind of security +-- policy implementation as well as a "model" implementation: +-- +-- > applyReal, applyModel :: Policy -> Operation -> Resource -> Actor -> Bool +-- +-- Then we could define a predicate that compares these two as follows: +-- +-- > realVsModel :: Predicate '[Policy, Operation, Resource, Actor] +-- > realVsModel = P.lam $ \p -> P.lam $ \o -> P.lam $ \r -> P.lam $ \a -> +-- > let real = applyReal p o r a +-- > model = applyModel p o r a +-- > in if real == model then +-- > P.pass +-- > else +-- > P.fail $ "real says " ++ show real ++ ", model says " ++ show model +-- +-- Such a predicate can then be used like any other, and rendering of the +-- arguments /to/ the predicate is handled automatically. For example: +-- +-- > test_realVsModel :: Property () +-- > test_realVsModel = assert $ +-- > realVsModel +-- > .$ ( "policy" , policy ) +-- > .$ ( "operation" , operation ) +-- > .$ ( "resource" , resource ) +-- > .$ ( "actor" , actor ) +-- +-- (Usually of course these inputs would be randomly generated.) This property +-- might result in +-- +-- > realVsModel: FAIL +-- > failed after 0 shrinks +-- > real says False, model says True +-- > policy : "strict" +-- > operation: "delete" +-- > resource : "db" +-- > actor : "joe" module Test.Falsify.Predicate ( Predicate -- opaque -- * Expressions , Expr -- opaque , prettyExpr -- * Functions - , Fn -- opaque + , Fn -- opaque + , FnName -- opaque , fn , fnWith , transparent -- * Construction - , alwaysPass - , alwaysFail + , pass + , fail , unary , binary -- * Auxiliary construction @@ -29,7 +257,10 @@ , flip , matchEither , matchBool + , lam -- * Evaluation and partial evaluation + , VarName -- opaque + , Err , eval , (.$) , at @@ -49,7 +280,7 @@ , pairwise ) where -import Prelude hiding (all, flip, even, odd, pred, elem) +import Prelude hiding (all, flip, even, odd, pred, elem, fail) import qualified Prelude import Data.Bifunctor @@ -57,6 +288,7 @@ import Data.List (intercalate) import Data.Maybe (catMaybes) import Data.SOP (NP(..), K(..), I(..), SListI) +import Data.String import qualified Data.SOP as SOP @@ -65,21 +297,30 @@ -------------------------------------------------------------------------------} -- | Variable -type Var = String +newtype VarName = WrapVarName{ + unwrapVarName :: String + } + deriving newtype (IsString) -- | Simple expression language -- -- The internal details of this type are (currently) not exposed. data Expr = -- | Variable - Var Var + Var VarName + -- | Function + -- + -- We distinguish between v'Var' and v'Fn' only for improved readability. + | Fn FnName + -- | Application | App Expr Expr -- | Non-associative infix operator - | Infix Var Expr Expr + | Infix FnName Expr Expr +-- | Pretty-print expression prettyExpr :: Expr -> String prettyExpr = go False where @@ -87,14 +328,15 @@ Bool -- Does the context require brackets? -> Expr -> String go needsBrackets = \case - Var x -> x + Var x -> unwrapVarName x + Fn f -> unwrapFnName f App e1 e2 -> parensIf needsBrackets $ intercalate " " [ go False e1 -- application is left associative , go True e2 ] Infix op e1 e2 -> parensIf needsBrackets $ intercalate " " [ go True e1 - , op + , unwrapFnName op , go True e2 ] @@ -106,10 +348,16 @@ Functions -------------------------------------------------------------------------------} +-- | Function name +newtype FnName = WrapFnName{ + unwrapFnName :: String + } + deriving newtype (IsString) + -- | Function (used for composition of a 'Predicate' with a function) data Fn a b = -- | Function that is visible in rendered results - Visible Var (b -> String) (a -> b) + Visible FnName (b -> String) (a -> b) -- | Function that should not be visible in rendered results -- @@ -117,11 +365,11 @@ | Transparent (a -> b) -- | Default constructor for a function -fn :: Show b => (Var, a -> b) -> Fn a b +fn :: Show b => (FnName, a -> b) -> Fn a b fn (n, f) = fnWith (n, show, f) -- | Generalization of 'fn' that does not depend on 'Show' -fnWith :: (Var, b -> String, a -> b) -> Fn a b +fnWith :: (FnName, b -> String, a -> b) -> Fn a b fnWith (n, r, f) = Visible n r f -- | Function that should not be visible in any rendered failure @@ -132,7 +380,7 @@ -- > p1 = P.eq `P.on` (P.fn "ord" ord) -- > p2 = P.eq `P.on` (P.transparent ord) -- --- Both of these compare two characters on their codepoints (through 'ord'), but +-- Both of these compare two characters on their codepoints (through @ord@), but -- they result in different failures. The first would give us something like -- -- > (ord x) /= (ord y) @@ -177,7 +425,7 @@ applyFn :: Fn a b -> Input a -> (Input b, Maybe (Expr, String)) applyFn (Visible n r f) x = ( Input { - inputExpr = App (Var n) $ inputExpr x + inputExpr = App (Fn n) $ inputExpr x , inputRendered = r $ f (inputValue x) , inputValue = f $ inputValue x } @@ -226,7 +474,7 @@ Pass :: Predicate xs -- | Predicate that always fails - Fail :: Predicate xs + Fail :: Err -> Predicate xs -- | Conjunction Both :: Predicate xs -> Predicate xs -> Predicate xs @@ -240,7 +488,7 @@ -- | Function compostion Dot :: Predicate (x' : xs) -> Fn x x' -> Predicate (x : xs) - -- | Analogue of 'Control.Arrow.(***)' + -- | Analogue of '(Control.Arrow.***)' Split :: Predicate (x' : y' : xs) -> (Fn x x', Fn y y') -> Predicate (x : y : xs) -- | Analogue of 'Prelude.flip' @@ -274,12 +522,12 @@ -------------------------------------------------------------------------------} -- | Constant 'True' -alwaysPass :: Predicate xs -alwaysPass = Pass +pass :: Predicate xs +pass = Pass -- | Constant 'False' -alwaysFail :: Predicate xs -alwaysFail = Fail +fail :: Err -> Predicate xs +fail = Fail -- | Unary predicate -- @@ -312,16 +560,16 @@ -------------------------------------------------------------------------------} -- | Specialization of 'unary' for unary relations -satisfies :: (Var, a -> Bool) -> Predicate '[a] +satisfies :: (FnName, a -> Bool) -> Predicate '[a] satisfies (n, p) = unary p $ \x -> - prettyExpr $ Var "not" `App` (Var n `App` x) + prettyExpr $ Fn "not" `App` (Fn n `App` x) -- | Specialization of 'binary' for relations -relatedBy :: (Var, a -> b -> Bool) -> Predicate [a, b] +relatedBy :: (FnName, a -> b -> Bool) -> Predicate [a, b] relatedBy (n, p) = binary p $ \x y -> - prettyExpr $ Var "not" `App` (Var n `App` x `App` y) + prettyExpr $ Fn "not" `App` (Fn n `App` x `App` y) {------------------------------------------------------------------------------- Combinators @@ -355,8 +603,8 @@ -- | Conditional -- --- This is a variation on 'choose' that provides no evidence for which branch is --- taken. +-- This is a variation on 'matchEither' that provides no evidence for which +-- branch is taken. matchBool :: Predicate xs -- ^ Predicate to evaluate if the condition is true -> Predicate xs -- ^ Predicate to evaluate if the condition is false @@ -368,6 +616,12 @@ fromBool True = Left () fromBool False = Right () +-- | Lambda abstraction +-- +-- See module documentation of "Test.Falsify.Predicate" for discussion. +lam :: (x -> Predicate xs) -> Predicate (x : xs) +lam k = Lam $ \Input{inputValue} -> k inputValue + {------------------------------------------------------------------------------- Failures -------------------------------------------------------------------------------} @@ -467,7 +721,7 @@ evalAt :: SListI xs => Predicate xs -> NP Input xs -> Either Failure () evalAt (Prim p err) xs = evalPrim p err xs evalAt Pass _ = return () -evalAt Fail xs = Left $ Failure "Fail" (renderInputs xs) +evalAt (Fail err) xs = Left $ Failure err (renderInputs xs) evalAt (Both p1 p2) xs = evalAt p1 xs >> evalAt p2 xs evalAt (Lam f) xs = evalLam f xs evalAt (p `At` x) xs = evalAt p (x :* xs) @@ -494,13 +748,13 @@ -- > P.relatedBy ("equiv", equiv) -- > .$ ("x", x) -- > .$ ("y", y) -(.$) :: Show x => Predicate (x : xs) -> (Var, x) -> Predicate xs +(.$) :: Show x => Predicate (x : xs) -> (VarName, x) -> Predicate xs p .$ (n, x) = p `at` (n, show x, x) -- | Generalization of '(.$)' that does not require a 'Show' instance at :: Predicate (x : xs) - -> (Var, String, x) -- ^ Rendered name, expression, and input proper + -> (VarName, String, x) -- ^ Rendered name, expression, and input proper -> Predicate xs p `at` (n, r, x) = p `atExpr` (Var n, r, x) @@ -522,7 +776,7 @@ -- -- This is an internal auxiliary. binaryInfix :: - Var -- ^ Infix operator corresponding to the relation /NOT/ holding + FnName -- ^ Infix operator corresponding to the relation /NOT/ holding -> (a -> b -> Bool) -> Predicate [a, b] binaryInfix op f = binary f $ \x y -> prettyExpr (Infix op x y) @@ -601,6 +855,5 @@ pred :: Expr -> (Word, a) -> (Word, a) -> Predicate '[] pred xs (i, x) (j, y) = p - `atExpr` (Infix "!!" xs (Var $ show i), show x, x) - `atExpr` (Infix "!!" xs (Var $ show j), show y, y) - + `atExpr` (Infix "!!" xs (Var $ WrapVarName $ show i), show x, x) + `atExpr` (Infix "!!" xs (Var $ WrapVarName $ show j), show y, y) diff --git a/src/Test/Falsify/Property.hs b/src/Test/Falsify/Property.hs deleted file mode 100644 --- a/src/Test/Falsify/Property.hs +++ /dev/null @@ -1,30 +0,0 @@ --- | Properties --- --- Intended for unqualified import. --- --- Most users will probably use "Test.Tasty.Falsify" instead of this module. -module Test.Falsify.Property ( - Property' -- opaque - , Property - -- * Run generators - , gen - , genWith - -- * 'Property' features - , testFailed - , assert - , info - , discard - , label - , collect - -- * Testing shrinking - , testShrinking - , testMinimum - -- * Testing generators - , testGen - , testShrinkingOfGen - ) where - -import Test.Falsify.Internal.Property - --- | Property that uses strings as errors -type Property = Property' String diff --git a/src/Test/Falsify/Range.hs b/src/Test/Falsify/Range.hs --- a/src/Test/Falsify/Range.hs +++ b/src/Test/Falsify/Range.hs @@ -1,9 +1,15 @@ -- | Numerical ranges +-- +-- Intended for qualified import. +-- +-- > import Test.Falsify +-- > import qualified Test.Falsify.Range as Range module Test.Falsify.Range ( - Range -- opaque + Range -- * Constructors -- ** Linear - , between + , uniform + , inclusive , enum , withOrigin -- ** Non-linear @@ -11,8 +17,6 @@ -- * Queries , origin -- * Primitive constructors - , ProperFraction(..) - , Precision(..) , constant , fromProperFraction , towards @@ -21,14 +25,19 @@ ) where import Data.Bits +import Data.Functor.Identity import Data.List.NonEmpty (NonEmpty(..)) import Data.Ord +import Data.Word import qualified Data.List.NonEmpty as NE +import Data.Falsify.ProperFraction (ProperFraction(..)) +import Data.Falsify.WordN (WordN) import Test.Falsify.Internal.Range -import Data.Functor.Identity +import qualified Data.Falsify.WordN as WordN + {------------------------------------------------------------------------------- Primitive ranges -------------------------------------------------------------------------------} @@ -43,8 +52,8 @@ -- -- * for all @x <= y@, @f x <= f y@, /or/ -- * for all @x <= y@, @f y <= f x@ -fromProperFraction :: Precision -> (ProperFraction -> a) -> Range a -fromProperFraction = FromProperFraction +fromProperFraction :: WordN.Precision -> (ProperFraction -> a) -> Range a +fromProperFraction p f = FromWordN p $ f . WordN.toProperFraction -- | Generate value in any of the specified ranges, then choose the one -- that is closest to the specified origin @@ -66,16 +75,64 @@ Constructing ranges -------------------------------------------------------------------------------} --- | Uniform selection between the given bounds, shrinking towards first bound -between :: forall a. (Integral a, FiniteBits a) => (a, a) -> Range a -between = skewedBy 0 +-- | Uniform selection anywhere in the full range @[minBound .. maxBound]@ +-- +-- Shrinks towards zero. +-- +-- If you don't need specific bounds, you should probably use 'uniform' instead +-- of 'inclusive', especially for large bit sizes, because we can more easily +-- guarantee a true uniform selection here. +uniform :: forall a. (Integral a, FiniteBits a, Bounded a) => Range a +uniform = FromWordN precision $ \x -> + if isUnsigned + then toUnsigned (WordN.forgetPrecision x) + else toSigned (WordN.forgetPrecision x) + where + precision :: WordN.Precision + precision = WordN.Precision $ fromIntegral $ finiteBitSize (undefined :: a) --- | Variation on 'between' for types that are 'Enum' but not 'Integral' + isUnsigned :: Bool + isUnsigned = signum (-1 :: a) == 1 + + toUnsigned :: Word64 -> a + toUnsigned = fromIntegral + + -- For signed numbers we must be careful. Consider Int8, starting with an + -- 8-bit precision Word64. That Word64 might shrink from 255 to 254; if we + -- just cast this to Int8, the corresponding values would be -1 and -2, + -- violating the requirement that we shrink towards zero. We therefore need + -- to "reflect" the negative range. + -- + -- NOTE: 'fromIntegral' just does a bit-wise cast, e.g + -- + -- > fromIntegral (200 :: Word64) :: Int8 + -- > == (-56) + toSigned :: Word64 -> a + toSigned x + | x <= maxPos = fromIntegral x + | otherwise = (maxBound :: a) - fromIntegral x + where + -- maxBound must fit within 64-bits + -- (assuming @a@ does not exceed 64 bits, of course) + maxPos :: Word64 + maxPos = fromIntegral (maxBound :: a) + +-- | Uniform selection inclusive the given bounds, shrinking towards first bound -- +-- NOTE: There is /no/ requirement that the first bound is lower than the +-- second; indeed, @uniform (0, -1)@ and @uniform (-1, 0)@ are /different/ +-- ranges: the former shrinks towards @0@, the latter towards @-1@. +-- +-- See also 'uniform'. +inclusive :: forall a. (Integral a, FiniteBits a) => (a, a) -> Range a +inclusive = skewedBy 0 + +-- | Variation on 'inclusive' for types that are 'Enum' but not 'Integral' +-- -- This is useful for types such as 'Char'. However, since this relies on -- 'Enum', it's limited by the precision of 'Int'. enum :: Enum a => (a, a) -> Range a -enum (x, y) = toEnum <$> between (fromEnum x, fromEnum y) +enum (x, y) = toEnum <$> inclusive (fromEnum x, fromEnum y) -- | Selection within the given bounds, shrinking towards the specified origin -- @@ -92,10 +149,10 @@ = Constant x | o == x - = between (x, y) + = inclusive (x, y) | o == y - = between (y, x) + = inclusive (y, x) -- Split the range into two halves. We are careful to do this only when needed: -- if we didn't (i.e., if the origin /equals/ one of the endpoints), that would @@ -103,8 +160,8 @@ -- would be at the origin, we would only ever produce that one value. | otherwise = towards o [ - between (o, y) - , between (o, x) + inclusive (o, y) + , inclusive (o, x) ] where originInBounds :: Bool @@ -117,7 +174,7 @@ Skew To introduce skew, we want something that is reasonably simply to implement - but also has some reasonal properties. Suppose a skew of @s@ means that we + but also has some reasonable properties. Suppose a skew of @s@ means that we generate value from the lower 20% of the range 60% of the time. Then: - Symmetry around the antidiagonal: we will generate a value from the @@ -235,8 +292,8 @@ -- To avoid this heavy bias, we instead do this: -- -- > 0..............1..............2..............3 - -- > [ /\ /\ ] - -- > ^^^^^^^^^^^^^^ ^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^ + -- > [ /| /| /] + -- > ^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^ -- > 0 1 2 -- -- By insisting that the fraction is a /proper/ fraction (i.e., not equal to @@ -264,7 +321,10 @@ -- This lower bound is verified in "TestSuite.Sanity.Range", which verifies that -- for small ranges, the expected distribution is never off by more than 1% -- from the actual distribution. -precisionRequiredToRepresent :: forall a. FiniteBits a => a -> Precision +-- +-- TODO: it would be nicer to move this to "Data.Falsify.WordN", but this +-- lower bound of 7 bits is quite hacky. Ideally we'd have a better story here. +precisionRequiredToRepresent :: forall a. FiniteBits a => a -> WordN.Precision precisionRequiredToRepresent x = fromIntegral $ 7 `max` (finiteBitSize (undefined :: a) - countLeadingZeros x) @@ -274,7 +334,7 @@ -- | Origin of the range (value we shrink towards) origin :: Range a -> a -origin = runIdentity . eval (\_precision -> Identity $ ProperFraction 0) +origin = runIdentity . eval (\p -> Identity $ WordN.zero p) {------------------------------------------------------------------------------- Evaluation @@ -285,15 +345,15 @@ -- Most users will probably never need to call this function. eval :: forall f a. Applicative f - => (Precision -> f ProperFraction) -> Range a -> f a -eval genFraction = go + => (WordN.Precision -> f WordN) -> Range a -> f a +eval genWordN = go where go :: forall x. Range x -> f x go r = case r of - Constant x -> pure x - FromProperFraction p f -> f <$> genFraction p - Smallest rs -> smallest <$> sequenceA (fmap go rs) + Constant x -> pure x + FromWordN p f -> f <$> genWordN p + Smallest rs -> smallest <$> sequenceA (fmap go rs) smallest :: Ord b => NonEmpty (x, b) -> x smallest = fst . NE.head . NE.sortBy (comparing snd) diff --git a/src/Test/Falsify/Reexported/Generator/Compound.hs b/src/Test/Falsify/Reexported/Generator/Compound.hs deleted file mode 100644 --- a/src/Test/Falsify/Reexported/Generator/Compound.hs +++ /dev/null @@ -1,436 +0,0 @@ --- | Compound generators -module Test.Falsify.Reexported.Generator.Compound ( - -- * Taking advantage of 'Selective' - choose - , oneof - -- * Lists - , list - , elem - , pick - , pickBiased - -- ** Shuffling - , shuffle - , permutation - -- * Tweak test data distribution - , frequency - -- * Trees - -- ** Binary trees - , tree - , bst - -- ** Shrink trees - , IsValidShrink(..) - , ShrinkTree - , path - , pathAny - -- * Auxiliary - , shrinkToNothing - , mark - ) where - -import Prelude hiding (either, elem) - -import Control.Monad -import Control.Selective -import Data.Either (either) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe (catMaybes) -import Data.Void - -import qualified Data.List.NonEmpty as NE -import qualified Data.Tree as Rose - -import Data.Falsify.List (Permutation) -import Data.Falsify.Marked -import Data.Falsify.Tree (Tree(..), Interval(..), Endpoint(..)) -import Test.Falsify.Internal.Generator -import Test.Falsify.Internal.Generator.Shrinking (IsValidShrink(..)) -import Test.Falsify.Range (Range) -import Test.Falsify.Reexported.Generator.Shrinking -import Test.Falsify.Reexported.Generator.Simple - -import qualified Data.Falsify.List as List -import qualified Data.Falsify.Tree as Tree -import qualified Test.Falsify.Range as Range - -{------------------------------------------------------------------------------- - Taking advantage of 'Selective' --------------------------------------------------------------------------------} - --- | Generate a value with one of two generators --- --- Shrinks towards the first generator;the two generators can shrink --- independently from each other. --- --- === Background --- --- In the remainder of this docstring we give some background to this function, --- which may be useful for general understanding of the @falsify@ library. --- --- The implementation takes advantage of the that 'Gen' is a selective functor --- to ensure that the two generators can shrink independently: if the initial --- value of the generator is some @y@ produced by the second generator, later --- shrunk to some @y'@, then if the generator can shrink to @x@ at some point, --- produced by the /first/ generator, then shrinking effectively "starts over": --- the value of @x@ is independent of @y'@. --- --- That is different from doing this: --- --- > do b <- bool --- > if b then l else r --- --- In this case, @l@ and @r@ will be generated from the /same/ sample tree, --- and so cannot shrink independently. --- --- It is /also/ different from --- --- > do x <- l --- > y <- r --- > b <- bool --- > return $ if b then x else y --- --- In this case, @l@ and @r@ are run against /different/ sample trees, like we --- do here, /but/ in this case if the current value produced by the generator is --- produced by the right generator, then the sample tree used for the left --- generator will always shrink to 'Minimal' (this /must/ be possible because --- we're not currently using it); this means that we would then only be able to --- shrink to a value from the left generator if the /minimal/ value produced by --- that generator happens to work. --- --- To rephrase that last point: generating values that are not actually used --- will lead to poor shrinking, since those values can always be shrunk to their --- minimal value, independently from whatever property is being tested: the --- shrinker does not know that the value is not being used. The correct way to --- conditionally use a value is to use the selective interface, as we do here. -choose :: Gen a -> Gen a -> Gen a -choose = ifS (bool True) - --- | Generate a value with one of many generators --- --- Uniformly selects a generator and shrinks towards the first one. -oneof :: NonEmpty (Gen a) -> Gen a -oneof gens = frequency $ map (1,) $ NE.toList gens - -{------------------------------------------------------------------------------- - Auxiliary: marking elements --------------------------------------------------------------------------------} - --- | Start with @Just x@ for some @x@, then shrink to @Nothing@ -shrinkToNothing :: Gen a -> Gen (Maybe a) -shrinkToNothing g = firstThen Just (const Nothing) <*> g - --- | Mark an element, shrinking towards 'Drop' --- --- This is similar to 'shrinkToNothing', except that 'Marked' still has a value --- in the 'Drop' case: marks are merely hints, that we may or may not use. -mark :: Gen a -> Gen (Marked Gen a) -mark x = flip Marked x <$> firstThen Keep Drop - -{------------------------------------------------------------------------------- - Lists --------------------------------------------------------------------------------} - --- | Generate list of specified length --- --- Shrinking behaviour: --- --- * The length of the list will shrink as specified by the given range. --- * We can drop random elements from the list, but prefer to drop them --- from near the /end/ of the list. --- --- Note on shrinking predictability: in the case that the specified 'Range' has --- an origin which is neither the lower bound nor the upper bound (and only in --- that case), 'list' can have confusing shrinking behaviour. For example, --- suppose we have a range @(0, 10)@ with origin 5. Then we could start by --- generating an intermediate list of length of 10 and then subsequently drop 5 --- elements from that, resulting in an optimal list length. However, we can now --- shrink that length from 10 to 2 (which is closer to 5, after all), but now we --- only have 2 elements to work with, and hence the generated list will now drop --- from 5 elements to 2. This is not necessarily a problem, because that length --- 2 can now subsequently shrink further towards closer to the origin (5), but --- nonetheless it might result in confusing intermediate shrinking steps. -list :: Range Word -> Gen a -> Gen [a] -list len gen = do - -- We do /NOT/ mark this call to 'inRange' as 'withoutShrinking': it could - -- shrink towards larger values, in which case we really need to generate - -- more elements. This doesn't really have any downsides: it merely means - -- that we would prefer to shrink towards a prefix of the list first, before - -- we try to drop random other elements from the list. - -- - -- If we have an expression such as @(,) <$> list .. <*> list@, the two - -- lists will be shrunk independently from each other due to the branching - -- point above them. Hence, it doesn't matter if first generator uses "fewer - -- samples" as it shrinks. - n <- inRange len - - -- Generate @n@ marks, indicating for each element if we want to keep that - -- element or not, so that we can drop elements from the middle of the list. - -- - -- Due to the left-biased nature of shrinking, this will shrink towards - -- dropped elements (@False@ values) near the start, but we want them near - -- the /end/, so we reverse the list. - marks <- fmap (List.keepAtLeast (Range.origin len) . reverse) $ - replicateM (fromIntegral n) $ mark gen - - -- Finally, generate the elements we want to keep - catMaybes <$> selectAllKept marks - --- | Choose random element --- --- Shrinks towards earlier elements. --- --- NOTE: Does not work on infinite lists (it computes the length of the list). -elem :: NonEmpty a -> Gen a -elem = fmap (\(_before, x, _after) -> x) . pick - --- | Generalization of 'elem' that additionally returns the parts of the list --- before and after the element -pick :: NonEmpty a -> Gen ([a], a, [a]) -pick = \xs -> - aux [] (NE.toList xs) <$> - inRange (Range.between (0, length xs - 1)) - where - aux :: [a] -> [a] -> Int -> ([a], a, [a]) - aux _ [] _ = error "pick: impossible" - aux prev (x:xs) 0 = (reverse prev, x, xs) - aux prev (x:xs) i = aux (x:prev) xs (i - 1) - --- | Choose random element from a list --- --- This is different from 'elem': it avoids first computing the length of the --- list, and is biased towards elements earlier in the list. The advantage is --- that this works for infinite lists, too. --- --- Also returns the elements from the list before and after the chosen element. -pickBiased :: NonEmpty a -> Gen ([a], a, [a]) -pickBiased = \xs -> pickChunk [] (List.chunksOfNonEmpty chunkSize xs) - where - chunkSize :: Word - chunkSize = 1_000 - - -- We want to avoid computing the length of the list, but equally we don't - -- want to skew /too/ heavily towards the start of the list. Therefore we - -- chunk the list (this is lazy), then flip a coin for each chunk, and once - -- we find a chunk, do an unbiased choice within that chunk. - pickChunk :: [NonEmpty a] -> NonEmpty (NonEmpty a) -> Gen ([a], a, [a]) - pickChunk prev (chunk :| []) = do - -- No choice left: we must generate use this chunk - withChunk prev chunk [] - pickChunk prev (chunk :| next@(n:ns)) = do - useChunk <- bool True - if useChunk - then withChunk prev chunk next - else pickChunk (chunk:prev) (n :| ns) - - withChunk :: [NonEmpty a] -> NonEmpty a -> [NonEmpty a] -> Gen ([a], a, [a]) - withChunk prev chunk next = do - (chunkBefore, chunkElem, chunkAfter) <- pick chunk - return ( - concat $ reverse $ chunkBefore : map NE.toList prev - , chunkElem - , chunkAfter ++ concatMap NE.toList next - ) - -{------------------------------------------------------------------------------- - Tweak test data distribution --------------------------------------------------------------------------------} - --- | Choose generator with the given frequency --- --- For example, --- --- > frequency [ --- > (1, genA) --- > , (2, genB) --- > ] --- --- will use @genA@ 1/3rd of the time, and @genB@ 2/3rds. --- --- Shrinks towards generators earlier in the list; the generators themselves --- are independent from each other (shrinking of @genB@ does not affect --- shrinking of @genA@). --- --- Precondition: there should at least one generator with non-zero frequency. -frequency :: forall a. [(Word, Gen a)] -> Gen a -frequency gens = - case filter ((/= 0) . fst) indexedGens of - [] -> error "frequency: no generators with non-zero frequency" - gens' -> do - let r :: Range Word - r = Range.between (0, sum (map fst gens') - 1) - (gen, genIx) <- (\i -> frequencyLookup i gens') <$> inRange r - perturb genIx gen - where - -- We need to be careful: we don't want to perturb the generator by the - -- value generated by 'inRange', because many different values could - -- correspond to the /same/ generator. Instead, we assign each generator its - -- own index, and use that instead. - indexedGens :: [(Word, (Gen a, Word))] - indexedGens = zipWith (\(f, g) i -> (f, (g, i))) gens [0..] - --- | Internal auxiliary to 'frequency' -frequencyLookup :: Word -> [(Word, x)] -> x -frequencyLookup = \i xs -> - case go i xs of - Just x -> x - Nothing -> - error $ concat [ - "frequencyLookup: index " - , show i - , " out of range of " - , show (map fst xs) - ] - where - go :: Word -> [(Word, x)] -> Maybe x - go _ [] = Nothing - go i ((n, x):xs) - | i < n = Just x - | otherwise = go (i - n) xs - -{------------------------------------------------------------------------------- - Shuffling --------------------------------------------------------------------------------} - --- | Shuffle list (construct a permutation) --- --- Shrinking behaviour: 'shuffle' is defined in terms of 'permutation', which --- provides some guarantees: it shrinks towards making changes near the /start/ --- of the list, and towards swapping /fewer/ elements of the list. --- --- It is difficult to define precisely how this affects the resulting list, but --- we /can/ say that if for a particular counter-example it suffices if two --- lists are different in /one/ element, then the shuffled list will in fact --- only be different in /one/ place from the original, and that one element will --- have been swapped with an immediate neighbour. -shuffle :: [a] -> Gen [a] -shuffle xs = - flip List.applyPermutation xs <$> - permutation (fromIntegral $ length xs) - --- | Generate permutation for a list of length @n@ --- --- This is essentially an implemention of Fisher-Yates, in that we generate a --- series of swaps (i, j), with 1 <= i <= n - 1 and @0 <= j <= i@, except that --- --- * We can shrink a choice of @i@ (towards 1). --- * We can drop arbitrary swaps. --- --- This ensures that we shrink towards making swaps nearer the /start/ of the --- list, as well as towards /fewer/ swaps. --- --- We make no attempt to make the permutation canonical; doing so makes it --- extremely difficult to get predicable shrinking behaviour. -permutation :: Word -> Gen Permutation -permutation 0 = return [] -permutation 1 = return [] -permutation n = do - swaps <- mapM (mark . genSwap) [n - 1, n - 2 .. 1] - catMaybes <$> selectAllKept swaps - where - genSwap :: Word -> Gen (Word, Word) - genSwap i = do - i' <- inRange $ Range.between (1, i) - j <- inRange $ Range.between (i, 0) - return (i', min i' j) - -{------------------------------------------------------------------------------- - Binary trees --------------------------------------------------------------------------------} - --- | Generate binary tree -tree :: forall a. Range Word -> Gen a -> Gen (Tree a) -tree size gen = do - n <- inRange size - t <- Tree.keepAtLeast (Range.origin size) . Tree.propagate <$> go n - Tree.genKept t - where - go :: Word -> Gen (Tree (Marked Gen a)) - go 0 = return Leaf - go n = do - -- Generate element at the root - x <- mark gen - - -- Choose how many elements to put in the left subtree - -- - -- This ranges from none (right-biased) to all (left-biased), shrinking - -- towards half the number of elements: hence, towards a balanced tree. - inLeft <- inRange $ Range.withOrigin (0, n - 1) ((n - 1) `div` 2) - let inRight = (n - 1) - inLeft - Branch x <$> go inLeft <*> go inRight - --- | Construct binary search tree --- --- Shrinks by replacing entire subtrees by the empty tree. -bst :: forall a b. Integral a => (a -> Gen b) -> Interval a -> Gen (Tree (a, b)) -bst gen = go >=> traverse (\a -> (a,) <$> gen a) - where - go :: Interval a -> Gen (Tree a) - go i = - case Tree.inclusiveBounds i of - Nothing -> pure Leaf - Just (lo, hi) -> firstThen id (const Leaf) <*> go' lo hi - - -- inclusive bounds, lo <= hi - go' :: a -> a -> Gen (Tree a) - go' lo hi = Branch mid - <$> go (Interval (Inclusive lo) (Exclusive mid)) - <*> go (Interval (Exclusive mid) (Inclusive hi)) - where - mid :: a - mid = lo + ((hi - lo) `div` 2) - -{------------------------------------------------------------------------------- - Shrink trees --------------------------------------------------------------------------------} - -type ShrinkTree = Rose.Tree - --- | Generate semi-random path through the tree --- --- Will only construct paths that satisfy the given predicate (typically, a --- property that is being tested). --- --- Shrinks towards shorter paths, and towards paths that use subtrees that --- appear earlier in the list of subtrees at any node in the tree. --- --- See also 'pathAny'. -path :: forall a p n. - (a -> IsValidShrink p n) -- ^ Predicate - -> ShrinkTree a - -> Gen (Either n (NonEmpty p)) -path validShrink = \(Rose.Node a as) -> - case validShrink a of - InvalidShrink n -> pure $ Left n - ValidShrink p -> Right <$> go p as - where - -- We only want to pick a shrunk value that matches the predicate, but we - -- potentially waste a /lot/ of work if we first evaluate the predicate for - -- /all/ potential shrunk values and then choose. So, instead we choose - -- first, evaluate the predicate, and if it fails, choose again. - go :: p -> [Rose.Tree a] -> Gen (NonEmpty p) - go p [] = pure (p :| []) - go p (a:as) = do - (before, a', after) <- pickBiased (a :| as) - - case checkPred a' of - Nothing -> - -- Not a valid shrink step. Pick a different one. - go p (before ++ after) - Just (p', as') -> - -- Found a valid shrink step. - -- - -- We only call @choose@ once we found a valid shrink step, - -- otherwise we would skew very heavily towards shorter paths. - choose - (pure (p :| [])) - (NE.cons p <$> go p' as') - - checkPred :: Rose.Tree a -> Maybe (p, [Rose.Tree a]) - checkPred (Rose.Node a as) = - case validShrink a of - InvalidShrink _ -> Nothing - ValidShrink b -> Just (b, as) - --- | Variation on 'path' without a predicate. -pathAny :: ShrinkTree a -> Gen (NonEmpty a) -pathAny = fmap (either absurd id) . path ValidShrink - diff --git a/src/Test/Falsify/Reexported/Generator/Function.hs b/src/Test/Falsify/Reexported/Generator/Function.hs deleted file mode 100644 --- a/src/Test/Falsify/Reexported/Generator/Function.hs +++ /dev/null @@ -1,393 +0,0 @@ -module Test.Falsify.Reexported.Generator.Function ( - Fun -- opaque - , applyFun - , pattern Fn - , pattern Fn2 - , pattern Fn3 - -- * Generation - , fun - -- * Construction - , Function(..) - , (:->) -- opaque - , functionMap - ) where - -import Prelude hiding (sum) - -import Control.Monad -import Data.Bifunctor -import Data.Char -import Data.Foldable (toList) -import Data.Int -import Data.Kind -import Data.List (intercalate) -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Ratio (Ratio) -import Data.Word -import GHC.Generics -import Numeric.Natural - -import qualified Data.Ratio as Ratio - -import Data.Falsify.Tree (Tree, Interval(..), Endpoint(..)) -import Test.Falsify.Internal.Generator (Gen) -import Test.Falsify.Reexported.Generator.Shrinking -import Test.Falsify.Reexported.Generator.Compound - -import qualified Data.Falsify.Tree as Tree - -{------------------------------------------------------------------------------- - Functions that can be shrunk and shown --------------------------------------------------------------------------------} - --- | Function @a -> b@ which can be shown, generated, and shrunk -data Fun a b = Fun { - concrete :: a :-> b - , defaultValue :: b - - -- Since functions are typically infinite, they can only safely be shown - -- once they are fully shrunk: after all, once a function has been fully - -- shrunk, we /know/ it must be finite, because in any given property, a - -- function will only ever be applied a finite number of times. - , isFullyShrunk :: Bool - } - deriving (Functor) - --- | Generate function @a -> b@ given a generator for @b@ -fun :: Function a => Gen b -> Gen (Fun a b) -fun gen = do - -- Generate value first, so that we try to shrink that first - defaultValue <- gen - concrete <- function gen - isFullyShrunk <- firstThen False True - return Fun{concrete, defaultValue, isFullyShrunk} - -{------------------------------------------------------------------------------- - Concrete functions - - NOTE: @Nil@ is useful as a separate constructor, since it does not have an - @Eq@ constraint. --------------------------------------------------------------------------------} - -data (:->) :: Type -> Type -> Type where - Nil :: a :-> b - Unit :: a -> () :-> a - Table :: Ord a => Tree (a, Maybe b) -> a :-> b - Sum :: (a :-> c) -> (b :-> c) -> (Either a b :-> c) - Prod :: (a :-> (b :-> c)) -> (a, b) :-> c - Map :: (b -> a) -> (a -> b) -> (a :-> c) -> (b :-> c) - -instance Functor ((:->) a) where - fmap _ Nil = Nil - fmap f (Unit x) = Unit (f x) - fmap f (Table xs) = Table (fmap (second (fmap f)) xs) - fmap f (Sum x y) = Sum (fmap f x) (fmap f y) - fmap f (Prod x) = Prod (fmap (fmap f) x) - fmap f (Map ab ba x) = Map ab ba (fmap f x) - --- | The basic building block for 'Function' instances --- --- Provides a 'Function' instance by mapping to and from a type that --- already has a 'Function' instance. -functionMap :: (b -> a) -> (a -> b) -> (a :-> c) -> b :-> c -functionMap = Map - --- | Apply concrete function -abstract :: (a :-> b) -> b -> (a -> b) -abstract Nil d _ = d -abstract (Unit x) _ _ = x -abstract (Prod p) d (x,y) = abstract (fmap (\q -> abstract q d y) p) d x -abstract (Sum p q) d exy = either (abstract p d) (abstract q d) exy -abstract (Table xys) d x = fromMaybe d . join $ Tree.lookup x xys -abstract (Map g _ p) d x = abstract p d (g x) - -{------------------------------------------------------------------------------- - Patterns - - These are analogue to their counterparts in QuickCheck. --------------------------------------------------------------------------------} - --- | Pattern synonym useful when generating functions of one argument -pattern Fn :: (a -> b) -> Fun a b -pattern Fn f <- (applyFun -> f) - --- | Pattern synonym useful when generating functions of two arguments -pattern Fn2 :: (a -> b -> c) -> Fun (a, b) c -pattern Fn2 f <- (applyFun2 -> f) - --- | Pattern synonym useful when generating functions of three arguments -pattern Fn3 :: (a -> b -> c -> d) -> Fun (a, b, c) d -pattern Fn3 f <- (applyFun3 -> f) - --- | Apply function to argument --- --- See also the 'Fn', 'Fn2', and 'Fn3' patter synonyms. -applyFun :: Fun a b -> a -> b -applyFun Fun{concrete, defaultValue} = abstract concrete defaultValue - -applyFun2 :: Fun (a, b) c -> (a -> b -> c) -applyFun2 f a b = applyFun f (a, b) - -applyFun3 :: Fun (a, b, c) d -> (a -> b -> c -> d) -applyFun3 f a b c = applyFun f (a, b, c) - -{-# COMPLETE Fn #-} -{-# COMPLETE Fn2 #-} -{-# COMPLETE Fn3 #-} - -{------------------------------------------------------------------------------- - Constructing concrete functions --------------------------------------------------------------------------------} - -shrinkToNil :: Gen (a :-> b) -> Gen (a :-> b) -shrinkToNil gen = fromMaybe Nil <$> shrinkToNothing gen - -table :: forall a b. (Integral a, Bounded a) => Gen b -> Gen (a :-> b) -table gen = Table <$> bst (\_a -> shrinkToNothing gen) i - where - i :: Interval a - i = Interval (Inclusive minBound) (Inclusive maxBound) - -unit :: Gen c -> Gen (() :-> c) -unit gen = shrinkToNil (Unit <$> gen) - -sum :: - (Gen c -> Gen ( a :-> c)) - -> (Gen c -> Gen ( b :-> c)) - -> (Gen c -> Gen (Either a b :-> c)) -sum f g gen = Sum <$> shrinkToNil (f gen) <*> shrinkToNil (g gen) - -prod :: - (forall c. Gen c -> Gen ( a :-> c)) - -> (forall c. Gen c -> Gen ( b :-> c)) - -> (forall c. Gen c -> Gen ((a, b) :-> c)) -prod f g = fmap Prod . f . g - -{------------------------------------------------------------------------------- - Show functions --------------------------------------------------------------------------------} - -instance (Show a, Show b) => Show (Fun a b) where - show Fun{concrete, defaultValue, isFullyShrunk} - | isFullyShrunk = showFunction concrete defaultValue - | otherwise = "" - --- | Show concrete function --- --- Only use this on finite functions. -showFunction :: (Show a, Show b) => (a :-> b) -> b -> String -showFunction p d = concat [ - "{" - , intercalate ", " $ concat [ - [ show x ++ "->" ++ show c - | (x,c) <- toTable p - ] - , ["_->" ++ show d] - ] - , "}" - ] - --- | Generating a table from a concrete function --- --- This is only used in the 'Show' instance. -toTable :: (a :-> b) -> [(a, b)] -toTable Nil = [] -toTable (Unit x) = [((), x)] -toTable (Prod p) = [ ((x,y),c) | (x,q) <- toTable p, (y,c) <- toTable q ] -toTable (Sum p q) = [ (Left x, c) | (x,c) <- toTable p ] - ++ [ (Right y,c) | (y,c) <- toTable q ] -toTable (Table xys) = mapMaybe (\(a, b) -> (a,) <$> b) $ toList xys -toTable (Map _ h p) = [ (h x, c) | (x,c) <- toTable p ] - -{------------------------------------------------------------------------------- - Class to construct functions --------------------------------------------------------------------------------} - --- | Generating functions -class Function a where - -- | Build reified function - -- - -- '(:->)' is an abstract type; if you need to add additional 'Function' - -- instances, you need to use 'functionMap', or rely on the default - -- implementation in terms of generics. - function :: Gen b -> Gen (a :-> b) - - default function :: (Generic a, GFunction (Rep a)) => Gen b -> Gen (a :-> b) - function gen = functionMap from to <$> gFunction gen - -instance Function Word8 where function = table -instance Function Int8 where function = table - -instance Function Int where function = integral -instance Function Int16 where function = integral -instance Function Int32 where function = integral -instance Function Int64 where function = integral -instance Function Word where function = integral -instance Function Word16 where function = integral -instance Function Word32 where function = integral -instance Function Word64 where function = integral -instance Function Integer where function = integral -instance Function Natural where function = integral - -instance Function Float where function = realFrac -instance Function Double where function = realFrac - -instance (Integral a, Function a) => Function (Ratio a) where - function = fmap (functionMap toPair fromPair) . function - where - toPair :: Ratio a -> (a, a) - toPair r = (Ratio.numerator r, Ratio.denominator r) - - fromPair :: (a, a) -> Ratio a - fromPair (n, d) = n Ratio.% d - -instance Function Char where - function = fmap (functionMap ord chr) . function - --- instances that depend on generics - -instance Function () -instance Function Bool - -instance (Function a, Function b) => Function (Either a b) - -instance Function a => Function [a] -instance Function a => Function (Maybe a) - --- Tuples (these are also using generics) - --- 2 -instance - ( Function a - , Function b - ) - => Function (a, b) - --- 3 -instance - ( Function a - , Function b - , Function c - ) - => Function (a, b, c) - --- 4 -instance - ( Function a - , Function b - , Function c - , Function d - ) - => Function (a, b, c, d) - --- 5 -instance - ( Function a - , Function b - , Function c - , Function d - , Function e - ) - => Function (a, b, c, d, e) - --- 6 -instance - ( Function a - , Function b - , Function c - , Function d - , Function e - , Function f - ) - => Function (a, b, c, d, e, f) - --- 7 -instance - ( Function a - , Function b - , Function c - , Function d - , Function e - , Function f - , Function g - ) - => Function (a, b, c, d, e, f, g) - -{------------------------------------------------------------------------------- - Support for numbers --------------------------------------------------------------------------------} - -integral :: Integral a => Gen b -> Gen (a :-> b) -integral = - fmap (functionMap - (fmap bytes . toSignedNatural . toInteger) - (fromInteger . fromSignedNatural . fmap unbytes) - ) - . function - where - bytes :: Natural -> [Word8] - bytes 0 = [] - bytes n = fromIntegral (n `mod` 256) : bytes (n `div` 256) - - unbytes :: [Word8] -> Natural - unbytes [] = 0 - unbytes (w:ws) = fromIntegral w + 256 * unbytes ws - -realFrac :: RealFrac a => Gen b -> Gen (a :-> b) -realFrac = fmap (functionMap toRational fromRational) . function - -data Signed a = Pos a | Neg a - deriving stock (Show, Functor, Generic) - deriving anyclass (Function) - -toSignedNatural :: Integer -> Signed Natural -toSignedNatural n - | n < 0 = Neg (fromInteger (abs n - 1)) - | otherwise = Pos (fromInteger n) - -fromSignedNatural :: Signed Natural -> Integer -fromSignedNatural (Neg n) = negate (toInteger n + 1) -fromSignedNatural (Pos n) = toInteger n - -{------------------------------------------------------------------------------- - Generic support for 'Function' --------------------------------------------------------------------------------} - -class GFunction f where - gFunction :: Gen b -> Gen (f p :-> b) - -instance GFunction f => GFunction (M1 i c f) where - gFunction = fmap (functionMap unM1 M1) . gFunction @f - -instance GFunction U1 where - gFunction = fmap (functionMap unwrap wrap) . unit - where - unwrap :: U1 p -> () - unwrap _ = () - - wrap :: () -> U1 p - wrap _ = U1 - -instance (GFunction f, GFunction g) => GFunction (f :*: g) where - gFunction = fmap (functionMap unwrap wrap) . prod (gFunction @f) (gFunction @g) - where - unwrap :: (f :*: g) p -> (f p, g p) - unwrap (x :*: y) = (x, y) - - wrap :: (f p, g p) -> (f :*: g) p - wrap (x, y) = x :*: y - -instance (GFunction f, GFunction g) => GFunction (f :+: g) where - gFunction = - fmap (functionMap unwrap wrap) . sum (gFunction @f) (gFunction @g) - where - unwrap :: (f :+: g) p -> Either (f p) (g p) - unwrap (L1 x) = Left x - unwrap (R1 y) = Right y - - wrap :: Either (f p) (g p) -> (f :+: g) p - wrap (Left x) = L1 x - wrap (Right y) = R1 y - -instance Function a => GFunction (K1 i a) where - gFunction = fmap (functionMap unK1 K1) . function @a diff --git a/src/Test/Falsify/Reexported/Generator/Precision.hs b/src/Test/Falsify/Reexported/Generator/Precision.hs deleted file mode 100644 --- a/src/Test/Falsify/Reexported/Generator/Precision.hs +++ /dev/null @@ -1,84 +0,0 @@ --- | Fixed precision generators -module Test.Falsify.Reexported.Generator.Precision ( - -- * @n@-bit words - WordN(..) - , wordN - -- ** Fractions - , properFraction - ) where - -import Prelude hiding (properFraction) - -import Data.Bits -import Data.Word -import GHC.Stack - -import Test.Falsify.Internal.Generator -import Test.Falsify.Internal.Range -import Test.Falsify.Internal.SampleTree (sampleValue) -import Test.Falsify.Internal.Search - -{------------------------------------------------------------------------------- - @n@-bit word --------------------------------------------------------------------------------} - --- | @n@-bit word -data WordN = WordN Precision Word64 - deriving (Show, Eq, Ord) - -forgetPrecision :: WordN -> Word64 -forgetPrecision (WordN _ x) = x - --- | Make @n@-bit word (@n <= 64@) --- --- Bits outside the requested precision will be zeroed. --- --- We use this to generate random @n@-bit words from random 64-bit words. --- It is important that we /truncate/ rather than /cap/ the value: capping the --- value (limiting it to a certain maximum) would result in a strong bias --- towards that maximum value. --- --- Of course, /shrinking/ of a Word64 bit does not translate automatically to --- shrinking of the lower @n@ bits of that word (a decrease in the larger --- 'Word64' may very well be an /increase/ in the lower @n@ bits), so this must --- be taken into account. -truncateAt :: Precision -> Word64 -> WordN -truncateAt desiredPrecision x = - WordN actualPrecision (x .&. mask actualPrecision) - where - maximumPrecision, actualPrecision :: Precision - maximumPrecision = Precision 64 - actualPrecision = min desiredPrecision maximumPrecision - - -- Maximum possible value - -- - -- If @n == 64@ then @2 ^ n@ will overflow, but it will overflow to @0@, and - -- @(-1) :: Word64 == maxBound@; so no need to treat this case separately. - mask :: Precision -> Word64 - mask (Precision n) = 2 ^ n - 1 - --- | Uniform selection of @n@-bit word of given precision, shrinking towards 0 -wordN :: Precision -> Gen WordN -wordN p = - fmap (truncateAt p . sampleValue) . primWith $ - binarySearch - . forgetPrecision - . truncateAt p - . sampleValue - -{------------------------------------------------------------------------------- - Fractions --------------------------------------------------------------------------------} - --- | Compute fraction from @n@-bit word -mkFraction :: WordN -> ProperFraction -mkFraction (WordN (Precision p) x) = - ProperFraction $ (fromIntegral x) / (2 ^ p) - --- | Uniform selection of fraction, shrinking towards 0 --- --- Precondition: precision must be at least 1 bit (a zero-bit number is constant --- 0; it is meaningless to have a fraction in a point range). -properFraction :: HasCallStack => Precision -> Gen ProperFraction -properFraction (Precision 0) = error "fraction: 0 precision" -properFraction p = mkFraction <$> wordN p diff --git a/src/Test/Falsify/Reexported/Generator/Shrinking.hs b/src/Test/Falsify/Reexported/Generator/Shrinking.hs deleted file mode 100644 --- a/src/Test/Falsify/Reexported/Generator/Shrinking.hs +++ /dev/null @@ -1,128 +0,0 @@ -module Test.Falsify.Reexported.Generator.Shrinking ( - -- * User-specified shrinking - shrinkToOneOf - , firstThen - , shrinkWith - -- * Support for shrink trees - , fromShrinkTree - , toShrinkTree - ) where - -import Prelude hiding (properFraction) - -import Data.Word - -import qualified Data.Tree as Rose - -import Test.Falsify.Internal.Generator -import Test.Falsify.Internal.SampleTree (Sample(..), SampleTree) - -{------------------------------------------------------------------------------- - Specialized shrinking behaviour --------------------------------------------------------------------------------} - --- | Start with @x@, then shrink to one of the @xs@ --- --- Once shrunk, will not shrink again. --- --- Minimal value is the first shrunk value, if it exists, and the original --- otherwise. -shrinkToOneOf :: forall a. a -> [a] -> Gen a -shrinkToOneOf x xs = - aux <$> primWith shrinker - where - aux :: Sample -> a - aux (NotShrunk _) = x - aux (Shrunk i) = index i xs - - -- When we shrink, we will try a bunch of new sample trees; we must ensure - -- that we can try /any/ of the possible shrunk values. - -- - -- We use this to implement 'fromShrinkTree'. Here, we explore a rose tree - -- of possibilities; at every level in the tree, once we make a choice, - -- we should commit to that choice and not consider it over and over again. - -- Thus, once shrunk, we should not shrink any further. - shrinker :: Sample -> [Word64] - shrinker (Shrunk _) = [] - shrinker (NotShrunk _) = zipWith const [0..] xs - - -- Index the list of possible shrunk values. This is a bit like @(!!)@ from - -- the prelude, but with some edge cases. - -- - -- - If the list is empty, we return the unshrunk value. - -- - Otherwise, if the index exceeds the bounds, we return the last element. - -- - -- These two special cases can arise in one of two circumstances: - -- - -- - When we run the generator against the 'Minimal' tree. This will give us - -- a @Shrunk 0@ value, independent of what the specified shrinking - -- function does, and it is important that we produce the right value. - -- - When the generator is run against a sample tree that was shrunk wrt to - -- a /different/ generator. In this case the value could be anything; - -- we return the final ("least preferred") element, and then rely on - -- later shrinking to replace this with a more preferred element. - index :: Word64 -> [a] -> a - index _ [] = x - index _ [y] = y - index 0 (y:_) = y - index n (_:ys) = index (n - 1) ys - --- | Generator that always produces @x@ as initial value, and shrinks to @y@ -firstThen :: forall a. a -> a -> Gen a -firstThen x y = x `shrinkToOneOf` [y] - --- | Shrink with provided shrinker --- --- This provides compatibility with QuickCheck-style manual shrinking. --- --- Defined in terms of 'fromShrinkTree'; see discussion there for some --- notes on performance. -shrinkWith :: forall a. (a -> [a]) -> Gen a -> Gen a -shrinkWith f gen = do - -- It is critical that we do not apply normal shrinking of the 'SampleTree' - -- here (not even to 'Minimal'). If we did, then the resulting shrink tree - -- would change, and we would be unable to iteratively construct a path - -- through the shrink tree. - -- - -- Of course, it can still happen that the generator gets reapplied in a - -- different context; we must take this case into account in - -- 'shrinkToOneOf'. - x <- withoutShrinking gen - fromShrinkTree $ Rose.unfoldTree (\x' -> (x', f x')) x - -{------------------------------------------------------------------------------- - Shrink trees --------------------------------------------------------------------------------} - --- | Construct generator from shrink tree --- --- This provides compatibility with Hedgehog-style integrated shrinking. --- --- This is O(n^2) in the number of shrink steps: as this shrinks, the generator --- is growing a path of indices which locates a particular value in the shrink --- tree (resulting from unfolding the provided shrinking function). At each --- step during the shrinking process the shrink tree is re-evaluated and the --- next value in the tree is located; since this path throws linearly, the --- overall cost is O(n^2). --- --- The O(n^2) cost is only incurred on /locating/ the next element to be tested; --- the property is not reevaluated at already-shrunk values. -fromShrinkTree :: forall a. Rose.Tree a -> Gen a -fromShrinkTree = go - where - go :: Rose.Tree a -> Gen a - go (Rose.Node x xs) = do - next <- Nothing `shrinkToOneOf` map Just xs - case next of - Nothing -> return x - Just x' -> go x' - --- | Expose the full shrink tree of a generator --- --- This generator does not shrink. -toShrinkTree :: forall a. Gen a -> Gen (Rose.Tree a) -toShrinkTree gen = - Rose.unfoldTree aux . runGen gen <$> captureLocalTree - where - aux :: (a, [SampleTree]) -> (a,[(a, [SampleTree])]) - aux (x, shrunk) = (x, map (runGen gen) shrunk) diff --git a/src/Test/Falsify/Reexported/Generator/Simple.hs b/src/Test/Falsify/Reexported/Generator/Simple.hs deleted file mode 100644 --- a/src/Test/Falsify/Reexported/Generator/Simple.hs +++ /dev/null @@ -1,64 +0,0 @@ --- | Simple (i.e., non-compound) generators -module Test.Falsify.Reexported.Generator.Simple ( - bool - , inRange - , integral - , enum - , int - ) where - -import Prelude hiding (properFraction) - -import Data.Bits -import Data.Word - -import Test.Falsify.Internal.Generator -import Test.Falsify.Internal.Range -import Test.Falsify.Internal.SampleTree (Sample(..), sampleValue) -import Test.Falsify.Reexported.Generator.Precision - -import qualified Test.Falsify.Range as Range - -{------------------------------------------------------------------------------- - Simple generators --------------------------------------------------------------------------------} - --- | Generate random bool, shrink towards the given value --- --- Chooses with equal probability between 'True' and 'False'. -bool :: Bool -> Gen Bool -bool target = aux . sampleValue <$> primWith shrinker - where - aux :: Word64 -> Bool - aux x | msbSet x = not target - | otherwise = target - - msbSet :: forall a. FiniteBits a => a -> Bool - msbSet x = testBit x (finiteBitSize (undefined :: a) - 1) - - shrinker :: Sample -> [Word64] - shrinker (Shrunk 0) = [] - shrinker _ = [0] - -{------------------------------------------------------------------------------- - Integral ranges --------------------------------------------------------------------------------} - --- | Generate value in the specified range -inRange :: Range a -> Gen a -inRange r = Range.eval properFraction r - --- | Deprecated alias for 'inRange' -integral :: Range a -> Gen a -{-# DEPRECATED integral "Use inRange instead" #-} -integral = inRange - --- | Deprecated alias for 'inRange' -enum :: Range a -> Gen a -{-# DEPRECATED enum "Use inRange instead" #-} -enum = inRange - --- | Type-specialization of 'inRange' -int :: Range Int -> Gen Int -int = inRange - diff --git a/src/Test/Falsify/SampleTree.hs b/src/Test/Falsify/SampleTree.hs new file mode 100644 --- /dev/null +++ b/src/Test/Falsify/SampleTree.hs @@ -0,0 +1,156 @@ +-- | Sample tree +-- +-- Intended for qualified import. +-- +-- > import Test.Falsify.SampleTree (SampleTree(..), pattern Inf, Sample(..)) +-- > import qualified Test.Falsify.SampleTree as SampleTree +module Test.Falsify.SampleTree ( + -- * Definition + SampleTree(..) + , Sample(..) + , pattern Inf + , sampleValue + -- * Construction + , fromPRNG + , fromSeed + , minimal + , constant + -- * Combinators + , map + , mod + ) where + +import Prelude hiding (map, mod) +import qualified Prelude + +import Data.Word +import System.Random.SplitMix + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | Sample tree +-- +-- A sample tree is a (conceptually and sometimes actually) infinite tree +-- representing drawing values from and splitting a PRNG. +data SampleTree = + -- | Default constructor + -- + -- The type of ST is really + -- + -- > ST :: Word64 & (SampleTree * SampleTree) -> SampleTree + -- + -- where @(&)@ is the additive conjunction from linear logic. In other + -- words, the intention is that /either/ the @Word64@ is used, /or/ + -- the pair of subtrees; put another way, we /either/ draw a value from the + -- PRNG, /or/ split it into two new PRNGs. + SampleTree Sample SampleTree SampleTree + + -- | Minimal tree (0 everywhere) + -- + -- This constructor allows us to represent an infinite tree in a finite way + -- and, importantly, /recognize/ a tree that is minimal everywhere. This is + -- necessary when shrinking in the context of generators that generate + -- infinitely large values. + | Minimal + deriving (Show) + +-- | Sample +-- +-- The samples in the t'SampleTree' record if they were the originally produced +-- sample, or whether they have been shrunk. +data Sample = + NotShrunk Word64 + | Shrunk Word64 + deriving (Show, Eq, Ord) + +{------------------------------------------------------------------------------- + Views +-------------------------------------------------------------------------------} + +-- | Value of the sample +-- +-- Samples differentiate between 'NotShrunk' and 'Shrunk', but for most use +-- cases this distinction does not matter. +sampleValue :: Sample -> Word64 +sampleValue (NotShrunk s) = s +sampleValue (Shrunk s) = s + +view :: SampleTree -> (Sample, SampleTree, SampleTree) +view Minimal = (Shrunk 0, Minimal, Minimal) +view (SampleTree s l r) = (s, l, r) + +-- | Pattern synonym for treating the sample tree as infinite +pattern Inf :: Sample -> SampleTree -> SampleTree -> SampleTree +pattern Inf s l r <- (view -> (s, l, r)) + +{-# COMPLETE Inf #-} + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +-- | Construct t'SampleTree' from splittable PRNG +fromPRNG :: SMGen -> SampleTree +fromPRNG = go + where + go :: SMGen -> SampleTree + go g = + let (n, _) = nextWord64 g + (l, r) = splitSMGen g + in SampleTree (NotShrunk n) (go l) (go r) + +-- | Consruct t'SampleTree' from initial seed +-- +-- The seed will be used to initialize an 'SMGen' +fromSeed :: Word64 -> SampleTree +fromSeed = fromPRNG . mkSMGen + +-- | Minimal sample tree +-- +-- Generators should produce the \"simplest\" value when given this tree, +-- for some suitable application-specific definition of \"simple\". +minimal :: SampleTree +minimal = Minimal + +-- | Sample tree that is the given value everywhere +-- +-- This is primarily useful for debugging. +constant :: Word64 -> SampleTree +constant s = go + where + go :: SampleTree + go = SampleTree (NotShrunk s) go go + +{------------------------------------------------------------------------------- + Combinators +-------------------------------------------------------------------------------} + +-- | Map function over all random samples in the tree +-- +-- Precondition: the function must preserve zeros: +-- +-- > f 0 == 0 +-- +-- This means that we have +-- +-- > map f M == M +-- +-- This is primarily useful for debugging. +map :: (Word64 -> Word64) -> SampleTree -> SampleTree +map f = go + where + go :: SampleTree -> SampleTree + go (SampleTree s l r) = SampleTree (mapSample s) (go l) (go r) + go Minimal = Minimal + + mapSample :: Sample -> Sample + mapSample (NotShrunk s) = NotShrunk (f s) + mapSample (Shrunk s) = Shrunk (f s) + +-- | Apply @mod m@ at every sample in the tree +-- +-- This is primarily useful for debugging. +mod :: Word64 -> SampleTree -> SampleTree +mod m = map (\s -> s `Prelude.mod` m) diff --git a/src/Test/Falsify/ShrinkTree.hs b/src/Test/Falsify/ShrinkTree.hs new file mode 100644 --- /dev/null +++ b/src/Test/Falsify/ShrinkTree.hs @@ -0,0 +1,34 @@ +-- | Hedgehog-style shrink trees +-- +-- Intended for qualified import. +-- +-- > import Test.Falsify +-- > import qualified Test.Falsify.ShrinkTree as ShrinkTree +module Test.Falsify.ShrinkTree ( + ShrinkTree(..) + -- * Construction + , unfold + ) where + +import qualified Data.Tree as Rose + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | Hedgehog-style shrink tree +newtype ShrinkTree a = WrapShrinkTree{ + unwrapShrinkTree :: Rose.Tree a + } + deriving stock (Eq, Functor) + +instance Show a => Show (ShrinkTree a) where + show = Rose.drawTree . fmap show . unwrapShrinkTree + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +-- | Quickcheck-style manual shrinking +unfold :: a -> (a -> [a]) -> ShrinkTree a +unfold x f = WrapShrinkTree $ Rose.unfoldTree (\a -> (a, f a)) x diff --git a/src/Test/Tasty/Falsify.hs b/src/Test/Tasty/Falsify.hs deleted file mode 100644 --- a/src/Test/Tasty/Falsify.hs +++ /dev/null @@ -1,28 +0,0 @@ --- | Support for @falsify@ in the @tasty@ framework --- --- As is customary, this also re-exports parts of the @falsify@ API, but not --- modules such as "Test.Falsify.Range" that are intended to be imported --- qualified. -module Test.Tasty.Falsify ( - -- * Test property - testProperty - -- * Configure test behaviour - , TestOptions(..) - , Verbose(..) - , ExpectFailure(..) - , testPropertyWith - -- * Re-exports - , module Test.Falsify.Property - -- ** Generators - , Gen - -- ** Functions - , pattern Gen.Fn - , pattern Gen.Fn2 - , pattern Gen.Fn3 - ) where - -import Test.Falsify.Generator (Gen) -import Test.Falsify.Internal.Driver.Tasty -import Test.Falsify.Property - -import qualified Test.Falsify.Reexported.Generator.Function as Gen diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -3,19 +3,10 @@ import Test.Tasty import qualified TestSuite.GenDefault - import qualified TestSuite.Sanity.Predicate import qualified TestSuite.Sanity.Range import qualified TestSuite.Sanity.Selective - -import qualified TestSuite.Prop.Generator.Compound -import qualified TestSuite.Prop.Generator.Function -import qualified TestSuite.Prop.Generator.Marking -import qualified TestSuite.Prop.Generator.Precision -import qualified TestSuite.Prop.Generator.Prim -import qualified TestSuite.Prop.Generator.Selective -import qualified TestSuite.Prop.Generator.Shrinking -import qualified TestSuite.Prop.Generator.Simple +import qualified TestSuite.Regression main :: IO () main = defaultMain $ testGroup "falsify" [ @@ -24,15 +15,6 @@ , TestSuite.Sanity.Selective.tests , TestSuite.Sanity.Predicate.tests ] - , testGroup "Prop" [ - TestSuite.Prop.Generator.Prim.tests - , TestSuite.Prop.Generator.Selective.tests - , TestSuite.Prop.Generator.Marking.tests - , TestSuite.Prop.Generator.Precision.tests - , TestSuite.Prop.Generator.Simple.tests - , TestSuite.Prop.Generator.Shrinking.tests - , TestSuite.Prop.Generator.Compound.tests - , TestSuite.Prop.Generator.Function.tests - ] + , TestSuite.Regression.tests , TestSuite.GenDefault.tests ] diff --git a/test/TestSuite/GenDefault.hs b/test/TestSuite/GenDefault.hs --- a/test/TestSuite/GenDefault.hs +++ b/test/TestSuite/GenDefault.hs @@ -1,80 +1,103 @@ -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} --- | We test the 'GenDefault' machinery by defining a tag, deriving some 'GenDefault' --- instances, and asserting that the derived generators yield more than one distinct --- value. +-- | Test the 'GenDefault' machinery +-- +-- We define a tag, derive some 'GenDefault' instances, and asserting that the +-- derived generators yield more than one distinct value. module TestSuite.GenDefault (tests) where -import Data.Proxy (Proxy (..)) -import qualified Data.Set as Set +import Control.Monad +import Data.Proxy import GHC.Exts (IsList, IsString) -import GHC.Generics (Generic) -import qualified Test.Falsify.GenDefault as FD -import qualified Test.Falsify.GenDefault.Std as FDS -import qualified Test.Falsify.Generator as FG -import qualified Test.Falsify.Interactive as FI -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertBool, testCase) -import Control.Monad (replicateM) +import GHC.Generics +import Test.Tasty +import Test.Tasty.HUnit +import qualified Data.Set as Set + +import Test.Falsify +import Test.Falsify.GenDefault hiding (GenDefault) +import Test.Falsify.Interactive (sample) + +{------------------------------------------------------------------------------- + Example tag +-------------------------------------------------------------------------------} + data Tag --- Exercise ViaTag +{------------------------------------------------------------------------------- + ViaTag +-------------------------------------------------------------------------------} -deriving via (FD.ViaTag FDS.Std Int) instance FD.GenDefault Tag Int -deriving via (FD.ViaTag FDS.Std Char) instance FD.GenDefault Tag Char +deriving via ViaTag Std Int instance GenDefault Tag Int +deriving via ViaTag Std Char instance GenDefault Tag Char --- Exercise ViaList +{------------------------------------------------------------------------------- + ViaList +-------------------------------------------------------------------------------} newtype AList a = AList [a] deriving newtype (Eq, Ord, Show, IsList) -deriving via (FD.ViaList (AList a) 0 2) instance FD.GenDefault Tag a => FD.GenDefault Tag (AList a) +deriving + via ViaList (AList a) 0 2 + instance GenDefault Tag a => GenDefault Tag (AList a) --- Exercise ViaString +{------------------------------------------------------------------------------- + ViaString +-------------------------------------------------------------------------------} newtype AString = AString String deriving newtype (Eq, Ord, Show, IsString) - deriving (FD.GenDefault Tag) via (FD.ViaString AString 0 2) + deriving (GenDefault Tag) via (ViaString AString 0 2) --- Exercise ViaEnum +{------------------------------------------------------------------------------- + ViaEnum +-------------------------------------------------------------------------------} data Choice = ChoiceA | ChoiceB deriving stock (Eq, Ord, Show, Enum, Bounded) - deriving (FD.GenDefault Tag) via (FD.ViaEnum Choice) + deriving (GenDefault Tag) via (ViaEnum Choice) --- Exercise ViaGeneric +{------------------------------------------------------------------------------- + ViaGeneric +-------------------------------------------------------------------------------} -deriving via (FD.ViaGeneric Tag (Maybe a)) instance FD.GenDefault Tag a => FD.GenDefault Tag (Maybe a) +deriving + via ViaGeneric Tag (Maybe a) + instance GenDefault Tag a => GenDefault Tag (Maybe a) data Record = Record !Int !(Maybe Record) deriving stock (Eq, Ord, Show, Generic) - deriving (FD.GenDefault Tag) via (FD.ViaGeneric Tag Record) + deriving (GenDefault Tag) via (ViaGeneric Tag Record) +{------------------------------------------------------------------------------- + Sanity check: verify that the generators can produce more than one value +-------------------------------------------------------------------------------} + data GenCase where - GenCase :: Ord a => String -> FG.Gen a -> GenCase + GenCase :: Ord a => String -> Gen a -> GenCase -genDefaultByProxy :: FD.GenDefault Tag a => Proxy a -> FG.Gen a -genDefaultByProxy _ = FD.genDefault (Proxy @Tag) +genDefaultByProxy :: GenDefault Tag a => Proxy a -> Gen a +genDefaultByProxy _ = genDefault (Proxy @Tag) -mkGenCase :: (Ord a, FD.GenDefault Tag a) => String -> Proxy a -> GenCase +mkGenCase :: (Ord a, GenDefault Tag a) => String -> Proxy a -> GenCase mkGenCase name = GenCase name . genDefaultByProxy genCases :: [GenCase] -genCases = - [ mkGenCase "Int" (Proxy @Int) - , mkGenCase "Char" (Proxy @Char) - , mkGenCase "Choice" (Proxy @Choice) - , mkGenCase "AList" (Proxy @(AList Char)) - , mkGenCase "AString" (Proxy @AString) - , mkGenCase "Record" (Proxy @Record) - ] +genCases = [ + mkGenCase "Int" (Proxy @Int) + , mkGenCase "Char" (Proxy @Char) + , mkGenCase "Choice" (Proxy @Choice) + , mkGenCase "AList" (Proxy @(AList Char)) + , mkGenCase "AString" (Proxy @AString) + , mkGenCase "Record" (Proxy @Record) + ] testGenCase :: GenCase -> TestTree -testGenCase (GenCase name gen) = testCase name $ do - xs <- fmap Set.fromList (replicateM 10 (FI.sample gen)) - assertBool "generates more than one value" (Set.size xs > 1) +testGenCase (GenCase name g) = testCase name $ do + xs <- fmap Set.fromList (replicateM 20 (sample g)) + assertBool "generates more than one value" (Set.size xs > 1) tests :: TestTree tests = testGroup "TestSuite.GenDefault" (fmap testGenCase genCases) diff --git a/test/TestSuite/Prop/Generator/Compound.hs b/test/TestSuite/Prop/Generator/Compound.hs deleted file mode 100644 --- a/test/TestSuite/Prop/Generator/Compound.hs +++ /dev/null @@ -1,326 +0,0 @@ -module TestSuite.Prop.Generator.Compound (tests) where - -import Control.Monad -import Data.Default -import Data.Foldable (toList) -import Data.Word -import Test.Tasty -import Test.Tasty.Falsify - -import qualified Data.Tree as Rose - -import Test.Falsify.Predicate (Predicate, (.$)) -import Test.Falsify.Generator (ShrinkTree, Permutation, Tree(..)) - -import qualified Test.Falsify.Generator as Gen -import qualified Test.Falsify.Predicate as P -import qualified Test.Falsify.Range as Range - -import TestSuite.Util.List - -import qualified TestSuite.Util.Tree as Tree - -tests :: TestTree -tests = testGroup "TestSuite.Prop.Generator.Compound" [ - testGroup "list" [ - testGroup "towardsShorter" [ - testProperty "shrinking" prop_list_towardsShorter_shrinking - , testProperty "minimum" prop_list_towardsShorter_minimum - ] - , testGroup "towardsShorterEven" [ - testPropertyWith expectFailure "shrinking" prop_list_towardsShorterEven_shrinking_wrong - , testProperty "minimum" prop_list_towardsShorterEven_minimum - ] - , testGroup "towardsLonger" [ - testProperty "shrinking" prop_list_towardsLonger_shrinking - , testProperty "minimum" prop_list_towardsLonger_minimum - ] - , testGroup "towardsOrigin" [ - testProperty "minimum" prop_list_towardsOrigin_minimum - ] - ] - , testGroup "perm" [ - testProperty "shrinking" prop_perm_shrinking - , testGroup "minimum" [ - testPropertyWith def{overrideMaxRatio = Just 1000} - (show n) $ prop_perm_minimum n - | n <- [0 .. 9] - ] - ] - , testGroup "tree" [ - testProperty "towardsSmaller1" prop_tree_towardsSmaller1 - , testProperty "towardsSmaller2" prop_tree_towardsSmaller2 - , testProperty "towardsOrigin1" prop_tree_towardsOrigin1 - , testProperty "towardsOrigin2" prop_tree_towardsOrigin2 - ] - , testGroup "shrinkTree" [ - testProperty "pathAny" prop_pathAny - , testProperty "toShrinkTree" prop_toShrinkTree - ] - , testGroup "frequency" [ - testProperty "shrinking" prop_frequency_shrinking - , testPropertyWith expectFailure - "shrinking_wrong" prop_frequency_shrinking_wrong - , testProperty "replicateM" prop_replicateM_shrinking - ] - ] - where - expectFailure :: TestOptions - expectFailure = def { - expectFailure = ExpectFailure - , overrideNumTests = Just 10_000 - } - -{------------------------------------------------------------------------------- - Lists - - Here and elsewhere, for the 'testMinimum' tests, we don't /always/ fail, but - check some property. This ensures that the minimum value isn't just always the - one produced by the @Minimal@ sample tree. --------------------------------------------------------------------------------} - -prop_list_towardsShorter_shrinking :: Property () -prop_list_towardsShorter_shrinking = - testShrinkingOfGen (P.ge `P.on` P.fn ("length", length)) $ - Gen.list (Range.between (10, 20)) $ - Gen.int $ Range.between (0, 1) - -prop_list_towardsShorter_minimum :: Property () -prop_list_towardsShorter_minimum = - testMinimum (P.satisfies ("expectedLength", (== 10) . length)) $ do - xs <- gen $ Gen.list (Range.between (10, 20)) $ - Gen.int $ Range.between (0, 1) - unless (pairwiseAll (<=) xs) $ testFailed xs - --- In principle the filtered list can /grow/ in size during shrinking (if --- a previously odd number is shrunk to be even). -prop_list_towardsShorterEven_shrinking_wrong :: Property () -prop_list_towardsShorterEven_shrinking_wrong = - testShrinkingOfGen (P.ge `P.on` P.fn ("length", length)) $ - fmap (filter even) $ - Gen.list (Range.between (10, 20)) $ - Gen.int $ Range.withOrigin (0, 10) 5 - --- Although [6,4] is the perfect counter-example here, we don't always get it, --- due to binary search -prop_list_towardsShorterEven_minimum :: Property () -prop_list_towardsShorterEven_minimum = - testMinimum (P.elem .$ ("expected", [[6,4],[8,6]])) $ do - xs <- gen $ fmap (filter even) $ - Gen.list (Range.between (10, 20)) $ - Gen.int $ Range.withOrigin (0, 10) 5 - unless (pairwiseAll (<=) xs) $ testFailed xs - -prop_list_towardsLonger_shrinking :: Property () -prop_list_towardsLonger_shrinking = - testShrinkingOfGen (P.le `P.on` P.fn ("length", length)) $ - Gen.list (Range.between (10, 0)) $ - Gen.int $ Range.between (0, 1) - -prop_list_towardsLonger_minimum :: Property () -prop_list_towardsLonger_minimum = - testMinimum (P.satisfies ("expectedLength", (== 10) . length)) $ do - xs <- gen $ Gen.list (Range.between (10, 0)) $ - Gen.int $ Range.between (0, 1) - unless (pairwiseAll (<=) xs) $ testFailed xs - -prop_list_towardsOrigin_minimum :: Property () -prop_list_towardsOrigin_minimum = - testMinimum (P.satisfies ("expectedLength", (== 5) . length)) $ do - xs <- gen $ Gen.list (Range.withOrigin (0, 10) 5) $ - Gen.int $ Range.between (0, 1) - unless (pairwiseAll (<=) xs) $ testFailed xs - -{------------------------------------------------------------------------------- - Permutations (and shuffling) --------------------------------------------------------------------------------} - -validPermShrink :: Predicate [Permutation, Permutation] -validPermShrink = mconcat [ - P.ge `P.on` P.fn ("numSwaps", length ) - , P.ge `P.on` P.fn ("distance", distance) - ] - where - distance :: Permutation -> Word - distance = sum . map weighted - - weighted :: (Word, Word) -> Word - weighted (i, j) - | i < j = error "unexpected swap" - | otherwise = (10 ^ i) * (i - j) - -prop_perm_shrinking :: Property () -prop_perm_shrinking = - testShrinkingOfGen validPermShrink $ - Gen.permutation 10 - -prop_perm_minimum :: Word -> Property () -prop_perm_minimum n = - testMinimum (P.satisfies ("suffixIsUnchanged", suffixIsUnchanged)) $ do - perm <- gen $ Gen.permutation 10 - let shuffled = Gen.applyPermutation perm [0 .. 9] - when (shuffled !! fromIntegral n /= n) $ testFailed perm - where - suffixIsUnchanged :: Permutation -> Bool - suffixIsUnchanged perm = - case perm of - [(i, j)] -> i == j + 1 && (i == n || j == n) - _otherwise -> False - -{------------------------------------------------------------------------------- - Tree - - TODO: We're currently only testing minimums here. - TODO: These are discarding a lot of tests; is it expected that a randomly - generated tree is so often weight or heigh balanced..? --------------------------------------------------------------------------------} - -prop_tree_towardsSmaller1 :: Property () -prop_tree_towardsSmaller1 = - testMinimum (P.satisfies ("expected", expected)) $ do - t <- gen $ Gen.tree (Range.between (0, 100)) $ - Gen.int $ Range.between (0, 1) - -- "Every tree is height balanced" - unless (Tree.isHeightBalanced t) $ testFailed t - where - expected :: Tree Int -> Bool - expected t = or [ - t == Branch 0 (Branch 0 Leaf (Branch 0 Leaf Leaf)) Leaf - , t == Branch 0 Leaf (Branch 0 Leaf (Branch 0 Leaf Leaf)) - ] - -prop_tree_towardsSmaller2 :: Property () -prop_tree_towardsSmaller2 = - testMinimum (P.elem .$ ("expected", expected)) $ do - t <- gen $ Gen.tree (Range.between (0, 100)) $ - Gen.int $ Range.between (0, 1) - -- "Every tree is weight balanced" - unless (Tree.isWeightBalanced t) $ testFailed t - where - -- For a minimal tree that is not weight-balanced, we need three elements in - -- one subtree and none in the other: the weight of the empty tree is 1, - -- the weight of the tree with three elements is 4, and 4 > Δ * 1, for Δ=3. - expected :: [Tree Int] - expected = [ - Branch 0 (Branch 0 (Branch 0 Leaf Leaf) (Branch 0 Leaf Leaf)) Leaf - , Branch 0 (Branch 0 Leaf (Branch 0 Leaf (Branch 0 Leaf Leaf))) Leaf - , Branch 0 Leaf (Branch 0 (Branch 0 Leaf Leaf) (Branch 0 Leaf Leaf)) - , Branch 0 Leaf (Branch 0 Leaf (Branch 0 Leaf (Branch 0 Leaf Leaf))) - ] - -prop_tree_towardsOrigin1 :: Property () -prop_tree_towardsOrigin1 = - testMinimum ( P.satisfies ("expected", expected) - `P.dot` P.fn ("size", Tree.size) - ) $ do - t <- gen $ Gen.tree (Range.withOrigin (0, 100) 10) $ pure () - unless (Tree.isHeightBalanced t) $ testFailed t - where - -- We can always find a non-balanced tree of roughly the specified size - -- (The /exact/ size might not always be reachable with single shrink steps) - expected :: Word -> Bool - expected sz = 8 <= sz && sz <= 10 - -prop_tree_towardsOrigin2 :: Property () -prop_tree_towardsOrigin2 = - testMinimum ( P.satisfies ("expected", expected) - `P.dot` P.fn ("size", Tree.size) - ) $ do - t <- gen $ Gen.tree (Range.withOrigin (0, 100) 10) $ pure () - unless (Tree.isWeightBalanced t) $ testFailed t - where - expected :: Word -> Bool - expected sz = 8 <= sz && sz <= 10 - -{------------------------------------------------------------------------------- - Shrink trees --------------------------------------------------------------------------------} - -prop_pathAny :: Property () -prop_pathAny = - testMinimum (P.expect ["", "a", "aa"]) $ do - xs <- gen $ toList <$> Gen.pathAny st - unless (length xs < 3) $ testFailed xs - where - -- Infinite ShrinkTree containing all strings containing lowercase letters - st :: ShrinkTree String - st = Rose.unfoldTree (\xs -> (xs, map (:xs) ['a' .. 'z'])) "" - -prop_toShrinkTree :: Property () -prop_toShrinkTree = - testMinimum (P.satisfies ("expected", expected)) $ do - xs <- gen $ Gen.toShrinkTree genToTest >>= fmap toList . Gen.pathAny - unless (pairwiseAll (>) xs) $ testFailed xs - where - -- Should be any kind of path in which the last two pairs of numbers are - -- NOT decreasing. - expected :: [Word64] -> Bool - expected xs = - case reverse xs of - x : y : _ -> x >= y - _otherwise -> False - - genToTest :: Gen Word64 - genToTest = (`mod` 100) <$> Gen.prim - - -{------------------------------------------------------------------------------- - Tweak test data distribution --------------------------------------------------------------------------------} - -propShrinkingList1 :: [Word] -> [Word] -> Bool -propShrinkingList1 = aux - where - aux [_, _, _] [_, _] = True - aux [_, _, _] [_] = True - aux [_, _] [_] = True - aux [x] [x'] = x >= x' - aux [x, y] [x', y'] = x >= x' && y >= y' - aux [x, y, z] [x', y', z'] = x >= x' && y >= y' && z >= z' - aux _ _ = error "impossible" - -propShrinkingList2 :: [Word] -> [Word] -> Bool -propShrinkingList2 = aux - where - aux :: [Word] -> [Word] -> Bool - aux [x, y, _] [x', y'] = x >= x' && y >= y' - aux [x, _, _] [x'] = x >= x' - aux [x, _] [x'] = x >= x' - aux [x] [x'] = x >= x' - aux [x, y] [x', y'] = x >= x' && y >= y' - aux [x, y, z] [x', y', z'] = x >= x' && y >= y' && z >= z' - aux _ _ = error "impossible" - -genListFrequency :: Gen [Word] -genListFrequency = - Gen.frequency [ - (1, replicateM 1 $ Gen.inRange $ Range.between (0, 10)) - , (2, replicateM 2 $ Gen.inRange $ Range.between (0, 10)) - , (3, replicateM 3 $ Gen.inRange $ Range.between (0, 10)) - ] - -genListMonad :: Gen [Word] -genListMonad = do - n <- Gen.inRange $ Range.between (1, 3) - replicateM n $ Gen.inRange $ Range.between (0, 10) - -prop_frequency_shrinking :: Property () -prop_frequency_shrinking = - testShrinkingOfGen - (P.relatedBy ("propShrinkingList1", propShrinkingList1)) - genListFrequency - --- 'propShrinkingList2' does /not/ hold for 'genListFrequency' because the --- generators are independent -prop_frequency_shrinking_wrong :: Property () -prop_frequency_shrinking_wrong = - testShrinkingOfGen - (P.relatedBy ("propShrinkingList2", propShrinkingList2)) - genListFrequency - --- 'propShrinkingList2' /does/ hold if we simply use 'replicateM'. -prop_replicateM_shrinking :: Property () -prop_replicateM_shrinking = - testShrinkingOfGen - (P.relatedBy ("propShrinkingList2", propShrinkingList2)) - genListMonad diff --git a/test/TestSuite/Prop/Generator/Function.hs b/test/TestSuite/Prop/Generator/Function.hs deleted file mode 100644 --- a/test/TestSuite/Prop/Generator/Function.hs +++ /dev/null @@ -1,153 +0,0 @@ -module TestSuite.Prop.Generator.Function (tests) where - -import Control.Monad -import Data.Default -import Data.Word -import Test.Tasty -import Test.Tasty.Falsify - -import qualified Data.Set as Set - -import Test.Falsify.Generator (Fun) - -import qualified Test.Falsify.Generator as Gen -import qualified Test.Falsify.Predicate as P -import qualified Test.Falsify.Range as Range - -tests :: TestTree -tests = testGroup "TestSuite.Prop.Generator.Function" [ - testGroup "BoolToBool" [ - testProperty "notConstant" prop_BoolToBool_notConstant - , testProperty "constant" prop_BoolToBool_constant - ] - , testProperty "Word8ToBool" prop_Word8ToBool - , testPropertyWith fewerTests "IntegerToBool" prop_IntegerToBool - , testProperty "IntToInt" prop_IntToInt - , testPropertyWith fewerTests "StringToBool" prop_StringToBool - ] - where - -- These tests are pretty slow - fewerTests :: TestOptions - fewerTests = def { - overrideNumTests = Just 10 - } - -{------------------------------------------------------------------------------- - Functions @Bool -> Bool@ - - TODO: Should we define these in terms of the concrete functions instead? --------------------------------------------------------------------------------} - -prop_BoolToBool_notConstant :: Property () -prop_BoolToBool_notConstant = - testMinimum (P.satisfies ("isConstant", isConstant)) $ do - fn <- gen $ Gen.fun (Gen.bool False) - let Fn f = fn - -- "No function Bool -> Bool can be constant" - unless (f False /= f True) $ testFailed fn - where - isConstant :: Fun Bool Bool -> Bool - isConstant fn = show fn == "{_->False}" - -prop_BoolToBool_constant :: Property () -prop_BoolToBool_constant = do - testMinimum (P.satisfies ("notConstant", notConstant)) $ do - fn <- gen $ Gen.fun (Gen.bool False) - let Fn f = fn - -- "Every function Bool -> Bool is constant" - unless (f False == f True) $ testFailed fn - where - notConstant :: Fun Bool Bool -> Bool - notConstant fn = or [ - show fn == "{True->True, _->False}" - , show fn == "{False->True, _->False}" - ] - -{------------------------------------------------------------------------------- - Functions @Word8 -> Bool@ --------------------------------------------------------------------------------} - -prop_Word8ToBool :: Property () -prop_Word8ToBool = do - testMinimum (P.satisfies ("notConstant", notConstant)) $ do - fn <- gen $ Gen.fun (Gen.bool False) - -- "Every function Word8 -> Bool is constant" - unless (isConstant fn) $ testFailed fn - where - notConstant :: Fun Word8 Bool -> Bool - notConstant fn = any aux [0 .. 255] - where - aux :: Word8 -> Bool - aux n = show fn == "{" ++ show n ++ "->True, _->False}" - - isConstant :: Fun Word8 Bool -> Bool - isConstant (Fn f) = - (\s -> Set.size s == 1) $ - Set.fromList (map f [minBound .. maxBound]) - -{------------------------------------------------------------------------------- - Functions @Integer -> Bool@ - - This is the first test where the input domain is infinite. --------------------------------------------------------------------------------} - -prop_IntegerToBool :: Property () -prop_IntegerToBool = - testMinimum (P.satisfies ("expected", expected)) $ do - fn <- gen $ Gen.fun (Gen.bool False) - let Fn f = fn - -- "Every fn from Integer to Bool must give the same result for π and φ" - unless (f 3142 == f 1618) $ testFailed fn - where - expected :: Fun Integer Bool -> Bool - expected fn = or [ - show fn == "{1618->True, _->False}" - , show fn == "{3142->True, _->False}" - ] - -{------------------------------------------------------------------------------- - Functions @Int -> Int@ --------------------------------------------------------------------------------} - -prop_IntToInt :: Property () -prop_IntToInt = - testMinimum (P.satisfies ("expected", expected)) $ do - fn <- gen $ Gen.fun (Gen.inRange $ Range.between (0, 100)) - let Fn f = fn - unless (f 0 == 0 && f 1 == 0) $ testFailed fn - where - expected :: Fun Int Int -> Bool - expected fn = or [ - show fn == "{1->1, _->0}" - , show fn == "{0->1, _->0}" - ] - -{------------------------------------------------------------------------------- - Functions @String -> Bool@ - - This example (as well as 'test_IntToInt_mapFilter') is adapted from - Koen Claessen's presentation "Shrinking and showing functions" - at Haskell Symposium 2012 . - - TODO: His example uses longer strings, which does work, it's just expensive. - We can definitely use some performance optimization here. --------------------------------------------------------------------------------} - -prop_StringToBool :: Property () -prop_StringToBool = - testMinimum (P.satisfies ("expected", expected)) $ do - fn <- gen $ Gen.fun (Gen.bool False) - let Fn p = fn - unless (p "abc" `implies` p "def") $ testFailed fn - where - -- TODO: Actually, the second case doesn't seem to get triggered. Not sure - -- why; maybe it's just unlikely..? - expected :: Fun String Bool -> Bool - expected fn = or [ - show fn == "{\"abc\"->True, _->False}" - , show fn == "{\"def\"->True, _->False}" - ] - - implies :: Bool -> Bool -> Bool - implies False _ = True - implies True b = b diff --git a/test/TestSuite/Prop/Generator/Marking.hs b/test/TestSuite/Prop/Generator/Marking.hs deleted file mode 100644 --- a/test/TestSuite/Prop/Generator/Marking.hs +++ /dev/null @@ -1,84 +0,0 @@ -module TestSuite.Prop.Generator.Marking (tests) where - -import Control.Monad -import Data.Map (Map) -import Data.Maybe (catMaybes) -import Data.Word -import Test.Tasty -import Test.Tasty.Falsify - -import qualified Data.Map as Map -import qualified Data.Set as Set - -import Test.Falsify.Generator (Marked(..), Mark(..)) - -import qualified Test.Falsify.Generator as Gen hiding (mark) -import qualified Test.Falsify.Predicate as P - -import TestSuite.Util.List - -tests :: TestTree -tests = testGroup "TestSuite.Prop.Generator.Marking" [ - testGroup "list" [ - testProperty "shrinking" prop_list_shrinking - , testProperty "minimum" prop_list_minimum - ] - ] - -{------------------------------------------------------------------------------- - Marking --------------------------------------------------------------------------------} - --- | Mark an element --- --- Marks as 'Drop' with 50% probability. --- --- We avoid using 'Gen.mark' here, which depends on @shrinkTo@. This version --- uses only 'Gen.prim'; the difference in behaviour is that this version of --- @mark@ can produce elements that are marked as drop from the get-go. -mark :: Gen a -> Gen (Marked Gen a) -mark x = flip Marked x <$> (aux <$> Gen.prim) - where - aux :: Word64 -> Mark - aux n = if n >= maxBound `div` 2 then Keep else Drop - -{------------------------------------------------------------------------------- - List --------------------------------------------------------------------------------} - -genMarkedList :: Gen [(Word, Word64)] -genMarkedList = do - xs <- forM [0 .. 9] (\i -> mark ((i, ) <$> Gen.prim)) - catMaybes <$> Gen.selectAllKept xs - -prop_list_shrinking :: Property () -prop_list_shrinking = - testShrinkingOfGen - ( mconcat [ - P.flip (P.relatedBy ("isSubsetOf", Set.isSubsetOf)) - `P.on` P.fn ("keysSet", Map.keysSet) - , P.relatedBy ("shrunkCod", shrunkCod) - ] - `P.on` P.transparent Map.fromList - ) - genMarkedList - where - shrunkCod :: Map Word Word64 -> Map Word Word64 -> Bool - shrunkCod orig shrunk = and [ - -- The 'shrunkDom' check justifies the use of @(!)@ here - orig Map.! k >= v - | (k, v) <- Map.toList shrunk - ] - -prop_list_minimum :: Property () -prop_list_minimum = - testMinimum (P.satisfies ("expected", expected)) $ do - xs <- gen $ genMarkedList - case xs of - (0, _):_ -> discard - _otherwise -> return () - unless (pairwiseAll (==) $ map snd xs) $ testFailed xs - where - expected :: [(Word, Word64)] -> Bool - expected [(i, 0), (j, 1)] | i < j = True - expected _otherwise = False diff --git a/test/TestSuite/Prop/Generator/Precision.hs b/test/TestSuite/Prop/Generator/Precision.hs deleted file mode 100644 --- a/test/TestSuite/Prop/Generator/Precision.hs +++ /dev/null @@ -1,69 +0,0 @@ -module TestSuite.Prop.Generator.Precision (tests) where - -import Control.Monad -import Test.Tasty -import Test.Tasty.Falsify - -import Test.Falsify.Generator (WordN(..)) -import Test.Falsify.Range (Precision(..), ProperFraction(..)) - -import qualified Test.Falsify.Generator as Gen -import qualified Test.Falsify.Predicate as P - -tests :: TestTree -tests = testGroup "TestSuite.Prop.Generator.Precision" [ - testGroup "wordN" [ - testGroup (show p) [ - testProperty "shrinking" $ prop_wordN_shrinking p - , testProperty "minimum" $ prop_wordN_minimum p - ] - | p <- map Precision [0, 1, 2, 3, 63, 64] - ] - , testGroup "fraction" [ - testGroup (show p) [ - testProperty "shrinking" $ prop_fraction_shrinking (Precision p) - , testProperty "minimum" $ prop_fraction_minimum (Precision p) target expected - ] - | (p, target, expected) <- [ - -- The higher the precision, the closer we can get to the target - (2 , 50, 75) - , (3 , 50, 62) - , (4 , 50, 56) - , (5 , 50, 53) - , (63 , 50, 51) - , (64 , 50, 51) - ] - ] - ] - -{------------------------------------------------------------------------------- - wordN --------------------------------------------------------------------------------} - -prop_wordN_shrinking :: Precision -> Property () -prop_wordN_shrinking p = - testShrinkingOfGen P.ge $ Gen.wordN p - -prop_wordN_minimum :: Precision -> Property () -prop_wordN_minimum p = - testMinimum (P.expect $ WordN p 0) $ do - x <- gen $ Gen.wordN p - testFailed x - -{------------------------------------------------------------------------------- - fraction --------------------------------------------------------------------------------} - -prop_fraction_shrinking :: Precision -> Property () -prop_fraction_shrinking p = - testShrinkingOfGen P.ge $ Gen.properFraction p - -prop_fraction_minimum :: Precision -> Word -> Word -> Property () -prop_fraction_minimum p target expected = - testMinimum ((P.expect expected) `P.dot` P.fn ("pct", pct)) $ do - x <- gen $ Gen.properFraction p - unless (pct x <= target) $ testFailed x - where - pct :: ProperFraction -> Word - pct (ProperFraction f) = round (f * 100) - diff --git a/test/TestSuite/Prop/Generator/Prim.hs b/test/TestSuite/Prop/Generator/Prim.hs deleted file mode 100644 --- a/test/TestSuite/Prop/Generator/Prim.hs +++ /dev/null @@ -1,383 +0,0 @@ -module TestSuite.Prop.Generator.Prim (tests) where - -import Prelude hiding (pred) - -import Control.Monad -import Control.Selective -import Data.Default -import Data.Word -import Test.Tasty -import Test.Tasty.Falsify - -import qualified Test.Falsify.Generator as Gen -import qualified Test.Falsify.Predicate as P - -import TestSuite.Util.List - -tests :: TestTree -tests = testGroup "TestSuite.Prop.Generator.Prim" [ - testGroup "prim" [ - testProperty "shrinking" prop_prim_shrinking - , testGroup "minimum" [ - testProperty (show target) $ prop_prim_minimum target - | target <- [0 .. 4] - ] - , testPropertyWith (def { expectFailure = ExpectFailure }) - "prim_minimum_wrong" prop_prim_minimum_wrong - ] - , testGroup "applicative" [ - testGroup "pair" [ - testProperty "shrinking" prop_applicative_pair_shrinking - , testProperty "minimum1" prop_applicative_pair_minimum1 - , testProperty "minimum2" prop_applicative_pair_minimum2 - ] - , testGroup "replicateM" [ - testProperty "shrinking" prop_applicative_replicateM_shrinking - , testProperty "minimum" prop_applicative_replicateM_minimum - ] - ] - , testGroup "monad" [ - testGroup "maybe" [ - testGroup "towardsNothing" [ - testProperty "shrinking" prop_monad_maybe_towardsNothing_shrinking - , testProperty "minimum" prop_monad_maybe_towardsNothing_minimum - , testPropertyWith expectFailure - "shrinking_wrong" prop_monad_maybe_towardsNothing_shrinking_wrong - ] - , testGroup "towardsJust" [ - testProperty "shrinking" prop_monad_maybe_towardsJust_shrinking - , testProperty "minimum" prop_monad_maybe_towardsJust_minimum - , testPropertyWith expectFailure - "minimum_wrong" prop_monad_maybe_towardsJust_minimum_wrong - ] - ] - , testGroup "either" [ - testProperty "shrinking" prop_monad_either_shrinking - ] - ] - , testGroup "selective" [ - testGroup "either" [ - testPropertyWith expectFailure - "shrinking" prop_selective_either_shrinking_wrong - ] - ] - , testGroup "captureLocalTree" [ - testProperty "shrinking1" prop_captureLocalTree_shrinking1 - , testProperty "shrinking2" prop_captureLocalTree_shrinking2 - ] - , testGroup "stream" [ - testProperty "shrinking1" prop_stream_shrinking1 - , testProperty "shrinking2" prop_stream_shrinking2 - , testProperty "minimum" prop_stream_minimum - ] - ] - where - expectFailure :: TestOptions - expectFailure = def { - expectFailure = ExpectFailure - , overrideNumTests = Just 100_000 - } - -{------------------------------------------------------------------------------- - Prim --------------------------------------------------------------------------------} - --- Gen.prime is the only generator where we a /strict/ inequality -prop_prim_shrinking :: Property () -prop_prim_shrinking = testShrinkingOfGen P.gt $ Gen.prim - --- The minimum is always 0, unless 0 is not a counter-example -prop_prim_minimum :: Word64 -> Property () -prop_prim_minimum target = do - testMinimum (P.expect $ if target == 0 then 1 else 0) $ do - x <- gen $ Gen.prim - unless (x == target) $ testFailed x - --- | Just to verify that we if we specify the /wrong/ minimum, we get a failure -prop_prim_minimum_wrong :: Property () -prop_prim_minimum_wrong = - testMinimum (P.expect 1) $ do - x <- gen $ Gen.prim - testFailed x - -{------------------------------------------------------------------------------- - Applicative: pairs --------------------------------------------------------------------------------} - -prop_applicative_pair_shrinking :: Property () -prop_applicative_pair_shrinking = - testShrinkingOfGen (P.relatedBy ("validShrink", validShrink)) $ - (,) <$> Gen.prim <*> Gen.prim - where - validShrink :: (Word64, Word64) -> (Word64, Word64) -> Bool - validShrink (x, y) (x', y') = x >= x' && y >= y' - -prop_applicative_pair_minimum1 :: Property () -prop_applicative_pair_minimum1 = - testMinimum (P.expect (1, 0)) $ do - (x, y) <- gen $ (,) <$> Gen.prim <*> Gen.prim - unless (x == 0 || x < y) $ testFailed (x, y) - -prop_applicative_pair_minimum2 :: Property () -prop_applicative_pair_minimum2 = - testMinimum (P.expect (1, 1)) $ do - (x, y) <- gen $ (,) <$> Gen.prim <*> Gen.prim - unless (x == 0 || x > y) $ testFailed (x, y) - -{------------------------------------------------------------------------------- - Applicative: replicateM --------------------------------------------------------------------------------} - -genList :: Gen [Word64] -genList = do - n <- (`min` 10) <$> Gen.prim - replicateM (fromIntegral n) Gen.prim - -prop_applicative_replicateM_shrinking :: Property () -prop_applicative_replicateM_shrinking = - testShrinkingOfGen (P.relatedBy ("validShrink", validShrink)) genList - where - validShrink :: [Word64] -> [Word64] -> Bool - validShrink [] [] = True - validShrink [] (_:_) = False - validShrink (_:_) [] = True - validShrink (x:xs) (y:ys) = x >= y && validShrink xs ys - -prop_applicative_replicateM_minimum :: Property () -prop_applicative_replicateM_minimum = - testMinimum (P.expect [0,1]) $ do - xs <- gen $ genList - unless (pairwiseAll (==) xs) $ testFailed xs - -{------------------------------------------------------------------------------- - Monad: Maybe (towards 'Nothing') --------------------------------------------------------------------------------} - -genSmall :: Gen Word64 -genSmall = do - startWithEven <- Gen.prim - if startWithEven >= maxBound `div` 2 - then Gen.exhaustive 100 - else Gen.exhaustive 99 -- smaller bound, to ensure shrinking - -genTowardsNothing :: Gen (Maybe Word64, Word64) -genTowardsNothing = do - genNothing <- (== 0) <$> Gen.prim - if genNothing - then (\ y -> (Nothing, y)) <$> genSmall - else (\x y -> (Just x, y)) <$> genSmall <*> genSmall - -prop_monad_maybe_towardsNothing_shrinking :: Property () -prop_monad_maybe_towardsNothing_shrinking = - testShrinkingOfGen - (P.relatedBy ("validShrink", validShrink)) - genTowardsNothing - where - validShrink :: (Maybe Word64, Word64) -> (Maybe Word64, Word64) -> Bool - validShrink (Nothing , y) (Nothing , y') = y >= y' - validShrink (Just _ , _) (Nothing , _ ) = True -- See @.._wrong@ property - validShrink (Nothing , _) (Just _ , _ ) = False - validShrink (Just x , y) (Just x' , y') = x >= x' && y >= y' - -prop_monad_maybe_towardsNothing_minimum :: Property () -prop_monad_maybe_towardsNothing_minimum = - testMinimum (P.expect expected) $ do - (x, y) <- gen $ genTowardsNothing - unless (even y) $ testFailed (x, y) - where - -- We are using different generators, a switch from 'Just' to 'Nothing' - -- might temporarily because @y@ to increase (see @.._wrong@), but we will - -- then continue to shrink that value. - expected :: (Maybe Word64, Word64) - expected = (Nothing, 1) - -prop_monad_maybe_towardsNothing_shrinking_wrong :: Property () -prop_monad_maybe_towardsNothing_shrinking_wrong = - testShrinkingOfGen - (P.relatedBy ("validShrink", validShrink)) - genTowardsNothing - where - -- This property is wrong: the two generators on the RHS have a different - -- structure, and therefore shrink independently. When we switch the - -- LHS from Just to Nothing, we run a /different/ generator. - validShrink :: (Maybe Word64, Word64) -> (Maybe Word64, Word64) -> Bool - validShrink (Nothing , y) (Nothing , y') = y >= y' - validShrink (Just _ , y) (Nothing , y') = y >= y' - validShrink (Nothing , _) (Just _ , _) = False - validShrink (Just x , y) (Just x' , y') = x >= x' && y >= y' - -{------------------------------------------------------------------------------- - Monad: Maybe (towards 'Just') - - Unlike hypothesis, we are always dealing with infinite sample tree; if a - "simpler" test case needs more samples, then they are available. --------------------------------------------------------------------------------} - -genTowardsJust :: Gen (Maybe Word64, Word64) -genTowardsJust = do - genJust <- (== 0) <$> Gen.prim - if genJust - then (\x y -> (Just x, y)) <$> genSmall <*> genSmall - else (\ y -> (Nothing, y)) <$> genSmall - -prop_monad_maybe_towardsJust_shrinking :: Property () -prop_monad_maybe_towardsJust_shrinking = - testShrinkingOfGen - (P.relatedBy ("validShrink", validShrink)) - genTowardsJust - where - validShrink :: (Maybe Word64, Word64) -> (Maybe Word64, Word64) -> Bool - validShrink (Nothing , y) (Nothing , y') = y >= y' - validShrink (Just _ , _) (Nothing , _ ) = False - validShrink (Nothing , _) (Just _ , _ ) = True - validShrink (Just x , y) (Just x' , y') = x >= x' && y >= y' - -prop_monad_maybe_towardsJust_minimum :: Property () -prop_monad_maybe_towardsJust_minimum = - testMinimum (P.satisfies ("expected", expected)) $ do - (x, y) <- gen $ genTowardsJust - unless (even y) $ testFailed (x, y) - where - expected :: (Maybe Word64, Word64) -> Bool - expected (Just _ , y) = y == 1 - expected (Nothing , _) = True - -prop_monad_maybe_towardsJust_minimum_wrong :: Property () -prop_monad_maybe_towardsJust_minimum_wrong = - testMinimum (P.expect expected) $ do - (x, y) <- gen $ genTowardsJust - unless (even y) $ testFailed (x, y) - where - -- We might not always be able to shrink from 'Nothing' to 'Just', because - -- the /value/ of that 'Just' might not be a counter-example; we would need - -- to take two shrink steps at once (switch from 'Just' to 'Nothing' /and/ - -- reduce the value of the 'Just'). - -- - -- 'Selective' does not help either (it also would need to take two steps); - -- we /could/ try to solve the problem by generating /both/ values always, - -- and using only one, but as we know, that is not an effective strategy: - -- generated-by-not-used values will always be shrunk to their minimal - -- value, independent of the property. - expected :: (Maybe Word64, Word64) - expected = (Just 0, 1) - -{------------------------------------------------------------------------------- - Monad: Either --------------------------------------------------------------------------------} - -genMonadEither :: Gen (Either Word64 Word64) -genMonadEither = do - genLeft <- (== 0) <$> Gen.prim -- shrink towards left - if genLeft - then Left <$> Gen.prim - else Right <$> Gen.prim - -prop_monad_either_shrinking :: Property () -prop_monad_either_shrinking = - testShrinkingOfGen - (P.relatedBy ("validShrink", validShrink)) - genMonadEither - where - -- The 'Left' and 'Right' case use the /same/ part of the sample tree, so - -- that if we shrink from one to the other, we /must/ get the same value. - validShrink :: Either Word64 Word64 -> Either Word64 Word64 -> Bool - validShrink _ (Left 0) = True -- We can always shrink to 'Minimal' - validShrink (Left x) (Left x') = x >= x' - validShrink (Left _) (Right _) = False - validShrink (Right x) (Left x') = x == x' - validShrink (Right x) (Right x') = x >= x' - -{------------------------------------------------------------------------------- - Selective: either --------------------------------------------------------------------------------} - -genSelectiveEither :: Gen (Either Word64 Word64) -genSelectiveEither = - ifS ((== 0) <$> Gen.prim) - (Left <$> Gen.prim) - (Right <$> Gen.prim) - -prop_selective_either_shrinking_wrong :: Property () -prop_selective_either_shrinking_wrong = - testShrinkingOfGen - (P.relatedBy ("validShrink", validShrink)) - genSelectiveEither - where - -- Like in 'prop_monad_either_shrinking', here the two generators are - -- independent, and so it's entirely possible we might shrink from @Right x@ - -- to @Left y@ for @x /= y@. - validShrink :: Either Word64 Word64 -> Either Word64 Word64 -> Bool - validShrink _ (Left 0) = True -- We can always shrink to 'Minimal' - validShrink (Left x) (Left x') = x >= x' - validShrink (Left _) (Right _) = False - validShrink (Right x) (Left x') = x == x' - validShrink (Right x) (Right x') = x >= x' - -{------------------------------------------------------------------------------- - captureLocalTree --------------------------------------------------------------------------------} - -prop_captureLocalTree_shrinking1 :: Property () -prop_captureLocalTree_shrinking1 = - testShrinkingOfGen P.alwaysFail $ - Gen.captureLocalTree - --- Check that we /still/ cannot shrink (i.e., monadic bind is not --- introducing a bug somewhere) -prop_captureLocalTree_shrinking2 :: Property () -prop_captureLocalTree_shrinking2 = - testShrinkingOfGen P.alwaysFail $ do - t1 <- Gen.captureLocalTree - t2 <- Gen.captureLocalTree - return (t1, t2) - -{------------------------------------------------------------------------------- - Stream - - The purpose of this test is to test generation (and shrinking) of infinite - data structures. The function generation tests will verify that also, but they - are much more complicated. --------------------------------------------------------------------------------} - --- | Infinite stream of values --- --- Intentionally does not have a 'Show' instance! -data Stream a = Stream a (Stream a) - -prefix :: Stream a -> Word64 -> [a] -prefix _ 0 = [] -prefix (Stream x xs) n = x : prefix xs (n - 1) - -genStream :: Gen (Stream Word64) -genStream = Stream <$> Gen.exhaustive 10 <*> genStream - -genStreamPrefix :: Gen [Word64] -genStreamPrefix = prefix <$> genStream <*> Gen.exhaustive 10 - --- | Check that we can test shrinking of infinite structures /at all/ -prop_stream_shrinking1 :: Property () -prop_stream_shrinking1 = - testShrinkingOfGen P.alwaysPass $ - genStreamPrefix - --- | Check that we shrink in the way we expect -prop_stream_shrinking2 :: Property () -prop_stream_shrinking2 = - testShrinkingOfGen pred $ - genStreamPrefix - where - pred :: P.Predicate '[[Word64], [Word64]] - pred = mconcat [ - P.ge `P.on` P.fn ("length", length) - , P.relatedBy ("elemsRelated", elemsRelated) - ] - - elemsRelated :: [Word64] -> [Word64] -> Bool - elemsRelated orig shrunk = and $ zipWith (>=) orig shrunk - -prop_stream_minimum :: Property () -prop_stream_minimum = - testMinimum (P.expect [0, 0]) $ do - xs <- gen genStreamPrefix - unless (pairwiseAll (<) xs) $ testFailed xs - diff --git a/test/TestSuite/Prop/Generator/Selective.hs b/test/TestSuite/Prop/Generator/Selective.hs deleted file mode 100644 --- a/test/TestSuite/Prop/Generator/Selective.hs +++ /dev/null @@ -1,99 +0,0 @@ -module TestSuite.Prop.Generator.Selective (tests) where - -import Control.Monad -import Control.Selective -import Data.Default -import Data.Word -import Test.Tasty -import Test.Tasty.Falsify - -import qualified Test.Falsify.Generator as Gen -import qualified Test.Falsify.Predicate as P - -tests :: TestTree -tests = testGroup "TestSuite.Prop.Generator.Selective" [ - testGroup "pair" [ - testProperty "ifM" $ prop_pair ifM - , testPropertyWith expectFailure "ifS" $ prop_pair ifS - , testProperty "ifThenElse" $ prop_pair_ifThenElse - ] - ] - where - expectFailure :: TestOptions - expectFailure = def { - expectFailure = ExpectFailure - , overrideNumTests = Just 10_000 - } - -{------------------------------------------------------------------------------- - Either - - We only only primitive generators here (avoiding generators like - 'Test.Falsify.Reexported.Generator.Simple.bool') to avoid getting distracted - by specific implementation details of derived generators. --------------------------------------------------------------------------------} - --- If we use monadic bind, the seed for the Right value is reused when --- when we shrink it to Left: they are not independent. --- --- Here this is still somewhat reasonable, but in general this means we --- will reuse a seed reduced in one context in a completely different --- context, which may not make any sense at all. -propEither :: - (Word64, Either Word64 Word64) - -> (Word64, Either Word64 Word64) - -> Bool -propEither _ (_, Left 0) = True -- Can always shrink to 'Minimal' -propEither (_, Right x) (_, Left y) = x == y -propEither _ _ = True - -genPair :: - (forall a. Gen Bool -> Gen a -> Gen a -> Gen a) - -> Gen (Word64, Either Word64 Word64) -genPair if_ = - (,) <$> Gen.prim - <*> if_ ((== 0) <$> Gen.prim) - (Left <$> Gen.exhaustive 100) - (Right <$> Gen.exhaustive 100) - -prop_pair :: (forall a. Gen Bool -> Gen a -> Gen a -> Gen a) -> Property () -prop_pair if_ = - testShrinkingOfGen (P.relatedBy ("propEither", propEither)) $ - genPair if_ - -prop_pair_ifThenElse :: Property () -prop_pair_ifThenElse = - testShrinking (P.relatedBy ("stayRight", stayRight)) $ do - pair <- gen $ genPair ifBoth - when (prop pair) $ testFailed pair - where - prop :: (Word64, Either Word64 Word64) -> Bool - prop (x, Right y) = x < 10 || y > x - prop (x, Left y) = x < 1 || y < x - - -- Since we are generating the left value before the right value, if we - -- /start/ with a right value, we will then shrink the left value first even - -- though it is not used: indeed, this /must/ always succeed precisely - -- /because/ that left value is not used. At that point we can no longer - -- reduce the Right to a Left, because @Left 0@ is not a counterexample. - stayRight :: - (Word64, Either Word64 Word64) - -> (Word64, Either Word64 Word64) - -> Bool - stayRight _ (_, Left 0) = True -- Can always shrink to 'Minimal' - stayRight (_, Right _) (_, Left _) = False - stayRight _ _ = True - -{------------------------------------------------------------------------------- - Generic auxiliary --------------------------------------------------------------------------------} - -ifM :: Gen Bool -> Gen a -> Gen a -> Gen a -ifM cond t f = cond `Gen.bindWithoutShortcut` \b -> if b then t else f - -ifBoth :: Gen Bool -> Gen a -> Gen a -> Gen a -ifBoth cond t f = - t `Gen.bindWithoutShortcut` \x -> - f `Gen.bindWithoutShortcut` \y -> - cond `Gen.bindWithoutShortcut` \b -> - return $ if b then x else y diff --git a/test/TestSuite/Prop/Generator/Shrinking.hs b/test/TestSuite/Prop/Generator/Shrinking.hs deleted file mode 100644 --- a/test/TestSuite/Prop/Generator/Shrinking.hs +++ /dev/null @@ -1,132 +0,0 @@ -module TestSuite.Prop.Generator.Shrinking (tests) where - -import Control.Monad -import Data.Default -import Data.Word -import Test.Tasty -import Test.Tasty.Falsify - -import qualified Test.QuickCheck as QuickCheck - -import qualified Test.Falsify.Generator as Gen -import qualified Test.Falsify.Predicate as P - -import TestSuite.Util.List - -tests :: TestTree -tests = testGroup "TestSuite.Prop.Generator.Shrinking" [ - testGroup "prim" [ - testPropertyWith expectFailure "prim" prop_prim_minimum - ] - , testGroup "shrinkTo" [ - testProperty "shrinking" prop_shrinkTo_shrinking - , testProperty "minimum" prop_shrinkTo_minimum - ] - , testGroup "firstThen" [ - testProperty "shrinking" prop_firstThen_shrinking - , testProperty "minimum" prop_firstThen_minimum - ] - , testGroup "shrinkWith" [ - testGroup "minimum" [ - testProperty "minimum" prop_shrinkWith_minimum_word - , testGroup "list" [ - testProperty (show i) $ prop_shrinkWith_minimum_list i - | i <- [20, 40, 60, 80, 100, 120, 140, 160, 180] - ] - ] - ] - ] - where - expectFailure :: TestOptions - expectFailure = def { - expectFailure = ExpectFailure - , overrideNumTests = Just 10_000 - } - -{------------------------------------------------------------------------------- - prim --------------------------------------------------------------------------------} - --- Binary search is not guaranteed to always find the minimum value. For --- example, if we are looking for counter-examples to the property that "all --- numbers are even", and we start with 3, then binary search will only try 0 --- and 2, both of which are even, and hence conclude that 3 is the minimum --- counter-example. This is true in QuickCheck, also. -prop_prim_minimum :: Property () -prop_prim_minimum = - testMinimum (P.expect 1) $ do - x <- gen Gen.prim - unless (even x) $ testFailed x - -{------------------------------------------------------------------------------- - shrinkTo --------------------------------------------------------------------------------} - -prop_shrinkTo_shrinking :: Property () -prop_shrinkTo_shrinking = - testShrinkingOfGen (P.relatedBy ("validShrink", validShrink)) $ - Gen.shrinkToOneOf 3 [0 :: Word .. 2] - where - -- 'shrinkToOneOf' only shrinks /once/, so the original (pre-shrink) value - -- /must/ be 3. - validShrink :: Word -> Word -> Bool - validShrink 3 0 = True - validShrink 3 1 = True - validShrink 3 2 = True - validShrink _ _ = False - -prop_shrinkTo_minimum :: Property () -prop_shrinkTo_minimum = - testMinimum (P.expect 1) $ do - x <- gen $ Gen.shrinkToOneOf 3 [0 :: Word .. 2] - unless (even x) $ testFailed x - -{------------------------------------------------------------------------------- - firstThen --------------------------------------------------------------------------------} - -prop_firstThen_shrinking :: Property () -prop_firstThen_shrinking = - testShrinkingOfGen (P.relatedBy ("validShrink", validShrink)) $ - Gen.firstThen True False - where - validShrink :: Bool -> Bool -> Bool - validShrink True False = True - validShrink _ _ = False - -prop_firstThen_minimum :: Property () -prop_firstThen_minimum = - testMinimum (P.expect False) $ do - x <- gen $ Gen.firstThen True False - testFailed x - -{------------------------------------------------------------------------------- - shrinkWith --------------------------------------------------------------------------------} - --- This is obviously not a valid general-purpose shrinking function for --- 'Word64', but that is not important here. -shrinkWord :: Word64 -> [Word64] -shrinkWord n = takeWhile (< n) [0 .. 100] - -prop_shrinkWith_minimum_word :: Property () -prop_shrinkWith_minimum_word = - testMinimum (P.expect 1) $ do - x <- gen $ Gen.shrinkWith shrinkWord Gen.prim - unless (even x) $ testFailed x - --- | Test performance of 'shrinkWith' --- --- We test this for lists of increasing size, to verify that this is not growing --- exponentially with the size of the list (and thereby verifying that we are --- not exploring the full shrink tree of those lists, because they certainly --- /are/ exponential in size). -prop_shrinkWith_minimum_list :: Int -> Property () -prop_shrinkWith_minimum_list listLength = - testMinimum (P.expect [1,0]) $ do - xs <- gen $ Gen.shrinkWith (QuickCheck.shrinkList shrinkWord) $ - replicateM listLength Gen.prim - unless (pairwiseAll (<=) xs) $ testFailed xs - - - diff --git a/test/TestSuite/Prop/Generator/Simple.hs b/test/TestSuite/Prop/Generator/Simple.hs deleted file mode 100644 --- a/test/TestSuite/Prop/Generator/Simple.hs +++ /dev/null @@ -1,189 +0,0 @@ -module TestSuite.Prop.Generator.Simple (tests) where - -import Control.Monad (unless) -import Data.List (intercalate) -import Data.Word -import Test.Tasty -import Test.Tasty.Falsify - -import Test.Falsify.Predicate ((.$)) - -import qualified Test.Falsify.Generator as Gen -import qualified Test.Falsify.Predicate as P -import qualified Test.Falsify.Range as Range -import Data.Bits -import Data.Proxy -import Data.Typeable - -tests :: TestTree -tests = testGroup "TestSuite.Prop.Generator.Simple" [ - testGroup "prim" [ - testProperty "shrinking" prop_prim_shrinking - , testGroup "minimum" [ - testProperty (show target) $ prop_prim_minimum target - | target <- [0 .. 4] - ] - ] - , testGroup "bool" [ - testGroup "towardsFalse" [ - testProperty "shrinking" $ prop_bool_shrinking False - , testProperty "minimum" $ prop_bool_minimum False - ] - , testGroup "towardsTrue" [ - testProperty "shrinking" $ prop_bool_shrinking True - , testProperty "minimum" $ prop_bool_minimum True - ] - ] - , testGroup "int" [ - testGroup "between" [ - testGroup (intercalate "_" [show x, show y]) [ - testProperty "shrinking" $ prop_int_between_shrinking (x, y) - , testGroup "minimum" [ - testProperty (show target) $ - prop_int_between_minimum (x, y) target - | target <- [0, 1, 99, 100] - ] - ] - | (x, y) <- [ - ( 0, 0) - , ( 0, 10) - , ( 0, 100) - , ( 10, 0) - , ( 10, 10) - , ( 10, 100) - , (100, 0) - , (100, 10) - , (100, 100) - ] - ] - , let test_int_withOrigin :: forall a. - (Typeable a, Show a, Integral a, FiniteBits a) - => Proxy a -> TestTree - test_int_withOrigin p = testGroup (show $ typeRep p) [ - testGroup (intercalate "_" [show x, show y, show o]) [ - testProperty "shrinking" $ - prop_integral_withOrigin_shrinking @a (x, y) o - , testGroup "minimum" [ - testProperty (show target) $ - prop_integral_withOrigin_minimum (x, y) o target - | target <- [0, 1, 49, 50, 51, 99, 100] - ] - ] - | ((x, y), o) <- [ - ((0, 10), 0) - , ((0, 10), 10) - , ((0, 10), 5) - , ((0, 100), 0) - , ((0, 100), 100) - , ((0, 100), 50) - ] - ] - in testGroup "withOrigin" [ - test_int_withOrigin (Proxy @Int) - , test_int_withOrigin (Proxy @Word) - ] - ] - , testGroup "char" [ - testGroup "enum" [ - testProperty "shrinking" $ prop_char_enum_shrinking ('a', 'z') - ] - ] - ] - - -{------------------------------------------------------------------------------- - Prim --------------------------------------------------------------------------------} - --- Gen.prime is the only generator where we a /strict/ inequality -prop_prim_shrinking :: Property () -prop_prim_shrinking = testShrinkingOfGen P.gt $ Gen.prim - --- The minimum is always 0, unless 0 is not a counter-example -prop_prim_minimum :: Word64 -> Property () -prop_prim_minimum target = do - testMinimum (P.expect $ if target == 0 then 1 else 0) $ do - x <- gen $ Gen.prim - unless (x == target) $ testFailed x - -{------------------------------------------------------------------------------- - Bool --------------------------------------------------------------------------------} - -prop_bool_shrinking :: Bool -> Property () -prop_bool_shrinking False = testShrinkingOfGen P.ge $ Gen.bool False -prop_bool_shrinking True = testShrinkingOfGen P.le $ Gen.bool True - -prop_bool_minimum :: Bool -> Property () -prop_bool_minimum target = - testMinimum (P.expect target) $ do - b <- gen $ Gen.bool target - testFailed b - -{------------------------------------------------------------------------------- - Range: 'between' - - This implicitly tests generation of fractions as well as determining - precision. --------------------------------------------------------------------------------} - -prop_int_between_shrinking :: (Int, Int) -> Property () -prop_int_between_shrinking (x, y) - | x <= y = testShrinkingOfGen P.ge $ Gen.inRange $ Range.between (x, y) - | otherwise = testShrinkingOfGen P.le $ Gen.inRange $ Range.between (x, y) - -prop_int_between_minimum :: (Int, Int) -> Int -> Property () -prop_int_between_minimum (x, y) _target | x == y = - testMinimum (P.expect x) $ do - n <- gen $ Gen.inRange $ Range.between (x, y) - -- The only value we can produce here is @x@, so no point looking for - -- anything these (that would just result in all tests being discarded) - testFailed n -prop_int_between_minimum (x, y) target = - testMinimum (P.expect expected) $ do - n <- gen $ Gen.inRange $ Range.between (x, y) - unless (n == target) $ testFailed n - where - expected :: Int - expected - | x < y = if target == x then x + 1 else x - | otherwise = if target == x then x - 1 else x - -{------------------------------------------------------------------------------- - Range: 'withOrigin' --------------------------------------------------------------------------------} - -prop_integral_withOrigin_shrinking :: - (Show a, Integral a, FiniteBits a) - => (a, a) -> a -> Property () -prop_integral_withOrigin_shrinking (x, y) o = - testShrinkingOfGen (P.towards o) $ - Gen.inRange $ Range.withOrigin (x, y) o - -prop_integral_withOrigin_minimum :: forall a. - (Show a, Integral a, FiniteBits a) - => (a, a) -> a -> a -> Property () -prop_integral_withOrigin_minimum (x, y) o _target | x == y = - testMinimum (P.expect x) $ do - -- See discussion in 'prop_int_between_minimum' - n <- gen $ Gen.inRange $ Range.withOrigin (x, y) o - testFailed n -prop_integral_withOrigin_minimum (x, y) o target = - testMinimum (P.elem .$ ("expected", expected)) $ do - n <- gen $ Gen.inRange $ Range.withOrigin (x, y) o - unless (n == target) $ testFailed n - where - expected :: [a] - expected - | target == o = [o + 1, o - 1] - | otherwise = [o] - -{------------------------------------------------------------------------------- - Range: 'enum' --------------------------------------------------------------------------------} - -prop_char_enum_shrinking :: (Char, Char) -> Property () -prop_char_enum_shrinking (x, y) - | x <= y = testShrinkingOfGen P.ge $ Gen.inRange $ Range.enum (x, y) - | otherwise = testShrinkingOfGen P.le $ Gen.inRange $ Range.enum (x, y) - diff --git a/test/TestSuite/Regression.hs b/test/TestSuite/Regression.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Regression.hs @@ -0,0 +1,53 @@ +module TestSuite.Regression (tests) where + +import Control.Monad +import Data.Int +import Data.Word +import Test.Tasty +import Test.Tasty.HUnit + +import Test.Falsify +import Test.Falsify.Interactive (sample) + +import qualified Test.Falsify.Generator as Gen +import qualified Test.Falsify.Range as Range + +{------------------------------------------------------------------------------- + Lists of tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "TestSuite.Regression" [ + testCase "issue81" test_issue81 + , testCase "issue89" test_issue89 + ] + +{------------------------------------------------------------------------------- + Specific tests +-------------------------------------------------------------------------------} + +test_issue81 :: Assertion +test_issue81 = do + checkNumOdd $ (length . filter odd) <$> replicateM n (genDefault @Std @Int undefined) + checkNumOdd $ (length . filter odd) <$> replicateM n (genDefault @Std @Int64 undefined) + checkNumOdd $ (length . filter odd) <$> replicateM n (genDefault @Std @Word64 undefined) + checkNumOdd $ (length . filter odd) <$> replicateM n (genDefault @Std @Word32 undefined) + checkNumOdd $ (length . filter odd) <$> replicateM n (genDefault @Std @Int32 undefined) + where + n = 100000 + + checkNumOdd :: Gen Int -> Assertion + checkNumOdd g = do + numOdd <- sample g + -- If we generate 100,000 numbers, the probability of generating less + -- than 1000 odd numbers is astronomically small. So if this happens, + -- it (almost) certainly is a bug. + assertBool "not enough odd numbers" $ numOdd > 1000 + +test_issue89 :: Assertion +test_issue89 = do + replicateM_ 10 $ do + f <- sample (Gen.fun (Gen.inRange (Range.inclusive (0 :: Int, 100)))) + let x = 0 :: Int8 + y = applyFun f x + assertBool "inRange" $ 0 <= y && y <= 100 diff --git a/test/TestSuite/Sanity/Predicate.hs b/test/TestSuite/Sanity/Predicate.hs --- a/test/TestSuite/Sanity/Predicate.hs +++ b/test/TestSuite/Sanity/Predicate.hs @@ -1,15 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} + module TestSuite.Sanity.Predicate (tests) where +import Data.Char import Test.Tasty import Test.Tasty.HUnit -import Test.Falsify.Predicate (Predicate, (.$)) + +import Test.Falsify import qualified Test.Falsify.Predicate as P -import Data.Char +{------------------------------------------------------------------------------- + List of tests +-------------------------------------------------------------------------------} + tests :: TestTree tests = testGroup "TestSuite.Sanity.Predicate" [ testCase "on" test_on ] + +{------------------------------------------------------------------------------- + Test: 'P.on' +-------------------------------------------------------------------------------} test_on :: Assertion test_on = do diff --git a/test/TestSuite/Sanity/Range.hs b/test/TestSuite/Sanity/Range.hs --- a/test/TestSuite/Sanity/Range.hs +++ b/test/TestSuite/Sanity/Range.hs @@ -4,16 +4,23 @@ import Data.Bifunctor import Data.Map (Map) import Data.Maybe (fromMaybe) +import Data.Word import Test.Tasty import Test.Tasty.HUnit import Text.Printf import qualified Data.Map as Map -import Test.Falsify.Range (Range, Precision(..), ProperFraction(..)) +import Data.Falsify.WordN (WordN) +import Test.Falsify +import qualified Data.Falsify.WordN as WordN import qualified Test.Falsify.Range as Range +{------------------------------------------------------------------------------- + List of tests +-------------------------------------------------------------------------------} + tests :: TestTree tests = testGroup "TestSuite.Sanity.Range" [ testGroup "between" [ @@ -22,6 +29,10 @@ ] ] +{------------------------------------------------------------------------------- + Test: 'between' +-------------------------------------------------------------------------------} + test_between :: Word -> Assertion test_between size = do assertEqual "domain" [0 .. size - 1] $ @@ -40,7 +51,7 @@ ] where r :: Range Word - r = Range.between (0, size - 1) + r = Range.inclusive (0, size - 1) expected, tolerance :: Double expected = 1 / fromIntegral size @@ -63,14 +74,14 @@ -- each value in the range is produced. stats :: forall a. Ord a => Range a -> [(a, Percentage)] stats r = - count Map.empty $ Range.eval genFraction r + count Map.empty $ Range.eval genWordN r where - genFraction :: Precision -> [ProperFraction] - genFraction (Precision p) + genWordN :: WordN.Precision -> [WordN] + genWordN (WordN.Precision p) | p >= 16 = error $ "stats: precision " ++ show p ++ " too high" | otherwise = [ - ProperFraction $ fromIntegral x / fromIntegral ((2 :: Word) ^ p) - | x <- [0 .. (2 :: Word) ^ p - 1] + WordN.unsafeFromWord64 (WordN.Precision p) x + | x <- [0 .. (2 :: Word64) ^ p - 1] ] count :: Map a Word -> [a] -> [(a, Percentage)] @@ -82,5 +93,3 @@ asPct :: Word -> Percentage asPct c = Percentage (fromIntegral c / fromIntegral total) (c == 0) - - diff --git a/test/TestSuite/Sanity/Selective.hs b/test/TestSuite/Sanity/Selective.hs --- a/test/TestSuite/Sanity/Selective.hs +++ b/test/TestSuite/Sanity/Selective.hs @@ -6,10 +6,15 @@ import Test.Tasty import Test.Tasty.HUnit -import Test.Falsify.Generator (Gen, Tree(..)) +import Data.Falsify.Tree (Tree(..)) +import Test.Falsify import Test.Falsify.Interactive (sample, shrink') import qualified Test.Falsify.Generator as Gen + +{------------------------------------------------------------------------------- + List of tests +-------------------------------------------------------------------------------} tests :: TestTree tests = testGroup "TestSuite.Sanity.Selective" [ diff --git a/test/TestSuite/Util/List.hs b/test/TestSuite/Util/List.hs deleted file mode 100644 --- a/test/TestSuite/Util/List.hs +++ /dev/null @@ -1,16 +0,0 @@ -module TestSuite.Util.List ( - -- * Predicates - pairwiseAll - ) where - -{------------------------------------------------------------------------------- - Predicates --------------------------------------------------------------------------------} - -pairwiseAll :: forall a. (a -> a -> Bool) -> [a] -> Bool -pairwiseAll p = go - where - go :: [a] -> Bool - go [] = True - go [_] = True - go (x:y:zs) = p x y && go (y:zs) diff --git a/test/TestSuite/Util/Tree.hs b/test/TestSuite/Util/Tree.hs deleted file mode 100644 --- a/test/TestSuite/Util/Tree.hs +++ /dev/null @@ -1,83 +0,0 @@ -module TestSuite.Util.Tree ( - -- * Stats - size - , weight - , height - -- * Balancing - , isWeightBalanced - , isHeightBalanced - ) where - -import Test.Falsify.Generator (Tree(..)) - -{------------------------------------------------------------------------------- - Tree stats --------------------------------------------------------------------------------} - --- | Size of the tree -size :: Tree a -> Word -size Leaf = 0 -size (Branch _ l r) = 1 + size l + size r - --- | Weight of the tree --- --- The weight of a tree is simply its size plus one. --- --- @O(1)@ -weight :: Tree a -> Word -weight = succ . size - --- | Height of the tree --- --- The height of a tree is the maximum length from the root to any of the leafs. --- --- @O(1)@ -height :: Tree a -> Word -height Leaf = 0 -height (Branch _ l r) = 1 + max (height l) (height r) - -{------------------------------------------------------------------------------- - Balancing --------------------------------------------------------------------------------} - --- | Check if the tree is weight-balanced --- --- A tree is weight-balanced if the weights of the subtrees does not differ --- by more than a factor 3. --- --- See "Balancing weight-balanced trees", Hirai and Yamamoto, JFP 21(3), 2011. -isWeightBalanced :: Tree a -> Bool -isWeightBalanced = checkBalanceCondition isBalanced - where - delta :: Word - delta = 3 - - isBalanced :: Tree a -> Tree a -> Bool - isBalanced a b = and [ - delta * weight a >= weight b - , delta * weight b >= weight a - ] - --- | Check if a tree is height-balanced --- --- A tree is height balanced if the heights of its subtrees do not differ --- by more than one. -isHeightBalanced :: Tree a -> Bool -isHeightBalanced = checkBalanceCondition isBalanced - where - isBalanced :: Tree a -> Tree a -> Bool - isBalanced a b = or [ - (height a <= height b) && (height b - height a <= 1) - , (height b <= height a) && (height a - height b <= 1) - ] - --- | Internal auxiliary: check given tree balance condition --- --- Property @p l r@ will be checked at every branch in the tree. -checkBalanceCondition :: forall a. (Tree a -> Tree a -> Bool) -> Tree a -> Bool -checkBalanceCondition p = go - where - go :: Tree a -> Bool - go Leaf = True - go (Branch _ l r) = and [p l r, go l, go r] -