packages feed

quickcheck-classes 0.6.2.2 → 0.6.3.0

raw patch · 44 files changed

+267/−3749 lines, 44 filesdep +quickcheck-classes-basedep ~primitivedep ~primitive-addrdep ~semiringssetup-changed

Dependencies added: quickcheck-classes-base

Dependency ranges changed: primitive, primitive-addr, semirings

Files

− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
changelog.md view
@@ -4,6 +4,18 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [0.6.3.0] - 2019-08-08+### Added+- `gcdDomainLaws`+- `euclideanLaws`+### Changed+- Replaces 0.6.2.2. That release should have been a minor version+  bump since it added new features.+- Support `primitive-0.6.4.0`.+- Extend `semiringLaws` to cover `fromNatural`+- Factor out a subset of laws tests into `quickcheck-classes-base`+  and depend on this library.+ ## [0.6.2.2] - 2019-06-18 ### Added - `numLaws`@@ -35,7 +47,7 @@ ### Change - Support QuickCheck 2.7 and 2.8. This adds `Arbitrary` orphan instances   to the test suite.-- Fix CPP that caused build failures on GHC 7.10 and some old +- Fix CPP that caused build failures on GHC 7.10 and some old   package versions. - Fix compiling the test suite without semigroupoids and compiling with old   versions of transformers.@@ -53,7 +65,7 @@ ### Added - Add `genericLaws` and `generic1Laws` - Add property tests for special classes of semigroups. This includes:-  commutative, idempotent, rectangular band, and exponential. +  commutative, idempotent, rectangular band, and exponential. - `bifoldableLaws`, `bifoldableFunctorLaws` - Add `showLaws`. @@ -169,7 +181,7 @@ ## [0.4.4] - 2018-03-23 ### Added - Cabal flags for controlling whether or not `aeson` and `semigroupoids`-  are used. These are mostly provided to accelerate builds `primitive`'s +  are used. These are mostly provided to accelerate builds `primitive`'s   test suite.  ## [0.4.3] - 2018-03-23
quickcheck-classes.cabal view
@@ -1,5 +1,5 @@ name: quickcheck-classes-version: 0.6.2.2+version: 0.6.3.0 synopsis: QuickCheck common typeclasses description:   This library provides QuickCheck properties to ensure@@ -60,14 +60,17 @@ flag unary-laws   description:     Include infrastructure for testing class laws of unary type constructors.+    It is required that this flag match the value that the `unary-laws` flag+    was given when building `quickcheck-classes-base`.   default: True   manual: True  flag binary-laws   description:     Include infrastructure for testing class laws of binary type constructors.-    Disabling `unary-laws` while keeping `binary-laws` enabled is an unsupported-    configuration.+    It is required that this flag match the value that the `unary-laws` flag+    was given when building `quickcheck-classes-base`. Disabling `unary-laws`+    while keeping `binary-laws` enabled is an unsupported configuration.   default: True   manual: True @@ -79,44 +82,15 @@     Test.QuickCheck.Classes.IsList   other-modules:     Test.QuickCheck.Classes.Alt-    Test.QuickCheck.Classes.Alternative-    Test.QuickCheck.Classes.Applicative     Test.QuickCheck.Classes.Apply-    -- Test.QuickCheck.Classes.Arrow-    Test.QuickCheck.Classes.Bifoldable-    Test.QuickCheck.Classes.Bifunctor-    Test.QuickCheck.Classes.Bitraversable-    Test.QuickCheck.Classes.Bits-    Test.QuickCheck.Classes.Category-    Test.QuickCheck.Classes.Common-    Test.QuickCheck.Classes.Compat-    Test.QuickCheck.Classes.Contravariant-    Test.QuickCheck.Classes.Enum-    Test.QuickCheck.Classes.Eq-    Test.QuickCheck.Classes.Foldable-    Test.QuickCheck.Classes.Functor-    Test.QuickCheck.Classes.Generic-    Test.QuickCheck.Classes.Integral-    Test.QuickCheck.Classes.Ix+    Test.QuickCheck.Classes.Euclidean     Test.QuickCheck.Classes.Json-    Test.QuickCheck.Classes.Monad-    Test.QuickCheck.Classes.MonadFail-    Test.QuickCheck.Classes.MonadPlus-    Test.QuickCheck.Classes.MonadZip-    Test.QuickCheck.Classes.Monoid     Test.QuickCheck.Classes.MVector-    Test.QuickCheck.Classes.Num-    Test.QuickCheck.Classes.Ord     Test.QuickCheck.Classes.Plus     Test.QuickCheck.Classes.Prim-    Test.QuickCheck.Classes.Semigroup     Test.QuickCheck.Classes.Semigroupoid     Test.QuickCheck.Classes.Semiring-    Test.QuickCheck.Classes.Show-    Test.QuickCheck.Classes.ShowRead-    Test.QuickCheck.Classes.Storable     Test.QuickCheck.Classes.Ring-    Test.QuickCheck.Classes.Traversable   build-depends:       base >= 4.5 && < 5     , base-orphans >= 0.1@@ -124,12 +98,13 @@     , contravariant     , QuickCheck >= 2.7     , transformers >= 0.3 && < 0.6-    , primitive >= 0.7 && < 0.8-    , primitive-addr >= 0.1.0.1 && < 0.2+    , primitive >= 0.6.4 && < 0.8+    , primitive-addr >= 0.1.0.2 && < 0.2     , containers >= 0.4.2.1     , semigroups >= 0.17     , tagged     , fail+    , quickcheck-classes-base >=0.6 && <0.7   if impl(ghc > 7.4) && impl(ghc < 7.6)     build-depends: ghc-prim   if impl(ghc > 8.5)@@ -151,7 +126,7 @@     build-depends: semigroupoids     cpp-options: -DHAVE_SEMIGROUPOIDS   if flag(semirings)-    build-depends: semirings >= 0.3.1.1+    build-depends: semirings >= 0.4.2     cpp-options: -DHAVE_SEMIRINGS   if flag(vector)     build-depends: vector >= 0.12
src/Test/QuickCheck/Classes.hs view
@@ -13,74 +13,76 @@ -} module Test.QuickCheck.Classes   ( -- * Running-    lawsCheck-  , lawsCheckMany-  , lawsCheckOne+    QCB.lawsCheck+  , QCB.lawsCheckMany+  , QCB.lawsCheckOne     -- * Properties     -- ** Ground types #if MIN_VERSION_base(4,7,0)-  , bitsLaws+  , QCB.bitsLaws #endif-  , eqLaws-  , numLaws-  , integralLaws-  , ixLaws+  , QCB.eqLaws+  , QCB.numLaws+  , QCB.integralLaws+  , QCB.ixLaws #if MIN_VERSION_base(4,7,0)-  , isListLaws+  , QCB.isListLaws #endif #if HAVE_AESON   , jsonLaws #endif-  , monoidLaws-  , commutativeMonoidLaws-  , semigroupMonoidLaws-  , ordLaws-  , enumLaws-  , boundedEnumLaws+  , QCB.monoidLaws+  , QCB.commutativeMonoidLaws+  , QCB.semigroupMonoidLaws+  , QCB.ordLaws+  , QCB.enumLaws+  , QCB.boundedEnumLaws   , primLaws-  , semigroupLaws-  , commutativeSemigroupLaws-  , exponentialSemigroupLaws-  , idempotentSemigroupLaws-  , rectangularBandSemigroupLaws+  , QCB.semigroupLaws+  , QCB.commutativeSemigroupLaws+  , QCB.exponentialSemigroupLaws+  , QCB.idempotentSemigroupLaws+  , QCB.rectangularBandSemigroupLaws #if HAVE_SEMIRINGS   , semiringLaws   , ringLaws+  , gcdDomainLaws+  , euclideanLaws #endif-  , showLaws-  , showReadLaws-  , storableLaws+  , QCB.showLaws+  , QCB.showReadLaws+  , QCB.storableLaws #if MIN_VERSION_base(4,5,0)-  , genericLaws-  , generic1Laws+  , QCB.genericLaws+  , QCB.generic1Laws #endif #if HAVE_UNARY_LAWS     -- ** Unary type constructors-  , alternativeLaws+  , QCB.alternativeLaws #if HAVE_SEMIGROUPOIDS   , altLaws   , applyLaws #endif-  , applicativeLaws-  , contravariantLaws -  , foldableLaws-  , functorLaws-  , monadLaws-  , monadPlusLaws-  , monadZipLaws+  , QCB.applicativeLaws+  , QCB.contravariantLaws+  , QCB.foldableLaws+  , QCB.functorLaws+  , QCB.monadLaws+  , QCB.monadPlusLaws+  , QCB.monadZipLaws #if HAVE_SEMIGROUPOIDS   , plusLaws   , extendedPlusLaws #endif-  , traversableLaws+  , QCB.traversableLaws #endif #if HAVE_BINARY_LAWS     -- ** Binary type constructors-  , bifoldableLaws-  , bifunctorLaws-  , bitraversableLaws -  , categoryLaws-  , commutativeCategoryLaws+  , QCB.bifoldableLaws+  , QCB.bifunctorLaws+  , QCB.bitraversableLaws +  , QCB.categoryLaws+  , QCB.commutativeCategoryLaws #if HAVE_SEMIGROUPOIDS   , semigroupoidLaws   , commutativeSemigroupoidLaws@@ -90,9 +92,9 @@ #endif #endif     -- * Types-  , Laws(..)-  , Proxy1(..)-  , Proxy2(..)+  , QCB.Laws(..)+  , QCB.Proxy1(..)+  , QCB.Proxy2(..)   ) where  --@@ -100,58 +102,31 @@ --  -- Ground Types-import Test.QuickCheck.Classes.Bits-import Test.QuickCheck.Classes.Enum-import Test.QuickCheck.Classes.Eq-import Test.QuickCheck.Classes.Num-import Test.QuickCheck.Classes.Integral-import Test.QuickCheck.Classes.Ix #if MIN_VERSION_base(4,7,0) import Test.QuickCheck.Classes.IsList #endif #if HAVE_AESON import Test.QuickCheck.Classes.Json #endif-import Test.QuickCheck.Classes.Monoid-import Test.QuickCheck.Classes.Ord import Test.QuickCheck.Classes.Prim-import Test.QuickCheck.Classes.Semigroup #if HAVE_SEMIRINGS+import Test.QuickCheck.Classes.Euclidean import Test.QuickCheck.Classes.Semiring import Test.QuickCheck.Classes.Ring #endif-import Test.QuickCheck.Classes.Show-import Test.QuickCheck.Classes.ShowRead-import Test.QuickCheck.Classes.Storable-#if MIN_VERSION_base(4,5,0)-import Test.QuickCheck.Classes.Generic-#endif -- Unary type constructors #if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Alternative #if HAVE_SEMIGROUPOIDS import Test.QuickCheck.Classes.Alt import Test.QuickCheck.Classes.Apply #endif-import Test.QuickCheck.Classes.Applicative-import Test.QuickCheck.Classes.Contravariant-import Test.QuickCheck.Classes.Foldable-import Test.QuickCheck.Classes.Functor-import Test.QuickCheck.Classes.Monad-import Test.QuickCheck.Classes.MonadPlus-import Test.QuickCheck.Classes.MonadZip #if HAVE_SEMIGROUPOIDS import Test.QuickCheck.Classes.Plus #endif-import Test.QuickCheck.Classes.Traversable #endif  -- Binary type constructors #if HAVE_BINARY_LAWS-import Test.QuickCheck.Classes.Bifunctor-import Test.QuickCheck.Classes.Bifoldable-import Test.QuickCheck.Classes.Bitraversable-import Test.QuickCheck.Classes.Category #if HAVE_SEMIGROUPOIDS import Test.QuickCheck.Classes.Semigroupoid #endif@@ -161,148 +136,4 @@ import Test.QuickCheck.Classes.MVector #endif ------ used below----import Test.QuickCheck-import Test.QuickCheck.Classes.Common (foldMapA, Laws(..))-import Control.Monad-import Data.Foldable-import Data.Monoid (Monoid(..))-import Data.Proxy (Proxy(..))-import Data.Semigroup (Semigroup)-import System.Exit (exitFailure)-import qualified Data.List as List-import qualified Data.Semigroup as SG---- | A convenience function for testing properties in GHCi.--- For example, at GHCi:------ >>> lawsCheck (monoidLaws (Proxy :: Proxy Ordering))--- Monoid: Associative +++ OK, passed 100 tests.--- Monoid: Left Identity +++ OK, passed 100 tests.--- Monoid: Right Identity +++ OK, passed 100 tests.------ Assuming that the 'Arbitrary' instance for 'Ordering' is good, we now--- have confidence that the 'Monoid' instance for 'Ordering' satisfies--- the monoid laws.-lawsCheck :: Laws -> IO ()-lawsCheck (Laws className properties) = do-  flip foldMapA properties $ \(name,p) -> do-    putStr (className ++ ": " ++ name ++ " ")-    quickCheck p---- | A convenience function that allows one to check many typeclass--- instances of the same type.------ >>> specialisedLawsCheckMany (Proxy :: Proxy Word) [jsonLaws, showReadLaws]--- ToJSON/FromJSON: Encoding Equals Value +++ OK, passed 100 tests.--- ToJSON/FromJSON: Partial Isomorphism +++ OK, passed 100 tests.--- Show/Read: Partial Isomorphism +++ OK, passed 100 tests.-lawsCheckOne :: Proxy a -> [Proxy a -> Laws] -> IO ()-lawsCheckOne p ls = foldlMapM (lawsCheck . ($ p)) ls---- | A convenience function for checking multiple typeclass instances---   of multiple types. Consider the following Haskell source file:------ @--- import Data.Proxy (Proxy(..))--- import Data.Map (Map)--- import Data.Set (Set)------ -- A 'Proxy' for 'Set' 'Int'.--- setInt :: Proxy (Set Int)--- setInt = Proxy------ -- A 'Proxy' for 'Map' 'Int' 'Int'.--- mapInt :: Proxy (Map Int Int)--- mapInt = Proxy------ myLaws :: Proxy a -> [Laws]--- myLaws p = [eqLaws p, monoidLaws p]------ namedTests :: [(String, [Laws])]--- namedTests =---   [ ("Set Int", myLaws setInt)---   , ("Map Int Int", myLaws mapInt)---   ]--- @------ Now, in GHCi:------ >>> lawsCheckMany namedTests------ @--- Testing properties for common typeclasses--- ---------------- -- Set Int ----- ------------------- Eq: Transitive +++ OK, passed 100 tests.--- Eq: Symmetric +++ OK, passed 100 tests.--- Eq: Reflexive +++ OK, passed 100 tests.--- Monoid: Associative +++ OK, passed 100 tests.--- Monoid: Left Identity +++ OK, passed 100 tests.--- Monoid: Right Identity +++ OK, passed 100 tests.--- Monoid: Concatenation +++ OK, passed 100 tests.------ -------------------- -- Map Int Int ----- ----------------------- Eq: Transitive +++ OK, passed 100 tests.--- Eq: Symmetric +++ OK, passed 100 tests.--- Eq: Reflexive +++ OK, passed 100 tests.--- Monoid: Associative +++ OK, passed 100 tests.--- Monoid: Left Identity +++ OK, passed 100 tests.--- Monoid: Right Identity +++ OK, passed 100 tests.--- Monoid: Concatenation +++ OK, passed 100 tests.--- @------ In the case of a failing test, the program terminates with--- exit code 1.-lawsCheckMany ::-     [(String,[Laws])] -- ^ Element is type name paired with typeclass laws-  -> IO ()-lawsCheckMany xs = do-  putStrLn "Testing properties for common typeclasses"-  r <- flip foldMapA xs $ \(typeName,laws) -> do-    putStrLn $ List.replicate (length typeName + 6) '-'-    putStrLn $ "-- " ++ typeName ++ " --"-    putStrLn $ List.replicate (length typeName + 6) '-'-    flip foldMapA laws $ \(Laws typeClassName properties) -> do-      flip foldMapA properties $ \(name,p) -> do-        putStr (typeClassName ++ ": " ++ name ++ " ")-        r <- quickCheckResult p-        return $ case r of-          Success{} -> Good-          _ -> Bad-  putStrLn ""-  case r of-    Good -> putStrLn "All tests succeeded"-    Bad -> do-      putStrLn "One or more tests failed"-      exitFailure--data Status = Bad | Good--instance Semigroup Status where-  Good <> x = x-  Bad <> _ = Bad--instance Monoid Status where-  mempty = Good-  mappend = (SG.<>)---- | In older versions of GHC, Proxy is not poly-kinded,---   so we provide Proxy1.-data Proxy1 (f :: * -> *) = Proxy1---- | In older versions of GHC, Proxy is not poly-kinded,---   so we provide Proxy2.-data Proxy2 (f :: * -> * -> *) = Proxy2---- This is used internally to work around a missing Monoid--- instance for IO on older GHCs.-foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b-foldlMapM f = foldlM (\b a -> liftM (mappend b) (f a)) mempty+import qualified Test.QuickCheck.Classes.Base as QCB
src/Test/QuickCheck/Classes/Alt.hs view
@@ -23,8 +23,7 @@ import Data.Functor.Classes (Eq1,Show1) import Test.QuickCheck.Property (Property) -import Test.QuickCheck.Classes.Common-import Test.QuickCheck.Classes.Compat (eq1)+import Test.QuickCheck.Classes.Internal  -- | Tests the following alt properties: --
− src/Test/QuickCheck/Classes/Alternative.hs 
@@ -1,80 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Alternative-  (-#if HAVE_UNARY_LAWS-    alternativeLaws-#endif-  ) where--import Control.Applicative (Alternative(..))-import Test.QuickCheck hiding ((.&.))-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Arbitrary (Arbitrary1(..))-import Data.Functor.Classes (Eq1,Show1)-#endif-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1)-#endif--#if HAVE_UNARY_LAWS---- | Tests the following alternative properties:------ [/Left Identity/]---   @'empty' '<|>' x ≡ x@--- [/Right Identity/]---   @x '<|>' 'empty' ≡ x@--- [/Associativity/]---   @a '<|>' (b '<|>' c) ≡ (a '<|>' b) '<|>' c)@-alternativeLaws ::-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Alternative f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Laws-alternativeLaws p = Laws "Alternative"-  [ ("Left Identity", alternativeLeftIdentity p)-  , ("Right Identity", alternativeRightIdentity p)-  , ("Associativity", alternativeAssociativity p)-  ]--alternativeLeftIdentity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Alternative f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-alternativeLeftIdentity _ = property $ \(Apply (a :: f Integer)) -> (eq1 (empty <|> a) a)--alternativeRightIdentity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Alternative f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-alternativeRightIdentity _ = property $ \(Apply (a :: f Integer)) -> (eq1 a (empty <|> a))--alternativeAssociativity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Alternative f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-alternativeAssociativity _ = property $ \(Apply (a :: f Integer)) (Apply (b :: f Integer)) (Apply (c :: f Integer)) -> eq1 (a <|> (b <|> c)) ((a <|> b) <|> c)--#endif
− src/Test/QuickCheck/Classes/Applicative.hs 
@@ -1,114 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Applicative-  (-#if HAVE_UNARY_LAWS-    applicativeLaws-#endif-  ) where--import Control.Applicative-import Test.QuickCheck hiding ((.&.))-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Arbitrary (Arbitrary1(..))-import Data.Functor.Classes (Eq1,Show1)-#endif-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1)-#endif--#if HAVE_UNARY_LAWS---- | Tests the following applicative properties:------ [/Identity/]---   @'pure' 'id' '<*>' v ≡ v@--- [/Composition/]---   @'pure' ('.') '<*>' u '<*>' v '<*>' w ≡ u '<*>' (v '<*>' w)@--- [/Homomorphism/]---   @'pure' f '<*>' 'pure' x ≡ 'pure' (f x)@--- [/Interchange/]---   @u '<*>' 'pure' y ≡ 'pure' ('$' y) '<*>' u@--- [/LiftA2 (1)/]---   @('<*>') ≡ 'liftA2' 'id'@-applicativeLaws ::-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Applicative f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Laws-applicativeLaws p = Laws "Applicative"-  [ ("Identity", applicativeIdentity p)-  , ("Composition", applicativeComposition p)-  , ("Homomorphism", applicativeHomomorphism p)-  , ("Interchange", applicativeInterchange p)-  , ("LiftA2 Part 1", applicativeLiftA2_1 p)-    -- todo: liftA2 part 2, we need an equation of two variables for this-  ]--applicativeIdentity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Applicative f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-applicativeIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (pure id <*> a) a--applicativeComposition :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Applicative f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-applicativeComposition _ = property $ \(Apply (u' :: f QuadraticEquation)) (Apply (v' :: f QuadraticEquation)) (Apply (w :: f Integer)) ->-  let u = fmap runQuadraticEquation u'-      v = fmap runQuadraticEquation v'-   in eq1 (pure (.) <*> u <*> v <*> w) (u <*> (v <*> w))--applicativeHomomorphism :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a))-#else-  (Applicative f, Eq1 f, Show1 f)-#endif-  => proxy f -> Property-applicativeHomomorphism _ = property $ \(e :: QuadraticEquation) (a :: Integer) ->-  let f = runQuadraticEquation e-   in eq1 (pure f <*> pure a) (pure (f a) :: f Integer)--applicativeInterchange :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Applicative f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-applicativeInterchange _ = property $ \(Apply (u' :: f QuadraticEquation)) (y :: Integer) ->-  let u = fmap runQuadraticEquation u'-   in eq1 (u <*> pure y) (pure ($ y) <*> u)--applicativeLiftA2_1 :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Applicative f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-applicativeLiftA2_1 _ = property $ \(Apply (f' :: f QuadraticEquation)) (Apply (x :: f Integer)) ->-  let f = fmap runQuadraticEquation f'-   in eq1 (liftA2 id f x) (f <*> x)--#endif
src/Test/QuickCheck/Classes/Apply.hs view
@@ -23,8 +23,7 @@ import Data.Functor.Classes (Eq1,Show1) import Test.QuickCheck.Property (Property) -import Test.QuickCheck.Classes.Common-import Test.QuickCheck.Classes.Compat (eq1)+import Test.QuickCheck.Classes.Internal  type ApplyProp proxy f = #if HAVE_QUANTIFIED_CONSTRAINTS
− src/Test/QuickCheck/Classes/Bifoldable.hs 
@@ -1,124 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Bifoldable-  (-#if HAVE_BINARY_LAWS-    bifoldableLaws-  , bifoldableFunctorLaws-#endif-  ) where--#if HAVE_BINARY_LAWS-import Data.Bifoldable(Bifoldable(..))-import Data.Bifunctor (Bifunctor(..))-import Test.QuickCheck hiding ((.&.))-import Data.Functor.Classes (Eq2,Show2)-import Test.QuickCheck.Property (Property)-import Data.Monoid-import Data.Orphans ()-import Test.QuickCheck.Classes.Common-#endif--#if HAVE_BINARY_LAWS---- | Tests the following 'Bifunctor' properties:------ [/Bifold Identity/]---   @'bifold' ≡ 'bifoldMap' 'id' 'id'@  --- [/BifoldMap Identity/]---   @'bifoldMap' f g ≡ 'bifoldr' ('mappend' '.' f) ('mappend' '.' g) 'mempty'@--- [/Bifoldr Identity/] ---   @'bifoldr' f g z t ≡ 'appEndo' ('bifoldMap' ('Endo' '.' f) ('Endo' '.' g) t) z@------ /Note/: This property test is only available when this package is built with--- @base-4.10+@ or @transformers-0.5+@.-bifoldableLaws :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Bifoldable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b))-#else-  (Bifoldable f, Eq2 f, Show2 f, Arbitrary2 f)-#endif-  => proxy f -> Laws-bifoldableLaws p = Laws "Bifoldable"-  [ ("Bifold Identity", bifoldIdentity p)-  , ("BifoldMap Identity", bifoldMapIdentity p)-  , ("Bifoldr Identity", bifoldrIdentity p)-  ]---- | Tests the following 'Bifunctor'/'Bifoldable' properties:------ [/Bifold Identity/]---   @'bifoldMap' f g ≡ 'bifold' '.' 'bimap' f g@--- [/BifoldMap Identity/]---   @'bifoldMap' f g '.' 'bimap' h i ≡ 'bifoldMap' (f '.' h) (g '.' i)@------ /Note/: This property test is only available when this package is built with--- @base-4.10+@ or @transformers-0.5+@.-bifoldableFunctorLaws :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Bifoldable f, Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b))-#else-  (Bifoldable f, Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f)-#endif-  => proxy f -> Laws-bifoldableFunctorLaws p = Laws "Bifoldable/Bifunctor"-  [ ("Bifoldable Bifunctor Law", bifoldableFunctorLaw p)-  , ("Bifoldable Bifunctor Law Implication", bifoldableFunctorImplication p)-  ]--bifoldableFunctorLaw :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Bifoldable f, Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b))-#else-  (Bifoldable f, Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f)-#endif-  => proxy f -> Property-bifoldableFunctorLaw _ = property $ \(Apply2 (x :: f Integer Integer)) -> bifoldMap Sum Sum x == (bifold (bimap Sum Sum x))--bifoldableFunctorImplication :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Bifoldable f, Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b))-#else-  (Bifoldable f, Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f)-#endif-  => proxy f -> Property-bifoldableFunctorImplication _ = property $ \(Apply2 (x :: f Integer Integer)) -> bifoldMap Sum Sum (bimap Product Product x) == bifoldMap (Sum . Product) (Sum . Product) x--bifoldIdentity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Bifoldable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b))-#else-  (Bifoldable f, Eq2 f, Show2 f, Arbitrary2 f)-#endif-  => proxy f -> Property-bifoldIdentity _ = property $ \(Apply2 (x :: f (Sum Integer) (Sum Integer))) -> (bifold x) == (bifoldMap id id x)--bifoldMapIdentity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Bifoldable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b))-#else-  (Bifoldable f, Eq2 f, Show2 f, Arbitrary2 f)-#endif-  => proxy f -> Property-bifoldMapIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> bifoldMap Sum Sum x == bifoldr (mappend . Sum) (mappend . Sum) mempty x--bifoldrIdentity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Bifoldable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b))-#else-  (Bifoldable f, Eq2 f, Show2 f, Arbitrary2 f)-#endif-  => proxy f -> Property-bifoldrIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) ->-  let f _ _ = mempty-      g _ _ = mempty-  in bifoldr f g (mempty :: Sum Integer) x == appEndo (bifoldMap (Endo . f) (Endo . g) x) mempty--#endif
− src/Test/QuickCheck/Classes/Bifunctor.hs 
@@ -1,94 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Bifunctor-  (-#if HAVE_BINARY_LAWS-    bifunctorLaws-#endif-  ) where--import Data.Bifunctor(Bifunctor(..))-import Test.QuickCheck hiding ((.&.))-#if HAVE_BINARY_LAWS-import Data.Functor.Classes (Eq2,Show2)-#endif-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common-#if HAVE_BINARY_LAWS-import Test.QuickCheck.Classes.Compat (eq2)-#endif--#if HAVE_BINARY_LAWS---- | Tests the following 'Bifunctor' properties:------ [/Identity/]---   @'bimap' 'id' 'id' ≡ 'id'@--- [/First Identity/]---   @'first' 'id' ≡ 'id'@--- [/Second Identity/] ---   @'second' 'id' ≡ 'id'@--- [/Bifunctor Composition/]---   @'bimap' f g ≡ 'first' f '.' 'second' g@ ------ /Note/: This property test is only available when this package is built with--- @base-4.9+@ or @transformers-0.5+@.-bifunctorLaws :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b))-#else-  (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f)-#endif-  => proxy f -> Laws-bifunctorLaws p = Laws "Bifunctor"-  [ ("Identity", bifunctorIdentity p)-  , ("First Identity", bifunctorFirstIdentity p)-  , ("Second Identity", bifunctorSecondIdentity p)-  , ("Bifunctor Composition", bifunctorComposition p)-  ]--bifunctorIdentity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b))-#else-  (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f)-#endif-  => proxy f -> Property-bifunctorIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq2 (bimap id id x) x--bifunctorFirstIdentity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b))-#else-  (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f)-#endif-  => proxy f -> Property-bifunctorFirstIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq2 (first id x) x--bifunctorSecondIdentity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b))-#else-  (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f)-#endif-  => proxy f -> Property-bifunctorSecondIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq2 (second id x) x--bifunctorComposition :: forall proxy f. -#if HAVE_QUANTIFIED_CONSTRAINTS-  (Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b))-#else-  (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f)-#endif-  => proxy f -> Property-bifunctorComposition _ = property $ \(Apply2 (z :: f Integer Integer)) -> eq2 (bimap id id z) ((first id . second id) z)--#endif
− src/Test/QuickCheck/Classes/Bitraversable.hs 
@@ -1,97 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Bitraversable-  (-#if HAVE_BINARY_LAWS-    bitraversableLaws-#endif-  ) where--import Data.Bitraversable(Bitraversable(..))-import Test.QuickCheck hiding ((.&.))-#if HAVE_BINARY_LAWS-import Data.Functor.Compose (Compose(..))-import Data.Functor.Identity (Identity(..))-import Data.Functor.Classes (Eq2,Show2)-#endif-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common-#if HAVE_BINARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1_2)-#endif--#if HAVE_BINARY_LAWS---- | Tests the following 'Bitraversable' properties:------ [/Naturality/]---   @'bitraverse' (t '.' f) (t '.' g) ≡ t '.' 'bitraverse' f g@ for every applicative transformation @t@--- [/Identity/]---   @'bitraverse' 'Identity' 'Identity' ≡ 'Identity'@--- [/Composition/] ---   @'Compose' '.' 'fmap' ('bitraverse' g1 g2) '.' 'bitraverse' f1 f2 ≡ 'bitraverse' ('Compose' '.' 'fmap' g1 g2 '.' f1) ('Compose' '.' 'fmap' g2 '.' f2)@------ /Note/: This property test is only available when this package is built with--- @base-4.9+@ or @transformers-0.5+@.-bitraversableLaws :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Bitraversable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b))-#else-  (Bitraversable f, Eq2 f, Show2 f, Arbitrary2 f)-#endif-  => proxy f -> Laws-bitraversableLaws p = Laws "Bitraversable"-  [ ("Naturality", bitraversableNaturality p)-  , ("Identity", bitraversableIdentity p)-  , ("Composition", bitraversableComposition p)-  ]--bitraversableNaturality :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Bitraversable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b))-#else-  (Bitraversable f, Eq2 f, Show2 f, Arbitrary2 f)-#endif-  => proxy f -> Property-bitraversableNaturality _ = property $ \(Apply2 (x :: f Integer Integer)) ->-  let t = apTrans-      f = func4-      g = func4-      x' = bitraverse (t . f) (t . g) x-      y' = t (bitraverse f g x)-  in eq1_2 x' y'--bitraversableIdentity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Bitraversable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b))-#else-  (Bitraversable f, Eq2 f, Show2 f, Arbitrary2 f)-#endif-  => proxy f -> Property-bitraversableIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq1_2 (bitraverse Identity Identity x) (Identity x)--bitraversableComposition :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Bitraversable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b))-#else-  (Bitraversable f, Eq2 f, Show2 f, Arbitrary2 f)-#endif-  => proxy f -> Property-bitraversableComposition _ = property $ \(Apply2 (x :: f Integer Integer)) ->-  let f1 = func6-      f2 = func5-      g1 = func4-      g2 = func4-      x' = Compose . fmap (bitraverse g1 g2) . bitraverse f1 f2 $ x-      y' = bitraverse (Compose . fmap g1 . f1) (Compose . fmap g2 . f2) x-  in eq1_2 x' y'--#endif
− src/Test/QuickCheck/Classes/Bits.hs 
@@ -1,182 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Bits-  (-#if MIN_VERSION_base(4,7,0)-  bitsLaws-#endif-  ) where--import Data.Bits-import Data.Proxy (Proxy)-import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Property (Property)--import qualified Data.Set as S--import Test.QuickCheck.Classes.Common (Laws(..), myForAllShrink)---- | Tests the following properties:------ [/Conjunction Idempotence/]---   @n .&. n ≡ n@--- [/Disjunction Idempotence/]---   @n .|. n ≡ n@--- [/Double Complement/]---   @complement (complement n) ≡ n@--- [/Set Bit/]---   @setBit n i ≡ n .|. bit i@--- [/Clear Bit/]---   @clearBit n i ≡ n .&. complement (bit i)@--- [/Complement Bit/]---   @complementBit n i ≡ xor n (bit i)@--- [/Clear Zero/]---   @clearBit zeroBits i ≡ zeroBits@--- [/Set Zero/]---   @setBit zeroBits i ≡ bit i@--- [/Test Zero/]---   @testBit zeroBits i ≡ False@--- [/Pop Zero/]---   @popCount zeroBits ≡ 0@--- [/Count Leading Zeros of Zero/]---   @countLeadingZeros zeroBits ≡ finiteBitSize ⊥@--- [/Count Trailing Zeros of Zero/]---   @countTrailingZeros zeroBits ≡ finiteBitSize ⊥@------ All of the useful instances of the 'Bits' typeclass--- also have 'FiniteBits' instances, so these property--- tests actually require that instance as well.------ /Note:/ This property test is only available when--- using @base-4.7@ or newer.-#if MIN_VERSION_base(4,7,0)-bitsLaws :: (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Laws-bitsLaws p = Laws "Bits"-  [ ("Conjunction Idempotence", bitsConjunctionIdempotence p)-  , ("Disjunction Idempotence", bitsDisjunctionIdempotence p)-  , ("Double Complement", bitsDoubleComplement p)-  , ("Set Bit", bitsSetBit p)-  , ("Clear Bit", bitsClearBit p)-  , ("Complement Bit", bitsComplementBit p)-  , ("Clear Zero", bitsClearZero p)-  , ("Set Zero", bitsSetZero p)-  , ("Test Zero", bitsTestZero p)-  , ("Pop Zero", bitsPopZero p)-#if MIN_VERSION_base(4,8,0)-  , ("Count Leading Zeros of Zero", bitsCountLeadingZeros p)-  , ("Count Trailing Zeros of Zero", bitsCountTrailingZeros p)-#endif-  ]-#endif--#if MIN_VERSION_base(4,7,0)-newtype BitIndex a = BitIndex Int--instance FiniteBits a => Arbitrary (BitIndex a) where-  arbitrary = let n = finiteBitSize (undefined :: a) in if n > 0-    then fmap BitIndex (choose (0,n - 1))-    else return (BitIndex 0)-  shrink (BitIndex x) = if x > 0 then map BitIndex (S.toList (S.fromList [x - 1, div x 2, 0])) else []--bitsConjunctionIdempotence :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property-bitsConjunctionIdempotence _ = myForAllShrink False (const True)-  (\(n :: a) -> ["n = " ++ show n])-  "n .&. n"-  (\n -> n .&. n)-  "n"-  (\n -> n)--bitsDisjunctionIdempotence :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property-bitsDisjunctionIdempotence _ = myForAllShrink False (const True)-  (\(n :: a) -> ["n = " ++ show n])-  "n .|. n"-  (\n -> n .|. n)-  "n"-  (\n -> n)--bitsDoubleComplement :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property-bitsDoubleComplement _ = myForAllShrink False (const True)-  (\(n :: a) -> ["n = " ++ show n])-  "complement (complement n)"-  (\n -> complement (complement n))-  "n"-  (\n -> n)--bitsSetBit :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property-bitsSetBit _ = myForAllShrink True (const True)-  (\(n :: a, BitIndex i :: BitIndex a) -> ["n = " ++ show n, "i = " ++ show i])-  "setBit n i"-  (\(n,BitIndex i) -> setBit n i)-  "n .|. bit i"-  (\(n,BitIndex i) -> n .|. bit i)--bitsClearBit :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property-bitsClearBit _ = myForAllShrink True (const True)-  (\(n :: a, BitIndex i :: BitIndex a) -> ["n = " ++ show n, "i = " ++ show i])-  "clearBit n i"-  (\(n,BitIndex i) -> clearBit n i)-  "n .&. complement (bit i)"-  (\(n,BitIndex i) -> n .&. complement (bit i))--bitsComplementBit :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property-bitsComplementBit _ = myForAllShrink True (const True)-  (\(n :: a, BitIndex i :: BitIndex a) -> ["n = " ++ show n, "i = " ++ show i])-  "complementBit n i"-  (\(n,BitIndex i) -> complementBit n i)-  "xor n (bit i)"-  (\(n,BitIndex i) -> xor n (bit i))--bitsClearZero :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property-bitsClearZero _ = myForAllShrink False (const True)-  (\(BitIndex n :: BitIndex a) -> ["n = " ++ show n])-  "clearBit zeroBits n"-  (\(BitIndex n) -> clearBit zeroBits n :: a)-  "zeroBits"-  (\_ -> zeroBits)--bitsSetZero :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property-bitsSetZero _ = myForAllShrink True (const True)-  (\(BitIndex i :: BitIndex a) -> ["i = " ++ show i])-  "setBit zeroBits i"-  (\(BitIndex i) -> setBit (zeroBits :: a) i)-  "bit i"-  (\(BitIndex i) -> bit i)--bitsTestZero :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property-bitsTestZero _ = myForAllShrink True (const True)-  (\(BitIndex i :: BitIndex a) -> ["i = " ++ show i])-  "testBit zeroBits i"-  (\(BitIndex i) -> testBit (zeroBits :: a) i)-  "False"-  (\_ -> False)--bitsPopZero :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property-bitsPopZero _ = myForAllShrink True (const True)-  (\() -> [])-  "popCount zeroBits"-  (\() -> popCount (zeroBits :: a))-  "0"-  (\() -> 0)-#endif--#if MIN_VERSION_base(4,8,0)-bitsCountLeadingZeros :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property-bitsCountLeadingZeros _ = myForAllShrink True (const True)-  (\() -> [])-  "countLeadingZeros zeroBits"-  (\() -> countLeadingZeros (zeroBits :: a))-  "finiteBitSize undefined"-  (\() -> finiteBitSize (undefined :: a))--bitsCountTrailingZeros :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property-bitsCountTrailingZeros _ = myForAllShrink True (const True)-  (\() -> [])-  "countTrailingZeros zeroBits"-  (\() -> countTrailingZeros (zeroBits :: a))-  "finiteBitSize undefined"-  (\() -> finiteBitSize (undefined :: a))-#endif
− src/Test/QuickCheck/Classes/Category.hs 
@@ -1,111 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Category-  (-#if HAVE_BINARY_LAWS-    categoryLaws-  , commutativeCategoryLaws-#endif-  ) where--import Prelude hiding (id, (.))-import Control.Category (Category(..))-import Test.QuickCheck hiding ((.&.))-#if HAVE_BINARY_LAWS-import Data.Functor.Classes (Eq2,Show2)-#endif-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common-#if HAVE_BINARY_LAWS-import Test.QuickCheck.Classes.Compat (eq2)-#endif--#if HAVE_BINARY_LAWS---- | Tests the following 'Category' properties:------ [/Right Identity/]---   @f '.' 'id' ≡ f@--- [/Left Identity/]---   @'id' '.' f ≡ f@--- [/Associativity/]---   @f '.' (g '.' h) ≡ (f '.' g) '.' h@------ /Note/: This property test is only available when this package is built with--- @base-4.9+@ or @transformers-0.5+@.-categoryLaws :: forall proxy c.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b))-#else-  (Category c, Eq2 c, Show2 c, Arbitrary2 c)-#endif-  => proxy c -> Laws-categoryLaws p = Laws "Category"-  [ ("Right Identity", categoryRightIdentity p)-  , ("Left Identity", categoryLeftIdentity p)-  , ("Associativity", categoryAssociativity p)-  ]---- | Test everything from 'categoryLaws' plus the following:------ [/Commutative/]---   @f '.' g ≡ g '.' f@------ /Note/: This property test is only available when this package is built with--- @base-4.9+@ or @transformers-0.5+@.-commutativeCategoryLaws :: forall proxy c.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b))-#else-  (Category c, Eq2 c, Show2 c, Arbitrary2 c)-#endif-  => proxy c -> Laws-commutativeCategoryLaws p = Laws "Commutative Category" $ lawsProperties (categoryLaws p) ++-  [ ("Commutative", categoryCommutativity p)-  ]--categoryRightIdentity :: forall proxy c.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b))-#else-  (Category c, Eq2 c, Show2 c, Arbitrary2 c)-#endif-  => proxy c -> Property-categoryRightIdentity _ = property $ \(Apply2 (x :: c Integer Integer)) -> eq2 (x . id) x--categoryLeftIdentity :: forall proxy c.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b))-#else-  (Category c, Eq2 c, Show2 c, Arbitrary2 c)-#endif-  => proxy c -> Property-categoryLeftIdentity _ = property $ \(Apply2 (x :: c Integer Integer)) -> eq2 (id . x) x--categoryAssociativity :: forall proxy c.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b))-#else-  (Category c, Eq2 c, Show2 c, Arbitrary2 c)-#endif-  => proxy c -> Property-categoryAssociativity _ = property $ \(Apply2 (f :: c Integer Integer)) (Apply2 (g :: c Integer Integer)) (Apply2 (h :: c Integer Integer)) -> eq2 (f . (g . h)) ((f . g) . h)--categoryCommutativity :: forall proxy c.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b))-#else-  (Category c, Eq2 c, Show2 c, Arbitrary2 c)-#endif-  => proxy c -> Property-categoryCommutativity _ = property $ \(Apply2 (f :: c Integer Integer)) (Apply2 (g :: c Integer Integer)) -> eq2 (f . g) (g . f)--#endif
− src/Test/QuickCheck/Classes/Common.hs 
@@ -1,496 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Common-  ( Laws(..)-  , foldMapA -  , myForAllShrink-  -- Modifiers-  , SmallList(..)-  , VerySmallList(..)-  , ShowReadPrecedence(..)--  -- only used for higher-kinded types-  , Apply(..)-#if HAVE_BINARY_LAWS-  , Apply2(..)-#endif-  , Triple(..)-  , ChooseFirst(..)-  , ChooseSecond(..)-  , LastNothing(..)-  , Bottom(..)-  , LinearEquation(..)-#if HAVE_UNARY_LAWS-  , LinearEquationM(..)-#endif-  , QuadraticEquation(..)-  , LinearEquationTwo(..)-#if HAVE_UNARY_LAWS-  , nestedEq1-  , propNestedEq1-  , toSpecialApplicative-#endif-  , flipPair-#if HAVE_UNARY_LAWS-  , apTrans-#endif-  , func1-  , func2-  , func3-#if HAVE_UNARY_LAWS-  , func4-#endif-  , func5-  , func6-  , reverseTriple-  , runLinearEquation-#if HAVE_UNARY_LAWS-  , runLinearEquationM-#endif-  , runQuadraticEquation-  , runLinearEquationTwo-  ) where--import Control.Applicative-import Control.Monad-import Data.Foldable-import Data.Traversable-import Data.Monoid-#if defined(HAVE_UNARY_LAWS)-import Data.Functor.Classes (Eq1(..),Show1(..),eq1,showsPrec1)-import Data.Functor.Compose-#endif-#if defined(HAVE_BINARY_LAWS)-import Data.Functor.Classes (Eq2(..),Show2(..),eq2,showsPrec2)-#endif-import Data.Semigroup (Semigroup)-import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Property (Property(..))--import qualified Control.Monad.Trans.Writer.Lazy as WL-import qualified Data.List as L-import qualified Data.Monoid as MND-import qualified Data.Semigroup as SG-import qualified Data.Set as S---- | A set of laws associated with a typeclass.-data Laws = Laws-  { lawsTypeclass :: String-    -- ^ Name of the typeclass whose laws are tested-  , lawsProperties :: [(String,Property)]-    -- ^ Pairs of law name and property-  }--myForAllShrink :: (Arbitrary a, Show b, Eq b)-  => Bool -- Should we show the RHS. It's better not to show it-          -- if the RHS is equal to the input.-  -> (a -> Bool) -- is the value a valid input-  -> (a -> [String]) -- show the 'a' values-  -> String -- show the LHS-  -> (a -> b) -- the function that makes the LHS-  -> String -- show the RHS-  -> (a -> b) -- the function that makes the RHS-  -> Property-myForAllShrink displayRhs isValid showInputs name1 calc1 name2 calc2 =-#if MIN_VERSION_QuickCheck(2,9,0)-  again $-#endif-  MkProperty $-  arbitrary >>= \x ->-    unProperty $-    shrinking shrink x $ \x' ->-      let b1 = calc1 x'-          b2 = calc2 x'-          sb1 = show b1-          sb2 = show b2-          description = "  Description: " ++ name1 ++ " = " ++ name2-          err = description ++ "\n" ++ unlines (map ("  " ++) (showInputs x')) ++ "  " ++ name1 ++ " = " ++ sb1 ++ (if displayRhs then "\n  " ++ name2 ++ " = " ++ sb2 else "")-       in isValid x' ==> counterexample err (b1 == b2)--#if HAVE_UNARY_LAWS--- the Functor constraint is needed for transformers-0.4-#if HAVE_QUANTIFIED_CONSTRAINTS-nestedEq1 :: (forall x. Eq x => Eq (f x), forall x. Eq x => Eq (g x), Eq a) => f (g a) -> f (g a) -> Bool-nestedEq1 = (==)-#else-nestedEq1 :: (Eq1 f, Eq1 g, Eq a, Functor f) => f (g a) -> f (g a) -> Bool-nestedEq1 x y = eq1 (Compose x) (Compose y)-#endif--#if HAVE_QUANTIFIED_CONSTRAINTS-propNestedEq1 :: (forall x. Eq x => Eq (f x), forall x. Eq x => Eq (g x), Eq a, forall x. Show x => Show (f x), forall x. Show x => Show (g x), Show a)-  => f (g a) -> f (g a) -> Property-propNestedEq1 = (===)-#else-propNestedEq1 :: (Eq1 f, Eq1 g, Eq a, Show1 f, Show1 g, Show a, Functor f)-  => f (g a) -> f (g a) -> Property-propNestedEq1 x y = Compose x === Compose y-#endif--toSpecialApplicative ::-     Compose Triple ((,) (S.Set Integer)) Integer-  -> Compose Triple (WL.Writer (S.Set Integer)) Integer-toSpecialApplicative (Compose (Triple a b c)) =-  Compose (Triple (WL.writer (flipPair a)) (WL.writer (flipPair b)) (WL.writer (flipPair c)))-#endif--flipPair :: (a,b) -> (b,a)-flipPair (x,y) = (y,x)--#if HAVE_UNARY_LAWS--- Reverse the list and accumulate the writers. We cannot--- use Sum or Product or else it wont actually be a valid--- applicative transformation.-apTrans ::-     Compose Triple (WL.Writer (S.Set Integer)) a-  -> Compose (WL.Writer (S.Set Integer)) Triple a-apTrans (Compose xs) = Compose (sequenceA (reverseTriple xs))-#endif--func1 :: Integer -> (Integer,Integer)-func1 i = (div (i + 5) 3, i * i - 2 * i + 1)--func2 :: (Integer,Integer) -> (Bool,Either Ordering Integer)-func2 (a,b) = (odd a, if even a then Left (compare a b) else Right (b + 2))--func3 :: Integer -> SG.Sum Integer-func3 i = SG.Sum (3 * i * i - 7 * i + 4)--#if HAVE_UNARY_LAWS-func4 :: Integer -> Compose Triple (WL.Writer (S.Set Integer)) Integer-func4 i = Compose $ Triple-  (WL.writer (i * i, S.singleton (i * 7 + 5)))-  (WL.writer (i + 2, S.singleton (i * i + 3)))-  (WL.writer (i * 7, S.singleton 4))-#endif--func5 :: Integer -> Triple Integer-func5 i = Triple (i + 2) (i * 3) (i * i)--func6 :: Integer -> Triple Integer-func6 i = Triple (i * i * i) (4 * i - 7) (i * i * i)--data Triple a = Triple a a a-  deriving (Show,Eq)--tripleLiftEq :: (a -> b -> Bool) -> Triple a -> Triple b -> Bool-tripleLiftEq p (Triple a1 b1 c1) (Triple a2 b2 c2) =-  p a1 a2 && p b1 b2 && p c1 c2--#if HAVE_UNARY_LAWS-instance Eq1 Triple where-#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)-  liftEq = tripleLiftEq-#else-  eq1 = tripleLiftEq (==)-#endif-#endif--tripleLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Triple a -> ShowS-tripleLiftShowsPrec elemShowsPrec _ p (Triple a b c) = showParen (p > 10)-  $ showString "Triple "-  . elemShowsPrec 11 a-  . showString " "-  . elemShowsPrec 11 b-  . showString " "-  . elemShowsPrec 11 c--#if HAVE_UNARY_LAWS-instance Show1 Triple where-#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)-  liftShowsPrec = tripleLiftShowsPrec-#else-  showsPrec1 = tripleLiftShowsPrec showsPrec showList-#endif-#endif--#if HAVE_UNARY_LAWS-instance Arbitrary1 Triple where-  liftArbitrary x = Triple <$> x <*> x <*> x--instance Arbitrary a => Arbitrary (Triple a) where-  arbitrary = liftArbitrary arbitrary-#else-instance Arbitrary a => Arbitrary (Triple a) where-  arbitrary = Triple <$> arbitrary <*> arbitrary <*> arbitrary-#endif--instance Functor Triple where-  fmap f (Triple a b c) = Triple (f a) (f b) (f c)--instance Applicative Triple where-  pure a = Triple a a a-  Triple f g h <*> Triple a b c = Triple (f a) (g b) (h c)--instance Foldable Triple where-  foldMap f (Triple a b c) = f a MND.<> f b MND.<> f c--instance Traversable Triple where-  traverse f (Triple a b c) = Triple <$> f a <*> f b <*> f c--reverseTriple :: Triple a -> Triple a-reverseTriple (Triple a b c) = Triple c b a--data ChooseSecond = ChooseSecond-  deriving (Eq)--data ChooseFirst = ChooseFirst-  deriving (Eq)--data LastNothing = LastNothing-  deriving (Eq)--data Bottom a = BottomUndefined | BottomValue a-  deriving (Eq)--instance Show ChooseFirst where-  show ChooseFirst = "\\a b -> if even a then a else b"--instance Show ChooseSecond where-  show ChooseSecond = "\\a b -> if even b then a else b"--instance Show LastNothing where-  show LastNothing = "0"--instance Show a => Show (Bottom a) where-  show x = case x of-    BottomUndefined -> "undefined"-    BottomValue a -> show a--instance Arbitrary ChooseSecond where-  arbitrary = pure ChooseSecond--instance Arbitrary ChooseFirst where-  arbitrary = pure ChooseFirst--instance Arbitrary LastNothing where-  arbitrary = pure LastNothing--instance Arbitrary a => Arbitrary (Bottom a) where-  arbitrary = fmap maybeToBottom arbitrary-  shrink x = map maybeToBottom (shrink (bottomToMaybe x))--bottomToMaybe :: Bottom a -> Maybe a-bottomToMaybe BottomUndefined = Nothing-bottomToMaybe (BottomValue a) = Just a--maybeToBottom :: Maybe a -> Bottom a-maybeToBottom Nothing = BottomUndefined-maybeToBottom (Just a) = BottomValue a--newtype Apply f a = Apply { getApply :: f a }--instance (Applicative f, Monoid a) => Semigroup (Apply f a) where-  Apply x <> Apply y = Apply $ liftA2 mappend x y--instance (Applicative f, Monoid a) => Monoid (Apply f a) where-  mempty = Apply $ pure mempty-  mappend = (SG.<>)--#if HAVE_UNARY_LAWS-#if HAVE_QUANTIFIED_CONSTRAINTS-deriving instance (forall x. Eq x => Eq (f x), Eq a) => Eq (Apply f a)-deriving instance (forall x. Arbitrary x => Arbitrary (f x), Arbitrary a) => Arbitrary (Apply f a)-deriving instance (forall x. Show x => Show (f x), Show a) => Show (Apply f a)-#else-instance (Eq1 f, Eq a) => Eq (Apply f a) where-  Apply a == Apply b = eq1 a b---- This show instance is intentionally a little bit wrong.--- We don't wrap the result in Apply since the end user--- should not be made aware of the Apply wrapper anyway.-instance (Show1 f, Show a) => Show (Apply f a) where-  showsPrec p = showsPrec1 p . getApply--instance (Arbitrary1 f, Arbitrary a) => Arbitrary (Apply f a) where-  arbitrary = fmap Apply arbitrary1-  shrink = map Apply . shrink1 . getApply-#endif-#endif--foldMapA :: (Foldable t, Monoid m, Semigroup m, Applicative f) => (a -> f m) -> t a -> f m-foldMapA f = getApply . foldMap (Apply . f)---#if HAVE_BINARY_LAWS-newtype Apply2 f a b = Apply2 { getApply2 :: f a b }--#if HAVE_QUANTIFIED_CONSTRAINTS-deriving instance (forall x y. (Eq x, Eq y) => Eq (f x y), Eq a, Eq b) => Eq (Apply2 f a b)-deriving instance (forall x y. (Arbitrary x, Arbitrary y) => Arbitrary (f x y), Arbitrary a, Arbitrary b) => Arbitrary (Apply2 f a b)-deriving instance (forall x y. (Show x, Show y) => Show (f x y), Show a, Show b) => Show (Apply2 f a b)-#else-instance (Eq2 f, Eq a, Eq b) => Eq (Apply2 f a b) where-  Apply2 a == Apply2 b = eq2 a b--instance (Show2 f, Show a, Show b) => Show (Apply2 f a b) where-  showsPrec p = showsPrec2 p . getApply2--instance (Arbitrary2 f, Arbitrary a, Arbitrary b) => Arbitrary (Apply2 f a b) where-  arbitrary = fmap Apply2 arbitrary2-  shrink = fmap Apply2 . shrink2 . getApply2-#endif-#endif--data LinearEquation = LinearEquation-  { _linearEquationLinear :: Integer-  , _linearEquationConstant :: Integer-  } deriving (Eq)--instance Show LinearEquation where-  showsPrec = showLinear-  showList = showLinearList--runLinearEquation :: LinearEquation -> Integer -> Integer-runLinearEquation (LinearEquation a b) x = a * x + b--showLinear :: Int -> LinearEquation -> ShowS-showLinear _ (LinearEquation a b) = shows a . showString " * x + " . shows b--showLinearList :: [LinearEquation] -> ShowS-showLinearList xs = SG.appEndo $ mconcat-   $ [SG.Endo (showChar '[')]-  ++ L.intersperse (SG.Endo (showChar ',')) (map (SG.Endo . showLinear 0) xs)-  ++ [SG.Endo (showChar ']')]--#if HAVE_UNARY_LAWS-data LinearEquationM m = LinearEquationM (m LinearEquation) (m LinearEquation)--runLinearEquationM :: Monad m => LinearEquationM m -> Integer -> m Integer-runLinearEquationM (LinearEquationM e1 e2) i = if odd i-  then liftM (flip runLinearEquation i) e1-  else liftM (flip runLinearEquation i) e2--#if HAVE_QUANTIFIED_CONSTRAINTS-deriving instance (forall x. Eq x => Eq (m x)) => Eq (LinearEquationM m)-instance (forall a. Show a => Show (m a)) => Show (LinearEquationM m) where-  show (LinearEquationM a b) = (\f -> f "")-    $ showString "\\x -> if odd x then "-    . showsPrec 0 a-    . showString " else "-    . showsPrec 0 b-instance (forall a. Arbitrary a => Arbitrary (m a)) => Arbitrary (LinearEquationM m) where-  arbitrary = liftA2 LinearEquationM arbitrary arbitrary-  shrink (LinearEquationM a b) = L.concat-    [ map (\x -> LinearEquationM x b) (shrink a)-    , map (\x -> LinearEquationM a x) (shrink b)-    ]-#else-instance Eq1 m => Eq (LinearEquationM m) where-  LinearEquationM a1 b1 == LinearEquationM a2 b2 = eq1 a1 a2 && eq1 b1 b2--instance Show1 m => Show (LinearEquationM m) where-  show (LinearEquationM a b) = (\f -> f "")-    $ showString "\\x -> if odd x then "-    . showsPrec1 0 a-    . showString " else "-    . showsPrec1 0 b--instance Arbitrary1 m => Arbitrary (LinearEquationM m) where-  arbitrary = liftA2 LinearEquationM arbitrary1 arbitrary1-  shrink (LinearEquationM a b) = L.concat-    [ map (\x -> LinearEquationM x b) (shrink1 a)-    , map (\x -> LinearEquationM a x) (shrink1 b)-    ]-#endif-#endif--instance Arbitrary LinearEquation where-  arbitrary = do-    (a,b) <- arbitrary-    return (LinearEquation (abs a) (abs b))-  shrink (LinearEquation a b) =-    let xs = shrink (a,b)-     in map (\(x,y) -> LinearEquation (abs x) (abs y)) xs---- this is a quadratic equation-data QuadraticEquation = QuadraticEquation-  { _quadraticEquationQuadratic :: Integer-  , _quadraticEquationLinear :: Integer-  , _quadraticEquationConstant :: Integer-  }-  deriving (Eq)---- This show instance is does not actually provide a--- way to create an equation. Instead, it makes it look--- like a lambda.-instance Show QuadraticEquation where-  show (QuadraticEquation a b c) = "\\x -> " ++ show a ++ " * x ^ 2 + " ++ show b ++ " * x + " ++ show c--instance Arbitrary QuadraticEquation where-  arbitrary = do-    (a,b,c) <- arbitrary-    return (QuadraticEquation (abs a) (abs b) (abs c))-  shrink (QuadraticEquation a b c) =-    let xs = shrink (a,b,c)-     in map (\(x,y,z) -> QuadraticEquation (abs x) (abs y) (abs z)) xs--runQuadraticEquation :: QuadraticEquation -> Integer -> Integer-runQuadraticEquation (QuadraticEquation a b c) x = a * x ^ (2 :: Integer) + b * x + c--data LinearEquationTwo = LinearEquationTwo-  { _linearEquationTwoX :: Integer-  , _linearEquationTwoY :: Integer-  }-  deriving (Eq)---- This show instance does not actually provide a--- way to create a LinearEquationTwo. Instead, it makes it look--- like a lambda that takes two variables.-instance Show LinearEquationTwo where-  show (LinearEquationTwo a b) = "\\x y -> " ++ show a ++ " * x + " ++ show b ++ " * y"--instance Arbitrary LinearEquationTwo where-  arbitrary = do-    (a,b) <- arbitrary-    return (LinearEquationTwo (abs a) (abs b))-  shrink (LinearEquationTwo a b) =-    let xs = shrink (a,b)-     in map (\(x,y) -> LinearEquationTwo (abs x) (abs y)) xs--runLinearEquationTwo :: LinearEquationTwo -> Integer -> Integer -> Integer-runLinearEquationTwo (LinearEquationTwo a b) x y = a * x + b * y--newtype SmallList a = SmallList { getSmallList :: [a] }-  deriving (Eq,Show)--instance Arbitrary a => Arbitrary (SmallList a) where-  arbitrary = do-    n <- choose (0,6)-    xs <- vector n-    return (SmallList xs)-  shrink = map SmallList . shrink . getSmallList--newtype VerySmallList a = VerySmallList { getVerySmallList :: [a] }-  deriving (Eq, Show, Semigroup, Monoid)--instance Arbitrary a => Arbitrary (VerySmallList a) where-  arbitrary = do-    n <- choose (0,2)-    xs <- vector n-    return (VerySmallList xs)-  shrink = map VerySmallList . shrink . getVerySmallList---- Haskell uses the operator precedences 0..9, the special function application--- precedence 10 and the precedence 11 for function arguments. Both show and--- read instances have to accept this range. According to the Haskell Language--- Report, the output of derived show instances in precedence context 11 has to--- be an atomic expression.-showReadPrecedences :: [Int]-showReadPrecedences = [0..11]--newtype ShowReadPrecedence = ShowReadPrecedence Int-  deriving (Eq,Ord,Show)-instance Arbitrary ShowReadPrecedence where-  arbitrary = ShowReadPrecedence <$> elements showReadPrecedences-  shrink (ShowReadPrecedence p) =-    [ ShowReadPrecedence p' | p' <- showReadPrecedences, p' < p ]
− src/Test/QuickCheck/Classes/Compat.hs 
@@ -1,84 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--module Test.QuickCheck.Classes.Compat-  ( isTrue#-#if HAVE_UNARY_LAWS-  , eq1-#endif-#if HAVE_BINARY_LAWS-  , eq2-  , eq1_2-#endif-  , readMaybe-  ) where--#if MIN_VERSION_base(4,6,0)-import Text.Read (readMaybe)-#else-import Text.ParserCombinators.ReadP (skipSpaces)-import Text.ParserCombinators.ReadPrec (lift, minPrec, readPrec_to_S)-import Text.Read (readPrec)-#endif--#if MIN_VERSION_base(4,7,0)-import GHC.Exts (isTrue#)-#endif--#if defined(HAVE_UNARY_LAWS) || defined(HAVE_BINARY_LAWS)-import qualified Data.Functor.Classes as C-#endif--#if !MIN_VERSION_base(4,6,0)-readMaybe :: Read a => String -> Maybe a-readMaybe s =-  case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of-    [x] -> Just x-    _   -> Nothing- where-  read' =-    do x <- readPrec-       lift skipSpaces-       return x-#endif--#if !MIN_VERSION_base(4,7,0)-isTrue# :: Bool -> Bool-isTrue# b = b-#endif--#if HAVE_UNARY_LAWS-#if HAVE_QUANTIFIED_CONSTRAINTS-eq1 :: (forall x. Eq x => Eq (f x), Eq a) => f a -> f a -> Bool-eq1 = (==)-#else-eq1 :: (C.Eq1 f, Eq a) => f a -> f a -> Bool-eq1 = C.eq1-#endif-#endif--#if HAVE_UNARY_LAWS-#if HAVE_QUANTIFIED_CONSTRAINTS-eq1_2 :: (forall a. Eq a => Eq (f a), forall a b. (Eq a, Eq b) => Eq (g a b), Eq x, Eq y)-  => f (g x y) -> f (g x y) -> Bool-eq1_2 = (==)-#else-eq1_2 :: (C.Eq1 f, C.Eq2 g, Eq a, Eq b) => f (g a b) -> f (g a b) -> Bool-eq1_2 = C.liftEq C.eq2-#endif-#endif--#if HAVE_BINARY_LAWS-#if HAVE_QUANTIFIED_CONSTRAINTS-eq2 :: (forall a. (Eq a, Eq b) => Eq (f a b), Eq a, Eq b) => f a b -> f a b -> Bool-eq2 = (==)-#else-eq2 :: (C.Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool-eq2 = C.eq2-#endif-#endif-
− src/Test/QuickCheck/Classes/Contravariant.hs 
@@ -1,74 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE ScopedTypeVariables #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Contravariant-  (-#if HAVE_UNARY_LAWS-    contravariantLaws-#endif-  ) where--import Data.Functor.Contravariant-import Test.QuickCheck hiding ((.&.))-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Arbitrary (Arbitrary1(..))-import Data.Functor.Classes (Eq1,Show1)-#endif-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1)-#endif--#if HAVE_UNARY_LAWS---- | Tests the following contravariant properties:------ [/Identity/]---   @'contramap' 'id' ≡ 'id'@--- [/Composition/]---   @'contramap' f '.' 'contramap' g ≡ 'contramap' (g '.' f)@-contravariantLaws ::-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Contravariant f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Contravariant f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f-  -> Laws-contravariantLaws p = Laws "Contravariant"-  [ ("Identity", contravariantIdentity p)-  , ("Composition", contravariantComposition p)-  ]--contravariantIdentity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Contravariant f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Contravariant f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-contravariantIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (contramap id a) a--contravariantComposition :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Contravariant f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Contravariant f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-contravariantComposition _ = property $ \(Apply (a :: f Integer)) (f' :: QuadraticEquation) (g' :: QuadraticEquation) -> do-  let f = runQuadraticEquation f'-      g = runQuadraticEquation g'-  eq1 (contramap f (contramap g a)) (contramap (g . f) a)--#endif
− src/Test/QuickCheck/Classes/Enum.hs 
@@ -1,77 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Enum-  ( enumLaws-  , boundedEnumLaws-  ) where--import Data.Proxy (Proxy)-import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common (Laws(..), myForAllShrink)---- | Tests the following properties:------ [/Succ Pred Identity/]---   @'succ' ('pred' x) ≡ x@--- [/Pred Succ Identity/]---   @'pred' ('succ' x) ≡ x@------ This only works for @Enum@ types that are not bounded, meaning--- that 'succ' and 'pred' must be total. This means that these property--- tests work correctly for types like 'Integer' but not for 'Int'.------ Sadly, there is not a good way to test 'fromEnum' and 'toEnum',--- since many types that have reasonable implementations for 'succ'--- and 'pred' have more inhabitants than 'Int' does.-enumLaws :: (Enum a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws-enumLaws p = Laws "Enum"-  [ ("Succ Pred Identity", succPredIdentity p)-  , ("Pred Succ Identity", predSuccIdentity p)-  ]---- | Tests the same properties as 'enumLaws' except that it requires--- the type to have a 'Bounded' instance. These tests avoid taking the--- successor of the maximum element or the predecessor of the minimal--- element.-boundedEnumLaws :: (Enum a, Bounded a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws-boundedEnumLaws p = Laws "Enum"-  [ ("Succ Pred Identity", succPredBoundedIdentity p)-  , ("Pred Succ Identity", predSuccBoundedIdentity p)-  ]--succPredIdentity :: forall a. (Enum a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-succPredIdentity _ = myForAllShrink False (const True)-  (\(a :: a) -> ["a = " ++ show a])-  "succ (pred x)"-  (\a -> succ (pred a))-  "x"-  (\a -> a)--predSuccIdentity :: forall a. (Enum a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-predSuccIdentity _ = myForAllShrink False (const True)-  (\(a :: a) -> ["a = " ++ show a])-  "pred (succ x)"-  (\a -> pred (succ a))-  "x"-  (\a -> a)--succPredBoundedIdentity :: forall a. (Enum a, Bounded a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-succPredBoundedIdentity _ = myForAllShrink False (\a -> a /= minBound)-  (\(a :: a) -> ["a = " ++ show a])-  "succ (pred x)"-  (\a -> succ (pred a))-  "x"-  (\a -> a)--predSuccBoundedIdentity :: forall a. (Enum a, Bounded a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-predSuccBoundedIdentity _ = myForAllShrink False (\a -> a /= maxBound)-  (\(a :: a) -> ["a = " ++ show a])-  "pred (succ x)"-  (\a -> pred (succ a))-  "x"-  (\a -> a)-
− src/Test/QuickCheck/Classes/Eq.hs 
@@ -1,50 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Eq-  ( eqLaws-  ) where--import Data.Proxy (Proxy)-import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common (Laws(..))---- | Tests the following properties:------ [/Transitive/]---   @a == b ∧ b == c ⇒ a == c@--- [/Symmetric/]---   @a == b ⇒ b == a@--- [/Reflexive/]---   @a == a@------ Some of these properties involve implication. In the case that--- the left hand side of the implication arrow does not hold, we--- do not retry. Consequently, these properties only end up being--- useful when the data type has a small number of inhabitants.-eqLaws :: (Eq a, Arbitrary a, Show a) => Proxy a -> Laws-eqLaws p = Laws "Eq"-  [ ("Transitive", eqTransitive p)-  , ("Symmetric", eqSymmetric p)-  , ("Reflexive", eqReflexive p)-  ]--eqTransitive :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property-eqTransitive _ = property $ \(a :: a) b c -> case a == b of-  True -> case b == c of-    True -> a == c-    False -> a /= c-  False -> case b == c of-    True -> a /= c-    False -> True--eqSymmetric :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property-eqSymmetric _ = property $ \(a :: a) b -> case a == b of-  True -> b == a-  False -> b /= a--eqReflexive :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property-eqReflexive _ = property $ \(a :: a) -> a == a
+ src/Test/QuickCheck/Classes/Euclidean.hs view
@@ -0,0 +1,122 @@+-- |+-- Module:      Test.QuickCheck.Classes.Euclidean+-- Copyright:   (c) 2019 Andrew Lelechenko+-- Licence:     BSD3+--++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall #-}++#if !HAVE_SEMIRINGS+module Test.QuickCheck.Classes.Euclidean where+#else++module Test.QuickCheck.Classes.Euclidean+  ( gcdDomainLaws+  , euclideanLaws+  ) where++import Prelude hiding (quotRem, quot, rem, gcd, lcm)+import Data.Maybe+import Data.Proxy (Proxy)+import Data.Euclidean+import Data.Semiring (Semiring(..))++import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Property (Property)++import Test.QuickCheck.Classes.Internal (Laws(..))++-- | Test that a 'GcdDomain' instance obey several laws.+--+-- Check that 'divide' is an inverse of times:+--+-- * @y \/= 0 => (x * y) \`divide\` y == Just x@,+-- * @y \/= 0, x \`divide\` y == Just z => x == z * y@.+--+-- Check that 'gcd' is a common divisor and is a multiple of any common divisor:+--+-- * @x \/= 0, y \/= 0 => isJust (x \`divide\` gcd x y) && isJust (y \`divide\` gcd x y)@,+-- * @z \/= 0 => isJust (gcd (x * z) (y * z) \`divide\` z)@.+--+-- Check that 'lcm' is a common multiple and is a factor of any common multiple:+--+-- * @x \/= 0, y \/= 0 => isJust (lcm x y \`divide\` x) && isJust (lcm x y \`divide\` y)@,+-- * @x \/= 0, y \/= 0, isJust (z \`divide\` x), isJust (z \`divide\` y) => isJust (z \`divide\` lcm x y)@.+--+-- Check that 'gcd' of 'coprime' numbers is a unit of the semiring (has an inverse):+--+-- * @y \/= 0, coprime x y => isJust (1 \`divide\` gcd x y)@.+gcdDomainLaws :: (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Laws+gcdDomainLaws p = Laws "GcdDomain"+  [ ("divide1", divideLaw1 p)+  , ("divide2", divideLaw2 p)+  , ("gcd1", gcdLaw1 p)+  , ("gcd2", gcdLaw2 p)+  , ("lcm1", lcmLaw1 p)+  , ("lcm2", lcmLaw2 p)+  , ("coprime", coprimeLaw p)+  ]++divideLaw1 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property+divideLaw1 _ = property $ \(x :: a) y ->+  y /= zero ==> (x `times` y) `divide` y === Just x++divideLaw2 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property+divideLaw2 _ = property $ \(x :: a) y ->+  y /= zero ==> maybe (property True) (\z -> x === z `times` y) (x `divide` y)++gcdLaw1 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property+gcdLaw1 _ = property $ \(x :: a) y ->+  x /= zero || y /= zero ==> isJust (x `divide` gcd x y) .&&. isJust (y `divide` gcd x y)++gcdLaw2 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property+gcdLaw2 _ = property $ \(x :: a) y z ->+  z /= zero ==> isJust (gcd (x `times` z) (y `times` z) `divide` z)++lcmLaw1 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property+lcmLaw1 _ = property $ \(x :: a) y ->+  x /= zero && y /= zero ==> isJust (lcm x y `divide` x) .&&. isJust (lcm x y `divide` y)++lcmLaw2 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property+lcmLaw2 _ = property $ \(x :: a) y z ->+  x /= zero && y /= zero ==> isNothing (z `divide` x) .||. isNothing (z `divide` y) .||. isJust (z `divide` lcm x y)++coprimeLaw :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property+coprimeLaw _ = property $ \(x :: a) y ->+  y /= zero ==> coprime x y === isJust (one `divide` gcd x y)++-- | Test that a 'Euclidean' instance obey laws of a Euclidean domain.+--+-- * @y \/= 0, r == x \`rem\` y => r == 0 || degree r < degree y@,+-- * @y \/= 0, (q, r) == x \`quotRem\` y => x == q * y + r@,+-- * @y \/= 0 => x \`quot\` x y == fst (x \`quotRem\` y)@,+-- * @y \/= 0 => x \`rem\` x y == snd (x \`quotRem\` y)@.+euclideanLaws :: (Eq a, Euclidean a, Arbitrary a, Show a) => Proxy a -> Laws+euclideanLaws p = Laws "Euclidean"+  [ ("degree", degreeLaw p)+  , ("quotRem", quotRemLaw p)+  , ("quot", quotLaw p)+  , ("rem", remLaw p)+  ]++degreeLaw :: forall a. (Eq a, Euclidean a, Arbitrary a, Show a) => Proxy a -> Property+degreeLaw _ = property $ \(x :: a) y ->+  y /= zero ==> let (_, r) = x `quotRem` y in (r === zero .||. degree r < degree y)++quotRemLaw :: forall a. (Eq a, Euclidean a, Arbitrary a, Show a) => Proxy a -> Property+quotRemLaw _ = property $ \(x :: a) y ->+  y /= zero ==> let (q, r) = x `quotRem` y in x === (q `times` y) `plus` r++quotLaw :: forall a. (Eq a, Euclidean a, Arbitrary a, Show a) => Proxy a -> Property+quotLaw _ = property $ \(x :: a) y ->+  y /= zero ==> quot x y === fst (quotRem x y)++remLaw :: forall a. (Eq a, Euclidean a, Arbitrary a, Show a) => Proxy a -> Property+remLaw _ = property $ \(x :: a) y ->+  y /= zero ==> rem x y === snd (quotRem x y)++#endif
− src/Test/QuickCheck/Classes/Foldable.hs 
@@ -1,187 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Foldable-  (-#if HAVE_UNARY_LAWS-    foldableLaws-#endif-  ) where--import Data.Monoid-import Data.Foldable-import Test.QuickCheck hiding ((.&.))-import Control.Exception (ErrorCall,try,evaluate)-import Control.Monad.Trans.Class (lift)-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Arbitrary (Arbitrary1(..))-#endif-import Test.QuickCheck.Monadic (monadicIO)-#if HAVE_UNARY_LAWS-import Data.Functor.Classes (Eq1,Show1)-#endif-import Test.QuickCheck.Property (Property)--import qualified Data.Foldable as F-import qualified Data.Semigroup as SG--import Test.QuickCheck.Classes.Common-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1)-#endif--#if HAVE_UNARY_LAWS---- | Tests the following 'Foldable' properties:------ [/fold/]---   @'fold' ≡ 'foldMap' 'id'@--- [/foldMap/]---   @'foldMap' f ≡ 'foldr' ('mappend' . f) 'mempty'@--- [/foldr/]---   @'foldr' f z t ≡ 'appEndo' ('foldMap' ('Endo' . f) t ) z@--- [/foldr'/]---   @'foldr'' f z0 xs ≡ let f\' k x z = k '$!' f x z in 'foldl' f\' 'id' xs z0@--- [/foldr1/]---   @'foldr1' f t ≡ let 'Just' (xs,x) = 'unsnoc' ('toList' t) in 'foldr' f x xs@--- [/foldl/]---   @'foldl' f z t ≡ 'appEndo' ('getDual' ('foldMap' ('Dual' . 'Endo' . 'flip' f) t)) z@--- [/foldl'/]---   @'foldl'' f z0 xs ≡ let f' x k z = k '$!' f z x in 'foldr' f\' 'id' xs z0@--- [/foldl1/]---   @'foldl1' f t ≡ let x : xs = 'toList' t in 'foldl' f x xs@--- [/toList/]---   @'F.toList' ≡ 'foldr' (:) []@--- [/null/]---   @'null' ≡ 'foldr' ('const' ('const' 'False')) 'True'@--- [/length/]---   @'length' ≡ 'getSum' . 'foldMap' ('const' ('Sum' 1))@------ Note that this checks to ensure that @foldl\'@ and @foldr\'@--- are suitably strict.-foldableLaws :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Foldable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Foldable f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Laws-foldableLaws = foldableLawsInternal--foldableLawsInternal :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Foldable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Foldable f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Laws-foldableLawsInternal p = Laws "Foldable"-  [ (,) "fold" $ property $ \(Apply (a :: f (VerySmallList Integer))) ->-      F.fold a == F.foldMap id a-  , (,) "foldMap" $ property $ \(Apply (a :: f Integer)) (e :: QuadraticEquation) ->-      let f = VerySmallList . return . runQuadraticEquation e-       in F.foldMap f a == F.foldr (mappend . f) mempty a-  , (,) "foldr" $ property $ \(e :: LinearEquationTwo) (z :: Integer) (Apply (t :: f Integer)) ->-      let f = runLinearEquationTwo e-       in F.foldr f z t == SG.appEndo (foldMap (SG.Endo . f) t) z-  , (,) "foldr'" (foldableFoldr' p)-  , (,) "foldl" $ property $ \(e :: LinearEquationTwo) (z :: Integer) (Apply (t :: f Integer)) ->-      let f = runLinearEquationTwo e-       in F.foldl f z t == SG.appEndo (SG.getDual (F.foldMap (SG.Dual . SG.Endo . flip f) t)) z-  , (,) "foldl'" (foldableFoldl' p)-  , (,) "foldl1" $ property $ \(e :: LinearEquationTwo) (Apply (t :: f Integer)) ->-      case compatToList t of-        [] -> True-        x : xs ->-          let f = runLinearEquationTwo e-           in F.foldl1 f t == F.foldl f x xs-  , (,) "foldr1" $ property $ \(e :: LinearEquationTwo) (Apply (t :: f Integer)) ->-      case unsnoc (compatToList t) of-        Nothing -> True-        Just (xs,x) ->-          let f = runLinearEquationTwo e-           in F.foldr1 f t == F.foldr f x xs-  , (,) "toList" $ property $ \(Apply (t :: f Integer)) ->-      eq1 (F.toList t) (F.foldr (:) [] t)-#if MIN_VERSION_base(4,8,0)-  , (,) "null" $ property $ \(Apply (t :: f Integer)) ->-      null t == F.foldr (const (const False)) True t-  , (,) "length" $ property $ \(Apply (t :: f Integer)) ->-      F.length t == SG.getSum (F.foldMap (const (SG.Sum 1)) t)-#endif-  ]--unsnoc :: [a] -> Maybe ([a],a)-unsnoc [] = Nothing-unsnoc [x] = Just ([],x)-unsnoc (x:y:xs) = fmap (\(bs,b) -> (x:bs,b)) (unsnoc (y : xs))--compatToList :: Foldable f => f a -> [a]-compatToList = foldMap (\x -> [x])--foldableFoldl' :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Foldable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Foldable f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-foldableFoldl' _ = property $ \(_ :: ChooseSecond) (_ :: LastNothing) (Apply (xs :: f (Bottom Integer))) ->-  monadicIO $ do-    let f :: Integer -> Bottom Integer -> Integer-        f a b = case b of-          BottomUndefined -> error "foldableFoldl' example"-          BottomValue v -> if even v-            then a-            else v-        z0 = 0-    r1 <- lift $ do-      let f' x k z = k $! f z x-      e <- try (evaluate (F.foldr f' id xs z0))-      case e of-        Left (_ :: ErrorCall) -> return Nothing-        Right i -> return (Just i)-    r2 <- lift $ do-      e <- try (evaluate (F.foldl' f z0 xs))-      case e of-        Left (_ :: ErrorCall) -> return Nothing-        Right i -> return (Just i)-    return (r1 == r2)--foldableFoldr' :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Foldable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Foldable f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-foldableFoldr' _ = property $ \(_ :: ChooseFirst) (_ :: LastNothing) (Apply (xs :: f (Bottom Integer))) ->-  monadicIO $ do-    let f :: Bottom Integer -> Integer -> Integer-        f a b = case a of-          BottomUndefined -> error "foldableFoldl' example"-          BottomValue v -> if even v-            then v-            else b-        z0 = 0-    r1 <- lift $ do-      let f' k x z = k $! f x z-      e <- try (evaluate (F.foldl f' id xs z0))-      case e of-        Left (_ :: ErrorCall) -> return Nothing-        Right i -> return (Just i)-    r2 <- lift $ do-      e <- try (evaluate (F.foldr' f z0 xs))-      case e of-        Left (_ :: ErrorCall) -> return Nothing-        Right i -> return (Just i)-    return (r1 == r2)--#endif
− src/Test/QuickCheck/Classes/Functor.hs 
@@ -1,86 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE ScopedTypeVariables #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Functor-  (-#if HAVE_UNARY_LAWS-    functorLaws-#endif-  ) where--import Data.Functor-import Test.QuickCheck hiding ((.&.))-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Arbitrary (Arbitrary1(..))-import Data.Functor.Classes (Eq1,Show1)-#endif-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1)-#endif--#if HAVE_UNARY_LAWS---- | Tests the following functor properties:------ [/Identity/]---   @'fmap' 'id' ≡ 'id'@--- [/Composition/]---   @'fmap' (f '.' g) ≡ 'fmap' f '.' 'fmap' g@--- [/Const/]---   @('<$') ≡ 'fmap' 'const'@-functorLaws ::-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Functor f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f-  -> Laws-functorLaws p = Laws "Functor"-  [ ("Identity", functorIdentity p)-  , ("Composition", functorComposition p)-  , ("Const", functorConst p)-  ]--functorIdentity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Functor f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-functorIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (fmap id a) a--functorComposition :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Functor f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-functorComposition _ = property $ \(Apply (a :: f Integer)) ->-  eq1 (fmap func2 (fmap func1 a)) (fmap (func2 . func1) a)--functorConst :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Functor f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-functorConst _ = property $ \(Apply (a :: f Integer)) ->-  eq1 (fmap (const 'X') a) ('X' <$ a)--#endif-
− src/Test/QuickCheck/Classes/Generic.hs 
@@ -1,112 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif-{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Generic-  (-#if MIN_VERSION_base(4,5,0)-    genericLaws-#if HAVE_UNARY_LAWS-  , generic1Laws-#endif-#endif-  ) where--#if MIN_VERSION_base(4,5,0)-import Control.Applicative-import Data.Semigroup as SG-import Data.Monoid as MD-import GHC.Generics-#if HAVE_UNARY_LAWS-import Data.Functor.Classes-#endif-import Data.Proxy (Proxy(Proxy))-import Test.QuickCheck-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common (Laws(..), Apply(..))---- | Tests the following properties:------ [/From-To Inverse/]---   @'from' '.' 'to' ≡  'id'@--- [/To-From Inverse/]---   @'to' '.' 'from' ≡  'id'@------ /Note:/ This property test is only available when--- using @base-4.5@ or newer.------ /Note:/ 'from' and 'to' don't actually care about--- the type variable @x@ in @'Rep' a x@, so here we instantiate--- it to @'()'@ by default. If you would like to instantiate @x@--- as something else, please file a bug report.-genericLaws :: (Generic a, Eq a, Arbitrary a, Show a, Show (Rep a ()), Arbitrary (Rep a ()), Eq (Rep a ())) => Proxy a -> Laws-genericLaws pa = Laws "Generic"-  [ ("From-To inverse", fromToInverse pa (Proxy :: Proxy ()))-  , ("To-From inverse", toFromInverse pa)-  ]--toFromInverse :: forall proxy a. (Generic a, Eq a, Arbitrary a, Show a) => proxy a -> Property-toFromInverse _ = property $ \(v :: a) -> (to . from $ v) == v--fromToInverse ::-     forall proxy a x.-     (Generic a, Show (Rep a x), Arbitrary (Rep a x), Eq (Rep a x))-  => proxy a-  -> proxy x-  -> Property-fromToInverse _ _ = property $ \(r :: Rep a x) -> r == (from (to r :: a)) --#if HAVE_UNARY_LAWS--- | Tests the following properties:------ [/From-To Inverse/]---   @'from1' '.' 'to1' ≡  'id'@--- [/To-From Inverse/]---   @'to1' '.' 'from1' ≡  'id'@------ /Note:/ This property test is only available when--- using @base-4.9@ or newer.-generic1Laws :: (Generic1 f, Eq1 f, Arbitrary1 f, Show1 f, Eq1 (Rep1 f), Show1 (Rep1 f), Arbitrary1 (Rep1 f))-  => proxy f -> Laws-generic1Laws p = Laws "Generic1"-  [ ("From1-To1 inverse", fromToInverse1 p)-  , ("To1-From1 inverse", toFromInverse1 p)-  ]---- hack for quantified constraints: under base >= 4.12,--- our usual 'Apply' wrapper has Eq, Show, and Arbitrary--- instances that are incompatible.-newtype GApply f a = GApply { getGApply :: f a }--instance (Applicative f, Semigroup a) => Semigroup (GApply f a) where-  GApply x <> GApply y = GApply $ liftA2 (SG.<>) x y--instance (Applicative f, Monoid a) => Monoid (GApply f a) where-  mempty = GApply $ pure mempty-  mappend (GApply x) (GApply y) = GApply $ liftA2 (MD.<>) x y--instance (Eq1 f, Eq a) => Eq (GApply f a) where-  GApply a == GApply b = eq1 a b--instance (Show1 f, Show a) => Show (GApply f a) where-  showsPrec p = showsPrec1 p . getGApply--instance (Arbitrary1 f, Arbitrary a) => Arbitrary (GApply f a) where-  arbitrary = fmap GApply arbitrary1-  shrink = map GApply . shrink1 . getGApply--toFromInverse1 :: forall proxy f. (Generic1 f, Eq1 f, Arbitrary1 f, Show1 f) => proxy f -> Property-toFromInverse1 _ = property $ \(GApply (v :: f Integer)) -> eq1 v (to1 . from1 $ v)--fromToInverse1 :: forall proxy f. (Generic1 f, Eq1 (Rep1 f), Arbitrary1 (Rep1 f), Show1 (Rep1 f)) => proxy f -> Property-fromToInverse1 _ = property $ \(GApply (r :: Rep1 f Integer)) -> eq1 r (from1 ((to1 $ r) :: f Integer))--#endif--#endif
− src/Test/QuickCheck/Classes/Integral.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Integral-  ( integralLaws-  ) where--import Data.Proxy (Proxy)-import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common (Laws(..), myForAllShrink)---- | Tests the following properties:------ [/Quotient Remainder/]---   @(quot x y) * y + (rem x y) ≡ x@--- [/Division Modulus/]---   @(div x y) * y + (mod x y) ≡ x@--- [/Integer Roundtrip/]---   @fromInteger (toInteger x) ≡ x@-integralLaws :: (Integral a, Arbitrary a, Show a) => Proxy a -> Laws-integralLaws p = Laws "Integral"-  [ ("Quotient Remainder", integralQuotientRemainder p)-  , ("Division Modulus", integralDivisionModulus p)-  , ("Integer Roundtrip", integralIntegerRoundtrip p)-  ]--integralQuotientRemainder :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property-integralQuotientRemainder _ = myForAllShrink False (\(_,y) -> y /= 0)-  (\(x :: a, y) -> ["x = " ++ show x, "y = " ++ show y])-  "(quot x y) * y + (rem x y)"-  (\(x,y) -> (quot x y) * y + (rem x y))-  "x"-  (\(x,_) -> x)--integralDivisionModulus :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property-integralDivisionModulus _ = myForAllShrink False (\(_,y) -> y /= 0)-  (\(x :: a, y) -> ["x = " ++ show x, "y = " ++ show y])-  "(div x y) * y + (mod x y)"-  (\(x,y) -> (div x y) * y + (mod x y))-  "x"-  (\(x,_) -> x)--integralIntegerRoundtrip :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property-integralIntegerRoundtrip _ = myForAllShrink False (const True)-  (\(x :: a) -> ["x = " ++ show x])-  "fromInteger (toInteger x)"-  (\x -> fromInteger (toInteger x))-  "x"-  (\x -> x)
src/Test/QuickCheck/Classes/IsList.hs view
@@ -1,251 +1,8 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}--{-# OPTIONS_GHC -Wall #-}--{-|--This module provides property tests for functions that operate on-list-like data types. If your data type is fully polymorphic in its-element type, is it recommended that you use @foldableLaws@ and-@traversableLaws@ from @Test.QuickCheck.Classes@. However, if your-list-like data type is either monomorphic in its element type-(like @Text@ or @ByteString@) or if it requires a typeclass-constraint on its element (like @Data.Vector.Unboxed@), the properties-provided here can be helpful for testing that your functions have-the expected behavior. All properties in this module require your data-type to have an 'IsList' instance.---} module Test.QuickCheck.Classes.IsList-  ( -#if MIN_VERSION_base(4,7,0)-    isListLaws -  , foldrProp-  , foldlProp-  , foldlMProp-  , mapProp-  , imapProp-  , imapMProp-  , traverseProp-  , generateProp-  , generateMProp-  , replicateProp-  , replicateMProp-  , filterProp-  , filterMProp-  , mapMaybeProp-  , mapMaybeMProp-#endif+  ( module Test.QuickCheck.Classes.Base.IsList   ) where -#if MIN_VERSION_base(4,7,0)-import Control.Applicative-import Control.Monad.ST (ST,runST)-import Control.Monad (mapM,filterM,replicateM)-import Control.Applicative (liftA2)-import GHC.Exts (IsList,Item,toList,fromList,fromListN)-import Data.Maybe (mapMaybe,catMaybes)-import Data.Proxy (Proxy)-import Data.Foldable (foldlM)-import Data.Traversable (traverse)-import Test.QuickCheck (Property,Arbitrary,CoArbitrary,(===),property,-  NonNegative(..))-#if MIN_VERSION_QuickCheck(2,10,0)-import Test.QuickCheck.Function (Function,Fun,applyFun,applyFun2)-#else-import Test.QuickCheck.Function (Function,Fun,apply)-#endif-import qualified Data.List as L--import Test.QuickCheck.Classes.Common (Laws(..), myForAllShrink)---- | Tests the following properties:------ [/Partial Isomorphism/]---   @fromList . toList ≡ id@--- [/Length Preservation/]---   @fromList xs ≡ fromListN (length xs) xs@------ /Note:/ This property test is only available when--- using @base-4.7@ or newer.-isListLaws :: (IsList a, Show a, Show (Item a), Arbitrary a, Arbitrary (Item a), Eq a) => Proxy a -> Laws-isListLaws p = Laws "IsList"-  [ ("Partial Isomorphism", isListPartialIsomorphism p)-  , ("Length Preservation", isListLengthPreservation p)-  ]--isListPartialIsomorphism :: forall a. (IsList a, Show a, Arbitrary a, Eq a) => Proxy a -> Property-isListPartialIsomorphism _ = myForAllShrink False (const True)-  (\(a :: a) -> ["a = " ++ show a])-  "fromList (toList a)"-  (\a -> fromList (toList a))-  "a"-  (\a -> a)--isListLengthPreservation :: forall a. (IsList a, Show (Item a), Arbitrary (Item a), Eq a) => Proxy a -> Property-isListLengthPreservation _ = property $ \(xs :: [Item a]) ->-  (fromList xs :: a) == fromListN (length xs) xs--foldrProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, CoArbitrary a, Function a)-  => Proxy a -- ^ input element type-  -> (forall b. (a -> b -> b) -> b -> c -> b) -- ^ foldr function-  -> Property-foldrProp _ f = property $ \c (b0 :: Integer) func ->-  let g = applyFun2 func in-  L.foldr g b0 (toList c) === f g b0 c-  -foldlProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, CoArbitrary a, Function a)-  => Proxy a -- ^ input element type-  -> (forall b. (b -> a -> b) -> b -> c -> b) -- ^ foldl function-  -> Property-foldlProp _ f = property $ \c (b0 :: Integer) func ->-  let g = applyFun2 func in-  L.foldl g b0 (toList c) === f g b0 c--foldlMProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, CoArbitrary a, Function a)-  => Proxy a -- ^ input element type-  -> (forall s b. (b -> a -> ST s b) -> b -> c -> ST s b) -- ^ monadic foldl function-  -> Property-foldlMProp _ f = property $ \c (b0 :: Integer) func ->-  runST (foldlM (stApplyFun2 func) b0 (toList c)) === runST (f (stApplyFun2 func) b0 c)--mapProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a)-  => Proxy a -- ^ input element type-  -> Proxy b -- ^ output element type-  -> ((a -> b) -> c -> d) -- ^ map function-  -> Property-mapProp _ _ f = property $ \c func ->-  fromList (map (applyFun func) (toList c)) === f (applyFun func) c--imapProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a)-  => Proxy a -- ^ input element type-  -> Proxy b -- ^ output element type-  -> ((Int -> a -> b) -> c -> d) -- ^ indexed map function-  -> Property-imapProp _ _ f = property $ \c func ->-  fromList (imapList (applyFun2 func) (toList c)) === f (applyFun2 func) c--imapMProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a)-  => Proxy a -- ^ input element type-  -> Proxy b -- ^ output element type-  -> (forall s. (Int -> a -> ST s b) -> c -> ST s d) -- ^ monadic indexed map function-  -> Property-imapMProp _ _ f = property $ \c func ->-  fromList (runST (imapMList (stApplyFun2 func) (toList c))) === runST (f (stApplyFun2 func) c)--traverseProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a)-  => Proxy a -- ^ input element type-  -> Proxy b -- ^ output element type-  -> (forall s. (a -> ST s b) -> c -> ST s d) -- ^ traverse function-  -> Property-traverseProp _ _ f = property $ \c func ->-  fromList (runST (mapM (return . applyFun func) (toList c))) === runST (f (return . applyFun func) c)---- | Property for the @generate@ function, which builds a container---   of a given length by applying a function to each index.-generateProp :: (Item c ~ a, Eq c, Show c, IsList c, Arbitrary a, Show a)-  => Proxy a -- ^ input element type-  -> (Int -> (Int -> a) -> c) -- generate function-  -> Property-generateProp _ f = property $ \(NonNegative len) func ->-  fromList (generateList len (applyFun func)) === f len (applyFun func)--generateMProp :: (Item c ~ a, Eq c, Show c, IsList c, Arbitrary a, Show a)-  => Proxy a -- ^ input element type-  -> (forall s. Int -> (Int -> ST s a) -> ST s c) -- monadic generate function-  -> Property-generateMProp _ f = property $ \(NonNegative len) func ->-  fromList (runST (stGenerateList len (stApplyFun func))) === runST (f len (stApplyFun func))--replicateProp :: (Item c ~ a, Eq c, Show c, IsList c, Arbitrary a, Show a)-  => Proxy a -- ^ input element type-  -> (Int -> a -> c) -- replicate function-  -> Property-replicateProp _ f = property $ \(NonNegative len) a ->-  fromList (replicate len a) === f len a--replicateMProp :: (Item c ~ a, Eq c, Show c, IsList c, Arbitrary a, Show a)-  => Proxy a -- ^ input element type-  -> (forall s. Int -> ST s a -> ST s c) -- replicate function-  -> Property-replicateMProp _ f = property $ \(NonNegative len) a ->-  fromList (runST (replicateM len (return a))) === runST (f len (return a))---- | Property for the @filter@ function, which keeps elements for which--- the predicate holds true.-filterProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, Eq c, CoArbitrary a, Function a)-  => Proxy a -- ^ element type-  -> ((a -> Bool) -> c -> c) -- ^ map function-  -> Property-filterProp _ f = property $ \c func ->-  fromList (filter (applyFun func) (toList c)) === f (applyFun func) c---- | Property for the @filterM@ function, which keeps elements for which--- the predicate holds true in an applicative context.-filterMProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, Eq c, CoArbitrary a, Function a)-  => Proxy a -- ^ element type-  -> (forall s. (a -> ST s Bool) -> c -> ST s c) -- ^ traverse function-  -> Property-filterMProp _ f = property $ \c func ->-  fromList (runST (filterM (return . applyFun func) (toList c))) === runST (f (return . applyFun func) c)---- | Property for the @mapMaybe@ function, which keeps elements for which--- the predicate holds true.-mapMaybeProp :: (IsList c, Item c ~ a, Item d ~ b, Eq d, IsList d, Arbitrary b, Show d, Show b, Arbitrary c, Show c, Show a, Eq c, CoArbitrary a, Function a)-  => Proxy a -- ^ input element type-  -> Proxy b -- ^ output element type-  -> ((a -> Maybe b) -> c -> d) -- ^ map function-  -> Property-mapMaybeProp _ _ f = property $ \c func ->-  fromList (mapMaybe (applyFun func) (toList c)) === f (applyFun func) c--mapMaybeMProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a)-  => Proxy a -- ^ input element type-  -> Proxy b -- ^ output element type-  -> (forall s. (a -> ST s (Maybe b)) -> c -> ST s d) -- ^ traverse function-  -> Property-mapMaybeMProp _ _ f = property $ \c func ->-  fromList (runST (mapMaybeMList (return . applyFun func) (toList c))) === runST (f (return . applyFun func) c)--imapList :: (Int -> a -> b) -> [a] -> [b]-imapList f xs = map (uncurry f) (zip (enumFrom 0) xs)--imapMList :: (Int -> a -> ST s b) -> [a] -> ST s [b]-imapMList f = go 0 where-  go !_ [] = return []-  go !ix (x : xs) = liftA2 (:) (f ix x) (go (ix + 1) xs)--mapMaybeMList :: Applicative f => (a -> f (Maybe b)) -> [a] -> f [b]-mapMaybeMList f = fmap catMaybes . traverse f--generateList :: Int -> (Int -> a) -> [a]-generateList len f = go 0 where-  go !ix = if ix < len-    then f ix : go (ix + 1)-    else []--stGenerateList :: Int -> (Int -> ST s a) -> ST s [a]-stGenerateList len f = go 0 where-  go !ix = if ix < len-    then liftA2 (:) (f ix) (go (ix + 1))-    else return []--stApplyFun :: Fun a b -> a -> ST s b-stApplyFun f a = return (applyFun f a)--stApplyFun2 :: Fun (a,b) c -> a -> b -> ST s c-stApplyFun2 f a b = return (applyFun2 f a b)--#if !MIN_VERSION_QuickCheck(2,10,0)-applyFun :: Fun a b -> (a -> b)-applyFun = apply+-- It would be better to do this with Cabal's module reexport feature,+-- but that would break compatibility with older GHCs. -applyFun2 :: Fun (a, b) c -> (a -> b -> c)-applyFun2 = curry . apply-#endif-#endif+import Test.QuickCheck.Classes.Base.IsList
− src/Test/QuickCheck/Classes/Ix.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Ix-  ( ixLaws-  ) where--import Data.Ix (Ix(..))-import Data.Proxy (Proxy)-import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common (Laws(..))---- | Tests the various 'Ix' properties:------   @'inRange' (l,u) i '==' 'elem' i ('range' (l,u))@------   @'range' (l,u) '!!' 'index' (l,u) i '==' i@, when @'inRange' (l,u) i@------   @'map' ('index' (l,u)) ('range' (l,u)) '==' [0 .. 'rangeSize' (l,u) - 1]@---   ---   @'rangeSize' (l,u) '==' 'length' ('range' (l,u))@-ixLaws :: (Ix a, Arbitrary a, Show a) => Proxy a -> Laws-ixLaws p = Laws "Ix"-  [ ("InRange", ixInRange p)-  , ("RangeIndex", ixRangeIndex p)-  , ("MapIndexRange", ixMapIndexRange p)-  , ("RangeSize", ixRangeSize p)-  ]--ixInRange :: forall a. (Show a, Ix a, Arbitrary a) => Proxy a -> Property-ixInRange _ = property $ \(l :: a) (u :: a) (i :: a) -> (l <= u) ==> do-  inRange (l,u) i == elem i (range (l,u))--ixRangeIndex :: forall a. (Show a, Ix a, Arbitrary a) => Proxy a -> Property-ixRangeIndex _ = property $ \(l :: a) (u :: a) (i :: a) -> ((l <= u) && (i >= l && i <= u)) ==> do-  range (l,u) !! index (l,u) i == i--ixMapIndexRange :: forall a. (Show a, Ix a, Arbitrary a) => Proxy a -> Property-ixMapIndexRange _ = property $ \(l :: a) (u :: a) -> (l <= u) ==> do-  map (index (l,u)) (range (l,u)) == [0 .. rangeSize (l,u) - 1]--ixRangeSize :: forall a. (Show a, Ix a, Arbitrary a) => Proxy a -> Property-ixRangeSize _ = property $ \(l :: a) (u :: a) -> (l <= u) ==> do-  rangeSize (l,u) == length (range (l,u))--
src/Test/QuickCheck/Classes/Json.hs view
@@ -19,7 +19,7 @@ import qualified Data.Aeson as AE #endif -import Test.QuickCheck.Classes.Common (Laws(..))+import Test.QuickCheck.Classes.Internal (Laws(..))  -- | Tests the following properties: --
src/Test/QuickCheck/Classes/MVector.hs view
@@ -1,3 +1,9 @@+-- |+-- Module:      Test.QuickCheck.Classes.MVector+-- Copyright:   (c) 2019 Andrew Lelechenko+-- Licence:     BSD3+--+ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -22,7 +28,7 @@ import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) -import Test.QuickCheck.Classes.Common (Laws(..))+import Test.QuickCheck.Classes.Internal (Laws(..))  -- | Test that a 'Vector.Unboxed.MVector' instance obey several laws. muvectorLaws :: (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Laws
− src/Test/QuickCheck/Classes/Monad.hs 
@@ -1,114 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Monad-  (-#if HAVE_UNARY_LAWS-    monadLaws-#endif-  ) where--import Control.Applicative-import Test.QuickCheck hiding ((.&.))-import Control.Monad (ap)-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Arbitrary (Arbitrary1(..))-import Data.Functor.Classes (Eq1,Show1)-#endif-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1)-#endif--#if HAVE_UNARY_LAWS---- | Tests the following monadic properties:------ [/Left Identity/]---   @'return' a '>>=' k ≡ k a@--- [/Right Identity/]---   @m '>>=' 'return' ≡ m@--- [/Associativity/]---   @m '>>=' (\\x -> k x '>>=' h) ≡ (m '>>=' k) '>>=' h@--- [/Return/]---   @'pure' ≡ 'return'@--- [/Ap/]---   @('<*>') ≡ 'ap'@-monadLaws ::-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Monad f, Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Laws-monadLaws p = Laws "Monad"-  [ ("Left Identity", monadLeftIdentity p)-  , ("Right Identity", monadRightIdentity p)-  , ("Associativity", monadAssociativity p)-  , ("Return", monadReturn p)-  , ("Ap", monadAp p)-  ]--monadLeftIdentity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Monad f, Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Monad f, Functor f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-monadLeftIdentity _ = property $ \(k' :: LinearEquationM f) (a :: Integer) ->-  let k = runLinearEquationM k'-   in eq1 (return a >>= k) (k a)--monadRightIdentity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Monad f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Monad f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-monadRightIdentity _ = property $ \(Apply (m :: f Integer)) ->-  eq1 (m >>= return) m--monadAssociativity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Monad f, Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Monad f, Functor f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-monadAssociativity _ = property $ \(Apply (m :: f Integer)) (k' :: LinearEquationM f) (h' :: LinearEquationM f) ->-  let k = runLinearEquationM k'-      h = runLinearEquationM h'-   in eq1 (m >>= (\x -> k x >>= h)) ((m >>= k) >>= h)--monadReturn :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Monad f, Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-monadReturn _ = property $ \(x :: Integer) ->-  eq1 (return x) (pure x :: f Integer)--monadAp :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Monad f, Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-monadAp _ = property $ \(Apply (f' :: f QuadraticEquation)) (Apply (x :: f Integer)) ->-  let f = fmap runQuadraticEquation f'-   in eq1 (ap f x) (f <*> x)--#endif
− src/Test/QuickCheck/Classes/MonadFail.hs 
@@ -1,57 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.MonadFail-  (-#if HAVE_UNARY_LAWS-    monadFailLaws-#endif-  ) where--#if HAVE_UNARY_LAWS--import Control.Applicative-import Test.QuickCheck hiding ((.&.))-import Control.Monad (ap)-import Test.QuickCheck.Arbitrary (Arbitrary1(..))-import Data.Functor.Classes (Eq1,Show1)-import Prelude hiding (fail)-import Control.Monad.Fail (MonadFail(..))-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common-import Test.QuickCheck.Classes.Compat (eq1)---- | Tests the following 'MonadFail' properties:--- --- [/Left Zero/]--- @'fail' s '>>=' f ≡ 'fail' s@-monadFailLaws :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (MonadFail f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (MonadFail f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Laws-monadFailLaws p = Laws "Monad"-  [ ("Left Zero", monadFailLeftZero p)-  ]- -monadFailLeftZero :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (MonadFail f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (MonadFail f, Functor f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-monadFailLeftZero _ = property $ \(k' :: LinearEquationM f) (s :: String) ->-  let k = runLinearEquationM k'-  in eq1 (fail s >>= k) (fail s)--#endif
− src/Test/QuickCheck/Classes/MonadPlus.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.MonadPlus-  (-#if HAVE_UNARY_LAWS-    monadPlusLaws-#endif-  ) where--import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Property (Property)-import Test.QuickCheck.Classes.Common-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1)-#endif-import Control.Monad (MonadPlus(mzero,mplus))--#if HAVE_UNARY_LAWS-import Test.QuickCheck.Arbitrary (Arbitrary1(..))-import Data.Functor.Classes (Eq1,Show1)-#endif--#if HAVE_UNARY_LAWS---- | Tests the following monad plus properties:------ [/Left Identity/]---   @'mplus' 'mzero' x ≡ x@--- [/Right Identity/]---   @'mplus' x 'mzero' ≡ x@--- [/Associativity/]---   @'mplus' a ('mplus' b c) ≡ 'mplus' ('mplus' a b) c)@ --- [/Left Zero/]---   @'mzero' '>>=' f ≡ 'mzero'@--- [/Right Zero/]---   @m '>>' 'mzero' ≡ 'mzero'@-monadPlusLaws ::-#if HAVE_QUANTIFIED_CONSTRAINTS-  (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Laws-monadPlusLaws p = Laws "MonadPlus"-  [ ("Left Identity", monadPlusLeftIdentity p)-  , ("Right Identity", monadPlusRightIdentity p)-  , ("Associativity", monadPlusAssociativity p)-  , ("Left Zero", monadPlusLeftZero p)-  , ("Right Zero", monadPlusRightZero p)-  ]--monadPlusLeftIdentity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-monadPlusLeftIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (mplus mzero a) a--monadPlusRightIdentity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-monadPlusRightIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (mplus a mzero) a--monadPlusAssociativity :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-monadPlusAssociativity _ = property $ \(Apply (a :: f Integer)) (Apply (b :: f Integer)) (Apply (c :: f Integer)) -> eq1 (mplus a (mplus b c)) (mplus (mplus a b) c)--monadPlusLeftZero :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-monadPlusLeftZero _ = property $ \(k' :: LinearEquationM f) -> eq1 (mzero >>= runLinearEquationM k') mzero--monadPlusRightZero :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-monadPlusRightZero _ = property $ \(Apply (a :: f Integer)) -> eq1 (a >> (mzero :: f Integer)) mzero--#endif
− src/Test/QuickCheck/Classes/MonadZip.hs 
@@ -1,65 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.MonadZip-  (-#if HAVE_UNARY_LAWS-    monadZipLaws-#endif-  ) where--import Control.Applicative-import Control.Arrow (Arrow(..))-import Control.Monad.Zip (MonadZip(mzip))-import Test.QuickCheck hiding ((.&.))-import Control.Monad (liftM)-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Arbitrary (Arbitrary1(..))-import Data.Functor.Classes (Eq1,Show1)-#endif-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1)-#endif--#if HAVE_UNARY_LAWS---- | Tests the following monadic zipping properties:------ [/Naturality/]---   @'liftM' (f '***' g) ('mzip' ma mb) = 'mzip' ('liftM' f ma) ('liftM' g mb)@------ In the laws above, the infix function @'***'@ refers to a typeclass--- method of 'Arrow'.-monadZipLaws ::-#if HAVE_QUANTIFIED_CONSTRAINTS-  (MonadZip f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (MonadZip f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Laws-monadZipLaws p = Laws "MonadZip"-  [ ("Naturality", monadZipNaturality p)-  ]--monadZipNaturality :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (MonadZip f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (MonadZip f, Functor f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property-monadZipNaturality _ = property $ \(f' :: LinearEquation) (g' :: LinearEquation) (Apply (ma :: f Integer)) (Apply (mb :: f Integer)) ->-  let f = runLinearEquation f'-      g = runLinearEquation g'-   in eq1 (liftM (f *** g) (mzip ma mb)) (mzip (liftM f ma) (liftM g mb))--#endif
− src/Test/QuickCheck/Classes/Monoid.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Monoid-  ( monoidLaws-  , commutativeMonoidLaws-  , semigroupMonoidLaws-  ) where--import Data.Semigroup-import Data.Monoid-import Data.Proxy (Proxy)-import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common (Laws(..), SmallList(..), myForAllShrink)---- | Tests the following properties:------ [/Associative/]---   @mappend a (mappend b c) ≡ mappend (mappend a b) c@--- [/Left Identity/]---   @mappend mempty a ≡ a@--- [/Right Identity/]---   @mappend a mempty ≡ a@--- [/Concatenation/]---   @mconcat as ≡ foldr mappend mempty as@-monoidLaws :: (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws-monoidLaws p = Laws "Monoid"-  [ ("Associative", monoidAssociative p)-  , ("Left Identity", monoidLeftIdentity p)-  , ("Right Identity", monoidRightIdentity p)-  , ("Concatenation", monoidConcatenation p)-  ]---- | Tests the following properties:------ [/Commutative/]---   @mappend a b ≡ mappend b a@------ Note that this does not test associativity or identity. Make sure to use--- 'monoidLaws' in addition to this set of laws.-commutativeMonoidLaws :: (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws-commutativeMonoidLaws p = Laws "Commutative Monoid"-  [ ("Commutative", monoidCommutative p)-  ]--semigroupMonoidLaws :: forall a. (Semigroup a, Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws-semigroupMonoidLaws p = Laws "Semigroup/Monoid"-  [ ("mappend == <>", semigroupMonoid p)-  ]--semigroupMonoid :: forall a. (Semigroup a, Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-semigroupMonoid _ = myForAllShrink True (const True)-  (\(a :: a,b) -> ["a = " ++ show a, "b = " ++ show b])-  "mappend a b"-  (\(a,b) -> mappend a b)-  "a <> b"-  (\(a,b) -> a Data.Semigroup.<> b)--monoidConcatenation :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-monoidConcatenation _ = myForAllShrink True (const True)-  (\(SmallList (as :: [a])) -> ["as = " ++ show as])-  "mconcat as"-  (\(SmallList as) -> mconcat as)-  "foldr mappend mempty as"-  (\(SmallList as) -> foldr mappend mempty as)--monoidAssociative :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-monoidAssociative _ = myForAllShrink True (const True)-  (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c])-  "mappend a (mappend b c)"-  (\(a,b,c) -> mappend a (mappend b c))-  "mappend (mappend a b) c"-  (\(a,b,c) -> mappend (mappend a b) c)--monoidLeftIdentity :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-monoidLeftIdentity _ = myForAllShrink False (const True)-  (\(a :: a) -> ["a = " ++ show a])-  "mappend mempty a"-  (\a -> mappend mempty a)-  "a"-  (\a -> a)--monoidRightIdentity :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-monoidRightIdentity _ = myForAllShrink False (const True)-  (\(a :: a) -> ["a = " ++ show a])-  "mappend a mempty"-  (\a -> mappend a mempty)-  "a"-  (\a -> a)--monoidCommutative :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-monoidCommutative _ = myForAllShrink True (const True)-  (\(a :: a,b) -> ["a = " ++ show a, "b = " ++ show b])-  "mappend a b"-  (\(a,b) -> mappend a b)-  "mappend b a"-  (\(a,b) -> mappend b a)
− src/Test/QuickCheck/Classes/Num.hs 
@@ -1,140 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Num-  ( numLaws-  ) where--import Data.Proxy (Proxy)-import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common (Laws(..), myForAllShrink)---- | Tests the following properties:------ [/Additive Commutativity/]---   @a + b ≡ b + a@--- [/Additive Left Identity/]---   @0 + a ≡ a@--- [/Additive Right Identity/]---   @a + 0 ≡ a@--- [/Multiplicative Associativity/]---   @a * (b * c) ≡ (a * b) * c@--- [/Multiplicative Left Identity/]---   @1 * a ≡ a@--- [/Multiplicative Right Identity/]---   @a * 1 ≡ a@--- [/Multiplication Left Distributes Over Addition/]---   @a * (b + c) ≡ (a * b) + (a * c)@--- [/Multiplication Right Distributes Over Addition/]---   @(a + b) * c ≡ (a * c) + (b * c)@--- [/Multiplicative Left Annihilation/]---   @0 * a ≡ 0@--- [/Multiplicative Right Annihilation/]---   @a * 0 ≡ 0@--- [/Additive Inverse/]---   @'negate' a '+' a ≡ 0@-numLaws :: (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws-numLaws p = Laws "Num"-  [ ("Additive Commutativity", numCommutativePlus p)-  , ("Additive Left Identity", numLeftIdentityPlus p)-  , ("Additive Right Identity", numRightIdentityPlus p)-  , ("Multiplicative Associativity", numAssociativeTimes p)-  , ("Multiplicative Left Identity", numLeftIdentityTimes p)-  , ("Multiplicative Right Identity", numRightIdentityTimes p)-  , ("Multiplication Left Distributes Over Addition", numLeftMultiplicationDistributes p)-  , ("Multiplication Right Distributes Over Addition", numRightMultiplicationDistributes p)-  , ("Multiplicative Left Annihilation", numLeftAnnihilation p)-  , ("Multiplicative Right Annihilation", numRightAnnihilation p)-  , ("Additive Inverse", numAdditiveInverse p)-  ]--numLeftMultiplicationDistributes :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-numLeftMultiplicationDistributes _ = myForAllShrink True (const True)-  (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c])-  "a * (b + c)"-  (\(a,b,c) -> a * (b + c))-  "(a * b) + (a * c)"-  (\(a,b,c) -> (a * b) + (a * c))--numRightMultiplicationDistributes :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-numRightMultiplicationDistributes _ = myForAllShrink True (const True)-  (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c])-  "(a + b) * c"-  (\(a,b,c) -> (a + b) * c)-  "(a * c) + (b * c)"-  (\(a,b,c) -> (a * c) + (b * c))--numLeftIdentityPlus :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-numLeftIdentityPlus _ = myForAllShrink False (const True)-  (\(a :: a) -> ["a = " ++ show a])-  "0 + a"-  (\a -> 0 + a)-  "a"-  (\a -> a)--numRightIdentityPlus :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-numRightIdentityPlus _ = myForAllShrink False (const True)-  (\(a :: a) -> ["a = " ++ show a])-  "a + 0"-  (\a -> a + 0)-  "a"-  (\a -> a)--numRightIdentityTimes :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-numRightIdentityTimes _ = myForAllShrink False (const True)-  (\(a :: a) -> ["a = " ++ show a])-  "a * 1"-  (\a -> a * 1)-  "a"-  (\a -> a)--numLeftIdentityTimes :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-numLeftIdentityTimes _ = myForAllShrink False (const True)-  (\(a :: a) -> ["a = " ++ show a])-  "1 * a"-  (\a -> 1 * a)-  "a"-  (\a -> a)--numLeftAnnihilation :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-numLeftAnnihilation _ = myForAllShrink False (const True)-  (\(a :: a) -> ["a = " ++ show a])-  "0 * a"-  (\a -> 0 * a)-  "0"-  (\_ -> 0)--numRightAnnihilation :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-numRightAnnihilation _ = myForAllShrink False (const True)-  (\(a :: a) -> ["a = " ++ show a])-  "a * 0"-  (\a -> a * 0)-  "0"-  (\_ -> 0)--numCommutativePlus :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-numCommutativePlus _ = myForAllShrink True (const True)-  (\(a :: a,b) -> ["a = " ++ show a, "b = " ++ show b])-  "a + b"-  (\(a,b) -> a + b)-  "b + a"-  (\(a,b) -> b + a)--numAssociativeTimes :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-numAssociativeTimes _ = myForAllShrink True (const True)-  (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c])-  "a * (b * c)"-  (\(a,b,c) -> a * (b * c))-  "(a * b) * c"-  (\(a,b,c) -> (a * b) * c)--numAdditiveInverse :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-numAdditiveInverse _ = myForAllShrink True (const True)-  (\(a :: a) -> ["a = " ++ show a])-  "negate a + a"-  (\a -> (-a) + a)-  "0"-  (const 0)
− src/Test/QuickCheck/Classes/Ord.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Ord-  ( ordLaws-  ) where--import Data.Proxy (Proxy)-import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common (Laws(..))---- | Tests the following properties:------ [/Antisymmetry/]---   @a ≤ b ∧ b ≤ a ⇒ a = b@ --- [/Transitivity/]---   @a ≤ b ∧ b ≤ c ⇒ a ≤ c@--- [/Totality/]---   @a ≤ b ∨ a > b@-ordLaws :: (Ord a, Arbitrary a, Show a) => Proxy a -> Laws-ordLaws p = Laws "Ord"-  [ ("Antisymmetry", ordAntisymmetric p)-  , ("Transitivity", ordTransitive p)-  , ("Totality", ordTotal p)-  ]--ordAntisymmetric :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property-ordAntisymmetric _ = property $ \(a :: a) b -> ((a <= b) && (b <= a)) == (a == b)--ordTotal :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property-ordTotal _ = property $ \(a :: a) b -> ((a <= b) || (b <= a)) == True---- Technically, this tests something a little stronger than it is supposed to.--- But that should be alright since this additional strength is implied by--- the rest of the Ord laws.-ordTransitive :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property-ordTransitive _ = property $ \(a :: a) b c -> case (compare a b, compare b c) of-  (LT,LT) -> a < c-  (LT,EQ) -> a < c-  (LT,GT) -> True-  (EQ,LT) -> a < c-  (EQ,EQ) -> a == c-  (EQ,GT) -> a > c-  (GT,LT) -> True-  (GT,EQ) -> a > c-  (GT,GT) -> a > c
src/Test/QuickCheck/Classes/Plus.hs view
@@ -28,8 +28,7 @@ import qualified Control.Applicative as Alternative import Test.QuickCheck.Property (Property) -import Test.QuickCheck.Classes.Common-import Test.QuickCheck.Classes.Compat (eq1)+import Test.QuickCheck.Classes.Internal  -- | Tests the following alt properties: --
src/Test/QuickCheck/Classes/Prim.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-}@@ -16,8 +17,8 @@ import Control.Monad.ST import Data.Proxy (Proxy) import Data.Primitive.ByteArray-import Data.Primitive.Types-import Data.Primitive.Addr+import Data.Primitive.Types (Prim(..))+import "primitive-addr" Data.Primitive.Addr import Foreign.Marshal.Alloc import GHC.Exts   (State#,Int#,Addr#,Int(I#),(*#),(+#),(<#),newByteArray#,unsafeFreezeByteArray#,@@ -36,8 +37,7 @@ import qualified Data.List as L import qualified Data.Primitive as P -import Test.QuickCheck.Classes.Common (Laws(..))-import Test.QuickCheck.Classes.Compat (isTrue#)+import Test.QuickCheck.Classes.Internal (Laws(..),isTrue#)  -- | Test that a 'Prim' instance obey the several laws. primLaws :: (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws
src/Test/QuickCheck/Classes/Ring.hs view
@@ -19,7 +19,7 @@ import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) -import Test.QuickCheck.Classes.Common (Laws(..), myForAllShrink)+import Test.QuickCheck.Classes.Internal (Laws(..), myForAllShrink)  #if HAVE_SEMIRINGS -- | Tests the following properties:
− src/Test/QuickCheck/Classes/Semigroup.hs 
@@ -1,145 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Semigroup-  ( -- * Laws-    semigroupLaws-  , commutativeSemigroupLaws-  , exponentialSemigroupLaws-  , idempotentSemigroupLaws-  , rectangularBandSemigroupLaws-  ) where--import Prelude hiding (foldr1)-import Data.Semigroup (Semigroup(..))-import Data.Proxy (Proxy)-import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common (Laws(..), SmallList(..), myForAllShrink)--import Data.Foldable (foldr1,toList)-import Data.List.NonEmpty (NonEmpty((:|)))--import qualified Data.List as L---- | Tests the following properties:------ [/Associative/]---   @a '<>' (b '<>' c) ≡ (a '<>' b) '<>' c@--- [/Concatenation/]---   @'sconcat' as ≡ 'foldr1' ('<>') as@--- [/Times/]---   @'stimes' n a ≡ 'foldr1' ('<>') ('replicate' n a)@-semigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws-semigroupLaws p = Laws "Semigroup"-  [ ("Associative", semigroupAssociative p)-  , ("Concatenation", semigroupConcatenation p)-  , ("Times", semigroupTimes p)-  ]---- | Tests the following properties:------ [/Commutative/]---   @a '<>' b ≡ b '<>' a@------ Note that this does not test associativity. Make sure to use--- 'semigroupLaws' in addition to this set of laws.-commutativeSemigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws-commutativeSemigroupLaws p = Laws "Commutative Semigroup"-  [ ("Commutative", semigroupCommutative p)-  ]---- | Tests the following properties:------ [/Idempotent/]---   @a '<>' a ≡ a@------ Note that this does not test associativity. Make sure to use--- 'semigroupLaws' in addition to this set of laws. In literature,--- this class of semigroup is known as a band.-idempotentSemigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws-idempotentSemigroupLaws p = Laws "Idempotent Semigroup"-  [ ("Idempotent", semigroupIdempotent p)-  ]---- | Tests the following properties:------ [/Rectangular Band/]---   @a '<>' b '<>' a ≡ a@------ Note that this does not test associativity. Make sure to use--- 'semigroupLaws' in addition to this set of laws.-rectangularBandSemigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws-rectangularBandSemigroupLaws p = Laws "Rectangular Band Semigroup"-  [ ("Rectangular Band", semigroupRectangularBand p)-  ]---- | Tests the following properties:------ [/Exponential/]---   @'stimes' n (a '<>' b) ≡ 'stimes' n a '<>' 'stimes' n b@------ Note that this does not test associativity. Make sure to use--- 'semigroupLaws' in addition to this set of laws.-exponentialSemigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws-exponentialSemigroupLaws p = Laws "Exponential Semigroup"-  [ ("Exponential", semigroupExponential p)-  ]--semigroupAssociative :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-semigroupAssociative _ = myForAllShrink True (const True)-  (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c])-  "a <> (b <> c)"-  (\(a,b,c) -> a <> (b <> c))-  "(a <> b) <> c"-  (\(a,b,c) -> (a <> b) <> c)--semigroupCommutative :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-semigroupCommutative _ = myForAllShrink True (const True)-  (\(a :: a,b) -> ["a = " ++ show a, "b = " ++ show b])-  "a <> b"-  (\(a,b) -> a <> b)-  "b <> a"-  (\(a,b) -> b <> a)--semigroupConcatenation :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-semigroupConcatenation _ = myForAllShrink True (const True)-  (\(a, SmallList (as :: [a])) -> ["as = " ++ show (a :| as)])-  "sconcat as"-  (\(a, SmallList as) -> sconcat (a :| as))-  "foldr1 (<>) as"-  (\(a, SmallList as) -> foldr1 (<>) (a :| as))--semigroupTimes :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-semigroupTimes _ = myForAllShrink True (\(_,n) -> n > 0)-  (\(a :: a, n :: Int) -> ["a = " ++ show a, "n = " ++ show n])-  "stimes n a"-  (\(a,n) -> stimes n a)-  "foldr1 (<>) (replicate n a)"-  (\(a,n) -> foldr1 (<>) (replicate n a))--semigroupExponential :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-semigroupExponential _ = myForAllShrink True (\(_,_,n) -> n > 0)-  (\(a :: a, b, n :: Int) -> ["a = " ++ show a, "b = " ++ show b, "n = " ++ show n])-  "stimes n (a <> b)"-  (\(a,b,n) -> stimes n (a <> b))-  "stimes n a <> stimes n b"-  (\(a,b,n) -> stimes n a <> stimes n b)--semigroupIdempotent :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-semigroupIdempotent _ = myForAllShrink False (const True)-  (\(a :: a) -> ["a = " ++ show a])-  "a <> a"-  (\a -> a <> a)-  "a"-  (\a -> a)--semigroupRectangularBand :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-semigroupRectangularBand _ = myForAllShrink False (const True)-  (\(a :: a, b) -> ["a = " ++ show a, "b = " ++ show b])-  "a <> b <> a"-  (\(a,b) -> a <> b <> a)-  "a"-  (\(a,_) -> a)
src/Test/QuickCheck/Classes/Semigroupoid.hs view
@@ -22,8 +22,7 @@ import Data.Functor.Classes (Eq2,Show2) import Test.QuickCheck.Property (Property) -import Test.QuickCheck.Classes.Common-import Test.QuickCheck.Classes.Compat (eq2)+import Test.QuickCheck.Classes.Internal  -- | Tests the following 'Semigroupoid' properties: --
src/Test/QuickCheck/Classes/Semiring.hs view
@@ -4,7 +4,7 @@ {-# OPTIONS_GHC -Wall #-}  module Test.QuickCheck.Classes.Semiring-  ( +  ( #if HAVE_SEMIRINGS     semiringLaws #endif@@ -13,13 +13,14 @@ #if HAVE_SEMIRINGS import Data.Semiring import Prelude hiding (Num(..))+import Prelude (fromInteger) #endif  import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) -import Test.QuickCheck.Classes.Common (Laws(..), myForAllShrink)+import Test.QuickCheck.Classes.Internal (Laws(..), myForAllShrink)  #if HAVE_SEMIRINGS -- | Tests the following properties:@@ -44,6 +45,17 @@ --   @0 * a ≡ 0@ -- [/Multiplicative Right Annihilation/] --   @a * 0 ≡ 0@+--+-- Also tests that 'fromNatural' is a homomorphism of semirings:+--+-- [/FromNatural Maps Zero/]+--   'fromNatural' 0 = 'zero'+-- [/FromNatural Maps One/]+--   'fromNatural' 1 = 'one'+-- [/FromNatural Maps Plus/]+--   'fromNatural' (@a@ + @b@) = 'fromNatural' @a@ + 'fromNatural' @b@+-- [/FromNatural Maps Times/]+--   'fromNatural' (@a@ * @b@) = 'fromNatural' @a@ * 'fromNatural' @b@ semiringLaws :: (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws semiringLaws p = Laws "Semiring"   [ ("Additive Commutativity", semiringCommutativePlus p)@@ -56,6 +68,10 @@   , ("Multiplication Right Distributes Over Addition", semiringRightMultiplicationDistributes p)   , ("Multiplicative Left Annihilation", semiringLeftAnnihilation p)   , ("Multiplicative Right Annihilation", semiringRightAnnihilation p)+  , ("FromNatural Maps Zero", semiringFromNaturalMapsZero p)+  , ("FromNatural Maps One", semiringFromNaturalMapsOne p)+  , ("FromNatural Maps Plus", semiringFromNaturalMapsPlus p)+  , ("FromNatural Maps Times", semiringFromNaturalMapsTimes p)   ]  semiringLeftMultiplicationDistributes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property@@ -137,5 +153,39 @@   (\(a,b,c) -> a * (b * c))   "(a * b) * c"   (\(a,b,c) -> (a * b) * c)++semiringFromNaturalMapsZero :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+semiringFromNaturalMapsZero _ = myForAllShrink False (const True)+  (\_ -> [""])+  "fromNatural 0"+  (\() -> fromNatural 0 :: a)+  "zero"+  (\() -> zero)++semiringFromNaturalMapsOne :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+semiringFromNaturalMapsOne _ = myForAllShrink False (const True)+  (\_ -> [""])+  "fromNatural 1"+  (\() -> fromNatural 1 :: a)+  "one"+  (\() -> one)++-- | There is no Arbitrary instance for Natural in QuickCheck,+-- so we use NonNegative Integer instead.+semiringFromNaturalMapsPlus :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+semiringFromNaturalMapsPlus _ = myForAllShrink True (const True)+  (\(NonNegative a, NonNegative b) -> ["a = " ++ show a, "b = " ++ show b])+  "fromNatural (a + b)"+  (\(NonNegative a, NonNegative b) -> fromNatural (fromInteger (a + b)) :: a)+  "fromNatural a + fromNatural b"+  (\(NonNegative a, NonNegative b) -> fromNatural (fromInteger a) + fromNatural (fromInteger b))++semiringFromNaturalMapsTimes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+semiringFromNaturalMapsTimes _ = myForAllShrink True (const True)+  (\(NonNegative a, NonNegative b) -> ["a = " ++ show a, "b = " ++ show b])+  "fromNatural (a * b)"+  (\(NonNegative a, NonNegative b) -> fromNatural (fromInteger (a * b)) :: a)+  "fromNatural a * fromNatural b"+  (\(NonNegative a, NonNegative b) -> fromNatural (fromInteger a) * fromNatural (fromInteger b))  #endif
− src/Test/QuickCheck/Classes/Show.hs 
@@ -1,48 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -Wall #-}--{-| Module      : Test.QuickCheck.Classes.Show-    Description : Properties for testing the properties of the Show type class.--}-module Test.QuickCheck.Classes.Show-  ( showLaws-  ) where--import Data.Proxy (Proxy)-import Test.QuickCheck (Arbitrary, Property, property)--import Test.QuickCheck.Classes.Common (Laws(..), ShowReadPrecedence(..))---- | Tests the following properties:------ [/Show/]--- @'show' a ≡ 'showsPrec' 0 a ""@--- [/Equivariance: 'showsPrec'/]--- @'showsPrec' p a r '++' s ≡ 'showsPrec' p a (r '++' s)@--- [/Equivariance: 'showList'/]--- @'showList' as r '++' s ≡ 'showList' as (r '++' s)@----showLaws :: (Show a, Arbitrary a) => Proxy a -> Laws-showLaws p = Laws "Show"-  [ ("Show", showShowsPrecZero p)-  , ("Equivariance: showsPrec", equivarianceShowsPrec p)-  , ("Equivariance: showList", equivarianceShowList p)-  ]--showShowsPrecZero :: forall a. (Show a, Arbitrary a) => Proxy a -> Property-showShowsPrecZero _ =-  property $ \(a :: a) ->-    show a == showsPrec 0 a ""--equivarianceShowsPrec :: forall a.-  (Show a, Arbitrary a) => Proxy a -> Property-equivarianceShowsPrec _ =-  property $ \(ShowReadPrecedence p) (a :: a) (r :: String) (s :: String) ->-    showsPrec p a r ++ s == showsPrec p a (r ++ s)--equivarianceShowList :: forall a.-  (Show a, Arbitrary a) => Proxy a -> Property-equivarianceShowList _ =-  property $ \(as :: [a]) (r :: String) (s :: String) ->-    showList as r ++ s == showList as (r ++ s)
− src/Test/QuickCheck/Classes/ShowRead.hs 
@@ -1,86 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wall #-}--{-| Module      : Test.QuickCheck.Classes.ShowRead-    Description : Properties for testing the interaction between the Show and Read-                  type classes.--}-module Test.QuickCheck.Classes.ShowRead-  ( showReadLaws-  ) where--import Data.Proxy (Proxy)-import Test.QuickCheck-import Text.Read (readListDefault)-import Text.Show (showListWith)--import Test.QuickCheck.Classes.Common (Laws(..), ShowReadPrecedence(..),-  SmallList(..), myForAllShrink)-import Test.QuickCheck.Classes.Compat (readMaybe)---- | Tests the following properties:------ [/Partial Isomorphism: 'show' \/ 'read'/]---   @'readMaybe' ('show' a) ≡ 'Just' a@--- [/Partial Isomorphism: 'show' \/ 'read' with initial space/]---   @'readMaybe' (" " ++ 'show' a) ≡ 'Just' a@--- [/Partial Isomorphism: 'showsPrec' \/ 'readsPrec'/]---   @(a,"") \`elem\` 'readsPrec' p ('showsPrec' p a "")@--- [/Partial Isomorphism: 'showList' \/ 'readList'/]---   @(as,"") \`elem\` 'readList' ('showList' as "")@--- [/Partial Isomorphism: 'showListWith' 'shows' \/ 'readListDefault'/]---   @(as,"") \`elem\` 'readListDefault' ('showListWith' 'shows' as "")@------ /Note:/ When using @base-4.5@ or older, a shim implementation--- of 'readMaybe' is used.----showReadLaws :: (Show a, Read a, Eq a, Arbitrary a) => Proxy a -> Laws-showReadLaws p = Laws "Show/Read"-  [ ("Partial Isomorphism: show/read", showReadPartialIsomorphism p)-  , ("Partial Isomorphism: show/read with initial space", showReadSpacePartialIsomorphism p)-  , ("Partial Isomorphism: showsPrec/readsPrec", showsPrecReadsPrecPartialIsomorphism p)-  , ("Partial Isomorphism: showList/readList", showListReadListPartialIsomorphism p)-  , ("Partial Isomorphism: showListWith shows / readListDefault",-     showListWithShowsReadListDefaultPartialIsomorphism p)-  ]---showReadPartialIsomorphism :: forall a.-  (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property-showReadPartialIsomorphism _ =-  myForAllShrink False (const True)-  (\(a :: a) -> ["a = " ++ show a])-  ("readMaybe (show a)")-  (\a -> readMaybe (show a))-  ("Just a")-  (\a -> Just a)--showReadSpacePartialIsomorphism :: forall a.-  (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property-showReadSpacePartialIsomorphism _ =-  myForAllShrink False (const True)-  (\(a :: a) -> ["a = " ++ show a])-  ("readMaybe (\" \" ++ show a)")-  (\a -> readMaybe (" " ++ show a))-  ("Just a")-  (\a -> Just a)--showsPrecReadsPrecPartialIsomorphism :: forall a.-  (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property-showsPrecReadsPrecPartialIsomorphism _ =-  property $ \(a :: a) (ShowReadPrecedence p) ->-    (a,"") `elem` readsPrec p (showsPrec p a "")--showListReadListPartialIsomorphism :: forall a.-  (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property-showListReadListPartialIsomorphism _ =-  property $ \(SmallList (as :: [a])) ->-    (as,"") `elem` readList (showList as "")--showListWithShowsReadListDefaultPartialIsomorphism :: forall a.-  (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property-showListWithShowsReadListDefaultPartialIsomorphism _ =-  property $ \(SmallList (as :: [a])) ->-    (as,"") `elem` readListDefault (showListWith shows as "")-
− src/Test/QuickCheck/Classes/Storable.hs 
@@ -1,150 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnboxedTuples #-}--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Storable-  ( storableLaws-  ) where--import Control.Applicative-import Data.Proxy (Proxy)-import Foreign.Marshal.Alloc-import Foreign.Marshal.Array-import Foreign.Storable--import GHC.Ptr (Ptr(..), plusPtr)-import System.IO.Unsafe-import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Property (Property)--import qualified Data.List as L--import Test.QuickCheck.Classes.Common (Laws(..))---- | Tests the following alternative properties:------ [/Set-Get/]---   @('pokeElemOff' ptr ix a >> 'peekElemOff' ptr ix') ≡ 'pure' a@--- [/Get-Set/]---   @('peekElemOff' ptr ix >> 'pokeElemOff' ptr ix a) ≡ 'pure' a@-storableLaws :: (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws-storableLaws p = Laws "Storable"-  [ ("Set-Get (you get back what you put in)", storableSetGet p)-  , ("Get-Set (putting back what you got out has no effect)", storableGetSet p)-  , ("List Conversion Roundtrips", storableList p)-  , ("peekElemOff a i ≡ peek (plusPtr a (i * sizeOf undefined))", storablePeekElem p)-  , ("peekElemOff a i x ≡ poke (plusPtr a (i * sizeOf undefined)) x ≡ id ", storablePokeElem p)-  , ("peekByteOff a i ≡ peek (plusPtr a i)", storablePeekByte p)-  , ("peekByteOff a i x ≡ poke (plusPtr a i) x ≡ id ", storablePokeByte p)-  ]--arrayArbitrary :: forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a)-arrayArbitrary len = do-  let go ix xs = if ix == len-        then pure xs-        else do-          x <- generate (arbitrary :: Gen a)-          go (ix + 1) (x : xs)-  as <- go 0 []-  newArray as--storablePeekElem :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-storablePeekElem _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do-  let len = L.length as-  ix <- choose (0, len - 1)-  return $ unsafePerformIO $ do-    addr :: Ptr a <- arrayArbitrary len-    x <- peekElemOff addr ix-    y <- peek (addr `plusPtr` (ix * sizeOf (undefined :: a)))-    free addr-    return (x == y)--storablePokeElem :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-storablePokeElem _ = property $ \(as :: [a]) (x :: a) -> (not (L.null as)) ==> do-  let len = L.length as-  ix <- choose (0, len - 1)-  return $ unsafePerformIO $ do-    addr :: Ptr a <- arrayArbitrary len-    pokeElemOff addr ix x-    u <- peekElemOff addr ix-    poke (addr `plusPtr` (ix * sizeOf x)) x-    v <- peekElemOff addr ix-    free addr-    return (u == v)--storablePeekByte :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-storablePeekByte _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do-  let len = L.length as-  off <- choose (0, len - 1)-  return $ unsafePerformIO $ do-    addr :: Ptr a <- arrayArbitrary len-    x :: a <- peekByteOff addr off-    y :: a <- peek (addr `plusPtr` off)-    free addr-    return (x == y)--storablePokeByte :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-storablePokeByte _ = property $ \(as :: [a]) (x :: a) -> (not (L.null as)) ==> do-  let len = L.length as-  off <- choose (0, len - 1)-  return $ unsafePerformIO $ do-    addr :: Ptr a <- arrayArbitrary len-    pokeByteOff addr off x-    u :: a <- peekByteOff addr off-    poke (addr `plusPtr` off) x-    v :: a <- peekByteOff addr off-    free addr-    return (u == v)--storableSetGet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-storableSetGet _ = property $ \(a :: a) len -> (len > 0) ==> do-  ix <- choose (0,len - 1)-  return $ unsafePerformIO $ do-    ptr :: Ptr a <- arrayArbitrary len-    pokeElemOff ptr ix a-    a' <- peekElemOff ptr ix-    free ptr-    return (a == a')--storableGetSet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-storableGetSet _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do-  let len = L.length as-  ix <- choose (0,len - 1)-  return $ unsafePerformIO $ do-    ptrA <- newArray as-    ptrB <- arrayArbitrary len-    copyArray ptrB ptrA len-    a <- peekElemOff ptrA ix-    pokeElemOff ptrA ix a-    res <- arrayEq ptrA ptrB len-    free ptrA-    free ptrB-    return res--storableList :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-storableList _ = property $ \(as :: [a]) -> unsafePerformIO $ do-  let len = L.length as-  ptr <- newArray as-  let rebuild :: Int -> IO [a]-      rebuild !ix = if ix < len-        then (:) <$> peekElemOff ptr ix <*> rebuild (ix + 1)-        else return []-  asNew <- rebuild 0-  free ptr-  return (as == asNew)--arrayEq :: forall a. (Storable a, Eq a) => Ptr a -> Ptr a -> Int -> IO Bool-arrayEq ptrA ptrB len = go 0 where-  go !i = if i < len-    then do-      a <- peekElemOff ptrA i-      b <- peekElemOff ptrB i-      if a == b-        then go (i + 1)-        else return False-    else return True
− src/Test/QuickCheck/Classes/Traversable.hs 
@@ -1,102 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Traversable-  (-#if HAVE_UNARY_LAWS-    traversableLaws-#endif-  ) where--import Data.Foldable (foldMap)-import Data.Traversable (Traversable,fmapDefault,foldMapDefault,sequenceA,traverse)-import Test.QuickCheck hiding ((.&.))-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Arbitrary (Arbitrary1(..))-import Data.Functor.Classes (Eq1,Show1)-#endif-import Data.Functor.Compose-import Data.Functor.Identity--import qualified Data.Set as S--import Test.QuickCheck.Classes.Common-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1)-#endif--#if HAVE_UNARY_LAWS---- | Tests the following 'Traversable' properties:------ [/Naturality/]---   @t '.' 'traverse' f ≡ 'traverse' (t '.' f)@---   for every applicative transformation @t@--- [/Identity/]---   @'traverse' 'Identity' ≡ 'Identity'@--- [/Composition/]---   @'traverse' ('Compose' '.' 'fmap' g '.' f) ≡ 'Compose' '.' 'fmap' ('traverse' g) '.' 'traverse' f@--- [/Sequence Naturality/]---   @t '.' 'sequenceA' ≡ 'sequenceA' '.' 'fmap' t@---   for every applicative transformation @t@--- [/Sequence Identity/]---   @'sequenceA' '.' 'fmap' 'Identity' ≡ 'Identity'@--- [/Sequence Composition/]---   @'sequenceA' '.' 'fmap' 'Compose' ≡ 'Compose' '.' 'fmap' 'sequenceA' '.' 'sequenceA'@--- [/foldMap/]---   @'foldMap' ≡ 'foldMapDefault'@--- [/fmap/]---   @'fmap' ≡ 'fmapDefault'@------ Where an /applicative transformation/ is a function------ @t :: (Applicative f, Applicative g) => f a -> g a@------ preserving the 'Applicative' operations, i.e.------ * Identity: @t ('pure' x) ≡ 'pure' x@--- * Distributivity: @t (x '<*>' y) ≡ t x '<*>' t y@-traversableLaws ::-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Traversable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Traversable f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Laws-traversableLaws = traversableLawsInternal--traversableLawsInternal :: forall proxy f.-#if HAVE_QUANTIFIED_CONSTRAINTS-  (Traversable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (Traversable f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Laws-traversableLawsInternal _ = Laws "Traversable"-  [ (,) "Naturality" $ property $ \(Apply (a :: f Integer)) ->-      propNestedEq1 (apTrans (traverse func4 a)) (traverse (apTrans . func4) a)-  , (,) "Identity" $ property $ \(Apply (t :: f Integer)) ->-      nestedEq1 (traverse Identity t) (Identity t)-  , (,) "Composition" $ property $ \(Apply (t :: f Integer)) ->-      nestedEq1 (traverse (Compose . fmap func5 . func6) t) (Compose (fmap (traverse func5) (traverse func6 t)))-  , (,) "Sequence Naturality" $ property $ \(Apply (x :: f (Compose Triple ((,) (S.Set Integer)) Integer))) ->-      let a = fmap toSpecialApplicative x in-      propNestedEq1 (apTrans (sequenceA a)) (sequenceA (fmap apTrans a))-  , (,) "Sequence Identity" $ property $ \(Apply (t :: f Integer)) ->-      nestedEq1 (sequenceA (fmap Identity t)) (Identity t)-  , (,) "Sequence Composition" $ property $ \(Apply (t :: f (Triple (Triple Integer)))) ->-      nestedEq1 (sequenceA (fmap Compose t)) (Compose (fmap sequenceA (sequenceA t)))-  , (,) "foldMap" $ property $ \(Apply (t :: f Integer)) ->-      foldMap func3 t == foldMapDefault func3 t-  , (,) "fmap" $ property $ \(Apply (t :: f Integer)) ->-      eq1 (fmap func3 t) (fmapDefault func3 t)-  ]---#endif