falsify 0.3.0 → 0.4.0

raw patch · 66 files changed

+3669/−4275 lines, 66 filesdep −QuickCheckdep −optparse-applicativedep −taggeddep ~data-defaultdep ~tastyPVP ok

version bump matches the API change (PVP)

Dependencies removed: QuickCheck, optparse-applicative, tagged

Dependency ranges changed: data-default, tasty

API changes (from Hackage documentation)

Files

• CHANGELOG.md +93/−0
• LICENSE +1/−1
• falsify.cabal +47/−54
• src/Data/Falsify/ConcreteFun.hs +130/−0
• src/Data/Falsify/Integer.hs +0/−59
• src/Data/Falsify/Internal/Integer.hs +59/−0
• src/Data/Falsify/Internal/List.hs +52/−0
• src/Data/Falsify/List.hs +0/−80
• src/Data/Falsify/Marked.hs +0/−57
• src/Data/Falsify/Permutation.hs +85/−0
• src/Data/Falsify/ProperFraction.hs +55/−0
• src/Data/Falsify/Tree.hs +87/−104
• src/Data/Falsify/WordN.hs +90/−0
• src/Test/Falsify.hs +74/−0
• src/Test/Falsify/Context.hs +75/−0
• src/Test/Falsify/Driver.hs +78/−0
• src/Test/Falsify/GenDefault.hs +47/−20
• src/Test/Falsify/GenDefault/Std.hs +7/−4
• src/Test/Falsify/Generator.hs +10/−36
• src/Test/Falsify/Interactive.hs +34/−39
• src/Test/Falsify/Internal/Driver.hs +155/−81
• src/Test/Falsify/Internal/Driver/ReplaySeed.hs +33/−29
• src/Test/Falsify/Internal/Driver/Tasty.hs +0/−176
• src/Test/Falsify/Internal/Fun.hs +78/−0
• src/Test/Falsify/Internal/Generator.hs +224/−12
• src/Test/Falsify/Internal/Generator/Compound.hs +461/−0
• src/Test/Falsify/Internal/Generator/Definition.hs +0/−238
• src/Test/Falsify/Internal/Generator/Function.hs +266/−0
• src/Test/Falsify/Internal/Generator/Precision.hs +38/−0
• src/Test/Falsify/Internal/Generator/Shrinking.hs +141/−143
• src/Test/Falsify/Internal/Generator/Simple.hs +52/−0
• src/Test/Falsify/Internal/Marked/Tree.hs +80/−0
• src/Test/Falsify/Internal/ProperFraction.hs +0/−58
• src/Test/Falsify/Internal/Property.hs +203/−65
• src/Test/Falsify/Internal/Range.hs +8/−6
• src/Test/Falsify/Internal/SampleTree.hs +4/−145
• src/Test/Falsify/Internal/Search.hs +1/−1
• src/Test/Falsify/Internal/Shrinking.hs +205/−0
• src/Test/Falsify/Marked.hs +79/−0
• src/Test/Falsify/Predicate.hs +287/−34
• src/Test/Falsify/Property.hs +0/−30
• src/Test/Falsify/Range.hs +34/−27
• src/Test/Falsify/Reexported/Generator/Compound.hs +0/−440
• src/Test/Falsify/Reexported/Generator/Function.hs +0/−398
• src/Test/Falsify/Reexported/Generator/Precision.hs +0/−73
• src/Test/Falsify/Reexported/Generator/Shrinking.hs +0/−128
• src/Test/Falsify/Reexported/Generator/Simple.hs +0/−64
• src/Test/Falsify/SampleTree.hs +156/−0
• src/Test/Falsify/ShrinkTree.hs +34/−0
• src/Test/Tasty/Falsify.hs +0/−28
• test/Main.hs +0/−19
• test/TestSuite/GenDefault.hs +64/−41
• test/TestSuite/Prop/Generator/Compound.hs +0/−326
• test/TestSuite/Prop/Generator/Function.hs +0/−153
• test/TestSuite/Prop/Generator/Marking.hs +0/−84
• test/TestSuite/Prop/Generator/Precision.hs +0/−69
• test/TestSuite/Prop/Generator/Prim.hs +0/−383
• test/TestSuite/Prop/Generator/Selective.hs +0/−99
• test/TestSuite/Prop/Generator/Shrinking.hs +0/−165
• test/TestSuite/Prop/Generator/Simple.hs +0/−189
• test/TestSuite/Regression.hs +5/−7
• test/TestSuite/Sanity/Predicate.hs +13/−2
• test/TestSuite/Sanity/Range.hs +18/−8
• test/TestSuite/Sanity/Selective.hs +6/−1
• test/TestSuite/Util/List.hs +0/−16
• test/TestSuite/Util/Tree.hs +0/−83

