QuickCheck 2.15.0.1 → 2.16.0.0

raw patch · 15 files changed

+477/−86 lines, 15 filesdep ~basenew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• QuickCheck.cabal +28/−12
• changelog +11/−0
• make-hugs +1/−0
• src/Test/QuickCheck.hs +11/−7
• src/Test/QuickCheck/Arbitrary.hs +2/−1
• src/Test/QuickCheck/Features.hs +21/−23
• src/Test/QuickCheck/Function.hs +3/−0
• src/Test/QuickCheck/Gen.hs +2/−2
• src/Test/QuickCheck/Modifiers.hs +25/−6
• src/Test/QuickCheck/Monoids.hs +83/−0
• src/Test/QuickCheck/Property.hs +36/−9
• src/Test/QuickCheck/State.hs +32/−18
• src/Test/QuickCheck/Test.hs +8/−8
• tests/Monoids.hs +146/−0
• tests/WithProgress.hs +68/−0

@@ -1,5 +1,5 @@ Name: QuickCheck-Version: 2.15.0.1+Version: 2.16.0.0 Cabal-Version: >= 1.10 Build-type: Simple License: BSD3@@ -8,15 +8,9 @@ Author: Koen Claessen <koen@chalmers.se> Maintainer: Nick Smallbone <nick@smallbone.se> Bug-reports: https://github.com/nick8325/quickcheck/issues-Tested-with: GHC == 7.0.4  ||-                 == 7.2.2  ||-                 == 7.4.1  ||-                 == 7.4.2  ||-                 == 7.6.3  ||-                 == 7.8.4  ||-                 == 7.10.3 ||+Tested-with: GHC == 7.10.3 ||                  == 8.0.2  ||-                 >= 8.2.2 && < 9.10+                 >= 8.2.2 && < 9.11 Homepage: https://github.com/nick8325/quickcheck Category:       Testing Synopsis:       Automatic testing of Haskell programs@@ -65,7 +59,7 @@ source-repository this   type:     git   location: https://github.com/nick8325/quickcheck-  tag:      2.15.0.1+  tag:      2.16  flag templateHaskell   Description: Build Test.QuickCheck.All, which uses Template Haskell.@@ -87,7 +81,7 @@     Build-depends: random >= 1.0.0.3 && < 1.2.0     cpp-options: -DOLD_RANDOM   else-    Build-depends: random >= 1.2.0 && < 1.3+    Build-depends: random >= 1.2.0 && < 1.4    -- We always use splitmix directly rather than going through StdGen   -- (it's somewhat more efficient).@@ -98,6 +92,9 @@   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,@@ -105,6 +102,7 @@     Test.QuickCheck.Gen,     Test.QuickCheck.Gen.Unsafe,     Test.QuickCheck.Monadic,+    Test.QuickCheck.Monoids,     Test.QuickCheck.Modifiers,     Test.QuickCheck.Property,     Test.QuickCheck.Test,@@ -133,7 +131,7 @@     cpp-options: -DNO_TEMPLATE_HASKELL    if !impl(ghc >= 8.0)-    cpp-options: -DNO_CALLSTACK+    cpp-options: -DNO_CALLSTACK -DNO_SEMIGROUP    if !impl(ghc >= 7.4)     cpp-options: -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS@@ -277,4 +275,22 @@     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+    if !impl(ghc >= 8.4)+      cpp-options: -DNO_SEMIGROUP_SUPERCLASS+    if !impl(ghc >= 8.0)+      cpp-options: -DNO_SEMIGROUP_CLASS++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

@@ -1,3 +1,14 @@+QuickCheck 2.16+	* 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 	* BREAKING: properties without quantification are no longer implicitly 	  wrapped in once

@@ -19,6 +19,7 @@     -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 

