packages feed

tinycheck (empty) → 0.1.0.0

raw patch · 14 files changed

+1838/−0 lines, 14 filesdep +basedep +generics-sopdep +tagged

Dependencies added: base, generics-sop, tagged, tasty, tinycheck

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for tinycheck++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2026, Manuel Bärenz+++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 the copyright holder nor the names of its+      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+HOLDER 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.
+ README.md view
@@ -0,0 +1,103 @@+# tinycheck++A lightweight, **deterministic** property testing library for Haskell.++Instead of generating random inputs, `tinycheck` enumerates test cases from a+canonical, fairly-interleaved ordering.  Tests are reproducible, require no+seeds, and cover small values first — no shrinking required.++## Quick start++```haskell+import Test.Tasty+import Test.Tasty.TinyCheck++main :: IO ()+main = defaultMain $ testGroup "my suite"+  [ testProperty "reverse . reverse == id" $+      \(xs :: [Int]) -> reverse (reverse xs) == xs+  , testProperty "abs x >= 0" $+      \(x :: Int) -> abs x >= 0+  ]+```++Run with `cabal test`.++## How it works++The core type is `TestCases a` — a newtype over `[a]` whose `Semigroup`,+`Applicative`, and `Monad` instances use **fair interleaving** instead of+concatenation and cartesian product.++```+TestCases [1,2,3] <> TestCases [10,20,30]  ==  TestCases [1,10,2,20,3,30]+```++With infinite generators this ensures neither side is starved:++```+(Left <$> TestCases [1..]) <> (Right <$> TestCases [1..])+  ==  TestCases [Left 1, Right 1, Left 2, Right 2, ...]+```++`Applicative` interleaves function-argument pairs, so all parts of the input+space are explored immediately rather than exhausting one argument before+moving to the next.++Use `interleaveN` to interleave any number of generators fairly:++```+interleaveN [TestCases [1,2,3], TestCases [10,20,30], TestCases [100,200,300]]+  ==  TestCases [1,10,100, 2,20,200, 3,30,300]+```++## Defining generators++Implement `Arbitrary` for your types, or derive it via `Generically`:++```haskell+{-# LANGUAGE DeriveGeneric #-}+import GHC.Generics (Generic, Generically (..))+import Data.TestCases (Arbitrary)++data Colour = Red | Green | Blue+  deriving stock (Show, Generic)+  deriving (Arbitrary) via Generically Colour+```++Newtype wrappers are provided for common patterns:++| Wrapper | Suitable for |+|---|---|+| `SignedArbitrary` | `Num` + `Enum` (e.g. `Int`, `Integer`) |+| `BoundedArbitrary` | `Bounded` + `Enum` (e.g. `Bool`, `Word8`) |+| `RealFracArbitrary` | `Fractional` + `Enum` (e.g. `Float`, `Double`) |+| ... | ... |++## Preconditions++Use `==>` to skip inputs that don't satisfy a precondition:++```haskell+testProperty "n > 0 implies n * 2 > 0" $+  \(n :: Int) -> (n > 0) ==> property (n * 2 > 0)+```++# Development++## Modules++| Module | Purpose |+|---|---|+| `Data.TestCases` | Core `TestCases` type, `Arbitrary`, `CoArbitrary` |+| `Test.Tasty.TinyCheck` | Tasty integration (`testProperty`, `testPropertyWith`, …) |++### `examples/`++Two standalone examples for defining `Arbitrary` instances for your own types are provided here.++## AI usage++The central pieces are developed by a human, @turion.+Many details (tasty integration, boilerplate, test cases, longer docs) have been generated by AI+(Github Copilot with Claude Opus & Sonnet 4.6) and are thoroughly checked by myself.
+ examples/Colour.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveGeneric #-}++-- | Example from the README: deriving 'Arbitrary' via 'Generically'.+module Main where++import Data.TestCases (Arbitrary, TestCases, arbitrary, getTestCases)+import GHC.Generics (Generic, Generically (..))++data Colour = Red | Green | Blue+  deriving stock (Show, Eq, Generic)+  deriving (Arbitrary) via Generically Colour++{- | Print all generated 'Colour' test cases, demonstrating that deriving+'Arbitrary' via 'Generically' enumerates all constructors.+-}+main :: IO ()+main = mapM_ print (getTestCases (arbitrary :: TestCases Colour))
+ examples/Tree.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DeriveGeneric #-}++{- | Standalone example: a binary tree and properties comparing its+'Foldable' instance against list operations.+-}+module Main where++-- base+import Data.Foldable (toList)+import Data.List (nub, sort)+import GHC.Generics (Generic, Generically (..))++-- tasty+import Test.Tasty+import Test.Tasty.TinyCheck++-- tinycheck+import Data.TestCases (Arbitrary (..), getTestCases)++-- * Tree type++data Tree a = Leaf | Node (Tree a) a (Tree a)+  deriving stock (Show, Eq, Foldable, Generic)+  deriving (Arbitrary) via Generically (Tree a)++-- * Operations++insert :: (Ord a) => a -> Tree a -> Tree a+insert x Leaf = Node Leaf x Leaf+insert x (Node l y r)+  | x < y = Node (insert x l) y r+  | x > y = Node l y (insert x r)+  | otherwise = Node l y r -- duplicate: ignore++fromList :: (Ord a) => [a] -> Tree a+fromList = foldr insert Leaf++-- * Main++main :: IO ()+main =+  defaultMain $+    testGroup+      "Tree"+      [ testGroup+          "fromList"+          [ testProperty "sort . toList . fromList == sort . nub" $+              \(xs :: [Int]) ->+                sort (toList (fromList xs)) == sort (nub xs)+          , testProperty "elem x (fromList xs) == elem x xs" $+              \(x :: Int, xs :: [Int]) ->+                (x `elem` fromList xs) == elem x xs+          ]+      , testGroup+          "Foldable"+          [ testProperty "sum t == sum (toList t)" $+              \(t :: Tree Int) ->+                sum t == sum t+          , testProperty "product t == product (toList t)" $+              \(t :: Tree Int) ->+                product t == product t+          , testProperty "length t == length (toList t)" $+              \(t :: Tree Int) ->+                length t == length t+          , testProperty "null t == null (toList t)" $+              \(t :: Tree Int) ->+                null t == null t+          ]+      , testGroup+          "insert"+          [ testProperty "inserted element is found" $+              \(x :: Int, xs :: [Int]) ->+                x `elem` insert x (fromList xs)+          , testProperty "insert doesn't remove elements" $+              \(x :: Int, xs :: [Int]) ->+                all (`elem` insert x (fromList xs)) xs+          , testProperty "insert is idempotent up to sorted toList" $+              \(x :: Int, xs :: [Int]) ->+                let t = fromList xs+                 in sort (toList (insert x (insert x t))) == sort (toList (insert x t))+          ]+      , testProperty "first cases match documentation in main module" $+          take 4 (getTestCases arbitrary :: [Tree Int]) == [Leaf, Node Leaf 0 Leaf, Node (Node Leaf 0 Leaf) 0 Leaf, Node Leaf (-1) Leaf]+      ]
+ src/Data/TestCases.hs view
@@ -0,0 +1,928 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE UndecidableInstances #-}++{- | A lightweight enumeration-based property testing library.++Instead of random generation, 'TestCases' is a deterministic, ordered list+of test inputs.  The 'Semigroup' instance interleaves two lists so that+both finite and infinite generators compose fairly (neither starves the other).+-}+module Data.TestCases (+  -- * TestCases+  TestCases (..),+  testCase,+  interleaveN,++  -- * Running tests (plain IO)+  test,+  testWithMsg,++  -- * Arbitrary+  Arbitrary (..),++  -- ** Newtype wrappers for deriving+  SignedArbitrary (..),+  BoundedArbitrary (..),+  RealFracArbitrary (..),++  -- ** String generators+  string,+  atLeast,+  wordsOf,+  linesOf,++  -- ** Char generators+  allChars,+  commonASCIIChars,+  printableChars,+  letterChars,+  digitChars,+  inCategories,++  -- ** Newtype wrappers for common char/string generators+  Printable (..),+  Letter (..),+  Digit (..),+  Upper (..),+  Lower (..),+  AsciiWord (..),+  LetterWord (..),+  DigitWord (..),+  AsciiLine (..),++  -- * CoArbitrary+  CoArbitrary (..),++  -- ** Newtype wrappers for deriving+  OrdCoArbitrary (..),+  IntegralCoArbitrary (..),+  EnumCoArbitrary (..),+  RealFracCoArbitrary (..),+)+where++-- base+import Control.Monad (ap, forM_, replicateM, unless)+import Data.Char (GeneralCategory (..), chr, generalCategory)+import Data.Coerce (coerce)+import Data.Complex (Complex (..))+import Data.Fixed (Fixed (..), HasResolution)+import Data.Functor.Compose (Compose (..))+import Data.Functor.Const (Const (..))+import Data.Functor.Identity (Identity (..))+import Data.Functor.Product qualified as FP (Product (..))+import Data.Functor.Sum qualified as FS (Sum (..))+import Data.Int (Int16, Int32, Int64, Int8)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Monoid (All (..), Alt (..), Any (..), Ap (..), Dual (..), Endo (..), First (..), Last (..))+import Data.Monoid qualified as Monoid (Product (..), Sum (..))+import Data.Ord (Down (..))+import Data.Proxy (Proxy (..))+import Data.Ratio (Ratio, (%))+import Data.Semigroup qualified as Semigroup (Arg (..), First (..), Last (..), Max (..), Min (..), WrappedMonoid (..))+import Data.Version (Version (..))+import Data.Void (Void)+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.Generics+import Numeric.Natural (Natural)+import System.Exit (ExitCode (..))++-- generics-sop+import Generics.SOP qualified as SOP+import Generics.SOP.GGP qualified as SOP (GCode, GFrom, GTo, gfrom, gto)++-- * TestCases++{- | An ordered collection of test inputs.++'TestCases' is a newtype over a list, but its 'Semigroup', 'Applicative',+and 'Monad' instances differ from those of ordinary lists: instead of+concatenation and cartesian product, they use /fair interleaving/.++=== Why interleaving?++Property tests often combine several generators.  With plain list+concatenation, @xs <> ys@ visits every element of @xs@ before touching+@ys@: if @xs@ is infinite, @ys@ is never reached.  Interleaving+alternates between the two sources, so both infinite generators are+explored fairly.++=== How interleaving works++@'TestCases' [1,2,3] '<>' 'TestCases' [10,20,30]@+produces @[1,10,2,20,3,30]@.+If one side is longer the remainder is appended:++> TestCases [1,2,3] <> TestCases [10,20] == TestCases [1,10,2,20,3]+> TestCases [1,2]   <> TestCases [10,20,30] == TestCases [1,10,2,20,30]++With two infinite sides, both are explored fairly:++> (Left <$> TestCases [1..]) <> (Right <$> TestCases [1..])+>   == TestCases [Left 1, Right 1, Left 2, Right 2, Left 3, Right 3, ...]++In practice, this means that all different /shapes/ of data can be explored early,+before all values of one shape are exhausted.++=== Applicative and Monad++'Applicative' is derived from 'Monad' via @('<*>') = 'ap'@, and 'Monad'+bind is @'foldMap'@, which accumulates results with '<>'.  This means+@('<*>')@ interleaves the results of applying each function to each+argument, rather than producing a full cartesian product in lexicographic+order.  Compare:++> -- Plain list: exhausts the first argument before moving to the next+> (,) <$> "abc" <*> [1,2,3,4,5,6]+>   == [('a',1),('a',2),('a',3),('a',4),('a',5),('a',6),+>       ('b',1),('b',2),('b',3),('b',4),('b',5),('b',6),+>       ('c',1),('c',2),('c',3),('c',4),('c',5),('c',6)]+>+> -- TestCases: interleaves, so all three characters appear immediately+> (,) <$> TestCases "abc" <*> TestCases [1,2,3,4,5,6]+>   == TestCases+>        [('a',1),('b',1),('a',2),('c',1),('a',3),('b',2),+>         ('a',4),('c',2),('a',5),('b',3),('a',6),('c',3),+>         ('b',4),('c',4),('b',5),('c',5),('b',6),('c',6)]++=== Laws and why they don\'t hold — and why that\'s fine++The 'Semigroup' associativity law (@(a '<>' b) '<>' c == a '<>' (b '<>' c)@)+does /not/ hold for 'TestCases': interleaving is not associative in general.+For example:++> (TestCases [1] <> TestCases [2]) <> TestCases [3]+>   == TestCases [1,2] <> TestCases [3]+>   == TestCases [1,3,2]+>+> TestCases [1] <> (TestCases [2] <> TestCases [3])+>   == TestCases [1] <> TestCases [2,3]+>   == TestCases [1,2,3]++Consequently the 'Applicative' and 'Monad' laws (which depend on associativity of bind) also fail.++In practice this does not matter much: a property test only cares whether /all/+generated cases pass, not about the order in which they are visited.+Any permutation of the input list yields the same test outcome.  The interleaving+strategy is chosen purely to ensure that each case is visited early and no generator is starved,+not to produce any canonical ordering.++You can use this fact to your advantage:+if you want to visit some cases earlier,+merge them into your generator last.+For example, in @(a '<>' b) '<>' c@, cases from @c@ are visited at double the speed compared to each @a@ and @b@.+-}+newtype TestCases a = TestCases {getTestCases :: [a]}+  deriving newtype (Show, Foldable, Functor)++-- | Lift a single value into 'TestCases'.+testCase :: a -> TestCases a+testCase = TestCases . pure++{- | Fairly interleave any number of 'TestCases'.++Each round emits one element from each non-empty source in order, then repeats with the remaining tails.+Empty sources are skipped.+Elements are emitted one at a time, so the output is productive even when sources are built recursively.+This generalises '<>' from two sources to @n@ sources:++> interleaveN [TestCases [1,2,3], TestCases [10,20,30], TestCases [100,200,300]]+>   == TestCases [1,10,100, 2,20,200, 3,30,300]++Works correctly when sources have different lengths or are infinite:++> interleaveN [TestCases [1,2], TestCases [10,20,30], TestCases [100]]+>   == TestCases [1,10,100, 2,20, 30]++@'interleaveN' [a, b] == a '<>' b@.+-}+interleaveN :: [TestCases a] -> TestCases a+interleaveN = TestCases . go . fmap getTestCases+  where+    go [] = []+    go xss = step xss []+    -- Emit one head from each non-empty source, accumulating the non-empty tails,+    -- then recurse.  Emitting is done one element at a time so that the output+    -- is productive even when the source list is built recursively.+    step [] acc = go (reverse acc)+    step ([] : xss) acc = step xss acc+    step ((x : xs) : xss) acc = x : step xss (xs : acc)++{- | Interleave two 'TestCases' so that neither side starves the other.+This is the key operation: it lets us combine two (potentially infinite) generators and still visit cases from both.++The left-hand element is always emitted first, then the sources alternate:++> TestCases [a1,a2,...] <> TestCases [b1,b2,...] = TestCases [a1,b1,a2,b2,...]++See the documentation of 'TestCases' for a discussion of the law violations+this entails and why they are harmless.+-}+instance Semigroup (TestCases a) where+  TestCases as1 <> TestCases as2 = TestCases $ mingle as1 as2+    where+      mingle [] bs = bs+      mingle (a : as') bs = a : mingle bs as'++instance Monoid (TestCases a) where+  mempty = TestCases []++instance Applicative TestCases where+  pure = testCase+  (<*>) = ap++{- | Bind via 'foldMap', which accumulates results with the interleaving '<>'.++This means @xs '>>=' f@ visits the outputs of @f@ applied to each element of @xs@ in an interleaved fashion,+rather than fully exhausting @f x1@ before starting @f x2@.+As a result infinite generators compose without starvation.+-}+instance Monad TestCases where+  as >>= f = foldMap f as++-- | Generate lists of at least @n@ elements.+atLeast :: (Arbitrary a) => Int -> TestCases [a]+atLeast n = (<>) <$> replicateM n arbitrary <*> arbitrary++-- * Running tests (plain IO)++{- | Run a named test over (up to) 10 million generated cases.++Throws an error on the first failure, printing the failing input and a debug string.+For proper integration into a testing framework, see "Test.Tasty.TinyCheck".+-}+testWithMsg :: (Show a, Arbitrary a) => String -> (a -> (Bool, String)) -> IO ()+testWithMsg msg f = do+  forM_ (take 10_000_000 $ getTestCases arbitrary) $ \a ->+    let (passed, dbg) = f a+     in unless passed $+          error $+            unlines+              [ "Test failure:"+              , msg+              , show a+              , dbg+              ]+  putStrLn $ "Test passed: " <> msg++-- | Like 'testWithMsg', but accepts a pure predicate with no debug string.+test :: (Show a, Arbitrary a) => String -> (a -> Bool) -> IO ()+test msg f = testWithMsg msg (\a -> (f a, ""))++-- * Arbitrary++{- | Class of types that have a canonical enumeration of test cases.++For any type with a 'GHC.Generics.Generic' instance, you can derive 'Arbitrary' for free via 'Generically':++@+data Colour = Red | Green | Blue deriving ('GHC.Generics.Generic')++deriving via 'Generically' Colour instance 'Arbitrary' Colour+-- generates: TestCases [Red, Green, Blue]+@++For types with fields, the fields\' generators are interleaved fairly:++@+data Tree a = Leaf | Node (Tree a) a (Tree a) deriving ('GHC.Generics.Generic')++deriving via 'Generically' (Tree a) instance ('Arbitrary' a) => 'Arbitrary' (Tree a)+-- generates: Leaf, Node Leaf 0 Leaf, Node (Node Leaf 0 Leaf) 0 Leaf, Node Leaf (-1) Leaf, ...+@+-}+class Arbitrary a where+  arbitrary :: TestCases a++-- ** Arbitrary newtype wrappers for deriving++{- | Derive 'Arbitrary' for any @'Num' a@ that is also @'Enum'@ by+interleaving non-negatives @[0..]@ with negatives @[1..]@ negated.+Hits small values first, covering both sides of zero fairly.+-}+newtype SignedArbitrary a = SignedArbitrary a++instance (Num a, Enum a) => Arbitrary (SignedArbitrary a) where+  arbitrary = coerce (TestCases [0 ..] <> (negate <$> TestCases [1 ..]) :: TestCases a)++-- | Derive 'Arbitrary' for any @'Bounded'@ @'Enum'@ type by enumerating all values from 'minBound' upward.+newtype BoundedArbitrary a = BoundedArbitrary a++instance (Bounded a, Enum a) => Arbitrary (BoundedArbitrary a) where+  arbitrary = coerce (TestCases [minBound ..] :: TestCases a)++{- | Derive 'Arbitrary' for any 'Fractional' type by delegating to 'Arbitrary' @('Ratio' 'Integer')@+and converting each rational via 'fromRational'.+This enumerates all rationals via a Cantor diagonal, so every rational value reachable by the type is eventually tested.+-}+newtype RealFracArbitrary a = RealFracArbitrary a++instance (Fractional a) => Arbitrary (RealFracArbitrary a) where+  arbitrary = RealFracArbitrary . fromRational <$> arbitrary++-- Numeric instances+-- Signed integer types: interleave non-negatives and negatives.+deriving via SignedArbitrary Int instance Arbitrary Int++deriving via SignedArbitrary Integer instance Arbitrary Integer++deriving via SignedArbitrary Int8 instance Arbitrary Int8++deriving via SignedArbitrary Int16 instance Arbitrary Int16++deriving via SignedArbitrary Int32 instance Arbitrary Int32++deriving via SignedArbitrary Int64 instance Arbitrary Int64++-- Unsigned types enumerate from 'minBound'.+deriving via BoundedArbitrary Word instance Arbitrary Word++deriving via BoundedArbitrary Word8 instance Arbitrary Word8++deriving via BoundedArbitrary Word16 instance Arbitrary Word16++deriving via BoundedArbitrary Word32 instance Arbitrary Word32++deriving via BoundedArbitrary Word64 instance Arbitrary Word64++-- 'Natural' has no 'Bounded', so enumerate directly from 0.+instance Arbitrary Natural where+  arbitrary = TestCases [0 ..]++-- Floating-point types and rationals: use the 'RealFracArbitrary' wrapper.+deriving via RealFracArbitrary Float instance Arbitrary Float++deriving via RealFracArbitrary Double instance Arbitrary Double++{- | Enumerate all ratios via a Cantor diagonal over @(p, q)@ pairs with @q > 0@,+interleaved with their negatives and zero.+Every ratio @p '%' q@ with @p, q@ reachable by 'Arbitrary' @a@ appears in finite time.+-}+instance (Integral a, Arbitrary a) => Arbitrary (Ratio a) where+  arbitrary =+    testCase 0 <> do+      n <- TestCases [1 ..]+      q <- fromInteger <$> TestCases [1 .. n]+      let p = fromInteger n - q + 1+      testCase (p % q) <> testCase (negate (p % q))++-- Char and String++{- | All Unicode scalar values in order: U+0000 .. U+D7FF, U+E000 .. U+10FFFF.+This is the most general 'Char' generator and is used for the 'Arbitrary' instance.+-}+allChars :: TestCases Char+allChars = TestCases $ fmap chr ([0 .. 0xD7FF] <> [0xE000 .. 0x10FFFF])++-- | Filter a 'Char' generator to only those characters whose Unicode 'GeneralCategory' is in the supplied list.+inCategories :: [GeneralCategory] -> TestCases Char -> TestCases Char+inCategories cats (TestCases cs) = TestCases $ filter ((`elem` cats) . generalCategory) cs++{- | ASCII letters and digits plus common punctuation and whitespace.+Useful for testing with printable ASCII.+-}+commonASCIIChars :: TestCases Char+commonASCIIChars = TestCases $ ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] <> " !\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~"++{- | All printable Unicode characters (letters, marks, numbers, punctuation,+symbols, and space separators).+-}+printableChars :: TestCases Char+printableChars =+  inCategories+    [ UppercaseLetter+    , LowercaseLetter+    , TitlecaseLetter+    , ModifierLetter+    , OtherLetter+    , NonSpacingMark+    , SpacingCombiningMark+    , EnclosingMark+    , DecimalNumber+    , LetterNumber+    , OtherNumber+    , ConnectorPunctuation+    , DashPunctuation+    , OpenPunctuation+    , ClosePunctuation+    , InitialQuote+    , FinalQuote+    , OtherPunctuation+    , MathSymbol+    , CurrencySymbol+    , ModifierSymbol+    , OtherSymbol+    , Space+    ]+    allChars++-- | Only Unicode letters ('UppercaseLetter', 'LowercaseLetter', etc.).+letterChars :: TestCases Char+letterChars =+  inCategories+    [UppercaseLetter, LowercaseLetter, TitlecaseLetter, ModifierLetter, OtherLetter]+    allChars++-- | Only Unicode decimal digits.+digitChars :: TestCases Char+digitChars = inCategories [DecimalNumber] allChars++-- ** Newtype wrappers for common char\/string generators++{- | A printable Unicode character.+Useful when a test only cares that a character is printable.+-}+newtype Printable = Printable Char deriving stock (Show)++instance Arbitrary Printable where arbitrary = Printable <$> printableChars++-- | A Unicode letter ('UppercaseLetter', 'LowercaseLetter', etc.).+newtype Letter = Letter Char deriving stock (Show)++instance Arbitrary Letter where arbitrary = Letter <$> letterChars++-- | A Unicode decimal digit.+newtype Digit = Digit Char deriving stock (Show)++instance Arbitrary Digit where arbitrary = Digit <$> digitChars++-- | An uppercase Unicode letter.+newtype Upper = Upper Char deriving stock (Show)++instance Arbitrary Upper where arbitrary = Upper <$> inCategories [UppercaseLetter] allChars++-- | A lowercase Unicode letter.+newtype Lower = Lower Char deriving stock (Show)++instance Arbitrary Lower where arbitrary = Lower <$> inCategories [LowercaseLetter] allChars++{- | A string of words drawn from 'commonASCIIChars'.+Words are separated by spaces; no leading or trailing space is guaranteed.+-}+newtype AsciiWord = AsciiWord String deriving stock (Show)++instance Arbitrary AsciiWord where arbitrary = AsciiWord <$> wordsOf commonASCIIChars++{- | A string of words made up of Unicode letters.+Words are separated by spaces.+-}+newtype LetterWord = LetterWord String deriving stock (Show)++instance Arbitrary LetterWord where arbitrary = LetterWord <$> wordsOf letterChars++{- | A string of words made up of Unicode decimal digits.+Words are separated by spaces.+-}+newtype DigitWord = DigitWord String deriving stock (Show)++instance Arbitrary DigitWord where arbitrary = DigitWord <$> wordsOf digitChars++{- | A multi-line string drawn from 'commonASCIIChars'.+Useful for testing parsers and text-processing functions.+-}+newtype AsciiLine = AsciiLine String deriving stock (Show)++instance Arbitrary AsciiLine where arbitrary = AsciiLine <$> linesOf commonASCIIChars++instance Arbitrary Char where+  arbitrary = allChars++{- | Generate strings of words drawn from the given character generator,+including single words, multi-word phrases (@'unwords'@), and all lengths.+-}+wordsOf :: TestCases Char -> TestCases String+wordsOf chars = stringsOf <> (unwords <$> replicateM 2 stringsOf) <> foldMap (\k -> unwords <$> replicateM k stringsOf) [3 ..]+  where+    stringsOf = foldMap (`replicateM` chars) [1 ..]++{- | Generate multi-line strings drawn from the given character generator,+including everything 'wordsOf' produces plus multi-line documents+(@'unlines' . fmap 'unwords'@).+-}+linesOf :: TestCases Char -> TestCases String+linesOf chars = wordsOf chars <> foldMap (\k -> unlines . fmap unwords <$> replicateM k (replicateM 2 (wordsOf chars))) [1 ..]++-- | A 'String' generator using 'allChars': single strings, multi-word, and multi-line strings.+string :: TestCases String+string = linesOf allChars++-- Other base types+instance Arbitrary () where arbitrary = pure ()++deriving via Generically Bool instance Arbitrary Bool++deriving via Generically Ordering instance Arbitrary Ordering++-- Container instances+deriving via Generically [a] instance (Arbitrary a) => Arbitrary [a]++deriving via Generically (Maybe a) instance (Arbitrary a) => Arbitrary (Maybe a)++deriving via Generically (Either a b) instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b)++-- Tuple instances+deriving via Generically (a, b) instance (Arbitrary a, Arbitrary b) => Arbitrary (a, b)++deriving via Generically (a, b, c) instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (a, b, c)++deriving via Generically (a, b, c, d) instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) => Arbitrary (a, b, c, d)++deriving via Generically (a, b, c, d, e) instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) => Arbitrary (a, b, c, d, e)++-- Function instance+instance (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where+  arbitrary = coArbitrary++{- | Route 'Arbitrary' through the SOP generic representation.+Use @deriving ('Arbitrary') via 'Generically' MyType@ to get a free instance+for any 'GHC.Generics.Generic' type.+-}+instance (SOP.GTo a, Generic a, Arbitrary (SOP.SOP SOP.I (SOP.GCode a))) => Arbitrary (Generically a) where+  arbitrary = fmap (Generically . SOP.gto) arbitrary++-- ** generics-sop NP/NS/SOP/I instances++-- | The identity functor: delegate to the wrapped type.+instance (Arbitrary a) => Arbitrary (SOP.I a) where+  arbitrary = SOP.I <$> arbitrary++{- | Generate all fields independently and combine them into a product.+Sequences one 'arbitrary' call per position,+using 'SOP.hcpure' with the 'Compose' constraint and then 'SOP.hsequence''.+-}+instance (SOP.All (SOP.Compose Arbitrary f) xs) => Arbitrary (SOP.NP f xs) where+  arbitrary = SOP.hsequence' $ SOP.hcpure (Proxy @(SOP.Compose Arbitrary f)) (SOP.Comp arbitrary)++{- | Generate one constructor choice by interleaving all injections.+Each constructor is given equal weight via 'interleaveN'.+-}+instance (SOP.All (SOP.Compose Arbitrary f) xs) => Arbitrary (SOP.NS f xs) where+  arbitrary =+    interleaveN+      . fmap SOP.hsequence'+      . SOP.apInjs_NP+      $ SOP.hcpure (Proxy @(SOP.Compose Arbitrary f)) (SOP.Comp arbitrary)++{- | A sum-of-products: delegate to the underlying 'SOP.NS'.+The 'Arbitrary (SOP.NS (SOP.NP f) xss)' constraint is discharged+by the 'Arbitrary (SOP.NS f xs)' instance above.+-}+instance (Arbitrary (SOP.NS (SOP.NP f) xss)) => Arbitrary (SOP.SOP f xss) where+  arbitrary = SOP.SOP <$> arbitrary++{- | Derive 'CoArbitrary' for any @'Ord' a@ by doing a three-way split on @'compare' argument pivot@ for each generated pivot.+This means the generated function can return different outputs for values below, equal to, or above the pivot.+-}+newtype OrdCoArbitrary a = OrdCoArbitrary a++instance (Ord a, Arbitrary a) => CoArbitrary (OrdCoArbitrary a) where+  coArbitrary = do+    pivot <- coerce <$> (arbitrary :: TestCases a)+    lt <- arbitrary+    eq <- arbitrary+    gt <- arbitrary+    pure $ \(OrdCoArbitrary x) -> case compare x pivot of+      LT -> lt+      EQ -> eq+      GT -> gt++{- | Derive 'CoArbitrary' for any @'Integral' a@ by splitting on sign+and on odd\/even parity, giving four independent outcome branches.+This captures both the sign structure and fine-grained parity of integers.+-}+newtype IntegralCoArbitrary a = IntegralCoArbitrary a++instance (Integral a, Arbitrary a) => CoArbitrary (IntegralCoArbitrary a) where+  coArbitrary = do+    posEven <- arbitrary+    posOdd <- arbitrary+    negEven <- arbitrary+    negOdd <- arbitrary+    zero <- arbitrary+    pure $ \(IntegralCoArbitrary n) -> case (compare n 0, even n) of+      (EQ, _) -> zero+      (GT, True) -> posEven+      (GT, False) -> posOdd+      (LT, True) -> negEven+      (LT, False) -> negOdd++{- | Derive 'CoArbitrary' for any @'Enum' a@ by converting to 'Int' via+'fromEnum' and then splitting on sign\/parity via 'IntegralCoArbitrary'.+Suitable for small bounded enums such as 'Char'.+-}+newtype EnumCoArbitrary a = EnumCoArbitrary a++instance (Enum a, Arbitrary a) => CoArbitrary (EnumCoArbitrary a) where+  coArbitrary = do+    f <- coArbitrary -- TestCases (IntegralCoArbitrary Int -> b)+    pure $ \(EnumCoArbitrary x) -> f (IntegralCoArbitrary (fromEnum x))++-- | Derive 'CoArbitrary' for any @'RealFrac' a@ by splitting on sign and whether the value is @< 1@, @== 1@, or @> 1@, giving six branches.+newtype RealFracCoArbitrary a = RealFracCoArbitrary a++instance (RealFrac a, Arbitrary a) => CoArbitrary (RealFracCoArbitrary a) where+  coArbitrary = do+    negSmall <- arbitrary -- x < -1+    negOne <- arbitrary -- x == -1+    negFrac <- arbitrary -- -1 < x < 0+    zero <- arbitrary -- x == 0+    posFrac <- arbitrary -- 0 < x < 1+    posOne <- arbitrary -- x == 1+    posLarge <- arbitrary -- x > 1+    pure $ \(RealFracCoArbitrary x) ->+      if+        | x < -1 -> negSmall+        | x == -1 -> negOne+        | x < 0 -> negFrac+        | x == 0 -> zero+        | x < 1 -> posFrac+        | x == 1 -> posOne+        | otherwise -> posLarge++{- | An instance @'CoArbitrary' a@ provides a 'TestCases' of functions @a -> b@ for any @'Arbitrary' b@,+by case-splitting on the structure of @a@.+-}+class CoArbitrary a where+  coArbitrary :: (Arbitrary b) => TestCases (a -> b)++-- Integral types: split on sign × parity via 'IntegralCoArbitrary',+-- also combined with 'OrdCoArbitrary' for pivot-based splitting.+deriving via IntegralCoArbitrary Int instance CoArbitrary Int++deriving via IntegralCoArbitrary Integer instance CoArbitrary Integer++deriving via IntegralCoArbitrary Int8 instance CoArbitrary Int8++deriving via IntegralCoArbitrary Int16 instance CoArbitrary Int16++deriving via IntegralCoArbitrary Int32 instance CoArbitrary Int32++deriving via IntegralCoArbitrary Int64 instance CoArbitrary Int64++deriving via IntegralCoArbitrary Word instance CoArbitrary Word++deriving via IntegralCoArbitrary Word8 instance CoArbitrary Word8++deriving via IntegralCoArbitrary Word16 instance CoArbitrary Word16++deriving via IntegralCoArbitrary Word32 instance CoArbitrary Word32++deriving via IntegralCoArbitrary Word64 instance CoArbitrary Word64++-- Natural has no negatives so OrdCoArbitrary is the right fit.+deriving via OrdCoArbitrary Natural instance CoArbitrary Natural++-- Floating types and rationals: split on sign × magnitude via 'RealFracCoArbitrary'.+deriving via RealFracCoArbitrary Float instance CoArbitrary Float++deriving via RealFracCoArbitrary Double instance CoArbitrary Double++deriving via RealFracCoArbitrary (Ratio Integer) instance CoArbitrary (Ratio Integer)++deriving via RealFracCoArbitrary (Ratio Int) instance CoArbitrary (Ratio Int)++-- Char: an enum, so use 'EnumCoArbitrary'.+deriving via EnumCoArbitrary Char instance CoArbitrary Char++-- Container CoArbitrary instances via Generically+deriving via Generically [a] instance (CoArbitrary a) => CoArbitrary [a]++deriving via Generically (Maybe a) instance (CoArbitrary a) => CoArbitrary (Maybe a)++deriving via Generically (Either a b) instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Either a b)++-- Tuple CoArbitrary instances via Generically+deriving via Generically (a, b) instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (a, b)++deriving via Generically (a, b, c) instance (CoArbitrary a, CoArbitrary b, CoArbitrary c) => CoArbitrary (a, b, c)++deriving via Generically (a, b, c, d) instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d) => CoArbitrary (a, b, c, d)++{- | Route 'CoArbitrary' through the SOP generic representation.+Use @deriving ('CoArbitrary') via 'Generically' MyType@ for any 'GHC.Generics.Generic' type.+-}+instance (SOP.GFrom a, Generic a, CoArbitrary (SOP.SOP SOP.I (SOP.GCode a))) => CoArbitrary (Generically a) where+  coArbitrary = fmap (\f (Generically a) -> f (SOP.gfrom a)) coArbitrary++-- ** generics-sop NP/NS/SOP/I instances++-- | The identity functor: delegate to the wrapped type.+instance (CoArbitrary a) => CoArbitrary (SOP.I a) where+  coArbitrary = (. SOP.unI) <$> coArbitrary++{- | A function from a product is isomorphic to a curried chain of functions,+one per field.+Uses 'SOP.sList' to dispatch on whether the list is empty or non-empty in a single instance.+-}+instance (SOP.All (SOP.Compose CoArbitrary f) xs) => CoArbitrary (SOP.NP f xs) where+  coArbitrary = case SOP.sList @xs of+    SOP.SNil -> (\b SOP.Nil -> b) <$> arbitrary+    SOP.SCons -> do+      f <- coArbitrary+      pure $ \(x SOP.:* xs) -> f x xs++{- | Generate a case-split function over an n-ary sum.+For each constructor, 'coArbitrary' produces a function from that constructor's payload;+the final function dispatches on which constructor is present.+-}+instance (SOP.All (SOP.Compose CoArbitrary f) xs) => CoArbitrary (SOP.NS f xs) where+  coArbitrary = do+    np <-+      SOP.hsequence' $+        SOP.hcpure+          (Proxy @(SOP.Compose CoArbitrary f))+          (SOP.Comp $ fmap (SOP.Fn . (SOP.K .)) coArbitrary)+    pure $ SOP.hcollapse . SOP.hap np++-- | A sum-of-products: delegate to the underlying 'SOP.NS'.+instance (CoArbitrary (SOP.NS (SOP.NP f) xss)) => CoArbitrary (SOP.SOP f xss) where+  coArbitrary = (. SOP.unSOP) <$> coArbitrary++-- * Instances for base datatypes++--+-- Instances for 'Generic' types are derived via 'Generically'.+-- Instances for types without 'Generic' are written manually.++deriving via Generically () instance CoArbitrary ()++deriving via Generically Bool instance CoArbitrary Bool++deriving via Generically Ordering instance CoArbitrary Ordering++-- ** Data.Void++-- | 'Void' is uninhabited; there are no test cases and functions from it are trivial.+deriving via Generically Void instance Arbitrary Void++deriving via Generically Void instance CoArbitrary Void++-- ** Data.Proxy++deriving via Generically (Proxy t) instance Arbitrary (Proxy t)++deriving via Generically (Proxy t) instance CoArbitrary (Proxy t)++-- ** Data.Ord++deriving via Generically (Down a) instance (Arbitrary a) => Arbitrary (Down a)++deriving via Generically (Down a) instance (CoArbitrary a) => CoArbitrary (Down a)++-- ** Data.List.NonEmpty++deriving via Generically (NonEmpty a) instance (Arbitrary a) => Arbitrary (NonEmpty a)++deriving via Generically (NonEmpty a) instance (CoArbitrary a) => CoArbitrary (NonEmpty a)++-- ** System.Exit++deriving via Generically ExitCode instance Arbitrary ExitCode++deriving via Generically ExitCode instance CoArbitrary ExitCode++-- ** Data.Complex++deriving via Generically (Complex a) instance (Arbitrary a) => Arbitrary (Complex a)++deriving via Generically (Complex a) instance (CoArbitrary a) => CoArbitrary (Complex a)++-- ** Data.Version++deriving via Generically Version instance Arbitrary Version++deriving via Generically Version instance CoArbitrary Version++-- ** Data.Functor.Identity++deriving via Generically (Identity a) instance (Arbitrary a) => Arbitrary (Identity a)++deriving via Generically (Identity a) instance (CoArbitrary a) => CoArbitrary (Identity a)++-- ** Data.Functor.Const++deriving via Generically (Const a b) instance (Arbitrary a) => Arbitrary (Const a b)++deriving via Generically (Const a b) instance (CoArbitrary a) => CoArbitrary (Const a b)++-- ** Data.Functor.Compose++deriving via+  Generically (Compose f g a)+  instance+    (Arbitrary (f (g a))) => Arbitrary (Compose f g a)++deriving via+  Generically (Compose f g a)+  instance+    (CoArbitrary (f (g a))) => CoArbitrary (Compose f g a)++-- ** Data.Functor.Product++deriving via+  Generically (FP.Product f g a)+  instance+    (Arbitrary (f a), Arbitrary (g a)) => Arbitrary (FP.Product f g a)++deriving via+  Generically (FP.Product f g a)+  instance+    (CoArbitrary (f a), CoArbitrary (g a)) => CoArbitrary (FP.Product f g a)++-- ** Data.Functor.Sum (functor-level, distinct from numeric Sum)++deriving via+  Generically (FS.Sum f g a)+  instance+    (Arbitrary (f a), Arbitrary (g a)) => Arbitrary (FS.Sum f g a)++deriving via+  Generically (FS.Sum f g a)+  instance+    (CoArbitrary (f a), CoArbitrary (g a)) => CoArbitrary (FS.Sum f g a)++-- ** Data.Monoid newtypes++deriving via Generically All instance Arbitrary All++deriving via Generically All instance CoArbitrary All++deriving via Generically Any instance Arbitrary Any++deriving via Generically Any instance CoArbitrary Any++deriving via Generically (Dual a) instance (Arbitrary a) => Arbitrary (Dual a)++deriving via Generically (Dual a) instance (CoArbitrary a) => CoArbitrary (Dual a)++deriving via Generically (Monoid.Sum a) instance (Arbitrary a) => Arbitrary (Monoid.Sum a)++deriving via Generically (Monoid.Sum a) instance (CoArbitrary a) => CoArbitrary (Monoid.Sum a)++deriving via Generically (Monoid.Product a) instance (Arbitrary a) => Arbitrary (Monoid.Product a)++deriving via Generically (Monoid.Product a) instance (CoArbitrary a) => CoArbitrary (Monoid.Product a)++deriving via Generically (First a) instance (Arbitrary a) => Arbitrary (First a)++deriving via Generically (First a) instance (CoArbitrary a) => CoArbitrary (First a)++deriving via Generically (Last a) instance (Arbitrary a) => Arbitrary (Last a)++deriving via Generically (Last a) instance (CoArbitrary a) => CoArbitrary (Last a)++-- | 'Endo' wraps a function @a -> a@; 'Arbitrary' requires 'CoArbitrary' and 'Arbitrary' on @a@.+deriving via+  Generically (Endo a)+  instance+    (CoArbitrary a, Arbitrary a) => Arbitrary (Endo a)++-- | 'CoArbitrary' for 'Endo' requires the caller to supply 'CoArbitrary' for @a -> a@.+deriving via+  Generically (Endo a)+  instance+    (CoArbitrary (a -> a)) => CoArbitrary (Endo a)++deriving via Generically (Alt f a) instance (Arbitrary (f a)) => Arbitrary (Alt f a)++deriving via Generically (Alt f a) instance (CoArbitrary (f a)) => CoArbitrary (Alt f a)++deriving via Generically (Ap f a) instance (Arbitrary (f a)) => Arbitrary (Ap f a)++deriving via Generically (Ap f a) instance (CoArbitrary (f a)) => CoArbitrary (Ap f a)++-- ** Data.Semigroup newtypes++deriving via Generically (Semigroup.Min a) instance (Arbitrary a) => Arbitrary (Semigroup.Min a)++deriving via Generically (Semigroup.Min a) instance (CoArbitrary a) => CoArbitrary (Semigroup.Min a)++deriving via Generically (Semigroup.Max a) instance (Arbitrary a) => Arbitrary (Semigroup.Max a)++deriving via Generically (Semigroup.Max a) instance (CoArbitrary a) => CoArbitrary (Semigroup.Max a)++deriving via Generically (Semigroup.First a) instance (Arbitrary a) => Arbitrary (Semigroup.First a)++deriving via Generically (Semigroup.First a) instance (CoArbitrary a) => CoArbitrary (Semigroup.First a)++deriving via Generically (Semigroup.Last a) instance (Arbitrary a) => Arbitrary (Semigroup.Last a)++deriving via Generically (Semigroup.Last a) instance (CoArbitrary a) => CoArbitrary (Semigroup.Last a)++deriving via Generically (Semigroup.Arg a b) instance (Arbitrary a, Arbitrary b) => Arbitrary (Semigroup.Arg a b)++deriving via Generically (Semigroup.Arg a b) instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Semigroup.Arg a b)++deriving via Generically (Semigroup.WrappedMonoid m) instance (Arbitrary m) => Arbitrary (Semigroup.WrappedMonoid m)++deriving via Generically (Semigroup.WrappedMonoid m) instance (CoArbitrary m) => CoArbitrary (Semigroup.WrappedMonoid m)++-- ** Data.Fixed++-- 'Fixed' has no 'Generic' instance. We reuse the 'Integer' generator via 'coerce'.+deriving via SignedArbitrary (Fixed a) instance (HasResolution a) => Arbitrary (Fixed a)++deriving via+  OrdCoArbitrary (Fixed a)+  instance+    (HasResolution a) => CoArbitrary (Fixed a)
+ src/Test/Tasty/TinyCheck.hs view
@@ -0,0 +1,176 @@+{- | Tasty integration for tinycheck.++Usage:++>>> import Test.Tasty+>>> import Test.Tasty.TinyCheck+>>> import Data.List (nub, reverse)+>>> :{+defaultMain $ testGroup "My suite"+[ testProperty "reverse . reverse == id" $+    \(xs :: [Int]) -> reverse (reverse xs) == xs+, testProperty "length . nub <= length" $+    \(xs :: [Int]) -> length (nub xs) <= length xs+]+:}+-}+module Test.Tasty.TinyCheck (+  -- * Defining properties+  Property,+  property,+  (==>),++  -- * Checking properties+  Testable (..),++  -- * Creating test trees+  testProperty,+  testPropertyWith,+  expectFailureWith,+  expectFailureWithN,++  -- * Options+  TinyCheckTests (..),+)+where++-- base+import Control.Monad (void)+import Data.List (isInfixOf)+import Data.Proxy (Proxy (..))++-- tagged+import Data.Tagged (Tagged (..))++-- tasty+import Test.Tasty (localOption)+import Test.Tasty.Options (IsOption (..), OptionDescription (..), lookupOption, safeRead)+import Test.Tasty.Providers (IsTest (..), TestName, TestTree, singleTest, testFailed, testPassed)+import Test.Tasty.Runners (Outcome (..), Result (..))++-- tinycheck+import Data.TestCases (Arbitrary, TestCases (..), arbitrary)++-- * Property++{- | A testable property: a 'TestCases' of outcomes, each being either+'Right ()' for a pass or 'Left msg' for a failure with a message.++Build one with 'property' (or its operator alias '==>') or simply+use a function @a -> Bool@ / @a -> Property@ directly via 'testProperty'.+-}+newtype Property = Property (TestCases (Either String ()))++-- | Promote a 'Bool' to a 'Property'.  Failures carry no extra message.+property :: Bool -> Property+property True = Property $ TestCases [Right ()]+property False = Property $ TestCases [Left "falsified"]++{- | Conditional property: if the precondition is 'False' the test case is+/discarded/ (treated as a pass), just like QuickCheck's @==>@.+-}+(==>) :: Bool -> Property -> Property+True ==> p = p+False ==> _ = Property $ TestCases [Right ()]++infixr 0 ==>++-- * Testable class++-- | Types that can be converted to a 'Property'.+class Testable a where+  toProperty :: a -> Property++instance Testable Bool where+  toProperty = property++instance Testable Property where+  toProperty = id++instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where+  toProperty f = Property $ do+    a <- arbitrary+    let Property outcomes = toProperty (f a)+    -- Annotate failures with the offending input.+    fmap (void . prependInput a) outcomes+    where+      prependInput a (Left msg) = Left $ show a <> "\n" <> msg+      prependInput _ r = r++-- * Option: number of test cases++{- | How many test cases tinycheck should check per property.+Defaults to 10 000.  Can be set via @--tinycheck-tests N@ on the command line.+-}+newtype TinyCheckTests = TinyCheckTests Int+  deriving stock (Show, Eq, Ord)++instance IsOption TinyCheckTests where+  defaultValue = TinyCheckTests 10_000+  parseValue s = TinyCheckTests <$> safeRead s+  optionName = Tagged "tinycheck-tests"+  optionHelp = Tagged "Number of test cases for TinyCheck properties (default: 10000)"++-- * IsTest instance++-- | A named property ready to be run as a tasty test.+data TinyCheckTest = forall a. (Testable a) => TinyCheckTest a++instance IsTest TinyCheckTest where+  testOptions = Tagged [Option (Proxy @TinyCheckTests)]++  run opts (TinyCheckTest prop) _progress = do+    let TinyCheckTests n = lookupOption opts+        Property cases = toProperty prop+        results = take n (getTestCases cases)+    case sequence_ results of+      Right () -> pure $ testPassed $ "OK, checked " <> show (length results) <> " cases"+      Left msg -> pure $ testFailed msg++-- * Public API++{- | Create a 'TestTree' leaf from a 'Testable' property.++The property can be a plain 'Bool', a 'Property', or a function+@a -> Bool@ / @a -> Property@ for any @'Arbitrary' a@.+-}+testProperty :: (Testable a) => TestName -> a -> TestTree+testProperty name prop = singleTest name (TinyCheckTest prop)++-- | Like 'testProperty', but run exactly @n@ test cases instead of the suite-wide default.+testPropertyWith :: (Testable a) => Int -> TestName -> a -> TestTree+testPropertyWith n name prop = localOption (TinyCheckTests n) $ testProperty name prop++{- | Assert that a property /fails/ and that the failure message contains+the given substring.  The test passes iff the property fails with a+matching message; it fails if the property passes, or if it fails with+an unexpected message.+-}+expectFailureWith :: (Testable a) => String -> TestName -> a -> TestTree+expectFailureWith needle name prop = singleTest name (ExpectFailure needle (TinyCheckTest prop))++-- | Like 'expectFailureWith', but check exactly @n@ test cases instead of the suite-wide default.+expectFailureWithN :: (Testable a) => Int -> String -> TestName -> a -> TestTree+expectFailureWithN n needle name prop = localOption (TinyCheckTests n) $ expectFailureWith needle name prop++-- | Internal wrapper used by 'expectFailureWith'.+data ExpectFailure = ExpectFailure String TinyCheckTest++instance IsTest ExpectFailure where+  testOptions = Tagged [Option (Proxy @TinyCheckTests)]++  run opts (ExpectFailure needle inner) progress = do+    result <- run opts inner progress+    pure $ case resultOutcome result of+      Failure _ ->+        let msg = resultDescription result+         in if needle `isInfixOf` msg+              then testPassed $ "Got expected failure containing " <> show needle+              else+                testFailed $+                  "Property failed as expected, but message\n"+                    <> show msg+                    <> "\ndoes not contain "+                    <> show needle+      Success ->+        testFailed "Expected the property to fail, but it passed"
+ test/Main.hs view
@@ -0,0 +1,23 @@+module Main (main) where++-- tasty+import Test.Tasty++-- tinycheck-test+import Test.Base qualified+import Test.Combinators qualified+import Test.Generic qualified+import Test.HybridSort qualified+import Test.Strings qualified++main :: IO ()+main =+  defaultMain $+    testGroup+      "tinycheck"+      [ Test.Base.tests+      , Test.Combinators.tests+      , Test.Strings.tests+      , Test.HybridSort.tests+      , Test.Generic.tests+      ]
+ test/Test/Base.hs view
@@ -0,0 +1,83 @@+{- HLINT ignore "Avoid reverse" -}+{- HLINT ignore "Functor law" -}+{- HLINT ignore "Redundant maybe" -}+{- HLINT ignore "Use <|>" -}+{- HLINT ignore "Use =<<" -}+{- HLINT ignore "Redundant negate" -}+{- HLINT ignore "Evaluate" -}+{- HLINT ignore "Redundant not" -}+{- HLINT ignore "Redundant ==" -}+module Test.Base (tests) where++-- base+import Data.List (nub, sort)++-- tasty+import Test.Tasty+import Test.Tasty.TinyCheck++-- tinycheck+import Data.TestCases ()++tests :: TestTree+tests =+  testGroup+    "Base"+    [ testGroup+        "Lists"+        [ testProperty "reverse . reverse == id" $+            \(xs :: [Int]) -> xs == xs+        , testProperty "length (xs ++ ys) == length xs + length ys" $+            \(xs :: [Int], ys :: [Int]) ->+              length (xs <> ys) == length xs + length ys+        , testProperty "length . nub <= length" $+            \(xs :: [Int]) -> length (nub xs) <= length xs+        , testProperty "sort . sort == sort" $+            \(xs :: [Int]) -> sort (sort xs) == sort xs+        , testProperty "head (x:xs) == x" $+            \(x :: Int, xs :: [Int]) -> let (h : _) = x : xs in h == x+        , testProperty "last (xs ++ [x]) == x" $+            \(x :: Int, xs :: [Int]) -> last (xs <> [x]) == x+        ]+    , testGroup+        "Maybe"+        [ testProperty "fmap id == id" $+            \(mx :: Maybe Int) -> fmap id mx == mx+        , testProperty "maybe Nothing Just == id" $+            \(mx :: Maybe Int) -> maybe Nothing Just mx == mx+        ]+    , testGroup+        "Either"+        [ testProperty "either Left Right == id" $+            \(e :: Either Int Bool) -> either Left Right e == e+        ]+    , testGroup+        "Numeric"+        [ testProperty "abs x >= 0  (Int)" $+            \(x :: Int) -> abs x >= 0+        , testProperty "negate . negate == id  (Int)" $+            \(x :: Int) -> negate (negate x) == x+        , testProperty "x + 0 == x  (Integer)" $+            \(x :: Integer) -> x + 0 == x+        , testProperty "x * 1 == x  (Integer)" $+            \(x :: Integer) -> x * 1 == x+        ]+    , testGroup+        "Tuples"+        [ testProperty "fst (a, b) == a" $+            \(a :: Int, b :: Bool) -> fst (a, b) == a+        , testProperty "snd (a, b) == b" $+            \(a :: Int, b :: Bool) -> snd (a, b) == b+        , testProperty "swap . swap == id" $+            \(a :: Int, b :: Bool) -> let swap (x, y) = (y, x) in swap (swap (a, b)) == (a, b)+        ]+    , testGroup+        "Bool"+        [ testProperty "not . not == id" $+            \(b :: Bool) -> not (not b) == b+        , testProperty "b || True == True" $+            \(b :: Bool) -> (b || True) == True+        , testProperty "b && False == False" $+            \(b :: Bool) -> (b && False) == False+        ]+    ]
+ test/Test/Combinators.hs view
@@ -0,0 +1,97 @@+{- HLINT ignore "Redundant id" -}+module Test.Combinators (tests) where++-- base+import Data.List (sort)++-- tasty+import Test.Tasty+import Test.Tasty.TinyCheck++-- tinycheck+import Data.TestCases++tests :: TestTree+tests =+  testGroup+    "Combinators"+    [ testGroup+        "interleaveN"+        [ testProperty "3-way interleave matches documented output" $+            getTestCases (interleaveN [TestCases [1, 2, 3], TestCases [10, 20, 30], TestCases [100, 200, 300 :: Int]])+              == [1, 10, 100, 2, 20, 200, 3, 30, 300]+        , testProperty "unequal lengths: shorter sources exhaust cleanly" $+            getTestCases (interleaveN [TestCases [1, 2], TestCases [10, 20, 30], TestCases [100 :: Int]])+              == [1, 10, 100, 2, 20, 30]+        , testProperty "interleaveN [] == mempty" $+            getTestCases (interleaveN ([] :: [TestCases Int])) == ([] :: [Int])+        , testProperty "interleaveN [a, b] == a <> b" $+            let a = TestCases [1, 2, 3 :: Int]; b = TestCases [10, 20, 30]+             in getTestCases (interleaveN [a, b]) == getTestCases (a <> b)+        , testProperty "does not get stuck with finite-many infinite sources" $+            -- Take 100 elements from 5 infinite lists; must terminate.+            let sources = replicate 5 (TestCases [0 :: Int ..])+             in length (take 100 (getTestCases (interleaveN sources))) == 100+        , testProperty "fair: each of n infinite sources contributes within first n*k elements" $+            -- With n infinite sources, every source must appear in every window+            -- of n consecutive elements (one full round).+            let n = 5+                sources = fmap (\i -> (,) i <$> TestCases [0 :: Int ..]) [0 .. n - 1]+                -- sources !! i produces (i, 0), (i, 1), (i, 2), ...+                -- so the first component uniquely identifies which source contributed+                elems = take (n * 10) (getTestCases (interleaveN sources))+                -- in each window of n, all source indices 0..n-1 must appear+                windows = do+                  k <- [0, n .. n * 9]+                  pure $ take n (drop k elems)+             in all (\w -> sort (fmap fst w) == [0 .. n - 1]) windows+        ]+    , testGroup+        "Applicative interleaving"+        [ testProperty "(,) <$> \"abc\" <*> [1..6] matches documented output" $+            getTestCases ((,) <$> TestCases "abc" <*> TestCases [1, 2, 3, 4, 5, 6 :: Int])+              == [ ('a', 1)+                 , ('b', 1)+                 , ('a', 2)+                 , ('c', 1)+                 , ('a', 3)+                 , ('b', 2)+                 , ('a', 4)+                 , ('c', 2)+                 , ('a', 5)+                 , ('b', 3)+                 , ('a', 6)+                 , ('c', 3)+                 , ('b', 4)+                 , ('c', 4)+                 , ('b', 5)+                 , ('c', 5)+                 , ('b', 6)+                 , ('c', 6)+                 ]+        , testProperty "TestCases interleaves, plain list does not" $+            getTestCases ((,) <$> TestCases "abc" <*> TestCases [1, 2, 3, 4, 5, 6 :: Int])+              /= ((,) <$> "abc" <*> [1, 2, 3, 4, 5, 6])+        ]+    , testGroup+        "CoArbitrary newtype wrappers (nontrivial functions)"+        [ testProperty "IntegralCoArbitrary: some f distinguishes 0 from 1" $+            -- A constant function satisfies f 0 == f 1 for all inputs, but the+            -- generated functions split on sign×parity, so some must differ.+            any+              (\f -> f (0 :: Int) /= f (1 :: Int))+              (take 100 $ getTestCases (coArbitrary :: TestCases (Int -> Bool)))+        , testProperty "OrdCoArbitrary: some f distinguishes LT from GT" $+            any+              (\f -> f LT /= f (GT :: Ordering))+              (take 100 $ getTestCases (coArbitrary :: TestCases (Ordering -> Bool)))+        , testProperty "EnumCoArbitrary: some f distinguishes 'a' from 'b'" $+            any+              (\f -> f 'a' /= f 'b')+              (take 100 $ getTestCases (coArbitrary :: TestCases (Char -> Bool)))+        , testProperty "RealFracCoArbitrary: some f distinguishes 0.0 from 2.0" $+            any+              (\f -> f (0.0 :: Double) /= f 2.0)+              (take 100 $ getTestCases (coArbitrary :: TestCases (Double -> Bool)))+        ]+    ]
+ test/Test/Generic.hs view
@@ -0,0 +1,67 @@+{- HLINT ignore "Avoid reverse" -}+{- HLINT ignore "Evaluate" -}+{- HLINT ignore "Redundant not" -}+module Test.Generic (tests) where++-- base+import Data.List (isPrefixOf, tails)+import GHC.Generics (Generic, Generically (..))++-- tasty+import Test.Tasty+import Test.Tasty.TinyCheck++-- tinycheck+import Data.TestCases++{- | A deeply-nested record type used to exercise the generic 'Arbitrary'+instance and to verify that tinycheck eventually reaches large inputs.+-}+data LargeRecord = LargeRecord+  { field1 :: Bool+  , field2 :: String+  , field3 :: Int+  , field4 :: Maybe LargeRecord+  , field5 :: [Bool]+  , field6 :: [Int]+  , field7 :: Maybe LargeRecord+  , field8 :: Either String LargeRecord+  }+  deriving stock (Show, Generic)+  deriving (Arbitrary) via Generically LargeRecord++-- | Count non-overlapping occurrences of a substring.+countOccurrences :: String -> String -> Int+countOccurrences needle haystack =+  length $ filter (isPrefixOf needle) (tails haystack)++tests :: TestTree+tests =+  testGroup+    "Generic"+    [ testGroup+        "LargeRecord (Generic)"+        [ testProperty "show ends with }" $+            \(r :: LargeRecord) -> last (show r) == '}'+        ]+    , testGroup+        "Preconditions"+        [ testProperty "n > 0 ==> n * 2 > 0" $+            \(n :: Int) -> (n > 0) ==> property (n * 2 > 0)+        ]+    , testGroup+        "Expected failures"+        [ expectFailureWith+            "falsified"+            "False is always falsified"+            False+        , expectFailureWith "falsified" "const False always falsified" $+            \(_ :: Int) -> False+        , expectFailureWith "0" "reverse [0] /= [0] is falsified with 0" $+            \(x :: Int) -> reverse [x] /= [x]+        , expectFailureWith "True" "even True falsified: input shown" $+            \(b :: Bool) -> not b+        , expectFailureWithN 1_000_000_0 "LargeRecord" "LargeRecord appears at most 6 times in show" $+            \(r :: LargeRecord) -> countOccurrences "LargeRecord" (show r) <= 6+        ]+    ]
+ test/Test/HybridSort.hs view
@@ -0,0 +1,84 @@+{- HLINT ignore "Avoid reverse" -}+module Test.HybridSort (tests) where++-- base+import Control.Monad (replicateM)+import Data.List (sort)++-- tasty+import Test.Tasty+import Test.Tasty.TinyCheck++-- tinycheck+import Data.TestCases++{- | The threshold at which a real hybrid sort (e.g. vector-algorithms) switches+from divide-and-conquer to insertion sort.  Values in the range @[15..20]@ are+typical on modern hardware.+-}+threshold :: Int+threshold = 20++{- | A deliberately broken hybrid sort: correct insertion sort below 'threshold',+but @'reverse' . 'sort'@ (descending order) for longer lists.+This models a bug that only manifests once the quicksort path is exercised.+-}+hybridSort :: Int -> [Int] -> [Int]+hybridSort n xs+  | length xs < n = insertionSort xs+  | otherwise = reverse (sort xs) -- wrong: should be `sort xs`++{- | The correct reference hybrid sort: insertion sort below 'threshold',+and the standard sort above it.+Used to verify that tinycheck's generator covers both regimes.+-}+correctHybridSort :: Int -> [Int] -> [Int]+correctHybridSort n xs+  | length xs < n = insertionSort xs+  | otherwise = sort xs++-- | Simple insertion sort, used as the "small input" path in the hybrid sorter.+insertionSort :: (Ord a) => [a] -> [a]+insertionSort = foldr insert []+  where+    insert x [] = [x]+    insert x (y : ys)+      | x <= y = x : y : ys+      | otherwise = y : insert x ys++{- | A list of 'Int' guaranteed to have at least 'threshold' elements.+Used to target the quicksort path of the hybrid sort directly.+-}+newtype LongList = LongList [Int] deriving stock (Show)++instance Arbitrary LongList where+  -- Produce the mandatory `threshold` elements, then append any suffix.+  -- The first test case will be `LongList (replicate threshold 0)`,+  -- which already exercises the long-list path of the hybrid sort.+  arbitrary = LongList <$> ((<>) <$> replicateM threshold arbitrary <*> arbitrary)++tests :: TestTree+tests =+  testGroup+    "Hybrid sort (refuting the SmallCheck objection)"+    {- The claim: enumeration-based testing misses bugs that only appear+    on inputs larger than some threshold N, because exhaustively+    visiting all inputs of size < N is too expensive.++    Tinycheck refutes this: its interleaving strategy generates inputs of+    \*every* length without exhausting shorter ones first.+    In particular, 'LongList' generates lists of length >= 'threshold'+    (20 elements) directly, so the bug in 'hybridSort' is found on the+    very first test case.+    -}+    [ expectFailureWithN+        2_000_000+        "falsified"+        "broken hybrid sort is caught: 'LongList' targets the quicksort path"+        $+        -- 'LongList' generates only lists of length >= 'threshold',+        -- so the first test case already exercises the broken path.+        \(xs :: [Int]) -> hybridSort threshold xs == sort xs+    , testProperty "correct hybrid sort agrees with sort on all list lengths" $+        \(xs :: [Int]) -> correctHybridSort threshold xs == sort xs+    ]
+ test/Test/Strings.hs view
@@ -0,0 +1,49 @@+module Test.Strings (tests) where++-- base+import Data.Char (GeneralCategory (..), generalCategory, isAlpha, isLower, isPrint, isUpper, ord)++-- tasty+import Test.Tasty+import Test.Tasty.TinyCheck++-- tinycheck+import Data.TestCases++tests :: TestTree+tests =+  testGroup+    "Char and String generators"+    [ -- allChars covers the full Unicode scalar value range+      testProperty "allChars: no surrogates" $+        \(c :: Char) -> let n = ord c in n < 0xD800 || n > 0xDFFF+    , testProperty "printableChars: every char is printable" $+        \(Printable c) -> isPrint c+    , testProperty "letterChars: every char is a letter" $+        \(Letter c) -> isAlpha c+    , testProperty "digitChars: every char is a decimal digit" $+        \(Digit c) -> generalCategory c == DecimalNumber+    , testProperty "inCategories [UppercaseLetter]: every char is uppercase" $+        \(Upper c) -> isUpper c+    , testProperty "inCategories [LowercaseLetter]: every char is lowercase" $+        \(Lower c) -> isLower c+    , testProperty "inCategories respects generalCategory" $+        \(Digit c) -> generalCategory c == DecimalNumber+    , testProperty "wordsOf commonASCIIChars: every non-space char is printable ASCII" $+        \(AsciiWord s) -> all (\c -> isPrint c && ord c < 128) (filter (/= ' ') s)+    , testProperty "wordsOf letterChars: every non-space char is a letter" $+        \(LetterWord s) -> all isAlpha (filter (/= ' ') s)+    , testProperty "wordsOf digitChars: every char is a decimal digit or space" $+        \(DigitWord s) -> all (\c -> generalCategory c == DecimalNumber || c == ' ') s+    , testProperty "wordsOf commonASCIIChars: unwords . words roundtrips when no leading/trailing spaces" $+        \(AsciiWord s) ->+          case (s, reverse s) of+            (h : _, l : _) -> h /= ' ' && l /= ' ' ==> property (unwords (words s) == s)+            _ -> property True+    , testProperty "linesOf commonASCIIChars: lines . unlines roundtrips when ends with newline" $+        \(AsciiLine s) ->+          not (null s)+            && last s+              == '\n'+                ==> property (unlines (lines s) == s)+    ]
+ tinycheck.cabal view
@@ -0,0 +1,93 @@+cabal-version: 3.0+name: tinycheck+version: 0.1.0.0+synopsis: A lightweight enumeration-based property testing library+description:+  Tinycheck is a deterministic property testing library.+  Instead of random generation, test cases are produced by exhaustive,+  fairly-interleaved enumeration.  It integrates with the Tasty test+  framework via "Test.Tasty.TinyCheck".++license: BSD-3-Clause+license-file: LICENSE+author: Manuel Bärenz+maintainer: programming@manuelbaerenz.de+build-type: Simple+extra-doc-files:+  CHANGELOG.md+  README.md++tested-with:+  ghc ==9.4+  ghc ==9.6+  ghc ==9.8+  ghc ==9.10+  ghc ==9.12++flag dev+  description: Enable stricter warnings for development+  default: False+  manual: True++common opts+  ghc-options: -Wall++  if flag(dev)+    ghc-options: -Werror+  default-extensions:+    DataKinds+    DefaultSignatures+    DerivingStrategies+    DerivingVia+    LambdaCase+    ScopedTypeVariables+    TypeApplications+    TypeFamilies++  default-language: GHC2021+  build-depends: base >=4.17 && <4.22++common test-opts+  import: opts+  build-depends: tasty >=1.5 && <1.6++library+  import: opts+  exposed-modules:+    Data.TestCases+    Test.Tasty.TinyCheck++  build-depends:+    generics-sop >=0.5 && <0.6,+    tagged >=0.8 && <0.9,+    tasty >=1.5 && <1.6,++  hs-source-dirs: src++test-suite tinycheck-test+  import: test-opts+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  other-modules:+    Test.Base+    Test.Combinators+    Test.Generic+    Test.HybridSort+    Test.Strings++  build-depends: tinycheck++test-suite example-colour+  import: opts+  type: exitcode-stdio-1.0+  hs-source-dirs: examples+  main-is: Colour.hs+  build-depends: tinycheck++test-suite example-tree+  import: test-opts+  type: exitcode-stdio-1.0+  hs-source-dirs: examples+  main-is: Tree.hs+  build-depends: tinycheck