quickcheck-classes-0.6.5.0/0000755000000000000000000000000007346545000013616 5ustar0000000000000000quickcheck-classes-0.6.5.0/LICENSE0000644000000000000000000000276207346545000014632 0ustar0000000000000000Copyright Andrew Martin (c) 2017 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Andrew Martin nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.quickcheck-classes-0.6.5.0/README.md0000755000000000000000000000460107346545000015101 0ustar0000000000000000# 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. ``` quickcheck-classes-0.6.5.0/changelog.md0000755000000000000000000001725607346545000016105 0ustar0000000000000000# 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-0.6.5.0/quickcheck-classes.cabal0000644000000000000000000001357507346545000020362 0ustar0000000000000000cabal-version: 2.4 name: quickcheck-classes version: 0.6.5.0 synopsis: QuickCheck common typeclasses description: 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: BSD-3-Clause license-file: LICENSE author: Andrew Martin, chessai maintainer: andrew.thaddeus@gmail.com copyright: 2018 Andrew Martin category: Testing build-type: Simple extra-source-files: README.md 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.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 , containers , primitive , 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 -- 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: Advanced.hs ghc-options: -O2 build-depends: , QuickCheck , base >= 4.12 , base-orphans >= 0.5 , containers , primitive , quickcheck-classes , tagged , tasty , tasty-quickcheck , transformers , vector if impl(ghc < 8.6) buildable: False default-language: Haskell2010 source-repository head type: git location: https://github.com/andrewthad/quickcheck-classes quickcheck-classes-0.6.5.0/src/Test/QuickCheck/0000755000000000000000000000000007346545000017336 5ustar0000000000000000quickcheck-classes-0.6.5.0/src/Test/QuickCheck/Classes.hs0000644000000000000000000000561707346545000021300 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# OPTIONS_GHC -Wall #-} {-| 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 QCB.lawsCheck , QCB.lawsCheckMany , QCB.lawsCheckOne -- * Properties -- ** 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 #endif , QCB.monoidLaws , QCB.commutativeMonoidLaws , QCB.semigroupMonoidLaws , QCB.ordLaws , QCB.enumLaws , QCB.boundedEnumLaws , primLaws , 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 , QCB.Laws(..) , QCB.Proxy1(..) , QCB.Proxy2(..) ) where -- -- re-exports -- -- 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 #if HAVE_VECTOR import Test.QuickCheck.Classes.MVector #endif import qualified Test.QuickCheck.Classes.Base as QCB quickcheck-classes-0.6.5.0/src/Test/QuickCheck/Classes/0000755000000000000000000000000007346545000020733 5ustar0000000000000000quickcheck-classes-0.6.5.0/src/Test/QuickCheck/Classes/Alt.hs0000644000000000000000000000404607346545000022013 0ustar0000000000000000{-# 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 quickcheck-classes-0.6.5.0/src/Test/QuickCheck/Classes/Apply.hs0000644000000000000000000000424007346545000022354 0ustar0000000000000000{-# 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 quickcheck-classes-0.6.5.0/src/Test/QuickCheck/Classes/Euclidean.hs0000644000000000000000000001104307346545000023157 0ustar0000000000000000-- | -- 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 quickcheck-classes-0.6.5.0/src/Test/QuickCheck/Classes/IsList.hs0000644000000000000000000000041207346545000022473 0ustar0000000000000000module 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 quickcheck-classes-0.6.5.0/src/Test/QuickCheck/Classes/Json.hs0000644000000000000000000000423707346545000022206 0ustar0000000000000000{-# 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 quickcheck-classes-0.6.5.0/src/Test/QuickCheck/Classes/MVector.hs0000644000000000000000000003323607346545000022655 0ustar0000000000000000-- | -- 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 quickcheck-classes-0.6.5.0/src/Test/QuickCheck/Classes/Plus.hs0000644000000000000000000000570707346545000022223 0ustar0000000000000000{-# 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 quickcheck-classes-0.6.5.0/src/Test/QuickCheck/Classes/Prim.hs0000644000000000000000000003262007346545000022201 0ustar0000000000000000{-# 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 quickcheck-classes-0.6.5.0/src/Test/QuickCheck/Classes/Ring.hs0000644000000000000000000000203607346545000022167 0ustar0000000000000000{-# 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 quickcheck-classes-0.6.5.0/src/Test/QuickCheck/Classes/Semigroupoid.hs0000644000000000000000000000572507346545000023746 0ustar0000000000000000{-# 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 quickcheck-classes-0.6.5.0/src/Test/QuickCheck/Classes/Semiring.hs0000644000000000000000000001564107346545000023053 0ustar0000000000000000{-# 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 quickcheck-classes-0.6.5.0/test/0000755000000000000000000000000007346545000014575 5ustar0000000000000000quickcheck-classes-0.6.5.0/test/Advanced.hs0000644000000000000000000001364007346545000016642 0ustar0000000000000000{-# 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' ()])) quickcheck-classes-0.6.5.0/test/Spec.hs0000644000000000000000000001475507346545000016037 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif import Control.Monad 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.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 #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 = do #if HAVE_SEMIGROUPOIDS #if MIN_VERSION_containers(0,5,9) quickCheck prop_map_apply_equals #endif #endif lawsCheckMany allPropsApplied allPropsApplied :: [(String,[Laws])] allPropsApplied = M.toList . M.fromListWith (++) $ [ ("Int",allLaws (Proxy :: Proxy Int)) , ("Int64",allLaws (Proxy :: Proxy Int64)) , ("Word",allLaws (Proxy :: Proxy Word)) #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 #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. ( 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)) , 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 -> liftM (mappend b) (f a)) mempty #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 #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 Rogue a = Rogue [a] deriving ( Eq, Show, Arbitrary #if HAVE_UNARY_LAWS , Arbitrary1 , Eq1 , Show1 #endif ) -- 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 ------------------- instance Arbitrary a => Arbitrary (Vector a) where 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 quickcheck-classes-0.6.5.0/test/Spec/0000755000000000000000000000000007346545000015467 5ustar0000000000000000quickcheck-classes-0.6.5.0/test/Spec/ShowRead.hs0000644000000000000000000001143007346545000017536 0ustar0000000000000000{-# 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 ]