diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,22 +1,25 @@ Changes ======= -Version 0.1 +Version 0.6 ----------- -The differences from 0.0 are two fixes (space-fault, output buffering), -an 'unsafe' but sometimes useful Testable (IO a) instance and additional -examples. +* Default Generic implementation of Serial instance (by Bas van Dijk) +* The code is split into modules +* Convert much of README into haddock documentation +* Many small API changes +* Remove impure Testable (IO a) instance -Version 0.2 +Version 0.5 ----------- -The 'smallCheck' driver now takes an argument d and runs test series -at depths 0..d without interaction, stopping if any test fails. -The interactive variant is still available as 'smallCheckI'. All -Prelude numeric types now have Serial instances, including floating-point -types. Serial types Nat and Natural are also defined. Examples extended. +Make the package build with GHC 7.2. Some cosmetic changes. +Version 0.4 +----------- + +The module SmallCheck is now Test.SmallCheck. Packaged with Cabal. + Version 0.3 ----------- @@ -27,12 +30,18 @@ now Integers, not Ints. Ord and Eq are now derived for the N types. Examples extended. -Version 0.4 +Version 0.2 ----------- -The module SmallCheck is now Test.SmallCheck. Packaged with Cabal. +The 'smallCheck' driver now takes an argument d and runs test series +at depths 0..d without interaction, stopping if any test fails. +The interactive variant is still available as 'smallCheckI'. All +Prelude numeric types now have Serial instances, including floating-point +types. Serial types Nat and Natural are also defined. Examples extended. -Version 0.5 +Version 0.1 ----------- -Make the package build with GHC 7.2. Some cosmetic changes. +The differences from 0.0 are two fixes (space-fault, output buffering), +an 'unsafe' but sometimes useful Testable (IO a) instance and additional +examples. diff --git a/CREDITS.md b/CREDITS.md --- a/CREDITS.md +++ b/CREDITS.md @@ -11,3 +11,10 @@ > the better method for functional coseries, to Neil Mitchell for > automating the derivation of Serial instances, to Matt Naylor for > the circuit-design examples and to Gwern Branwen for Cabal packaging. + +Contributors +------------ + +The following people have contributed to SmallCheck: + +* Bas van Dijk (default Generic implementation of Serial instance) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,257 +1,32 @@ -SmallCheck: another lightweight testing library in Haskell -========================================================== - -If you are a Haskell programmer and a QuickCheck user do you ever wish -you could: - -* write test generators for your own types more easily? -* be sure that any counter-examples found are minimal? -* write properties using existentials as well as universals? -* establish complete coverage of a defined test-space? -* display counter-examples of functional type? -* always repeat tests and obtain the same results? - -If so, try SmallCheck! This note should be enough to get you started, -assuming some prior experience with QuickCheck. - -Similarities and Differences ----------------------------- - -In many ways SmallCheck is very similar to QuickCheck. It uses the -idea of type-based generators for test data, and the way testable -properties are expressed is closely based on the QuickCheck approach. Like -QuickCheck, SmallCheck tests whether properties hold for finite completely -defined values at specific types, and reports counter-examples. - -The big difference is that instead of using a sample of randomly generated -values, SmallCheck tests properties for all the finitely many values -up to some depth, progressively increasing the depth used. For data -values, depth means depth of construction. For functional values, it -is a measure combining the depth to which arguments may be evaluated -and the depth of possible results. - -QuickCheck's statistics-gathering operators have been omitted from -SmallCheck's property language, as they seem more relevant to the -random-testing approach. - -Data Generators ---------------- - -SmallCheck itself defines data generators for all the data types used -by the Prelude. - -Writing SmallCheck generators for application-specific types is -straightforward. Just as the QuickCheck user defines 'arbitrary' -generators, so a SmallCheck user defines 'series' generators -- but -it is a more straightforward task, using SmallCheck's cons family -of generic combinators where N is constructor arity. For example: - - data Tree a = Null | Fork Tree a Tree - - instance Serial a => Serial (Tree a) where - series = cons0 Null \/ cons3 Fork - -The default interpretation of depth for datatypes is the depth of nested -construction: constructor functions, including those for newtypes, build -results with depth one greater than their deepest argument. But this -default can be over-ridden by composing a cons application with an -application of 'depth', like this: - - newtype Light a = Light a - - instance Serial a => Serial (Light a) where - series = cons1 Light . depth 0 - -The depth of Light x is just the depth of x. - -Function Generators -------------------- - -To generate functions of an application-specific argument type requires a -second method 'coseries' -- cf. 'coarbitrary' in QuickCheck. Again there -is a standard pattern, this time using the alts combinators where -again N is constructor arity. Here are Tree and Light instances: - - coseries rs d = [ \t -> case t of - Null -> z - Fork t1 x t2 -> f t1 x t2 - | z <- alts0 rs d , - f <- alts3 rs d ] - - coseries rs d = [ \l -> case l of - Light x -> f x - | f <- (alts1 rs . depth 0) d ] - -(NB changed from Version 0.2: 'coseries' and 'alts' family now take a -series argument -- here rs. In the coseries definitions we simply pass -on rs as series argument in each 'alts' application.) - -Automated Derivation of Generators ----------------------------------- - -For small examples, Series instances are easy enough to define by hand, -following the above patterns. But for programs with many or large data -type definitions, automatic derivation using a tool such as 'derive' -is a better option. For example, the following command-line appends to -Prog.hs the Series instances for all data types defined there. - - $ derive Prog.hs -d Serial --append - -Properties ----------- - -SmallCheck's testable properties are closely based on those of QuickCheck -but with the introduction of existential quantifiers. Suppose we have -defined a function - - isPrefix :: Eq a => [a] -> [a] -> Bool - -and wish to specify it by some suitable property. Using QuickCheck we -might define - - prop_isPrefix1 :: String -> String -> Bool - prop_isPrefix1 xs ys = isPrefix xs (xs++ys) - -where xs and ys are universally quantified. This property is necessary -but not sufficient for a correct isPrefix. For example, it is satisfied -by the function that always returns True! We can test the same property -using SmallCheck. But we can also test the following property, which -involves an existentially quantified variable: - - prop_isPrefix2 :: String -> String -> Property - prop_isPrefix2 xs ys = isPrefix xs ys ==> - exists $ \xs' -> ys == xs++xs' - -The default testing of existentials is bounded by the same depth as their -context, here the depth-bound for xs and ys. This rule has important -consequences. Just as a universal property may be satisfied when the -depth bound is shallow but fail when it is deeper, so the reverse may be -true for an existential property. So when testing properties involving -existentials it may be appropriate to try deeper testing after a shallow -failure. However, sometimes the default same-depth-bound interpretation -of existential properties can make testing of a valid property fail at -all depths. Here is a contrived but illustrative example: - - prop_append1 :: [Bool] -> [Bool] -> Property - prop_append1 xs ys = exists $ \zs -> zs == xs++ys - -Customised variants of 'exists' are handy in such circumstances. -For example, 'existsDeeperBy' transforms the depth bound by a given -Int->Int function: - - prop_append2 :: [Bool] -> [Bool] -> Property - prop_append2 xs ys = existsDeeperBy (*2) $ \zs -> zs == xs++ys - -There are also quantifiers for unique existence. Their names include -a 1 immediately after 'exists': eg. exists1, exists1DeeperBy. - -Pragmatics of ==> ------------------ - -As in QuickCheck, the ==> operator can be used to express a restricting -condition under which a property should hold. For example, testing a -propositional-logic module (see examples/logical), we might define: - - prop_tautEval :: Proposition -> Environment -> Property - prop_tautEval p e = - tautology p ==> eval p e - -But here is an alternative definition: - - prop_tautEval :: Proposition -> Property - prop_taut p = - tautology p ==> \e -> eval p e - -The first definition generates p and e for each test, whereas the second -only generates e if the tautology p holds. This difference is not great -in QuickCheck where single random values are generated, but in SmallCheck -the second definition is far better as the test-space is reduced from -P*E to T'+T*E where P, T, T' and E are the numbers of propositions, -tautologies, non-tautologies and environments. - -Testing -------- - -Just as QuickCheck has a top-level function 'quickCheck' so SmallCheck -has 'smallCheck d'. - - smallCheck :: Testable a => Int -> a -> IO () - -It runs series of tests using depth bounds 0..d, stopping if any test -fails, and prints a summary report or a counter-example. The variant: - - smallCheckI :: Testable a => a -> IO () - -is interactive. Instead of requiring a maximum-depth argument, it invites -the user to decide whether to do deeper tests and whether to continue -after a failure. The interface is low-tech: y (or just ) -means "yes", anything else means "no". For example: - - haskell> smallCheckI prop_append1 - Depth 0: - Completed 1 test(s) without failure. - Deeper? y - Depth 1: - Failed test no. 5. Test values follow. - [True] - [True] - Continue? n - Deeper? n - haskell> - -Having methods to generate series of all (depth-bounded) values of -an argument type, SmallCheck can give at least partial information -about the extension of a function. For example, if we test the -property - - prop_assoc op = - \x y z -> (x `op` y) `op` z == x `op` (y `op` z) - where - typeInfo = op :: Bool -> Bool -> Bool - -the result is shown as follows. - - haskell> smallCheckI prop_assoc - Depth 0: - Failed test no. 22. Test values follow. - {True->{True->True;False->True};False->{True->False;False->True}} - False - True - False - -When (unique) existential properties are tested, any failure reports -conclude with "non-existence" (or "non-uniqueness" followed by two -witnesses). - -Large Test Spaces ------------------ +SmallCheck: a property-based testing library for Haskell +======================================================== -Using the standard generic scheme to define series of test value, it -often turns out that at some small depth d the 10,000-100,000 tests -are quickly checked, but at depth d+1 it is infeasible to complete -the billions of tests. There are ways to reduce some dimensions of -the search space so that other dimensions can be tested more deeply: -for example, cut the scope of quantifiers to a small fixed domain -(forAllElem, thereExistsElem), use newtypes to define restricted series -for some data types (see the 'examples' directory) or assign depth >1 -to some constructors. +SmallCheck is a testing library that allows to verify properties for all test +cases up to some depth. The test cases are generated automatically by +SmallCheck. -Function spaces grow exponentially in relation to their result and -argument spaces. Even with a depth bound, testing all functional -arguments is a challenge. Keep base-types as small as possible. -For example, try testing higher-order polymorphic functions over their -() or Bool instances. +Usefulness of such an approach to testing is based on the following observation: -Final Notes ------------ +> If a program fails to meet its specification in some cases, it almost always +> fails in some simple case. -The name is intended to acknowledge QuickCheck, not to suggest that -SmallCheck replaces it. See also Lazy SmallCheck. Each tool has its -advantages and disadvantages when compared with the others. +To get started with SmallCheck: -SmallCheck is a Haskell 98 package (aside from using unsafePerformIO to test IO -computations). It can be [obtained][hackage] from hackage. +* Read the [documentation][haddock] +* Look at some [examples][examples] +* If you have experience with QuickCheck, [read the comparison of QuickCheck and SmallCheck][comparison] +* Install it and give it a try! + `cabal update; cabal install smallcheck` +* Read the [paper][paper] or [other materials][oldpage] from the original + authors of SmallCheck (note that that information might be somewhat outdated) +* If you see something that can be improved, please [submit an issue][issues] +* Check out [the source code][github] at GitHub +[haddock]: http://hackage.haskell.org/packages/archive/smallcheck/latest/doc/html/Test-SmallCheck.html [hackage]: http://hackage.haskell.org/package/smallcheck - -Comments and suggestions are welcome. +[examples]: https://github.com/feuerbach/smallcheck/tree/master/examples +[paper]: http://www.cs.york.ac.uk/fp/smallcheck/smallcheck.pdf +[oldpage]: http://www.cs.york.ac.uk/fp/smallcheck/ +[comparison]: https://github.com/feuerbach/smallcheck/wiki/Comparison-with-QuickCheck +[github]: https://github.com/feuerbach/smallcheck +[issues]: https://github.com/feuerbach/smallcheck/issues diff --git a/Test/SmallCheck.hs b/Test/SmallCheck.hs --- a/Test/SmallCheck.hs +++ b/Test/SmallCheck.hs @@ -1,432 +1,72 @@ ---------------------------------------------------------------------- --- SmallCheck: another lightweight testing library. --- Colin Runciman, August 2006 --- Version 0.4, 23 May 2008 +-------------------------------------------------------------------- +-- | +-- Module : Test.SmallCheck +-- Copyright : (c) Colin Runciman et al. +-- License : BSD3 +-- Maintainer: Roman Cheplyaka -- --- After QuickCheck, by Koen Claessen and John Hughes (2000-2004). ---------------------------------------------------------------------- - +-- This module exports the main pieces of SmallCheck functionality. +-- +-- For pointers to other sources of information about SmallCheck, please refer +-- to the README at +-- +-------------------------------------------------------------------- module Test.SmallCheck ( - smallCheck, smallCheckI, depthCheck, test, - Property, Testable, - forAll, forAllElem, - exists, existsDeeperBy, thereExists, thereExistsElem, - exists1, exists1DeeperBy, thereExists1, thereExists1Elem, - (==>), - Series, Serial(..), - (\/), (><), two, three, four, - cons0, cons1, cons2, cons3, cons4, - alts0, alts1, alts2, alts3, alts4, - N(..), Nat, Natural, - depth, inc, dec - ) where - -import Data.List (intersperse) -import Control.Monad (when) -import System.IO (stdout, hFlush) -import System.IO.Unsafe (unsafePerformIO) -- used only for Testable (IO a) - ------------------- ----------------- - --- Series arguments should be interpreted as a depth bound (>=0) --- Series results should have finite length - -type Series a = Int -> [a] - --- sum -infixr 7 \/ -(\/) :: Series a -> Series a -> Series a -s1 \/ s2 = \d -> s1 d ++ s2 d - --- product -infixr 8 >< -(><) :: Series a -> Series b -> Series (a,b) -s1 >< s2 = \d -> [(x,y) | x <- s1 d, y <- s2 d] - -------------------- ------------------ - --- enumerated data values should be finite and fully defined --- enumerated functional values should be total and strict - --- bounds: --- for data values, the depth of nested constructor applications --- for functional values, both the depth of nested case analysis --- and the depth of results - -class Serial a where - series :: Series a - coseries :: Series b -> Series (a->b) - -instance Serial () where - series _ = [()] - coseries rs d = [ \() -> b - | b <- rs d ] - -instance Serial Int where - series d = [(-d)..d] - coseries rs d = [ \i -> if i > 0 then f (N (i - 1)) - else if i < 0 then g (N (abs i - 1)) - else z - | z <- alts0 rs d, f <- alts1 rs d, g <- alts1 rs d ] - -instance Serial Integer where - series d = [ toInteger (i :: Int) - | i <- series d ] - coseries rs d = [ f . (fromInteger :: Integer->Int) - | f <- coseries rs d ] - -newtype N a = N a - deriving (Eq, Ord) - -instance Show a => Show (N a) where - show (N i) = show i - -instance (Integral a, Serial a) => Serial (N a) where - series d = map N [0..d'] - where - d' = fromInteger (toInteger d) - coseries rs d = [ \(N i) -> if i > 0 then f (N (i - 1)) - else z - | z <- alts0 rs d, f <- alts1 rs d ] - -type Nat = N Int -type Natural = N Integer - -instance Serial Float where - series d = [ encodeFloat sig exp - | (sig,exp) <- series d, - odd sig || sig==0 && exp==0 ] - coseries rs d = [ f . decodeFloat - | f <- coseries rs d ] - -instance Serial Double where - series d = [ frac (x :: Float) - | x <- series d ] - coseries rs d = [ f . (frac :: Double->Float) - | f <- coseries rs d ] - -frac :: (Real a, Fractional a, Real b, Fractional b) => a -> b -frac = fromRational . toRational - -instance Serial Char where - series d = take (d+1) ['a'..'z'] - coseries rs d = [ \c -> f (N (fromEnum c - fromEnum 'a')) - | f <- coseries rs d ] - -instance (Serial a, Serial b) => - Serial (a,b) where - series = series >< series - coseries rs = map uncurry . (coseries $ coseries rs) - -instance (Serial a, Serial b, Serial c) => - Serial (a,b,c) where - series = \d -> [(a,b,c) | (a,(b,c)) <- series d] - coseries rs = map uncurry3 . (coseries $ coseries $ coseries rs) - -instance (Serial a, Serial b, Serial c, Serial d) => - Serial (a,b,c,d) where - series = \d -> [(a,b,c,d) | (a,(b,(c,d))) <- series d] - coseries rs = map uncurry4 . (coseries $ coseries $ coseries $ coseries rs) - -uncurry3 :: (a->b->c->d) -> ((a,b,c)->d) -uncurry3 f (x,y,z) = f x y z - -uncurry4 :: (a->b->c->d->e) -> ((a,b,c,d)->e) -uncurry4 f (w,x,y,z) = f w x y z - -two :: Series a -> Series (a,a) -two s = s >< s - -three :: Series a -> Series (a,a,a) -three s = \d -> [(x,y,z) | (x,(y,z)) <- (s >< s >< s) d] - -four :: Series a -> Series (a,a,a,a) -four s = \d -> [(w,x,y,z) | (w,(x,(y,z))) <- (s >< s >< s >< s) d] - -cons0 :: - a -> Series a -cons0 c _ = [c] - -cons1 :: Serial a => - (a->b) -> Series b -cons1 c d = [c z | d > 0, z <- series (d-1)] - -cons2 :: (Serial a, Serial b) => - (a->b->c) -> Series c -cons2 c d = [c y z | d > 0, (y,z) <- series (d-1)] - -cons3 :: (Serial a, Serial b, Serial c) => - (a->b->c->d) -> Series d -cons3 c d = [c x y z | d > 0, (x,y,z) <- series (d-1)] - -cons4 :: (Serial a, Serial b, Serial c, Serial d) => - (a->b->c->d->e) -> Series e -cons4 c d = [c w x y z | d > 0, (w,x,y,z) <- series (d-1)] - -alts0 :: Series a -> - Series a -alts0 as d = as d - -alts1 :: Serial a => - Series b -> Series (a->b) -alts1 bs d = if d > 0 then coseries bs (dec d) - else [\_ -> x | x <- bs d] - -alts2 :: (Serial a, Serial b) => - Series c -> Series (a->b->c) -alts2 cs d = if d > 0 then coseries (coseries cs) (dec d) - else [\_ _ -> x | x <- cs d] - -alts3 :: (Serial a, Serial b, Serial c) => - Series d -> Series (a->b->c->d) -alts3 ds d = if d > 0 then coseries (coseries (coseries ds)) (dec d) - else [\_ _ _ -> x | x <- ds d] - -alts4 :: (Serial a, Serial b, Serial c, Serial d) => - Series e -> Series (a->b->c->d->e) -alts4 es d = if d > 0 then coseries (coseries (coseries (coseries es))) (dec d) - else [\_ _ _ _ -> x | x <- es d] - -instance Serial Bool where - series = cons0 True \/ cons0 False - coseries rs d = [ \x -> if x then r1 else r2 - | r1 <- rs d, r2 <- rs d ] - -instance Serial a => Serial (Maybe a) where - series = cons0 Nothing \/ cons1 Just - coseries rs d = [ \m -> case m of - Nothing -> z - Just x -> f x - | z <- alts0 rs d , - f <- alts1 rs d ] - -instance (Serial a, Serial b) => Serial (Either a b) where - series = cons1 Left \/ cons1 Right - coseries rs d = [ \e -> case e of - Left x -> f x - Right y -> g y - | f <- alts1 rs d , - g <- alts1 rs d ] - -instance Serial a => Serial [a] where - series = cons0 [] \/ cons2 (:) - coseries rs d = [ \xs -> case xs of - [] -> y - (x:xs') -> f x xs' - | y <- alts0 rs d , - f <- alts2 rs d ] - --- Thanks to Ralf Hinze for the definition of coseries --- using the nest auxiliary. - -instance (Serial a, Serial b) => Serial (a->b) where - series = coseries series - coseries rs d = - [ \ f -> g [ f a | a <- args ] - | g <- nest args d ] - where - args = series d - nest [] _ = [ \[] -> c - | c <- rs d ] - nest (a:as) _ = [ \(b:bs) -> f b bs - | f <- coseries (nest as) d ] - --- For customising the depth measure. Use with care! - -depth :: Int -> Int -> Int -depth d d' | d >= 0 = d'+1-d - | otherwise = error "SmallCheck.depth: argument < 0" - -dec :: Int -> Int -dec d | d > 0 = d-1 - | otherwise = error "SmallCheck.dec: argument <= 0" - -inc :: Int -> Int -inc d = d+1 - --- show the extension of a function (in part, bounded both by --- the number and depth of arguments) -instance (Serial a, Show a, Show b) => Show (a->b) where - show f = - if maxarheight == 1 - && sumarwidth + length ars * length "->;" < widthLimit then - "{"++( - concat $ intersperse ";" $ [a++"->"++r | (a,r) <- ars] - )++"}" - else - concat $ [a++"->\n"++indent r | (a,r) <- ars] - where - ars = take lengthLimit [ (show x, show (f x)) - | x <- series depthLimit ] - maxarheight = maximum [ max (height a) (height r) - | (a,r) <- ars ] - sumarwidth = sum [ length a + length r - | (a,r) <- ars] - indent = unlines . map (" "++) . lines - height = length . lines - (widthLimit,lengthLimit,depthLimit) = (80,20,3)::(Int,Int,Int) - ----------------- ------------------ - --- adapted from QuickCheck originals: here results come in lists, --- properties have depth arguments, stamps (for classifying random --- tests) are omitted, existentials are introduced - -newtype PR = Prop [Result] - -data Result = Result {ok :: Maybe Bool, arguments :: [String]} - -nothing :: Result -nothing = Result {ok = Nothing, arguments = []} - -result :: Result -> PR -result res = Prop [res] - -newtype Property = Property (Int -> PR) - -class Testable a where - property :: a -> Int -> PR - -instance Testable Bool where - property b _ = Prop [Result (Just b) []] - -instance Testable PR where - property prop _ = prop - -instance (Serial a, Show a, Testable b) => Testable (a->b) where - property f = f' where Property f' = forAll series f - -instance Testable Property where - property (Property f) d = f d - --- For testing properties involving IO. Unsafe, so use with care! -instance Testable a => Testable (IO a) where - property = property . unsafePerformIO - -evaluate :: Testable a => a -> Series Result -evaluate x d = rs where Prop rs = property x d - -forAll :: (Show a, Testable b) => Series a -> (a->b) -> Property -forAll xs f = Property $ \d -> Prop $ - [ r{arguments = show x : arguments r} - | x <- xs d, r <- evaluate (f x) d ] - -forAllElem :: (Show a, Testable b) => [a] -> (a->b) -> Property -forAllElem xs = forAll (const xs) - -existence :: (Show a, Testable b) => Bool -> Series a -> (a->b) -> Property -existence u xs f = Property existenceDepth - where - existenceDepth d = Prop [ Result (Just valid) arguments ] - where - witnesses = [ show x | x <- xs d, all pass (evaluate (f x) d) ] - valid = enough witnesses - enough = if u then unique else (not . null) - arguments = if valid then [] - else if null witnesses then ["non-existence"] - else "non-uniqueness" : take 2 witnesses - -unique :: [a] -> Bool -unique [_] = True -unique _ = False - -pass :: Result -> Bool -pass (Result Nothing _) = True -pass (Result (Just b) _) = b - -thereExists :: (Show a, Testable b) => Series a -> (a->b) -> Property -thereExists = existence False - -thereExists1 :: (Show a, Testable b) => Series a -> (a->b) -> Property -thereExists1 = existence True - -thereExistsElem :: (Show a, Testable b) => [a] -> (a->b) -> Property -thereExistsElem xs = thereExists (const xs) - -thereExists1Elem :: (Show a, Testable b) => [a] -> (a->b) -> Property -thereExists1Elem xs = thereExists1 (const xs) - -exists :: (Show a, Serial a, Testable b) => (a->b) -> Property -exists = thereExists series - -exists1 :: (Show a, Serial a, Testable b) => (a->b) -> Property -exists1 = thereExists1 series - -existsDeeperBy :: (Show a, Serial a, Testable b) => (Int->Int) -> (a->b) -> Property -existsDeeperBy f = thereExists (series . f) - -exists1DeeperBy :: (Show a, Serial a, Testable b) => (Int->Int) -> (a->b) -> Property -exists1DeeperBy f = thereExists1 (series . f) - -infixr 0 ==> - -(==>) :: Testable a => Bool -> a -> Property -True ==> x = Property (property x) -False ==> x = Property (const (result nothing)) - ---------------------- ---------------------- - --- similar in spirit to QuickCheck but with iterative deepening + -- * Constructing tests -test :: Testable a => a -> IO () -test = smallCheckI + -- | The simplest kind of test is a function (possibly of many + -- arguments) returning 'Bool'. + -- + -- In addition, you can use the combinators shown below. For more + -- advanced combinators, see "Test.SmallCheck.Property". --- test for values of depths 0..d stopping when a property --- fails or when it has been checked for all these values -smallCheck :: Testable a => Int -> a -> IO () -smallCheck d = iterCheck 0 (Just d) + Testable, + Property, + property, --- interactive variant, asking the user whether testing should --- continue/go deeper after a failure/completed iteration -smallCheckI :: Testable a => a -> IO () -smallCheckI = iterCheck 0 Nothing + -- ** Existential quantification -depthCheck :: Testable a => Int -> a -> IO () -depthCheck d = iterCheck d (Just d) + -- | Suppose we have defined a function + -- + -- >isPrefix :: Eq a => [a] -> [a] -> Bool + -- + -- and wish to specify it by some suitable property. We might define + -- + -- >prop_isPrefix1 :: String -> String -> Bool + -- >prop_isPrefix1 xs ys = isPrefix xs (xs++ys) + -- + -- where @xs@ and @ys@ are universally quantified. This property is necessary + -- but not sufficient for a correct @isPrefix@. For example, it is satisfied + -- by the function that always returns @True@! + -- + -- We can also test the following property, which involves an existentially + -- quantified variable: + -- + -- >prop_isPrefix2 :: String -> String -> Property + -- >prop_isPrefix2 xs ys = isPrefix xs ys ==> exists $ \xs' -> ys == xs++xs' -iterCheck :: Testable a => Int -> Maybe Int -> a -> IO () -iterCheck dFrom mdTo t = iter dFrom - where - iter d = do - putStrLn ("Depth "++show d++":") - let Prop results = property t d - ok <- check (mdTo==Nothing) 0 0 True results - maybe (whenUserWishes " Deeper" () $ iter (d+1)) - (\dTo -> when (ok && d < dTo) $ iter (d+1)) - mdTo + exists, + exists1, + existsDeeperBy, + exists1DeeperBy, -check :: Bool -> Integer -> Integer -> Bool -> [Result] -> IO Bool -check i n x ok rs | null rs = do - putStr (" Completed "++show n++" test(s)") - putStrLn (if ok then " without failure." else ".") - when (x > 0) $ - putStrLn (" But "++show x++" did not meet ==> condition.") - return ok -check i n x ok (Result Nothing _ : rs) = do - progressReport i n x - check i (n+1) (x+1) ok rs -check i n x f (Result (Just True) _ : rs) = do - progressReport i n x - check i (n+1) x f rs -check i n x f (Result (Just False) args : rs) = do - putStrLn (" Failed test no. "++show (n+1)++". Test values follow.") - mapM_ (putStrLn . (" "++)) args - ( if i then - whenUserWishes " Continue" False $ check i (n+1) x False rs - else - return False ) + -- ** Conditioning + (==>), -whenUserWishes :: String -> a -> IO a -> IO a -whenUserWishes wish x action = do - putStr (wish++"? ") - hFlush stdout - reply <- getLine - ( if (null reply || reply=="y") then action - else return x ) + -- * Running tests + -- | The functions below can be used to run SmallCheck tests. + -- + -- As an alternative, consider using @test-framework@ package. + -- + -- It allows to organize SmallCheck properties into a test suite (possibly + -- together with HUnit or QuickCheck tests), apply timeouts, get nice + -- statistics etc. + -- + -- To use SmallCheck properties with test-framework, install + -- @test-framework-smallcheck@ package. + smallCheck, depthCheck, smallCheckI, + Depth + ) where -progressReport :: Bool -> Integer -> Integer -> IO () -progressReport i n x | n >= x = do - when i $ ( putStr (n' ++ replicate (length n') '\b') >> - hFlush stdout ) - where - n' = show n +import Test.SmallCheck.Property +import Test.SmallCheck.Drivers diff --git a/Test/SmallCheck/Drivers.hs b/Test/SmallCheck/Drivers.hs new file mode 100644 --- /dev/null +++ b/Test/SmallCheck/Drivers.hs @@ -0,0 +1,91 @@ +-------------------------------------------------------------------- +-- | +-- Module : Test.SmallCheck.Drivers +-- Copyright : (c) Colin Runciman et al. +-- License : BSD3 +-- Maintainer: Roman Cheplyaka +-- +-- Functions to run SmallCheck tests. +-------------------------------------------------------------------- +module Test.SmallCheck.Drivers ( + smallCheck, smallCheckI, depthCheck + ) where + +import System.IO (stdout, hFlush) +import Control.Monad (when) +import Test.SmallCheck.Property + +-- | Run series of tests using depth bounds 0..d, stopping if any test fails, +-- and print a summary report or a counter-example. +smallCheck :: Testable a => Depth -> a -> IO () +smallCheck d = iterCheck 0 (Just d) + +-- | Same as 'smallCheck', but test for values of depth d only +depthCheck :: Testable a => Depth -> a -> IO () +depthCheck d = iterCheck d (Just d) + +-- | Interactive variant, asking the user whether testing should +-- continue\/go deeper after a failure\/completed iteration. +-- +-- Example session: +-- +-- >haskell> smallCheckI prop_append1 +-- >Depth 0: +-- > Completed 1 test(s) without failure. +-- > Deeper? y +-- >Depth 1: +-- > Failed test no. 5. Test values follow. +-- > [True] +-- > [True] +-- > Continue? n +-- > Deeper? n +-- >haskell> +smallCheckI :: Testable a => a -> IO () +smallCheckI = iterCheck 0 Nothing + +iterCheck :: Testable a => Depth -> Maybe Depth -> a -> IO () +iterCheck dFrom mdTo t = iter dFrom + where + iter d = do + putStrLn ("Depth "++show d++":") + let results = test t d + ok <- check (mdTo==Nothing) 0 0 True results + maybe (whenUserWishes " Deeper" () $ iter (d+1)) + (\dTo -> when (ok && d < dTo) $ iter (d+1)) + mdTo + +check :: Bool -> Integer -> Integer -> Bool -> [TestCase] -> IO Bool +check i n x ok rs | null rs = do + putStr (" Completed "++show n++" test(s)") + putStrLn (if ok then " without failure." else ".") + when (x > 0) $ + putStrLn (" But "++show x++" did not meet ==> condition.") + return ok +check i n x ok (TestCase Inappropriate _ : rs) = do + progressReport i n x + check i (n+1) (x+1) ok rs +check i n x f (TestCase Pass _ : rs) = do + progressReport i n x + check i (n+1) x f rs +check i n x f (TestCase Fail args : rs) = do + putStrLn (" Failed test no. "++show (n+1)++". Test values follow.") + mapM_ (putStrLn . (" "++)) args + ( if i then + whenUserWishes " Continue" False $ check i (n+1) x False rs + else + return False ) + +whenUserWishes :: String -> a -> IO a -> IO a +whenUserWishes wish x action = do + putStr (wish++"? ") + hFlush stdout + reply <- getLine + ( if (null reply || reply=="y") then action + else return x ) + +progressReport :: Bool -> Integer -> Integer -> IO () +progressReport i n x | n >= x = do + when i $ ( putStr (n' ++ replicate (length n') '\b') >> + hFlush stdout ) + where + n' = show n diff --git a/Test/SmallCheck/Property.hs b/Test/SmallCheck/Property.hs new file mode 100644 --- /dev/null +++ b/Test/SmallCheck/Property.hs @@ -0,0 +1,176 @@ +-------------------------------------------------------------------- +-- | +-- Module : Test.SmallCheck.Property +-- Copyright : (c) Colin Runciman et al. +-- License : BSD3 +-- Maintainer: Roman Cheplyaka +-- +-- Properties and tools to construct them. +-------------------------------------------------------------------- +module Test.SmallCheck.Property ( + -- * Basic definitions + TestCase(..), + TestResult(..), + resultIsOk, + + Property, Depth, Testable(..), + property, mkProperty, + + -- * Constructing tests + (==>), exists, existsDeeperBy, exists1, exists1DeeperBy, + -- ** Series- and list-based constructors + -- | Combinators below can be used to explicitly specify the domain of + -- quantification (as 'Series' or lists). + -- + -- Hopefully, their meaning is evident from their names and types. + forAll, forAllElem, + thereExists, thereExistsElem, + thereExists1, thereExists1Elem + ) where + +import Test.SmallCheck.Series + +data TestResult + = Pass + | Fail + | Inappropriate + -- ^ 'Inappropriate' means that the precondition of '==>' + -- was not satisfied +data TestCase = TestCase { result :: TestResult, arguments :: [String] } + +-- | Wrapper type for 'Testable's +newtype Property = Property (Depth -> [TestCase]) + +-- | Wrap a 'Testable' into a 'Property' +property :: Testable a => a -> Property +property = Property . test + +-- | A lower-level way to create properties. Use 'property' if possible. +-- +-- The argument is a function that produces the list of results given the depth +-- of testing. +mkProperty :: (Depth -> [TestCase]) -> Property +mkProperty = Property + +-- | Anything of a 'Testable' type can be regarded as a \"test\" +class Testable a where + test :: a -> Depth -> [TestCase] + +instance Testable Bool where + test b _ = [TestCase (boolToResult b) []] + +instance (Serial a, Show a, Testable b) => Testable (a->b) where + test f = f' where Property f' = forAll series f + +instance Testable Property where + test (Property f) d = f d + +forAll :: (Show a, Testable b) => Series a -> (a->b) -> Property +forAll xs f = Property $ \d -> + [ r{arguments = show x : arguments r} + | x <- xs d, r <- test (f x) d ] + +forAllElem :: (Show a, Testable b) => [a] -> (a->b) -> Property +forAllElem xs = forAll (const xs) + +existence :: (Show a, Testable b) => Bool -> Series a -> (a->b) -> Property +existence u xs f = Property existenceDepth + where + existenceDepth d = [ TestCase (boolToResult valid) arguments ] + where + witnesses = [ show x | x <- xs d, all (resultIsOk . result) (test (f x) d) ] + valid = enough witnesses + enough = if u then unique else (not . null) + arguments = if valid then [] + else if null witnesses then ["non-existence"] + else "non-uniqueness" : take 2 witnesses + +unique :: [a] -> Bool +unique [_] = True +unique _ = False + +-- | Return 'False' iff the result is 'Fail' +resultIsOk :: TestResult -> Bool +resultIsOk r = + case r of + Fail -> False + Pass -> True + Inappropriate -> True + +boolToResult :: Bool -> TestResult +boolToResult b = if b then Pass else Fail + +thereExists :: (Show a, Testable b) => Series a -> (a->b) -> Property +thereExists = existence False + +thereExists1 :: (Show a, Testable b) => Series a -> (a->b) -> Property +thereExists1 = existence True + +thereExistsElem :: (Show a, Testable b) => [a] -> (a->b) -> Property +thereExistsElem xs = thereExists (const xs) + +thereExists1Elem :: (Show a, Testable b) => [a] -> (a->b) -> Property +thereExists1Elem xs = thereExists1 (const xs) + +-- | @'exists' p@ holds iff it is possible to find an argument @a@ (within the +-- depth constraints!) satisfying the predicate @p@ +exists :: (Show a, Serial a, Testable b) => (a->b) -> Property +exists = thereExists series + +-- | Like 'exists', but additionally require the uniqueness of the +-- argument satisfying the predicate +exists1 :: (Show a, Serial a, Testable b) => (a->b) -> Property +exists1 = thereExists1 series + +-- | The default testing of existentials is bounded by the same depth as their +-- context. This rule has important consequences. Just as a universal property +-- may be satisfied when the depth bound is shallow but fail when it is deeper, +-- so the reverse may be true for an existential property. So when testing +-- properties involving existentials it may be appropriate to try deeper testing +-- after a shallow failure. However, sometimes the default same-depth-bound +-- interpretation of existential properties can make testing of a valid property +-- fail at all depths. Here is a contrived but illustrative example: +-- +-- >prop_append1 :: [Bool] -> [Bool] -> Property +-- >prop_append1 xs ys = exists $ \zs -> zs == xs++ys +-- +-- 'existsDeeperBy' transforms the depth bound by a given @'Depth' -> 'Depth'@ function: +-- +-- >prop_append2 :: [Bool] -> [Bool] -> Property +-- >prop_append2 xs ys = existsDeeperBy (*2) $ \zs -> zs == xs++ys +existsDeeperBy :: (Show a, Serial a, Testable b) => (Depth->Depth) -> (a->b) -> Property +existsDeeperBy f = thereExists (series . f) + +-- | Like 'existsDeeperBy', but additionally require the uniqueness of the +-- argument satisfying the predicate +exists1DeeperBy :: (Show a, Serial a, Testable b) => (Depth->Depth) -> (a->b) -> Property +exists1DeeperBy f = thereExists1 (series . f) + +infixr 0 ==> + +-- | The '==>' operator can be used to express a +-- restricting condition under which a property should hold. For example, +-- testing a propositional-logic module (see examples/logical), we might +-- define: +-- +-- >prop_tautEval :: Proposition -> Environment -> Property +-- >prop_tautEval p e = +-- > tautology p ==> eval p e +-- +-- But here is an alternative definition: +-- +-- >prop_tautEval :: Proposition -> Property +-- >prop_taut p = +-- > tautology p ==> \e -> eval p e +-- +-- The first definition generates p and e for each test, whereas the +-- second only generates e if the tautology p holds. +-- +-- The second definition is far better as the test-space is +-- reduced from PE to T'+TE where P, T, T' and E are the numbers of +-- propositions, tautologies, non-tautologies and environments. +(==>) :: Testable a => Bool -> a -> Property +True ==> x = Property (test x) +False ==> x = Property (const [nothing]) + where + nothing = TestCase { result = Inappropriate, arguments = [] } diff --git a/Test/SmallCheck/Series.hs b/Test/SmallCheck/Series.hs new file mode 100644 --- /dev/null +++ b/Test/SmallCheck/Series.hs @@ -0,0 +1,410 @@ +-------------------------------------------------------------------- +-- | +-- Module : Test.SmallCheck.Series +-- Copyright : (c) Colin Runciman et al. +-- License : BSD3 +-- Maintainer: Roman Cheplyaka +-- +-- Generation of test data. +-------------------------------------------------------------------- +{-# LANGUAGE CPP #-} + +#ifdef GENERICS +{-# LANGUAGE DefaultSignatures + , FlexibleContexts + , TypeOperators + , TypeSynonymInstances + , FlexibleInstances + #-} +#endif + +module Test.SmallCheck.Series ( + -- * Basic definitions + Depth, Series, Serial(..), + + -- * Data Generators + -- | SmallCheck itself defines data generators for all the data types used + -- by the Prelude. + -- + -- Writing SmallCheck generators for application-specific types is + -- straightforward. You need to define a 'series' generator, typically using + -- @consN@ family of generic combinators where N is constructor arity. + -- + -- For example: + -- + -- >data Tree a = Null | Fork (Tree a) a (Tree a) + -- > + -- >instance Serial a => Serial (Tree a) where + -- > series = cons0 Null \/ cons3 Fork + -- + -- The default interpretation of depth for datatypes is the depth of nested + -- construction: constructor functions, including those for newtypes, build + -- results with depth one greater than their deepest argument. But this + -- default can be over-ridden by composing a @consN@ application with an + -- application of 'depth', like this: + -- + -- >newtype Light a = Light a + -- > + -- >instance Serial a => Serial (Light a) where + -- > series = cons1 Light . depth 0 + -- + -- The depth of @Light x@ is just the depth of @x@. + + cons0, cons1, cons2, cons3, cons4, + -- * Function Generators + + -- | To generate functions of an application-specific argument type + -- requires a second method 'coseries'. Again there is a standard + -- pattern, this time using the altsN combinators where again N is + -- constructor arity. Here are Tree and Light instances: + -- + -- >coseries rs d = [ \t -> case t of + -- > Null -> z + -- > Fork t1 x t2 -> f t1 x t2 + -- > | z <- alts0 rs d , + -- > f <- alts3 rs d ] + -- > + -- >coseries rs d = [ \l -> case l of + -- > Light x -> f x + -- > | f <- (alts1 rs . depth 0) d ] + alts0, alts1, alts2, alts3, alts4, + + -- * Automated Derivation of Generators + + -- | For small examples, Series instances are easy enough to define by hand, + -- following the above patterns. But for programs with many or large data + -- type definitions, automatic derivation using a tool such as \"derive\" + -- is a better option. For example, the following command-line appends to + -- Prog.hs the Series instances for all data types defined there. + -- + -- >$ derive Prog.hs -d Serial --append + + -- ** Using GHC Generics + -- | For GHC users starting from GHC 7.2.1 there's also an option to use GHC's + -- Generics to get 'Serial' instance for free. + -- + -- Example: + -- + -- >{-# LANGUAGE DeriveGeneric #-} + -- >import Test.SmallCheck + -- >import GHC.Generics + -- > + -- >data Tree a = Null | Fork (Tree a) a (Tree a) + -- > deriving Generic + -- >instance Serial a => Serial (Tree a) + -- + -- Here we enable the @DeriveGeneric@ extension which allows to derive 'Generic' + -- instance for our data type. Then we declare that @Tree a@ is an instance of + -- 'Serial', but do not provide any definitions. This causes GHC to use the + -- default definitions that use the 'Generic' instance. + + -- * Other useful definitions + (\/), (><), + N(..), Nat, Natural, + depth + ) where + +import Data.List (intersperse) + +#ifdef GENERICS +import GHC.Generics +import Data.DList (DList, toList, fromList) +import Data.Monoid (mempty, mappend) +#endif + +-- | Maximum depth of generated test values +-- +-- For data values, it is the depth of nested constructor applications. +-- +-- For functional values, it is both the depth of nested case analysis +-- and the depth of results. +type Depth = Int + +-- | 'Series' is a function from the depth to a finite list of values. +type Series a = Depth -> [a] + +-- | Sum (union) of series +infixr 7 \/ +(\/) :: Series a -> Series a -> Series a +s1 \/ s2 = \d -> s1 d ++ s2 d + +-- | Product of series +infixr 8 >< +(><) :: Series a -> Series b -> Series (a,b) +s1 >< s2 = \d -> [(x,y) | x <- s1 d, y <- s2 d] + +class Serial a where + series :: Series a + coseries :: Series b -> Series (a->b) + +#ifdef GENERICS + default series :: (Generic a, GSerial (Rep a)) => Series a + series = map to . gSeries + + default coseries :: (Generic a, GSerial (Rep a)) => Series b -> Series (a->b) + coseries rs = map (. from) . gCoseries rs + +class GSerial f where + gSeries :: Series (f a) + gCoseries :: Series b -> Series (f a -> b) + +instance GSerial f => GSerial (M1 i c f) where + gSeries = map M1 . gSeries + gCoseries rs = map (. unM1) . gCoseries rs + {-# INLINE gSeries #-} + {-# INLINE gCoseries #-} + +instance Serial c => GSerial (K1 i c) where + gSeries = map K1 . series + gCoseries rs = map (. unK1) . coseries rs + {-# INLINE gSeries #-} + {-# INLINE gCoseries #-} + +instance GSerial U1 where + gSeries = cons0 U1 + gCoseries rs d = [\U1 -> b | b <- rs d] + {-# INLINE gSeries #-} + {-# INLINE gCoseries #-} + +instance (GSerial a, GSerial b) => GSerial (a :*: b) where + gSeries d = [x :*: y | x <- gSeries d, y <- gSeries d] + gCoseries rs = map uncur . gCoseries (gCoseries rs) + where + uncur f (x :*: y) = f x y + {-# INLINE gSeries #-} + {-# INLINE gCoseries #-} + +instance (GSerialSum a, GSerialSum b) => GSerial (a :+: b) where + gSeries = toList . gSeriesSum + gCoseries = gCoseriesSum + {-# INLINE gSeries #-} + {-# INLINE gCoseries #-} + +class GSerialSum f where + gSeriesSum :: DSeries (f a) + gCoseriesSum :: Series b -> Series (f a -> b) + +type DSeries a = Depth -> DList a + +instance (GSerialSum a, GSerialSum b) => GSerialSum (a :+: b) where + gSeriesSum d = fmap L1 (gSeriesSum d) `mappend` fmap R1 (gSeriesSum d) + gCoseriesSum rs d = [ \e -> case e of + L1 x -> f x + R1 y -> g y + | f <- gCoseriesSum rs d + , g <- gCoseriesSum rs d + ] + {-# INLINE gSeriesSum #-} + {-# INLINE gCoseriesSum #-} + +instance GSerial f => GSerialSum (C1 c f) where + gSeriesSum d | d > 0 = fromList $ gSeries (d-1) + | otherwise = mempty + gCoseriesSum rs d | d > 0 = gCoseries rs (d-1) + | otherwise = [\_ -> x | x <- rs d] + {-# INLINE gSeriesSum #-} + {-# INLINE gCoseriesSum #-} +#endif + +instance Serial () where + series _ = [()] + coseries rs d = [ \() -> b + | b <- rs d ] + +instance Serial Int where + series d = [(-d)..d] + coseries rs d = [ \i -> if i > 0 then f (N (i - 1)) + else if i < 0 then g (N (abs i - 1)) + else z + | z <- alts0 rs d, f <- alts1 rs d, g <- alts1 rs d ] + +instance Serial Integer where + series d = [ toInteger (i :: Int) + | i <- series d ] + coseries rs d = [ f . (fromInteger :: Integer->Int) + | f <- coseries rs d ] + +-- | 'N' is a wrapper for 'Integral' types that causes only non-negative values +-- to be generated. Generated functions of type @N a -> b@ do not distinguish +-- different negative values of @a@. +-- +-- See also 'Nat' and 'Natural'. +newtype N a = N a + deriving (Eq, Ord) + +instance Show a => Show (N a) where + show (N i) = show i + +instance (Integral a, Serial a) => Serial (N a) where + series d = map N [0..d'] + where + d' = fromInteger (toInteger d) + coseries rs d = [ \(N i) -> if i > 0 then f (N (i - 1)) + else z + | z <- alts0 rs d, f <- alts1 rs d ] + +type Nat = N Int +type Natural = N Integer + +instance Serial Float where + series d = [ encodeFloat sig exp + | (sig,exp) <- series d, + odd sig || sig==0 && exp==0 ] + coseries rs d = [ f . decodeFloat + | f <- coseries rs d ] + +instance Serial Double where + series d = [ frac (x :: Float) + | x <- series d ] + coseries rs d = [ f . (frac :: Double->Float) + | f <- coseries rs d ] + +frac :: (Real a, Fractional a, Real b, Fractional b) => a -> b +frac = fromRational . toRational + +instance Serial Char where + series d = take (d+1) ['a'..'z'] + coseries rs d = [ \c -> f (N (fromEnum c - fromEnum 'a')) + | f <- coseries rs d ] + +instance (Serial a, Serial b) => + Serial (a,b) where + series = series >< series + coseries rs = map uncurry . (coseries $ coseries rs) + +instance (Serial a, Serial b, Serial c) => + Serial (a,b,c) where + series = \d -> [(a,b,c) | (a,(b,c)) <- series d] + coseries rs = map uncurry3 . (coseries $ coseries $ coseries rs) + +instance (Serial a, Serial b, Serial c, Serial d) => + Serial (a,b,c,d) where + series = \d -> [(a,b,c,d) | (a,(b,(c,d))) <- series d] + coseries rs = map uncurry4 . (coseries $ coseries $ coseries $ coseries rs) + +uncurry3 :: (a->b->c->d) -> ((a,b,c)->d) +uncurry3 f (x,y,z) = f x y z + +uncurry4 :: (a->b->c->d->e) -> ((a,b,c,d)->e) +uncurry4 f (w,x,y,z) = f w x y z + +cons0 :: + a -> Series a +cons0 c _ = [c] + +cons1 :: Serial a => + (a->b) -> Series b +cons1 c d = [c z | d > 0, z <- series (d-1)] + +cons2 :: (Serial a, Serial b) => + (a->b->c) -> Series c +cons2 c d = [c y z | d > 0, (y,z) <- series (d-1)] + +cons3 :: (Serial a, Serial b, Serial c) => + (a->b->c->d) -> Series d +cons3 c d = [c x y z | d > 0, (x,y,z) <- series (d-1)] + +cons4 :: (Serial a, Serial b, Serial c, Serial d) => + (a->b->c->d->e) -> Series e +cons4 c d = [c w x y z | d > 0, (w,x,y,z) <- series (d-1)] + +alts0 :: Series a -> + Series a +alts0 as d = as d + +alts1 :: Serial a => + Series b -> Series (a->b) +alts1 bs d = if d > 0 then coseries bs (dec d) + else [\_ -> x | x <- bs d] + +alts2 :: (Serial a, Serial b) => + Series c -> Series (a->b->c) +alts2 cs d = if d > 0 then coseries (coseries cs) (dec d) + else [\_ _ -> x | x <- cs d] + +alts3 :: (Serial a, Serial b, Serial c) => + Series d -> Series (a->b->c->d) +alts3 ds d = if d > 0 then coseries (coseries (coseries ds)) (dec d) + else [\_ _ _ -> x | x <- ds d] + +alts4 :: (Serial a, Serial b, Serial c, Serial d) => + Series e -> Series (a->b->c->d->e) +alts4 es d = if d > 0 then coseries (coseries (coseries (coseries es))) (dec d) + else [\_ _ _ _ -> x | x <- es d] + +instance Serial Bool where + series = cons0 True \/ cons0 False + coseries rs d = [ \x -> if x then r1 else r2 + | r1 <- rs d, r2 <- rs d ] + +instance Serial a => Serial (Maybe a) where + series = cons0 Nothing \/ cons1 Just + coseries rs d = [ \m -> case m of + Nothing -> z + Just x -> f x + | z <- alts0 rs d , + f <- alts1 rs d ] + +instance (Serial a, Serial b) => Serial (Either a b) where + series = cons1 Left \/ cons1 Right + coseries rs d = [ \e -> case e of + Left x -> f x + Right y -> g y + | f <- alts1 rs d , + g <- alts1 rs d ] + +instance Serial a => Serial [a] where + series = cons0 [] \/ cons2 (:) + coseries rs d = [ \xs -> case xs of + [] -> y + (x:xs') -> f x xs' + | y <- alts0 rs d , + f <- alts2 rs d ] + +-- Thanks to Ralf Hinze for the definition of coseries +-- using the nest auxiliary. +instance (Serial a, Serial b) => Serial (a->b) where + series = coseries series + coseries rs d = + [ \ f -> g [ f a | a <- args ] + | g <- nest args d ] + where + args = series d + nest [] _ = [ \[] -> c + | c <- rs d ] + nest (a:as) _ = [ \(b:bs) -> f b bs + | f <- coseries (nest as) d ] + +-- | For customising the depth measure. Use with care! +depth :: Depth -> Depth -> Depth +depth d d' | d >= 0 = d'+1-d + | otherwise = error "SmallCheck.depth: argument < 0" + +dec :: Depth -> Depth +dec d | d > 0 = d-1 + | otherwise = error "SmallCheck.dec: argument <= 0" + +inc :: Depth -> Depth +inc d = d+1 + +-- show the extension of a function (in part, bounded both by +-- the number and depth of arguments) +instance (Serial a, Show a, Show b) => Show (a->b) where + show f = + if maxarheight == 1 + && sumarwidth + length ars * length "->;" < widthLimit then + "{"++( + concat $ intersperse ";" $ [a++"->"++r | (a,r) <- ars] + )++"}" + else + concat $ [a++"->\n"++indent r | (a,r) <- ars] + where + ars = take lengthLimit [ (show x, show (f x)) + | x <- series depthLimit ] + maxarheight = maximum [ max (height a) (height r) + | (a,r) <- ars ] + sumarwidth = sum [ length a + length r + | (a,r) <- ars] + indent = unlines . map (" "++) . lines + height = length . lines + (widthLimit,lengthLimit,depthLimit) = (80,20,3)::(Int,Int,Depth) diff --git a/examples/binarytries/BinaryTries.hs b/examples/binarytries/BinaryTries.hs --- a/examples/binarytries/BinaryTries.hs +++ b/examples/binarytries/BinaryTries.hs @@ -7,6 +7,7 @@ module BinaryTries where import Test.SmallCheck +import Test.SmallCheck.Series -- first representation diff --git a/examples/circuits/Mux.hs b/examples/circuits/Mux.hs --- a/examples/circuits/Mux.hs +++ b/examples/circuits/Mux.hs @@ -1,5 +1,6 @@ import List import Test.SmallCheck +import Test.SmallCheck.Series type Bit = Bool diff --git a/examples/logical/LogicProps.hs b/examples/logical/LogicProps.hs --- a/examples/logical/LogicProps.hs +++ b/examples/logical/LogicProps.hs @@ -7,6 +7,7 @@ module PropLogic where import Test.SmallCheck +import Test.SmallCheck.Series import List (nub) diff --git a/examples/numeric/NumProps.hs b/examples/numeric/NumProps.hs --- a/examples/numeric/NumProps.hs +++ b/examples/numeric/NumProps.hs @@ -5,6 +5,8 @@ ---------------------------------------- import Test.SmallCheck +import Test.SmallCheck.Series +import Test.SmallCheck.Property primes :: [Int] primes = sieve [2..] diff --git a/examples/regular/Regular.hs b/examples/regular/Regular.hs --- a/examples/regular/Regular.hs +++ b/examples/regular/Regular.hs @@ -5,6 +5,7 @@ import Monad (liftM) import Test.SmallCheck +import Test.SmallCheck.Series -- A data type of regular expressions. @@ -97,21 +98,7 @@ \/ cons1 cat \/ cons1 Rep -prop_readShow :: RE -> IO Bool -prop_readShow re = do - writeFile "tmp" (show re) - re' <- liftM read (readFile "tmp") - return (re'==re) +prop_readShow :: RE -> Bool +prop_readShow re = read (show re) == re -main = do - rule - putStrLn "Testing property involving IO. Always returns True?" - putStrLn "do\n\ - \ writeFile \"tmp\" (show re)\n\ - \ re' <- liftM read (readFile \"tmp\")\n\ - \ return (re'==re)" - rule - smallCheck 4 prop_readShow - where - rule = putStrLn - "----------------------------------------------------" +main = smallCheck 4 prop_readShow diff --git a/examples/run-examples.sh b/examples/run-examples.sh new file mode 100644 --- /dev/null +++ b/examples/run-examples.sh @@ -0,0 +1,3 @@ +find -iname '*.hs' \ + -exec grep -q ^main {} \; \ + -exec runghc {} \; diff --git a/smallcheck.cabal b/smallcheck.cabal --- a/smallcheck.cabal +++ b/smallcheck.cabal @@ -1,5 +1,5 @@ Name: smallcheck -Version: 0.5 +Version: 0.6 Cabal-Version: >= 1.6 License: BSD3 License-File: LICENSE @@ -10,11 +10,10 @@ Stability: Beta Category: Testing -Synopsis: Another lightweight testing library in Haskell. -Description: SmallCheck is similar to QuickCheck (Claessen and Hughes 2000-) but - instead of testing for a sample of randomly generated values, SmallCheck - tests properties for all the finitely many values up to some depth, - progressively increasing the depth used. +Synopsis: A property-based testing library +Description: SmallCheck is a testing library that allows to verify properties + for all test cases up to some depth. The test cases are generated + automatically by SmallCheck. Build-Type: Simple Extra-source-files: examples/numeric/NumProps.hs, examples/logical/LogicProps.hs, @@ -24,12 +23,15 @@ examples/imperative/StackMap.hs, examples/imperative/Compiler.hs, examples/listy/ListProps.hs, examples/regular/Regular.hs, examples/circuits/BitAdd.hs, examples/circuits/Mux.hs, examples/circuits/Sad.hs, - examples/binarytries/BinaryTries.hs - -Data-files: examples/numeric/README, examples/logical/README, examples/imperative/README, + examples/binarytries/BinaryTries.hs, + examples/numeric/README, examples/logical/README, examples/imperative/README, examples/listy/README, examples/regular/README, examples/circuits/README, - examples/binarytries/README, README.md, CREDITS.md, CHANGES.md + examples/binarytries/README, + README.md, CREDITS.md, CHANGES.md, + examples/run-examples.sh + + Source-repository head type: git location: git://github.com/feuerbach/smallcheck.git @@ -37,10 +39,18 @@ Source-repository this type: git location: git://github.com/feuerbach/smallcheck.git - tag: v0.5 + tag: v0.6 Library Build-Depends: base == 4.* - Exposed-modules: Test.SmallCheck + Exposed-modules: + Test.SmallCheck + Test.SmallCheck.Drivers + Test.SmallCheck.Property + Test.SmallCheck.Series + + if impl(ghc >= 7.2.1) + cpp-options: -DGENERICS + build-depends: ghc-prim >= 0.2, dlist >= 0.2 && < 0.6