leancheck 0.9.2 → 0.9.3
raw patch · 33 files changed
+940/−699 lines, 33 files
Files
- .travis.yml +13/−9
- Makefile +5/−0
- README.md +5/−0
- TODO.md +1/−11
- changelog.md +7/−0
- doc/tutorial.md +53/−0
- leancheck.cabal +5/−3
- mk/depend.mk +11/−5
- mk/haskell.mk +1/−1
- mk/install-on +30/−0
- src/Test/LeanCheck.hs +18/−2
- src/Test/LeanCheck/Basic.hs +77/−78
- src/Test/LeanCheck/Core.hs +208/−127
- src/Test/LeanCheck/Derive.hs +78/−78
- src/Test/LeanCheck/Error.hs +20/−18
- src/Test/LeanCheck/Generic.hs +15/−15
- src/Test/LeanCheck/IO.hs +39/−35
- src/Test/LeanCheck/Stats.hs +72/−72
- src/Test/LeanCheck/Tiers.hs +115/−114
- stack.yaml +1/−12
- test/Test.hs +16/−0
- test/derive.hs +5/−3
- test/error.hs +6/−4
- test/fun.hs +5/−4
- test/funshow.hs +6/−4
- test/generic.hs +4/−2
- test/io.hs +1/−1
- test/main.hs +49/−48
- test/operators.hs +7/−4
- test/sdist +23/−8
- test/stats.hs +2/−2
- test/tiers.hs +13/−11
- test/types.hs +29/−28
.travis.yml view
@@ -1,6 +1,6 @@ # .travis.yml file for LeanCheck #-# Copyright: (c) 2017-2018 Rudy Matela+# Copyright: (c) 2017-2020 Rudy Matela # License: 3-Clause BSD (see the file LICENSE) # Maintainer: Rudy Matela <rudy@matela.com.br> @@ -37,32 +37,35 @@ - make haddock - make test-sdist - cabal test --ghc-option=-O0-- stack --no-terminal --skip-ghc-check test --ghc-options=-O0+- stack --resolver $STACKVER --no-terminal --skip-ghc-check test --ghc-options=-O0 matrix: allow_failures: - ghc: 'head' include: - ghc: 'head'- env: GHCVER=head CABALVER=head+ env: GHCVER=head CABALVER=head STACKVER=nightly-2020-03-28 addons: {apt: {packages: [ghc-head, cabal-install-head], sources: hvr-ghc}}+ - ghc: '8.10'+ env: GHCVER=8.10.1 CABALVER=3.2 STACKVER=nightly-2020-03-28+ addons: {apt: {packages: [ghc-8.10.1, cabal-install-3.2], sources: hvr-ghc}} - ghc: '8.8'- env: GHCVER=8.8.3 CABALVER=3.0+ env: GHCVER=8.8.3 CABALVER=3.0 STACKVER=lts-15.5 addons: {apt: {packages: [ghc-8.8.3, cabal-install-3.0], sources: hvr-ghc}} - ghc: '8.6'- env: GHCVER=8.6.5 CABALVER=2.4+ env: GHCVER=8.6.5 CABALVER=2.4 STACKVER=lts-14.27 addons: {apt: {packages: [ghc-8.6.5, cabal-install-2.4], sources: hvr-ghc}} - ghc: '8.4'- env: GHCVER=8.4.4 CABALVER=2.2+ env: GHCVER=8.4.4 CABALVER=2.2 STACKVER=lts-12.26 addons: {apt: {packages: [ghc-8.4.4, cabal-install-2.2], sources: hvr-ghc}} - ghc: '8.2'- env: GHCVER=8.2.2 CABALVER=2.0+ env: GHCVER=8.2.2 CABALVER=2.0 STACKVER=lts-11.22 addons: {apt: {packages: [ghc-8.2.2, cabal-install-2.0], sources: hvr-ghc}} - ghc: '8.0'- env: GHCVER=8.0.2 CABALVER=1.24+ env: GHCVER=8.0.2 CABALVER=1.24 STACKVER=lts-9.21 addons: {apt: {packages: [ghc-8.0.2, cabal-install-1.24], sources: hvr-ghc}} - ghc: '7.10'- env: GHCVER=7.10.3 CABALVER=1.22+ env: GHCVER=7.10.3 CABALVER=1.22 STACKVER=lts-6.35 addons: {apt: {packages: [ghc-7.10.3, cabal-install-1.22], sources: hvr-ghc}} # we only support stack with GHC >= 7.10 - ghc: '7.8'@@ -104,6 +107,7 @@ - make haddock HADDOCKFLAGS= - make test-sdist - cabal test+ # Hugs is not a GHC version. But this is how travis can handle it. - ghc: 'hugs' env: GHCVER=hugs addons: {apt: {packages: [hugs]}}
Makefile view
@@ -47,8 +47,13 @@ update-diff-test: update-diff-test-tiers update-diff-test-funtiers $(patsubst %,%.update-diff-test,$(EGS)) +test-10000: $(patsubst %,%.run-10000,$(TESTS)) diff-test test-sdist+ %.run: % ./$<++%.run-10000: %+ ./$< 10000 eg/%.diff-test: eg/% ./$< | diff -rud test/diff/$<.out -
README.md view
@@ -35,6 +35,11 @@ $ cabal update $ cabal install leancheck +Starting from Cabal v3.0, you need to pass `--lib` as an argument to cabal+install:++ $ cabal install leancheck --lib+ Checking if properties are True -------------------------------
TODO.md view
@@ -3,14 +3,4 @@ List of things to do for LeanCheck. --misc-------* parameterize number of tests in test programs and add slow-test target---documentation----------------* on tutorial.md, write about how to create test programs;+Nothing planned at the moment.
changelog.md view
@@ -1,6 +1,13 @@ Changelog for LeanCheck ======================= +v0.9.3+------++* improve Haddock documentation+* use consistent code format+* improve CI scripts and Makefile+ v0.9.2 ------
doc/tutorial.md view
@@ -242,6 +242,53 @@ If you are unsure, you can always use *both* PBT and UT. +Writing a test program+----------------------++Writing a test program with LeanCheck is pretty simple. The following example+shows a full test program for the function `sort`.++ import Test.LeanCheck+ import Data.List (sort, elemIndices)+ import System.Exit (exitFailure)++ main :: IO ()+ main =+ case elemIndices False (tests 100) of+ [] -> putStrLn "Tests passed!"+ is -> putStrLn ("Failed tests:" ++ show is) >> exitFailure++ -- given a maximum number of tests,+ -- this function returns the test results+ tests :: Int -> [Bool]+ tests n =+ [ holds n $ \xs -> ordered (sort xs :: [Int])+ , holds n $ \xs -> length (sort xs :: [Int]) == length xs+ , holds n $ \x xs -> (x `elem` (sort xs :: [Int])) == (x `elem` xs)+ ]++ ordered :: Ord a => [a] -> Bool+ ordered (x:y:xs) = x <= y && ordered (y:xs)+ ordered _ = True++The above program prints the indices of failed tests if there are any.+The programmer can then copy-paste the selected test in GHCi to investigate.+The above program also returns an error code in case one of the tests fails+using `exitFailure`, so `make` or a CI system will detect that a test has+failed.++If you prefer a more heavyweight solution, LeanCheck has providers for the+Haskell testing frameworks [Tasty], [test-framework] and [Hspec]:++* [LeanCheck provider for Tasty]+ -- `$ cabal install tasty-leancheck` ;+* [LeanCheck provider for test-framework]+ -- `$ cabal install test-framework-leancheck` ;+* [LeanCheck provider for Hspec]+ -- `$ cabal install hspec-leancheck` .+++ Other property-based testing tools for Haskell ---------------------------------------------- @@ -283,3 +330,9 @@ [Ranking programs using Black-Box testing (2010)]: http://www.cse.chalmers.se/~nicsma/papers/ranking-programs.pdf +[Tasty]: https://github.com/feuerbach/tasty#readme+[test-framework]: https://haskell.github.io/test-framework/+[Hspec]: https://hspec.github.io/+[LeanCheck provider for Tasty]: https://hackage.haskell.org/package/tasty-leancheck+[LeanCheck provider for test-framework]: https://hackage.haskell.org/package/test-framework-leancheck+[LeanCheck provider for Hspec]: https://hackage.haskell.org/package/hspec-leancheck
leancheck.cabal view
@@ -11,7 +11,7 @@ -- this cabal file too complicated. -- Rudy name: leancheck-version: 0.9.2+version: 0.9.3 synopsis: Enumerative property-based testing description: LeanCheck is a simple enumerative property-based testing library.@@ -65,11 +65,13 @@ , mk/ghcdeps , mk/haddock-i , mk/haskell.mk+ , mk/install-on , stack.yaml , test/diff/*.out , test/diff/eg/*.out , test/sdist-tested-with: GHC==8.8+tested-with: GHC==8.10+ , GHC==8.8 , GHC==8.6 , GHC==8.4 , GHC==8.2@@ -87,7 +89,7 @@ source-repository this type: git location: https://github.com/rudymatela/leancheck- tag: v0.9.2+ tag: v0.9.3 library exposed-modules: Test.LeanCheck
mk/depend.mk view
@@ -249,11 +249,6 @@ src/Test/LeanCheck/Core.hs \ src/Test/LeanCheck/Basic.hs \ mk/Toplibs.hs-Setup.o: \- Setup.hs-Setup: \- Setup.hs \- mk/toplibs src/Test/LeanCheck/Basic.o: \ src/Test/LeanCheck/Core.hs \ src/Test/LeanCheck/Basic.hs@@ -463,12 +458,22 @@ test/fun.hs \ src/Test/LeanCheck/Utils/Types.hs \ src/Test/LeanCheck/Tiers.hs \+ src/Test/LeanCheck/Stats.hs \ src/Test/LeanCheck.hs \ src/Test/LeanCheck/IO.hs \+ src/Test/LeanCheck/Function/Show.hs \+ src/Test/LeanCheck/Function/ShowFunction.hs \+ src/Test/LeanCheck/Function/Show/EightLines.hs \+ src/Test/LeanCheck/Function.hs \+ src/Test/LeanCheck/Function/ListsOfPairs.hs \+ src/Test/LeanCheck/Function/Listable.hs \+ src/Test/LeanCheck/Function/Listable/ListsOfPairs.hs \+ src/Test/LeanCheck/Error.hs \ src/Test/LeanCheck/Derive.hs \ src/Test/LeanCheck/Core.hs \ src/Test/LeanCheck/Basic.hs test/funshow.o: \+ test/Test.hs \ test/funshow.hs \ src/Test/LeanCheck/Utils/Types.hs \ src/Test/LeanCheck/Utils/TypeBinding.hs \@@ -484,6 +489,7 @@ src/Test/LeanCheck/Core.hs \ src/Test/LeanCheck/Basic.hs test/funshow: \+ test/Test.hs \ test/funshow.hs \ mk/toplibs test/fun: \
mk/haskell.mk view
@@ -39,7 +39,7 @@ # ALL_HSS: all Haskell files # You can override ALL/LIB_HSS in your main Makefile LIST_LIB_HSS ?= find src -name "*.hs"-LIST_ALL_HSS ?= find \( -path "./dist" -o -path "./.stack-work" \) -prune \+LIST_ALL_HSS ?= find \( -path "./dist*" -o -path "./.stack-work" -o -path "./Setup.hs" \) -prune \ -o -name "*.*hs" -print LIB_HSS ?= $(shell $(LIST_LIB_HSS)) ALL_HSS ?= $(shell $(LIST_ALL_HSS))
+ mk/install-on view
@@ -0,0 +1,30 @@+#!/bin/bash+#+# mk/install-on: install or updates the mk folder on a Haskell project+#+# usage: ./mk/install-on path/to/project+#+# This assumes a few things:+#+# * tests are stored in a "test/" folder+# * sources are stored in a "src/" folder+set -e++errxit() {+ echo "$@" > /dev/stderr+ exit 1+}++src=`dirname $0`/..+dst="$1"++[ -n "$dst" ] || errxit "destination folder not provided"++mkdir -p $dst/mk+mkdir -p $dst/test++cp $src/mk/ghcdeps $dst/mk/ghcdeps+cp $src/mk/haddock-i $dst/mk/haddock-i+cp $src/mk/haskell.mk $dst/mk/haskell.mk+cp $src/mk/install-on $dst/mk/install-on+cp $src/test/sdist $dst/test/sdist
src/Test/LeanCheck.hs view
@@ -20,17 +20,33 @@ -- -- For example: ----- > holds 1000 $ \xs -> length (sort xs) == length (xs::[Int])---+-- > > import Data.List (sort)+-- > > holds 1000 $ \xs -> length (sort xs) == length (xs::[Int])+-- > True -- -- To get the smallest 'counterExample' by testing up to a thousand values, -- we evaluate: -- -- > counterExample 1000 property --+-- 'Nothing' indicates no counterexample was found,+-- a 'Just' value indicates a counterexample.+--+-- For instance:+--+-- > > import Data.List (union)+-- > > counterExample 1000 $ \xs ys -> union xs ys == union ys (xs :: [Int])+-- > Just ["[]","[0,0]"]+-- -- The suggested values for the number of tests to use with LeanCheck are -- 500, 1 000 or 10 000. LeanCheck is memory intensive and you should take -- care if you go beyond that.+--+-- The function 'check' can also be used to test and report counterexamples.+--+-- > > check $ \xs ys -> union xs ys == union ys (xs :: [Int])+-- > *** Failed! Falsifiable (after 4 tests):+-- > [] [0,0] -- -- -- Arguments of properties should be instances of the 'Listable' typeclass.
src/Test/LeanCheck/Basic.hs view
@@ -60,113 +60,112 @@ instance (Listable a, Listable b, Listable c, Listable d, Listable e, Listable f) => Listable (a,b,c,d,e,f) where- tiers = productWith (\x (y,z,w,v,u) -> (x,y,z,w,v,u)) tiers tiers+ tiers = productWith (\x (y,z,w,v,u) -> (x,y,z,w,v,u)) tiers tiers instance (Listable a, Listable b, Listable c, Listable d, Listable e, Listable f, Listable g) => Listable (a,b,c,d,e,f,g) where- tiers = productWith (\x (y,z,w,v,u,r) -> (x,y,z,w,v,u,r)) tiers tiers+ tiers = productWith (\x (y,z,w,v,u,r) -> (x,y,z,w,v,u,r)) tiers tiers instance (Listable a, Listable b, Listable c, Listable d, Listable e, Listable f, Listable g, Listable h) => Listable (a,b,c,d,e,f,g,h) where- tiers = productWith (\x (y,z,w,v,u,r,s) -> (x,y,z,w,v,u,r,s))- tiers tiers+ tiers = productWith (\x (y,z,w,v,u,r,s) -> (x,y,z,w,v,u,r,s)) tiers tiers instance (Listable a, Listable b, Listable c, Listable d, Listable e, Listable f, Listable g, Listable h, Listable i) => Listable (a,b,c,d,e,f,g,h,i) where- tiers = productWith (\x (y,z,w,v,u,r,s,t) -> (x,y,z,w,v,u,r,s,t))- tiers tiers+ tiers = productWith (\x (y,z,w,v,u,r,s,t) -> (x,y,z,w,v,u,r,s,t))+ tiers tiers instance (Listable a, Listable b, Listable c, Listable d, Listable e, Listable f, Listable g, Listable h, Listable i, Listable j) => Listable (a,b,c,d,e,f,g,h,i,j) where- tiers = productWith (\x (y,z,w,v,u,r,s,t,o) -> (x,y,z,w,v,u,r,s,t,o))- tiers tiers+ tiers = productWith (\x (y,z,w,v,u,r,s,t,o) -> (x,y,z,w,v,u,r,s,t,o))+ tiers tiers instance (Listable a, Listable b, Listable c, Listable d, Listable e, Listable f, Listable g, Listable h, Listable i, Listable j, Listable k) => Listable (a,b,c,d,e,f,g,h,i,j,k) where- tiers = productWith (\x (y,z,w,v,u,r,s,t,o,p) -> (x,y,z,w,v,u,r,s,t,o,p))- tiers tiers+ tiers = productWith (\x (y,z,w,v,u,r,s,t,o,p) -> (x,y,z,w,v,u,r,s,t,o,p))+ tiers tiers instance (Listable a, Listable b, Listable c, Listable d, Listable e, Listable f, Listable g, Listable h, Listable i, Listable j, Listable k, Listable l) => Listable (a,b,c,d,e,f,g,h,i,j,k,l) where- tiers = productWith (\x (y,z,w,v,u,r,s,t,o,p,q) ->- (x,y,z,w,v,u,r,s,t,o,p,q))- tiers tiers+ tiers = productWith (\x (y,z,w,v,u,r,s,t,o,p,q) ->+ (x,y,z,w,v,u,r,s,t,o,p,q))+ tiers tiers -- | Returns tiers of applications of a 6-argument constructor. cons6 :: (Listable a, Listable b, Listable c, Listable d, Listable e, Listable f) => (a -> b -> c -> d -> e -> f -> g) -> [[g]]-cons6 f = delay $ mapT (uncurry6 f) tiers+cons6 f = delay $ mapT (uncurry6 f) tiers -- | Returns tiers of applications of a 7-argument constructor. cons7 :: (Listable a, Listable b, Listable c, Listable d, Listable e, Listable f, Listable g) => (a -> b -> c -> d -> e -> f -> g -> h) -> [[h]]-cons7 f = delay $ mapT (uncurry7 f) tiers+cons7 f = delay $ mapT (uncurry7 f) tiers -- | Returns tiers of applications of a 8-argument constructor. cons8 :: (Listable a, Listable b, Listable c, Listable d, Listable e, Listable f, Listable g, Listable h) => (a -> b -> c -> d -> e -> f -> g -> h -> i) -> [[i]]-cons8 f = delay $ mapT (uncurry8 f) tiers+cons8 f = delay $ mapT (uncurry8 f) tiers -- | Returns tiers of applications of a 9-argument constructor. cons9 :: (Listable a, Listable b, Listable c, Listable d, Listable e, Listable f, Listable g, Listable h, Listable i) => (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> [[j]]-cons9 f = delay $ mapT (uncurry9 f) tiers+cons9 f = delay $ mapT (uncurry9 f) tiers -- | Returns tiers of applications of a 10-argument constructor. cons10 :: (Listable a, Listable b, Listable c, Listable d, Listable e, Listable f, Listable g, Listable h, Listable i, Listable j) => (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> [[k]]-cons10 f = delay $ mapT (uncurry10 f) tiers+cons10 f = delay $ mapT (uncurry10 f) tiers -- | Returns tiers of applications of a 11-argument constructor. cons11 :: (Listable a, Listable b, Listable c, Listable d, Listable e, Listable f, Listable g, Listable h, Listable i, Listable j, Listable k) => (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l) -> [[l]]-cons11 f = delay $ mapT (uncurry11 f) tiers+cons11 f = delay $ mapT (uncurry11 f) tiers -- | Returns tiers of applications of a 12-argument constructor. cons12 :: (Listable a, Listable b, Listable c, Listable d, Listable e, Listable f, Listable g, Listable h, Listable i, Listable j, Listable k, Listable l) => (a->b->c->d->e->f->g->h->i->j->k->l->m) -> [[m]]-cons12 f = delay $ mapT (uncurry12 f) tiers+cons12 f = delay $ mapT (uncurry12 f) tiers uncurry6 :: (a->b->c->d->e->f->g) -> (a,b,c,d,e,f) -> g-uncurry6 f (x,y,z,w,v,u) = f x y z w v u+uncurry6 f (x,y,z,w,v,u) = f x y z w v u uncurry7 :: (a->b->c->d->e->f->g->h) -> (a,b,c,d,e,f,g) -> h-uncurry7 f (x,y,z,w,v,u,r) = f x y z w v u r+uncurry7 f (x,y,z,w,v,u,r) = f x y z w v u r uncurry8 :: (a->b->c->d->e->f->g->h->i) -> (a,b,c,d,e,f,g,h) -> i-uncurry8 f (x,y,z,w,v,u,r,s) = f x y z w v u r s+uncurry8 f (x,y,z,w,v,u,r,s) = f x y z w v u r s uncurry9 :: (a->b->c->d->e->f->g->h->i->j) -> (a,b,c,d,e,f,g,h,i) -> j-uncurry9 f (x,y,z,w,v,u,r,s,t) = f x y z w v u r s t+uncurry9 f (x,y,z,w,v,u,r,s,t) = f x y z w v u r s t uncurry10 :: (a->b->c->d->e->f->g->h->i->j->k) -> (a,b,c,d,e,f,g,h,i,j) -> k-uncurry10 f (x,y,z,w,v,u,r,s,t,o) = f x y z w v u r s t o+uncurry10 f (x,y,z,w,v,u,r,s,t,o) = f x y z w v u r s t o uncurry11 :: (a->b->c->d->e->f->g->h->i->j->k->l) -> (a,b,c,d,e,f,g,h,i,j,k) -> l-uncurry11 f (x,y,z,w,v,u,r,s,t,o,p) = f x y z w v u r s t o p+uncurry11 f (x,y,z,w,v,u,r,s,t,o,p) = f x y z w v u r s t o p uncurry12 :: (a->b->c->d->e->f->g->h->i->j->k->l->m) -> (a,b,c,d,e,f,g,h,i,j,k,l) -> m-uncurry12 f (x,y,z,w,v,u,r,s,t,o,p,q) = f x y z w v u r s t o p q+uncurry12 f (x,y,z,w,v,u,r,s,t,o,p,q) = f x y z w v u r s t o p q --- | > list :: [Rational] =+-- | > list :: [Rational] = -- > [ 0 % 1 -- > , 1 % 1 -- > , (-1) % 1@@ -181,86 +180,86 @@ -- > , ... -- > ] instance (Integral a, Listable a) => Listable (Ratio a) where- tiers = mapT (uncurry (%)) . reset+ tiers = mapT (uncurry (%)) . reset $ tiers `suchThat` (\(n,d) -> d > 0 && n `gcd` d == 1) instance (RealFloat a, Listable a) => Listable (Complex a) where- tiers = cons2 (:+)+ tiers = cons2 (:+) --- | > list :: [Word] = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, ...]+-- | > list :: [Word] = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, ...] instance Listable Word where- list = listIntegral+ list = listIntegral --- | > list :: [Word8] = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, ..., 255]+-- | > list :: [Word8] = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, ..., 255] instance Listable Word8 where- list = listIntegral+ list = listIntegral --- | > list :: [Word16] = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, ..., 65535]+-- | > list :: [Word16] = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, ..., 65535] instance Listable Word16 where- list = listIntegral+ list = listIntegral --- | > list :: [Word32] = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, ...]+-- | > list :: [Word32] = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, ...] instance Listable Word32 where- list = listIntegral+ list = listIntegral --- | > list :: [Word64] = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, ...]+-- | > list :: [Word64] = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, ...] instance Listable Word64 where- list = listIntegral+ list = listIntegral --- | > list :: [Int8] = [0, 1, -1, 2, -2, 3, -3, ..., 127, -127, -128]+-- | > list :: [Int8] = [0, 1, -1, 2, -2, 3, -3, ..., 127, -127, -128] instance Listable Int8 where- list = listIntegral+ list = listIntegral --- | > list :: [Int16] = [0, 1, -1, 2, -2, ..., 32767, -32767, -32768]+-- | > list :: [Int16] = [0, 1, -1, 2, -2, ..., 32767, -32767, -32768] instance Listable Int16 where- list = listIntegral+ list = listIntegral --- | > list :: [Int32] = [0, 1, -1, 2, -2, 3, -3, 4, -4, 5, -5, 6, ...]+-- | > list :: [Int32] = [0, 1, -1, 2, -2, 3, -3, 4, -4, 5, -5, 6, ...] instance Listable Int32 where- list = listIntegral+ list = listIntegral --- | > list :: [Int64] = [0, 1, -1, 2, -2, 3, -3, 4, -4, 5, -5, 6, ...]+-- | > list :: [Int64] = [0, 1, -1, 2, -2, 3, -3, 4, -4, 5, -5, 6, ...] instance Listable Int64 where- list = listIntegral+ list = listIntegral -instance Listable CChar where list = listIntegral-instance Listable CSChar where list = listIntegral-instance Listable CUChar where list = listIntegral-instance Listable CShort where list = listIntegral-instance Listable CUShort where list = listIntegral-instance Listable CInt where list = listIntegral-instance Listable CUInt where list = listIntegral-instance Listable CLong where list = listIntegral-instance Listable CULong where list = listIntegral-instance Listable CPtrdiff where list = listIntegral-instance Listable CSize where list = listIntegral-instance Listable CWchar where list = listIntegral-instance Listable CSigAtomic where list = listIntegral-instance Listable CLLong where list = listIntegral-instance Listable CULLong where list = listIntegral-instance Listable CIntPtr where list = listIntegral-instance Listable CUIntPtr where list = listIntegral-instance Listable CIntMax where list = listIntegral-instance Listable CUIntMax where list = listIntegral-instance Listable CClock where list = listIntegral-instance Listable CTime where list = listIntegral-instance Listable CFloat where tiers = tiersFloating-instance Listable CDouble where tiers = tiersFloating+instance Listable CChar where list = listIntegral+instance Listable CSChar where list = listIntegral+instance Listable CUChar where list = listIntegral+instance Listable CShort where list = listIntegral+instance Listable CUShort where list = listIntegral+instance Listable CInt where list = listIntegral+instance Listable CUInt where list = listIntegral+instance Listable CLong where list = listIntegral+instance Listable CULong where list = listIntegral+instance Listable CPtrdiff where list = listIntegral+instance Listable CSize where list = listIntegral+instance Listable CWchar where list = listIntegral+instance Listable CSigAtomic where list = listIntegral+instance Listable CLLong where list = listIntegral+instance Listable CULLong where list = listIntegral+instance Listable CIntPtr where list = listIntegral+instance Listable CUIntPtr where list = listIntegral+instance Listable CIntMax where list = listIntegral+instance Listable CUIntMax where list = listIntegral+instance Listable CClock where list = listIntegral+instance Listable CTime where list = listIntegral+instance Listable CFloat where tiers = tiersFloating+instance Listable CDouble where tiers = tiersFloating #if __GLASGOW_HASKELL__ >= 802-instance Listable CBool where list = listIntegral+instance Listable CBool where list = listIntegral #endif #if __GLASGOW_HASKELL__-instance Listable CUSeconds where list = listIntegral-instance Listable CSUSeconds where list = listIntegral+instance Listable CUSeconds where list = listIntegral+instance Listable CSUSeconds where list = listIntegral #endif -- | Only includes valid POSIX exit codes -- -- > > list :: [ExitCode] -- > [ExitSuccess, ExitFailure 1, ExitFailure 2, ..., ExitFailure 255]-instance Listable ExitCode where list = ExitSuccess : map ExitFailure [1..255]+instance Listable ExitCode where list = ExitSuccess : map ExitFailure [1..255] -instance Listable GeneralCategory where list = [minBound..maxBound]+instance Listable GeneralCategory where list = [minBound..maxBound] instance Listable IOMode where tiers = cons0 ReadMode@@ -303,7 +302,7 @@ -- @ \`ofWeight\` /n/ @ is equivalent to 'reset' followed -- by @/n/@ applications of 'delay'. ofWeight :: [[a]] -> Int -> [[a]]-ofWeight xss w = dropWhile null xss `addWeight` w+ofWeight xss w = dropWhile null xss `addWeight` w -- | Adds to the weight of a constructor or tiers. --@@ -325,4 +324,4 @@ -- -- @ \`addWeight\` /n/ @ is equivalent to @/n/@ applications of 'delay'. addWeight :: [[a]] -> Int -> [[a]]-addWeight xss w = replicate w [] ++ xss+addWeight xss w = replicate w [] ++ xss
src/Test/LeanCheck/Core.hs view
@@ -96,10 +96,10 @@ -- -- For algebraic data types, the general form for 'tiers' is ----- > tiers = cons<N> ConstructorA--- > \/ cons<N> ConstructorB--- > \/ ...--- > \/ cons<N> ConstructorZ+-- > tiers = cons<N> ConstructorA+-- > \/ cons<N> ConstructorB+-- > \/ ...+-- > \/ cons<N> ConstructorZ -- -- where @N@ is the number of arguments of each constructor @A...Z@. --@@ -138,24 +138,23 @@ class Listable a where tiers :: [[a]] list :: [a]- tiers = toTiers list- list = concat tiers+ tiers = toTiers list+ list = concat tiers {-# MINIMAL list | tiers #-} -- | Takes a list of values @xs@ and transform it into tiers on which each -- tier is occupied by a single element from @xs@. ----- > > toTiers [x, y, z, ...]--- > [ [x], [y], [z], ...]+-- > toTiers [x, y, z, ...] = [[x], [y], [z], ...] -- -- To convert back to a list, just 'concat'. toTiers :: [a] -> [[a]]-toTiers = map (:[])+toTiers = map (:[]) -- | > list :: [()] = [()] -- > tiers :: [[()]] = [[()]] instance Listable () where- list = [()]+ list = [()] -- | Tiers of 'Integral' values. -- Can be used as a default implementation of 'list' for 'Integral' types.@@ -174,83 +173,83 @@ -- an arithmetic operation is negative such as 'GHC.Natural'. For these, use -- @[0..]@ as the 'list' implementation. listIntegral :: (Ord a, Num a) => [a]-listIntegral = 0 : positives +| negatives+listIntegral = 0 : positives +| negatives where- positives = takeWhile (>0) $ iterate (+1) 1 -- stop generating on overflow- negatives = takeWhile (<0) $ iterate (subtract 1) (-1)+ positives = takeWhile (>0) $ iterate (+1) 1 -- stop generating on overflow+ negatives = takeWhile (<0) $ iterate (subtract 1) (-1) --- | > tiers :: [[Int]] = [[0], [1], [-1], [2], [-2], [3], [-3], ...]--- > list :: [Int] = [0, 1, -1, 2, -2, 3, -3, 4, -4, 5, -5, 6, ...]+-- | > tiers :: [[Int]] = [[0], [1], [-1], [2], [-2], [3], [-3], ...]+-- > list :: [Int] = [0, 1, -1, 2, -2, 3, -3, 4, -4, 5, -5, 6, ...] instance Listable Int where- list = listIntegral+ list = listIntegral --- | > list :: [Int] = [0, 1, -1, 2, -2, 3, -3, 4, -4, 5, -5, 6, ...]+-- | > list :: [Int] = [0, 1, -1, 2, -2, 3, -3, 4, -4, 5, -5, 6, ...] instance Listable Integer where- list = listIntegral+ list = listIntegral --- | > list :: [Char] = ['a', ' ', 'b', 'A', 'c', '\', 'n', 'd', ...]+-- | > list :: [Char] = ['a', ' ', 'b', 'A', 'c', '\', 'n', 'd', ...] instance Listable Char where- list = ['a'..'z']- +| [' ','\n']- +| ['A'..'Z']- +| ['0'..'9']- +| ['!'..'/']- +| ['\t']- +| [':'..'@']- +| ['['..'`']- +| ['{'..'~']+ list = ['a'..'z']+ +| [' ','\n']+ +| ['A'..'Z']+ +| ['0'..'9']+ +| ['!'..'/']+ +| ['\t']+ +| [':'..'@']+ +| ['['..'`']+ +| ['{'..'~'] --- | > tiers :: [[Bool]] = [[False,True]]--- > list :: [[Bool]] = [False,True]+-- | > tiers :: [[Bool]] = [[False,True]]+-- > list :: [[Bool]] = [False,True] instance Listable Bool where- tiers = cons0 False \/ cons0 True+ tiers = cons0 False \/ cons0 True --- | > tiers :: [[Maybe Int]] = [[Nothing], [Just 0], [Just 1], ...]--- > tiers :: [[Maybe Bool]] = [[Nothing], [Just False, Just True]]+-- | > tiers :: [[Maybe Int]] = [[Nothing], [Just 0], [Just 1], ...]+-- > tiers :: [[Maybe Bool]] = [[Nothing], [Just False, Just True]] instance Listable a => Listable (Maybe a) where- tiers = cons0 Nothing \/ cons1 Just+ tiers = cons0 Nothing \/ cons1 Just --- | > tiers :: [[Either Bool Bool]] =+-- | > tiers :: [[Either Bool Bool]] = -- > [[Left False, Right False, Left True, Right True]]--- > tiers :: [[Either Int Int]] = [ [Left 0, Right 0]--- > , [Left 1, Right 1]--- > , [Left (-1), Right (-1)]--- > , [Left 2, Right 2]--- > , ... ]+-- > tiers :: [[Either Int Int]] = [ [Left 0, Right 0]+-- > , [Left 1, Right 1]+-- > , [Left (-1), Right (-1)]+-- > , [Left 2, Right 2]+-- > , ... ] instance (Listable a, Listable b) => Listable (Either a b) where- tiers = reset (cons1 Left)- \\// reset (cons1 Right)+ tiers = reset (cons1 Left)+ \\// reset (cons1 Right) --- | > tiers :: [[(Int,Int)]] =--- > [ [(0,0)]--- > , [(0,1),(1,0)]--- > , [(0,-1),(1,1),(-1,0)]--- > , ...]--- > list :: [(Int,Int)] = [ (0,0), (0,1), (1,0), (0,-1), (1,1), ...]+-- | > tiers :: [[(Int,Int)]] =+-- > [ [(0,0)]+-- > , [(0,1),(1,0)]+-- > , [(0,-1),(1,1),(-1,0)]+-- > , ...]+-- > list :: [(Int,Int)] = [ (0,0), (0,1), (1,0), (0,-1), (1,1), ...] instance (Listable a, Listable b) => Listable (a,b) where- tiers = tiers >< tiers+ tiers = tiers >< tiers --- | > list :: [(Int,Int,Int)] = [ (0,0,0), (0,0,1), (0,1,0), ...]+-- | > list :: [(Int,Int,Int)] = [ (0,0,0), (0,0,1), (0,1,0), ...] instance (Listable a, Listable b, Listable c) => Listable (a,b,c) where- tiers = productWith (\x (y,z) -> (x,y,z)) tiers tiers+ tiers = productWith (\x (y,z) -> (x,y,z)) tiers tiers instance (Listable a, Listable b, Listable c, Listable d) => Listable (a,b,c,d) where- tiers = productWith (\x (y,z,w) -> (x,y,z,w)) tiers tiers+ tiers = productWith (\x (y,z,w) -> (x,y,z,w)) tiers tiers instance (Listable a, Listable b, Listable c, Listable d, Listable e) => Listable (a,b,c,d,e) where- tiers = productWith (\x (y,z,w,v) -> (x,y,z,w,v)) tiers tiers+ tiers = productWith (\x (y,z,w,v) -> (x,y,z,w,v)) tiers tiers --- | > tiers :: [[ [Int] ]] = [ [ [] ]--- > , [ [0] ]--- > , [ [0,0], [1] ]--- > , [ [0,0,0], [0,1], [1,0], [-1] ]--- > , ... ]--- > list :: [ [Int] ] = [ [], [0], [0,0], [1], [0,0,0], ... ]+-- | > tiers :: [[ [Int] ]] = [ [ [] ]+-- > , [ [0] ]+-- > , [ [0,0], [1] ]+-- > , [ [0,0,0], [0,1], [1,0], [-1] ]+-- > , ... ]+-- > list :: [ [Int] ] = [ [], [0], [0,0], [1], [0,0,0], ... ] instance (Listable a) => Listable [a] where- tiers = cons0 []- \/ cons2 (:)+ tiers = cons0 []+ \/ cons2 (:) -- | Tiers of 'Fractional' values. -- This can be used as the implementation of 'tiers' for 'Fractional' types.@@ -272,8 +271,8 @@ -- > , ... -- > ] tiersFractional :: Fractional a => [[a]]-tiersFractional = mapT (\(x,y) -> fromInteger x / fromInteger y) . reset- $ tiers `suchThat` \(n,d) -> d > 0 && n `gcd` d == 1+tiersFractional = mapT (\(x,y) -> fromInteger x / fromInteger y) . reset+ $ tiers `suchThat` \(n,d) -> d > 0 && n `gcd` d == 1 -- | Tiers of 'Floating' values. -- This can be used as the implementation of 'tiers' for 'Floating' types.@@ -281,7 +280,7 @@ -- This function is equivalent to 'tiersFractional' -- with positive and negative infinities included: 1/0 and -1/0. ----- > tiersFloating :: [[Float]] =+-- > tiersFloating :: [[Float]] = -- > [ [0.0] -- > , [1.0] -- > , [-1.0, Infinity]@@ -300,11 +299,11 @@ -- -- @NaN@ and @-0@ are excluded from this enumeration. tiersFloating :: Fractional a => [[a]]-tiersFloating = tiersFractional \/ [ [], [], [1/0], [-1/0] {- , [-0], [0/0] -} ]+tiersFloating = tiersFractional \/ [ [], [], [1/0], [-1/0] {- , [-0], [0/0] -} ] -- | @NaN@ and @-0@ are not included in the list of 'Float's. ----- > list :: [Float] =+-- > list :: [Float] = -- > [ 0.0 -- > , 1.0, -1.0, Infinity -- > , 0.5, 2.0, -Infinity, -0.5, -2.0@@ -313,19 +312,19 @@ -- > , ... -- > ] instance Listable Float where- tiers = tiersFloating+ tiers = tiersFloating -- | @NaN@ and @-0@ are not included in the list of 'Double's. -- -- > list :: [Double] = [0.0, 1.0, -1.0, Infinity, 0.5, 2.0, ...] instance Listable Double where- tiers = tiersFloating+ tiers = tiersFloating --- | > list :: [Ordering] = [LT, EQ, GT]+-- | > list :: [Ordering] = [LT, EQ, GT] instance Listable Ordering where- tiers = cons0 LT- \/ cons0 EQ- \/ cons0 GT+ tiers = cons0 LT+ \/ cons0 EQ+ \/ cons0 GT -- | 'map' over tiers --@@ -333,7 +332,7 @@ -- -- > mapT f [xs, ys, zs, ...] = [map f xs, map f ys, map f zs] mapT :: (a -> b) -> [[a]] -> [[b]]-mapT = map . map+mapT = map . map -- | 'filter' tiers --@@ -341,51 +340,111 @@ -- -- > filterT odd tiers = [[], [1], [-1], [], [], [3], [-3], [], [], [5], ...] filterT :: (a -> Bool) -> [[a]] -> [[a]]-filterT f = map (filter f)+filterT f = map (filter f) -- | 'concat' tiers of tiers+--+-- > concatT [ [xss0, yss0, zss0, ...]+-- > , [xss1, yss1, zss1, ...]+-- > , [xss2, yss2, zss2, ...]+-- > , ...+-- > ]+-- > = xss0 \/ yss0 \/ zss0 \/ ...+-- > \/ delay (xss1 \/ yss1 \/ zss1 \/ ...+-- > \/ delay (xss2 \/ yss2 \/ zss2 \/ ...+-- > \/ (delay ...)))+--+-- (cf. 'concatMapT') concatT :: [[ [[a]] ]] -> [[a]]-concatT = foldr (\+:/) [] . map (foldr (\/) [])- where xss \+:/ yss = xss \/ ([]:yss)+concatT = foldr (\+:/) [] . map (foldr (\/) [])+ where+ xss \+:/ yss = xss \/ ([]:yss) -- | 'concatMap' over tiers+--+-- > concatMapT f [ [x0, y0, z0]+-- > , [x1, y1, z1]+-- > , [x2, y2, z2]+-- > , ...+-- > ]+-- > = f x0 \/ f y0 \/ f z0 \/ ...+-- > \/ delay (f x1 \/ f y1 \/ f z1 \/ ...+-- > \/ delay (f x2 \/ f y2 \/ f z2 \/ ...+-- > \/ (delay ...)))+--+-- (cf. 'concatT') concatMapT :: (a -> [[b]]) -> [[a]] -> [[b]]-concatMapT f = concatT . mapT f+concatMapT f = concatT . mapT f -- | Given a constructor with no arguments, -- returns 'tiers' of all possible applications of this constructor.--- Since in this case there is only one possible application (to no--- arguments), only a single value, of size/weight 0, will be present in the--- resulting list of tiers.+--+-- Since in this case there is only one possible application (to no+-- arguments), only a single value, of size/weight 0, will be present in the+-- resulting list of tiers.+--+-- To be used in the declaration of 'tiers' in 'Listable' instances.+--+-- > instance Listable <Type> where+-- > tiers = ...+-- > \/ cons0 <Constructor>+-- > \/ ... cons0 :: a -> [[a]]-cons0 x = [[x]]+cons0 x = [[x]] -- | Given a constructor with one 'Listable' argument, -- return 'tiers' of applications of this constructor.--- By default, returned values will have size/weight of 1.+--+-- By default, returned values will have size/weight of 1.+--+-- To be used in the declaration of 'tiers' in 'Listable' instances.+--+-- > instance Listable <Type> where+-- > tiers = ...+-- > \/ cons1 <Constructor>+-- > \/ ... cons1 :: Listable a => (a -> b) -> [[b]]-cons1 f = delay $ mapT f tiers+cons1 f = delay $ mapT f tiers -- | Given a constructor with two 'Listable' arguments, -- return 'tiers' of applications of this constructor.--- By default, returned values will have size/weight of 1.+--+-- By default, returned values will have size/weight of 1.+--+-- To be used in the declaration of 'tiers' in 'Listable' instances.+--+-- > instance Listable <Type> where+-- > tiers = ...+-- > \/ cons2 <Constructor>+-- > \/ ... cons2 :: (Listable a, Listable b) => (a -> b -> c) -> [[c]]-cons2 f = delay $ mapT (uncurry f) tiers+cons2 f = delay $ mapT (uncurry f) tiers -- | Returns tiers of applications of a 3-argument constructor.+--+-- To be used in the declaration of 'tiers' in 'Listable' instances.+--+-- > instance Listable <Type> where+-- > tiers = ...+-- > \/ cons3 <Constructor>+-- > \/ ... cons3 :: (Listable a, Listable b, Listable c) => (a -> b -> c -> d) -> [[d]]-cons3 f = delay $ mapT (uncurry3 f) tiers+cons3 f = delay $ mapT (uncurry3 f) tiers -- | Returns tiers of applications of a 4-argument constructor.+--+-- To be used in the declaration of 'tiers' in 'Listable' instances. cons4 :: (Listable a, Listable b, Listable c, Listable d) => (a -> b -> c -> d -> e) -> [[e]]-cons4 f = delay $ mapT (uncurry4 f) tiers+cons4 f = delay $ mapT (uncurry4 f) tiers -- | Returns tiers of applications of a 5-argument constructor.+--+-- To be used in the declaration of 'tiers' in 'Listable' instances. cons5 :: (Listable a, Listable b, Listable c, Listable d, Listable e) => (a -> b -> c -> d -> e -> f) -> [[f]]-cons5 f = delay $ mapT (uncurry5 f) tiers+cons5 f = delay $ mapT (uncurry5 f) tiers -- | Delays the enumeration of 'tiers'. -- Conceptually this function adds to the weight of a constructor.@@ -401,7 +460,7 @@ -- > \/ delay (cons<N> <Constructor>) -- > \/ ... delay :: [[a]] -> [[a]]-delay = ([]:)+delay = ([]:) -- | Resets any delays in a list-of 'tiers'. -- Conceptually this function makes a constructor "weightless",@@ -424,7 +483,7 @@ -- constructors. In general this will make the list of size 0 infinite, -- breaking the 'tiers' invariant (each tier must be finite). reset :: [[a]] -> [[a]]-reset = dropWhile null+reset = dropWhile null -- | Tiers of values that follow a property. --@@ -445,24 +504,24 @@ -- -- This function is just a 'flip'ped version of `filterT`. suchThat :: [[a]] -> (a->Bool) -> [[a]]-suchThat = flip filterT+suchThat = flip filterT -- | Lazily interleaves two lists, switching between elements of the two. -- Union/sum of the elements in the lists. -- -- > [x,y,z,...] +| [a,b,c,...] = [x,a,y,b,z,c,...] (+|) :: [a] -> [a] -> [a]-[] +| ys = ys-(x:xs) +| ys = x:(ys +| xs)+[] +| ys = ys+(x:xs) +| ys = x:(ys +| xs) infixr 5 +| -- | Append tiers --- sum of two tiers enumerations. -- -- > [xs,ys,zs,...] \/ [as,bs,cs,...] = [xs++as, ys++bs, zs++cs, ...] (\/) :: [[a]] -> [[a]] -> [[a]]-xss \/ [] = xss-[] \/ yss = yss-(xs:xss) \/ (ys:yss) = (xs ++ ys) : xss \/ yss+xss \/ [] = xss+[] \/ yss = yss+(xs:xss) \/ (ys:yss) = (xs ++ ys) : xss \/ yss infixr 7 \/ -- | Interleave tiers --- sum of two tiers enumerations.@@ -470,9 +529,9 @@ -- -- > [xs,ys,zs,...] \/ [as,bs,cs,...] = [xs+|as, ys+|bs, zs+|cs, ...] (\\//) :: [[a]] -> [[a]] -> [[a]]-xss \\// [] = xss-[] \\// yss = yss-(xs:xss) \\// (ys:yss) = (xs +| ys) : xss \\// yss+xss \\// [] = xss+[] \\// yss = yss+(xs:xss) \\// (ys:yss) = (xs +| ys) : xss \\// yss infixr 7 \\// -- | Take a tiered product of lists of tiers.@@ -483,7 +542,8 @@ -- > , t0**u2 ++ t1**u1 ++ t2**u0 -- > , ... ... ... ... -- > ]--- > where xs ** ys = [(x,y) | x <- xs, y <- ys]+-- > where+-- > xs ** ys = [(x,y) | x <- xs, y <- ys] -- -- Example: --@@ -494,20 +554,25 @@ -- > , [(3,0),(2,1),(1,2),(0,3)] -- > , ... -- > ]+--+-- (cf. 'productWith') (><) :: [[a]] -> [[b]] -> [[(a,b)]]-(><) = productWith (,)+(><) = productWith (,) infixr 8 >< -- | Take a tiered product of lists of tiers. -- 'productWith' can be defined by '><', as: -- -- > productWith f xss yss = map (uncurry f) $ xss >< yss+--+-- (cf. '><') productWith :: (a->b->c) -> [[a]] -> [[b]] -> [[c]]-productWith _ _ [] = []-productWith _ [] _ = []-productWith f (xs:xss) yss = map (xs **) yss- \/ delay (productWith f xss yss)- where xs ** ys = [x `f` y | x <- xs, y <- ys]+productWith _ _ [] = []+productWith _ [] _ = []+productWith f (xs:xss) yss = map (xs **) yss+ \/ delay (productWith f xss yss)+ where+ xs ** ys = [x `f` y | x <- xs, y <- ys] -- | 'Testable' values are functions -- of 'Listable' arguments that return boolean values.@@ -522,16 +587,19 @@ -- -- * @ Int -> Bool @ -- * @ String -> [Int] -> Bool @+--+-- (cf. 'results') class Testable a where resultiers :: a -> [[([String],Bool)]] instance Testable Bool where- resultiers p = [[([],p)]]+ resultiers p = [[([],p)]] instance (Testable b, Show a, Listable a) => Testable (a->b) where- resultiers p = concatMapT resultiersFor tiers- where resultiersFor x = mapFst (showsPrec 11 x "":) `mapT` resultiers (p x)- mapFst f (x,y) = (f x, y)+ resultiers p = concatMapT resultiersFor tiers+ where+ resultiersFor x = mapFst (showsPrec 11 x "":) `mapT` resultiers (p x)+ mapFst f (x,y) = (f x, y) -- | List all results of a 'Testable' property. -- Each result is a pair of a list of strings and a boolean.@@ -561,14 +629,14 @@ -- > , ... -- > ] results :: Testable a => a -> [([String],Bool)]-results = concat . resultiers+results = concat . resultiers -- | Lists all counter-examples for a number of tests to a property, -- -- > > counterExamples 12 $ \xs -> xs == nub (xs :: [Int]) -- > [["[0,0]"],["[0,0,0]"],["[0,0,0,0]"],["[0,0,1]"],["[0,1,0]"]] counterExamples :: Testable a => Int -> a -> [[String]]-counterExamples n p = [as | (as,False) <- take n (results p)]+counterExamples n p = [as | (as,False) <- take n (results p)] -- | Up to a number of tests to a property, -- returns 'Just' the first counter-example@@ -577,14 +645,14 @@ -- > > counterExample 100 $ \xs -> [] `union` xs == (xs::[Int]) -- > Just ["[0,0]"] counterExample :: Testable a => Int -> a -> Maybe [String]-counterExample n = listToMaybe . counterExamples n+counterExample n = listToMaybe . counterExamples n -- | Lists all witnesses up to a number of tests to a property. -- -- > > witnesses 1000 (\x -> x > 1 && x < 77 && 77 `rem` x == 0) -- > [["7"],["11"]] witnesses :: Testable a => Int -> a -> [[String]]-witnesses n p = [as | (as,True) <- take n (results p)]+witnesses n p = [as | (as,True) <- take n (results p)] -- | Up to a number of tests to a property, -- returns 'Just' the first witness@@ -593,44 +661,57 @@ -- > > witness 1000 (\x -> x > 1 && x < 77 && 77 `rem` x == 0) -- > Just ["7"] witness :: Testable a => Int -> a -> Maybe [String]-witness n = listToMaybe . witnesses n+witness n = listToMaybe . witnesses n -- | Does a property __hold__ up to a number of test values? ----- > holds 1000 $ \xs -> length (sort xs) == length xs+-- > > holds 1000 $ \xs -> length (sort xs) == length xs+-- > True --+-- > > holds 1000 $ \x -> x == x + 1+-- > False+-- -- The suggested number of test values are 500, 1 000 or 10 000. -- With more than that you may or may not run out of memory -- depending on the types being tested. -- This also applies to 'fails', 'exists', etc.+--+-- (cf. 'fails', 'counterExample') holds :: Testable a => Int -> a -> Bool-holds n = and . take n . map snd . results+holds n = and . take n . map snd . results -- | Does a property __fail__ for a number of test values? ----- > fails 1000 $ \xs -> xs ++ ys == ys ++ xs+-- > > fails 1000 $ \xs -> xs ++ ys == ys ++ xs+-- > True+--+-- > > holds 1000 $ \xs -> length (sort xs) == length xs+-- > False+--+-- This is the negation of 'holds'. fails :: Testable a => Int -> a -> Bool-fails n = not . holds n+fails n = not . holds n -- | There __exists__ an assignment of values that satisfies a property -- up to a number of test values? ----- > exists 1000 $ \x -> x > 10+-- > > exists 1000 $ \x -> x > 10+-- > True exists :: Testable a => Int -> a -> Bool-exists n = or . take n . map snd . results+exists n = or . take n . map snd . results uncurry3 :: (a->b->c->d) -> (a,b,c) -> d-uncurry3 f (x,y,z) = f x y z+uncurry3 f (x,y,z) = f x y z uncurry4 :: (a->b->c->d->e) -> (a,b,c,d) -> e-uncurry4 f (x,y,z,w) = f x y z w+uncurry4 f (x,y,z,w) = f x y z w uncurry5 :: (a->b->c->d->e->f) -> (a,b,c,d,e) -> f-uncurry5 f (x,y,z,w,v) = f x y z w v+uncurry5 f (x,y,z,w,v) = f x y z w v -- | Boolean implication operator. Useful for defining conditional properties: ----- > prop_something x y = condition x y ==> something x y+-- > prop_something x y = condition x y ==> something x y -- -- Examples: --@@ -638,6 +719,6 @@ -- > > check prop_addMonotonic -- > +++ OK, passed 200 tests. (==>) :: Bool -> Bool -> Bool-False ==> _ = True-True ==> p = p+False ==> _ = True+True ==> p = p infixr 0 ==>
src/Test/LeanCheck/Derive.hs view
@@ -9,7 +9,7 @@ -- a simple enumerative property-based testing library. -- -- Needs GHC and Template Haskell--- (tested on GHC 7.4, 7.6, 7.8, 7.10, 8.0, 8.2 and 8.4).+-- (tested on GHC 7.4, 7.6, 7.8, 7.10, 8.0, 8.2, 8.4, 8.6 and 8.8). -- -- If LeanCheck does not compile under later GHCs, this module is probably the -- culprit.@@ -35,14 +35,14 @@ #if __GLASGOW_HASKELL__ < 706 -- reportWarning was only introduced in GHC 7.6 / TH 2.8 reportWarning :: String -> Q ()-reportWarning = report False+reportWarning = report False #endif -- | Derives a 'Listable' instance for a given type 'Name'. -- -- Consider the following @Stack@ datatype: ----- > data Stack a = Stack a (Stack a) | Empty+-- > data Stack a = Stack a (Stack a) | Empty -- -- Writing --@@ -51,7 +51,7 @@ -- will automatically derive the following 'Listable' instance: -- -- > instance Listable a => Listable (Stack a) where--- > tiers = cons2 Stack \/ cons0 Empty+-- > tiers = cons2 Stack \/ cons0 Empty -- -- __Warning:__ if the values in your type need to follow a data invariant, the -- derived instance won't respect it. Use this only on "free"@@ -59,31 +59,31 @@ -- -- Needs the @TemplateHaskell@ extension. deriveListable :: Name -> DecsQ-deriveListable = deriveListableX True False+deriveListable = deriveListableX True False -- | Same as 'deriveListable' but does not warn when the requested instance -- already exists. The function 'deriveListable' is preferable in most -- situations. deriveListableIfNeeded :: Name -> DecsQ-deriveListableIfNeeded = deriveListableX False False+deriveListableIfNeeded = deriveListableX False False -- | Derives a 'Listable' instance for a given type 'Name' -- cascading derivation of type arguments as well. -- -- Consider the following series of datatypes: ----- > data Position = CEO | Manager | Programmer--- >--- > data Person = Person--- > { name :: String--- > , age :: Int--- > , position :: Position--- > }+-- > data Position = CEO | Manager | Programmer -- >--- > data Company = Company--- > { name :: String--- > , employees :: [Person]+-- > data Person = Person+-- > { name :: String+-- > , age :: Int+-- > , position :: Position -- > }+-- >+-- > data Company = Company+-- > { name :: String+-- > , employees :: [Person]+-- > } -- -- Writing --@@ -92,18 +92,18 @@ -- will automatically derive the following three 'Listable' instances: -- -- > instance Listable Position where--- > tiers = cons0 CEO \/ cons0 Manager \/ cons0 Programmer+-- > tiers = cons0 CEO \/ cons0 Manager \/ cons0 Programmer -- > -- > instance Listable Person where--- > tiers = cons3 Person+-- > tiers = cons3 Person -- > -- > instance Listable Company where--- > tiers = cons2 Company+-- > tiers = cons2 Company deriveListableCascading :: Name -> DecsQ-deriveListableCascading = deriveListableX True True+deriveListableCascading = deriveListableX True True deriveListableX :: Bool -> Bool -> Name -> DecsQ-deriveListableX warnExisting cascade t = do+deriveListableX warnExisting cascade t = do is <- t `isInstanceOf` ''Listable if is then do@@ -116,7 +116,7 @@ else reallyDeriveListable t reallyDeriveListable :: Name -> DecsQ-reallyDeriveListable t = do+reallyDeriveListable t = do (nt,vs) <- normalizeType t #if __GLASGOW_HASKELL__ >= 710 cxt <- sequence [[t| Listable $(return v) |] | v <- vs]@@ -125,7 +125,7 @@ #endif #if __GLASGOW_HASKELL__ >= 708 cxt |=>| [d| instance Listable $(return nt)- where tiers = $(deriveTiers t) |]+ where tiers = $(deriveTiers t) |] #else tiersE <- deriveTiers t return [ InstanceD@@ -143,21 +143,21 @@ -- This function can be used in the definition of 'Listable' instances: -- -- > instance Listable MyType where--- > tiers = $(deriveTiers)+-- > tiers = $(deriveTiers) deriveTiers :: Name -> ExpQ-deriveTiers t = conse =<< typeConstructors t+deriveTiers t = conse =<< typeConstructors t where- cone n as = do+ cone n as = do (Just consN) <- lookupValueName $ "cons" ++ show (length as) [| $(varE consN) $(conE n) |]- conse = foldr1 (\e1 e2 -> [| $e1 \/ $e2 |]) . map (uncurry cone)+ conse = foldr1 (\e1 e2 -> [| $e1 \/ $e2 |]) . map (uncurry cone) -- | Given a type 'Name', derives an expression to be placed as the result of -- 'list': -- -- > concat $ consN C1 \/ consN C2 \/ ... \/ consN CN deriveList :: Name -> ExpQ-deriveList t = [| concat $(deriveTiers t) |]+deriveList t = [| concat $(deriveTiers t) |] -- Not only really derive Listable instances, -- but cascade through argument types.@@ -172,35 +172,35 @@ -- * Template haskell utilities typeConArgs :: Name -> Q [Name]-typeConArgs t = do+typeConArgs t = do is <- isTypeSynonym t if is then liftM typeConTs $ typeSynonymType t else liftM (nubMerges . map typeConTs . concat . map snd) $ typeConstructors t where typeConTs :: Type -> [Name]- typeConTs (AppT t1 t2) = typeConTs t1 `nubMerge` typeConTs t2- typeConTs (SigT t _) = typeConTs t- typeConTs (VarT _) = []- typeConTs (ConT n) = [n]+ typeConTs (AppT t1 t2) = typeConTs t1 `nubMerge` typeConTs t2+ typeConTs (SigT t _) = typeConTs t+ typeConTs (VarT _) = []+ typeConTs (ConT n) = [n] #if __GLASGOW_HASKELL__ >= 800- -- typeConTs (PromotedT n) = [n] ?- typeConTs (InfixT t1 n t2) = typeConTs t1 `nubMerge` typeConTs t2- typeConTs (UInfixT t1 n t2) = typeConTs t1 `nubMerge` typeConTs t2- typeConTs (ParensT t) = typeConTs t+ -- typeConTs (PromotedT n) = [n] ?+ typeConTs (InfixT t1 n t2) = typeConTs t1 `nubMerge` typeConTs t2+ typeConTs (UInfixT t1 n t2) = typeConTs t1 `nubMerge` typeConTs t2+ typeConTs (ParensT t) = typeConTs t #endif- typeConTs _ = []+ typeConTs _ = [] typeConArgsThat :: Name -> (Name -> Q Bool) -> Q [Name]-typeConArgsThat t p = do+typeConArgsThat t p = do targs <- typeConArgs t tbs <- mapM (\t' -> do is <- p t'; return (t',is)) targs return [t' | (t',p) <- tbs, p] typeConCascadingArgsThat :: Name -> (Name -> Q Bool) -> Q [Name]-t `typeConCascadingArgsThat` p = do+t `typeConCascadingArgsThat` p = do ts <- t `typeConArgsThat` p- let p' t' = do is <- p t'; return $ t' `notElem` (t:ts) && is+ let p' t' = do is <- p t'; return $ t' `notElem` (t:ts) && is tss <- mapM (`typeConCascadingArgsThat` p') ts return $ nubMerges (ts:tss) @@ -210,21 +210,21 @@ -- -- Suppose: ----- > data DT a b c ... = ...+-- > data DT a b c ... = ... -- -- Then, in pseudo-TH: -- -- > normalizeType [t|DT|] == Q (DT a b c ..., [a, b, c, ...]) normalizeType :: Name -> Q (Type, [Type])-normalizeType t = do+normalizeType t = do ar <- typeArity t vs <- newVarTs ar return (foldl AppT (ConT t) vs, vs) where newNames :: [String] -> Q [Name]- newNames = mapM newName+ newNames = mapM newName newVarTs :: Int -> Q [Type]- newVarTs n = liftM (map VarT)+ newVarTs n = liftM (map VarT) $ newNames (take n . map (:[]) $ cycle ['a'..'z']) -- Normalizes a type by applying it to units (`()`) while possible.@@ -233,19 +233,19 @@ -- > normalizeTypeUnits ''Maybe === [t| Maybe () |] -- > normalizeTypeUnits ''Either === [t| Either () () |] normalizeTypeUnits :: Name -> Q Type-normalizeTypeUnits t = do+normalizeTypeUnits t = do ar <- typeArity t return (foldl AppT (ConT t) (replicate ar (TupleT 0))) -- Given a type name and a class name, -- returns whether the type is an instance of that class. isInstanceOf :: Name -> Name -> Q Bool-isInstanceOf tn cl = do+isInstanceOf tn cl = do ty <- normalizeTypeUnits tn isInstance cl [ty] isntInstanceOf :: Name -> Name -> Q Bool-isntInstanceOf tn cl = liftM not (isInstanceOf tn cl)+isntInstanceOf tn cl = liftM not (isInstanceOf tn cl) -- | Given a type name, return the number of arguments taken by that type. -- Examples in partially broken TH:@@ -259,7 +259,7 @@ -- This works for Data's and Newtype's and it is useful when generating -- typeclass instances. typeArity :: Name -> Q Int-typeArity t = do+typeArity t = do ti <- reify t return . length $ case ti of #if __GLASGOW_HASKELL__ < 800@@ -282,13 +282,13 @@ -- -- > typeConstructors ''[] === Q [('[],[]),('(:),[VarT a,AppT ListT (VarT a)])] ----- > data Pair a = P a a+-- > data Pair a = P a a -- > typeConstructors ''Pair === Q [('P,[VarT a, VarT a])] ----- > data Point = Pt Int Int+-- > data Point = Pt Int Int -- > typeConstructors ''Point === Q [('Pt,[ConT Int, ConT Int])] typeConstructors :: Name -> Q [(Name,[Type])]-typeConstructors t = do+typeConstructors t = do ti <- reify t return . map simplify $ case ti of #if __GLASGOW_HASKELL__ < 800@@ -301,21 +301,21 @@ _ -> error $ "error (typeConstructors): symbol " ++ show t ++ " is neither newtype nor data" where- simplify (NormalC n ts) = (n,map snd ts)- simplify (RecC n ts) = (n,map trd ts)- simplify (InfixC t1 n t2) = (n,[snd t1,snd t2])- simplify _ = error "Test.LeanCheck.Derive.typeConstructors: unhandled case (see source)"- trd (x,y,z) = z+ simplify (NormalC n ts) = (n,map snd ts)+ simplify (RecC n ts) = (n,map trd ts)+ simplify (InfixC t1 n t2) = (n,[snd t1,snd t2])+ simplify _ = error "Test.LeanCheck.Derive.typeConstructors: unhandled case (see source)"+ trd (x,y,z) = z isTypeSynonym :: Name -> Q Bool-isTypeSynonym t = do+isTypeSynonym t = do ti <- reify t return $ case ti of TyConI (TySynD _ _ _) -> True _ -> False typeSynonymType :: Name -> Q Type-typeSynonymType t = do+typeSynonymType t = do ti <- reify t return $ case ti of TyConI (TySynD _ _ t') -> t'@@ -325,50 +325,50 @@ -- Append to instance contexts in a declaration. -- -- > sequence [[|Eq b|],[|Eq c|]] |=>| [t|instance Eq a => Cl (Ty a) where f=g|]--- > == [t| instance (Eq a, Eq b, Eq c) => Cl (Ty a) where f = g |]+-- > == [t| instance (Eq a, Eq b, Eq c) => Cl (Ty a) where f = g |] (|=>|) :: Cxt -> DecsQ -> DecsQ-c |=>| qds = do ds <- qds- return $ map (`ac` c) ds+c |=>| qds = do ds <- qds+ return $ map (`ac` c) ds #if __GLASGOW_HASKELL__ < 800- where ac (InstanceD c ts ds) c' = InstanceD (c++c') ts ds- ac d _ = d+ where ac (InstanceD c ts ds) c' = InstanceD (c++c') ts ds+ ac d _ = d #else- where ac (InstanceD o c ts ds) c' = InstanceD o (c++c') ts ds- ac d _ = d+ where ac (InstanceD o c ts ds) c' = InstanceD o (c++c') ts ds+ ac d _ = d #endif -- > nubMerge xs ys == nub (merge xs ys) -- > nubMerge xs ys == nub (sort (xs ++ ys)) nubMerge :: Ord a => [a] -> [a] -> [a]-nubMerge [] ys = ys-nubMerge xs [] = xs-nubMerge (x:xs) (y:ys) | x < y = x : xs `nubMerge` (y:ys)- | x > y = y : (x:xs) `nubMerge` ys- | otherwise = x : xs `nubMerge` ys+nubMerge [] ys = ys+nubMerge xs [] = xs+nubMerge (x:xs) (y:ys) | x < y = x : xs `nubMerge` (y:ys)+ | x > y = y : (x:xs) `nubMerge` ys+ | otherwise = x : xs `nubMerge` ys nubMerges :: Ord a => [[a]] -> [a]-nubMerges = foldr nubMerge []+nubMerges = foldr nubMerge [] #else -- When using Hugs or other compiler without Template Haskell errorNotGHC :: a-errorNotGHC = error "Only defined when using GHC"+errorNotGHC = error "Only defined when using GHC" deriveListable :: a-deriveListable = errorNotGHC+deriveListable = errorNotGHC deriveListableIfNeeded :: a-deriveListableIfNeeded = errorNotGHC+deriveListableIfNeeded = errorNotGHC deriveListableCascading :: a-deriveListableCascading = errorNotGHC+deriveListableCascading = errorNotGHC deriveTiers :: a-deriveTiers = errorNotGHC+deriveTiers = errorNotGHC deriveList :: a-deriveList = errorNotGHC+deriveList = errorNotGHC -- closing #ifdef __GLASGOW_HASKELL__ #endif
src/Test/LeanCheck/Error.hs view
@@ -73,7 +73,7 @@ -- | Takes a value and a function. Ignores the value. Binds the argument of -- the function to the type of the value. bindArgumentType :: a -> (a -> b) -> a -> b-bindArgumentType _ f = f+bindArgumentType _ f = f -- | Transforms a value into 'Just' that value or 'Nothing' on some errors: --@@ -93,7 +93,7 @@ -- -- This function uses 'unsafePerformIO'. errorToNothing :: a -> Maybe a-errorToNothing x = unsafePerformIO $+errorToNothing x = unsafePerformIO $ #if __GLASGOW_HASKELL__ (Just `liftM` evaluate x) `catches` map ($ return Nothing) [ hf (undefined :: ArithException)@@ -101,17 +101,18 @@ , hf (undefined :: ErrorCall) , hf (undefined :: PatternMatchFail) ]- where hf :: Exception e => e -> IO a -> Handler a -- handlerFor- hf e h = Handler $ bindArgumentType e (\_ -> h)+ where+ hf :: Exception e => e -> IO a -> Handler a -- handlerFor+ hf e h = Handler $ bindArgumentType e (\_ -> h) #else (Just `liftM` evaluate x) `catch` (\_ -> return Nothing) #endif -- | Transforms a value into 'Just' that value or 'Nothing' on error. anyErrorToNothing :: a -> Maybe a-anyErrorToNothing x = unsafePerformIO $+anyErrorToNothing x = unsafePerformIO $ #if __GLASGOW_HASKELL__- (Just `liftM` evaluate x) `catch` \e -> do let _ = e :: SomeException+ (Just `liftM` evaluate x) `catch` \e -> do let _ = e :: SomeException return Nothing #else (Just `liftM` evaluate x) `catch` (\_ -> return Nothing)@@ -130,7 +131,7 @@ -- -- This functions uses 'unsafePerformIO'. errorToFalse :: Bool -> Bool-errorToFalse = fromError False+errorToFalse = fromError False -- | Transforms errors into 'True' values. --@@ -145,7 +146,7 @@ -- -- This functions uses 'unsafePerformIO'. errorToTrue :: Bool -> Bool-errorToTrue = fromError True+errorToTrue = fromError True -- | Transforms errors into a default value. --@@ -155,7 +156,7 @@ -- > > fromError 0 (undefined :: Int) -- > 0 fromError :: a -> a -> a-fromError x = fromMaybe x . errorToNothing+fromError x = fromMaybe x . errorToNothing -- | An error-catching version of 'Test.LeanCheck.holds' -- that returns 'False' in case of errors.@@ -172,34 +173,35 @@ -- > > holds 100 prop_cannot_be_seven -- > False holds :: Testable a => Int -> a -> Bool-holds n = errorToFalse . C.holds n+holds n = errorToFalse . C.holds n -- | An error-catching version of 'Test.LeanCheck.fails' -- that returns 'True' in case of errors. fails :: Testable a => Int -> a -> Bool-fails n = errorToTrue . C.fails n+fails n = errorToTrue . C.fails n -- | An error-catching version of 'Test.LeanCheck.exists'. exists :: Testable a => Int -> a -> Bool-exists n = or . take n . map snd . results+exists n = or . take n . map snd . results -- | An error-catching version of 'Test.LeanCheck.counterExample'. counterExample :: Testable a => Int -> a -> Maybe [String]-counterExample n = listToMaybe . counterExamples n+counterExample n = listToMaybe . counterExamples n -- | An error-catching version of 'Test.LeanCheck.witness'. witness :: Testable a => Int -> a -> Maybe [String]-witness n = listToMaybe . witnesses n+witness n = listToMaybe . witnesses n -- | An error-catching version of 'Test.LeanCheck.counterExamples'. counterExamples :: Testable a => Int -> a -> [[String]]-counterExamples n = map fst . filter (not . snd) . take n . results+counterExamples n = map fst . filter (not . snd) . take n . results -- | An error-catching version of 'Test.LeanCheck.witnesses'. witnesses :: Testable a => Int -> a -> [[String]]-witnesses n = map fst . filter snd . take n . results+witnesses n = map fst . filter snd . take n . results -- | An error-catching version of 'Test.LeanCheck.results'. results :: Testable a => a -> [([String],Bool)]-results = map (mapSnd errorToFalse) . C.results- where mapSnd f (x,y) = (x,f y)+results = map (mapSnd errorToFalse) . C.results+ where+ mapSnd f (x,y) = (x,f y)
src/Test/LeanCheck/Generic.hs view
@@ -30,59 +30,59 @@ -- Use it to define your 'Listable' instances like so: -- -- > instance Listable MyType where--- > list = genericList+-- > list = genericList -- -- Consider using 'genericTiers' instead of this -- (unless you know what you're doing). genericList :: (Generic a, Listable' (Rep a)) => [a]-genericList = concat genericTiers+genericList = concat genericTiers -- | A generic implementation of 'tiers' for instances of 'Generic'. -- -- Use it to define your 'Listable' instances like so: -- -- > instance Listable MyType where--- > tiers = genericTiers+-- > tiers = genericTiers genericTiers :: (Generic a, Listable' (Rep a)) => [[a]]-genericTiers = mapT to tiers'+genericTiers = mapT to tiers' class Listable' f where tiers' :: [[f p]] instance Listable' V1 where- tiers' = undefined+ tiers' = undefined instance Listable' U1 where- tiers' = [[U1]]+ tiers' = [[U1]] instance Listable c => Listable' (K1 i c) where- tiers' = mapT K1 tiers+ tiers' = mapT K1 tiers instance (Listable' a, Listable' b) => Listable' (a :+: b) where- tiers' = mapT L1 tiers' \/ mapT R1 tiers'+ tiers' = mapT L1 tiers' \/ mapT R1 tiers' instance (Listable' a, Listable' b) => Listable' (a :*: b) where- tiers' = productWith (:*:) tiers' tiers'+ tiers' = productWith (:*:) tiers' tiers' instance Listable' f => Listable' (S1 c f) where- tiers' = mapT M1 tiers'+ tiers' = mapT M1 tiers' instance Listable' f => Listable' (D1 c f) where- tiers' = mapT M1 tiers'+ tiers' = mapT M1 tiers' #if __GLASGOW_HASKELL__ >= 710 -- don't delay when there is a constructor with 0 arguments instance {-# OVERLAPPING #-} Listable' (C1 c U1) where- tiers' = mapT M1 tiers'+ tiers' = mapT M1 tiers' -- delay when there is a constructor with 1 or more arguments instance {-# OVERLAPPABLE #-} Listable' f => Listable' (C1 c f) where- tiers' = delay $ mapT M1 tiers'+ tiers' = delay $ mapT M1 tiers' #else instance Listable' (C1 c U1)- where tiers' = mapT M1 tiers'+ where tiers' = mapT M1 tiers' instance Listable' f => Listable' (C1 c f)- where tiers' = delay $ mapT M1 tiers'+ where tiers' = delay $ mapT M1 tiers' #endif
src/Test/LeanCheck/IO.hs view
@@ -27,18 +27,19 @@ #else -- on Hugs import Control.Exception (Exception, catch, evaluate)-type SomeException = Exception+type SomeException = Exception #endif -- | Checks a property printing results on 'System.IO.stdout' -- -- > > check $ \xs -> sort (sort xs) == sort (xs::[Int]) -- > +++ OK, passed 200 tests.+-- -- > > check $ \xs ys -> xs `union` ys == ys `union` (xs::[Int]) -- > *** Failed! Falsifiable (after 4 tests): -- > [] [0,0] check :: Testable a => a -> IO ()-check p = checkResult p >> return ()+check p = checkResult p >> return () -- | Check a property for a given number of tests -- printing results on 'System.IO.stdout'@@ -46,7 +47,7 @@ -- > > checkFor 1000 $ \xs -> sort (sort xs) == sort (xs::[Int]) -- > +++ OK, passed 1000 tests. checkFor :: Testable a => Int -> a -> IO ()-checkFor n p = checkResultFor n p >> return ()+checkFor n p = checkResultFor n p >> return () -- | Check a property -- printing results on 'System.IO.stdout' and@@ -54,16 +55,18 @@ -- -- > > p <- checkResult $ \xs -> sort (sort xs) == sort (xs::[Int]) -- > +++ OK, passed 200 tests.+-- > -- > > q <- checkResult $ \xs ys -> xs `union` ys == ys `union` (xs::[Int]) -- > *** Failed! Falsifiable (after 4 tests): -- > [] [0,0]+-- > -- > > p && q -- > False -- -- There is no option to silence this function: -- for silence, you should use 'Test.LeanCheck.holds'. checkResult :: Testable a => a -> IO Bool-checkResult p = checkResultFor 200 p+checkResult p = checkResultFor 200 p -- | Check a property for a given number of tests -- printing results on 'System.IO.stdout' and@@ -76,56 +79,57 @@ -- There is no option to silence this function: -- for silence, you should use 'Test.LeanCheck.holds'. checkResultFor :: Testable a => Int -> a -> IO Bool-checkResultFor n p = do+checkResultFor n p = do r <- resultIO n p putStrLn . showResult n $ r return (isOK r)- where isOK (OK _) = True- isOK _ = False+ where+ isOK (OK _) = True+ isOK _ = False -data Result = OK Int- | Falsified Int [String]- | Exception Int [String] String+data Result = OK Int+ | Falsified Int [String]+ | Exception Int [String] String deriving (Eq, Show) resultsIO :: Testable a => Int -> a -> [IO Result]-resultsIO n = zipWith torio [1..] . take n . results+resultsIO n = zipWith torio [1..] . take n . results where- tor i (_,True) = OK i- tor i (as,False) = Falsified i as- torio i r@(as,_) = evaluate (tor i r)- `catch` \e -> let _ = e :: SomeException- in return (Exception i as (show e))+ tor i (_,True) = OK i+ tor i (as,False) = Falsified i as+ torio i r@(as,_) = evaluate (tor i r)+ `catch` \e -> let _ = e :: SomeException+ in return (Exception i as (show e)) resultIO :: Testable a => Int -> a -> IO Result-resultIO n = computeResult . resultsIO n+resultIO n = computeResult . resultsIO n where- computeResult [] = error "resultIO: no results, empty Listable enumeration?"- computeResult [r] = r- computeResult (r:rs) = r >>= \r -> case r of- (OK _) -> computeResult rs- _ -> return r+ computeResult [] = error "resultIO: no results, empty Listable enumeration?"+ computeResult [r] = r+ computeResult (r:rs) = r >>= \r -> case r of+ (OK _) -> computeResult rs+ _ -> return r showResult :: Int -> Result -> String-showResult m (OK n) = "+++ OK, passed " ++ show n ++ " tests"- ++ takeWhile (\_ -> n < m) " (exhausted)" ++ "."-showResult m (Falsified i ce) = "*** Failed! Falsifiable (after "- ++ show i ++ " tests):\n" ++ joinArgs ce-showResult m (Exception i ce e) = "*** Failed! Exception '" ++ e ++ "' (after "- ++ show i ++ " tests):\n" ++ joinArgs ce+showResult m (OK n) = "+++ OK, passed " ++ show n ++ " tests"+ ++ takeWhile (\_ -> n < m) " (exhausted)" ++ "."+showResult m (Falsified i ce) = "*** Failed! Falsifiable (after "+ ++ show i ++ " tests):\n" ++ joinArgs ce+showResult m (Exception i ce e) = "*** Failed! Exception '" ++ e ++ "' (after "+ ++ show i ++ " tests):\n" ++ joinArgs ce -- joins the counter-example arguments joinArgs :: [String] -> String-joinArgs ce | any ('\n' `elem`) ce = unlines $ map (chopBreak . deparenf) ce- | otherwise = unwords ce+joinArgs ce | any ('\n' `elem`) ce = unlines $ map (chopBreak . deparenf) ce+ | otherwise = unwords ce -- deparenthises a functional expression if it is parenthized deparenf :: String -> String-deparenf ('(':'\\':cs) | last cs == ')' = '\\':init cs-deparenf cs = cs+deparenf ('(':'\\':cs) | last cs == ')' = '\\':init cs+deparenf cs = cs -- chops a line break at the end if there is any chopBreak :: String -> String-chopBreak [] = []-chopBreak ['\n'] = []-chopBreak (x:xs) = x:chopBreak xs+chopBreak [] = []+chopBreak ['\n'] = []+chopBreak (x:xs) = x:chopBreak xs
src/Test/LeanCheck/Stats.hs view
@@ -32,15 +32,15 @@ import Data.List (transpose) intercalate :: [a] -> [[a]] -> [a]-intercalate xs xss = concat (intersperse xs xss)+intercalate xs xss = concat (intersperse xs xss) where- intersperse :: a -> [a] -> [a]- intersperse _ [] = []- intersperse sep (x:xs) = x : prependToAll sep xs+ intersperse :: a -> [a] -> [a]+ intersperse _ [] = []+ intersperse sep (x:xs) = x : prependToAll sep xs where- prependToAll :: a -> [a] -> [a]- prependToAll _ [] = []- prependToAll sep (x:xs) = sep : x : prependToAll sep xs+ prependToAll :: a -> [a] -> [a]+ prependToAll _ [] = []+ prependToAll sep (x:xs) = sep : x : prependToAll sep xs #endif -- | Prints statistics about a given 'Listable' generator@@ -64,17 +64,17 @@ -- label, collect, classify and tabulate -- while keeping statistics separate from your properties. classStats :: (Listable a, Show b) => Int -> (a -> b) -> IO ()-classStats n f = putStrLn- . table " "- . map showCount- $ countsOn (unquote . show . f) xs+classStats n f = putStrLn+ . table " "+ . map showCount+ $ countsOn (unquote . show . f) xs where- xs = take n list- len = length xs- showCount (s,n) = [ s ++ ":"- , show n ++ "/" ++ show len- , show (100 * n `div` len) ++ "%"- ]+ xs = take n list+ len = length xs+ showCount (s,n) = [ s ++ ":"+ , show n ++ "/" ++ show len+ , show (100 * n `div` len) ++ "%"+ ] -- | Same as 'classStats', but separated by 'tiers'. --@@ -100,20 +100,20 @@ -- > True: 6 1 1 1 1 1 1 -- > False: 57 0 1 3 7 15 31 classStatsT :: (Listable a, Show b) => Int -> (a -> b) -> IO ()-classStatsT n f = putStrLn- . table " "- . (heading:)- . ([" "]:)- . map showCounts- . prependTotal- . countsTOn (unquote . show . f)- $ take n tiers+classStatsT n f = putStrLn+ . table " "+ . (heading:)+ . ([" "]:)+ . map showCounts+ . prependTotal+ . countsTOn (unquote . show . f)+ $ take n tiers where- heading = "" : "tot " : map show [0..(n-1)]- showCounts (s,n,ns) = (s ++ ":") : (show n ++ " ") : map show ns- (_,n,ns) -+- (_,n',ns') = ("tot", n + n', zipWith (+) ns ns')- totalizeCounts = foldr (-+-) (undefined, 0, repeat 0)- prependTotal cs = totalizeCounts cs : cs+ heading = "" : "tot " : map show [0..(n-1)]+ showCounts (s,n,ns) = (s ++ ":") : (show n ++ " ") : map show ns+ (_,n,ns) -+- (_,n',ns') = ("tot", n + n', zipWith (+) ns ns')+ totalizeCounts = foldr (-+-) (undefined, 0, repeat 0)+ prependTotal cs = totalizeCounts cs : cs -- | How many values match each of a list of conditions? -- @@ -128,15 +128,15 @@ -- > > conditionStats 1000 [("ordered", ordered :: [Int] -> Bool)] -- > ordered: 131/1000 13% conditionStats :: Listable a => Int -> [(String,a->Bool)] -> IO ()-conditionStats n = putStrLn . table " " . map show1+conditionStats n = putStrLn . table " " . map show1 where- xs = take n list- len = length xs- show1 (s,f) = let c = count f xs- in [ s ++ ":"- , show c ++ "/" ++ show len- , show (100 * c `div` len) ++ "%" ]- count f = length . filter f+ xs = take n list+ len = length xs+ show1 (s,f) = let c = count f xs+ in [ s ++ ":"+ , show c ++ "/" ++ show len+ , show (100 * c `div` len) ++ "%" ]+ count f = length . filter f -- | Same as 'conditionStats' but by tier. --@@ -155,11 +155,11 @@ -- > total: 1 1 2 4 8 16 32 64 128 256 -- > ordered: 1 1 2 3 5 7 11 15 22 30 conditionStatsT :: Listable a => Int -> [(String,a->Bool)] -> IO ()-conditionStatsT n = putStrLn . table " " . map show1 . (("total", const True):)+conditionStatsT n = putStrLn . table " " . map show1 . (("total", const True):) where- xss = take n tiers- show1 (s,f) = (s ++ ":") : map (show . count f) xss- count f = length . filter f+ xss = take n tiers+ show1 (s,f) = (s ++ ":") : map (show . count f) xss+ count f = length . filter f -- | Classify values using their 'Eq' instance. --@@ -168,7 +168,7 @@ -- -- (cf. 'classifyBy', 'classifyOn') classify :: Eq a => [a] -> [[a]]-classify = classifyBy (==)+classify = classifyBy (==) -- | Classify values by a given comparison function. --@@ -177,11 +177,11 @@ -- -- (cf. 'classify', 'classifyOn') classifyBy :: (a -> a -> Bool) -> [a] -> [[a]]-classifyBy (==) [] = []-classifyBy (==) (x:xs) = (x:filter (== x) xs)+classifyBy (==) [] = []+classifyBy (==) (x:xs) = (x:filter (== x) xs) : classifyBy (==) (filter (/= x) xs) where- x /= y = not (x == y)+ x /= y = not (x == y) -- | Classify values based on the result of a given function. --@@ -193,7 +193,7 @@ -- -- (cf. 'classify', 'classifyBy') classifyOn :: Eq b => (a -> b) -> [a] -> [[a]]-classifyOn f xs = map (map fst)+classifyOn f xs = map (map fst) . classifyBy ((==) `on` snd) $ map (\x -> (x,f x)) xs @@ -204,12 +204,12 @@ -- -- Values are returned in the order they appear. counts :: Eq a => [a] -> [(a,Int)]-counts = map headLength . classify+counts = map headLength . classify -- | Returns the counts of each value in a list -- using a given comparison function. countsBy :: (a -> a -> Bool) -> [a] -> [(a,Int)]-countsBy (==) = map headLength . classifyBy (==)+countsBy (==) = map headLength . classifyBy (==) -- | Returns the counts of each value in a list -- based on a projection.@@ -217,34 +217,34 @@ -- > > countsOn length ["sheep", "chip", "ship", "cheap", "Mississippi"] -- > [(5,2),(4,2),(11,1)] countsOn :: Eq b => (a -> b) -> [a] -> [(b,Int)]-countsOn f = map (\xs -> (f $ head xs, length xs)) . classifyOn f+countsOn f = map (\xs -> (f $ head xs, length xs)) . classifyOn f countsT :: Eq a => [[a]] -> [(a,Int,[Int])]-countsT xss = [(x,n,map (count x) xss) | (x,n) <- counts (concat xss)]+countsT xss = [(x,n,map (count x) xss) | (x,n) <- counts (concat xss)] where- count x = length . filter (== x)+ count x = length . filter (== x) countsTOn :: Eq b => (a -> b) -> [[a]] -> [(b,Int,[Int])]-countsTOn f = countsT . mapT f+countsTOn f = countsT . mapT f headLength :: [a] -> (a,Int)-headLength xs = (head xs, length xs)+headLength xs = (head xs, length xs) unquote :: String -> String-unquote ('"':s) | last s == '"' = init s-unquote s = s+unquote ('"':s) | last s == '"' = init s+unquote s = s table :: String -> [[String]] -> String-table s [] = ""-table s sss = unlines- . map (removeTrailing ' ')- . map (intercalate s)- . transpose- . map (normalize ' ')- . foldr1 (zipWith (++))- . map (normalize "" . map lines)- . normalize ""- $ sss+table s [] = ""+table s sss = unlines+ . map (removeTrailing ' ')+ . map (intercalate s)+ . transpose+ . map (normalize ' ')+ . foldr1 (zipWith (++))+ . map (normalize "" . map lines)+ . normalize ""+ $ sss -- | Fits a list to a certain width by appending a certain value --@@ -252,19 +252,19 @@ -- -- > fit 0 6 [1,2,3] == [1,2,3,0,0,0] fit :: a -> Int -> [a] -> [a]-fit x n xs = replicate (n - length xs) x ++ xs+fit x n xs = replicate (n - length xs) x ++ xs -- | normalize makes all list the same length by adding a value -- -- > normalize ["asdf","qw","er"] == normalize ["asdf","qw ","er "] normalize :: a -> [[a]] -> [[a]]-normalize x xs = map (x `fit` maxLength xs) xs+normalize x xs = map (x `fit` maxLength xs) xs -- | Given a list of lists returns the maximum length maxLength :: [[a]] -> Int-maxLength = maximum . (0:) . map length+maxLength = maximum . (0:) . map length removeTrailing :: Eq a => a -> [a] -> [a]-removeTrailing x = reverse- . dropWhile (==x)- . reverse+removeTrailing x = reverse+ . dropWhile (==x)+ . reverse
src/Test/LeanCheck/Tiers.hs view
@@ -81,7 +81,7 @@ -- You should use 'cons1' instead: this serves more as an illustration of how -- 'setCons' and 'bagCons' work (see source). listCons :: Listable a => ([a] -> b) -> [[b]]-listCons = (`mapT` listsOf tiers)+listCons = (`mapT` listsOf tiers) -- | Given a constructor that takes a bag of elements (as a list), -- lists tiers of applications of this constructor.@@ -90,7 +90,7 @@ -- -- > bagCons Bag bagCons :: Listable a => ([a] -> b) -> [[b]]-bagCons = (`mapT` bagsOf tiers)+bagCons = (`mapT` bagsOf tiers) -- | Given a constructor that takes a set of elements (as a list), -- lists tiers of applications of this constructor.@@ -99,16 +99,16 @@ -- would read: -- -- > instance Listable a => Listable (Set a) where--- > tiers = cons0 empty \/ cons2 insert+-- > tiers = cons0 empty \/ cons2 insert -- -- The above instance has a problem: it generates repeated sets. -- A more efficient implementation that does not repeat sets is given by: ----- > tiers = setCons fromList+-- > tiers = setCons fromList -- -- Alternatively, you can use 'setsOf' direclty. setCons :: Listable a => ([a] -> b) -> [[b]]-setCons = (`mapT` setsOf tiers)+setCons = (`mapT` setsOf tiers) -- | Given a constructor that takes a map of elements (encoded as a list), -- lists tiers of applications of this constructor@@ -119,28 +119,28 @@ -- This allows defining an efficient implementation of `tiers` that does not -- repeat maps given by: ----- > tiers = mapCons fromList+-- > tiers = mapCons fromList mapCons :: (Listable a, Listable b) => ([(a,b)] -> c) -> [[c]]-mapCons = (`mapT` maps tiers tiers)+mapCons = (`mapT` maps tiers tiers) -- | Given a constructor that takes a list with no duplicate elements, -- return tiers of applications of this constructor. noDupListCons :: Listable a => ([a] -> b) -> [[b]]-noDupListCons = (`mapT` noDupListsOf tiers)+noDupListCons = (`mapT` noDupListsOf tiers) -- | Like 'cons0' but lifted over a 'Maybe' value. -- -- Only a 'Just' value will be returned. maybeCons0 :: Maybe b -> [[b]]-maybeCons0 Nothing = []-maybeCons0 (Just x) = [[x]]+maybeCons0 Nothing = []+maybeCons0 (Just x) = [[x]] -- | Like 'cons1' but lifted over a 'Maybe' result. -- -- This discard 'Nothing' values. -- Only 'Just' values are returned. maybeCons1 :: Listable a => (a -> Maybe b) -> [[b]]-maybeCons1 f = delay $ mapMaybeT f tiers+maybeCons1 f = delay $ mapMaybeT f tiers -- | Like 'cons2' but lifted over a 'Maybe' result. --@@ -149,33 +149,34 @@ -- -- Useful when declaring generators which have pre-conditions: ----- > data Fraction = Fraction Int Int+-- > data Fraction = Fraction Int Int -- >--- > mkFraction _ 0 = Nothing--- > mkFraction n d = Fraction n d+-- > mkFraction _ 0 = Nothing+-- > mkFraction n d = Fraction n d -- > -- > instance Listable Fraction where--- > tiers = maybeCons2 mkFraction+-- > tiers = maybeCons2 mkFraction maybeCons2 :: (Listable a, Listable b) => (a -> b -> Maybe c) -> [[c]]-maybeCons2 f = delay $ mapMaybeT (uncurry f) tiers+maybeCons2 f = delay $ mapMaybeT (uncurry f) tiers -- | Like '><', but over 3 lists of tiers. product3 :: [[a]] -> [[b]]-> [[c]] -> [[(a,b,c)]]-product3 = product3With (\x y z -> (x,y,z))+product3 = product3With (\x y z -> (x,y,z)) -- | Like 'productWith', but over 3 lists of tiers. product3With :: (a->b->c->d) -> [[a]] -> [[b]] -> [[c]] -> [[d]]-product3With f xss yss zss = productWith ($) (productWith f xss yss) zss+product3With f xss yss zss = productWith ($) (productWith f xss yss) zss -- | Take the product of lists of tiers -- by a function returning a 'Maybe' value -- discarding 'Nothing' values. productMaybeWith :: (a->b->Maybe c) -> [[a]] -> [[b]] -> [[c]]-productMaybeWith _ _ [] = []-productMaybeWith _ [] _ = []-productMaybeWith f (xs:xss) yss = map (xs **) yss- \/ delay (productMaybeWith f xss yss)- where xs ** ys = catMaybes [ f x y | x <- xs, y <- ys ]+productMaybeWith _ _ [] = []+productMaybeWith _ [] _ = []+productMaybeWith f (xs:xss) yss = map (xs **) yss+ \/ delay (productMaybeWith f xss yss)+ where+ xs ** ys = catMaybes [ f x y | x <- xs, y <- ys ] -- | Takes as argument tiers of element values; -- returns tiers of pairs with distinct element values.@@ -184,13 +185,13 @@ -- -- > distinctPairs xss = xss >< xss `suchThat` uncurry (/=) distinctPairs :: [[a]] -> [[(a,a)]]-distinctPairs = distinctPairsWith (,)+distinctPairs = distinctPairsWith (,) -- | 'distinctPairs' by a given function: ----- > distinctPairsWith f = mapT (uncurry f) . distinctPairs+-- > distinctPairsWith f = mapT (uncurry f) . distinctPairs distinctPairsWith :: (a -> a -> b) -> [[a]] -> [[b]]-distinctPairsWith f = concatT . choicesWith (\e -> mapT (f e))+distinctPairsWith f = concatT . choicesWith (\e -> mapT (f e)) -- | Takes as argument tiers of element values; -- returns tiers of unordered pairs where, in enumeration order,@@ -207,13 +208,13 @@ -- -- > distinctPairs xss = xss >< xss `suchThat` uncurry (<=) unorderedPairs :: [[a]] -> [[(a,a)]]-unorderedPairs = unorderedPairsWith (,)+unorderedPairs = unorderedPairsWith (,) -- | 'unorderedPairs' by a given function: ----- > unorderedPairsWith f = mapT (uncurry f) . unorderedPairs+-- > unorderedPairsWith f = mapT (uncurry f) . unorderedPairs unorderedPairsWith :: (a -> a -> b) -> [[a]] -> [[b]]-unorderedPairsWith f = concatT . bagChoicesWith (\e -> mapT (f e))+unorderedPairsWith f = concatT . bagChoicesWith (\e -> mapT (f e)) -- | Takes as argument tiers of element values; -- returns tiers of unordered pairs where, in enumeration order,@@ -225,13 +226,13 @@ -- -- > distinctPairs xss = xss >< xss `suchThat` uncurry (<) unorderedDistinctPairs :: [[a]] -> [[(a,a)]]-unorderedDistinctPairs = unorderedDistinctPairsWith (,)+unorderedDistinctPairs = unorderedDistinctPairsWith (,) -- | 'unorderedPairs' by a given function: ----- > unorderedDistinctPairsWith f = mapT (uncurry f) . unorderedDistinctPairs+-- > unorderedDistinctPairsWith f = mapT (uncurry f) . unorderedDistinctPairs unorderedDistinctPairsWith :: (a -> a -> b) -> [[a]] -> [[b]]-unorderedDistinctPairsWith f = concatT . setChoicesWith (\e -> mapT (f e))+unorderedDistinctPairsWith f = concatT . setChoicesWith (\e -> mapT (f e)) -- | Takes as argument tiers of element values; -- returns tiers of lists of elements.@@ -252,8 +253,8 @@ -- > , ... -- > ] listsOf :: [[a]] -> [[[a]]]-listsOf xss = cons0 []- \/ delay (productWith (:) xss (listsOf xss))+listsOf xss = cons0 []+ \/ delay (productWith (:) xss (listsOf xss)) -- | Takes the product of N lists of tiers, producing lists of length N. --@@ -265,19 +266,19 @@ -- > products [xss,yss] = mapT (\(x,y) -> [x,y]) (xss >< yss) -- > products [xss,yss,zss] = product3With (\x y z -> [x,y,z]) xss yss zss products :: [ [[a]] ] -> [[ [a] ]]-products = foldr (productWith (:)) [[[]]]+products = foldr (productWith (:)) [[[]]] -- | Delete the first occurence of an element in a tier. -- -- For normalized lists-of-tiers without repetitions, the following holds: ----- > deleteT x = normalizeT . (`suchThat` (/= x))+-- > deleteT x = normalizeT . (`suchThat` (/= x)) deleteT :: Eq a => a -> [[a]] -> [[a]]-deleteT _ [] = []-deleteT y ([]:xss) = [] : deleteT y xss-deleteT y [[x]] | x == y = []-deleteT y ((x:xs):xss) | x == y = xs:xss- | otherwise = [[x]] \/ deleteT y (xs:xss)+deleteT _ [] = []+deleteT y ([]:xss) = [] : deleteT y xss+deleteT y [[x]] | x == y = []+deleteT y ((x:xs):xss) | x == y = xs:xss+ | otherwise = [[x]] \/ deleteT y (xs:xss) -- | Normalizes tiers by removing up to 12 empty tiers from the end of a list -- of tiers.@@ -288,57 +289,57 @@ -- The arbitrary limit of 12 tiers is necessary as this function would loop if -- there is an infinite trail of empty tiers. normalizeT :: [[a]] -> [[a]]-normalizeT [] = []-normalizeT [[]] = []-normalizeT [[],[]] = []-normalizeT [[],[],[]] = []-normalizeT [[],[],[],[]] = []-normalizeT [[],[],[],[], []] = []-normalizeT [[],[],[],[], [],[]] = []-normalizeT [[],[],[],[], [],[],[]] = []-normalizeT [[],[],[],[], [],[],[],[]] = []-normalizeT [[],[],[],[], [],[],[],[], []] = []-normalizeT [[],[],[],[], [],[],[],[], [],[]] = []-normalizeT [[],[],[],[], [],[],[],[], [],[],[]] = []-normalizeT [[],[],[],[], [],[],[],[], [],[],[],[]] = []-normalizeT (xs:xss) = xs:normalizeT xss+normalizeT [] = []+normalizeT [[]] = []+normalizeT [[],[]] = []+normalizeT [[],[],[]] = []+normalizeT [[],[],[],[]] = []+normalizeT [[],[],[],[], []] = []+normalizeT [[],[],[],[], [],[]] = []+normalizeT [[],[],[],[], [],[],[]] = []+normalizeT [[],[],[],[], [],[],[],[]] = []+normalizeT [[],[],[],[], [],[],[],[], []] = []+normalizeT [[],[],[],[], [],[],[],[], [],[]] = []+normalizeT [[],[],[],[], [],[],[],[], [],[],[]] = []+normalizeT [[],[],[],[], [],[],[],[], [],[],[],[]] = []+normalizeT (xs:xss) = xs:normalizeT xss -- | Concatenate tiers of maybes catMaybesT :: [[Maybe a]] -> [[a]]-catMaybesT = map catMaybes+catMaybesT = map catMaybes -- | Like 'Data.Maybe.mapMaybe' but for tiers. mapMaybeT :: (a -> Maybe b) -> [[a]] -> [[b]]-mapMaybeT f = catMaybesT . mapT f+mapMaybeT f = catMaybesT . mapT f -- | Discard elements _not_ matching a predicate. ----- > discardT odd [[1],[2,3],[4]] = [[],[2],[4]]+-- > discardT odd [[1],[2,3],[4]] = [[],[2],[4]] discardT :: (a -> Bool) -> [[a]] -> [[a]]-discardT p = filterT (not . p)+discardT p = filterT (not . p) -- | Discard later elements maching a binary predicate -- (in relation to an earlier element). ----- > discardLaterT (>) [[0],[1],[-1],[2],[-2],...] = [[0],[],[-1],[],[-2],...]--- > discardLaterT (==) [[0],[0,1],[0,1,2],[0,1,2,3],...] = [[0],[1],[2],[3]]+-- > discardLaterT (>) [[0],[1],[-1],[2],[-2],...] = [[0],[],[-1],[],[-2],...]+-- > discardLaterT (==) [[0],[0,1],[0,1,2],[0,1,2,3],...] = [[0],[1],[2],[3]] -- -- This function is quite innefficient, use with care. -- Consuming the n-th element takes @O(n^2)@ operations. discardLaterT :: (a -> a -> Bool) -> [[a]] -> [[a]]-discardLaterT d [] = []-discardLaterT d ([]:xss) = [] : discardLaterT d xss-discardLaterT d ((x:xs):xss) = [[x]]- \/ discardLaterT d (discardT (`d` x) (xs:xss))+discardLaterT d [] = []+discardLaterT d ([]:xss) = [] : discardLaterT d xss+discardLaterT d ((x:xs):xss) = [[x]]+ \/ discardLaterT d (discardT (`d` x) (xs:xss)) -- | Removes repetitions from tiers. ----- > nubT [[0],[0,1],[0,1,2],[0,1,2,3],...] = [[0],[1],[2],[3],...]--- > nubT [[0],[-1,0,1],[-2,-1,0,1,2],...] = [[0],[-1,1],[-2,2],...]+-- > nubT [[0],[0,1],[0,1,2],[0,1,2,3],...] = [[0],[1],[2],[3],...]+-- > nubT [[0],[-1,0,1],[-2,-1,0,1,2],...] = [[0],[-1,1],[-2,2],...] -- -- Consuming the n-th element takes @O(n^2)@ operations. nubT :: Ord a => [[a]] -> [[a]]-nubT = discardLaterT (==)+nubT = discardLaterT (==) -- | Takes as argument tiers of element values; -- returns tiers of lists with no repeated elements.@@ -368,7 +369,7 @@ -- > , ... -- > ] bagsOf :: [[a]] -> [[[a]]]-bagsOf = ([[]]:) . concatT . bagChoicesWith (\x xss -> mapT (x:) (bagsOf xss))+bagsOf = ([[]]:) . concatT . bagChoicesWith (\x xss -> mapT (x:) (bagsOf xss)) -- | Takes as argument tiers of element values;@@ -389,18 +390,18 @@ -- For 'Data.Set.Set' (from "Data.Set"), we would have: -- -- > instance Listable a => Listable (Set a) where--- > tiers = mapT fromList $ setsOf tiers+-- > tiers = mapT fromList $ setsOf tiers setsOf :: [[a]] -> [[[a]]]-setsOf = ([[]]:) . concatT . setChoicesWith (\x xss -> mapT (x:) (setsOf xss))+setsOf = ([[]]:) . concatT . setChoicesWith (\x xss -> mapT (x:) (setsOf xss)) -- | Takes as arguments tiers of source and target values; -- returns tiers of maps from the source to the target encoded as lists -- without repetition. maps :: [[a]] -> [[b]] -> [[[(a,b)]]]-maps xss yss = concatMapT mapsFor (setsOf xss)+maps xss yss = concatMapT mapsFor (setsOf xss) where --mapsFor :: [a] -> [[ [(a,b)] ]]- mapsFor xs = zip xs `mapT` products (const yss `map` xs)+ mapsFor xs = zip xs `mapT` products (const yss `map` xs) -- | Lists tiers of choices. -- Choices are pairs of values and tiers excluding that value.@@ -413,15 +414,15 @@ -- -- Each choice is sized by the extracted element. choices :: [[a]] -> [[(a,[[a]])]]-choices = choicesWith (,)+choices = choicesWith (,) -- | Like 'choices', but allows a custom function. choicesWith :: (a -> [[a]] -> b) -> [[a]] -> [[b]]-choicesWith f [] = []-choicesWith f [[]] = []-choicesWith f ([]:xss) = [] : choicesWith (\y yss -> f y ([]:normalizeT yss)) xss-choicesWith f ((x:xs):xss) = [[f x (xs:xss)]]- \/ choicesWith (\y (ys:yss) -> f y ((x:ys):yss)) (xs:xss)+choicesWith f [] = []+choicesWith f [[]] = []+choicesWith f ([]:xss) = [] : choicesWith (\y yss -> f y ([]:normalizeT yss)) xss+choicesWith f ((x:xs):xss) = [[f x (xs:xss)]]+ \/ choicesWith (\y (ys:yss) -> f y ((x:ys):yss)) (xs:xss) -- | Like 'choices' but lists tiers of non-decreasing (ascending) choices. -- Used to construct 'bagsOf' values.@@ -437,15 +438,15 @@ -- > , ... -- > ] bagChoices :: [[a]] -> [[(a,[[a]])]]-bagChoices = bagChoicesWith (,)+bagChoices = bagChoicesWith (,) -- | Like 'bagChoices' but customized by a function. bagChoicesWith :: (a -> [[a]] -> b) -> [[a]] -> [[b]]-bagChoicesWith f [] = []-bagChoicesWith f [[]] = []-bagChoicesWith f ([]:xss) = [] : bagChoicesWith (\y yss -> f y ([]:yss)) xss-bagChoicesWith f ((x:xs):xss) = [[f x ((x:xs):xss)]]- \/ bagChoicesWith f (xs:xss)+bagChoicesWith f [] = []+bagChoicesWith f [[]] = []+bagChoicesWith f ([]:xss) = [] : bagChoicesWith (\y yss -> f y ([]:yss)) xss+bagChoicesWith f ((x:xs):xss) = [[f x ((x:xs):xss)]]+ \/ bagChoicesWith f (xs:xss) -- | Like 'choices' but lists tiers of strictly ascending choices. -- Used to construct 'setsOf' values.@@ -457,15 +458,15 @@ -- > , [(3,[[],[],[]])] -- > ] setChoices :: [[a]] -> [[(a,[[a]])]]-setChoices = setChoicesWith (,)+setChoices = setChoicesWith (,) -- | Like 'setChoices' but customized by a function. setChoicesWith :: (a -> [[a]] -> b) -> [[a]] -> [[b]]-setChoicesWith f [] = []-setChoicesWith f [[]] = []-setChoicesWith f ([]:xss) = [] : setChoicesWith (\y yss -> f y ([]:normalizeT yss)) xss-setChoicesWith f ((x:xs):xss) = [[f x (xs:xss)]]- \/ setChoicesWith f (xs:xss)+setChoicesWith f [] = []+setChoicesWith f [[]] = []+setChoicesWith f ([]:xss) = [] : setChoicesWith (\y yss -> f y ([]:normalizeT yss)) xss+setChoicesWith f ((x:xs):xss) = [[f x (xs:xss)]]+ \/ setChoicesWith f (xs:xss) -- | Takes as argument an integer length and tiers of element values; -- returns tiers of lists of element values of the given length.@@ -477,7 +478,7 @@ -- > , ... -- > ] listsOfLength :: Int -> [[a]] -> [[[a]]]-listsOfLength n xss = products (replicate n xss)+listsOfLength n xss = products (replicate n xss) @@ -487,36 +488,36 @@ -- | Shows a list of strings, one element per line. -- The returned string _does not_ end with a line break. ----- > listLines [] = "[]"--- > listLines ["0"] = "[0]"--- > listLines ["0","1"] = "[ 0\n\--- > \, 1\n\--- > \]"+-- > listLines [] = "[]"+-- > listLines ["0"] = "[0]"+-- > listLines ["0","1"] = "[ 0\n\+-- > \, 1\n\+-- > \]" listLines :: [String] -> String-listLines [] = "[]"-listLines [s] | '\n' `notElem` s = "[" ++ s ++ "]"-listLines ss = (++ "]")+listLines [] = "[]"+listLines [s] | '\n' `notElem` s = "[" ++ s ++ "]"+listLines ss = (++ "]") . unlines . zipWith beside (["[ "] ++ repeat ", ") $ ss where beside :: String -> String -> String- beside s = init- . unlines- . zipWith (++) ([s] ++ repeat (replicate (length s) ' '))- . lines+ beside s = init+ . unlines+ . zipWith (++) ([s] ++ repeat (replicate (length s) ' '))+ . lines -- | Shows a list, one element per line. -- The returned string _does not_ end with a line break. ----- > listLines [] = "[]"--- > listLines [0] = "[0]"--- > listLines [0,1] = "[ 0\n\--- > \, 1\n\--- > \]"+-- > listLines [] = "[]"+-- > listLines [0] = "[0]"+-- > listLines [0,1] = "[ 0\n\+-- > \, 1\n\+-- > \]" showListLines :: Show a => [a] -> String-showListLines = listLines . map show+showListLines = listLines . map show -- | Shows a list of strings, adding @...@ to the end when longer than given -- length.@@ -525,14 +526,14 @@ -- > dotsLongerThan 3 ["1","2","3","4"] = [1,2,3,...] -- > dotsLongerThan 5 $ map show [1..] = [1,2,3,4,5,...] dotsLongerThan :: Int -> [String] -> [String]-dotsLongerThan n xs = take n xs ++ ["..." | not . null $ drop n xs]+dotsLongerThan n xs = take n xs ++ ["..." | not . null $ drop n xs] -- | Alternative to 'show' for 'tiers' with one element per line. -- (useful for debugging, see also 'printTiers'). -- -- This function can be useful when debugging your 'Listable' instances. showTiers :: Show a => Int -> [[a]] -> String-showTiers n = listLines . dotsLongerThan n . map showListLines+showTiers n = listLines . dotsLongerThan n . map showListLines -- | Alternative to 'print' for 'tiers' with one element per line. -- (useful for debugging, see also 'showTiers').@@ -551,7 +552,7 @@ -- -- This function can be useful when debugging your 'Listable' instances. printTiers :: Show a => Int -> [[a]] -> IO ()-printTiers n = putStrLn . showTiers n+printTiers n = putStrLn . showTiers n -- | Checks if a list-of-tiers is finite. --@@ -559,7 +560,7 @@ -- finite if it has less than 13 values. This function may give -- false negatives. finite :: [[a]] -> Bool-finite = null . drop 12 . concat . take 60+finite = null . drop 12 . concat . take 60 -- NOTE: `take 60` is there because otherwise this function would not -- terminate in a tier-of-lists with an infinite tail of empty tiers, like: -- > import Test.LeanCheck.Function.ListsOfPairs
stack.yaml view
@@ -1,15 +1,4 @@-# stack.yaml docs:-# https://docs.haskellstack.org/en/stable/yaml_configuration/--# resolver: nightly-2015-09-21-# resolver: ghc-7.10.2-resolver: lts-13.6+resolver: lts-15.5 # or ghc-8.8.3 packages: - .--extra-deps: []--flags: {}--extra-package-dbs: []
test/Test.hs view
@@ -11,6 +11,8 @@ module Test ( module Test.LeanCheck + , getMaxTestsFromArgs+ , tNatPairOrd , tNatTripleOrd , tNatQuadrupleOrd@@ -35,7 +37,21 @@ import Test.LeanCheck import Data.List import Data.Ord+import Data.Maybe+import System.Environment import Test.LeanCheck.Utils.Types (Nat(..))++readMaybe :: Read a => String -> Maybe a+readMaybe s = case readsPrec 0 s of+ [(x,"")] -> Just x+ _ -> Nothing++getMaxTestsFromArgs :: Int -> IO Int+getMaxTestsFromArgs n = do+ as <- getArgs+ return $ case as of+ (s:_) -> fromMaybe n $ readMaybe s+ _ -> n -- | check if a list is ordered ordered :: Ord a => [a] -> Bool
test/derive.hs view
@@ -75,13 +75,15 @@ deriveListableIfNeeded ''Either main :: IO ()-main =- case elemIndices False (tests 100) of+main = do+ max <- getMaxTestsFromArgs 200+ case elemIndices False (tests max) of [] -> putStrLn "Tests passed!" is -> do putStrLn ("Failed tests:" ++ show is) exitFailure -tests n =+tests :: Int -> [Bool]+tests n = [ True , map unD0 list =| n |= list
test/error.hs view
@@ -1,7 +1,7 @@ -- Copyright (c) 2015-2020 Rudy Matela. -- Distributed under the 3-Clause BSD licence (see the file LICENSE). {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}-import Test ()+import Test (getMaxTestsFromArgs) import System.Exit (exitFailure) import Data.List (elemIndices,sort)@@ -10,13 +10,15 @@ import Test.LeanCheck.Utils.Types (Nat) main :: IO ()-main =- case elemIndices False (tests 100) of+main = do+ max <- getMaxTestsFromArgs 200+ case elemIndices False (tests max) of [] -> putStrLn "Tests passed!" is -> do putStrLn ("Failed tests:" ++ show is) exitFailure -tests n =+tests :: Int -> [Bool]+tests n = [ True , not $ holds n prop_sortMinE
test/fun.hs view
@@ -7,14 +7,15 @@ import Test.LeanCheck.Function () main :: IO ()-main =- case elemIndices False (tests 200) of+main = do+ max <- getMaxTestsFromArgs 200+ case elemIndices False (tests max) of [] -> putStrLn "Tests passed!" is -> do putStrLn ("Failed tests:" ++ show is) exitFailure tests :: Int -> [Bool]-tests n =+tests n = [ True , fails n prop_foldlr , holds n prop_foldlr'@@ -23,7 +24,7 @@ , fails n prop_false' ] -type A = Int+type A = Int prop_foldlr :: (A -> A -> A) -> A -> [A] -> Bool prop_foldlr f z xs = foldr f z xs == foldl f z xs
test/funshow.hs view
@@ -1,6 +1,7 @@ -- Copyright (c) 2015-2020 Rudy Matela. -- Distributed under the 3-Clause BSD licence (see the file LICENSE). {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+import Test (getMaxTestsFromArgs) import System.Exit (exitFailure) import Data.List (elemIndices,sort) import Test.LeanCheck.Function.ShowFunction@@ -8,14 +9,15 @@ import Test.LeanCheck.Utils.TypeBinding main :: IO ()-main =- case elemIndices False tests of+main = do+ max <- getMaxTestsFromArgs 200+ case elemIndices False (tests max) of [] -> putStrLn "Tests passed!" is -> do putStrLn ("Failed tests:" ++ show is) exitFailure -tests :: [Bool]-tests =+tests :: Int -> [Bool]+tests _ = [ True -- undefined values --
test/generic.hs view
@@ -49,12 +49,14 @@ main :: IO ()-main =- case elemIndices False (tests 100) of+main = do+ max <- getMaxTestsFromArgs 200+ case elemIndices False (tests max) of [] -> putStrLn "Tests passed!" is -> do putStrLn ("Failed tests:" ++ show is) exitFailure +tests :: Int -> [Bool] tests n = [ True
test/io.hs view
@@ -3,7 +3,7 @@ import Test main :: IO ()-main = do+main = do check $ \x -> (x::Int) + x == 2*x -- should pass --check $ \x -> (x::Int) + x == x -- should fail, falsifiable --check $ \x -> (x::Int) `div` x == 1 -- should fail, exception
test/main.hs view
@@ -14,85 +14,86 @@ import Data.Word main :: IO ()-main =- case elemIndices False tests of+main = do+ max <- getMaxTestsFromArgs 200+ case elemIndices False (tests max) of [] -> putStrLn "Tests passed!" is -> do putStrLn ("Failed tests:" ++ show is) exitFailure -tests :: [Bool]-tests =+tests :: Int -> [Bool]+tests n = [ True -- interleave , [1,2,3] +| [0,0,0] == [1,0,2,0,3,0] , take 3 ([1,2] +| (0:undefined)) == [1,0,2]- , [0,2..] +| [1,3..] =| 100 |= [0,1..]+ , [0,2..] +| [1,3..] =| n |= [0,1..] -- etc- , tNatPairOrd 100- , tNatTripleOrd 200- , tNatQuadrupleOrd 300- , tNatQuintupleOrd 400- , tNatListOrd 500- , tListsOfNatOrd 500+ , tNatPairOrd n+ , tNatTripleOrd n+ , tNatQuadrupleOrd n+ , tNatQuintupleOrd n+ , tNatListOrd n+ , tListsOfNatOrd n , listsOf (tiers::[[Nat]]) =| 10 |= tiers -- tests!- , counterExample 10 (\x y -> x + y /= (x::Int)) == Just ["0", "0"]- , counterExample 10 (\x y -> x + y == (x::Int)) == Just ["0", "1"]- , counterExample 10 (maybe True (==(0::Int))) == Just ["(Just 1)"]- , holds 100 (\x -> x == (x::Int))+ , counterExample n (\x y -> x + y /= (x::Int)) == Just ["0", "0"]+ , counterExample n (\x y -> x + y == (x::Int)) == Just ["0", "1"]+ , counterExample n (maybe True (==(0::Int))) == Just ["(Just 1)"]+ , holds n (\x -> x == (x::Int)) -- For when NaN is in the enumeration (by default, it is not): --, fails 100 (\x -> x == (x::Float)) -- NaN != NaN :-) --, counterExample 100 (\x -> x == (x::Float)) == Just ["NaN"]- , counterExample 10 (\x y -> x + y == (x::Float)) == Just ["0.0","1.0"]- , counterExample 10 (\x y -> x + y == (x::Double)) == Just ["0.0","1.0"]- , holds 50 (\x -> x + 1 /= (x::Int))- , counterExample 50 (\x -> x + 1 /= (x::Float)) == Just ["Infinity"]- || counterExample 50 (\x -> x + 1 /= (x::Float)) == Just ["inf"] -- bug on Hugs 2006-09?- , counterExample 50 (\x -> x + 1 /= (x::Double)) == Just ["Infinity"]- || counterExample 50 (\x -> x + 1 /= (x::Float)) == Just ["inf"] -- bug on Hugs 2006-09?- , allUnique (take 100 list :: [Float])- , allUnique (take 500 list :: [Double])+ , counterExample n (\x y -> x + y == (x::Float)) == Just ["0.0","1.0"]+ , counterExample n (\x y -> x + y == (x::Double)) == Just ["0.0","1.0"]+ , holds n (\x -> x + 1 /= (x::Int))+ , counterExample n (\x -> x + 1 /= (x::Float)) == Just ["Infinity"]+ || counterExample n (\x -> x + 1 /= (x::Float)) == Just ["inf"] -- bug on Hugs 2006-09?+ , counterExample n (\x -> x + 1 /= (x::Double)) == Just ["Infinity"]+ || counterExample n (\x -> x + 1 /= (x::Float)) == Just ["inf"] -- bug on Hugs 2006-09?+ , allUnique (take n list :: [Float])+ , allUnique (take n list :: [Double]) - , allUnique (take 500 list :: [Rational])- , allUnique (take 100 list :: [Ratio Nat])- , orderedOn (\r -> numerator r + denominator r) (take 500 (list :: [Ratio Nat]))- , orderedOn (\r -> abs (numerator r) + abs(denominator r)) (take 500 (list :: [Rational]))+ , allUnique (take n list :: [Rational])+ , allUnique (take n list :: [Ratio Nat])+ , orderedOn (\r -> numerator r + denominator r) (take n (list :: [Ratio Nat]))+ , orderedOn (\r -> abs (numerator r) + abs(denominator r)) (take n (list :: [Rational])) , list == [LT, EQ, GT]- , orderedOn length (take 500 (list :: [[Ordering]]))- , orderedOn length (take 500 (list :: [[Bool]]))+ , orderedOn length (take n (list :: [[Ordering]]))+ , orderedOn length (take n (list :: [[Bool]])) - , strictlyOrderedOn (\xs -> (sum $ map (+1) xs, xs)) (take 500 (list :: [[Word]]))+ , strictlyOrderedOn (\xs -> (sum $ map (+1) xs, xs)) (take n (list :: [[Word]])) - , tPairEqParams 100- , tTripleEqParams 100+ , tPairEqParams n+ , tTripleEqParams n , tProductsIsFilterByLength (tiers :: [[ Nat ]]) 10 `all` [1..10] , tProductsIsFilterByLength (tiers :: [[ Bool ]]) 6 `all` [1..10] , tProductsIsFilterByLength (tiers :: [[ [Nat] ]]) 6 `all` [1..10] - , holds 100 $ (\/) ==== zipWith' (++) [] [] -:> [[uint2]]- , holds 100 $ (\/) ==== zipWith' (++) [] [] -:> [[bool]]- , holds 100 $ (\\//) ==== zipWith' (+|) [] [] -:> [[uint2]]- , holds 100 $ (\\//) ==== zipWith' (+|) [] [] -:> [[bool]]+ , holds n $ (\/) ==== zipWith' (++) [] [] -:> [[uint2]]+ , holds n $ (\/) ==== zipWith' (++) [] [] -:> [[bool]]+ , holds n $ (\\//) ==== zipWith' (+|) [] [] -:> [[uint2]]+ , holds n $ (\\//) ==== zipWith' (+|) [] [] -:> [[bool]] - , holds 100 $ \x -> x == (x :: Word)- , holds 100 $ \x -> x == (x :: Word8)- , holds 100 $ \x -> x == (x :: Word16)- , holds 100 $ \x -> x == (x :: Word32)- , holds 100 $ \x -> x == (x :: Word64)+ , holds n $ \x -> x == (x :: Word)+ , holds n $ \x -> x == (x :: Word8)+ , holds n $ \x -> x == (x :: Word16)+ , holds n $ \x -> x == (x :: Word32)+ , holds n $ \x -> x == (x :: Word64) - , holds 100 $ \x -> x == (x :: Int)- , holds 100 $ \x -> x == (x :: Int8)- , holds 100 $ \x -> x == (x :: Int16)- , holds 100 $ \x -> x == (x :: Int32)- , holds 100 $ \x -> x == (x :: Int64)+ , holds n $ \x -> x == (x :: Int)+ , holds n $ \x -> x == (x :: Int8)+ , holds n $ \x -> x == (x :: Int16)+ , holds n $ \x -> x == (x :: Int32)+ , holds n $ \x -> x == (x :: Int64) - , holds 100 $ \x -> x == (x :: Complex Double)+ , holds n $ \x -> x == (x :: Complex Double) ] allUnique :: Ord a => [a] -> Bool
test/operators.hs view
@@ -11,8 +11,9 @@ import Data.Function (on) main :: IO ()-main =- case elemIndices False (tests 100) of+main = do+ max <- getMaxTestsFromArgs 200+ case elemIndices False (tests max) of [] -> putStrLn "Tests passed!" is -> do putStrLn ("Failed tests:" ++ show is) exitFailure@@ -107,7 +108,7 @@ , holds n $ okEqOrd -:> int , holds n $ okEqOrd -:> char , holds n $ okEqOrd -:> bool- , holds n $ okEqOrd -:> [()]+ , holds m $ okEqOrd -:> [()] , holds n $ okEqOrd -:> [int] , holds n $ okEqOrd -:> [bool] , holds n $ okEqOrd -:> float -- fails if NaN is included in enumeration@@ -134,7 +135,7 @@ , holds n $ isIdentity id -:> int , holds n $ isIdentity (+0) -:> int- , holds n $ isIdentity sort -:> [()]+ , holds m $ isIdentity sort -:> [()] , holds n $ isIdentity (not . not) , fails n $ isIdentity not @@ -142,6 +143,8 @@ , fails n $ isNeverIdentity abs -:> int , fails n $ isNeverIdentity negate -:> int ]+ where+ m = 200 --none :: (a -> Bool) -> [a] -> Bool --none p = not . or . map p
test/sdist view
@@ -4,22 +4,37 @@ # # Copyright (c) 2015-2020 Rudy Matela. # Distributed under the 3-Clause BSD licence.++set -xe+ export LC_ALL=C # consistent sort+ pkgver=` cat *.cabal | grep "^version:" | sed -e "s/version: *//"` pkgname=`cat *.cabal | grep "^name:" | sed -e "s/name: *//"` pkgbase=$pkgname-$pkgver-set -xe-cabal sdist &&++cabal sdist++# Try to find the package generated by cabal. pkg=`find dist* -name $pkgbase.tar.gz`+[ -f "$pkg" ]+# If the script fails here, either:+# * no package was generated+# * there are packages in both dist and dist-newstyle folders.+ tmp=`mktemp -d /tmp/test-sdist-XXXXXXXXXX`-tar -tf $pkg | sort --ignore-case > $tmp/ls-cabal-i &&-tar -tf $pkg | sort --ignore-case --unique > $tmp/ls-cabal-iu &&-diff -rud $tmp/ls-cabal-i $tmp/ls-cabal-iu &&++# Test if our file is compatible with case-insensitive filesystems.+tar -tf $pkg | sort --ignore-case > $tmp/ls-cabal-i+tar -tf $pkg | sort --ignore-case --unique > $tmp/ls-cabal-iu+diff -rud $tmp/ls-cabal-i $tmp/ls-cabal-iu+ if [ -d .git ] then- # on git repo, test if files are the same- git ls-files | sort > $tmp/ls-git &&- tar -tf $pkg | grep -v "/$" | sed -e "s,$pkgbase/,," | sort > $tmp/ls-cabal &&+ # Test if files included by cabal are the same as files tracked in git.+ git ls-files | sort > $tmp/ls-git+ tar -tf $pkg | grep -v "/$" | sed -e "s,$pkgbase/,," | sort > $tmp/ls-cabal diff -rud $tmp/ls-git $tmp/ls-cabal fi+ rm -r $tmp
test/stats.hs view
@@ -41,8 +41,8 @@ putStrLn "take 1 :: [Int] -> [Int]" classStatsT 6 (take 1 :: [Int] -> [Int]) -- case elemIndices False (tests 100) of+ max <- getMaxTestsFromArgs 200+ case elemIndices False (tests max) of [] -> putStrLn "Tests passed!" is -> do putStrLn ("Failed tests:" ++ show is) exitFailure
test/tiers.hs view
@@ -11,13 +11,15 @@ import Test.LeanCheck.Tiers main :: IO ()-main =- case elemIndices False tests of+main = do+ max <- getMaxTestsFromArgs 200+ case elemIndices False (tests max) of [] -> putStrLn "Tests passed!" is -> do putStrLn ("Failed tests:" ++ show is) exitFailure -tests =+tests :: Int -> [Bool]+tests n = [ True , checkNoDup 12@@ -29,17 +31,17 @@ , checkLengthListingsOfLength 5 5 , checkSizesListingsOfLength 5 5 - , all (uncurry (/=)) . concat . take 100 $ distinctPairs (tiers :: [[Nat]])+ , all (uncurry (/=)) . concat . take 200 $ distinctPairs (tiers :: [[Nat]]) , productMaybeWith ($) [[const Nothing, Just]] [[1],[2],[3],[4]] == [[1],[2],[3],[4]] , productMaybeWith (flip ($)) [[1],[2],[3],[4]] [[const Nothing],[Just]] == [[],[1],[2],[3],[4]] - , holds 100 $ deleteT_is_map_delete 10 -:> nat- , holds 100 $ deleteT_is_map_delete 10 -:> int- , holds 100 $ deleteT_is_map_delete 10 -:> bool- , holds 100 $ deleteT_is_map_delete 10 -:> int2+ , holds n $ deleteT_is_map_delete 10 -:> nat+ , holds n $ deleteT_is_map_delete 10 -:> int+ , holds n $ deleteT_is_map_delete 10 -:> bool+ , holds n $ deleteT_is_map_delete 10 -:> int2 , finite (tiers :: [[ Bool ]]) == True , finite (tiers :: [[ (Bool,Bool) ]]) == True@@ -64,11 +66,11 @@ , finite (tiers :: [[ (Bool,Bool,Bool,Bool,Bool) ]]) == False , finite (tiers :: [[ (Bool,Bool,Bool,Bool,Bool,Bool) ]]) == False - , holds 100 $ \xss -> ordered . concat $ discardLaterT (<) (xss::[[Int]])- , holds 100 $ \xss -> ordered . concat $ discardLaterT (<=) (xss::[[Int]])+ , holds n $ \xss -> ordered . concat $ discardLaterT (<) (xss::[[Int]])+ , holds n $ \xss -> ordered . concat $ discardLaterT (<=) (xss::[[Int]]) , (length . concat $ discardLaterT (<=) [[1..100]]) == 100 , (length . concat $ discardLaterT (<=) [[00..99],[100..199::Int]]) == 200- , holds 100 $ \xss -> nub (concat xss) == concat (nubT xss :: [[Int]])+ , holds n $ \xss -> nub (concat xss) == concat (nubT xss :: [[Int]]) ] deleteT_is_map_delete :: (Eq a, Listable a) => Int -> a -> Bool
test/types.hs view
@@ -10,8 +10,9 @@ import Data.Char hiding (Space) main :: IO ()-main =- case elemIndices False tests of+main = do+ max <- getMaxTestsFromArgs 200+ case elemIndices False (tests max) of [] -> putStrLn "Tests passed!" is -> do putStrLn ("Failed tests:" ++ show is) exitFailure@@ -23,8 +24,8 @@ signedRange n = map fromIntegral [-(2^(n-1))..(2^(n-1))-1] unsignedRange n = map fromIntegral [0..(2^n)-1] --tests =+tests :: Int -> [Bool]+tests n = [ True , list `permutation` [minBound..maxBound :: Int1]@@ -103,35 +104,35 @@ -- abs minBound == minBound- , fails 100 (\i -> abs i > (0::Int1))- , fails 100 (\i -> abs i > (0::Int2))- , fails 100 (\i -> abs i > (0::Int3))- , fails 100 (\i -> abs i > (0::Int4))+ , fails n (\i -> abs i > (0::Int1))+ , fails n (\i -> abs i > (0::Int2))+ , fails n (\i -> abs i > (0::Int3))+ , fails n (\i -> abs i > (0::Int4)) -- maxBound + 1 == minBound- , fails 100 (\i -> i + 1 < (i::Int1))- , fails 100 (\i -> i + 1 < (i::Int2))- , fails 100 (\i -> i + 1 < (i::Int3))- , fails 100 (\i -> i + 1 < (i::Int4))+ , fails n (\i -> i + 1 < (i::Int1))+ , fails n (\i -> i + 1 < (i::Int2))+ , fails n (\i -> i + 1 < (i::Int3))+ , fails n (\i -> i + 1 < (i::Int4)) - , holds 100 (\(Nat n) -> n >= 0)- , holds 100 (\(Natural n) -> n >= 0)+ , holds n (\(Nat n) -> n >= 0)+ , holds n (\(Natural n) -> n >= 0) - , holds 100 $ \(Space c) -> isSpace c- , holds 100 $ \(Lower c) -> isLower c- , holds 100 $ \(Upper c) -> isUpper c- , holds 100 $ \(Alpha c) -> isAlpha c- , holds 100 $ \(Digit c) -> isDigit c- , holds 100 $ \(AlphaNum c) -> isAlphaNum c- , holds 100 $ \(Letter c) -> isLetter c+ , holds n $ \(Space c) -> isSpace c+ , holds n $ \(Lower c) -> isLower c+ , holds n $ \(Upper c) -> isUpper c+ , holds n $ \(Alpha c) -> isAlpha c+ , holds n $ \(Digit c) -> isDigit c+ , holds n $ \(AlphaNum c) -> isAlphaNum c+ , holds n $ \(Letter c) -> isLetter c - , holds 100 $ \(Spaces s) -> all isSpace s- , holds 100 $ \(Lowers s) -> all isLower s- , holds 100 $ \(Uppers s) -> all isUpper s- , holds 100 $ \(Alphas s) -> all isAlpha s- , holds 100 $ \(Digits s) -> all isDigit s- , holds 100 $ \(AlphaNums s) -> all isAlphaNum s- , holds 100 $ \(Letters s) -> all isLetter s+ , holds n $ \(Spaces s) -> all isSpace s+ , holds n $ \(Lowers s) -> all isLower s+ , holds n $ \(Uppers s) -> all isUpper s+ , holds n $ \(Alphas s) -> all isAlpha s+ , holds n $ \(Digits s) -> all isDigit s+ , holds n $ \(AlphaNums s) -> all isAlphaNum s+ , holds n $ \(Letters s) -> all isLetter s ] where unXs (Xs xs) = xs