diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..9c61b87 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +(The following is the 3-clause BSD license.) + +Copyright (c) 2000-2017, Koen Claessen +Copyright (c) 2006-2008, Björn Bringert +Copyright (c) 2009-2017, Nick Smallbone + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +- 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. +- Neither the names of the copyright owners nor the names of the + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"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 COPYRIGHT +OWNER 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. diff --git a/QuickCheck.cabal b/QuickCheck.cabal new file mode 100644 index 0000000..357a6b7 --- /dev/null +++ b/QuickCheck.cabal @@ -0,0 +1,171 @@ +Name: QuickCheck +Version: 2.10.1 +Cabal-Version: >= 1.8 +Build-type: Simple +License: BSD3 +License-file: LICENSE +Copyright: 2000-2017 Koen Claessen, 2006-2008 Björn Bringert, 2009-2017 Nick Smallbone +Author: Koen Claessen +Maintainer: Nick Smallbone ; see also QuickCheck mailing list (https://groups.google.com/forum/#!forum/haskell-quickcheck) +Bug-reports: https://github.com/nick8325/quickcheck/issues +Tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC >= 7.4 +Homepage: https://github.com/nick8325/quickcheck +Category: Testing +Synopsis: Automatic testing of Haskell programs +Description: + QuickCheck is a library for random testing of program properties. + . + The programmer provides a specification of the program, in the form of + properties which functions should satisfy, and QuickCheck then tests that the + properties hold in a large number of randomly generated cases. + . + Specifications are expressed in Haskell, using combinators defined in the + QuickCheck library. QuickCheck provides combinators to define properties, + observe the distribution of test data, and define test data generators. + . + The + explains how to write generators and properties; + it is out-of-date in some details but still full of useful advice. + . + A user of QuickCheck has written an unofficial, but detailed, tutorial which + you can find at + . + +extra-source-files: + README + changelog + examples/Heap.hs + examples/Heap_Program.hs + examples/Heap_ProgramAlgebraic.hs + examples/Lambda.hs + examples/Merge.hs + examples/Set.hs + examples/Simple.hs + +source-repository head + type: git + location: https://github.com/nick8325/quickcheck + +source-repository this + type: git + location: https://github.com/nick8325/quickcheck + tag: 2.10.1 + +flag templateHaskell + Description: Build Test.QuickCheck.All, which uses Template Haskell. + Default: True + +library + Build-depends: base >=4.3 && <5, random, containers + + -- Modules that are always built. + Exposed-Modules: + Test.QuickCheck, + Test.QuickCheck.Arbitrary, + Test.QuickCheck.Gen, + Test.QuickCheck.Gen.Unsafe, + Test.QuickCheck.Monadic, + Test.QuickCheck.Modifiers, + Test.QuickCheck.Property, + Test.QuickCheck.Test, + Test.QuickCheck.Text, + Test.QuickCheck.Poly, + Test.QuickCheck.State, + Test.QuickCheck.Random, + Test.QuickCheck.Exception + + -- GHC-specific modules. + if impl(ghc) + Exposed-Modules: Test.QuickCheck.Function + Build-depends: transformers >= 0.3, deepseq + else + cpp-options: -DNO_TRANSFORMERS -DNO_DEEPSEQ + + if impl(ghc) && flag(templateHaskell) + Build-depends: template-haskell >= 2.4 + Other-Extensions: TemplateHaskell + Exposed-Modules: Test.QuickCheck.All + else + cpp-options: -DNO_TEMPLATE_HASKELL + + if !impl(ghc >= 7.2) + cpp-options: -DNO_FOREIGN_C_USECONDS + + -- The new generics appeared in GHC 7.2... + if impl(ghc < 7.2) + cpp-options: -DNO_GENERICS + -- ...but in 7.2-7.4 it lives in the ghc-prim package. + if impl(ghc >= 7.2) && impl(ghc < 7.6) + Build-depends: ghc-prim + + -- Safe Haskell appeared in GHC 7.2, but GHC.Generics isn't safe until 7.4. + if impl (ghc < 7.4) + cpp-options: -DNO_SAFE_HASKELL + + -- Use tf-random on newer GHCs. + if impl(ghc) + Build-depends: tf-random >= 0.4 + else + cpp-options: -DNO_TF_RANDOM + + if !impl(ghc >= 7.6) + cpp-options: -DNO_POLYKINDS + + if !impl(ghc >= 8.0) + cpp-options: -DNO_MONADFAIL + + -- Switch off most optional features on non-GHC systems. + if !impl(ghc) + -- If your Haskell compiler can cope without some of these, please + -- send a message to the QuickCheck mailing list! + cpp-options: -DNO_TIMEOUT -DNO_NEWTYPE_DERIVING -DNO_GENERICS -DNO_TEMPLATE_HASKELL -DNO_SAFE_HASKELL + if !impl(hugs) && !impl(uhc) + cpp-options: -DNO_ST_MONAD -DNO_MULTI_PARAM_TYPE_CLASSES + + -- LANGUAGE pragmas don't have any effect in Hugs. + if impl(hugs) + Extensions: CPP + + if impl(uhc) + -- Cabal under UHC needs pointing out all the dependencies of the + -- random package. + Build-depends: old-time, old-locale + -- Plus some bits of the standard library are missing. + cpp-options: -DNO_FIXED -DNO_EXCEPTIONS + +Test-Suite test-quickcheck + type: exitcode-stdio-1.0 + hs-source-dirs: + examples + main-is: Heap.hs + build-depends: base, QuickCheck + if !flag(templateHaskell) + Buildable: False + +Test-Suite test-quickcheck-gcoarbitrary + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: GCoArbitraryExample.hs + build-depends: base, QuickCheck + if !impl(ghc >= 7.2) + buildable: False + if impl(ghc >= 7.2) && impl(ghc < 7.6) + build-depends: ghc-prim + +Test-Suite test-quickcheck-generators + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Generators.hs + build-depends: base, QuickCheck + if !flag(templateHaskell) + Buildable: False + +Test-Suite test-quickcheck-gshrink + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: GShrinkExample.hs + build-depends: base, QuickCheck + if !impl(ghc >= 7.2) + buildable: False + if impl(ghc >= 7.2) && impl(ghc < 7.6) + build-depends: ghc-prim diff --git a/README b/README new file mode 100644 index 0000000..3d64f26 --- /dev/null +++ b/README @@ -0,0 +1,8 @@ +This is QuickCheck 2, a library for random testing of program properties. + +Install it in the usual way: + +$ cabal install + +There is a Google group for user discussion and questions at +https://groups.google.com/forum/#!forum/haskell-quickcheck. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 index 0000000..e2c31e7 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/env runghc + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs new file mode 100644 index 0000000..0b64155 --- /dev/null +++ b/Test/QuickCheck.hs @@ -0,0 +1,231 @@ +{-| +The +gives detailed information about using QuickCheck effectively. + +To start using QuickCheck, write down your property as a function returning @Bool@. +For example, to check that reversing a list twice gives back the same list you can write: + +@ +import Test.QuickCheck + +prop_reverse :: [Int] -> Bool +prop_reverse xs = reverse (reverse xs) == xs +@ + +You can then use QuickCheck to test @prop_reverse@ on 100 random lists: + +>>> quickCheck prop_reverse ++++ OK, passed 100 tests. + +To run more tests you can use the 'withMaxSuccess' combinator: + +>>> quickCheck (withMaxSuccess 10000 prop_reverse) ++++ OK, passed 10000 tests. + +To use QuickCheck on your own data types you will need to write 'Arbitrary' +instances for those types. See the + for +details about how to do that. + +This module exports most of QuickCheck's functionality, but see also +"Test.QuickCheck.Monadic" which helps with testing impure or monadic code. +-} +{-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} +#endif +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE PatternSynonyms #-} +#endif +module Test.QuickCheck + ( + -- * Running tests + quickCheck + , Args(..), Result(..) + , stdArgs + , quickCheckWith + , quickCheckWithResult + , quickCheckResult + -- ** Running tests verbosely + , verboseCheck + , verboseCheckWith + , verboseCheckWithResult + , verboseCheckResult +#ifndef NO_TEMPLATE_HASKELL + -- ** Testing all properties in a module + , quickCheckAll + , verboseCheckAll + , forAllProperties + -- ** Testing polymorphic properties + , polyQuickCheck + , polyVerboseCheck + , monomorphic +#endif + + -- * Random generation + , Gen + -- ** Generator combinators + , choose + , oneof + , frequency + , elements + , growingElements + , sized + , getSize + , resize + , scale + , suchThat + , suchThatMap + , suchThatMaybe + , listOf + , listOf1 + , vectorOf + , infiniteListOf + , shuffle + , sublistOf + -- ** Generators which use Arbitrary + , vector + , orderedList + , infiniteList + -- ** Running a generator + , generate + -- ** Generator debugging + , sample + , sample' + + -- * Arbitrary and CoArbitrary classes + , Arbitrary(..) + , CoArbitrary(..) + + -- ** Unary and Binary classes + , Arbitrary1(..) + , arbitrary1 + , shrink1 + , Arbitrary2(..) + , arbitrary2 + , shrink2 + + -- ** Helper functions for implementing arbitrary + , arbitrarySizedIntegral + , arbitrarySizedNatural + , arbitrarySizedFractional + , arbitrarySizedBoundedIntegral + , arbitraryBoundedIntegral + , arbitraryBoundedRandom + , arbitraryBoundedEnum + , arbitraryUnicodeChar + , arbitraryASCIIChar + , arbitraryPrintableChar + -- ** Helper functions for implementing shrink +#ifndef NO_GENERICS + , genericCoarbitrary + , genericShrink + , subterms + , recursivelyShrink +#endif + , shrinkNothing + , shrinkList + , shrinkMap + , shrinkMapBy + , shrinkIntegral + , shrinkRealFrac + -- ** Helper functions for implementing coarbitrary + , variant + , coarbitraryIntegral + , coarbitraryReal + , coarbitraryShow + , coarbitraryEnum + , (><) + + -- ** Type-level modifiers for changing generator behavior + , Blind(..) + , Fixed(..) + , OrderedList(..) + , NonEmptyList(..) + , Positive(..) + , NonZero(..) + , NonNegative(..) + , Large(..) + , Small(..) + , Smart(..) + , Shrink2(..) +#ifndef NO_MULTI_PARAM_TYPE_CLASSES + , Shrinking(..) + , ShrinkState(..) +#endif + , ASCIIString(..) + , UnicodeString(..) + , PrintableString(..) + + -- ** Functions + , Fun + , applyFun + , applyFun2 + , applyFun3 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 + , pattern Fn + , pattern Fn2 + , pattern Fn3 +#endif + , Function (..) + , functionMap + + -- * Properties + , Property, Testable(..) + -- ** Property combinators + , forAll + , forAllShrink + , shrinking + , (==>) + , (===) +#ifndef NO_DEEPSEQ + , total +#endif + , ioProperty + -- *** Controlling property execution + , verbose + , once + , again + , withMaxSuccess + , within + , noShrinking + -- *** Conjunction and disjunction + , (.&.) + , (.&&.) + , conjoin + , (.||.) + , disjoin + -- *** What to do on failure + , counterexample + , printTestCase + , whenFail + , whenFail' + , expectFailure + -- *** Analysing test distribution + , label + , collect + , classify + , cover + -- *** Miscellaneous + , Discard(..) + , discard + , mapSize + ) + where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck.Gen +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Modifiers +import Test.QuickCheck.Property hiding ( Result(..) ) +import Test.QuickCheck.Test +import Test.QuickCheck.Exception +import Test.QuickCheck.Function +#ifndef NO_TEMPLATE_HASKELL +import Test.QuickCheck.All +#endif + +-------------------------------------------------------------------------- +-- the end. diff --git a/Test/QuickCheck/All.hs b/Test/QuickCheck/All.hs new file mode 100644 index 0000000..7e32318 --- /dev/null +++ b/Test/QuickCheck/All.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE TemplateHaskell, Rank2Types, CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Trustworthy #-} +#endif + +-- | Test all properties in the current module, using Template Haskell. +-- You need to have a @{-\# LANGUAGE TemplateHaskell \#-}@ pragma in +-- your module for any of these to work. +module Test.QuickCheck.All( + -- ** Testing all properties in a module + quickCheckAll, + verboseCheckAll, + forAllProperties, + -- ** Testing polymorphic properties + polyQuickCheck, + polyVerboseCheck, + monomorphic) where + +import Language.Haskell.TH +import Test.QuickCheck.Property hiding (Result) +import Test.QuickCheck.Test +import Data.Char +import Data.List +import Control.Monad + +import qualified System.IO as S + +-- | Test a polymorphic property, defaulting all type variables to 'Integer'. +-- +-- Invoke as @$('polyQuickCheck' 'prop)@, where @prop@ is a property. +-- Note that just evaluating @'quickCheck' prop@ in GHCi will seem to +-- work, but will silently default all type variables to @()@! +-- +-- @$('polyQuickCheck' \'prop)@ means the same as +-- @'quickCheck' $('monomorphic' \'prop)@. +-- If you want to supply custom arguments to 'polyQuickCheck', +-- you will have to combine 'quickCheckWith' and 'monomorphic' yourself. +-- +-- If you want to use 'polyQuickCheck' in the same file where you defined the +-- property, the same scoping problems pop up as in 'quickCheckAll': +-- see the note there about @return []@. +polyQuickCheck :: Name -> ExpQ +polyQuickCheck x = [| quickCheck $(monomorphic x) |] + +-- | Test a polymorphic property, defaulting all type variables to 'Integer'. +-- This is just a convenience function that combines 'verboseCheck' and 'monomorphic'. +-- +-- If you want to use 'polyVerboseCheck' in the same file where you defined the +-- property, the same scoping problems pop up as in 'quickCheckAll': +-- see the note there about @return []@. +polyVerboseCheck :: Name -> ExpQ +polyVerboseCheck x = [| verboseCheck $(monomorphic x) |] + +type Error = forall a. String -> a + +-- | Monomorphise an arbitrary property by defaulting all type variables to 'Integer'. +-- +-- For example, if @f@ has type @'Ord' a => [a] -> [a]@ +-- then @$('monomorphic' 'f)@ has type @['Integer'] -> ['Integer']@. +-- +-- If you want to use 'monomorphic' in the same file where you defined the +-- property, the same scoping problems pop up as in 'quickCheckAll': +-- see the note there about @return []@. +monomorphic :: Name -> ExpQ +monomorphic t = do + ty0 <- fmap infoType (reify t) + let err msg = error $ msg ++ ": " ++ pprint ty0 + (polys, ctx, ty) <- deconstructType err ty0 + case polys of + [] -> return (expName t) + _ -> do + integer <- [t| Integer |] + ty' <- monomorphiseType err integer ty + return (SigE (expName t) ty') + +expName :: Name -> Exp +expName n = if isVar n then VarE n else ConE n + +-- See section 2.4 of the Haskell 2010 Language Report, plus support for "[]" +isVar :: Name -> Bool +isVar = let isVar' (c:_) = not (isUpper c || c `elem` ":[") + isVar' _ = True + in isVar' . nameBase + +infoType :: Info -> Type +#if MIN_VERSION_template_haskell(2,11,0) +infoType (ClassOpI _ ty _) = ty +infoType (DataConI _ ty _) = ty +infoType (VarI _ ty _) = ty +#else +infoType (ClassOpI _ ty _ _) = ty +infoType (DataConI _ ty _ _) = ty +infoType (VarI _ ty _ _) = ty +#endif + +deconstructType :: Error -> Type -> Q ([Name], Cxt, Type) +deconstructType err ty0@(ForallT xs ctx ty) = do + let plain (PlainTV _) = True +#if MIN_VERSION_template_haskell(2,8,0) + plain (KindedTV _ StarT) = True +#else + plain (KindedTV _ StarK) = True +#endif + plain _ = False + unless (all plain xs) $ err "Higher-kinded type variables in type" + return (map (\(PlainTV x) -> x) xs, ctx, ty) +deconstructType _ ty = return ([], [], ty) + +monomorphiseType :: Error -> Type -> Type -> TypeQ +monomorphiseType err mono ty@(VarT n) = return mono +monomorphiseType err mono (AppT t1 t2) = liftM2 AppT (monomorphiseType err mono t1) (monomorphiseType err mono t2) +monomorphiseType err mono ty@(ForallT _ _ _) = err $ "Higher-ranked type" +monomorphiseType err mono ty = return ty + +-- | Test all properties in the current module, using a custom +-- 'quickCheck' function. The same caveats as with 'quickCheckAll' +-- apply. +-- +-- @$'forAllProperties'@ has type @('Property' -> 'IO' 'Result') -> 'IO' 'Bool'@. +-- An example invocation is @$'forAllProperties' 'quickCheckResult'@, +-- which does the same thing as @$'quickCheckAll'@. +-- +-- 'forAllProperties' has the same issue with scoping as 'quickCheckAll': +-- see the note there about @return []@. +forAllProperties :: Q Exp -- :: (Property -> IO Result) -> IO Bool +forAllProperties = do + Loc { loc_filename = filename } <- location + when (filename == "") $ error "don't run this interactively" + ls <- runIO (fmap lines (readUTF8File filename)) + let prefixes = map (takeWhile (\c -> isAlphaNum c || c == '_' || c == '\'') . dropWhile (\c -> isSpace c || c == '>')) ls + idents = nubBy (\x y -> snd x == snd y) (filter (("prop_" `isPrefixOf`) . snd) (zip [1..] prefixes)) +#if MIN_VERSION_template_haskell(2,8,0) + warning x = reportWarning ("Name " ++ x ++ " found in source file but was not in scope") +#else + warning x = report False ("Name " ++ x ++ " found in source file but was not in scope") +#endif + quickCheckOne :: (Int, String) -> Q [Exp] + quickCheckOne (l, x) = do + exists <- (warning x >> return False) `recover` (reify (mkName x) >> return True) + if exists then sequence [ [| ($(stringE $ x ++ " from " ++ filename ++ ":" ++ show l), + property $(monomorphic (mkName x))) |] ] + else return [] + [| runQuickCheckAll $(fmap (ListE . concat) (mapM quickCheckOne idents)) |] + +readUTF8File name = S.openFile name S.ReadMode >>= + set_utf8_io_enc >>= + S.hGetContents + +-- Deal with UTF-8 input and output. +set_utf8_io_enc :: S.Handle -> IO S.Handle +#if __GLASGOW_HASKELL__ > 611 +-- possibly if MIN_VERSION_base(4,2,0) +set_utf8_io_enc h = do S.hSetEncoding h S.utf8; return h +#else +set_utf8_io_enc h = return h +#endif + +-- | Test all properties in the current module. +-- The name of the property must begin with @prop_@. +-- Polymorphic properties will be defaulted to 'Integer'. +-- Returns 'True' if all tests succeeded, 'False' otherwise. +-- +-- To use 'quickCheckAll', add a definition to your module along +-- the lines of +-- +-- > return [] +-- > runTests = $quickCheckAll +-- +-- and then execute @runTests@. +-- +-- Note: the bizarre @return []@ in the example above is needed on +-- GHC 7.8; without it, 'quickCheckAll' will not be able to find +-- any of the properties. For the curious, the @return []@ is a +-- Template Haskell splice that makes GHC insert the empty list +-- of declarations at that point in the program; GHC typechecks +-- everything before the @return []@ before it starts on the rest +-- of the module, which means that the later call to 'quickCheckAll' +-- can see everything that was defined before the @return []@. Yikes! +quickCheckAll :: Q Exp +quickCheckAll = [| $(forAllProperties) quickCheckResult |] + +-- | Test all properties in the current module. +-- This is just a convenience function that combines 'quickCheckAll' and 'verbose'. +-- +-- 'verboseCheckAll' has the same issue with scoping as 'quickCheckAll': +-- see the note there about @return []@. +verboseCheckAll :: Q Exp +verboseCheckAll = [| $(forAllProperties) verboseCheckResult |] + +runQuickCheckAll :: [(String, Property)] -> (Property -> IO Result) -> IO Bool +runQuickCheckAll ps qc = + fmap and . forM ps $ \(xs, p) -> do + putStrLn $ "=== " ++ xs ++ " ===" + r <- qc p + putStrLn "" + return $ case r of + Success { } -> True + Failure { } -> False + NoExpectedFailure { } -> False + GaveUp { } -> False + InsufficientCoverage { } -> False diff --git a/Test/QuickCheck/Arbitrary.hs b/Test/QuickCheck/Arbitrary.hs new file mode 100644 index 0000000..9c2e7d2 --- /dev/null +++ b/Test/QuickCheck/Arbitrary.hs @@ -0,0 +1,1399 @@ +-- | Type classes for random generation of values. +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +#ifndef NO_GENERICS +{-# LANGUAGE DefaultSignatures, FlexibleContexts, TypeOperators #-} +{-# LANGUAGE FlexibleInstances, KindSignatures, ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPING_ +#endif +#endif +#ifndef NO_POLYKINDS +{-# LANGUAGE PolyKinds #-} +#endif +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Trustworthy #-} +#endif +#ifndef NO_NEWTYPE_DERIVING +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +#endif +module Test.QuickCheck.Arbitrary + ( + -- * Arbitrary and CoArbitrary classes + Arbitrary(..) + , CoArbitrary(..) + + -- ** Unary and Binary classes + , Arbitrary1(..) + , arbitrary1 + , shrink1 + , Arbitrary2(..) + , arbitrary2 + , shrink2 + + -- ** Helper functions for implementing arbitrary + , arbitrarySizedIntegral -- :: Integral a => Gen a + , arbitrarySizedNatural -- :: Integral a => Gen a + , arbitraryBoundedIntegral -- :: (Bounded a, Integral a) => Gen a + , arbitrarySizedBoundedIntegral -- :: (Bounded a, Integral a) => Gen a + , arbitrarySizedFractional -- :: Fractional a => Gen a + , arbitraryBoundedRandom -- :: (Bounded a, Random a) => Gen a + , arbitraryBoundedEnum -- :: (Bounded a, Enum a) => Gen a + -- ** Generators for various kinds of character + , arbitraryUnicodeChar -- :: Gen Char + , arbitraryASCIIChar -- :: Gen Char + , arbitraryPrintableChar -- :: Gen Char + -- ** Helper functions for implementing shrink +#ifndef NO_GENERICS + , genericShrink -- :: (Generic a, Arbitrary a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) => a -> [a] + , subterms -- :: (Generic a, Arbitrary a, GSubterms (Rep a) a) => a -> [a] + , recursivelyShrink -- :: (Generic a, RecursivelyShrink (Rep a)) => a -> [a] + , genericCoarbitrary -- :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b +#endif + , shrinkNothing -- :: a -> [a] + , shrinkList -- :: (a -> [a]) -> [a] -> [[a]] + , shrinkMap -- :: Arbitrary a -> (a -> b) -> (b -> a) -> b -> [b] + , shrinkMapBy -- :: (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b] + , shrinkIntegral -- :: Integral a => a -> [a] + , shrinkRealFrac -- :: RealFrac a => a -> [a] + -- ** Helper functions for implementing coarbitrary + , coarbitraryIntegral -- :: Integral a => a -> Gen b -> Gen b + , coarbitraryReal -- :: Real a => a -> Gen b -> Gen b + , coarbitraryShow -- :: Show a => a -> Gen b -> Gen b + , coarbitraryEnum -- :: Enum a => a -> Gen b -> Gen b + , (><) + + -- ** Generators which use arbitrary + , vector -- :: Arbitrary a => Int -> Gen [a] + , orderedList -- :: (Ord a, Arbitrary a) => Gen [a] + , infiniteList -- :: Arbitrary a => Gen [a] + ) + where + +-------------------------------------------------------------------------- +-- imports + +import Control.Applicative +import Data.Foldable(toList) +import System.Random(Random) +import Test.QuickCheck.Gen +import Test.QuickCheck.Random +import Test.QuickCheck.Gen.Unsafe + +{- +import Data.Generics + ( (:*:)(..) + , (:+:)(..) + , Unit(..) + ) +-} + +import Data.Char + ( ord + , isLower + , isUpper + , toLower + , isDigit + , isSpace + , isPrint + , generalCategory + , GeneralCategory(..) + ) + +#ifndef NO_FIXED +import Data.Fixed + ( Fixed + , HasResolution + ) +#endif + +import Data.Ratio + ( Ratio + , (%) + , numerator + , denominator + ) + +import Data.Complex + ( Complex((:+)) ) + +import Data.List + ( sort + , nub + ) + +import Data.Version (Version (..)) + +import Control.Monad + ( liftM + , liftM2 + , liftM3 + , liftM4 + , liftM5 + ) + +import Data.Int(Int8, Int16, Int32, Int64) +import Data.Word(Word, Word8, Word16, Word32, Word64) +import System.Exit (ExitCode(..)) +import Foreign.C.Types + +#ifndef NO_GENERICS +import GHC.Generics +#endif + +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.IntSet as IntSet +import qualified Data.IntMap as IntMap +import qualified Data.Sequence as Sequence + +import qualified Data.Monoid as Monoid + +#ifndef NO_TRANSFORMERS +import Data.Functor.Identity +import Data.Functor.Constant +import Data.Functor.Compose +import Data.Functor.Product +#endif + +-------------------------------------------------------------------------- +-- ** class Arbitrary + +-- | Random generation and shrinking of values. +-- +-- QuickCheck provides @Arbitrary@ instances for most types in @base@, +-- except those which incur extra dependencies. +-- For a wider range of @Arbitrary@ instances see the +-- +-- package. +class Arbitrary a where + -- | A generator for values of the given type. + -- + -- It is worth spending time thinking about what sort of test data + -- you want - good generators are often the difference between + -- finding bugs and not finding them. You can use 'sample', + -- 'label' and 'classify' to check the quality of your test data. + -- + -- There is no generic @arbitrary@ implementation included because we don't + -- know how to make a high-quality one. If you want one, consider using the + -- package. + -- + -- The + -- goes into detail on how to write good generators. Make sure to look at it, + -- especially if your type is recursive! + arbitrary :: Gen a + + -- | Produces a (possibly) empty list of all the possible + -- immediate shrinks of the given value. + -- + -- The default implementation returns the empty list, so will not try to + -- shrink the value. If your data type has no special invariants, you can + -- enable shrinking by defining @shrink = 'genericShrink'@, but by customising + -- the behaviour of @shrink@ you can often get simpler counterexamples. + -- + -- Most implementations of 'shrink' should try at least three things: + -- + -- 1. Shrink a term to any of its immediate subterms. + -- You can use 'subterms' to do this. + -- + -- 2. Recursively apply 'shrink' to all immediate subterms. + -- You can use 'recursivelyShrink' to do this. + -- + -- 3. Type-specific shrinkings such as replacing a constructor by a + -- simpler constructor. + -- + -- For example, suppose we have the following implementation of binary trees: + -- + -- > data Tree a = Nil | Branch a (Tree a) (Tree a) + -- + -- We can then define 'shrink' as follows: + -- + -- > shrink Nil = [] + -- > shrink (Branch x l r) = + -- > -- shrink Branch to Nil + -- > [Nil] ++ + -- > -- shrink to subterms + -- > [l, r] ++ + -- > -- recursively shrink subterms + -- > [Branch x' l' r' | (x', l', r') <- shrink (x, l, r)] + -- + -- There are a couple of subtleties here: + -- + -- * QuickCheck tries the shrinking candidates in the order they + -- appear in the list, so we put more aggressive shrinking steps + -- (such as replacing the whole tree by @Nil@) before smaller + -- ones (such as recursively shrinking the subtrees). + -- + -- * It is tempting to write the last line as + -- @[Branch x' l' r' | x' <- shrink x, l' <- shrink l, r' <- shrink r]@ + -- but this is the /wrong thing/! It will force QuickCheck to shrink + -- @x@, @l@ and @r@ in tandem, and shrinking will stop once /one/ of + -- the three is fully shrunk. + -- + -- There is a fair bit of boilerplate in the code above. + -- We can avoid it with the help of some generic functions. + -- The function 'genericShrink' tries shrinking a term to all of its + -- subterms and, failing that, recursively shrinks the subterms. + -- Using it, we can define 'shrink' as: + -- + -- > shrink x = shrinkToNil x ++ genericShrink x + -- > where + -- > shrinkToNil Nil = [] + -- > shrinkToNil (Branch _ l r) = [Nil] + -- + -- 'genericShrink' is a combination of 'subterms', which shrinks + -- a term to any of its subterms, and 'recursivelyShrink', which shrinks + -- all subterms of a term. These may be useful if you need a bit more + -- control over shrinking than 'genericShrink' gives you. + -- + -- A final gotcha: we cannot define 'shrink' as simply @'shrink' x = Nil:'genericShrink' x@ + -- as this shrinks @Nil@ to @Nil@, and shrinking will go into an + -- infinite loop. + -- + -- If all this leaves you bewildered, you might try @'shrink' = 'genericShrink'@ to begin with, + -- after deriving @Generic@ for your type. However, if your data type has any + -- special invariants, you will need to check that 'genericShrink' can't break those invariants. + shrink :: a -> [a] + shrink _ = [] + +-- | Lifting of the 'Arbitrary' class to unary type constructors. +class Arbitrary1 f where + liftArbitrary :: Gen a -> Gen (f a) + liftShrink :: (a -> [a]) -> f a -> [f a] + liftShrink _ _ = [] + +arbitrary1 :: (Arbitrary1 f, Arbitrary a) => Gen (f a) +arbitrary1 = liftArbitrary arbitrary + +shrink1 :: (Arbitrary1 f, Arbitrary a) => f a -> [f a] +shrink1 = liftShrink shrink + +-- | Lifting of the 'Arbitrary' class to binary type constructors. +class Arbitrary2 f where + liftArbitrary2 :: Gen a -> Gen b -> Gen (f a b) + liftShrink2 :: (a -> [a]) -> (b -> [b]) -> f a b -> [f a b] + liftShrink2 _ _ _ = [] + +arbitrary2 :: (Arbitrary2 f, Arbitrary a, Arbitrary b) => Gen (f a b) +arbitrary2 = liftArbitrary2 arbitrary arbitrary + +shrink2 :: (Arbitrary2 f, Arbitrary a, Arbitrary b) => f a b -> [f a b] +shrink2 = liftShrink2 shrink shrink + +#ifndef NO_GENERICS +-- | Shrink a term to any of its immediate subterms, +-- and also recursively shrink all subterms. +genericShrink :: (Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) => a -> [a] +genericShrink x = subterms x ++ recursivelyShrink x + +-- | Recursively shrink all immediate subterms. +recursivelyShrink :: (Generic a, RecursivelyShrink (Rep a)) => a -> [a] +recursivelyShrink = map to . grecursivelyShrink . from + +class RecursivelyShrink f where + grecursivelyShrink :: f a -> [f a] + +instance (RecursivelyShrink f, RecursivelyShrink g) => RecursivelyShrink (f :*: g) where + grecursivelyShrink (x :*: y) = + [x' :*: y | x' <- grecursivelyShrink x] ++ + [x :*: y' | y' <- grecursivelyShrink y] + +instance (RecursivelyShrink f, RecursivelyShrink g) => RecursivelyShrink (f :+: g) where + grecursivelyShrink (L1 x) = map L1 (grecursivelyShrink x) + grecursivelyShrink (R1 x) = map R1 (grecursivelyShrink x) + +instance RecursivelyShrink f => RecursivelyShrink (M1 i c f) where + grecursivelyShrink (M1 x) = map M1 (grecursivelyShrink x) + +instance Arbitrary a => RecursivelyShrink (K1 i a) where + grecursivelyShrink (K1 x) = map K1 (shrink x) + +instance RecursivelyShrink U1 where + grecursivelyShrink U1 = [] + +instance RecursivelyShrink V1 where + -- The empty type can't be shrunk to anything. + grecursivelyShrink _ = [] + + +-- | All immediate subterms of a term. +subterms :: (Generic a, GSubterms (Rep a) a) => a -> [a] +subterms = gSubterms . from + + +class GSubterms f a where + -- | Provides the immediate subterms of a term that are of the same type + -- as the term itself. + -- + -- Requires a constructor to be stripped off; this means it skips through + -- @M1@ wrappers and returns @[]@ on everything that's not `(:*:)` or `(:+:)`. + -- + -- Once a `(:*:)` or `(:+:)` constructor has been reached, this function + -- delegates to `gSubtermsIncl` to return the immediately next constructor + -- available. + gSubterms :: f a -> [a] + +instance GSubterms V1 a where + -- The empty type can't be shrunk to anything. + gSubterms _ = [] + +instance GSubterms U1 a where + gSubterms U1 = [] + +instance (GSubtermsIncl f a, GSubtermsIncl g a) => GSubterms (f :*: g) a where + gSubterms (l :*: r) = gSubtermsIncl l ++ gSubtermsIncl r + +instance (GSubtermsIncl f a, GSubtermsIncl g a) => GSubterms (f :+: g) a where + gSubterms (L1 x) = gSubtermsIncl x + gSubterms (R1 x) = gSubtermsIncl x + +instance GSubterms f a => GSubterms (M1 i c f) a where + gSubterms (M1 x) = gSubterms x + +instance GSubterms (K1 i a) b where + gSubterms (K1 _) = [] + + +class GSubtermsIncl f a where + -- | Provides the immediate subterms of a term that are of the same type + -- as the term itself. + -- + -- In contrast to `gSubterms`, this returns the immediate next constructor + -- available. + gSubtermsIncl :: f a -> [a] + +instance GSubtermsIncl V1 a where + -- The empty type can't be shrunk to anything. + gSubtermsIncl _ = [] + +instance GSubtermsIncl U1 a where + gSubtermsIncl U1 = [] + +instance (GSubtermsIncl f a, GSubtermsIncl g a) => GSubtermsIncl (f :*: g) a where + gSubtermsIncl (l :*: r) = gSubtermsIncl l ++ gSubtermsIncl r + +instance (GSubtermsIncl f a, GSubtermsIncl g a) => GSubtermsIncl (f :+: g) a where + gSubtermsIncl (L1 x) = gSubtermsIncl x + gSubtermsIncl (R1 x) = gSubtermsIncl x + +instance GSubtermsIncl f a => GSubtermsIncl (M1 i c f) a where + gSubtermsIncl (M1 x) = gSubtermsIncl x + +-- This is the important case: We've found a term of the same type. +instance OVERLAPPING_ GSubtermsIncl (K1 i a) a where + gSubtermsIncl (K1 x) = [x] + +instance OVERLAPPING_ GSubtermsIncl (K1 i a) b where + gSubtermsIncl (K1 _) = [] + +#endif + +-- instances + +instance (CoArbitrary a) => Arbitrary1 ((->) a) where + liftArbitrary arbB = promote (`coarbitrary` arbB) + +instance (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where + arbitrary = arbitrary1 + +instance Arbitrary () where + arbitrary = return () + +instance Arbitrary Bool where + arbitrary = choose (False,True) + shrink True = [False] + shrink False = [] + +instance Arbitrary Ordering where + arbitrary = elements [LT, EQ, GT] + shrink GT = [EQ, LT] + shrink LT = [EQ] + shrink EQ = [] + +instance Arbitrary1 Maybe where + liftArbitrary arb = frequency [(1, return Nothing), (3, liftM Just arb)] + + liftShrink shr (Just x) = Nothing : [ Just x' | x' <- shr x ] + liftShrink _ Nothing = [] + +instance Arbitrary a => Arbitrary (Maybe a) where + arbitrary = arbitrary1 + shrink = shrink1 + +instance Arbitrary2 Either where + liftArbitrary2 arbA arbB = oneof [liftM Left arbA, liftM Right arbB] + + liftShrink2 shrA _ (Left x) = [ Left x' | x' <- shrA x ] + liftShrink2 _ shrB (Right y) = [ Right y' | y' <- shrB y ] + +instance Arbitrary a => Arbitrary1 (Either a) where + liftArbitrary = liftArbitrary2 arbitrary + liftShrink = liftShrink2 shrink + +instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where + arbitrary = arbitrary2 + shrink = shrink2 + +instance Arbitrary1 [] where + liftArbitrary = listOf + liftShrink = shrinkList + +instance Arbitrary a => Arbitrary [a] where + arbitrary = arbitrary1 + shrink = shrink1 + +-- | Shrink a list of values given a shrinking function for individual values. +shrinkList :: (a -> [a]) -> [a] -> [[a]] +shrinkList shr xs = concat [ removes k n xs | k <- takeWhile (>0) (iterate (`div`2) n) ] + ++ shrinkOne xs + where + n = length xs + + shrinkOne [] = [] + shrinkOne (x:xs) = [ x':xs | x' <- shr x ] + ++ [ x:xs' | xs' <- shrinkOne xs ] + + removes k n xs + | k > n = [] + | null xs2 = [[]] + | otherwise = xs2 : map (xs1 ++) (removes k (n-k) xs2) + where + xs1 = take k xs + xs2 = drop k xs + +{- + -- "standard" definition for lists: + shrink [] = [] + shrink (x:xs) = [ xs ] + ++ [ x:xs' | xs' <- shrink xs ] + ++ [ x':xs | x' <- shrink x ] +-} + +instance Integral a => Arbitrary (Ratio a) where + arbitrary = arbitrarySizedFractional + shrink = shrinkRealFrac + +instance (RealFloat a, Arbitrary a) => Arbitrary (Complex a) where + arbitrary = liftM2 (:+) arbitrary arbitrary + shrink (x :+ y) = [ x' :+ y | x' <- shrink x ] ++ + [ x :+ y' | y' <- shrink y ] + +#ifndef NO_FIXED +instance HasResolution a => Arbitrary (Fixed a) where + arbitrary = arbitrarySizedFractional + shrink = shrinkRealFrac +#endif + +instance Arbitrary2 (,) where + liftArbitrary2 = liftM2 (,) + liftShrink2 shrA shrB (x, y) = + [ (x', y) | x' <- shrA x ] + ++ [ (x, y') | y' <- shrB y ] + +instance (Arbitrary a) => Arbitrary1 ((,) a) where + liftArbitrary = liftArbitrary2 arbitrary + liftShrink = liftShrink2 shrink + +instance (Arbitrary a, Arbitrary b) => Arbitrary (a,b) where + arbitrary = arbitrary2 + shrink = shrink2 + +instance (Arbitrary a, Arbitrary b, Arbitrary c) + => Arbitrary (a,b,c) + where + arbitrary = liftM3 (,,) arbitrary arbitrary arbitrary + + shrink (x, y, z) = + [ (x', y', z') + | (x', (y', z')) <- shrink (x, (y, z)) ] + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) + => Arbitrary (a,b,c,d) + where + arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary + + shrink (w, x, y, z) = + [ (w', x', y', z') + | (w', (x', (y', z'))) <- shrink (w, (x, (y, z))) ] + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) + => Arbitrary (a,b,c,d,e) + where + arbitrary = liftM5 (,,,,) arbitrary arbitrary arbitrary arbitrary arbitrary + + shrink (v, w, x, y, z) = + [ (v', w', x', y', z') + | (v', (w', (x', (y', z')))) <- shrink (v, (w, (x, (y, z)))) ] + +instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e + , Arbitrary f + ) + => Arbitrary (a,b,c,d,e,f) + where + arbitrary = return (,,,,,) + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary + + shrink (u, v, w, x, y, z) = + [ (u', v', w', x', y', z') + | (u', (v', (w', (x', (y', z'))))) <- shrink (u, (v, (w, (x, (y, z))))) ] + +instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e + , Arbitrary f, Arbitrary g + ) + => Arbitrary (a,b,c,d,e,f,g) + where + arbitrary = return (,,,,,,) + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + + shrink (t, u, v, w, x, y, z) = + [ (t', u', v', w', x', y', z') + | (t', (u', (v', (w', (x', (y', z')))))) <- shrink (t, (u, (v, (w, (x, (y, z)))))) ] + +instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e + , Arbitrary f, Arbitrary g, Arbitrary h + ) + => Arbitrary (a,b,c,d,e,f,g,h) + where + arbitrary = return (,,,,,,,) + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + + shrink (s, t, u, v, w, x, y, z) = + [ (s', t', u', v', w', x', y', z') + | (s', (t', (u', (v', (w', (x', (y', z'))))))) + <- shrink (s, (t, (u, (v, (w, (x, (y, z))))))) ] + +instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e + , Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i + ) + => Arbitrary (a,b,c,d,e,f,g,h,i) + where + arbitrary = return (,,,,,,,,) + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary + + shrink (r, s, t, u, v, w, x, y, z) = + [ (r', s', t', u', v', w', x', y', z') + | (r', (s', (t', (u', (v', (w', (x', (y', z')))))))) + <- shrink (r, (s, (t, (u, (v, (w, (x, (y, z)))))))) ] + +instance ( Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e + , Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i, Arbitrary j + ) + => Arbitrary (a,b,c,d,e,f,g,h,i,j) + where + arbitrary = return (,,,,,,,,,) + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary + + shrink (q, r, s, t, u, v, w, x, y, z) = + [ (q', r', s', t', u', v', w', x', y', z') + | (q', (r', (s', (t', (u', (v', (w', (x', (y', z'))))))))) + <- shrink (q, (r, (s, (t, (u, (v, (w, (x, (y, z))))))))) ] + +-- typical instance for primitive (numerical) types + +instance Arbitrary Integer where + arbitrary = arbitrarySizedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int where + arbitrary = arbitrarySizedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int8 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int16 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int32 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int64 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word8 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word16 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word32 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word64 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Char where + arbitrary = + frequency + [(3, arbitraryASCIIChar), + (1, arbitraryUnicodeChar)] + + shrink c = filter (<. c) $ nub + $ ['a','b','c'] + ++ [ toLower c | isUpper c ] + ++ ['A','B','C'] + ++ ['1','2','3'] + ++ [' ','\n'] + where + a <. b = stamp a < stamp b + stamp a = ( (not (isLower a) + , not (isUpper a) + , not (isDigit a)) + , (not (a==' ') + , not (isSpace a) + , a) + ) + +instance Arbitrary Float where + arbitrary = arbitrarySizedFractional + shrink = shrinkRealFrac + +instance Arbitrary Double where + arbitrary = arbitrarySizedFractional + shrink = shrinkRealFrac + +instance Arbitrary CChar where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CSChar where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CUChar where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CShort where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CUShort where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CInt where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CUInt where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CLong where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CULong where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CPtrdiff where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CSize where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CWchar where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CSigAtomic where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CLLong where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CULLong where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CIntPtr where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CUIntPtr where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CIntMax where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary CUIntMax where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +#ifndef NO_NEWTYPE_DERIVING +-- The following four types have no Bounded instance, +-- so we fake it by discovering the bounds at runtime. +instance Arbitrary CClock where + arbitrary = fmap unBounds arbitrary + shrink = shrinkMap unBounds Bounds + +instance Arbitrary CTime where + arbitrary = fmap unBounds arbitrary + shrink = shrinkMap unBounds Bounds + +#ifndef NO_FOREIGN_C_USECONDS +instance Arbitrary CUSeconds where + arbitrary = fmap unBounds arbitrary + shrink = shrinkMap unBounds Bounds + +instance Arbitrary CSUSeconds where + arbitrary = fmap unBounds arbitrary + shrink = shrinkMap unBounds Bounds +#endif + +newtype Bounds a = Bounds { unBounds :: a } + deriving (Eq, Ord, Num, Enum, Real, Show) + +instance (Ord a, Num a) => Bounded (Bounds a) where + -- assume max has all 1s in binary expansion + maxBound = maximum (nubIterate (\x -> 2*x+1) 1) + -- assume min has a leading 1 and rest 0s in binary expansion (or is 0) + minBound = minimum (0:nubIterate (*2) 1) + +instance (Num a, Real a, Enum a) => Integral (Bounds a) where + toInteger = fromIntegral . fromEnum + x `quotRem` y = + let (z, w) = toInteger x `quotRem` toInteger y in + (fromInteger z, fromInteger w) + +instance (Ord a, Num a, Real a, Enum a) => Arbitrary (Bounds a) where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +-- Like iterate, but stop when you reach an existing value. +nubIterate :: Eq a => (a -> a) -> a -> [a] +nubIterate f x = iter [] x + where + iter xs x + | x `elem` xs = [] + | otherwise = x:iter (x:xs) (f x) +#endif + +instance Arbitrary CFloat where + arbitrary = arbitrarySizedFractional + shrink = shrinkRealFrac + +instance Arbitrary CDouble where + arbitrary = arbitrarySizedFractional + shrink = shrinkRealFrac + +-- Arbitrary instances for container types +instance (Ord a, Arbitrary a) => Arbitrary (Set.Set a) where + arbitrary = fmap Set.fromList arbitrary + shrink = map Set.fromList . shrink . Set.toList +instance (Ord k, Arbitrary k) => Arbitrary1 (Map.Map k) where + liftArbitrary = fmap Map.fromList . liftArbitrary . liftArbitrary + liftShrink shr = map Map.fromList . liftShrink (liftShrink shr) . Map.toList +instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where + arbitrary = arbitrary1 + shrink = shrink1 +instance Arbitrary IntSet.IntSet where + arbitrary = fmap IntSet.fromList arbitrary + shrink = map IntSet.fromList . shrink . IntSet.toList +instance Arbitrary1 IntMap.IntMap where + liftArbitrary = fmap IntMap.fromList . liftArbitrary . liftArbitrary + liftShrink shr = map IntMap.fromList . liftShrink (liftShrink shr) . IntMap.toList +instance Arbitrary a => Arbitrary (IntMap.IntMap a) where + arbitrary = arbitrary1 + shrink = shrink1 +instance Arbitrary1 Sequence.Seq where + liftArbitrary = fmap Sequence.fromList . liftArbitrary + liftShrink shr = map Sequence.fromList . liftShrink shr . toList +instance Arbitrary a => Arbitrary (Sequence.Seq a) where + arbitrary = arbitrary1 + shrink = shrink1 + +-- Arbitrary instance for Ziplist +instance Arbitrary1 ZipList where + liftArbitrary = fmap ZipList . liftArbitrary + liftShrink shr = map ZipList . liftShrink shr . getZipList +instance Arbitrary a => Arbitrary (ZipList a) where + arbitrary = arbitrary1 + shrink = shrink1 + +#ifndef NO_TRANSFORMERS +-- Arbitrary instance for transformers' Functors +instance Arbitrary1 Identity where + liftArbitrary = fmap Identity + liftShrink shr = map Identity . shr . runIdentity +instance Arbitrary a => Arbitrary (Identity a) where + arbitrary = arbitrary1 + shrink = shrink1 + +instance Arbitrary2 Constant where + liftArbitrary2 arbA _ = fmap Constant arbA + liftShrink2 shrA _ = fmap Constant . shrA . getConstant +instance Arbitrary a => Arbitrary1 (Constant a) where + liftArbitrary = liftArbitrary2 arbitrary + liftShrink = liftShrink2 shrink +-- Have to be defined explicitly, as Constant is kind polymorphic +instance Arbitrary a => Arbitrary (Constant a b) where + arbitrary = fmap Constant arbitrary + shrink = map Constant . shrink . getConstant + +instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (Product f g) where + liftArbitrary arb = liftM2 Pair (liftArbitrary arb) (liftArbitrary arb) + liftShrink shr (Pair f g) = + [ Pair f' g | f' <- liftShrink shr f ] ++ + [ Pair f g' | g' <- liftShrink shr g ] +instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (Product f g a) where + arbitrary = arbitrary1 + shrink = shrink1 + +instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (Compose f g) where + liftArbitrary = fmap Compose . liftArbitrary . liftArbitrary + liftShrink shr = map Compose . liftShrink (liftShrink shr) . getCompose +instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (Compose f g a) where + arbitrary = arbitrary1 + shrink = shrink1 +#endif + +-- Arbitrary instance for Const +instance Arbitrary2 Const where + liftArbitrary2 arbA _ = fmap Const arbA + liftShrink2 shrA _ = fmap Const . shrA . getConst +instance Arbitrary a => Arbitrary1 (Const a) where + liftArbitrary = liftArbitrary2 arbitrary + liftShrink = liftShrink2 shrink +-- Have to be defined explicitly, as Const is kind polymorphic +instance Arbitrary a => Arbitrary (Const a b) where + arbitrary = fmap Const arbitrary + shrink = map Const . shrink . getConst + +instance Arbitrary (m a) => Arbitrary (WrappedMonad m a) where + arbitrary = WrapMonad <$> arbitrary + shrink (WrapMonad a) = map WrapMonad (shrink a) + +instance Arbitrary (a b c) => Arbitrary (WrappedArrow a b c) where + arbitrary = WrapArrow <$> arbitrary + shrink (WrapArrow a) = map WrapArrow (shrink a) + +-- Arbitrary instances for Monoid +instance Arbitrary a => Arbitrary (Monoid.Dual a) where + arbitrary = fmap Monoid.Dual arbitrary + shrink = map Monoid.Dual . shrink . Monoid.getDual + +instance (Arbitrary a, CoArbitrary a) => Arbitrary (Monoid.Endo a) where + arbitrary = fmap Monoid.Endo arbitrary + shrink = map Monoid.Endo . shrink . Monoid.appEndo + +instance Arbitrary Monoid.All where + arbitrary = fmap Monoid.All arbitrary + shrink = map Monoid.All . shrink . Monoid.getAll + +instance Arbitrary Monoid.Any where + arbitrary = fmap Monoid.Any arbitrary + shrink = map Monoid.Any . shrink . Monoid.getAny + +instance Arbitrary a => Arbitrary (Monoid.Sum a) where + arbitrary = fmap Monoid.Sum arbitrary + shrink = map Monoid.Sum . shrink . Monoid.getSum + +instance Arbitrary a => Arbitrary (Monoid.Product a) where + arbitrary = fmap Monoid.Product arbitrary + shrink = map Monoid.Product . shrink . Monoid.getProduct + +#if defined(MIN_VERSION_base) +#if MIN_VERSION_base(3,0,0) +instance Arbitrary a => Arbitrary (Monoid.First a) where + arbitrary = fmap Monoid.First arbitrary + shrink = map Monoid.First . shrink . Monoid.getFirst + +instance Arbitrary a => Arbitrary (Monoid.Last a) where + arbitrary = fmap Monoid.Last arbitrary + shrink = map Monoid.Last . shrink . Monoid.getLast +#endif + +#if MIN_VERSION_base(4,8,0) +instance Arbitrary (f a) => Arbitrary (Monoid.Alt f a) where + arbitrary = fmap Monoid.Alt arbitrary + shrink = map Monoid.Alt . shrink . Monoid.getAlt +#endif +#endif + +-- | Generates 'Version' with non-empty non-negative @versionBranch@, and empty @versionTags@ +instance Arbitrary Version where + arbitrary = sized $ \n -> + do k <- choose (0, log2 n) + xs <- vectorOf (k+1) arbitrarySizedNatural + return (Version xs []) + where + log2 :: Int -> Int + log2 n | n <= 1 = 0 + | otherwise = 1 + log2 (n `div` 2) + + shrink (Version xs _) = + [ Version xs' [] + | xs' <- shrink xs + , length xs' > 0 + , all (>=0) xs' + ] + +instance Arbitrary QCGen where + arbitrary = MkGen (\g _ -> g) + +instance Arbitrary ExitCode where + arbitrary = frequency [(1, return ExitSuccess), (3, liftM ExitFailure arbitrary)] + + shrink (ExitFailure x) = ExitSuccess : [ ExitFailure x' | x' <- shrink x ] + shrink _ = [] + + + +-- ** Helper functions for implementing arbitrary + +-- | Generates an integral number. The number can be positive or negative +-- and its maximum absolute value depends on the size parameter. +arbitrarySizedIntegral :: Integral a => Gen a +arbitrarySizedIntegral = + sized $ \n -> + inBounds fromInteger (choose (-toInteger n, toInteger n)) + +-- | Generates a natural number. The number's maximum value depends on +-- the size parameter. +arbitrarySizedNatural :: Integral a => Gen a +arbitrarySizedNatural = + sized $ \n -> + inBounds fromInteger (choose (0, toInteger n)) + +inBounds :: Integral a => (Integer -> a) -> Gen Integer -> Gen a +inBounds fi g = fmap fi (g `suchThat` (\x -> toInteger (fi x) == x)) + +-- | Generates a fractional number. The number can be positive or negative +-- and its maximum absolute value depends on the size parameter. +arbitrarySizedFractional :: Fractional a => Gen a +arbitrarySizedFractional = + sized $ \n -> + let n' = toInteger n in + do a <- choose ((-n') * precision, n' * precision) + b <- choose (1, precision) + return (fromRational (a % b)) + where + precision = 9999999999999 :: Integer + +-- Useful for getting at minBound and maxBound without having to +-- fiddle around with asTypeOf. +withBounds :: Bounded a => (a -> a -> Gen a) -> Gen a +withBounds k = k minBound maxBound + +-- | Generates an integral number. The number is chosen uniformly from +-- the entire range of the type. You may want to use +-- 'arbitrarySizedBoundedIntegral' instead. +arbitraryBoundedIntegral :: (Bounded a, Integral a) => Gen a +arbitraryBoundedIntegral = + withBounds $ \mn mx -> + do n <- choose (toInteger mn, toInteger mx) + return (fromInteger n) + +-- | Generates an element of a bounded type. The element is +-- chosen from the entire range of the type. +arbitraryBoundedRandom :: (Bounded a, Random a) => Gen a +arbitraryBoundedRandom = choose (minBound,maxBound) + +-- | Generates an element of a bounded enumeration. +arbitraryBoundedEnum :: (Bounded a, Enum a) => Gen a +arbitraryBoundedEnum = + withBounds $ \mn mx -> + do n <- choose (fromEnum mn, fromEnum mx) + return (toEnum n) + +-- | Generates an integral number from a bounded domain. The number is +-- chosen from the entire range of the type, but small numbers are +-- generated more often than big numbers. Inspired by demands from +-- Phil Wadler. +arbitrarySizedBoundedIntegral :: (Bounded a, Integral a) => Gen a +arbitrarySizedBoundedIntegral = + withBounds $ \mn mx -> + sized $ \s -> + do let bits n | n == 0 = 0 + | otherwise = 1 + bits (n `quot` 2) + k = 2^(s*(bits mn `max` bits mx `max` 40) `div` 80) + n <- choose (toInteger mn `max` (-k), toInteger mx `min` k) + return (fromInteger n) + +-- ** Generators for various kinds of character + +-- | Generates any Unicode character (but not a surrogate) +arbitraryUnicodeChar :: Gen Char +arbitraryUnicodeChar = + arbitraryBoundedEnum `suchThat` (not . isSurrogate) + where + isSurrogate c = generalCategory c == Surrogate + +-- | Generates a random ASCII character (0-127). +arbitraryASCIIChar :: Gen Char +arbitraryASCIIChar = choose ('\0', '\127') + +-- | Generates a printable Unicode character. +arbitraryPrintableChar :: Gen Char +arbitraryPrintableChar = arbitrary `suchThat` isPrint + +-- ** Helper functions for implementing shrink + +-- | Returns no shrinking alternatives. +shrinkNothing :: a -> [a] +shrinkNothing _ = [] + +-- | Map a shrink function to another domain. This is handy if your data type +-- has special invariants, but is /almost/ isomorphic to some other type. +-- +-- @ +-- shrinkOrderedList :: (Ord a, Arbitrary a) => [a] -> [[a]] +-- shrinkOrderedList = shrinkMap sort id +-- +-- shrinkSet :: (Ord a, Arbitrary a) => Set a -> Set [a] +-- shrinkSet = shrinkMap fromList toList +-- @ +shrinkMap :: Arbitrary a => (a -> b) -> (b -> a) -> b -> [b] +shrinkMap f g = shrinkMapBy f g shrink + +-- | Non-overloaded version of `shrinkMap`. +shrinkMapBy :: (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b] +shrinkMapBy f g shr = map f . shr . g + +-- | Shrink an integral number. +shrinkIntegral :: Integral a => a -> [a] +shrinkIntegral x = + nub $ + [ -x + | x < 0, -x > x + ] ++ + [ x' + | x' <- takeWhile (<< x) (0:[ x - i | i <- tail (iterate (`quot` 2) x) ]) + ] + where + -- a << b is "morally" abs a < abs b, but taking care of overflow. + a << b = case (a >= 0, b >= 0) of + (True, True) -> a < b + (False, False) -> a > b + (True, False) -> a + b < 0 + (False, True) -> a + b > 0 + +-- | Shrink a fraction. +shrinkRealFrac :: RealFrac a => a -> [a] +shrinkRealFrac x = + nub $ + [ -x + | x < 0 + ] ++ + map fromInteger (shrinkIntegral (truncate x)) + +-------------------------------------------------------------------------- +-- ** CoArbitrary + +#ifndef NO_GENERICS +-- | Used for random generation of functions. +-- +-- If you are using a recent GHC, there is a default definition of +-- 'coarbitrary' using 'genericCoarbitrary', so if your type has a +-- 'Generic' instance it's enough to say +-- +-- > instance CoArbitrary MyType +-- +-- You should only use 'genericCoarbitrary' for data types where +-- equality is structural, i.e. if you can't have two different +-- representations of the same value. An example where it's not +-- safe is sets implemented using binary search trees: the same +-- set can be represented as several different trees. +-- Here you would have to explicitly define +-- @coarbitrary s = coarbitrary (toList s)@. +#else +-- | Used for random generation of functions. +#endif +class CoArbitrary a where + -- | Used to generate a function of type @a -> b@. + -- The first argument is a value, the second a generator. + -- You should use 'variant' to perturb the random generator; + -- the goal is that different values for the first argument will + -- lead to different calls to 'variant'. An example will help: + -- + -- @ + -- instance CoArbitrary a => CoArbitrary [a] where + -- coarbitrary [] = 'variant' 0 + -- coarbitrary (x:xs) = 'variant' 1 . coarbitrary (x,xs) + -- @ + coarbitrary :: a -> Gen b -> Gen b +#ifndef NO_GENERICS + default coarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b + coarbitrary = genericCoarbitrary + +-- | Generic CoArbitrary implementation. +genericCoarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b +genericCoarbitrary = gCoarbitrary . from + +class GCoArbitrary f where + gCoarbitrary :: f a -> Gen b -> Gen b + +instance GCoArbitrary U1 where + gCoarbitrary U1 = id + +instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :*: g) where + -- Like the instance for tuples. + gCoarbitrary (l :*: r) = gCoarbitrary l . gCoarbitrary r + +instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :+: g) where + -- Like the instance for Either. + gCoarbitrary (L1 x) = variant 0 . gCoarbitrary x + gCoarbitrary (R1 x) = variant 1 . gCoarbitrary x + +instance GCoArbitrary f => GCoArbitrary (M1 i c f) where + gCoarbitrary (M1 x) = gCoarbitrary x + +instance CoArbitrary a => GCoArbitrary (K1 i a) where + gCoarbitrary (K1 x) = coarbitrary x +#endif + +{-# DEPRECATED (><) "Use ordinary function composition instead" #-} +-- | Combine two generator perturbing functions, for example the +-- results of calls to 'variant' or 'coarbitrary'. +(><) :: (Gen a -> Gen a) -> (Gen a -> Gen a) -> (Gen a -> Gen a) +(><) = (.) + +instance (Arbitrary a, CoArbitrary b) => CoArbitrary (a -> b) where + coarbitrary f gen = + do xs <- arbitrary + coarbitrary (map f xs) gen + +instance CoArbitrary () where + coarbitrary _ = id + +instance CoArbitrary Bool where + coarbitrary False = variant 0 + coarbitrary True = variant 1 + +instance CoArbitrary Ordering where + coarbitrary GT = variant 0 + coarbitrary EQ = variant 1 + coarbitrary LT = variant 2 + +instance CoArbitrary a => CoArbitrary (Maybe a) where + coarbitrary Nothing = variant 0 + coarbitrary (Just x) = variant 1 . coarbitrary x + +instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Either a b) where + coarbitrary (Left x) = variant 0 . coarbitrary x + coarbitrary (Right y) = variant 1 . coarbitrary y + +instance CoArbitrary a => CoArbitrary [a] where + coarbitrary [] = variant 0 + coarbitrary (x:xs) = variant 1 . coarbitrary (x,xs) + +instance (Integral a, CoArbitrary a) => CoArbitrary (Ratio a) where + coarbitrary r = coarbitrary (numerator r,denominator r) + +#ifndef NO_FIXED +instance HasResolution a => CoArbitrary (Fixed a) where + coarbitrary = coarbitraryReal +#endif + +instance (RealFloat a, CoArbitrary a) => CoArbitrary (Complex a) where + coarbitrary (x :+ y) = coarbitrary x . coarbitrary y + +instance (CoArbitrary a, CoArbitrary b) + => CoArbitrary (a,b) + where + coarbitrary (x,y) = coarbitrary x + . coarbitrary y + +instance (CoArbitrary a, CoArbitrary b, CoArbitrary c) + => CoArbitrary (a,b,c) + where + coarbitrary (x,y,z) = coarbitrary x + . coarbitrary y + . coarbitrary z + +instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d) + => CoArbitrary (a,b,c,d) + where + coarbitrary (x,y,z,v) = coarbitrary x + . coarbitrary y + . coarbitrary z + . coarbitrary v + +instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d, CoArbitrary e) + => CoArbitrary (a,b,c,d,e) + where + coarbitrary (x,y,z,v,w) = coarbitrary x + . coarbitrary y + . coarbitrary z + . coarbitrary v + . coarbitrary w + +-- typical instance for primitive (numerical) types + +instance CoArbitrary Integer where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Int where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Int8 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Int16 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Int32 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Int64 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Word where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Word8 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Word16 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Word32 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Word64 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Char where + coarbitrary = coarbitrary . ord + +instance CoArbitrary Float where + coarbitrary = coarbitraryReal + +instance CoArbitrary Double where + coarbitrary = coarbitraryReal + +-- Coarbitrary instances for container types +instance CoArbitrary a => CoArbitrary (Set.Set a) where + coarbitrary = coarbitrary. Set.toList +instance (CoArbitrary k, CoArbitrary v) => CoArbitrary (Map.Map k v) where + coarbitrary = coarbitrary . Map.toList +instance CoArbitrary IntSet.IntSet where + coarbitrary = coarbitrary . IntSet.toList +instance CoArbitrary a => CoArbitrary (IntMap.IntMap a) where + coarbitrary = coarbitrary . IntMap.toList +instance CoArbitrary a => CoArbitrary (Sequence.Seq a) where + coarbitrary = coarbitrary . toList + +-- CoArbitrary instance for Ziplist +instance CoArbitrary a => CoArbitrary (ZipList a) where + coarbitrary = coarbitrary . getZipList + +#ifndef NO_TRANSFORMERS +-- CoArbitrary instance for transformers' Functors +instance CoArbitrary a => CoArbitrary (Identity a) where + coarbitrary = coarbitrary . runIdentity + +instance CoArbitrary a => CoArbitrary (Constant a b) where + coarbitrary = coarbitrary . getConstant +#endif + +-- CoArbitrary instance for Const +instance CoArbitrary a => CoArbitrary (Const a b) where + coarbitrary = coarbitrary . getConst + +-- CoArbitrary instances for Monoid +instance CoArbitrary a => CoArbitrary (Monoid.Dual a) where + coarbitrary = coarbitrary . Monoid.getDual + +instance (Arbitrary a, CoArbitrary a) => CoArbitrary (Monoid.Endo a) where + coarbitrary = coarbitrary . Monoid.appEndo + +instance CoArbitrary Monoid.All where + coarbitrary = coarbitrary . Monoid.getAll + +instance CoArbitrary Monoid.Any where + coarbitrary = coarbitrary . Monoid.getAny + +instance CoArbitrary a => CoArbitrary (Monoid.Sum a) where + coarbitrary = coarbitrary . Monoid.getSum + +instance CoArbitrary a => CoArbitrary (Monoid.Product a) where + coarbitrary = coarbitrary . Monoid.getProduct + +#if defined(MIN_VERSION_base) +#if MIN_VERSION_base(3,0,0) +instance CoArbitrary a => CoArbitrary (Monoid.First a) where + coarbitrary = coarbitrary . Monoid.getFirst + +instance CoArbitrary a => CoArbitrary (Monoid.Last a) where + coarbitrary = coarbitrary . Monoid.getLast +#endif + +#if MIN_VERSION_base(4,8,0) +instance CoArbitrary (f a) => CoArbitrary (Monoid.Alt f a) where + coarbitrary = coarbitrary . Monoid.getAlt +#endif +#endif + +instance CoArbitrary Version where + coarbitrary (Version a b) = coarbitrary (a, b) + +-- ** Helpers for implementing coarbitrary + +-- | A 'coarbitrary' implementation for integral numbers. +coarbitraryIntegral :: Integral a => a -> Gen b -> Gen b +coarbitraryIntegral = variant + +-- | A 'coarbitrary' implementation for real numbers. +coarbitraryReal :: Real a => a -> Gen b -> Gen b +coarbitraryReal x = coarbitrary (toRational x) + +-- | 'coarbitrary' helper for lazy people :-). +coarbitraryShow :: Show a => a -> Gen b -> Gen b +coarbitraryShow x = coarbitrary (show x) + +-- | A 'coarbitrary' implementation for enums. +coarbitraryEnum :: Enum a => a -> Gen b -> Gen b +coarbitraryEnum = variant . fromEnum + +-------------------------------------------------------------------------- +-- ** arbitrary generators + +-- these are here and not in Gen because of the Arbitrary class constraint + +-- | Generates a list of a given length. +vector :: Arbitrary a => Int -> Gen [a] +vector k = vectorOf k arbitrary + +-- | Generates an ordered list. +orderedList :: (Ord a, Arbitrary a) => Gen [a] +orderedList = sort `fmap` arbitrary + +-- | Generates an infinite list. +infiniteList :: Arbitrary a => Gen [a] +infiniteList = infiniteListOf arbitrary + +-------------------------------------------------------------------------- +-- the end. diff --git a/Test/QuickCheck/Exception.hs b/Test/QuickCheck/Exception.hs new file mode 100644 index 0000000..502b4a2 --- /dev/null +++ b/Test/QuickCheck/Exception.hs @@ -0,0 +1,113 @@ +-- | Throwing and catching exceptions. Internal QuickCheck module. + +-- Hide away the nasty implementation-specific ways of catching +-- exceptions behind a nice API. The main trouble is catching ctrl-C. + +{-# LANGUAGE CPP #-} +module Test.QuickCheck.Exception where + +#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 700) +#define OLD_EXCEPTIONS +#endif + +#if defined(NO_EXCEPTIONS) +#else +import qualified Control.Exception as E +#endif + +#if defined(NO_EXCEPTIONS) +type AnException = () +#elif defined(OLD_EXCEPTIONS) +type AnException = E.Exception +#else +type AnException = E.SomeException +#endif + +#ifdef NO_EXCEPTIONS +tryEvaluate :: a -> IO (Either AnException a) +tryEvaluate x = return (Right x) + +tryEvaluateIO :: IO a -> IO (Either AnException a) +tryEvaluateIO m = fmap Right m + +evaluate :: a -> IO a +evaluate x = x `seq` return x + +isInterrupt :: AnException -> Bool +isInterrupt _ = False + +discard :: a +discard = error "'discard' not supported, since your Haskell system can't catch exceptions" + +isDiscard :: AnException -> Bool +isDiscard _ = False + +finally :: IO a -> IO b -> IO a +finally mx my = do + x <- mx + my + return x + +#else +-------------------------------------------------------------------------- +-- try evaluate + +tryEvaluate :: a -> IO (Either AnException a) +tryEvaluate x = tryEvaluateIO (return x) + +tryEvaluateIO :: IO a -> IO (Either AnException a) +tryEvaluateIO m = E.tryJust notAsync (m >>= E.evaluate) + where + notAsync :: E.SomeException -> Maybe AnException +#if MIN_VERSION_base(4,7,0) + notAsync e = case E.fromException e of + Just (E.SomeAsyncException _) -> Nothing + Nothing -> Just e +#else + notAsync e = case E.fromException e :: Maybe E.AsyncException of + Just _ -> Nothing + Nothing -> Just e +#endif + +--tryEvaluateIO m = Right `fmap` m + +evaluate :: a -> IO a +evaluate = E.evaluate + +-- | Test if an exception was a @^C@. +-- QuickCheck won't try to shrink an interrupted test case. +isInterrupt :: AnException -> Bool + +#if defined(OLD_EXCEPTIONS) +isInterrupt _ = False +#else +isInterrupt e = E.fromException e == Just E.UserInterrupt +#endif + +-- | A special exception that makes QuickCheck discard the test case. +-- Normally you should use '==>', but if for some reason this isn't +-- possible (e.g. you are deep inside a generator), use 'discard' +-- instead. +discard :: a + +isDiscard :: AnException -> Bool +(discard, isDiscard) = (E.throw (E.ErrorCall msg), isDiscard) + where + msg = "DISCARD. " ++ + "You should not see this exception, it is internal to QuickCheck." +#if defined(OLD_EXCEPTIONS) + isDiscard (E.ErrorCall msg') = msg' == msg + isDiscard _ = False +#else + isDiscard e = + case E.fromException e of + Just (E.ErrorCall msg') -> msg' == msg + _ -> False +#endif + +finally :: IO a -> IO b -> IO a +finally = E.finally +#endif + +-------------------------------------------------------------------------- +-- the end. diff --git a/Test/QuickCheck/Function.hs b/Test/QuickCheck/Function.hs new file mode 100644 index 0000000..2a36d6d --- /dev/null +++ b/Test/QuickCheck/Function.hs @@ -0,0 +1,531 @@ +{-# LANGUAGE TypeOperators, GADTs, CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} +#endif +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +#endif + +#ifndef NO_GENERICS +{-# LANGUAGE DefaultSignatures, FlexibleContexts #-} +#endif + +#ifndef NO_POLYKINDS +{-# LANGUAGE PolyKinds #-} +#endif + +-- | Generation of random shrinkable, showable functions. +-- See the paper \"Shrinking and showing functions\" by Koen Claessen. +-- +-- Example of use: +-- +-- >>> :{ +-- >>> let prop :: Fun String Integer -> Bool +-- >>> prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant" +-- >>> :} +-- >>> quickCheck prop +-- *** Failed! Falsifiable (after 3 tests and 134 shrinks): +-- {"elephant"->1, "monkey"->1, _->0} +-- +-- To generate random values of type @'Fun' a b@, +-- you must have an instance @'Function' a@. +-- If your type has a 'Show' instance, you can use 'functionShow' to write the instance; otherwise, +-- use 'functionMap' to give a bijection between your type and a type that is already an instance of 'Function'. +-- See the @'Function' [a]@ instance for an example of the latter. +module Test.QuickCheck.Function + ( Fun(..) + , applyFun + , apply + , applyFun2 + , applyFun3 + , (:->) + , Function(..) + , functionMap + , functionShow + , functionIntegral + , functionRealFrac + , functionBoundedEnum +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 + , pattern Fn + , pattern Fn2 + , pattern Fn3 +#endif + ) + where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Poly + +import Data.Char +import Data.Word +import Data.List( intersperse ) +import Data.Ratio +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Sequence as Sequence +import Data.Int +import Data.Complex +import Data.Foldable(toList) + +#ifndef NO_FIXED +import Data.Fixed +#endif + +#ifndef NO_GENERICS +import GHC.Generics hiding (C) +#endif + +-------------------------------------------------------------------------- +-- concrete functions + +-- | The type of possibly partial concrete functions +data a :-> c where + Pair :: (a :-> (b :-> c)) -> ((a,b) :-> c) + (:+:) :: (a :-> c) -> (b :-> c) -> (Either a b :-> c) + Unit :: c -> (() :-> c) + Nil :: a :-> c + Table :: Eq a => [(a,c)] -> (a :-> c) + Map :: (a -> b) -> (b -> a) -> (b :-> c) -> (a :-> c) + +instance Functor ((:->) a) where + fmap f (Pair p) = Pair (fmap (fmap f) p) + fmap f (p:+:q) = fmap f p :+: fmap f q + fmap f (Unit c) = Unit (f c) + fmap f Nil = Nil + fmap f (Table xys) = Table [ (x,f y) | (x,y) <- xys ] + fmap f (Map g h p) = Map g h (fmap f p) + +instance (Show a, Show b) => Show (a:->b) where + show p = showFunction p Nothing + +-- only use this on finite functions +showFunction :: (Show a, Show b) => (a :-> b) -> Maybe b -> String +showFunction p md = + "{" ++ concat (intersperse ", " ( [ show x ++ "->" ++ show c + | (x,c) <- table p + ] + ++ [ "_->" ++ show d + | Just d <- [md] + ] )) ++ "}" + +-- turning a concrete function into an abstract function (with a default result) +abstract :: (a :-> c) -> c -> (a -> c) +abstract (Pair p) d (x,y) = abstract (fmap (\q -> abstract q d y) p) d x +abstract (p :+: q) d exy = either (abstract p d) (abstract q d) exy +abstract (Unit c) _ _ = c +abstract Nil d _ = d +abstract (Table xys) d x = head ([y | (x',y) <- xys, x == x'] ++ [d]) +abstract (Map g _ p) d x = abstract p d (g x) + +-- generating a table from a concrete function +table :: (a :-> c) -> [(a,c)] +table (Pair p) = [ ((x,y),c) | (x,q) <- table p, (y,c) <- table q ] +table (p :+: q) = [ (Left x, c) | (x,c) <- table p ] + ++ [ (Right y,c) | (y,c) <- table q ] +table (Unit c) = [ ((), c) ] +table Nil = [] +table (Table xys) = xys +table (Map _ h p) = [ (h x, c) | (x,c) <- table p ] + +-------------------------------------------------------------------------- +-- Function + +-- | The class @Function a@ is used for random generation of showable +-- functions of type @a -> b@. +-- +-- There is a default implementation for 'function', which you can use +-- if your type has structural equality. Otherwise, you can normally +-- use 'functionMap' or 'functionShow'. +class Function a where + function :: (a->b) -> (a:->b) +#ifndef NO_GENERICS + default function :: (Generic a, GFunction (Rep a)) => (a->b) -> (a:->b) + function = genericFunction +#endif + +-- basic instances + +-- | Provides a 'Function' instance for types with 'Bounded' and 'Enum'. +-- Use only for small types (i.e. not integers): creates +-- the list @['minBound'..'maxBound']@! +functionBoundedEnum :: (Eq a, Bounded a, Enum a) => (a->b) -> (a:->b) +functionBoundedEnum f = Table [(x,f x) | x <- [minBound..maxBound]] + +-- | Provides a 'Function' instance for types with 'RealFrac'. +functionRealFrac :: RealFrac a => (a->b) -> (a:->b) +functionRealFrac = functionMap toRational fromRational + +-- | Provides a 'Function' instance for types with 'Integral'. +functionIntegral :: Integral a => (a->b) -> (a:->b) +functionIntegral = functionMap fromIntegral fromInteger + +-- | Provides a 'Function' instance for types with 'Show' and 'Read'. +functionShow :: (Show a, Read a) => (a->c) -> (a:->c) +functionShow f = functionMap show read f + +-- | The basic building block for 'Function' instances. +-- Provides a 'Function' instance by mapping to and from a type that +-- already has a 'Function' instance. +functionMap :: Function b => (a->b) -> (b->a) -> (a->c) -> (a:->c) +functionMap = functionMapWith function + +functionMapWith :: ((b->c) -> (b:->c)) -> (a->b) -> (b->a) -> (a->c) -> (a:->c) +functionMapWith function g h f = Map g h (function (\b -> f (h b))) + +instance Function () where + function f = Unit (f ()) + +instance (Function a, Function b) => Function (a,b) where + function = functionPairWith function function + +functionPairWith :: ((a->b->c) -> (a:->(b->c))) -> ((b->c) -> (b:->c)) -> ((a,b)->c) -> ((a,b):->c) +functionPairWith func1 func2 f = Pair (func2 `fmap` func1 (curry f)) + +instance (Function a, Function b) => Function (Either a b) where + function = functionEitherWith function function + +functionEitherWith :: ((a->c) -> (a:->c)) -> ((b->c) -> (b:->c)) -> (Either a b->c) -> (Either a b:->c) +functionEitherWith func1 func2 f = func1 (f . Left) :+: func2 (f . Right) + +-- tuple convenience instances + +instance (Function a, Function b, Function c) => Function (a,b,c) where + function = functionMap (\(a,b,c) -> (a,(b,c))) (\(a,(b,c)) -> (a,b,c)) + +instance (Function a, Function b, Function c, Function d) => Function (a,b,c,d) where + function = functionMap (\(a,b,c,d) -> (a,(b,c,d))) (\(a,(b,c,d)) -> (a,b,c,d)) + +instance (Function a, Function b, Function c, Function d, Function e) => Function (a,b,c,d,e) where + function = functionMap (\(a,b,c,d,e) -> (a,(b,c,d,e))) (\(a,(b,c,d,e)) -> (a,b,c,d,e)) + +instance (Function a, Function b, Function c, Function d, Function e, Function f) => Function (a,b,c,d,e,f) where + function = functionMap (\(a,b,c,d,e,f) -> (a,(b,c,d,e,f))) (\(a,(b,c,d,e,f)) -> (a,b,c,d,e,f)) + +instance (Function a, Function b, Function c, Function d, Function e, Function f, Function g) => Function (a,b,c,d,e,f,g) where + function = functionMap (\(a,b,c,d,e,f,g) -> (a,(b,c,d,e,f,g))) (\(a,(b,c,d,e,f,g)) -> (a,b,c,d,e,f,g)) + +-- other instances + +instance Function a => Function [a] where + function = functionMap g h + where + g [] = Left () + g (x:xs) = Right (x,xs) + + h (Left _) = [] + h (Right (x,xs)) = x:xs + +instance Function a => Function (Maybe a) where + function = functionMap g h + where + g Nothing = Left () + g (Just x) = Right x + + h (Left _) = Nothing + h (Right x) = Just x + +instance Function Bool where + function = functionMap g h + where + g False = Left () + g True = Right () + + h (Left _) = False + h (Right _) = True + +instance Function Integer where + function = functionMap gInteger hInteger + where + gInteger n | n < 0 = Left (gNatural (abs n - 1)) + | otherwise = Right (gNatural n) + + hInteger (Left ws) = -(hNatural ws + 1) + hInteger (Right ws) = hNatural ws + + gNatural 0 = [] + gNatural n = (fromIntegral (n `mod` 256) :: Word8) : gNatural (n `div` 256) + + hNatural [] = 0 + hNatural (w:ws) = fromIntegral w + 256 * hNatural ws + +instance Function Int where + function = functionIntegral + +instance Function Word where + function = functionIntegral + +instance Function Char where + function = functionMap ord chr + +instance Function Float where + function = functionRealFrac + +instance Function Double where + function = functionRealFrac + +-- instances for assorted types in the base package + +instance Function Ordering where + function = functionMap g h + where + g LT = Left False + g EQ = Left True + g GT = Right () + + h (Left False) = LT + h (Left True) = EQ + h (Right _) = GT + +instance (Integral a, Function a) => Function (Ratio a) where + function = functionMap g h + where + g r = (numerator r, denominator r) + h (n, d) = n % d + +#ifndef NO_FIXED +instance HasResolution a => Function (Fixed a) where + function = functionRealFrac +#endif + +instance (RealFloat a, Function a) => Function (Complex a) where + function = functionMap g h + where + g (x :+ y) = (x, y) + h (x, y) = x :+ y + +instance (Ord a, Function a) => Function (Set.Set a) where + function = functionMap Set.toList Set.fromList + +instance (Ord a, Function a, Function b) => Function (Map.Map a b) where + function = functionMap Map.toList Map.fromList + +instance Function IntSet.IntSet where + function = functionMap IntSet.toList IntSet.fromList + +instance Function a => Function (IntMap.IntMap a) where + function = functionMap IntMap.toList IntMap.fromList + +instance Function a => Function (Sequence.Seq a) where + function = functionMap toList Sequence.fromList + +instance Function Int8 where + function = functionBoundedEnum + +instance Function Int16 where + function = functionIntegral + +instance Function Int32 where + function = functionIntegral + +instance Function Int64 where + function = functionIntegral + +instance Function Word8 where + function = functionBoundedEnum + +instance Function Word16 where + function = functionIntegral + +instance Function Word32 where + function = functionIntegral + +instance Function Word64 where + function = functionIntegral + +-- poly instances + +instance Function A where + function = functionMap unA A + +instance Function B where + function = functionMap unB B + +instance Function C where + function = functionMap unC C + +instance Function OrdA where + function = functionMap unOrdA OrdA + +instance Function OrdB where + function = functionMap unOrdB OrdB + +instance Function OrdC where + function = functionMap unOrdC OrdC + +-- instance Arbitrary + +instance (Function a, CoArbitrary a, Arbitrary b) => Arbitrary (a:->b) where + arbitrary = function `fmap` arbitrary + shrink = shrinkFun shrink + +-------------------------------------------------------------------------- +-- generic function instances + +#ifndef NO_GENERICS +-- | Generic 'Function' implementation. +genericFunction :: (Generic a, GFunction (Rep a)) => (a->b) -> (a:->b) +genericFunction = functionMapWith gFunction from to + +class GFunction f where + gFunction :: (f a -> b) -> (f a :-> b) + +instance GFunction U1 where + gFunction = functionMap (\U1 -> ()) (\() -> U1) + +instance (GFunction f, GFunction g) => GFunction (f :*: g) where + gFunction = functionMapWith (functionPairWith gFunction gFunction) g h + where + g (x :*: y) = (x, y) + h (x, y) = x :*: y + +instance (GFunction f, GFunction g) => GFunction (f :+: g) where + gFunction = functionMapWith (functionEitherWith gFunction gFunction) g h + where + g (L1 x) = Left x + g (R1 x) = Right x + h (Left x) = L1 x + h (Right x) = R1 x + +instance GFunction f => GFunction (M1 i c f) where + gFunction = functionMapWith gFunction (\(M1 x) -> x) M1 + +instance Function a => GFunction (K1 i a) where + gFunction = functionMap (\(K1 x) -> x) K1 +#endif + +-------------------------------------------------------------------------- +-- shrinking + +shrinkFun :: (c -> [c]) -> (a :-> c) -> [a :-> c] +shrinkFun shr (Pair p) = + [ pair p' | p' <- shrinkFun (\q -> shrinkFun shr q) p ] + where + pair Nil = Nil + pair p = Pair p + +shrinkFun shr (p :+: q) = + [ p .+. Nil | not (isNil q) ] ++ + [ Nil .+. q | not (isNil p) ] ++ + [ p .+. q' | q' <- shrinkFun shr q ] ++ + [ p' .+. q | p' <- shrinkFun shr p ] + where + isNil :: (a :-> b) -> Bool + isNil Nil = True + isNil _ = False + + Nil .+. Nil = Nil + p .+. q = p :+: q + +shrinkFun shr (Unit c) = + [ Nil ] ++ + [ Unit c' | c' <- shr c ] + +shrinkFun shr (Table xys) = + [ table xys' | xys' <- shrinkList shrXy xys ] + where + shrXy (x,y) = [(x,y') | y' <- shr y] + + table [] = Nil + table xys = Table xys + +shrinkFun shr Nil = + [] + +shrinkFun shr (Map g h p) = + [ mapp g h p' | p' <- shrinkFun shr p ] + where + mapp g h Nil = Nil + mapp g h p = Map g h p + +-------------------------------------------------------------------------- +-- the Fun modifier + +-- | Generation of random shrinkable, showable functions. +-- +-- To generate random values of type @'Fun' a b@, +-- you must have an instance @'Function' a@. +-- +-- See also 'applyFun', and 'Fn' with GHC >= 7.8. +data Fun a b = Fun (a :-> b, b, Shrunk) (a -> b) +data Shrunk = Shrunk | NotShrunk deriving Eq + +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 +-- | A modifier for testing functions. +-- +-- > prop :: Fun String Integer -> Bool +-- > prop (Fn f) = f "banana" == f "monkey" +-- > || f "banana" == f "elephant" +#if __GLASGOW_HASKELL__ >= 800 +pattern Fn :: (a -> b) -> Fun a b +#endif +pattern Fn f <- (applyFun -> f) + +-- | A modifier for testing binary functions. +-- +-- > prop_zipWith :: Fun (Int, Bool) Char -> [Int] -> [Bool] -> Bool +-- > prop_zipWith (Fn2 f) xs ys = zipWith f xs ys == [ f x y | (x, y) <- zip xs ys] +#if __GLASGOW_HASKELL__ >= 800 +pattern Fn2 :: (a -> b -> c) -> Fun (a, b) c +#endif +pattern Fn2 f <- (applyFun2 -> f) + +-- | A modifier for testing ternary functions. +#if __GLASGOW_HASKELL__ >= 800 +pattern Fn3 :: (a -> b -> c -> d) -> Fun (a, b, c) d +#endif +pattern Fn3 f <- (applyFun3 -> f) +#endif + +mkFun :: (a :-> b) -> b -> Fun a b +mkFun p d = Fun (p, d, NotShrunk) (abstract p d) + +-- | Alias to 'applyFun'. +apply :: Fun a b -> (a -> b) +apply = applyFun + +-- | Extracts the value of a function. +-- +-- 'Fn' is the pattern equivalent of this function. +-- +-- > prop :: Fun String Integer -> Bool +-- > prop f = applyFun f "banana" == applyFun f "monkey" +-- > || applyFun f "banana" == applyFun f "elephant" +applyFun :: Fun a b -> (a -> b) +applyFun (Fun _ f) = f + +-- | Extracts the value of a binary function. +-- +-- 'Fn2' is the pattern equivalent of this function. +-- +-- > prop_zipWith :: Fun (Int, Bool) Char -> [Int] -> [Bool] -> Bool +-- > prop_zipWith f xs ys = zipWith (applyFun2 f) xs ys == [ applyFun2 f x y | (x, y) <- zip xs ys] +-- +applyFun2 :: Fun (a, b) c -> (a -> b -> c) +applyFun2 (Fun _ f) a b = f (a, b) + +-- | Extracts the value of a ternary function. 'Fn3' is the +-- pattern equivalent of this function. +applyFun3 :: Fun (a, b, c) d -> (a -> b -> c -> d) +applyFun3 (Fun _ f) a b c = f (a, b, c) + +instance (Show a, Show b) => Show (Fun a b) where + show (Fun (_, _, NotShrunk) _) = "" + show (Fun (p, d, Shrunk) _) = showFunction p (Just d) + +instance (Function a, CoArbitrary a, Arbitrary b) => Arbitrary (Fun a b) where + arbitrary = + do p <- arbitrary + d <- arbitrary + return (mkFun p d) + + shrink (Fun (p, d, s) f) = + [ mkFun p' d' | (p', d') <- shrink (p, d) ] ++ + [ Fun (p, d, Shrunk) f | s == NotShrunk ] + +-------------------------------------------------------------------------- +-- the end. diff --git a/Test/QuickCheck/Gen.hs b/Test/QuickCheck/Gen.hs new file mode 100644 index 0000000..5894e06 --- /dev/null +++ b/Test/QuickCheck/Gen.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE CPP #-} +#ifndef NO_ST_MONAD +{-# LANGUAGE Rank2Types #-} +#endif +-- | Test case generation. +module Test.QuickCheck.Gen where + +-------------------------------------------------------------------------- +-- imports + +import System.Random + ( Random + , random + , randomR + , split + ) + +import Control.Monad + ( ap + , replicateM + , filterM + ) + +import Control.Applicative + ( Applicative(..) ) + +import Test.QuickCheck.Random +import Data.List +import Data.Ord +import Data.Maybe + +-------------------------------------------------------------------------- +-- ** Generator type + +-- | A generator for values of type @a@. +-- +-- The third-party package +-- +-- provides a monad transformer version of @GenT@. +newtype Gen a = MkGen{ + unGen :: QCGen -> Int -> a -- ^ Run the generator on a particular seed. + -- If you just want to get a random value out, consider using 'generate'. + } + +instance Functor Gen where + fmap f (MkGen h) = + MkGen (\r n -> f (h r n)) + +instance Applicative Gen where + pure = return + (<*>) = ap + +instance Monad Gen where + return x = + MkGen (\_ _ -> x) + + MkGen m >>= k = + MkGen (\r n -> + case split r of + (r1, r2) -> + let MkGen m' = k (m r1 n) + in m' r2 n + ) + +-------------------------------------------------------------------------- +-- ** Primitive generator combinators + +-- | Modifies a generator using an integer seed. +variant :: Integral n => n -> Gen a -> Gen a +variant k (MkGen g) = MkGen (\r n -> g (variantQCGen k r) n) + +-- | Used to construct generators that depend on the size parameter. +-- +-- For example, 'listOf', which uses the size parameter as an upper bound on +-- length of lists it generates, can be defined like this: +-- +-- > listOf :: Gen a -> Gen [a] +-- > listOf gen = sized $ \n -> +-- > do k <- choose (0,n) +-- > vectorOf k gen +-- +-- You can also do this using 'getSize'. +sized :: (Int -> Gen a) -> Gen a +sized f = MkGen (\r n -> let MkGen m = f n in m r n) + +-- | Generates the size parameter. Used to construct generators that depend on +-- the size parameter. +-- +-- For example, 'listOf', which uses the size parameter as an upper bound on +-- length of lists it generates, can be defined like this: +-- +-- > listOf :: Gen a -> Gen [a] +-- > listOf gen = do +-- > n <- getSize +-- > k <- choose (0,n) +-- > vectorOf k gen +-- +-- You can also do this using 'sized'. +getSize :: Gen Int +getSize = sized pure + +-- | Overrides the size parameter. Returns a generator which uses +-- the given size instead of the runtime-size parameter. +resize :: Int -> Gen a -> Gen a +resize n _ | n < 0 = error "Test.QuickCheck.resize: negative size" +resize n (MkGen g) = MkGen (\r _ -> g r n) + +-- | Adjust the size parameter, by transforming it with the given +-- function. +scale :: (Int -> Int) -> Gen a -> Gen a +scale f g = sized (\n -> resize (f n) g) + +-- | Generates a random element in the given inclusive range. +choose :: Random a => (a,a) -> Gen a +choose rng = MkGen (\r _ -> let (x,_) = randomR rng r in x) + +-- | Generates a random element over the natural range of `a`. +chooseAny :: Random a => Gen a +chooseAny = MkGen (\r _ -> let (x,_) = random r in x) + +-- | Run a generator. The size passed to the generator is always 30; +-- if you want another size then you should explicitly use 'resize'. +generate :: Gen a -> IO a +generate (MkGen g) = + do r <- newQCGen + return (g r 30) + +-- | Generates some example values. +sample' :: Gen a -> IO [a] +sample' g = + generate (sequence [ resize n g | n <- [0,2..20] ]) + +-- | Generates some example values and prints them to 'stdout'. +sample :: Show a => Gen a -> IO () +sample g = + do cases <- sample' g + mapM_ print cases + +-------------------------------------------------------------------------- +-- ** Common generator combinators + +-- | Generates a value that satisfies a predicate. +suchThat :: Gen a -> (a -> Bool) -> Gen a +gen `suchThat` p = + do mx <- gen `suchThatMaybe` p + case mx of + Just x -> return x + Nothing -> sized (\n -> resize (n+1) (gen `suchThat` p)) + +-- | Generates a value for which the given function returns a 'Just', and then +-- applies the function. +suchThatMap :: Gen a -> (a -> Maybe b) -> Gen b +gen `suchThatMap` f = + fmap fromJust $ fmap f gen `suchThat` isJust + +-- | Tries to generate a value that satisfies a predicate. +-- If it fails to do so after enough attempts, returns @Nothing@. +suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a) +gen `suchThatMaybe` p = sized (try 0 . max 1) + where + try _ 0 = return Nothing + try k n = do x <- resize (2*k+n) gen + if p x then return (Just x) else try (k+1) (n-1) + +-- | Randomly uses one of the given generators. The input list +-- must be non-empty. +oneof :: [Gen a] -> Gen a +oneof [] = error "QuickCheck.oneof used with empty list" +oneof gs = choose (0,length gs - 1) >>= (gs !!) + +-- | Chooses one of the given generators, with a weighted random distribution. +-- The input list must be non-empty. +frequency :: [(Int, Gen a)] -> Gen a +frequency [] = error "QuickCheck.frequency used with empty list" +frequency xs0 = choose (1, tot) >>= (`pick` xs0) + where + tot = sum (map fst xs0) + + pick n ((k,x):xs) + | n <= k = x + | otherwise = pick (n-k) xs + pick _ _ = error "QuickCheck.pick used with empty list" + +-- | Generates one of the given values. The input list must be non-empty. +elements :: [a] -> Gen a +elements [] = error "QuickCheck.elements used with empty list" +elements xs = (xs !!) `fmap` choose (0, length xs - 1) + +-- | Generates a random subsequence of the given list. +sublistOf :: [a] -> Gen [a] +sublistOf xs = filterM (\_ -> choose (False, True)) xs + +-- | Generates a random permutation of the given list. +shuffle :: [a] -> Gen [a] +shuffle xs = do + ns <- vectorOf (length xs) (choose (minBound :: Int, maxBound)) + return (map snd (sortBy (comparing fst) (zip ns xs))) + +-- | Takes a list of elements of increasing size, and chooses +-- among an initial segment of the list. The size of this initial +-- segment increases with the size parameter. +-- The input list must be non-empty. +growingElements :: [a] -> Gen a +growingElements [] = error "QuickCheck.growingElements used with empty list" +growingElements xs = sized $ \n -> elements (take (1 `max` size n) xs) + where + k = length xs + mx = 100 + log' = round . log . toDouble + size n = (log' n + 1) * k `div` log' mx + toDouble = fromIntegral :: Int -> Double + +{- WAS: +growingElements xs = sized $ \n -> elements (take (1 `max` (n * k `div` 100)) xs) + where + k = length xs +-} + +-- | Generates a list of random length. The maximum length depends on the +-- size parameter. +listOf :: Gen a -> Gen [a] +listOf gen = sized $ \n -> + do k <- choose (0,n) + vectorOf k gen + +-- | Generates a non-empty list of random length. The maximum length +-- depends on the size parameter. +listOf1 :: Gen a -> Gen [a] +listOf1 gen = sized $ \n -> + do k <- choose (1,1 `max` n) + vectorOf k gen + +-- | Generates a list of the given length. +vectorOf :: Int -> Gen a -> Gen [a] +vectorOf = replicateM + +-- | Generates an infinite list. +infiniteListOf :: Gen a -> Gen [a] +infiniteListOf gen = sequence (repeat gen) + +-------------------------------------------------------------------------- +-- the end. diff --git a/Test/QuickCheck/Gen/Unsafe.hs b/Test/QuickCheck/Gen/Unsafe.hs new file mode 100644 index 0000000..514e8e9 --- /dev/null +++ b/Test/QuickCheck/Gen/Unsafe.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} +#endif +#ifndef NO_ST_MONAD +{-# LANGUAGE Rank2Types #-} +#endif +-- | Unsafe combinators for the 'Gen' monad. +-- +-- 'Gen' is only morally a monad: two generators that are supposed +-- to be equal will give the same probability distribution, but they +-- might be different as functions from random number seeds to values. +-- QuickCheck maintains the illusion that a 'Gen' is a probability +-- distribution and does not allow you to distinguish two generators +-- that have the same distribution. +-- +-- The functions in this module allow you to break this illusion by +-- reusing the same random number seed twice. This is unsafe because +-- by applying the same seed to two morally equal generators, you can +-- see whether they are really equal or not. +module Test.QuickCheck.Gen.Unsafe where + +import Test.QuickCheck.Gen +import Control.Monad + +-- | Promotes a monadic generator to a generator of monadic values. +promote :: Monad m => m (Gen a) -> Gen (m a) +promote m = do + eval <- delay + return (liftM eval m) + +-- | Randomly generates a function of type @'Gen' a -> a@, which +-- you can then use to evaluate generators. Mostly useful in +-- implementing 'promote'. +delay :: Gen (Gen a -> a) +delay = MkGen (\r n g -> unGen g r n) + +#ifndef NO_ST_MONAD +-- | A variant of 'delay' that returns a polymorphic evaluation function. +-- Can be used in a pinch to generate polymorphic (rank-2) values: +-- +-- > genSelector :: Gen (a -> a -> a) +-- > genSelector = elements [\x y -> x, \x y -> y] +-- > +-- > data Selector = Selector (forall a. a -> a -> a) +-- > genPolySelector :: Gen Selector +-- > genPolySelector = do +-- > Capture eval <- capture +-- > return (Selector (eval genSelector)) +capture :: Gen Capture +capture = MkGen (\r n -> Capture (\g -> unGen g r n)) + +newtype Capture = Capture (forall a. Gen a -> a) +#endif diff --git a/Test/QuickCheck/Modifiers.hs b/Test/QuickCheck/Modifiers.hs new file mode 100644 index 0000000..32018f5 --- /dev/null +++ b/Test/QuickCheck/Modifiers.hs @@ -0,0 +1,378 @@ +{-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Trustworthy #-} +#endif +#ifndef NO_MULTI_PARAM_TYPE_CLASSES +{-# LANGUAGE MultiParamTypeClasses #-} +#endif +#ifndef NO_NEWTYPE_DERIVING +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +#endif +-- | Modifiers for test data. +-- +-- These types do things such as restricting the kind of test data that can be generated. +-- They can be pattern-matched on in properties as a stylistic +-- alternative to using explicit quantification. +-- +-- Examples: +-- +-- @ +-- -- Functions cannot be shown (but see "Test.QuickCheck.Function") +-- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) = +-- takeWhile p xs ++ dropWhile p xs == xs +-- @ +-- +-- @ +-- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) = +-- take n xs ++ drop n xs == xs +-- @ +-- +-- @ +-- -- cycle does not work for empty lists +-- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['A'])) = +-- take n (cycle xs) == take n (xs ++ cycle xs) +-- @ +-- +-- @ +-- -- Instead of 'forAll' 'orderedList' +-- prop_Sort ('Ordered' (xs :: ['OrdA'])) = +-- sort xs == xs +-- @ +module Test.QuickCheck.Modifiers + ( + -- ** Type-level modifiers for changing generator behavior + Blind(..) + , Fixed(..) + , OrderedList(..) + , NonEmptyList(..) + , Positive(..) + , NonZero(..) + , NonNegative(..) + , Large(..) + , Small(..) + , Smart(..) + , Shrink2(..) +#ifndef NO_MULTI_PARAM_TYPE_CLASSES + , Shrinking(..) + , ShrinkState(..) +#endif + , ASCIIString(..) + , UnicodeString(..) + , PrintableString(..) + ) + where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck.Gen +import Test.QuickCheck.Arbitrary + +import Data.List + ( sort + ) +import Data.Ix (Ix) + +-------------------------------------------------------------------------- +-- | @Blind x@: as x, but x does not have to be in the 'Show' class. +newtype Blind a = Blind {getBlind :: a} + deriving ( Eq, Ord +#ifndef NO_NEWTYPE_DERIVING + , Num, Integral, Real, Enum +#endif + ) + +instance Functor Blind where + fmap f (Blind x) = Blind (f x) + +instance Show (Blind a) where + show _ = "(*)" + +instance Arbitrary a => Arbitrary (Blind a) where + arbitrary = Blind `fmap` arbitrary + + shrink (Blind x) = [ Blind x' | x' <- shrink x ] + +-------------------------------------------------------------------------- +-- | @Fixed x@: as x, but will not be shrunk. +newtype Fixed a = Fixed {getFixed :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Num, Integral, Real, Enum +#endif + ) + +instance Functor Fixed where + fmap f (Fixed x) = Fixed (f x) + +instance Arbitrary a => Arbitrary (Fixed a) where + arbitrary = Fixed `fmap` arbitrary + + -- no shrink function + +-------------------------------------------------------------------------- +-- | @Ordered xs@: guarantees that xs is ordered. +newtype OrderedList a = Ordered {getOrdered :: [a]} + deriving ( Eq, Ord, Show, Read ) + +instance Functor OrderedList where + fmap f (Ordered x) = Ordered (map f x) + +instance (Ord a, Arbitrary a) => Arbitrary (OrderedList a) where + arbitrary = Ordered `fmap` orderedList + + shrink (Ordered xs) = + [ Ordered xs' + | xs' <- shrink xs + , sort xs' == xs' + ] + +-------------------------------------------------------------------------- +-- | @NonEmpty xs@: guarantees that xs is non-empty. +newtype NonEmptyList a = NonEmpty {getNonEmpty :: [a]} + deriving ( Eq, Ord, Show, Read ) + +instance Functor NonEmptyList where + fmap f (NonEmpty x) = NonEmpty (map f x) + +instance Arbitrary a => Arbitrary (NonEmptyList a) where + arbitrary = NonEmpty `fmap` (arbitrary `suchThat` (not . null)) + + shrink (NonEmpty xs) = + [ NonEmpty xs' + | xs' <- shrink xs + , not (null xs') + ] + +-------------------------------------------------------------------------- +-- | @Positive x@: guarantees that @x \> 0@. +newtype Positive a = Positive {getPositive :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Enum +#endif + ) + +instance Functor Positive where + fmap f (Positive x) = Positive (f x) + +instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where + arbitrary = + ((Positive . abs) `fmap` (arbitrary `suchThat` (/= 0))) `suchThat` gt0 + where gt0 (Positive x) = x > 0 + + shrink (Positive x) = + [ Positive x' + | x' <- shrink x + , x' > 0 + ] + +-------------------------------------------------------------------------- +-- | @NonZero x@: guarantees that @x \/= 0@. +newtype NonZero a = NonZero {getNonZero :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Enum +#endif + ) + +instance Functor NonZero where + fmap f (NonZero x) = NonZero (f x) + +instance (Num a, Eq a, Arbitrary a) => Arbitrary (NonZero a) where + arbitrary = fmap NonZero $ arbitrary `suchThat` (/= 0) + + shrink (NonZero x) = [ NonZero x' | x' <- shrink x, x' /= 0 ] + +-------------------------------------------------------------------------- +-- | @NonNegative x@: guarantees that @x \>= 0@. +newtype NonNegative a = NonNegative {getNonNegative :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Enum +#endif + ) + +instance Functor NonNegative where + fmap f (NonNegative x) = NonNegative (f x) + +instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonNegative a) where + arbitrary = + (frequency + -- why is this distrbution like this? + [ (5, (NonNegative . abs) `fmap` arbitrary) + , (1, return (NonNegative 0)) + ] + ) `suchThat` ge0 + where ge0 (NonNegative x) = x >= 0 + + shrink (NonNegative x) = + [ NonNegative x' + | x' <- shrink x + , x' >= 0 + ] + +-------------------------------------------------------------------------- +-- | @Large x@: by default, QuickCheck generates 'Int's drawn from a small +-- range. @Large Int@ gives you values drawn from the entire range instead. +newtype Large a = Large {getLarge :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Num, Integral, Real, Enum, Ix +#endif + ) + +instance Functor Large where + fmap f (Large x) = Large (f x) + +instance (Integral a, Bounded a) => Arbitrary (Large a) where + arbitrary = fmap Large arbitrarySizedBoundedIntegral + shrink (Large x) = fmap Large (shrinkIntegral x) + +-------------------------------------------------------------------------- +-- | @Small x@: generates values of @x@ drawn from a small range. +-- The opposite of 'Large'. +newtype Small a = Small {getSmall :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Num, Integral, Real, Enum, Ix +#endif + ) + +instance Functor Small where + fmap f (Small x) = Small (f x) + +instance Integral a => Arbitrary (Small a) where + arbitrary = fmap Small arbitrarySizedIntegral + shrink (Small x) = map Small (shrinkIntegral x) + +-------------------------------------------------------------------------- +-- | @Shrink2 x@: allows 2 shrinking steps at the same time when shrinking x +newtype Shrink2 a = Shrink2 {getShrink2 :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Num, Integral, Real, Enum +#endif + ) + +instance Functor Shrink2 where + fmap f (Shrink2 x) = Shrink2 (f x) + +instance Arbitrary a => Arbitrary (Shrink2 a) where + arbitrary = + Shrink2 `fmap` arbitrary + + shrink (Shrink2 x) = + [ Shrink2 y | y <- shrink_x ] ++ + [ Shrink2 z + | y <- shrink_x + , z <- shrink y + ] + where + shrink_x = shrink x + +-------------------------------------------------------------------------- +-- | @Smart _ x@: tries a different order when shrinking. +data Smart a = + Smart Int a + +instance Functor Smart where + fmap f (Smart n x) = Smart n (f x) + +instance Show a => Show (Smart a) where + showsPrec n (Smart _ x) = showsPrec n x + +instance Arbitrary a => Arbitrary (Smart a) where + arbitrary = + do x <- arbitrary + return (Smart 0 x) + + shrink (Smart i x) = take i' ys `ilv` drop i' ys + where + ys = [ Smart j y | (j,y) <- [0..] `zip` shrink x ] + i' = 0 `max` (i-2) + + [] `ilv` bs = bs + as `ilv` [] = as + (a:as) `ilv` (b:bs) = a : b : (as `ilv` bs) + +{- + shrink (Smart i x) = part0 ++ part2 ++ part1 + where + ys = [ Smart i y | (i,y) <- [0..] `zip` shrink x ] + i' = 0 `max` (i-2) + k = i `div` 10 + + part0 = take k ys + part1 = take (i'-k) (drop k ys) + part2 = drop i' ys +-} + + -- drop a (drop b xs) == drop (a+b) xs | a,b >= 0 + -- take a (take b xs) == take (a `min` b) xs + -- take a xs ++ drop a xs == xs + + -- take k ys ++ take (i'-k) (drop k ys) ++ drop i' ys + -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys) + -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys) + -- == take k ys ++ drop k ys + -- == ys + +#ifndef NO_MULTI_PARAM_TYPE_CLASSES +-------------------------------------------------------------------------- +-- | @Shrinking _ x@: allows for maintaining a state during shrinking. +data Shrinking s a = + Shrinking s a + +class ShrinkState s a where + shrinkInit :: a -> s + shrinkState :: a -> s -> [(a,s)] + +instance Functor (Shrinking s) where + fmap f (Shrinking s x) = Shrinking s (f x) + +instance Show a => Show (Shrinking s a) where + showsPrec n (Shrinking _ x) = showsPrec n x + +instance (Arbitrary a, ShrinkState s a) => Arbitrary (Shrinking s a) where + arbitrary = + do x <- arbitrary + return (Shrinking (shrinkInit x) x) + + shrink (Shrinking s x) = + [ Shrinking s' x' + | (x',s') <- shrinkState x s + ] + +#endif /* NO_MULTI_PARAM_TYPE_CLASSES */ + +-------------------------------------------------------------------------- +-- | @ASCIIString@: generates an ASCII string. +newtype ASCIIString = ASCIIString {getASCIIString :: String} + deriving ( Eq, Ord, Show, Read ) + +instance Arbitrary ASCIIString where + arbitrary = ASCIIString `fmap` listOf arbitraryASCIIChar + shrink (ASCIIString xs) = ASCIIString `fmap` shrink xs + +-------------------------------------------------------------------------- +-- | @UnicodeString@: generates a unicode String. +-- The string will not contain surrogate pairs. +newtype UnicodeString = UnicodeString {getUnicodeString :: String} + deriving ( Eq, Ord, Show, Read ) + +instance Arbitrary UnicodeString where + arbitrary = UnicodeString `fmap` listOf arbitraryUnicodeChar + shrink (UnicodeString xs) = UnicodeString `fmap` shrink xs + +-------------------------------------------------------------------------- +-- | @PrintableString@: generates a printable unicode String. +-- The string will not contain surrogate pairs. +newtype PrintableString = PrintableString {getPrintableString :: String} + deriving ( Eq, Ord, Show, Read ) + +instance Arbitrary PrintableString where + arbitrary = PrintableString `fmap` listOf arbitraryPrintableChar + shrink (PrintableString xs) = PrintableString `fmap` shrink xs + +-- the end. diff --git a/Test/QuickCheck/Monadic.hs b/Test/QuickCheck/Monadic.hs new file mode 100644 index 0000000..9a3c470 --- /dev/null +++ b/Test/QuickCheck/Monadic.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +#if !defined(NO_ST_MONAD) && !(MIN_VERSION_base(4,8,0)) +{-# LANGUAGE Trustworthy #-} +#else +{-# LANGUAGE Safe #-} +#endif +#endif +#ifndef NO_ST_MONAD +{-# LANGUAGE Rank2Types #-} +#endif +{-| +Module : Test.QuickCheck.Monadic + +Allows testing of monadic values. Will generally follow this form: + +@ +prop_monadic a b = 'monadicIO' $ do + a\' \<- 'run' (f a) + b\' \<- 'run' (f b) + -- ... + 'assert' someBoolean +@ + +Example using the @FACTOR(1)@ command-line utility: + +@ +import System.Process +import Test.QuickCheck +import Test.QuickCheck.Monadic + +-- $ factor 16 +-- 16: 2 2 2 2 +factor :: Integer -> IO [Integer] +factor n = parse \`fmap\` 'System.Process.readProcess' \"factor\" [show n] \"\" where + + parse :: String -> [Integer] + parse = map read . tail . words + +prop_factor :: Positive Integer -> Property +prop_factor ('Test.QuickCheck.Modifiers.Positive' n) = 'monadicIO' $ do + factors \<- 'run' (factor n) + + 'assert' (product factors == n) +@ + +>>> quickCheck prop_factor ++++ OK, passed 100 tests. + +See the paper \"\". +-} +module Test.QuickCheck.Monadic ( + -- * Property monad + PropertyM(..) + + -- * Monadic specification combinators + , run + , assert + , pre + , wp + , pick + , forAllM + , monitor + , stop + + -- * Run functions + , monadic + , monadic' + , monadicIO +#ifndef NO_ST_MONAD + , monadicST + , runSTGen +#endif + ) where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck.Gen +import Test.QuickCheck.Gen.Unsafe +import Test.QuickCheck.Property + +import Control.Monad(liftM, liftM2) + +import Control.Monad.ST +import Control.Applicative + +#ifndef NO_TRANSFORMERS +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +#endif + +#ifndef NO_MONADFAIL +import qualified Control.Monad.Fail as Fail +#endif + +-------------------------------------------------------------------------- +-- type PropertyM + +-- | The property monad is really a monad transformer that can contain +-- monadic computations in the monad @m@ it is parameterized by: +-- +-- * @m@ - the @m@-computations that may be performed within @PropertyM@ +-- +-- Elements of @PropertyM m a@ may mix property operations and @m@-computations. +newtype PropertyM m a = + MkPropertyM { unPropertyM :: (a -> Gen (m Property)) -> Gen (m Property) } + +bind :: PropertyM m a -> (a -> PropertyM m b) -> PropertyM m b +MkPropertyM m `bind` f = MkPropertyM (\k -> m (\a -> unPropertyM (f a) k)) + +fail_ :: Monad m => String -> PropertyM m a +fail_ s = stop (failed { reason = s }) + +instance Functor (PropertyM m) where + fmap f (MkPropertyM m) = MkPropertyM (\k -> m (k . f)) + +instance Applicative (PropertyM m) where + pure x = MkPropertyM (\k -> k x) + mf <*> mx = + mf `bind` \f -> mx `bind` \x -> pure (f x) + +instance Monad m => Monad (PropertyM m) where + return = pure + (>>=) = bind + fail = fail_ + +#ifndef NO_MONADFAIL +instance Monad m => Fail.MonadFail (PropertyM m) where + fail = fail_ +#endif + +#ifndef NO_TRANSFORMERS +instance MonadTrans PropertyM where + lift = run + +instance MonadIO m => MonadIO (PropertyM m) where + liftIO = run . liftIO +#endif + +stop :: (Testable prop, Monad m) => prop -> PropertyM m a +stop p = MkPropertyM (\_k -> return (return (property p))) + +-- should think about strictness/exceptions here +-- assert :: Testable prop => prop -> PropertyM m () +-- | Allows embedding non-monadic properties into monadic ones. +assert :: Monad m => Bool -> PropertyM m () +assert True = return () +assert False = fail "Assertion failed" + +-- should think about strictness/exceptions here +-- | Tests preconditions. Unlike 'assert' this does not cause the +-- property to fail, rather it discards them just like using the +-- implication combinator 'Test.QuickCheck.Property.==>'. +-- +-- This allows representing the +-- +-- > {p} x ← e{q} +-- +-- as +-- +-- @ +-- pre p +-- x \<- run e +-- assert q +-- @ +-- +pre :: Monad m => Bool -> PropertyM m () +pre True = return () +pre False = stop rejected + +-- should be called lift? +-- | The lifting operation of the property monad. Allows embedding +-- monadic\/'IO'-actions in properties: +-- +-- @ +-- log :: Int -> IO () +-- +-- prop_foo n = monadicIO $ do +-- run (log n) +-- -- ... +-- @ +run :: Monad m => m a -> PropertyM m a +run m = MkPropertyM (liftM (m >>=) . promote) + +-- | Quantification in a monadic property, fits better with +-- /do-notation/ than 'forAllM'. +pick :: (Monad m, Show a) => Gen a -> PropertyM m a +pick gen = MkPropertyM $ \k -> + do a <- gen + mp <- k a + return (do p <- mp + return (forAll (return a) (const p))) + +-- | The +-- +-- > wp(x ← e, p) +-- +-- can be expressed as in code as @wp e (\\x -> p)@. +wp :: Monad m => m a -> (a -> PropertyM m b) -> PropertyM m b +wp m k = run m >>= k + +-- | An alternative to quantification a monadic properties to 'pick', +-- with a notation similar to 'forAll'. + +forAllM :: (Monad m, Show a) => Gen a -> (a -> PropertyM m b) -> PropertyM m b +forAllM gen k = pick gen >>= k + +-- | Allows making observations about the test data: +-- +-- @ +-- monitor ('collect' e) +-- @ +-- +-- collects the distribution of value of @e@. +-- +-- @ +-- monitor ('counterexample' "Failure!") +-- @ +-- +-- Adds @"Failure!"@ to the counterexamples. +monitor :: Monad m => (Property -> Property) -> PropertyM m () +monitor f = MkPropertyM (\k -> (f `liftM`) `fmap` (k ())) + +-- run functions + +monadic :: (Testable a, Monad m) => (m Property -> Property) -> PropertyM m a -> Property +monadic runner m = property (fmap runner (monadic' m)) + +monadic' :: (Testable a, Monad m) => PropertyM m a -> Gen (m Property) +monadic' (MkPropertyM m) = m (\prop -> return (return (property prop))) + +-- | Runs the property monad for 'IO'-computations. +-- +-- @ +-- prop_cat msg = monadicIO $ do +-- (exitCode, stdout, _) \<- run ('System.Process.readProcessWithExitCode' "cat" [] msg) +-- +-- pre ('System.Exit.ExitSuccess' == exitCode) +-- +-- assert (stdout == msg) +-- @ +-- +-- >>> quickCheck prop_cat +-- +++ OK, passed 100 tests. +-- +monadicIO :: Testable a => PropertyM IO a -> Property +monadicIO = monadic ioProperty + +#ifndef NO_ST_MONAD +-- | Runs the property monad for 'ST'-computations. +-- +-- @ +-- -- Your mutable sorting algorithm here +-- sortST :: Ord a => [a] -> 'Control.Monad.ST.ST' s (MVector s a) +-- sortST = 'Data.Vector.thaw' . 'Data.Vector.fromList' . 'Data.List.sort' +-- +-- prop_sortST xs = monadicST $ do +-- sorted \<- run ('Data.Vector.freeze' =<< sortST xs) +-- assert ('Data.Vector.toList' sorted == sort xs) +-- @ +-- +-- >>> quickCheck prop_sortST +-- +++ OK, passed 100 tests. +-- +monadicST :: Testable a => (forall s. PropertyM (ST s) a) -> Property +monadicST m = property (runSTGen (monadic' m)) + +runSTGen :: (forall s. Gen (ST s a)) -> Gen a +runSTGen f = do + Capture eval <- capture + return (runST (eval f)) +#endif + +-------------------------------------------------------------------------- +-- the end. diff --git a/Test/QuickCheck/Poly.hs b/Test/QuickCheck/Poly.hs new file mode 100644 index 0000000..8044fdd --- /dev/null +++ b/Test/QuickCheck/Poly.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} +#endif +-- | Types to help with testing polymorphic properties. +-- +-- Types 'A', 'B' and 'C' are @newtype@ wrappers around 'Integer' that +-- implement 'Eq', 'Show', 'Arbitrary' and 'CoArbitrary'. Types +-- 'OrdA', 'OrdB' and 'OrdC' also implement 'Ord' and 'Num'. +-- +-- See also "Test.QuickCheck.All" for an automatic way of testing +-- polymorphic properties. +module Test.QuickCheck.Poly + ( A(..), B(..), C(..) + , OrdA(..), OrdB(..), OrdC(..) + ) + where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck.Arbitrary + +-------------------------------------------------------------------------- +-- polymorphic A, B, C (in Eq) + +-- A + +newtype A = A{ unA :: Integer } + deriving ( Eq ) + +instance Show A where + showsPrec n (A x) = showsPrec n x + +instance Arbitrary A where + arbitrary = (A . (+1) . abs) `fmap` arbitrary + shrink (A x) = [ A x' | x' <- shrink x, x' > 0 ] + +instance CoArbitrary A where + coarbitrary = coarbitrary . unA + +-- B + +newtype B = B{ unB :: Integer } + deriving ( Eq ) + +instance Show B where + showsPrec n (B x) = showsPrec n x + +instance Arbitrary B where + arbitrary = (B . (+1) . abs) `fmap` arbitrary + shrink (B x) = [ B x' | x' <- shrink x, x' > 0 ] + +instance CoArbitrary B where + coarbitrary = coarbitrary . unB + +-- C + +newtype C = C{ unC :: Integer } + deriving ( Eq ) + +instance Show C where + showsPrec n (C x) = showsPrec n x + +instance Arbitrary C where + arbitrary = (C . (+1) . abs) `fmap` arbitrary + shrink (C x) = [ C x' | x' <- shrink x, x' > 0 ] + +instance CoArbitrary C where + coarbitrary = coarbitrary . unC + +-------------------------------------------------------------------------- +-- polymorphic OrdA, OrdB, OrdC (in Eq, Ord) + +-- OrdA + +newtype OrdA = OrdA{ unOrdA :: Integer } + deriving ( Eq, Ord ) + +liftOrdA + :: (Integer -> Integer) + -> OrdA -> OrdA +liftOrdA f (OrdA x) = OrdA (f x) + +liftOrdA2 + :: (Integer -> Integer -> Integer) + -> OrdA -> OrdA -> OrdA +liftOrdA2 f (OrdA x) (OrdA y) = OrdA (f x y) + +instance Num OrdA where + (+) = liftOrdA2 (+) + (*) = liftOrdA2 (*) + (-) = liftOrdA2 (-) + negate = liftOrdA negate + abs = liftOrdA abs + signum = liftOrdA signum + fromInteger = OrdA . fromInteger + + +instance Show OrdA where + showsPrec n (OrdA x) = showsPrec n x + +instance Arbitrary OrdA where + arbitrary = (OrdA . (+1) . abs) `fmap` arbitrary + shrink (OrdA x) = [ OrdA x' | x' <- shrink x, x' > 0 ] + +instance CoArbitrary OrdA where + coarbitrary = coarbitrary . unOrdA + +-- OrdB + +newtype OrdB = OrdB{ unOrdB :: Integer } + deriving ( Eq, Ord ) + +liftOrdB + :: (Integer -> Integer) + -> OrdB -> OrdB +liftOrdB f (OrdB x) = OrdB (f x) + +liftOrdB2 + :: (Integer -> Integer -> Integer) + -> OrdB -> OrdB -> OrdB +liftOrdB2 f (OrdB x) (OrdB y) = OrdB (f x y) + +instance Num OrdB where + (+) = liftOrdB2 (+) + (*) = liftOrdB2 (*) + (-) = liftOrdB2 (-) + negate = liftOrdB negate + abs = liftOrdB abs + signum = liftOrdB signum + fromInteger = OrdB . fromInteger + +instance Show OrdB where + showsPrec n (OrdB x) = showsPrec n x + +instance Arbitrary OrdB where + arbitrary = (OrdB . (+1) . abs) `fmap` arbitrary + shrink (OrdB x) = [ OrdB x' | x' <- shrink x, x' > 0 ] + +instance CoArbitrary OrdB where + coarbitrary = coarbitrary . unOrdB + +-- OrdC + +newtype OrdC = OrdC{ unOrdC :: Integer } + deriving ( Eq, Ord ) + +liftOrdC + :: (Integer -> Integer) + -> OrdC -> OrdC +liftOrdC f (OrdC x) = OrdC (f x) + +liftOrdC2 + :: (Integer -> Integer -> Integer) + -> OrdC -> OrdC -> OrdC +liftOrdC2 f (OrdC x) (OrdC y) = OrdC (f x y) + +instance Num OrdC where + (+) = liftOrdC2 (+) + (*) = liftOrdC2 (*) + (-) = liftOrdC2 (-) + negate = liftOrdC negate + abs = liftOrdC abs + signum = liftOrdC signum + fromInteger = OrdC . fromInteger + +instance Show OrdC where + showsPrec n (OrdC x) = showsPrec n x + +instance Arbitrary OrdC where + arbitrary = (OrdC . (+1) . abs) `fmap` arbitrary + shrink (OrdC x) = [ OrdC x' | x' <- shrink x, x' > 0 ] + +instance CoArbitrary OrdC where + coarbitrary = coarbitrary . unOrdC + +-------------------------------------------------------------------------- +-- the end. diff --git a/Test/QuickCheck/Property.hs b/Test/QuickCheck/Property.hs new file mode 100644 index 0000000..52457cd --- /dev/null +++ b/Test/QuickCheck/Property.hs @@ -0,0 +1,629 @@ +-- | Combinators for constructing properties. +{-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} +#endif +module Test.QuickCheck.Property where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck.Gen +import Test.QuickCheck.Gen.Unsafe +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Text( isOneLine, putLine ) +import Test.QuickCheck.Exception +import Test.QuickCheck.State hiding (labels) + +#ifndef NO_TIMEOUT +import System.Timeout(timeout) +#endif +import Data.Maybe +import Control.Applicative +import Control.Monad +import qualified Data.Map as Map +import Data.Map(Map) +import qualified Data.Set as Set +import Data.Set(Set) +#ifndef NO_DEEPSEQ +import Control.DeepSeq +#endif + +-------------------------------------------------------------------------- +-- fixities + +infixr 0 ==> +infixr 1 .&. +infixr 1 .&&. +infixr 1 .||. + +-- The story for exception handling: +-- +-- To avoid insanity, we have rules about which terms can throw +-- exceptions when we evaluate them: +-- * A rose tree must evaluate to WHNF without throwing an exception +-- * The 'ok' component of a Result must evaluate to Just True or +-- Just False or Nothing rather than raise an exception +-- * IORose _ must never throw an exception when executed +-- +-- Both rose trees and Results may loop when we evaluate them, though, +-- so we have to be careful not to force them unnecessarily. +-- +-- We also have to be careful when we use fmap or >>= in the Rose +-- monad that the function we supply is total, or else use +-- protectResults afterwards to install exception handlers. The +-- mapResult function on Properties installs an exception handler for +-- us, though. +-- +-- Of course, the user is free to write "error "ha ha" :: Result" if +-- they feel like it. We have to make sure that any user-supplied Rose +-- Results or Results get wrapped in exception handlers, which we do by: +-- * Making the 'property' function install an exception handler +-- round its argument. This function always gets called in the +-- right places, because all our Property-accepting functions are +-- actually polymorphic over the Testable class so they have to +-- call 'property'. +-- * Installing an exception handler round a Result before we put it +-- in a rose tree (the only place Results can end up). + +-------------------------------------------------------------------------- +-- * Property and Testable types + +-- | The type of properties. +newtype Property = MkProperty { unProperty :: Gen Prop } + +-- | The class of properties, i.e., types which QuickCheck knows how to test. +-- Typically a property will be a function returning 'Bool' or 'Property'. +-- +-- If a property does no quantification, i.e. has no +-- parameters and doesn't use 'forAll', it will only be tested once. +-- This may not be what you want if your property is an @IO Bool@. +-- You can change this behaviour using the 'again' combinator. +class Testable prop where + -- | Convert the thing to a property. + property :: prop -> Property + +-- | If a property returns 'Discard', the current test case is discarded, +-- the same as if a precondition was false. +data Discard = Discard + +instance Testable Discard where + property _ = property rejected + +-- This instance is here to make it easier to turn IO () into a Property. +instance Testable () where + property = property . liftUnit + where + -- N.B. the unit gets forced only inside 'property', + -- so that we turn exceptions into test failures + liftUnit () = succeeded + +instance Testable Bool where + property = property . liftBool + +instance Testable Result where + property = MkProperty . return . MkProp . protectResults . return + +instance Testable Prop where + property (MkProp r) = MkProperty . return . MkProp . ioRose . return $ r + +instance Testable prop => Testable (Gen prop) where + property mp = MkProperty $ do p <- mp; unProperty (again p) + +instance Testable Property where + property (MkProperty mp) = MkProperty $ do p <- mp; unProperty (property p) + +-- | Do I/O inside a property. +{-# DEPRECATED morallyDubiousIOProperty "Use 'ioProperty' instead" #-} +morallyDubiousIOProperty :: Testable prop => IO prop -> Property +morallyDubiousIOProperty = ioProperty + +-- | Do I/O inside a property. +-- +-- Warning: any random values generated inside of the argument to @ioProperty@ +-- will not currently be shrunk. For best results, generate all random values +-- before calling @ioProperty@. +ioProperty :: Testable prop => IO prop -> Property +ioProperty = + MkProperty . fmap (MkProp . ioRose . fmap unProp) . + promote . fmap (unProperty . noShrinking) + +instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where + property f = forAllShrink arbitrary shrink f + +-- ** Exception handling +protect :: (AnException -> a) -> IO a -> IO a +protect f x = either f id `fmap` tryEvaluateIO x + +-------------------------------------------------------------------------- +-- ** Type Prop + +newtype Prop = MkProp{ unProp :: Rose Result } + +-- ** type Rose + +data Rose a = MkRose a [Rose a] | IORose (IO (Rose a)) +-- Only use IORose if you know that the argument is not going to throw an exception! +-- Otherwise, try ioRose. +ioRose :: IO (Rose Result) -> Rose Result +ioRose = IORose . protectRose + +joinRose :: Rose (Rose a) -> Rose a +joinRose (IORose rs) = IORose (fmap joinRose rs) +joinRose (MkRose (IORose rm) rs) = IORose $ do r <- rm; return (joinRose (MkRose r rs)) +joinRose (MkRose (MkRose x ts) tts) = + -- first shrinks outer quantification; makes most sense + MkRose x (map joinRose tts ++ ts) + -- first shrinks inner quantification: terrible + --MkRose x (ts ++ map joinRose tts) + +instance Functor Rose where + -- f must be total + fmap f (IORose rs) = IORose (fmap (fmap f) rs) + fmap f (MkRose x rs) = MkRose (f x) [ fmap f r | r <- rs ] + +instance Applicative Rose where + pure = return + -- f must be total + (<*>) = liftM2 ($) + +instance Monad Rose where + return x = MkRose x [] + -- k must be total + m >>= k = joinRose (fmap k m) + +-- | Execute the "IORose" bits of a rose tree, returning a tree +-- constructed by MkRose. +reduceRose :: Rose Result -> IO (Rose Result) +reduceRose r@(MkRose _ _) = return r +reduceRose (IORose m) = m >>= reduceRose + +-- | Apply a function to the outermost MkRose constructor of a rose tree. +-- The function must be total! +onRose :: (a -> [Rose a] -> Rose a) -> Rose a -> Rose a +onRose f (MkRose x rs) = f x rs +onRose f (IORose m) = IORose (fmap (onRose f) m) + +-- | Wrap a rose tree in an exception handler. +protectRose :: IO (Rose Result) -> IO (Rose Result) +protectRose = protect (return . exception "Exception") + +-- | Wrap all the Results in a rose tree in exception handlers. +protectResults :: Rose Result -> Rose Result +protectResults = onRose $ \x rs -> + IORose $ do + y <- protectResult (return x) + return (MkRose y (map protectResults rs)) + +-- ** Result type + +-- | Different kinds of callbacks +data Callback + = PostTest CallbackKind (State -> Result -> IO ()) -- ^ Called just after a test + | PostFinalFailure CallbackKind (State -> Result -> IO ()) -- ^ Called with the final failing test-case +data CallbackKind = Counterexample -- ^ Affected by the 'verbose' combinator + | NotCounterexample -- ^ Not affected by the 'verbose' combinator + +-- | The result of a single test. +data Result + = MkResult + { ok :: Maybe Bool -- ^ result of the test case; Nothing = discard + , expect :: Bool -- ^ indicates what the expected result of the property is + , reason :: String -- ^ a message indicating what went wrong + , theException :: Maybe AnException -- ^ the exception thrown, if any + , abort :: Bool -- ^ if True, the test should not be repeated + , maybeNumTests :: Maybe Int -- ^ stop after this many tests + , labels :: Map String Int -- ^ all labels used by this property + , stamp :: Set String -- ^ the collected labels for this test case + , callbacks :: [Callback] -- ^ the callbacks for this test case + , testCase :: [String] -- ^ the generated test case + } + +exception :: String -> AnException -> Result +exception msg err + | isDiscard err = rejected + | otherwise = failed{ reason = formatException msg err, + theException = Just err } + +formatException :: String -> AnException -> String +formatException msg err = msg ++ ":" ++ format (show err) + where format xs | isOneLine xs = " '" ++ xs ++ "'" + | otherwise = "\n" ++ unlines [ " " ++ l | l <- lines xs ] + +protectResult :: IO Result -> IO Result +protectResult = protect (exception "Exception") + +succeeded, failed, rejected :: Result +(succeeded, failed, rejected) = + (result{ ok = Just True }, + result{ ok = Just False }, + result{ ok = Nothing }) + where + result = + MkResult + { ok = undefined + , expect = True + , reason = "" + , theException = Nothing + , abort = True + , maybeNumTests = Nothing + , labels = Map.empty + , stamp = Set.empty + , callbacks = [] + , testCase = [] + } + +-------------------------------------------------------------------------- +-- ** Lifting and mapping functions + +liftBool :: Bool -> Result +liftBool True = succeeded +liftBool False = failed { reason = "Falsifiable" } + +mapResult :: Testable prop => (Result -> Result) -> prop -> Property +mapResult f = mapRoseResult (protectResults . fmap f) + +mapTotalResult :: Testable prop => (Result -> Result) -> prop -> Property +mapTotalResult f = mapRoseResult (fmap f) + +-- f here mustn't throw an exception (rose tree invariant). +mapRoseResult :: Testable prop => (Rose Result -> Rose Result) -> prop -> Property +mapRoseResult f = mapProp (\(MkProp t) -> MkProp (f t)) + +mapProp :: Testable prop => (Prop -> Prop) -> prop -> Property +mapProp f = MkProperty . fmap f . unProperty . property + +-------------------------------------------------------------------------- +-- ** Property combinators + +-- | Changes the maximum test case size for a property. +mapSize :: Testable prop => (Int -> Int) -> prop -> Property +mapSize f p = MkProperty (sized ((`resize` unProperty (property p)) . f)) + +-- | Shrinks the argument to a property if it fails. Shrinking is done +-- automatically for most types. This function is only needed when you want to +-- override the default behavior. +shrinking :: Testable prop => + (a -> [a]) -- ^ 'shrink'-like function. + -> a -- ^ The original argument + -> (a -> prop) -> Property +shrinking shrinker x0 pf = MkProperty (fmap (MkProp . joinRose . fmap unProp) (promote (props x0))) + where + props x = + MkRose (unProperty (property (pf x))) [ props x' | x' <- shrinker x ] + +-- | Disables shrinking for a property altogether. +noShrinking :: Testable prop => prop -> Property +noShrinking = mapRoseResult (onRose (\res _ -> MkRose res [])) + +-- | Adds a callback +callback :: Testable prop => Callback -> prop -> Property +callback cb = mapTotalResult (\res -> res{ callbacks = cb : callbacks res }) + +-- | Adds the given string to the counterexample if the property fails. +counterexample :: Testable prop => String -> prop -> Property +counterexample s = + mapTotalResult (\res -> res{ testCase = s:testCase res }) . + callback (PostFinalFailure Counterexample $ \st _res -> do + s <- showCounterexample s + putLine (terminal st) s) + +showCounterexample :: String -> IO String +showCounterexample s = do + let force [] = return () + force (x:xs) = x `seq` force xs + res <- tryEvaluateIO (force s) + return $ + case res of + Left err -> + formatException "Exception thrown while showing test case" err + Right () -> + s + +-- | Adds the given string to the counterexample if the property fails. +{-# DEPRECATED printTestCase "Use counterexample instead" #-} +printTestCase :: Testable prop => String -> prop -> Property +printTestCase = counterexample + +-- | Performs an 'IO' action after the last failure of a property. +whenFail :: Testable prop => IO () -> prop -> Property +whenFail m = + callback $ PostFinalFailure NotCounterexample $ \_st _res -> + m + +-- | Performs an 'IO' action every time a property fails. Thus, +-- if shrinking is done, this can be used to keep track of the +-- failures along the way. +whenFail' :: Testable prop => IO () -> prop -> Property +whenFail' m = + callback $ PostTest NotCounterexample $ \_st res -> + if ok res == Just False + then m + else return () + +-- | Prints out the generated testcase every time the property is tested. +-- Only variables quantified over /inside/ the 'verbose' are printed. +verbose :: Testable prop => prop -> Property +verbose = mapResult (\res -> res { callbacks = newCallbacks (callbacks res) ++ callbacks res }) + where newCallbacks cbs = + PostTest Counterexample (\st res -> putLine (terminal st) (status res ++ ":")): + [ PostTest Counterexample f | PostFinalFailure Counterexample f <- cbs ] ++ + [ PostTest Counterexample (\st res -> putLine (terminal st) "") ] + status MkResult{ok = Just True} = "Passed" + status MkResult{ok = Just False} = "Failed" + status MkResult{ok = Nothing} = "Skipped (precondition false)" + +-- | Indicates that a property is supposed to fail. +-- QuickCheck will report an error if it does not fail. +expectFailure :: Testable prop => prop -> Property +expectFailure = mapTotalResult (\res -> res{ expect = False }) + +-- | Modifies a property so that it only will be tested once. +-- Opposite of 'again'. +once :: Testable prop => prop -> Property +once = mapTotalResult (\res -> res{ abort = True }) + +-- | Modifies a property so that it will be tested repeatedly. +-- Opposite of 'once'. +again :: Testable prop => prop -> Property +again = mapTotalResult (\res -> res{ abort = False }) + +-- | Configures how many times a property will be tested. +-- +-- For example, +-- +-- > quickCheck (withMaxSuccess 1000 p) +-- +-- will test @p@ up to 1000 times. +withMaxSuccess :: Testable prop => Int -> prop -> Property +withMaxSuccess n = n `seq` mapTotalResult (\res -> res{ maybeNumTests = Just n }) + +-- | Attaches a label to a property. This is used for reporting +-- test case distribution. +-- +-- For example: +-- +-- > prop_reverse_reverse :: [Int] -> Property +-- > prop_reverse_reverse xs = +-- > label ("length of input is " ++ show (length xs)) $ +-- > reverse (reverse xs) === xs +-- +-- >>> quickCheck prop_reverse_reverse +-- +++ OK, passed 100 tests: +-- 7% length of input is 7 +-- 6% length of input is 3 +-- 5% length of input is 4 +-- 4% length of input is 6 +-- ... +label :: Testable prop => String -> prop -> Property +label s = classify True s + +-- | Attaches a label to a property. This is used for reporting +-- test case distribution. +-- +-- > collect x = label (show x) +-- +-- For example: +-- +-- > prop_reverse_reverse :: [Int] -> Property +-- > prop_reverse_reverse xs = +-- > collect (length xs) $ +-- > reverse (reverse xs) === xs +-- +-- >>> quickCheck prop_reverse_reverse +-- +++ OK, passed 100 tests: +-- 7% 7 +-- 6% 3 +-- 5% 4 +-- 4% 6 +-- ... +collect :: (Show a, Testable prop) => a -> prop -> Property +collect x = label (show x) + +-- | Records how many test cases satisfy a given condition. +-- +-- For example: +-- +-- > prop_sorted_sort :: [Int] -> Property +-- > prop_sorted_sort xs = +-- > sorted xs ==> +-- > classify (length xs > 1) "non-trivial" $ +-- > sort xs === xs +-- +-- >>> quickCheck prop_sorted_sort +-- +++ OK, passed 100 tests (22% non-trivial). +classify :: Testable prop => + Bool -- ^ @True@ if the test case should be labelled. + -> String -- ^ Label. + -> prop -> Property +classify b s = cover b 0 s + +-- | Checks that at least the given proportion of /successful/ test +-- cases belong to the given class. Discarded tests (i.e. ones +-- with a false precondition) do not affect coverage. +-- +-- For example: +-- +-- > prop_sorted_sort :: [Int] -> Property +-- > prop_sorted_sort xs = +-- > sorted xs ==> +-- > cover (length xs > 1) 50 "non-trivial" $ +-- > sort xs === xs +-- +-- >>> quickCheck prop_sorted_sort +-- *** Insufficient coverage after 100 tests (only 24% non-trivial, not 50%). +cover :: Testable prop => + Bool -- ^ @True@ if the test case belongs to the class. + -> Int -- ^ The required percentage (0-100) of test cases. + -> String -- ^ Label for the test case class. + -> prop -> Property +cover x n s = + x `seq` n `seq` s `listSeq` + mapTotalResult $ + \res -> res { + labels = Map.insertWith max s n (labels res), + stamp = if x then Set.insert s (stamp res) else stamp res } + where [] `listSeq` z = z + (x:xs) `listSeq` z = x `seq` xs `listSeq` z + +-- | Implication for properties: The resulting property holds if +-- the first argument is 'False' (in which case the test case is discarded), +-- or if the given property holds. +(==>) :: Testable prop => Bool -> prop -> Property +False ==> _ = property Discard +True ==> p = property p + +-- | Considers a property failed if it does not complete within +-- the given number of microseconds. +within :: Testable prop => Int -> prop -> Property +within n = mapRoseResult f + where + f rose = ioRose $ do + let m `orError` x = fmap (fromMaybe x) m + MkRose res roses <- timeout n (reduceRose rose) `orError` + return timeoutResult + res' <- timeout n (protectResult (return res)) `orError` + timeoutResult + return (MkRose res' (map f roses)) + + timeoutResult = failed { reason = "Timeout" } +#ifdef NO_TIMEOUT + timeout _ = fmap Just +#endif + +-- | Explicit universal quantification: uses an explicitly given +-- test case generator. +forAll :: (Show a, Testable prop) + => Gen a -> (a -> prop) -> Property +forAll gen pf = forAllShrink gen (\_ -> []) pf + +-- | Like 'forAll', but tries to shrink the argument for failing test cases. +forAllShrink :: (Show a, Testable prop) + => Gen a -> (a -> [a]) -> (a -> prop) -> Property +forAllShrink gen shrinker pf = + again $ + MkProperty $ + gen >>= \x -> + unProperty $ + shrinking shrinker x $ \x' -> + counterexample (show x') (pf x') + +-- | Nondeterministic choice: 'p1' '.&.' 'p2' picks randomly one of +-- 'p1' and 'p2' to test. If you test the property 100 times it +-- makes 100 random choices. +(.&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property +p1 .&. p2 = + again $ + MkProperty $ + arbitrary >>= \b -> + unProperty $ + counterexample (if b then "LHS" else "RHS") $ + if b then property p1 else property p2 + +-- | Conjunction: 'p1' '.&&.' 'p2' passes if both 'p1' and 'p2' pass. +(.&&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property +p1 .&&. p2 = conjoin [property p1, property p2] + +-- | Take the conjunction of several properties. +conjoin :: Testable prop => [prop] -> Property +conjoin ps = + again $ + MkProperty $ + do roses <- mapM (fmap unProp . unProperty . property) ps + return (MkProp (conj id roses)) + where + conj k [] = + MkRose (k succeeded) [] + + conj k (p : ps) = IORose $ do + rose@(MkRose result _) <- reduceRose p + case ok result of + _ | not (expect result) -> + return (return failed { reason = "expectFailure may not occur inside a conjunction" }) + Just True -> return (conj (addLabels result . addCallbacks result . k) ps) + Just False -> return rose + Nothing -> do + rose2@(MkRose result2 _) <- reduceRose (conj (addCallbacks result . k) ps) + return $ + -- Nasty work to make sure we use the right callbacks + case ok result2 of + Just True -> MkRose (result2 { ok = Nothing }) [] + Just False -> rose2 + Nothing -> rose2 + + addCallbacks result r = + r { callbacks = callbacks result ++ callbacks r } + addLabels result r = + r { labels = Map.unionWith max (labels result) (labels r), + stamp = Set.union (stamp result) (stamp r) } + +-- | Disjunction: 'p1' '.||.' 'p2' passes unless 'p1' and 'p2' simultaneously fail. +(.||.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property +p1 .||. p2 = disjoin [property p1, property p2] + +-- | Take the disjunction of several properties. +disjoin :: Testable prop => [prop] -> Property +disjoin ps = + again $ + MkProperty $ + do roses <- mapM (fmap unProp . unProperty . property) ps + return (MkProp (foldr disj (MkRose failed []) roses)) + where + disj :: Rose Result -> Rose Result -> Rose Result + disj p q = + do result1 <- p + case ok result1 of + _ | not (expect result1) -> return expectFailureError + Just True -> return result1 + Just False -> do + result2 <- q + return $ + case ok result2 of + _ | not (expect result2) -> expectFailureError + Just True -> result2 + Just False -> + MkResult { + ok = Just False, + expect = True, + reason = sep (reason result1) (reason result2), + theException = theException result1 `mplus` theException result2, + -- The following three fields are not important because the + -- test case has failed anyway + abort = False, + maybeNumTests = Nothing, + labels = Map.empty, + stamp = Set.empty, + callbacks = + callbacks result1 ++ + [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] ++ + callbacks result2, + testCase = + testCase result1 ++ + testCase result2 } + Nothing -> result2 + Nothing -> do + result2 <- q + return (case ok result2 of + _ | not (expect result2) -> expectFailureError + Just True -> result2 + _ -> result1) + + expectFailureError = failed { reason = "expectFailure may not occur inside a disjunction" } + sep [] s = s + sep s [] = s + sep s s' = s ++ ", " ++ s' + +-- | Like '==', but prints a counterexample when it fails. +infix 4 === +(===) :: (Eq a, Show a) => a -> a -> Property +x === y = + counterexample (show x ++ " /= " ++ show y) (x == y) + +#ifndef NO_DEEPSEQ +-- | Checks that a value is total, i.e., doesn't crash when evaluated. +total :: NFData a => a -> Property +total x = property (rnf x) +#endif + +-------------------------------------------------------------------------- +-- the end. diff --git a/Test/QuickCheck/Random.hs b/Test/QuickCheck/Random.hs new file mode 100644 index 0000000..277ed0f --- /dev/null +++ b/Test/QuickCheck/Random.hs @@ -0,0 +1,108 @@ +-- | A wrapper around the system random number generator. Internal QuickCheck module. +{-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Trustworthy #-} +#endif +module Test.QuickCheck.Random where + +#ifndef NO_TF_RANDOM +import System.Random +import System.Random.TF +import System.Random.TF.Gen(splitn) +import Data.Word +import Data.Bits + +#define TheGen TFGen + +newTheGen :: IO TFGen +newTheGen = newTFGen + +bits, mask, doneBit :: Integral a => a +bits = 14 +mask = 0x3fff +doneBit = 0x4000 + +chip :: Bool -> Word32 -> TFGen -> TFGen +chip done n g = splitn g (bits+1) (if done then m .|. doneBit else m) + where + m = n .&. mask + +chop :: Integer -> Integer +chop n = n `shiftR` bits + +stop :: Integral a => a -> Bool +stop n = n <= mask + +mkTheGen :: Int -> TFGen +mkTheGen = mkTFGen + +#else +import System.Random + +#define TheGen StdGen + +newTheGen :: IO StdGen +newTheGen = newStdGen + +mkTheGen :: Int -> StdGen +mkTheGen = mkStdGen + +chip :: Bool -> Int -> StdGen -> StdGen +chip finished n = boolVariant finished . boolVariant (even n) + +chop :: Integer -> Integer +chop n = n `div` 2 + +stop :: Integral a => a -> Bool +stop n = n <= 1 +#endif + +-- | The "standard" QuickCheck random number generator. +-- A wrapper around either 'TFGen' on GHC, or 'StdGen' +-- on other Haskell systems. +newtype QCGen = QCGen TheGen + +instance Show QCGen where + showsPrec n (QCGen g) s = showsPrec n g "" ++ s +instance Read QCGen where + readsPrec n xs = [(QCGen g, ys) | (g, ys) <- readsPrec n xs] + +instance RandomGen QCGen where + split (QCGen g) = + case split g of + (g1, g2) -> (QCGen g1, QCGen g2) + genRange (QCGen g) = genRange g + next (QCGen g) = + case next g of + (x, g') -> (x, QCGen g') + +newQCGen :: IO QCGen +newQCGen = fmap QCGen newTheGen + +mkQCGen :: Int -> QCGen +mkQCGen n = QCGen (mkTheGen n) + +bigNatVariant :: Integer -> TheGen -> TheGen +bigNatVariant n g + | g `seq` stop n = chip True (fromInteger n) g + | otherwise = (bigNatVariant $! chop n) $! chip False (fromInteger n) g + +{-# INLINE natVariant #-} +natVariant :: Integral a => a -> TheGen -> TheGen +natVariant n g + | g `seq` stop n = chip True (fromIntegral n) g + | otherwise = bigNatVariant (toInteger n) g + +{-# INLINE variantTheGen #-} +variantTheGen :: Integral a => a -> TheGen -> TheGen +variantTheGen n g + | n >= 1 = natVariant (n-1) (boolVariant False g) + | n == 0 = natVariant (0 `asTypeOf` n) (boolVariant True g) + | otherwise = bigNatVariant (negate (toInteger n)) (boolVariant True g) + +boolVariant :: Bool -> TheGen -> TheGen +boolVariant False = fst . split +boolVariant True = snd . split + +variantQCGen :: Integral a => a -> QCGen -> QCGen +variantQCGen n (QCGen g) = QCGen (variantTheGen n g) diff --git a/Test/QuickCheck/State.hs b/Test/QuickCheck/State.hs new file mode 100644 index 0000000..6aa7e4c --- /dev/null +++ b/Test/QuickCheck/State.hs @@ -0,0 +1,40 @@ +-- | QuickCheck's internal state. Internal QuickCheck module. +module Test.QuickCheck.State where + +import Test.QuickCheck.Text +import Test.QuickCheck.Random +import Data.Map(Map) +import Data.Set(Set) + +-------------------------------------------------------------------------- +-- State + +-- | State represents QuickCheck's internal state while testing a property. +-- The state is made visible to callback functions. +data State + = MkState + -- static + { terminal :: Terminal -- ^ the current terminal + , maxSuccessTests :: Int -- ^ maximum number of successful tests needed + , maxDiscardedRatio :: Int -- ^ maximum number of discarded tests per successful test + , computeSize :: Int -> Int -> Int -- ^ how to compute the size of test cases from + -- #tests and #discarded tests + , numTotMaxShrinks :: !Int -- ^ How many shrinks to try before giving up + + -- dynamic + , numSuccessTests :: !Int -- ^ the current number of tests that have succeeded + , numDiscardedTests :: !Int -- ^ the current number of discarded tests + , numRecentlyDiscardedTests :: !Int -- ^ the number of discarded tests since the last successful test + , labels :: !(Map String Int) -- ^ all labels that have been defined so far + , collected :: ![Set String] -- ^ all labels that have been collected so far + , expectedFailure :: !Bool -- ^ indicates if the property is expected to fail + , randomSeed :: !QCGen -- ^ the current random seed + + -- shrinking + , numSuccessShrinks :: !Int -- ^ number of successful shrinking steps so far + , numTryShrinks :: !Int -- ^ number of failed shrinking steps since the last successful shrink + , numTotTryShrinks :: !Int -- ^ total number of failed shrinking steps + } + +-------------------------------------------------------------------------- +-- the end. diff --git a/Test/QuickCheck/Test.hs b/Test/QuickCheck/Test.hs new file mode 100644 index 0000000..f9b61d2 --- /dev/null +++ b/Test/QuickCheck/Test.hs @@ -0,0 +1,489 @@ +-- | The main test loop. +{-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} +#endif +module Test.QuickCheck.Test where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck.Gen +import Test.QuickCheck.Property hiding ( Result( reason, theException, labels ) ) +import qualified Test.QuickCheck.Property as P +import Test.QuickCheck.Text +import Test.QuickCheck.State hiding (labels) +import qualified Test.QuickCheck.State as S +import Test.QuickCheck.Exception +import Test.QuickCheck.Random +import System.Random(split) +#if defined(MIN_VERSION_containers) +#if MIN_VERSION_containers(0,5,0) +import qualified Data.Map.Strict as Map +#else +import qualified Data.Map as Map +#endif +#else +import qualified Data.Map as Map +#endif +import qualified Data.Set as Set + +import Data.Char + ( isSpace + ) + +import Data.List + ( sort + , sortBy + , group + , intersperse + ) + +import Data.Maybe(fromMaybe) +import Data.Ord(comparing) +import Text.Printf(printf) + +-------------------------------------------------------------------------- +-- quickCheck + +-- * Running tests + +-- | Args specifies arguments to the QuickCheck driver +data Args + = Args + { replay :: Maybe (QCGen,Int) + -- ^ Should we replay a previous test? + -- Note: saving a seed from one version of QuickCheck and + -- replaying it in another is not supported. + -- If you want to store a test case permanently you should save + -- the test case itself. + , maxSuccess :: Int + -- ^ Maximum number of successful tests before succeeding. Testing stops + -- at the first failure. If all tests are passing and you want to run more tests, + -- increase this number. + , maxDiscardRatio :: Int + -- ^ Maximum number of discarded tests per successful test before giving up + , maxSize :: Int + -- ^ Size to use for the biggest test cases + , chatty :: Bool + -- ^ Whether to print anything + , maxShrinks :: Int + -- ^ Maximum number of shrinks to before giving up. Setting this to zero + -- turns shrinking off. + } + deriving ( Show, Read ) + +-- | Result represents the test result +data Result + -- | A successful test run + = Success + { numTests :: Int -- ^ Number of tests performed + , labels :: [(String,Double)] -- ^ Labels and frequencies found during all successful tests + , output :: String -- ^ Printed output + } + -- | Given up + | GaveUp + { numTests :: Int -- Number of tests performed + , labels :: [(String,Double)] -- Labels and frequencies found during all successful tests + , output :: String -- Printed output + } + -- | A failed test run + | Failure + { numTests :: Int -- Number of tests performed + , numShrinks :: Int -- ^ Number of successful shrinking steps performed + , numShrinkTries :: Int -- ^ Number of unsuccessful shrinking steps performed + , numShrinkFinal :: Int -- ^ Number of unsuccessful shrinking steps performed since last successful shrink + , usedSeed :: QCGen -- ^ What seed was used + , usedSize :: Int -- ^ What was the test size + , reason :: String -- ^ Why did the property fail + , theException :: Maybe AnException -- ^ The exception the property threw, if any + , labels :: [(String,Double)] -- Labels and frequencies found during all successful tests + , output :: String -- Printed output + , failingTestCase :: [String] -- ^ The test case which provoked the failure + } + -- | A property that should have failed did not + | NoExpectedFailure + { numTests :: Int -- Number of tests performed + , labels :: [(String,Double)] -- Labels and frequencies found during all successful tests + , output :: String -- Printed output + } + -- | The tests passed but a use of 'cover' had insufficient coverage + | InsufficientCoverage + { numTests :: Int -- Number of tests performed + , labels :: [(String,Double)] -- Labels and frequencies found during all successful tests + , output :: String -- Printed output + } + deriving ( Show ) + +-- | Check if the test run result was a success +isSuccess :: Result -> Bool +isSuccess Success{} = True +isSuccess _ = False + +-- | The default test arguments +stdArgs :: Args +stdArgs = Args + { replay = Nothing + , maxSuccess = 100 + , maxDiscardRatio = 10 + , maxSize = 100 + , chatty = True + , maxShrinks = maxBound + } + +-- | Tests a property and prints the results to 'stdout'. +-- +-- By default up to 100 tests are performed, which may not be enough +-- to find all bugs. To run more tests, use 'withMaxSuccess'. +quickCheck :: Testable prop => prop -> IO () +quickCheck p = quickCheckWith stdArgs p + +-- | Tests a property, using test arguments, and prints the results to 'stdout'. +quickCheckWith :: Testable prop => Args -> prop -> IO () +quickCheckWith args p = quickCheckWithResult args p >> return () + +-- | Tests a property, produces a test result, and prints the results to 'stdout'. +quickCheckResult :: Testable prop => prop -> IO Result +quickCheckResult p = quickCheckWithResult stdArgs p + +-- | Tests a property, using test arguments, produces a test result, and prints the results to 'stdout'. +quickCheckWithResult :: Testable prop => Args -> prop -> IO Result +quickCheckWithResult a p = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do + rnd <- case replay a of + Nothing -> newQCGen + Just (rnd,_) -> return rnd + test MkState{ terminal = tm + , maxSuccessTests = maxSuccess a + , maxDiscardedRatio = maxDiscardRatio a + , computeSize = case replay a of + Nothing -> computeSize' + Just (_,s) -> computeSize' `at0` s + , numTotMaxShrinks = maxShrinks a + , numSuccessTests = 0 + , numDiscardedTests = 0 + , numRecentlyDiscardedTests = 0 + , S.labels = Map.empty + , collected = [] + , expectedFailure = False + , randomSeed = rnd + , numSuccessShrinks = 0 + , numTryShrinks = 0 + , numTotTryShrinks = 0 + } (unGen (unProperty (property p))) + where computeSize' n d + -- e.g. with maxSuccess = 250, maxSize = 100, goes like this: + -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98. + | n `roundTo` maxSize a + maxSize a <= maxSuccess a || + n >= maxSuccess a || + maxSuccess a `mod` maxSize a == 0 = (n `mod` maxSize a + d `div` 10) `min` maxSize a + | otherwise = + ((n `mod` maxSize a) * maxSize a `div` (maxSuccess a `mod` maxSize a) + d `div` 10) `min` maxSize a + n `roundTo` m = (n `div` m) * m + at0 f s 0 0 = s + at0 f s n d = f n d + +-- | Tests a property and prints the results and all test cases generated to 'stdout'. +-- This is just a convenience function that means the same as @'quickCheck' . 'verbose'@. +verboseCheck :: Testable prop => prop -> IO () +verboseCheck p = quickCheck (verbose p) + +-- | Tests a property, using test arguments, and prints the results and all test cases generated to 'stdout'. +-- This is just a convenience function that combines 'quickCheckWith' and 'verbose'. +verboseCheckWith :: Testable prop => Args -> prop -> IO () +verboseCheckWith args p = quickCheckWith args (verbose p) + +-- | Tests a property, produces a test result, and prints the results and all test cases generated to 'stdout'. +-- This is just a convenience function that combines 'quickCheckResult' and 'verbose'. +verboseCheckResult :: Testable prop => prop -> IO Result +verboseCheckResult p = quickCheckResult (verbose p) + +-- | Tests a property, using test arguments, produces a test result, and prints the results and all test cases generated to 'stdout'. +-- This is just a convenience function that combines 'quickCheckWithResult' and 'verbose'. +verboseCheckWithResult :: Testable prop => Args -> prop -> IO Result +verboseCheckWithResult a p = quickCheckWithResult a (verbose p) + +-------------------------------------------------------------------------- +-- main test loop + +test :: State -> (QCGen -> Int -> Prop) -> IO Result +test st f + | numSuccessTests st >= maxSuccessTests st = + doneTesting st f + | numDiscardedTests st >= maxDiscardedRatio st * maxSuccessTests st = + giveUp st f + | otherwise = + runATest st f + +doneTesting :: State -> (QCGen -> Int -> Prop) -> IO Result +doneTesting st _f + | not (expectedFailure st) = do + putPart (terminal st) + ( bold ("*** Failed!") + ++ " Passed " + ++ show (numSuccessTests st) + ++ " tests (expected failure)" + ) + finished NoExpectedFailure + | not (null (insufficientlyCovered st)) = do + putPart (terminal st) + ( bold ("*** Insufficient coverage after ") + ++ show (numSuccessTests st) + ++ " tests" + ) + finished InsufficientCoverage + | otherwise = do + putPart (terminal st) + ( "+++ OK, passed " + ++ show (numSuccessTests st) + ++ " tests" + ) + finished Success + where + finished k = do + success st + theOutput <- terminalOutput (terminal st) + return (k (numSuccessTests st) (summary st) theOutput) + +giveUp :: State -> (QCGen -> Int -> Prop) -> IO Result +giveUp st _f = + do -- CALLBACK gave_up? + putPart (terminal st) + ( bold ("*** Gave up!") + ++ " Passed only " + ++ show (numSuccessTests st) + ++ " tests" + ) + success st + theOutput <- terminalOutput (terminal st) + return GaveUp{ numTests = numSuccessTests st + , labels = summary st + , output = theOutput + } + +runATest :: State -> (QCGen -> Int -> Prop) -> IO Result +runATest st f = + do -- CALLBACK before_test + putTemp (terminal st) + ( "(" + ++ number (numSuccessTests st) "test" + ++ concat [ "; " ++ show (numDiscardedTests st) ++ " discarded" + | numDiscardedTests st > 0 + ] + ++ ")" + ) + let size = computeSize st (numSuccessTests st) (numRecentlyDiscardedTests st) + MkRose res ts <- protectRose (reduceRose (unProp (f rnd1 size))) + res <- callbackPostTest st res + + let continue break st' | abort res = break st' + | otherwise = test st' + cons x xs + | Set.null x = xs + | otherwise = x:xs + + case res of + MkResult{ok = Just True, stamp = stamp, expect = expect, maybeNumTests = mnt} -> -- successful test + do continue doneTesting + st{ numSuccessTests = numSuccessTests st + 1 + , numRecentlyDiscardedTests = 0 + , maxSuccessTests = fromMaybe (maxSuccessTests st) mnt + , randomSeed = rnd2 + , S.labels = Map.unionWith max (S.labels st) (P.labels res) + , collected = stamp `cons` collected st + , expectedFailure = expect + } f + + MkResult{ok = Nothing, expect = expect, maybeNumTests = mnt} -> -- discarded test + do continue giveUp + st{ numDiscardedTests = numDiscardedTests st + 1 + , numRecentlyDiscardedTests = numRecentlyDiscardedTests st + 1 + , maxSuccessTests = fromMaybe (maxSuccessTests st) mnt + , randomSeed = rnd2 + , S.labels = Map.unionWith max (S.labels st) (P.labels res) + , expectedFailure = expect + } f + + MkResult{ok = Just False} -> -- failed test + do if expect res + then putPart (terminal st) (bold "*** Failed! ") + else putPart (terminal st) "+++ OK, failed as expected. " + (numShrinks, totFailed, lastFailed, res) <- foundFailure st res ts + theOutput <- terminalOutput (terminal st) + if not (expect res) then + return Success{ labels = summary st, + numTests = numSuccessTests st+1, + output = theOutput } + else do + testCase <- mapM showCounterexample (P.testCase res) + return Failure{ usedSeed = randomSeed st -- correct! (this will be split first) + , usedSize = size + , numTests = numSuccessTests st+1 + , numShrinks = numShrinks + , numShrinkTries = totFailed + , numShrinkFinal = lastFailed + , output = theOutput + , reason = P.reason res + , theException = P.theException res + , labels = summary st + , failingTestCase = testCase + } + where + (rnd1,rnd2) = split (randomSeed st) + +summary :: State -> [(String, Double)] +summary st = reverse + . sortBy (comparing snd) + . map (\ss -> (head ss, fromIntegral (length ss) * 100 / fromIntegral (numSuccessTests st))) + . group + . sort + $ [ concat (intersperse ", " s') + | s <- collected st + -- HACK: don't print out labels that were created by 'cover'. + , let s' = [ t | t <- Set.toList s, Map.lookup t (S.labels st) == Just 0 ] + , not (null s') + ] + +success :: State -> IO () +success st = + case allLabels ++ covers of + [] -> do putLine (terminal st) "." + [pt] -> do putLine (terminal st) + ( " (" + ++ dropWhile isSpace pt + ++ ")." + ) + cases -> do putLine (terminal st) ":" + mapM_ (putLine $ terminal st) cases + where + allLabels :: [String] + allLabels = map (formatLabel (numSuccessTests st) True) (summary st) + + covers :: [String] + covers = [ ("only " ++ formatLabel (numSuccessTests st) False (l, p) ++ ", not " ++ show reqP ++ "%") + | (l, reqP, p) <- insufficientlyCovered st ] + +formatLabel :: Int -> Bool -> (String, Double) -> String +formatLabel n pad (x, p) = showP pad p ++ " " ++ x + where + showP :: Bool -> Double -> String + showP pad p = + (if pad && p < 10 then " " else "") ++ + printf "%.*f" places p ++ "%" + + -- Show no decimal places if <= 100 successful tests, + -- one decimal place if <= 1000 successful tests, + -- two decimal places if <= 10000 successful tests, and so on. + places :: Integer + places = + ceiling (logBase 10 (fromIntegral n) - 2 :: Double) `max` 0 + +labelCount :: String -> State -> Int +labelCount l st = + -- XXX in case of a disjunction, a label can occur several times, + -- need to think what to do there + length [ l' | l' <- concat (map Set.toList (collected st)), l == l' ] + +percentage :: Integral a => State -> a -> Double +percentage st n = + fromIntegral n * 100 / fromIntegral (numSuccessTests st) + +insufficientlyCovered :: State -> [(String, Int, Double)] +insufficientlyCovered st = + [ (l, reqP, p) + | (l, reqP) <- Map.toList (S.labels st), + let p = percentage st (labelCount l st), + p < fromIntegral reqP ] + +-------------------------------------------------------------------------- +-- main shrinking loop + +foundFailure :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) +foundFailure st res ts = + do localMin st{ numTryShrinks = 0 } res res ts + +localMin :: State -> P.Result -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) +-- Don't try to shrink for too long +localMin st res _ ts + | numSuccessShrinks st + numTotTryShrinks st >= numTotMaxShrinks st = + localMinFound st res +localMin st res _ ts = do + r <- tryEvaluateIO $ + putTemp (terminal st) + ( short 26 (oneLine (P.reason res)) + ++ " (after " ++ number (numSuccessTests st+1) "test" + ++ concat [ " and " + ++ show (numSuccessShrinks st) + ++ concat [ "." ++ show (numTryShrinks st) | numTryShrinks st > 0 ] + ++ " shrink" + ++ (if numSuccessShrinks st == 1 + && numTryShrinks st == 0 + then "" else "s") + | numSuccessShrinks st > 0 || numTryShrinks st > 0 + ] + ++ ")..." + ) + case r of + Left err -> + localMinFound st (exception "Exception while printing status message" err) { callbacks = callbacks res } + Right () -> do + r <- tryEvaluate ts + case r of + Left err -> + localMinFound st + (exception "Exception while generating shrink-list" err) { callbacks = callbacks res } + Right ts' -> localMin' st res ts' + +localMin' :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) +localMin' st res [] = localMinFound st res +localMin' st res (t:ts) = + do -- CALLBACK before_test + MkRose res' ts' <- protectRose (reduceRose t) + res' <- callbackPostTest st res' + if ok res' == Just False + then localMin st{ numSuccessShrinks = numSuccessShrinks st + 1, + numTryShrinks = 0 } res' res ts' + else localMin st{ numTryShrinks = numTryShrinks st + 1, + numTotTryShrinks = numTotTryShrinks st + 1 } res res ts + +localMinFound :: State -> P.Result -> IO (Int, Int, Int, P.Result) +localMinFound st res = + do let report = concat [ + "(after " ++ number (numSuccessTests st+1) "test", + concat [ " and " ++ number (numSuccessShrinks st) "shrink" + | numSuccessShrinks st > 0 + ], + "): " + ] + if isOneLine (P.reason res) + then putLine (terminal st) (P.reason res ++ " " ++ report) + else do + putLine (terminal st) report + sequence_ + [ putLine (terminal st) msg + | msg <- lines (P.reason res) + ] + callbackPostFinalFailure st res + -- NB no need to check if callbacks threw an exception because + -- we are about to return to the user anyway + return (numSuccessShrinks st, numTotTryShrinks st - numTryShrinks st, numTryShrinks st, res) + +-------------------------------------------------------------------------- +-- callbacks + +callbackPostTest :: State -> P.Result -> IO P.Result +callbackPostTest st res = protect (exception "Exception running callback") $ do + sequence_ [ f st res | PostTest _ f <- callbacks res ] + return res + +callbackPostFinalFailure :: State -> P.Result -> IO () +callbackPostFinalFailure st res = do + x <- tryEvaluateIO $ sequence_ [ f st res | PostFinalFailure _ f <- callbacks res ] + case x of + Left err -> do + putLine (terminal st) "*** Exception running callback: " + tryEvaluateIO $ putLine (terminal st) (show err) + return () + Right () -> return () + +-------------------------------------------------------------------------- +-- the end. diff --git a/Test/QuickCheck/Text.hs b/Test/QuickCheck/Text.hs new file mode 100644 index 0000000..41e98db --- /dev/null +++ b/Test/QuickCheck/Text.hs @@ -0,0 +1,150 @@ +-- | Terminal control. Internal QuickCheck module. +module Test.QuickCheck.Text + ( Str(..) + , ranges + + , number + , short + , showErr + , oneLine + , isOneLine + , bold + + , newTerminal + , withStdioTerminal + , withNullTerminal + , terminalOutput + , handle + , Terminal + , putTemp + , putPart + , putLine + ) + where + +-------------------------------------------------------------------------- +-- imports + +import System.IO + ( hFlush + , hPutStr + , stdout + , stderr + , Handle + , BufferMode (..) + , hGetBuffering + , hSetBuffering + , hIsTerminalDevice + ) + +import Data.IORef +import Test.QuickCheck.Exception + +-------------------------------------------------------------------------- +-- literal string + +newtype Str = MkStr String + +instance Show Str where + show (MkStr s) = s + +ranges :: (Show a, Integral a) => a -> a -> Str +ranges k n = MkStr (show n' ++ " -- " ++ show (n'+k-1)) + where + n' = k * (n `div` k) + +-------------------------------------------------------------------------- +-- formatting + +number :: Int -> String -> String +number n s = show n ++ " " ++ s ++ if n == 1 then "" else "s" + +short :: Int -> String -> String +short n s + | n < k = take (n-2-i) s ++ ".." ++ drop (k-i) s + | otherwise = s + where + k = length s + i = if n >= 5 then 3 else 0 + +showErr :: Show a => a -> String +showErr = unwords . words . show + +oneLine :: String -> String +oneLine = unwords . words + +isOneLine :: String -> Bool +isOneLine xs = '\n' `notElem` xs + +bold :: String -> String +-- not portable: +--bold s = "\ESC[1m" ++ s ++ "\ESC[0m" +bold s = s -- for now + +-------------------------------------------------------------------------- +-- putting strings + +data Terminal + = MkTerminal (IORef ShowS) (IORef Int) (String -> IO ()) (String -> IO ()) + +newTerminal :: (String -> IO ()) -> (String -> IO ()) -> IO Terminal +newTerminal out err = + do res <- newIORef (showString "") + tmp <- newIORef 0 + return (MkTerminal res tmp out err) + +withBuffering :: IO a -> IO a +withBuffering action = do + mode <- hGetBuffering stderr + -- By default stderr is unbuffered. This is very slow, hence we explicitly + -- enable line buffering. + hSetBuffering stderr LineBuffering + action `finally` hSetBuffering stderr mode + +withStdioTerminal :: (Terminal -> IO a) -> IO a +withStdioTerminal action = do + isatty <- hIsTerminalDevice stderr + let err = if isatty then handle stderr else const (return ()) + withBuffering (newTerminal (handle stdout) err >>= action) + +withNullTerminal :: (Terminal -> IO a) -> IO a +withNullTerminal action = + newTerminal (const (return ())) (const (return ())) >>= action + +terminalOutput :: Terminal -> IO String +terminalOutput (MkTerminal res _ _ _) = fmap ($ "") (readIORef res) + +handle :: Handle -> String -> IO () +handle h s = do + hPutStr h s + hFlush h + +flush :: Terminal -> IO () +flush (MkTerminal _ tmp _ err) = + do n <- readIORef tmp + writeIORef tmp 0 + err (replicate n ' ' ++ replicate n '\b') + +putPart, putTemp, putLine :: Terminal -> String -> IO () +putPart tm@(MkTerminal res _ out _) s = + do flush tm + force s + out s + modifyIORef res (. showString s) + where + force :: [a] -> IO () + force = evaluate . seqList + + seqList :: [a] -> () + seqList [] = () + seqList (x:xs) = x `seq` seqList xs + +putLine tm s = putPart tm (s ++ "\n") + +putTemp tm@(MkTerminal _ tmp _ err) s = + do flush tm + err (s ++ [ '\b' | _ <- s ]) + modifyIORef tmp (+ length s) + +-------------------------------------------------------------------------- +-- the end. diff --git a/changelog b/changelog new file mode 100644 index 0000000..b703e6b --- /dev/null +++ b/changelog @@ -0,0 +1,207 @@ +QuickCheck 2.10.1 (release 2017-10-06) + * Arbitrary instances for Foreign.C.Types are available in more + GHC versions. + * Fixed a bug where withMaxSuccess didn't adjust the allowed + number of discarded tests. + * Remove quadratic behaviour in terminal output. + +QuickCheck 2.10 (released 2017-06-15) + * New combinators: + - withMaxSuccess sets the maximum number of test cases for a property. + - shrinkMap/shrinkMapBy are helpers for defining shrink functions. + - total checks that a value is non-crashing. + - suchThatMap is similar to 'suchThat' + but takes a Maybe-returning function instead of a predicate. + - getSize returns the current test case size. + + * Random strings and characters now include Unicode characters by + default. To generate only ASCII characters, use the new + ASCIIString modifier or arbitraryASCIIChar generator. + The following modifiers and generators also control the + kind of strings generated: UnicodeString, PrintableString, + arbitraryUnicodeChar, arbitraryPrintableChar. + + * QuickCheck no longer catches asynchronous exceptions, which + means that pressing ctrl-C will now cancel testing without + printing a counterexample. If you are debugging an infinite loop, + please use the 'within' combinator or 'verboseCheck' instead. + ('within' is better as it allows the counterexample to be + shrunk.) + + * Much of Test.QuickCheck.Function (showable random functions) + is now exported from Test.QuickCheck. + - Test.QuickCheck.Function now defines functions and + pattern synonyms which simplify testing functions of + more than one argument: apply2, apply3, Fn2, Fn3. + + * New typeclasses Arbitrary1 and Arbitrary2 which lift Arbitrary + to unary/binary type constructors, like in Data.Functor.Classes. + + * Some Arbitrary instances have been removed: NonEmpty, Natural. + This is because they resulted in a lot of extra dependencies. + You can now find them in the quickcheck-instances package. + Alternatively, use the NonEmptyList and NonNegative modifiers. + + * New Arbitrary instances for the following types: Proxy, ExitCode, + WrappedMonad, WrappedArrow, QCGen, and the types in + Foreign.C.Types and Data.Functor.{Product,Compose}. + Also a Function instance for Word. + + * The functions in Test.QuickCheck.Monadic which take an argument + of type PropertyM m a now expect that 'a' to be Testable, and test it. + To reduce breakage from this, () is now an instance of Testable which + always succeeds. + - PropertyM now has a MonadFail instance on recent GHCs. + Furthermore, the constraints on some instances were loosened. + + * Miscellaneous API changes: + - Result now returns the counterexample as a list of strings. + See the "failingTestCase" field. + - Args now has a `maxShrinks` argument, the maximum number of + shrinks to try before giving up shrinking. + - The 'labels' field of Result now encodes frequencies as Doubles + rather than Ints. + + * Bugfixes: + - 'Test.QuickCheck.Function', 'Test.QuickCheck.Poly', and + 'Test.QuickCheck.Monadic' are now Safe modules. + - Result.theException and Result.reason were taken from + the pre-shrunk counterexample, not the shrunk one. + - The Testable Property instance improperly used 'again'. + - Gen.>>= is strict in the result of split, fixing a space leak. + - within now gives a better error message on timeout + + * Some more examples and links have been added to the documentation. + +QuickCheck 2.9.2 (released 2016-09-15) + * Fix a bug where some properties were only being tested once + * Make shrinking of floating-point values less aggressive + * Add function chooseAny :: Random a => Gen a + +QuickCheck 2.9.1 (released 2016-07-11) + * 'again' was only used in forAllShrink, not forAll + +QuickCheck 2.9 (released 2016-07-10) + * Arbitrary, CoArbitrary and Function instances for more types + * Generics for automatic Function instances + * A new combinator "again" which undoes the effect of "once" + * Remove "exhaustive" from Testable typeclass; + instead, combinators which are nonexhaustive (such as forAll) + call "again", which should be more robust + + * Drop support for GHC 6.x + + * Fixed bugs: + * arbitrarySizedBoundedIntegral wasn't generating huge integers + * verboseCheck failed with Test.QuickCheck.Function + * label had a space leak + +QuickCheck 2.8.2 (released 2016-01-15) + * GHC 8 support + * Add Arbitrary and CoArbitrary instances for types in + containers package + * Improve speed of shuffle combinator + * Only print to stderr if it's a terminal. + * Small changes: slightly improve documentation, + remove redundant constraints from some functions' types, + small improvements to Test.QuickCheck.All. + +QuickCheck 2.8.1 (released 2015-04-03) + * Fix bug where exceptions thrown printing counterexamples weren't + being caught when terminal output was disabled + * Don't export Test.QuickCheck.Property.result + +QuickCheck 2.8 (released 2015-03-18) + * New features: + * Support for GHC 7.10 + * Arbitrary instance for Natural + * New generators shuffle and sublistOf + * Support for generic coarbitrary + * When using the cover combinator, insufficient coverage now + causes the property to fail + + * API changes: + * Test.QuickCheck.Function: new pattern synonym Fn + * genericShrink no longer requires Typeable + * Result has a new constructor InsufficientCoverage + * resize throws an error if the size is negative + + * Bug fixes: + * Fix memory leaks + * Exceptions thrown by callbacks now cause the test to fail + * Fixed a bug where the cover combinator wouldn't give a + warning if coverage was 0% + +QuickCheck 2.7.3 (released 2014-03-24) + * Add annotations for Safe Haskell. + +QuickCheck 2.7.2 (released 2014-03-22) + * Fix bug in cabal file which broke cabal test + +QuickCheck 2.7.1 (released 2014-03-20) + * Fixed bug - the Small modifier didn't work on unsigned types + * Changed arbitrarySizedIntegral to have an Integral constraint + instead of just Num + +QuickCheck 2.7 (released 2014-03-19) + + * New features: + * New genericShrink function provides generic shrinking with GHC. + * New combinator x === y: fails if x /= y, but also prints their values + * New function generate :: Gen a -> IO a for running a generator. + * New combinators infiniteList and infiniteListOf for generating infinite lists. + * Several combinators added to the main Test.QuickCheck module which + were previously languishing in other modules. Of particular interest: + quickCheckAll, ioProperty. + * New combinators delay and capture which can be used (unsafely!) + to reuse the random number seed. Useful for generating + polymorphic (rank-2) values. + * A new Discard data type and a Testable instance for discarding test cases. + * All modifiers now have Functor instances and accessor functions. + * Pressing ctrl-C during shrinking now shows the last failed + test case, rather than the current shrinking candidate. + * Experimental support for UHC. You will need the latest version of Cabal from git. + + * Better distribution of test data: + * The Int generator now only generates fairly small numbers. + * The new Small and Large modifiers control the distribution of integers + (Small generates small numbers, Large from the whole range). + * Floating-point numbers shrink better. + + * Improved random number generation: + * QuickCheck now uses TFGen rather than StdGen on newer versions + of GHC, because StdGen's random numbers aren't always random. + * 'variant' now uses a prefix code. This should prevent some + potential bananaskins with coarbitrary. + + * API changes: + * The Gen monad now uses an abstract type QCGen rather than StdGen. + * The Result type now returns the thrown exception and number + of failed shrink attempts. + * Property is now a newtype rather than Gen Prop as it was before. + * promote is moved into the new module Test.QuickCheck.Gen.Unsafe. + * 'printTestCase' is deprecated - its new name is 'counterexample' + * 'morallyDubiousIOProperty' is deprecated - its new name is + 'ioProperty', no moral judgement involved :) + +QuickCheck 2.6, released 2013-03-07 + + * Add convenience Function instances for up to 7-tuples + * Make stderr line buffered to reduce console I/O. + * Return a flag to say whether the test case was interrupted. + +QuickCheck 2.5, released 2012-06-18 + + * Replace maxDiscard with maxDiscardRatio + * Remove Testable () instance. + * Added a 'discard' exception that discards the current test case + * Add accessors for modifiers (where it makes sense) + * Rename 'stop' to 'abort' to avoid a name clash + * Added a 'once' combinator + * If a property is of type Bool, only run it once + * Add coarbitraryEnum to Test.QuickCheck module. + * Add 'coarbitrary' helper for Enums. + * Rejiggled the formatting code to support multi-line error messages + * Add instances for Ordering and Fixed. + * Added arbitraryBoundedEnum generator (thanks to Antoine Latter). + * Add verboseCheckAll and polyverboseCheck function for usability. diff --git a/examples/Heap.hs b/examples/Heap.hs new file mode 100644 index 0000000..3f701b7 --- /dev/null +++ b/examples/Heap.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} +module Main where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck + +import Data.List + ( sort + , (\\) + ) + +import Control.Monad + ( liftM + , liftM2 + ) + +-------------------------------------------------------------------------- +-- skew heaps + +data Heap a + = Node a (Heap a) (Heap a) + | Empty + deriving ( Eq, Ord, Show ) + +empty :: Heap a +empty = Empty + +isEmpty :: Heap a -> Bool +isEmpty Empty = True +isEmpty _ = False + +unit :: a -> Heap a +unit x = Node x empty empty + +size :: Heap a -> Int +size Empty = 0 +size (Node _ h1 h2) = 1 + size h1 + size h2 + +insert :: Ord a => a -> Heap a -> Heap a +insert x h = unit x `merge` h + +removeMin :: Ord a => Heap a -> Maybe (a, Heap a) +removeMin Empty = Nothing +removeMin (Node x h1 h2) = Just (x, h1 `merge` h2) + +merge :: Ord a => Heap a -> Heap a -> Heap a +h1 `merge` Empty = h1 +Empty `merge` h2 = h2 +h1@(Node x h11 h12) `merge` h2@(Node y h21 h22) + | x <= y = Node x (h12 `merge` h2) h11 + | otherwise = Node y (h22 `merge` h1) h21 + +fromList :: Ord a => [a] -> Heap a +fromList xs = merging [ unit x | x <- xs ] + where + merging [] = empty + merging [h] = h + merging hs = merging (sweep hs) + + sweep [] = [] + sweep [h] = [h] + sweep (h1:h2:hs) = (h1 `merge` h2) : sweep hs + +toList :: Heap a -> [a] +toList h = toList' [h] + where + toList' [] = [] + toList' (Empty : hs) = toList' hs + toList' (Node x h1 h2 : hs) = x : toList' (h1:h2:hs) + +toSortedList :: Ord a => Heap a -> [a] +toSortedList Empty = [] +toSortedList (Node x h1 h2) = x : toList (h1 `merge` h2) + +-------------------------------------------------------------------------- +-- specification + +invariant :: Ord a => Heap a -> Bool +invariant Empty = True +invariant (Node x h1 h2) = x <=? h1 && x <=? h2 && invariant h1 && invariant h2 + +(<=?) :: Ord a => a -> Heap a -> Bool +x <=? Empty = True +x <=? Node y _ _ = x <= y + +(==?) :: Ord a => Heap a -> [a] -> Bool +h ==? xs = invariant h && sort (toList h) == sort xs + +-------------------------------------------------------------------------- +-- properties + +prop_Empty = + empty ==? ([] :: [Int]) + +prop_IsEmpty (h :: Heap Int) = + isEmpty h == null (toList h) + +prop_Unit (x :: Int) = + unit x ==? [x] + +prop_Size (h :: Heap Int) = + size h == length (toList h) + +prop_Insert x (h :: Heap Int) = + insert x h ==? (x : toList h) + +prop_RemoveMin (h :: Heap Int) = + cover (size h > 1) 80 "non-trivial" $ + case removeMin h of + Nothing -> h ==? [] + Just (x,h') -> x == minimum (toList h) && h' ==? (toList h \\ [x]) + +prop_Merge h1 (h2 :: Heap Int) = + (h1 `merge` h2) ==? (toList h1 ++ toList h2) + +prop_FromList (xs :: [Int]) = + fromList xs ==? xs + +prop_ToSortedList (h :: Heap Int) = + h ==? xs && xs == sort xs + where + xs = toSortedList h + +-------------------------------------------------------------------------- +-- generators + +instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where + arbitrary = sized (arbHeap Nothing) + where + arbHeap mx n = + frequency $ + [ (1, return Empty) ] ++ + [ (7, do my <- arbitrary `suchThatMaybe` ((>= mx) . Just) + case my of + Nothing -> return Empty + Just y -> liftM2 (Node y) arbHeap2 arbHeap2 + where arbHeap2 = arbHeap (Just y) (n `div` 2)) + | n > 0 + ] + +-------------------------------------------------------------------------- +-- main + +return [] +main = $quickCheckAll + +-------------------------------------------------------------------------- +-- the end. +{- + shrink Empty = [] + shrink (Node x h1 h2) = + [ h1, h2 ] + ++ [ Node x h1' h2 | h1' <- shrink h1, x <=? h1' ] + ++ [ Node x h1 h2' | h2' <- shrink h2, x <=? h2' ] + ++ [ Node x' h1 h2 | x' <- shrink x, x' <=? h1, x' <=? h2 ] +-} + +-- toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) + +{- +prop_HeapIsNotSorted (h :: Heap Int) = + expectFailure $ + toList h == toSortedList h +-} + diff --git a/examples/Heap_Program.hs b/examples/Heap_Program.hs new file mode 100644 index 0000000..e5f406c --- /dev/null +++ b/examples/Heap_Program.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} +module Main where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck +import Test.QuickCheck.Poly + +import Data.List + ( sort + , (\\) + ) + +import Control.Monad + ( liftM + , liftM2 + ) + +-------------------------------------------------------------------------- +-- skew heaps + +data Heap a + = Node a (Heap a) (Heap a) + | Nil + deriving ( Eq, Ord, Show ) + +empty :: Heap a +empty = Nil + +isEmpty :: Heap a -> Bool +isEmpty Nil = True +isEmpty _ = False + +unit :: a -> Heap a +unit x = Node x empty empty + +size :: Heap a -> Int +size Nil = 0 +size (Node _ h1 h2) = 1 + size h1 + size h2 + +insert :: Ord a => a -> Heap a -> Heap a +insert x h = unit x `merge` h + +removeMin :: Ord a => Heap a -> Maybe (a, Heap a) +removeMin Nil = Nothing +removeMin (Node x h1 h2) = Just (x, h1 `merge` h2) + +merge :: Ord a => Heap a -> Heap a -> Heap a +h1 `merge` Nil = h1 +Nil `merge` h2 = h2 +h1@(Node x h11 h12) `merge` h2@(Node y h21 h22) + | x <= y = Node x (h12 `merge` h2) h11 + | otherwise = Node y (h22 `merge` h1) h21 + +fromList :: Ord a => [a] -> Heap a +fromList xs = merging [ unit x | x <- xs ] + where + merging [] = empty + merging [h] = h + merging hs = merging (sweep hs) + + sweep [] = [] + sweep [h] = [h] + sweep (h1:h2:hs) = (h1 `merge` h2) : sweep hs + +toList :: Heap a -> [a] +toList h = toList' [h] + where + toList' [] = [] + toList' (Nil : hs) = toList' hs + toList' (Node x h1 h2 : hs) = x : toList' (h1:h2:hs) + +toSortedList :: Ord a => Heap a -> [a] +toSortedList Nil = [] +toSortedList (Node x h1 h2) = x : toList (h1 `merge` h2) + +-------------------------------------------------------------------------- +-- heap programs + +data HeapP a + = Empty + | Unit a + | Insert a (HeapP a) + | SafeRemoveMin (HeapP a) + | Merge (HeapP a) (HeapP a) + | FromList [a] + deriving (Show) + +heap :: Ord a => HeapP a -> Heap a +heap Empty = empty +heap (Unit x) = unit x +heap (Insert x p) = insert x (heap p) +heap (SafeRemoveMin p) = case removeMin (heap p) of + Nothing -> empty -- arbitrary choice + Just (_,h) -> h +heap (Merge p q) = heap p `merge` heap q +heap (FromList xs) = fromList xs + +instance Arbitrary a => Arbitrary (HeapP a) where + arbitrary = sized arbHeapP + where + arbHeapP s = + frequency + [ (1, do return Empty) + , (1, do x <- arbitrary + return (Unit x)) + , (s, do x <- arbitrary + p <- arbHeapP s1 + return (Insert x p)) + , (s, do p <- arbHeapP s1 + return (SafeRemoveMin p)) + , (s, do p <- arbHeapP s2 + q <- arbHeapP s2 + return (Merge p q)) + , (1, do xs <- arbitrary + return (FromList xs)) + ] + where + s1 = s-1 + s2 = s`div`2 + + + shrink (Unit x) = [ Unit x' | x' <- shrink x ] + shrink (FromList xs) = [ Unit x | x <- xs ] + ++ [ FromList xs' | xs' <- shrink xs ] + shrink (Insert x p) = [ p ] + ++ [ Insert x p' | p' <- shrink p ] + ++ [ Insert x' p | x' <- shrink x ] + shrink (SafeRemoveMin p) = [ p ] + ++ [ SafeRemoveMin p' | p' <- shrink p ] + shrink (Merge p q) = [ p, q ] + ++ [ Merge p' q | p' <- shrink p ] + ++ [ Merge p q' | q' <- shrink q ] + shrink _ = [] + +data HeapPP a = HeapPP (HeapP a) (Heap a) + deriving (Show) + +instance (Ord a, Arbitrary a) => Arbitrary (HeapPP a) where + arbitrary = + do p <- arbitrary + return (HeapPP p (heap p)) + + shrink (HeapPP p _) = + [ HeapPP p' (heap p') | p' <- shrink p ] + +-------------------------------------------------------------------------- +-- properties + +(==?) :: Heap OrdA -> [OrdA] -> Bool +h ==? xs = sort (toList h) == sort xs + +prop_Empty = + empty ==? [] + +prop_IsEmpty (HeapPP _ h) = + isEmpty h == null (toList h) + +prop_Unit x = + unit x ==? [x] + +prop_Size (HeapPP _ h) = + size h == length (toList h) + +prop_Insert x (HeapPP _ h) = + insert x h ==? (x : toList h) + +prop_RemoveMin (HeapPP _ h) = + cover (size h > 1) 80 "non-trivial" $ + case removeMin h of + Nothing -> h ==? [] + Just (x,h') -> x == minimum (toList h) && h' ==? (toList h \\ [x]) + +prop_Merge (HeapPP _ h1) (HeapPP _ h2) = + (h1 `merge` h2) ==? (toList h1 ++ toList h2) + +prop_FromList xs = + fromList xs ==? xs + +prop_ToSortedList (HeapPP _ h) = + h ==? xs && xs == sort xs + where + xs = toSortedList h + +-------------------------------------------------------------------------- +-- main + +return [] +main = $(quickCheckAll) + +-------------------------------------------------------------------------- +-- the end. + +-- toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) + + diff --git a/examples/Heap_ProgramAlgebraic.hs b/examples/Heap_ProgramAlgebraic.hs new file mode 100644 index 0000000..bfa9626 --- /dev/null +++ b/examples/Heap_ProgramAlgebraic.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, GADTs #-} +module Main where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck +import Test.QuickCheck.Poly + +import Data.List + ( sort + , nub + , (\\) + ) + +import Data.Maybe + ( fromJust + ) + +import Control.Monad + ( liftM + , liftM2 + ) + +-------------------------------------------------------------------------- +-- skew heaps + +data Heap a + = Node a (Heap a) (Heap a) + | Nil + deriving ( Eq, Ord, Show ) + +empty :: Heap a +empty = Nil + +isEmpty :: Heap a -> Bool +isEmpty Nil = True +isEmpty _ = False + +unit :: a -> Heap a +unit x = Node x empty empty + +size :: Heap a -> Int +size Nil = 0 +size (Node _ h1 h2) = 1 + size h1 + size h2 + +insert :: Ord a => a -> Heap a -> Heap a +insert x h = unit x `merge` h + +removeMin :: Ord a => Heap a -> Maybe (a, Heap a) +removeMin Nil = Nothing +removeMin (Node x h1 h2) = Just (x, h1 `merge` h2) + +merge :: Ord a => Heap a -> Heap a -> Heap a +h1 `merge` Nil = h1 +Nil `merge` h2 = h2 +h1@(Node x h11 h12) `merge` h2@(Node y h21 h22) + | x <= y = Node x (h12 `merge` h2) h11 + | otherwise = Node y (h22 `merge` h1) h21 + +fromList :: Ord a => [a] -> Heap a +fromList xs = merging [ unit x | x <- xs ] [] + where + merging [] [] = empty + merging [p] [] = p + merging (p:q:ps) qs = merging ps ((p`merge`q):qs) + merging ps qs = merging (ps ++ reverse qs) [] + +toList :: Heap a -> [a] +toList h = toList' [h] + where + toList' [] = [] + toList' (Nil : hs) = toList' hs + toList' (Node x h1 h2 : hs) = x : toList' (h1:h2:hs) + +toSortedList :: Ord a => Heap a -> [a] +toSortedList Nil = [] +toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) + +-------------------------------------------------------------------------- +-- heap programs + +data HeapP a + = Empty + | Unit a + | Insert a (HeapP a) + | SafeRemoveMin (HeapP a) + | Merge (HeapP a) (HeapP a) + | FromList [a] + deriving (Show) + +safeRemoveMin :: Ord a => Heap a -> Heap a +safeRemoveMin h = case removeMin h of + Nothing -> empty -- arbitrary choice + Just (_,h) -> h + +heap :: Ord a => HeapP a -> Heap a +heap Empty = empty +heap (Unit x) = unit x +heap (Insert x p) = insert x (heap p) +heap (SafeRemoveMin p) = safeRemoveMin (heap p) +heap (Merge p q) = heap p `merge` heap q +heap (FromList xs) = fromList xs + +instance (Ord a, Arbitrary a) => Arbitrary (HeapP a) where + arbitrary = sized arbHeapP + where + arbHeapP s = + frequency + [ (1, do return Empty) + , (1, do x <- arbitrary + return (Unit x)) + , (s, do x <- arbitrary + p <- arbHeapP s1 + return (Insert x p)) + , (s, do p <- arbHeapP s1 + return (SafeRemoveMin p)) + , (s, do p <- arbHeapP s2 + q <- arbHeapP s2 + return (Merge p q)) + , (1, do xs <- arbitrary + return (FromList xs)) + ] + where + s1 = s-1 + s2 = s`div`2 + + + shrink Empty = [] + shrink (Unit x) = [ Unit x' | x' <- shrink x ] + shrink (FromList xs) = [ Unit x | x <- xs ] + ++ [ FromList xs' | xs' <- shrink xs ] + shrink p = + [ FromList (toList (heap p)) ] ++ + case p of + Insert x p -> [ p ] + ++ [ Insert x p' | p' <- shrink p ] + ++ [ Insert x' p | x' <- shrink x ] + SafeRemoveMin p -> [ p ] + ++ [ SafeRemoveMin p' | p' <- shrink p ] + Merge p q -> [ p, q ] + ++ [ Merge p' q | p' <- shrink p ] + ++ [ Merge p q' | q' <- shrink q ] + +data HeapPP a = HeapPP (HeapP a) (Heap a) + deriving (Show) + +instance (Ord a, Arbitrary a) => Arbitrary (HeapPP a) where + arbitrary = + do p <- arbitrary + return (HeapPP p (heap p)) + + shrink (HeapPP p _) = + [ HeapPP p' (heap p') | p' <- shrink p ] + +-------------------------------------------------------------------------- +-- properties + +data Context a where + Context :: Eq b => (Heap a -> b) -> Context a + +instance (Ord a, Arbitrary a) => Arbitrary (Context a) where + arbitrary = + do f <- sized arbContext + let vec h = (size h, toSortedList h, isEmpty h) + return (Context (vec . f)) + where + arbContext s = + frequency + [ (1, do return id) + , (s, do x <- arbitrary + f <- arbContext (s-1) + return (insert x . f)) + , (s, do f <- arbContext (s-1) + return (safeRemoveMin . f)) + , (s, do HeapPP _ h <- arbitrary + f <- arbContext (s`div`2) + elements [ (h `merge`) . f, (`merge` h) . f ]) + ] + +instance Show (Context a) where + show _ = "*" + +(=~) :: Heap Char -> Heap Char -> Property +--h1 =~ h2 = sort (toList h1) == sort (toList h2) +--h1 =~ h2 = property (nub (sort (toList h1)) == nub (sort (toList h2))) -- bug! +h1 =~ h2 = property (\(Context c) -> c h1 == c h2) + +{- +The normal form is: + + insert x1 (insert x2 (... empty)...) + +where x1 <= x2 <= ... +-} + +-- heap creating operations + +prop_Unit x = + unit x =~ insert x empty + +prop_RemoveMin_Empty = + removeMin (empty :: Heap OrdA) == Nothing + +prop_RemoveMin_Insert1 x = + removeMin (insert x empty :: Heap OrdA) == Just (x, empty) + +prop_RemoveMin_Insert2 x y (HeapPP _ h) = + removeMin (insert x (insert y h)) ==~ + (insert (max x y) `maph` removeMin (insert (min x y) h)) + where + f `maph` Just (x,h) = Just (x, f h) + f `maph` Nothing = Nothing + + Nothing ==~ Nothing = property True + Just (x,h1) ==~ Just (y,h2) = x==y .&&. h1 =~ h2 + +prop_InsertSwap x y (HeapPP _ h) = + insert x (insert y h) =~ insert y (insert x h) + +prop_MergeInsertLeft x (HeapPP _ h1) (HeapPP _ h2) = + (insert x h1 `merge` h2) =~ insert x (h1 `merge` h2) + +prop_MergeInsertRight x (HeapPP _ h1) (HeapPP _ h2) = + (h1 `merge` insert x h2) =~ insert x (h1 `merge` h2) + +-- heap observing operations + +prop_Size_Empty = + size empty == 0 + +prop_Size_Insert x (HeapPP _ (h :: Heap OrdA)) = + size (insert x h) == 1 + size h + +prop_ToList_Empty = + toList empty == ([] :: [OrdA]) + +prop_ToList_Insert x (HeapPP _ (h :: Heap OrdA)) = + sort (toList (insert x h)) == sort (x : toList h) + +prop_ToSortedList (HeapPP _ (h :: Heap OrdA)) = + toSortedList h == sort (toList h) + +-------------------------------------------------------------------------- +-- main + +return [] +main = $(quickCheckAll) + +-------------------------------------------------------------------------- +-- the end. + + + diff --git a/examples/Lambda.hs b/examples/Lambda.hs new file mode 100644 index 0000000..42aac86 --- /dev/null +++ b/examples/Lambda.hs @@ -0,0 +1,363 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} +module Main where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck + +import Control.Monad + ( liftM + , liftM2 + ) + +import Data.Char + ( toUpper + ) + +import Data.Set (Set) +import qualified Data.Set as Set + +-------------------------------------------------------------------------- +-- types for lambda expressions + +-- variables + +newtype Var = MkVar String + deriving ( Eq, Ord ) + +instance Show Var where + show (MkVar s) = s + +varList :: [Var] +varList = [ MkVar s + | let vs = [ c:v | v <- "" : vs, c <- ['a'..'z'] ] + , s <- vs + ] + +instance Arbitrary Var where + arbitrary = growingElements [ MkVar [c] | c <- ['a'..'z'] ] + +-- constants + +newtype Con = MkCon String + deriving ( Eq, Ord ) + +instance Show Con where + show (MkCon s) = s + +instance Arbitrary Con where + arbitrary = growingElements [ MkCon [c] | c <- ['A'..'Z'] ] + +-- expressions + +data Exp + = Lam Var Exp + | App Exp Exp + | Var Var + | Con Con + deriving ( Eq, Ord ) + +instance Show Exp where + showsPrec n (Lam x t) = showParen (n>0) (showString "\\" . shows x . showString "." . shows t) + showsPrec n (App s t) = showParen (n>1) (showsPrec 1 s . showString " " . showsPrec 2 t) + showsPrec _ (Var x) = shows x + showsPrec _ (Con c) = shows c + +instance Arbitrary Exp where + arbitrary = sized arbExp + where + arbExp n = + frequency $ + [ (2, liftM Var arbitrary) + , (1, liftM Con arbitrary) + ] ++ + concat + [ [ (5, liftM2 Lam arbitrary arbExp1) + , (5, liftM2 App arbExp2 arbExp2) + ] + | n > 0 + ] + where + arbExp1 = arbExp (n-1) + arbExp2 = arbExp (n `div` 2) + + shrink (Lam x a) = [ a ] + ++ [ Lam x a' | a' <- shrink a ] + shrink (App a b) = [ a, b ] + ++ [ ab + | Lam x a' <- [a] + , let ab = subst x b a' + , length (show ab) < length (show (App a b)) + ] + ++ [ App a' b | a' <- shrink a ] + ++ [ App a b' | b' <- shrink b ] + shrink (Var x) = [Con (MkCon (map toUpper (show x)))] + shrink _ = [] + +-------------------------------------------------------------------------- +-- functions for lambda expressions + +free :: Exp -> Set Var +free (Lam x a) = Set.delete x (free a) +free (App a b) = free a `Set.union` free b +free (Var x) = Set.singleton x +free (Con _) = Set.empty + +subst :: Var -> Exp -> Exp -> Exp +subst x c (Var y) | x == y = c +subst x b (Lam y a) | x /= y = Lam y (subst x b a) +subst x c (App a b) = App (subst x c a) (subst x c b) +subst x c a = a + +fresh :: Var -> Set Var -> Var +fresh x ys = head (filter (`Set.notMember` ys) (x:varList)) + +rename :: Var -> Var -> Exp -> Exp +rename x y a | x == y = a + | otherwise = subst x (Var y) a + +-- different bugs: +--subst x b (Lam y a) | x /= y = Lam y (subst x b a) -- bug 1 +--subst x b (Lam y a) | x /= y = Lam y' (subst x b (rename y y' a)) where y':_ = (y:varList) \\ free b -- bug 2 +--subst x b (Lam y a) | x /= y = Lam y' (subst x b (rename y y' a)) where y' = (y:varList) \\ (x:free b) -- bug 3 +--subst x b (Lam y a) | x /= y = Lam y' (subst x b (rename y y' a)) where y' = fresh y (x:free b) -- bug 4 +--subst x c (Lam y a) | x /= y = Lam y' (subst x c (rename y y' a)) where y' = fresh y (x `insert` delete y (free a) `union` free c) + +-------------------------------------------------------------------------- +-- properties for substitutions + +showResult :: (Show a, Testable prop) => a -> (a -> prop) -> Property +showResult x f = + whenFail (putStrLn ("Result: " ++ show x)) $ + f x + +prop_SubstFreeNoVarCapture a x b = + showResult (subst x b a) $ \subst_x_b_a -> + x `Set.member` free_a ==> + free subst_x_b_a == (Set.delete x free_a `Set.union` free b) + where + free_a = free a + +prop_SubstNotFreeSame a x b = + showResult (subst x b a) $ \subst_x_b_a -> + x `Set.notMember` free a ==> + subst_x_b_a == a + +prop_SubstNotFreeSameVars a x b = + showResult (subst x b a) $ \subst_x_b_a -> + x `Set.notMember` free a ==> + free subst_x_b_a == free a + +main1 = + do quickCheck prop_SubstFreeNoVarCapture + quickCheck prop_SubstNotFreeSame + quickCheck prop_SubstNotFreeSameVars + +--expectFailure $ + + + + + + + + +-------------------------------------------------------------------------- +-- eval + +eval :: Exp -> Exp +eval (Var x) = error "eval: free variable" +eval (App a b) = + case eval a of + Lam x a' -> eval (subst x b a') + a' -> App a' (eval b) +eval a = a + +-------------------------------------------------------------------------- +-- closed lambda expressions + +newtype ClosedExp = Closed Exp deriving ( Show ) + +instance Arbitrary ClosedExp where + arbitrary = Closed `fmap` sized (arbExp []) + where + arbExp xs n = + frequency $ + [ (8, liftM Var (elements xs)) + | not (null xs) + ] ++ + [ (2, liftM Con arbitrary) + ] ++ + [ (20, do x <- arbitrary + t <- arbExp (x:xs) n' + return (Lam x t)) + | n > 0 || null xs + ] ++ + [ (20, liftM2 App (arbExp xs n2) (arbExp xs n2)) + | n > 0 + ] + where + n' = n-1 + n2 = n `div` 2 + + shrink (Closed a) = + [ Closed a' | a' <- shrink a, Set.null (free a') ] + +-------------------------------------------------------------------------- +-- properties for closed lambda expressions + +isValue :: Exp -> Bool +isValue (Var _) = False +isValue (App (Lam _ _) _) = False +isValue (App a b) = isValue a && isValue b +isValue _ = True + +prop_ClosedExpIsClosed (Closed a) = + Set.null (free a) + +prop_EvalProducesValue (Closed a) = + within 1000 $ + isValue (eval a) + +main2 = + do quickCheck prop_ClosedExpIsClosed + quickCheck prop_EvalProducesValue + +-- expectFailure $ + +-------------------------------------------------------------------------- +-- main + +main = + do main1 + main2 + +-------------------------------------------------------------------------- +-- the end. + +{- +instance Arbitrary Exp where + arbitrary = sized (arbExp []) + where + + arbitrary = repair [] `fmap` sized arbExp + where + arbExp n = + frequency $ + [ (1, liftM Var arbitrary) + ] ++ concat + [ [ (3, liftM2 Lam arbitrary (arbExp n')) + , (4, liftM2 App (arbExp n2) (arbExp n2)) + ] + | n > 0 + ] + where + n' = n-1 + n2 = n `div` 2 + + repair xs (Var x) + | x `elem` xs = Var x + | null xs = Lam x (Var x) + | otherwise = Var (xs !! (ord (last (show x)) `mod` length xs)) + repair xs (App a b) = App (repair xs a) (repair xs b) + repair xs (Lam x a) = Lam x (repair (x:xs) a) + + -- lots of clever shrinking added + shrinkRec (Lam x a) = [ a | x `notElem` free a ] + shrinkRec (App a b) = [ a, b ] + ++ [ red + | Lam x a' <- [a] + , let red = subst x b a' + , length (show red) < length (show (App a b)) + ] + shrinkRec (Var x) = [Con (MkCon (map toUpper (show x)))] + shrinkRec _ = [] + +-- types + +data Type + = Base Con + | Type :-> Type + deriving ( Eq, Show ) + +instance Arbitrary Type where + arbitrary = sized arbType + where + arbType n = + frequency $ + [ (1, liftM Base arbitrary) + ] ++ + [ (4, liftM2 (:->) arbType2 arbType2) + | n > 0 + ] + where + arbType2 = arbType (n `div` 2) + +newtype WellTypedExp = WellTyped Exp + deriving ( Eq, Show ) + +arbExpWithType n env t = + frequency $ + [ (2, liftM Var (elements xs)) + | let xs = [ x | (x,t') <- env, t == t' ] + , not (null xs) + ] ++ + [ (1, return (Con b)) + | Base b <- [t] + ] ++ + [ (if n > 0 then 5 else 1 + , do x <- arbitrary + b <- arbExpWithType n1 ((x,ta):[ xt | xt <- env, fst xt /= x ]) tb + return (Lam x b)) + | ta :-> tb <- [t] + ] ++ + [ (5, do tb <- arbitrary + a <- arbExpWithType n2 env (tb :-> t) + b <- arbExpWithType n2 env tb + return (App a b)) + | n > 0 + ] + where + n1 = n-1 + n2 = n `div` 2 + +instance Arbitrary WellTypedExp where + arbitrary = + do t <- arbitrary + e <- sized (\n -> arbExpWithType n [] t) + return (WellTyped e) + + shrink _ = [] + +newtype OpenExp = Open Exp + deriving ( Eq, Show ) + +instance Arbitrary OpenExp where + arbitrary = Open `fmap` sized arbExp + where + arbExp n = + frequency $ + [ (2, liftM Var arbitrary) + , (1, liftM Con arbitrary) + ] ++ + concat + [ [ (5, liftM2 Lam arbitrary arbExp1) + , (5, liftM2 App arbExp2 arbExp2) + ] + | n > 0 + ] + where + arbExp1 = arbExp (n-1) + arbExp2 = arbExp (n `div` 2) + + shrink (Open a) = map Open (shrink a) + +prop_EvalProducesValueWT (WellTyped a) = + isValue (eval a) + +-} + +x = MkVar "x" +y = MkVar "y" + diff --git a/examples/Merge.hs b/examples/Merge.hs new file mode 100644 index 0000000..8b1d2dd --- /dev/null +++ b/examples/Merge.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} +module Main where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck + +import Data.List + ( sort + ) + +-------------------------------------------------------------------------- +-- merge sort + +msort :: Ord a => [a] -> [a] +msort xs = merging [ [x] | x <- xs ] + +merging :: Ord a => [[a]] -> [a] +merging [] = [] +merging [xs] = xs +merging xss = merging (sweep xss) + +sweep :: Ord a => [[a]] -> [[a]] +sweep [] = [] +sweep [xs] = [xs] +sweep (xs:ys:xss) = merge xs ys : sweep xss + +merge :: Ord a => [a] -> [a] -> [a] +merge xs [] = xs +merge [] ys = ys +merge (x:xs) (y:ys) + | x <= y = x : merge xs (y:ys) + | otherwise = y : merge (x:xs) ys + +-------------------------------------------------------------------------- +-- example properties + +ordered :: Ord a => [a] -> Bool +ordered [] = True +ordered [x] = True +ordered (x:y:xs) = x <= y && ordered (y:xs) + +prop_Merge xs (ys :: [Int]) = + ordered xs && ordered ys ==> + collect (length xs + length ys) $ + ordered (xs `merge` ys) + +-- collect (sort [length xs, length ys]) $ + + + + + + + + + + + + + + + + + + + +-------------------------------------------------------------------------- +-- quantificiation + +--prop_Merge (Ordered xs) (Ordered (ys :: [Int])) = +-- ordered (xs `merge` ys) + + + + + + + + + + + + + +-- classify (length xs `min` length ys >= 5) "not trivial" $ +-- cover (length xs `min` length ys >= 5) 70 "not trivial" $ + +{- + shrink (Ordered xs) = + [ Ordered xs' + | xs' <- shrink xs + , ordered xs' + ] +-} + +-------------------------------------------------------------------------- +-- merging + +prop_Merging (xss :: [OrderedList Int]) = + ordered (merging [ xs | Ordered xs <- xss ]) + + + + + + + +-- mapSize (`div` 2) $ \(xss :: [OrderedList Int]) -> + +return [] +main = $quickCheckAll + +-------------------------------------------------------------------------- +-- the end. diff --git a/examples/Set.hs b/examples/Set.hs new file mode 100644 index 0000000..b380e28 --- /dev/null +++ b/examples/Set.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} +module Main where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck + +import Text.Show.Functions +import Data.List + ( sort + , group + , nub + , (\\) + ) + +import Control.Monad + ( liftM + , liftM2 + ) + +import Data.Maybe + +--import Text.Show.Functions + +-------------------------------------------------------------------------- +-- binary search trees + +data Set a + = Node a (Set a) (Set a) + | Empty + deriving ( Eq, Ord, Show ) + +empty :: Set a +empty = Empty + +isEmpty :: Set a -> Bool +isEmpty Empty = True +isEmpty _ = False + +unit :: a -> Set a +unit x = Node x empty empty + +size :: Set a -> Int +size Empty = 0 +size (Node _ s1 s2) = 1 + size s1 + size s2 + +insert :: Ord a => a -> Set a -> Set a +insert x s = s `union` unit x + +merge :: Set a -> Set a -> Set a +s `merge` Empty = s +s `merge` Node x Empty s2 = Node x s s2 +s `merge` Node x (Node y s11 s12) s2 = Node y s (Node x (s11 `merge` s12) s2) + +delete :: Ord a => a -> Set a -> Set a +delete x Empty = Empty +delete x (Node x' s1 s2) = + case x `compare` x' of + LT -> Node x' (delete x s1) s2 + EQ -> s1 `merge` s2 + GT -> Node x' s1 (delete x s2) + +union :: Ord a => Set a -> Set a -> Set a +{- +s1 `union` Empty = s1 +Empty `union` s2 = s2 +s1@(Node x s11 s12) `union` s2@(Node y s21 s22) = + case x `compare` y of + LT -> Node x s11 (s12 `union` Node y Empty s22) `union` s21 + EQ -> Node x (s11 `union` s21) (s12 `union` s22) + --GT -> s11 `union` Node y s21 (Node x Empty s12 `union` s22) + GT -> Node x (s11 `union` Node y s21 Empty) s12 `union` s22 +-} +s1 `union` Empty = s1 +Empty `union` s2 = s2 +Node x s11 s12 `union` s2 = Node x (s11 `union` s21) (s12 `union` s22) + where + (s21,s22) = split x s2 + +split :: Ord a => a -> Set a -> (Set a, Set a) +split x Empty = (Empty, Empty) +split x (Node y s1 s2) = + case x `compare` y of + LT -> (s11, Node y s12 s2) + EQ -> (s1, s2) + GT -> (Node y s1 s21, s22) + where + (s11,s12) = split x s1 + (s21,s22) = split x s2 + +mapp :: (a -> b) -> Set a -> Set b +mapp f Empty = Empty +mapp f (Node x s1 s2) = Node (f x) (mapp f s1) (mapp f s2) + +fromList :: Ord a => [a] -> Set a +--fromList xs = build [ (empty,x) | x <- sort xs ] +fromList xs = build [ (empty,head x) | x <- group (sort xs) ] + where + build [] = empty + build [(s,x)] = attach x s + build sxs = build (sweep sxs) + + sweep [] = [] + sweep [sx] = [sx] + sweep ((s1,x1):(s2,x2):sxs) = (Node x1 s1 s2,x2) : sweep sxs + + attach x Empty = unit x + attach x (Node y s1 s2) = Node y s1 (attach x s2) + +toList :: Set a -> [a] +toList s = toSortedList s + +toSortedList :: Set a -> [a] +toSortedList s = toList' s [] + where + toList' Empty xs = xs + toList' (Node x s1 s2) xs = toList' s1 (x : toList' s2 xs) + +-------------------------------------------------------------------------- +-- generators + +instance (Ord a, Arbitrary a) => Arbitrary (Set a) where + arbitrary = sized (arbSet Nothing Nothing) + where + arbSet mx my n = + frequency $ + [ (1, return Empty) ] ++ + [ (7, do mz <- arbitrary `suchThatMaybe` (isOK mx my) + case mz of + Nothing -> return Empty + Just z -> liftM2 (Node z) (arbSet mx mz n2) + (arbSet mz my n2) + where n2 = n `div` 2) + | n > 0 + ] + + isOK mx my z = + maybe True ( ShrinkSub (Set a) + +-------------------------------------------------------------------------- +-- properties + +(.<) :: Ord a => Set a -> a -> Bool +Empty .< x = True +Node y _ s .< x = y < x && s .< x + +(<.) :: Ord a => a -> Set a -> Bool +x <. Empty = True +x <. Node y _ s = x < y && x <. s + +(==?) :: Ord a => Set a -> [a] -> Bool +s ==? xs = invariant s && sort (toList s) == nub (sort xs) + +invariant :: Ord a => Set a -> Bool +invariant Empty = True +invariant (Node x s1 s2) = s1 .< x && x <. s2 && invariant s1 && invariant s2 + +prop_Invariant (s :: Set Int) = + invariant s + +prop_Empty = + empty ==? ([] :: [Int]) + +prop_Unit (x :: Int) = + unit x ==? [x] + +prop_Size (s :: Set Int) = + cover (size s >= 15) 60 "large" $ + size s == length (toList s) + +prop_Insert x (s :: Set Int) = + insert x s ==? (x : toList s) + +prop_Delete x (s :: Set Int) = + delete x s ==? (toList s \\ [x]) + +prop_Union s1 (s2 :: Set Int) = + (s1 `union` s2) ==? (toList s1 ++ toList s2) + +prop_Mapp (f :: Int -> Int) (s :: Set Int) = + expectFailure $ + whenFail (putStrLn ("Fun: " ++ show [ (x,f x) | x <- toList s])) $ + mapp f s ==? map f (toList s) + +prop_FromList (xs :: [Int]) = + fromList xs ==? xs + +prop_ToSortedList (s :: Set Int) = + s ==? xs && xs == sort xs + where + xs = toSortedList s + +-- whenFail (putStrLn ("Result: " ++ show (fromList xs))) $ + +prop_FromList' (xs :: [Int]) = + shrinking shrink xs $ \xs' -> + fromList xs ==? xs + +-------------------------------------------------------------------------- +-- main + +return [] +main = $quickCheckAll + +-------------------------------------------------------------------------- +-- the end. diff --git a/examples/Simple.hs b/examples/Simple.hs new file mode 100644 index 0000000..b173df6 --- /dev/null +++ b/examples/Simple.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} +module Main where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck + +-------------------------------------------------------------------------- +-- example 1 + +allEqual x y z = x == y && y == z +allEqual' x y z = 2*x == y + z + +prop_SimonThompson x y (z :: Int) = + allEqual x y z == allEqual' x y z + +-------------------------------------------------------------------------- +-- example 2 + +prop_ReverseReverse :: Eq a => [a] -> Bool +prop_ReverseReverse xs = + reverse (reverse xs) == xs + +prop_Reverse xs = + reverse xs == xs + +-------------------------------------------------------------------------- +-- example 3 + +prop_Error (x,y) = + 2*x <= 5*y + +-------------------------------------------------------------------------- +-- main + +return [] +prop_conj = counterexample "Simon Thompson" $(monomorphic 'prop_SimonThompson) .&&. + counterexample "reverse" $(monomorphic 'prop_Reverse) +prop_disj = counterexample "reverse" $(monomorphic 'prop_Reverse) .||. + counterexample "Simon Thompson" $(monomorphic 'prop_SimonThompson) +return [] +main = $quickCheckAll + +-------------------------------------------------------------------------- +-- the end. diff --git a/tests/GCoArbitraryExample.hs b/tests/GCoArbitraryExample.hs new file mode 100644 index 0000000..34ac551 --- /dev/null +++ b/tests/GCoArbitraryExample.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveGeneric, ScopedTypeVariables #-} + +module Main where + +import GHC.Generics (Generic) +import Test.QuickCheck +import Test.QuickCheck.Function + +data D a = C1 a | C2 deriving (Eq, Show, Read, Generic) + + +instance Arbitrary a => Arbitrary (D a) +instance CoArbitrary a => CoArbitrary (D a) + +instance (Show a, Read a) => Function (D a) where + function = functionShow + +main :: IO () +main = quickCheck $ \(Fun _ f) -> + f (C1 (2::Int)) `elem` [0, 1 :: Int] diff --git a/tests/GShrinkExample.hs b/tests/GShrinkExample.hs new file mode 100644 index 0000000..c88e559 --- /dev/null +++ b/tests/GShrinkExample.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric, ScopedTypeVariables #-} + +module Main where + +import GHC.Generics (Generic) +import Test.QuickCheck + +data Nat = Z | S Nat deriving (Eq, Show, Generic) + + +instance Arbitrary Nat + + +main :: IO () +main = do + print $ genericShrink (S (S Z)) == [S Z] + print $ genericShrink [0::Int] == [[]] diff --git a/tests/Generators.hs b/tests/Generators.hs new file mode 100644 index 0000000..29469d4 --- /dev/null +++ b/tests/Generators.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, Rank2Types, NoMonomorphismRestriction #-} +import Test.QuickCheck +import Test.QuickCheck.Gen.Unsafe +import Data.List +import Data.Int +import Data.Word +import Data.Version (showVersion, parseVersion) +import Text.ParserCombinators.ReadP (readP_to_S) + +newtype Path a = Path [a] deriving (Show, Functor) + +instance Arbitrary a => Arbitrary (Path a) where + arbitrary = do + x <- arbitrary + fmap Path (pathFrom x) + where + pathFrom x = sized $ \n -> + fmap (x:) $ + oneof $ + [return []] ++ + [resize (n-1) (pathFrom y) | n > 0, y <- shrink x] + + shrink (Path xs) = map Path [ ys | ys <- inits xs, length ys > 0 && length ys < length xs ] + +path :: (a -> Bool) -> Path a -> Bool +path p (Path xs) = all p xs + +somePath :: (a -> Bool) -> Path a -> Property +somePath p = expectFailure . path (not . p) + +newtype Extremal a = Extremal { getExtremal :: a } deriving (Show, Eq, Ord, Num, Enum, Real, Integral) + +instance (Arbitrary a, Bounded a) => Arbitrary (Extremal a) where + arbitrary = + fmap Extremal $ + frequency + [(1, return minBound), + (1, return maxBound), + (8, arbitrary)] + shrink (Extremal x) = map Extremal (shrink x) + +smallProp :: Integral a => Path a -> Bool +smallProp = path (\x -> (x >= -100 || -100 `asTypeOf` x >= 0) && x <= 100) + +largeProp :: Integral a => Path a -> Property +largeProp = somePath (\x -> x < -1000000 || x > 1000000) + +prop_int :: Path Int -> Bool +prop_int = smallProp + +prop_int32 :: Path Int32 -> Property +prop_int32 = largeProp + +prop_word :: Path Word -> Property +prop_word = largeProp + +prop_word32 :: Path Word32 -> Property +prop_word32 = largeProp + +prop_integer :: Path Integer -> Bool +prop_integer = smallProp + +prop_small :: Path (Small Int) -> Bool +prop_small = smallProp + +prop_large :: Path (Large Int) -> Property +prop_large = largeProp + +prop_smallWord :: Path (Small Word) -> Bool +prop_smallWord = smallProp + +prop_largeWord :: Path (Large Word) -> Property +prop_largeWord = largeProp + +data Choice a b = Choice a b deriving Show +instance (Arbitrary a, Arbitrary b) => Arbitrary (Choice a b) where + arbitrary = do + Capture eval <- capture + return (Choice (eval arbitrary) (eval arbitrary)) + +idemProp :: (Eq a, Arbitrary a, Arbitrary b) => (b -> a) -> Choice a b -> Bool +idemProp f (Choice x y) = x == f y + +prop_fixed_length :: Arbitrary a => Path (Fixed a) -> Bool +prop_fixed_length (Path xs) = length xs == 1 + +prop_fixed_idem = idemProp getFixed +prop_blind_idem = idemProp getBlind + +prop_ordered_list = path (\(Ordered xs) -> sort xs == xs) +prop_nonempty_list = path (\(NonEmpty xs) -> not (null xs)) + +pathInt, somePathInt :: + (Arbitrary (f (Extremal Int)), Show (f (Extremal Int)), + Arbitrary (f Integer), Show (f Integer), + Arbitrary (f (Extremal Int8)), Show (f (Extremal Int8)), + Arbitrary (f (Extremal Int16)), Show (f (Extremal Int16)), + Arbitrary (f (Extremal Int32)), Show (f (Extremal Int32)), + Arbitrary (f (Extremal Int64)), Show (f (Extremal Int64)), + Arbitrary (f (Extremal Word)), Show (f (Extremal Word)), + Arbitrary (f (Extremal Word8)), Show (f (Extremal Word8)), + Arbitrary (f (Extremal Word16)), Show (f (Extremal Word16)), + Arbitrary (f (Extremal Word32)), Show (f (Extremal Word32)), + Arbitrary (f (Extremal Word64)), Show (f (Extremal Word64))) => + (forall a. f a -> a) -> (forall a. Integral a => a -> Bool) -> Property +pathInt f p = + conjoin + [counterexample "Int" (path ((p :: Int -> Bool) . getExtremal . f)), + counterexample "Integer" (path ((p :: Integer -> Bool) . f)), + counterexample "Int8" (path ((p :: Int8 -> Bool) . getExtremal . f)), + counterexample "Int16" (path ((p :: Int16 -> Bool) . getExtremal . f)), + counterexample "Int32" (path ((p :: Int32 -> Bool) . getExtremal . f)), + counterexample "Int64" (path ((p :: Int64 -> Bool) . getExtremal . f)), + counterexample "Word" (path ((p :: Word -> Bool) . getExtremal . f)), + counterexample "Word8" (path ((p :: Word8 -> Bool) . getExtremal . f)), + counterexample "Word16" (path ((p :: Word16 -> Bool) . getExtremal . f)), + counterexample "Word32" (path ((p :: Word32 -> Bool) . getExtremal . f)), + counterexample "Word64" (path ((p :: Word64 -> Bool) . getExtremal . f))] +somePathInt f p = expectFailure (pathInt f (not . p)) + +prop_positive = pathInt getPositive (> 0) +prop_positive_bound = somePathInt getPositive (== 1) + +prop_nonzero = pathInt getNonZero (/= 0) +prop_nonzero_bound_1 = somePathInt getNonZero (== 1) +prop_nonzero_bound_2 = somePathInt getNonZero (== -1) + +prop_nonnegative = pathInt getNonNegative (>= 0) +prop_nonnegative_bound = somePathInt getNonNegative (== 0) + +reachesBound :: (Bounded a, Integral a, Arbitrary a) => + a -> Property +reachesBound x = expectFailure (x < 3 * (maxBound `div` 4)) + +prop_reachesBound_Int8 = reachesBound :: Int8 -> Property +prop_reachesBound_Int16 = reachesBound :: Int16 -> Property +prop_reachesBound_Int32 = reachesBound :: Int32 -> Property +prop_reachesBound_Int64 = reachesBound :: Int64 -> Property +prop_reachesBound_Word = reachesBound :: Word -> Property +prop_reachesBound_Word8 = reachesBound :: Word8 -> Property +prop_reachesBound_Word16 = reachesBound :: Word16 -> Property +prop_reachesBound_Word32 = reachesBound :: Word32 -> Property +prop_reachesBound_Word64 = reachesBound :: Word64 -> Property + +-- Bad shrink: infinite list +-- +-- remove unexpectedFailure in prop_B1, shrinking should not loop forever. +data B1 = B1 Int deriving (Eq, Show) + +instance Arbitrary B1 where + arbitrary = fmap B1 arbitrary + shrink x = x : shrink x + +prop_B1 :: B1 -> Property +prop_B1 (B1 n) = expectFailure $ n === n + 1 + +return [] +main = $forAllProperties (quickCheckWithResult stdArgs { maxShrinks = 10000 }) >>= print