diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -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 @@ -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]}} diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 - diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 ------------------------------- diff --git a/TODO.md b/TODO.md --- a/TODO.md +++ b/TODO.md @@ -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. diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 ------ diff --git a/doc/tutorial.md b/doc/tutorial.md --- a/doc/tutorial.md +++ b/doc/tutorial.md @@ -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 diff --git a/leancheck.cabal b/leancheck.cabal --- a/leancheck.cabal +++ b/leancheck.cabal @@ -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 diff --git a/mk/depend.mk b/mk/depend.mk --- a/mk/depend.mk +++ b/mk/depend.mk @@ -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: \ diff --git a/mk/haskell.mk b/mk/haskell.mk --- a/mk/haskell.mk +++ b/mk/haskell.mk @@ -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)) diff --git a/mk/install-on b/mk/install-on new file mode 100644 --- /dev/null +++ b/mk/install-on @@ -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 diff --git a/src/Test/LeanCheck.hs b/src/Test/LeanCheck.hs --- a/src/Test/LeanCheck.hs +++ b/src/Test/LeanCheck.hs @@ -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. diff --git a/src/Test/LeanCheck/Basic.hs b/src/Test/LeanCheck/Basic.hs --- a/src/Test/LeanCheck/Basic.hs +++ b/src/Test/LeanCheck/Basic.hs @@ -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 diff --git a/src/Test/LeanCheck/Core.hs b/src/Test/LeanCheck/Core.hs --- a/src/Test/LeanCheck/Core.hs +++ b/src/Test/LeanCheck/Core.hs @@ -96,10 +96,10 @@ -- -- For algebraic data types, the general form for 'tiers' is -- --- > tiers = cons ConstructorA --- > \/ cons ConstructorB --- > \/ ... --- > \/ cons ConstructorZ +-- > tiers = cons ConstructorA +-- > \/ cons ConstructorB +-- > \/ ... +-- > \/ cons 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 where +-- > tiers = ... +-- > \/ cons0 +-- > \/ ... 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 where +-- > tiers = ... +-- > \/ cons1 +-- > \/ ... 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 where +-- > tiers = ... +-- > \/ cons2 +-- > \/ ... 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 where +-- > tiers = ... +-- > \/ cons3 +-- > \/ ... 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 ) -- > \/ ... 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 ==> diff --git a/src/Test/LeanCheck/Derive.hs b/src/Test/LeanCheck/Derive.hs --- a/src/Test/LeanCheck/Derive.hs +++ b/src/Test/LeanCheck/Derive.hs @@ -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 diff --git a/src/Test/LeanCheck/Error.hs b/src/Test/LeanCheck/Error.hs --- a/src/Test/LeanCheck/Error.hs +++ b/src/Test/LeanCheck/Error.hs @@ -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) diff --git a/src/Test/LeanCheck/Generic.hs b/src/Test/LeanCheck/Generic.hs --- a/src/Test/LeanCheck/Generic.hs +++ b/src/Test/LeanCheck/Generic.hs @@ -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 diff --git a/src/Test/LeanCheck/IO.hs b/src/Test/LeanCheck/IO.hs --- a/src/Test/LeanCheck/IO.hs +++ b/src/Test/LeanCheck/IO.hs @@ -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 diff --git a/src/Test/LeanCheck/Stats.hs b/src/Test/LeanCheck/Stats.hs --- a/src/Test/LeanCheck/Stats.hs +++ b/src/Test/LeanCheck/Stats.hs @@ -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 diff --git a/src/Test/LeanCheck/Tiers.hs b/src/Test/LeanCheck/Tiers.hs --- a/src/Test/LeanCheck/Tiers.hs +++ b/src/Test/LeanCheck/Tiers.hs @@ -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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -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: [] diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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 diff --git a/test/derive.hs b/test/derive.hs --- a/test/derive.hs +++ b/test/derive.hs @@ -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 diff --git a/test/error.hs b/test/error.hs --- a/test/error.hs +++ b/test/error.hs @@ -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 diff --git a/test/fun.hs b/test/fun.hs --- a/test/fun.hs +++ b/test/fun.hs @@ -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 diff --git a/test/funshow.hs b/test/funshow.hs --- a/test/funshow.hs +++ b/test/funshow.hs @@ -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 -- diff --git a/test/generic.hs b/test/generic.hs --- a/test/generic.hs +++ b/test/generic.hs @@ -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 diff --git a/test/io.hs b/test/io.hs --- a/test/io.hs +++ b/test/io.hs @@ -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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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 diff --git a/test/operators.hs b/test/operators.hs --- a/test/operators.hs +++ b/test/operators.hs @@ -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 diff --git a/test/sdist b/test/sdist --- a/test/sdist +++ b/test/sdist @@ -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 diff --git a/test/stats.hs b/test/stats.hs --- a/test/stats.hs +++ b/test/stats.hs @@ -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 diff --git a/test/tiers.hs b/test/tiers.hs --- a/test/tiers.hs +++ b/test/tiers.hs @@ -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 diff --git a/test/types.hs b/test/types.hs --- a/test/types.hs +++ b/test/types.hs @@ -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