@@ -50,8 +50,8 @@ +++ 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+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:  @@@ -73,7 +73,7 @@   (     -- * Running tests     quickCheck-  , Args(..), Result(..)+  , Args(..), Result(..), TestProgress(..)   , stdArgs   , quickCheckWith   , quickCheckWithResult@@ -236,24 +236,24 @@     --     -- @     -- -- Functions cannot be shown (but see 'Function')-    -- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) =+    -- prop_TakeDropWhile ('Blind' p) (xs :: ['Test.QuickCheck.Poly.A']) =     --   takeWhile p xs ++ dropWhile p xs == xs     -- @     --     -- @-    -- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) =+    -- 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 :: ['A'])) =+    -- 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 :: ['OrdA'])) =+    -- prop_Sort ('Ordered' (xs :: ['Test.QuickCheck.Poly.OrdA'])) =     --   sort xs == xs     -- @   , Blind(..)@@ -315,8 +315,10 @@   , (.&.)   , (.&&.)   , conjoin+  , Every (..)   , (.||.)   , disjoin+  , Some (..)     -- ** What to do on failure #ifndef NO_TYPEABLE   , Witness(..)@@ -326,6 +328,7 @@ #endif   , counterexample   , printTestCase+  , withProgress   , whenFail   , whenFail'   , expectFailure@@ -355,6 +358,7 @@ 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

@@ -202,7 +202,8 @@   -- It is worth spending time thinking about what sort of test data   -- you want - good generators are often the difference between   -- finding bugs and not finding them. You can use 'sample',-  -- 'label' and 'classify' to check the quality of your test data.+  -- '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

