packages feed

tasty-falsify (empty) → 0.1.0

raw patch · 18 files changed

+2080/−0 lines, 18 filesdep +QuickCheckdep +basedep +containers

Dependencies added: QuickCheck, base, containers, data-default, falsify, optparse-applicative, selective, tagged, tasty, tasty-falsify

Files

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