quickcheck-helpers (empty) → 1.0.0

raw patch · 6 files changed

+548/−0 lines, 6 filesdep +QuickCheckdep +basedep +quickcheck-helpers

Dependencies added: QuickCheck, base, quickcheck-helpers, tasty, tasty-quickcheck, tasty-quickcheck-laws

Files

• CHANGELOG.md +5/−0
• LICENSE.md +20/−0
• README.md +129/−0
• quickcheck-helpers.cabal +56/−0
• src/Test/QuickCheck/Helpers.hs +254/−0
• test/Main.hs +84/−0

@@ -0,0 +1,5 @@+# Changelog for `quickcheck-helpers`++## 1.0.0++First release.

@@ -0,0 +1,20 @@+# The MIT License (MIT)++Copyright © 2026 MLabs++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the “Software”), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,129 @@+# `quickcheck-helpers`++## What is this?++Consider a typical product type:++```haskell+data Pair a = Pair a a+```++To use `Pair` in QuickCheck tests, you need an `Arbitrary` instance. For product+types, the `arbitrary` method is easy to define:++```haskell+instance Arbitrary a => Arbitrary (Pair a) where+    arbitrary = Pair <$> arbitrary <*> arbitrary+```++However, if we try to define `shrink` similarly, we will get serious issues:++```haskell+instance Arbitrary a => Arbitrary (Pair a) where+    -- Fine+    arbitrary = Pair <$> arbitrary <*> arbitrary+    -- Very not fine+    shrink (Pair x y) = Pair <$> shrink x <*> shrink y+```++Why? Consider `Pair 0 6 :: Pair Int`. We expect that this should still shrink:+even though the first field is not shrinkable, the second one still is. If we+try to shrink, however, we get an unpleasant surprise:++```+>>> shrink (Pair 0 6 :: Pair Int)+[]+```++In general, if we define shrinkers for product types in the way shown above,+shrinking will stop when _any_ field is non-shrinkable. This is not a+consequence of the syntax per se: even if we rewrite it monadically, this still+happens.++To avoid this, we have two options. One is to manually write the shrinker in a+very specific way:++```haskell+instance Arbitrary a => Arbitrary (Pair a) where+    -- No change+    arbitrary = Pair <$> arbitrary <*> arbitrary+    -- Fix, but at what cost?+    shrink (Pair x y) = (Pair <$> pure x <*> shrink y) <|>+                        (Pair <$> shrink x <*> pure y)+```++This will solve the problem, but it's tedious, error-prone and very long.++Another option is to derive `Generic` for your type, then use `genericShrink`+from QuickCheck:++```haskell+data Pair a = Pair a a+    deriving stock (Generic)++instance Arbitrary a => Arbitrary (Pair a) where+    -- No change+    arbitrary = Pair <$> arbitrary <*> arbitrary+    shrink = genericShrink+```++This will also solve the problem, but comes at significant costs in compile-time+performance, run-time performance and a complete and utter lack of clarity about+what actual code gets generated. These are all problems typical of `Generic`+use. However, there is also a deeper problem with this solution. Consider the+following data type:++```haskell+data CountedList a = CountedList Int [a]+    deriving stock (Generic)+```++This data type requires maintaining a _non-structural_ invariant about the `Int`+field. Specifically, the `Int` field must be exactly the length of the `[a]`+field. However, if we attempt to use `genericShrink` with this type:++```haskell+instance Arbitrary a => Arbitrary (CountedList a) where+    arbitrary = do+        NonNegative len <- arbitrary+        CountedList len <$> vectorOf len+    shrink = genericShrink+```++you will end up with many nonsensical shrinks:++```+shrink (CountedList 2 [1, 3] :: CountedList Int)+>>> [CountedList 0 [1,3],CountedList 1 [1,3],CountedList 2 [],CountedList 2 [3],CountedList 2 [1],CountedList 2 [0,3],CountedList 2 [1,0],CountedList 2 [1,2]]+```++Thus, both solutions are in some way inadequate.++`quickcheck-helpers` solves this problem, allowing both concise definitions of+`shrink` for product types (mirroring `arbitrary`) while also giving full+control if necessary.++## How do I use it?++For the `Pair` example above:++```+import Test.QuickCheck.Helpers (toShrink, neShrink)++data Pair a = Pair a a++instance Arbitrary a => Arbitrary (Pair a) where+    -- No change+    arbitrary = Pair <$> arbitrary <*> arbitrary+    -- Using the new functionality+    shrink (Pair x y) = toShrink (Pair <$> neShrink x <*> neShrink y)+```++This solution has both the conciseness of the original (and wrong) shrinkers,+while also giving the improved shrinks of either of the naive solutions, without+the downsides.++## What can I do with this?++This library is licensed under the MIT license. See the `LICENSE.md` file for+details.