@@ -11,6 +11,7 @@ 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)@@ -85,26 +86,23 @@  -- | A variant of 'labelledExamples' that takes test arguments and returns a result. labelledExamplesWithResult :: Testable prop => Args -> prop -> IO Result-labelledExamplesWithResult args prop =-  withState args $ \state -> do-    let-      loop :: Set String -> State -> IO Result-      loop feats state = withNullTerminal $ \nullterm -> do-        res <- test state{terminal = nullterm} (property (prop_noNewFeatures feats prop))-        let feats' = features (failingLabels res) (failingClasses res)-        case res of-          Failure{reason = "New feature found"} -> do-            putLine (terminal state) $-              "*** Found example of " ++-              concat (intersperse ", " (Set.toList (feats' Set.\\ feats)))-            mapM_ (putLine (terminal state)) (failingTestCase res)-            putStrLn ""-            loop (Set.union feats feats')-              state{randomSeed = usedSeed res, replayStartSize = Just $ usedSize res}-          _ -> do-            out <- terminalOutput nullterm-            putStr out-            return res-      at0 f s 0 0 = s-      at0 f s n d = f n d-    loop Set.empty state+labelledExamplesWithResult args prop = loop Set.empty Nothing+  where+    loop :: Set String -> Maybe (QCGen, Int) -> IO Result+    loop feats replay = withNullTerminal $ \nullterm -> do+      res <- quickCheckWithResult stdArgs{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

@@ -37,6 +37,7 @@ -- See the @'Function' [a]@ instance for an example of the latter. module Test.QuickCheck.Function   ( Fun(..)+  , mkFun   , applyFun   , apply   , applyFun2@@ -584,6 +585,8 @@ #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) 

@@ -157,7 +157,7 @@ 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`.+-- | Generates a random element over the natural range of @a@. chooseAny :: Random a => Gen a chooseAny = MkGen (\r _ -> let (x,_) = random r in x) @@ -244,7 +244,7 @@ sample' g =   generate (sequence [ resize n g | n <- [0,2..20] ]) --- | Generates some example values and prints them to 'stdout'.+-- | Generates some example values and prints them to 'System.IO.stdout'. sample :: Show a => Gen a -> IO () sample g =   sequence_ [ do r <- newQCGen

@@ -24,24 +24,24 @@ -- -- @ -- -- Functions cannot be shown (but see "Test.QuickCheck.Function")--- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) =+-- prop_TakeDropWhile ('Blind' p) (xs :: ['Test.QuickCheck.Poly.A']) = --   takeWhile p xs ++ dropWhile p xs == xs -- @ -- -- @--- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) =+-- 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 :: ['A'])) =+-- 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 :: ['OrdA'])) =+-- -- Instead of 'Test.QuickCheck.forAll' 'orderedList'+-- prop_Sort ('Ordered' (xs :: ['Test.QuickCheck.Poly.OrdA'])) = --   sort xs == xs -- @ module Test.QuickCheck.Modifiers@@ -62,6 +62,7 @@   , Small(..)   , Smart(..)   , Shrink2(..)+  , NoShrink(..) #ifndef NO_MULTI_PARAM_TYPE_CLASSES   , Shrinking(..)   , ShrinkState(..)@@ -182,7 +183,7 @@ -- -- > prop_take_10 :: InfiniteList Char -> Bool -- > prop_take_10 (InfiniteList xs _) =--- >   or [ x == 'a' | x <- take 10 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:@@ -411,6 +412,24 @@     ]    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.

@@ -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

@@ -18,13 +18,16 @@ import Test.QuickCheck.Arbitrary import Test.QuickCheck.Text( isOneLine, putLine ) import Test.QuickCheck.Exception-import Test.QuickCheck.State( State(terminal), Confidence(..) )+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 MIN_VERSION_base(4,8,0)+import Control.Exception (displayException)+#endif import Control.Monad import qualified Data.Map as Map import Data.Map(Map)@@ -319,7 +322,11 @@                         theException = Just err }  formatException :: String -> AnException -> String+#if MIN_VERSION_base(4,8,0)+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 ] @@ -443,6 +450,25 @@       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. --@@ -525,8 +551,9 @@ withMaxSize n = n `seq` mapTotalResult (\res -> res{ maybeMaxTestSize = Just n })  #ifndef NO_TYPEABLE--- | Return a value in the 'witnesses' field of the 'Result' returned by 'quickCheckResult'. Witnesses--- are returned outer-most first.+-- | 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: --@@ -766,7 +793,7 @@   mapTotalResult $     \res -> res { tables = [(key, value) | value <- values] ++ tables res } --- | Checks that the values in a given 'table' appear a certain proportion of+-- | 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@@ -775,7 +802,7 @@ -- __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 'tabular' combinator...+-- Continuing the example from the 'tabulate' combinator... -- -- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show) -- > prop_chatroom :: [Command] -> Property@@ -909,8 +936,8 @@     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+-- | 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 =@@ -920,7 +947,7 @@     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.+-- | Conjunction: @p1@ '.&&.' @p2@ passes if both @p1@ and @p2@ pass. (.&&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property p1 .&&. p2 = conjoin [property p1, property p2] @@ -958,7 +985,7 @@         classes = classes result ++ classes r,         tables = tables result ++ tables r } --- | Disjunction: 'p1' '.||.' 'p2' passes unless 'p1' and 'p2' simultaneously fail.+-- | Disjunction: @p1@ '.||.' @p2@ passes unless @p1@ and @p2@ simultaneously fail. (.||.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property p1 .||. p2 = disjoin [property p1, property p2] 

@@ -63,35 +63,49 @@     -- ^ total number of failed shrinking steps   } --- | The statistical parameters used by 'checkCoverage'.+-- | The statistical parameters used by 'Test.QuickCheck.checkCoverage'. data Confidence =   Confidence {     certainty :: Integer,-    -- ^ How certain '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@.+    -- ^ 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 'checkCoverage' at the cost of false-    -- positives.+    -- Lower values will speed up 'Test.QuickCheck.checkCoverage' at the cost of+    -- false positives.     ---    -- If you are using '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-    -- '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.+    -- 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, 'checkCoverage' will not reject coverage-    -- levels that are only slightly below the required levels.+    -- ^ 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 'checkCoverage' at the cost of not detecting-    -- minor coverage violations.+    -- 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.

@@ -177,7 +177,7 @@   , maxShrinks      = maxBound   } --- | Tests a property and prints the results to 'stdout'.+-- | 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 'withMaxSuccess'.@@ -190,15 +190,15 @@ quickCheck :: Testable prop => prop -> IO () quickCheck p = quickCheckWith stdArgs p --- | Tests a property, using test arguments, and prints the results to 'stdout'.+-- | 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 'stdout'.+-- | 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 'stdout'.+-- | 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))@@ -258,7 +258,7 @@ 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 'stdout'.+-- | 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/@@ -267,7 +267,7 @@ 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'.+-- | 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/@@ -276,7 +276,7 @@ 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'.+-- | 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/@@ -285,7 +285,7 @@ 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'.+-- | 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/

@@ -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 = $quickCheckAll+

@@ -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