summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorandrewthad <>2019-08-08 17:32:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-08-08 17:32:00 (GMT)
commitd291dae0919a18d84af1d312acfbe25b42a461d9 (patch)
tree7b28d63ce5c368a140fd3523f121f02224d9f2da
parentd11b4b08f1947ec26697b23a1f6afa9f79f3c441 (diff)
version 0.6.3.00.6.3.0
-rw-r--r--Setup.hs2
-rwxr-xr-xchangelog.md18
-rw-r--r--quickcheck-classes.cabal47
-rw-r--r--src/Test/QuickCheck/Classes.hs261
-rw-r--r--src/Test/QuickCheck/Classes/Alt.hs3
-rw-r--r--src/Test/QuickCheck/Classes/Alternative.hs80
-rw-r--r--src/Test/QuickCheck/Classes/Applicative.hs114
-rw-r--r--src/Test/QuickCheck/Classes/Apply.hs3
-rw-r--r--src/Test/QuickCheck/Classes/Bifoldable.hs124
-rw-r--r--src/Test/QuickCheck/Classes/Bifunctor.hs94
-rw-r--r--src/Test/QuickCheck/Classes/Bitraversable.hs97
-rw-r--r--src/Test/QuickCheck/Classes/Bits.hs182
-rw-r--r--src/Test/QuickCheck/Classes/Category.hs111
-rw-r--r--src/Test/QuickCheck/Classes/Common.hs496
-rw-r--r--src/Test/QuickCheck/Classes/Compat.hs84
-rw-r--r--src/Test/QuickCheck/Classes/Contravariant.hs74
-rw-r--r--src/Test/QuickCheck/Classes/Enum.hs77
-rw-r--r--src/Test/QuickCheck/Classes/Eq.hs50
-rw-r--r--src/Test/QuickCheck/Classes/Euclidean.hs122
-rw-r--r--src/Test/QuickCheck/Classes/Foldable.hs187
-rw-r--r--src/Test/QuickCheck/Classes/Functor.hs86
-rw-r--r--src/Test/QuickCheck/Classes/Generic.hs112
-rw-r--r--src/Test/QuickCheck/Classes/Integral.hs52
-rw-r--r--src/Test/QuickCheck/Classes/IsList.hs251
-rw-r--r--src/Test/QuickCheck/Classes/Ix.hs49
-rw-r--r--src/Test/QuickCheck/Classes/Json.hs2
-rw-r--r--src/Test/QuickCheck/Classes/MVector.hs8
-rw-r--r--src/Test/QuickCheck/Classes/Monad.hs114
-rw-r--r--src/Test/QuickCheck/Classes/MonadFail.hs57
-rw-r--r--src/Test/QuickCheck/Classes/MonadPlus.hs104
-rw-r--r--src/Test/QuickCheck/Classes/MonadZip.hs65
-rw-r--r--src/Test/QuickCheck/Classes/Monoid.hs100
-rw-r--r--src/Test/QuickCheck/Classes/Num.hs140
-rw-r--r--src/Test/QuickCheck/Classes/Ord.hs49
-rw-r--r--src/Test/QuickCheck/Classes/Plus.hs3
-rw-r--r--src/Test/QuickCheck/Classes/Prim.hs8
-rw-r--r--src/Test/QuickCheck/Classes/Ring.hs2
-rw-r--r--src/Test/QuickCheck/Classes/Semigroup.hs145
-rw-r--r--src/Test/QuickCheck/Classes/Semigroupoid.hs3
-rw-r--r--src/Test/QuickCheck/Classes/Semiring.hs54
-rw-r--r--src/Test/QuickCheck/Classes/Show.hs48
-rw-r--r--src/Test/QuickCheck/Classes/ShowRead.hs86
-rw-r--r--src/Test/QuickCheck/Classes/Storable.hs150
-rw-r--r--src/Test/QuickCheck/Classes/Traversable.hs102
44 files changed, 267 insertions, 3749 deletions
diff --git a/Setup.hs b/Setup.hs
deleted file mode 100644
index 9a994af..0000000
--- a/Setup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/changelog.md b/changelog.md
index 4175c1b..be37933 100755
--- a/changelog.md
+++ b/changelog.md
@@ -4,6 +4,18 @@ All notable changes to this project will be documented in this file.
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 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.
### 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 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.
### 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 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.
## [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
diff --git a/quickcheck-classes.cabal b/quickcheck-classes.cabal
index 0db6975..3224d47 100644
--- a/quickcheck-classes.cabal
+++ b/quickcheck-classes.cabal
@@ -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 vector
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 @@ library
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 @@ library
, 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 @@ library
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
diff --git a/src/Test/QuickCheck/Classes.hs b/src/Test/QuickCheck/Classes.hs
index 58a67d8..8041371 100644
--- a/src/Test/QuickCheck/Classes.hs
+++ b/src/Test/QuickCheck/Classes.hs
@@ -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 @@ module Test.QuickCheck.Classes
#endif
#endif
-- * Types
- , Laws(..)
- , Proxy1(..)
- , Proxy2(..)
+ , QCB.Laws(..)
+ , QCB.Proxy1(..)
+ , QCB.Proxy2(..)
) where
--
@@ -100,58 +102,31 @@ module Test.QuickCheck.Classes
--
-- 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.Semigroupoid
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
diff --git a/src/Test/QuickCheck/Classes/Alt.hs b/src/Test/QuickCheck/Classes/Alt.hs
index 1c2b1c3..94d6ef3 100644
--- a/src/Test/QuickCheck/Classes/Alt.hs
+++ b/src/Test/QuickCheck/Classes/Alt.hs
@@ -23,8 +23,7 @@ import Test.QuickCheck.Arbitrary (Arbitrary1(..))
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:
--
diff --git a/src/Test/QuickCheck/Classes/Alternative.hs b/src/Test/QuickCheck/Classes/Alternative.hs
deleted file mode 100644
index 25a661f..0000000
--- a/src/Test/QuickCheck/Classes/Alternative.hs
+++ /dev/null
@@ -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
diff --git a/src/Test/QuickCheck/Classes/Applicative.hs b/src/Test/QuickCheck/Classes/Applicative.hs
deleted file mode 100644
index eef7c4f..0000000
--- a/src/Test/QuickCheck/Classes/Applicative.hs
+++ /dev/null
@@ -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
diff --git a/src/Test/QuickCheck/Classes/Apply.hs b/src/Test/QuickCheck/Classes/Apply.hs
index 9a18636..b1aa876 100644
--- a/src/Test/QuickCheck/Classes/Apply.hs
+++ b/src/Test/QuickCheck/Classes/Apply.hs
@@ -23,8 +23,7 @@ import Test.QuickCheck.Arbitrary (Arbitrary1(..))
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
diff --git a/src/Test/QuickCheck/Classes/Bifoldable.hs b/src/Test/QuickCheck/Classes/Bifoldable.hs
deleted file mode 100644
index cfc453d..0000000
--- a/src/Test/QuickCheck/Classes/Bifoldable.hs
+++ /dev/null
@@ -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 \ No newline at end of file
diff --git a/src/Test/QuickCheck/Classes/Bifunctor.hs b/src/Test/QuickCheck/Classes/Bifunctor.hs
deleted file mode 100644
index 1e8cc50..0000000
--- a/src/Test/QuickCheck/Classes/Bifunctor.hs
+++ /dev/null
@@ -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
diff --git a/src/Test/QuickCheck/Classes/Bitraversable.hs b/src/Test/QuickCheck/Classes/Bitraversable.hs
deleted file mode 100644
index 5deedef..0000000
--- a/src/Test/QuickCheck/Classes/Bitraversable.hs
+++ /dev/null
@@ -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
diff --git a/src/Test/QuickCheck/Classes/Bits.hs b/src/Test/QuickCheck/Classes/Bits.hs
deleted file mode 100644
index 7cb633b..0000000
--- a/src/Test/QuickCheck/Classes/Bits.hs
+++ /dev/null
@@ -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
diff --git a/src/Test/QuickCheck/Classes/Category.hs b/src/Test/QuickCheck/Classes/Category.hs
deleted file mode 100644
index 6f65f4a..0000000
--- a/src/Test/QuickCheck/Classes/Category.hs
+++ /dev/null
@@ -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
diff --git a/src/Test/QuickCheck/Classes/Common.hs b/src/Test/QuickCheck/Classes/Common.hs
deleted file mode 100644
index c1ada55..0000000
--- a/src/Test/QuickCheck/Classes/Common.hs
+++ /dev/null
@@ -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 ]
diff --git a/src/Test/QuickCheck/Classes/Compat.hs b/src/Test/QuickCheck/Classes/Compat.hs
deleted file mode 100644
index 8d6bed3..0000000
--- a/src/Test/QuickCheck/Classes/Compat.hs
+++ /dev/null
@@ -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
-
diff --git a/src/Test/QuickCheck/Classes/Contravariant.hs b/src/Test/QuickCheck/Classes/Contravariant.hs
deleted file mode 100644
index faacacb..0000000
--- a/src/Test/QuickCheck/Classes/Contravariant.hs
+++ /dev/null
@@ -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
diff --git a/src/Test/QuickCheck/Classes/Enum.hs b/src/Test/QuickCheck/Classes/Enum.hs
deleted file mode 100644
index fabfc08..0000000
--- a/src/Test/QuickCheck/Classes/Enum.hs
+++ /dev/null
@@ -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)
-
diff --git a/src/Test/QuickCheck/Classes/Eq.hs b/src/Test/QuickCheck/Classes/Eq.hs
deleted file mode 100644
index 41059e5..0000000
--- a/src/Test/QuickCheck/Classes/Eq.hs
+++ /dev/null
@@ -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
diff --git a/src/Test/QuickCheck/Classes/Euclidean.hs b/src/Test/QuickCheck/Classes/Euclidean.hs
new file mode 100644
index 0000000..d4b34a8
--- /dev/null
+++ b/src/Test/QuickCheck/Classes/Euclidean.hs
@@ -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
diff --git a/src/Test/QuickCheck/Classes/Foldable.hs b/src/Test/QuickCheck/Classes/Foldable.hs
deleted file mode 100644
index 5e4ee5c..0000000
--- a/src/Test/QuickCheck/Classes/Foldable.hs
+++ /dev/null
@@ -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
diff --git a/src/Test/QuickCheck/Classes/Functor.hs b/src/Test/QuickCheck/Classes/Functor.hs
deleted file mode 100644
index 7e1f01e..0000000
--- a/src/Test/QuickCheck/Classes/Functor.hs
+++ /dev/null
@@ -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
-
diff --git a/src/Test/QuickCheck/Classes/Generic.hs b/src/Test/QuickCheck/Classes/Generic.hs
deleted file mode 100644
index 8d63484..0000000
--- a/src/Test/QuickCheck/Classes/Generic.hs
+++ /dev/null
@@ -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
diff --git a/src/Test/QuickCheck/Classes/Integral.hs b/src/Test/QuickCheck/Classes/Integral.hs
deleted file mode 100644
index 542e0a3..0000000
--- a/src/Test/QuickCheck/Classes/Integral.hs
+++ /dev/null
@@ -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)
diff --git a/src/Test/QuickCheck/Classes/IsList.hs b/src/Test/QuickCheck/Classes/IsList.hs
index 7474230..dd18cec 100644
--- a/src/Test/QuickCheck/Classes/IsList.hs
+++ b/src/Test/QuickCheck/Classes/IsList.hs
@@ -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
diff --git a/src/Test/QuickCheck/Classes/Ix.hs b/src/Test/QuickCheck/Classes/Ix.hs
deleted file mode 100644
index 6b06019..0000000
--- a/src/Test/QuickCheck/Classes/Ix.hs
+++ /dev/null
@@ -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))
-
-
diff --git a/src/Test/QuickCheck/Classes/Json.hs b/src/Test/QuickCheck/Classes/Json.hs
index 86769b1..8930f68 100644
--- a/src/Test/QuickCheck/Classes/Json.hs
+++ b/src/Test/QuickCheck/Classes/Json.hs
@@ -19,7 +19,7 @@ import Data.Aeson (FromJSON(..), ToJSON(..))
import qualified Data.Aeson as AE
#endif
-import Test.QuickCheck.Classes.Common (Laws(..))
+import Test.QuickCheck.Classes.Internal (Laws(..))
-- | Tests the following properties:
--
diff --git a/src/Test/QuickCheck/Classes/MVector.hs b/src/Test/QuickCheck/Classes/MVector.hs
index e1d9569..1273b38 100644
--- a/src/Test/QuickCheck/Classes/MVector.hs
+++ b/src/Test/QuickCheck/Classes/MVector.hs
@@ -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 qualified Data.Vector.Unboxed.Mutable as MU
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
diff --git a/src/Test/QuickCheck/Classes/Monad.hs b/src/Test/QuickCheck/Classes/Monad.hs
deleted file mode 100644
index 4505636..0000000
--- a/src/Test/QuickCheck/Classes/Monad.hs
+++ /dev/null
@@ -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
diff --git a/src/Test/QuickCheck/Classes/MonadFail.hs b/src/Test/QuickCheck/Classes/MonadFail.hs
deleted file mode 100644
index 6cc246e..0000000
--- a/src/Test/QuickCheck/Classes/MonadFail.hs
+++ /dev/null
@@ -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
diff --git a/src/Test/QuickCheck/Classes/MonadPlus.hs b/src/Test/QuickCheck/Classes/MonadPlus.hs
deleted file mode 100644
index e7059e4..0000000
--- a/src/Test/QuickCheck/Classes/MonadPlus.hs
+++ /dev/null
@@ -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
diff --git a/src/Test/QuickCheck/Classes/MonadZip.hs b/src/Test/QuickCheck/Classes/MonadZip.hs
deleted file mode 100644
index 434249f..0000000
--- a/src/Test/QuickCheck/Classes/MonadZip.hs
+++ /dev/null
@@ -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
diff --git a/src/Test/QuickCheck/Classes/Monoid.hs b/src/Test/QuickCheck/Classes/Monoid.hs
deleted file mode 100644
index 645e6e2..0000000
--- a/src/Test/QuickCheck/Classes/Monoid.hs
+++ /dev/null
@@ -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)
diff --git a/src/Test/QuickCheck/Classes/Num.hs b/src/Test/QuickCheck/Classes/Num.hs
deleted file mode 100644
index 1ee4ced..0000000
--- a/src/Test/QuickCheck/Classes/Num.hs
+++ /dev/null
@@ -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)
diff --git a/src/Test/QuickCheck/Classes/Ord.hs b/src/Test/QuickCheck/Classes/Ord.hs
deleted file mode 100644
index 96a156b..0000000
--- a/src/Test/QuickCheck/Classes/Ord.hs
+++ /dev/null
@@ -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
diff --git a/src/Test/QuickCheck/Classes/Plus.hs b/src/Test/QuickCheck/Classes/Plus.hs
index 5c3df8f..7cf9481 100644
--- a/src/Test/QuickCheck/Classes/Plus.hs
+++ b/src/Test/QuickCheck/Classes/Plus.hs
@@ -28,8 +28,7 @@ import Data.Functor.Classes (Eq1,Show1)
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:
--
diff --git a/src/Test/QuickCheck/Classes/Prim.hs b/src/Test/QuickCheck/Classes/Prim.hs
index 8cf0f18..e05e065 100644
--- a/src/Test/QuickCheck/Classes/Prim.hs
+++ b/src/Test/QuickCheck/Classes/Prim.hs
@@ -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.Primitive (PrimMonad, PrimState,primitive,primitive_)
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 Test.QuickCheck.Property (Property)
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
diff --git a/src/Test/QuickCheck/Classes/Ring.hs b/src/Test/QuickCheck/Classes/Ring.hs
index 94f6de8..55e4017 100644
--- a/src/Test/QuickCheck/Classes/Ring.hs
+++ b/src/Test/QuickCheck/Classes/Ring.hs
@@ -19,7 +19,7 @@ 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:
diff --git a/src/Test/QuickCheck/Classes/Semigroup.hs b/src/Test/QuickCheck/Classes/Semigroup.hs
deleted file mode 100644
index 9e534e8..0000000
--- a/src/Test/QuickCheck/Classes/Semigroup.hs
+++ /dev/null
@@ -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)
diff --git a/src/Test/QuickCheck/Classes/Semigroupoid.hs b/src/Test/QuickCheck/Classes/Semigroupoid.hs
index 2ce7cf5..1580e0a 100644
--- a/src/Test/QuickCheck/Classes/Semigroupoid.hs
+++ b/src/Test/QuickCheck/Classes/Semigroupoid.hs
@@ -22,8 +22,7 @@ import Test.QuickCheck hiding ((.&.))
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:
--
diff --git a/src/Test/QuickCheck/Classes/Semiring.hs b/src/Test/QuickCheck/Classes/Semiring.hs
index b0944f1..5604f5b 100644
--- a/src/Test/QuickCheck/Classes/Semiring.hs
+++ b/src/Test/QuickCheck/Classes/Semiring.hs
@@ -4,7 +4,7 @@
{-# OPTIONS_GHC -Wall #-}
module Test.QuickCheck.Classes.Semiring
- (
+ (
#if HAVE_SEMIRINGS
semiringLaws
#endif
@@ -13,13 +13,14 @@ module Test.QuickCheck.Classes.Semiring
#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 @@ import Test.QuickCheck.Classes.Common (Laws(..), myForAllShrink)
-- @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 @@ semiringLaws p = Laws "Semiring"
, ("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
@@ -138,4 +154,38 @@ semiringAssociativeTimes _ = myForAllShrink True (const True)
"(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
diff --git a/src/Test/QuickCheck/Classes/Show.hs b/src/Test/QuickCheck/Classes/Show.hs
deleted file mode 100644
index 789baca..0000000
--- a/src/Test/QuickCheck/Classes/Show.hs
+++ /dev/null
@@ -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)
diff --git a/src/Test/QuickCheck/Classes/ShowRead.hs b/src/Test/QuickCheck/Classes/ShowRead.hs
deleted file mode 100644
index 0ee3ce9..0000000
--- a/src/Test/QuickCheck/Classes/ShowRead.hs
+++ /dev/null
@@ -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 "")
-
diff --git a/src/Test/QuickCheck/Classes/Storable.hs b/src/Test/QuickCheck/Classes/Storable.hs
deleted file mode 100644
index e31f182..0000000
--- a/src/Test/QuickCheck/Classes/Storable.hs
+++ /dev/null
@@ -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
diff --git a/src/Test/QuickCheck/Classes/Traversable.hs b/src/Test/QuickCheck/Classes/Traversable.hs
deleted file mode 100644
index 0b1bffd..0000000
--- a/src/Test/QuickCheck/Classes/Traversable.hs
+++ /dev/null
@@ -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