@@ -0,0 +1,56 @@+cabal-version: 3.0+name: quickcheck-helpers+version: 1.0.0+synopsis: Helpers for writing shrinkers.+description:+  Provides a way to write shrinkers both concisely and easily, while+  not sacrificing effectiveness.++license: MIT+author: Koz Ross+maintainer: koz@mlabs.city+copyright: (C) MLabs 2026+category: Test+build-type: Simple+tested-with: ghc =={9.8.4, 9.10.3, 9.12.4, 9.14.1}+extra-source-files:+  CHANGELOG.md+  LICENSE.md+  README.md++common lang+  build-depends: base >=4.19.0.0 && <5+  ghc-options:+    -Wmissing-export-lists+    -Wall+    -Wcompat+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wredundant-constraints+    -Wmissing-deriving-strategies+    -Wredundant-bang-patterns++  default-language: Haskell2010++library+  import: lang+  exposed-modules: Test.QuickCheck.Helpers+  build-depends: QuickCheck ^>=2.18.0.0+  hs-source-dirs: src++test-suite tests+  import: lang+  type: exitcode-stdio-1.0+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N++  main-is: Main.hs+  hs-source-dirs: test+  build-depends:+    QuickCheck,+    quickcheck-helpers,+    tasty ^>=1.5.5,+    tasty-quickcheck ^>=0.11.1,+    tasty-quickcheck-laws ^>=0.0.3,

