smallcheck-0.6/0000755000000000000000000000000011671107470011657 5ustar0000000000000000smallcheck-0.6/CREDITS.md0000644000000000000000000000116411671107470013300 0ustar0000000000000000Credits ======= The original authors of SmallCheck are Colin Runciman, Matthew Naylor, and Fredrik Lindblad. Colin Runciman: > Thanks to Galois Connections, my hosts when I first wrote SmallCheck, > to users who have mailed me with feedback, to Ralf Hinze who suggested > 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) smallcheck-0.6/CHANGES.md0000644000000000000000000000256411671107470013260 0ustar0000000000000000Changes ======= Version 0.6 ----------- * 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.5 ----------- 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 ----------- Existential quantifiers now have unique variants for which two witnesses are reported when uniqueness fails. The over-generating coseries method for functions of functional arguments has been replaced; now 'coseries' and the 'alts' family take a series argument. Test counters are now Integers, not Ints. Ord and Eq are now derived for the N types. Examples extended. Version 0.2 ----------- 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.1 ----------- The differences from 0.0 are two fixes (space-fault, output buffering), an 'unsafe' but sometimes useful Testable (IO a) instance and additional examples. smallcheck-0.6/smallcheck.cabal0000644000000000000000000000413111671107470014750 0ustar0000000000000000Name: smallcheck Version: 0.6 Cabal-Version: >= 1.6 License: BSD3 License-File: LICENSE Author: Colin Runciman Maintainer: Roman Cheplyaka Homepage: https://github.com/feuerbach/smallcheck Bug-reports: https://github.com/feuerbach/smallcheck/issues Stability: Beta Category: Testing 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, examples/imperative/Interpreter.hs, examples/imperative/Syntax.hs, examples/imperative/Machine.hs, examples/imperative/Behaviour.hs, examples/imperative/Properties.hs, examples/imperative/Value.hs, 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, 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/run-examples.sh Source-repository head type: git location: git://github.com/feuerbach/smallcheck.git Source-repository this type: git location: git://github.com/feuerbach/smallcheck.git tag: v0.6 Library Build-Depends: base == 4.* 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 smallcheck-0.6/LICENSE0000644000000000000000000000261611671107470012671 0ustar0000000000000000All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. smallcheck-0.6/Setup.hs0000644000000000000000000000005611671107470013314 0ustar0000000000000000import Distribution.Simple main = defaultMain smallcheck-0.6/README.md0000644000000000000000000000304711671107470013142 0ustar0000000000000000SmallCheck: a property-based testing library for Haskell ======================================================== 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. Usefulness of such an approach to testing is based on the following observation: > If a program fails to meet its specification in some cases, it almost always > fails in some simple case. To get started with SmallCheck: * 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 [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 smallcheck-0.6/examples/0000755000000000000000000000000011671107470013475 5ustar0000000000000000smallcheck-0.6/examples/run-examples.sh0000755000000000000000000000011611671107470016452 0ustar0000000000000000find -iname '*.hs' \ -exec grep -q ^main {} \; \ -exec runghc {} \; smallcheck-0.6/examples/listy/0000755000000000000000000000000011671107470014641 5ustar0000000000000000smallcheck-0.6/examples/listy/ListProps.hs0000644000000000000000000000544311671107470017142 0ustar0000000000000000------------------------------------------------ -- Properties (some valid some invalid) of a few -- standard list-processing functions. -- A test module for SmallCheck. -- Colin Runciman, August 2006. -- Revised for 0.2, November 2006. ------------------------------------------------ module ListProps where import Test.SmallCheck -- properties about higher-order functions -- plausible-looking but invalid laws about folds prop_fold1 :: [Bool] -> Property prop_fold1 xs = not (null xs) ==> \f -> foldl1 f xs == foldr1 f xs prop_fold2 :: [Bool] -> [Bool] -> Property prop_fold2 xs ys = not (null xs) && not (null ys) ==> \f -> foldr1 f xs `f` foldr1 f ys == foldr1 f (xs++ys) -- properties using 'exists' with data and functional arguments -- invalid because depth-bound for zs same as for xs ys prop_union1 :: [Bool] -> [Bool] -> Property prop_union1 xs ys = exists $ \zs -> \b -> (b `elem` zs) == (b `elem` xs || b `elem` ys) -- valid variant: depth-bound doubled in existential prop_union2 :: [Bool] -> [Bool] -> Property prop_union2 xs ys = existsDeeperBy (*2) $ \zs -> \b -> (b `elem` zs) == (b `elem` xs || b `elem` ys) -- do magical span arguments exist? prop_span1 :: [Bool] -> [Bool] -> [Bool] -> Property prop_span1 xs ys zs = xs++ys == zs ==> exists $ \t -> (xs,ys) == span t zs -- deliberate mistake in final isPrefix equation isPrefix :: Ord a => [a] -> [a] -> Bool isPrefix [] ys = True isPrefix (x:xs) [] = False isPrefix (x:xs) (y:ys) = x==y || isPrefix xs ys -- this completeness property still holds isPrefixComplete :: String -> String -> Bool isPrefixComplete xs ys = isPrefix xs (xs ++ ys) -- but this existential soundness property fails isPrefixSound :: String -> String -> Property isPrefixSound xs ys = isPrefix xs ys ==> exists $ \xs' -> ys == (xs ++ xs') main :: IO () main = do test1 "\\xs -> not (null xs) ==>\n\ \ \\f -> foldl1 f xs == foldr1 f xs ?" prop_fold1 test1 "\\xs ys -> not (null xs) && not (null ys) ==>\n \ \ \\f -> foldr1 f xs `f` foldr1 f ys == foldr1 f (xs++ys) ?" prop_fold2 test1 "\\xs ys -> exists $ \\zs ->\n\ \ \\b -> (b `elem` zs) == (b `elem` xs || b `elem` ys) ?" prop_union1 test1 "\\xs ys -> existsDeeperBy (*2) $ \\zs ->\n\ \ \\b -> (b `elem` zs) == (b `elem` xs || b `elem` ys) ?" prop_union2 test1 "\\xs ys zs -> xs++ys==zs ==>\n\ \ exists $ \\t -> (xs,ys) == span t zs ?" prop_span1 test1 "\\xs ys -> isPrefix xs (xs++ys) ?" isPrefixComplete test1 "\\xs ys zs -> isPrefix xs ys ==>\n\ \ exists $ \\xs' -> ys == xs ++ xs' ?" isPrefixSound test1 :: Testable a => String -> a -> IO () test1 s t = do rule putStrLn s rule smallCheck 4 t where rule = putStrLn "----------------------------------------------------" smallcheck-0.6/examples/listy/README0000644000000000000000000000053111671107470015520 0ustar0000000000000000First see ../../README. In this directory, compile or interpret ListProps.main (SmallCheck is the only other module required) for a small selection of self-introducing tests of list-processing functions. The definition of isPrefix is deliberately incorrect: the completeness property still holds, but the existential soundness property fails. smallcheck-0.6/examples/circuits/0000755000000000000000000000000011671107470015322 5ustar0000000000000000smallcheck-0.6/examples/circuits/Sad.hs0000644000000000000000000000731111671107470016367 0ustar0000000000000000import Test.SmallCheck -- We take the following specification for the sum of absolute -- differences, and develop a circuit generator that has the same -- behaviour. sad :: [Int] -> [Int] -> Int sad xs ys = sum (map abs (zipWith (-) xs ys)) type Bit = Bool low :: Bit low = False high :: Bit high = True inv :: Bit -> Bit inv a = not a and2 :: Bit -> Bit -> Bit and2 a b = a && b or2 a b = a || b xor2 a b = a /= b xnor2 a b = a == b mux2 :: Bit -> Bit -> Bit -> Bit mux2 sel a b = (sel && b) || (not sel && a) bitAdd :: Bit -> [Bit] -> [Bit] bitAdd x [] = [x] bitAdd x (y:ys) = let (sum,carry) = halfAdd x y in sum:bitAdd carry ys halfAdd x y = (xor2 x y,and2 x y) binAdd :: [Bit] -> [Bit] -> [Bit] binAdd xs ys = binAdd' low xs ys binAdd' cin [] [] = [cin] binAdd' cin (x:xs) [] = bitAdd cin (x:xs) binAdd' cin [] (y:ys) = bitAdd cin (y:ys) binAdd' cin (x:xs) (y:ys) = let (sum,cout) = fullAdd cin x y in sum:binAdd' cout xs ys fullAdd cin a b = let (s0,c0) = halfAdd a b (s1,c1) = halfAdd cin s0 in (s1,xor2 c0 c1) binGte :: [Bit] -> [Bit] -> Bit binGte xs ys = binGte' high xs ys binGte' gin [] [] = gin binGte' gin (x:xs) [] = orl (gin:x:xs) binGte' gin [] (y:ys) = and2 gin (orl (y:ys)) binGte' gin (x:xs) (y:ys) = let gout = gteCell gin x y in binGte' gout xs ys gteCell gin x y = mux2 (xnor2 x y) x gin orl :: [Bit] -> Bit orl xs = tree or2 low xs binDiff :: [Bit] -> [Bit] -> [Bit] binDiff xs ys = let xs' = pad (length ys) xs ys' = pad (length xs) ys gte = binGte xs' ys' xs'' = map (xor2 (inv gte)) xs' ys'' = map (xor2 gte) ys' in init (binAdd' high xs'' ys'') pad :: Int -> [Bit] -> [Bit] pad n xs | m > n = xs | otherwise = xs ++ replicate (n-m) False where m = length xs tree :: (a -> a -> a) -> a -> [a] -> a tree f z [] = z tree f z [x] = x tree f z (x:y:ys) = tree f z (ys ++ [f x y]) binSum :: [[Bit]] -> [Bit] binSum xs = tree binAdd [] xs binSad :: [[Bit]] -> [[Bit]] -> [Bit] binSad xs ys = binSum (zipWith binDiff xs ys) num :: [Bit] -> Int num [] = 0 num (a:as) = fromEnum a + 2 * num as prop_binSad xs ys = sad (map num xs) (map num ys) == num (binSad xs ys) main = smallCheck 3 prop_binSad smallcheck-0.6/examples/circuits/BitAdd.hs0000644000000000000000000000072111671107470017005 0ustar0000000000000000import Test.SmallCheck and2 (a,b) = a && b xor2 (a,b) = a /= b halfAdd (a,b) = (sum,carry) where sum = xor2 (a,b) carry = and2 (a,b) bit False = 0 bit True = 1 num [] = 0 num (a:as) = bit a + 2 * num as bitAdd a [] = [a] bitAdd a (b:bs) = s : bitAdd c bs where (s,c) = halfAdd (a,b) prop_bitAdd a as = num (bitAdd a as) == bit a + num as main = smallCheck 8 prop_bitAdd smallcheck-0.6/examples/circuits/README0000644000000000000000000000302111671107470016176 0ustar0000000000000000First see ../../README. The programs in this directory define a number of different circuits. Some of these were originally written in Lava and were used to generate circuit netlists for external synthesis tools and propositional logic for external theorem provers. They have been slightly adapted as examples for SmallCheck, so that they do not depend on Lava. BitAdd.hs defines a trivial circuit that takes two inputs, a bit and a bit-vector (i.e. a list of bits), and returns a bit-vector containing the sum of the two. Using SmallCheck, it is straightforward to verify that the circuit behaves correctly for all bit-vector inputs up to the given size. Sad.hs defines a more complicated circuit that works over two lists of lists of bits, but verification with SmallCheck is just as simple and useful as before. Mux.hs defines a simple multiplexor and a more complicated variant that is optimised for Xilinx FPGAs. Originally, the correctness of the more complicated version was argued by verifying its equivalence with the simpler version using an external SAT solver. However, using SmallCheck, more general properties can be expressed, and so each circuit can be verified independently in terms of Haskell's list indexing operator (!!). The correctness properties are again easy to express in SmallCheck, but their antecedents filter out so many test cases as to make them inefficient. This problem is resolved by writing a custom test-case generator using SmallCheck's "Serial" class. Matthew Naylor, University of York, 22nd Jan 2007. smallcheck-0.6/examples/circuits/Mux.hs0000644000000000000000000000702611671107470016434 0ustar0000000000000000import List import Test.SmallCheck import Test.SmallCheck.Series type Bit = Bool unaryMux :: [Bit] -> [[Bit]] -> [Bit] unaryMux sel xs = map (tree (||)) $ transpose $ zipWith (\s x -> map (s &&) x) sel xs tree :: (a -> a -> a) -> [a] -> a tree f [x] = x tree f (x:y:ys) = tree f (ys ++ [f x y]) decode :: [Bit] -> [Bit] decode [] = [True] decode [x] = [not x,x] decode (x:xs) = concatMap (\y -> [not x && y,x && y]) rest where rest = decode xs binaryMux :: [Bit] -> [[Bit]] -> [Bit] binaryMux sel xs = unaryMux (decode sel) xs bitMux2 :: Bit -> Bit -> Bit -> Bit bitMux2 sel x y = (sel && y) || (not sel && x) muxf5 = bitMux2 muxf6 = bitMux2 busMux2 :: Bit -> [Bit] -> [Bit] -> [Bit] busMux2 sel xs ys = zipWith (bitMux2 sel) xs ys bitMux8 :: [Bit] -> [Bit] -> Bit bitMux8 _ [x] = x bitMux8 (s0:_) [x0,x1] = bitMux2 s0 x0 x1 bitMux8 (s0:s1:_) [x0,x1,x2,x3] = muxf5 s1 (bitMux8 [s0] [x0,x1]) (bitMux8 [s0] [x2,x3]) bitMux8 (s0:s1:s2:_) [x0,x1,x2,x3,x4,x5,x6,x7] = muxf6 s2 (bitMux8 [s0,s1] [x0,x1,x2,x3]) (bitMux8 [s0,s1] [x4,x5,x6,x7]) bitMux8 sels xs = bitMux8 (take n sels) (pad m xs) where n = log2 (length xs) m = 2 ^ n log2 :: Int -> Int log2 n = length (takeWhile (< n) (iterate (*2) 1)) pad :: Int -> [Bit] -> [Bit] pad n xs | m > n = xs | otherwise = xs ++ replicate (n-m) False where m = length xs bitMux :: [Bit] -> [Bit] -> Bit bitMux sels [x] = x bitMux sels xs = bitMux (drop 3 sels) ys where ys = zipWith bitMux8 (repeat (take 3 sels)) (groupn 8 xs) groupn :: Int -> [a] -> [[a]] groupn n [] = [] groupn n xs = take n xs : groupn n (drop n xs) binaryMux' :: [Bit] -> [[Bit]] -> [Bit] binaryMux' sel = map (bitMux sel) . transpose num :: [Bit] -> Int num [] = 0 num (a:as) = fromEnum a + 2 * num as -- Property 0: binaryMux is correct prop_mux0 sel xs = length xs == 2 ^ length sel && all ((== length (head xs)) . length) xs ==> binaryMux sel xs == xs !! num sel -- But this is inefficient as most of the test cases do not meet the -- antecedent. Instead, we can define a custom generator in which -- the number of inputs grows exponentially (i.e. 2^) with respect to -- the width of the address word. newtype Word = Word { bits :: [Bit] } deriving Show newtype File = File { wrds :: [Word] } deriving Show instance Serial Word where series n = map Word $ sequence (replicate n [False,True]) instance Serial File where series n = map File $ sequence $ replicate (2^n) ws where ws = series n :: [Word] prop_mux0' sel xs = xs' !! num sel' == binaryMux sel' xs' where sel' = bits sel xs' = map bits (wrds xs) -- Property 1: binaryMux' is correct prop_mux1 sel xs = xs' !! num sel' == binaryMux' sel' xs' where sel' = bits sel xs' = map bits (wrds xs) main = smallCheck 2 prop_mux1 smallcheck-0.6/examples/numeric/0000755000000000000000000000000011671107470015137 5ustar0000000000000000smallcheck-0.6/examples/numeric/README0000644000000000000000000000130411671107470016015 0ustar0000000000000000First see ../../README. In this directory, NumProps.hs illustrates the use of test series for natural numbers, either by explicit signatures including Nat (or Natural) or by use of the N constructor. It also illustrates use of floating-point series. Compile or interpret NumProps (SmallCheck is the only other module required) and run main for a small selection of self-introducing tests -- a couple about natural numbers and primes, and a couple about floating point numbers. For version 0.3 the second property about primes has been strengthened by making the existence unique. The restriction on the exponent list was prompted by reports of non-uniqueness when the 'exists1' version was first tested. smallcheck-0.6/examples/numeric/NumProps.hs0000644000000000000000000000317611671107470017265 0ustar0000000000000000---------------------------------------- -- Illustrating numerics in SmallCheck -- Colin Runciman, November 2006. -- Modified for SmallCheck 0.3, May 2008 ---------------------------------------- import Test.SmallCheck import Test.SmallCheck.Series import Test.SmallCheck.Property primes :: [Int] primes = sieve [2..] where sieve (p:xs) = p : filter (noFactorIn primes) xs noFactorIn (p:ps) x = p*p > x || x `mod` p > 0 && noFactorIn ps x -- using natural numbers prop_primes1 :: Nat -> Property prop_primes1 (N n) = n > 1 ==> forAll (`take` primes) $ \p -> p `mod` n > 0 || n == p prop_primes2 :: Nat -> Property prop_primes2 (N n) = n > 0 ==> exists1 $ \exponents -> (null exponents || last exponents /= N 0) && n == product (zipWith power primes exponents) where power p (N e) = product (replicate e p) -- using floating point numbers prop_logExp :: Float -> Bool prop_logExp x = exp (log x) == x prop_recipRecip :: Float -> Bool prop_recipRecip x = 1.0 / (1.0 / x) == x main :: IO () main = do test1 "\\(N n) -> n > 1 ==> forAll (`take` primes) $ \\p ->\n\ \ p `mod` n > 0 || n == p" prop_primes1 test1 "\\(N n) -> n > 0 ==> exists1 $ \\exponents ->\n\ \ (null exponents || last exponents /= N 0) &&\n\ \ n == product (zipWith power primes exponents)" prop_primes2 test1 "\\x -> exp (log x) == x" prop_logExp test1 "\\x -> 1.0 / (1.0 / x) == x" prop_recipRecip test1 :: Testable a => String -> a -> IO () test1 s t = do rule putStrLn s rule smallCheck 8 t where rule = putStrLn "----------------------------------------------------" smallcheck-0.6/examples/binarytries/0000755000000000000000000000000011671107470016030 5ustar0000000000000000smallcheck-0.6/examples/binarytries/BinaryTries.hs0000644000000000000000000000370211671107470020621 0ustar0000000000000000------------------------------------------------- -- Binary tries representing sets of bitstrings. -- A test module for SmallCheck. -- Colin Runciman, May 2008. ------------------------------------------------- module BinaryTries where import Test.SmallCheck import Test.SmallCheck.Series -- first representation data BT1 = E | B Bool BT1 BT1 deriving Show instance Serial BT1 where series = cons0 E \/ cons3 B contains1 :: BT1 -> [Bool] -> Bool contains1 E _ = False contains1 (B b _ _) [] = b contains1 (B _ z _) (False:s) = contains1 z s contains1 (B _ _ o) (True :s) = contains1 o s prop_uniqueBT1 :: ([Bool]->Bool) -> Property prop_uniqueBT1 f = exists1DeeperBy (+1) $ \bt -> contains1 bt === f -- second representation data BT2 = E2 | NE BT2' deriving Show data BT2' = T | O Bool BT2' | I Bool BT2' | OI Bool BT2' BT2' deriving Show instance Serial BT2 where series = cons0 E2 \/ cons1 NE instance Serial BT2' where series = cons0 T \/ cons2 O \/ cons2 I \/ cons3 OI contains2 :: BT2 -> [Bool] -> Bool contains2 = contains1 . convert convert :: BT2 -> BT1 convert E2 = E convert (NE bt') = convert' bt' convert' :: BT2' -> BT1 convert' T = B True E E convert' (O b z') = B b (convert' z') E convert' (I b o' ) = B b E (convert' o') convert' (OI b o' z') = B b (convert' z') (convert' o') prop_uniqueBT2 :: ([Bool]->Bool) -> Property prop_uniqueBT2 f = exists1DeeperBy (+1) $ \bt -> contains2 bt === f (===) :: Eq b => (a->b) -> (a->b) -> a -> Bool f === g = \x -> f x == g x main :: IO () main = do test1 "\\f -> exists1DeeperBy (+1) $ \\bt1 -> contains1 bt1 === f ?" prop_uniqueBT1 test1 "\\f -> exists1DeeperBy (+1) $ \\bt1 -> contains2 bt2 === f ?" prop_uniqueBT2 test1 :: Testable a => String -> a -> IO () test1 s t = do rule putStrLn s rule smallCheck 2 t where rule = putStrLn "----------------------------------------------------------" smallcheck-0.6/examples/binarytries/README0000644000000000000000000000107711671107470016715 0ustar0000000000000000First see ../../README. In this directory, BinaryTries.hs illustrates properties quantified over functions and requiring the unique existence of a data-structure. Two different trie representations are defined for sets of bitstrings. The properties state that each set has a unique representation as a trie -- true for the second representation, but not for the first. The properties are specified using functions with boolean results as a pure representation of sets, independent of any data structure. Compile or interpret BinaryTries.main for the self-introducing tests. smallcheck-0.6/examples/imperative/0000755000000000000000000000000011671107470015642 5ustar0000000000000000smallcheck-0.6/examples/imperative/Behaviour.hs0000644000000000000000000000110011671107470020112 0ustar0000000000000000module Behaviour(Trace(..),(+++),approx) where data Trace a = Step (Trace a) | a :> Trace a | End | Crash deriving (Eq, Show) (+++) :: Trace a -> Trace a -> Trace a Step s +++ t = Step (s +++ t) (x :> s) +++ t = x :> (s +++ t) End +++ t = t Crash +++ t = Crash approx :: Eq a => Int -> Trace a -> Trace a -> Bool approx 0 _ _ = True approx n (a :> s) (b :> t) = a == b && approx (n-1) s t approx n (Step s) (Step t) = approx (n-1) s t approx n End End = True approx n Crash Crash = True approx n _ _ = False smallcheck-0.6/examples/imperative/Machine.hs0000644000000000000000000000273611671107470017552 0ustar0000000000000000module Machine(Instruction(..), exec) where import Array import Behaviour import Value data Instruction = Push Value | Pop | Fetch Int | Store Int | Instr1 Op1 | Instr2 Op2 | Display | Jump Int | JumpUnless Int | Halt deriving (Eq, Show) exec :: [Instruction] -> Trace Value exec instrs = run 1 [] where size = length instrs memory = array (1,size) ([1..] `zip` instrs) run pc stack = if pc < 1 || size < pc then Crash else case (memory ! pc, stack) of (Push x , stack) -> run pc' (x : stack) (Pop , _ : stack) -> run pc' stack (Fetch n , stack) | length stack > n -> run pc' (stack !! n : stack) (Store n , x : stack) | length stack >= n -> run pc' (take (n-1) stack ++ x : drop n stack) (Instr1 op1 , i : stack) -> run pc' (uno op1 i : stack) (Instr2 op2 , i : j : stack) -> run pc' (duo op2 j i : stack) (Display , i : stack) -> i :> run pc' stack (Jump n , stack) -> step n (run (pc' + n) stack) (JumpUnless n , Log b : stack) | b -> run pc' stack | otherwise -> step n (run (pc' + n) stack) (Halt , stack) -> End _ -> Crash where pc' = pc + 1 step :: Int -> Trace Value -> Trace Value step n t | n < 0 = Step t | otherwise = t smallcheck-0.6/examples/imperative/Compiler.hs0000644000000000000000000000227111671107470017752 0ustar0000000000000000module Compiler(compile) where import Machine import Syntax import StackMap import Value compile :: Command -> [Instruction] compile c = replicate (depth sm) (Push Wrong) ++ compObey sm c ++ [Halt] where sm = stackMap c compObey :: StackMap -> Command -> [Instruction] compObey sm Skip = [] compObey sm (v := e) = compEval sm e ++ [Store (location sm v + 1)] compObey sm (c1 :-> c2) = compObey sm c1 ++ compObey sm c2 compObey sm (If e c1 c2) = compEval sm e ++ [JumpUnless (length isc1 + 1)] ++ isc1 ++ [Jump (length isc2)] ++ isc2 where isc1 = compObey sm c1 isc2 = compObey sm c2 compObey sm (While e c) = ise ++ [JumpUnless (length isc + 1)] ++ isc ++ [Jump (negate (length isc + 1 + length ise + 1))] where ise = compEval sm e isc = compObey sm c compObey sm (Print e) = compEval sm e ++ [Display] compEval :: StackMap -> Expr -> [Instruction] compEval sm (Val v) = [Push v] compEval sm (Var v) = [Fetch (location sm v)] compEval sm (Uno op1 e) = -- was op before arg eval compEval sm e ++ [Instr1 op1] compEval sm (Duo op2 e1 e2) = -- was op before arg evals compEval sm e1 ++ compEval (push sm) e2 ++ [Instr2 op2] smallcheck-0.6/examples/imperative/README0000644000000000000000000000101111671107470016513 0ustar0000000000000000First see ../../README. This directory gives the largest illustrative example. We test for congruence between an interpreter and compiler for a small imperative language. The example is adapted from an original using QuickCheck, as described in the lecture notes for AFP'02 (LNCS 2638). Compared with the simpler example in ../logic, here specialised instances are used to restrict the input space to programs in a standard form. Run Properties.main and compare the rate of growth for the last two properties tested. smallcheck-0.6/examples/imperative/StackMap.hs0000644000000000000000000000157011671107470017704 0ustar0000000000000000module StackMap where import Syntax import List( union ) type StackMap = (Int,[Name]) stackMap :: Command -> StackMap stackMap c = (0, comVars c) push :: StackMap -> StackMap push (n, vars) = (n+1, vars) pop :: StackMap -> StackMap pop (n, vars) = (n-1, vars) location :: StackMap -> Name -> Int location (n, vars) v = n + length (takeWhile (/=v) vars) depth :: StackMap -> Int depth (n, vars) = n + length vars expVars :: Expr -> [Name] expVars (Var v) = [v] expVars (Val _) = [] expVars (Uno _ a) = expVars a expVars (Duo _ a b) = expVars a `union` expVars b comVars :: Command -> [Name] comVars Skip = [] comVars (x := e) = [x] `union` expVars e comVars (c1 :-> c2) = comVars c1 `union` comVars c2 comVars (If e c1 c2) = expVars e `union` comVars c1 `union` comVars c2 comVars (While e c) = expVars e `union` comVars c comVars (Print e) = expVars e smallcheck-0.6/examples/imperative/Syntax.hs0000644000000000000000000000051611671107470017466 0ustar0000000000000000module Syntax(Name, Expr(..), Command(..)) where import Value type Name = String data Expr = Var Name | Val Value | Uno Op1 Expr | Duo Op2 Expr Expr deriving (Eq, Show) data Command = Skip | Name := Expr | Command :-> Command | If Expr Command Command | While Expr Command | Print Expr deriving (Eq, Show) smallcheck-0.6/examples/imperative/Properties.hs0000644000000000000000000001117011671107470020332 0ustar0000000000000000import Behaviour import Interpreter import Compiler import Machine import Syntax import Value import Test.SmallCheck ------------- ------------- -- In the abstract syntax variables are just strings, -- but we do not want to enumerate all lists of characters. -- Just a couple of distinct names. newtype VarName = VarName Name instance Serial VarName where series = const [VarName [c] | c <- ['a'..'b']] var :: VarName -> Expr var (VarName v) = Var v assign :: VarName -> Expr -> Command assign (VarName v) e = (v := e) -- Uses of depth 0 ensure that all occurrences of variables -- or literals are treated as zero-depth atoms. -- The rest is completely standard, but for the use of -- 'var' for Var and 'assign' for Assign. instance Serial Value where series = cons0 Wrong \/ cons1 Log . depth 0 \/ cons1 Num . depth 0 instance Serial Op1 where series = const [Not, Minus] instance Serial Op2 where series = const [And, Or, Eq, Less, LessEq, Add, Sub, Mul, Div, Mod] instance Serial Expr where series = cons1 var . depth 0 \/ cons1 Val . depth 0 \/ cons2 Uno \/ cons3 Duo instance Serial Command where series = cons0 Skip \/ cons1 Print \/ cons2 assign \/ cons2 (:->) \/ cons3 If \/ cons2 While ----------------- ------------------- -- If we want a series for a subset of the values in -- a given type, one way to define it is via a newtype. -- Here, expressions without variables. newtype ClosedExpr = Closed Expr deriving Show instance Serial ClosedExpr where series = cons1 val . depth 0 \/ cons2 uno \/ cons3 duo where val v = Closed (Val v) uno op (Closed e) = Closed (Uno op e) duo op (Closed e1) (Closed e2) = Closed (Duo op e1 e2) ----------------- ----------------- -- The space of all commands grows very quickly with depth, -- and many syntactically legal commands are bound to fail. -- Here we define a restricted subset of commands in a -- 'standard form': -- -- Skip only occurs as an else-alternative -- -- Print is only applied to simple variables -- -- Only integer values are assigned to variables. -- -- If and While conditions are compound comparisons. newtype StdCommand = Std Command deriving Show instance Serial StdCommand where series = cons1 print' \/ cons2 assign' \/ cons2 seq' \/ cons3 if' \/ cons2 while' where print' (VarName v) = Std (Print (Var v)) assign' (VarName v) (I e) = Std (v := e) seq' (Std c0) (Std c1) = Std (c0 :-> c1) if' (B e) (Std c0) (SkipOrStd c1) = Std (If e c0 c1) while' (B e) (Std c) = Std (While e c) newtype SkipOrStdCommand = SkipOrStd Command instance Serial SkipOrStdCommand where series = cons0 skip \/ cons1 std . depth 0 where skip = SkipOrStd Skip std (Std c) = SkipOrStd c newtype IExpr = I Expr instance Serial IExpr where series = cons1 var' . depth 0 \/ cons1 val' . depth 0 \/ cons1 uno' \/ cons3 duo' where var' (VarName v) = I (Var v) val' i = I (Val (Num i)) uno' (I e) = I (Uno Minus e) duo' (I2 d) (I e0) (I e1) = I (Duo d e0 e1) newtype IOp2 = I2 Op2 instance Serial IOp2 where series = const [I2 op | op <- [Add, Sub, Mul, Div, Mod]] newtype BExpr = B Expr instance Serial BExpr where series = cons1 uno' \/ cons3 duo' \/ cons3 cmp' where uno' (B e) = B (Uno Not e) duo' (B2 d) (B e0) (B e1) = B (Duo d e0 e1) cmp' (C2 c) (I e0) (I e1) = B (Duo c e0 e1) newtype BOp2 = B2 Op2 instance Serial BOp2 where series = const [B2 op | op <- [And,Or]] newtype COp2 = C2 Op2 instance Serial COp2 where series = const [C2 op | op <- [Eq,Less,LessEq]] -------- -------- newtype Approx = Approx Int deriving Show instance Serial Approx where series d = [Approx d] (=~=) :: Eq a => Trace a -> Trace a -> Approx -> Bool s =~= t = \(Approx d) -> approx d s t ----------------- ------------------ prop_Congruence :: Command -> Property prop_Congruence p = t1 /= Crash || t2 /= Crash ==> (t1 =~= t2) where t1 = obey p t2 = exec (compile p) prop_StdCongruence :: StdCommand -> Property prop_StdCongruence (Std p) = prop_Congruence p main :: IO () main = do putStrLn "-- congruence for all programs:" smallCheck 2 prop_Congruence putStrLn "-- congruence for standard-form programs:" smallCheck 2 prop_StdCongruence smallcheck-0.6/examples/imperative/Value.hs0000644000000000000000000000206111671107470017251 0ustar0000000000000000module Value(Value(..), Op1(..), Op2(..), uno, duo) where data Value = Num Int | Log Bool | Wrong deriving (Eq, Show) data Op1 = Not | Minus deriving (Eq, Show) data Op2 = And | Or | Mul | Add | Sub | Div | Mod | Less | LessEq | Eq deriving (Eq, Show) uno :: Op1 -> Value -> Value uno Not (Log b) = Log (not b) uno Minus (Num n) = Num (negate n) uno _ _ = Wrong duo :: Op2 -> Value -> Value -> Value duo And (Log a) (Log b) = Log (a && b) duo Or (Log a) (Log b) = Log (a || b) duo Eq (Log a) (Log b) = Log (a == b) duo Mul (Num m) (Num n) = Num (m * n) duo Add (Num m) (Num n) = Num (m + n) duo Sub (Num m) (Num n) = Num (m - n) duo Div (Num m) (Num n) | n /= 0 = Num (m `div` n) duo Mod (Num m) (Num n) | n /= 0 = Num (m `mod` n) duo Less (Num m) (Num n) = Log (m < n) duo LessEq (Num m) (Num n) = Log (m <= n) duo Eq (Num m) (Num n) = Log (m == n) duo _ _ _ = Wrong smallcheck-0.6/examples/imperative/Interpreter.hs0000644000000000000000000000243711671107470020507 0ustar0000000000000000module Interpreter(obey) where import Syntax import Behaviour import Value type Env = [(Name,Value)] obey :: Command -> Trace Value obey p = fst (run p []) look :: Name -> Env -> Value look x s = maybe Wrong id (lookup x s) update :: Name -> Value -> Env -> Env update x a s = (x,a) : filter (\(y,_) -> y/=x) s run :: Command -> Env -> (Trace Value, Env) run Skip s = (End, s) run (x := e) s = (End, update x (eval e s) s) run (p :-> q) s = let (outp, sp) = run p s (outq, sq) = run q sp in (outp +++ outq, sq) run (If e p q) s = case eval e s of -- was True -> q, False -> p Log True -> run p s Log False -> run q s _ -> (Crash, s) run (While e p) s = case eval e s of Log True -> let (outp,sp) = run p s (outw,sw) = run (While e p) sp in (outp +++ Step outw, sw) Log False -> (End, s) _ -> (Crash, s) run (Print e) s = (eval e s :> End, s) eval :: Expr -> Env -> Value eval (Var x) s = look x s eval (Val v) s = v eval (Uno op a) s = uno op (eval a s) eval (Duo op a b) s = duo op (eval a s) (eval b s) smallcheck-0.6/examples/regular/0000755000000000000000000000000011671107470015136 5ustar0000000000000000smallcheck-0.6/examples/regular/README0000644000000000000000000000066011671107470016020 0ustar0000000000000000First see ../../README. In this directory, Regular.hs illustrates a test involving IO -- writing and reading expressions to/from a file. The use of 'smart constructors' in the series definition is necessary for the property to hold, but does *not* reduce the number of tests -- rather, there are duplicated tests for the same expressions generated in different ways. Compile or interpret Regular.main for a self-introducing test. smallcheck-0.6/examples/regular/Regular.hs0000644000000000000000000000524211671107470017076 0ustar0000000000000000module Regular where import Char (isAlpha) import List (intersperse) import Monad (liftM) import Test.SmallCheck import Test.SmallCheck.Series -- A data type of regular expressions. data RE = Emp | Lam | Sym Char | Alt [RE] | Cat [RE] | Rep RE deriving Eq isEmp, isLam, isSym, isCat, isAlt, isRep :: RE -> Bool isEmp Emp = True isEmp _ = False isLam Lam = True isLam _ = False isSym (Sym _) = True isSym _ = False isAlt (Alt _) = True isAlt _ = False isCat (Cat _) = True isCat _ = False isRep (Rep _) = True isRep _ = False -- Syms may be used to represent terminals or variables. -- Using cat and alt instead of Cat and Alt ensures that: -- (1) Cat and Alt arguments are multi-item lists; -- (2) items in Cat arguments are not Cats; -- (3) items in Alt arguments are not Alts. cat :: [RE] -> RE cat [] = Lam cat [x] = x cat xs = Cat (concatMap catList xs) where catList (Cat ys) = ys catList z = [z] alt :: [RE] -> RE alt [] = Emp alt [x] = x alt xs = Alt (concatMap altList xs) where altList (Alt ys) = ys altList z = [z] instance Read RE where readsPrec _ s = [rest s [[[]]]] rest :: String -> [[[RE]]] -> (RE,String) rest "" ( a:as) = if null as then (a2re a,"") else wrong rest ('+':s) ((c:a):as) = if null c then wrong else rest s (([]:c:a):as) rest ('*':s) ((c:a):as) = case c of [] -> wrong (x:xs) -> rest s (((Rep x:xs):a):as) rest ('0':s) ((c:a):as) = rest s (((Emp:c):a):as) rest ('1':s) ((c:a):as) = rest s (((Lam:c):a):as) rest ('(':s) as = rest s ([[]]:as) rest (')':s) (a:as) = case as of [] -> wrong ((c:a'):as') -> rest s (((a2re a:c):a'):as') rest (' ':s) as = rest s as rest (v :s) ((c:a):as) = if isAlpha v then rest s (((Sym v:c):a):as) else if null as then (a2re (c:a),v:s) else wrong a2re :: [[RE]] -> RE a2re = alt . reverse . map (cat . reverse) wrong = error "unreadable RE" instance Show RE where show Emp = "0" show Lam = "1" show (Sym c) = [c] show (Alt xs) = concat (intersperse "+" (map show xs)) show (Cat xs) = concatMap (showBrackIf isAlt) xs show (Rep x) = showBrackIf (\x -> isCat x || isAlt x) x ++ "*" showBrackIf p x = ['(' | q] ++ show x ++ [')' | q] where q = p x instance Serial RE where series = cons0 Emp \/ cons0 Lam \/ cons1 Sym . depth 0 \/ cons1 alt \/ cons1 cat \/ cons1 Rep prop_readShow :: RE -> Bool prop_readShow re = read (show re) == re main = smallCheck 4 prop_readShow smallcheck-0.6/examples/logical/0000755000000000000000000000000011671107470015107 5ustar0000000000000000smallcheck-0.6/examples/logical/LogicProps.hs0000644000000000000000000000656211671107470017535 0ustar0000000000000000---------------------------------------------------- -- Propositional formulae, satisfiable, tautologous. -- A test module for SmallCheck. -- Colin Runciman, August 2006. ---------------------------------------------------- module PropLogic where import Test.SmallCheck import Test.SmallCheck.Series import List (nub) data Prop = Var Name | Not Prop | And Prop Prop | Or Prop Prop | Imp Prop Prop instance Show Prop where show p = case p of Var n -> show n Not q -> "~"++show' q And q r -> show' q++"&"++show' r Or q r -> show' q++"|"++show' r Imp q r -> show' q++"=>"++show' r where show' x = if priority p > priority x then "("++show x++")" else show x priority (Var _) = 5 priority (Not _) = 4 priority (And _ _) = 3 priority (Or _ _) = 2 priority (Imp _ _) = 1 data Name = P | Q | R deriving (Eq,Show) type Env = Name -> Bool eval :: Prop -> Env -> Bool eval (Var v) env = env v eval (Not p) env = not (eval p env) eval (And p q) env = eval p env && eval q env eval (Or p q) env = eval p env || eval q env eval (Imp p q) env = eval p env <= eval q env envsFor :: Prop -> [Env] envsFor p = foldr bind [const False] (nub (varsOf p)) where bind v es = concat [ [\x -> x==v || e x, e] | e <- es ] varsOf :: Prop -> [Name] varsOf (Var v) = [v] varsOf (Not p) = varsOf p varsOf (And p q) = varsOf p ++ varsOf q varsOf (Or p q) = varsOf p ++ varsOf q varsOf (Imp p q) = varsOf p ++ varsOf q tautologous :: Prop -> Bool tautologous p = all (eval p) (envsFor p) satisfiable :: Prop -> Bool satisfiable p = any (eval p) (envsFor p) instance Serial Name where series = cons0 P \/ cons0 Q \/ cons0 R coseries rs d = [ \n -> case n of P -> x ; Q -> y ; R -> z | x <- alts0 rs d, y <- alts0 rs d, z <- alts0 rs d ] instance Serial Prop where series = cons1 Var \/ cons1 Not \/ cons2 And \/ cons2 Or \/ cons2 Imp ---------------------- --------------------- prop_taut1 :: Prop -> Property prop_taut1 p = tautologous p ==> \e -> eval p e prop_taut2 :: Prop -> Property prop_taut2 p = not (tautologous p) ==> exists (\e -> not $ eval p e) prop_sat1 :: Prop -> Env -> Property prop_sat1 p e = eval p e ==> satisfiable p prop_sat2 :: Prop -> Property prop_sat2 p = satisfiable p ==> exists (\e -> eval p e) prop_tautSat1 :: Prop -> Property prop_tautSat1 p = not (tautologous p) ==> satisfiable (Not p) prop_tautSat2 :: Prop -> Property prop_tautSat2 p = not (satisfiable p) ==> tautologous (Not p) main :: IO () main = do test1 "\\p -> tautologous p ==> \\e -> eval p e ?" prop_taut1 test1 "\\p -> not (tautologous p) ==>\n\ \ exists (\\e -> not $ eval p e) ?" prop_taut2 test1 "\\p e -> eval p e ==> satisfiable p ?" prop_sat1 test1 "\\p -> satisfiable p ==> exists (\\e -> eval p e) ?" prop_sat2 test1 "\\p -> not (tautologous p) ==> satisfiable (Not p) ?" prop_tautSat1 test1 "\\p -> not (satisfiable p) ==> tautologous (Not p) ?" prop_tautSat2 test1 :: Testable a => String -> a -> IO () test1 s t = do rule putStrLn s rule smallCheck 3 t where rule = putStrLn "----------------------------------------------------" smallcheck-0.6/examples/logical/README0000644000000000000000000000047511671107470015775 0ustar0000000000000000First see ../../README. In this directory, LogicProps.hs illustrates the basic way to define Serial instances of your own types, and hence Testable properties of functions over them. Compile or interpret LogicProps.main (SmallCheck is the only other module required) for a small selection of self-introducing tests. smallcheck-0.6/Test/0000755000000000000000000000000011671107470012576 5ustar0000000000000000smallcheck-0.6/Test/SmallCheck.hs0000644000000000000000000000433111671107470015141 0ustar0000000000000000-------------------------------------------------------------------- -- | -- Module : Test.SmallCheck -- Copyright : (c) Colin Runciman et al. -- License : BSD3 -- Maintainer: Roman Cheplyaka -- -- 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 ( -- * Constructing tests -- | 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". Testable, Property, property, -- ** Existential quantification -- | 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' exists, exists1, existsDeeperBy, exists1DeeperBy, -- ** Conditioning (==>), -- * 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 import Test.SmallCheck.Property import Test.SmallCheck.Drivers smallcheck-0.6/Test/SmallCheck/0000755000000000000000000000000011671107470014604 5ustar0000000000000000smallcheck-0.6/Test/SmallCheck/Drivers.hs0000644000000000000000000000544111671107470016562 0ustar0000000000000000-------------------------------------------------------------------- -- | -- 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 smallcheck-0.6/Test/SmallCheck/Property.hs0000644000000000000000000001421111671107470016763 0ustar0000000000000000-------------------------------------------------------------------- -- | -- 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 = [] } smallcheck-0.6/Test/SmallCheck/Series.hs0000644000000000000000000003214211671107470016374 0ustar0000000000000000-------------------------------------------------------------------- -- | -- 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)