packages feed

QuickCheck 2.8.1 → 2.18.0.0

raw patch · 61 files changed

Files

LICENSE view
@@ -1,7 +1,8 @@-Copyright (c) 2000-2015, Koen Claessen+(The following is the 3-clause BSD license.)++Copyright (c) 2000-2019, Koen Claessen Copyright (c) 2006-2008, Björn Bringert-Copyright (c) 2009-2015, Nick Smallbone-All rights reserved.+Copyright (c) 2009-2019, Nick Smallbone  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
QuickCheck.cabal view
@@ -1,35 +1,56 @@ Name: QuickCheck-Version: 2.8.1-Cabal-Version: >= 1.8+Version: 2.18.0.0+Cabal-Version: >= 1.10 Build-type: Simple License: BSD3 License-file: LICENSE-Extra-source-files: README changelog-Copyright: 2000-2015 Koen Claessen, 2006-2008 Björn Bringert, 2009-2015 Nick Smallbone+Copyright: 2000-2019 Koen Claessen, 2006-2008 Björn Bringert, 2009-2019 Nick Smallbone Author: Koen Claessen <koen@chalmers.se>-Maintainer: QuickCheck developers <quickcheck@projects.haskell.org>-Bug-reports: mailto:quickcheck@projects.haskell.org-Tested-with: GHC >=6.10, Hugs, UHC+Maintainer: Nick Smallbone <nick@smallbone.se>+Bug-reports: https://github.com/nick8325/quickcheck/issues+Tested-with: GHC >= 8.10 && < 9.15, hugs 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 provided by+  QuickCheck. QuickCheck provides combinators to define properties, observe the+  distribution of test data, and define test data generators.   .-  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.+  Most of QuickCheck's functionality is exported by the main "Test.QuickCheck"+  module. The main exception is the monadic property testing library in+  "Test.QuickCheck.Monadic".   .-  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.+  If you are new to QuickCheck, you can try looking at the following resources:   .-  You can find a (slightly out-of-date but useful) manual at-  <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html>.+  * The <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html official QuickCheck manual>.+    It's a bit out-of-date in some details and doesn't cover newer QuickCheck features,+    but is still full of good advice.+  * <https://begriffs.com/posts/2017-01-14-design-use-quickcheck.html>,+    a detailed tutorial written by a user of QuickCheck.+  .+  The <https://hackage.haskell.org/package/quickcheck-instances quickcheck-instances>+  companion package provides instances for types in Haskell Platform packages+  at the cost of additional dependencies. +extra-source-files:+  README+  changelog.md+  examples/Heap.hs+  examples/Heap_Program.hs+  examples/Heap_ProgramAlgebraic.hs+  examples/Lambda.hs+  examples/Merge.hs+  examples/Set.hs+  examples/Simple.hs+  make-hugs+  test-hugs+  test-mhs+ source-repository head   type:     git   location: https://github.com/nick8325/quickcheck@@ -37,43 +58,51 @@ source-repository this   type:     git   location: https://github.com/nick8325/quickcheck-  tag:      2.8.1--flag base3-  Description: Choose the new smaller, split-up base package.--flag base4-  Description: Choose the even newer base package with extensible exceptions.--flag base4point8-  Description: Choose the even more newer base package with natural numbers.+  tag:      2.18  flag templateHaskell   Description: Build Test.QuickCheck.All, which uses Template Haskell.+  Default: True+  Manual: True +flag old-random+  Description: Build against a pre-1.2.0 version of the random package.+  Default: False+  Manual: False+ library-  -- Choose which library versions to use.-  if flag(base4point8)-    Build-depends: base >= 4.8 && < 5+  Hs-source-dirs: src+  Build-depends: base >=4.14 && <5, containers+  Default-language: Haskell2010++  -- New vs old random.+  if flag(old-random)+    Build-depends: random >= 1.0.0.3 && < 1.2.0+    cpp-options: -DOLD_RANDOM   else-    if flag(base4)-      Build-depends: base >= 4 && < 4.8-    else-      if flag(base3)-        Build-depends: base >= 3 && < 4-      else-        Build-depends: base < 3-  if flag(base4point8) || flag(base4) || flag(base3)-    Build-depends: random-  Build-depends: containers+    Build-depends: random >= 1.2.0 && < 1.4 +  -- We always use splitmix directly rather than going through StdGen+  -- (it's somewhat more efficient).+  -- However, Hugs traps overflow on Word64, so we have to stick+  -- with StdGen there.+  if impl(hugs)+    cpp-options: -DNO_SPLITMIX+  else+    Build-depends: splitmix >= 0.1.0.2 && <0.2++  if impl(hugs)+    cpp-options: -DNO_SEMIGROUP -DNO_EXISTENTIAL_FIELD_SELECTORS+   -- Modules that are always built.   Exposed-Modules:     Test.QuickCheck,+    Test.QuickCheck.Compat,     Test.QuickCheck.Arbitrary,     Test.QuickCheck.Gen,     Test.QuickCheck.Gen.Unsafe,     Test.QuickCheck.Monadic,+    Test.QuickCheck.Monoids,     Test.QuickCheck.Modifiers,     Test.QuickCheck.Property,     Test.QuickCheck.Test,@@ -81,88 +110,177 @@     Test.QuickCheck.Poly,     Test.QuickCheck.State,     Test.QuickCheck.Random,-    Test.QuickCheck.Exception+    Test.QuickCheck.Exception,+    Test.QuickCheck.Features    -- GHC-specific modules.-  if impl(ghc)+  if impl(ghc) || impl(mhs)     Exposed-Modules: Test.QuickCheck.Function-  if impl(ghc >= 7)-    Build-depends: transformers >= 0.2-  else-    cpp-options: -DNO_TRANSFORMERS-  if impl(ghc >= 6.12) && flag(templateHaskell)+    Build-depends: transformers >= 0.3, deepseq >= 1.1.0.0++  if impl(ghc) && flag(templateHaskell)     Build-depends: template-haskell >= 2.4+    Other-Extensions: TemplateHaskellQuotes     Exposed-Modules: Test.QuickCheck.All   else     cpp-options: -DNO_TEMPLATE_HASKELL -  -- Compiler-specific tweaks, lots of 'em!--  -- On old versions of GHC use the ghc package to catch ctrl-C.-  if impl(ghc >= 6.7) && impl(ghc < 6.13)-      Build-depends: ghc--  -- We want to use extensible-exceptions even if linking against base-3.-  if impl(ghc >= 6.9) && impl (ghc < 7.0)-    Build-depends: extensible-exceptions--  -- GHC < 7.0 can't cope with multiple LANGUAGE pragmas in the same file.-  if impl(ghc < 7)-    Extensions: GeneralizedNewtypeDeriving, MultiParamTypeClasses, Rank2Types, TypeOperators--  -- 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+  if !impl(ghc) && !impl(mhs)+    cpp-options: -DNO_CALLSTACK+                 -DNO_SEMIGROUP+                 -DNO_CTYPES_CONSTRUCTORS+                 -DNO_FOREIGN_C_USECONDS+                 -DNO_POLYKINDS+                 -DNO_MONADFAIL+                 -DNO_TRANSFORMERS+                 -DNO_DEEPSEQ -  -- 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+  -- random is explicitly Trustworthy since 1.0.1.0+  -- similar constraint for containers+  if impl(ghc)+    Build-depends: random >=1.0.1.0+                 , containers >=0.4.2.1 -  -- Use tf-random on newer GHCs.-  if impl(ghc >= 7) && (flag(base4point8) || flag(base4))-    Build-depends: tf-random >= 0.4-  else-    cpp-options: -DNO_TF_RANDOM+  if impl(ghc >= 9.8)+    ghc-options: -Wno-x-partial -  -- Natural numbers.-  if !flag(base4point8)-    cpp-options: -DNO_NATURALS+  if impl(ghc < 9.4)+    Build-depends: data-array-byte    -- Switch off most optional features on non-GHC systems.-  if !impl(ghc)+  if !impl(ghc) && !impl(mhs)     -- 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+    cpp-options: -DNO_TIMEOUT -DNO_NEWTYPE_DERIVING -DNO_GENERICS+      -DNO_TEMPLATE_HASKELL -DNO_SAFE_HASKELL -DNO_TYPEABLE -DNO_GADTS+      -DNO_EXTRA_METHODS_IN_APPLICATIVE -DOLD_RANDOM -DNO_CALLSTACK     if !impl(hugs) && !impl(uhc)       cpp-options: -DNO_ST_MONAD -DNO_MULTI_PARAM_TYPE_CLASSES +  if impl(mhs)+    cpp-options: -DNO_GENERICS -DNO_TEMPLATE_HASKELL -DNO_CTYPES_CONSTRUCTORS+                 -DNO_EXISTENTIAL_FIELD_SELECTORS+   -- 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+    Default-Extensions: CPP  Test-Suite test-quickcheck     type: exitcode-stdio-1.0+    Default-language: Haskell2010     hs-source-dirs:         examples     main-is: Heap.hs-    build-depends:-      base,-      containers,-      QuickCheck == 2.8.1,-      template-haskell >= 2.4,-      test-framework >= 0.4 && < 0.9-    if flag(templateHaskell)-        Buildable: True-    else+    build-depends: base, QuickCheck+    if !flag(templateHaskell)         Buildable: False +Test-Suite test-quickcheck-gcoarbitrary+    type: exitcode-stdio-1.0+    Default-language: Haskell2010+    hs-source-dirs: tests+    main-is: GCoArbitraryExample.hs+    build-depends: base, QuickCheck+    if !flag(templateHaskell)+        buildable: False++Test-Suite test-quickcheck-generators+    type: exitcode-stdio-1.0+    Default-language: Haskell2010+    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+    Default-language: Haskell2010+    hs-source-dirs: tests+    main-is: GShrinkExample.hs+    build-depends: base, QuickCheck+    if !flag(templateHaskell)+        buildable: False++Test-Suite test-quickcheck-terminal+    type: exitcode-stdio-1.0+    Default-language: Haskell2010+    hs-source-dirs: tests+    main-is: Terminal.hs+    build-depends: base, process, deepseq >= 1.1.0.0, QuickCheck+    if !flag(templateHaskell)+        buildable: False++Test-Suite test-quickcheck-monadfix+    type: exitcode-stdio-1.0+    Default-language: Haskell2010+    hs-source-dirs: tests+    main-is: MonadFix.hs+    build-depends: base, QuickCheck+    if !flag(templateHaskell)+        buildable: False++Test-Suite test-quickcheck-split+    type: exitcode-stdio-1.0+    Default-language: Haskell2010+    hs-source-dirs: tests+    main-is: Split.hs+    build-depends: base, QuickCheck+    if impl(ghc >= 9.8)+      ghc-options: -Wno-x-partial++Test-Suite test-quickcheck-strictness+    type: exitcode-stdio-1.0+    Default-language: Haskell2010+    hs-source-dirs: tests+    main-is: Strictness.hs+    build-depends: base, QuickCheck, containers+    if !flag(templateHaskell)+        buildable: False++Test-Suite test-quickcheck-misc+    type: exitcode-stdio-1.0+    Default-language: Haskell2010+    hs-source-dirs: tests+    main-is: Misc.hs+    build-depends: base, QuickCheck, containers+    if !flag(templateHaskell)+        buildable: False++Test-Suite test-quickcheck-discard+    type: exitcode-stdio-1.0+    Default-language: Haskell2010+    hs-source-dirs: tests+    main-is: DiscardRatio.hs+    build-depends: base, QuickCheck++Test-Suite test-quickcheck-monoids+    type: exitcode-stdio-1.0+    Default-language: Haskell2010+    hs-source-dirs: tests+    main-is: Monoids.hs+    build-depends: base, QuickCheck++Test-Suite test-quickcheck-withprogress+    type: exitcode-stdio-1.0+    Default-language: Haskell2010+    hs-source-dirs: tests+    main-is: WithProgress.hs+    build-depends: base, QuickCheck++Test-Suite test-quickcheck-instances+    type: exitcode-stdio-1.0+    Default-language: Haskell2010+    hs-source-dirs: tests+    other-modules: CollectDataTypes+    main-is: RunCollectDataTypes.hs+    build-depends:+      base,+      QuickCheck,+      transformers,+      split,+      process,+      template-haskell,+      hint+    if !flag(templateHaskell) || impl(ghc <= 8.10)+        buildable: False
README view
@@ -1,14 +1,11 @@ This is QuickCheck 2, a library for random testing of program properties. -Install it in the usual way:--$ cabal install--Please report bugs to the QuickCheck mailing list at-quickcheck@projects.haskell.org.+Add `QuickCheck` to your package dependencies to use it in tests or REPL. -If you get errors about Template Haskell, try+The quickcheck-instances [1] companion package provides instances for types in+Haskell Platform packages at the cost of additional dependencies. -$ cabal install -f-templateHaskell+The make-hugs script makes a Hugs-compatible version of QuickCheck.+It may also be useful for other non-GHC implementations. -but please report this as a bug.+[1]: http://hackage.haskell.org/package/quickcheck-instances
− Test/QuickCheck.hs 
@@ -1,228 +0,0 @@-{-| For further information see the <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual>.--To use QuickCheck to check a property, first define a function-expressing that property (functions expressing properties under test-tend to be prefixed with @prop_@). Testing that @n + m = m + n@ holds-for @Integer@s one might write:--@-import Test.QuickCheck--prop_commutativeAdd :: Integer -> Integer -> Bool-prop_commutativeAdd n m = n + m == m + n-@--and testing:-->>> quickcheck prop_commutativeAdd-+++ OK, passed 100 tests.--which tests @prop_commutativeAdd@ on 100 random @(Integer, Integer)@ pairs.--'verboseCheck' can be used to see the actual values generated:-->>> verboseCheck prop_commutativeAdd-Passed:-0-0-  …98 tests omitted…-Passed:--68-6-+++ OK, passed 100 tests.--and if more than 100 tests are needed the number of tests can be-increased by updating the 'stdArgs' record:-->>> quickCheckWith stdArgs { maxSuccess = 500 } prop_commutativeAdd-+++ OK, passed 500 tests.--To let QuickCheck generate values of your own data type an 'Arbitrary'-instance must be defined:--@-data Point = MkPoint Int Int deriving Eq--instance Arbitrary Point where-  arbitrary = do-    x <- 'arbitrary'-    y <- arbitrary-    return (MkPoint x y)--swapPoint :: Point -> Point-swapPoint (MkPoint x y) = MkPoint y x---- swapPoint . swapPoint = id-prop_swapInvolution point = swapPoint (swapPoint point) == point-@-->>> quickCheck prop_swapInvolution-+++ OK, passed 100 tests.--See "Test.QuickCheck.Function" for generating random shrinkable,-showable functions used for testing higher-order functions and-"Test.QuickCheck.Monadic" for testing impure or monadic code-(e.g. effectful code in 'IO').---}-{-# LANGUAGE CPP #-}-#ifndef NO_SAFE_HASKELL-{-# LANGUAGE Safe #-}-#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-  , resize-  , scale-  , suchThat-  , 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(..)--    -- ** Helper functions for implementing arbitrary-  , arbitrarySizedIntegral-  , arbitrarySizedNatural-  , arbitrarySizedFractional-  , arbitrarySizedBoundedIntegral-  , arbitraryBoundedIntegral-  , arbitraryBoundedRandom-  , arbitraryBoundedEnum-    -- ** Helper functions for implementing shrink-#ifndef NO_GENERICS-  , genericCoarbitrary-  , genericShrink-  , subterms-  , recursivelyShrink-#endif-  , shrinkNothing-  , shrinkList-  , shrinkIntegral-  , shrinkRealFrac-  , shrinkRealFracToInteger-    -- ** 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--    -- * Properties-  , Property, Testable(..)-    -- ** Property combinators-  , forAll-  , forAllShrink-  , shrinking-  , (==>)-  , (===)-  , ioProperty-    -- *** Controlling property execution-  , verbose-  , once-  , 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.Text-import Test.QuickCheck.Exception-#ifndef NO_TEMPLATE_HASKELL-import Test.QuickCheck.All-#endif------------------------------------------------------------------------------- the end.
− Test/QuickCheck/All.hs 
@@ -1,189 +0,0 @@-{-# 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 (VarE t)-    _ -> do-      integer <- [t| Integer |]-      ty' <- monomorphiseType err integer ty-      return (SigE (VarE t) ty')--infoType :: Info -> Type-infoType (ClassOpI _ ty _ _) = ty-infoType (DataConI _ ty _ _) = ty-infoType (VarI _ ty _ _) = ty--deconstructType :: Error -> Type -> Q ([Name], Cxt, Type)-deconstructType err ty0@(ForallT xs ctx ty) = do-  let plain (PlainTV  _)       = True-#ifndef MIN_VERSION_template_haskell-      plain (KindedTV _ StarT) = True-#else-#if MIN_VERSION_template_haskell(2,8,0)-      plain (KindedTV _ StarT) = True-#else-      plain (KindedTV _ StarK) = True-#endif-#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 == "<interactive>") $ 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 __GLASGOW_HASKELL__ > 705-      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
− Test/QuickCheck/Arbitrary.hs 
@@ -1,838 +0,0 @@--- | Type classes for random generation of values.-{-# LANGUAGE CPP #-}-#ifndef NO_GENERICS-{-# LANGUAGE DefaultSignatures, FlexibleContexts, TypeOperators #-}-{-# LANGUAGE FlexibleInstances, KindSignatures, ScopedTypeVariables #-}-{-# LANGUAGE MultiParamTypeClasses, OverlappingInstances #-}-#endif-#ifndef NO_SAFE_HASKELL-{-# LANGUAGE Safe #-}-#endif-module Test.QuickCheck.Arbitrary-  (-  -- * Arbitrary and CoArbitrary classes-    Arbitrary(..)-  , CoArbitrary(..)--  -- ** 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-  -- ** 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]]-  , shrinkIntegral           -- :: Integral a => a -> [a]-  , shrinkRealFrac           -- :: RealFrac a => a -> [a]-  , shrinkRealFracToInteger  -- :: 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 System.Random(Random)-import Test.QuickCheck.Gen-import Test.QuickCheck.Gen.Unsafe--{--import Data.Generics-  ( (:*:)(..)-  , (:+:)(..)-  , Unit(..)-  )--}--import Data.Char-  ( chr-  , ord-  , isLower-  , isUpper-  , toLower-  , isDigit-  , isSpace-  )--#ifndef NO_FIXED-import Data.Fixed-  ( Fixed-  , HasResolution-  )-#endif--#ifndef NO_NATURALS-import Numeric.Natural-#endif--import Data.Ratio-  ( Ratio-  , (%)-  , numerator-  , denominator-  )--import Data.Complex-  ( Complex((:+)) )--import Data.List-  ( sort-  , nub-  )--import Control.Monad-  ( liftM-  , liftM2-  , liftM3-  , liftM4-  , liftM5-  )--import Data.Int(Int8, Int16, Int32, Int64)-import Data.Word(Word, Word8, Word16, Word32, Word64)--#ifndef NO_GENERICS-import GHC.Generics-#endif------------------------------------------------------------------------------- ** class Arbitrary---- | Random generation and shrinking of values.-class Arbitrary a where-  -- | A generator for values of the given type.-  arbitrary :: Gen a-  arbitrary = error "no default generator"--  -- | 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.-  ---  -- Most implementations of 'shrink' should try at least three things:-  ---  -- 1. Shrink a term to any of its immediate subterms.-  ---  -- 2. Recursively apply 'shrink' to all immediate subterms.-  ---  -- 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;-  -- note that these only work on GHC 7.2 and above.-  -- 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 _ = []--#ifndef NO_GENERICS--- | Shrink a term to any of its immediate subterms,--- and also recursively shrink all subterms.-genericShrink :: (Generic a, Arbitrary 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, Arbitrary 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 Arbitrary a => GSubtermsIncl (K1 i a) a where-  gSubtermsIncl (K1 x) = [x]--instance GSubtermsIncl (K1 i a) b where-  gSubtermsIncl (K1 _) = []--#endif---- instances--instance (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where-  arbitrary = promote (`coarbitrary` arbitrary)--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 Arbitrary a => Arbitrary (Maybe a) where-  arbitrary = frequency [(1, return Nothing), (3, liftM Just arbitrary)]--  shrink (Just x) = Nothing : [ Just x' | x' <- shrink x ]-  shrink _        = []--instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where-  arbitrary = oneof [liftM Left arbitrary, liftM Right arbitrary]--  shrink (Left x)  = [ Left  x' | x' <- shrink x ]-  shrink (Right y) = [ Right y' | y' <- shrink y ]--instance Arbitrary a => Arbitrary [a] where-  arbitrary = sized $ \n ->-    do k <- choose (0,n)-       sequence [ arbitrary | _ <- [1..k] ]--  shrink xs = shrinkList shrink xs---- | 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 a) => Arbitrary (Ratio a) where-  arbitrary = arbitrarySizedFractional-  shrink    = shrinkRealFracToInteger--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 (Arbitrary a, Arbitrary b)-      => Arbitrary (a,b)- where-  arbitrary = liftM2 (,) arbitrary arbitrary--  shrink (x, y) =-       [ (x', y) | x' <- shrink x ]-    ++ [ (x, y') | y' <- shrink y ]--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)))) ]---- typical instance for primitive (numerical) types--instance Arbitrary Integer where-  arbitrary = arbitrarySizedIntegral-  shrink    = shrinkIntegral--#ifndef NO_NATURALS-instance Arbitrary Natural where-  arbitrary = arbitrarySizedNatural-  shrink    = shrinkIntegral-#endif--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 = chr `fmap` oneof [choose (0,127), choose (0,255)]-  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---- ** 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 `quot` 2 == 0 = 0-                  | otherwise = 1 + bits (n `quot` 2)-           k  = 2^(s*(bits mn `max` bits mx `max` 40) `div` 100)-       n <- choose (toInteger mn `max` (-k), toInteger mx `min` k)-       return (fromInteger n)---- ** Helper functions for implementing shrink---- | Returns no shrinking alternatives.-shrinkNothing :: a -> [a]-shrinkNothing _ = []---- | 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, but only shrink to integral values.-shrinkRealFracToInteger :: RealFrac a => a -> [a]-shrinkRealFracToInteger x =-  nub $-  [ -x-  | x < 0-  ] ++-  map fromInteger (shrinkIntegral (truncate x))---- | Shrink a fraction.-shrinkRealFrac :: RealFrac a => a -> [a]-shrinkRealFrac x =-  nub $-  shrinkRealFracToInteger x ++-  [ x - x'-  | x' <- take 20 (iterate (/ 2) x)-  , (x - x') << x ]- where-  a << b = abs a < abs b------------------------------------------------------------------------------- ** 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--#ifndef NO_NATURALS-instance CoArbitrary Natural where-  coarbitrary = coarbitraryIntegral-#endif--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---- ** 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 of a given length.-orderedList :: (Ord a, Arbitrary a) => Gen [a]-orderedList = sort `fmap` arbitrary---- | Generate an infinite list.-infiniteList :: Arbitrary a => Gen [a]-infiniteList = infiniteListOf arbitrary------------------------------------------------------------------------------- the end.
− Test/QuickCheck/Exception.hs 
@@ -1,134 +0,0 @@--- | 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__ < 609)-#define OLD_EXCEPTIONS-#endif--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 607-#define GHC_INTERRUPT--#if __GLASGOW_HASKELL__ < 613-#define GHCI_INTERRUPTED_EXCEPTION-#endif--#if __GLASGOW_HASKELL__ >= 700-#define NO_BASE_3-#endif-#endif--#if defined(NO_EXCEPTIONS)-#elif defined(OLD_EXCEPTIONS) || defined(NO_BASE_3)-import qualified Control.Exception as E-#else-import qualified Control.Exception.Extensible as E-#endif--#if defined(GHC_INTERRUPT)-#if defined(GHCI_INTERRUPTED_EXCEPTION)-import Panic(GhcException(Interrupted))-#endif-import Data.Typeable-#if defined(OLD_EXCEPTIONS)-import Data.Dynamic-#endif-#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.try (m >>= E.evaluate)---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(GHC_INTERRUPT)-#if defined(OLD_EXCEPTIONS)-isInterrupt (E.DynException e) = fromDynamic e == Just Interrupted-isInterrupt _ = False-#elif defined(GHCI_INTERRUPTED_EXCEPTION)-isInterrupt e =-  E.fromException e == Just Interrupted || E.fromException e == Just E.UserInterrupt-#else-isInterrupt e = E.fromException e == Just E.UserInterrupt-#endif--#else /* !defined(GHC_INTERRUPT) */-isInterrupt _ = False-#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.SomeException e) =-    case cast e of-      Just (E.ErrorCall msg') -> msg' == msg-      _ -> False-#endif--finally :: IO a -> IO b -> IO a-finally = E.finally-#endif------------------------------------------------------------------------------- the end.
− Test/QuickCheck/Function.hs 
@@ -1,305 +0,0 @@-{-# LANGUAGE TypeOperators, GADTs, CPP #-}--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE PatternSynonyms #-}-#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(..)-  , apply-  , (:->)-  , Function(..)-  , functionMap-  , functionShow-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708-  , pattern Fn-#endif-  )- where------------------------------------------------------------------------------- imports--import Test.QuickCheck.Arbitrary-import Test.QuickCheck.Poly--import Data.Char-import Data.Word-import Data.List( intersperse )-import Data.Maybe( fromJust )-import Data.Ratio-import Control.Arrow( (&&&) )------------------------------------------------------------------------------- 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--class Function a where-  function :: (a->b) -> (a:->b)---- basic instances--instance Function () where-  function f = Unit (f ())--instance Function Word8 where-  function f = Table [(x,f x) | x <- [0..255]]--instance (Function a, Function b) => Function (a,b) where-  function f = Pair (function `fmap` function (curry f))--instance (Function a, Function b) => Function (Either a b) where-  function f = function (f . Left) :+: function (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--functionMap :: Function b => (a->b) -> (b->a) -> (a->c) -> (a:->c)-functionMap g h f = Map g h (function (\b -> f (h b)))--functionShow :: (Show a, Read a) => (a->c) -> (a:->c)-functionShow f = functionMap show read f--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 = functionMap fromIntegral fromInteger--instance Function Char where-  function = functionMap ord' chr'-   where-    ord' c = fromIntegral (ord c) :: Word8-    chr' n = chr (fromIntegral n)--instance (Function a, Integral a) => Function (Ratio a) where-  function = functionMap (numerator &&& denominator) (uncurry (%))---- 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------------------------------------------------------------------------------- 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--data Fun a b = Fun (a :-> b, b) (a -> b)--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708--- | A pattern for matching against the function only:------ > prop :: Fun String Integer -> Bool--- > prop (Fn f) = f "banana" == f "monkey"---              || f "banana" == f "elephant"-pattern Fn f <- Fun _ f-#endif--mkFun :: (a :-> b) -> b -> Fun a b-mkFun p d = Fun (p,d) (abstract p d)--apply :: Fun a b -> (a -> b)-apply (Fun _ f) = f--instance (Show a, Show b) => Show (Fun a b) where-  show (Fun (p,d) _) = 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) _) =-    [ mkFun p' d' | (p', d') <- shrink (p, d) ]------------------------------------------------------------------------------- the end.
− Test/QuickCheck/Gen.hs 
@@ -1,209 +0,0 @@-{-# LANGUAGE CPP #-}-#ifndef NO_ST_MONAD-{-# LANGUAGE Rank2Types #-}-#endif--- | Test case generation.-module Test.QuickCheck.Gen where------------------------------------------------------------------------------- imports--import System.Random-  ( Random-  , StdGen-  , randomR-  , split-  , newStdGen-  )--import Control.Monad-  ( liftM-  , ap-  , replicateM-  , filterM-  )--import Control.Applicative-  ( Applicative(..)-  , (<$>)-  )--import Control.Arrow-  ( second-  )--import Test.QuickCheck.Random------------------------------------------------------------------------------- ** Generator type---- | A generator for values of type @a@.-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 ->-      let (r1,r2)  = split r-          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.-sized :: (Int -> Gen a) -> Gen a-sized f = MkGen (\r n -> let MkGen m = f n in m r n)---- | 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)---- | 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))---- | Tries to generate a value that satisfies a predicate.-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 [] = return []-shuffle xs = do-  (y, ys) <- elements (selectOne xs)-  (y:) <$> shuffle ys-  where-    selectOne [] = []-    selectOne (y:ys) = (y,ys) : map (second (y:)) (selectOne ys)---- | 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.
− Test/QuickCheck/Gen/Unsafe.hs 
@@ -1,51 +0,0 @@-{-# LANGUAGE CPP #-}-#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
− Test/QuickCheck/Modifiers.hs 
@@ -1,346 +0,0 @@-{-# 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-  )- where------------------------------------------------------------------------------- imports--import Test.QuickCheck.Gen-import Test.QuickCheck.Arbitrary--import Data.List-  ( sort-  )------------------------------------------------------------------------------- | @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, Ord 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-#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-#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 */------------------------------------------------------------------------------- the end.
− Test/QuickCheck/Monadic.hs 
@@ -1,253 +0,0 @@-{-# LANGUAGE CPP #-}-#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 \"<http://www.cse.chalmers.se/~rjmh/Papers/QuickCheckST.ps Testing Monadic Code with QuickCheck>\".--}-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------------------------------------------------------------------------------- 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) }--instance Functor (PropertyM m) where-  fmap f (MkPropertyM m) = MkPropertyM (\k -> m (k . f))--instance Monad m => Applicative (PropertyM m) where-  pure = return-  (<*>) = liftM2 ($)--instance Monad m => Monad (PropertyM m) where-  return x            = MkPropertyM (\k -> k x)-  MkPropertyM m >>= f = MkPropertyM (\k -> m (\a -> unPropertyM (f a) k))-  fail s              = stop (failed { reason = s })--#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 <https://en.wikipedia.org/wiki/Hoare_logic Hoare triple>------ > {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 <https://en.wikipedia.org/wiki/Predicate_transformer_semantics#Weakest_preconditions weakest precondition>------ > 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 :: Monad m => (m Property -> Property) -> PropertyM m a -> Property-monadic runner m = property (fmap runner (monadic' m))--monadic' :: Monad m => PropertyM m a -> Gen (m Property)-monadic' (MkPropertyM m) = m (const (return (return (property True))))---- | 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 :: 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 :: (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.
− Test/QuickCheck/Poly.hs 
@@ -1,133 +0,0 @@-{-# LANGUAGE CPP #-}-#ifndef NO_NEWTYPE_DERIVING-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-#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-#ifndef NO_NEWTYPE_DERIVING-           , Num-#endif-           )--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-#ifndef NO_NEWTYPE_DERIVING-           , Num-#endif-           )--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-#ifndef NO_NEWTYPE_DERIVING-           , Num-#endif-           )--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.
− Test/QuickCheck/Property.hs 
@@ -1,536 +0,0 @@--- | 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( showErr, 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)------------------------------------------------------------------------------- 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.------ Backwards combatibility note: in older versions of QuickCheck--- 'Property' was a type synonym for @'Gen' 'Prop'@, so you could mix--- and match property combinators and 'Gen' monad operations. Code--- that does this will no longer typecheck.--- However, it is easy to fix: because of the 'Testable' typeclass, any--- combinator that expects a 'Property' will also accept a @'Gen' 'Property'@.--- If you have a 'Property' where you need a @'Gen' 'a'@, simply wrap--- the property combinator inside a 'return' to get a @'Gen' 'Property'@, and--- all should be well.-newtype Property = MkProperty { unProperty :: Gen Prop }---- | The class of things which can be tested, i.e. turned into a property.-class Testable prop where-  -- | Convert the thing to a property.-  property :: prop -> Property-  -- | If true, the property will only be tested once.-  -- However, if used inside a quantifier, it will be tested normally.-  exhaustive :: prop -> Bool-  exhaustive _ = False---- | 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-  exhaustive _ = True--instance Testable Bool where-  property = property . liftBool-  exhaustive _ = True--instance Testable Result where-  property = MkProperty . return . MkProp . protectResults . return-  exhaustive _ = True--instance Testable Prop where-  property (MkProp r) = MkProperty . return . MkProp . ioRose . return $ r-  exhaustive _ = True--instance Testable prop => Testable (Gen prop) where-  property mp = MkProperty $ do p <- mp; unProperty (property p)--instance Testable Property where-  property = property . unProperty---- | Do I/O inside a property. This can obviously lead to unrepeatable--- testcases, so use with care.-{-# DEPRECATED morallyDubiousIOProperty "Use ioProperty instead" #-}-morallyDubiousIOProperty :: Testable prop => IO prop -> Property-morallyDubiousIOProperty = ioProperty -- Silly names aren't all they're cracked up to be :)---- | Do I/O inside a property. This can obviously lead to unrepeatable--- testcases, so use with care.------ For more advanced monadic testing you may want to look at--- "Test.QuickCheck.Monadic".-ioProperty :: Testable prop => IO prop -> Property-ioProperty = MkProperty . fmap (MkProp . ioRose . fmap unProp) . promote . fmap (unProperty . property)--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-  , labels       :: Map String Int    -- ^ all labels used by this property-  , stamp        :: Set String        -- ^ the collected values for this test case-  , callbacks    :: [Callback]        -- ^ the callbacks for this 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        = False-      , labels       = Map.empty-      , stamp        = Set.empty-      , callbacks    = []-      }------------------------------------------------------------------------------- ** 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 property if it fails. Shrinking is done--- automatically for most types. This 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.-counterexample :: Testable prop => String -> prop -> Property-counterexample s =-  callback $ PostFinalFailure Counterexample $ \st _res -> do-    res <- tryEvaluateIO (putLine (terminal st) s)-    case res of-      Left err ->-        putLine (terminal st) (formatException "Exception thrown while printing test case" err)-      Right () ->-        return ()---- | Adds the given string to the counterexample.-{-# 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 ]-        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.-once :: Testable prop => prop -> Property-once = mapTotalResult (\res -> res{ abort = True })---- | Attaches a label to a property. This is used for reporting--- test case distribution.-label :: Testable prop => String -> prop -> Property-label s = classify True s---- | Labels a property with a value:------ > collect x = label (show x)-collect :: (Show a, Testable prop) => a -> prop -> Property-collect x = label (show x)---- | Conditionally labels test case.-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.-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-  -- We rely on the fact that the property will catch the timeout-  -- exception and turn it into a failed test case.-  where-    f rose = ioRose $ do-      let m `orError` x = fmap (fromMaybe (error x)) m-      MkRose res roses <- timeout n (reduceRose rose) `orError`-                          "within: timeout exception not caught in Rose Result"-      res' <- timeout n (protectResult (return res)) `orError`-              "within: timeout exception not caught in Result"-      return (MkRose res' (map f roses))-#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 =-  MkProperty $-  gen >>= \x ->-    unProperty (counterexample (show x) (pf x))---- | 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 =-  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 =-  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 =-  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 =-  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,-                   labels = Map.empty,-                   stamp = Set.empty,-                   callbacks =-                     callbacks result1 ++-                     [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] ++-                     callbacks 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)-------------------------------------------------------------------------------- the end.
− Test/QuickCheck/Random.hs 
@@ -1,108 +0,0 @@--- | 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) = showsPrec n g-instance Read QCGen where-  readsPrec n xs = [(QCGen g, ys) | (g, ys) <- readsPrec n xs]--instance RandomGen QCGen where-  split (QCGen g) = (QCGen g1, QCGen g2)-    where-      (g1, g2) = split g-  genRange (QCGen g) = genRange g-  next (QCGen g) = (x, QCGen g')-    where-      (x, g') = next 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)
− Test/QuickCheck/State.hs 
@@ -1,40 +0,0 @@--- | QuickCheck's internal state. Internal QuickCheck module.-module Test.QuickCheck.State where--import Test.QuickCheck.Text-import Test.QuickCheck.Random-import qualified Data.Map as Map-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-  , maxDiscardedTests         :: Int               -- ^ maximum number of tests that can be discarded-  , computeSize               :: Int -> Int -> Int -- ^ how to compute the size of test cases from-                                                   --   #tests and #discarded tests--  -- 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.
− Test/QuickCheck/Test.hs 
@@ -1,440 +0,0 @@--- | 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)-import qualified Data.Map as Map-import qualified Data.Set as Set--import Data.Char-  ( isSpace-  )--import Data.List-  ( sort-  , group-  , groupBy-  , intersperse-  )------------------------------------------------------------------------------ quickCheck---- * Running tests---- | Args specifies arguments to the QuickCheck driver-data Args-  = Args-  { replay          :: Maybe (QCGen,Int) -- ^ Should we replay a previous test?-  , maxSuccess      :: Int               -- ^ Maximum number of successful tests before succeeding-  , 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-  }- deriving ( Show, Read )---- | Result represents the test result-data Result-  -- | A successful test run-  = Success-    { numTests       :: Int               -- ^ Number of tests performed-    , labels         :: [(String,Int)]    -- ^ Labels and frequencies found during all successful tests-    , output         :: String            -- ^ Printed output-    }-  -- | Given up-  | GaveUp-    { numTests       :: Int               --   Number of tests performed-    , labels         :: [(String,Int)]    --   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,Int)]    --   Labels and frequencies found during all successful tests-    , output         :: String            --   Printed output-    }-  -- | A property that should have failed did not-  | NoExpectedFailure-    { numTests       :: Int               --   Number of tests performed-    , labels         :: [(String,Int)]    --   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,Int)]    --   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--- noShrinking flag?-  }---- | Tests a property and prints the results to 'stdout'.-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-                 , maxDiscardedTests         = maxDiscardRatio a * maxSuccess a-                 , computeSize               = case replay a of-                                                 Nothing    -> computeSize'-                                                 Just (_,s) -> computeSize' `at0` s-                 , 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-        property' p-          | exhaustive p = once (property p)-          | otherwise = property p---- | 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 >= maxDiscardedTests 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-  | insufficientCoverage 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} -> -- successful test-         do continue doneTesting-              st{ numSuccessTests           = numSuccessTests st + 1-                , numRecentlyDiscardedTests = 0-                , 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} -> -- discarded test-         do continue giveUp-              st{ numDiscardedTests         = numDiscardedTests st + 1-                , numRecentlyDiscardedTests = numRecentlyDiscardedTests st + 1-                , 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) <- 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-              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-                            }- where-  (rnd1,rnd2) = split (randomSeed st)--summary :: State -> [(String,Int)]-summary st = reverse-           . sort-           . map (\ss -> (head ss, (length ss * 100) `div` numSuccessTests st))-           . group-           . sort-           $ [ concat (intersperse ", " (Set.toList s))-             | s <- collected st-             , not (Set.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) ":"-                sequence_ [ putLine (terminal st) pt | pt <- cases ]- where-  allLabels = reverse-            . sort-            . map (\ss -> (showP ((length ss * 100) `div` numSuccessTests st) ++ head ss))-            . group-            . sort-            $ [ concat (intersperse ", " s')-              | s <- collected st-              , let s' = [ t | t <- Set.toList s, Map.lookup t (S.labels st) == Just 0 ]-              , not (null s')-              ]--  covers = [ ("only " ++ show (labelPercentage l st) ++ "% " ++ l ++ ", not " ++ show reqP ++ "%")-           | (l, reqP) <- Map.toList (S.labels st)-           , labelPercentage l st < reqP-           ]--  showP p = (if p < 10 then " " else "") ++ show p ++ "% "--labelPercentage :: String -> State -> Int-labelPercentage l st =-  -- XXX in case of a disjunction, a label can occur several times,-  -- need to think what to do there-  (100 * occur) `div` maxSuccessTests st-  where-    occur = length [ l' | l' <- concat (map Set.toList (collected st)), l == l' ]--insufficientCoverage :: State -> Bool-insufficientCoverage st =-  or [ labelPercentage l st < reqP | (l, reqP) <- Map.toList (S.labels st) ]------------------------------------------------------------------------------- main shrinking loop--foundFailure :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int)-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)-localMin st MkResult{P.theException = Just e} lastRes _-  | isInterrupt e = localMinFound st lastRes-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)-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)-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)------------------------------------------------------------------------------- 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.
− Test/QuickCheck/Text.hs 
@@ -1,148 +0,0 @@--- | 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 Control.Applicative-import System.IO-  ( hFlush-  , hPutStr-  , stdout-  , stderr-  , Handle-  , BufferMode (..)-  , hGetBuffering-  , hSetBuffering-  )--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 String) (IORef Int) (String -> IO ()) (String -> IO ())--newTerminal :: (String -> IO ()) -> (String -> IO ()) -> IO Terminal-newTerminal out err =-  do res <- newIORef ""-     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 =-  withBuffering (newTerminal (handle stdout) (handle stderr) >>= action)--withNullTerminal :: (Terminal -> IO a) -> IO a-withNullTerminal action =-  newTerminal (const (return ())) (const (return ())) >>= action--terminalOutput :: Terminal -> IO String-terminalOutput (MkTerminal res _ _ _) = 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 (++ 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.
− changelog 
@@ -1,99 +0,0 @@-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.
+ changelog.md view
@@ -0,0 +1,457 @@+## UNRELEASED++## QuickCheck 2.18.0.0 (released 2026-02-26)+* BREAKING: Added a number of `CoArbitrary` and `Function` instances for types in `base`+* Improve implementation of `shrinkIntegral` (thanks tom93)+* Improve implementation of `Arbitrary NonEmptyList` (thanks konsumlamm)+* Convert changelog to markdown (thanks Artem)+* Deprecate `withMaxSuccess` in favour of the renamed `withNumTests`+* `Test.QuickCheck.Function` marked as `Trustworthy` not `Safe`+* Fix bug in heap example++## QuickCheck 2.17.1.0 (released 2025-10-13)+* Fix random-1.2 support (thanks bodigrim)+* Update docs (thanks effectfully)++## QuickCheck 2.17.0.0 (released 2025-10-07)+* Lower the memory use of `arbitrary` for `Double` and `Float` (thanks+ChickenProp)+* BREAKING: Remove `Gen.Class`+* BREAKING: Add `Arbitrary` instances for most of the types in `base`+* Add microHS support (thanks Lennart)++## QuickCheck 2.16.0.0 (released 2025-06-17)+* Add a `Safe` declaration to `Test.QuickCheck.Monoids`+* Fix `Test.QuickCheck.Features` to not depend on the internal testing loop+* Add `withProgress` to install common callbacks for downstream tools+* Relax bounds on `random` dependency (thanks to LaurentRDC and+Andreas Abel)+* Fix some haddock issues (thanks to pgujjula)+* Use `displayException` instead of `show` (thanks Edsko)+* Added helper monoids `Every` and `Some` for predicates (thanks+Marcin)++## QuickCheck 2.15 (released 2024-04-22)+* BREAKING: properties without quantification are no longer implicitly+  wrapped in once+* Add witness property modifier and witnesses field in result on+compilers that support Typeable to allow conveniently exposing+counterexamples+* Add assertException, assertExceptionIO, assertDeepException, and+assertDeepExceptionIO (thanks to Alexey Kuleshevich)+* Add withMaxSize, withMaxShrinks, and withMaxDiscardRatio combinators+* Add recheck+* Add HasCallStack to partial top-level functions+* Updated some documentation+* Fix overflow bug when calculating discard ratio+* Fix error printing bug when shrinks are discarded+* Fix withMaxSuccess not working when checkCoverage is turned on+* Fix a bug whereby an unfortunately timed discard could unduly fail a+property running with checkCoverage+* Fix Arbitrary intance for Map breaking invariants from+Data.Map.Strict (thanks to Neil Mayhew)+* Fix non-covered classes not showing up in output as 0% covered+* Fix Negative's Arbitrary instance discarding an unnecessary number+of generated values.+* Fix promote doing an unnecessary seed split+* Fix a bug whereby maxSuccess and discardRatio would interact poorly+to produce too few size increases.+* Fix a couple of underflow bugs in generators for Small Natural and+Ratio Natural+* Fix a bug whereby the internal DISCARDED exception would show up+user-side in sample++## QuickCheck 2.14.3 (released 2023-05-31)+* Add shrinkBoundedEnum (thanks to Jonathan Knowles)+* Add discardAfter for discarding tests on timeout (thanks to Justus Sagemüller)+* Add assertWith for monadic testing (thanks to KtorZ)+* Add functionElements to Test.QuickCheck.Function (thanks to Oleg Grenrus)+* Add Arbitrary instance for Newline (thanks to Daniel Bramucci)+* Improve Arbitrary instances for Float and Double (thanks to Oleg Grenrus)+* Improve arbitrarySizedFractional (thanks to Bodigrim)+* Fix shrinkRealFrac and shrinkDecimal, which were broken+* Speed up printing of progress messages (thanks to Bodigrim)+* Add COMPLETE pragmas for Fn and family (thanks to ilkecan)+* Make templateHaskell flag manual (thanks to Oleg Grenrus)++## QuickCheck 2.14.2 (released 2020-11-14)+* Add Arbitrary instances for Tree (thanks to Oleg Grenrus)+* GHC 9.0 compatibility (thanks to Vilem-Benjamin Liepelt)++## QuickCheck 2.14.1 (released 2020-07-05)+* Compatibility with random >= 1.2.++## QuickCheck 2.14 (released 2020-03-28)+* QuickCheck is now much faster at generating test data!+  As a result, many properties can now be tested a lot faster;+  the examples distributed with QuickCheck run about twice as+  fast as before, for example. Of course, your mileage may vary.++  The reason for this is that there are now specialised versions+  of the 'choose' combinator for various types. These are:+  chooseInt, chooseInteger, chooseBoundedIntegral, and chooseEnum.+  These combinators are identical to 'choose' but much faster.+  All QuickCheck combinators, with the exception of 'choose'+  itself, use the new combinators behind the scenes.++  You should see a speedup without doing anything, but to get a+  further speedup, consider replacing any uses of 'choose' in your+  own generators with the new combinators.++  We are hoping that future releases of the 'random' library may+  speed up 'choose', in which case these combinators may no longer+  be needed.++  Thanks to Oleg Grenrus for suggesting to bypass 'choose' for+  random number generation, and providing the appropriate+  primitive in his 'splitmix' random number library.++* Smaller changes and bugfixes:+- RecursivelyShrink and GSubterms are exported from+  Test.QuickCheck.Test (thanks to Tom Mortiboy).+- Don't generate invalid unicode characters+  (thanks to Boris Stepanov).+- When a call to 'within' fails, include the duration of the+  timeout in the failure report (thanks to William Rusnack).+- In Gen, avoid splitting the seed in the implementation of+  >>, *> and <* (thanks to David Feuer).+- Fix a couple of bugs with shrinking of floating-point+  numbers.+- Export functionMapWith, functionEitherWith and+  functionPairWith from Test.QuickCheck.Function+  (thanks to Oleg Grenrus).+- Remove redundant RealFloat constraint from+  Arbitrary/CoArbitrary instances for Complex+  (thanks to Bodigrim).++## QuickCheck 2.13.2 (released 2019-06-30)+* Compatibility with GHC 8.8 (thanks to Bodigrim)+* Improve error message when 'frequency' is used with only zero weights+* Add 'functionVoid' combinator (thanks to Oleg Grenrus)+* Tighten bounds for random package (thanks to Oleg Grenrus)++## QuickCheck 2.13.1 (released 2019-03-29)+* A couple of bug fixes++## QuickCheck 2.13 (released 2019-03-26)+* Properties with multiple arguments now shrink better.+  Previously, the first argument was shrunk, then the second, and+  so on. Now, the arguments are shrunk as a whole, so shrink steps+  for different arguments can be interleaved.++* New features:+    - New modifiers Negative and NonPositive+    - A Testable instance for Maybe prop (where Nothing means 'discard+      the test case')+* Dependencies on C code removed:+    - Use splitmix instead of tf-random for random number generation+    - Remove dependency on 'erf' package+* Small changes:+    - Say 'Falsified' instead of 'Falsifiable' when a property fails+* Compatibility improvements:+    - Explicitly derive instance Typeable Args+    - Lower bound on deepseq+    - A script for building Hugs packages++## QuickCheck 2.12.6 (released 2018-10-02)+* Make arbitrarySizedBoundedIntegral handle huge sizes correctly.+* Add changelog for QuickCheck 2.12.5 :)++## QuickCheck 2.12.5 (released 2018-09-30)+* Export isSuccess from Test.QuickCheck.+* Export CoArbitrary even when generics are disabled (bugfix).+* Fix bug in shrinkDecimal.+* Include Test.QuickCheck.Gen in exposed modules for Haddock.++## QuickCheck 2.12.3, 2.12.4 (released 2018-09-12)+* Shrinking for Float and Decimal now works by reducing the number+  of digits in the number. The new function shrinkDecimal+  implements this shrinking behaviour.+* Shrinking for Rational now tries to make the numerator and+  denominator of the number smaller. Previously it tried to reduce+  the magnitude of the number.++## QuickCheck 2.12.2 (released 2018-09-10)+* Fix infinite shrinking loop for fractional types.+* Add SortedList modifier.++## QuickCheck 2.12.1 (released 2018-09-06)+* Fix bug in 'classify'.++## QuickCheck 2.12 (released 2018-09-03)+* Silently breaking changes!+    - The Arbitrary instance for Word now generates only small+      values, the same as Int+    - cover no longer causes a property failure if coverage is+      insufficient. It just prints a warning. (But see next item!)++* Overhaul of label/cover family of combinators:+    - New property combinator checkCoverage, which checks coverage+      requirements in a statistically sound way, and *does* fail if+      they are not met.+    - Order of arguments to cover swapped, to make it easier to+      switch between classify and cover+    - New combinators tabulate and coverTable, for reporting test+      case distribution more flexibly than label.+    - When label is called multiple times in a property, each call+      produces a separate table of frequencies.++* New functions:+    - (=/=): like (/=), but prints a counterexample+      (thanks to tom-bop)+    - forAllShow/forAllShrinkShow: quantification using an+      explicit show function (thanks to Stevan Andjelkovic)+    - forAllBlind/forAllShrinkBlind: quantification without+      printing anything+    - verboseShrinking: see how a counterexample is shrunk+    - labelledExamples: given a property which uses label,+      generate an example test case for each label+    - idempotentIOProperty: a variant of ioProperty which shrinks+      better but only works for idempotent I/O actions++* Other improvements:+    - MonadFix Gen instance (thanks to Jon Fowler)+    - Rational numbers shrink using continued fractions+      (thanks to Justus Sagemüller)+    - Function instances for Const, Identity, and the types in+      Data.Monoid; instance Functor Fun (thanks to Erik Schnetter+      and Xia Li-yao)+    - More of Test.QuickCheck.Function is exported from+      Test.QuickCheck+    - Semantics of .||. changed to improve short-circuiting:+      if the left argument's precondition is false, the right+      argument is not evaluated and the whole disjunction is+      considered to have a false precondition+    - Bug fix: suchThatMaybe always increased size to at least 1++* Miscellaneous API changes:+    - Result type has changed a bit:+        - InsufficientCovered constructor is gone+        - Type of labels has changed+        - New fields classes, tables++## QuickCheck 2.11.1 - 2.11.3 (released 2018-01-12)+* Cosmetic fixes.++## QuickCheck 2.11 (released 2018-01-12)+* New features:+    - InfiniteList modifier generates infinite lists and shows+      only the relevant part.+    - applyArbitrary2/3/4 for applying a function to random+      arguments.+    - Template Haskell function allProperties returns all+      properties in a module.++* Applicative Gen instances do less splitting.+* Property now has a Typeable instance.+* (===) now prints correct output when the property is true.+* Test.QuickCheck now exports Fun constructor.+* verboseCheck output is now slightly less confusing.++## QuickCheck 2.10.1 (released 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.
examples/Heap.hs view
@@ -5,8 +5,6 @@ -- imports  import Test.QuickCheck-import Test.QuickCheck.Text-import Test.QuickCheck.All  import Data.List   ( sort@@ -74,7 +72,7 @@  toSortedList :: Ord a => Heap a -> [a] toSortedList Empty          = []-toSortedList (Node x h1 h2) = x : toList (h1 `merge` h2)+toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2)  -------------------------------------------------------------------------- -- specification@@ -109,7 +107,7 @@   insert x h ==? (x : toList h)  prop_RemoveMin (h :: Heap Int) =-  cover (size h > 1) 80 "non-trivial" $+  cover 80 (size h > 1) "non-trivial" $   case removeMin h of     Nothing     -> h ==? []     Just (x,h') -> x == minimum (toList h) && h' ==? (toList h \\ [x])@@ -146,24 +144,21 @@ -- main  return []-main = $quickCheckAll+main = do True <- $quickCheckAll; return ()  -------------------------------------------------------------------------- -- 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 ]--} +-- 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--}+-- prop_HeapIsNotSorted (h :: Heap Int) =+--   expectFailure $+--     toList h == toSortedList h
+ examples/Heap_Program.hs view
@@ -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 80 (size h > 1) "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 = do True <- $quickCheckAll; return ()++--------------------------------------------------------------------------+-- the end.++-- toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2)++
+ examples/Heap_ProgramAlgebraic.hs view
@@ -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 = do True <- $quickCheckAll; return ()++--------------------------------------------------------------------------+-- the end.+++
+ examples/Lambda.hs view
@@ -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"+
+ examples/Merge.hs view
@@ -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 = do True <- $quickCheckAll; return ()++--------------------------------------------------------------------------+-- the end.
+ examples/Set.hs view
@@ -0,0 +1,207 @@+{-# 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++--------------------------------------------------------------------------+-- 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 (<z) mx && maybe True (z<) my++  shrink Empty            = []+  shrink t@(Node x s1 s2) = [ s1, s2 ]+                         ++ [ t' | x' <- shrink x, let t' = Node x' s1 s2, invariant t' ]++--------------------------------------------------------------------------+-- 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 60 (size s >= 15) "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++prop_FromList' (xs :: [Int]) =+  shrinking shrink xs $ \xs' ->+    fromList xs ==? xs++--------------------------------------------------------------------------+-- main++return []+main = do True <- $quickCheckAll; return ()++--------------------------------------------------------------------------+-- the end.
+ examples/Simple.hs view
@@ -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 = do True <- $quickCheckAll; return ()++--------------------------------------------------------------------------+-- the end.
+ make-hugs view
@@ -0,0 +1,28 @@+#!/bin/bash++set -e++TOPDIR=$(dirname "$0")+TARGETDIR=$TOPDIR/quickcheck-hugs++find "$TOPDIR/src" -name '*.hs' | while read -r src; do+  tgt="$TARGETDIR/$(echo "$src" | sed "s/^$TOPDIR\/src"'//')"++  echo "Processing $src -> $tgt"++  mkdir -p "$(dirname "$tgt")"+  # If you want to switch on and off other features, look in+  # QuickCheck.cabal to see what's available, or submit a patch+  # adding a new -DNO_... flag.+  cpphs --noline -DOLD_RANDOM -DNO_SPLITMIX -DNO_TEMPLATE_HASKELL \+    -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS -DNO_GENERICS \+    -DNO_SAFE_HASKELL -DNO_POLYKINDS -DNO_MONADFAIL -DNO_TIMEOUT \+    -DNO_NEWTYPE_DERIVING -DNO_TYPEABLE -DNO_GADTS -DNO_TRANSFORMERS \+    -DNO_DEEPSEQ -DNO_EXTRA_METHODS_IN_APPLICATIVE -DNO_CALLSTACK \+    -DNO_SEMIGROUP -DNO_EXISTENTIAL_FIELD_SELECTORS \+    "$src" > "$tgt"+done++echo "A Hugs-compatible version of QuickCheck is now"+echo "available in the quickcheck-hugs directory."+echo "Load it with hugs -98."
+ src/Test/QuickCheck.hs view
@@ -0,0 +1,381 @@+{-|+The <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual>+gives detailed information about using QuickCheck effectively.+You can also try <https://begriffs.com/posts/2017-01-14-design-use-quickcheck.html>,+a tutorial written by a user of QuickCheck.++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 'withNumTests' combinator:++>>> quickCheck (withNumTests 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+<http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual> for+details about how to do that.++When testing fails @quickCheck@ will try to give you a minimal counterexample to+your property:+@+import Test.QuickCheck++prop_reverse_bad :: [Int] -> Bool+prop_reverse_bad xs = reverse xs == xs++>>> quickCheck prop_reverse_bad+*** Failed! Falsified (after 3 tests and 3 shrinks):+[0,1]+@++However, beware because not all properties that ought to fail will fail when you expect+them to:++@+>>> quickCheck $ \ x y -> x == y++++ Ok, passed 100 tests.+@++That's because GHCi will default any type variables in your property to @()@, so in the example+above @quickCheck@ was really testing that @()@ is equal to itself. To avoid this behaviour it+is best practise to monomorphise your polymorphic properties when testing:++@+>>> quickCheck $ \ x y -> (x :: Int) == y+*** Failed! Falsified (after 4 tests and 3 shrinks):+0+1+@++-}+{-# 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(..), TestProgress(..)+  , stdArgs+  , quickCheckWith+  , quickCheckWithResult+  , quickCheckResult+  , recheck+  , isSuccess+    -- ** Running tests verbosely+  , verboseCheck+  , verboseCheckWith+  , verboseCheckWithResult+  , verboseCheckResult+#ifndef NO_TEMPLATE_HASKELL+    -- ** Testing all properties in a module++    -- | These functions 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.+  , quickCheckAll+  , verboseCheckAll+  , forAllProperties+  , allProperties+    -- ** Testing polymorphic properties+  , polyQuickCheck+  , polyVerboseCheck+  , monomorphic+#endif++    -- * The 'Arbitrary' typeclass: generation of random values+  , Arbitrary(..)+    -- ** Helper functions for implementing 'shrink'+#ifndef NO_GENERICS+  , genericShrink+  , subterms+  , recursivelyShrink+#endif+  , shrinkNothing+  , shrinkList+  , shrinkMap+  , shrinkMapBy+  , shrinkIntegral+  , shrinkRealFrac+  , shrinkBoundedEnum+  , shrinkDecimal++    -- ** Lifting of 'Arbitrary' to unary and binary type constructors+  , Arbitrary1(..)+  , arbitrary1+  , shrink1+  , Arbitrary2(..)+  , arbitrary2+  , shrink2++    -- * The 'Gen' monad: combinators for building random generators+  , Gen+    -- ** Generator combinators+  , choose+  , chooseInt+  , chooseInteger+#ifndef NO_SPLITMIX+  , chooseWord64+  , chooseInt64+  , chooseUpTo+#endif+  , chooseBoundedIntegral+  , chooseEnum+  , chooseAny+  , oneof+  , frequency+  , elements+  , growingElements+  , sized+  , getSize+  , resize+  , scale+  , suchThat+  , suchThatMap+  , suchThatMaybe+  , applyArbitrary2+  , applyArbitrary3+  , applyArbitrary4+    -- ** Generators for lists+  , listOf+  , listOf1+  , vectorOf+  , vector+  , infiniteListOf+  , infiniteList+  , shuffle+  , sublistOf+  , orderedList+    -- ** Generators for particular types+  , arbitrarySizedIntegral+  , arbitrarySizedNatural+  , arbitrarySizedFractional+  , arbitrarySizedBoundedIntegral+  , arbitraryBoundedIntegral+  , arbitraryBoundedRandom+  , arbitraryBoundedEnum+  , arbitraryUnicodeChar+  , arbitraryASCIIChar+  , arbitraryPrintableChar+    -- ** Running generators+  , generate+    -- ** Debugging generators+  , sample+  , sample'++#ifndef NO_GADTS+    -- * The 'Function' typeclass: generation of random shrinkable, showable functions++    -- | Example of use:+    --+    -- >>> :{+    -- >>> let prop :: Fun String Integer -> Bool+    -- >>>     prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant"+    -- >>> :}+    -- >>> quickCheck prop+    -- *** Failed! Falsified (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.+    --+    -- For more information, see the paper \"Shrinking and showing functions\" by Koen Claessen.+  , Fun (..)+  , applyFun+  , applyFun2+  , applyFun3+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+  , pattern Fn+  , pattern Fn2+  , pattern Fn3+#endif+  , Function (..)+  , functionMap+  , functionShow+  , functionIntegral+  , functionRealFrac+  , functionBoundedEnum+  , functionVoid+#endif++    -- * The 'CoArbitrary' typeclass: generation of functions the old-fashioned way+  , CoArbitrary(..)+#ifndef NO_GENERICS+  , genericCoarbitrary+#endif+  , variant+  , coarbitraryIntegral+  , coarbitraryReal+  , coarbitraryShow+  , coarbitraryEnum+  , (><)++    -- * Type-level modifiers for changing generator behavior++    -- | 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 'Function')+    -- prop_TakeDropWhile ('Blind' p) (xs :: ['Test.QuickCheck.Poly.A']) =+    --   takeWhile p xs ++ dropWhile p xs == xs+    -- @+    --+    -- @+    -- prop_TakeDrop ('NonNegative' n) (xs :: ['Test.QuickCheck.Poly.A']) =+    --   take n xs ++ drop n xs == xs+    -- @+    --+    -- @+    -- -- cycle does not work for empty lists+    -- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['Test.QuickCheck.Poly.A'])) =+    --   take n (cycle xs) == take n (xs ++ cycle xs)+    -- @+    --+    -- @+    -- -- Instead of 'forAll' 'orderedList'+    -- prop_Sort ('Ordered' (xs :: ['Test.QuickCheck.Poly.OrdA'])) =+    --   sort xs == xs+    -- @+  , Blind(..)+  , Fixed(..)+  , OrderedList(..)+  , NonEmptyList(..)+  , InfiniteList(..)+  , SortedList(..)+  , Positive(..)+  , Negative(..)+  , NonZero(..)+  , NonNegative(..)+  , NonPositive(..)+  , Large(..)+  , Small(..)+  , Smart(..)+  , Shrink2(..)+#ifndef NO_MULTI_PARAM_TYPE_CLASSES+  , Shrinking(..)+  , ShrinkState(..)+#endif+  , ASCIIString(..)+  , UnicodeString(..)+  , PrintableString(..)++    -- * Property combinators+  , Property, Testable(..)+  , forAll+  , forAllShrink+  , forAllShow+  , forAllShrinkShow+  , forAllBlind+  , forAllShrinkBlind+  , shrinking+  , (==>)+  , Discard(..)+  , discard+  , (===)+  , (=/=)+#ifndef NO_DEEPSEQ+  , total+#endif+  , ioProperty+  , idempotentIOProperty+    -- ** Controlling property execution+  , verbose+  , verboseShrinking+  , noShrinking+  , withNumTests+  , withMaxSuccess+  , within+  , discardAfter+  , withDiscardRatio+  , withMaxSize+  , withMaxShrinks+  , once+  , again+  , mapSize+    -- ** Conjunction and disjunction+  , (.&.)+  , (.&&.)+  , conjoin+  , Every (..)+  , (.||.)+  , disjoin+  , Some (..)+    -- ** What to do on failure+#ifndef NO_TYPEABLE+  , Witness(..)+  , witness+  , coerceWitness+  , castWitness+#endif+  , counterexample+  , printTestCase+  , withProgress+  , whenFail+  , whenFail'+  , expectFailure+    -- * Analysing test case distribution+  , label+  , collect+  , classify+  , tabulate+    -- ** Checking test case distribution+  , cover+  , coverTable+  , checkCoverage+  , checkCoverageWith+  , Confidence(..)+  , stdConfidence+    -- ** Generating example test cases+  , labelledExamples+  , labelledExamplesWith+  , labelledExamplesWithResult+  , labelledExamplesResult+  )+ where++--------------------------------------------------------------------------+-- imports++import Test.QuickCheck.Gen+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Modifiers+import Test.QuickCheck.Monoids+import Test.QuickCheck.Property hiding ( Result(..) )+import Test.QuickCheck.Test+import Test.QuickCheck.Exception+#ifndef NO_GADTS+import Test.QuickCheck.Function+#endif+import Test.QuickCheck.Features+import Test.QuickCheck.State+#ifndef NO_TEMPLATE_HASKELL+import Test.QuickCheck.All+#endif++--------------------------------------------------------------------------+-- the end.
+ src/Test/QuickCheck/All.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE Rank2Types, CPP #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE TemplateHaskellQuotes #-}+#else+{-# LANGUAGE TemplateHaskell #-}+#endif+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Trustworthy #-}+#endif++-- | __Note__: the contents of this module are re-exported by+-- "Test.QuickCheck". You do not need to import it directly.+--+-- 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,+  allProperties,+  runQuickCheckAll,+  -- ** 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 (isPrefixOf, nubBy)+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 |] `appE` 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 |] `appE` 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 (ForallT xs ctx ty) = do+#if MIN_VERSION_template_haskell(2,17,0)+  let plain (PlainTV nm _)        = return nm+      plain (KindedTV nm _ StarT) = return nm+#else+  let plain (PlainTV nm)          = return nm+#  if MIN_VERSION_template_haskell(2,8,0)+      plain (KindedTV nm StarT)   = return nm+#  else+      plain (KindedTV nm StarK)   = return nm+#  endif+#endif+      plain _                     = err "Higher-kinded type variables in type"+  xs' <- mapM plain xs+  return (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 = [| runQuickCheckAll |] `appE` allProperties++-- | List all properties in the current module.+--+-- @$'allProperties'@ has type @[('String', 'Property')]@.+--+-- 'allProperties' has the same issue with scoping as 'quickCheckAll':+-- see the note there about @return []@.+allProperties :: Q Exp+allProperties = do+  Loc { loc_filename = filename } <- location+  when (filename == "<interactive>") $ 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+          [ tupE+            [ stringE $ x ++ " from " ++ filename ++ ":" ++ show l+            , [| property |] `appE` monomorphic (mkName x)+            ]+          ]+         else return []+  fmap (ListE . concat) (mapM quickCheckOne idents) `sigE` [t| [(String, Property)] |]++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 and later; 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 `appE` [| 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 `appE` [| 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
+ src/Test/QuickCheck/Arbitrary.hs view
@@ -0,0 +1,1981 @@+-- | Type classes for random generation of values.+--+-- __Note__: the contents of this module are re-exported by+-- "Test.QuickCheck". You do not need to import it directly.+{-# 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+  , applyArbitrary2+  , applyArbitrary3+  , applyArbitrary4+  , 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+  , RecursivelyShrink+  , GSubterms+  , 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]+  , shrinkBoundedEnum        -- :: (Bounded a, Enum a) => a -> [a]+  , shrinkDecimal            -- :: 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)+#if MIN_VERSION_random(1,3,0)+import System.Random(Random, uniformByteArray)+#else+import System.Random(Random)+#endif+import Test.QuickCheck.Gen+import Test.QuickCheck.Random+import Test.QuickCheck.Gen.Unsafe+#if defined(__MHS__)+-- These two are not exported by Control.Applicative.+-- Why should they be?  They are just bloat.+import Data.ZipList+import Control.WrappedMonad+#endif++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 (..))++#if defined(MIN_VERSION_base)+import Numeric.Natural++import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty++import System.IO+  ( Newline(..)+  , NewlineMode(..)+  , SeekMode(..)+  , BufferMode(..)+  , TextEncoding+  , latin1, utf8, utf8_bom, utf16, utf16le, utf16be, utf32, utf32le, utf32be, localeEncoding, char8+  , IOMode(..)+  )+#endif++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.IntSet as IntSet+#if MIN_VERSION_containers(0,5,0)+import qualified Data.Map.Strict as Map+import qualified Data.IntMap.Strict as IntMap+#else+import qualified Data.Map as Map+import qualified Data.IntMap as IntMap+#endif+import qualified Data.Sequence as Sequence+import qualified Data.Tree as Tree++import qualified Data.Monoid as Monoid+#if defined(MIN_VERSION_base)+import qualified Data.Semigroup as Semigroup+#endif++#ifndef NO_TRANSFORMERS+import Data.Functor.Identity+import Data.Functor.Constant+import Data.Functor.Compose+import Data.Functor.Product+#endif++#if defined(MIN_VERSION_base)+import qualified Data.Semigroup as Semigroup+import Data.Ord++import System.Console.GetOpt+    ( ArgDescr(..), ArgOrder(..), OptDescr(..) )++import Data.Functor.Contravariant++import Data.Array.Byte+import qualified GHC.Exts as Exts++#if MIN_VERSION_base(4,16,0)+import Data.Tuple+#endif+#endif++import Data.Bits+import Text.Printf++import Test.QuickCheck.Compat++--------------------------------------------------------------------------+-- ** 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+-- <http://hackage.haskell.org/package/quickcheck-instances quickcheck-instances>+-- 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',+  -- 'Test.QuickCheck.label' and 'Test.QuickCheck.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+  -- <http://hackage.haskell.org/package/testing-feat testing-feat> or+  -- <http://hackage.haskell.org/package/generic-random generic-random> packages.+  --+  -- The <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual>+  -- 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 non-Nil subterms+  -- >   [t | t@Branch{} <- [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 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 = chooseEnum (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++#if defined(MIN_VERSION_base)+instance Arbitrary1 NonEmpty where+  liftArbitrary arb = NonEmpty.fromList <$> listOf1 arb+  liftShrink shr xs = [ NonEmpty.fromList xs' | xs' <- liftShrink shr (NonEmpty.toList xs), not (null xs') ]++instance Arbitrary a => Arbitrary (NonEmpty a) where+  arbitrary = arbitrary1+  shrink = shrink1+#endif++instance Integral a => Arbitrary (Ratio a) where+  arbitrary = sized $ \ n -> do+    denom <- chooseInt (1, max 1 n)+    let lb | isNonNegativeType fromI = 0+           | otherwise = (-n*denom)+        -- NOTE: this is a trick to make sure we get around lack of scoped type+        -- variables by pinning the result-type of fromIntegral.+        fromI = fromIntegral+    numer <- chooseInt (lb, n*denom)+    pure $ fromI numer % fromI denom+  shrink = shrinkRealFrac+++#if defined(MIN_VERSION_base)+instance Arbitrary a => Arbitrary (Complex a) where+#else+instance (RealFloat a, Arbitrary a) => Arbitrary (Complex a) where+#endif+  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    = shrinkDecimal+#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++#if defined(MIN_VERSION_base)+instance Arbitrary Natural where+  arbitrary = arbitrarySizedNatural+  shrink    = shrinkIntegral+#endif++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 = arbitrarySizedNatural+  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 = oneof+    -- generate 0..1 numbers with full precision+    [ genFloat+    -- generate integral numbers+    , fromIntegral <$> (arbitrary :: Gen Int)+    -- generate fractions with small denominators+    , smallDenominators+    -- uniform -size..size with with denominators ~ size+    , uniform+    -- and uniform -size..size with higher precision+    , arbitrarySizedFractional+    ]+    where+      smallDenominators = sized $ \n -> do+        i <- chooseInt (0, min n 256)+        pure (fromRational (streamNth i rationalUniverse))++      uniform = sized $ \n -> do+        let n' = toInteger n+        b <- chooseInteger (1, max 1 n')+        a <- chooseInteger ((-n') * b, n' * b)+        return (fromRational (a % b))++  shrink    = shrinkDecimal++instance Arbitrary Double where+  arbitrary = oneof+    -- generate 0..1 numbers with full precision+    [ genDouble+    -- generate integral numbers+    , fromIntegral <$> (arbitrary :: Gen Int)+    -- generate fractions with small denominators+    , smallDenominators+    -- uniform -size..size with with denominators ~ size+    , uniform+    -- and uniform -size..size with higher precision+    , arbitrarySizedFractional+    ]+    where+      smallDenominators = sized $ \n -> do+        i <- chooseInt (0, min n 256)+        pure (fromRational (streamNth i rationalUniverse))++      uniform = sized $ \n -> do+        let n' = toInteger n+        b <- chooseInteger (1, max 1 n')+        a <- chooseInteger ((-n') * b, n' * b)+        return (fromRational (a % b))++  shrink    = shrinkDecimal++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_CTYPES_CONSTRUCTORS+-- The following four types have no Bounded instance,+-- so we fake it by discovering the bounds at runtime.+instance Arbitrary CClock where+  arbitrary = fmap CClock arbitrary+  shrink (CClock x) = map CClock (shrink x)++instance Arbitrary CTime where+  arbitrary = fmap CTime arbitrary+  shrink (CTime x) = map CTime (shrink x)++#ifndef NO_FOREIGN_C_USECONDS+instance Arbitrary CUSeconds where+  arbitrary = fmap CUSeconds arbitrary+  shrink (CUSeconds x) = map CUSeconds (shrink x)++instance Arbitrary CSUSeconds where+  arbitrary = fmap CSUSeconds arbitrary+  shrink (CSUSeconds x) = map CSUSeconds (shrink x)+#endif+#endif++instance Arbitrary CFloat where+  arbitrary = arbitrarySizedFractional+  shrink = shrinkDecimal++instance Arbitrary CDouble where+  arbitrary = arbitrarySizedFractional+  shrink = shrinkDecimal++-- Arbitrary instances for container types+-- | WARNING: Users working on the internals of the @Set@ type via e.g. @Data.Set.Internal@+-- should be aware that this instance aims to give a good representation of @Set a@+-- as mathematical sets but *does not* aim to provide a varied distribution over the+-- underlying representation.+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+-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here.+instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where+  arbitrary = arbitrary1+  shrink = shrink1+-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here.+instance Arbitrary IntSet.IntSet where+  arbitrary = fmap IntSet.fromList arbitrary+  shrink = map IntSet.fromList . shrink . IntSet.toList+-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here.+instance Arbitrary1 IntMap.IntMap where+  liftArbitrary = fmap IntMap.fromList . liftArbitrary . liftArbitrary+  liftShrink shr = map IntMap.fromList . liftShrink (liftShrink shr) . IntMap.toList+-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here.+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+-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here.+instance Arbitrary a => Arbitrary (Sequence.Seq a) where+  arbitrary = arbitrary1+  shrink = shrink1+instance Arbitrary1 Tree.Tree where+    liftArbitrary arb = sized $ \n -> do+        k <- chooseInt (0, n)+        go k+      where+        go n = do -- n is the size of the trees.+            value <- arb+            pars <- arbPartition (n - 1) -- can go negative!+            forest <- mapM go pars+            return $ Tree.Node value forest++        arbPartition :: Int -> Gen [Int]+        arbPartition k = case compare k 1 of+            LT -> pure []+            EQ -> pure [1]+            GT -> do+                first <- chooseInt (1, k)+                rest <- arbPartition $ k - first+                shuffle (first : rest)++    liftShrink shr = go+      where+        go (Tree.Node val forest) = forest +++            [ Tree.Node e fs+            | (e, fs) <- liftShrink2 shr (liftShrink go) (val, forest)+            ]+instance Arbitrary a => Arbitrary (Tree.Tree 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)+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++instance Arbitrary (f a) => Arbitrary (Monoid.Alt f a) where+  arbitrary = fmap Monoid.Alt arbitrary+  shrink = map Monoid.Alt . shrink . Monoid.getAlt++instance Arbitrary a => Arbitrary (Semigroup.Min a) where+  arbitrary = fmap Semigroup.Min arbitrary+  shrink = map Semigroup.Min . shrink . Semigroup.getMin++instance Arbitrary a => Arbitrary (Semigroup.Max a) where+  arbitrary = fmap Semigroup.Max arbitrary+  shrink = map Semigroup.Max . shrink . Semigroup.getMax++instance Arbitrary a => Arbitrary (Semigroup.First a) where+  arbitrary = fmap Semigroup.First arbitrary+  shrink = map Semigroup.First . shrink . Semigroup.getFirst++instance Arbitrary a => Arbitrary (Semigroup.Last a) where+  arbitrary = fmap Semigroup.Last arbitrary+  shrink = map Semigroup.Last . shrink . Semigroup.getLast++instance (Arbitrary a, Arbitrary b) => Arbitrary (Semigroup.Arg a b) where+  arbitrary = Semigroup.Arg <$> arbitrary <*> arbitrary+  shrink (Semigroup.Arg a b) = uncurry Semigroup.Arg <$> shrink (a, b)++instance Arbitrary a => Arbitrary (Semigroup.WrappedMonoid a) where+  arbitrary = Semigroup.WrapMonoid <$> arbitrary+  shrink = map Semigroup.WrapMonoid . shrink . Semigroup.unwrapMonoid++#if !MIN_VERSION_base(4,15,0)+instance Arbitrary a => Arbitrary (Semigroup.Option a) where+  arbitrary = Semigroup.Option <$> arbitrary+  shrink = map Semigroup.Option . shrink . Semigroup.getOption++instance CoArbitrary a => CoArbitrary (Semigroup.Option a) where+  coarbitrary = coarbitrary . Semigroup.getOption+#endif++#if MIN_VERSION_base(4,16,0)+instance Arbitrary a => Arbitrary (Iff a) where+  arbitrary = Iff <$> arbitrary+  shrink = map Iff . shrink . getIff++instance Arbitrary a => Arbitrary (Ior a) where+  arbitrary = Ior <$> arbitrary+  shrink = map Ior . shrink . getIor++instance Arbitrary a => Arbitrary (Xor a) where+  arbitrary = Xor <$> arbitrary+  shrink = map Xor . shrink . getXor++instance Arbitrary a => Arbitrary (And a) where+  arbitrary = And <$> arbitrary+  shrink = map And . shrink . getAnd++instance CoArbitrary a => CoArbitrary (And a) where+  coarbitrary = coarbitrary . getAnd++instance CoArbitrary a => CoArbitrary (Iff a) where+  coarbitrary = coarbitrary . getIff++instance CoArbitrary a => CoArbitrary (Ior a) where+  coarbitrary = coarbitrary . getIor++instance CoArbitrary a => CoArbitrary (Xor a) where+  coarbitrary = coarbitrary . getXor+#endif++#if !defined(__MHS__)+instance Arbitrary ByteArray where+#if MIN_VERSION_random(1,3,0)+  arbitrary = do+    pin <- arbitrary+    len <- abs <$> arbitrary+    MkGen $ \ qcGen _ -> fst $ uniformByteArray pin len qcGen+#else+  arbitrary = Exts.fromList <$> arbitrary+#endif+  shrink = map Exts.fromList . shrink . Exts.toList++instance CoArbitrary ByteArray where+  coarbitrary = coarbitrary . Exts.toList++-- MicroHs does not have Exts.fromList+#endif /* !defined(__MHS__) */++#if MIN_VERSION_base(4,16,0)++instance Arbitrary a => Arbitrary (Solo a) where+  arbitrary = mkSolo <$> arbitrary+  shrink = map mkSolo . shrink . getSolo++instance CoArbitrary a => CoArbitrary (Solo a) where+  coarbitrary = coarbitrary . getSolo++#endif++instance Arbitrary a => Arbitrary (Down a) where+  arbitrary = fmap Down arbitrary+  shrink = map Down . shrink . getDown++instance CoArbitrary a => CoArbitrary (Down a) where+  coarbitrary = coarbitrary . getDown++#endif++#ifdef __GLASGOW_HASKELL__++instance Arbitrary a => Arbitrary (ArgDescr a) where+  arbitrary = oneof [ NoArg <$> arbitrary+                    , ReqArg <$> arbitrary <*> arbitrary+                    , OptArg <$> arbitrary <*> arbitrary+                    ]++  shrink (NoArg i) = [ NoArg i' | i' <- shrink i ]+  shrink (ReqArg a1 a2) = [ ReqArg a1' a2 | a1' <- shrink a1 ] +++                          [ ReqArg a1 a2' | a2' <- shrink a2 ]+  shrink (OptArg a1 a2) = [ OptArg a1' a2 | a1' <- shrink a1 ] +++                          [ OptArg a1 a2' | a2' <- shrink a2 ]++instance Arbitrary a => Arbitrary (ArgOrder a) where+  arbitrary = oneof [ return RequireOrder+                    , return Permute+                    , ReturnInOrder <$> arbitrary+                    ]++  shrink RequireOrder      = []+  shrink Permute           = []+  shrink (ReturnInOrder a) = [ ReturnInOrder a' | a' <- shrink a ]++instance Arbitrary a => Arbitrary (OptDescr a) where+  arbitrary = Option+                <$> arbitrary+                <*> arbitrary+                <*> arbitrary+                <*> arbitrary++  shrink (Option a b c d) = [ Option a' b c d | a' <- shrink a ] +++                            [ Option a b' c d | b' <- shrink b ] +++                            [ Option a b c' d | c' <- shrink c ] +++                            [ Option a b c d' | d' <- shrink d ]++-- Data.Functor.Contravariant++-- can maybe use Arbitrary1/2 for these+instance CoArbitrary a => Arbitrary (Predicate a) where+  arbitrary = Predicate <$> arbitrary++  shrink (Predicate p) = [ Predicate p' | p' <- shrink p ]++instance (Arbitrary a, CoArbitrary b) => Arbitrary (Op a b) where+  arbitrary = Op <$> arbitrary++  shrink (Op f) = [ Op f' | f' <- shrink f ]++instance CoArbitrary a => Arbitrary (Equivalence a) where+  arbitrary = do+    Comparison cmp <- arbitrary+    return $ Equivalence (\x y -> cmp x y == EQ)++instance CoArbitrary a => Arbitrary (Comparison a) where+  arbitrary = do+    Comparison . comparing <$> (liftArbitrary arbitrary :: Gen (a -> Integer))++#endif++-- | Generates 'Version' with non-empty non-negative @versionBranch@, and empty @versionTags@+instance Arbitrary Version where+  arbitrary = sized $ \n ->+    do k <- chooseInt (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 _        = []++#if defined(MIN_VERSION_base)+instance Arbitrary Newline where+  arbitrary = elements [LF, CRLF]++  -- The behavior of code for LF is generally simpler than for CRLF+  -- See the documentation for this type, which states that Haskell+  -- Internally always assumes newlines are \n and this type represents+  -- how to translate that to and from the outside world, where LF means+  -- no translation.+  shrink LF = []+  shrink CRLF = [LF]++instance Arbitrary NewlineMode where+  arbitrary = NewlineMode <$> arbitrary <*> arbitrary++  shrink (NewlineMode inNL outNL) = [NewlineMode inNL' outNL' | (inNL', outNL') <- shrink (inNL, outNL)]++instance Arbitrary GeneralCategory where+  arbitrary = arbitraryBoundedEnum+  shrink = shrinkBoundedEnum++instance Arbitrary SeekMode where+  arbitrary = elements [ AbsoluteSeek, RelativeSeek, SeekFromEnd ]+  shrink x = takeWhile (x /=) [ AbsoluteSeek, RelativeSeek, SeekFromEnd ]++instance Arbitrary TextEncoding where+  arbitrary = elements [ latin1, utf8, utf8_bom, utf16, utf16le, utf16be, utf32, utf32le, utf32be, localeEncoding, char8 ]++instance Arbitrary BufferMode where+  arbitrary = oneof [ pure NoBuffering+                    , pure LineBuffering+                    , pure $ BlockBuffering Nothing+                    , BlockBuffering . Just . (+1) . fromIntegral <$> (arbitrary :: Gen Natural)+                    ]+  shrink NoBuffering = []+  shrink LineBuffering = [ NoBuffering ]+  shrink (BlockBuffering m) = [ NoBuffering, LineBuffering ] ++ map BlockBuffering (filter (maybe True (>0)) $ shrink m)++instance Arbitrary IOMode where+  arbitrary = elements [ReadMode, WriteMode, AppendMode, ReadWriteMode]+  shrink x = takeWhile (/=x) [ReadMode, WriteMode, AppendMode, ReadWriteMode]++instance Arbitrary FormatSign where+  arbitrary = elements [SignPlus, SignSpace]+  shrink SignPlus = []+  shrink SignSpace = [SignPlus]++instance Arbitrary FormatAdjustment where+  arbitrary = elements [LeftAdjust, ZeroPad]+  shrink LeftAdjust = []+  shrink ZeroPad = [LeftAdjust]++instance Arbitrary FormatParse where+  arbitrary = FormatParse <$> arbitrary <*> arbitrary <*> arbitrary+  shrink (FormatParse a b c) = [ FormatParse a' b' c' | (a', b', c') <- shrink (a, b, c) ]++instance Arbitrary FieldFormat where+  arbitrary = FieldFormat <$> arbitrary+                          <*> arbitrary+                          <*> arbitrary+                          <*> arbitrary+                          <*> arbitrary+                          <*> arbitrary+                          <*> arbitrary+  shrink (FieldFormat a b c d e f g) = [ FieldFormat a' b' c' d' e' f' g' | (a', b', c', d', e', f', g') <- shrink (a, b, c, d, e, f, g) ]++#endif++-- ** Helper functions for implementing arbitrary++-- | Apply a binary function to random arguments.+applyArbitrary2 :: (Arbitrary a, Arbitrary b) => (a -> b -> r) -> Gen r+applyArbitrary2 f = liftA2 f arbitrary arbitrary++-- | Apply a ternary function to random arguments.+applyArbitrary3+  :: (Arbitrary a, Arbitrary b, Arbitrary c)+  => (a -> b -> c -> r) -> Gen r+applyArbitrary3 f = liftA3 f arbitrary arbitrary arbitrary++-- | Apply a function of arity 4 to random arguments.+applyArbitrary4+  :: (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d)+  => (a -> b -> c -> d -> r) -> Gen r+applyArbitrary4 f = applyArbitrary3 (uncurry f)++-- | 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+  | isNonNegativeType fromI = arbitrarySizedNatural+  | otherwise = sized $ \n -> inBounds fromI (chooseInt (-n, n))+  where+    -- NOTE: this is a trick to make sure we get around lack of scoped type+    -- variables by pinning the result-type of fromIntegral.+    fromI = fromIntegral++isNonNegativeType :: Enum a => (Int -> a) -> Bool+isNonNegativeType fromI =+  case enumFromThen (fromI 1) (fromI 0) of+    [_, _] -> True+    _ -> False++-- | Generates a natural number. The number's maximum value depends on+-- the size parameter.+arbitrarySizedNatural :: Integral a => Gen a+arbitrarySizedNatural =+  sized $ \n ->+  inBounds fromIntegral (chooseInt (0, n))++inBounds :: Integral a => (Int -> a) -> Gen Int -> Gen a+inBounds fi g = fmap fi (g `suchThat` (\x -> toInteger x == toInteger (fi x)))++-- | Uniformly 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 -> do+    denom <- chooseInt (1, max 1 n)+    numer <- chooseInt (-n*denom, n*denom)+    pure $ fromIntegral numer / fromIntegral denom++-- Useful for getting at minBound and maxBound without having to+-- fiddle around with asTypeOf.+{-# INLINE withBounds #-}+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 = chooseBoundedIntegral (minBound, maxBound)++-- | 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 = chooseEnum (minBound, maxBound)++-- | 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+-- INLINEABLE so that this combinator gets specialised at each type,+-- which means that the constant 'bits' in the let-block below will+-- only be computed once.+{-# INLINEABLE arbitrarySizedBoundedIntegral #-}+arbitrarySizedBoundedIntegral =+  withBounds $ \mn mx ->+  let ilog2 1 = 0+      ilog2 n | n > 0 = 1 + ilog2 (n `div` 2)++      -- How many bits are needed to represent this type?+      -- (This number is an upper bound, not exact.)+      bits = ilog2 (toInteger mx - toInteger mn + 1) in+  sized $ \k ->+    let+      -- Reach maximum size by k=80, or quicker for small integer types+      power = ((bits `max` 40) * k) `div` 80++      -- Bounds should be 2^power, but:+      --   * clamp the result to minBound/maxBound+      --   * clamp power to 'bits', in case k is a huge number+      lo = toInteger mn `max` (-1 `shiftL` (power `min` bits))+      hi = toInteger mx `min` (1 `shiftL` (power `min` bits)) in+    fmap fromInteger (chooseInteger (lo, hi))++-- ** Generators for various kinds of character++-- | Generates any Unicode character (but not a surrogate)+arbitraryUnicodeChar :: Gen Char+arbitraryUnicodeChar =+  arbitraryBoundedEnum `suchThat` isValidUnicode+  where+    isValidUnicode c = case generalCategory c of+      Surrogate -> False+      NotAssigned -> False+      _ -> True++-- | Generates a random ASCII character (0-127).+arbitraryASCIIChar :: Gen Char+arbitraryASCIIChar = chooseEnum ('\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 =+  [ -x | x < 0, -x > x ] +++  [ x - i | i <- takeWhile (/= 0) (iterate (`quot` 2) x)]++-- | Shrink an element of a bounded enumeration.+--+-- === __Example__+--+-- @+-- data MyEnum = E0 | E1 | E2 | E3 | E4 | E5 | E6 | E7 | E8 | E9+--    deriving (Bounded, Enum, Eq, Ord, Show)+-- @+--+-- >>> shrinkBoundedEnum E9+-- [E0,E5,E7,E8]+--+-- >>> shrinkBoundedEnum E5+-- [E0,E3,E4]+--+-- >>> shrinkBoundedEnum E0+-- []+--+shrinkBoundedEnum :: (Bounded a, Enum a, Eq a) => a -> [a]+shrinkBoundedEnum a+  | a == minBound =+    []+  | otherwise =+    toEnum <$> filter (>= minBoundInt) (shrinkIntegral $ fromEnum a)+  where+    minBoundInt :: Int+    minBoundInt = fromEnum (minBound `asTypeOf` a)++-- | Shrink a fraction, preferring numbers with smaller+-- numerators or denominators. See also 'shrinkDecimal'.+shrinkRealFrac :: RealFrac a => a -> [a]+shrinkRealFrac x+  | not (x == x)  = 0 : takeWhile (< 1000) numbers -- NaN+  | x > 0 && not (2*x+1>x) = 0 : takeWhile (<x) numbers -- infinity+  | x < 0 = negate x:map negate (shrinkRealFrac (negate x))+  | otherwise = -- x is finite and >= 0+    -- To ensure termination+    filter (\y -> abs y < abs x) $+      -- Try shrinking to an integer first+      map fromInteger (shrink (truncate x) ++ [truncate x]) +++      -- Shrink the numerator+      [fromRational (num' % denom) | num' <- shrink num] +++      -- Shrink the denominator, and keep the fraction as close+      -- to the original as possible, rounding towards zero+      [fromRational (truncate (num * denom' % denom) % denom')+      | denom' <- shrink denom, denom' /= 0 ]+  where+    num = numerator (toRational x)+    denom = denominator (toRational x)+    numbers = iterate (*2) 1++-- | Shrink a real number, preferring numbers with shorter+-- decimal representations. See also 'shrinkRealFrac'.+shrinkDecimal :: RealFrac a => a -> [a]+shrinkDecimal x+  | not (x == x)  = 0 : takeWhile (< 1000) numbers -- NaN+  | not (2*abs x+1>abs x) = 0 : takeWhile (<x) numbers -- infinity+  | x < 0 = negate x:map negate (shrinkDecimal (negate x))+  | otherwise = -- x is finite and >= 0+    -- e.g. shrink pi =+    --   shrink 3 ++ map (/ 10) (shrink 31) +++    --   map (/ 100) (shrink 314) + ...,+    -- where the inner calls to shrink use integer shrinking.+    [ y+    | precision <- take 6 (iterate (*10) 1),+      let m = round (toRational x * precision),+      precision == 1 || m `mod` 10 /= 0, -- don't allow shrinking to increase digits+      n <- m:shrink m,+      let y = fromRational (fromInteger n / precision),+      abs y < abs x ]+  where+    -- 1, 2, 3, ..., 10, 20, 30, ..., 100, 200, 300, etc.+    numbers = concat $ iterate (map (*10)) (map fromInteger [1..9])++--------------------------------------------------------------------------+-- ** CoArbitrary++#ifndef NO_GENERICS+-- | Used for random generation of functions.+-- You should consider using 'Test.QuickCheck.Fun' instead, which+-- can show the generated functions as strings.+--+-- 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++#if defined(MIN_VERSION_base)+instance CoArbitrary a => CoArbitrary (Complex a) where+#else+instance (RealFloat a, CoArbitrary a) => CoArbitrary (Complex a) where+#endif+  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++#if defined(MIN_VERSION_base)+instance CoArbitrary Natural where+  coarbitrary = coarbitraryIntegral+#endif++-- 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+instance CoArbitrary a => CoArbitrary (Tree.Tree a) where+  coarbitrary (Tree.Node val forest) = coarbitrary val . coarbitrary forest++-- CoArbitrary instance for Ziplist+instance CoArbitrary a => CoArbitrary (ZipList a) where+  coarbitrary = coarbitrary . getZipList++-- CoArbitrary instance for NonEmpty+#if defined(MIN_VERSION_base)+instance CoArbitrary a => CoArbitrary (NonEmpty a) where+  coarbitrary (a NonEmpty.:| as) = coarbitrary (a, as)+#endif++#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)+instance CoArbitrary a => CoArbitrary (Monoid.First a) where+  coarbitrary = coarbitrary . Monoid.getFirst++instance CoArbitrary a => CoArbitrary (Monoid.Last a) where+  coarbitrary = coarbitrary . Monoid.getLast++instance CoArbitrary (f a) => CoArbitrary (Monoid.Alt f a) where+  coarbitrary = coarbitrary . Monoid.getAlt++instance CoArbitrary a => CoArbitrary (Semigroup.Max a) where+  coarbitrary = coarbitrary . Semigroup.getMax++instance CoArbitrary a => CoArbitrary (Semigroup.Min a) where+  coarbitrary = coarbitrary . Semigroup.getMin++instance CoArbitrary a => CoArbitrary (Semigroup.First a) where+  coarbitrary = coarbitrary . Semigroup.getFirst++instance CoArbitrary a => CoArbitrary (Semigroup.Last a) where+  coarbitrary = coarbitrary . Semigroup.getLast++instance CoArbitrary Newline where+  coarbitrary LF = variant 0+  coarbitrary CRLF = variant 1++instance CoArbitrary NewlineMode where+  coarbitrary (NewlineMode inNL outNL) = coarbitrary inNL . coarbitrary outNL++instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Semigroup.Arg a b) where+  coarbitrary (Semigroup.Arg a b) = coarbitrary (a, b)++instance CoArbitrary GeneralCategory where+  coarbitrary = coarbitrary . fromEnum++instance CoArbitrary SeekMode where+  coarbitrary = coarbitrary . fromEnum++instance CoArbitrary IOMode where+#if !defined(__MHS__)+  coarbitrary = coarbitrary . fromEnum+#else+  coarbitrary ReadMode = variant 0+  coarbitrary WriteMode = variant 1+  coarbitrary AppendMode = variant 2+  coarbitrary ReadWriteMode = variant 3+#endif++instance CoArbitrary FieldFormat where+  coarbitrary ff = coarbitrary (fmtWidth ff)+                 . coarbitrary (fmtPrecision ff)+                 . coarbitrary (fmtAdjust ff)+                 . coarbitrary (fmtSign ff)+                 . coarbitrary (fmtAlternate ff)+                 . coarbitrary (fmtModifiers ff)+                 . coarbitrary (fmtChar ff)++instance CoArbitrary FormatParse where+  coarbitrary fp = coarbitrary (fpModifiers fp)+                 . coarbitrary (fpChar fp)+                 . coarbitrary (fpRest fp)++instance CoArbitrary FormatAdjustment where+  coarbitrary LeftAdjust = coarbitrary True+  coarbitrary ZeroPad = coarbitrary False++instance CoArbitrary FormatSign where+  coarbitrary SignPlus = coarbitrary True+  coarbitrary SignSpace = coarbitrary False++instance CoArbitrary BufferMode where+  coarbitrary = coarbitrary . embed+    where embed NoBuffering = Left True+          embed LineBuffering = Left False+          embed (BlockBuffering m) = Right m++instance CoArbitrary ExitCode where+  coarbitrary = coarbitrary . embed+    where embed ExitSuccess = Nothing+          embed (ExitFailure i) = Just i++#if !defined(__MHS__)+instance CoArbitrary TextEncoding where+  coarbitrary = coarbitrary . show -- No other way as far as I can tell :(+#endif++instance CoArbitrary a => CoArbitrary (Semigroup.WrappedMonoid a) where+  coarbitrary = coarbitrary . Semigroup.unwrapMonoid++#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+++--------------------------------------------------------------------------+-- ** Rational helper++infixr 5 :<+data Stream a = !a :< Stream a++streamNth :: Int -> Stream a -> a+streamNth n (x :< xs) | n <= 0    = x+                      | otherwise = streamNth (n - 1) xs++-- We read into this stream only with ~size argument, capped to 256,+-- so it's ok to have it as CAF. (256 chosen somewhat arbitrarily, the+-- point is just to stop this blowing up.)+--+rationalUniverse :: Stream Rational+rationalUniverse = 0 :< 1 :< (-1) :< go leftSideStream+  where+    go (x :< xs) =+      let nx = -x+          rx = recip x+          nrx = -rx+      in nx `seq` rx `seq` nrx `seq` (x :< rx :< nx :< nrx :< go xs)++-- All the rational numbers on the left side of the Calkin-Wilf tree,+-- in breadth-first order.+leftSideStream :: Stream Rational+leftSideStream = (1 % 2) :< go leftSideStream+  where+    go (x :< xs) =+        lChild `seq` rChild `seq`+        (lChild :< rChild :< go xs)+      where+        nd = numerator x + denominator x+        lChild = numerator x % nd+        rChild = nd % denominator x++--------------------------------------------------------------------------+-- the end.
+ src/Test/QuickCheck/Compat.hs view
@@ -0,0 +1,34 @@+-- This module provides tools to simplify compat code across different compiler and library versions+{-# LANGUAGE CPP #-}+module Test.QuickCheck.Compat where++#if MIN_VERSION_base(4,16,0)+import Data.Tuple+#endif++#if MIN_VERSION_base(4,16,0)++#if !MIN_VERSION_base(4,18,0)++getSolo :: Solo a -> a+getSolo (Solo a) = a++mkSolo :: a -> Solo a+mkSolo = Solo++#elif !MIN_VERSION_base(4,19,0)++getSolo :: Solo a -> a+getSolo (MkSolo a) = a++mkSolo :: a -> Solo a+mkSolo = MkSolo++#else++mkSolo :: a -> Solo a+mkSolo = MkSolo++#endif++#endif
+ src/Test/QuickCheck/Exception.hs view
@@ -0,0 +1,118 @@+-- | 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.++{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE CPP #-}+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Safe #-}+#endif+module Test.QuickCheck.Exception where++#if (!defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 700)) && !defined(__MHS__)+#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 :: AnException -> Maybe AnException+#if defined(MIN_VERSION_base)+    notAsync e = case E.fromException e of+        Just (E.SomeAsyncException _) -> Nothing+        Nothing                       -> Just e+#elif !defined(OLD_EXCEPTIONS)+    notAsync e = case E.fromException e :: Maybe E.AsyncException of+        Just _  -> Nothing+        Nothing -> Just e+#else+    notAsync e = Just e+#endif++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 error value. If a property evaluates 'discard', it+-- causes QuickCheck to discard the current test case.+-- This can be useful if you want to discard the current test case,+-- but are somewhere you can't use 'Test.QuickCheck.==>', such as inside a+-- generator.+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.
+ src/Test/QuickCheck/Features.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE CPP #-}+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Safe #-}+#endif+{-# OPTIONS_HADDOCK hide #-}+module Test.QuickCheck.Features where++import Test.QuickCheck.Property hiding (Result, reason)+import qualified Test.QuickCheck.Property as P+import Test.QuickCheck.Test+import Test.QuickCheck.Gen+import Test.QuickCheck.State+import Test.QuickCheck.Text+import Test.QuickCheck.Random+import qualified Data.Set as Set+import Data.Set(Set)+import Data.List (intersperse)+import Data.IORef+import Data.Maybe++features :: [String] -> Set String -> Set String+features labels classes =+  Set.fromList labels `Set.union` classes++prop_noNewFeatures :: Testable prop => Set String -> prop -> Property+prop_noNewFeatures feats prop =+  mapResult f prop+  where+    f res =+      case ok res of+        Just True+          | not (features (P.labels res) (Set.fromList (map fst $ filter snd $ P.classes res)) `Set.isSubsetOf` feats) ->+            res{ok = Just False, P.reason = "New feature found"}+        _ -> res++-- | Given a property, which must use 'label', 'collect', 'classify' or 'cover'+-- to associate labels with test cases, find an example test case for each possible label.+-- The example test cases are minimised using shrinking.+--+-- For example, suppose we test @'Data.List.delete' x xs@ and record the number+-- of times that @x@ occurs in @xs@:+--+-- > prop_delete :: Int -> [Int] -> Property+-- > prop_delete x xs =+-- >   classify (count x xs == 0) "count x xs == 0" $+-- >   classify (count x xs == 1) "count x xs == 1" $+-- >   classify (count x xs >= 2) "count x xs >= 2" $+-- >   counterexample (show (delete x xs)) $+-- >   count x (delete x xs) == max 0 (count x xs-1)+-- >   where count x xs = length (filter (== x) xs)+--+-- 'labelledExamples' generates three example test cases, one for each label:+--+-- >>> labelledExamples prop_delete+-- *** Found example of count x xs == 0+-- 0+-- []+-- []+-- <BLANKLINE>+-- *** Found example of count x xs == 1+-- 0+-- [0]+-- []+-- <BLANKLINE>+-- *** Found example of count x xs >= 2+-- 5+-- [5,5]+-- [5]+-- <BLANKLINE>+-- +++ OK, passed 100 tests:+-- 78% count x xs == 0+-- 21% count x xs == 1+--  1% count x xs >= 2+++labelledExamples :: Testable prop => prop -> IO ()+labelledExamples prop = labelledExamplesWith stdArgs prop++-- | A variant of 'labelledExamples' that takes test arguments.+labelledExamplesWith :: Testable prop => Args -> prop -> IO ()+labelledExamplesWith args prop = labelledExamplesWithResult args prop >> return ()++-- | A variant of 'labelledExamples' that returns a result.+labelledExamplesResult :: Testable prop => prop -> IO Result+labelledExamplesResult prop = labelledExamplesWithResult stdArgs prop++-- | A variant of 'labelledExamples' that takes test arguments and returns a result.+labelledExamplesWithResult :: Testable prop => Args -> prop -> IO Result+labelledExamplesWithResult args prop = loop Set.empty $ replay args+  where+    loop :: Set String -> Maybe (QCGen, Int) -> IO Result+    loop feats replay = withNullTerminal $ \nullterm -> do+      res <- quickCheckWithResult args{chatty = False, replay = replay} (prop_noNewFeatures feats prop)+      let feats' = features (failingLabels res) (failingClasses res)+      case res of+        Failure{reason = "New feature found"} -> do+          putStrLn $+            "*** Found example of " +++            concat (intersperse ", " (Set.toList (feats' Set.\\ feats)))+          mapM_ putStrLn (failingTestCase res)+          putStrLn ""+          loop (Set.union feats feats') (Just (usedSeed res, usedSize res))+        _ -> do+          out <- terminalOutput nullterm+          putStr out+          return res+    at0 f s 0 0 = s+    at0 f s n d = f n d
+ src/Test/QuickCheck/Function.hs view
@@ -0,0 +1,772 @@+{-# LANGUAGE TypeOperators, GADTs, CPP, Rank2Types #-}+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Trustworthy #-}+#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.+--+-- __Note__: most of the contents of this module are re-exported by+-- "Test.QuickCheck". You probably do not need to import it directly.+--+-- Example of use:+--+-- >>> :{+-- >>> let prop :: Fun String Integer -> Bool+-- >>>     prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant"+-- >>> :}+-- >>> quickCheck prop+-- *** Failed! Falsified (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(..)+  , mkFun+  , applyFun+  , apply+  , applyFun2+  , applyFun3+  , (:->)+  , Function(..)+  , functionMap+  , functionShow+  , functionIntegral+  , functionRealFrac+  , functionBoundedEnum+  , functionElements+  , functionVoid+  , functionMapWith+  , functionEitherWith+  , functionPairWith+#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 Control.Applicative+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 qualified Data.Tree as Tree+import Data.Int+import Data.Complex+import Data.Foldable(toList)+import Data.Functor.Identity+import qualified Data.Monoid as Monoid+import qualified Data.Semigroup as Semigroup+import qualified Data.List.NonEmpty as NonEmpty+import Numeric.Natural+import qualified Data.Bits as Bits+import Data.Tuple+import Data.Ord+import Data.Functor.Contravariant+import Text.Printf+import System.IO+import System.Exit+import Data.Version+import Data.Array.Byte+import qualified GHC.Exts as Exts++#if defined(__MHS__)+import Data.ZipList+import Control.WrappedMonad+#endif++#if defined(MIN_VERSION_base)+import System.IO+  ( Newline(..)+  , NewlineMode(..)+  )+#endif++#ifndef NO_FIXED+import Data.Fixed+#endif++#ifndef NO_GENERICS+import GHC.Generics hiding (C)+#endif++import Test.QuickCheck.Compat++--------------------------------------------------------------------------+-- 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)+#if defined(__MHS__)+{- This is a temporary fix for a deficiency in the MicroHs type checker. -}+abstract (Pair p)    d xy    =+  case xy of+    (x,y) -> abstract (fmap (\q -> abstract q d y) p) d x+#else+abstract (Pair p)    d (x,y) = abstract (fmap (\q -> abstract q d y) p) d x+#endif+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 = functionElements [minBound..maxBound]++-- | Provides a 'Function' instance for small finite types.+functionElements :: Eq a => [a] ->  (a->b) -> (a:->b)+functionElements xs f = Table [(x,f x) | x <- xs]++-- | 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++-- | Provides a 'Function' instance for types isomorphic to 'Data.Void.Void'.+--+-- An actual @'Function' 'Data.Void.Void'@ instance is defined in+-- @quickcheck-instances@.+functionVoid :: (forall b. void -> b) -> void :-> c+functionVoid _ = Nil++-- | 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++-- | @since 2.13.3+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 (Const a b) where+  function = functionMap getConst Const++instance Function a => Function (Identity a) where+  function = functionMap runIdentity Identity++instance (Function a, Function b) => Function (a,b) where+  function = functionPairWith function function++-- | @since 2.13.3+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++-- | @since 2.13.3+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 (NonEmpty.NonEmpty a) where+  function = functionMap (\(a NonEmpty.:| as) -> (a, as)) (\(a, as) -> a NonEmpty.:| as)++instance Function a => Function (ZipList a) where+  function = functionMap getZipList ZipList++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++instance Function Natural where+  function = functionIntegral++-- 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 a => Function (Tree.Tree a) where+  function = functionMap (\(Tree.Node x xs) -> (x,xs)) (uncurry Tree.Node)++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++#if defined(MIN_VERSION_base)+instance Function Newline where+  function = functionMap g h+    where+      g LF = False+      g CRLF = True++      h False = LF+      h True = CRLF++instance Function NewlineMode where+  function = functionMap g h+    where+      g (NewlineMode inNL outNL) = (inNL,outNL)+      h (inNL,outNL) = NewlineMode inNL outNL+#endif++-- instances for Data.Monoid newtypes++instance Function a => Function (Monoid.Dual a) where+  function = functionMap Monoid.getDual Monoid.Dual++instance Function Monoid.All where+  function = functionMap Monoid.getAll Monoid.All++instance Function Monoid.Any where+  function = functionMap Monoid.getAny Monoid.Any++instance Function a => Function (Monoid.Sum a) where+  function = functionMap Monoid.getSum Monoid.Sum++instance Function a => Function (Monoid.Product a) where+  function = functionMap Monoid.getProduct Monoid.Product++instance Function a => Function (Monoid.First a) where+  function = functionMap Monoid.getFirst Monoid.First++instance Function a => Function (Monoid.Last a) where+  function = functionMap Monoid.getLast Monoid.Last++instance Function (f a) => Function (Monoid.Alt f a) where+  function = functionMap Monoid.getAlt Monoid.Alt++instance Function a => Function (Semigroup.Min a) where+  function = functionMap Semigroup.getMin Semigroup.Min++instance Function a => Function (Semigroup.Max a) where+  function = functionMap Semigroup.getMax Semigroup.Max++instance Function a => Function (Semigroup.Last a) where+  function = functionMap Semigroup.getLast Semigroup.Last++instance Function a => Function (Semigroup.First a) where+  function = functionMap Semigroup.getFirst Semigroup.First++instance Function a => Function (Semigroup.WrappedMonoid a) where+  function = functionMap Semigroup.unwrapMonoid Semigroup.WrapMonoid++instance (Function a, Function b) => Function (Semigroup.Arg a b) where+  function = functionMap (\(Semigroup.Arg a b) -> (a, b)) (uncurry Semigroup.Arg)++#if MIN_VERSION_base(4,16,0)+instance Function a => Function (Bits.And a) where+  function = functionMap Bits.getAnd Bits.And++instance Function a => Function (Bits.Ior a) where+  function = functionMap Bits.getIor Bits.Ior++instance Function a => Function (Bits.Xor a) where+  function = functionMap Bits.getXor Bits.Xor++instance Function a => Function (Bits.Iff a) where+  function = functionMap Bits.getIff Bits.Iff+#endif++instance Function FormatSign where+  function = functionMap (\x -> case x of SignPlus -> True; _ -> False) (\b -> if b then SignPlus else SignSpace)++instance Function FormatAdjustment where+  function = functionMap (\x -> case x of LeftAdjust -> True; _ -> False) (\b -> if b then LeftAdjust else ZeroPad)++instance Function FormatParse where+  function = functionMap to from+    where to fp = (fpModifiers fp, fpChar fp, fpRest fp)+          from (a, b, c) = FormatParse a b c++instance Function FieldFormat where+  function = functionMap to from+    where to ff = ( fmtWidth ff+                  , fmtPrecision ff+                  , fmtAdjust ff+                  , fmtSign ff+                  , fmtAlternate ff+                  , fmtModifiers ff+                  , fmtChar ff)+          from (a, b, c, d, e, f, g) = FieldFormat a b c d e f g++instance Function GeneralCategory where+  function = functionBoundedEnum++instance Function SeekMode where+  function = functionElements [AbsoluteSeek, RelativeSeek, SeekFromEnd]++instance Function IOMode where+  function = functionElements [ReadMode, WriteMode, AppendMode, ReadWriteMode]++instance Function BufferMode where+  function = functionMap to from+    where to NoBuffering = Left True+          to LineBuffering = Left False+          to (BlockBuffering m) = Right m++          from (Left True) = NoBuffering+          from (Left False) = LineBuffering+          from (Right m)    = BlockBuffering m++instance Function ExitCode where+  function = functionMap to from+    where to ExitSuccess = Nothing+          to (ExitFailure c) = Just c++          from Nothing = ExitSuccess+          from (Just c) = ExitFailure c++instance Function Version where+  function = functionMap to from+    where to (Version a b) = (a, b)+          from (a, b) = Version a b++#if !defined(__MHS__)+instance Function ByteArray where+  function = functionMap Exts.toList Exts.fromList+#endif++#if MIN_VERSION_base(4,16,0)+instance Function a => Function (Solo a) where+  function = functionMap getSolo mkSolo+#endif++instance Function a => Function (Down a) where+  function = functionMap getDown Down++#if !MIN_VERSION_base(4,15,0)+instance Function a => Function (Semigroup.Option a) where+  function = functionMap Semigroup.getOption Semigroup.Option+#endif++-- 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 :: Eq aa => [(aa,cc)] -> (aa :-> cc) -- MicroHs needs this+  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++instance Functor (Fun a) where+  fmap f (Fun (p, d, s) g) = Fun (fmap f p, f d, s) (f . g)++#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)+#if __GLASGOW_HASKELL__ >= 802+{-# COMPLETE Fn #-}+#endif++-- | 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)+#if __GLASGOW_HASKELL__ >= 802+{-# COMPLETE Fn2 #-}+#endif++-- | 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)+#if __GLASGOW_HASKELL__ >= 802+{-# COMPLETE Fn3 #-}+#endif+#endif++-- | Create a `Fun` from a function representation and a default value (in case the function+-- is partial).+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) _) = "<fun>"+  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.
+ src/Test/QuickCheck/Gen.hs view
@@ -0,0 +1,385 @@+{-# LANGUAGE CPP #-}+#ifndef NO_ST_MONAD+{-# LANGUAGE Rank2Types #-}+#endif+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Safe #-}+#endif+-- | Test case generation.+--+-- __Note__: the contents of this module (except for the definition of+-- 'Gen') are re-exported by "Test.QuickCheck". You probably do not+-- need to import it directly.+module Test.QuickCheck.Gen where++--------------------------------------------------------------------------+-- imports++import Test.QuickCheck.Exception++import System.Random+  ( Random+  , random+  , randomR+  )++import Control.Monad+  ( ap+  , replicateM+  , filterM+  )++import Control.Monad.Fix+  ( MonadFix(..) )++import Control.Applicative+  ( Applicative(..) )++import Test.QuickCheck.Random+import Data.List (sortBy)+import Data.Ord+import Data.Maybe+#ifndef NO_SPLITMIX+import System.Random.SplitMix(bitmaskWithRejection64', nextInteger, nextDouble, nextFloat, SMGen)+#endif+import Data.Word+import Data.Int+import Data.Bits+import Control.Applicative+#ifndef NO_CALLSTACK+import GHC.Stack+#define WITHCALLSTACK(ty) HasCallStack => ty+#else+#define WITHCALLSTACK(ty) ty+#endif++--------------------------------------------------------------------------+-- ** Generator type++-- | A generator for values of type @a@.+--+-- The third-party packages+-- <http://hackage.haskell.org/package/QuickCheck-GenT QuickCheck-GenT>+-- and+-- <http://hackage.haskell.org/package/quickcheck-transformer quickcheck-transformer>+-- provide monad transformer versions of @Gen@.+newtype Gen a = MkGen{+  unGen :: QCGen -> Int -> a -- ^ Run the generator on a particular seed and size.+                             -- 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 x =+    MkGen (\_ _ -> x)+  (<*>) = ap++#ifndef NO_EXTRA_METHODS_IN_APPLICATIVE+  -- We don't need to split the seed for these.+  _ *> m = m+  m <* _ = m+#endif++instance Monad Gen where+  return = pure++  MkGen m >>= k =+    MkGen (\r n ->+      case splitImpl r of+        (r1, r2) ->+          let MkGen m' = k (m r1 n)+          in m' r2 n+    )++  (>>) = (*>)++instance MonadFix Gen where+  mfix f =+    MkGen $ \r n ->+      let a = unGen (f a) r n+      in a++--------------------------------------------------------------------------+-- ** 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 (integerVariant (toInteger 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)++-- | Returns 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 :: WITHCALLSTACK(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.+-- For integral and enumerated types, the specialised variants of+-- 'choose' below run much quicker.+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)++-- | A fast implementation of 'choose' for enumerated types.+chooseEnum :: Enum a => (a, a) -> Gen a+chooseEnum (lo, hi) =+  fmap toEnum (chooseInt (fromEnum lo, fromEnum hi))++-- | A fast implementation of 'choose' for 'Int'.+chooseInt :: (Int, Int) -> Gen Int+chooseInt = chooseBoundedIntegral++-- Note about INLINEABLE: we specialise chooseBoundedIntegral+-- for each concrete type, so that all the bounds checks get+-- simplified away.+{-# INLINEABLE chooseBoundedIntegral #-}+-- | A fast implementation of 'choose' for bounded integral types.+chooseBoundedIntegral :: (Bounded a, Integral a) => (a, a) -> Gen a+chooseBoundedIntegral (lo, hi)+#ifndef NO_SPLITMIX+  | toInteger mn >= toInteger (minBound :: Int64) &&+    toInteger mx <= toInteger (maxBound :: Int64) =+      fmap fromIntegral (chooseInt64 (fromIntegral lo, fromIntegral hi))+  | toInteger mn >= toInteger (minBound :: Word64) &&+    toInteger mx <= toInteger (maxBound :: Word64) =+      fmap fromIntegral (chooseWord64 (fromIntegral lo, fromIntegral hi))+#endif+  | otherwise =+      fmap fromInteger (chooseInteger (toInteger lo, toInteger hi))+#ifndef NO_SPLITMIX+  where+    mn = minBound `asTypeOf` lo+    mx = maxBound `asTypeOf` hi+#endif++-- | A fast implementation of 'choose' for 'Integer'.+chooseInteger :: (Integer, Integer) -> Gen Integer+#ifdef NO_SPLITMIX+chooseInteger = choose+#else+chooseInteger (lo, hi)+  | lo >= toInteger (minBound :: Int64) && lo <= toInteger (maxBound :: Int64) &&+    hi >= toInteger (minBound :: Int64) && hi <= toInteger (maxBound :: Int64) =+    fmap toInteger (chooseInt64 (fromInteger lo, fromInteger hi))+  | lo >= toInteger (minBound :: Word64) && lo <= toInteger (maxBound :: Word64) &&+    hi >= toInteger (minBound :: Word64) && hi <= toInteger (maxBound :: Word64) =+    fmap toInteger (chooseWord64 (fromInteger lo, fromInteger hi))+  | otherwise = MkGen $ \(QCGen g) _ -> fst (nextInteger lo hi g)++chooseWord64 :: (Word64, Word64) -> Gen Word64+chooseWord64 (lo, hi)+  | lo <= hi = chooseWord64' (lo, hi)+  | otherwise = chooseWord64' (hi, lo)+  where+    chooseWord64' :: (Word64, Word64) -> Gen Word64+    chooseWord64' (lo, hi) =+      fmap (+ lo) (chooseUpTo (hi - lo))++chooseInt64 :: (Int64, Int64) -> Gen Int64+chooseInt64 (lo, hi)+  | lo <= hi = chooseInt64' (lo, hi)+  | otherwise = chooseInt64' (hi, lo)+  where+    chooseInt64' :: (Int64, Int64) -> Gen Int64+    chooseInt64' (lo, hi) = do+      w <- chooseUpTo (fromIntegral hi - fromIntegral lo)+      return (fromIntegral (w + fromIntegral lo))++chooseUpTo :: Word64 -> Gen Word64+chooseUpTo n =+  MkGen $ \(QCGen g) _ ->+    fst (bitmaskWithRejection64' n g)+#endif++-- | 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 'System.IO.stdout'.+sample :: Show a => Gen a -> IO ()+sample g =+  sequence_ [ do r <- newQCGen+                 munit <- tryEvaluateIO (print $ unGen g r n)+                 case munit of+                  Left e+                    | isDiscard e -> putStrLn "<DISCARDED>"+                    | otherwise -> error $ unlines $ "Uncaught exception in sample: " : map ("  " ++) (lines $ show e)+                  Right () -> return ()+            | n <- [0,2..20] ]++--------------------------------------------------------------------------+-- ** Floating point++-- | Generate 'Double' in 0..1 range+genDouble :: Gen Double++-- | Generate 'Float' in 0..1 range+genFloat :: Gen Float++#ifndef NO_SPLITMIX+genDouble = MkGen $ \(QCGen g) _ -> fst (nextDouble g)+genFloat  = MkGen $ \(QCGen g) _ -> fst (nextFloat g)+#else+genDouble = choose (0,1)+genFloat  = choose (0,1)+#endif++--------------------------------------------------------------------------+-- ** 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 (\n -> try n (2*n))+ where+  try m n+    | m > n = return Nothing+    | otherwise = do+        x <- resize m gen+        if p x then return (Just x) else try (m+1) n++-- | Randomly uses one of the given generators. The input list+-- must be non-empty.+oneof :: WITHCALLSTACK([Gen a] -> Gen a)+oneof [] = error "QuickCheck.oneof used with empty list"+oneof gs = chooseInt (0,length gs - 1) >>= (gs !!)++-- | Chooses one of the given generators, with a weighted random distribution.+-- The input list must be non-empty.+frequency :: WITHCALLSTACK([(Int, Gen a)] -> Gen a)+frequency [] = error "QuickCheck.frequency used with empty list"+frequency xs+  | any (< 0) (map fst xs) =+    error "QuickCheck.frequency: negative weight"+  | all (== 0) (map fst xs) =+    error "QuickCheck.frequency: all weights were zero"+frequency xs0 = chooseInt (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 :: WITHCALLSTACK([a] -> Gen a)+elements [] = error "QuickCheck.elements used with empty list"+elements xs = (xs !!) `fmap` chooseInt (0, length xs - 1)++-- | Generates a random subsequence of the given list.+sublistOf :: [a] -> Gen [a]+sublistOf xs = filterM (\_ -> chooseEnum (False, True)) xs++-- | Generates a random permutation of the given list.+shuffle :: [a] -> Gen [a]+shuffle xs = do+  ns <- vectorOf (length xs) (chooseInt (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 :: WITHCALLSTACK([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 <- chooseInt (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 <- chooseInt (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.
+ src/Test/QuickCheck/Gen/Unsafe.hs view
@@ -0,0 +1,53 @@+{-# 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+import Control.Applicative++-- | Promotes a monadic generator to a generator of monadic values.+promote :: Monad m => m (Gen a) -> Gen (m a)+promote m = flip liftM m <$> delay++-- | 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
+ src/Test/QuickCheck/Modifiers.hs view
@@ -0,0 +1,549 @@+{-# 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+#ifndef NO_TYPEABLE+{-# LANGUAGE DeriveDataTypeable #-}+#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.+--+-- __Note__: the contents of this module are re-exported by+-- "Test.QuickCheck". You do not need to import it directly.+--+-- Examples:+--+-- @+-- -- Functions cannot be shown (but see "Test.QuickCheck.Function")+-- prop_TakeDropWhile ('Blind' p) (xs :: ['Test.QuickCheck.Poly.A']) =+--   takeWhile p xs ++ dropWhile p xs == xs+-- @+--+-- @+-- prop_TakeDrop ('NonNegative' n) (xs :: ['Test.QuickCheck.Poly.A']) =+--   take n xs ++ drop n xs == xs+-- @+--+-- @+-- -- cycle does not work for empty lists+-- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['Test.QuickCheck.Poly.A'])) =+--   take n (cycle xs) == take n (xs ++ cycle xs)+-- @+--+-- @+-- -- Instead of 'Test.QuickCheck.forAll' 'orderedList'+-- prop_Sort ('Ordered' (xs :: ['Test.QuickCheck.Poly.OrdA'])) =+--   sort xs == xs+-- @+module Test.QuickCheck.Modifiers+  (+  -- ** Type-level modifiers for changing generator behavior+    Blind(..)+  , Fixed(..)+  , OrderedList(..)+  , NonEmptyList(..)+  , InfiniteList(..)+  , SortedList(..)+  , Positive(..)+  , Negative(..)+  , NonZero(..)+  , NonNegative(..)+  , NonPositive(..)+  , Large(..)+  , Small(..)+  , Smart(..)+  , Shrink2(..)+  , NoShrink(..)+#ifndef NO_MULTI_PARAM_TYPE_CLASSES+  , Shrinking(..)+  , ShrinkState(..)+#endif+  , ASCIIString(..)+  , UnicodeString(..)+  , PrintableString(..)+  )+ where++--------------------------------------------------------------------------+-- imports++import Test.QuickCheck.Gen+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Exception++import Data.List+  ( sort+  )+import Data.Ix (Ix)++#ifndef NO_TYPEABLE+import Data.Typeable (Typeable)+#endif++--------------------------------------------------------------------------+-- | @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+#ifndef NO_TYPEABLE+          , Typeable+#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+#ifndef NO_TYPEABLE+          , Typeable+#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+#ifndef NO_TYPEABLE+          , Typeable+#endif+          )++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+#ifndef NO_TYPEABLE+          , Typeable+#endif+          )++instance Functor NonEmptyList where+  fmap f (NonEmpty x) = NonEmpty (map f x)++instance Arbitrary1 NonEmptyList where+  liftArbitrary = fmap NonEmpty . listOf1+  liftShrink shr = map NonEmpty . filter (not . null) . shrinkList shr . getNonEmpty++instance Arbitrary a => Arbitrary (NonEmptyList a) where+  arbitrary = arbitrary1+  shrink = shrink1++----------------------------------------------------------------------+-- | @InfiniteList xs _@: guarantees that xs is an infinite list.+-- When a counterexample is found, only prints the prefix of xs+-- that was used by the program.+--+-- Here is a contrived example property:+--+-- > prop_take_10 :: InfiniteList Char -> Bool+-- > prop_take_10 (InfiniteList xs _) =+-- >   or [ x == \'a\' | x <- take 10 xs ]+--+-- In the following counterexample, the list must start with @"bbbbbbbbbb"@ but+-- the remaining (infinite) part can contain anything:+--+-- >>> quickCheck prop_take_10+-- *** Failed! Falsified (after 1 test and 14 shrinks):+-- "bbbbbbbbbb" ++ ...+data InfiniteList a =+  InfiniteList {+    getInfiniteList :: [a],+    infiniteListInternalData :: InfiniteListInternalData a }++-- Uses a similar trick to Test.QuickCheck.Function:+-- the Arbitrary instance generates an infinite list, which is+-- reduced to a finite prefix by shrinking. We use discard to+-- check that nothing coming after the finite prefix is used+-- (see infiniteListFromData).+data InfiniteListInternalData a = Infinite [a] | FinitePrefix [a]++infiniteListFromData :: InfiniteListInternalData a -> InfiniteList a+infiniteListFromData info@(Infinite xs) = InfiniteList xs info+infiniteListFromData info@(FinitePrefix xs) =+  InfiniteList (xs ++ discard) info++instance Show a => Show (InfiniteList a) where+  showsPrec _ (InfiniteList _ (Infinite _)) =+    ("<infinite list>" ++)+  showsPrec n (InfiniteList _ (FinitePrefix xs)) =+    (if n > 10 then ('(':) else id) .+    showsPrec 0 xs .+    (" ++ ..." ++) .+    (if n > 10 then (')':) else id)++instance Arbitrary a => Arbitrary (InfiniteList a) where+  arbitrary = fmap infiniteListFromData arbitrary+  shrink (InfiniteList _ info) =+    map infiniteListFromData (shrink info)++instance Arbitrary a => Arbitrary (InfiniteListInternalData a) where+  arbitrary = fmap Infinite infiniteList+  shrink (Infinite xs) =+    [FinitePrefix (take n xs) | n <- map (2^) [0..]]+  shrink (FinitePrefix xs) =+    map FinitePrefix (shrink xs)++--------------------------------------------------------------------------+-- | @Sorted xs@: guarantees that xs is sorted.+newtype SortedList a = Sorted {getSorted :: [a]}+ deriving ( Eq, Ord, Show, Read+#ifndef NO_TYPEABLE+          , Typeable+#endif+          )++instance Functor SortedList where+  fmap f (Sorted x) = Sorted (map f x)++instance (Arbitrary a, Ord a) => Arbitrary (SortedList a) where+  arbitrary = fmap (Sorted . sort) arbitrary++  shrink (Sorted xs) =+    [ Sorted xs'+    | xs' <- map sort (shrink xs)+    ]++--------------------------------------------------------------------------+-- | @Positive x@: guarantees that @x \> 0@.+newtype Positive a = Positive {getPositive :: a}+ deriving ( Eq, Ord, Show, Read+#ifndef NO_NEWTYPE_DERIVING+          , Enum+#endif+#ifndef NO_TYPEABLE+          , Typeable+#endif+          )++instance Functor Positive where+  fmap f (Positive x) = Positive (f x)++instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where+  arbitrary = fmap Positive (fmap abs arbitrary `suchThat` (> 0))+  shrink (Positive x) = [ Positive x' | x' <- shrink x , x' > 0 ]++--------------------------------------------------------------------------+-- | @Negative x@: guarantees that @x \< 0@.+newtype Negative a = Negative {getNegative :: a}+ deriving ( Eq, Ord, Show, Read+#ifndef NO_NEWTYPE_DERIVING+          , Enum+#endif+#ifndef NO_TYPEABLE+          , Typeable+#endif+          )++instance Functor Negative where+  fmap f (Negative x) = Negative (f x)++instance (Num a, Ord a, Arbitrary a) => Arbitrary (Negative a) where+  arbitrary = fmap Negative (fmap (negate . abs) arbitrary `suchThat` (< 0))+  shrink (Negative x) = [ Negative 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+#ifndef NO_TYPEABLE+          , Typeable+#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+#ifndef NO_TYPEABLE+          , Typeable+#endif+          )++instance Functor NonNegative where+  fmap f (NonNegative x) = NonNegative (f x)++instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonNegative a) where+  arbitrary = fmap NonNegative (fmap abs arbitrary `suchThat` (>= 0))+  shrink (NonNegative x) = [ NonNegative x' | x' <- shrink x , x' >= 0 ]++--------------------------------------------------------------------------+-- | @NonPositive x@: guarantees that @x \<= 0@.+newtype NonPositive a = NonPositive {getNonPositive :: a}+ deriving ( Eq, Ord, Show, Read+#ifndef NO_NEWTYPE_DERIVING+          , Enum+#endif+#ifndef NO_TYPEABLE+          , Typeable+#endif+          )++instance Functor NonPositive where+  fmap f (NonPositive x) = NonPositive (f x)++instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonPositive a) where+  arbitrary = fmap NonPositive (arbitrary `suchThat` (<= 0))+  shrink (NonPositive x) = [ NonPositive 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+#ifndef NO_TYPEABLE+          , Typeable+#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+#ifndef NO_TYPEABLE+          , Typeable+#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+#ifndef NO_TYPEABLE+          , Typeable+#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++--------------------------------------------------------------------------+-- | @NoShrink x@: no shrinking+newtype NoShrink a = NoShrink {getNoShrink :: a}+ deriving ( Eq, Ord, Show, Read+#ifndef NO_NEWTYPE_DERIVING+          , Num, Integral, Real, Enum, Ix+#endif+#ifndef NO_TYPEABLE+          , Typeable+#endif+          )++instance Functor NoShrink where+  fmap f (NoShrink x) = NoShrink (f x)++instance Arbitrary a => Arbitrary (NoShrink a) where+  arbitrary = fmap NoShrink arbitrary++--------------------------------------------------------------------------+-- | @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+#ifndef NO_TYPEABLE+          , Typeable+#endif+           )++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+#ifndef NO_TYPEABLE+          , Typeable+#endif+           )++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+#ifndef NO_TYPEABLE+          , Typeable+#endif+           )++instance Arbitrary PrintableString where+  arbitrary = PrintableString `fmap` listOf arbitraryPrintableChar+  shrink (PrintableString xs) = PrintableString `fmap` shrink xs++-- the end.
+ src/Test/QuickCheck/Monadic.hs view
@@ -0,0 +1,368 @@+{-# LANGUAGE CPP #-}+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Safe #-}+#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 \"<http://www.cse.chalmers.se/~rjmh/Papers/QuickCheckST.ps Testing Monadic Code with QuickCheck>\".+-}+module Test.QuickCheck.Monadic (+  -- * Property monad+    PropertyM(..)++  -- * Monadic specification combinators+  , run+  , assert+  , assertWith+  , pre+  , wp+  , pick+  , forAllM+  , monitor+  , stop++  -- * Run functions+  , monadic+  , monadic'+  , monadicIO+#ifndef NO_ST_MONAD+  , monadicST+  , runSTGen+#endif++  -- * Exceptions++#ifndef NO_EXCEPTIONS+  , assertException+  , assertExceptionIO+#ifndef NO_DEEPSEQ+  , assertDeepException+  , assertDeepExceptionIO+#endif+#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++#ifndef NO_DEEPSEQ+import Control.DeepSeq+#endif++#ifndef NO_EXCEPTIONS+import qualified Control.Exception as E+#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++#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"++-- | Like 'assert' but allows caller to specify an explicit message to show on failure.+--+-- __Example:__+--+-- @+-- do+--   assertWith True  "My first predicate."+--   assertWith False "My other predicate."+--   ...+-- @+--+-- @+-- Assertion failed (after 2 tests):+--     Passed: My first predicate+--     Failed: My other predicate+-- @+assertWith :: Monad m => Bool -> String -> PropertyM m ()+assertWith condition msg = do+    let prefix = if condition then "Passed: " else "Failed: "+    monitor $ counterexample $ prefix ++ msg+    assert condition++-- 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 <https://en.wikipedia.org/wiki/Hoare_logic Hoare triple>+--+-- > {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'.+-- __Note__: values generated by 'pick' do not shrink.+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 <https://en.wikipedia.org/wiki/Predicate_transformer_semantics#Weakest_preconditions weakest precondition>+--+-- > 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++-- | Quantification in monadic properties to 'pick', with a notation similar to+-- 'forAll'. __Note__: values generated by 'forAllM' do not shrink.++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++-- Exceptions+++#ifndef NO_EXCEPTIONS++-- | Evaluate the value to Weak Head Normal Form (WHNF) and fail if it does not result in+-- an expected exception being thrown.+assertException ::+     E.Exception exc+  => (exc -> Bool) -- ^ Return `True` if that is the exception that was expected+  -> a -- ^ Value that should result in an exception, when evaluated to WHNF+  -> Property+assertException isExc value = assertExceptionIO isExc (return value)+++-- | Make sure that a specific exception is thrown during an IO action. The result is+-- evaluated to WHNF.+assertExceptionIO ::+     E.Exception exc+  => (exc -> Bool) -- ^ Return `True` if that is the exception that was expected+  -> IO a -- ^ An action that should throw the expected exception+  -> Property+assertExceptionIO isExc action =+  monadicIO $ do+    hasFailed <-+      run+        (E.catch+           (do res <- action+               res `seq` return False)+           (return . isExc))+    assert hasFailed++#ifndef NO_DEEPSEQ++-- | Same as `assertException`, but evaluate the value to Normal Form (NF) and fail if it+-- does not result in an expected exception being thrown.+assertDeepException ::+     (NFData a, E.Exception exc)+  => (exc -> Bool) -- ^ Return True if that is the exception that was expected+  -> a -- ^ Value that should result in an exception, when fully evaluated to NF+  -> Property+assertDeepException isExc value = assertException isExc (rnf value)++-- | Make sure that a specific exception is thrown during an IO action. The result is+-- evaluated to NF.+assertDeepExceptionIO ::+     (NFData a, E.Exception exc)+  => (exc -> Bool) -- ^ Return True if that is the exception that was expected+  -> IO a -- ^ An action that should throw the expected exception+  -> Property+assertDeepExceptionIO isExc action = assertExceptionIO isExc (fmap rnf action)++#endif+#endif++--------------------------------------------------------------------------+-- the end.
+ src/Test/QuickCheck/Monoids.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Safe #-}++module Test.QuickCheck.Monoids+  ( Every (..)+  , Some (..)+  ) where++#ifndef NO_SEMIGROUP+import Data.List.NonEmpty as NonEmpty+import Data.Semigroup (Semigroup (..))+#else+import Data.Monoid (Monoid (..))+#endif+import Test.QuickCheck.Property++-- | Conjunction monoid built with `.&&.`.+--+-- Use `property @Every` as an accessor which doesn't leak+-- existential variables.+--+-- Note: monoid laws are satisfied up to 'Test.QuickCheck.isSuccess' unless one+-- is using `checkCoverage`.+--+#ifndef NO_EXISTENTIAL_FIELD_SELECTORS+data Every = forall p. Testable p => Every { getEvery :: p }+#else+data Every = forall p. Testable p => Every p+#endif++instance Testable Every where+    property (Every p) = property p++#ifndef NO_SEMIGROUP+instance Semigroup Every where+    Every p <> Every p' = Every (p .&&. p')+    sconcat = Every . conjoin . NonEmpty.toList++instance Monoid Every where+    mempty = Every True+    mappend = (<>)+    mconcat = Every . conjoin+#else+instance Monoid Every where+    mempty = Every True+    mappend (Every p) (Every p') = Every (p .&&. p')+    mconcat = Every . conjoin+#endif+++-- | Disjunction monoid built with `.||.`.+--+-- Use `property @Some` as an accessor which doesn't leak+-- existential variables.+--+-- Note: monoid laws are satisfied up to 'Test.QuickCheck.isSuccess' unless one+-- is using `checkCoverage`.+--+#ifndef NO_EXISTENTIAL_FIELD_SELECTORS+data Some = forall p. Testable p => Some { getSome :: p }+#else+data Some = forall p. Testable p => Some p+#endif++instance Testable Some where+    property (Some p) = property p++#ifndef NO_SEMIGROUP+instance Semigroup Some where+    Some p <> Some p' = Some (p .||. p')+    sconcat = Some . disjoin . NonEmpty.toList++instance Monoid Some where+    mempty = Some False+    mappend = (<>)+    mconcat = Some . disjoin+#else+instance Monoid Some where+    mempty = Some False+    mappend (Some p) (Some p') = Some (p .||. p')+    mconcat = Some . disjoin+#endif
+ src/Test/QuickCheck/Poly.hs view
@@ -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.
+ src/Test/QuickCheck/Property.hs view
@@ -0,0 +1,1099 @@+{-# OPTIONS_HADDOCK hide #-}+-- | Combinators for constructing properties.+{-# LANGUAGE CPP #-}+#ifndef NO_TYPEABLE+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+#endif+#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( State(terminal, numSuccessTests, numDiscardedTests, maxSuccessTests, numSuccessShrinks, numTryShrinks, numTotTryShrinks), Confidence(..), TestProgress(..) )++#ifndef NO_TIMEOUT+import System.Timeout(timeout)+#endif+import Data.Maybe+import Control.Applicative+#if defined(MIN_VERSION_base)+import Control.Exception (displayException)+#endif+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+#ifndef NO_TYPEABLE+import Data.Typeable (Typeable, cast)+#endif+import Data.Maybe++--------------------------------------------------------------------------+-- 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 }+#ifndef NO_TYPEABLE+  deriving (Typeable)+#endif++-- | The class of properties, i.e., types which QuickCheck knows how to test.+-- Typically a property will be a function returning 'Bool' or 'Property'.+class Testable prop where+  -- | Convert the thing to a property.+  property :: prop -> Property++  -- | Optional; used internally in order to improve shrinking.+  -- Tests a property but also quantifies over an extra value+  -- (with a custom shrink and show function).+  -- The 'Testable' instance for functions defines+  -- @propertyForAllShrinkShow@ in a way that improves shrinking.+  propertyForAllShrinkShow :: Gen a -> (a -> [a]) -> (a -> [String]) -> (a -> prop) -> Property+  propertyForAllShrinkShow gen shr shw f =+    forAllShrinkBlind gen shr $+      \x -> foldr counterexample (property (f x)) (shw x)++-- | If a property returns 'Discard', the current test case is discarded,+-- the same as if a precondition was false.+--+-- An example is the definition of '==>':+--+-- > (==>) :: Testable prop => Bool -> prop -> Property+-- > False ==> _ = property Discard+-- > True  ==> p = property p+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 prop => Testable (Maybe prop) where+  property = property . liftMaybe+    where+      -- See comment for liftUnit above+      liftMaybe Nothing = property Discard+      liftMaybe (Just prop) = property prop++instance Testable Bool where+  property = property . liftBool++instance Testable Result where+  property = MkProperty . return . MkProp . protectResults . return++instance Testable Prop where+  property p = MkProperty . return . protectProp $ p++instance Testable prop => Testable (Gen prop) where+  property mp = MkProperty $ do p <- mp; unProperty (property p)++instance Testable Property where+  property (MkProperty mp) = MkProperty (fmap protectProp mp)++-- | 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@, or use 'idempotentIOProperty' if that is safe.+ioProperty :: Testable prop => IO prop -> Property+ioProperty prop = idempotentIOProperty (fmap noShrinking prop)++-- | Do I/O inside a property.+--+-- Warning: during shrinking, the I/O may not always be re-executed.+-- Instead, the I/O may be executed once and then its result retained.+-- If this is not acceptable, use 'ioProperty' instead.+idempotentIOProperty :: Testable prop => IO prop -> Property+idempotentIOProperty =+  MkProperty . fmap (MkProp . ioRose . fmap unProp) .+  promote . fmap (unProperty . property)++instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where+  property f =+    propertyForAllShrinkShow arbitrary shrink (return . show) f+  propertyForAllShrinkShow gen shr shw f =+    -- gen :: Gen b, shr :: b -> [b], f :: b -> a -> prop+    -- Idea: Generate and shrink (b, a) as a pair+    propertyForAllShrinkShow+      (liftM2 (,) gen arbitrary)+      (liftShrink2 shr shrink)+      (\(x, y) -> shw x ++ [show y])+      (uncurry 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 x = MkRose x []+  -- f must be total+  (<*>) = liftM2 ($)++instance Monad Rose where+  return = pure+  -- 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 the top level of a 'Prop' in an exception handler.+protectProp :: Prop -> Prop+protectProp (MkProp r) = MkProp (IORose . protectRose . return $ r)++-- | 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++#ifndef NO_TYPEABLE+data Witness = forall a. (Typeable a, Show a) => Wit a++instance Show Witness where+  show (Wit a) = show a++coerceWitness :: Typeable a => Witness -> a+coerceWitness (Wit a) = case cast a of+  Nothing -> error $ "Can't coerceWitness " ++ show a+  Just a -> a++castWitness :: Typeable a => Witness -> Maybe a+castWitness (Wit a) = cast a++#define WITNESSES(a) , theWitnesses a+#else+#define WITNESSES(a)+#endif++-- | 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+  , maybeCheckCoverage  :: Maybe Confidence+    -- ^ required coverage confidence+  , maybeDiscardedRatio :: Maybe Int+    -- ^ maximum number of discarded tests per successful test+  , maybeMaxShrinks     :: Maybe Int+    -- ^ maximum number of shrinks+  , maybeMaxTestSize    :: Maybe Int+    -- ^ maximum test size+  , labels              :: [String]+    -- ^ test case labels+  , classes             :: [(String, Bool)]+    -- ^ test case classes+  , tables              :: [(String, String)]+    -- ^ test case tables+  , requiredCoverage    :: [(Maybe String, String, Double)]+    -- ^ required coverage+  , callbacks           :: [Callback]+    -- ^ the callbacks for this test case+  , testCase            :: [String]+    -- ^ the generated test case+  WITNESSES(:: [Witness])+  }++exception :: String -> AnException -> Result+exception msg err+  | isDiscard err = rejected+  | otherwise = failed{ reason = formatException msg err,+                        theException = Just err }++formatException :: String -> AnException -> String+#if defined(MIN_VERSION_base)+formatException msg err = msg ++ ":" ++ format (displayException err)+#else+formatException msg err = msg ++ ":" ++ format (show err)+#endif+  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               = False+      , maybeNumTests       = Nothing+      , maybeCheckCoverage  = Nothing+      , maybeDiscardedRatio = Nothing+      , maybeMaxShrinks     = Nothing+      , maybeMaxTestSize    = Nothing+      , labels              = []+      , classes             = []+      , tables              = []+      , requiredCoverage    = []+      , callbacks           = []+      , testCase            = []+      WITNESSES(= [])+      }++--------------------------------------------------------------------------+-- ** Lifting and mapping functions++liftBool :: Bool -> Result+liftBool True = succeeded+liftBool False = failed { reason = "Falsified" }++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++-- | Adjust the test case size for a property, by transforming it with the given+-- function.+mapSize :: Testable prop => (Int -> Int) -> prop -> Property+mapSize f = property . scale f . unProperty . property++-- | 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.+-- Only quantification /inside/ the call to 'noShrinking' is affected.+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 ()++-- | Performs an IO action every time a property is tested, after every test.+-- The IO action is allowed to depend on @TestProgress@, which contains information+-- regarding how testing is progressing.+--+-- Note: QC invokes callbacks before the internal state has been updated to reflect the+-- most recent test. The means that e.g. @currentPassed@ will, after the first test has+-- been executed, still show 0.+withProgress :: Testable prop => (TestProgress -> IO ()) -> prop -> Property+withProgress m =+  callback $ PostTest NotCounterexample $ \st _r ->+    let tp = TestProgress { currentPassed        = numSuccessTests st+                          , currentDiscarded     = numDiscardedTests st+                          , maxTests             = maxSuccessTests st+                          , currentShrinks       = numSuccessShrinks st+                          , currentFailedShrinks = numTryShrinks st+                          , currentTotalShrinks  = numTotTryShrinks st+                          }+    in m tp++-- | Prints out the generated test case every time the property is tested.+-- Only variables quantified over /inside/ the 'verbose' are printed.+--+-- Note: for technical reasons, the test case is printed out /after/+-- the property is tested. To debug a property that goes into an+-- infinite loop, use 'within' to add a timeout instead.+verbose :: Testable prop => prop -> Property+verbose = mapResult (\res -> res { callbacks = newCallback (callbacks res):callbacks res })+  where newCallback cbs =+          PostTest Counterexample $ \st res -> do+            putLine (terminal st) (status res ++ ":")+            sequence_ [ f st res | PostFinalFailure Counterexample f <- cbs ]+            putLine (terminal st) ""+        status MkResult{ok = Just True} = "Passed"+        status MkResult{ok = Just False} = "Failed"+        status MkResult{ok = Nothing} = "Skipped (precondition false)"++-- | Prints out the generated test case every time the property fails, including during shrinking.+-- Only variables quantified over /inside/ the 'verboseShrinking' are printed.+--+-- Note: for technical reasons, the test case is printed out /after/+-- the property is tested. To debug a property that goes into an+-- infinite loop, use 'within' to add a timeout instead.+verboseShrinking :: Testable prop => prop -> Property+verboseShrinking = mapResult (\res -> res { callbacks = newCallback (callbacks res):callbacks res })+  where newCallback cbs =+          PostTest Counterexample $ \st res ->+            when (ok res == Just False) $ do+              putLine (terminal st) "Failed:"+              sequence_ [ f st res | PostFinalFailure Counterexample f <- cbs ]+              putLine (terminal st) ""++-- | 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.+{-# DEPRECATED withMaxSuccess "Use withNumTests instead" #-}+withMaxSuccess :: Testable prop => Int -> prop -> Property+withMaxSuccess = withNumTests++-- | Configures how many times a property will be tested.+--+-- For example,+--+-- > quickCheck (withNumTests 1000 p)+--+-- will test @p@ up to 1000 times.+withNumTests :: Testable prop => Int -> prop -> Property+withNumTests n = n `seq` mapTotalResult (\res -> res{ maybeNumTests = Just n })++-- | Configures how many times a property is allowed to be discarded before failing.+--+-- For example,+--+-- > quickCheck (withDiscardRatio 10 p)+--+-- will allow @p@ to fail up to 10 times per successful test.+withDiscardRatio :: Testable prop => Int -> prop -> Property+withDiscardRatio n = n `seq` mapTotalResult (\res -> res{ maybeDiscardedRatio = Just n })++-- | Configure the maximum number of times a property will be shrunk.+--+-- For example,+--+-- > quickCheck (withMaxShrinks 100 p)+--+-- will cause @p@ to only attempt 100 shrinks on failure.+withMaxShrinks :: Testable prop => Int -> prop -> Property+withMaxShrinks n = n `seq` mapTotalResult (\res -> res{ maybeMaxShrinks = Just n })++-- | Configure the maximum size a property will be tested at.+withMaxSize :: Testable prop => Int -> prop -> Property+withMaxSize n = n `seq` mapTotalResult (\res -> res{ maybeMaxTestSize = Just n })++#ifndef NO_TYPEABLE+-- | Return a value in the 'Test.QuickCheck.witnesses' field of the 'Result'+-- returned by 'Test.QuickCheck.quickCheckResult'. Witnesses are returned+-- outer-most first.+--+-- In ghci, for example:+--+-- >>> [Wit x] <- fmap witnesses . quickCheckResult $ \ x -> witness x $ x == (0 :: Int)+-- *** Failed! Falsified (after 2 tests):+-- 1+-- >>> x+-- 1+-- >>> :t x+-- x :: Int+witness :: (Typeable a, Show a, Testable prop) => a -> prop -> Property+witness a = a `seq` mapTotalResult (\res -> res{ theWitnesses = Wit a : theWitnesses res })+#endif++-- | Check that all coverage requirements defined by 'cover' and 'coverTable'+-- are met, using a statistically sound test, and fail if they are not met.+--+-- Ordinarily, a failed coverage check does not cause the property to fail.+-- This is because the coverage requirement is not tested in a statistically+-- sound way. If you use 'cover' to express that a certain value must appear 20%+-- of the time, QuickCheck will warn you if the value only appears in 19 out of+-- 100 test cases - but since the coverage varies randomly, you may have just+-- been unlucky, and there may not be any real problem with your test+-- generation.+--+-- When you use 'checkCoverage', QuickCheck uses a statistical test to account+-- for the role of luck in coverage failures. It will run as many tests as+-- needed until it is sure about whether the coverage requirements are met. If a+-- coverage requirement is not met, the property fails.+--+-- Example:+--+-- > quickCheck (checkCoverage prop_foo)+checkCoverage :: Testable prop => prop -> Property+checkCoverage = checkCoverageWith stdConfidence++-- | Check coverage requirements using a custom confidence level.+-- See 'stdConfidence'.+--+-- An example of making the statistical test less stringent in order to improve+-- performance:+--+-- > quickCheck (checkCoverageWith stdConfidence{certainty = 10^6} prop_foo)+checkCoverageWith :: Testable prop => Confidence -> prop -> Property+checkCoverageWith confidence =+  certainty confidence `seq`+  tolerance confidence `seq`+  mapTotalResult (\res -> res{ maybeCheckCoverage = Just confidence })++-- | The standard parameters used by 'checkCoverage': @certainty = 10^9@,+-- @tolerance = 0.9@. See 'Confidence' for the meaning of the parameters.+stdConfidence :: Confidence+stdConfidence =+  Confidence {+    certainty = 10^9,+    tolerance = 0.9 }++-- | Attaches a label to a test case. 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+-- ...+--+-- Each use of 'label' in your property results in a separate+-- table of test case distribution in the output. If this is+-- not what you want, use 'tabulate'.+label :: Testable prop => String -> prop -> Property+label s =+#ifndef NO_DEEPSEQ+  s `deepseq`+#endif+  mapTotalResult $+    \res -> res { labels = s:labels res }++-- | Attaches a label to a test case. 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+-- ...+--+-- Each use of 'collect' in your property results in a separate+-- table of test case distribution in the output. If this is+-- not what you want, use 'tabulate'.+collect :: (Show a, Testable prop) => a -> prop -> Property+collect x = label (show x)++-- | Reports 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 =+#ifndef NO_DEEPSEQ+  s `deepseq`+#endif+  b `seq`+  mapTotalResult $+    \res -> res { classes = (s, b):classes res }++-- | 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.+--+-- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but+-- the property does /not/ fail. To make the property fail, use 'checkCoverage'.+--+-- For example:+--+-- > prop_sorted_sort :: [Int] -> Property+-- > prop_sorted_sort xs =+-- >   sorted xs ==>+-- >   cover 50 (length xs > 1) "non-trivial" $+-- >   sort xs === xs+--+-- >>> quickCheck prop_sorted_sort+-- +++ OK, passed 100 tests; 135 discarded (26% non-trivial).+-- <BLANKLINE>+-- Only 26% non-trivial, but expected 50%+cover :: Testable prop =>+         Double -- ^ The required percentage (0-100) of test cases.+      -> Bool   -- ^ @True@ if the test case belongs to the class.+      -> String -- ^ Label for the test case class.+      -> prop -> Property+cover p x s = mapTotalResult f . classify x s+  where+    f res = res { requiredCoverage = (Nothing, s, p/100):requiredCoverage res }++-- | Collects information about test case distribution into a table.+-- The arguments to 'tabulate' are the table's name and a list of values+-- associated with the current test case. After testing, QuickCheck prints the+-- frequency of all collected values. The frequencies are expressed as a+-- percentage of the total number of values collected.+--+-- You should prefer 'tabulate' to 'label' when each test case is associated+-- with a varying number of values. Here is a (not terribly useful) example,+-- where the test data is a list of integers and we record all values that+-- occur in the list:+--+-- > prop_sorted_sort :: [Int] -> Property+-- > prop_sorted_sort xs =+-- >   sorted xs ==>+-- >   tabulate "List elements" (map show xs) $+-- >   sort xs === xs+--+-- >>> quickCheck prop_sorted_sort+-- +++ OK, passed 100 tests; 1684 discarded.+-- <BLANKLINE>+-- List elements (109 in total):+--  3.7% 0+--  3.7% 17+--  3.7% 2+--  3.7% 6+--  2.8% -6+--  2.8% -7+--+-- Here is a more useful example. We are testing a chatroom, where the user can+-- log in, log out, or send a message:+--+-- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show)+-- > instance Arbitrary Command where ...+--+-- There are some restrictions on command sequences; for example, the user must+-- log in before doing anything else. The function @valid :: [Command] -> Bool@+-- checks that a command sequence is allowed. Our property then has the form:+--+-- > prop_chatroom :: [Command] -> Property+-- > prop_chatroom cmds =+-- >   valid cmds ==>+-- >     ...+--+-- The use of '==>' may skew test case distribution. We use 'collect' to see the+-- length of the command sequences, and 'tabulate' to get the frequencies of the+-- individual commands:+--+-- > prop_chatroom :: [Command] -> Property+-- > prop_chatroom cmds =+-- >   wellFormed cmds LoggedOut ==>+-- >   'collect' (length cmds) $+-- >   'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $+-- >     ...+--+-- >>> quickCheckWith stdArgs{maxDiscardRatio = 1000} prop_chatroom+-- +++ OK, passed 100 tests; 2775 discarded:+-- 60% 0+-- 20% 1+-- 15% 2+--  3% 3+--  1% 4+--  1% 5+-- <BLANKLINE>+-- Commands (68 in total):+-- 62% LogIn+-- 22% SendMessage+-- 16% LogOut+tabulate :: Testable prop => String -> [String] -> prop -> Property+tabulate key values =+#ifndef NO_DEEPSEQ+  key `deepseq` values `deepseq`+#endif+  mapTotalResult $+    \res -> res { tables = [(key, value) | value <- values] ++ tables res }++-- | Checks that the values in a given @table@ appear a certain proportion of+-- the time. A call to 'coverTable' @table@ @[(x1, p1), ..., (xn, pn)]@ asserts+-- that of the values in @table@, @x1@ should appear at least @p1@ percent of+-- the time that @table@ appears, @x2@ at least @p2@ percent of the time that+-- @table@ appears, and so on.+--+-- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but+-- the property does /not/ fail. To make the property fail, use 'checkCoverage'.+--+-- Continuing the example from the 'tabulate' combinator...+--+-- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show)+-- > prop_chatroom :: [Command] -> Property+-- > prop_chatroom cmds =+-- >   wellFormed cmds LoggedOut ==>+-- >   'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $+-- >     ...+--+-- ...we can add a coverage requirement as follows, which checks that @LogIn@,+-- @LogOut@ and @SendMessage@ each occur at least 25% of the time:+--+-- > prop_chatroom :: [Command] -> Property+-- > prop_chatroom cmds =+-- >   wellFormed cmds LoggedOut ==>+-- >   coverTable "Commands" [("LogIn", 25), ("LogOut", 25), ("SendMessage", 25)] $+-- >   'tabulate' "Commands" (map (show . 'Data.Data.toConstr') cmds) $+-- >     ... property goes here ...+--+-- >>> quickCheck prop_chatroom+-- +++ OK, passed 100 tests; 2909 discarded:+-- 56% 0+-- 17% 1+-- 10% 2+--  6% 3+--  5% 4+--  3% 5+--  3% 7+-- <BLANKLINE>+-- Commands (111 in total):+-- 51.4% LogIn+-- 30.6% SendMessage+-- 18.0% LogOut+-- <BLANKLINE>+-- Table 'Commands' had only 18.0% LogOut, but expected 25.0%+coverTable :: Testable prop =>+  String -> [(String, Double)] -> prop -> Property+coverTable table xs =+#ifndef NO_DEEPSEQ+  table `deepseq` xs `deepseq`+#endif+  mapTotalResult $+    \res -> res { requiredCoverage = ys ++ requiredCoverage res }+  where+    ys = [(Just table, x, p/100) | (x, p) <- xs]++-- | 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. Note that using implication carelessly can+-- severely skew test case distribution: consider using 'cover' to make sure+-- that your test data is still good quality.+(==>) :: 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.+--+-- Note: if the property times out, variables quantified inside the+-- `within` will not be printed. Therefore, you should use `within`+-- only in the body of your property.+--+-- Good: @prop_foo a b c = within 1000000 ...@+--+-- Bad: @prop_foo = within 1000000 $ \\a b c -> ...@+--+-- Bad: @prop_foo a b c = ...; main = quickCheck (within 1000000 prop_foo)@+within :: Testable prop => Int -> prop -> Property+within n = onTimeout+   (failed { reason = "Timeout of " ++ show n ++ " microseconds exceeded." })+   n++-- | Discards the test case if it does not complete within the given+-- number of microseconds. This can be useful when testing algorithms+-- that have pathological cases where they run extremely slowly.+discardAfter :: Testable prop => Int -> prop -> Property+discardAfter n = onTimeout+   (rejected { reason = "Timeout of " ++ show n ++ " microseconds exceeded." })+   n++onTimeout :: Testable prop => Result -> Int -> prop -> Property+onTimeout timeoutResult n = mapRoseResult f+  where+    f rose = ioRose $ do+      let orError :: IO (Maybe a) -> a -> IO a+          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))+#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 with an explicitly given show function.+forAllShow :: Testable prop+           => Gen a -> (a -> String) -> (a -> prop) -> Property+forAllShow gen shower pf = forAllShrinkShow gen (\_ -> []) shower pf++-- | Like 'forAll', but without printing the generated value.+forAllBlind :: Testable prop+           => Gen a -> (a -> prop) -> Property+forAllBlind gen pf = forAllShrinkBlind 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 = forAllShrinkShow gen shrinker show++-- | Like 'forAllShrink', but with an explicitly given show function.+forAllShrinkShow+  :: Testable prop+  => Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property+forAllShrinkShow gen shrinker shower pf =+  forAllShrinkBlind gen shrinker (\x -> counterexample (shower x) (pf x))++-- | Like 'forAllShrink', but without printing the generated value.+forAllShrinkBlind+  :: Testable prop+  => Gen a -> (a -> [a]) -> (a -> prop) -> Property+forAllShrinkBlind gen shrinker pf =+  MkProperty $+  gen >>= \x ->+    unProperty $+    shrinking shrinker x pf++-- | 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 =+  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 =+  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 . addCallbacksAndCoverage result . k) ps)+      Just False -> return rose+      Nothing -> do+        rose2@(MkRose result2 _) <- reduceRose (conj (addCallbacksAndCoverage 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++  addCallbacksAndCoverage result r =+    r { callbacks = callbacks result ++ callbacks r,+        requiredCoverage = requiredCoverage result ++ requiredCoverage r }+  addLabels result r =+    r { labels = labels result ++ labels r,+        classes = classes result ++ classes r,+        tables = tables result ++ tables 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 =+  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 False -> do+           result2 <- q+           return $+             case ok result2 of+               _ | not (expect result2) -> expectFailureError+               Just True -> addCoverage result1 result2+               Just False ->+                 MkResult {+                   ok = Just False,+                   expect = True,+                   reason = sep (reason result1) (reason result2),+                   theException = theException result1 `mplus` theException result2,+                   -- The following few fields are not important because the+                   -- test case has failed anyway+                   abort = False,+                   maybeNumTests = Nothing,+                   maybeCheckCoverage = Nothing,+                   maybeDiscardedRatio = Nothing,+                   maybeMaxShrinks = Nothing,+                   maybeMaxTestSize = Nothing,+                   labels = [],+                   classes = [],+                   tables = [],+                   requiredCoverage = [],+                   callbacks =+                     callbacks result1 +++                     [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] +++                     callbacks result2,+                   testCase =+                     testCase result1 +++                     testCase result2+                   WITNESSES(= theWitnesses result1 ++ theWitnesses result2)+                   }+               Nothing -> result2+         -- The "obvious" semantics of .||. has:+         --   discard .||. true = true+         --   discard .||. discard = discard+         -- but this implementation gives discard .||. true = discard.+         -- This is reasonable because evaluating result2 in the case+         -- that result1 discards is just busy-work - it won't ever+         -- cause the property to fail. On the other hand, discarding+         -- instead of returning true causes us to execute one more+         -- test case - but assuming that preconditions are cheap to+         -- evaluate, this is no more work than evaluating result2+         -- would be, while (unlike evaluating result2) it might catch+         -- a bug.+         _ -> return result1++  expectFailureError = failed { reason = "expectFailure may not occur inside a disjunction" }+  sep [] s = s+  sep s [] = s+  sep s s' = s ++ ", " ++ s'++  addCoverage result r =+    r { requiredCoverage = requiredCoverage result ++ requiredCoverage r }++-- | Like '==', but prints a counterexample when it fails.+infix 4 ===+(===) :: (Eq a, Show a) => a -> a -> Property+x === y =+  counterexample (show x ++ interpret res ++ show y) res+  where+    res = x == y+    interpret True  = " == "+    interpret False = " /= "++-- | Like '/=', but prints a counterexample when it fails.+infix 4 =/=+(=/=) :: (Eq a, Show a) => a -> a -> Property+x =/= y =+  counterexample (show x ++ interpret res ++ show y) res+  where+    res = x /= y+    interpret True  = " /= "+    interpret False = " == "++#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.
+ src/Test/QuickCheck/Random.hs view
@@ -0,0 +1,131 @@+{-# OPTIONS_HADDOCK hide #-}+-- | 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++import System.Random+#ifndef NO_SPLITMIX+import System.Random.SplitMix+#endif+import Data.Bits++-- | The "standard" QuickCheck random number generator.+-- A wrapper around either 'SMGen' on GHC, or 'StdGen'+-- on other Haskell systems.+#ifdef NO_SPLITMIX+newtype QCGen = QCGen StdGen+#else+newtype QCGen = QCGen SMGen+#endif++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]++splitImpl :: QCGen -> (QCGen, QCGen)+#ifdef NO_SPLITMIX+splitImpl (QCGen g) =+    case split g of+      (g1, g2) -> (QCGen g1, QCGen g2)+#else+splitImpl (QCGen g) =+    case splitSMGen g of+      (g1, g2) -> (QCGen g1, QCGen g2)+#endif++instance RandomGen QCGen where+#if !MIN_VERSION_random(1,3,0)+  split = splitImpl+#endif+#ifdef NO_SPLITMIX+  genRange (QCGen g) = genRange g+  next = wrapQCGen next+#else+  genRange _ = (minBound, maxBound)+  next = wrapQCGen nextInt++#ifndef OLD_RANDOM+  genWord8 = wrapQCGen genWord8+  genWord16 = wrapQCGen genWord16+  genWord32 = wrapQCGen genWord32+  genWord64 = wrapQCGen genWord64+  genWord32R r = wrapQCGen (genWord32R r)+  genWord64R r = wrapQCGen (genWord64R r)+#if MIN_VERSION_random(1,3,0)+  genShortByteString n = wrapQCGen (uniformShortByteString n)+#endif+#endif+#endif++#if MIN_VERSION_random(1,3,0)+instance SplitGen QCGen where+  splitGen = splitImpl+#endif++{-# INLINE wrapQCGen #-}+#ifdef NO_SPLITMIX+wrapQCGen :: (StdGen -> (a, StdGen)) -> (QCGen -> (a, QCGen))+#else+wrapQCGen :: (SMGen -> (a, SMGen)) -> (QCGen -> (a, QCGen))+#endif+wrapQCGen f (QCGen g) =+  case f g of+    (x, g') -> (x, QCGen g')++newQCGen :: IO QCGen+#ifdef NO_SPLITMIX+newQCGen = fmap QCGen newStdGen+#else+newQCGen = fmap QCGen newSMGen+#endif++mkQCGen :: Int -> QCGen+#ifdef NO_SPLITMIX+mkQCGen n = QCGen (mkStdGen n)+#else+mkQCGen n = QCGen (mkSMGen (fromIntegral n))+#endif++-- Parameterised in order to make this code testable.+class Splittable a where+  left, right :: a -> a++instance Splittable QCGen where+  left = fst . splitImpl+  right = snd . splitImpl++-- The logic behind 'variant'. Given a random number seed, and an integer, uses+-- splitting to transform the seed according to the integer. We use a+-- prefix-free code so that calls to integerVariant n g for different values of+-- n are guaranteed to return independent seeds.+{-# INLINE integerVariant #-}+integerVariant :: Splittable a => Integer -> a -> a+integerVariant n g+  -- Use one bit to encode the sign, then use Elias gamma coding+  -- (https://en.wikipedia.org/wiki/Elias_gamma_coding) to do the rest.+  -- Actually, the first bit encodes whether n >= 1 or not;+  -- this has the advantage that both 0 and 1 get short codes.+  | n >= 1 = gamma n $! left g+  | otherwise = gamma (1-n) $! right g+  where+    gamma n =+      encode k . zeroes k+      where+        k = ilog2 n++        encode (-1) g = g+        encode k g+          | testBit n k =+            encode (k-1) $! right g+          | otherwise =+            encode (k-1) $! left g++        zeroes 0 g = g+        zeroes k g = zeroes (k-1) $! left g++    ilog2 1 = 0+    ilog2 n = 1 + ilog2 (n `div` 2)
+ src/Test/QuickCheck/State.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE CPP #-}+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Safe #-}+#endif+{-# OPTIONS_HADDOCK hide #-}+-- | QuickCheck's internal state. Internal QuickCheck module.+module Test.QuickCheck.State where++import Test.QuickCheck.Text+import Test.QuickCheck.Random+import Data.Map(Map)++--------------------------------------------------------------------------+-- 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+  , coverageConfidence        :: Maybe Confidence+    -- ^ how to compute the size of test cases from+    --   #tests and #discarded tests+  , numTotMaxShrinks          :: !Int+    -- ^ How many shrinks to try before giving up+  , replayStartSize           :: Maybe Int+    -- ^ Size to start at when replaying+  , maxTestSize               :: !Int+    -- ^ Maximum size of test++    -- 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)+    -- ^ counts for each combination of labels (label/collect)+  , classes                   :: !(Map String Int)+    -- ^ counts for each class of test case (classify/cover)+  , tables                    :: !(Map String (Map String Int))+    -- ^ tables collected using tabulate+  , requiredCoverage          :: !(Map (Maybe String, String) Double)+    -- ^ coverage requirements+  , expected                  :: !Bool+    -- ^ indicates the expected result of the property+  , 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 statistical parameters used by 'Test.QuickCheck.checkCoverage'.+data Confidence =+  Confidence {+    certainty :: Integer,+    -- ^ How certain 'Test.QuickCheck.checkCoverage' must be before the property+    -- fails. If the coverage requirement is met, and the certainty parameter is+    -- @n@, then you should get a false positive at most one in @n@ runs of+    -- QuickCheck. The default value is @10^9@.+    --+    -- Lower values will speed up 'Test.QuickCheck.checkCoverage' at the cost of+    -- false positives.+    --+    -- If you are using 'Test.QuickCheck.checkCoverage' as part of a test suite,+    -- you should be careful not to set @certainty@ too low. If you want, say, a+    -- 1% chance of a false positive during a project's lifetime, then+    -- certainty@ should be set to at least @100 * m * n@, where @m@ is the+    -- number of uses of 'Test.QuickCheck.cover' in the test suite, and @n@ is+    -- the number of times you expect the test suite to be run during the+    -- project's lifetime. The default value is chosen to be big enough for most+    -- projects.+    tolerance :: Double+    -- ^ For statistical reasons, 'Test.QuickCheck.checkCoverage' will not+    -- reject coverage levels that are only slightly below the required levels.+    -- If the required level is @p@ then an actual level of @tolerance * p@+    -- will be accepted. The default value is @0.9@.+    --+    -- Lower values will speed up 'Test.QuickCheck.checkCoverage' at the cost of+    -- not detecting minor coverage violations.+    }+  deriving Show++-- | TestProgress, contains information that might be interesting to external+-- libraries, e.g. Tasty. From this it is possible to install your own callbacks+-- that reports e.g. progress.+data TestProgress+  = TestProgress+  { currentPassed        :: Int -- ^ Number of tests passed so far+  , currentDiscarded     :: Int -- ^ Number of discared tests so far+  , maxTests             :: Int -- ^ Number of tests to execute+  , currentShrinks       :: Int -- ^ Number of successful shrinking steps+  , currentFailedShrinks :: Int -- ^ Number of failed shrinking steps since last successful one+  , currentTotalShrinks  :: Int -- ^ Total number of failed shrinking steps+  } deriving Show++--------------------------------------------------------------------------+-- the end.
+ src/Test/QuickCheck/Test.hs view
@@ -0,0 +1,780 @@+{-# OPTIONS_HADDOCK hide #-}+-- | The main test loop.+{-# LANGUAGE CPP #-}+#ifndef NO_TYPEABLE+{-# LANGUAGE DeriveDataTypeable #-}+#endif+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Trustworthy #-}+#endif+module Test.QuickCheck.Test where++--------------------------------------------------------------------------+-- imports++import Control.Applicative+import Test.QuickCheck.Gen+import Test.QuickCheck.Property hiding ( Result( reason, theException, labels, classes, tables ), (.&.) )+import qualified Test.QuickCheck.Property as P+import Test.QuickCheck.Text+import Test.QuickCheck.State hiding (labels, classes, tables, requiredCoverage)+import qualified Test.QuickCheck.State as S+import Test.QuickCheck.Exception+import Test.QuickCheck.Random+#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.Set(Set)+import Data.Map(Map)++import Data.Char+  ( isSpace+  )++import Data.List+  ( sort+  , sortBy+  , group+  , intersperse+  )++import Data.Maybe(fromMaybe, isNothing, catMaybes)+import Data.Ord(comparing)+import Text.Printf(printf)+import Control.Monad+import Data.Bits+import Data.Maybe++#ifndef NO_TYPEABLE+import Data.Typeable (Typeable)+#endif++--------------------------------------------------------------------------+-- 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 do before giving up. Setting this to zero+    --   turns shrinking off.+  }+ deriving ( Show, Read+#ifndef NO_TYPEABLE+  , Typeable+#endif+  )++-- | Result represents the test result+data Result+  -- | A successful test run+  = Success+    { numTests     :: Int+      -- ^ Number of tests performed+    , numDiscarded :: Int+      -- ^ Number of tests skipped+    , labels       :: !(Map [String] Int)+      -- ^ The number of test cases having each combination of labels (see 'label')+    , classes      :: !(Map String Int)+      -- ^ The number of test cases having each class (see 'classify')+    , tables       :: !(Map String (Map String Int))+      -- ^ Data collected by 'tabulate'+    , output       :: String+      -- ^ Printed output+    }+  -- | Given up+  | GaveUp+    { numTests     :: Int+    , numDiscarded :: Int+      -- ^ Number of tests skipped+    , labels       :: !(Map [String] Int)+    , classes      :: !(Map String Int)+    , tables       :: !(Map String (Map String Int))+    , output       :: String+    }+  -- | A failed test run+  | Failure+    { numTests        :: Int+    , numDiscarded    :: Int+      -- ^ Number of tests skipped+    , 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+    , output          :: String+    , failingTestCase :: [String]+      -- ^ The test case which provoked the failure+    , failingLabels   :: [String]+      -- ^ The test case's labels (see 'label')+    , failingClasses  :: Set String+      -- ^ The test case's classes (see 'classify')+#ifndef NO_TYPEABLE+    , witnesses :: [Witness]+      -- ^ The existentially quantified witnesses provided by 'witness'+#endif+    }+  -- | A property that should have failed did not+  | NoExpectedFailure+    { numTests     :: Int+    , numDiscarded :: Int+      -- ^ Number of tests skipped+    , labels       :: !(Map [String] Int)+    , classes      :: !(Map String Int)+    , tables       :: !(Map String (Map String Int))+    , output       :: String+    }+ 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 'System.IO.stdout'.+--+-- By default up to 100 tests are performed, which may not be enough+-- to find all bugs. To run more tests, use 'withNumTests'.+--+-- If you want to get the counterexample as a Haskell value,+-- rather than just printing it, try the+-- <http://hackage.haskell.org/package/quickcheck-with-counterexamples quickcheck-with-counterexamples>+-- package.++quickCheck :: Testable prop => prop -> IO ()+quickCheck p = quickCheckWith stdArgs p++-- | Tests a property, using test arguments, and prints the results to 'System.IO.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 'System.IO.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 'System.IO.stdout'.+quickCheckWithResult :: Testable prop => Args -> prop -> IO Result+quickCheckWithResult a p =+  withState a (\s -> test s (property p))++-- | Re-run a property with the seed and size that failed in a run of 'quickCheckResult'.+recheck :: Testable prop => Result -> prop -> IO ()+recheck res@Failure{} = quickCheckWith stdArgs{ replay = Just (usedSeed res, usedSize res)} . once+recheck _ = error "Can only recheck tests that failed with a counterexample."++withState :: Args -> (State -> IO a) -> IO a+withState a test = (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+                 , coverageConfidence        = Nothing+                 , maxDiscardedRatio         = maxDiscardRatio a+                 , replayStartSize           = snd <$> replay a+                 , maxTestSize               = maxSize a+                 , numTotMaxShrinks          = maxShrinks a+                 , numSuccessTests           = 0+                 , numDiscardedTests         = 0+                 , numRecentlyDiscardedTests = 0+                 , S.labels                  = Map.empty+                 , S.classes                 = Map.empty+                 , S.tables                  = Map.empty+                 , S.requiredCoverage        = Map.empty+                 , expected                  = True+                 , randomSeed                = rnd+                 , numSuccessShrinks         = 0+                 , numTryShrinks             = 0+                 , numTotTryShrinks          = 0+                 }++computeSize :: State -> Int+computeSize MkState{replayStartSize = Just s,numSuccessTests = 0,numRecentlyDiscardedTests=0} = s+-- NOTE: Beware that changing this means you also have to change `prop_discardCoverage` as that currently relies+-- on the sequence produced by this function.+computeSize MkState{maxSuccessTests = ms, maxTestSize = mts, maxDiscardedRatio = md,numSuccessTests=n,numRecentlyDiscardedTests=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` mts + mts <= ms ||+      n >= ms ||+      ms `mod` mts == 0 = (n `mod` mts + d `div` dDenom) `min` mts+    | otherwise =+      ((n `mod` mts) * mts `div` (ms `mod` mts) + d `div` dDenom) `min` mts+  where+    -- The inverse of the rate at which we increase size as a function of discarded tests+    -- if the discard ratio is high we can afford this to be slow, but if the discard ratio+    -- is low we risk bowing out too early+    dDenom+      | md > 0 = (ms * md `div` 3) `clamp` (1, 10)+      | otherwise = 1 -- Doesn't matter because there will be no discards allowed+    n `roundTo` m = (n `div` m) * m++clamp :: Ord a => a -> (a, a) -> a+clamp x (l, h) = max l (min x h)++-- | Tests a property and prints the results and all test cases generated to 'System.IO.stdout'.+-- This is just a convenience function that means the same as @'quickCheck' . 'verbose'@.+--+-- Note: for technical reasons, the test case is printed out /after/+-- the property is tested. To debug a property that goes into an+-- infinite loop, use 'within' to add a timeout instead.+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 'System.IO.stdout'.+-- This is just a convenience function that combines 'quickCheckWith' and 'verbose'.+--+-- Note: for technical reasons, the test case is printed out /after/+-- the property is tested. To debug a property that goes into an+-- infinite loop, use 'within' to add a timeout instead.+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 'System.IO.stdout'.+-- This is just a convenience function that combines 'quickCheckResult' and 'verbose'.+--+-- Note: for technical reasons, the test case is printed out /after/+-- the property is tested. To debug a property that goes into an+-- infinite loop, use 'within' to add a timeout instead.+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 'System.IO.stdout'.+-- This is just a convenience function that combines 'quickCheckWithResult' and 'verbose'.+--+-- Note: for technical reasons, the test case is printed out /after/+-- the property is tested. To debug a property that goes into an+-- infinite loop, use 'within' to add a timeout instead.+verboseCheckWithResult :: Testable prop => Args -> prop -> IO Result+verboseCheckWithResult a p = quickCheckWithResult a (verbose p)++--------------------------------------------------------------------------+-- main test loop++test :: State -> Property -> IO Result+test st prop+  | finishedSuccessfully st         = doneTesting st+  | finishedInsufficientCoverage st = failCoverage st+  | tooManyDiscards st              = giveUp st+  | otherwise                       = runATest st prop++finishedSuccessfully :: State -> Bool+finishedSuccessfully st+  | checkingCoverage st =+      and [ timeToCheckCoverage st+          , coverageKnownSufficient st+          , numSuccessTests st >= maxSuccessTests st+          ]+  | otherwise = numSuccessTests st >= maxSuccessTests st++finishedInsufficientCoverage :: State -> Bool+finishedInsufficientCoverage st =+  and [ checkingCoverage st+      , timeToCheckCoverage st+      , coverageKnownInsufficient st+      ]++tooManyDiscards :: State -> Bool+tooManyDiscards st+  | maxDiscardedRatio st > 0 = numDiscardedTests st `div` maxDiscardedRatio st >= max (numSuccessTests st) (maxSuccessTests st)+  | otherwise = numDiscardedTests st > 0++checkingCoverage :: State -> Bool+checkingCoverage st = isJust (coverageConfidence st)++timeToCheckCoverage :: State -> Bool+timeToCheckCoverage st+ -- This is the time when we would normally finish testing, so lets check+ -- it now to see if we can finish testing already+ | numSuccessTests st == maxSuccessTests st && numRecentlyDiscardedTests st == 0 = True+ -- We are on test 100 * 2^k for k > 0+ | otherwise =+    and [ numSuccessTests st > 0+        , numSuccessTests st `mod` 100 == 0+        , powerOfTwo (numSuccessTests st `div` 100)+        ]+  where powerOfTwo n = n .&. (n - 1) == 0++coverageKnownSufficient :: State -> Bool+coverageKnownSufficient st@MkState{coverageConfidence=Just confidence} =+  and [ sufficientlyCovered confidence tot n p | (_, _, tot, n, p) <- allCoverage st ]+coverageKnownSufficient _ = True++coverageKnownInsufficient :: State -> Bool+coverageKnownInsufficient st@MkState{coverageConfidence=Just confidence} =+  or [ insufficientlyCovered (Just (certainty confidence)) tot n p+     | (_, _, tot, n, p) <- allCoverage st ]+coverageKnownInsufficient _ = False++failCoverage :: State -> IO Result+failCoverage st =+             -- The last test wasn't actually successful, as the coverage failed+             -- also this prevents an off-by-one error in the printing+    runATest st{numSuccessTests = numSuccessTests st - 1}+             $ foldr counterexample (property failed{P.reason = "Insufficient coverage"})+                                    (paragraphs [theLabels, theTables])+    where (theLabels, theTables) = labelsAndTables st++doneTesting :: State -> IO Result+doneTesting st+  | expected st == False = do+      putPart (terminal st)+        ( bold ("*** Failed!")+       ++ " Passed "+       ++ showTestCount st+       ++ " (expected failure)"+        )+      finished NoExpectedFailure+  | otherwise = do+      putPart (terminal st)+        ( "+++ OK, passed "+       ++ showTestCount st+        )+      finished Success+  where+    finished k = do+      success st+      theOutput <- terminalOutput (terminal st)+      return (k (numSuccessTests st) (numDiscardedTests st) (S.labels st) (S.classes st) (S.tables st) theOutput)++giveUp :: State -> IO Result+giveUp st =+  do -- CALLBACK gave_up?+     putPart (terminal st)+       ( bold ("*** Gave up!")+      ++ " Passed only "+      ++ showTestCount st+      ++ " tests"+       )+     success st+     theOutput <- terminalOutput (terminal st)+     return GaveUp{ numTests     = numSuccessTests st+                  , numDiscarded = numDiscardedTests st+                  , labels       = S.labels st+                  , classes      = S.classes st+                  , tables       = S.tables st+                  , output       = theOutput+                  }++showTestCount :: State -> String+showTestCount st = formatTestCount (numSuccessTests st) (numDiscardedTests st)++formatTestCount :: Int -> Int -> String+formatTestCount succeeded discarded =+     number succeeded "test"+  ++ concat [ "; " ++ show discarded ++ " discarded"+            | discarded > 0+            ]++runATest :: State -> Property -> IO Result+runATest st prop =+  do -- CALLBACK before_test+     putTemp (terminal st)+        ( "("+       ++ showTestCount st+       ++ ")"+        )++     let size = computeSize st++     MkRose res ts <- protectRose (reduceRose (unProp (unGen (unProperty prop) rnd1 size)))+     res <- callbackPostTest st res++     let continue :: (State -> IO Result) -> State -> IO Result+         continue break st'+           | abort res = break $ updateState st'+           | otherwise = test (updateState st') prop++         updateState st0 = addNewOptions $ st0{ randomSeed = rnd2 }++         addNewOptions st0 = st0{ maxSuccessTests   = fromMaybe (maxSuccessTests st0) (maybeNumTests res)+                                , maxDiscardedRatio = fromMaybe (maxDiscardedRatio st0) (maybeDiscardedRatio res)+                                , numTotMaxShrinks  = fromMaybe (numTotMaxShrinks st0) (maybeMaxShrinks res)+                                , maxTestSize       = fromMaybe (maxTestSize st0) (maybeMaxTestSize res)+                                , expected          = expect res+                                }++         addCoverageInfo st0 =+           st0{ coverageConfidence = maybeCheckCoverage res `mplus` coverageConfidence st0+              , S.labels = Map.insertWith (+) (P.labels res) 1 (S.labels st0)+              , S.classes = Map.unionWith (+) (S.classes st0)+                                              (Map.fromList [ (s, if b then 1 else 0) | (s, b) <- P.classes res ])+              , S.tables =+                foldr (\(tab, x) -> Map.insertWith (Map.unionWith (+)) tab (Map.singleton x 1))+                  (S.tables st0) (P.tables res)+              , S.requiredCoverage =+                foldr (\(key, value, p) -> Map.insertWith max (key, value) p)+                  (S.requiredCoverage st0) (P.requiredCoverage res)+              }++         stC = addCoverageInfo st++     case res of+       MkResult{ok = Just True} -> -- successful test+         do continue doneTesting+              stC{ numSuccessTests           = numSuccessTests st + 1+                 , numRecentlyDiscardedTests = 0+                 }++       MkResult{ok = Nothing} -> -- discarded test+         do continue giveUp+              -- Don't add coverage info from this test+              st{ numDiscardedTests         = numDiscardedTests st + 1+                , numRecentlyDiscardedTests = numRecentlyDiscardedTests st + 1+                }++       MkResult{ok = Just False} -> -- failed test+         do (numShrinks, totFailed, lastFailed, res) <- foundFailure (addNewOptions stC) res ts+            theOutput <- terminalOutput (terminal stC)+            if not (expect res) then+              return Success{ labels = S.labels stC,+                              classes = S.classes stC,+                              tables = S.tables stC,+                              numTests = numSuccessTests stC+1,+                              numDiscarded = numDiscardedTests stC,+                              output = theOutput }+             else do+              testCase <- mapM showCounterexample (P.testCase res)+              return Failure{ usedSeed        = randomSeed stC -- correct! (this will be split first)+                            , usedSize        = size+                            , numTests        = numSuccessTests stC + 1+                            , numDiscarded    = numDiscardedTests stC+                            , numShrinks      = numShrinks+                            , numShrinkTries  = totFailed+                            , numShrinkFinal  = lastFailed+                            , output          = theOutput+                            , reason          = P.reason res+                            , theException    = P.theException res+                            , failingTestCase = testCase+                            , failingLabels   = P.labels res+                            , failingClasses  = Set.fromList (map fst $ filter snd $ P.classes res)+#ifndef NO_TYPEABLE+                            , witnesses = theWitnesses res+#endif+                            }+ where+  (rnd1,rnd2) = splitImpl (randomSeed st)++failureSummary :: State -> P.Result -> String+failureSummary st res = fst (failureSummaryAndReason st res)++failureReason :: State -> P.Result -> [String]+failureReason st res = snd (failureSummaryAndReason st res)++failureSummaryAndReason :: State -> P.Result -> (String, [String])+failureSummaryAndReason st res = (summary, full)+  where+    summary =+      header +++      short 26 (oneLine theReason ++ " ") +++      count True ++ "..."++    full =+      (header +++       (if isOneLine theReason then theReason ++ " " else "") +++       count False ++ ":"):+      if isOneLine theReason then [] else lines theReason++    theReason = P.reason res++    header =+      if expect res then+        bold "*** Failed! "+      else "+++ OK, failed as expected. "++    count full =+      "(after " ++ number (numSuccessTests st+1) "test" +++      concat [+        " and " +++        show (numSuccessShrinks st) +++        concat [ "." ++ show (numTryShrinks st) | showNumTryShrinks ] +++        " shrink" +++        (if numSuccessShrinks st == 1 && not showNumTryShrinks then "" else "s")+        | numSuccessShrinks st > 0 || showNumTryShrinks ] +++      ")"+      where+        showNumTryShrinks = full && numTryShrinks st > 0++success :: State -> IO ()+success st = do+  mapM_ (putLine $ terminal st) (paragraphs [short, long])+  where+    (short, long) =+      case labelsAndTables st of+        ([msg], long) ->+          ([" (" ++ dropWhile isSpace msg ++ ")."], long)+        ([], long) ->+          (["."], long)+        (short, long) ->+          (":":short, long)++labelsAndTables :: State -> ([String], [String])+labelsAndTables st = (theLabels, theTables)+  where+    theLabels :: [String]+    theLabels =+      paragraphs $+        [ showTable (numSuccessTests st) Nothing m+        | m <- S.classes st:Map.elems numberedLabels ]++    numberedLabels :: Map Int (Map String Int)+    numberedLabels =+      Map.fromListWith (Map.unionWith (+)) $+        [ (i, Map.singleton l n)+        | (labels, n) <- Map.toList (S.labels st),+          (i, l) <- zip [0..] labels ]++    theTables :: [String]+    theTables =+      paragraphs $+        [ showTable (sum (Map.elems m)) (Just table) m+        | (table, m) <- Map.toList (S.tables st) ] +++        [[ (case mtable of Nothing -> "Only "; Just table -> "Table '" ++ table ++ "' had only ")+         ++ lpercent n tot ++ " " ++ label ++ ", but expected " ++ lpercentage p tot+         | (mtable, label, tot, n, p) <- allCoverage st,+           insufficientlyCovered (fmap certainty (coverageConfidence st)) tot n p ]]++showTable :: Int -> Maybe String -> Map String Int -> [String]+showTable k mtable m =+  [table ++ " " ++ total ++ ":" | Just table <- [mtable]] +++  (map format .+   -- Descending order of occurrences+   reverse . sortBy (comparing snd) .+   -- If #occurences the same, sort in increasing order of key+   -- (note: works because sortBy is stable)+   reverse . sortBy (comparing fst) $ Map.toList m)+  where+    format (key, v) =+      rpercent v k ++ " " ++ key++    total = printf "(%d in total)" k++--------------------------------------------------------------------------+-- 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 ts++localMin :: State -> 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) (failureSummary st res)+  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+          | isDiscard err -> localMinFound st res+          | otherwise ->+          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' ts'+      else localMin st{ numTryShrinks    = numTryShrinks st + 1,+                        numTotTryShrinks = numTotTryShrinks st + 1 } res ts++localMinFound :: State -> P.Result -> IO (Int, Int, Int, P.Result)+localMinFound st res =+  do sequence_ [ putLine (terminal st) msg | msg <- failureReason st 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 ()++----------------------------------------------------------------------+-- computing coverage++sufficientlyCovered :: Confidence -> Int -> Int -> Double -> Bool+sufficientlyCovered confidence n k p =+  -- Accept the coverage if, with high confidence, the actual probability is+  -- at least 0.9 times the required one.+  wilsonLow (fromIntegral k) (fromIntegral n) (1 / fromIntegral err) >= tol * p+  where+    err = certainty confidence+    tol = tolerance confidence++insufficientlyCovered :: Maybe Integer -> Int -> Int -> Double -> Bool+insufficientlyCovered Nothing n k p =+  fromIntegral k < p * fromIntegral n+insufficientlyCovered (Just err) n k p =+  wilsonHigh (fromIntegral k) (fromIntegral n) (1 / fromIntegral err) < p++-- https://en.wikipedia.org/wiki/Binomial_proportion_confidence_interval#Wilson_score_interval+-- Note:+-- https://www.ncss.com/wp-content/themes/ncss/pdf/Procedures/PASS/Confidence_Intervals_for_One_Proportion.pdf+-- suggests we should use a instead of a/2 for a one-sided test. Look+-- into this.+wilson :: Integer -> Integer -> Double -> Double+wilson k n z =+  (p + z*z/(2*nf) + z*sqrt (p*(1-p)/nf + z*z/(4*nf*nf)))/(1 + z*z/nf)+  where+    nf = fromIntegral n+    p = fromIntegral k / fromIntegral n++wilsonLow :: Integer -> Integer -> Double -> Double+wilsonLow k n a = wilson k n (invnormcdf (a/2))++wilsonHigh :: Integer -> Integer -> Double -> Double+wilsonHigh k n a = wilson k n (invnormcdf (1-a/2))++-- Algorithm taken from+-- https://web.archive.org/web/20151110174102/http://home.online.no/~pjacklam/notes/invnorm/+-- Accurate to about one part in 10^9.+--+-- The 'erf' package uses the same algorithm, but with an extra step+-- to get a fully accurate result, which we skip because it requires+-- the 'erfc' function.+invnormcdf :: Double -> Double+invnormcdf p+  | p < 0  = 0/0+  | p > 1  = 0/0+  | p == 0 = -1/0+  | p == 1 = 1/0+  | p < p_low =+    let+      q = sqrt(-2*log(p))+    in+      (((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6) /+      ((((d1*q+d2)*q+d3)*q+d4)*q+1)+  | p <= p_high =+    let+      q = p - 0.5+      r = q*q+    in+      (((((a1*r+a2)*r+a3)*r+a4)*r+a5)*r+a6)*q /+      (((((b1*r+b2)*r+b3)*r+b4)*r+b5)*r+1)+  | otherwise =+    let+      q = sqrt(-2*log(1-p))+    in+      -(((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6) /+       ((((d1*q+d2)*q+d3)*q+d4)*q+1)+  where+    a1 = -3.969683028665376e+01+    a2 =  2.209460984245205e+02+    a3 = -2.759285104469687e+02+    a4 =  1.383577518672690e+02+    a5 = -3.066479806614716e+01+    a6 =  2.506628277459239e+00++    b1 = -5.447609879822406e+01+    b2 =  1.615858368580409e+02+    b3 = -1.556989798598866e+02+    b4 =  6.680131188771972e+01+    b5 = -1.328068155288572e+01++    c1 = -7.784894002430293e-03+    c2 = -3.223964580411365e-01+    c3 = -2.400758277161838e+00+    c4 = -2.549732539343734e+00+    c5 =  4.374664141464968e+00+    c6 =  2.938163982698783e+00++    d1 =  7.784695709041462e-03+    d2 =  3.224671290700398e-01+    d3 =  2.445134137142996e+00+    d4 =  3.754408661907416e+00++    p_low  = 0.02425+    p_high = 1 - p_low+++allCoverage :: State -> [(Maybe String, String, Int, Int, Double)]+allCoverage st =+  [ (key, value, tot, n, p)+  | ((key, value), p) <- Map.toList (S.requiredCoverage st),+    let tot =+          case key of+            Just key -> Map.findWithDefault 0 key totals+            Nothing -> numSuccessTests st,+    let n = Map.findWithDefault 0 value (Map.findWithDefault Map.empty key combinedCounts) ]+  where+    combinedCounts :: Map (Maybe String) (Map String Int)+    combinedCounts =+      Map.insert Nothing (S.classes st)+        (Map.mapKeys Just (S.tables st))++    totals :: Map String Int+    totals = fmap (sum . Map.elems) (S.tables st)++--------------------------------------------------------------------------+-- the end.
+ src/Test/QuickCheck/Text.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE CPP #-}+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Safe #-}+#endif+{-# OPTIONS_HADDOCK hide #-}+-- | Terminal control and text helper functions. Internal QuickCheck module.+module Test.QuickCheck.Text+  ( Str(..)+  , ranges++  , number+  , short+  , showErr+  , oneLine+  , isOneLine+  , bold+  , ljust, rjust, centre, lpercent, rpercent, lpercentage, rpercentage+  , drawTable, Cell(..)+  , paragraphs++  , newTerminal+  , withStdioTerminal+  , withHandleTerminal+  , 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 Data.List (intersperse, transpose)+import Text.Printf+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++ljust n xs = xs ++ replicate (n - length xs) ' '+rjust n xs = replicate (n - length xs) ' ' ++ xs+centre n xs =+  ljust n $+  replicate ((n - length xs) `div` 2) ' ' ++ xs++lpercent, rpercent :: (Integral a, Integral b) => a -> b -> String+lpercent n k =+  lpercentage (fromIntegral n / fromIntegral k) k++rpercent n k =+  rpercentage (fromIntegral n / fromIntegral k) k++lpercentage, rpercentage :: Integral a => Double -> a -> String+lpercentage p n =+  printf "%.*f" places (100*p) ++ "%"+  where+    -- Show no decimal places if k <= 100,+    -- one decimal place if k <= 1000,+    -- two decimal places if k <= 10000, and so on.+    places :: Integer+    places =+      ceiling (logBase 10 (fromIntegral n) - 2 :: Double) `max` 0++rpercentage p n = padding ++ lpercentage p n+  where+    padding = if p < 0.1 then " " else ""++data Cell = LJust String | RJust String | Centred String deriving Show++text :: Cell -> String+text (LJust xs) = xs+text (RJust xs) = xs+text (Centred xs) = xs++-- Flatten a table into a list of rows+flattenRows :: [[Cell]] -> [String]+flattenRows rows = map row rows+  where+    cols = transpose rows+    widths = map (maximum . map (length . text)) cols++    row cells = concat (intersperse " " (zipWith cell widths cells))+    cell n (LJust xs) = ljust n xs+    cell n (RJust xs) = rjust n xs+    cell n (Centred xs) = centre n xs++-- Draw a table given a header and contents+drawTable :: [String] -> [[Cell]] -> [String]+drawTable headers table =+  [line] +++  [border '|' ' ' header | header <- headers] +++  [line | not (null headers) && not (null rows)] +++  [border '|' ' ' row | row <- rows] +++  [line]+  where+    rows = flattenRows table++    headerwidth = maximum (0:map length headers)+    bodywidth = maximum (0:map length rows)+    width = max headerwidth bodywidth++    line = border '+' '-' $ replicate width '-'+    border x y xs = [x, y] ++ centre width xs ++ [y, x]++paragraphs :: [[String]] -> [String]+paragraphs = concat . intersperse [""] . filter (not . null)++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++withHandleTerminal :: Handle -> Maybe Handle -> (Terminal -> IO a) -> IO a+withHandleTerminal outh merrh action = do+  let+    err =+      case merrh of+        Nothing -> const (return ())+        Just errh -> handle errh+  newTerminal (handle outh) err >>= action++withStdioTerminal :: (Terminal -> IO a) -> IO a+withStdioTerminal action = do+  isatty <- hIsTerminalDevice stderr+  if isatty then+    withBuffering (withHandleTerminal stdout (Just stderr) action)+   else+    withBuffering (withHandleTerminal stdout Nothing 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++putPart, putTemp, putLine :: Terminal -> String -> IO ()+putPart tm@(MkTerminal res _ out _) s =+  do putTemp 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 oldLen <- readIORef tmp+     let newLen = length s+         maxLen = max newLen oldLen+     err $ s ++ replicate (maxLen - newLen) ' ' ++ replicate maxLen '\b'+     writeIORef tmp newLen++--------------------------------------------------------------------------+-- the end.
+ test-hugs view
@@ -0,0 +1,29 @@+#!/bin/sh++set -e++CABAL=${CABAL:-cabal}+HC=${HC:-ghc}++# Install cpphs if it is not in path+command -v cpphs || ${CABAL} v2-install --ignore-project --with-compiler "$HC" cpphs++# Regenerate quickcheck-hugs+sh make-hugs+find quickcheck-hugs++die() {+    echo "TEST FAILED"+    exit 1+}++dotest() {+  echo "$2" | hugs -98 -Pquickcheck-hugs: -p'> ' "$1" | tee hugs.output+  grep -q "$3" hugs.output || die+}++# Simple tests+dotest Test.QuickCheck 'quickCheck $ \xs -> reverse (reverse xs) === (xs :: [Int])' "OK, passed 100 tests."+dotest Test.QuickCheck 'quickCheck $ \xs -> reverse xs === (xs :: [Int])' "\[0,1\]"+echo+echo 'All tests passed!'
+ test-mhs view
@@ -0,0 +1,25 @@+#!/bin/sh++set -e++mcabal -r install++die() {+    echo "TEST FAILED"+    exit 1+}++dotest() {+  cat >Main.hs <<EOF+import $1+main = $2+EOF+  mhs Main.hs -oMain && ./Main | tee mhs.output+  grep -q "$3" mhs.output || die+}++# Simple tests+dotest Test.QuickCheck 'quickCheck $ \xs -> reverse (reverse xs) === (xs :: [Int])' "OK, passed 100 tests."+dotest Test.QuickCheck 'quickCheck $ \xs -> reverse xs === (xs :: [Int])' "\[0,1\]"+echo+echo 'All tests passed!'
+ tests/CollectDataTypes.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE TemplateHaskell, RecordWildCards, DeriveLift, TupleSections, CPP, TypeOperators #-}+module CollectDataTypes where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Ppr+import Language.Haskell.Interpreter hiding (lift)+import Data.Maybe+import Data.List+import System.Process+import Data.List.Split+import Control.Monad+import Control.Monad.Trans.Maybe+import Control.Monad.IO.Class+import Text.Printf+import Data.Either+import Data.Char+import Data.Function+import Test.QuickCheck+import Test.QuickCheck.Function++data DataType =+  DataType {+    dt_package :: String,+    dt_module :: String,+    dt_type :: String }+  deriving (Show, Lift)++getPackageDataTypes :: String -> IO [DataType]+getPackageDataTypes pkg = do+  mods <- filter isValidModule <$> getPackageModules pkg+  typess <- mapM getModuleDataTypes mods+  return [DataType pkg mod typ | (mod, types) <- zip mods typess, typ <- types]++getPackageModules :: String -> IO [String]+getPackageModules pkg =+  concatMap (parseWords . words) . splitOn ", " . unwords . words <$> readProcess cmd args ""+  where+    cmd:args = ["ghc-pkg", "field", pkg, "exposed-modules", "--simple-output"]+    parseWords [mod, "from", _] = [mod]+    parseWords xs = xs++getModuleDataTypes :: String -> IO [String]+getModuleDataTypes mod = do+  putStrLn mod+  Right names <- runInterpreter $ getModuleExports mod+  return [x | Data x _ <- names]++haskellName :: DataType -> String+haskellName DataType{..} = printf "%s.%s" dt_module (stripParens dt_type)+  where+    stripParens = reverse . dropWhile (== ')') . reverse . dropWhile (== '(')++dataTypeType :: DataType -> Q (Maybe Type)+dataTypeType dt = do+  mname <- lookupTypeName (haskellName dt)+  case mname of+    Nothing -> return Nothing+    Just name -> Just <$> reifyType name++typeArity :: Type -> Maybe Int+typeArity (AppT (AppT ArrowT StarT) kind) = succ <$> typeArity kind+typeArity StarT = return 0+typeArity _ = Nothing++createProperties :: String -> Q [Dec]+createProperties pkg = do+  datatypes0 <- runIO (getPackageDataTypes pkg)+  let datatypes = [ dt | dt <- datatypes0, not $ haskellName dt `elem` typeBlacklist ]+  let mkImport dt = printf "import %s -- for %s" (dt_module dt) (dt_type dt)+  missingModules <- fmap (map mkImport . nubBy ((==) `on` dt_module)) $ filterM (\ dt -> isNothing <$> dataTypeType dt) datatypes+  unless (null missingModules) $ error ("Missing the following imports:\n" ++ unlines missingModules)+  namesAndDecs <- fmap concat $ mapM createProperty datatypes+  let (allNames, props) = unzip namesAndDecs+  allPropsDec <- [d| allProps =+                        $(pure $ ListE [ TupE [Just (LitE (StringL $ nameBase name)), Just (VarE name)]+                                              | name <- allNames ]+                         )+                 |]+  return $ allPropsDec ++ props++createProperty :: DataType -> Q [(Name, Dec)]+createProperty dt = do+  mtype <- dataTypeType dt+  -- TODO: monad?!+  case mtype of+    Nothing -> error $ "Can't find type in scope " ++ show dt+    Just typ -> case typeArity typ of+      Nothing -> pure []+      Just arity -> do+        Just name <- lookupTypeName (haskellName dt)+        Just int <- lookupTypeName "Int"+        nm <- newName ("prop_" ++ filter isAlphaNum (haskellName dt))+        nmCo <- newName ("prop_co_" ++ filter isAlphaNum (haskellName dt))+        nmFunction <- newName ("prop_function_" ++ filter isAlphaNum (haskellName dt))+        let propName = pure $ VarP nm+        let propNameCo = pure $ VarP nmCo+        let propNameFunction = pure $ VarP nmFunction+        let ty = pure $ foldl AppT (ConT name) $ replicate arity (ConT int)+        dArbitrary <- map (nm,) <$> [d| $propName = forAllBlind (arbitrary :: Gen $ty) (\ x -> x `seq` True) |]+        dCoArbitrary <- map (nmCo,) <$> [d| $propNameCo = forAllBlind (arbitrary :: Gen ($ty -> Integer)) (\ x -> x `seq` True) |]+        dFunction <- map (nmFunction,) <$> [d| $propNameFunction = forAllBlind (arbitrary :: Gen ($ty :-> Integer)) (\ x -> x `seq` True) |]+        return $ dArbitrary ++ dCoArbitrary ++ dFunction++typeBlacklist :: [String]+typeBlacklist = [ "Prelude.IO"+                , "Prelude.ReadS"+                , "Prelude.ShowS"+                , "System.IO.IO"+                , "System.IO.Error.IOError"+                , "Prelude.IOError"+                , "Data.Kind.Type"+                , "Data.Array.Byte.MutableByteArray"+                , "Data.IORef.IORef"+                , "Data.Kind.Constraint"+                , "Data.Unique.Unique"+                , "Data.STRef.STRef"+                , "Data.STRef.Lazy.STRef"+                , "Data.STRef.Strict.STRef"+                , "Data.Void.Void"+                , "Data.Proxy.KProxy"+                , "Data.Monoid.Endo"+                , "Data.Semigroup.Endo"+                , "Data.List.[]" -- This is buggy and annoying+                , "System.IO.HandlePosn"+                , "System.IO.Handle"+                , "Text.Printf.FieldFormatter" -- This is a function type and it+                                               -- requires an annoying coarbitrary instance+                , "Text.Printf.ModifierParser"+                , "Text.Show.ShowS"+                ] +++                -- These are phantom types used for indexing+                [ "Data.Fixed.E" ++ show i | i <- [0,1,2,3,6,9,12] ] +++#if MIN_VERSION_base(4,15,0)+                -- Exists but is deprecated+                [ "Data.Semigroup.Option" ] +++#endif+                -- TODO: Some controversial ones?+                [ "System.IO.Error.IOErrorType" ] +++                -- Some higher order types we ignore for the sake of CoArbitrary and Function issues+                [ "System.Console.GetOpt.OptDescr"+                , "System.Console.GetOpt.ArgOrder"+                , "System.Console.GetOpt.ArgDescr"+                ] +++                -- System specific and, likewise, not easily doable in Function+                [ "System.IO.TextEncoding" ] +++                -- Ignored for `Function` because the test monomorphises to `Int`. fixme.+                [ "Data.Complex.Complex" ]+++++modulePrefixBlacklist :: [String]+modulePrefixBlacklist = [ "GHC"+                        , "Foreign"+                        , "Control.Exception"+                          -- Exports things like MVar etc+                        , "Control.Concurrent"+                          -- Exports ST and RealWorld that we can't support+                        , "Control.Monad.ST"+                          -- Existential wrapper around a Typeable thing, could+                          -- be supported but would be a bit artificially+                          -- limited to wrapping a bunch of types we can list+                        , "Data.Dynamic"+                          -- We _could_ support this, but it would result in+                          -- the same problem as with Dynamic+                        , "Data.Typeable"+                        , "Type.Reflection"+                          -- System.Mem.Weak and System.Mem.Stable export+                          -- pointer types we don't support+                        , "System.Mem"+                          -- Exports an exception+                        , "System.Timeout"+                        -- Exports types, but not the constructors (or ways of+                        -- creating them, e.g. Number).  No feasible way to+                        -- create meaningful generator+                        , "Text.Read"+                        -- Old generics implementation that doesn't fit nicely+                        -- with arbitrary, as it has the same kind of problem+                        -- that Typeable and Dynamic face+                        , "Data.Data"+                        -- Platform specific types that one could implement but+                        -- would be tricky to keep consistent and correct+                        -- across a number of platforms, esp. since we don't+                        -- have good CI tests for them+                        , "System.Posix"+                        -- This exports a bunch of combinators whose only real+                        -- role is to build a parser of an opaque type,+                        -- consequently there isn't some super-interesting+                        -- useful work you can do with it and it should be OK+                        -- not to provide instances for it+                        , "Text.ParserCombinators.ReadP"+                        -- Slightly controversial, but this is only ignored for+                        -- the sake of CoArbitrary and Function+                        , "Data.Functor.Contravariant"+                        ]++isValidModule :: String -> Bool+isValidModule mod = not $ any (`isPrefixOf` mod) modulePrefixBlacklist
+ tests/DiscardRatio.hs view
@@ -0,0 +1,56 @@+module Main where++import Control.Monad+import System.Exit+import Test.QuickCheck++assert :: String -> Bool -> IO  ()+assert s False = do+  putStrLn $ s ++ " failed!"+  exitFailure+assert _ _     = return ()++quickCheckYesWith, quickCheckNoWith :: Testable p => Args -> p -> IO ()+quickCheckYesWith args p = do+  res <- quickCheckWithResult args p+  unless (isSuccess res) exitFailure+quickCheckNoWith args p = do+  res <- quickCheckWithResult args p+  when (isSuccess res) exitFailure+quickCheckYes, quickCheckNo :: Testable p => p -> IO ()+quickCheckYes = quickCheckYesWith stdArgs+quickCheckNo = quickCheckNoWith stdArgs++check :: Result -> Int -> Int -> IO ()+check res n d = do+  quickCheckYes $ once $ n === numTests res+  quickCheckYes $ once $ d === numDiscarded res++main :: IO ()+main = do+  putStrLn "Expecting gave up after 200 tries: False ==> True"+  res <- quickCheckResult $ withDiscardRatio 2 $ False ==> True+  check res 0 200+  res <- quickCheckWithResult stdArgs{maxDiscardRatio = 2} $ False ==> True+  check res 0 200++  putStrLn "\nExpecting success after 100 tests: x == x"+  res <- quickCheckResult $ withDiscardRatio 2 $ \ x -> (x :: Int) == x+  check res 100 0+  res <- quickCheckWithResult stdArgs{maxDiscardRatio = 2} $ \ x -> (x :: Int) == x+  check res 100 0++  -- The real ratio is 20, if 1 works or 40 doesn't it's+  -- probably because we broke something!+  let p50 = forAll (choose (1, 1000)) $ \ x -> (x :: Int) < 50 ==> True+  putStrLn "\nExpecting failure (discard ratio 1): x < 50 ==> True"+  quickCheckNo $ withDiscardRatio 1 p50+  quickCheckNoWith stdArgs{maxDiscardRatio = 1} p50+  putStrLn "\nExpecting success (discard ratio 40): x < 50 ==> True"+  quickCheckYes $ withDiscardRatio 40 p50+  quickCheckYesWith stdArgs{maxDiscardRatio = 40} p50++  -- Annoying interactions of discard and cover+  quickCheckYes $ forAllBlind (oneof [return True, return discard]) $ \ b -> cover 10 b "b" True+  quickCheck $ cover 10 discard "b" True+  quickCheck $ classify discard "b" True
+ tests/GCoArbitraryExample.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DeriveGeneric, ScopedTypeVariables, TemplateHaskell #-}++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) where arbitrary = error "not implemented"+instance CoArbitrary a => CoArbitrary (D a)++instance (Show a, Read a) => Function (D a) where+  function = functionShow++prop_coarbitrary (Fun _ f) =+  expectFailure $+  withNumTests 1000 $+  f (C1 (2::Int)) `elem` [0, 1 :: Int]++return []+main = do True <- $quickCheckAll; return ()
+ tests/GShrinkExample.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE DeriveGeneric, ScopedTypeVariables, TemplateHaskell #-}++module Main where++import GHC.Generics (Generic)+import Test.QuickCheck++data Nat = Z | S Nat deriving (Eq, Show, Generic)+++instance Arbitrary Nat where arbitrary = error "not implemented"++prop_shrink =+  genericShrink (S (S Z)) === [S Z] .&&.+  genericShrink [0::Int] === [[]]++return []++main :: IO ()+main = do True <- $quickCheckAll; return ()
+ tests/Generators.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, Rank2Types, NoMonomorphismRestriction #-}+import Test.QuickCheck+import Test.QuickCheck.Gen.Unsafe+import Data.List (inits, sort, nub)+import Data.Int+import Data.Word+import Data.Version+import System.Exit+import Data.Complex+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 100 x)+    where+      pathFrom n x =+        fmap (x:) $+        case shrink x of+          [] -> return []+          _ | n == 0 -> return []+          ys -> oneof [pathFrom (n-1) y | y <- ys]++  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 . withNumTests 1000 . 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))) =>+  Bool -> (forall a. f a -> a) -> (forall a. Integral a => a -> Bool) -> Property+pathInt word 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" (not word .||. path ((p :: Word -> Bool) . getExtremal . f)),+     counterexample "Word8" (not word .||. path ((p :: Word8 -> Bool) . getExtremal . f)),+     counterexample "Word16" (not word .||. path ((p :: Word16 -> Bool) . getExtremal . f)),+     counterexample "Word32" (not word .||. path ((p :: Word32 -> Bool) . getExtremal . f)),+     counterexample "Word64" (not word .||. path ((p :: Word64 -> Bool) . getExtremal . f))]+somePathInt word f p = expectFailure (pathInt word f (not . p))++prop_positive = pathInt True getPositive (> 0)+prop_positive_bound = somePathInt True getPositive (== 1)++prop_nonzero = pathInt True getNonZero (/= 0)+prop_nonzero_bound_1 = somePathInt True getNonZero (== 1)+prop_nonzero_bound_2 = somePathInt True getNonZero (== -1)++prop_nonnegative = pathInt True getNonNegative (>= 0)+prop_nonnegative_bound = somePathInt True getNonNegative (== 0)++prop_negative = pathInt False getNegative (< 0)+prop_negative_bound = somePathInt False getNegative (== -1)++prop_nonpositive = pathInt True getNonPositive (<= 0)+prop_nonpositive_bound = somePathInt True getNonPositive (== 0)++reachesBound :: (Bounded a, Integral a, Arbitrary a) =>+  a -> Property+reachesBound x = withNumTests 1000 (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_Word8 = reachesBound :: Word8 -> Property+prop_reachesBound_Word16 = reachesBound :: Word16 -> Property+prop_reachesBound_Word32 = reachesBound :: Word32 -> Property+prop_reachesBound_Word64 = reachesBound :: Word64 -> Property++-- Shrinking should not loop.+noShrinkingLoop :: (Eq a, Arbitrary a) => Path a -> Bool+noShrinkingLoop (Path (x:xs)) = x `notElem` xs++prop_no_shrinking_loop_Unit = noShrinkingLoop :: Path () -> Bool+prop_no_shrinking_loop_Bool = noShrinkingLoop :: Path Bool -> Bool+prop_no_shrinking_loop_Ordering = noShrinkingLoop :: Path Ordering -> Bool+prop_no_shrinking_loop_Maybe = noShrinkingLoop :: Path (Maybe Int) -> Bool+prop_no_shrinking_loop_Either = noShrinkingLoop :: Path (Either Int Int) -> Bool+prop_no_shrinking_loop_List = noShrinkingLoop :: Path [Int] -> Bool+prop_no_shrinking_loop_Ratio = noShrinkingLoop :: Path Rational -> Bool+prop_no_shrinking_loop_Complex = noShrinkingLoop :: Path (Complex Double) -> Bool+prop_no_shrinking_loop_Fixed = noShrinkingLoop :: Path (Fixed Int) -> Bool+prop_no_shrinking_loop_Pair = noShrinkingLoop :: Path (Int, Int) -> Bool+prop_no_shrinking_loop_Triple = noShrinkingLoop :: Path (Int, Int, Int) -> Bool+prop_no_shrinking_loop_Integer = noShrinkingLoop :: Path Integer -> Bool+prop_no_shrinking_loop_Int = noShrinkingLoop :: Path Int -> Bool+prop_no_shrinking_loop_Int8 = noShrinkingLoop :: Path Int8 -> Bool+prop_no_shrinking_loop_Int16 = noShrinkingLoop :: Path Int16 -> Bool+prop_no_shrinking_loop_Int32 = noShrinkingLoop :: Path Int32 -> Bool+prop_no_shrinking_loop_Int64 = noShrinkingLoop :: Path Int64 -> Bool+prop_no_shrinking_loop_Word = noShrinkingLoop :: Path Word -> Bool+prop_no_shrinking_loop_Word8 = noShrinkingLoop :: Path Word8 -> Bool+prop_no_shrinking_loop_Word16 = noShrinkingLoop :: Path Word16 -> Bool+prop_no_shrinking_loop_Word32 = noShrinkingLoop :: Path Word32 -> Bool+prop_no_shrinking_loop_Word64 = noShrinkingLoop :: Path Word64 -> Bool+prop_no_shrinking_loop_Char = noShrinkingLoop :: Path Char -> Bool+prop_no_shrinking_loop_Float = noShrinkingLoop :: Path Float -> Bool+prop_no_shrinking_loop_Double = noShrinkingLoop :: Path Double -> Bool+prop_no_shrinking_loop_Version = noShrinkingLoop :: Path Version -> Bool+prop_no_shrinking_loop_ExitCode = noShrinkingLoop :: Path ExitCode -> Bool++-- Check that shrinking a Double always produces a shrinking candidate.+prop_shrink_candidate_double :: Property+prop_shrink_candidate_double =+  forAllShrink gen shrink $ \x ->+    x > 0 ==>+    not (null (shrink x))+  where+    gen :: Gen Double+    gen = oneof [arbitrary, fmap fromInteger arbitrary]++-- 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++-- Double properties:++-- We occasionaly generate duplicates.+prop_double_duplicate_list :: [Double] -> Property+prop_double_duplicate_list xs = expectFailure $ nub xs === xs where+  sorted = sort xs++-- And enough numbers to show basic IEEE pit falls.+prop_double_assoc :: Double -> Double -> Double -> Property+prop_double_assoc x y z = expectFailure $ x + (y + z) === (x + y) + z+++return []+main = do True <- $forAllProperties (quickCheckWithResult stdArgs { maxShrinks = 10000 }); return ()
+ tests/Misc.hs view
@@ -0,0 +1,50 @@+-- Miscellaneous tests.++{-# LANGUAGE TemplateHaskell #-}+import Test.QuickCheck+import Test.QuickCheck.Random+import Data.Map+import Control.Monad++prop_verbose :: Blind (Int -> Int -> Bool) -> Property+prop_verbose (Blind p) =+  forAll (mkQCGen <$> arbitrary) $ \g ->+  ioProperty $ do+    res1 <- quickCheckWithResult stdArgs{replay = Just (g, 100), chatty = False} p+    res2 <- quickCheckWithResult stdArgs{replay = Just (g, 100), chatty = False} (verbose p)+    return $+      numTests res1 === numTests res2 .&&.+      failingTestCase res1 === failingTestCase res2++prop_failingTestCase :: Blind (Int -> Int -> Int -> Bool) -> Property+prop_failingTestCase (Blind p) = ioProperty $ do+  res <- quickCheckWithResult stdArgs{chatty = False} p+  let [x, y, z] = failingTestCase res+  return (not (p (read x) (read y) (read z)))++prop_maxSize :: Property+prop_maxSize = withMaxSize 10 (forAll (arbitrary :: Gen Int) $ \ x -> abs x < 10)++prop_cover :: Property+prop_cover = withNumTests 1000+           $ checkCoverage+           $ forAll (arbitrary :: Gen Int)+           $ \ x -> cover 5 (x > 0) "positive" True++-- Issue #382+prop_discardCoverage :: Property+prop_discardCoverage = checkCoverage $ forAll (sized $ \ n -> pure n) $ \ x -> cover 10 True "label" $ x /= 99 ==> True++return []+main = do+  True <- $quickCheckAll+  Success{classes=cls} <- quickCheckResult $ classify False "A" $ classify True "B" True+  [("A",0),("B",100)] <- return $ toList cls+  Success{numTests=1000} <- quickCheckResult prop_cover+  forM_ [const discard, const [discard], \ x -> discard : shrink x] $ \ shr -> do+    Failure{reason="Falsified"} <- quickCheckResult $ forAllShrink arbitrary shr (odd :: Int -> Bool)+    return ()+  -- These shouldn't crash+  sample (discard :: Gen Int)+  sample (oneof [discard, return 1] :: Gen Int)+  sample (oneof [return (1, discard), return (1, 1)] :: Gen (Int, Int))
+ tests/MonadFix.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE TemplateHaskell, RecursiveDo #-}+import Test.QuickCheck+import Control.Monad.Fix++-- A simple (not complete) test for the MonadFix instance.+cyclicList :: Gen [Int]+cyclicList = do+  rec xs <- fmap (:ys) arbitrary+      ys <- fmap (:xs) arbitrary+  return xs++prop_cyclic :: Property+prop_cyclic =+  forAll (Blind <$> cyclicList) $ \(Blind xs) ->+    -- repeats with period 2+    and $ take 100 $ zipWith (==) xs (drop 2 xs)++prop_period2 :: Property+prop_period2 =+  expectFailure $+  forAll (Blind <$> cyclicList) $ \(Blind xs) ->+    -- does not always repeat with period 1+    and $ take 100 $ zipWith (==) xs (drop 1 xs)++return []+main = do True <- $quickCheckAll; return ()
+ tests/Monoids.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell  #-}+{-# LANGUAGE ConstraintKinds #-}++#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-orphans #-}+#endif+{-# LANGUAGE FlexibleInstances #-}++module Main (main) where++#ifndef NO_SEMIGROUP_CLASS+import Data.List.NonEmpty+import Data.Semigroup (Semigroup (..))+#else+import Data.Monoid (Monoid (..), (<>))+#endif++import Test.QuickCheck++#ifdef NO_SEMIGROUP_CLASS+type Semigroup = Monoid+sconcat :: Monoid a => [a] -> a+sconcat = mconcat+#endif++instance Arbitrary Every where+    arbitrary = oneof [ pure $ Every True+                      , pure $ Every False+                      , pure $ Every (counterexample "False" False)+                      , pure $ Every (counterexample "True" True)+                      , pure $ Every (ioProperty (return True))+                      , pure $ Every (ioProperty (return False))+                      , pure $ Every (checkCoverage $ cover 100 True "" True)+                      , pure $ Every (checkCoverage $ cover 100 True "" False)+                      , pure $ Every (checkCoverage $ cover 100 False "" False)+                      ]+++instance Arbitrary Some where+    arbitrary = oneof [ pure $ Some True+                      , pure $ Some False+                      , pure $ Some (counterexample "False" False)+                      , pure $ Some (counterexample "True" True)+                      , pure $ Some (ioProperty (return True))+                      , pure $ Some (ioProperty (return False))+                      , pure $ Some (checkCoverage $ cover 100 True  "" True)+                      , pure $ Some (checkCoverage $ cover 100 True  "" False)+                      , pure $ Some (checkCoverage $ cover 100 False "" True)+                      , pure $ Some (checkCoverage $ cover 100 False "" False)+                      ]+++newtype Fail a = Fail a++instance Arbitrary (Fail Every) where+    arbitrary = oneof [ Fail <$> (arbitrary :: Gen Every)+                      , pure $ Fail $ Every (checkCoverage $ cover 100 False "" True)+                      ]+++check_associative_law :: (Testable p, Semigroup p) => Blind p -> Blind p -> Blind p -> Property+check_associative_law (Blind a) (Blind b) (Blind c) = ioProperty $ do+    x <- isSuccess <$> quickCheckWithResult args (a <> (b <> c))+    y <- isSuccess <$> quickCheckWithResult args ((a <> b) <> c)+    return (x == y)+++#ifndef NO_SEMIGROUP_SUPERCLASS+check_unit_law :: (Testable p, Monoid p) => Blind p -> Property+#else+check_unit_law :: (Testable p, Monoid p, Semigroup p) => Blind p -> Property+#endif+check_unit_law (Blind a) = ioProperty $ do+    x <- isSuccess <$> quickCheckWithResult args (a <> mempty)+    y <- isSuccess <$> quickCheckWithResult args (mempty <> a)+    z <- isSuccess <$> quickCheckWithResult args a+    return (x == y .&&. y == z)+++#ifndef NO_SEMIGROUP_CLASS+check_sconcat_law :: (Testable p, Semigroup p) => Blind p -> Blind p -> Property+check_sconcat_law (Blind a) (Blind b) = ioProperty $ do+    x <- isSuccess <$> quickCheckWithResult args (sconcat $ a :| [b])+    y <- isSuccess <$> quickCheckWithResult args (a <> b)+    return (x == y)+#endif+++#ifndef NO_SEMIGROUP_SUPERCLASS+check_mconcat_law :: (Testable p, Monoid p) => Blind p -> Blind p -> Property+#else+check_mconcat_law :: (Testable p, Monoid p, Semigroup p) => Blind p -> Blind p -> Property+#endif+check_mconcat_law (Blind a) (Blind b) = ioProperty $ do+    x <- isSuccess <$> quickCheckWithResult args (mconcat [a, b])+    y <- isSuccess <$> quickCheckWithResult args (a <> b)+    return (x == y)+++--+-- Auxiliary definitions+--++args :: Args+args = stdArgs { chatty = False, maxShrinks = 0 }++--+-- Properties+--++prop_every_associative :: Blind Every -> Blind Every -> Blind Every -> Property+prop_every_associative = check_associative_law++prop_every_unit :: Blind Every -> Property+prop_every_unit = check_unit_law++prop_every_unit_fail :: Blind (Fail Every) -> Property+prop_every_unit_fail (Blind (Fail a)) =+    expectFailure $ check_unit_law (Blind a)++#ifndef NO_SEMIGROUP_CLASS+prop_every_sconcat_law :: Blind Every -> Blind Every -> Property+prop_every_sconcat_law = check_sconcat_law+#endif++prop_every_mconcat_law :: Blind Every -> Blind Every -> Property+prop_every_mconcat_law = check_mconcat_law++prop_some_associative :: Blind Some -> Blind Some -> Blind Some -> Property+prop_some_associative = check_associative_law++prop_some_unit :: Blind Some -> Property+prop_some_unit = check_unit_law++#ifndef NO_SEMIGROUP_CLASS+prop_some_sconcat_law :: Blind Some -> Blind Some -> Property+prop_some_sconcat_law = check_sconcat_law+#endif++prop_some_mconcat_law :: Blind Some -> Blind Some -> Property+prop_some_mconcat_law = check_mconcat_law++return []+main = do True <- $quickCheckAll; return ()+
+ tests/RunCollectDataTypes.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE TemplateHaskell, CPP #-}+{-# OPTIONS_GHC -ddump-splices #-}+import CollectDataTypes+import Language.Haskell.TH+import Test.QuickCheck.All+import Test.QuickCheck++import Control.Applicative+import Control.Arrow+import Control.Concurrent+import Control.Concurrent.Chan+import Control.Concurrent.MVar+import Control.Concurrent.QSem+import Control.Concurrent.QSemN+import Control.Exception+import Control.Exception.Base+import Control.Monad.ST+import Control.Monad.ST.Lazy+import Control.Monad.ST.Strict+#if defined(MIN_VERSION_base)+#if MIN_VERSION_base(4,17,0)+import Data.Array.Byte+#endif+#endif+import Data.Bits+import Data.Bool+import Data.Char+import Data.Complex+import Data.Data+import Data.Dynamic+import Data.Either+import Data.Fixed+import Data.Functor.Compose+import Data.Functor.Const+import Data.Functor.Contravariant+import Data.Functor.Identity+import Data.Functor.Product+import Data.Functor.Sum+import Data.IORef+import Data.Int+import Data.Kind+import Data.List.NonEmpty+import Data.Maybe+import Data.Monoid+import Data.Ord+import Data.Proxy+import Data.Ratio+import Data.STRef+import Data.STRef.Lazy+import Data.STRef.Strict+import Data.Semigroup+import Data.String+import Data.Tuple+import Data.Type.Bool+import Data.Type.Coercion+import Data.Type.Equality+#if defined(MIN_VERSION_base)+#if MIN_VERSION_base(4,16,0)+import Data.Type.Ord+#endif+#endif+import Data.Typeable+import Data.Unique+import Data.Version+import Data.Void+import Data.Word+import Numeric.Natural+import System.Console.GetOpt+import System.Exit+import System.IO+import System.IO.Error+import System.Mem.StableName+import System.Mem.Weak+import System.Posix.Internals+import System.Posix.Types+import System.Timeout+import Text.ParserCombinators.ReadP+import Text.ParserCombinators.ReadPrec+import Text.Printf+import Text.Read+import Text.Read.Lex+import Text.Show+import Type.Reflection+import Type.Reflection.Unsafe+import Unsafe.Coerce++$(createProperties "base")++main = runQuickCheckAll allProps quickCheckResult
+ tests/Split.hs view
@@ -0,0 +1,28 @@+import Test.QuickCheck+import Test.QuickCheck.Random+import Data.List (group, isPrefixOf, sort)++-- This type allows us to run integerVariant and get a list of bits out.+newtype Splits = Splits { unSplits :: [Bool] } deriving (Eq, Ord, Show)++instance Splittable Splits where+  left (Splits xs) = Splits (xs ++ [False])+  right (Splits xs) = Splits (xs ++ [True])++-- Check that integerVariant gives a prefix-free code,+-- i.e., if m /= n then integerVariant m is not a prefix of integerVariant n.+prop_split_prefix :: Property+prop_split_prefix =+  once $ forAllShrink (return [-10000..10000]) shrink $ \ns ->+    map head (group (sort ns)) == sort ns ==> -- no duplicates+    let+      codes :: [Splits]+      codes = sort [integerVariant n (Splits []) | n <- ns]++      ok (Splits xs) (Splits ys) = not (xs `isPrefixOf` ys)+    in+      -- After sorting, any prefix will end up immediately before+      -- one of its suffixes+      and (zipWith ok codes (drop 1 codes))++main = do Success{} <- quickCheckResult prop_split_prefix; return ()
+ tests/Strictness.hs view
@@ -0,0 +1,42 @@+-- Strictness tests.++{-# LANGUAGE CPP, TemplateHaskell #-}+import Test.QuickCheck++import Control.Exception (Exception (..), throw)++#if MIN_VERSION_containers(0,5,0)+import Control.Exception (evaluate, try)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+#endif++data Thunk++instance Arbitrary Thunk where+  arbitrary = throw ThunkError++instance Show Thunk where+  show _ = "Thunk"++data ThunkError = ThunkError deriving Show++instance Exception ThunkError++prop_strictMap :: Property+#if MIN_VERSION_containers(0,5,0)+prop_strictMap = again . ioProperty $ do+  m <- generate arbitrary+  result <- try $ evaluate m :: IO (Either ThunkError (Map Int Thunk))+  pure $ case result of+    Right _ | not (Map.null m) -> counterexample ("Thunks in Map: " ++ show m) False+    _ -> property True+#else+prop_strictMap = once $ property True+#endif++return []+main :: IO ()+main = do+  True <- $quickCheckAll+  return ()
+ tests/Terminal.hs view
@@ -0,0 +1,94 @@+-- Check that the terminal output works correctly.+{-# LANGUAGE TemplateHaskell, DeriveGeneric #-}+import Test.QuickCheck+import Test.QuickCheck.Text+import System.Process+import System.IO+import Control.Exception+import GHC.Generics+import Control.DeepSeq++data Command =+    PutPart String+  | PutLine String+  | PutTemp String+  deriving (Eq, Ord, Show, Generic)++instance Arbitrary Command where+  arbitrary =+    oneof [+      PutPart <$> line,+      PutLine <$> line,+      PutTemp <$> line]+    where+      line = filter (/= '\n') <$> arbitrary+  shrink = genericShrink++exec :: Terminal -> Command -> IO ()+exec tm (PutPart xs) = putPart tm xs+exec tm (PutLine xs) = putLine tm xs+exec tm (PutTemp xs) = putTemp tm xs++eval :: [Command] -> String+eval = concatMap eval1+  where+    eval1 (PutPart xs) = xs+    eval1 (PutLine xs) = xs ++ "\n"+    -- PutTemp only has an effect on stderr+    eval1 (PutTemp xs) = ""++-- Evaluate the result of printing a given string, taking backspace+-- characters into account.+format :: String -> String+format xs = format1 [] [] xs+  where+    -- Arguments: text before the cursor (in reverse order),+    -- text after the cursor, text to print+    format1 xs ys [] = line xs ys+    -- \n emits a new line+    format1 xs ys ('\n':zs) = line xs ys ++ "\n" ++ format1 [] [] zs+    -- \b moves the cursor to the left+    format1 (x:xs) ys ('\b':zs) = format1 xs (x:xs) zs+    -- beginning of line: \b ignored+    format1 [] ys ('\b':zs) = format1 [] ys zs+    -- Normal printing puts the character before the cursor,+    -- and overwrites the next character after the cursor+    format1 xs ys (z:zs) = format1 (z:xs) (drop 1 ys) zs++    line xs ys = reverse xs ++ ys++-- Check that the terminal satisfies the following properties:+-- * The text written to stdout matches what's returned by terminalOutput+-- * The output agrees with the model implementation 'eval'+-- * Anything written to stderr (presumably by putTemp) is erased+prop_terminal :: [Command] -> Property+prop_terminal cmds =+  withNumTests 1000 $ ioProperty $+  withPipe $ \stdout_read stdout_write ->+  withPipe $ \stderr_read stderr_write -> do+    out <- withHandleTerminal stdout_write (Just stderr_write) $ \tm -> do+      mapM_ (exec tm) (cmds ++ [PutPart ""])+      terminalOutput tm+    stdout <- stdout_read+    stderr <- stderr_read+    return $ conjoin [+        counterexample "output == terminalOutput" $ stdout === out,+        counterexample "output == model" $ out === eval cmds,+        counterexample "putTemp erased" $ all (== ' ') (format stderr) ]+  where+    withPipe :: (IO String -> Handle -> IO a) -> IO a+    withPipe action = do+      (readh, writeh) <- createPipe+      hSetEncoding readh utf8+      hSetEncoding writeh utf8+      let+        read = do+          hClose writeh+          contents <- hGetContents readh+          return $!! contents+      action read writeh `finally` do+        hClose readh+        hClose writeh++return []+main = do True <- $quickCheckAll; return ()
+ tests/WithProgress.hs view
@@ -0,0 +1,68 @@+import Test.QuickCheck+import Test.QuickCheck.Monadic++import Data.IORef+import System.Exit (exitSuccess, exitFailure)+import Control.Monad (when)++main :: IO ()+main = do+  succ <- newIORef 0+  disc <- newIORef 0++  -- test 1  +  quickCheck (propTestWithProgress succ)+  i <- readIORef succ+  when (i /= 99) exitFailure++  modifyIORef succ (const 0)++  -- test 2+  quickCheck (proptestWithProgressDiscard succ disc)+  i1 <- readIORef succ+  i2 <- readIORef disc+  putStrLn $ show i1+  putStrLn $ show i2+  when (i1 /= 0 || i2 /= 999) exitFailure++  modifyIORef succ (const 0)+  modifyIORef disc (const 0)++  -- test 3+  quickCheck (proptestWithProgressNotInstalled succ disc)+  i1 <- readIORef succ+  i2 <- readIORef disc+  putStrLn $ show i1+  putStrLn $ show i2+  when (i1 /= 0 || i2 /= 0) exitFailure++  exitSuccess++-- all these tests succeed, incrementing the counter every time+propTestWithProgress :: IORef Int -> Property+propTestWithProgress ref =+    forAll (arbitrary :: Gen Int) $ \n ->+        withProgress (\p -> modifyIORef ref (\_ -> currentPassed p))+        $ n == n++-- all of these tests are discarded, never updating the currentPassed counter, but always+-- the currentDiscarded one.+proptestWithProgressDiscard :: IORef Int -> IORef Int -> Property+proptestWithProgressDiscard succ disc =+    forAll (arbitrary :: Gen Int) $ \n ->+        withProgress (\p -> do+          modifyIORef succ (\_ -> currentPassed p)+          modifyIORef disc (\_ -> currentDiscarded p))+        $ n > 1000 ==>+          n == n++-- The callback is installed after the test on n, meaning that since all tests are+-- discarded, it will never be called. It will never be executed.+proptestWithProgressNotInstalled :: IORef Int -> IORef Int -> Property+proptestWithProgressNotInstalled succ disc =+    forAll (arbitrary :: Gen Int) $ \n ->+      n > 1000 ==>+        withProgress (\p -> do+          modifyIORef succ (\_ -> currentPassed p)+          modifyIORef disc (\_ -> currentDiscarded p))+        $ n == n