diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for tinycheck + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/examples/Colour.hs b/examples/Colour.hs new file mode 100644 --- /dev/null +++ b/examples/Colour.hs @@ -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)) diff --git a/examples/Tree.hs b/examples/Tree.hs new file mode 100644 --- /dev/null +++ b/examples/Tree.hs @@ -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] + ] diff --git a/src/Data/TestCases.hs b/src/Data/TestCases.hs new file mode 100644 --- /dev/null +++ b/src/Data/TestCases.hs @@ -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) diff --git a/src/Test/Tasty/TinyCheck.hs b/src/Test/Tasty/TinyCheck.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/TinyCheck.hs @@ -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" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ] diff --git a/test/Test/Base.hs b/test/Test/Base.hs new file mode 100644 --- /dev/null +++ b/test/Test/Base.hs @@ -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 + ] + ] diff --git a/test/Test/Combinators.hs b/test/Test/Combinators.hs new file mode 100644 --- /dev/null +++ b/test/Test/Combinators.hs @@ -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))) + ] + ] diff --git a/test/Test/Generic.hs b/test/Test/Generic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Generic.hs @@ -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 + ] + ] diff --git a/test/Test/HybridSort.hs b/test/Test/HybridSort.hs new file mode 100644 --- /dev/null +++ b/test/Test/HybridSort.hs @@ -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 + ] diff --git a/test/Test/Strings.hs b/test/Test/Strings.hs new file mode 100644 --- /dev/null +++ b/test/Test/Strings.hs @@ -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) + ] diff --git a/tinycheck.cabal b/tinycheck.cabal new file mode 100644 --- /dev/null +++ b/tinycheck.cabal @@ -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