@@ -1,5 +1,98 @@ # 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

@@ -1,4 +1,4 @@-Copyright (c) 2023, Well-Typed LLP+Copyright (c) 2023-2026, Well-Typed LLP  All rights reserved. 

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               falsify-version:            0.3.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                     @<https://hackage.haskell.org/package/tasty tasty>@,-                    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@@ -32,7 +33,7 @@                   , GHC==9.6.7                   , GHC==9.8.4                   , GHC==9.10.3-                  , GHC==9.12.2+                  , GHC==9.12.4                   , GHC==9.14.1  source-repository head@@ -81,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.ProperFraction+      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.13-    , containers           >= 0.6  && < 0.9-    , data-default         >= 0.7  && < 0.9-    , mtl                  >= 2.2  && < 2.4-    , optics-core          >= 0.3  && < 0.5-    , optparse-applicative >= 0.16 && < 0.20-    , 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.6-    , 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@@ -149,28 +155,15 @@       Main.hs   other-modules:       TestSuite.GenDefault-      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.Regression       TestSuite.Sanity.Predicate       TestSuite.Sanity.Range       TestSuite.Sanity.Selective-      TestSuite.Util.List-      TestSuite.Util.Tree   build-depends:-    , QuickCheck  >= 2.14 && < 2.19-    , 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

@@ -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+-- (<https://dl.acm.org/doi/10.1145/2430532.2364516>). 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 ]

@@ -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 <https://en.wikipedia.org/wiki/Elias_gamma_coding> .-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

@@ -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 <https://en.wikipedia.org/wiki/Elias_gamma_coding> .+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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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+

@@ -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 "*" []

@@ -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)

@@ -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

@@ -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)

@@ -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+        )

@@ -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 qualified Control.Applicative as Ap-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,6 +50,10 @@ 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} @@ -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

@@ -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 ()

@@ -2,19 +2,16 @@ -- -- Intended for qualified import. ----- > import Test.Falsify.Generator (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@@ -84,14 +63,9 @@  import Prelude hiding (either, elem, properFraction) -import Data.Falsify.List-import Data.Falsify.Marked-import Data.Falsify.Tree- import Test.Falsify.Internal.Generator-import Test.Falsify.Internal.ProperFraction-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 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

@@ -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

@@ -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]       ] 

@@ -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

@@ -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-    }

@@ -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     = "<fun>"++{-------------------------------------------------------------------------------+  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 #-}

@@ -1,15 +1,7 @@--- | 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@@ -23,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, [])

@@ -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

@@ -1,238 +0,0 @@-module Test.Falsify.Internal.Generator.Definition (-    -- * Definition-    Gen(..)-  , bindWithoutShortcut-  , minimalValue-    -- * 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]-        ]---- | 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, [])

@@ -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

@@ -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

@@ -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+    }

@@ -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

@@ -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

