packages feed

leancheck 0.6.2 → 0.6.3

raw patch · 16 files changed

+595/−96 lines, 16 files

Files

TODO.md view
@@ -18,7 +18,17 @@  * (?) on leancheck.cabal, add upper bound for template-haskell package +* Show when test cases are exhausted after testing: +	> check $ \p -> p == (p :: Bool)+	+++ OK, passed 2 tests (test cases exhausted).++  Instead of just:++	> check $ \p -> p == (p :: Bool)+	+++ OK, passed 2 tests.++ documentation ------------- @@ -29,17 +39,47 @@ * on data-invariant.md, write missing section;  -v0.6.3+v0.6.4 ------ +* On `bench/tiers`, print if the enumeration has repetitions+  (import `Function.Eq` for that)++* Add `names` function to the ShowFunction typeclass that lists templates of+  names for variables of the type.+  Sadly, there is no way to do this without introducing a typeclass restriction+  on function arguments.  Make a separate `Argument` typeclass to do that?+ * add `classify` function to measure distribution of data:   something like:      classifyBy :: (a -> b) -> [a] -> [(b,a)] 	countsBy :: (a -> b) -> [a] -> [(b,Int)] +* idea for restructuring Function modules (all under `Test.LeanCheck.Function`): -v0.6.4+	Show                  -- exports just Show (a -> b)+	Listable              -- exports just Listable (a -> b), based on LoP++	Listable.ListsOfPairs -- exports just Listable (a -> b), based on LoP+	Listable.CoListable   -- exports just Listable (a -> b), based on CoL++	CoListable            -- exports just the CoListable typeclass+	ListsOfPairs          -- exports just the LoP auxiliary functions+	ShowFunction          -- exports just the ShowFunction typeclass++  This structure seems somehow more clear to me.  It also allows, in the future, adding:++	module Test.LeanCheck.Function.Listable.Mixed where+	import Test.LeanCheck.Function.CoListable   as CoL+	import Test.LeanCheck.Function.ListsOfPairs as LoP+	instance Listable (a -> b) where+	  tiers = LoP.functions tiers tiers \/ CoL.cotiers tiers++  so that the user gets an enumeration of functions with repetitions, but using+  a mixed strategy for generation of values.++v0.6.5 ------  * implement stub `Test.LeanCheck.Function.*` modules;
leancheck.cabal view
@@ -11,7 +11,7 @@ -- this cabal file too complicated.  -- Rudy  name:                leancheck-version:             0.6.2+version:             0.6.3 synopsis:            Cholesterol-free property-based testing description:   LeanCheck is a simple enumerative property-based testing library.@@ -33,7 +33,7 @@ maintainer:          Rudy Matela <rudy@matela.com.br> category:            Testing build-type:          Simple-cabal-version:       >=1.10+cabal-version:       >=1.18  extra-doc-files: README.md                , CREDITS.md@@ -50,7 +50,7 @@ source-repository this   type:            git   location:        https://github.com/rudymatela/leancheck-  tag:             v0.6.2+  tag:             v0.6.3  library   exposed-modules: Test.LeanCheck@@ -66,6 +66,7 @@                  , Test.LeanCheck.Utils.Operators                  , Test.LeanCheck.Function                  , Test.LeanCheck.Function.ListsOfPairs+                 , Test.LeanCheck.Function.FunListable                  , Test.LeanCheck.Function.CoListable                  , Test.LeanCheck.Function.Eq                  , Test.LeanCheck.Function.Periodic
src/Test/LeanCheck.hs view
@@ -73,6 +73,8 @@   , cons11   , cons12 +  , delay+  , reset   , ofWeight   , addWeight   , suchThat
src/Test/LeanCheck/Basic.hs view
@@ -12,7 +12,8 @@ --   * support for 'Listable' 6-tuples up to 12-tuples; --   * 'tiers' constructors (@consN@) with arities from 6 up to 12; --   * a 'Listable' 'Ratio' instance (consequently 'Listable' 'Rational');---   * a 'Listable' 'Word' instance.+--   * a 'Listable' 'Word' instance;+--   * the operators 'addWeight' and 'ofWeight'. -- -- "Test.LeanCheck" already exports everything from this module. -- You are probably better off importing it.@@ -29,6 +30,9 @@   , cons10   , cons11   , cons12++  , ofWeight+  , addWeight   ) where @@ -83,39 +87,39 @@  cons6 :: (Listable a, Listable b, Listable c, Listable d, Listable e, Listable f)       => (a -> b -> c -> d -> e -> f -> g) -> [[g]]-cons6 f = mapT (uncurry6 f) tiers `addWeight` 1+cons6 f = delay $ mapT (uncurry6 f) tiers  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 = mapT (uncurry7 f) tiers `addWeight` 1+cons7 f = delay $ mapT (uncurry7 f) tiers  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 = mapT (uncurry8 f) tiers `addWeight` 1+cons8 f = delay $ mapT (uncurry8 f) tiers  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 = mapT (uncurry9 f) tiers `addWeight` 1+cons9 f = delay $ mapT (uncurry9 f) tiers  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 = mapT (uncurry10 f) tiers `addWeight` 1+cons10 f = delay $ mapT (uncurry10 f) tiers  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 = mapT (uncurry11 f) tiers `addWeight` 1+cons11 f = delay $ mapT (uncurry11 f) tiers  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 = mapT (uncurry12 f) tiers `addWeight` 1+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@@ -141,9 +145,27 @@ 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  instance (Integral a, Listable a) => Listable (Ratio a) where-  tiers = mapT (uncurry (%))+  tiers = mapT (uncurry (%)) . reset         $ tiers `suchThat` (\(n,d) -> d > 0 && n `gcd` d == 1)-                `ofWeight` 0 -- make size 0 not be "usually" empty  instance Listable Word where   list = [0..]++-- | Resets the weight of a constructor (or tiers)+-- Typically used as an infix constructor when defining Listable instances:+--+-- > cons<N> `ofWeight` <W>+--+-- Be careful: do not apply @`ofWeight` 0@ to recursive data structure+-- constructors.  In general this will make the list of size 0 infinite,+-- breaking the tier invariant (each tier must be finite).+--+-- 'ofWeight' is closely related to 'reset'.+ofWeight :: [[a]] -> Int -> [[a]]+ofWeight xss w = dropWhile null xss `addWeight` w++-- | Adds to the weight of tiers of a constructor+--+-- 'addWeight' is closely related to 'delay'.+addWeight :: [[a]] -> Int -> [[a]]+addWeight xss w = replicate w [] ++ xss
src/Test/LeanCheck/Core.hs view
@@ -54,8 +54,8 @@   , cons4   , cons5 -  , ofWeight-  , addWeight+  , delay+  , reset   , suchThat    -- ** Combining lists of tiers@@ -134,6 +134,8 @@ listIntegral :: (Enum a, Num a) => [a] listIntegral = [0,-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, ...] instance Listable Int where   list = listIntegral @@ -151,17 +153,22 @@       +| ['['..'`']       +| ['{'..'~'] +-- | > tiers :: [[Bool]] = [[False,True]]+--   > list :: [[Bool]] = [False,True] instance Listable Bool where   tiers = cons0 False \/ cons0 True +-- | > tiers :: [[Maybe Int]] = [[Nothing], [Just 0], [Just 1], [Just -1], ...]+--   > tiers :: [[Maybe Bool]] = [[Nothing], [Just False, Just True]] instance Listable a => Listable (Maybe a) where   tiers = cons0 Nothing \/ cons1 Just  instance (Listable a, Listable b) => Listable (Either a b) where-  tiers = cons1 Left  `ofWeight` 0-     \\// cons1 Right `ofWeight` 0+  tiers = reset (cons1 Left)+     \\// reset (cons1 Right) --- | > 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), (-1,0), ...] instance (Listable a, Listable b) => Listable (a,b) where   tiers = tiers >< tiers @@ -179,6 +186,12 @@          Listable (a,b,c,d,e) where   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], [0,1], [1,0], [-1], ... ] instance (Listable a) => Listable [a] where   tiers = cons0 []        \/ cons2 (:)@@ -237,22 +250,22 @@ --   return 'tiers' of applications of this constructor. --   By default, returned values will have size/weight of 1. cons1 :: Listable a => (a -> b) -> [[b]]-cons1 f = mapT f tiers `addWeight` 1+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. cons2 :: (Listable a, Listable b) => (a -> b -> c) -> [[c]]-cons2 f = mapT (uncurry f) tiers `addWeight` 1+cons2 f = delay $ mapT (uncurry f) tiers  -- | Returns tiers of applications of a 3-argument constructor. cons3 :: (Listable a, Listable b, Listable c) => (a -> b -> c -> d) -> [[d]]-cons3 f = mapT (uncurry3 f) tiers `addWeight` 1+cons3 f = delay $ mapT (uncurry3 f) tiers  -- | Returns tiers of applications of a 4-argument constructor. cons4 :: (Listable a, Listable b, Listable c, Listable d)       => (a -> b -> c -> d -> e) -> [[e]]-cons4 f = mapT (uncurry4 f) tiers `addWeight` 1+cons4 f = delay $ mapT (uncurry4 f) tiers  -- | Returns tiers of applications of a 5-argument constructor. --@@ -262,22 +275,28 @@ -- but are hidden from the Haddock documentation. cons5 :: (Listable a, Listable b, Listable c, Listable d, Listable e)       => (a -> b -> c -> d -> e -> f) -> [[f]]-cons5 f = mapT (uncurry5 f) tiers `addWeight` 1+cons5 f = delay $ mapT (uncurry5 f) tiers --- | Resets the weight of a constructor (or tiers)--- Typically used as an infix constructor when defining Listable instances:+-- | Delays the enumeration of 'tiers'.+-- Conceptually this function adds to the weight of a constructor.+-- Typically used when defining 'Listable' instances: ----- > cons<N> `ofWeight` <W>+-- > delay (cons<N> <Constr>)+delay :: [[a]] -> [[a]]+delay = ([]:)++-- | Resets any delays in a list-of 'tiers'.+-- Conceptually this function makes a constructor "weightless",+-- assuring the first tier is non-empty.+-- Typically used when defining Listable instances: ----- Be careful: do not apply @`ofWeight` 0@ to recursive data structure+-- > reset (cons<N> <Constr>)+--+-- Be careful: do not apply @reset@ to recursive data structure -- constructors.  In general this will make the list of size 0 infinite,--- breaking the tier invariant (each tier must be finite).-ofWeight :: [[a]] -> Int -> [[a]]-ofWeight xss w = dropWhile null xss `addWeight` w---- | Adds to the weight of tiers of a constructor-addWeight :: [[a]] -> Int -> [[a]]-addWeight xss w = replicate w [] ++ xss+-- breaking the 'tiers' invariant (each tier must be finite).+reset :: [[a]] -> [[a]]+reset = dropWhile null  -- | Tiers of values that follow a property --@@ -344,7 +363,7 @@ productWith _ _ [] = [] productWith _ [] _ = [] productWith f (xs:xss) yss = map (xs **) yss-                          \/ productWith f xss yss `addWeight` 1+                          \/ delay (productWith f xss yss)   where xs ** ys = [x `f` y | x <- xs, y <- ys]  -- | 'Testable' values are functions@@ -378,7 +397,7 @@  -- | Lists all counter-examples for a number of tests to a property, counterExamples :: Testable a => Int -> a -> [[String]]-counterExamples n = map fst . filter (not . snd) . take n . results+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@@ -391,7 +410,7 @@  -- | Lists all witnesses up to a number of tests to a property, witnesses :: Testable a => Int -> a -> [[String]]-witnesses n = map fst . filter snd . take n . results+witnesses n p = [as | (as,True) <- take n (results p)]  -- | Up to a number of tests to a property, --   returns 'Just' the first witness
src/Test/LeanCheck/Function.hs view
@@ -28,6 +28,9 @@ -- -- Take care: all the above 'Listable' instances are __experimental__.  Only -- one of the above can be imported at a time.+--+-- Warning: this is only intended to be used in testing modules.  Avoid+-- importing this on modules that are used as libraries. module Test.LeanCheck.Function () where import Test.LeanCheck.Function.ListsOfPairs () import Test.LeanCheck.Function.Show ()
src/Test/LeanCheck/Function/CoListable.hs view
@@ -8,7 +8,8 @@ -- a simple enumerative property-based testing library. -- -- This module exports a 'Listable' instance for function enumeration by means--- of a 'CoListable' typeclass.+-- of a 'CoListable' typeclass.  This is very similar to the coseries+-- enumeration of SmallCheck. -- -- This module /does not currently work/, it it just a sketch and a stub. module Test.LeanCheck.Function.CoListable@@ -17,9 +18,14 @@  import Test.LeanCheck import Test.LeanCheck.Tiers+import Test.LeanCheck.Utils (Nat(..), Nat2(..), Nat3(..)) import Data.Maybe (fromMaybe)  +instance (CoListable a, Listable b) => Listable (a -> b) where+  tiers = cotiers tiers++ (\+:/) :: [[a]] -> [[a]] -> [[a]] xss \+:/ yss = xss \/ ([]:yss) infixr 9 \+:/@@ -59,6 +65,8 @@                   (cotiers (cotiers rss))  +instance (CoListable a, CoListable b) => CoListable (a,b) where+  cotiers = mapT uncurry . cotiers . cotiers   instance CoListable Int where@@ -66,6 +74,18 @@            \+:/ productWith                   (\f g  i -> if i >= 0 then f (i-1) else g (i+1))                   (cotiers rss) (cotiers rss)++instance CoListable Nat where+  cotiers rss = mapT const rss+           \+:/ productWith+                  (\f g  i -> if even i then f (i`div`2) else g (i`div`2))+                  (cotiers rss) (cotiers rss)++instance CoListable Nat2 where+  cotiers rss = (\rs x -> rs !! fromIntegral x) `mapT` products [rss,rss]++instance CoListable Nat3 where+  cotiers rss = (\rs x -> rs !! fromIntegral x) `mapT` products [rss,rss,rss]   alts0 :: [[a]] -> [[a]]
src/Test/LeanCheck/Function/Eq.hs view
@@ -8,6 +8,9 @@ -- a simple enumerative property-based testing library. -- -- A toy Eq instance for Functions.+--+-- Warning: this is only intended to be used in testing modules.  Avoid+-- importing this on modules that are used as libraries. module Test.LeanCheck.Function.Eq () where  import Test.LeanCheck.Core
+ src/Test/LeanCheck/Function/FunListable.hs view
@@ -0,0 +1,133 @@+-- |+-- Module      : Test.LeanCheck.FunListable+-- Copyright   : (c) 2015-2017 Rudy Matela+-- License     : 3-Clause BSD  (see the file LICENSE)+-- Maintainer  : Rudy Matela <rudy@matela.com.br>+--+-- This module is part of LeanCheck,+-- a simple enumerative property-based testing library.+--+-- This module exports a 'Listable' instance for function enumeration by means+-- of a 'FunListable' typeclass (similar to 'FunListable').+--+-- This module /does not currently work/, it it just a sketch and a stub.+module Test.LeanCheck.Function.FunListable+where+++import Test.LeanCheck+import Test.LeanCheck.Tiers+import Test.LeanCheck.Utils (Nat(..), Nat2(..), Nat3(..))+import Data.Maybe (fromMaybe)+++sndArgTypeOf :: b -> (a -> b -> c) -> b+x `sndArgTypeOf` _ = x+++instance (FunListable a, Listable b) => Listable (a -> b) where+  tiers = concatMapT mkfss funtiers+    where+    mkfss (n, mkf) = mapT mkf (products (replicate n tiers)+                    `suchThat` validResults (undefined `sndArgTypeOf` mkf))+++(\+:/) :: [[a]] -> [[a]] -> [[a]]+xss \+:/ yss = xss \/ ([]:yss)+infixr 9 \+:/+++class FunListable a where+  validResults   :: a -> [b] -> Bool+  validResults   x  =  not . invalidResults x+  invalidResults :: a -> [b] -> Bool+  invalidResults x  =  not .   validResults x+  funtiers :: [[ (Int, [b] -> (a -> b)) ]]++-- maybe the other function FunListable needs is a okResults that checks if+-- results follow required pattern for each type:+--   * for lists, there shouldnt be repeated element suffix+--        a,a,a,a,a,b is ok+--        a,b,c,d,e,e is not ok.+--   * for integers, there shouldnt be adjacent repeated elements+--        a,b,a,b,a,b,a,b is ok+--        a,b,c,d,e,f,f,g is not ok+--        of course, this for the enumeration where I have the points.+--   * for pairs, apply the invariants accordingly in the matrix (is that+--     possible?)+--        I think it is.  Apply one invariant to columns, the other to lines.++instance FunListable () where+  validResults _ _ = True+  funtiers = [[ (1, \[r]  () -> r) ]]+++instance FunListable Bool where+  validResults _ _ = True+  funtiers = [[ (2, \[r1,r2]  b -> if b then r1 else r2) ]]++-- have funtiers = [[ (1, \[r1]  b -> r1) ]+--                  ,[ (1, \[r1]  b -> if b then r1 else not r1 ]+--                  ]+++instance FunListable a => FunListable (Maybe a) where+  validResults _ _   =  True+  funtiers = mapT (\(n, mkf) -> (n+1, \(r:rs)  m -> case m of+                                                       Nothing -> r+                                                       Just x  -> mkf rs x)) funtiers+++instance (FunListable a, FunListable b) => FunListable (Either a b) where+  validResults _ _  =  True+  funtiers = productWith+                (\(nf, mf) (ng, mg) -> (nf + ng, \rs  e -> case e of+                                                             Left  x -> mf (take nf rs) x+                                                             Right y -> mg (drop nf rs) y))+                funtiers+                funtiers+++-- NOTE: big problem: adding r1 == r2 below instroduces an Eq restriction on+-- the result type.  Which does not exist for (a->b).  Maybe create a new+-- typeclass: FunResult, then rename FunListable to FunArg.  This way we can+-- have the equality check (or any other special checks) for types that have+-- equality and ignore it for types that don't.+instance (FunListable a) => FunListable [a] where+  validResults _ [r1,r2]  {- -- | r1 == r2 -} =  False  -- The results cannot end with repetitions+  validResults x (r:rs)   =  validResults x rs+  validResults _ _        =  True+  funtiers = [[ (1, \[r]  xs -> r) ]]+         \+:/ mapT (\(n, f) -> (1 + n, \(r:rs)  xs -> case xs of+                                                        []     -> r+                                                        (x:xs) -> f rs (x,xs))) funtiers+++instance (FunListable a, FunListable b) => FunListable (a,b) where+  validResults _ _  =  True  -- TODO: check lines and columns+  funtiers = productWith (\(n, f)  (m, g)+                            -> (n*m, \rs  (x,y) -> toMatrix m rs+                                                !! f [0..(n-1)] x+                                                !! g [0..(m-1)] y))+                funtiers+                funtiers+++toMatrix :: Int -> [a] -> [[a]]+toMatrix n [] = []+toMatrix n xs = take n xs+              : toMatrix n (drop n xs)+++instance FunListable Int where+  funtiers = [[]] -- TODO: implement funtiers :: [[...Int...]]+  -- mapT (... findInterval something ...) tiers++instance FunListable Nat where+  funtiers = [[]] -- TODO: implement funtiers :: [[...Nat...]]++instance FunListable Nat2 where+  funtiers = [[]] -- TODO: implement funtiers :: [[...Nat2...]]++instance FunListable Nat3 where+  funtiers = [[]] -- TODO: implement funtiers :: [[...Nat3...]]
src/Test/LeanCheck/Function/ListsOfPairs.hs view
@@ -15,8 +15,6 @@ module Test.LeanCheck.Function.ListsOfPairs   ( functionPairs   , associations-  , pairsToFunction-  , defaultFunPairsToFunction   ) where @@ -25,17 +23,24 @@ import Data.Maybe (fromMaybe)  instance (Eq a, Listable a, Listable b) => Listable (a -> b) where-  tiers = mapT (uncurry $ flip defaultPairsToFunction)-        $ functions list tiers+  tiers = tiers -->> tiers  -functions :: [[a]] -> [[b]] -> [[([(a,b)],b)]]-functions xss yss =-  concatMapT-    (\(r,yss) -> mapT (\ps -> (ps,r)) $ functionPairs xss yss)-    (choices yss)+(-->>) :: Eq a => [[a]] -> [[b]] -> [[a->b]]+xss -->> yss+  | finite xss = mapT ((undefined `mutate`) . zip (concat xss))+                      (products $ replicate (length $ concat xss) yss)+  | otherwise  = concatMapT+                   (\(r,yss) -> mapT (const r `mutate`) (functionPairs xss yss))+                   (choices yss)  +mutate :: Eq a => (a -> b) -> [(a,b)] -> (a -> b)+mutate f ms = foldr mut f ms+  where+  mut (x',fx') f x = if x == x' then fx' else f x++ -- | Given a list of domain values, and tiers of codomain values, -- return tiers of lists of ordered pairs of domain and codomain values. --@@ -46,30 +51,23 @@ -- | Given tiers of input values and tiers of output values, -- return tiers with all possible lists of input-output pairs. -- Those represent functional relations.-functionPairs :: [[a]] -> [[b]] -> [[[(a,b)]]]-functionPairs xss yss = concatMapT (`associations` yss)-                                   (setsOf xss)---- | Returns a function given by a list of input-output pairs.--- The result is wrapped in a maybe value.--- The output for bound inputs is 'Just' a value.--- The output for unbound inputs is 'Nothing'.-pairsToMaybeFunction :: Eq a => [(a,b)] -> a -> Maybe b-pairsToMaybeFunction []          _ = Nothing-pairsToMaybeFunction ((a',r):bs) a | a == a'   = Just r-                                   | otherwise = pairsToMaybeFunction bs a+functionPairs :: [[a]] -> [[b]] -> [[ [(a,b)] ]]+functionPairs xss yss = concatMapT (`associations` yss) (incompleteSetsOf xss)+-- incompleteSetsOf is needed, instead of setsOf, because mutating *all* values+-- of a constant function makes no sense (we would have already enumerated that+-- function anyway).  As of 2c23c1a, it makes no difference whether+-- incompleteSetsOf is used instead of setsOf for types with less than 12+-- values. --- | Returns a partial function given by a list of input-output pairs.+-- | Returns tiers of sets excluding the universe set. ----- NOTE: This function *will* return undefined values for unbound inputs.-pairsToFunction :: Eq a => [(a,b)] -> a -> b-pairsToFunction bs a = fromMaybe undefined (pairsToMaybeFunction bs a)----- | Returns a function given by a list of input-output pairs and a default value.-defaultPairsToFunction :: Eq a => b -> [(a,b)] -> a -> b-defaultPairsToFunction r bs a = fromMaybe r (pairsToMaybeFunction bs a)---defaultFunPairsToFunction :: Eq a => (a -> b) -> [(a,b)] -> a -> b-defaultFunPairsToFunction f bs a = fromMaybe (f a) (pairsToMaybeFunction bs a)+-- > incompleteSetsOf (tiers :: [[Bool]])  =  [[],[[False],[True]],[]]+-- > incompleteSetsOf (tiers :: [[()]])    =  [[]]+--+-- This is the same as 'setsOf' on types with infinite values:+--+-- > incompleteSetsOf (tiers :: [[Int]])  =  setsOf (tiers :: [[Int]])+incompleteSetsOf :: [[a]] -> [[ [a] ]]+incompleteSetsOf  =  init . setsOf+-- the above implementation works because, and depends on the fact that:+-- the last tier returned by setsOf contains only the complete set
src/Test/LeanCheck/Function/Show.hs view
@@ -8,6 +8,9 @@ -- a simple enumerative property-based testing library. -- -- A 'Show' instance for functions.+--+-- Warning: this is only intended to be used in testing modules.  Avoid+-- importing this on modules that are used as libraries. module Test.LeanCheck.Function.Show () where  import Test.LeanCheck.Function.ShowFunction
src/Test/LeanCheck/IO.hs view
@@ -59,7 +59,7 @@ checkResultFor :: Testable a => Int -> a -> IO Bool checkResultFor n p = do   r <- resultIO n p-  putStrLn . showResult $ r+  putStrLn . showResult n $ r   return (isOK r)   where isOK (OK _) = True         isOK _      = False@@ -86,9 +86,10 @@   where isFailure (OK _) = False         isFailure _      = True -showResult :: Result -> String-showResult (OK n)             = "+++ OK, passed " ++ show n ++ " tests."-showResult (Falsified i ce)   = "*** Failed! Falsifiable (after "-                             ++ show i ++ " tests):\n" ++ unwords ce-showResult (Exception i ce e) = "*** Failed! Exception '" ++ e ++ "' (after "-                             ++ show i ++ " tests):\n" ++ unwords ce+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" ++ unwords ce+showResult m (Exception i ce e) = "*** Failed! Exception '" ++ e ++ "' (after "+                               ++ show i ++ " tests):\n" ++ unwords ce
src/Test/LeanCheck/Tiers.hs view
@@ -54,6 +54,15 @@   , choices   , setChoices   , bagChoices++  -- * Showing and printing lists-of-tiers+  -- | Lists-of-tiers are already show instances as their type is just @[[a]]@.+  --   The following functions are alternatives to 'print' and 'show' with one+  --   element per line and can be useful for debugging.+  , printTiers+  , showTiers++  , finite   ) where @@ -106,10 +115,10 @@ maybeCons0 (Just x) = [[x]]  maybeCons1 :: Listable a => (a -> Maybe b) -> [[b]]-maybeCons1 f = mapMaybeT f tiers `addWeight` 1+maybeCons1 f = delay $ mapMaybeT f tiers  maybeCons2 :: (Listable a, Listable b) => (a -> b -> Maybe c) -> [[c]]-maybeCons2 f = mapMaybeT (uncurry f) tiers `addWeight` 1+maybeCons2 f = delay $ mapMaybeT (uncurry f) tiers  -- | Like '><', but over 3 lists of tiers. product3 :: [[a]] -> [[b]]-> [[c]] -> [[(a,b,c)]]@@ -126,7 +135,7 @@ productMaybeWith _ _ [] = [] productMaybeWith _ [] _ = [] productMaybeWith f (xs:xss) yss = map (xs **) yss-                               \/ productMaybeWith f xss yss `addWeight` 1+                               \/ delay (productMaybeWith f xss yss)   where xs ** ys = catMaybes [ f x y | x <- xs, y <- ys ]  -- | Takes as argument tiers of element values;@@ -205,7 +214,7 @@ -- >                      ] listsOf :: [[a]] -> [[[a]]] listsOf xss = cons0 []-           \/ productWith (:) xss (listsOf xss) `addWeight` 1+           \/ delay (productWith (:) xss (listsOf xss))  -- | Takes the product of N lists of tiers, producing lists of length N. --@@ -221,7 +230,7 @@  -- | Delete the first occurence of an element in a tier. ----- For tiers without repetitions, the following holds:+-- For normalized lists-of-tiers without repetitions, the following holds: -- -- > deleteT x = normalizeT . (`suchThat` (/= x)) deleteT :: Eq a => a -> [[a]] -> [[a]]@@ -231,17 +240,28 @@ deleteT y ((x:xs):xss) | x == y    = xs:xss                        | otherwise = [[x]] \/ deleteT y (xs:xss) --- | Normalizes tiers by removing an empty tier from the end of a list of---   tiers.------ > normalizeT [xs0,xs1,...,xsN,[]] = [xs0,xs1,...,xsN]+-- | Normalizes tiers by removing up to 12 empty tiers from the end of a list+--   of tiers. -----   Note this will only remove a single empty tier:+-- > normalizeT [xs0,xs1,...,xsN,[]]     =  [xs0,xs1,...,xsN]+-- > normalizeT [xs0,xs1,...,xsN,[],[]]  =  [xs0,xs1,...,xsN] ----- > normalizeT [xs0,xs1,...,xsN,[],[]] = [xs0,xs1,...,xsN,[]]+-- 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  -- | Concatenate tiers of maybes@@ -321,7 +341,7 @@ choicesWith :: (a -> [[a]] -> b) -> [[a]] -> [[b]] choicesWith f []           = [] choicesWith f [[]]         = []-choicesWith f ([]:xss)     = [] : choicesWith (\y yss -> f y ([]:yss)) xss+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) @@ -365,7 +385,7 @@ setChoicesWith :: (a -> [[a]] -> b) -> [[a]] -> [[b]] setChoicesWith f []           = [] setChoicesWith f [[]]         = []-setChoicesWith f ([]:xss)     = [] : setChoicesWith (\y yss -> f y ([]:yss)) xss+setChoicesWith f ([]:xss)     = [] : setChoicesWith (\y yss -> f y ([]:normalizeT yss)) xss setChoicesWith f ((x:xs):xss) = [[f x (xs:xss)]]                              \/ setChoicesWith f (xs:xss) @@ -380,3 +400,91 @@ -- >   ] listsOfLength :: Int -> [[a]] -> [[[a]]] listsOfLength n xss = products (replicate n xss)+++++-- -- Showing tiers of values -- --++-- | 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 :: [String] -> String+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+++-- | 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\+-- >                   \]"+showListLines :: Show a => [a] -> String+showListLines = listLines . map show++-- | Shows a list of strings, adding @...@ to the end when longer than given+--   length.+--+-- > dotsLongerThan 3 ["1","2"]          =  [1,2]+-- > 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]++-- | 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++-- | Alternative to 'print' for 'tiers' with one element per line.+--   (useful for debugging, see also 'showTiers').+--+-- > > printTiers 3 (tiers :: [[Int]])+-- > [ [0]+-- > , [1]+-- > , [-1]+-- > , ...+-- > ]+-- > > printTiers 3 (tiers :: [[Bool]])+-- > [ [ False+-- >   , True+-- >   ]+-- > ]+--+-- This function can be useful when debugging your 'Listable' instances.+printTiers :: Show a => Int -> [[a]] -> IO ()+printTiers n = putStrLn . showTiers n++-- | Checks if a list-of-tiers is finite.+--+-- **Warning:** this is just an approximation, a list-of-tiers is considered+--              finite if it has less than 13 values.  This function may give+--              false negatives.+finite :: [[a]] -> Bool+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+-- > map length (tiers :: [[ Nat -> () ]]) [1,0,0,0,0,0,...]+-- maybe this `take 60` has to be copied in other places of LeanCheck to avoid+-- similar issues of non-temrination.
src/Test/LeanCheck/Utils/Types.hs view
@@ -44,16 +44,26 @@   , Nat6 (..)   , Nat7 (..) -  -- * Aliases to word types (deprecated)+  -- ** Aliases to word types (deprecated)   , UInt1   , UInt2   , UInt3   , UInt4++  -- * Extreme Integers+  , X (..)++  -- * List-wrapper types+  , NoDup (..)+  , Bag (..)+  , Set (..)   ) where -- TODO: Add Ix and Bits instances  import Test.LeanCheck (Listable(..), listIntegral)+import Test.LeanCheck.Core ((+|))+import Test.LeanCheck.Tiers (noDupListCons, setCons, bagCons) import Data.Ratio ((%))  narrowU :: Int -> Int -> Int@@ -445,3 +455,58 @@ type UInt2 = Word2 type UInt3 = Word3 type UInt4 = Word4++newtype NoDup a = NoDup [a] deriving (Show, Read, Eq, Ord)+newtype Bag a = Bag [a] deriving (Show, Read, Eq, Ord)+newtype Set a = Set [a] deriving (Show, Read, Eq, Ord)++instance Listable a => Listable (NoDup a) where tiers = noDupListCons NoDup+instance Listable a => Listable (Bag a)   where tiers = bagCons Bag+instance Listable a => Listable (Set a)   where tiers = setCons Set++newtype X a = X {unX :: a} deriving (Eq, Ord)+instance Show a => Show (X a) where show (X x) = show x+instance (Integral a, Bounded a) => Listable (X a) where list = map X listXIntegral++-- FIXME: make this work for Int2 / Word2 types+--        by checking then using normal enumeration+listXIntegral :: (Bounded a, Integral a) => [a]+listXIntegral = l undefined+  where+  l :: (Ord a, Num a, Bounded a, Integral a) => a -> [a]+  l a | minBound `asTypeOf` a < 0 = listXIntegralN+      | otherwise                 = listXIntegralP+-- The type-hackery above is needed so that we don't need to activate+-- ScopedTypeVariables++listXIntegralN :: (Bounded a, Integral a) => [a]+listXIntegralN = 0 : (extremes 1 maxBound) +| (extremes (-1) minBound)+-- listXIntegralN :: Int4 =+--    0 : (([1,2,3,4] +| [7,6,5]) +| ([-1,-2,-3,-4] +| [-8,-7,-6,-5]))++listXIntegralP :: (Bounded a, Integral a) => [a]+listXIntegralP = 0 : [1..midBound] ++| [maxBound,(maxBound-1)..(midBound+1)]+  where+  midBound = maxBound `div` 3 * 2++extremes :: (Integral a) => a -> a -> [a]+extremes x y+  | x > y      =  [x,x-1..m] +| [y..m-1]+  | otherwise  =  [x..m] +| [y,y-1..m+1]+  where m = mid x y++mid :: Integral a => a -> a -> a+mid x y = x `div` 2+        + y `div` 2+        + if odd x && odd y then 1 else 0++-- | Lazily interleaves two lists, switching between elements of the two.+--   This version uses the first list more frequently than the second.+--+-- > [x,y,z,w] +| [a,b] == [x,y, a, z,w, b]+(++|) :: [a] -> [a] -> [a]+[]        ++| ys      =  ys+xs        ++| []      =  xs+[x]       ++| ys      =  x:ys+(x:x':xs) ++| (y:ys)  =  x:x':y:(xs ++| ys)+infixr 5 ++|
tests/test-tiers.hs view
@@ -39,6 +39,29 @@   , holds 100 $ deleteT_is_map_delete 10 -:> int   , holds 100 $ deleteT_is_map_delete 10 -:> bool   , holds 100 $ deleteT_is_map_delete 10 -:> int2++  , finite (tiers :: [[ Bool ]])  == True+  , finite (tiers :: [[ (Bool,Bool) ]]) == True+  , finite (tiers :: [[ Nat1 ]])  == True+  , finite (tiers :: [[ Nat2 ]])  == True+  , finite (tiers :: [[ Nat3 ]])  == True+  , finite (tiers :: [[ Nat4 ]])  == True+  , finite (tiers :: [[ Nat5 ]])  == True+  , finite (tiers :: [[ Nat6 ]])  == True+  , finite (tiers :: [[ Nat7 ]])  == True+  , finite (tiers :: [[ Word1 ]])  == True+  , finite (tiers :: [[ Word2 ]])  == True+  , finite (tiers :: [[ Word3 ]])  == True++  , finite (tiers :: [[ Nat ]])   == False+  , finite (tiers :: [[ Int ]])   == False+  , finite (tiers :: [[ [Int] ]]) == False+  , finite (tiers :: [[ [()] ]])  == False++  -- false negatives, more than 12 values:+  , finite (tiers :: [[ Word4 ]])  == False+  , finite (tiers :: [[ (Bool,Bool,Bool,Bool,Bool) ]]) == False+  , finite (tiers :: [[ (Bool,Bool,Bool,Bool,Bool,Bool) ]]) == False   ]  deleteT_is_map_delete :: (Eq a, Listable a) => Int -> a -> Bool
tests/test-types.hs view
@@ -1,9 +1,11 @@ -- Copyright (c) 2015-2017 Rudy Matela. -- Distributed under the 3-Clause BSD licence (see the file LICENSE). import System.Exit (exitFailure)-import Data.List (elemIndices,delete)+import Data.List (elemIndices,delete,isPrefixOf) import Test.LeanCheck.Utils.Types import Test.LeanCheck (list,fails)+import Data.Word+import Data.Int  main :: IO () main =@@ -42,6 +44,39 @@   , list `permutation` [minBound..maxBound :: Nat6]   , list `permutation` [minBound..maxBound :: Nat7] +  , map (unX) list `permutation` [minBound..maxBound :: Int8]+  , map (unX) list `permutation` [minBound..maxBound :: Int4]+  , map (unX) list `permutation` [minBound..maxBound :: Int3]+-- TODO: make the following commented tests pass:+--, map (unX) list `permutation` [minBound..maxBound :: Int2]+--, map (unX) list `permutation` [minBound..maxBound :: Int1]+  , map (unX) list `permutation` [minBound..maxBound :: Word8]+  , map (unX) list `permutation` [minBound..maxBound :: Word4]+  , map (unX) list `permutation` [minBound..maxBound :: Word3]+  , map (unX) list `permutation` [minBound..maxBound :: Word2]+  , map (unX) list `permutation` [minBound..maxBound :: Word1]+  , map (unX) list `permutation` [minBound..maxBound :: Nat7]+  , map (unX) list `permutation` [minBound..maxBound :: Nat6]+  , map (unX) list `permutation` [minBound..maxBound :: Nat5]+  , map (unX) list `permutation` [minBound..maxBound :: Nat4]+-- TODO: make the following commented tests pass:+--, map (unX) list `permutation` [minBound..maxBound :: Nat3]+--, map (unX) list `permutation` [minBound..maxBound :: Nat2]+--, map (unX) list `permutation` [minBound..maxBound :: Nat1]++  , (prefiX :: [Int8])  `isPrefixOf` map (unX) list+  , (prefiX :: [Int16]) `isPrefixOf` map (unX) list+  , (prefiX :: [Int32]) `isPrefixOf` map (unX) list+  , (prefiX :: [Int64]) `isPrefixOf` map (unX) list+  , (prefiX :: [Int])   `isPrefixOf` map (unX) list++  , (prefiXN :: [Word8])  `isPrefixOf` map (unX) list+  , (prefiXN :: [Word16]) `isPrefixOf` map (unX) list+  , (prefiXN :: [Word32]) `isPrefixOf` map (unX) list+  , (prefiXN :: [Word64]) `isPrefixOf` map (unX) list+  , (prefiXN :: [Word])   `isPrefixOf` map (unX) list++   , [minBound..maxBound :: Int1] == signedRange 1   , [minBound..maxBound :: Int2] == signedRange 2   , [minBound..maxBound :: Int3] == signedRange 3@@ -64,6 +99,29 @@   , fails 100 (\i -> i + 1 < (i::Int2))   , fails 100 (\i -> i + 1 < (i::Int3))   , fails 100 (\i -> i + 1 < (i::Int4))+  ]+++prefiX :: (Bounded a, Integral a) => [a]+prefiX =+  [ 0+  , 1, -1+  , maxBound, minBound+  , 2, -2+  , maxBound-1, minBound+1+  , 3, -3+  , maxBound-2, minBound+2+  ]++prefiXN :: (Bounded a, Integral a) => [a]+prefiXN =+  [ 0+  , 1, 2+  , maxBound+  , 3, 4+  , maxBound-1+  , 5, 6+  , maxBound-2   ]