@@ -0,0 +1,254 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module: Test.QuickCheck.Helpers+-- Description: Some functions to help define shrinkers.+-- Copyright: MLabs (C) 2026+-- License: MIT+-- Maintainer: koz@mlabs.city+--+-- = Why we need this+--+-- Consider the following data type:+--+-- > data Pair a = Pair a a+--+-- If we want to define an 'Arbitrary' instance for this type, the 'arbitrary'+-- method is straightforward:+--+-- > instance Arbitrary a => Arbitrary (Pair a) where+-- >     arbitrary = Pair <$> arbitrary <*> arbitrary+--+-- In particular, we can use the applicative syntax to describe 'arbitrary' over+-- @Pair@, which is essentially a product type, both clearly and concisely. One+-- would naturally then believe that 'shrink' would be quite similar:+--+-- > instance Arbitrary a => Arbitrary (Pair a) where+-- >     -- totally fine+-- >     arbitrary = Pair <$> arbitrary <*> arbitrary+-- >     -- very much not fine+-- >     shrink (Pair x y) = Pair <$> shrink x <*> shrink y+--+-- It is, however, very much /not/ similar, nor the right approach. To see why,+-- consider @x = Pair 0 6 :: Pair Int@. We expect that @x@ shrinks; however,+-- using our definition, this will not happen:+--+-- >>> shrink (Pair 0 6 :: Pair Int)+-- []+--+-- This stems from the behaviour of @[]@ as the non-determinism effect: once we+-- get an empty list, the entire computation is \'cut off\'. Thus, in a+-- definition like the one above, a non-shrinking value in /any/ part of a+-- @Pair@ term will block the entire shrink:+--+-- >>> shrink (Pair 6 0 :: Pair Int)+-- []+-- >>> shrink (Pair 0 0 :: Pair Int)+-- []+--+-- While this doesn't violate any of the implicit requirements of shrinking, it+-- is definitely suboptimal: we end up failing to shrink too soon, potentially+-- leaving us with very complex counter-examples.+--+-- The correct way to write a \'product shrinker\' would be something akin to+-- the following:+--+-- > instance Arbitrary a => Arbitrary (Pair a) where+-- >     arbitrary = Pair <$> arbitrary <*> arbitrary+-- >     shrink (Pair x y) = (Pair <$> pure x <*> shrink y) <|>+--                           (Pair <$> shrink x <*> pure y)+--+-- Thus, for an @n@-ary product type, we have to write @n@-many entries between+-- @<|>@, each with @n@-many fields, shrinking exactly one each time. This is+-- long, tedious, and error-prone, especially on larger products.+--+-- = Why not use @Generic@?+--+-- If @Pair@ was given an instance of @Generic@, we could avoid this tedium:+--+-- > data Pair a = Pair a a+-- >     deriving stock (Generic)+-- >+-- > instance Arbitrary a => Arbitrary (Pair a) where+-- >     arbitrary = Pair <$> arbitrary <*> arbitrary+-- >     shrink = genericShrink+--+-- However, setting aside the lack of code clarity and performance issues of+-- @Generic@, this method is not suitable for any type with \'internal+-- invariants\'. More specifically, 'Test.Quickcheck.genericShrink' is purely structural, and+-- will not maintain any invariant that isn't enforced by the type system+-- directly. For example, consider the following:+--+-- > data CountedList a = CountedList Int [a]+--+-- Here, the @Int@ field has to obey the following invariants:+--+-- * Must be non-negative; and+-- * Must be the same as the length of the @[a]@ field.+--+-- If we were to implement 'Arbitrary' for @CountedList@ using 'Test.QuickCheck.genericShrink'+-- for the shrinker, we would end up with nonsensical shrinks that violate these+-- invariants. This could cause test failures that would never reflect realistic+-- use of this type: we expect that its API would maintain these invariants, and+-- thus, such situations should not arise.+--+-- Thus, in any situation where we have invariants that aren't \'purely+-- structural\', this method is incorrect and cannot be used.+--+-- = Our solution+--+-- We want to ensure that for a product type, shrinking only fails if /all/+-- fields fail to shrink, rather than if /any/ fields fail to shrink. For this,+-- we have 'Shrink', which is essentially @[]@ with the added ability to+-- remember what term we asked it to shrink. This allows us to avoid the \'early+-- failure\' problem of @[]@ described earlier. We can use 'neShrink' to+-- \'promote\' regular shrinkers for fields into 'Shrink'. Once we're finished+-- with our product type, we can use 'runShrink' to \'return\' back to @[]@.+--+-- If we use 'Shrink' via 'neShrink' and 'runShrink' to define @Pair@'s+-- 'Arbitrary' instance, we get the following:+--+-- > data Pair a = Pair a a+-- >+-- > instance Arbitrary a => Arbitrary (Pair a) where+-- >     arbitrary = Pair <$> arbitrary <*> arbitrary+-- >     shrink (Pair x y) = 'runShrink' (Pair <$> 'neShrink' x <*> 'neShrink' y)+--+-- We now can have a similar level of clarity and conciseness to the 'arbitrary'+-- method, but /without/ the undesirable behaviour we saw before:+--+-- >>> shrink (Pair 0 6 :: Pair Int)+-- [Pair 0 5, Pair 0 3, Pair 0 0]+-- >>> shrink (Pair 6 0 :: Pair Int)+-- [Pair 5 0, Pair 3 0, Pair 0 0]+-- >>> shrink (Pair 0 0 :: Pair Int)+-- []+--+-- @since 1.0.0+module Test.QuickCheck.Helpers+  ( Shrink,+    neShrink,+    neShrinkOver,+    neShrinkWhen,+    runShrink,+    toShrink,+  )+where++import Data.Coerce (Coercible, coerce)+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty ((:|)))+import Test.QuickCheck (Arbitrary (arbitrary, shrink), oneof)++-- | A \'non-empty\' shrinking effect. Unlike shrinkers implemented in @[]@,+-- 'Shrink' remembers what value it was asked to shrink, and can produce it if+-- no shrinks are available.+--+-- @since 1.0.0+data Shrink (a :: Type)+  = NonShrinking a+  | Shrinking (NonEmpty a)+  deriving stock+    ( -- | @since 1.0.0+      Eq,+      -- | @since 1.0.0+      Show,+      -- | @since 1.0.0+      Functor+    )++-- | @since 1.0.0+instance Applicative Shrink where+  pure = NonShrinking+  fs <*> xs = case fs of+    NonShrinking f -> case xs of+      NonShrinking x -> NonShrinking (f x)+      Shrinking xs' -> Shrinking (fmap f xs')+    Shrinking fs' -> case xs of+      NonShrinking x -> Shrinking (fmap ($ x) fs')+      Shrinking xs' -> Shrinking (fs' <*> xs')++-- | @since 1.0.0+instance (Arbitrary a) => Arbitrary (Shrink a) where+  arbitrary = oneof [NonShrinking <$> arbitrary, Shrinking <$> arbitrary]+  shrink = \case+    NonShrinking _ -> []+    Shrinking xs -> Shrinking <$> shrink xs++-- | Convert a 'Shrink' into an expected QuickCheck shrinker result.+-- Specifically, if a 'Shrink' has no valid shrink targets, 'runShrink' will+-- produce an empty list; otherwise, it will produce a list of targets.+--+-- @since 1.0.0+runShrink ::+  forall (a :: Type).+  Shrink a ->+  [a]+runShrink = \case+  NonShrinking _ -> []+  Shrinking (y :| ys) -> y : ys++-- | As 'runShrink', but instead of converting a 'Shrink', it will convert a+-- function producing a shrink into a valid implementation of the 'shrink' type+-- class method of 'Arbitrary'.+--+-- @since 1.0.0+toShrink ::+  forall (a :: Type).+  (a -> Shrink a) ->+  a ->+  [a]+toShrink f x = runShrink (f x)++-- | \'Promotes\' an implementation of 'shrink' into 'Shrink'.+--+-- @since 1.0.0+neShrink ::+  forall (a :: Type).+  (Arbitrary a) => a -> Shrink a+neShrink x = case shrink x of+  [] -> NonShrinking x+  (y : ys) -> Shrinking (y :| ys)++-- | As 'neShrink', but by way of a \'wrapper\' we can 'coerce' through. Useful+-- with modifiers, as it means you don't have to manually unwrap and re-wrap+-- them.+--+-- = Note+--+-- This function is ambiguously typed, and expects a type argument to determine+-- what \'wrapper\' to use. The type signature is designed to allow easy use of+-- @TypeApplications@ for this:+--+-- > -- Wraps a value into NonNegative for shrinking, then unwraps+-- > neShrinkOver @(NonNegative Integer) x+--+-- @since 1.0.0+neShrinkOver ::+  forall (b :: Type) (a :: Type).+  (Arbitrary b, Coercible a b) =>+  a -> Shrink a+neShrinkOver x = case coerce . shrink @b . coerce $ x of+  [] -> NonShrinking x+  (y : ys) -> Shrinking (y :| ys)++-- | As 'neShrink', but allows adding a condition that any shrunk results must+-- satisfy. This is needed because 'Shrink' cannot be an instance of+-- 'Control.Applicative.Alternative'.+--+-- @since 1.0.0+neShrinkWhen ::+  forall (a :: Type).+  (Arbitrary a) =>+  (a -> Bool) ->+  a ->+  Shrink a+neShrinkWhen cond x = case filter cond . shrink $ x of+  [] -> NonShrinking x+  (y : ys) -> Shrinking (y :| ys)

@@ -0,0 +1,84 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Main (main) where++import Data.Kind (Type)+import Data.Proxy (Proxy (Proxy))+import Test.QuickCheck+  ( Arbitrary (arbitrary, shrink),+    Gen,+    Property,+    forAll,+    (.&&.),+    (===),+  )+import Test.QuickCheck.Helpers (Shrink, neShrink, toShrink)+import Test.QuickCheck.Poly (A)+import Test.Tasty (adjustOption, defaultMain, testGroup)+import Test.Tasty.QuickCheck (QuickCheckTests, testProperty)+import Test.Tasty.QuickCheck.Laws (Checkable)+import Test.Tasty.QuickCheck.Laws.Applicative (testApplicativeLaws1)++main :: IO ()+main =+  defaultMain . adjustOption moreTests . testGroup "Tests" $+    [ adjustOption fewerTests $ testApplicativeLaws1 (Proxy @Shrink) (Proxy @()) (Proxy @A) (const (==)),+      testProperty "Shrink with <*>" propBadShrink,+      testProperty "neShrink with <*> (left non-shrinking)" propGoodShrinkLeft,+      testProperty "neShrink with <*> (right non-shrinking)" propGoodShrinkRight+    ]+  where+    moreTests :: QuickCheckTests -> QuickCheckTests+    moreTests = max 10_000+    -- Needed because the test for Applicative's associativity takes forever+    -- otherwise+    fewerTests :: QuickCheckTests -> QuickCheckTests+    fewerTests x = x `quot` 8++-- Properties++propBadShrink :: Property+propBadShrink = forAll ((,) <$> genPairLeft @Int <*> genPairRight @Int) $ \(pLeft, pRight) ->+  [] === badShrink pLeft .&&. [] === badShrink pRight++propGoodShrinkLeft :: Property+propGoodShrinkLeft = forAll @(Pair Int) genPairLeft $ \p@(Pair x y) ->+  (Pair x <$> shrink y) === goodShrink p++propGoodShrinkRight :: Property+propGoodShrinkRight = forAll @(Pair Int) genPairRight $ \p@(Pair x y) ->+  (Pair <$> shrink x <*> pure y) === goodShrink p++-- Helpers++data Pair (a :: Type) = Pair a a+  deriving stock (Eq, Show)++genPairLeft ::+  forall (a :: Type).+  (Arbitrary a, Num a) => Gen (Pair a)+genPairLeft = Pair 0 <$> arbitrary++genPairRight ::+  forall (a :: Type).+  (Arbitrary a, Num a) => Gen (Pair a)+genPairRight = Pair <$> arbitrary <*> pure 0++badShrink ::+  forall (a :: Type).+  (Arbitrary a) => Pair a -> [Pair a]+badShrink (Pair x y) = Pair <$> shrink x <*> shrink y++goodShrink ::+  forall (a :: Type).+  (Arbitrary a) => Pair a -> [Pair a]+goodShrink = toShrink (\(Pair x y) -> Pair <$> neShrink x <*> neShrink y)++-- Ugh+deriving via Integer instance Checkable A