packages feed

quickcheck-classes 0.3.1 → 0.6.5.0

raw patch · 19 files changed

Files

README.md view
@@ -1,1 +1,94 @@ # quickcheck-classes++This library provides sets of properties that should hold for common typeclasses,+along with three (3) simple functions that you can use to test them.++### `lawsCheck`:++A convenience function for testing properties in GHCi.+For example, at GHCi:++```bash+>>> 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.++### `lawsCheckMany`:++A convenience function for checking multiple typeclass instances+of multiple types. Consider the following Haskell source file:++```haskell+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:++```bash+>>> 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.++```++### `lawsCheckOne`++A convenience function that allows one to check many typeclass+instances of the same type.++For example, in GHCi:++```bash+>>> lawsCheckOne (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.+```
− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ changelog.md view
@@ -0,0 +1,228 @@+# Changelog+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/).++Note that since `quickcheck-classes` reexports larges parts of+`quickcheck-classes-base`, changelog entries that deal with any of the+classes from `base` are duplicated across the two changelogs.++## [0.6.5.0] - 2021-04-12+### Added+- Laws for `abs` and `signum`+- Storable Set-Set Law (resolves issue 101).+- Add laws for `quotRem` and `divMod`.+- Use non-commutative monoid for bifoldable tests (resolves issue 98)+- `substitutiveEqLaws`, which tests for Eq substitutivity.+- Negation law check for `Eq`.+- Document that users can provide their own `Laws`.++## [0.6.4.0] - 2019-09-13+### Changed+- Use newer semirings++## [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`+- `bitraversableLaws`++## [0.6.2.1] - 2019-05-23+### Fixed+- Removal of BadList test that was causing the test suite to fail++## [0.6.2.0] - 2019-05-23+### Added+- `ixLaws`+- `contravariantLaws`+- `semigroupMonoidLaws`+### Changed+- extend `mvectorLaws`+- extend `applyLaws` to include associativity+### Fixed+- bug in `foldableLaws` which could fail to catch implementations of `foldMap` or `fold`+  that evaluate in the wrong order++## [0.6.1.0] - 2019-01-12+### Change+- `genericLaws` and `generic1Laws` were not exported. Now they are.+### Added+- Add `muvectorLaws`.++## [0.6.0.0] - 2018-12-24+### 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+  package versions.+- Fix compiling the test suite without semigroupoids and compiling with old+  versions of transformers.+- Add lower bound for semigroups to make sure the `stimes` method is available.+- The laws `commutativeSemigroupLaws` and `commutativeMonoidLaws` no longer+  check any property other than commutativity. They must now be used in conjunction+  with, rather than in place of, `semigroupLaws` and `monoidLaws`. This is a breaking+  change.+- Fix the right distribution law for semirings.+- The function `lawsCheckMany` now terminates with exit code 1 if a+  test fails.+- Extend `showReadLaws` with new properties for `showsPrec`, `readsPrec`,+  `showList` and `readList`.+- Prettify JSON partial isomorphism test failure.+### Added+- Add `genericLaws` and `generic1Laws`+- Add property tests for special classes of semigroups. This includes:+  commutative, idempotent, rectangular band, and exponential.+- `bifoldableLaws`, `bifoldableFunctorLaws`+- Add `showLaws`.++## [0.5.0.0] - 2018-09-25+### Change+- When compiling with GHC 8.6 and newer, use `QuantifiedConstraints` instead+  of `Eq1`, `Show1`, `Arbitrary1`, `Eq2`, `Show`, and `Arbitrary2`.++## [0.4.14.3] - 2018-09-21+### Change+- Fix a CPP conditional import problem that caused build failures on GHC 7.10+- Set an explicit lower bound for containers++## [0.4.14.2] - 2018-09-12+### Change+- Support QuickCheck-2.12+- Fix compilation for containers<0.5.9+- Fix compilation with QuickCheck-2.9++## [0.4.14.1] - 2018-07-24+### Change+- Build correctly when dependency on semigroupoids is disabled.++## [0.4.14] - 2018-07-23+### Added+- commutativeSemigroupLaws+- the following typeclasses:+    `Data.Semigroupoid.Semigroupoid` (semigroupoids)+    `Data.Functor.Plus.Plus` (semigroupoids)++### Change+- semiringLaws were never exported, we now export them.+- make documentation for `MonadPlus` and `Alternative` consistent.+- bump semirings to 0.2.0.0+- deprecate `Test.QuickCheck.Classes.specialisedLawsCheckMany`+  in favour of `Test.QuickCheck.Classes.lawsCheckOne`++## [0.4.13] - 2018-07-18+### Added+- Laws for `Enum` typeclass.+- Laws for `Category` typeclass.++## [0.4.12] - 2018-06-07+### Added+- Remaining laws for `Storable` typeclass.+- Laws for `Prim` typeclass requiring `setByteArray` and `setOffAddr` to+  match the behavior that would result from manually iterating over the+  array and writing the value element-by-element.+### Change+- Correct the law from the `Bits` typeclass that relates `clearBit`+  and `zeroBits`.+- Limit the size of the lists that are used when testing that+  `mconcat` and `sconcat` have behaviors that match their default+  implementations. For some data structures, concatenating the+  elements in a list of several dozen arbitrary values does not+  finish in a reasonable amount of time. So, the size of these+  has been limited to 6.+- Make library build against `primitive-0.6.1.0`.++## [0.4.11.1] - 2018-05-25+### Change+- Fix compatibility with older GHCs when `semigroupoids` support+  is disabled.++## [0.4.11] - 2018-05-24+### Added+- Greatly improved documentation+- `specialisedLawsCheckMany` function, a shorter way for the user+  to use `lawsCheckMany` on a single type.++### Change+- Some internal names, making it more clear what it is that they do.++## [0.4.10] - 2018-05-03+### Added+- Property tests for `mconcat`, `sconcat`, and `stimes`. It isn't+  common to override the defaults for these, but when you do, it's+  nice to check that they agree with what they are supposed to do.++## [0.4.9] - 2018-04-06+### Change+- Be more careful with import of `Data.Primitive`. There is a+  branch of `primitive` that adds `PrimArray`. The implementation+  of `PrimArray` in this library should eventually be removed, but+  for now it will be sufficient to ensure that it does not create+  a conflicting import problem with the one in the branch.++## [0.4.8] - 2018-03-29+### Change+- Fix compilation regression for older versions of transformers.++## [0.4.7] - 2018-03-29+### Change+- Split up monolithic module into hidden internal modules.+- Fix compilation regression for older GHCs.++## [0.4.6] - 2018-03-29+### Added+- Property test the naturality law for `MonadZip`. There is another law+  that instances should satisfy (the Information Preservation law), but+  it's more difficult to write a test for. It has been omitted for now.+- Property tests for all `MonadPlus` laws.+- Several additional property tests for list-like containers: mapMaybe,+  replicate, filter.++## [0.4.5] - 2018-03-26+### Added+- Property tests for list-like containers that have `IsList` instances.+  These are useful for things that are nearly `Foldable` or nearly `Traversable`+  but are either constrained in their element type or totally monomorphic+  in it.++## [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+  test suite.++## [0.4.3] - 2018-03-23+### Added+- Property tests for `foldl1` and `foldr1`.+- Property tests for `Traversable`.++## [0.4.2] - 2018-03-22+### Changed+- Made compatible with `transformers-0.3`. Tests for higher-kinded+  typeclasses are unavailable when built with a sufficiently old+  version of both `transformers` and `base`. This is because `Eq1`+  and `Show1` are unavailable in this situation.++## [0.4.1] - 2018-03-21+### Changed+- Made compatible with `transformers-0.4`.++## [0.4.0] - 2018-03-20+### Added+- Property tests for `Bifunctor` and `Alternative`.+### Changed+- Made compatible with older GHCs all the way back to 7.8.4.+- Lower dependency footprint. Eliminate the dependency on `prim-array`+  and inline the relevant functions and types from it into+  `Test.QuickCheck.Classes`. None of these are exported.
quickcheck-classes.cabal view
@@ -1,51 +1,197 @@+cabal-version: 2.4 name: quickcheck-classes-version: 0.3.1+version: 0.6.5.0 synopsis: QuickCheck common typeclasses description:-  This library provides quickcheck properties to-  ensure that typeclass instances the set of laws that they are-  supposed to. There are other libraries that do similar-  things, such as `genvalidity-hspec` and `checkers`. This-  library differs from other solutions by not introducing-  any new typeclasses that the user needs to learn. The source-  code for this library should be easy to understand if you-  are already familiar with quickcheck. Open an issue-  if you feel that this is not the case.+  This library provides QuickCheck properties to ensure+  that typeclass instances adhere to the set of laws that+  they are supposed to. There are other libraries that do+  similar things, such as `genvalidity-hspec` and `checkers`.+  This library differs from other solutions by not introducing+  any new typeclasses that the user needs to learn.+  .+  /Note:/ on GHC < 8.5, this library uses the higher-kinded typeclasses+  ('Data.Functor.Classes.Show1', 'Data.Functor.Classes.Eq1', 'Data.Functor.Classes.Ord1', etc.),+  but on GHC >= 8.5, it uses `-XQuantifiedConstraints` to express these+  constraints more cleanly. homepage: https://github.com/andrewthad/quickcheck-classes#readme-license: BSD3+license: BSD-3-Clause license-file: LICENSE-author: Andrew Martin+author: Andrew Martin, chessai maintainer: andrew.thaddeus@gmail.com-copyright: 2017 Andrew Martin+copyright: 2018 Andrew Martin category: Testing build-type: Simple extra-source-files: README.md-cabal-version: >=1.10+extra-source-files: changelog.md +flag aeson+  description:+    You can disable the use of the `aeson` package using `-f-aeson`.+    .+    This may be useful for accelerating builds in sandboxes for expert users.+  default: True+  manual: True++flag semigroupoids+  description:+    You can disable the use of the `semigroupoids` package using `-f-semigroupoids`.+    .+    This may be useful for accelerating builds in sandboxes for expert users.+  default: True+  manual: True++flag semirings+  description:+    You can disable the use of the `semirings` package using `-f-semirings`.+    .+    This may be useful for accelerating builds in sandboxes for expert users.+  default: True+  manual: True++flag vector+  description:+    You can disable the use of the `vector` package using `-f-vector`.+    .+    This may be useful for accelerating builds in sandboxes for expert users.+  default: True+  manual: True++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.+    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+ library+  default-language: Haskell2010   hs-source-dirs: src   exposed-modules:     Test.QuickCheck.Classes+    Test.QuickCheck.Classes.IsList+  other-modules:+    Test.QuickCheck.Classes.Alt+    Test.QuickCheck.Classes.Apply+    Test.QuickCheck.Classes.Euclidean+    Test.QuickCheck.Classes.Json+    Test.QuickCheck.Classes.MVector+    Test.QuickCheck.Classes.Plus+    Test.QuickCheck.Classes.Prim+    Test.QuickCheck.Classes.Semigroupoid+    Test.QuickCheck.Classes.Semiring+    Test.QuickCheck.Classes.Ring   build-depends:-      base >= 4.7 && < 5+    , base >= 4.5 && < 5+    , QuickCheck >= 2.7+    , transformers >= 0.3 && < 0.6+    , primitive >= 0.6.4 && < 0.8+    , primitive-addr >= 0.1.0.2 && < 0.2+    , containers >= 0.4.2.1+    , quickcheck-classes-base >=0.6.2 && <0.7+  if impl(ghc < 8.0)+    build-depends:+      , semigroups >= 0.17+      , fail+  if impl(ghc < 7.8)+    build-depends: tagged+  if impl(ghc > 7.4) && impl(ghc < 7.6)+    build-depends: ghc-prim+  if impl(ghc > 8.5)+    cpp-options: -DHAVE_QUANTIFIED_CONSTRAINTS+  if flag(unary-laws)+    build-depends:+      , transformers >= 0.4.0+      , QuickCheck >= 2.10.0+    cpp-options: -DHAVE_UNARY_LAWS+  if flag(binary-laws)+    build-depends:+      , transformers >= 0.5.0+      , QuickCheck >= 2.10.0+    cpp-options: -DHAVE_BINARY_LAWS+  if flag(aeson)+    build-depends: aeson >= 0.9+    cpp-options: -DHAVE_AESON+  if flag(semigroupoids)+    build-depends: semigroupoids+    cpp-options: -DHAVE_SEMIGROUPOIDS+  if flag(semirings)+    build-depends: semirings >= 0.4.2+    cpp-options: -DHAVE_SEMIRINGS+  if flag(vector)+    build-depends: vector >= 0.12+    cpp-options: -DHAVE_VECTOR++-- The basic test suite is compatible with all the versions of GHC that+-- this library supports. It is useful for confirming whether the laws tests+-- behave correct. Additionally, it helps catch CPP mistakes.+test-suite basic+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Spec.hs+  other-modules:+    Spec.ShowRead+  build-depends:+    , base+    , base-orphans >= 0.5+    , quickcheck-classes     , QuickCheck-    , transformers+    , containers     , primitive-    , prim-array-    , aeson+    , vector+    , transformers+    , tagged+  if impl(ghc > 8.5)+    cpp-options: -DHAVE_QUANTIFIED_CONSTRAINTS+  if flag(unary-laws)+    cpp-options: -DHAVE_UNARY_LAWS+  if flag(binary-laws)+    cpp-options: -DHAVE_BINARY_LAWS+  if flag(aeson)+    build-depends: aeson+    cpp-options: -DHAVE_AESON+  if flag(semigroupoids)+    build-depends: semigroupoids+    cpp-options: -DHAVE_SEMIGROUPOIDS+  if flag(vector)+    build-depends: vector >= 0.12+    cpp-options: -DHAVE_VECTOR   default-language: Haskell2010 -test-suite test+-- The advanced test suite only builds with the newest version+-- of GHC. It is intended to be a sort of regression test for GHC and for+-- base. It check instances for a number of types in base. It also checks+-- a bunch of derived instances for data types of varying sizes. And it+-- does some tests on UnboxedSums.+test-suite advanced   type: exitcode-stdio-1.0   hs-source-dirs: test-  main-is: Spec.hs+  main-is: Advanced.hs+  ghc-options: -O2   build-depends:-      base-    , quickcheck-classes     , QuickCheck+    , base >= 4.12+    , base-orphans >= 0.5+    , containers     , primitive-    , aeson+    , quickcheck-classes+    , tagged+    , tasty+    , tasty-quickcheck+    , transformers     , vector+  if impl(ghc < 8.6)+    buildable: False   default-language: Haskell2010  source-repository head
src/Test/QuickCheck/Classes.hs view
@@ -1,871 +1,140 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE KindSignatures #-}  {-# OPTIONS_GHC -Wall #-} -{-|--This library provides lists of properties that should hold for common typeclasses.-All of these take a 'Proxy' argument that is used to nail down the type for which-the typeclass dictionaries should be tested. 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. We can check multiple typeclasses with:-->>> foldMap (lawsCheck . ($ (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.+{-| This library provides sets of properties that should hold for common+    typeclasses. +    /Note:/ on GHC < 8.6, this library uses the higher-kinded typeclasses+    ('Data.Functor.Classes.Show1', 'Data.Functor.Classes.Eq1', 'Data.Functor.Classes.Ord1', etc.),+    but on GHC >= 8.6, it uses @-XQuantifiedConstraints@ to express these+    constraints more cleanly. -} module Test.QuickCheck.Classes   ( -- * Running-    lawsCheck-  , lawsCheckMany+    QCB.lawsCheck+  , QCB.lawsCheckMany+  , QCB.lawsCheckOne     -- * Properties-    -- ** Ground Types-  , semigroupLaws-  , monoidLaws-  , commutativeMonoidLaws-  , eqLaws-  , ordLaws-  , showReadLaws+    -- ** Ground types+#if MIN_VERSION_base(4,7,0)+  , QCB.bitsLaws+#endif+  , QCB.eqLaws+  , QCB.substitutiveEqLaws+  , QCB.numLaws+  , QCB.integralLaws+  , QCB.ixLaws+#if MIN_VERSION_base(4,7,0)+  , QCB.isListLaws+#endif+#if HAVE_AESON   , jsonLaws-  , isListLaws+#endif+  , QCB.monoidLaws+  , QCB.commutativeMonoidLaws+  , QCB.semigroupMonoidLaws+  , QCB.ordLaws+  , QCB.enumLaws+  , QCB.boundedEnumLaws   , primLaws-  , storableLaws-#if MIN_VERSION_QuickCheck(2,10,0)-    -- ** Higher-Kinded Types-  , functorLaws-  , applicativeLaws-  , monadLaws-  , foldableLaws+  , QCB.semigroupLaws+  , QCB.commutativeSemigroupLaws+  , QCB.exponentialSemigroupLaws+  , QCB.idempotentSemigroupLaws+  , QCB.rectangularBandSemigroupLaws+#if HAVE_SEMIRINGS+  , semiringLaws+  , ringLaws+  , gcdDomainLaws+  , euclideanLaws #endif+  , QCB.showLaws+  , QCB.showReadLaws+  , QCB.storableLaws+#if MIN_VERSION_base(4,5,0)+  , QCB.genericLaws+  , QCB.generic1Laws+#endif+#if HAVE_UNARY_LAWS+    -- ** Unary type constructors+  , QCB.alternativeLaws+#if HAVE_SEMIGROUPOIDS+  , altLaws+  , applyLaws+#endif+  , QCB.applicativeLaws+  , QCB.contravariantLaws+  , QCB.foldableLaws+  , QCB.functorLaws+  , QCB.monadLaws+  , QCB.monadPlusLaws+  , QCB.monadZipLaws+#if HAVE_SEMIGROUPOIDS+  , plusLaws+  , extendedPlusLaws+#endif+  , QCB.traversableLaws+#endif+#if HAVE_BINARY_LAWS+    -- ** Binary type constructors+  , QCB.bifoldableLaws+  , QCB.bifunctorLaws+  , QCB.bitraversableLaws+  , QCB.categoryLaws+  , QCB.commutativeCategoryLaws+#if HAVE_SEMIGROUPOIDS+  , semigroupoidLaws+  , commutativeSemigroupoidLaws+#endif+#if HAVE_VECTOR+  , muvectorLaws+#endif+#endif     -- * Types-  , Laws(..)+  , QCB.Laws(..)+  , QCB.Proxy1(..)+  , QCB.Proxy2(..)   ) where -import Test.QuickCheck-import Test.QuickCheck.Monadic (monadicIO)-import Test.QuickCheck.Property (Property(..))-import Data.Primitive hiding (sizeOf,newArray,copyArray)-import Data.Primitive.PrimArray-import Data.Proxy-import Control.Monad.ST-import Control.Monad-import Data.Monoid (Endo(..),Sum(..),Dual(..))-import GHC.Ptr (Ptr(..))-import Data.Primitive.Addr (Addr(..))-import Foreign.Marshal.Alloc-import System.IO.Unsafe-import Data.Semigroup (Semigroup)-import GHC.Exts (IsList(fromList,toList,fromListN),Item)-import Foreign.Marshal.Array-import Foreign.Storable-import Text.Read (readMaybe)-import Data.Aeson (FromJSON(..),ToJSON(..))-import Data.Functor.Classes-import Control.Applicative-import Data.Foldable (foldlM,fold,foldMap,foldl',foldr')-import Control.Exception (ErrorCall,evaluate,try)-import Control.Monad.Trans.Class (lift)-import qualified Data.Foldable as F-import qualified Data.Aeson as AE-import qualified Data.Primitive as P-import qualified Data.Semigroup as SG-import qualified GHC.OldList as L--#if MIN_VERSION_QuickCheck(2,10,0)-import Test.QuickCheck.Arbitrary (Arbitrary1(..))-#endif---- | 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-  }---- | A convenience function for working testing properties in GHCi.---   See the test suite of this library for an example of how to---   integrate multiple properties into larger test suite.-lawsCheck :: Laws -> IO ()-lawsCheck (Laws className properties) = do-  flip foldlMapM properties $ \(name,p) -> do-    putStr (className ++ ": " ++ name ++ " ")-    quickCheck p---- | A convenience function for checking multiple typeclass instances---   of multiple types.-lawsCheckMany ::-     [(String,[Laws])] -- ^ Element is type name paired with typeclass laws-  -> IO ()-lawsCheckMany xs = do-  putStrLn "Testing properties for common typeclasses"-  r <- flip foldlMapM xs $ \(typeName,laws) -> do-    putStrLn $ "------------"-    putStrLn $ "-- " ++ typeName-    putStrLn $ "------------"-    flip foldlMapM laws $ \(Laws typeClassName properties) -> do-      flip foldlMapM 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 -> putStrLn "One or more tests failed"--data Status = Bad | Good--instance Monoid Status where-  mempty = Good-  mappend Good x = x-  mappend Bad _ = Bad--foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b-foldlMapM f = foldlM (\b a -> fmap (mappend b) (f a)) mempty--jsonLaws :: (ToJSON a, FromJSON a, Show a, Arbitrary a, Eq a) => Proxy a -> Laws-jsonLaws p = Laws "ToJSON/FromJSON"-  [ ("Encoding Equals Value", jsonEncodingEqualsValue p)-  , ("Partial Isomorphism", jsonEncodingPartialIsomorphism p)-  ]---- | Tests the following properties: ----- [/Partial Isomorphism/]---   @fromList . toList ≡ id@--- [/Length Preservation/]---   @fromList xs ≡ fromListN (length xs) xs@-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)-  ]--showReadLaws :: (Show a, Read a, Eq a, Arbitrary a) => Proxy a -> Laws-showReadLaws p = Laws "Show/Read"-  [ ("Partial Isomorphism", showReadPartialIsomorphism p)-  ]---- | Tests the following properties:+-- re-exports ----- [/Associative/]---   @a <> (b <> c) ≡ (a <> b) <> c@-semigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws-semigroupLaws p = Laws "Semigroup"-  [ ("Associative", semigroupAssociative p)-  ] --- | 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)-  ]---- | Tests the following properties:------ [/Transitive/]---   @a ≤ b ∧ b ≤ c ⇒ a ≤ c@--- [/Comparable/]---   @a ≤ b ∨ a > b@-ordLaws :: (Ord a, Arbitrary a, Show a) => Proxy a -> Laws-ordLaws p = Laws "Ord"-  [ ("Transitive", ordTransitive p)-  , ("Comparable", ordComparable p)-  ]---- | 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@-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)-  ]---- | Tests everything from 'monoidProps' plus the following:------ [/Commutative/]---   @mappend a b ≡ mappend b a@-commutativeMonoidLaws :: (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws-commutativeMonoidLaws p = Laws "Commutative Monoid" $ lawsProperties (monoidLaws p) ++-  [ ("Commutative", monoidCommutative p)-  ]---- | Test that a 'Prim' instance obey the several laws.-primLaws :: (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws-primLaws p = Laws "Prim"-  [ ("ByteArray Set-Get (you get back what you put in)", primSetGetByteArray p)-  , ("ByteArray Get-Set (putting back what you got out has no effect)", primGetSetByteArray p)-  , ("ByteArray Set-Set (setting twice is same as setting once)", primSetSetByteArray p)-  , ("ByteArray List Conversion Roundtrips", primListByteArray p)-  , ("Addr Set-Get (you get back what you put in)", primSetGetAddr p)-  , ("Addr Get-Set (putting back what you got out has no effect)", primGetSetAddr p)-  , ("Addr List Conversion Roundtrips", primListAddr p)-  ]--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)-  ]--isListPartialIsomorphism :: forall a. (IsList a, Show a, Arbitrary a, Eq a) => Proxy a -> Property-isListPartialIsomorphism _ = myForAllShrink False-  (\(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--showReadPartialIsomorphism :: forall a. (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property-showReadPartialIsomorphism _ = property $ \(a :: a) ->-  readMaybe (show a) == Just a---- TODO: improve the quality of the error message if--- something does not pass this test.-jsonEncodingEqualsValue :: forall a. (ToJSON a, Show a, Arbitrary a) => Proxy a -> Property-jsonEncodingEqualsValue _ = property $ \(a :: a) ->-  case AE.decode (AE.encode a) of-    Nothing -> False-    Just (v :: AE.Value) -> v == toJSON a--jsonEncodingPartialIsomorphism :: forall a. (ToJSON a, FromJSON a, Show a, Eq a, Arbitrary a) => Proxy a -> Property-jsonEncodingPartialIsomorphism _ = property $ \(a :: a) ->-  AE.decode (AE.encode a) == Just a--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---- 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--ordComparable :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property-ordComparable _ = property $ \(a :: a) b -> a > b || b >= a--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--semigroupAssociative :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-semigroupAssociative _ = property $ \(a :: a) b c -> a SG.<> (b SG.<> c) == (a SG.<> b) SG.<> c--monoidAssociative :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-monoidAssociative _ = myForAllShrink 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-  (\(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-  (\(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 _ = property $ \(a :: a) b -> mappend a b == mappend b a--primListByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-primListByteArray _ = property $ \(as :: [a]) ->-  as == toList (fromList as :: PrimArray a)--primListAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-primListAddr _ = property $ \(as :: [a]) -> unsafePerformIO $ do-  let len = L.length as-  ptr@(Ptr addr#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))-  let addr = Addr addr#-  let go :: Int -> [a] -> IO ()-      go !ix xs = case xs of-        [] -> return ()-        (x : xsNext) -> do-          writeOffAddr addr ix x-          go (ix + 1) xsNext-  go 0 as-  let rebuild :: Int -> IO [a]-      rebuild !ix = if ix < len-        then (:) <$> readOffAddr addr ix <*> rebuild (ix + 1)-        else return []-  asNew <- rebuild 0-  free ptr-  return (as == asNew)--primSetGetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-primSetGetByteArray _ = property $ \(a :: a) len -> (len > 0) ==> do-  ix <- choose (0,len - 1)-  return $ runST $ do-    arr <- newPrimArray len-    writePrimArray arr ix a-    a' <- readPrimArray arr ix-    return (a == a')--primGetSetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-primGetSetByteArray _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do-  let arr1 = fromList as :: PrimArray a-      len = L.length as-  ix <- choose (0,len - 1)-  arr2 <- return $ runST $ do-    marr <- newPrimArray len-    copyPrimArray marr 0 arr1 0 len-    a <- readPrimArray marr ix-    writePrimArray marr ix a-    unsafeFreezePrimArray marr-  return (arr1 == arr2)--primSetSetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-primSetSetByteArray _ = property $ \(a :: a) (as :: [a]) -> (not (L.null as)) ==> do-  let arr1 = fromList as :: PrimArray a-      len = L.length as-  ix <- choose (0,len - 1)-  (arr2,arr3) <- return $ runST $ do-    marr2 <- newPrimArray len-    copyPrimArray marr2 0 arr1 0 len-    writePrimArray marr2 ix a-    marr3 <- newPrimArray len-    copyMutablePrimArray marr3 0 marr2 0 len-    arr2 <- unsafeFreezePrimArray marr2-    writePrimArray marr3 ix a-    arr3 <- unsafeFreezePrimArray marr3-    return (arr2,arr3)-  return (arr2 == arr3)--primSetGetAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-primSetGetAddr _ = property $ \(a :: a) len -> (len > 0) ==> do-  ix <- choose (0,len - 1)-  return $ unsafePerformIO $ do-    ptr@(Ptr addr#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))-    let addr = Addr addr#-    writeOffAddr addr ix a-    a' <- readOffAddr addr ix-    free ptr-    return (a == a')--primGetSetAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-primGetSetAddr _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do-  let arr1 = fromList as :: PrimArray a-      len = L.length as-  ix <- choose (0,len - 1)-  arr2 <- return $ unsafePerformIO $ do-    ptr@(Ptr addr#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))-    let addr = Addr addr#-    copyPrimArrayToPtr ptr arr1 0 len-    a :: a <- readOffAddr addr ix-    writeOffAddr addr ix a-    marr <- newPrimArray len-    copyPtrToMutablePrimArray marr 0 ptr len-    free ptr-    unsafeFreezePrimArray marr-  return (arr1 == arr2)--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 <- mallocArray 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 <- mallocArray 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--#if MIN_VERSION_QuickCheck(2,10,0)--- | Tests the following applicative properties:------ [/Identity/]---   @'fmap' 'id' ≡ 'id'@--- [/Composition/]---   @fmap (f . g) ≡ 'fmap' f . 'fmap' g@--- [/Const/]---   @(<$) ≡ 'fmap' 'const'@-functorLaws :: (Functor f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Laws-functorLaws p = Laws "Functor"-  [ ("Identity", functorIdentity p)-  , ("Composition", functorComposition p)-  , ("Const", functorConst p)-  ]---- | 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 :: (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => 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-  ]----- | 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 :: (Monad f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Laws-monadLaws p = Laws "Monad"-  [ ("Left Identity", monadLeftIdentity p)-  , ("Right Identity", monadRightIdentity p)-  , ("Associativity", monadAssociativity p)-  , ("Return", monadReturn p)-  , ("Ap", monadAp p)-  ]---- | 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@--- [/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@--- [/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 :: (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Laws-foldableLaws = foldableLawsInternal--foldableLawsInternal :: forall f. (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Laws-foldableLawsInternal p = Laws "Foldable"-  [ (,) "fold" $ property $ \(Apply (a :: f (Sum Integer))) ->-      fold a == foldMap id a-  , (,) "foldMap" $ property $ \(Apply (a :: f Integer)) (e :: Equation) ->-      let f = Sum . runEquation e-       in foldMap f a == foldr (mappend . f) mempty a-  , (,) "foldr" $ property $ \(e :: EquationTwo) (z :: Integer) (Apply (t :: f Integer)) ->-      let f = runEquationTwo e-       in foldr f z t == appEndo (foldMap (Endo . f) t) z-  , (,) "foldr'" (foldableFoldr' p)-  , (,) "foldl" $ property $ \(e :: EquationTwo) (z :: Integer) (Apply (t :: f Integer)) ->-      let f = runEquationTwo e-       in foldl f z t == appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z-  , (,) "foldl'" (foldableFoldl' p)-  , (,) "toList" $ property $ \(Apply (t :: f Integer)) ->-      eq1 (F.toList t) (foldr (:) [] t)-  , (,) "null" $ property $ \(Apply (t :: f Integer)) ->-      null t == foldr (const (const False)) True t-  , (,) "length" $ property $ \(Apply (t :: f Integer)) ->-      length t == getSum (foldMap (const (Sum 1)) t)-  ]--foldableFoldl' :: forall f. (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => 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 (foldr f' id xs z0))-      case e of-        Left (_ :: ErrorCall) -> return Nothing-        Right i -> return (Just i)-    r2 <- lift $ do-      e <- try (evaluate (foldl' f z0 xs))-      case e of-        Left (_ :: ErrorCall) -> return Nothing-        Right i -> return (Just i)-    return (r1 == r2)--foldableFoldr' :: forall f. (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => 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 (foldl f' id xs z0))-      case e of-        Left (_ :: ErrorCall) -> return Nothing-        Right i -> return (Just i)-    r2 <- lift $ do-      e <- try (evaluate (foldr' f z0 xs))-      case e of-        Left (_ :: ErrorCall) -> return Nothing-        Right i -> return (Just i)-    return (r1 == r2)--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--data Apply f a = Apply { getApply :: f a }--instance (Eq1 f, Eq a) => Eq (Apply f a) where-  Apply a == Apply b = eq1 a b--data LinearEquation = LinearEquation-  { _linearEquationLinear :: Integer-  , _linearEquationConstant :: Integer-  } deriving (Eq)--data LinearEquationM m = LinearEquationM (m LinearEquation) (m LinearEquation)--runLinearEquation :: Integer -> LinearEquation -> Integer-runLinearEquation x (LinearEquation a b) = a * x + b--runLinearEquationM :: Functor m => LinearEquationM m -> Integer -> m Integer-runLinearEquationM (LinearEquationM e1 e2) i = if odd i-  then fmap (runLinearEquation i) e1-  else fmap (runLinearEquation i) e2--instance Eq1 m => Eq (LinearEquationM m) where-  LinearEquationM a1 b1 == LinearEquationM a2 b2 = eq1 a1 a2 && eq1 b1 b2--showLinear :: Int -> LinearEquation -> ShowS-showLinear _ (LinearEquation a b) = shows a . showString " * x + " . shows b--showLinearList :: [LinearEquation] -> ShowS-showLinearList xs = appEndo $ mconcat-   $ [Endo (showChar '[')]-  ++ L.intersperse (Endo (showChar ',')) (map (Endo . showLinear 0) xs)-  ++ [Endo (showChar ']')]--instance Show1 m => Show (LinearEquationM m) where-  show (LinearEquationM a b) = (\f -> f "")-    $ showString "\\x -> if odd x then "-    . liftShowsPrec showLinear showLinearList 0 a-    . showString " else "-    . liftShowsPrec showLinear showLinearList 0 b--instance Arbitrary1 m => Arbitrary (LinearEquationM m) where-  arbitrary = liftA2 LinearEquationM arbitrary1 arbitrary1-  shrink (LinearEquationM a b) = concat-    [ map (\x -> LinearEquationM x b) (shrink1 a)-    , map (\x -> LinearEquationM a x) (shrink1 b)-    ]--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 Equation = Equation Integer Integer 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 Equation where-  show (Equation a b c) = "\\x -> " ++ show a ++ " * x ^ 2 + " ++ show b ++ " * x + " ++ show c--instance Arbitrary Equation where-  arbitrary = do-    (a,b,c) <- arbitrary-    return (Equation (abs a) (abs b) (abs c))-  shrink (Equation a b c) =-    let xs = shrink (a,b,c)-     in map (\(x,y,z) -> Equation (abs x) (abs y) (abs z)) xs--runEquation :: Equation -> Integer -> Integer-runEquation (Equation a b c) x = a * x ^ (2 :: Integer) + b * x + c---- linear equation of two variables-data EquationTwo = EquationTwo Integer Integer-  deriving (Eq)---- This show instance is does not actually provide a--- way to create an EquationTwo. Instead, it makes it look--- like a lambda that takes two variables.-instance Show EquationTwo where-  show (EquationTwo a b) = "\\x y -> " ++ show a ++ " * x + " ++ show b ++ " * y"--instance Arbitrary EquationTwo where-  arbitrary = do-    (a,b) <- arbitrary-    return (EquationTwo (abs a) (abs b))-  shrink (EquationTwo a b) =-    let xs = shrink (a,b)-     in map (\(x,y) -> EquationTwo (abs x) (abs y)) xs--runEquationTwo :: EquationTwo -> Integer -> Integer -> Integer-runEquationTwo (EquationTwo a b) x y = a * x + b * y---- 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--functorIdentity :: forall f. (Functor f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property-functorIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (fmap id a) a--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))--functorComposition :: forall f. (Functor f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property-functorComposition _ = property $ \(Apply (a :: f Integer)) ->-  eq1 (fmap func2 (fmap func1 a)) (fmap (func2 . func1) a)--functorConst :: forall f. (Functor f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property-functorConst _ = property $ \(Apply (a :: f Integer)) ->-  eq1 (fmap (const 'X') a) ('X' <$ a)--applicativeIdentity :: forall f. (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property-applicativeIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (pure id <*> a) a--applicativeComposition :: forall f. (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property-applicativeComposition _ = property $ \(Apply (u' :: f Equation)) (Apply (v' :: f Equation)) (Apply (w :: f Integer)) ->-  let u = fmap runEquation u'-      v = fmap runEquation v'-   in eq1 (pure (.) <*> u <*> v <*> w) (u <*> (v <*> w))--applicativeHomomorphism :: forall f. (Applicative f, Eq1 f, Show1 f) => Proxy f -> Property-applicativeHomomorphism _ = property $ \(e :: Equation) (a :: Integer) ->-  let f = runEquation e-   in eq1 (pure f <*> pure a) (pure (f a) :: f Integer)--applicativeInterchange :: forall f. (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property-applicativeInterchange _ = property $ \(Apply (u' :: f Equation)) (y :: Integer) ->-  let u = fmap runEquation u'-   in eq1 (u <*> pure y) (pure ($ y) <*> u)--applicativeLiftA2_1 :: forall f. (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property-applicativeLiftA2_1 _ = property $ \(Apply (f' :: f Equation)) (Apply (x :: f Integer)) -> -  let f = fmap runEquation f'-   in eq1 (liftA2 id f x) (f <*> x)--monadLeftIdentity :: forall f. (Monad f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property-monadLeftIdentity _ = property $ \(k' :: LinearEquationM f) (a :: Integer) -> -  let k = runLinearEquationM k'-   in eq1 (return a >>= k) (k a)--monadRightIdentity :: forall f. (Monad f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property-monadRightIdentity _ = property $ \(Apply (m :: f Integer)) -> -  eq1 (m >>= return) m--monadAssociativity :: forall f. (Monad f, Eq1 f, Show1 f, Arbitrary1 f) => 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 f. (Monad f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property-monadReturn _ = property $ \(x :: Integer) ->-  eq1 (return x) (pure x :: f Integer)--monadAp :: forall f. (Monad f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property-monadAp _ = property $ \(Apply (f' :: f Equation)) (Apply (x :: f Integer)) -> -  let f = fmap runEquation f'-   in eq1 (ap f x) (f <*> x)+-- Ground Types+#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.Prim+#if HAVE_SEMIRINGS+import Test.QuickCheck.Classes.Euclidean+import Test.QuickCheck.Classes.Semiring+import Test.QuickCheck.Classes.Ring+#endif+-- Unary type constructors+#if HAVE_UNARY_LAWS+#if HAVE_SEMIGROUPOIDS+import Test.QuickCheck.Classes.Alt+import Test.QuickCheck.Classes.Apply+#endif+#if HAVE_SEMIGROUPOIDS+import Test.QuickCheck.Classes.Plus+#endif+#endif +-- Binary type constructors+#if HAVE_BINARY_LAWS+#if HAVE_SEMIGROUPOIDS+import Test.QuickCheck.Classes.Semigroupoid #endif+#endif -myForAllShrink :: (Arbitrary a, Show b, Eq b) => Bool -> (a -> [String]) -> String -> (a -> b) -> String -> (a -> b) -> Property-myForAllShrink displayRhs showInputs name1 calc1 name2 calc2 =-  again $-  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 counterexample err (b1 == b2)+#if HAVE_VECTOR+import Test.QuickCheck.Classes.MVector+#endif +import qualified Test.QuickCheck.Classes.Base as QCB
+ src/Test/QuickCheck/Classes/Alt.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++#if HAVE_QUANTIFIED_CONSTRAINTS+{-# LANGUAGE QuantifiedConstraints #-}+#endif++{-# OPTIONS_GHC -Wall #-}++module Test.QuickCheck.Classes.Alt+  (+#if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS)+    altLaws+#endif+) where++#if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS)+import Data.Functor+import Data.Functor.Alt (Alt)+import qualified Data.Functor.Alt as Alt+import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Arbitrary (Arbitrary1(..))+import Data.Functor.Classes (Eq1,Show1)+import Test.QuickCheck.Property (Property)++import Test.QuickCheck.Classes.Internal++-- | Tests the following alt properties:+--+-- [/Associativity/]+--   @(a 'Alt.<!>' b) 'Alt.<!>' c ≡ a 'Alt.<!>' (b 'Alt.<!>' c)@+-- [/Left Distributivity/]+--   @f '<$>' (a 'Alt.<!>' b) ≡ (f '<$>' a) 'Alt.<!>' (f '<$>' b)@+altLaws :: forall proxy f.+#if HAVE_QUANTIFIED_CONSTRAINTS+  (Alt f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))+#else+  (Alt f, Eq1 f, Show1 f, Arbitrary1 f)+#endif+  => proxy f -> Laws+altLaws p = Laws "Alt"+  [ ("Associativity", altAssociative p)+  , ("Left Distributivity", altLeftDistributive p)+  ]++altAssociative :: forall proxy f.+#if HAVE_QUANTIFIED_CONSTRAINTS+  (Alt f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))+#else+  (Alt f, Eq1 f, Show1 f, Arbitrary1 f)+#endif+  => proxy f -> Property+altAssociative _ = property $ \(Apply (a :: f Integer)) (Apply (b :: f Integer)) (Apply (c :: f Integer)) -> eq1 ((a Alt.<!> b) Alt.<!> c) (a Alt.<!> (b Alt.<!> c))++altLeftDistributive :: forall proxy f.+#if HAVE_QUANTIFIED_CONSTRAINTS+  (Alt f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))+#else+  (Alt f, Eq1 f, Show1 f, Arbitrary1 f)+#endif+  => proxy f -> Property+altLeftDistributive _ = property $ \(Apply (a :: f Integer)) (Apply (b :: f Integer)) -> eq1 (id <$> (a Alt.<!> b)) ((id <$> a) Alt.<!> (id <$> b))+#endif
+ src/Test/QuickCheck/Classes/Apply.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++#if HAVE_QUANTIFIED_CONSTRAINTS+{-# LANGUAGE QuantifiedConstraints #-}+#endif++{-# OPTIONS_GHC -Wall #-}++module Test.QuickCheck.Classes.Apply+  (+#if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS)+    applyLaws+#endif+) where++#if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS)+import Data.Functor+import qualified Data.Functor.Apply as FunctorApply+import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Arbitrary (Arbitrary1(..))+import Data.Functor.Classes (Eq1,Show1)+import Test.QuickCheck.Property (Property)++import Test.QuickCheck.Classes.Internal++type ApplyProp proxy f =+#if HAVE_QUANTIFIED_CONSTRAINTS+  (FunctorApply.Apply f, forall x. Eq x => Eq (f x), forall x. Show x => Show (f x), forall x. Arbitrary x => Arbitrary (f x)) +#else+  (FunctorApply.Apply f, Eq1 f, Show1 f, Arbitrary1 f)+#endif+  => proxy f -> Property++-- | Tests the following alt properties:+--+-- [/LiftF2 (1)/]+--   @('FunctorApply.<.>') ≡ 'FunctorApply.liftF2' 'id'@+-- [/Associativity/]+--   @'fmap' ('.') u 'FunctorApply.<.>' v 'FunctorApply.<.>' w ≡ u 'FunctorApply.<.>' (v 'FunctorApply.<.>' w)@+applyLaws ::+#if HAVE_QUANTIFIED_CONSTRAINTS+  (FunctorApply.Apply f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))+#else+  (FunctorApply.Apply f, Eq1 f, Show1 f, Arbitrary1 f)+#endif+  => proxy f -> Laws+applyLaws p = Laws "Apply"+  [ ("LiftF2 part 1", applyLiftF2_1 p)+  , ("Associativity", applyAssociativity p)+  ]++applyLiftF2_1 :: forall proxy f. ApplyProp proxy f+applyLiftF2_1 _ = property $ \(Apply (f' :: f QuadraticEquation)) (Apply (x :: f Integer)) ->+  let f = fmap runQuadraticEquation f'+  in eq1 (FunctorApply.liftF2 id f x) (f FunctorApply.<.> x)++applyAssociativity :: forall proxy f. ApplyProp proxy f+applyAssociativity _ = property $ \(Apply (u' :: f QuadraticEquation)) (Apply (v' :: f QuadraticEquation)) (Apply (w :: f Integer)) ->+  let u = fmap runQuadraticEquation u'+      v = fmap runQuadraticEquation v'+   in eq1 (fmap (.) u FunctorApply.<.> v FunctorApply.<.> w) (u FunctorApply.<.> (v FunctorApply.<.> w))++#endif
+ src/Test/QuickCheck/Classes/Euclidean.hs view
@@ -0,0 +1,122 @@+-- |+-- Module:      Test.QuickCheck.Classes.Euclidean+-- Copyright:   (c) 2019 Andrew Lelechenko+-- Licence:     BSD3+--++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall #-}++#if !HAVE_SEMIRINGS+module Test.QuickCheck.Classes.Euclidean where+#else++module Test.QuickCheck.Classes.Euclidean+  ( gcdDomainLaws+  , euclideanLaws+  ) where++import Prelude hiding (quotRem, quot, rem, gcd, lcm)+import Data.Maybe+import Data.Proxy (Proxy)+import Data.Euclidean+import Data.Semiring (Semiring(..))++import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Property (Property)++import Test.QuickCheck.Classes.Internal (Laws(..))++-- | Test that a 'GcdDomain' instance obey several laws.+--+-- Check that 'divide' is an inverse of times:+--+-- * @y \/= 0 => (x * y) \`divide\` y == Just x@,+-- * @y \/= 0, x \`divide\` y == Just z => x == z * y@.+--+-- Check that 'gcd' is a common divisor and is a multiple of any common divisor:+--+-- * @x \/= 0, y \/= 0 => isJust (x \`divide\` gcd x y) && isJust (y \`divide\` gcd x y)@,+-- * @z \/= 0 => isJust (gcd (x * z) (y * z) \`divide\` z)@.+--+-- Check that 'lcm' is a common multiple and is a factor of any common multiple:+--+-- * @x \/= 0, y \/= 0 => isJust (lcm x y \`divide\` x) && isJust (lcm x y \`divide\` y)@,+-- * @x \/= 0, y \/= 0, isJust (z \`divide\` x), isJust (z \`divide\` y) => isJust (z \`divide\` lcm x y)@.+--+-- Check that 'gcd' of 'coprime' numbers is a unit of the semiring (has an inverse):+--+-- * @y \/= 0, coprime x y => isJust (1 \`divide\` gcd x y)@.+gcdDomainLaws :: (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Laws+gcdDomainLaws p = Laws "GcdDomain"+  [ ("divide1", divideLaw1 p)+  , ("divide2", divideLaw2 p)+  , ("gcd1", gcdLaw1 p)+  , ("gcd2", gcdLaw2 p)+  , ("lcm1", lcmLaw1 p)+  , ("lcm2", lcmLaw2 p)+  , ("coprime", coprimeLaw p)+  ]++divideLaw1 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property+divideLaw1 _ = property $ \(x :: a) y ->+  y /= zero ==> (x `times` y) `divide` y === Just x++divideLaw2 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property+divideLaw2 _ = property $ \(x :: a) y ->+  y /= zero ==> maybe (property True) (\z -> x === z `times` y) (x `divide` y)++gcdLaw1 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property+gcdLaw1 _ = property $ \(x :: a) y ->+  x /= zero || y /= zero ==> isJust (x `divide` gcd x y) .&&. isJust (y `divide` gcd x y)++gcdLaw2 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property+gcdLaw2 _ = property $ \(x :: a) y z ->+  z /= zero ==> isJust (gcd (x `times` z) (y `times` z) `divide` z)++lcmLaw1 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property+lcmLaw1 _ = property $ \(x :: a) y ->+  x /= zero && y /= zero ==> isJust (lcm x y `divide` x) .&&. isJust (lcm x y `divide` y)++lcmLaw2 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property+lcmLaw2 _ = property $ \(x :: a) y z ->+  x /= zero && y /= zero ==> isNothing (z `divide` x) .||. isNothing (z `divide` y) .||. isJust (z `divide` lcm x y)++coprimeLaw :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property+coprimeLaw _ = property $ \(x :: a) y ->+  y /= zero ==> coprime x y === isJust (one `divide` gcd x y)++-- | Test that a 'Euclidean' instance obey laws of a Euclidean domain.+--+-- * @y \/= 0, r == x \`rem\` y => r == 0 || degree r < degree y@,+-- * @y \/= 0, (q, r) == x \`quotRem\` y => x == q * y + r@,+-- * @y \/= 0 => x \`quot\` x y == fst (x \`quotRem\` y)@,+-- * @y \/= 0 => x \`rem\` x y == snd (x \`quotRem\` y)@.+euclideanLaws :: (Eq a, Euclidean a, Arbitrary a, Show a) => Proxy a -> Laws+euclideanLaws p = Laws "Euclidean"+  [ ("degree", degreeLaw p)+  , ("quotRem", quotRemLaw p)+  , ("quot", quotLaw p)+  , ("rem", remLaw p)+  ]++degreeLaw :: forall a. (Eq a, Euclidean a, Arbitrary a, Show a) => Proxy a -> Property+degreeLaw _ = property $ \(x :: a) y ->+  y /= zero ==> let (_, r) = x `quotRem` y in (r === zero .||. degree r < degree y)++quotRemLaw :: forall a. (Eq a, Euclidean a, Arbitrary a, Show a) => Proxy a -> Property+quotRemLaw _ = property $ \(x :: a) y ->+  y /= zero ==> let (q, r) = x `quotRem` y in x === (q `times` y) `plus` r++quotLaw :: forall a. (Eq a, Euclidean a, Arbitrary a, Show a) => Proxy a -> Property+quotLaw _ = property $ \(x :: a) y ->+  y /= zero ==> quot x y === fst (quotRem x y)++remLaw :: forall a. (Eq a, Euclidean a, Arbitrary a, Show a) => Proxy a -> Property+remLaw _ = property $ \(x :: a) y ->+  y /= zero ==> rem x y === snd (quotRem x y)++#endif
+ src/Test/QuickCheck/Classes/IsList.hs view
@@ -0,0 +1,8 @@+module Test.QuickCheck.Classes.IsList+  ( module Test.QuickCheck.Classes.Base.IsList+  ) where++-- It would be better to do this with Cabal's module reexport feature,+-- but that would break compatibility with older GHCs.++import Test.QuickCheck.Classes.Base.IsList
+ src/Test/QuickCheck/Classes/Json.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall #-}++module Test.QuickCheck.Classes.Json+  (+#if HAVE_AESON+    jsonLaws+#endif  +  ) where++import Data.Proxy (Proxy)+import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Property (Property(..))++#if HAVE_AESON+import Data.Aeson (FromJSON(..), ToJSON(..))+import qualified Data.Aeson as AE+#endif++import Test.QuickCheck.Classes.Internal (Laws(..))++-- | Tests the following properties:+--+-- [/Partial Isomorphism/]+--   @decode . encode ≡ Just@+-- [/Encoding Equals Value/]+--   @decode . encode ≡ Just . toJSON@+--+-- Note that in the second property, the type of decode is @ByteString -> Value@,+-- not @ByteString -> a@+#if HAVE_AESON+jsonLaws :: (ToJSON a, FromJSON a, Show a, Arbitrary a, Eq a) => Proxy a -> Laws+jsonLaws p = Laws "ToJSON/FromJSON"+  [ ("Partial Isomorphism", jsonEncodingPartialIsomorphism p)+  , ("Encoding Equals Value", jsonEncodingEqualsValue p)+  ]++-- TODO: improve the quality of the error message if+-- something does not pass this test.+jsonEncodingEqualsValue :: forall a. (ToJSON a, Show a, Arbitrary a) => Proxy a -> Property+jsonEncodingEqualsValue _ = property $ \(a :: a) ->+  case AE.decode (AE.encode a) of+    Nothing -> False+    Just (v :: AE.Value) -> v == toJSON a++jsonEncodingPartialIsomorphism :: forall a. (ToJSON a, FromJSON a, Show a, Eq a, Arbitrary a) => Proxy a -> Property+jsonEncodingPartialIsomorphism _ =+#if MIN_VERSION_QuickCheck(2,9,0)+  again $+#endif+  MkProperty $+    arbitrary >>= \(x :: a) ->+      unProperty $+      shrinking shrink x $ \x' ->+        let desc1 = "Just"+            desc2 = "Data.Aeson.decode . Data.Aeson.encode"+            name1 = "Data.Aeson.encode a"+            name2 = "Data.Aeson.decode (Data.Aeson.encode a)"+            b1  = AE.encode x'+            b2  = AE.decode (AE.encode x')+            sb1 = show b1+            sb2 = show b2+            description = "  Description: " ++ desc1 ++ " == " ++ desc2+            err = description ++ "\n" ++ unlines (map ("  " ++) (["a = " ++ show x'])) ++ "  " ++ name1 ++ " = " ++ sb1 ++ "\n  " ++ name2 ++ " = " ++ sb2+        in counterexample err (Just x' == b2)+#endif
+ src/Test/QuickCheck/Classes/MVector.hs view
@@ -0,0 +1,354 @@+-- |+-- Module:      Test.QuickCheck.Classes.MVector+-- Copyright:   (c) 2019 Andrew Lelechenko+-- Licence:     BSD3+--++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall #-}++#if !HAVE_VECTOR+module Test.QuickCheck.Classes.MVector where+#else++module Test.QuickCheck.Classes.MVector+  ( muvectorLaws+  ) where++import Control.Applicative+import Control.Monad (when)+import Control.Monad.ST+import Data.Functor+import Data.Proxy (Proxy)+import qualified Data.Vector.Generic.Mutable as MU (basicInitialize)+import qualified Data.Vector.Unboxed.Mutable as MU++import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Property (Property)++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+muvectorLaws p = Laws "Vector.Unboxed.MVector"+  [ ("New-Length", newLength p)+  , ("Replicate-Length", replicateLength p)+  , ("Slice-Length", sliceLength p)+  , ("Grow-Length", growLength p)++  , ("Write-Read", writeRead p)+  , ("Set-Read", setRead p)+  , ("Sliced-Set-Read", slicedSetRead p)+  , ("Replicate-Read", replicateRead p)++  , ("Slice-Overlaps", sliceOverlaps p)+  , ("Slice-Copy", sliceCopy p)+  , ("Slice-Move", sliceMove p)++  , ("Write-Copy-Read", writeCopyRead p)+  , ("Write-Move-Read", writeMoveRead p)+  , ("Write-Grow-Read", writeGrowRead p)+  , ("Sliced-Write-Copy-Read", slicedWriteCopyRead p)+  , ("Sliced-Write-Move-Read", slicedWriteMoveRead p)+  , ("Sliced-Write-Grow-Read", slicedWriteGrowRead p)++  , ("Write-InitializeAround-Read", writeInitializeAroundRead p)+  , ("Write-ClearAround-Read", writeClearAroundRead p)+  , ("Write-SetAround-Read", writeSetAroundRead p)+  , ("Write-WriteAround-Read", writeWriteAroundRead p)+  , ("Write-CopyAround-Read", writeCopyAroundRead p)+  , ("Write-MoveAround-Read", writeMoveAroundRead p)++  , ("Write-InitializeBetween-Read", writeInitializeBetweenRead p)+  , ("Write-ClearBetween-Read", writeClearBetweenRead p)+  , ("Write-SetBetween-Read", writeSetBetweenRead p)+  , ("Write-CopyBetween-Read", writeCopyBetweenRead p)+  , ("Write-MoveBetween-Read", writeMoveBetweenRead p)+  ]++-------------------------------------------------------------------------------+-- Length++newLength :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+newLength _ = property $ \(NonNegative len) -> do+  (=== len) (runST $ MU.length <$> (MU.new len :: ST s (MU.MVector s a)))++replicateLength :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+replicateLength _ = property $ \(a :: a) (NonNegative len) -> do+  (=== len) (runST $ MU.length <$> MU.replicate len a)++sliceLength :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+sliceLength _ = property $ \(NonNegative ix) (NonNegative subLen) (Positive excess) -> do+  (=== subLen) (runST $ MU.length . MU.slice ix subLen <$> (MU.new (ix + subLen + excess) :: ST s (MU.MVector s a)))++growLength :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+growLength _ = property $ \(Positive len) (Positive by) -> do+  (=== len + by) $ runST $ do+    arr <- MU.new len :: ST s (MU.MVector s a)+    MU.length <$> MU.grow arr by++-------------------------------------------------------------------------------+-- Read++writeRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+  (=== a) $ runST $ do+    arr <- MU.new (ix + excess)+    MU.write arr ix a+    MU.read arr ix++setRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+setRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+  (=== a) $ runST $ do+    arr <- MU.new (ix + excess)+    MU.set arr a+    MU.read arr ix++slicedSetRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+slicedSetRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) before after -> do+  (=== a) $ runST $ do+    arr <- newSlice before after (ix + excess)+    MU.set arr a+    MU.read arr ix++replicateRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+replicateRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+  (=== a) $ runST $ do+    arr <- MU.replicate (ix + excess) a+    MU.read arr ix++-------------------------------------------------------------------------------+-- Overlaps++sliceOverlaps :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+sliceOverlaps _ = property $ \(NonNegative i) (NonNegative ij) (NonNegative jk) (NonNegative kl) (NonNegative lm) -> do+  let j = i + ij+      k = j + jk+      l = k + kl+      m = l + lm+  property $ runST $ do+    arr <- MU.new (m + 1) :: ST s (MU.MVector s a)+    let slice1 = MU.slice i (k - i + 1) arr+        slice2 = MU.slice j (l - j + 1) arr+    pure $ MU.overlaps slice1 slice2++sliceCopy :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+sliceCopy _ = property $ \(a :: a) (NonNegative i) (NonNegative ix) (Positive excess) (NonNegative ij) (NonNegative jk) -> do+  let j = i + ix + excess + ij+      k = j + ix + excess + jk+  runST $ do+    arr <- MU.new k :: ST s (MU.MVector s a)+    let src = MU.slice i (ix + excess) arr+        dst = MU.slice j (ix + excess) arr+    if MU.overlaps src dst then pure (property True) else do+      MU.write src ix a+      MU.copy dst src+      valSrc <- MU.read src ix+      valDst <- MU.read dst ix+      pure (valSrc === a .&&. valDst === a)++sliceMove :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+sliceMove _ = property $ \(a :: a) (NonNegative i) (NonNegative ix) (Positive excess) (NonNegative ij) (NonNegative jk) -> do+  let j = i + ix + excess + ij+      k = j + ix + excess + jk+  (=== a) $ runST $ do+    arr <- MU.new k :: ST s (MU.MVector s a)+    let src = MU.slice i (ix + excess) arr+        dst = MU.slice j (ix + excess) arr+    MU.write src ix a+    MU.move dst src+    MU.read dst ix++-------------------------------------------------------------------------------+-- Write + copy/move/grow++writeCopyRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeCopyRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+  (=== a) $ runST $ do+    src <- MU.new (ix + excess)+    MU.write src ix a+    dst <- MU.new (ix + excess)+    MU.copy dst src+    MU.clear src+    MU.read dst ix++writeMoveRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeMoveRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+  (=== a) $ runST $ do+    src <- MU.new (ix + excess)+    MU.write src ix a+    dst <- MU.new (ix + excess)+    MU.move dst src+    MU.clear src+    MU.read dst ix++writeGrowRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeGrowRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) (Positive by) -> do+  (=== a) $ runST $ do+    src <- MU.new (ix + excess)+    MU.write src ix a+    dst <- MU.grow src by+    MU.clear src+    MU.read dst ix++slicedWriteCopyRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+slicedWriteCopyRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) beforeSrc afterSrc beforeDst afterDst -> do+  (=== a) $ runST $ do+    src <- newSlice beforeSrc afterSrc (ix + excess)+    MU.write src ix a+    dst <- newSlice beforeDst afterDst (ix + excess)+    MU.copy dst src+    MU.clear src+    MU.read dst ix++slicedWriteMoveRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+slicedWriteMoveRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) beforeSrc afterSrc beforeDst afterDst -> do+  (=== a) $ runST $ do+    src <- newSlice beforeSrc afterSrc (ix + excess)+    MU.write src ix a+    dst <- newSlice beforeDst afterDst (ix + excess)+    MU.move dst src+    MU.clear src+    MU.read dst ix++slicedWriteGrowRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+slicedWriteGrowRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) (Positive by) beforeSrc afterSrc -> do+  (=== a) $ runST $ do+    src <- newSlice beforeSrc afterSrc (ix + excess)+    MU.write src ix a+    dst <- MU.grow src by+    MU.clear src+    MU.read dst ix++-------------------------------------------------------------------------------+-- Write + overwrite around++writeInitializeAroundRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeInitializeAroundRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+  (=== a) $ runST $ do+    arr <- MU.new (ix + excess)+    MU.write arr ix a+    when (ix > 0) $+      MU.basicInitialize (MU.slice 0 ix arr)+    when (excess > 1) $+      MU.basicInitialize (MU.slice (ix + 1) (excess - 1) arr)+    MU.read arr ix++writeClearAroundRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeClearAroundRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+  (=== a) $ runST $ do+    arr <- MU.new (ix + excess)+    MU.write arr ix a+    when (ix > 0) $+      MU.clear (MU.slice 0 ix arr)+    when (excess > 1) $+      MU.clear (MU.slice (ix + 1) (excess - 1) arr)+    MU.read arr ix++writeSetAroundRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeSetAroundRead _ = property $ \(a :: a) (b :: a) (NonNegative ix) (Positive excess) -> do+  (=== a) $ runST $ do+    arr <- MU.new (ix + excess)+    MU.write arr ix a+    when (ix > 0) $+      MU.set (MU.slice 0 ix arr) b+    when (excess > 1) $+      MU.set (MU.slice (ix + 1) (excess - 1) arr) b+    MU.read arr ix++writeWriteAroundRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeWriteAroundRead _ = property $ \(a :: a) (b :: a) (NonNegative ix) (Positive excess) -> do+  (=== a) $ runST $ do+    arr <- MU.new (ix + excess)+    MU.write arr ix a+    when (ix > 0) $+      MU.write arr (ix - 1) b+    when (excess > 1) $+      MU.write arr (ix + 1) b+    MU.read arr ix++writeCopyAroundRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeCopyAroundRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+  (=== a) $ runST $ do+    src <- MU.new (ix + excess)+    dst <- MU.new (ix + excess)+    MU.write dst ix a+    when (ix > 0) $+      MU.copy (MU.slice 0 ix dst) (MU.slice 0 ix src)+    when (excess > 1) $+      MU.copy (MU.slice (ix + 1) (excess - 1) dst) (MU.slice (ix + 1) (excess - 1) src)+    MU.read dst ix++writeMoveAroundRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeMoveAroundRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+  (=== a) $ runST $ do+    src <- MU.new (ix + excess)+    dst <- MU.new (ix + excess)+    MU.write dst ix a+    when (ix > 0) $+      MU.move (MU.slice 0 ix dst) (MU.slice 0 ix src)+    when (excess > 1) $+      MU.move (MU.slice (ix + 1) (excess - 1) dst) (MU.slice (ix + 1) (excess - 1) src)+    MU.read dst ix++-------------------------------------------------------------------------------+-- Two writes + overwrite in between++writeInitializeBetweenRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeInitializeBetweenRead _ = property $ \(a :: a) (b :: a) (NonNegative ix) (Positive dix) (Positive excess) -> do+  (=== (a, b)) $ runST $ do+    arr <- MU.new (ix + dix + excess)+    MU.write arr ix a+    MU.write arr (ix + dix) b+    MU.basicInitialize (MU.slice (ix + 1) (dix - 1) arr)+    (,) <$> MU.read arr ix <*> MU.read arr (ix + dix)++writeClearBetweenRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeClearBetweenRead _ = property $ \(a :: a) (b :: a) (NonNegative ix) (Positive dix) (Positive excess) -> do+  (=== (a, b)) $ runST $ do+    arr <- MU.new (ix + dix + excess)+    MU.write arr ix a+    MU.write arr (ix + dix) b+    MU.clear (MU.slice (ix + 1) (dix - 1) arr)+    (,) <$> MU.read arr ix <*> MU.read arr (ix + dix)++writeSetBetweenRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeSetBetweenRead _ = property $ \(a :: a) (b :: a) (c :: a) (NonNegative ix) (Positive dix) (Positive excess) -> do+  (=== (a, b)) $ runST $ do+    arr <- MU.new (ix + dix + excess)+    MU.write arr ix a+    MU.write arr (ix + dix) b+    MU.set (MU.slice (ix + 1) (dix - 1) arr) c+    (,) <$> MU.read arr ix <*> MU.read arr (ix + dix)++writeCopyBetweenRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeCopyBetweenRead _ = property $ \(a :: a) (b :: a) (NonNegative ix) (Positive dix) (Positive excess) -> do+  (=== (a, b)) $ runST $ do+    src <- MU.new (ix + dix + excess)+    dst <- MU.new (ix + dix + excess)+    MU.write dst ix a+    MU.write dst (ix + dix) b+    MU.copy (MU.slice (ix + 1) (dix - 1) dst) (MU.slice (ix + 1) (dix - 1) src)+    (,) <$> MU.read dst ix <*> MU.read dst (ix + dix)++writeMoveBetweenRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeMoveBetweenRead _ = property $ \(a :: a) (b :: a) (NonNegative ix) (Positive dix) (Positive excess) -> do+  (=== (a, b)) $ runST $ do+    src <- MU.new (ix + dix + excess)+    dst <- MU.new (ix + dix + excess)+    MU.write dst ix a+    MU.write dst (ix + dix) b+    MU.move (MU.slice (ix + 1) (dix - 1) dst) (MU.slice (ix + 1) (dix - 1) src)+    (,) <$> MU.read dst ix <*> MU.read dst (ix + dix)++-------------------------------------------------------------------------------+-- Utils++newSlice :: MU.Unbox a => NonNegative Int -> NonNegative Int -> Int -> ST s (MU.MVector s a)+newSlice (NonNegative before) (NonNegative after) len = do+  arr <- MU.new (before + len + after)+  pure $ MU.slice before len arr++#endif
+ src/Test/QuickCheck/Classes/Plus.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++#if HAVE_QUANTIFIED_CONSTRAINTS+{-# LANGUAGE QuantifiedConstraints #-}+#endif++{-# OPTIONS_GHC -Wall #-}++module Test.QuickCheck.Classes.Plus+  (+#if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS)+    plusLaws+  , extendedPlusLaws+#endif+  ) where++#if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS)+import Data.Functor+import Data.Functor.Alt (Alt)+import Data.Functor.Plus (Plus)+import qualified Data.Functor.Alt as Alt+import qualified Data.Functor.Plus as Plus++import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Arbitrary (Arbitrary1(..))+import Data.Functor.Classes (Eq1,Show1)+import qualified Control.Applicative as Alternative+import Test.QuickCheck.Property (Property)++import Test.QuickCheck.Classes.Internal++-- | Tests the following alt properties:+--+-- [/Left Identity/]+--   @'Plus.zero' 'Alt.<!>' m ≡ m@+-- [/Right Identity/]+--   @m 'Alt.<!>' 'Plus.zero' ≡ m@+plusLaws :: forall proxy f.+#if HAVE_QUANTIFIED_CONSTRAINTS+  (Plus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))+#else+  (Plus f, Eq1 f, Show1 f, Arbitrary1 f)+#endif+  => proxy f -> Laws+plusLaws p = Laws "Plus"+  [ ("Left Identity", plusLeftIdentity p)+  , ("Right Identity", plusRightIdentity p)+  ]++-- | Tests everything from 'altLaws', plus the following:+--+-- [/Congruency/]+--   @'Plus.zero' ≡ 'Alternative.empty'@+extendedPlusLaws :: forall proxy f.+#if HAVE_QUANTIFIED_CONSTRAINTS+  (Plus f, Alternative.Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))+#else+  (Plus f, Alternative.Alternative f, Eq1 f, Show1 f, Arbitrary1 f)+#endif+  => proxy f -> Laws+extendedPlusLaws p = Laws "Plus extended to Alternative" $ lawsProperties (plusLaws p) +++  [ ("Congruency", extendedPlusLaw p)+  ]++extendedPlusLaw :: forall proxy f.+#if HAVE_QUANTIFIED_CONSTRAINTS+  (Plus f, Alternative.Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))+#else+  (Plus f, Alternative.Alternative f, Eq1 f, Show1 f, Arbitrary1 f)+#endif+  => proxy f -> Property+extendedPlusLaw _ = property $ eq1 (Plus.zero :: f Integer) (Alternative.empty :: f Integer)++plusLeftIdentity :: forall proxy f.+#if HAVE_QUANTIFIED_CONSTRAINTS+  (Plus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))+#else+  (Plus f, Eq1 f, Show1 f, Arbitrary1 f)+#endif+  => proxy f -> Property+plusLeftIdentity _ = property $ \(Apply (m :: f Integer)) -> eq1 (Plus.zero Alt.<!> m) m++plusRightIdentity :: forall proxy f.+#if HAVE_QUANTIFIED_CONSTRAINTS+  (Plus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))+#else+  (Plus f, Eq1 f, Show1 f, Arbitrary1 f)+#endif+  => proxy f -> Property+plusRightIdentity _ = property $ \(Apply (m :: f Integer)) -> eq1 (m Alt.<!> Plus.zero) m++#endif
+ src/Test/QuickCheck/Classes/Prim.hs view
@@ -0,0 +1,390 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}++{-# OPTIONS_GHC -Wall #-}++module Test.QuickCheck.Classes.Prim+  ( primLaws+  ) where++import Control.Applicative+import Control.Monad.Primitive (PrimMonad, PrimState,primitive,primitive_)+import Control.Monad.ST+import Data.Proxy (Proxy)+import Data.Primitive.ByteArray+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#,+   copyMutableByteArray#,copyByteArray#,quotInt#,sizeofByteArray#)++#if MIN_VERSION_base(4,7,0)+import GHC.Exts (IsList(fromList,toList,fromListN),Item,+  copyByteArrayToAddr#,copyAddrToByteArray#)+#endif++import GHC.Ptr (Ptr(..))+import System.IO.Unsafe+import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Property (Property)++import qualified Data.List as L+import qualified Data.Primitive as P++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+primLaws p = Laws "Prim"+  [ ("ByteArray Put-Get (you get back what you put in)", primPutGetByteArray p)+  , ("ByteArray Get-Put (putting back what you got out has no effect)", primGetPutByteArray p)+  , ("ByteArray Put-Put (putting twice is same as putting once)", primPutPutByteArray p)+  , ("ByteArray Set Range", primSetByteArray p)+#if MIN_VERSION_base(4,7,0)+  , ("ByteArray List Conversion Roundtrips", primListByteArray p)+#endif+  , ("Addr Put-Get (you get back what you put in)", primPutGetAddr p)+  , ("Addr Get-Put (putting back what you got out has no effect)", primGetPutAddr p)+  , ("Addr Set Range", primSetOffAddr p)+  , ("Addr List Conversion Roundtrips", primListAddr p)+  ]++primListAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primListAddr _ = property $ \(as :: [a]) -> unsafePerformIO $ do+  let len = L.length as+  ptr@(Ptr addr#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))+  let addr = Addr addr#+  let go :: Int -> [a] -> IO ()+      go !ix xs = case xs of+        [] -> return ()+        (x : xsNext) -> do+          writeOffAddr addr ix x+          go (ix + 1) xsNext+  go 0 as+  let rebuild :: Int -> IO [a]+      rebuild !ix = if ix < len+        then (:) <$> readOffAddr addr ix <*> rebuild (ix + 1)+        else return []+  asNew <- rebuild 0+  free ptr+  return (as == asNew)++primPutGetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primPutGetByteArray _ = property $ \(a :: a) len -> (len > 0) ==> do+  ix <- choose (0,len - 1)+  return $ runST $ do+    arr <- newPrimArray len+    writePrimArray arr ix a+    a' <- readPrimArray arr ix+    return (a == a')++primGetPutByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primGetPutByteArray _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do+  let arr1 = primArrayFromList as :: PrimArray a+      len = L.length as+  ix <- choose (0,len - 1)+  arr2 <- return $ runST $ do+    marr <- newPrimArray len+    copyPrimArray marr 0 arr1 0 len+    a <- readPrimArray marr ix+    writePrimArray marr ix a+    unsafeFreezePrimArray marr+  return (arr1 == arr2)++primPutPutByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primPutPutByteArray _ = property $ \(a :: a) (as :: [a]) -> (not (L.null as)) ==> do+  let arr1 = primArrayFromList as :: PrimArray a+      len = L.length as+  ix <- choose (0,len - 1)+  (arr2,arr3) <- return $ runST $ do+    marr2 <- newPrimArray len+    copyPrimArray marr2 0 arr1 0 len+    writePrimArray marr2 ix a+    marr3 <- newPrimArray len+    copyMutablePrimArray marr3 0 marr2 0 len+    arr2 <- unsafeFreezePrimArray marr2+    writePrimArray marr3 ix a+    arr3 <- unsafeFreezePrimArray marr3+    return (arr2,arr3)+  return (arr2 == arr3)++primPutGetAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primPutGetAddr _ = property $ \(a :: a) len -> (len > 0) ==> do+  ix <- choose (0,len - 1)+  return $ unsafePerformIO $ do+    ptr@(Ptr addr#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))+    let addr = Addr addr#+    writeOffAddr addr ix a+    a' <- readOffAddr addr ix+    free ptr+    return (a == a')++primGetPutAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primGetPutAddr _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do+  let arr1 = primArrayFromList as :: PrimArray a+      len = L.length as+  ix <- choose (0,len - 1)+  arr2 <- return $ unsafePerformIO $ do+    ptr@(Ptr addr#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))+    let addr = Addr addr#+    copyPrimArrayToPtr ptr arr1 0 len+    a :: a <- readOffAddr addr ix+    writeOffAddr addr ix a+    marr <- newPrimArray len+    copyPtrToMutablePrimArray marr 0 ptr len+    free ptr+    unsafeFreezePrimArray marr+  return (arr1 == arr2)++primSetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primSetByteArray _ = property $ \(as :: [a]) (z :: a) -> do+  let arr1 = primArrayFromList as :: PrimArray a+      len = L.length as+  x <- choose (0,len)+  y <- choose (0,len)+  let lo = min x y+      hi = max x y+  return $ runST $ do+    marr2 <- newPrimArray len+    copyPrimArray marr2 0 arr1 0 len+    marr3 <- newPrimArray len+    copyPrimArray marr3 0 arr1 0 len+    setPrimArray marr2 lo (hi - lo) z+    internalDefaultSetPrimArray marr3 lo (hi - lo) z+    arr2 <- unsafeFreezePrimArray marr2+    arr3 <- unsafeFreezePrimArray marr3+    return (arr2 == arr3)++primSetOffAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primSetOffAddr _ = property $ \(as :: [a]) (z :: a) -> do+  let arr1 = primArrayFromList as :: PrimArray a+      len = L.length as+  x <- choose (0,len)+  y <- choose (0,len)+  let lo = min x y+      hi = max x y+  return $ unsafePerformIO $ do+    ptrA@(Ptr addrA#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))+    let addrA = Addr addrA#+    copyPrimArrayToPtr ptrA arr1 0 len+    ptrB@(Ptr addrB#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))+    let addrB = Addr addrB#+    copyPrimArrayToPtr ptrB arr1 0 len+    setOffAddr addrA lo (hi - lo) z+    internalDefaultSetOffAddr addrB lo (hi - lo) z+    marrA <- newPrimArray len+    copyPtrToMutablePrimArray marrA 0 ptrA len+    free ptrA+    marrB <- newPrimArray len+    copyPtrToMutablePrimArray marrB 0 ptrB len+    free ptrB+    arrA <- unsafeFreezePrimArray marrA+    arrB <- unsafeFreezePrimArray marrB+    return (arrA == arrB)++-- byte array with phantom variable that specifies element type+data PrimArray a = PrimArray ByteArray#+data MutablePrimArray s a = MutablePrimArray (MutableByteArray# s)++instance (Eq a, Prim a) => Eq (PrimArray a) where+  a1 == a2 = sizeofPrimArray a1 == sizeofPrimArray a2 && loop (sizeofPrimArray a1 - 1)+    where+    loop !i | i < 0 = True+            | otherwise = indexPrimArray a1 i == indexPrimArray a2 i && loop (i-1)++#if MIN_VERSION_base(4,7,0)+instance Prim a => IsList (PrimArray a) where+  type Item (PrimArray a) = a+  fromList = primArrayFromList+  fromListN = primArrayFromListN+  toList = primArrayToList+#endif++indexPrimArray :: forall a. Prim a => PrimArray a -> Int -> a+indexPrimArray (PrimArray arr#) (I# i#) = indexByteArray# arr# i#++sizeofPrimArray :: forall a. Prim a => PrimArray a -> Int+sizeofPrimArray (PrimArray arr#) = I# (quotInt# (sizeofByteArray# arr#) (P.sizeOf# (undefined :: a)))++newPrimArray :: forall m a. (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a)+newPrimArray (I# n#)+  = primitive (\s# ->+      case newByteArray# (n# *# sizeOf# (undefined :: a)) s# of+        (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #)+    )++readPrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> m a+readPrimArray (MutablePrimArray arr#) (I# i#)+  = primitive (readByteArray# arr# i#)++writePrimArray ::+     (Prim a, PrimMonad m)+  => MutablePrimArray (PrimState m) a+  -> Int+  -> a+  -> m ()+writePrimArray (MutablePrimArray arr#) (I# i#) x+  = primitive_ (writeByteArray# arr# i# x)++unsafeFreezePrimArray+  :: PrimMonad m => MutablePrimArray (PrimState m) a -> m (PrimArray a)+unsafeFreezePrimArray (MutablePrimArray arr#)+  = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of+                        (# s'#, arr'# #) -> (# s'#, PrimArray arr'# #))++#if !MIN_VERSION_base(4,7,0)+ptrToAddr :: Ptr a -> Addr+ptrToAddr (Ptr x) = Addr x++generateM_ :: Monad m => Int -> (Int -> m a) -> m ()+generateM_ n f = go 0 where+  go !ix = if ix < n+    then f ix >> go (ix + 1)+    else return ()+#endif++copyPrimArrayToPtr :: forall m a. (PrimMonad m, Prim a)+  => Ptr a       -- ^ destination pointer+  -> PrimArray a -- ^ source array+  -> Int         -- ^ offset into source array+  -> Int         -- ^ number of prims to copy+  -> m ()+#if MIN_VERSION_base(4,7,0)+copyPrimArrayToPtr (Ptr addr#) (PrimArray ba#) (I# soff#) (I# n#) =+  primitive (\ s# ->+      let s'# = copyByteArrayToAddr# ba# (soff# *# siz#) addr# (n# *# siz#) s#+      in (# s'#, () #))+  where siz# = sizeOf# (undefined :: a)+#else+copyPrimArrayToPtr addr ba soff n =+  generateM_ n $ \ix -> writeOffAddr (ptrToAddr addr) ix (indexPrimArray ba (ix + soff))+#endif++copyPtrToMutablePrimArray :: forall m a. (PrimMonad m, Prim a)+  => MutablePrimArray (PrimState m) a+  -> Int+  -> Ptr a+  -> Int+  -> m ()+#if MIN_VERSION_base(4,7,0)+copyPtrToMutablePrimArray (MutablePrimArray ba#) (I# doff#) (Ptr addr#) (I# n#) =+  primitive (\ s# ->+      let s'# = copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#) s#+      in (# s'#, () #))+  where siz# = sizeOf# (undefined :: a)+#else+copyPtrToMutablePrimArray ba doff addr n =+  generateM_ n $ \ix -> do+    x <- readOffAddr (ptrToAddr addr) ix+    writePrimArray ba (doff + ix) x+#endif++copyMutablePrimArray :: forall m a.+     (PrimMonad m, Prim a)+  => MutablePrimArray (PrimState m) a -- ^ destination array+  -> Int -- ^ offset into destination array+  -> MutablePrimArray (PrimState m) a -- ^ source array+  -> Int -- ^ offset into source array+  -> Int -- ^ number of bytes to copy+  -> m ()+copyMutablePrimArray (MutablePrimArray dst#) (I# doff#) (MutablePrimArray src#) (I# soff#) (I# n#)+  = primitive_ (copyMutableByteArray#+      src#+      (soff# *# (sizeOf# (undefined :: a)))+      dst#+      (doff# *# (sizeOf# (undefined :: a)))+      (n# *# (sizeOf# (undefined :: a)))+    )++copyPrimArray :: forall m a.+     (PrimMonad m, Prim a)+  => MutablePrimArray (PrimState m) a -- ^ destination array+  -> Int -- ^ offset into destination array+  -> PrimArray a -- ^ source array+  -> Int -- ^ offset into source array+  -> Int -- ^ number of bytes to copy+  -> m ()+copyPrimArray (MutablePrimArray dst#) (I# doff#) (PrimArray src#) (I# soff#) (I# n#)+  = primitive_ (copyByteArray#+      src#+      (soff# *# (sizeOf# (undefined :: a)))+      dst#+      (doff# *# (sizeOf# (undefined :: a)))+      (n# *# (sizeOf# (undefined :: a)))+    )++setPrimArray+  :: (Prim a, PrimMonad m)+  => MutablePrimArray (PrimState m) a -- ^ array to fill+  -> Int -- ^ offset into array+  -> Int -- ^ number of values to fill+  -> a -- ^ value to fill with+  -> m ()+setPrimArray (MutablePrimArray dst#) (I# doff#) (I# sz#) x+  = primitive_ (P.setByteArray# dst# doff# sz# x)++primArrayFromList :: Prim a => [a] -> PrimArray a+primArrayFromList xs = primArrayFromListN (L.length xs) xs++primArrayFromListN :: forall a. Prim a => Int -> [a] -> PrimArray a+primArrayFromListN len vs = runST run where+  run :: forall s. ST s (PrimArray a)+  run = do+    arr <- newPrimArray len+    let go :: [a] -> Int -> ST s ()+        go !xs !ix = case xs of+          [] -> return ()+          a : as -> do+            writePrimArray arr ix a+            go as (ix + 1)+    go vs 0+    unsafeFreezePrimArray arr++primArrayToList :: forall a. Prim a => PrimArray a -> [a]+primArrayToList arr = go 0 where+  !len = sizeofPrimArray arr+  go :: Int -> [a]+  go !ix = if ix < len+    then indexPrimArray arr ix : go (ix + 1)+    else []++#if MIN_VERSION_base(4,7,0)+primListByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primListByteArray _ = property $ \(as :: [a]) ->+  as == toList (fromList as :: PrimArray a)+#endif++setOffAddr :: forall a. Prim a => Addr -> Int -> Int -> a -> IO ()+setOffAddr addr ix len a = setAddr (plusAddr addr (P.sizeOf (undefined :: a) * ix)) len a++internalDefaultSetPrimArray :: Prim a+  => MutablePrimArray s a -> Int -> Int -> a -> ST s ()+internalDefaultSetPrimArray (MutablePrimArray arr) (I# i) (I# len) ident =+  primitive_ (internalDefaultSetByteArray# arr i len ident)++internalDefaultSetByteArray# :: Prim a+  => MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s+internalDefaultSetByteArray# arr# i# len# ident = go 0#+  where+  go ix# s0 = if isTrue# (ix# <# len#)+    then case writeByteArray# arr# (i# +# ix#) ident s0 of+      s1 -> go (ix# +# 1#) s1+    else s0++internalDefaultSetOffAddr :: Prim a => Addr -> Int -> Int -> a -> IO ()+internalDefaultSetOffAddr (Addr addr) (I# ix) (I# len) a = primitive_+  (internalDefaultSetOffAddr# addr ix len a)++internalDefaultSetOffAddr# :: Prim a => Addr# -> Int# -> Int# -> a -> State# s -> State# s+internalDefaultSetOffAddr# addr# i# len# ident = go 0#+  where+  go ix# s0 = if isTrue# (ix# <# len#)+    then case writeOffAddr# addr# (i# +# ix#) ident s0 of+      s1 -> go (ix# +# 1#) s1+    else s0
+ src/Test/QuickCheck/Classes/Ring.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall #-}++module Test.QuickCheck.Classes.Ring+  ( +#if HAVE_SEMIRINGS+    ringLaws+#endif+  ) where++#if HAVE_SEMIRINGS+import Data.Semiring+import Prelude hiding (Num(..))+#endif++import Data.Proxy (Proxy)+import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Property (Property)++import Test.QuickCheck.Classes.Internal (Laws(..), myForAllShrink)++#if HAVE_SEMIRINGS+-- | Tests the following properties:+--+-- [/Additive Inverse/]+--   @'negate' a '+' a ≡ 0@+--+-- Note that this does not test any of the laws tested by 'Test.QuickCheck.Classes.Semiring.semiringLaws'.+ringLaws :: (Ring a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws+ringLaws p = Laws "Ring"+  [ ("Additive Inverse", ringAdditiveInverse p)+  ]++ringAdditiveInverse :: forall a. (Ring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+ringAdditiveInverse _ = myForAllShrink True (const True)+  (\(a :: a) -> ["a = " ++ show a])+  "negate a + a"+  (\a -> negate a + a)+  "0"+  (const zero)+#endif
+ src/Test/QuickCheck/Classes/Semigroupoid.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++#if HAVE_QUANTIFIED_CONSTRAINTS+{-# LANGUAGE QuantifiedConstraints #-}+#endif++{-# OPTIONS_GHC -Wall #-}++module Test.QuickCheck.Classes.Semigroupoid+  (+#if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_BINARY_LAWS)+    semigroupoidLaws+  , commutativeSemigroupoidLaws+#endif+  ) where++#if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_BINARY_LAWS)+import Prelude hiding (id, (.))+import Data.Semigroupoid (Semigroupoid(..))+import Test.QuickCheck hiding ((.&.))+import Data.Functor.Classes (Eq2,Show2)+import Test.QuickCheck.Property (Property)++import Test.QuickCheck.Classes.Internal++-- | Tests the following 'Semigroupoid' properties:+--+-- [/Associativity/]+--   @f `'o'` (g `'o'` h) ≡ (f `'o'` g) `'o'` h@+--+-- /Note/: This property test is only available when this package is built with+-- @base-4.9+@ or @transformers-0.5+@.+semigroupoidLaws :: forall proxy s.+#if HAVE_QUANTIFIED_CONSTRAINTS+  (Semigroupoid s, forall a b. (Eq a, Eq b) => Eq (s a b), forall a b. (Show a, Show b) => Show (s a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (s a b))+#else+  (Semigroupoid s, Eq2 s, Show2 s, Arbitrary2 s)+#endif+  => proxy s -> Laws+semigroupoidLaws p = Laws "Semigroupoid"+  [ ("Associativity", semigroupoidAssociativity p)+  ]++-- | Tests everything from 'semigroupoidLaws' plus the following:+--+-- [/Commutative/]+--   @f `'o'` g ≡ g `'o'` f@+--+-- /Note/: This property test is only available when this package is built with+-- @base-4.9+@ or @transformers-0.5+@.+commutativeSemigroupoidLaws :: forall proxy s.+#if HAVE_QUANTIFIED_CONSTRAINTS+  (Semigroupoid s, forall a b. (Eq a, Eq b) => Eq (s a b), forall a b. (Show a, Show b) => Show (s a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (s a b))+#else+  (Semigroupoid s, Eq2 s, Show2 s, Arbitrary2 s)+#endif+  => proxy s -> Laws+commutativeSemigroupoidLaws p = Laws "Commutative Semigroupoid" $ lawsProperties (semigroupoidLaws p) +++  [ ("Commutative", semigroupoidCommutativity p)+  ]++semigroupoidAssociativity :: forall proxy s.+#if HAVE_QUANTIFIED_CONSTRAINTS+  (Semigroupoid s, forall a b. (Eq a, Eq b) => Eq (s a b), forall a b. (Show a, Show b) => Show (s a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (s a b))+#else+  (Semigroupoid s, Eq2 s, Show2 s, Arbitrary2 s)+#endif+  => proxy s -> Property+semigroupoidAssociativity _ = property $ \(Apply2 (f :: s Integer Integer)) (Apply2 (g :: s Integer Integer)) (Apply2 (h :: s Integer Integer)) -> eq2 (f `o` (g `o` h)) ((f `o` g) `o` h)++semigroupoidCommutativity :: forall proxy s.+#if HAVE_QUANTIFIED_CONSTRAINTS+  (Semigroupoid s, forall a b. (Eq a, Eq b) => Eq (s a b), forall a b. (Show a, Show b) => Show (s a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (s a b))+#else+  (Semigroupoid s, Eq2 s, Show2 s, Arbitrary2 s)+#endif+  => proxy s -> Property+semigroupoidCommutativity _ = property $ \(Apply2 (f :: s Integer Integer)) (Apply2 (g :: s Integer Integer)) -> eq2 (f `o` g) (g `o` f)++#endif
+ src/Test/QuickCheck/Classes/Semiring.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall #-}++module Test.QuickCheck.Classes.Semiring+  (+#if HAVE_SEMIRINGS+    semiringLaws+#endif+  ) where++#if HAVE_SEMIRINGS+import Data.Semiring hiding (fromInteger)+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.Internal (Laws(..), myForAllShrink)++#if HAVE_SEMIRINGS+-- | 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@+--+-- 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)+  , ("Additive Left Identity", semiringLeftIdentityPlus p)+  , ("Additive Right Identity", semiringRightIdentityPlus p)+  , ("Multiplicative Associativity", semiringAssociativeTimes p)+  , ("Multiplicative Left Identity", semiringLeftIdentityTimes p)+  , ("Multiplicative Right Identity", semiringRightIdentityTimes p)+  , ("Multiplication Left Distributes Over Addition", semiringLeftMultiplicationDistributes p)+  , ("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+semiringLeftMultiplicationDistributes _ = 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))++semiringRightMultiplicationDistributes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+semiringRightMultiplicationDistributes _ = 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))++semiringLeftIdentityPlus :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+semiringLeftIdentityPlus _ = myForAllShrink False (const True)+  (\(a :: a) -> ["a = " ++ show a])+  "0 + a"+  (\a -> zero + a)+  "a"+  (\a -> a)++semiringRightIdentityPlus :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+semiringRightIdentityPlus _ = myForAllShrink False (const True)+  (\(a :: a) -> ["a = " ++ show a])+  "a + 0"+  (\a -> a + zero)+  "a"+  (\a -> a)++semiringRightIdentityTimes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+semiringRightIdentityTimes _ = myForAllShrink False (const True)+  (\(a :: a) -> ["a = " ++ show a])+  "a * 1"+  (\a -> a * one)+  "a"+  (\a -> a)++semiringLeftIdentityTimes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+semiringLeftIdentityTimes _ = myForAllShrink False (const True)+  (\(a :: a) -> ["a = " ++ show a])+  "1 * a"+  (\a -> one * a)+  "a"+  (\a -> a)++semiringLeftAnnihilation :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+semiringLeftAnnihilation _ = myForAllShrink False (const True)+  (\(a :: a) -> ["a = " ++ show a])+  "0 * a"+  (\a -> zero * a)+  "0"+  (\_ -> zero)++semiringRightAnnihilation :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+semiringRightAnnihilation _ = myForAllShrink False (const True)+  (\(a :: a) -> ["a = " ++ show a])+  "a * 0"+  (\a -> a * zero)+  "0"+  (\_ -> zero)++semiringCommutativePlus :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+semiringCommutativePlus _ = 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)++semiringAssociativeTimes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+semiringAssociativeTimes _ = 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)++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
+ test/Advanced.hs view
@@ -0,0 +1,193 @@+{-# language DerivingStrategies #-}+{-# language DerivingVia #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language LambdaCase #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}++import Test.Tasty (TestTree,defaultMain,testGroup,adjustOption)+import Test.QuickCheck (Arbitrary)+import Data.Proxy (Proxy(..))+import Data.Set (Set)+import Data.Primitive (Array)+import Control.Monad (forM_,replicateM)+import Data.Monoid (All(..))+import Test.QuickCheck.Classes (eqLaws,ordLaws)+import Data.Typeable (Typeable,typeRep)+import Data.Coerce (coerce)+import Data.Set (Set)++import qualified Data.Set as S+import qualified Data.List as L+import qualified GHC.Exts as E+import qualified Test.QuickCheck as QC+import qualified Test.Tasty.QuickCheck as TQC+import qualified Test.QuickCheck.Classes as QCC++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "universe"+  [ testGroup "deriving"+    [ testGroup "strict"+      [ laws @A [eqLaws,ordLaws]+      , laws @B [eqLaws,ordLaws]+      , laws @C [eqLaws,ordLaws]+      , laws @D [eqLaws,ordLaws]+      , laws @E [eqLaws,ordLaws]+      , laws @F [eqLaws,ordLaws]+      , laws @G [eqLaws,ordLaws]+      , laws @H [eqLaws,ordLaws]+      , laws @I [eqLaws,ordLaws]+      , laws @K [eqLaws,ordLaws]+      ]+    , testGroup "thunk"+      [ laws @(Thunk A) [eqLaws,ordLaws]+      , laws @(Thunk B) [eqLaws,ordLaws]+      , laws @(Thunk C) [eqLaws,ordLaws]+      , laws @(Thunk D) [eqLaws,ordLaws]+      , laws @(Thunk E) [eqLaws,ordLaws]+      , laws @(Thunk F) [eqLaws,ordLaws]+      , laws @(Thunk G) [eqLaws,ordLaws]+      , laws @(Thunk H) [eqLaws,ordLaws]+      , laws @(Thunk I) [eqLaws,ordLaws]+      , laws @(Thunk K) [eqLaws,ordLaws]+      ]+    , testGroup "lazy"+      [ laws @(Lazy A) [eqLaws,ordLaws]+      , laws @(Lazy B) [eqLaws,ordLaws]+      , laws @(Lazy C) [eqLaws,ordLaws]+      , laws @(Lazy D) [eqLaws,ordLaws]+      , laws @(Lazy E) [eqLaws,ordLaws]+      , laws @(Lazy F) [eqLaws,ordLaws]+      , laws @(Lazy G) [eqLaws,ordLaws]+      , laws @(Lazy H) [eqLaws,ordLaws]+      , laws @(Lazy I) [eqLaws,ordLaws]+      , laws @(Lazy K) [eqLaws,ordLaws]+      ]+    ]+  , testGroup "containers"+    [ testGroup "strict"+      [ laws @(Set A) [eqLaws,ordLaws]+      , laws @(Set B) [eqLaws,ordLaws]+      , laws @(Set C) [eqLaws,ordLaws]+      , laws @(Set D) [eqLaws,ordLaws]+      , laws @(Set E) [eqLaws,ordLaws]+      , laws @(Set F) [eqLaws,ordLaws]+      , laws @(Set G) [eqLaws,ordLaws]+      , laws @(Set H) [eqLaws,ordLaws]+      , laws @(Set I) [eqLaws,ordLaws]+      , laws @(Set K) [eqLaws,ordLaws]+      ]+    , testGroup "lazy"+      [ laws @(SmallLazySet A) [eqLaws,ordLaws]+      , laws @(SmallLazySet B) [eqLaws,ordLaws]+      , laws @(SmallLazySet C) [eqLaws,ordLaws]+      , laws @(SmallLazySet D) [eqLaws,ordLaws]+      , laws @(SmallLazySet E) [eqLaws,ordLaws]+      , laws @(SmallLazySet F) [eqLaws,ordLaws]+      , laws @(SmallLazySet G) [eqLaws,ordLaws]+      , laws @(SmallLazySet H) [eqLaws,ordLaws]+      , laws @(SmallLazySet I) [eqLaws,ordLaws]+      , laws @(SmallLazySet K) [eqLaws,ordLaws]+      ]+    ]+  ]++data A = A0+  deriving stock (Eq,Ord,Show,Read,Bounded,Enum)+  deriving Arbitrary via (Enumeration A)++data B = B0 | B1+  deriving stock (Eq,Ord,Show,Read,Bounded,Enum)+  deriving Arbitrary via (Enumeration B)++data C = C0 | C1 | C2+  deriving stock (Eq,Ord,Show,Read,Bounded,Enum)+  deriving Arbitrary via (Enumeration C)++data D = D0 | D1 | D2 | D3+  deriving stock (Eq,Ord,Show,Read,Bounded,Enum)+  deriving Arbitrary via (Enumeration D)++data E = E0 | E1 | E2 | E3 | E4+  deriving stock (Eq,Ord,Show,Read,Bounded,Enum)+  deriving Arbitrary via (Enumeration E)++data F = F0 | F1 | F2 | F3 | F4 | F5+  deriving stock (Eq,Ord,Show,Read,Bounded,Enum)+  deriving Arbitrary via (Enumeration F)++data G = G0 | G1 | G2 | G3 | G4 | G5 | G6+  deriving stock (Eq,Ord,Show,Read,Bounded,Enum)+  deriving Arbitrary via (Enumeration G)++data H = H0 | H1 | H2 | H3 | H4 | H5 | H6 | H7+  deriving stock (Eq,Ord,Show,Read,Bounded,Enum)+  deriving Arbitrary via (Enumeration H)++data I = I0 | I1 | I2 | I3 | I4 | I5 | I6 | I7 | I8+  deriving stock (Eq,Ord,Show,Read,Bounded,Enum)+  deriving Arbitrary via (Enumeration I)++data J = J0 | J1 | J2 | J3 | J4 | J5 | J6 | J7 | J8 | J9+  deriving stock (Eq,Ord,Show,Read,Bounded,Enum)+  deriving Arbitrary via (Enumeration J)++data K = K0 | K1 | K2 | K3 | K4 | K5 | K6 | K7 | K8 | K9 | K10+  deriving stock (Eq,Ord,Show,Read,Bounded,Enum)+  deriving Arbitrary via (Enumeration K)++laws :: forall a. Typeable a => [Proxy a -> QCC.Laws] -> TestTree+laws = testGroup (show (typeRep (Proxy :: Proxy a))) . map+  ( \f -> let QCC.Laws name pairs = f (Proxy :: Proxy a) in+    testGroup name (map (uncurry TQC.testProperty) pairs)+  )++newtype Enumeration a = Enumeration a++instance (Bounded a, Enum a, Eq a) => Arbitrary (Enumeration a) where+  arbitrary = fmap Enumeration TQC.arbitraryBoundedEnum+  shrink (Enumeration x) = if x == minBound+    then []+    else [Enumeration (pred x)]++data Thunk a = Thunk a+  deriving stock (Eq,Ord,Show,Read)++newtype Lazy a = Lazy a+  deriving newtype (Eq,Ord,Show,Read)++newtype SmallLazySet a = SmallLazySet (Set a)+  deriving newtype (Eq,Ord,Show,Read)++instance Arbitrary a => Arbitrary (Thunk a) where+  arbitrary = do+    a <- TQC.arbitrary+    let {-# NOINLINE b #-}+        b () = a+    pure (Thunk (b ()))+  shrink (Thunk x) = map Thunk (TQC.shrink x)++instance Arbitrary a => Arbitrary (Lazy a) where+  arbitrary = do+    a <- TQC.arbitrary+    let {-# NOINLINE b #-}+        b () = a+    pure (Lazy (b ()))+  shrink (Lazy x) = map Lazy (TQC.shrink x)++instance (Arbitrary a, Ord a) => Arbitrary (SmallLazySet a) where+  arbitrary = do+    a <- TQC.arbitrary+    b <- TQC.arbitrary+    c <- TQC.arbitrary+    let {-# NOINLINE a' #-}+        a' () = a+    let {-# NOINLINE b' #-}+        b' () = b+    let {-# NOINLINE c' #-}+        c' () = c+    pure (SmallLazySet (S.fromList [a' (), b' (), c' (), a' (), b' (), c' ()]))+
test/Spec.hs view
@@ -1,76 +1,260 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-} -import Test.QuickCheck-import Data.Proxy-import Data.Word-import Data.Int+#if HAVE_QUANTIFIED_CONSTRAINTS+{-# LANGUAGE QuantifiedConstraints #-}+#endif+ import Control.Monad-import Data.Primitive+import Control.Monad.Zip (MonadZip)+import Control.Applicative+#if defined(VERSION_aeson)+import Data.Aeson (ToJSON,FromJSON)+#endif+import Data.Bits import Data.Foldable-import Data.Monoid (Sum)-import Foreign.Storable+import Data.Map (Map)+import qualified Data.Map as M+#if MIN_VERSION_containers(0,5,9)+import qualified Data.Map.Merge.Strict as MM+#endif+import Data.Traversable+#if HAVE_SEMIGROUPOIDS+import Data.Functor.Apply (Apply((<.>)))+#endif+#if HAVE_BINARY_LAWS+import Data.Functor.Const (Const(..))+#endif+#if HAVE_UNARY_LAWS import Data.Functor.Classes-import Data.Aeson (ToJSON,FromJSON)+#endif+import Data.Int+import Data.Monoid (Sum(..),Monoid,mappend,mconcat,mempty)+import Data.Orphans ()+import Data.Primitive+import Data.Proxy import Data.Vector (Vector)+import Data.Word+import Foreign.Storable+import Test.QuickCheck+import Text.Show.Functions  import qualified Data.Vector as V+import qualified Data.Foldable as F  import Test.QuickCheck.Classes+import qualified Spec.ShowRead  main :: IO ()-main = lawsCheckMany allPropsApplied+main = do+#if HAVE_SEMIGROUPOIDS+#if MIN_VERSION_containers(0,5,9)+  quickCheck prop_map_apply_equals+#endif+#endif+  lawsCheckMany allPropsApplied  allPropsApplied :: [(String,[Laws])]-allPropsApplied = +allPropsApplied = M.toList . M.fromListWith (++) $   [ ("Int",allLaws (Proxy :: Proxy Int))   , ("Int64",allLaws (Proxy :: Proxy Int64))   , ("Word",allLaws (Proxy :: Proxy Word))-#if MIN_VERSION_QuickCheck(2,10,0)-  , ("Maybe",allHigherLaws (Proxy :: Proxy Maybe))-  , ("List",allHigherLaws (Proxy :: Proxy []))+#if HAVE_BINARY_LAWS+  , ("Tuple"+    , [ bitraversableLaws (Proxy :: Proxy (,))+      , bifoldableLaws (Proxy :: Proxy (,))+      ]+    )+  , ("Const"+    , [ bifoldableLaws (Proxy :: Proxy Const)+      , bitraversableLaws (Proxy :: Proxy Const)+      ]+    )+  , ("Either"+    , [ bitraversableLaws (Proxy :: Proxy Either)+      , bifoldableLaws (Proxy :: Proxy Either)+      ]+    ) #endif-  , ("Vector",[isListLaws (Proxy :: Proxy (Vector Word))])+#if HAVE_UNARY_LAWS+  , ("Maybe",allHigherLaws (Proxy1 :: Proxy1 Maybe))+  , ("List",allHigherLaws (Proxy1 :: Proxy1 []))+--  , ("BadList",allHigherLaws (Proxy1 :: Proxy1 BadList))+#endif+#if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS)+#if MIN_VERSION_base(4,9,0) && MIN_VERSION_containers(0,5,9)+  , ("Map", someHigherLaws (Proxy1 :: Proxy1 (Map Int)))+  , ("Pound", someHigherLaws (Proxy1 :: Proxy1 (Pound Int)))+#endif+#endif+#if MIN_VERSION_base(4,7,0)+  , ("Vector",+    [ isListLaws (Proxy :: Proxy (Vector Word))+#if HAVE_VECTOR+    , muvectorLaws (Proxy :: Proxy Word8)+    , muvectorLaws (Proxy :: Proxy (Int, Word))+#endif+    ])+#endif   ]+  ++ Spec.ShowRead.lawsApplied -allLaws :: forall a. (Num a, Prim a, Storable a, Ord a, Arbitrary a, Show a, Read a, ToJSON a, FromJSON a) => Proxy a -> [Laws]-allLaws p = +allLaws :: forall a.+  ( Integral a+  , Num a+  , Prim a+  , Storable a+  , Ord a+  , Arbitrary a+  , Show a+  , Read a+  , Enum a+  , Bounded a+#if defined(VERSION_aeson)+  , ToJSON a+  , FromJSON a+#endif+#if MIN_VERSION_base(4,7,0)+  , FiniteBits a+#endif+  ) => Proxy a -> [Laws]+allLaws p =   [ primLaws p   , storableLaws p+  , semigroupLaws (Proxy :: Proxy (Sum a))   , monoidLaws (Proxy :: Proxy (Sum a))-  , showReadLaws p+  , boundedEnumLaws p+#if defined(VERSION_aeson)   , jsonLaws p+#endif   , eqLaws p   , ordLaws p+  , numLaws p+  , integralLaws p+#if MIN_VERSION_base(4,7,0)+  , bitsLaws p+#endif   ]  foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b-foldlMapM f = foldlM (\b a -> fmap (mappend b) (f a)) mempty+foldlMapM f = foldlM (\b a -> liftM (mappend b) (f a)) mempty -#if MIN_VERSION_QuickCheck(2,10,0)-allHigherLaws :: (Foldable f, Monad f, Eq1 f, Arbitrary1 f, Show1 f) => Proxy f -> [Laws]-allHigherLaws p = +#if HAVE_UNARY_LAWS+allHigherLaws ::+  (Traversable f, MonadZip f, MonadPlus f, Applicative f,+#if HAVE_QUANTIFIED_CONSTRAINTS+   forall a. Eq a => Eq (f a), forall a. Arbitrary a => Arbitrary (f a),+   forall a. Show a => Show (f a)+#else+   Eq1 f, Arbitrary1 f, Show1 f+#endif+  ) => proxy f -> [Laws]+allHigherLaws p =   [ functorLaws p   , applicativeLaws p   , monadLaws p+  , monadPlusLaws p+  , monadZipLaws p   , foldableLaws p+  , traversableLaws p   ] #endif --- This type is fails the laws for the strict functions+#if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS)+someHigherLaws ::+  (Apply f,+#if HAVE_QUANTIFIED_CONSTRAINTS+   forall a. Eq a => Eq (f a), forall a. Arbitrary a => Arbitrary (f a),+   forall a. Show a => Show (f a)+#else+   Eq1 f, Arbitrary1 f, Show1 f+#endif+  ) => proxy f -> [Laws]+someHigherLaws p =+  [ applyLaws p+  ]+#endif++-- This type fails the laws for the strict functions -- in Foldable. It is used just to confirm that -- those property tests actually work.-newtype Rouge a = Rouge [a]-  deriving (Eq,Show,Arbitrary,Arbitrary1,Eq1,Show1)+newtype Rogue a = Rogue [a]+  deriving+  ( Eq, Show, Arbitrary+#if HAVE_UNARY_LAWS+  , Arbitrary1+  , Eq1+  , Show1+#endif+  ) -instance Foldable Rouge where-  foldMap f (Rouge xs) = foldMap f xs-  foldl f x (Rouge xs) = foldl f x xs-  foldl' f x (Rouge xs) = foldl f x xs-  foldr' f x (Rouge xs) = foldr f x xs+-- Note: when using base < 4.6, the Rogue type does+-- not really test anything.+instance Foldable Rogue where+  foldMap f (Rogue xs) = F.foldMap f xs+  foldl f x (Rogue xs) = F.foldl f x xs+#if MIN_VERSION_base(4,6,0)+  foldl' f x (Rogue xs) = F.foldl f x xs+  foldr' f x (Rogue xs) = F.foldr f x xs+#endif +newtype BadList a = BadList [a]+  deriving+  ( Eq, Show, Arbitrary+  , Arbitrary1, Eq1, Show1+  , Traversable, Functor, MonadZip, Monad, Applicative, MonadPlus, Alternative+  )++instance Foldable BadList where+  foldMap f (BadList xs) = F.foldMap f xs+  fold (BadList xs) = fold (reverse xs)++newtype Pound k v = Pound { getPound :: Map k v }+  deriving+  ( Eq, Functor, Show, Arbitrary+#if HAVE_UNARY_LAWS+  , Arbitrary1+  -- The following instances are only available for the variants+  -- of the type classes in base, not for those in transformers.+#if MIN_VERSION_base(4,9,0) && MIN_VERSION_containers(0,5,9)+  , Eq1+  , Show1+#endif+#endif+  )++#if HAVE_SEMIGROUPOIDS+#if MIN_VERSION_containers(0,5,9)+instance Ord k => Apply (Pound k) where+  Pound m1 <.> Pound m2 = Pound $+    MM.merge+      MM.dropMissing+      MM.dropMissing+      (MM.zipWithMatched (\_ f a -> f a))+      m1+      m2+#endif+#endif++#if HAVE_SEMIGROUPOIDS+#if MIN_VERSION_containers(0,5,9)+prop_map_apply_equals :: Map Int (Int -> Int)+                      -> Map Int Int+                      -> Bool+prop_map_apply_equals mf ma =+  let pf = Pound mf+      pa = Pound ma+      m = mf <.> ma+      p = pf <.> pa+  in m == (getPound p)+#endif+#endif+ ------------------- -- Orphan Instances -------------------@@ -79,3 +263,14 @@   arbitrary = V.fromList <$> arbitrary   shrink v = map V.fromList (shrink (V.toList v)) +#if !MIN_VERSION_QuickCheck(2,8,2)+instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where+  arbitrary = M.fromList <$> arbitrary+  shrink m = map M.fromList (shrink (M.toList m))+#endif++#if !MIN_VERSION_QuickCheck(2,9,0)+instance Arbitrary a => Arbitrary (Sum a) where+  arbitrary = Sum <$> arbitrary+  shrink = map Sum . shrink . getSum+#endif
+ test/Spec/ShowRead.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wall #-}++module Spec.ShowRead where++import Control.Applicative (liftA2)+import Data.Complex (Complex)+import Data.Fixed (E0, E1, E12, Fixed, HasResolution)+import Data.Int (Int64, Int8)+import Data.Orphans ()+import Data.Proxy (Proxy(Proxy))+import Data.Ratio (Ratio)+import Data.Word+import Test.QuickCheck (Arbitrary(arbitrary), elements)+#if MIN_VERSION_QuickCheck(2,8,2)+import Data.IntMap (IntMap)+import Data.IntSet (IntSet)+import Data.Map (Map)+import Data.Sequence (Seq)+import Data.Set (Set)+#endif+#if MIN_VERSION_QuickCheck(2,9,0)+import Control.Applicative (Const, ZipList)+import Data.Functor.Constant (Constant)+import Data.Functor.Identity (Identity)+import Data.Version (Version)+#endif+#if MIN_VERSION_QuickCheck(2,10,0)+import Data.Functor.Compose (Compose)+import Data.Functor.Product (Product)+#endif++import Test.QuickCheck.Classes++data Prefix = Prefix | Prefix' | Prefix_+  deriving (Eq, Read, Show)++instance Arbitrary Prefix where+  arbitrary = elements [Prefix, Prefix', Prefix_]++data WeirdRecord = (:*) { left :: Int, right :: Int }+  deriving (Eq, Read, Show)++instance Arbitrary WeirdRecord where+  arbitrary = liftA2 (:*) arbitrary arbitrary++lawsApplied :: [(String,[Laws])]+lawsApplied =+  [ -- local+    ("Prefix",         allShowReadLaws (Proxy :: Proxy Prefix))+  , ("WeirdRecord",    allShowReadLaws (Proxy :: Proxy WeirdRecord))++    -- base+  , ("()",             allShowReadLaws (Proxy :: Proxy ()))+  , ("Bool",           allShowReadLaws (Proxy :: Proxy Bool))+  , ("Char",           allShowReadLaws (Proxy :: Proxy Char))+  , ("Complex Float",  allShowReadLaws (Proxy :: Proxy (Complex Float)))+  , ("Complex Double", allShowReadLaws (Proxy :: Proxy (Complex Double)))+  , ("Double",         allShowReadLaws (Proxy :: Proxy Double))+  , ("Either",         allShowReadLaws (Proxy :: Proxy (Either Int Int)))+  , ("Fixed E12",      allFixedLaws (Proxy :: Proxy (Fixed E12)))+  -- , ("Fixed E9",       allFixedLaws (Proxy :: Proxy (Fixed E9)))+  -- , ("Fixed E6",       allFixedLaws (Proxy :: Proxy (Fixed E6)))+  -- , ("Fixed E3",       allFixedLaws (Proxy :: Proxy (Fixed E3)))+  -- , ("Fixed E2",       allFixedLaws (Proxy :: Proxy (Fixed E2)))+  , ("Fixed E1",       allFixedLaws (Proxy :: Proxy (Fixed E1)))+  , ("Fixed E0",       allFixedLaws (Proxy :: Proxy (Fixed E0)))+  , ("Float",          allShowReadLaws (Proxy :: Proxy Float))+  , ("Int",            allShowReadLaws (Proxy :: Proxy Int))+  -- , ("Int16",          allShowReadLaws (Proxy :: Proxy Int16))+  -- , ("Int32",          allShowReadLaws (Proxy :: Proxy Int32))+  , ("Int64",          allShowReadLaws (Proxy :: Proxy Int64))+  , ("Int8",           allShowReadLaws (Proxy :: Proxy Int8))+  , ("Integer",        allShowReadLaws (Proxy :: Proxy Integer))+  , ("List",           allShowReadLaws (Proxy :: Proxy [Int]))+  , ("Maybe",          allShowReadLaws (Proxy :: Proxy (Maybe Int)))+  , ("Ordering",       allShowReadLaws (Proxy :: Proxy Ordering))+  , ("Ratio",          allShowReadLaws (Proxy :: Proxy (Ratio Int)))+  , ("Tuple2",         allShowReadLaws (Proxy :: Proxy (Int,Int)))+  , ("Tuple3",         allShowReadLaws (Proxy :: Proxy (Int,Int,Int)))+  , ("Word",           allShowReadLaws (Proxy :: Proxy Word))+  -- , ("Word16",         allShowReadLaws (Proxy :: Proxy Word16))+  -- , ("Word32",         allShowReadLaws (Proxy :: Proxy Word32))+  , ("Word64",         allShowReadLaws (Proxy :: Proxy Word64))+  , ("Word8",          allShowReadLaws (Proxy :: Proxy Word8))+#if MIN_VERSION_QuickCheck(2,9,0)+  , ("Const",          allShowReadLaws (Proxy :: Proxy (Const Int Int)))+  , ("Constant",       allShowReadLaws (Proxy :: Proxy (Constant Int Int)))+  , ("Identity",       allShowReadLaws (Proxy :: Proxy (Identity Int)))+  , ("Version",        allShowReadLaws (Proxy :: Proxy Version))+  , ("ZipList",        allShowReadLaws (Proxy :: Proxy (ZipList Int)))+#endif+#if MIN_VERSION_QuickCheck(2,10,0)+  , ("Compose",        allShowReadLaws (Proxy :: Proxy (Compose [] Maybe Int)))+  , ("Product",        allShowReadLaws (Proxy :: Proxy (Product [] Maybe Int)))+#endif++  -- containers+#if MIN_VERSION_QuickCheck(2,8,2)+  , ("IntMap",         allShowReadLaws (Proxy :: Proxy (IntMap Int)))+  , ("IntSet",         allShowReadLaws (Proxy :: Proxy IntSet))+  , ("Map",            allShowReadLaws (Proxy :: Proxy (Map Int Int)))+  , ("Seq",            allShowReadLaws (Proxy :: Proxy (Seq Int)))+  , ("Set",            allShowReadLaws (Proxy :: Proxy (Set Int)))+#endif+  ]++allShowReadLaws :: (Show a, Read a, Eq a, Arbitrary a) => Proxy a -> [Laws]+allShowReadLaws p = map ($p)+  [ showLaws+  , showReadLaws+  ]++allFixedLaws :: HasResolution e => Proxy (Fixed e) -> [Laws]+allFixedLaws p = map ($p)+  [ showLaws+#if MIN_VERSION_base(4,7,0)+  -- Earlier versions of base have a buggy read instance.+  , showReadLaws+#endif+  ]