@@ -1,58 +0,0 @@-module Test.Falsify.Internal.ProperFraction (-    ProperFraction(ProperFraction)-    -- * Construction and generation-  , mkFraction-  , properFraction-  ) where--import Prelude hiding (properFraction)--import GHC.Show-import GHC.Stack--import Test.Falsify.Reexported.Generator.Precision-import Test.Falsify.Internal.Generator--{--------------------------------------------------------------------------------  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 '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 #-}--{--------------------------------------------------------------------------------  Construction--------------------------------------------------------------------------------}---- | 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

@@ -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

@@ -6,8 +6,10 @@  import Data.List.NonEmpty (NonEmpty) -import Test.Falsify.Reexported.Generator.Precision+import Data.Falsify.WordN (WordN) +import qualified Data.Falsify.WordN as WordN+ {-------------------------------------------------------------------------------   Definition -------------------------------------------------------------------------------}@@ -17,14 +19,14 @@   -- | Constant (point) range   Constant :: a -> Range a -  -- | Construct value from 'WordN' of the given precision+  -- | Construct value from t'WordN' of the given precision   --   -- This is the main constructor for 'Range'.   ---  -- Typically this 'WordN' is used to construct a fraction which is then used-  -- to index the range (see 'fromProperFraction'), though some generators use-  -- the 'WordN' directly.-  FromWordN :: Precision -> (WordN -> 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\"   --

@@ -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)-

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -2,14 +2,14 @@ -- -- Intended for qualified import. ----- > import Test.Falsify.Range (Range)+-- > import Test.Falsify -- > import qualified Test.Falsify.Range as Range module Test.Falsify.Range (-    Range -- opaque+    Range     -- * Constructors     -- ** Linear   , uniform-  , between+  , inclusive   , enum   , withOrigin     -- ** Non-linear@@ -17,8 +17,6 @@     -- * Queries   , origin     -- * Primitive constructors-  , ProperFraction(..)-  , Precision(..)   , constant   , fromProperFraction   , towards@@ -34,10 +32,12 @@  import qualified Data.List.NonEmpty as NE -import Test.Falsify.Internal.ProperFraction+import Data.Falsify.ProperFraction (ProperFraction(..))+import Data.Falsify.WordN (WordN) import Test.Falsify.Internal.Range-import Test.Falsify.Reexported.Generator.Precision +import qualified Data.Falsify.WordN as WordN+ {-------------------------------------------------------------------------------   Primitive ranges -------------------------------------------------------------------------------}@@ -52,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 p f = FromWordN p $ f . mkFraction+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@@ -80,16 +80,16 @@ -- Shrinks towards zero. -- -- If you don't need specific bounds, you should probably use 'uniform' instead--- of 'between', especially for large bit sizes, because we can more easily+-- 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 $ \(WordN _ x) ->+uniform = FromWordN precision $ \x ->     if isUnsigned-      then toUnsigned x-      else toSigned   x+      then toUnsigned (WordN.forgetPrecision x)+      else toSigned   (WordN.forgetPrecision x)   where-    precision :: Precision-    precision = Precision $ fromIntegral $ finiteBitSize (undefined :: a)+    precision :: WordN.Precision+    precision = WordN.Precision $ fromIntegral $ finiteBitSize (undefined :: a)      isUnsigned :: Bool     isUnsigned = signum (-1 :: a) == 1@@ -117,18 +117,22 @@         maxPos :: Word64         maxPos = fromIntegral (maxBound :: a) --- | Uniform selection between the given bounds, shrinking towards first bound+-- | 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'.-between :: forall a. (Integral a, FiniteBits a) => (a, a) -> Range a-between = skewedBy 0+inclusive :: forall a. (Integral a, FiniteBits a) => (a, a) -> Range a+inclusive = skewedBy 0 --- | Variation on 'between' for types that are 'Enum' but not 'Integral'+-- | 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 --@@ -145,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@@ -156,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@@ -317,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) @@ -327,7 +334,7 @@  -- | Origin of the range (value we shrink towards) origin ::  Range a -> a-origin = runIdentity . eval (\p -> Identity $ WordN p 0)+origin = runIdentity . eval (\p -> Identity $ WordN.zero p)  {-------------------------------------------------------------------------------   Evaluation@@ -338,7 +345,7 @@ -- Most users will probably never need to call this function. eval :: forall f a.      Applicative f-  => (Precision -> f WordN) -> Range a -> f a+  => (WordN.Precision -> f WordN) -> Range a -> f a eval genWordN = go   where     go :: forall x. Range x -> f x

@@ -1,440 +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-        -- Go through 'Integer' to avoid overflow-        mid' :: Integer-        mid' = fromIntegral lo + ((fromIntegral hi - fromIntegral lo) `div` 2)--        mid :: a-        mid = fromInteger mid'--{--------------------------------------------------------------------------------  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-

@@ -1,398 +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.Void (Void)-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     = "<fun>"---- | 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 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 (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 V1 where-  gFunction _ = pure Nil--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

@@ -1,73 +0,0 @@--- | Fixed precision generators-module Test.Falsify.Reexported.Generator.Precision (-    -- * @n@-bit words-    Precision(..)-  , WordN(..)-    -- * Construction and generation-  , truncateAt-  , wordN-  ) where--import Data.Bits-import Data.Word--import Test.Falsify.Internal.Generator-import Test.Falsify.Internal.SampleTree (sampleValue)-import Test.Falsify.Internal.Search--{--------------------------------------------------------------------------------  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)--forgetPrecision :: WordN -> Word64-forgetPrecision (WordN _ x) = x--{--------------------------------------------------------------------------------  Construction and generation--------------------------------------------------------------------------------}---- | 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

@@ -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)

@@ -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 wordN 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-

@@ -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)

@@ -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

@@ -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