├── quickcheck-classes ├── test │ ├── Basic.hs │ ├── Spec │ │ └── ShowRead.hs │ ├── Advanced.hs │ └── Spec.hs ├── src │ └── Test │ │ └── QuickCheck │ │ ├── Classes │ │ ├── IsList.hs │ │ ├── Ring.hs │ │ ├── Alt.hs │ │ ├── Apply.hs │ │ ├── Json.hs │ │ ├── Semigroupoid.hs │ │ ├── Plus.hs │ │ ├── Euclidean.hs │ │ ├── Semiring.hs │ │ └── Prim.hs │ │ └── Classes.hs ├── LICENSE ├── README.md ├── quickcheck-classes.cabal └── changelog.md ├── Setup.hs ├── cabal.project ├── README.md ├── projects ├── ghc-8-4-3-no-semigroupoids.project ├── ghc-7-10-3-transformers-0-5-5-0.project ├── ghc-8-4-3-containers-0-6-quickcheck-2-9.project ├── ghc-7-4-2-transformers-0-4-1-0.project ├── ghc-7-10-3-transformers-0-4-1-0.project ├── ghc-7-8-4-transformers-0-3-0-0.project ├── ghc-7-10-3-no-semigroupoids.project ├── ghc-7-10-3-transformers-0-5-containers-0-6-quickcheck-2-12.project └── ghc-7-8-4-transformers-0-3-containers-0-5-9.project ├── stack.yaml ├── .gitignore ├── .github └── workflows │ └── haskell.yaml └── quickcheck-classes-base ├── changelog.md ├── LICENSE ├── src └── Test │ └── QuickCheck │ └── Classes │ ├── Ord.hs │ ├── MonadFail.hs │ ├── Show.hs │ ├── Ix.hs │ ├── MonadZip.hs │ ├── Arrow.hs │ ├── Contravariant.hs │ ├── Eq.hs │ ├── Functor.hs │ ├── Alternative.hs │ ├── Integral.hs │ ├── Enum.hs │ ├── Bifunctor.hs │ ├── ShowRead.hs │ ├── Bitraversable.hs │ ├── MonadPlus.hs │ ├── Monoid.hs │ ├── Monad.hs │ ├── Traversable.hs │ ├── Generic.hs │ ├── Applicative.hs │ ├── Category.hs │ ├── Storable.hs │ ├── Bifoldable.hs │ ├── Semigroup.hs │ ├── Num.hs │ ├── Foldable.hs │ ├── Bits.hs │ ├── Base.hs │ └── Base │ └── IsList.hs └── quickcheck-classes-base.cabal /quickcheck-classes/test/Basic.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./quickcheck-classes ./quickcheck-classes-base 2 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # quickcheck-classes 2 | 3 | [QuickCheck](https://hackage.haskell.org/package/QuickCheck) properties for common typeclasses 4 | -------------------------------------------------------------------------------- /projects/ghc-8-4-3-no-semigroupoids.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | with-compiler: ghc-8.4.3 3 | flags: 4 | quickcheck-classes -semigroupoids 5 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.2 2 | packages: 3 | - quickcheck-classes-base 4 | - quickcheck-classes 5 | extra-deps: 6 | - primitive-addr-0.1.0.2 7 | -------------------------------------------------------------------------------- /projects/ghc-7-10-3-transformers-0-5-5-0.project: -------------------------------------------------------------------------------- 1 | packages: quickcheck-classes.cabal 2 | with-compiler: ghc-7.10.3 3 | 4 | constraints: 5 | transformers ==0.5.5.0 6 | -------------------------------------------------------------------------------- /projects/ghc-8-4-3-containers-0-6-quickcheck-2-9.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | with-compiler: ghc-8.4.3 3 | 4 | constraints: 5 | containers ==0.6.* 6 | , QuickCheck ==2.9.* 7 | -------------------------------------------------------------------------------- /projects/ghc-7-4-2-transformers-0-4-1-0.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | with-compiler: /opt/ghc/7.4.2/bin/ghc 3 | 4 | constraints: 5 | transformers ==0.4.1.0 6 | , transformers-compat ==0.5.1.4 7 | -------------------------------------------------------------------------------- /projects/ghc-7-10-3-transformers-0-4-1-0.project: -------------------------------------------------------------------------------- 1 | packages: quickcheck-classes.cabal 2 | with-compiler: ghc-7.10.3 3 | 4 | constraints: 5 | transformers ==0.4.1.0 6 | , transformers-compat ==0.5.1.4 7 | -------------------------------------------------------------------------------- /projects/ghc-7-8-4-transformers-0-3-0-0.project: -------------------------------------------------------------------------------- 1 | packages: quickcheck-classes.cabal 2 | with-compiler: ghc-7.8.4 3 | 4 | constraints: 5 | transformers ==0.3.0.0 6 | , transformers-compat ==0.5.1.3 7 | -------------------------------------------------------------------------------- /projects/ghc-7-10-3-no-semigroupoids.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | with-compiler: ghc-7.10.3 3 | flags: 4 | quickcheck-classes -semigroupoids 5 | constraints: 6 | transformers >= 0.5 7 | , QuickCheck >= 2.10 8 | -------------------------------------------------------------------------------- /projects/ghc-7-10-3-transformers-0-5-containers-0-6-quickcheck-2-12.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | with-compiler: ghc-7.10.3 3 | 4 | constraints: 5 | transformers == 0.5.* 6 | , containers == 0.6.* 7 | , QuickCheck == 2.12.* 8 | -------------------------------------------------------------------------------- /projects/ghc-7-8-4-transformers-0-3-containers-0-5-9.project: -------------------------------------------------------------------------------- 1 | packages: quickcheck-classes.cabal 2 | with-compiler: ghc-7.8.4 3 | 4 | constraints: 5 | transformers ==0.3.* 6 | , containers ==0.5.9.* 7 | 8 | package quickcheck-classes 9 | flags: -aeson 10 | -------------------------------------------------------------------------------- /quickcheck-classes/src/Test/QuickCheck/Classes/IsList.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickCheck.Classes.IsList 2 | ( module Test.QuickCheck.Classes.Base.IsList 3 | ) where 4 | 5 | -- It would be better to do this with Cabal's module reexport feature, 6 | -- but that would break compatibility with older GHCs. 7 | 8 | import Test.QuickCheck.Classes.Base.IsList 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.aux 2 | cabal-dev 3 | .cabal-sandbox 4 | cabal.config 5 | cabal.sandbox.config 6 | *.chi 7 | *.chs.h 8 | config/client_session_key.aes 9 | playground/ 10 | dist* 11 | .DS_Store 12 | *.dyn_hi 13 | *.dyn_o 14 | *.hi 15 | *.hp 16 | .hpc 17 | .ghci 18 | .hsenv* 19 | *.o 20 | *.prof 21 | *.sqlite3 22 | untracked/ 23 | uploads/ 24 | static/combined/ 25 | static/tmp/ 26 | *.swp 27 | .virtualenv 28 | .stack-work/ 29 | yesod-devel/ 30 | tmp/ 31 | config/client_session_key.aes 32 | playground/auth.txt 33 | **/*.dump-hi 34 | tags 35 | TAGS 36 | result* 37 | *.ghc* 38 | 39 | docs/db/unthreat 40 | -------------------------------------------------------------------------------- /.github/workflows/haskell.yaml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | - push 5 | - pull_request 6 | 7 | jobs: 8 | build: 9 | runs-on: ubuntu-latest 10 | strategy: 11 | fail-fast: false 12 | matrix: 13 | ghc: ['8.6', '8.8', '8.10', '9.0', '9.2', '9.4', '9.6', '9.8', '9.10', '9.12'] 14 | steps: 15 | - uses: actions/checkout@v4 16 | - uses: haskell-actions/setup@v2 17 | with: 18 | ghc-version: ${{ matrix.ghc }} 19 | - name: Build quickcheck-classes-base 20 | run: cabal build quickcheck-classes-base 21 | - name: Build quickcheck-classes 22 | run: cabal build quickcheck-classes 23 | - name: Test 24 | run: | 25 | cabal run quickcheck-classes:basic 26 | cabal run quickcheck-classes:advanced 27 | -------------------------------------------------------------------------------- /quickcheck-classes/src/Test/QuickCheck/Classes/Ring.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | {-# OPTIONS_GHC -Wall #-} 5 | 6 | module Test.QuickCheck.Classes.Ring 7 | ( 8 | #if HAVE_SEMIRINGS 9 | ringLaws 10 | #endif 11 | ) where 12 | 13 | #if HAVE_SEMIRINGS 14 | import Data.Semiring 15 | import Prelude hiding (Num(..)) 16 | #endif 17 | 18 | import Data.Proxy (Proxy) 19 | import Test.QuickCheck hiding ((.&.)) 20 | 21 | import Test.QuickCheck.Classes.Internal (Laws(..), myForAllShrink) 22 | 23 | #if HAVE_SEMIRINGS 24 | -- | Tests the following properties: 25 | -- 26 | -- [/Additive Inverse/] 27 | -- @'negate' a '+' a ≡ 0@ 28 | -- 29 | -- Note that this does not test any of the laws tested by 'Test.QuickCheck.Classes.Semiring.semiringLaws'. 30 | ringLaws :: (Ring a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws 31 | ringLaws p = Laws "Ring" 32 | [ ("Additive Inverse", ringAdditiveInverse p) 33 | ] 34 | 35 | ringAdditiveInverse :: forall a. (Ring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 36 | ringAdditiveInverse _ = myForAllShrink True (const True) 37 | (\(a :: a) -> ["a = " ++ show a]) 38 | "negate a + a" 39 | (\a -> negate a + a) 40 | "0" 41 | (const zero) 42 | #endif 43 | -------------------------------------------------------------------------------- /quickcheck-classes-base/changelog.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | All notable changes to this project will be documented in this file. 3 | 4 | The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) 5 | and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). 6 | 7 | Note that since `quickcheck-classes` reexports larges parts of 8 | `quickcheck-classes-base`, changelog entries that deal with any of the 9 | classes from `base` are duplicated across the two changelogs. 10 | 11 | ## [0.6.2.0] - 2021-04-12 12 | 13 | - Storable Set-Set Law (resolves issue 101). 14 | - Trim unneeded dependencies (tagged, base-orphans) 15 | - Trim unneeded dependencies on newer GHCs (bifunctors, contravariant) 16 | 17 | ## [0.6.1.0] - 2020-09-09 18 | ### Added 19 | - Laws for `abs` and `signum` 20 | - Storable Set-Set Law (resolves issue 101). 21 | - Add laws for `quotRem` and `divMod`. 22 | - Use non-commutative monoid for bifoldable tests (resolves issue 98) 23 | - `substitutiveEqLaws`, which tests for Eq substitutivity. 24 | - Negation law check for `Eq`. 25 | - Document that users can provide their own `Laws`. 26 | 27 | ## [0.6.0.0] - 2019-08-08 28 | ### Added 29 | - Initial release. This factor out a subset of laws tests 30 | from `quickcheck-classes` and depend on this library that 31 | have a more minimal dependency footprint. 32 | - Add laws for left rotate and right rotate. 33 | - Add law that checks that subtraction is the same thing as 34 | adding the negation of a number. 35 | -------------------------------------------------------------------------------- /quickcheck-classes/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Andrew Martin (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Andrew Martin nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /quickcheck-classes-base/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Andrew Martin (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Andrew Martin nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Ord.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | {-# OPTIONS_GHC -Wall #-} 4 | 5 | module Test.QuickCheck.Classes.Ord 6 | ( ordLaws 7 | ) where 8 | 9 | import Data.Proxy (Proxy) 10 | import Test.QuickCheck hiding ((.&.)) 11 | 12 | import Test.QuickCheck.Classes.Internal (Laws(..)) 13 | 14 | -- | Tests the following properties: 15 | -- 16 | -- [/Antisymmetry/] 17 | -- @a ≤ b ∧ b ≤ a ⇒ a = b@ 18 | -- [/Transitivity/] 19 | -- @a ≤ b ∧ b ≤ c ⇒ a ≤ c@ 20 | -- [/Totality/] 21 | -- @a ≤ b ∨ a > b@ 22 | ordLaws :: (Ord a, Arbitrary a, Show a) => Proxy a -> Laws 23 | ordLaws p = Laws "Ord" 24 | [ ("Antisymmetry", ordAntisymmetric p) 25 | , ("Transitivity", ordTransitive p) 26 | , ("Totality", ordTotal p) 27 | ] 28 | 29 | ordAntisymmetric :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property 30 | ordAntisymmetric _ = property $ \(a :: a) b -> ((a <= b) && (b <= a)) == (a == b) 31 | 32 | ordTotal :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property 33 | ordTotal _ = property $ \(a :: a) b -> ((a <= b) || (b <= a)) == True 34 | 35 | -- Technically, this tests something a little stronger than it is supposed to. 36 | -- But that should be alright since this additional strength is implied by 37 | -- the rest of the Ord laws. 38 | ordTransitive :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property 39 | ordTransitive _ = property $ \(a :: a) b c -> case (compare a b, compare b c) of 40 | (LT,LT) -> a < c 41 | (LT,EQ) -> a < c 42 | (LT,GT) -> True 43 | (EQ,LT) -> a < c 44 | (EQ,EQ) -> a == c 45 | (EQ,GT) -> a > c 46 | (GT,LT) -> True 47 | (GT,EQ) -> a > c 48 | (GT,GT) -> a > c 49 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/MonadFail.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | #if HAVE_QUANTIFIED_CONSTRAINTS 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | #endif 7 | 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | module Test.QuickCheck.Classes.MonadFail 11 | ( 12 | #if HAVE_UNARY_LAWS 13 | monadFailLaws 14 | #endif 15 | ) where 16 | 17 | #if HAVE_UNARY_LAWS 18 | 19 | import Control.Applicative 20 | import Test.QuickCheck hiding ((.&.)) 21 | import Control.Monad (ap) 22 | import Test.QuickCheck.Arbitrary (Arbitrary1(..)) 23 | import Data.Functor.Classes (Eq1,Show1) 24 | import Prelude hiding (fail) 25 | import Control.Monad.Fail (MonadFail(..)) 26 | 27 | import Test.QuickCheck.Classes.Internal 28 | 29 | -- | Tests the following 'MonadFail' properties: 30 | -- 31 | -- [/Left Zero/] 32 | -- @'fail' s '>>=' f ≡ 'fail' s@ 33 | monadFailLaws :: forall proxy f. 34 | #if HAVE_QUANTIFIED_CONSTRAINTS 35 | (MonadFail f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 36 | #else 37 | (MonadFail f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) 38 | #endif 39 | => proxy f -> Laws 40 | monadFailLaws p = Laws "Monad" 41 | [ ("Left Zero", monadFailLeftZero p) 42 | ] 43 | 44 | monadFailLeftZero :: forall proxy f. 45 | #if HAVE_QUANTIFIED_CONSTRAINTS 46 | (MonadFail f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 47 | #else 48 | (MonadFail f, Functor f, Eq1 f, Show1 f, Arbitrary1 f) 49 | #endif 50 | => proxy f -> Property 51 | monadFailLeftZero _ = property $ \(k' :: LinearEquationM f) (s :: String) -> 52 | let k = runLinearEquationM k' 53 | in eq1 (fail s >>= k) (fail s) 54 | 55 | #endif 56 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Show.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# OPTIONS_GHC -Wall #-} 4 | 5 | {-| Module : Test.QuickCheck.Classes.Show 6 | Description : Properties for testing the properties of the Show type class. 7 | -} 8 | module Test.QuickCheck.Classes.Show 9 | ( showLaws 10 | ) where 11 | 12 | import Data.Proxy (Proxy) 13 | import Test.QuickCheck (Arbitrary, Property, property) 14 | 15 | import Test.QuickCheck.Classes.Internal (Laws(..), ShowReadPrecedence(..)) 16 | 17 | -- | Tests the following properties: 18 | -- 19 | -- [/Show/] 20 | -- @'show' a ≡ 'showsPrec' 0 a ""@ 21 | -- [/Equivariance: 'showsPrec'/] 22 | -- @'showsPrec' p a r '++' s ≡ 'showsPrec' p a (r '++' s)@ 23 | -- [/Equivariance: 'showList'/] 24 | -- @'showList' as r '++' s ≡ 'showList' as (r '++' s)@ 25 | -- 26 | showLaws :: (Show a, Arbitrary a) => Proxy a -> Laws 27 | showLaws p = Laws "Show" 28 | [ ("Show", showShowsPrecZero p) 29 | , ("Equivariance: showsPrec", equivarianceShowsPrec p) 30 | , ("Equivariance: showList", equivarianceShowList p) 31 | ] 32 | 33 | showShowsPrecZero :: forall a. (Show a, Arbitrary a) => Proxy a -> Property 34 | showShowsPrecZero _ = 35 | property $ \(a :: a) -> 36 | show a == showsPrec 0 a "" 37 | 38 | equivarianceShowsPrec :: forall a. 39 | (Show a, Arbitrary a) => Proxy a -> Property 40 | equivarianceShowsPrec _ = 41 | property $ \(ShowReadPrecedence p) (a :: a) (r :: String) (s :: String) -> 42 | showsPrec p a r ++ s == showsPrec p a (r ++ s) 43 | 44 | equivarianceShowList :: forall a. 45 | (Show a, Arbitrary a) => Proxy a -> Property 46 | equivarianceShowList _ = 47 | property $ \(as :: [a]) (r :: String) (s :: String) -> 48 | showList as r ++ s == showList as (r ++ s) 49 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Ix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | {-# OPTIONS_GHC -Wall #-} 4 | 5 | module Test.QuickCheck.Classes.Ix 6 | ( ixLaws 7 | ) where 8 | 9 | import Data.Ix (Ix(..)) 10 | import Data.Proxy (Proxy) 11 | import Test.QuickCheck hiding ((.&.)) 12 | 13 | import Test.QuickCheck.Classes.Internal (Laws(..)) 14 | 15 | -- | Tests the various 'Ix' properties: 16 | -- 17 | -- @'inRange' (l,u) i '==' 'elem' i ('range' (l,u))@ 18 | -- 19 | -- @'range' (l,u) '!!' 'index' (l,u) i '==' i@, when @'inRange' (l,u) i@ 20 | -- 21 | -- @'map' ('index' (l,u)) ('range' (l,u)) '==' [0 .. 'rangeSize' (l,u) - 1]@ 22 | -- 23 | -- @'rangeSize' (l,u) '==' 'length' ('range' (l,u))@ 24 | ixLaws :: (Ix a, Arbitrary a, Show a) => Proxy a -> Laws 25 | ixLaws p = Laws "Ix" 26 | [ ("InRange", ixInRange p) 27 | , ("RangeIndex", ixRangeIndex p) 28 | , ("MapIndexRange", ixMapIndexRange p) 29 | , ("RangeSize", ixRangeSize p) 30 | ] 31 | 32 | ixInRange :: forall a. (Show a, Ix a, Arbitrary a) => Proxy a -> Property 33 | ixInRange _ = property $ \(l :: a) (u :: a) (i :: a) -> (l <= u) ==> do 34 | inRange (l,u) i == elem i (range (l,u)) 35 | 36 | ixRangeIndex :: forall a. (Show a, Ix a, Arbitrary a) => Proxy a -> Property 37 | ixRangeIndex _ = property $ \(l :: a) (u :: a) (i :: a) -> ((l <= u) && (i >= l && i <= u)) ==> do 38 | range (l,u) !! index (l,u) i == i 39 | 40 | ixMapIndexRange :: forall a. (Show a, Ix a, Arbitrary a) => Proxy a -> Property 41 | ixMapIndexRange _ = property $ \(l :: a) (u :: a) -> (l <= u) ==> do 42 | map (index (l,u)) (range (l,u)) == [0 .. rangeSize (l,u) - 1] 43 | 44 | ixRangeSize :: forall a. (Show a, Ix a, Arbitrary a) => Proxy a -> Property 45 | ixRangeSize _ = property $ \(l :: a) (u :: a) -> (l <= u) ==> do 46 | rangeSize (l,u) == length (range (l,u)) 47 | 48 | 49 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/MonadZip.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | #if HAVE_QUANTIFIED_CONSTRAINTS 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | #endif 7 | 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | module Test.QuickCheck.Classes.MonadZip 11 | ( 12 | #if HAVE_UNARY_LAWS 13 | monadZipLaws 14 | #endif 15 | ) where 16 | 17 | import Control.Applicative 18 | import Control.Arrow (Arrow(..)) 19 | import Control.Monad.Zip (MonadZip(mzip)) 20 | import Test.QuickCheck hiding ((.&.)) 21 | import Control.Monad (liftM) 22 | #if HAVE_UNARY_LAWS 23 | import Test.QuickCheck.Arbitrary (Arbitrary1(..)) 24 | import Data.Functor.Classes (Eq1,Show1) 25 | #endif 26 | 27 | import Test.QuickCheck.Classes.Internal 28 | 29 | #if HAVE_UNARY_LAWS 30 | 31 | -- | Tests the following monadic zipping properties: 32 | -- 33 | -- [/Naturality/] 34 | -- @'liftM' (f '***' g) ('mzip' ma mb) = 'mzip' ('liftM' f ma) ('liftM' g mb)@ 35 | -- 36 | -- In the laws above, the infix function @'***'@ refers to a typeclass 37 | -- method of 'Arrow'. 38 | monadZipLaws :: 39 | #if HAVE_QUANTIFIED_CONSTRAINTS 40 | (MonadZip f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 41 | #else 42 | (MonadZip f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) 43 | #endif 44 | => proxy f -> Laws 45 | monadZipLaws p = Laws "MonadZip" 46 | [ ("Naturality", monadZipNaturality p) 47 | ] 48 | 49 | monadZipNaturality :: forall proxy f. 50 | #if HAVE_QUANTIFIED_CONSTRAINTS 51 | (MonadZip f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 52 | #else 53 | (MonadZip f, Functor f, Eq1 f, Show1 f, Arbitrary1 f) 54 | #endif 55 | => proxy f -> Property 56 | monadZipNaturality _ = property $ \(f' :: LinearEquation) (g' :: LinearEquation) (Apply (ma :: f Integer)) (Apply (mb :: f Integer)) -> 57 | let f = runLinearEquation f' 58 | g = runLinearEquation g' 59 | in eq1 (liftM (f *** g) (mzip ma mb)) (mzip (liftM f ma) (liftM g mb)) 60 | 61 | #endif 62 | -------------------------------------------------------------------------------- /quickcheck-classes/src/Test/QuickCheck/Classes/Alt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | #if HAVE_QUANTIFIED_CONSTRAINTS 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | #endif 7 | 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | module Test.QuickCheck.Classes.Alt 11 | ( 12 | #if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS) 13 | altLaws 14 | #endif 15 | ) where 16 | 17 | #if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS) 18 | import Data.Functor 19 | import Data.Functor.Alt (Alt) 20 | import qualified Data.Functor.Alt as Alt 21 | import Test.QuickCheck hiding ((.&.)) 22 | import Test.QuickCheck.Arbitrary (Arbitrary1(..)) 23 | import Data.Functor.Classes (Eq1,Show1) 24 | 25 | import Test.QuickCheck.Classes.Internal 26 | 27 | -- | Tests the following alt properties: 28 | -- 29 | -- [/Associativity/] 30 | -- @(a 'Alt.' b) 'Alt.' c ≡ a 'Alt.' (b 'Alt.' c)@ 31 | -- [/Left Distributivity/] 32 | -- @f '<$>' (a 'Alt.' b) ≡ (f '<$>' a) 'Alt.' (f '<$>' b)@ 33 | altLaws :: forall proxy f. 34 | #if HAVE_QUANTIFIED_CONSTRAINTS 35 | (Alt f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 36 | #else 37 | (Alt f, Eq1 f, Show1 f, Arbitrary1 f) 38 | #endif 39 | => proxy f -> Laws 40 | altLaws p = Laws "Alt" 41 | [ ("Associativity", altAssociative p) 42 | , ("Left Distributivity", altLeftDistributive p) 43 | ] 44 | 45 | altAssociative :: forall proxy f. 46 | #if HAVE_QUANTIFIED_CONSTRAINTS 47 | (Alt f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 48 | #else 49 | (Alt f, Eq1 f, Show1 f, Arbitrary1 f) 50 | #endif 51 | => proxy f -> Property 52 | 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)) 53 | 54 | altLeftDistributive :: forall proxy f. 55 | #if HAVE_QUANTIFIED_CONSTRAINTS 56 | (Alt f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 57 | #else 58 | (Alt f, Eq1 f, Show1 f, Arbitrary1 f) 59 | #endif 60 | => proxy f -> Property 61 | altLeftDistributive _ = property $ \(Apply (a :: f Integer)) (Apply (b :: f Integer)) -> eq1 (id <$> (a Alt. b)) ((id <$> a) Alt. (id <$> b)) 62 | #endif 63 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Arrow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | #if HAVE_QUANTIFIED_CONSTRAINTS 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | #endif 7 | 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | -- N.B.: This module is not currently built. 11 | module Test.QuickCheck.Classes.Arrow 12 | ( 13 | #if HAVE_BINARY_LAWS 14 | arrowLaws 15 | #endif 16 | ) where 17 | 18 | import Prelude hiding (id, (.)) 19 | import Control.Applicative 20 | import Control.Arrow (Arrow(..)) 21 | import Control.Category (Category(..), (>>>), (<<<)) 22 | import Test.QuickCheck hiding ((.&.)) 23 | #if HAVE_BINARY_LAWS 24 | import Data.Functor.Classes (Eq2,Show2) 25 | #endif 26 | 27 | import Test.QuickCheck.Classes.Internal 28 | 29 | #if HAVE_BINARY_LAWS 30 | 31 | -- | Tests the following 'Arrow' properties: 32 | -- [/Law1/] 33 | -- @'arr' 'id' ≡ 'id'@ 34 | -- [/Law2/] 35 | -- @'arr' (f '>>>' g) ≡ 'arr' f '>>>' 'arr' g@ 36 | -- [/Law3/] 37 | -- @'first' ('arr' f) ≡ 'arr' ('first' f)@ 38 | -- [/Law4/] 39 | -- @'first' (f '>>>' g) ≡ 'first' f >>> 'first' g@ 40 | -- [/Law5/] 41 | -- @'first' f '>>>' 'arr' 'fst' ≡ 'arr' 'fst' '>>>' f 42 | -- [/Law6/] 43 | -- @'first' f '>>>' 'arr' ('id' '***' g) ≡ 'arr' ('id' '***' g) '>>>' 'first' f@ 44 | -- [/Law7/] 45 | -- @'first' ('first' f) '>>>' 'arr' assoc ≡ 'arr' assoc '>>>' 'first' f@ 46 | -- 47 | -- where 48 | -- @assoc ((a,b),c) = (a,(b,c)) 49 | -- 50 | -- /Note/: This property test is only available when this package is built with 51 | -- @base-4.9+@ or @transformers-0.5+@. 52 | arrowLaws :: forall proxy f. 53 | #if HAVE_QUANTIFIED_CONSTRAINTS 54 | (Arrow f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 55 | #else 56 | (Arrow f, Eq2 f, Show2 f, Arbitrary2 f) 57 | #endif 58 | => proxy f -> Laws 59 | arrowLaws p = Laws "Arrow" 60 | [ ("Law1", arrowLaw1 p) 61 | ] 62 | 63 | arrowLaw1 :: forall proxy f. 64 | #if HAVE_QUANTIFIED_CONSTRAINTS 65 | (Arrow f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 66 | #else 67 | (Arrow f, Eq2 f, Show2 f, Arbitrary2 f) 68 | #endif 69 | => proxy f -> Property 70 | arrowLaw1 _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq2 (arr id x) (id x) 71 | 72 | #endif 73 | 74 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Contravariant.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | #if HAVE_QUANTIFIED_CONSTRAINTS 7 | {-# LANGUAGE QuantifiedConstraints #-} 8 | #endif 9 | 10 | {-# OPTIONS_GHC -Wall #-} 11 | 12 | module Test.QuickCheck.Classes.Contravariant 13 | ( 14 | #if HAVE_UNARY_LAWS 15 | contravariantLaws 16 | #endif 17 | ) where 18 | 19 | import Data.Functor.Contravariant 20 | import Test.QuickCheck hiding ((.&.)) 21 | #if HAVE_UNARY_LAWS 22 | import Test.QuickCheck.Arbitrary (Arbitrary1(..)) 23 | import Data.Functor.Classes (Eq1,Show1) 24 | #endif 25 | 26 | import Test.QuickCheck.Classes.Internal 27 | 28 | #if HAVE_UNARY_LAWS 29 | 30 | -- | Tests the following contravariant properties: 31 | -- 32 | -- [/Identity/] 33 | -- @'contramap' 'id' ≡ 'id'@ 34 | -- [/Composition/] 35 | -- @'contramap' f '.' 'contramap' g ≡ 'contramap' (g '.' f)@ 36 | contravariantLaws :: 37 | #if HAVE_QUANTIFIED_CONSTRAINTS 38 | (Contravariant f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 39 | #else 40 | (Contravariant f, Eq1 f, Show1 f, Arbitrary1 f) 41 | #endif 42 | => proxy f 43 | -> Laws 44 | contravariantLaws p = Laws "Contravariant" 45 | [ ("Identity", contravariantIdentity p) 46 | , ("Composition", contravariantComposition p) 47 | ] 48 | 49 | contravariantIdentity :: forall proxy f. 50 | #if HAVE_QUANTIFIED_CONSTRAINTS 51 | (Contravariant f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 52 | #else 53 | (Contravariant f, Eq1 f, Show1 f, Arbitrary1 f) 54 | #endif 55 | => proxy f -> Property 56 | contravariantIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (contramap id a) a 57 | 58 | contravariantComposition :: forall proxy f. 59 | #if HAVE_QUANTIFIED_CONSTRAINTS 60 | (Contravariant f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 61 | #else 62 | (Contravariant f, Eq1 f, Show1 f, Arbitrary1 f) 63 | #endif 64 | => proxy f -> Property 65 | contravariantComposition _ = property $ \(Apply (a :: f Integer)) (f' :: QuadraticEquation) (g' :: QuadraticEquation) -> do 66 | let f = runQuadraticEquation f' 67 | g = runQuadraticEquation g' 68 | eq1 (contramap f (contramap g a)) (contramap (g . f) a) 69 | 70 | #endif 71 | -------------------------------------------------------------------------------- /quickcheck-classes/src/Test/QuickCheck/Classes/Apply.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | #if HAVE_QUANTIFIED_CONSTRAINTS 6 | {-# LANGUAGE QuantifiedConstraints #-} 7 | #endif 8 | 9 | {-# OPTIONS_GHC -Wall #-} 10 | 11 | module Test.QuickCheck.Classes.Apply 12 | ( 13 | #if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS) 14 | applyLaws 15 | #endif 16 | ) where 17 | 18 | #if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS) 19 | import Data.Functor 20 | import qualified Data.Functor.Apply as FunctorApply 21 | import Test.QuickCheck hiding ((.&.)) 22 | import Test.QuickCheck.Arbitrary (Arbitrary1(..)) 23 | import Data.Functor.Classes (Eq1,Show1) 24 | 25 | import Test.QuickCheck.Classes.Internal 26 | 27 | type ApplyProp proxy f = 28 | #if HAVE_QUANTIFIED_CONSTRAINTS 29 | (FunctorApply.Apply f, forall x. Eq x => Eq (f x), forall x. Show x => Show (f x), forall x. Arbitrary x => Arbitrary (f x)) 30 | #else 31 | (FunctorApply.Apply f, Eq1 f, Show1 f, Arbitrary1 f) 32 | #endif 33 | => proxy f -> Property 34 | 35 | -- | Tests the following alt properties: 36 | -- 37 | -- [/LiftF2 (1)/] 38 | -- @('FunctorApply.<.>') ≡ 'FunctorApply.liftF2' 'id'@ 39 | -- [/Associativity/] 40 | -- @'fmap' ('.') u 'FunctorApply.<.>' v 'FunctorApply.<.>' w ≡ u 'FunctorApply.<.>' (v 'FunctorApply.<.>' w)@ 41 | applyLaws :: 42 | #if HAVE_QUANTIFIED_CONSTRAINTS 43 | (FunctorApply.Apply f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 44 | #else 45 | (FunctorApply.Apply f, Eq1 f, Show1 f, Arbitrary1 f) 46 | #endif 47 | => proxy f -> Laws 48 | applyLaws p = Laws "Apply" 49 | [ ("LiftF2 part 1", applyLiftF2_1 p) 50 | , ("Associativity", applyAssociativity p) 51 | ] 52 | 53 | applyLiftF2_1 :: forall proxy f. ApplyProp proxy f 54 | applyLiftF2_1 _ = property $ \(Apply (f' :: f QuadraticEquation)) (Apply (x :: f Integer)) -> 55 | let f = fmap runQuadraticEquation f' 56 | in eq1 (FunctorApply.liftF2 id f x) (f FunctorApply.<.> x) 57 | 58 | applyAssociativity :: forall proxy f. ApplyProp proxy f 59 | applyAssociativity _ = property $ \(Apply (u' :: f QuadraticEquation)) (Apply (v' :: f QuadraticEquation)) (Apply (w :: f Integer)) -> 60 | let u = fmap runQuadraticEquation u' 61 | v = fmap runQuadraticEquation v' 62 | in eq1 (fmap (.) u FunctorApply.<.> v FunctorApply.<.> w) (u FunctorApply.<.> (v FunctorApply.<.> w)) 63 | 64 | #endif 65 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Eq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | {-# OPTIONS_GHC -Wall #-} 4 | 5 | module Test.QuickCheck.Classes.Eq 6 | ( eqLaws 7 | , substitutiveEqLaws 8 | ) where 9 | 10 | import Data.Proxy (Proxy) 11 | import Test.QuickCheck hiding ((.&.)) 12 | import Test.QuickCheck.Function 13 | 14 | import Test.QuickCheck.Classes.Internal (Laws(..)) 15 | 16 | -- | Tests the following properties: 17 | -- 18 | -- [/Transitive/] 19 | -- @a '==' b ∧ b '==' c ⇒ a '==' c@ 20 | -- [/Symmetric/] 21 | -- @a '==' b ⇒ b '==' a@ 22 | -- [/Reflexive/] 23 | -- @a '==' a@ 24 | -- [/Negation/] 25 | -- @x '/=' y '==' 'not' (x '==' y)@ 26 | -- 27 | -- Some of these properties involve implication. In the case that 28 | -- the left hand side of the implication arrow does not hold, we 29 | -- do not retry. Consequently, these properties only end up being 30 | -- useful when the data type has a small number of inhabitants. 31 | eqLaws :: (Eq a, Arbitrary a, Show a) => Proxy a -> Laws 32 | eqLaws p = Laws "Eq" 33 | [ ("Transitive", eqTransitive p) 34 | , ("Symmetric", eqSymmetric p) 35 | , ("Reflexive", eqReflexive p) 36 | ] 37 | 38 | eqTransitive :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property 39 | eqTransitive _ = property $ \(a :: a) b c -> case a == b of 40 | True -> case b == c of 41 | True -> a == c 42 | False -> a /= c 43 | False -> case b == c of 44 | True -> a /= c 45 | False -> True 46 | 47 | eqSymmetric :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property 48 | eqSymmetric _ = property $ \(a :: a) b -> case a == b of 49 | True -> b == a 50 | False -> b /= a 51 | 52 | eqReflexive :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property 53 | eqReflexive _ = property $ \(a :: a) -> a == a 54 | 55 | eqNegation :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property 56 | eqNegation _ = property $ \(x :: a) y -> (x /= y) == not (x == y) 57 | 58 | -- | Tests the following properties: 59 | -- 60 | -- [/Substitutive/] 61 | -- @x '==' y ⇒ f x '==' f y@ 62 | -- 63 | -- /Note/: This does not test `eqLaws`. 64 | -- If you want to use this, You should use it in addition to `eqLaws`. 65 | substitutiveEqLaws :: forall a. (Eq a, Arbitrary a, CoArbitrary a, Function a, Show a) => Proxy a -> Laws 66 | substitutiveEqLaws _ = Laws "Eq" 67 | [ ("Substitutivity" 68 | , property $ \(x :: a) y (f :: Fun a Integer) -> 69 | x == y ==> applyFun f x == applyFun f y 70 | ) 71 | ] 72 | -------------------------------------------------------------------------------- /quickcheck-classes/src/Test/QuickCheck/Classes/Json.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | {-# OPTIONS_GHC -Wall #-} 5 | 6 | module Test.QuickCheck.Classes.Json 7 | ( 8 | #if HAVE_AESON 9 | jsonLaws 10 | #endif 11 | ) where 12 | 13 | import Data.Proxy (Proxy) 14 | import Test.QuickCheck hiding ((.&.)) 15 | import Test.QuickCheck.Property (Property(..)) 16 | 17 | #if HAVE_AESON 18 | import Data.Aeson (FromJSON(..), ToJSON(..)) 19 | import qualified Data.Aeson as AE 20 | #endif 21 | 22 | import Test.QuickCheck.Classes.Internal (Laws(..)) 23 | 24 | -- | Tests the following properties: 25 | -- 26 | -- [/Partial Isomorphism/] 27 | -- @decode . encode ≡ Just@ 28 | -- [/Encoding Equals Value/] 29 | -- @decode . encode ≡ Just . toJSON@ 30 | -- 31 | -- Note that in the second property, the type of decode is @ByteString -> Value@, 32 | -- not @ByteString -> a@ 33 | #if HAVE_AESON 34 | jsonLaws :: (ToJSON a, FromJSON a, Show a, Arbitrary a, Eq a) => Proxy a -> Laws 35 | jsonLaws p = Laws "ToJSON/FromJSON" 36 | [ ("Partial Isomorphism", jsonEncodingPartialIsomorphism p) 37 | , ("Encoding Equals Value", jsonEncodingEqualsValue p) 38 | ] 39 | 40 | -- TODO: improve the quality of the error message if 41 | -- something does not pass this test. 42 | jsonEncodingEqualsValue :: forall a. (ToJSON a, Show a, Arbitrary a) => Proxy a -> Property 43 | jsonEncodingEqualsValue _ = property $ \(a :: a) -> 44 | case AE.decode (AE.encode a) of 45 | Nothing -> False 46 | Just (v :: AE.Value) -> v == toJSON a 47 | 48 | jsonEncodingPartialIsomorphism :: forall a. (ToJSON a, FromJSON a, Show a, Eq a, Arbitrary a) => Proxy a -> Property 49 | jsonEncodingPartialIsomorphism _ = 50 | #if MIN_VERSION_QuickCheck(2,9,0) 51 | again $ 52 | #endif 53 | MkProperty $ 54 | arbitrary >>= \(x :: a) -> 55 | unProperty $ 56 | shrinking shrink x $ \x' -> 57 | let desc1 = "Just" 58 | desc2 = "Data.Aeson.decode . Data.Aeson.encode" 59 | name1 = "Data.Aeson.encode a" 60 | name2 = "Data.Aeson.decode (Data.Aeson.encode a)" 61 | b1 = AE.encode x' 62 | b2 = AE.decode (AE.encode x') 63 | sb1 = show b1 64 | sb2 = show b2 65 | description = " Description: " ++ desc1 ++ " == " ++ desc2 66 | err = description ++ "\n" ++ unlines (map (" " ++) (["a = " ++ show x'])) ++ " " ++ name1 ++ " = " ++ sb1 ++ "\n " ++ name2 ++ " = " ++ sb2 67 | in counterexample err (Just x' == b2) 68 | #endif 69 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Functor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | #if HAVE_QUANTIFIED_CONSTRAINTS 7 | {-# LANGUAGE QuantifiedConstraints #-} 8 | #endif 9 | 10 | {-# OPTIONS_GHC -Wall #-} 11 | 12 | module Test.QuickCheck.Classes.Functor 13 | ( 14 | #if HAVE_UNARY_LAWS 15 | functorLaws 16 | #endif 17 | ) where 18 | 19 | import Data.Functor 20 | import Test.QuickCheck hiding ((.&.)) 21 | #if HAVE_UNARY_LAWS 22 | import Test.QuickCheck.Arbitrary (Arbitrary1(..)) 23 | import Data.Functor.Classes (Eq1,Show1) 24 | #endif 25 | 26 | import Test.QuickCheck.Classes.Internal 27 | 28 | #if HAVE_UNARY_LAWS 29 | 30 | -- | Tests the following functor properties: 31 | -- 32 | -- [/Identity/] 33 | -- @'fmap' 'id' ≡ 'id'@ 34 | -- [/Composition/] 35 | -- @'fmap' (f '.' g) ≡ 'fmap' f '.' 'fmap' g@ 36 | -- [/Const/] 37 | -- @('<$') ≡ 'fmap' 'const'@ 38 | functorLaws :: 39 | #if HAVE_QUANTIFIED_CONSTRAINTS 40 | (Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 41 | #else 42 | (Functor f, Eq1 f, Show1 f, Arbitrary1 f) 43 | #endif 44 | => proxy f 45 | -> Laws 46 | functorLaws p = Laws "Functor" 47 | [ ("Identity", functorIdentity p) 48 | , ("Composition", functorComposition p) 49 | , ("Const", functorConst p) 50 | ] 51 | 52 | functorIdentity :: forall proxy f. 53 | #if HAVE_QUANTIFIED_CONSTRAINTS 54 | (Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 55 | #else 56 | (Functor f, Eq1 f, Show1 f, Arbitrary1 f) 57 | #endif 58 | => proxy f -> Property 59 | functorIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (fmap id a) a 60 | 61 | functorComposition :: forall proxy f. 62 | #if HAVE_QUANTIFIED_CONSTRAINTS 63 | (Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 64 | #else 65 | (Functor f, Eq1 f, Show1 f, Arbitrary1 f) 66 | #endif 67 | => proxy f -> Property 68 | functorComposition _ = property $ \(Apply (a :: f Integer)) -> 69 | eq1 (fmap func2 (fmap func1 a)) (fmap (func2 . func1) a) 70 | 71 | functorConst :: forall proxy f. 72 | #if HAVE_QUANTIFIED_CONSTRAINTS 73 | (Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 74 | #else 75 | (Functor f, Eq1 f, Show1 f, Arbitrary1 f) 76 | #endif 77 | => proxy f -> Property 78 | functorConst _ = property $ \(Apply (a :: f Integer)) -> 79 | eq1 (fmap (const 'X') a) ('X' <$ a) 80 | 81 | #endif 82 | 83 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Alternative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | #if HAVE_QUANTIFIED_CONSTRAINTS 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | #endif 7 | 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | module Test.QuickCheck.Classes.Alternative 11 | ( 12 | #if HAVE_UNARY_LAWS 13 | alternativeLaws 14 | #endif 15 | ) where 16 | 17 | import Control.Applicative (Alternative(..)) 18 | import Test.QuickCheck hiding ((.&.)) 19 | #if HAVE_UNARY_LAWS 20 | import Test.QuickCheck.Arbitrary (Arbitrary1(..)) 21 | import Data.Functor.Classes (Eq1,Show1) 22 | #endif 23 | 24 | import Test.QuickCheck.Classes.Internal 25 | 26 | #if HAVE_UNARY_LAWS 27 | 28 | -- | Tests the following alternative properties: 29 | -- 30 | -- [/Left Identity/] 31 | -- @'empty' '<|>' x ≡ x@ 32 | -- [/Right Identity/] 33 | -- @x '<|>' 'empty' ≡ x@ 34 | -- [/Associativity/] 35 | -- @a '<|>' (b '<|>' c) ≡ (a '<|>' b) '<|>' c)@ 36 | alternativeLaws :: 37 | #if HAVE_QUANTIFIED_CONSTRAINTS 38 | (Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 39 | #else 40 | (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) 41 | #endif 42 | => proxy f -> Laws 43 | alternativeLaws p = Laws "Alternative" 44 | [ ("Left Identity", alternativeLeftIdentity p) 45 | , ("Right Identity", alternativeRightIdentity p) 46 | , ("Associativity", alternativeAssociativity p) 47 | ] 48 | 49 | alternativeLeftIdentity :: forall proxy f. 50 | #if HAVE_QUANTIFIED_CONSTRAINTS 51 | (Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 52 | #else 53 | (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) 54 | #endif 55 | => proxy f -> Property 56 | alternativeLeftIdentity _ = property $ \(Apply (a :: f Integer)) -> (eq1 (empty <|> a) a) 57 | 58 | alternativeRightIdentity :: forall proxy f. 59 | #if HAVE_QUANTIFIED_CONSTRAINTS 60 | (Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 61 | #else 62 | (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) 63 | #endif 64 | => proxy f -> Property 65 | alternativeRightIdentity _ = property $ \(Apply (a :: f Integer)) -> (eq1 a (empty <|> a)) 66 | 67 | alternativeAssociativity :: forall proxy f. 68 | #if HAVE_QUANTIFIED_CONSTRAINTS 69 | (Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 70 | #else 71 | (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) 72 | #endif 73 | => proxy f -> Property 74 | alternativeAssociativity _ = property $ \(Apply (a :: f Integer)) (Apply (b :: f Integer)) (Apply (c :: f Integer)) -> eq1 (a <|> (b <|> c)) ((a <|> b) <|> c) 75 | 76 | #endif 77 | -------------------------------------------------------------------------------- /quickcheck-classes/README.md: -------------------------------------------------------------------------------- 1 | # quickcheck-classes 2 | 3 | This library provides sets of properties that should hold for common typeclasses, 4 | along with three (3) simple functions that you can use to test them. 5 | 6 | ### `lawsCheck`: 7 | 8 | A convenience function for testing properties in GHCi. 9 | For example, at GHCi: 10 | 11 | ```bash 12 | >>> lawsCheck (monoidLaws (Proxy :: Proxy Ordering)) 13 | Monoid: Associative +++ OK, passed 100 tests. 14 | Monoid: Left Identity +++ OK, passed 100 tests. 15 | Monoid: Right Identity +++ OK, passed 100 tests. 16 | ``` 17 | 18 | Assuming that the `Arbitrary` instance for `Ordering` is good, we now 19 | have confidence that the `Monoid` instance for `Ordering` satisfies 20 | the monoid laws. 21 | 22 | ### `lawsCheckMany`: 23 | 24 | A convenience function for checking multiple typeclass instances 25 | of multiple types. Consider the following Haskell source file: 26 | 27 | ```haskell 28 | import Data.Proxy (Proxy(..)) 29 | import Data.Map (Map) 30 | import Data.Set (Set) 31 | 32 | -- A 'Proxy' for 'Set' 'Int'. 33 | setInt :: Proxy (Set Int) 34 | setInt = Proxy 35 | 36 | -- A 'Proxy' for 'Map' 'Int' 'Int'. 37 | mapInt :: Proxy (Map Int Int) 38 | mapInt = Proxy 39 | 40 | myLaws :: Proxy a -> [Laws] 41 | myLaws p = [eqLaws p, monoidLaws p] 42 | 43 | namedTests :: [(String, [Laws])] 44 | namedTests = 45 | [ ("Set Int", myLaws setInt) 46 | , ("Map Int Int", myLaws mapInt) 47 | ] 48 | ``` 49 | 50 | Now, in GHCi: 51 | 52 | ```bash 53 | >>> lawsCheckMany namedTests 54 | 55 | Testing properties for common typeclasses 56 | ------------- 57 | -- Set Int -- 58 | ------------- 59 | 60 | Eq: Transitive +++ OK, passed 100 tests. 61 | Eq: Symmetric +++ OK, passed 100 tests. 62 | Eq: Reflexive +++ OK, passed 100 tests. 63 | Monoid: Associative +++ OK, passed 100 tests. 64 | Monoid: Left Identity +++ OK, passed 100 tests. 65 | Monoid: Right Identity +++ OK, passed 100 tests. 66 | Monoid: Concatenation +++ OK, passed 100 tests. 67 | 68 | ----------------- 69 | -- Map Int Int -- 70 | ----------------- 71 | 72 | Eq: Transitive +++ OK, passed 100 tests. 73 | Eq: Symmetric +++ OK, passed 100 tests. 74 | Eq: Reflexive +++ OK, passed 100 tests. 75 | Monoid: Associative +++ OK, passed 100 tests. 76 | Monoid: Left Identity +++ OK, passed 100 tests. 77 | Monoid: Right Identity +++ OK, passed 100 tests. 78 | Monoid: Concatenation +++ OK, passed 100 tests. 79 | 80 | ``` 81 | 82 | ### `lawsCheckOne` 83 | 84 | A convenience function that allows one to check many typeclass 85 | instances of the same type. 86 | 87 | For example, in GHCi: 88 | 89 | ```bash 90 | >>> lawsCheckOne (Proxy :: Proxy Word) [jsonLaws, showReadLaws] 91 | ToJSON/FromJSON: Encoding Equals Value +++ OK, passed 100 tests. 92 | ToJSON/FromJSON: Partial Isomorphism +++ OK, passed 100 tests. 93 | Show/Read: Partial Isomorphism +++ OK, passed 100 tests. 94 | ``` 95 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Integral.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | {-# OPTIONS_GHC -Wall #-} 4 | 5 | module Test.QuickCheck.Classes.Integral 6 | ( integralLaws 7 | ) where 8 | 9 | import Data.Proxy (Proxy) 10 | import Test.QuickCheck hiding ((.&.)) 11 | 12 | import Test.QuickCheck.Classes.Internal (Laws(..), myForAllShrink) 13 | 14 | -- | Tests the following properties: 15 | -- 16 | -- [/Quotient Remainder/] 17 | -- @(quot x y) * y + (rem x y) ≡ x@ 18 | -- [/Division Modulus/] 19 | -- @(div x y) * y + (mod x y) ≡ x@ 20 | -- [/Integer Roundtrip/] 21 | -- @fromInteger (toInteger x) ≡ x@ 22 | -- [/QuotRem is (Quot, Rem)/] 23 | -- @quotRem x y ≡ (quot x y, rem x y)@ 24 | -- [/DivMod is (Div, Mod)/] 25 | -- @divMod x y ≡ (div x y, mod x y)@ 26 | integralLaws :: (Integral a, Arbitrary a, Show a) => Proxy a -> Laws 27 | integralLaws p = Laws "Integral" 28 | [ ("Quotient Remainder", integralQuotientRemainder p) 29 | , ("Division Modulus", integralDivisionModulus p) 30 | , ("Integer Roundtrip", integralIntegerRoundtrip p) 31 | , ("QuotRem is (Quot, Rem)", integralQuotRem p) 32 | , ("DivMod is (Div, Mod)", integralDivMod p) 33 | ] 34 | 35 | integralQuotientRemainder :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property 36 | integralQuotientRemainder _ = myForAllShrink False (\(_,y) -> y /= 0) 37 | (\(x :: a, y) -> ["x = " ++ show x, "y = " ++ show y]) 38 | "(quot x y) * y + (rem x y)" 39 | (\(x,y) -> (quot x y) * y + (rem x y)) 40 | "x" 41 | (\(x,_) -> x) 42 | 43 | integralDivisionModulus :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property 44 | integralDivisionModulus _ = myForAllShrink False (\(_,y) -> y /= 0) 45 | (\(x :: a, y) -> ["x = " ++ show x, "y = " ++ show y]) 46 | "(div x y) * y + (mod x y)" 47 | (\(x,y) -> (div x y) * y + (mod x y)) 48 | "x" 49 | (\(x,_) -> x) 50 | 51 | integralIntegerRoundtrip :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property 52 | integralIntegerRoundtrip _ = myForAllShrink False (const True) 53 | (\(x :: a) -> ["x = " ++ show x]) 54 | "fromInteger (toInteger x)" 55 | (\x -> fromInteger (toInteger x)) 56 | "x" 57 | (\x -> x) 58 | 59 | integralQuotRem :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property 60 | integralQuotRem _ = myForAllShrink False (\(_,y) -> y /= 0) 61 | (\(x :: a, y) -> ["x = " ++ show x, "y = " ++ show y]) 62 | "quotRem x y" 63 | (\(x,y) -> quotRem x y) 64 | "(quot x y, rem x y)" 65 | (\(x,y) -> (quot x y, rem x y)) 66 | 67 | integralDivMod :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property 68 | integralDivMod _ = myForAllShrink False (\(_,y) -> y /= 0) 69 | (\(x :: a, y) -> ["x = " ++ show x, "y = " ++ show y]) 70 | "divMod x y" 71 | (\(x,y) -> divMod x y) 72 | "(div x y, mod x y)" 73 | (\(x,y) -> (div x y, mod x y)) 74 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Enum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | {-# OPTIONS_GHC -Wall #-} 4 | 5 | module Test.QuickCheck.Classes.Enum 6 | ( enumLaws 7 | , boundedEnumLaws 8 | ) where 9 | 10 | import Data.Proxy (Proxy) 11 | import Test.QuickCheck hiding ((.&.)) 12 | 13 | import Test.QuickCheck.Classes.Internal (Laws(..), myForAllShrink) 14 | 15 | -- | Tests the following properties: 16 | -- 17 | -- [/Succ Pred Identity/] 18 | -- @'succ' ('pred' x) ≡ x@ 19 | -- [/Pred Succ Identity/] 20 | -- @'pred' ('succ' x) ≡ x@ 21 | -- 22 | -- This only works for @Enum@ types that are not bounded, meaning 23 | -- that 'succ' and 'pred' must be total. This means that these property 24 | -- tests work correctly for types like 'Integer' but not for 'Int'. 25 | -- 26 | -- Sadly, there is not a good way to test 'fromEnum' and 'toEnum', 27 | -- since many types that have reasonable implementations for 'succ' 28 | -- and 'pred' have more inhabitants than 'Int' does. 29 | enumLaws :: (Enum a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws 30 | enumLaws p = Laws "Enum" 31 | [ ("Succ Pred Identity", succPredIdentity p) 32 | , ("Pred Succ Identity", predSuccIdentity p) 33 | ] 34 | 35 | -- | Tests the same properties as 'enumLaws' except that it requires 36 | -- the type to have a 'Bounded' instance. These tests avoid taking the 37 | -- successor of the maximum element or the predecessor of the minimal 38 | -- element. 39 | boundedEnumLaws :: (Enum a, Bounded a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws 40 | boundedEnumLaws p = Laws "Enum" 41 | [ ("Succ Pred Identity", succPredBoundedIdentity p) 42 | , ("Pred Succ Identity", predSuccBoundedIdentity p) 43 | ] 44 | 45 | succPredIdentity :: forall a. (Enum a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 46 | succPredIdentity _ = myForAllShrink False (const True) 47 | (\(a :: a) -> ["a = " ++ show a]) 48 | "succ (pred x)" 49 | (\a -> succ (pred a)) 50 | "x" 51 | (\a -> a) 52 | 53 | predSuccIdentity :: forall a. (Enum a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 54 | predSuccIdentity _ = myForAllShrink False (const True) 55 | (\(a :: a) -> ["a = " ++ show a]) 56 | "pred (succ x)" 57 | (\a -> pred (succ a)) 58 | "x" 59 | (\a -> a) 60 | 61 | succPredBoundedIdentity :: forall a. (Enum a, Bounded a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 62 | succPredBoundedIdentity _ = myForAllShrink False (\a -> a /= minBound) 63 | (\(a :: a) -> ["a = " ++ show a]) 64 | "succ (pred x)" 65 | (\a -> succ (pred a)) 66 | "x" 67 | (\a -> a) 68 | 69 | predSuccBoundedIdentity :: forall a. (Enum a, Bounded a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 70 | predSuccBoundedIdentity _ = myForAllShrink False (\a -> a /= maxBound) 71 | (\(a :: a) -> ["a = " ++ show a]) 72 | "pred (succ x)" 73 | (\a -> pred (succ a)) 74 | "x" 75 | (\a -> a) 76 | 77 | -------------------------------------------------------------------------------- /quickcheck-classes/src/Test/QuickCheck/Classes/Semigroupoid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | #if HAVE_QUANTIFIED_CONSTRAINTS 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | #endif 7 | 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | module Test.QuickCheck.Classes.Semigroupoid 11 | ( 12 | #if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_BINARY_LAWS) 13 | semigroupoidLaws 14 | , commutativeSemigroupoidLaws 15 | #endif 16 | ) where 17 | 18 | #if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_BINARY_LAWS) 19 | import Prelude hiding (id, (.)) 20 | import Data.Semigroupoid (Semigroupoid(..)) 21 | import Test.QuickCheck hiding ((.&.)) 22 | import Data.Functor.Classes (Eq2,Show2) 23 | 24 | import Test.QuickCheck.Classes.Internal 25 | 26 | -- | Tests the following 'Semigroupoid' properties: 27 | -- 28 | -- [/Associativity/] 29 | -- @f `'o'` (g `'o'` h) ≡ (f `'o'` g) `'o'` h@ 30 | -- 31 | -- /Note/: This property test is only available when this package is built with 32 | -- @base-4.9+@ or @transformers-0.5+@. 33 | semigroupoidLaws :: forall proxy s. 34 | #if HAVE_QUANTIFIED_CONSTRAINTS 35 | (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)) 36 | #else 37 | (Semigroupoid s, Eq2 s, Show2 s, Arbitrary2 s) 38 | #endif 39 | => proxy s -> Laws 40 | semigroupoidLaws p = Laws "Semigroupoid" 41 | [ ("Associativity", semigroupoidAssociativity p) 42 | ] 43 | 44 | -- | Tests everything from 'semigroupoidLaws' plus the following: 45 | -- 46 | -- [/Commutative/] 47 | -- @f `'o'` g ≡ g `'o'` f@ 48 | -- 49 | -- /Note/: This property test is only available when this package is built with 50 | -- @base-4.9+@ or @transformers-0.5+@. 51 | commutativeSemigroupoidLaws :: forall proxy s. 52 | #if HAVE_QUANTIFIED_CONSTRAINTS 53 | (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)) 54 | #else 55 | (Semigroupoid s, Eq2 s, Show2 s, Arbitrary2 s) 56 | #endif 57 | => proxy s -> Laws 58 | commutativeSemigroupoidLaws p = Laws "Commutative Semigroupoid" $ lawsProperties (semigroupoidLaws p) ++ 59 | [ ("Commutative", semigroupoidCommutativity p) 60 | ] 61 | 62 | semigroupoidAssociativity :: forall proxy s. 63 | #if HAVE_QUANTIFIED_CONSTRAINTS 64 | (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)) 65 | #else 66 | (Semigroupoid s, Eq2 s, Show2 s, Arbitrary2 s) 67 | #endif 68 | => proxy s -> Property 69 | 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) 70 | 71 | semigroupoidCommutativity :: forall proxy s. 72 | #if HAVE_QUANTIFIED_CONSTRAINTS 73 | (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)) 74 | #else 75 | (Semigroupoid s, Eq2 s, Show2 s, Arbitrary2 s) 76 | #endif 77 | => proxy s -> Property 78 | semigroupoidCommutativity _ = property $ \(Apply2 (f :: s Integer Integer)) (Apply2 (g :: s Integer Integer)) -> eq2 (f `o` g) (g `o` f) 79 | 80 | #endif 81 | -------------------------------------------------------------------------------- /quickcheck-classes/src/Test/QuickCheck/Classes/Plus.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | #if HAVE_QUANTIFIED_CONSTRAINTS 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | #endif 7 | 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | module Test.QuickCheck.Classes.Plus 11 | ( 12 | #if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS) 13 | plusLaws 14 | , extendedPlusLaws 15 | #endif 16 | ) where 17 | 18 | #if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS) 19 | import Data.Functor 20 | import Data.Functor.Alt (Alt) 21 | import Data.Functor.Plus (Plus) 22 | import qualified Data.Functor.Alt as Alt 23 | import qualified Data.Functor.Plus as Plus 24 | 25 | import Test.QuickCheck hiding ((.&.)) 26 | import Test.QuickCheck.Arbitrary (Arbitrary1(..)) 27 | import Data.Functor.Classes (Eq1,Show1) 28 | import qualified Control.Applicative as Alternative 29 | 30 | import Test.QuickCheck.Classes.Internal 31 | 32 | -- | Tests the following alt properties: 33 | -- 34 | -- [/Left Identity/] 35 | -- @'Plus.zero' 'Alt.' m ≡ m@ 36 | -- [/Right Identity/] 37 | -- @m 'Alt.' 'Plus.zero' ≡ m@ 38 | plusLaws :: forall proxy f. 39 | #if HAVE_QUANTIFIED_CONSTRAINTS 40 | (Plus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 41 | #else 42 | (Plus f, Eq1 f, Show1 f, Arbitrary1 f) 43 | #endif 44 | => proxy f -> Laws 45 | plusLaws p = Laws "Plus" 46 | [ ("Left Identity", plusLeftIdentity p) 47 | , ("Right Identity", plusRightIdentity p) 48 | ] 49 | 50 | -- | Tests everything from 'altLaws', plus the following: 51 | -- 52 | -- [/Congruency/] 53 | -- @'Plus.zero' ≡ 'Alternative.empty'@ 54 | extendedPlusLaws :: forall proxy f. 55 | #if HAVE_QUANTIFIED_CONSTRAINTS 56 | (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)) 57 | #else 58 | (Plus f, Alternative.Alternative f, Eq1 f, Show1 f, Arbitrary1 f) 59 | #endif 60 | => proxy f -> Laws 61 | extendedPlusLaws p = Laws "Plus extended to Alternative" $ lawsProperties (plusLaws p) ++ 62 | [ ("Congruency", extendedPlusLaw p) 63 | ] 64 | 65 | extendedPlusLaw :: forall proxy f. 66 | #if HAVE_QUANTIFIED_CONSTRAINTS 67 | (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)) 68 | #else 69 | (Plus f, Alternative.Alternative f, Eq1 f, Show1 f, Arbitrary1 f) 70 | #endif 71 | => proxy f -> Property 72 | extendedPlusLaw _ = property $ eq1 (Plus.zero :: f Integer) (Alternative.empty :: f Integer) 73 | 74 | plusLeftIdentity :: forall proxy f. 75 | #if HAVE_QUANTIFIED_CONSTRAINTS 76 | (Plus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 77 | #else 78 | (Plus f, Eq1 f, Show1 f, Arbitrary1 f) 79 | #endif 80 | => proxy f -> Property 81 | plusLeftIdentity _ = property $ \(Apply (m :: f Integer)) -> eq1 (Plus.zero Alt. m) m 82 | 83 | plusRightIdentity :: forall proxy f. 84 | #if HAVE_QUANTIFIED_CONSTRAINTS 85 | (Plus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 86 | #else 87 | (Plus f, Eq1 f, Show1 f, Arbitrary1 f) 88 | #endif 89 | => proxy f -> Property 90 | plusRightIdentity _ = property $ \(Apply (m :: f Integer)) -> eq1 (m Alt. Plus.zero) m 91 | 92 | #endif 93 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Bifunctor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | #if HAVE_QUANTIFIED_CONSTRAINTS 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | #endif 7 | 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | module Test.QuickCheck.Classes.Bifunctor 11 | ( 12 | #if HAVE_BINARY_LAWS 13 | bifunctorLaws 14 | #endif 15 | ) where 16 | 17 | import Data.Bifunctor(Bifunctor(..)) 18 | import Test.QuickCheck hiding ((.&.)) 19 | #if HAVE_BINARY_LAWS 20 | import Data.Functor.Classes (Eq2,Show2) 21 | #endif 22 | 23 | import Test.QuickCheck.Classes.Internal 24 | 25 | #if HAVE_BINARY_LAWS 26 | 27 | -- | Tests the following 'Bifunctor' properties: 28 | -- 29 | -- [/Identity/] 30 | -- @'bimap' 'id' 'id' ≡ 'id'@ 31 | -- [/First Identity/] 32 | -- @'first' 'id' ≡ 'id'@ 33 | -- [/Second Identity/] 34 | -- @'second' 'id' ≡ 'id'@ 35 | -- [/Bifunctor Composition/] 36 | -- @'bimap' f g ≡ 'first' f '.' 'second' g@ 37 | -- 38 | -- /Note/: This property test is only available when this package is built with 39 | -- @base-4.9+@ or @transformers-0.5+@. 40 | bifunctorLaws :: forall proxy f. 41 | #if HAVE_QUANTIFIED_CONSTRAINTS 42 | (Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 43 | #else 44 | (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) 45 | #endif 46 | => proxy f -> Laws 47 | bifunctorLaws p = Laws "Bifunctor" 48 | [ ("Identity", bifunctorIdentity p) 49 | , ("First Identity", bifunctorFirstIdentity p) 50 | , ("Second Identity", bifunctorSecondIdentity p) 51 | , ("Bifunctor Composition", bifunctorComposition p) 52 | ] 53 | 54 | bifunctorIdentity :: forall proxy f. 55 | #if HAVE_QUANTIFIED_CONSTRAINTS 56 | (Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 57 | #else 58 | (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) 59 | #endif 60 | => proxy f -> Property 61 | bifunctorIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq2 (bimap id id x) x 62 | 63 | bifunctorFirstIdentity :: forall proxy f. 64 | #if HAVE_QUANTIFIED_CONSTRAINTS 65 | (Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 66 | #else 67 | (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) 68 | #endif 69 | => proxy f -> Property 70 | bifunctorFirstIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq2 (first id x) x 71 | 72 | bifunctorSecondIdentity :: forall proxy f. 73 | #if HAVE_QUANTIFIED_CONSTRAINTS 74 | (Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 75 | #else 76 | (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) 77 | #endif 78 | => proxy f -> Property 79 | bifunctorSecondIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq2 (second id x) x 80 | 81 | bifunctorComposition :: forall proxy f. 82 | #if HAVE_QUANTIFIED_CONSTRAINTS 83 | (Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 84 | #else 85 | (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) 86 | #endif 87 | => proxy f -> Property 88 | bifunctorComposition _ = property $ \(Apply2 (z :: f Integer Integer)) -> eq2 (bimap id id z) ((first id . second id) z) 89 | 90 | #endif 91 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/ShowRead.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | {-# OPTIONS_GHC -Wall #-} 4 | 5 | {-| Module : Test.QuickCheck.Classes.ShowRead 6 | Description : Properties for testing the interaction between the Show and Read 7 | type classes. 8 | -} 9 | module Test.QuickCheck.Classes.ShowRead 10 | ( showReadLaws 11 | ) where 12 | 13 | import Data.Proxy (Proxy) 14 | import Test.QuickCheck 15 | import Text.Read (readListDefault) 16 | import Text.Show (showListWith) 17 | 18 | import Test.QuickCheck.Classes.Internal (Laws(..), ShowReadPrecedence(..), 19 | SmallList(..), myForAllShrink,readMaybe) 20 | 21 | -- | Tests the following properties: 22 | -- 23 | -- [/Partial Isomorphism: 'show' \/ 'read'/] 24 | -- @'readMaybe' ('show' a) ≡ 'Just' a@ 25 | -- [/Partial Isomorphism: 'show' \/ 'read' with initial space/] 26 | -- @'readMaybe' (" " ++ 'show' a) ≡ 'Just' a@ 27 | -- [/Partial Isomorphism: 'showsPrec' \/ 'readsPrec'/] 28 | -- @(a,"") \`elem\` 'readsPrec' p ('showsPrec' p a "")@ 29 | -- [/Partial Isomorphism: 'showList' \/ 'readList'/] 30 | -- @(as,"") \`elem\` 'readList' ('showList' as "")@ 31 | -- [/Partial Isomorphism: 'showListWith' 'shows' \/ 'readListDefault'/] 32 | -- @(as,"") \`elem\` 'readListDefault' ('showListWith' 'shows' as "")@ 33 | -- 34 | -- /Note:/ When using @base-4.5@ or older, a shim implementation 35 | -- of 'readMaybe' is used. 36 | -- 37 | showReadLaws :: (Show a, Read a, Eq a, Arbitrary a) => Proxy a -> Laws 38 | showReadLaws p = Laws "Show/Read" 39 | [ ("Partial Isomorphism: show/read", showReadPartialIsomorphism p) 40 | , ("Partial Isomorphism: show/read with initial space", showReadSpacePartialIsomorphism p) 41 | , ("Partial Isomorphism: showsPrec/readsPrec", showsPrecReadsPrecPartialIsomorphism p) 42 | , ("Partial Isomorphism: showList/readList", showListReadListPartialIsomorphism p) 43 | , ("Partial Isomorphism: showListWith shows / readListDefault", 44 | showListWithShowsReadListDefaultPartialIsomorphism p) 45 | ] 46 | 47 | 48 | showReadPartialIsomorphism :: forall a. 49 | (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property 50 | showReadPartialIsomorphism _ = 51 | myForAllShrink False (const True) 52 | (\(a :: a) -> ["a = " ++ show a]) 53 | ("readMaybe (show a)") 54 | (\a -> readMaybe (show a)) 55 | ("Just a") 56 | (\a -> Just a) 57 | 58 | showReadSpacePartialIsomorphism :: forall a. 59 | (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property 60 | showReadSpacePartialIsomorphism _ = 61 | myForAllShrink False (const True) 62 | (\(a :: a) -> ["a = " ++ show a]) 63 | ("readMaybe (\" \" ++ show a)") 64 | (\a -> readMaybe (" " ++ show a)) 65 | ("Just a") 66 | (\a -> Just a) 67 | 68 | showsPrecReadsPrecPartialIsomorphism :: forall a. 69 | (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property 70 | showsPrecReadsPrecPartialIsomorphism _ = 71 | property $ \(a :: a) (ShowReadPrecedence p) -> 72 | (a,"") `elem` readsPrec p (showsPrec p a "") 73 | 74 | showListReadListPartialIsomorphism :: forall a. 75 | (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property 76 | showListReadListPartialIsomorphism _ = 77 | property $ \(SmallList (as :: [a])) -> 78 | (as,"") `elem` readList (showList as "") 79 | 80 | showListWithShowsReadListDefaultPartialIsomorphism :: forall a. 81 | (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property 82 | showListWithShowsReadListDefaultPartialIsomorphism _ = 83 | property $ \(SmallList (as :: [a])) -> 84 | (as,"") `elem` readListDefault (showListWith shows as "") 85 | 86 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Bitraversable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | #if HAVE_QUANTIFIED_CONSTRAINTS 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | #endif 7 | 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | module Test.QuickCheck.Classes.Bitraversable 11 | ( 12 | #if HAVE_BINARY_LAWS 13 | bitraversableLaws 14 | #endif 15 | ) where 16 | 17 | import Data.Bitraversable(Bitraversable(..)) 18 | import Test.QuickCheck hiding ((.&.)) 19 | #if HAVE_BINARY_LAWS 20 | import Data.Functor.Compose (Compose(..)) 21 | import Data.Functor.Identity (Identity(..)) 22 | import Data.Functor.Classes (Eq2,Show2) 23 | #endif 24 | 25 | import Test.QuickCheck.Classes.Internal 26 | 27 | #if HAVE_BINARY_LAWS 28 | 29 | -- | Tests the following 'Bitraversable' properties: 30 | -- 31 | -- [/Naturality/] 32 | -- @'bitraverse' (t '.' f) (t '.' g) ≡ t '.' 'bitraverse' f g@ for every applicative transformation @t@ 33 | -- [/Identity/] 34 | -- @'bitraverse' 'Identity' 'Identity' ≡ 'Identity'@ 35 | -- [/Composition/] 36 | -- @'Compose' '.' 'fmap' ('bitraverse' g1 g2) '.' 'bitraverse' f1 f2 ≡ 'bitraverse' ('Compose' '.' 'fmap' g1 g2 '.' f1) ('Compose' '.' 'fmap' g2 '.' f2)@ 37 | -- 38 | -- /Note/: This property test is only available when this package is built with 39 | -- @base-4.9+@ or @transformers-0.5+@. 40 | bitraversableLaws :: forall proxy f. 41 | #if HAVE_QUANTIFIED_CONSTRAINTS 42 | (Bitraversable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 43 | #else 44 | (Bitraversable f, Eq2 f, Show2 f, Arbitrary2 f) 45 | #endif 46 | => proxy f -> Laws 47 | bitraversableLaws p = Laws "Bitraversable" 48 | [ ("Naturality", bitraversableNaturality p) 49 | , ("Identity", bitraversableIdentity p) 50 | , ("Composition", bitraversableComposition p) 51 | ] 52 | 53 | bitraversableNaturality :: forall proxy f. 54 | #if HAVE_QUANTIFIED_CONSTRAINTS 55 | (Bitraversable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 56 | #else 57 | (Bitraversable f, Eq2 f, Show2 f, Arbitrary2 f) 58 | #endif 59 | => proxy f -> Property 60 | bitraversableNaturality _ = property $ \(Apply2 (x :: f Integer Integer)) -> 61 | let t = apTrans 62 | f = func4 63 | g = func4 64 | x' = bitraverse (t . f) (t . g) x 65 | y' = t (bitraverse f g x) 66 | in eq1_2 x' y' 67 | 68 | bitraversableIdentity :: forall proxy f. 69 | #if HAVE_QUANTIFIED_CONSTRAINTS 70 | (Bitraversable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 71 | #else 72 | (Bitraversable f, Eq2 f, Show2 f, Arbitrary2 f) 73 | #endif 74 | => proxy f -> Property 75 | bitraversableIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq1_2 (bitraverse Identity Identity x) (Identity x) 76 | 77 | bitraversableComposition :: forall proxy f. 78 | #if HAVE_QUANTIFIED_CONSTRAINTS 79 | (Bitraversable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 80 | #else 81 | (Bitraversable f, Eq2 f, Show2 f, Arbitrary2 f) 82 | #endif 83 | => proxy f -> Property 84 | bitraversableComposition _ = property $ \(Apply2 (x :: f Integer Integer)) -> 85 | let f1 = func6 86 | f2 = func5 87 | g1 = func4 88 | g2 = func4 89 | x' = Compose . fmap (bitraverse g1 g2) . bitraverse f1 f2 $ x 90 | y' = bitraverse (Compose . fmap g1 . f1) (Compose . fmap g2 . f2) x 91 | in eq1_2 x' y' 92 | 93 | #endif 94 | -------------------------------------------------------------------------------- /quickcheck-classes/src/Test/QuickCheck/Classes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | 4 | {-# OPTIONS_GHC -Wall #-} 5 | 6 | {-| This library provides sets of properties that should hold for common 7 | typeclasses. 8 | 9 | /Note:/ on GHC < 8.6, this library uses the higher-kinded typeclasses 10 | ('Data.Functor.Classes.Show1', 'Data.Functor.Classes.Eq1', 'Data.Functor.Classes.Ord1', etc.), 11 | but on GHC >= 8.6, it uses @-XQuantifiedConstraints@ to express these 12 | constraints more cleanly. 13 | -} 14 | module Test.QuickCheck.Classes 15 | ( -- * Running 16 | QCB.lawsCheck 17 | , QCB.lawsCheckMany 18 | , QCB.lawsCheckOne 19 | -- * Properties 20 | -- ** Ground types 21 | #if MIN_VERSION_base(4,7,0) 22 | , QCB.bitsLaws 23 | #endif 24 | , QCB.eqLaws 25 | , QCB.substitutiveEqLaws 26 | , QCB.numLaws 27 | , QCB.integralLaws 28 | , QCB.ixLaws 29 | #if MIN_VERSION_base(4,7,0) 30 | , QCB.isListLaws 31 | #endif 32 | #if HAVE_AESON 33 | , jsonLaws 34 | #endif 35 | , QCB.monoidLaws 36 | , QCB.commutativeMonoidLaws 37 | , QCB.semigroupMonoidLaws 38 | , QCB.ordLaws 39 | , QCB.enumLaws 40 | , QCB.boundedEnumLaws 41 | , primLaws 42 | , QCB.semigroupLaws 43 | , QCB.commutativeSemigroupLaws 44 | , QCB.exponentialSemigroupLaws 45 | , QCB.idempotentSemigroupLaws 46 | , QCB.rectangularBandSemigroupLaws 47 | #if HAVE_SEMIRINGS 48 | , semiringLaws 49 | , ringLaws 50 | , gcdDomainLaws 51 | , euclideanLaws 52 | #endif 53 | , QCB.showLaws 54 | , QCB.showReadLaws 55 | , QCB.storableLaws 56 | #if MIN_VERSION_base(4,5,0) 57 | , QCB.genericLaws 58 | , QCB.generic1Laws 59 | #endif 60 | #if HAVE_UNARY_LAWS 61 | -- ** Unary type constructors 62 | , QCB.alternativeLaws 63 | #if HAVE_SEMIGROUPOIDS 64 | , altLaws 65 | , applyLaws 66 | #endif 67 | , QCB.applicativeLaws 68 | , QCB.contravariantLaws 69 | , QCB.foldableLaws 70 | , QCB.functorLaws 71 | , QCB.monadLaws 72 | , QCB.monadPlusLaws 73 | , QCB.monadZipLaws 74 | #if HAVE_SEMIGROUPOIDS 75 | , plusLaws 76 | , extendedPlusLaws 77 | #endif 78 | , QCB.traversableLaws 79 | #endif 80 | #if HAVE_BINARY_LAWS 81 | -- ** Binary type constructors 82 | , QCB.bifoldableLaws 83 | , QCB.bifunctorLaws 84 | , QCB.bitraversableLaws 85 | , QCB.categoryLaws 86 | , QCB.commutativeCategoryLaws 87 | #if HAVE_SEMIGROUPOIDS 88 | , semigroupoidLaws 89 | , commutativeSemigroupoidLaws 90 | #endif 91 | #if HAVE_VECTOR 92 | , muvectorLaws 93 | #endif 94 | #endif 95 | -- * Types 96 | , QCB.Laws(..) 97 | , QCB.Proxy1(..) 98 | , QCB.Proxy2(..) 99 | ) where 100 | 101 | -- 102 | -- re-exports 103 | -- 104 | 105 | -- Ground Types 106 | #if MIN_VERSION_base(4,7,0) 107 | import Test.QuickCheck.Classes.IsList 108 | #endif 109 | #if HAVE_AESON 110 | import Test.QuickCheck.Classes.Json 111 | #endif 112 | import Test.QuickCheck.Classes.Prim 113 | #if HAVE_SEMIRINGS 114 | import Test.QuickCheck.Classes.Euclidean 115 | import Test.QuickCheck.Classes.Semiring 116 | import Test.QuickCheck.Classes.Ring 117 | #endif 118 | -- Unary type constructors 119 | #if HAVE_UNARY_LAWS 120 | #if HAVE_SEMIGROUPOIDS 121 | import Test.QuickCheck.Classes.Alt 122 | import Test.QuickCheck.Classes.Apply 123 | #endif 124 | #if HAVE_SEMIGROUPOIDS 125 | import Test.QuickCheck.Classes.Plus 126 | #endif 127 | #endif 128 | 129 | -- Binary type constructors 130 | #if HAVE_BINARY_LAWS 131 | #if HAVE_SEMIGROUPOIDS 132 | import Test.QuickCheck.Classes.Semigroupoid 133 | #endif 134 | #endif 135 | 136 | #if HAVE_VECTOR 137 | import Test.QuickCheck.Classes.MVector 138 | #endif 139 | 140 | import qualified Test.QuickCheck.Classes.Base as QCB 141 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/MonadPlus.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | #if HAVE_QUANTIFIED_CONSTRAINTS 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | #endif 7 | 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | module Test.QuickCheck.Classes.MonadPlus 11 | ( 12 | #if HAVE_UNARY_LAWS 13 | monadPlusLaws 14 | #endif 15 | ) where 16 | 17 | import Test.QuickCheck hiding ((.&.)) 18 | import Test.QuickCheck.Classes.Internal 19 | import Control.Monad (MonadPlus(mzero,mplus)) 20 | 21 | #if HAVE_UNARY_LAWS 22 | import Test.QuickCheck.Arbitrary (Arbitrary1(..)) 23 | import Data.Functor.Classes (Eq1,Show1) 24 | #endif 25 | 26 | #if HAVE_UNARY_LAWS 27 | 28 | -- | Tests the following monad plus properties: 29 | -- 30 | -- [/Left Identity/] 31 | -- @'mplus' 'mzero' x ≡ x@ 32 | -- [/Right Identity/] 33 | -- @'mplus' x 'mzero' ≡ x@ 34 | -- [/Associativity/] 35 | -- @'mplus' a ('mplus' b c) ≡ 'mplus' ('mplus' a b) c)@ 36 | -- [/Left Zero/] 37 | -- @'mzero' '>>=' f ≡ 'mzero'@ 38 | -- [/Right Zero/] 39 | -- @m '>>' 'mzero' ≡ 'mzero'@ 40 | monadPlusLaws :: 41 | #if HAVE_QUANTIFIED_CONSTRAINTS 42 | (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 43 | #else 44 | (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) 45 | #endif 46 | => proxy f -> Laws 47 | monadPlusLaws p = Laws "MonadPlus" 48 | [ ("Left Identity", monadPlusLeftIdentity p) 49 | , ("Right Identity", monadPlusRightIdentity p) 50 | , ("Associativity", monadPlusAssociativity p) 51 | , ("Left Zero", monadPlusLeftZero p) 52 | , ("Right Zero", monadPlusRightZero p) 53 | ] 54 | 55 | monadPlusLeftIdentity :: forall proxy f. 56 | #if HAVE_QUANTIFIED_CONSTRAINTS 57 | (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 58 | #else 59 | (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) 60 | #endif 61 | => proxy f -> Property 62 | monadPlusLeftIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (mplus mzero a) a 63 | 64 | monadPlusRightIdentity :: forall proxy f. 65 | #if HAVE_QUANTIFIED_CONSTRAINTS 66 | (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 67 | #else 68 | (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) 69 | #endif 70 | => proxy f -> Property 71 | monadPlusRightIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (mplus a mzero) a 72 | 73 | monadPlusAssociativity :: forall proxy f. 74 | #if HAVE_QUANTIFIED_CONSTRAINTS 75 | (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 76 | #else 77 | (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) 78 | #endif 79 | => proxy f -> Property 80 | monadPlusAssociativity _ = property $ \(Apply (a :: f Integer)) (Apply (b :: f Integer)) (Apply (c :: f Integer)) -> eq1 (mplus a (mplus b c)) (mplus (mplus a b) c) 81 | 82 | monadPlusLeftZero :: forall proxy f. 83 | #if HAVE_QUANTIFIED_CONSTRAINTS 84 | (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 85 | #else 86 | (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) 87 | #endif 88 | => proxy f -> Property 89 | monadPlusLeftZero _ = property $ \(k' :: LinearEquationM f) -> eq1 (mzero >>= runLinearEquationM k') mzero 90 | 91 | monadPlusRightZero :: forall proxy f. 92 | #if HAVE_QUANTIFIED_CONSTRAINTS 93 | (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 94 | #else 95 | (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) 96 | #endif 97 | => proxy f -> Property 98 | monadPlusRightZero _ = property $ \(Apply (a :: f Integer)) -> eq1 (a >> (mzero :: f Integer)) mzero 99 | 100 | #endif 101 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Monoid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | {-# OPTIONS_GHC -Wall #-} 4 | 5 | module Test.QuickCheck.Classes.Monoid 6 | ( monoidLaws 7 | , commutativeMonoidLaws 8 | , semigroupMonoidLaws 9 | ) where 10 | 11 | import Data.Semigroup 12 | import Data.Monoid 13 | import Data.Proxy (Proxy) 14 | import Test.QuickCheck hiding ((.&.)) 15 | 16 | import Test.QuickCheck.Classes.Internal (Laws(..), SmallList(..), myForAllShrink) 17 | 18 | -- | Tests the following properties: 19 | -- 20 | -- [/Associative/] 21 | -- @mappend a (mappend b c) ≡ mappend (mappend a b) c@ 22 | -- [/Left Identity/] 23 | -- @mappend mempty a ≡ a@ 24 | -- [/Right Identity/] 25 | -- @mappend a mempty ≡ a@ 26 | -- [/Concatenation/] 27 | -- @mconcat as ≡ foldr mappend mempty as@ 28 | monoidLaws :: (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws 29 | monoidLaws p = Laws "Monoid" 30 | [ ("Associative", monoidAssociative p) 31 | , ("Left Identity", monoidLeftIdentity p) 32 | , ("Right Identity", monoidRightIdentity p) 33 | , ("Concatenation", monoidConcatenation p) 34 | ] 35 | 36 | -- | Tests the following properties: 37 | -- 38 | -- [/Commutative/] 39 | -- @mappend a b ≡ mappend b a@ 40 | -- 41 | -- Note that this does not test associativity or identity. Make sure to use 42 | -- 'monoidLaws' in addition to this set of laws. 43 | commutativeMonoidLaws :: (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws 44 | commutativeMonoidLaws p = Laws "Commutative Monoid" 45 | [ ("Commutative", monoidCommutative p) 46 | ] 47 | 48 | semigroupMonoidLaws :: forall a. (Semigroup a, Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws 49 | semigroupMonoidLaws p = Laws "Semigroup/Monoid" 50 | [ ("mappend == <>", semigroupMonoid p) 51 | ] 52 | 53 | semigroupMonoid :: forall a. (Semigroup a, Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 54 | semigroupMonoid _ = myForAllShrink True (const True) 55 | (\(a :: a,b) -> ["a = " ++ show a, "b = " ++ show b]) 56 | "mappend a b" 57 | (\(a,b) -> mappend a b) 58 | "a <> b" 59 | (\(a,b) -> a Data.Semigroup.<> b) 60 | 61 | monoidConcatenation :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 62 | monoidConcatenation _ = myForAllShrink True (const True) 63 | (\(SmallList (as :: [a])) -> ["as = " ++ show as]) 64 | "mconcat as" 65 | (\(SmallList as) -> mconcat as) 66 | "foldr mappend mempty as" 67 | (\(SmallList as) -> foldr mappend mempty as) 68 | 69 | monoidAssociative :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 70 | monoidAssociative _ = myForAllShrink True (const True) 71 | (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) 72 | "mappend a (mappend b c)" 73 | (\(a,b,c) -> mappend a (mappend b c)) 74 | "mappend (mappend a b) c" 75 | (\(a,b,c) -> mappend (mappend a b) c) 76 | 77 | monoidLeftIdentity :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 78 | monoidLeftIdentity _ = myForAllShrink False (const True) 79 | (\(a :: a) -> ["a = " ++ show a]) 80 | "mappend mempty a" 81 | (\a -> mappend mempty a) 82 | "a" 83 | (\a -> a) 84 | 85 | monoidRightIdentity :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 86 | monoidRightIdentity _ = myForAllShrink False (const True) 87 | (\(a :: a) -> ["a = " ++ show a]) 88 | "mappend a mempty" 89 | (\a -> mappend a mempty) 90 | "a" 91 | (\a -> a) 92 | 93 | monoidCommutative :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 94 | monoidCommutative _ = myForAllShrink True (const True) 95 | (\(a :: a,b) -> ["a = " ++ show a, "b = " ++ show b]) 96 | "mappend a b" 97 | (\(a,b) -> mappend a b) 98 | "mappend b a" 99 | (\(a,b) -> mappend b a) 100 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | #if HAVE_QUANTIFIED_CONSTRAINTS 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | #endif 7 | 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | module Test.QuickCheck.Classes.Monad 11 | ( 12 | #if HAVE_UNARY_LAWS 13 | monadLaws 14 | #endif 15 | ) where 16 | 17 | import Control.Applicative 18 | import Test.QuickCheck hiding ((.&.)) 19 | import Control.Monad (ap) 20 | #if HAVE_UNARY_LAWS 21 | import Test.QuickCheck.Arbitrary (Arbitrary1(..)) 22 | import Data.Functor.Classes (Eq1,Show1) 23 | #endif 24 | 25 | import Test.QuickCheck.Classes.Internal 26 | 27 | #if HAVE_UNARY_LAWS 28 | 29 | -- | Tests the following monadic properties: 30 | -- 31 | -- [/Left Identity/] 32 | -- @'return' a '>>=' k ≡ k a@ 33 | -- [/Right Identity/] 34 | -- @m '>>=' 'return' ≡ m@ 35 | -- [/Associativity/] 36 | -- @m '>>=' (\\x -> k x '>>=' h) ≡ (m '>>=' k) '>>=' h@ 37 | -- [/Return/] 38 | -- @'pure' ≡ 'return'@ 39 | -- [/Ap/] 40 | -- @('<*>') ≡ 'ap'@ 41 | monadLaws :: 42 | #if HAVE_QUANTIFIED_CONSTRAINTS 43 | (Monad f, Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 44 | #else 45 | (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) 46 | #endif 47 | => proxy f -> Laws 48 | monadLaws p = Laws "Monad" 49 | [ ("Left Identity", monadLeftIdentity p) 50 | , ("Right Identity", monadRightIdentity p) 51 | , ("Associativity", monadAssociativity p) 52 | , ("Return", monadReturn p) 53 | , ("Ap", monadAp p) 54 | ] 55 | 56 | monadLeftIdentity :: forall proxy f. 57 | #if HAVE_QUANTIFIED_CONSTRAINTS 58 | (Monad f, Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 59 | #else 60 | (Monad f, Functor f, Eq1 f, Show1 f, Arbitrary1 f) 61 | #endif 62 | => proxy f -> Property 63 | monadLeftIdentity _ = property $ \(k' :: LinearEquationM f) (a :: Integer) -> 64 | let k = runLinearEquationM k' 65 | in eq1 (return a >>= k) (k a) 66 | 67 | monadRightIdentity :: forall proxy f. 68 | #if HAVE_QUANTIFIED_CONSTRAINTS 69 | (Monad f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 70 | #else 71 | (Monad f, Eq1 f, Show1 f, Arbitrary1 f) 72 | #endif 73 | => proxy f -> Property 74 | monadRightIdentity _ = property $ \(Apply (m :: f Integer)) -> 75 | eq1 (m >>= return) m 76 | 77 | monadAssociativity :: forall proxy f. 78 | #if HAVE_QUANTIFIED_CONSTRAINTS 79 | (Monad f, Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 80 | #else 81 | (Monad f, Functor f, Eq1 f, Show1 f, Arbitrary1 f) 82 | #endif 83 | => proxy f -> Property 84 | monadAssociativity _ = property $ \(Apply (m :: f Integer)) (k' :: LinearEquationM f) (h' :: LinearEquationM f) -> 85 | let k = runLinearEquationM k' 86 | h = runLinearEquationM h' 87 | in eq1 (m >>= (\x -> k x >>= h)) ((m >>= k) >>= h) 88 | 89 | monadReturn :: forall proxy f. 90 | #if HAVE_QUANTIFIED_CONSTRAINTS 91 | (Monad f, Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 92 | #else 93 | (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) 94 | #endif 95 | => proxy f -> Property 96 | monadReturn _ = property $ \(x :: Integer) -> 97 | eq1 (return x) (pure x :: f Integer) 98 | 99 | monadAp :: forall proxy f. 100 | #if HAVE_QUANTIFIED_CONSTRAINTS 101 | (Monad f, Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 102 | #else 103 | (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) 104 | #endif 105 | => proxy f -> Property 106 | monadAp _ = property $ \(Apply (f' :: f QuadraticEquation)) (Apply (x :: f Integer)) -> 107 | let f = fmap runQuadraticEquation f' 108 | in eq1 (ap f x) (f <*> x) 109 | 110 | #endif 111 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Traversable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | #if HAVE_QUANTIFIED_CONSTRAINTS 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | #endif 7 | 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | module Test.QuickCheck.Classes.Traversable 11 | ( 12 | #if HAVE_UNARY_LAWS 13 | traversableLaws 14 | #endif 15 | ) where 16 | 17 | import Data.Foldable (foldMap) 18 | import Data.Traversable (Traversable,fmapDefault,foldMapDefault,sequenceA,traverse) 19 | import Test.QuickCheck hiding ((.&.)) 20 | #if HAVE_UNARY_LAWS 21 | import Test.QuickCheck.Arbitrary (Arbitrary1(..)) 22 | import Data.Functor.Classes (Eq1,Show1) 23 | #endif 24 | import Data.Functor.Compose 25 | import Data.Functor.Identity 26 | 27 | import qualified Data.Set as S 28 | 29 | import Test.QuickCheck.Classes.Internal 30 | 31 | #if HAVE_UNARY_LAWS 32 | 33 | -- | Tests the following 'Traversable' properties: 34 | -- 35 | -- [/Naturality/] 36 | -- @t '.' 'traverse' f ≡ 'traverse' (t '.' f)@ 37 | -- for every applicative transformation @t@ 38 | -- [/Identity/] 39 | -- @'traverse' 'Identity' ≡ 'Identity'@ 40 | -- [/Composition/] 41 | -- @'traverse' ('Compose' '.' 'fmap' g '.' f) ≡ 'Compose' '.' 'fmap' ('traverse' g) '.' 'traverse' f@ 42 | -- [/Sequence Naturality/] 43 | -- @t '.' 'sequenceA' ≡ 'sequenceA' '.' 'fmap' t@ 44 | -- for every applicative transformation @t@ 45 | -- [/Sequence Identity/] 46 | -- @'sequenceA' '.' 'fmap' 'Identity' ≡ 'Identity'@ 47 | -- [/Sequence Composition/] 48 | -- @'sequenceA' '.' 'fmap' 'Compose' ≡ 'Compose' '.' 'fmap' 'sequenceA' '.' 'sequenceA'@ 49 | -- [/foldMap/] 50 | -- @'foldMap' ≡ 'foldMapDefault'@ 51 | -- [/fmap/] 52 | -- @'fmap' ≡ 'fmapDefault'@ 53 | -- 54 | -- Where an /applicative transformation/ is a function 55 | -- 56 | -- @t :: (Applicative f, Applicative g) => f a -> g a@ 57 | -- 58 | -- preserving the 'Applicative' operations, i.e. 59 | -- 60 | -- * Identity: @t ('pure' x) ≡ 'pure' x@ 61 | -- * Distributivity: @t (x '<*>' y) ≡ t x '<*>' t y@ 62 | traversableLaws :: 63 | #if HAVE_QUANTIFIED_CONSTRAINTS 64 | (Traversable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 65 | #else 66 | (Traversable f, Eq1 f, Show1 f, Arbitrary1 f) 67 | #endif 68 | => proxy f -> Laws 69 | traversableLaws = traversableLawsInternal 70 | 71 | traversableLawsInternal :: forall proxy f. 72 | #if HAVE_QUANTIFIED_CONSTRAINTS 73 | (Traversable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 74 | #else 75 | (Traversable f, Eq1 f, Show1 f, Arbitrary1 f) 76 | #endif 77 | => proxy f -> Laws 78 | traversableLawsInternal _ = Laws "Traversable" 79 | [ (,) "Naturality" $ property $ \(Apply (a :: f Integer)) -> 80 | propNestedEq1 (apTrans (traverse func4 a)) (traverse (apTrans . func4) a) 81 | , (,) "Identity" $ property $ \(Apply (t :: f Integer)) -> 82 | nestedEq1 (traverse Identity t) (Identity t) 83 | , (,) "Composition" $ property $ \(Apply (t :: f Integer)) -> 84 | nestedEq1 (traverse (Compose . fmap func5 . func6) t) (Compose (fmap (traverse func5) (traverse func6 t))) 85 | , (,) "Sequence Naturality" $ property $ \(Apply (x :: f (Compose Triple ((,) (S.Set Integer)) Integer))) -> 86 | let a = fmap toSpecialApplicative x in 87 | propNestedEq1 (apTrans (sequenceA a)) (sequenceA (fmap apTrans a)) 88 | , (,) "Sequence Identity" $ property $ \(Apply (t :: f Integer)) -> 89 | nestedEq1 (sequenceA (fmap Identity t)) (Identity t) 90 | , (,) "Sequence Composition" $ property $ \(Apply (t :: f (Triple (Triple Integer)))) -> 91 | nestedEq1 (sequenceA (fmap Compose t)) (Compose (fmap sequenceA (sequenceA t))) 92 | , (,) "foldMap" $ property $ \(Apply (t :: f Integer)) -> 93 | foldMap func3 t == foldMapDefault func3 t 94 | , (,) "fmap" $ property $ \(Apply (t :: f Integer)) -> 95 | eq1 (fmap func3 t) (fmapDefault func3 t) 96 | ] 97 | 98 | 99 | #endif 100 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | #if HAVE_QUANTIFIED_CONSTRAINTS 6 | {-# LANGUAGE QuantifiedConstraints #-} 7 | #endif 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | module Test.QuickCheck.Classes.Generic 11 | ( 12 | #if MIN_VERSION_base(4,5,0) 13 | genericLaws 14 | #if HAVE_UNARY_LAWS 15 | , generic1Laws 16 | #endif 17 | #endif 18 | ) where 19 | 20 | #if MIN_VERSION_base(4,5,0) 21 | import Control.Applicative 22 | import Data.Semigroup as SG 23 | import Data.Monoid as MD 24 | import GHC.Generics 25 | #if HAVE_UNARY_LAWS 26 | import Data.Functor.Classes 27 | #endif 28 | import Data.Proxy (Proxy(Proxy)) 29 | import Test.QuickCheck 30 | 31 | import Test.QuickCheck.Classes.Internal (Laws(..), Apply(..)) 32 | 33 | -- | Tests the following properties: 34 | -- 35 | -- [/From-To Inverse/] 36 | -- @'from' '.' 'to' ≡ 'id'@ 37 | -- [/To-From Inverse/] 38 | -- @'to' '.' 'from' ≡ 'id'@ 39 | -- 40 | -- /Note:/ This property test is only available when 41 | -- using @base-4.5@ or newer. 42 | -- 43 | -- /Note:/ 'from' and 'to' don't actually care about 44 | -- the type variable @x@ in @'Rep' a x@, so here we instantiate 45 | -- it to @'()'@ by default. If you would like to instantiate @x@ 46 | -- as something else, please file a bug report. 47 | genericLaws :: (Generic a, Eq a, Arbitrary a, Show a, Show (Rep a ()), Arbitrary (Rep a ()), Eq (Rep a ())) => Proxy a -> Laws 48 | genericLaws pa = Laws "Generic" 49 | [ ("From-To inverse", fromToInverse pa (Proxy :: Proxy ())) 50 | , ("To-From inverse", toFromInverse pa) 51 | ] 52 | 53 | toFromInverse :: forall proxy a. (Generic a, Eq a, Arbitrary a, Show a) => proxy a -> Property 54 | toFromInverse _ = property $ \(v :: a) -> (to . from $ v) == v 55 | 56 | fromToInverse :: 57 | forall proxy a x. 58 | (Generic a, Show (Rep a x), Arbitrary (Rep a x), Eq (Rep a x)) 59 | => proxy a 60 | -> proxy x 61 | -> Property 62 | fromToInverse _ _ = property $ \(r :: Rep a x) -> r == (from (to r :: a)) 63 | 64 | #if HAVE_UNARY_LAWS 65 | -- | Tests the following properties: 66 | -- 67 | -- [/From-To Inverse/] 68 | -- @'from1' '.' 'to1' ≡ 'id'@ 69 | -- [/To-From Inverse/] 70 | -- @'to1' '.' 'from1' ≡ 'id'@ 71 | -- 72 | -- /Note:/ This property test is only available when 73 | -- using @base-4.9@ or newer. 74 | generic1Laws :: (Generic1 f, Eq1 f, Arbitrary1 f, Show1 f, Eq1 (Rep1 f), Show1 (Rep1 f), Arbitrary1 (Rep1 f)) 75 | => proxy f -> Laws 76 | generic1Laws p = Laws "Generic1" 77 | [ ("From1-To1 inverse", fromToInverse1 p) 78 | , ("To1-From1 inverse", toFromInverse1 p) 79 | ] 80 | 81 | -- hack for quantified constraints: under base >= 4.12, 82 | -- our usual 'Apply' wrapper has Eq, Show, and Arbitrary 83 | -- instances that are incompatible. 84 | newtype GApply f a = GApply { getGApply :: f a } 85 | 86 | instance (Applicative f, Semigroup a) => Semigroup (GApply f a) where 87 | GApply x <> GApply y = GApply $ liftA2 (SG.<>) x y 88 | 89 | instance (Applicative f, Monoid a) => Monoid (GApply f a) where 90 | mempty = GApply $ pure mempty 91 | mappend (GApply x) (GApply y) = GApply $ liftA2 (MD.<>) x y 92 | 93 | instance (Eq1 f, Eq a) => Eq (GApply f a) where 94 | GApply a == GApply b = eq1 a b 95 | 96 | instance (Show1 f, Show a) => Show (GApply f a) where 97 | showsPrec p = showsPrec1 p . getGApply 98 | 99 | instance (Arbitrary1 f, Arbitrary a) => Arbitrary (GApply f a) where 100 | arbitrary = fmap GApply arbitrary1 101 | shrink = map GApply . shrink1 . getGApply 102 | 103 | toFromInverse1 :: forall proxy f. (Generic1 f, Eq1 f, Arbitrary1 f, Show1 f) => proxy f -> Property 104 | toFromInverse1 _ = property $ \(GApply (v :: f Integer)) -> eq1 v (to1 . from1 $ v) 105 | 106 | fromToInverse1 :: forall proxy f. (Generic1 f, Eq1 (Rep1 f), Arbitrary1 (Rep1 f), Show1 (Rep1 f)) => proxy f -> Property 107 | fromToInverse1 _ = property $ \(GApply (r :: Rep1 f Integer)) -> eq1 r (from1 ((to1 $ r) :: f Integer)) 108 | 109 | #endif 110 | 111 | #endif 112 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Applicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | #if HAVE_QUANTIFIED_CONSTRAINTS 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | #endif 7 | 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | module Test.QuickCheck.Classes.Applicative 11 | ( 12 | #if HAVE_UNARY_LAWS 13 | applicativeLaws 14 | #endif 15 | ) where 16 | 17 | import Control.Applicative 18 | import Test.QuickCheck hiding ((.&.)) 19 | #if HAVE_UNARY_LAWS 20 | import Test.QuickCheck.Arbitrary (Arbitrary1(..)) 21 | import Data.Functor.Classes (Eq1,Show1) 22 | #endif 23 | 24 | import Test.QuickCheck.Classes.Internal 25 | 26 | #if HAVE_UNARY_LAWS 27 | 28 | -- | Tests the following applicative properties: 29 | -- 30 | -- [/Identity/] 31 | -- @'pure' 'id' '<*>' v ≡ v@ 32 | -- [/Composition/] 33 | -- @'pure' ('.') '<*>' u '<*>' v '<*>' w ≡ u '<*>' (v '<*>' w)@ 34 | -- [/Homomorphism/] 35 | -- @'pure' f '<*>' 'pure' x ≡ 'pure' (f x)@ 36 | -- [/Interchange/] 37 | -- @u '<*>' 'pure' y ≡ 'pure' ('$' y) '<*>' u@ 38 | -- [/LiftA2 (1)/] 39 | -- @('<*>') ≡ 'liftA2' 'id'@ 40 | applicativeLaws :: 41 | #if HAVE_QUANTIFIED_CONSTRAINTS 42 | (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 43 | #else 44 | (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) 45 | #endif 46 | => proxy f -> Laws 47 | applicativeLaws p = Laws "Applicative" 48 | [ ("Identity", applicativeIdentity p) 49 | , ("Composition", applicativeComposition p) 50 | , ("Homomorphism", applicativeHomomorphism p) 51 | , ("Interchange", applicativeInterchange p) 52 | , ("LiftA2 Part 1", applicativeLiftA2_1 p) 53 | -- todo: liftA2 part 2, we need an equation of two variables for this 54 | ] 55 | 56 | applicativeIdentity :: forall proxy f. 57 | #if HAVE_QUANTIFIED_CONSTRAINTS 58 | (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 59 | #else 60 | (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) 61 | #endif 62 | => proxy f -> Property 63 | applicativeIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (pure id <*> a) a 64 | 65 | applicativeComposition :: forall proxy f. 66 | #if HAVE_QUANTIFIED_CONSTRAINTS 67 | (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 68 | #else 69 | (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) 70 | #endif 71 | => proxy f -> Property 72 | applicativeComposition _ = property $ \(Apply (u' :: f QuadraticEquation)) (Apply (v' :: f QuadraticEquation)) (Apply (w :: f Integer)) -> 73 | let u = fmap runQuadraticEquation u' 74 | v = fmap runQuadraticEquation v' 75 | in eq1 (pure (.) <*> u <*> v <*> w) (u <*> (v <*> w)) 76 | 77 | applicativeHomomorphism :: forall proxy f. 78 | #if HAVE_QUANTIFIED_CONSTRAINTS 79 | (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a)) 80 | #else 81 | (Applicative f, Eq1 f, Show1 f) 82 | #endif 83 | => proxy f -> Property 84 | applicativeHomomorphism _ = property $ \(e :: QuadraticEquation) (a :: Integer) -> 85 | let f = runQuadraticEquation e 86 | in eq1 (pure f <*> pure a) (pure (f a) :: f Integer) 87 | 88 | applicativeInterchange :: forall proxy f. 89 | #if HAVE_QUANTIFIED_CONSTRAINTS 90 | (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 91 | #else 92 | (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) 93 | #endif 94 | => proxy f -> Property 95 | applicativeInterchange _ = property $ \(Apply (u' :: f QuadraticEquation)) (y :: Integer) -> 96 | let u = fmap runQuadraticEquation u' 97 | in eq1 (u <*> pure y) (pure ($ y) <*> u) 98 | 99 | applicativeLiftA2_1 :: forall proxy f. 100 | #if HAVE_QUANTIFIED_CONSTRAINTS 101 | (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 102 | #else 103 | (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) 104 | #endif 105 | => proxy f -> Property 106 | applicativeLiftA2_1 _ = property $ \(Apply (f' :: f QuadraticEquation)) (Apply (x :: f Integer)) -> 107 | let f = fmap runQuadraticEquation f' 108 | in eq1 (liftA2 id f x) (f <*> x) 109 | 110 | #endif 111 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Category.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | #if HAVE_QUANTIFIED_CONSTRAINTS 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | #endif 7 | 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | module Test.QuickCheck.Classes.Category 11 | ( 12 | #if HAVE_BINARY_LAWS 13 | categoryLaws 14 | , commutativeCategoryLaws 15 | #endif 16 | ) where 17 | 18 | import Prelude hiding (id, (.)) 19 | import Control.Category (Category(..)) 20 | import Test.QuickCheck hiding ((.&.)) 21 | #if HAVE_BINARY_LAWS 22 | import Data.Functor.Classes (Eq2,Show2) 23 | #endif 24 | 25 | import Test.QuickCheck.Classes.Internal 26 | 27 | #if HAVE_BINARY_LAWS 28 | 29 | -- | Tests the following 'Category' properties: 30 | -- 31 | -- [/Right Identity/] 32 | -- @f '.' 'id' ≡ f@ 33 | -- [/Left Identity/] 34 | -- @'id' '.' f ≡ f@ 35 | -- [/Associativity/] 36 | -- @f '.' (g '.' h) ≡ (f '.' g) '.' h@ 37 | -- 38 | -- /Note/: This property test is only available when this package is built with 39 | -- @base-4.9+@ or @transformers-0.5+@. 40 | categoryLaws :: forall proxy c. 41 | #if HAVE_QUANTIFIED_CONSTRAINTS 42 | (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b)) 43 | #else 44 | (Category c, Eq2 c, Show2 c, Arbitrary2 c) 45 | #endif 46 | => proxy c -> Laws 47 | categoryLaws p = Laws "Category" 48 | [ ("Right Identity", categoryRightIdentity p) 49 | , ("Left Identity", categoryLeftIdentity p) 50 | , ("Associativity", categoryAssociativity p) 51 | ] 52 | 53 | -- | Test everything from 'categoryLaws' plus the following: 54 | -- 55 | -- [/Commutative/] 56 | -- @f '.' g ≡ g '.' f@ 57 | -- 58 | -- /Note/: This property test is only available when this package is built with 59 | -- @base-4.9+@ or @transformers-0.5+@. 60 | commutativeCategoryLaws :: forall proxy c. 61 | #if HAVE_QUANTIFIED_CONSTRAINTS 62 | (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b)) 63 | #else 64 | (Category c, Eq2 c, Show2 c, Arbitrary2 c) 65 | #endif 66 | => proxy c -> Laws 67 | commutativeCategoryLaws p = Laws "Commutative Category" $ lawsProperties (categoryLaws p) ++ 68 | [ ("Commutative", categoryCommutativity p) 69 | ] 70 | 71 | categoryRightIdentity :: forall proxy c. 72 | #if HAVE_QUANTIFIED_CONSTRAINTS 73 | (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b)) 74 | #else 75 | (Category c, Eq2 c, Show2 c, Arbitrary2 c) 76 | #endif 77 | => proxy c -> Property 78 | categoryRightIdentity _ = property $ \(Apply2 (x :: c Integer Integer)) -> eq2 (x . id) x 79 | 80 | categoryLeftIdentity :: forall proxy c. 81 | #if HAVE_QUANTIFIED_CONSTRAINTS 82 | (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b)) 83 | #else 84 | (Category c, Eq2 c, Show2 c, Arbitrary2 c) 85 | #endif 86 | => proxy c -> Property 87 | categoryLeftIdentity _ = property $ \(Apply2 (x :: c Integer Integer)) -> eq2 (id . x) x 88 | 89 | categoryAssociativity :: forall proxy c. 90 | #if HAVE_QUANTIFIED_CONSTRAINTS 91 | (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b)) 92 | #else 93 | (Category c, Eq2 c, Show2 c, Arbitrary2 c) 94 | #endif 95 | => proxy c -> Property 96 | categoryAssociativity _ = property $ \(Apply2 (f :: c Integer Integer)) (Apply2 (g :: c Integer Integer)) (Apply2 (h :: c Integer Integer)) -> eq2 (f . (g . h)) ((f . g) . h) 97 | 98 | categoryCommutativity :: forall proxy c. 99 | #if HAVE_QUANTIFIED_CONSTRAINTS 100 | (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b)) 101 | #else 102 | (Category c, Eq2 c, Show2 c, Arbitrary2 c) 103 | #endif 104 | => proxy c -> Property 105 | categoryCommutativity _ = property $ \(Apply2 (f :: c Integer Integer)) (Apply2 (g :: c Integer Integer)) -> eq2 (f . g) (g . f) 106 | 107 | #endif 108 | -------------------------------------------------------------------------------- /quickcheck-classes-base/quickcheck-classes-base.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: quickcheck-classes-base 3 | version: 0.6.2.0 4 | synopsis: QuickCheck common typeclasses from @base@ 5 | description: 6 | This libary is a minimal variant of [quickcheck-classes](https://hackage.haskell.org/package/quickcheck-classes) that 7 | only provides laws for typeclasses from [base](https://hackage.haskell.org/package/base). The main purpose 8 | of splitting this out is so that [primitive](https://hackage.haskell.org/package/primitive) can depend on 9 | @quickcheck-classes-base@ in its test suite, avoiding the circular 10 | dependency that arises if @quickcheck-classes@ is used instead. 11 | . 12 | This library provides @QuickCheck@ properties to ensure 13 | that typeclass instances adhere to the set of laws that 14 | they are supposed to. There are other libraries that do 15 | similar things, such as [genvalidity-hspec](https://hackage.haskell.org/package/genvalidity-hspec) 16 | and [checkers](https://hackage.haskell.org/package/checkers). 17 | This library differs from other solutions by not introducing 18 | any new typeclasses that the user needs to learn. 19 | . 20 | /Note:/ on GHC < 8.5, this library uses the higher-kinded typeclasses 21 | ('Data.Functor.Classes.Show1', 'Data.Functor.Classes.Eq1', 'Data.Functor.Classes.Ord1', etc.), 22 | but on GHC >= 8.5, it uses @-XQuantifiedConstraints@ to express these 23 | constraints more cleanly. 24 | homepage: https://github.com/andrewthad/quickcheck-classes#readme 25 | license: BSD-3-Clause 26 | license-file: LICENSE 27 | author: Andrew Martin, chessai 28 | maintainer: andrew.thaddeus@gmail.com 29 | copyright: 2019 Andrew Martin 30 | category: Testing 31 | build-type: Simple 32 | extra-source-files: changelog.md 33 | 34 | flag unary-laws 35 | description: 36 | Include infrastructure for testing class laws of unary type constructors. 37 | default: True 38 | manual: True 39 | 40 | flag binary-laws 41 | description: 42 | Include infrastructure for testing class laws of binary type constructors. 43 | Disabling @unary-laws@ while keeping @binary-laws@ enabled is an unsupported 44 | configuration. 45 | default: True 46 | manual: True 47 | 48 | library 49 | default-language: Haskell2010 50 | hs-source-dirs: src 51 | exposed-modules: 52 | Test.QuickCheck.Classes.Base 53 | Test.QuickCheck.Classes.Base.IsList 54 | Test.QuickCheck.Classes.Internal 55 | other-modules: 56 | Test.QuickCheck.Classes.Alternative 57 | Test.QuickCheck.Classes.Applicative 58 | Test.QuickCheck.Classes.Bifoldable 59 | Test.QuickCheck.Classes.Bifunctor 60 | Test.QuickCheck.Classes.Bitraversable 61 | Test.QuickCheck.Classes.Bits 62 | Test.QuickCheck.Classes.Category 63 | Test.QuickCheck.Classes.Contravariant 64 | Test.QuickCheck.Classes.Enum 65 | Test.QuickCheck.Classes.Eq 66 | Test.QuickCheck.Classes.Foldable 67 | Test.QuickCheck.Classes.Functor 68 | Test.QuickCheck.Classes.Generic 69 | Test.QuickCheck.Classes.Integral 70 | Test.QuickCheck.Classes.Ix 71 | Test.QuickCheck.Classes.Monad 72 | Test.QuickCheck.Classes.MonadFail 73 | Test.QuickCheck.Classes.MonadPlus 74 | Test.QuickCheck.Classes.MonadZip 75 | Test.QuickCheck.Classes.Monoid 76 | Test.QuickCheck.Classes.Num 77 | Test.QuickCheck.Classes.Ord 78 | Test.QuickCheck.Classes.Semigroup 79 | Test.QuickCheck.Classes.Show 80 | Test.QuickCheck.Classes.ShowRead 81 | Test.QuickCheck.Classes.Storable 82 | Test.QuickCheck.Classes.Traversable 83 | build-depends: 84 | , base >= 4.5 && < 5 85 | , QuickCheck >= 2.7 86 | , transformers >= 0.3 && < 0.7 87 | , containers >= 0.4.2.1 88 | if impl(ghc < 8.6) 89 | build-depends: contravariant 90 | if impl(ghc < 8.2) 91 | build-depends: bifunctors 92 | if impl(ghc < 8.0) 93 | build-depends: 94 | , semigroups >= 0.17 95 | , fail 96 | if impl(ghc < 7.8) 97 | build-depends: tagged 98 | if impl(ghc > 7.4) && impl(ghc < 7.6) 99 | build-depends: ghc-prim 100 | if impl(ghc > 8.5) 101 | cpp-options: -DHAVE_QUANTIFIED_CONSTRAINTS 102 | if flag(unary-laws) 103 | build-depends: 104 | , transformers >= 0.4.0 105 | , QuickCheck >= 2.10.0 106 | cpp-options: -DHAVE_UNARY_LAWS 107 | if flag(binary-laws) 108 | build-depends: 109 | , transformers >= 0.5.0 110 | , QuickCheck >= 2.10.0 111 | cpp-options: -DHAVE_BINARY_LAWS 112 | 113 | source-repository head 114 | type: git 115 | location: https://github.com/andrewthad/quickcheck-classes 116 | -------------------------------------------------------------------------------- /quickcheck-classes/src/Test/QuickCheck/Classes/Euclidean.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Test.QuickCheck.Classes.Euclidean 3 | -- Copyright: (c) 2019 Andrew Lelechenko 4 | -- Licence: BSD3 5 | -- 6 | 7 | {-# LANGUAGE CPP #-} 8 | {-# LANGUAGE FlexibleContexts #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | 11 | {-# OPTIONS_GHC -Wall #-} 12 | 13 | #if !HAVE_SEMIRINGS 14 | module Test.QuickCheck.Classes.Euclidean where 15 | #else 16 | 17 | module Test.QuickCheck.Classes.Euclidean 18 | ( gcdDomainLaws 19 | , euclideanLaws 20 | ) where 21 | 22 | import Prelude hiding (quotRem, quot, rem, gcd, lcm) 23 | import Data.Maybe 24 | import Data.Proxy (Proxy) 25 | import Data.Euclidean 26 | import Data.Semiring (Semiring(..)) 27 | 28 | import Test.QuickCheck hiding ((.&.)) 29 | 30 | import Test.QuickCheck.Classes.Internal (Laws(..)) 31 | 32 | -- | Test that a 'GcdDomain' instance obey several laws. 33 | -- 34 | -- Check that 'divide' is an inverse of times: 35 | -- 36 | -- * @y \/= 0 => (x * y) \`divide\` y == Just x@, 37 | -- * @y \/= 0, x \`divide\` y == Just z => x == z * y@. 38 | -- 39 | -- Check that 'gcd' is a common divisor and is a multiple of any common divisor: 40 | -- 41 | -- * @x \/= 0, y \/= 0 => isJust (x \`divide\` gcd x y) && isJust (y \`divide\` gcd x y)@, 42 | -- * @z \/= 0 => isJust (gcd (x * z) (y * z) \`divide\` z)@. 43 | -- 44 | -- Check that 'lcm' is a common multiple and is a factor of any common multiple: 45 | -- 46 | -- * @x \/= 0, y \/= 0 => isJust (lcm x y \`divide\` x) && isJust (lcm x y \`divide\` y)@, 47 | -- * @x \/= 0, y \/= 0, isJust (z \`divide\` x), isJust (z \`divide\` y) => isJust (z \`divide\` lcm x y)@. 48 | -- 49 | -- Check that 'gcd' of 'coprime' numbers is a unit of the semiring (has an inverse): 50 | -- 51 | -- * @y \/= 0, coprime x y => isJust (1 \`divide\` gcd x y)@. 52 | gcdDomainLaws :: (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Laws 53 | gcdDomainLaws p = Laws "GcdDomain" 54 | [ ("divide1", divideLaw1 p) 55 | , ("divide2", divideLaw2 p) 56 | , ("gcd1", gcdLaw1 p) 57 | , ("gcd2", gcdLaw2 p) 58 | , ("lcm1", lcmLaw1 p) 59 | , ("lcm2", lcmLaw2 p) 60 | , ("coprime", coprimeLaw p) 61 | ] 62 | 63 | divideLaw1 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property 64 | divideLaw1 _ = property $ \(x :: a) y -> 65 | y /= zero ==> (x `times` y) `divide` y === Just x 66 | 67 | divideLaw2 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property 68 | divideLaw2 _ = property $ \(x :: a) y -> 69 | y /= zero ==> maybe (property True) (\z -> x === z `times` y) (x `divide` y) 70 | 71 | gcdLaw1 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property 72 | gcdLaw1 _ = property $ \(x :: a) y -> 73 | x /= zero || y /= zero ==> isJust (x `divide` gcd x y) .&&. isJust (y `divide` gcd x y) 74 | 75 | gcdLaw2 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property 76 | gcdLaw2 _ = property $ \(x :: a) y z -> 77 | z /= zero ==> isJust (gcd (x `times` z) (y `times` z) `divide` z) 78 | 79 | lcmLaw1 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property 80 | lcmLaw1 _ = property $ \(x :: a) y -> 81 | x /= zero && y /= zero ==> isJust (lcm x y `divide` x) .&&. isJust (lcm x y `divide` y) 82 | 83 | lcmLaw2 :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property 84 | lcmLaw2 _ = property $ \(x :: a) y z -> 85 | x /= zero && y /= zero ==> isNothing (z `divide` x) .||. isNothing (z `divide` y) .||. isJust (z `divide` lcm x y) 86 | 87 | coprimeLaw :: forall a. (Eq a, GcdDomain a, Arbitrary a, Show a) => Proxy a -> Property 88 | coprimeLaw _ = property $ \(x :: a) y -> 89 | y /= zero ==> coprime x y === isJust (one `divide` gcd x y) 90 | 91 | -- | Test that a 'Euclidean' instance obey laws of a Euclidean domain. 92 | -- 93 | -- * @y \/= 0, r == x \`rem\` y => r == 0 || degree r < degree y@, 94 | -- * @y \/= 0, (q, r) == x \`quotRem\` y => x == q * y + r@, 95 | -- * @y \/= 0 => x \`quot\` x y == fst (x \`quotRem\` y)@, 96 | -- * @y \/= 0 => x \`rem\` x y == snd (x \`quotRem\` y)@. 97 | euclideanLaws :: (Eq a, Euclidean a, Arbitrary a, Show a) => Proxy a -> Laws 98 | euclideanLaws p = Laws "Euclidean" 99 | [ ("degree", degreeLaw p) 100 | , ("quotRem", quotRemLaw p) 101 | , ("quot", quotLaw p) 102 | , ("rem", remLaw p) 103 | ] 104 | 105 | degreeLaw :: forall a. (Eq a, Euclidean a, Arbitrary a, Show a) => Proxy a -> Property 106 | degreeLaw _ = property $ \(x :: a) y -> 107 | y /= zero ==> let (_, r) = x `quotRem` y in (r === zero .||. degree r < degree y) 108 | 109 | quotRemLaw :: forall a. (Eq a, Euclidean a, Arbitrary a, Show a) => Proxy a -> Property 110 | quotRemLaw _ = property $ \(x :: a) y -> 111 | y /= zero ==> let (q, r) = x `quotRem` y in x === (q `times` y) `plus` r 112 | 113 | quotLaw :: forall a. (Eq a, Euclidean a, Arbitrary a, Show a) => Proxy a -> Property 114 | quotLaw _ = property $ \(x :: a) y -> 115 | y /= zero ==> quot x y === fst (quotRem x y) 116 | 117 | remLaw :: forall a. (Eq a, Euclidean a, Arbitrary a, Show a) => Proxy a -> Property 118 | remLaw _ = property $ \(x :: a) y -> 119 | y /= zero ==> rem x y === snd (quotRem x y) 120 | 121 | #endif 122 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Storable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | {-# OPTIONS_GHC -Wall #-} 5 | 6 | module Test.QuickCheck.Classes.Storable 7 | ( storableLaws 8 | ) where 9 | 10 | import Control.Applicative 11 | import Control.Monad 12 | import Data.Proxy (Proxy) 13 | import Foreign.Marshal.Alloc 14 | import Foreign.Marshal.Array 15 | import Foreign.Storable 16 | import GHC.Ptr (Ptr(..), plusPtr) 17 | import Test.QuickCheck hiding ((.&.)) 18 | 19 | import Test.QuickCheck.Classes.Internal (Laws(..)) 20 | 21 | -- | Tests the following 'Storable' properties: 22 | -- 23 | -- [/Set-Get/] 24 | -- @('pokeElemOff' ptr ix a >> 'peekElemOff' ptr ix') ≡ 'pure' a@ 25 | -- [/Get-Set/] 26 | -- @('peekElemOff' ptr ix >> 'pokeElemOff' ptr ix a) ≡ 'pure' a@ 27 | storableLaws :: (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws 28 | storableLaws p = Laws "Storable" 29 | [ ("Set-Get (you get back what you put in)", storableSetGet p) 30 | , ("Get-Set (putting back what you got out has no effect)", storableGetSet p) 31 | , ("Set-Set (if you set something twice, the first set is inconsequential", storableSetSet p) 32 | , ("List Conversion Roundtrips", storableList p) 33 | , ("peekElemOff a i ≡ peek (plusPtr a (i * sizeOf undefined))", storablePeekElem p) 34 | , ("peekElemOff a i x ≡ poke (plusPtr a (i * sizeOf undefined)) x ≡ id ", storablePokeElem p) 35 | , ("peekByteOff a i ≡ peek (plusPtr a i)", storablePeekByte p) 36 | , ("peekByteOff a i x ≡ poke (plusPtr a i) x ≡ id ", storablePokeByte p) 37 | ] 38 | 39 | arrayArbitrary :: forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a) 40 | arrayArbitrary = newArray <=< generate . vector 41 | 42 | storablePeekElem :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 43 | storablePeekElem _ = property $ \(Positive len) ix' -> ioProperty $ do 44 | let ix = ix' `mod` len 45 | addr :: Ptr a <- arrayArbitrary len 46 | x <- peekElemOff addr ix 47 | y <- peek (addr `advancePtr` ix) 48 | free addr 49 | return (x ==== y) 50 | 51 | storablePokeElem :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 52 | storablePokeElem _ = property $ \(Positive len) (x :: a) ix' -> ioProperty $ do 53 | let ix = ix' `mod` len 54 | addr <- arrayArbitrary len 55 | pokeElemOff addr ix x 56 | u <- peekElemOff addr ix 57 | poke (addr `advancePtr` ix) x 58 | v <- peekElemOff addr ix 59 | free addr 60 | return (u ==== v) 61 | 62 | storablePeekByte :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 63 | storablePeekByte _ = property $ \(Positive len) off' -> ioProperty $ do 64 | let off = (off' `mod` len) * sizeOf (undefined :: a) 65 | addr :: Ptr a <- arrayArbitrary len 66 | x :: a <- peekByteOff addr off 67 | y :: a <- peek (addr `plusPtr` off) 68 | free addr 69 | return (x ==== y) 70 | 71 | storablePokeByte :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 72 | storablePokeByte _ = property $ \(Positive len) (x :: a) off' -> ioProperty $ do 73 | let off = (off' `mod` len) * sizeOf (undefined :: a) 74 | addr :: Ptr a <- arrayArbitrary len 75 | pokeByteOff addr off x 76 | u :: a <- peekByteOff addr off 77 | poke (addr `plusPtr` off) x 78 | v :: a <- peekByteOff addr off 79 | free addr 80 | return (u ==== v) 81 | 82 | storableSetGet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 83 | storableSetGet _ = property $ \(a :: a) (Positive len) ix' -> ioProperty $ do 84 | let ix = ix' `mod` len 85 | ptr <- arrayArbitrary len 86 | pokeElemOff ptr ix a 87 | a' <- peekElemOff ptr ix 88 | free ptr 89 | return (a ==== a') 90 | 91 | storableGetSet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 92 | storableGetSet _ = property $ \(NonEmpty (as :: [a])) ix' -> ioProperty $ do 93 | let len = length as 94 | ix = ix' `mod` len 95 | ptrA <- newArray as 96 | ptrB <- arrayArbitrary len 97 | copyArray ptrB ptrA len 98 | a <- peekElemOff ptrA ix 99 | pokeElemOff ptrA ix a 100 | 101 | arrA <- peekArray len ptrA 102 | arrB <- peekArray len ptrB 103 | free ptrA 104 | free ptrB 105 | return $ conjoin $ zipWith (===) arrA arrB 106 | 107 | storableSetSet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 108 | storableSetSet _ = property $ \(x :: a) (y :: a) (Positive len) ix' -> ioProperty $ do 109 | let ix = ix' `mod` len 110 | ptr <- arrayArbitrary len 111 | pokeElemOff ptr ix x 112 | pokeElemOff ptr ix y 113 | atIx <- peekElemOff ptr ix 114 | free ptr 115 | return $ atIx ==== y 116 | 117 | storableList :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 118 | storableList _ = property $ \(as :: [a]) -> ioProperty $ do 119 | let len = length as 120 | ptr <- newArray as 121 | let rebuild !ix = if ix < len 122 | then (:) <$> peekElemOff ptr ix <*> rebuild (ix + 1) 123 | else return [] 124 | asNew <- rebuild 0 125 | free ptr 126 | return (as ==== asNew) 127 | 128 | (====) :: (Eq a, Show a) => a -> a -> Property 129 | x ==== y 130 | | x /= x && y /= y = discard 131 | | otherwise = x === y 132 | -------------------------------------------------------------------------------- /quickcheck-classes/test/Spec/ShowRead.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | 4 | module Spec.ShowRead where 5 | 6 | import Control.Applicative (liftA2) 7 | import Data.Complex (Complex) 8 | import Data.Fixed (E0, E1, E12, Fixed, HasResolution) 9 | import Data.Int (Int64, Int8) 10 | import Data.Orphans () 11 | import Data.Proxy (Proxy(Proxy)) 12 | import Data.Ratio (Ratio) 13 | import Data.Word 14 | import Test.QuickCheck (Arbitrary(arbitrary), elements) 15 | #if MIN_VERSION_QuickCheck(2,8,2) 16 | import Data.IntMap (IntMap) 17 | import Data.IntSet (IntSet) 18 | import Data.Map (Map) 19 | import Data.Sequence (Seq) 20 | import Data.Set (Set) 21 | #endif 22 | #if MIN_VERSION_QuickCheck(2,9,0) 23 | import Control.Applicative (Const, ZipList) 24 | import Data.Functor.Constant (Constant) 25 | import Data.Functor.Identity (Identity) 26 | import Data.Version (Version) 27 | #endif 28 | #if MIN_VERSION_QuickCheck(2,10,0) 29 | import Data.Functor.Compose (Compose) 30 | import Data.Functor.Product (Product) 31 | #endif 32 | 33 | import Test.QuickCheck.Classes 34 | 35 | data Prefix = Prefix | Prefix' | Prefix_ 36 | deriving (Eq, Read, Show) 37 | 38 | instance Arbitrary Prefix where 39 | arbitrary = elements [Prefix, Prefix', Prefix_] 40 | 41 | data WeirdRecord = (:*) { left :: Int, right :: Int } 42 | deriving (Eq, Read, Show) 43 | 44 | instance Arbitrary WeirdRecord where 45 | arbitrary = liftA2 (:*) arbitrary arbitrary 46 | 47 | lawsApplied :: [(String,[Laws])] 48 | lawsApplied = 49 | [ -- local 50 | ("Prefix", allShowReadLaws (Proxy :: Proxy Prefix)) 51 | , ("WeirdRecord", allShowReadLaws (Proxy :: Proxy WeirdRecord)) 52 | 53 | -- base 54 | , ("()", allShowReadLaws (Proxy :: Proxy ())) 55 | , ("Bool", allShowReadLaws (Proxy :: Proxy Bool)) 56 | , ("Char", allShowReadLaws (Proxy :: Proxy Char)) 57 | , ("Complex Float", allShowReadLaws (Proxy :: Proxy (Complex Float))) 58 | , ("Complex Double", allShowReadLaws (Proxy :: Proxy (Complex Double))) 59 | , ("Double", allShowReadLaws (Proxy :: Proxy Double)) 60 | , ("Either", allShowReadLaws (Proxy :: Proxy (Either Int Int))) 61 | , ("Fixed E12", allFixedLaws (Proxy :: Proxy (Fixed E12))) 62 | -- , ("Fixed E9", allFixedLaws (Proxy :: Proxy (Fixed E9))) 63 | -- , ("Fixed E6", allFixedLaws (Proxy :: Proxy (Fixed E6))) 64 | -- , ("Fixed E3", allFixedLaws (Proxy :: Proxy (Fixed E3))) 65 | -- , ("Fixed E2", allFixedLaws (Proxy :: Proxy (Fixed E2))) 66 | , ("Fixed E1", allFixedLaws (Proxy :: Proxy (Fixed E1))) 67 | , ("Fixed E0", allFixedLaws (Proxy :: Proxy (Fixed E0))) 68 | , ("Float", allShowReadLaws (Proxy :: Proxy Float)) 69 | , ("Int", allShowReadLaws (Proxy :: Proxy Int)) 70 | -- , ("Int16", allShowReadLaws (Proxy :: Proxy Int16)) 71 | -- , ("Int32", allShowReadLaws (Proxy :: Proxy Int32)) 72 | , ("Int64", allShowReadLaws (Proxy :: Proxy Int64)) 73 | , ("Int8", allShowReadLaws (Proxy :: Proxy Int8)) 74 | , ("Integer", allShowReadLaws (Proxy :: Proxy Integer)) 75 | , ("List", allShowReadLaws (Proxy :: Proxy [Int])) 76 | , ("Maybe", allShowReadLaws (Proxy :: Proxy (Maybe Int))) 77 | , ("Ordering", allShowReadLaws (Proxy :: Proxy Ordering)) 78 | , ("Ratio", allShowReadLaws (Proxy :: Proxy (Ratio Int))) 79 | , ("Tuple2", allShowReadLaws (Proxy :: Proxy (Int,Int))) 80 | , ("Tuple3", allShowReadLaws (Proxy :: Proxy (Int,Int,Int))) 81 | , ("Word", allShowReadLaws (Proxy :: Proxy Word)) 82 | -- , ("Word16", allShowReadLaws (Proxy :: Proxy Word16)) 83 | -- , ("Word32", allShowReadLaws (Proxy :: Proxy Word32)) 84 | , ("Word64", allShowReadLaws (Proxy :: Proxy Word64)) 85 | , ("Word8", allShowReadLaws (Proxy :: Proxy Word8)) 86 | #if MIN_VERSION_QuickCheck(2,9,0) 87 | , ("Const", allShowReadLaws (Proxy :: Proxy (Const Int Int))) 88 | , ("Constant", allShowReadLaws (Proxy :: Proxy (Constant Int Int))) 89 | , ("Identity", allShowReadLaws (Proxy :: Proxy (Identity Int))) 90 | , ("Version", allShowReadLaws (Proxy :: Proxy Version)) 91 | , ("ZipList", allShowReadLaws (Proxy :: Proxy (ZipList Int))) 92 | #endif 93 | #if MIN_VERSION_QuickCheck(2,10,0) 94 | , ("Compose", allShowReadLaws (Proxy :: Proxy (Compose [] Maybe Int))) 95 | , ("Product", allShowReadLaws (Proxy :: Proxy (Product [] Maybe Int))) 96 | #endif 97 | 98 | -- containers 99 | #if MIN_VERSION_QuickCheck(2,8,2) 100 | , ("IntMap", allShowReadLaws (Proxy :: Proxy (IntMap Int))) 101 | , ("IntSet", allShowReadLaws (Proxy :: Proxy IntSet)) 102 | , ("Map", allShowReadLaws (Proxy :: Proxy (Map Int Int))) 103 | , ("Seq", allShowReadLaws (Proxy :: Proxy (Seq Int))) 104 | , ("Set", allShowReadLaws (Proxy :: Proxy (Set Int))) 105 | #endif 106 | ] 107 | 108 | allShowReadLaws :: (Show a, Read a, Eq a, Arbitrary a) => Proxy a -> [Laws] 109 | allShowReadLaws p = map ($p) 110 | [ showLaws 111 | , showReadLaws 112 | ] 113 | 114 | allFixedLaws :: HasResolution e => Proxy (Fixed e) -> [Laws] 115 | allFixedLaws p = map ($p) 116 | [ showLaws 117 | #if MIN_VERSION_base(4,7,0) 118 | -- Earlier versions of base have a buggy read instance. 119 | , showReadLaws 120 | #endif 121 | ] 122 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Bifoldable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | #if HAVE_QUANTIFIED_CONSTRAINTS 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | #endif 7 | 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | module Test.QuickCheck.Classes.Bifoldable 11 | ( 12 | #if HAVE_BINARY_LAWS 13 | bifoldableLaws 14 | , bifoldableFunctorLaws 15 | #endif 16 | ) where 17 | 18 | #if HAVE_BINARY_LAWS 19 | import Data.Bifoldable(Bifoldable(..)) 20 | import Data.Bifunctor (Bifunctor(..)) 21 | import Test.QuickCheck hiding ((.&.)) 22 | import Data.Functor.Classes (Eq2,Show2) 23 | import Data.Monoid 24 | import Test.QuickCheck.Classes.Internal 25 | #endif 26 | 27 | #if HAVE_BINARY_LAWS 28 | 29 | -- | Tests the following 'Bifunctor' properties: 30 | -- 31 | -- [/Bifold Identity/] 32 | -- @'bifold' ≡ 'bifoldMap' 'id' 'id'@ 33 | -- [/BifoldMap Identity/] 34 | -- @'bifoldMap' f g ≡ 'bifoldr' ('mappend' '.' f) ('mappend' '.' g) 'mempty'@ 35 | -- [/Bifoldr Identity/] 36 | -- @'bifoldr' f g z t ≡ 'appEndo' ('bifoldMap' ('Endo' '.' f) ('Endo' '.' g) t) z@ 37 | -- 38 | -- /Note/: This property test is only available when this package is built with 39 | -- @base-4.10+@ or @transformers-0.5+@. 40 | bifoldableLaws :: forall proxy f. 41 | #if HAVE_QUANTIFIED_CONSTRAINTS 42 | (Bifoldable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 43 | #else 44 | (Bifoldable f, Eq2 f, Show2 f, Arbitrary2 f) 45 | #endif 46 | => proxy f -> Laws 47 | bifoldableLaws p = Laws "Bifoldable" 48 | [ ("Bifold Identity", bifoldIdentity p) 49 | , ("BifoldMap Identity", bifoldMapIdentity p) 50 | , ("Bifoldr Identity", bifoldrIdentity p) 51 | ] 52 | 53 | -- | Tests the following 'Bifunctor'/'Bifoldable' properties: 54 | -- 55 | -- [/Bifold Identity/] 56 | -- @'bifoldMap' f g ≡ 'bifold' '.' 'bimap' f g@ 57 | -- [/BifoldMap Identity/] 58 | -- @'bifoldMap' f g '.' 'bimap' h i ≡ 'bifoldMap' (f '.' h) (g '.' i)@ 59 | -- 60 | -- /Note/: This property test is only available when this package is built with 61 | -- @base-4.10+@ or @transformers-0.5+@. 62 | bifoldableFunctorLaws :: forall proxy f. 63 | #if HAVE_QUANTIFIED_CONSTRAINTS 64 | (Bifoldable f, Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 65 | #else 66 | (Bifoldable f, Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) 67 | #endif 68 | => proxy f -> Laws 69 | bifoldableFunctorLaws p = Laws "Bifoldable/Bifunctor" 70 | [ ("Bifoldable Bifunctor Law", bifoldableFunctorLaw p) 71 | , ("Bifoldable Bifunctor Law Implication", bifoldableFunctorImplication p) 72 | ] 73 | 74 | bifoldableFunctorLaw :: forall proxy f. 75 | #if HAVE_QUANTIFIED_CONSTRAINTS 76 | (Bifoldable f, Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 77 | #else 78 | (Bifoldable f, Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) 79 | #endif 80 | => proxy f -> Property 81 | bifoldableFunctorLaw _ = property $ \(Apply2 (x :: f Integer Integer)) -> bifoldMap mkMonoid mkMonoid x == (bifold (bimap mkMonoid mkMonoid x)) 82 | 83 | bifoldableFunctorImplication :: forall proxy f. 84 | #if HAVE_QUANTIFIED_CONSTRAINTS 85 | (Bifoldable f, Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 86 | #else 87 | (Bifoldable f, Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) 88 | #endif 89 | => proxy f -> Property 90 | bifoldableFunctorImplication _ = property $ \(Apply2 (x :: f Integer Integer)) -> bifoldMap mkMonoid mkMonoid (bimap mkMonoid mkMonoid x) == bifoldMap (mkMonoid . mkMonoid) (mkMonoid . mkMonoid) x 91 | 92 | bifoldIdentity :: forall proxy f. 93 | #if HAVE_QUANTIFIED_CONSTRAINTS 94 | (Bifoldable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 95 | #else 96 | (Bifoldable f, Eq2 f, Show2 f, Arbitrary2 f) 97 | #endif 98 | => proxy f -> Property 99 | bifoldIdentity _ = property $ \(Apply2 (x :: f [Integer] [Integer])) -> (bifold x) == (bifoldMap id id x) 100 | 101 | bifoldMapIdentity :: forall proxy f. 102 | #if HAVE_QUANTIFIED_CONSTRAINTS 103 | (Bifoldable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 104 | #else 105 | (Bifoldable f, Eq2 f, Show2 f, Arbitrary2 f) 106 | #endif 107 | => proxy f -> Property 108 | bifoldMapIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> bifoldMap mkMonoid mkMonoid x == bifoldr (mappend . mkMonoid) (mappend . mkMonoid) mempty x 109 | 110 | bifoldrIdentity :: forall proxy f. 111 | #if HAVE_QUANTIFIED_CONSTRAINTS 112 | (Bifoldable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) 113 | #else 114 | (Bifoldable f, Eq2 f, Show2 f, Arbitrary2 f) 115 | #endif 116 | => proxy f -> Property 117 | bifoldrIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> 118 | let f _ _ = mempty 119 | g _ _ = mempty 120 | in bifoldr f g (mempty :: [Integer]) x == appEndo (bifoldMap (Endo . f) (Endo . g) x) mempty 121 | 122 | mkMonoid :: a -> [a] 123 | mkMonoid x = [x] 124 | #endif 125 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Semigroup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | {-# OPTIONS_GHC -Wall #-} 4 | 5 | module Test.QuickCheck.Classes.Semigroup 6 | ( -- * Laws 7 | semigroupLaws 8 | , commutativeSemigroupLaws 9 | , exponentialSemigroupLaws 10 | , idempotentSemigroupLaws 11 | , rectangularBandSemigroupLaws 12 | ) where 13 | 14 | import Prelude hiding (foldr1) 15 | import Data.Semigroup (Semigroup(..)) 16 | import Data.Proxy (Proxy) 17 | import Test.QuickCheck hiding ((.&.)) 18 | 19 | import Test.QuickCheck.Classes.Internal (Laws(..), SmallList(..), myForAllShrink) 20 | 21 | import Data.Foldable (foldr1,toList) 22 | import Data.List.NonEmpty (NonEmpty((:|))) 23 | 24 | -- | Tests the following properties: 25 | -- 26 | -- [/Associative/] 27 | -- @a '<>' (b '<>' c) ≡ (a '<>' b) '<>' c@ 28 | -- [/Concatenation/] 29 | -- @'sconcat' as ≡ 'foldr1' ('<>') as@ 30 | -- [/Times/] 31 | -- @'stimes' n a ≡ 'foldr1' ('<>') ('replicate' n a)@ 32 | semigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws 33 | semigroupLaws p = Laws "Semigroup" 34 | [ ("Associative", semigroupAssociative p) 35 | , ("Concatenation", semigroupConcatenation p) 36 | , ("Times", semigroupTimes p) 37 | ] 38 | 39 | -- | Tests the following properties: 40 | -- 41 | -- [/Commutative/] 42 | -- @a '<>' b ≡ b '<>' a@ 43 | -- 44 | -- Note that this does not test associativity. Make sure to use 45 | -- 'semigroupLaws' in addition to this set of laws. 46 | commutativeSemigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws 47 | commutativeSemigroupLaws p = Laws "Commutative Semigroup" 48 | [ ("Commutative", semigroupCommutative p) 49 | ] 50 | 51 | -- | Tests the following properties: 52 | -- 53 | -- [/Idempotent/] 54 | -- @a '<>' a ≡ a@ 55 | -- 56 | -- Note that this does not test associativity. Make sure to use 57 | -- 'semigroupLaws' in addition to this set of laws. In literature, 58 | -- this class of semigroup is known as a band. 59 | idempotentSemigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws 60 | idempotentSemigroupLaws p = Laws "Idempotent Semigroup" 61 | [ ("Idempotent", semigroupIdempotent p) 62 | ] 63 | 64 | -- | Tests the following properties: 65 | -- 66 | -- [/Rectangular Band/] 67 | -- @a '<>' b '<>' a ≡ a@ 68 | -- 69 | -- Note that this does not test associativity. Make sure to use 70 | -- 'semigroupLaws' in addition to this set of laws. 71 | rectangularBandSemigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws 72 | rectangularBandSemigroupLaws p = Laws "Rectangular Band Semigroup" 73 | [ ("Rectangular Band", semigroupRectangularBand p) 74 | ] 75 | 76 | -- | Tests the following properties: 77 | -- 78 | -- [/Exponential/] 79 | -- @'stimes' n (a '<>' b) ≡ 'stimes' n a '<>' 'stimes' n b@ 80 | -- 81 | -- Note that this does not test associativity. Make sure to use 82 | -- 'semigroupLaws' in addition to this set of laws. 83 | exponentialSemigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws 84 | exponentialSemigroupLaws p = Laws "Exponential Semigroup" 85 | [ ("Exponential", semigroupExponential p) 86 | ] 87 | 88 | semigroupAssociative :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 89 | semigroupAssociative _ = myForAllShrink True (const True) 90 | (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) 91 | "a <> (b <> c)" 92 | (\(a,b,c) -> a <> (b <> c)) 93 | "(a <> b) <> c" 94 | (\(a,b,c) -> (a <> b) <> c) 95 | 96 | semigroupCommutative :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 97 | semigroupCommutative _ = myForAllShrink True (const True) 98 | (\(a :: a,b) -> ["a = " ++ show a, "b = " ++ show b]) 99 | "a <> b" 100 | (\(a,b) -> a <> b) 101 | "b <> a" 102 | (\(a,b) -> b <> a) 103 | 104 | semigroupConcatenation :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 105 | semigroupConcatenation _ = myForAllShrink True (const True) 106 | (\(a, SmallList (as :: [a])) -> ["as = " ++ show (a :| as)]) 107 | "sconcat as" 108 | (\(a, SmallList as) -> sconcat (a :| as)) 109 | "foldr1 (<>) as" 110 | (\(a, SmallList as) -> foldr1 (<>) (a :| as)) 111 | 112 | semigroupTimes :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 113 | semigroupTimes _ = myForAllShrink True (const True) 114 | (\(a :: a, Positive (n :: Int)) -> ["a = " ++ show a, "n = " ++ show n]) 115 | "stimes n a" 116 | (\(a, Positive n) -> stimes n a) 117 | "foldr1 (<>) (replicate n a)" 118 | (\(a, Positive n) -> foldr1 (<>) (replicate n a)) 119 | 120 | semigroupExponential :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 121 | semigroupExponential _ = myForAllShrink True (const True) 122 | (\(a :: a, b, Positive (n :: Int)) -> ["a = " ++ show a, "b = " ++ show b, "n = " ++ show n]) 123 | "stimes n (a <> b)" 124 | (\(a, b, Positive n) -> stimes n (a <> b)) 125 | "stimes n a <> stimes n b" 126 | (\(a, b, Positive n) -> stimes n a <> stimes n b) 127 | 128 | semigroupIdempotent :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 129 | semigroupIdempotent _ = myForAllShrink False (const True) 130 | (\(a :: a) -> ["a = " ++ show a]) 131 | "a <> a" 132 | (\a -> a <> a) 133 | "a" 134 | (\a -> a) 135 | 136 | semigroupRectangularBand :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 137 | semigroupRectangularBand _ = myForAllShrink False (const True) 138 | (\(a :: a, b) -> ["a = " ++ show a, "b = " ++ show b]) 139 | "a <> b <> a" 140 | (\(a,b) -> a <> b <> a) 141 | "a" 142 | (\(a,_) -> a) 143 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Num.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | {-# OPTIONS_GHC -Wall #-} 4 | 5 | module Test.QuickCheck.Classes.Num 6 | ( numLaws 7 | ) where 8 | 9 | import Data.Proxy (Proxy) 10 | import Test.QuickCheck hiding ((.&.)) 11 | 12 | import Test.QuickCheck.Classes.Internal (Laws(..), myForAllShrink) 13 | 14 | -- | Tests the following properties: 15 | -- 16 | -- [/Additive Commutativity/] 17 | -- @a + b ≡ b + a@ 18 | -- [/Additive Left Identity/] 19 | -- @0 + a ≡ a@ 20 | -- [/Additive Right Identity/] 21 | -- @a + 0 ≡ a@ 22 | -- [/Multiplicative Associativity/] 23 | -- @a * (b * c) ≡ (a * b) * c@ 24 | -- [/Multiplicative Left Identity/] 25 | -- @1 * a ≡ a@ 26 | -- [/Multiplicative Right Identity/] 27 | -- @a * 1 ≡ a@ 28 | -- [/Multiplication Left Distributes Over Addition/] 29 | -- @a * (b + c) ≡ (a * b) + (a * c)@ 30 | -- [/Multiplication Right Distributes Over Addition/] 31 | -- @(a + b) * c ≡ (a * c) + (b * c)@ 32 | -- [/Multiplicative Left Annihilation/] 33 | -- @0 * a ≡ 0@ 34 | -- [/Multiplicative Right Annihilation/] 35 | -- @a * 0 ≡ 0@ 36 | -- [/Additive Inverse/] 37 | -- @'negate' a '+' a ≡ 0@ 38 | -- [/Subtraction/] 39 | -- @a '+' 'negate' b ≡ a '-' b@ 40 | -- [/Abs Is Idempotent/] 41 | -- @'abs' ('abs' a) ≡ 'abs' a 42 | -- [/Signum Is Idempotent/] 43 | -- @'signum' ('signum' a) ≡ 'signum' a 44 | -- [/Product Of Abs And Signum Is Id/] 45 | -- @'abs' a * 'signum' a ≡ a@ 46 | numLaws :: (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws 47 | numLaws p = Laws "Num" 48 | [ ("Additive Commutativity", numCommutativePlus p) 49 | , ("Additive Left Identity", numLeftIdentityPlus p) 50 | , ("Additive Right Identity", numRightIdentityPlus p) 51 | , ("Multiplicative Associativity", numAssociativeTimes p) 52 | , ("Multiplicative Left Identity", numLeftIdentityTimes p) 53 | , ("Multiplicative Right Identity", numRightIdentityTimes p) 54 | , ("Multiplication Left Distributes Over Addition", numLeftMultiplicationDistributes p) 55 | , ("Multiplication Right Distributes Over Addition", numRightMultiplicationDistributes p) 56 | , ("Multiplicative Left Annihilation", numLeftAnnihilation p) 57 | , ("Multiplicative Right Annihilation", numRightAnnihilation p) 58 | , ("Additive Inverse", numAdditiveInverse p) 59 | , ("Subtraction", numSubtraction p) 60 | , ("Abs Is Idempotent", absIdempotence p) 61 | , ("Signum Is Idempotent", signumIdempotence p) 62 | , ("Product Of Abs And Signum Is Id", absSignumId p) 63 | ] 64 | 65 | numLeftMultiplicationDistributes :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 66 | numLeftMultiplicationDistributes _ = myForAllShrink True (const True) 67 | (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) 68 | "a * (b + c)" 69 | (\(a,b,c) -> a * (b + c)) 70 | "(a * b) + (a * c)" 71 | (\(a,b,c) -> (a * b) + (a * c)) 72 | 73 | numRightMultiplicationDistributes :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 74 | numRightMultiplicationDistributes _ = myForAllShrink True (const True) 75 | (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) 76 | "(a + b) * c" 77 | (\(a,b,c) -> (a + b) * c) 78 | "(a * c) + (b * c)" 79 | (\(a,b,c) -> (a * c) + (b * c)) 80 | 81 | numLeftIdentityPlus :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 82 | numLeftIdentityPlus _ = myForAllShrink False (const True) 83 | (\(a :: a) -> ["a = " ++ show a]) 84 | "0 + a" 85 | (\a -> 0 + a) 86 | "a" 87 | (\a -> a) 88 | 89 | numRightIdentityPlus :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 90 | numRightIdentityPlus _ = myForAllShrink False (const True) 91 | (\(a :: a) -> ["a = " ++ show a]) 92 | "a + 0" 93 | (\a -> a + 0) 94 | "a" 95 | (\a -> a) 96 | 97 | numRightIdentityTimes :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 98 | numRightIdentityTimes _ = myForAllShrink False (const True) 99 | (\(a :: a) -> ["a = " ++ show a]) 100 | "a * 1" 101 | (\a -> a * 1) 102 | "a" 103 | (\a -> a) 104 | 105 | numLeftIdentityTimes :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 106 | numLeftIdentityTimes _ = myForAllShrink False (const True) 107 | (\(a :: a) -> ["a = " ++ show a]) 108 | "1 * a" 109 | (\a -> 1 * a) 110 | "a" 111 | (\a -> a) 112 | 113 | numLeftAnnihilation :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 114 | numLeftAnnihilation _ = myForAllShrink False (const True) 115 | (\(a :: a) -> ["a = " ++ show a]) 116 | "0 * a" 117 | (\a -> 0 * a) 118 | "0" 119 | (\_ -> 0) 120 | 121 | numRightAnnihilation :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 122 | numRightAnnihilation _ = myForAllShrink False (const True) 123 | (\(a :: a) -> ["a = " ++ show a]) 124 | "a * 0" 125 | (\a -> a * 0) 126 | "0" 127 | (\_ -> 0) 128 | 129 | numCommutativePlus :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 130 | numCommutativePlus _ = myForAllShrink True (const True) 131 | (\(a :: a,b) -> ["a = " ++ show a, "b = " ++ show b]) 132 | "a + b" 133 | (\(a,b) -> a + b) 134 | "b + a" 135 | (\(a,b) -> b + a) 136 | 137 | numAssociativeTimes :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 138 | numAssociativeTimes _ = myForAllShrink True (const True) 139 | (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) 140 | "a * (b * c)" 141 | (\(a,b,c) -> a * (b * c)) 142 | "(a * b) * c" 143 | (\(a,b,c) -> (a * b) * c) 144 | 145 | numAdditiveInverse :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 146 | numAdditiveInverse _ = myForAllShrink True (const True) 147 | (\(a :: a) -> ["a = " ++ show a]) 148 | "negate a + a" 149 | (\a -> (-a) + a) 150 | "0" 151 | (const 0) 152 | 153 | numSubtraction :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 154 | numSubtraction _ = myForAllShrink True (const True) 155 | (\(a :: a, b :: a) -> ["a = " ++ show a, "b = " ++ show b]) 156 | "a + negate b" 157 | (\(a,b) -> a + negate b) 158 | "a - b" 159 | (\(a,b) -> a - b) 160 | 161 | absIdempotence :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 162 | absIdempotence _ = myForAllShrink True (const True) 163 | (\(a :: a) -> ["a = " ++ show a]) 164 | "abs (abs a)" 165 | (abs . abs) 166 | "abs a" 167 | abs 168 | 169 | signumIdempotence :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 170 | signumIdempotence _ = myForAllShrink True (const True) 171 | (\(a :: a) -> ["a = " ++ show a]) 172 | "signum (signum a)" 173 | (signum . signum) 174 | "signum a" 175 | signum 176 | 177 | absSignumId :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 178 | absSignumId _ = myForAllShrink True (const True) 179 | (\(a :: a) -> ["a = " ++ show a]) 180 | "abs a * signum a" 181 | (\a -> abs a * signum a) 182 | "a" 183 | id 184 | -------------------------------------------------------------------------------- /quickcheck-classes/quickcheck-classes.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: quickcheck-classes 3 | version: 0.6.5.0 4 | synopsis: QuickCheck common typeclasses 5 | description: 6 | This library provides QuickCheck properties to ensure 7 | that typeclass instances adhere to the set of laws that 8 | they are supposed to. There are other libraries that do 9 | similar things, such as [genvalidity-hspec](https://hackage.haskell.org/package/genvalidity-hspec) 10 | and [checkers](https://hackage.haskell.org/package/checkers). 11 | This library differs from other solutions by not introducing 12 | any new typeclasses that the user needs to learn. 13 | . 14 | /Note:/ on GHC < 8.5, this library uses the higher-kinded typeclasses 15 | ('Data.Functor.Classes.Show1', 'Data.Functor.Classes.Eq1', 'Data.Functor.Classes.Ord1', etc.), 16 | but on GHC >= 8.5, it uses @-XQuantifiedConstraints@ to express these 17 | constraints more cleanly. 18 | homepage: https://github.com/andrewthad/quickcheck-classes#readme 19 | license: BSD-3-Clause 20 | license-file: LICENSE 21 | author: Andrew Martin, chessai 22 | maintainer: andrew.thaddeus@gmail.com 23 | copyright: 2018 Andrew Martin 24 | category: Testing 25 | build-type: Simple 26 | extra-source-files: README.md 27 | extra-source-files: changelog.md 28 | 29 | flag aeson 30 | description: 31 | You can disable the use of the @aeson@ package using @-f-aeson@. 32 | . 33 | This may be useful for accelerating builds. 34 | default: True 35 | manual: True 36 | 37 | flag semigroupoids 38 | description: 39 | You can disable the use of the @semigroupoids@ package using @-f-semigroupoids@. 40 | . 41 | This may be useful for accelerating builds. 42 | default: True 43 | manual: True 44 | 45 | flag semirings 46 | description: 47 | You can disable the use of the @semirings@ package using @-f-semirings@. 48 | . 49 | This may be useful for accelerating builds. 50 | default: True 51 | manual: True 52 | 53 | flag vector 54 | description: 55 | You can disable the use of the @vector@ package using @-f-vector@. 56 | . 57 | This may be useful for accelerating builds. 58 | default: True 59 | manual: True 60 | 61 | flag unary-laws 62 | description: 63 | Include infrastructure for testing class laws of unary type constructors. 64 | It is required that this flag match the value that the @unary-laws@ flag 65 | was given when building @quickcheck-classes-base@. 66 | default: True 67 | manual: True 68 | 69 | flag binary-laws 70 | description: 71 | Include infrastructure for testing class laws of binary type constructors. 72 | It is required that this flag match the value that the @unary-laws@ flag 73 | was given when building @quickcheck-classes-base@. Disabling @unary-laws@ 74 | while keeping @binary-laws@ enabled is an unsupported configuration. 75 | default: True 76 | manual: True 77 | 78 | library 79 | default-language: Haskell2010 80 | hs-source-dirs: src 81 | exposed-modules: 82 | Test.QuickCheck.Classes 83 | Test.QuickCheck.Classes.IsList 84 | other-modules: 85 | Test.QuickCheck.Classes.Alt 86 | Test.QuickCheck.Classes.Apply 87 | Test.QuickCheck.Classes.Euclidean 88 | Test.QuickCheck.Classes.Json 89 | Test.QuickCheck.Classes.MVector 90 | Test.QuickCheck.Classes.Plus 91 | Test.QuickCheck.Classes.Prim 92 | Test.QuickCheck.Classes.Semigroupoid 93 | Test.QuickCheck.Classes.Semiring 94 | Test.QuickCheck.Classes.Ring 95 | build-depends: 96 | , base >= 4.5 && < 5 97 | , QuickCheck >= 2.7 98 | , transformers >= 0.3 && < 0.7 99 | , primitive >= 0.6.4 && < 0.10 100 | , primitive-addr >= 0.1.0.2 && < 0.2 101 | , containers >= 0.4.2.1 102 | , quickcheck-classes-base >=0.6.2 && <0.7 103 | if impl(ghc < 8.0) 104 | build-depends: 105 | , semigroups >= 0.17 106 | , fail 107 | if impl(ghc < 7.8) 108 | build-depends: tagged 109 | if impl(ghc > 7.4) && impl(ghc < 7.6) 110 | build-depends: ghc-prim 111 | if impl(ghc > 8.5) 112 | cpp-options: -DHAVE_QUANTIFIED_CONSTRAINTS 113 | if flag(unary-laws) 114 | build-depends: 115 | , transformers >= 0.4.0 116 | , QuickCheck >= 2.10.0 117 | cpp-options: -DHAVE_UNARY_LAWS 118 | if flag(binary-laws) 119 | build-depends: 120 | , transformers >= 0.5.0 121 | , QuickCheck >= 2.10.0 122 | cpp-options: -DHAVE_BINARY_LAWS 123 | if flag(aeson) 124 | build-depends: aeson >= 0.9 125 | cpp-options: -DHAVE_AESON 126 | if flag(semigroupoids) 127 | build-depends: semigroupoids 128 | cpp-options: -DHAVE_SEMIGROUPOIDS 129 | if flag(semirings) 130 | build-depends: semirings >= 0.4.2 131 | cpp-options: -DHAVE_SEMIRINGS 132 | if flag(vector) 133 | build-depends: vector >= 0.12 134 | cpp-options: -DHAVE_VECTOR 135 | 136 | -- The basic test suite is compatible with all the versions of GHC that 137 | -- this library supports. It is useful for confirming whether the laws tests 138 | -- behave correct. Additionally, it helps catch CPP mistakes. 139 | test-suite basic 140 | type: exitcode-stdio-1.0 141 | hs-source-dirs: test 142 | main-is: Spec.hs 143 | other-modules: 144 | Spec.ShowRead 145 | build-depends: 146 | , base 147 | , base-orphans >= 0.5 148 | , quickcheck-classes 149 | , QuickCheck 150 | , containers 151 | , primitive 152 | , vector 153 | , transformers 154 | , tagged 155 | if impl(ghc > 8.5) 156 | cpp-options: -DHAVE_QUANTIFIED_CONSTRAINTS 157 | if flag(unary-laws) 158 | cpp-options: -DHAVE_UNARY_LAWS 159 | if flag(binary-laws) 160 | cpp-options: -DHAVE_BINARY_LAWS 161 | if flag(aeson) 162 | build-depends: aeson 163 | cpp-options: -DHAVE_AESON 164 | if flag(semigroupoids) 165 | build-depends: semigroupoids 166 | cpp-options: -DHAVE_SEMIGROUPOIDS 167 | if flag(vector) 168 | build-depends: vector >= 0.12 169 | cpp-options: -DHAVE_VECTOR 170 | default-language: Haskell2010 171 | 172 | -- The advanced test suite only builds with the newest version 173 | -- of GHC. It is intended to be a sort of regression test for GHC and for 174 | -- base. It check instances for a number of types in base. It also checks 175 | -- a bunch of derived instances for data types of varying sizes. And it 176 | -- does some tests on UnboxedSums. 177 | test-suite advanced 178 | type: exitcode-stdio-1.0 179 | hs-source-dirs: test 180 | main-is: Advanced.hs 181 | ghc-options: -O2 182 | build-depends: 183 | , QuickCheck 184 | , base >= 4.12 185 | , base-orphans >= 0.5 186 | , containers 187 | , primitive 188 | , quickcheck-classes 189 | , tagged 190 | , tasty 191 | , tasty-quickcheck 192 | , transformers 193 | , vector 194 | if impl(ghc < 8.6) 195 | buildable: False 196 | default-language: Haskell2010 197 | 198 | source-repository head 199 | type: git 200 | location: https://github.com/andrewthad/quickcheck-classes 201 | -------------------------------------------------------------------------------- /quickcheck-classes/test/Advanced.hs: -------------------------------------------------------------------------------- 1 | {-# language DerivingStrategies #-} 2 | {-# language DerivingVia #-} 3 | {-# language GeneralizedNewtypeDeriving #-} 4 | {-# language LambdaCase #-} 5 | {-# language ScopedTypeVariables #-} 6 | {-# language TypeApplications #-} 7 | 8 | import Test.Tasty (TestTree,defaultMain,testGroup,adjustOption) 9 | import Test.QuickCheck (Arbitrary) 10 | import Data.Proxy (Proxy(..)) 11 | import Data.Set (Set) 12 | import Data.Primitive (Array) 13 | import Control.Monad (forM_,replicateM) 14 | import Data.Monoid (All(..)) 15 | import Test.QuickCheck.Classes (eqLaws,ordLaws) 16 | import Data.Typeable (Typeable,typeRep) 17 | import Data.Coerce (coerce) 18 | import Data.Set (Set) 19 | 20 | import qualified Data.Set as S 21 | import qualified Data.List as L 22 | import qualified GHC.Exts as E 23 | import qualified Test.QuickCheck as QC 24 | import qualified Test.Tasty.QuickCheck as TQC 25 | import qualified Test.QuickCheck.Classes as QCC 26 | 27 | main :: IO () 28 | main = defaultMain tests 29 | 30 | tests :: TestTree 31 | tests = testGroup "universe" 32 | [ testGroup "deriving" 33 | [ testGroup "strict" 34 | [ laws @A [eqLaws,ordLaws] 35 | , laws @B [eqLaws,ordLaws] 36 | , laws @C [eqLaws,ordLaws] 37 | , laws @D [eqLaws,ordLaws] 38 | , laws @E [eqLaws,ordLaws] 39 | , laws @F [eqLaws,ordLaws] 40 | , laws @G [eqLaws,ordLaws] 41 | , laws @H [eqLaws,ordLaws] 42 | , laws @I [eqLaws,ordLaws] 43 | , laws @K [eqLaws,ordLaws] 44 | ] 45 | , testGroup "thunk" 46 | [ laws @(Thunk A) [eqLaws,ordLaws] 47 | , laws @(Thunk B) [eqLaws,ordLaws] 48 | , laws @(Thunk C) [eqLaws,ordLaws] 49 | , laws @(Thunk D) [eqLaws,ordLaws] 50 | , laws @(Thunk E) [eqLaws,ordLaws] 51 | , laws @(Thunk F) [eqLaws,ordLaws] 52 | , laws @(Thunk G) [eqLaws,ordLaws] 53 | , laws @(Thunk H) [eqLaws,ordLaws] 54 | , laws @(Thunk I) [eqLaws,ordLaws] 55 | , laws @(Thunk K) [eqLaws,ordLaws] 56 | ] 57 | , testGroup "lazy" 58 | [ laws @(Lazy A) [eqLaws,ordLaws] 59 | , laws @(Lazy B) [eqLaws,ordLaws] 60 | , laws @(Lazy C) [eqLaws,ordLaws] 61 | , laws @(Lazy D) [eqLaws,ordLaws] 62 | , laws @(Lazy E) [eqLaws,ordLaws] 63 | , laws @(Lazy F) [eqLaws,ordLaws] 64 | , laws @(Lazy G) [eqLaws,ordLaws] 65 | , laws @(Lazy H) [eqLaws,ordLaws] 66 | , laws @(Lazy I) [eqLaws,ordLaws] 67 | , laws @(Lazy K) [eqLaws,ordLaws] 68 | ] 69 | ] 70 | , testGroup "containers" 71 | [ testGroup "strict" 72 | [ laws @(Set A) [eqLaws,ordLaws] 73 | , laws @(Set B) [eqLaws,ordLaws] 74 | , laws @(Set C) [eqLaws,ordLaws] 75 | , laws @(Set D) [eqLaws,ordLaws] 76 | , laws @(Set E) [eqLaws,ordLaws] 77 | , laws @(Set F) [eqLaws,ordLaws] 78 | , laws @(Set G) [eqLaws,ordLaws] 79 | , laws @(Set H) [eqLaws,ordLaws] 80 | , laws @(Set I) [eqLaws,ordLaws] 81 | , laws @(Set K) [eqLaws,ordLaws] 82 | ] 83 | , testGroup "lazy" 84 | [ laws @(SmallLazySet A) [eqLaws,ordLaws] 85 | , laws @(SmallLazySet B) [eqLaws,ordLaws] 86 | , laws @(SmallLazySet C) [eqLaws,ordLaws] 87 | , laws @(SmallLazySet D) [eqLaws,ordLaws] 88 | , laws @(SmallLazySet E) [eqLaws,ordLaws] 89 | , laws @(SmallLazySet F) [eqLaws,ordLaws] 90 | , laws @(SmallLazySet G) [eqLaws,ordLaws] 91 | , laws @(SmallLazySet H) [eqLaws,ordLaws] 92 | , laws @(SmallLazySet I) [eqLaws,ordLaws] 93 | , laws @(SmallLazySet K) [eqLaws,ordLaws] 94 | ] 95 | ] 96 | ] 97 | 98 | data A = A0 99 | deriving stock (Eq,Ord,Show,Read,Bounded,Enum) 100 | deriving Arbitrary via (Enumeration A) 101 | 102 | data B = B0 | B1 103 | deriving stock (Eq,Ord,Show,Read,Bounded,Enum) 104 | deriving Arbitrary via (Enumeration B) 105 | 106 | data C = C0 | C1 | C2 107 | deriving stock (Eq,Ord,Show,Read,Bounded,Enum) 108 | deriving Arbitrary via (Enumeration C) 109 | 110 | data D = D0 | D1 | D2 | D3 111 | deriving stock (Eq,Ord,Show,Read,Bounded,Enum) 112 | deriving Arbitrary via (Enumeration D) 113 | 114 | data E = E0 | E1 | E2 | E3 | E4 115 | deriving stock (Eq,Ord,Show,Read,Bounded,Enum) 116 | deriving Arbitrary via (Enumeration E) 117 | 118 | data F = F0 | F1 | F2 | F3 | F4 | F5 119 | deriving stock (Eq,Ord,Show,Read,Bounded,Enum) 120 | deriving Arbitrary via (Enumeration F) 121 | 122 | data G = G0 | G1 | G2 | G3 | G4 | G5 | G6 123 | deriving stock (Eq,Ord,Show,Read,Bounded,Enum) 124 | deriving Arbitrary via (Enumeration G) 125 | 126 | data H = H0 | H1 | H2 | H3 | H4 | H5 | H6 | H7 127 | deriving stock (Eq,Ord,Show,Read,Bounded,Enum) 128 | deriving Arbitrary via (Enumeration H) 129 | 130 | data I = I0 | I1 | I2 | I3 | I4 | I5 | I6 | I7 | I8 131 | deriving stock (Eq,Ord,Show,Read,Bounded,Enum) 132 | deriving Arbitrary via (Enumeration I) 133 | 134 | data J = J0 | J1 | J2 | J3 | J4 | J5 | J6 | J7 | J8 | J9 135 | deriving stock (Eq,Ord,Show,Read,Bounded,Enum) 136 | deriving Arbitrary via (Enumeration J) 137 | 138 | data K = K0 | K1 | K2 | K3 | K4 | K5 | K6 | K7 | K8 | K9 | K10 139 | deriving stock (Eq,Ord,Show,Read,Bounded,Enum) 140 | deriving Arbitrary via (Enumeration K) 141 | 142 | laws :: forall a. Typeable a => [Proxy a -> QCC.Laws] -> TestTree 143 | laws = testGroup (show (typeRep (Proxy :: Proxy a))) . map 144 | ( \f -> let QCC.Laws name pairs = f (Proxy :: Proxy a) in 145 | testGroup name (map (uncurry TQC.testProperty) pairs) 146 | ) 147 | 148 | newtype Enumeration a = Enumeration a 149 | 150 | instance (Bounded a, Enum a, Eq a) => Arbitrary (Enumeration a) where 151 | arbitrary = fmap Enumeration TQC.arbitraryBoundedEnum 152 | shrink (Enumeration x) = if x == minBound 153 | then [] 154 | else [Enumeration (pred x)] 155 | 156 | data Thunk a = Thunk a 157 | deriving stock (Eq,Ord,Show,Read) 158 | 159 | newtype Lazy a = Lazy a 160 | deriving newtype (Eq,Ord,Show,Read) 161 | 162 | newtype SmallLazySet a = SmallLazySet (Set a) 163 | deriving newtype (Eq,Ord,Show,Read) 164 | 165 | instance Arbitrary a => Arbitrary (Thunk a) where 166 | arbitrary = do 167 | a <- TQC.arbitrary 168 | let {-# NOINLINE b #-} 169 | b () = a 170 | pure (Thunk (b ())) 171 | shrink (Thunk x) = map Thunk (TQC.shrink x) 172 | 173 | instance Arbitrary a => Arbitrary (Lazy a) where 174 | arbitrary = do 175 | a <- TQC.arbitrary 176 | let {-# NOINLINE b #-} 177 | b () = a 178 | pure (Lazy (b ())) 179 | shrink (Lazy x) = map Lazy (TQC.shrink x) 180 | 181 | instance (Arbitrary a, Ord a) => Arbitrary (SmallLazySet a) where 182 | arbitrary = do 183 | a <- TQC.arbitrary 184 | b <- TQC.arbitrary 185 | c <- TQC.arbitrary 186 | let {-# NOINLINE a' #-} 187 | a' () = a 188 | let {-# NOINLINE b' #-} 189 | b' () = b 190 | let {-# NOINLINE c' #-} 191 | c' () = c 192 | pure (SmallLazySet (S.fromList [a' (), b' (), c' (), a' (), b' (), c' ()])) 193 | 194 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Foldable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | #if HAVE_QUANTIFIED_CONSTRAINTS 6 | {-# LANGUAGE QuantifiedConstraints #-} 7 | #endif 8 | 9 | {-# OPTIONS_GHC -Wall #-} 10 | 11 | module Test.QuickCheck.Classes.Foldable 12 | ( 13 | #if HAVE_UNARY_LAWS 14 | foldableLaws 15 | #endif 16 | ) where 17 | 18 | import Data.Monoid 19 | import Data.Foldable 20 | import Test.QuickCheck hiding ((.&.)) 21 | import Control.Exception (ErrorCall,try,evaluate) 22 | import Control.Monad.Trans.Class (lift) 23 | #if HAVE_UNARY_LAWS 24 | import Test.QuickCheck.Arbitrary (Arbitrary1(..)) 25 | #endif 26 | import Test.QuickCheck.Monadic (monadicIO) 27 | #if HAVE_UNARY_LAWS 28 | import Data.Functor.Classes (Eq1,Show1) 29 | #endif 30 | 31 | import qualified Data.Foldable as F 32 | import qualified Data.Semigroup as SG 33 | 34 | import Test.QuickCheck.Classes.Internal 35 | 36 | #if HAVE_UNARY_LAWS 37 | 38 | -- | Tests the following 'Foldable' properties: 39 | -- 40 | -- [/fold/] 41 | -- @'fold' ≡ 'foldMap' 'id'@ 42 | -- [/foldMap/] 43 | -- @'foldMap' f ≡ 'foldr' ('mappend' . f) 'mempty'@ 44 | -- [/foldr/] 45 | -- @'foldr' f z t ≡ 'appEndo' ('foldMap' ('Endo' . f) t ) z@ 46 | -- [/foldr'/] 47 | -- @'foldr'' f z0 xs ≡ let f\' k x z = k '$!' f x z in 'foldl' f\' 'id' xs z0@ 48 | -- [/foldr1/] 49 | -- @'foldr1' f t ≡ let 'Just' (xs,x) = 'unsnoc' ('toList' t) in 'foldr' f x xs@ 50 | -- [/foldl/] 51 | -- @'foldl' f z t ≡ 'appEndo' ('getDual' ('foldMap' ('Dual' . 'Endo' . 'flip' f) t)) z@ 52 | -- [/foldl'/] 53 | -- @'foldl'' f z0 xs ≡ let f' x k z = k '$!' f z x in 'foldr' f\' 'id' xs z0@ 54 | -- [/foldl1/] 55 | -- @'foldl1' f t ≡ let x : xs = 'toList' t in 'foldl' f x xs@ 56 | -- [/toList/] 57 | -- @'F.toList' ≡ 'foldr' (:) []@ 58 | -- [/null/] 59 | -- @'null' ≡ 'foldr' ('const' ('const' 'False')) 'True'@ 60 | -- [/length/] 61 | -- @'length' ≡ 'getSum' . 'foldMap' ('const' ('Sum' 1))@ 62 | -- 63 | -- Note that this checks to ensure that @foldl\'@ and @foldr\'@ 64 | -- are suitably strict. 65 | foldableLaws :: forall proxy f. 66 | #if HAVE_QUANTIFIED_CONSTRAINTS 67 | (Foldable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 68 | #else 69 | (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) 70 | #endif 71 | => proxy f -> Laws 72 | foldableLaws = foldableLawsInternal 73 | 74 | foldableLawsInternal :: forall proxy f. 75 | #if HAVE_QUANTIFIED_CONSTRAINTS 76 | (Foldable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 77 | #else 78 | (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) 79 | #endif 80 | => proxy f -> Laws 81 | foldableLawsInternal p = Laws "Foldable" 82 | [ (,) "fold" $ property $ \(Apply (a :: f (VerySmallList Integer))) -> 83 | F.fold a == F.foldMap id a 84 | , (,) "foldMap" $ property $ \(Apply (a :: f Integer)) (e :: QuadraticEquation) -> 85 | let f = VerySmallList . return . runQuadraticEquation e 86 | in F.foldMap f a == F.foldr (mappend . f) mempty a 87 | , (,) "foldr" $ property $ \(e :: LinearEquationTwo) (z :: Integer) (Apply (t :: f Integer)) -> 88 | let f = runLinearEquationTwo e 89 | in F.foldr f z t == SG.appEndo (foldMap (SG.Endo . f) t) z 90 | , (,) "foldr'" (foldableFoldr' p) 91 | , (,) "foldl" $ property $ \(e :: LinearEquationTwo) (z :: Integer) (Apply (t :: f Integer)) -> 92 | let f = runLinearEquationTwo e 93 | in F.foldl f z t == SG.appEndo (SG.getDual (F.foldMap (SG.Dual . SG.Endo . flip f) t)) z 94 | , (,) "foldl'" (foldableFoldl' p) 95 | , (,) "foldl1" $ property $ \(e :: LinearEquationTwo) (Apply (t :: f Integer)) -> 96 | case compatToList t of 97 | [] -> True 98 | x : xs -> 99 | let f = runLinearEquationTwo e 100 | in F.foldl1 f t == F.foldl f x xs 101 | , (,) "foldr1" $ property $ \(e :: LinearEquationTwo) (Apply (t :: f Integer)) -> 102 | case unsnoc (compatToList t) of 103 | Nothing -> True 104 | Just (xs,x) -> 105 | let f = runLinearEquationTwo e 106 | in F.foldr1 f t == F.foldr f x xs 107 | , (,) "toList" $ property $ \(Apply (t :: f Integer)) -> 108 | eq1 (F.toList t) (F.foldr (:) [] t) 109 | #if MIN_VERSION_base(4,8,0) 110 | , (,) "null" $ property $ \(Apply (t :: f Integer)) -> 111 | null t == F.foldr (const (const False)) True t 112 | , (,) "length" $ property $ \(Apply (t :: f Integer)) -> 113 | F.length t == SG.getSum (F.foldMap (const (SG.Sum 1)) t) 114 | #endif 115 | ] 116 | 117 | unsnoc :: [a] -> Maybe ([a],a) 118 | unsnoc [] = Nothing 119 | unsnoc [x] = Just ([],x) 120 | unsnoc (x:y:xs) = fmap (\(bs,b) -> (x:bs,b)) (unsnoc (y : xs)) 121 | 122 | compatToList :: Foldable f => f a -> [a] 123 | compatToList = foldMap (\x -> [x]) 124 | 125 | foldableFoldl' :: forall proxy f. 126 | #if HAVE_QUANTIFIED_CONSTRAINTS 127 | (Foldable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 128 | #else 129 | (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) 130 | #endif 131 | => proxy f -> Property 132 | foldableFoldl' _ = property $ \(_ :: ChooseSecond) (_ :: LastNothing) (Apply (xs :: f (Bottom Integer))) -> 133 | monadicIO $ do 134 | let f :: Integer -> Bottom Integer -> Integer 135 | f a b = case b of 136 | BottomUndefined -> error "foldableFoldl' example" 137 | BottomValue v -> if even v 138 | then a 139 | else v 140 | z0 = 0 141 | r1 <- lift $ do 142 | let f' x k z = k $! f z x 143 | e <- try (evaluate (F.foldr f' id xs z0)) 144 | case e of 145 | Left (_ :: ErrorCall) -> return Nothing 146 | Right i -> return (Just i) 147 | r2 <- lift $ do 148 | e <- try (evaluate (F.foldl' f z0 xs)) 149 | case e of 150 | Left (_ :: ErrorCall) -> return Nothing 151 | Right i -> return (Just i) 152 | return (r1 == r2) 153 | 154 | foldableFoldr' :: forall proxy f. 155 | #if HAVE_QUANTIFIED_CONSTRAINTS 156 | (Foldable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) 157 | #else 158 | (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) 159 | #endif 160 | => proxy f -> Property 161 | foldableFoldr' _ = property $ \(_ :: ChooseFirst) (_ :: LastNothing) (Apply (xs :: f (Bottom Integer))) -> 162 | monadicIO $ do 163 | let f :: Bottom Integer -> Integer -> Integer 164 | f a b = case a of 165 | BottomUndefined -> error "foldableFoldl' example" 166 | BottomValue v -> if even v 167 | then v 168 | else b 169 | z0 = 0 170 | r1 <- lift $ do 171 | let f' k x z = k $! f x z 172 | e <- try (evaluate (F.foldl f' id xs z0)) 173 | case e of 174 | Left (_ :: ErrorCall) -> return Nothing 175 | Right i -> return (Just i) 176 | r2 <- lift $ do 177 | e <- try (evaluate (F.foldr' f z0 xs)) 178 | case e of 179 | Left (_ :: ErrorCall) -> return Nothing 180 | Right i -> return (Just i) 181 | return (r1 == r2) 182 | 183 | #endif 184 | -------------------------------------------------------------------------------- /quickcheck-classes/src/Test/QuickCheck/Classes/Semiring.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | {-# OPTIONS_GHC -Wall #-} 5 | 6 | module Test.QuickCheck.Classes.Semiring 7 | ( 8 | #if HAVE_SEMIRINGS 9 | semiringLaws 10 | #endif 11 | ) where 12 | 13 | #if HAVE_SEMIRINGS 14 | import Data.Semiring hiding (fromInteger) 15 | import Prelude hiding (Num(..)) 16 | import Prelude (fromInteger) 17 | #endif 18 | 19 | import Data.Proxy (Proxy) 20 | import Test.QuickCheck hiding ((.&.)) 21 | 22 | import Test.QuickCheck.Classes.Internal (Laws(..), myForAllShrink) 23 | 24 | #if HAVE_SEMIRINGS 25 | -- | Tests the following properties: 26 | -- 27 | -- [/Additive Commutativity/] 28 | -- @a + b ≡ b + a@ 29 | -- [/Additive Left Identity/] 30 | -- @0 + a ≡ a@ 31 | -- [/Additive Right Identity/] 32 | -- @a + 0 ≡ a@ 33 | -- [/Multiplicative Associativity/] 34 | -- @a * (b * c) ≡ (a * b) * c@ 35 | -- [/Multiplicative Left Identity/] 36 | -- @1 * a ≡ a@ 37 | -- [/Multiplicative Right Identity/] 38 | -- @a * 1 ≡ a@ 39 | -- [/Multiplication Left Distributes Over Addition/] 40 | -- @a * (b + c) ≡ (a * b) + (a * c)@ 41 | -- [/Multiplication Right Distributes Over Addition/] 42 | -- @(a + b) * c ≡ (a * c) + (b * c)@ 43 | -- [/Multiplicative Left Annihilation/] 44 | -- @0 * a ≡ 0@ 45 | -- [/Multiplicative Right Annihilation/] 46 | -- @a * 0 ≡ 0@ 47 | -- 48 | -- Also tests that 'fromNatural' is a homomorphism of semirings: 49 | -- 50 | -- [/FromNatural Maps Zero/] 51 | -- 'fromNatural' 0 = 'zero' 52 | -- [/FromNatural Maps One/] 53 | -- 'fromNatural' 1 = 'one' 54 | -- [/FromNatural Maps Plus/] 55 | -- 'fromNatural' (@a@ + @b@) = 'fromNatural' @a@ + 'fromNatural' @b@ 56 | -- [/FromNatural Maps Times/] 57 | -- 'fromNatural' (@a@ * @b@) = 'fromNatural' @a@ * 'fromNatural' @b@ 58 | semiringLaws :: (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws 59 | semiringLaws p = Laws "Semiring" 60 | [ ("Additive Commutativity", semiringCommutativePlus p) 61 | , ("Additive Left Identity", semiringLeftIdentityPlus p) 62 | , ("Additive Right Identity", semiringRightIdentityPlus p) 63 | , ("Multiplicative Associativity", semiringAssociativeTimes p) 64 | , ("Multiplicative Left Identity", semiringLeftIdentityTimes p) 65 | , ("Multiplicative Right Identity", semiringRightIdentityTimes p) 66 | , ("Multiplication Left Distributes Over Addition", semiringLeftMultiplicationDistributes p) 67 | , ("Multiplication Right Distributes Over Addition", semiringRightMultiplicationDistributes p) 68 | , ("Multiplicative Left Annihilation", semiringLeftAnnihilation p) 69 | , ("Multiplicative Right Annihilation", semiringRightAnnihilation p) 70 | , ("FromNatural Maps Zero", semiringFromNaturalMapsZero p) 71 | , ("FromNatural Maps One", semiringFromNaturalMapsOne p) 72 | , ("FromNatural Maps Plus", semiringFromNaturalMapsPlus p) 73 | , ("FromNatural Maps Times", semiringFromNaturalMapsTimes p) 74 | ] 75 | 76 | semiringLeftMultiplicationDistributes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 77 | semiringLeftMultiplicationDistributes _ = myForAllShrink True (const True) 78 | (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) 79 | "a * (b + c)" 80 | (\(a,b,c) -> a * (b + c)) 81 | "(a * b) + (a * c)" 82 | (\(a,b,c) -> (a * b) + (a * c)) 83 | 84 | semiringRightMultiplicationDistributes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 85 | semiringRightMultiplicationDistributes _ = myForAllShrink True (const True) 86 | (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) 87 | "(a + b) * c" 88 | (\(a,b,c) -> (a + b) * c) 89 | "(a * c) + (b * c)" 90 | (\(a,b,c) -> (a * c) + (b * c)) 91 | 92 | semiringLeftIdentityPlus :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 93 | semiringLeftIdentityPlus _ = myForAllShrink False (const True) 94 | (\(a :: a) -> ["a = " ++ show a]) 95 | "0 + a" 96 | (\a -> zero + a) 97 | "a" 98 | (\a -> a) 99 | 100 | semiringRightIdentityPlus :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 101 | semiringRightIdentityPlus _ = myForAllShrink False (const True) 102 | (\(a :: a) -> ["a = " ++ show a]) 103 | "a + 0" 104 | (\a -> a + zero) 105 | "a" 106 | (\a -> a) 107 | 108 | semiringRightIdentityTimes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 109 | semiringRightIdentityTimes _ = myForAllShrink False (const True) 110 | (\(a :: a) -> ["a = " ++ show a]) 111 | "a * 1" 112 | (\a -> a * one) 113 | "a" 114 | (\a -> a) 115 | 116 | semiringLeftIdentityTimes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 117 | semiringLeftIdentityTimes _ = myForAllShrink False (const True) 118 | (\(a :: a) -> ["a = " ++ show a]) 119 | "1 * a" 120 | (\a -> one * a) 121 | "a" 122 | (\a -> a) 123 | 124 | semiringLeftAnnihilation :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 125 | semiringLeftAnnihilation _ = myForAllShrink False (const True) 126 | (\(a :: a) -> ["a = " ++ show a]) 127 | "0 * a" 128 | (\a -> zero * a) 129 | "0" 130 | (\_ -> zero) 131 | 132 | semiringRightAnnihilation :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 133 | semiringRightAnnihilation _ = myForAllShrink False (const True) 134 | (\(a :: a) -> ["a = " ++ show a]) 135 | "a * 0" 136 | (\a -> a * zero) 137 | "0" 138 | (\_ -> zero) 139 | 140 | semiringCommutativePlus :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 141 | semiringCommutativePlus _ = myForAllShrink True (const True) 142 | (\(a :: a,b) -> ["a = " ++ show a, "b = " ++ show b]) 143 | "a + b" 144 | (\(a,b) -> a + b) 145 | "b + a" 146 | (\(a,b) -> b + a) 147 | 148 | semiringAssociativeTimes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 149 | semiringAssociativeTimes _ = myForAllShrink True (const True) 150 | (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) 151 | "a * (b * c)" 152 | (\(a,b,c) -> a * (b * c)) 153 | "(a * b) * c" 154 | (\(a,b,c) -> (a * b) * c) 155 | 156 | semiringFromNaturalMapsZero :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 157 | semiringFromNaturalMapsZero _ = myForAllShrink False (const True) 158 | (\_ -> [""]) 159 | "fromNatural 0" 160 | (\() -> fromNatural 0 :: a) 161 | "zero" 162 | (\() -> zero) 163 | 164 | semiringFromNaturalMapsOne :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 165 | semiringFromNaturalMapsOne _ = myForAllShrink False (const True) 166 | (\_ -> [""]) 167 | "fromNatural 1" 168 | (\() -> fromNatural 1 :: a) 169 | "one" 170 | (\() -> one) 171 | 172 | -- | There is no Arbitrary instance for Natural in QuickCheck, 173 | -- so we use NonNegative Integer instead. 174 | semiringFromNaturalMapsPlus :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 175 | semiringFromNaturalMapsPlus _ = myForAllShrink True (const True) 176 | (\(NonNegative a, NonNegative b) -> ["a = " ++ show a, "b = " ++ show b]) 177 | "fromNatural (a + b)" 178 | (\(NonNegative a, NonNegative b) -> fromNatural (fromInteger (a + b)) :: a) 179 | "fromNatural a + fromNatural b" 180 | (\(NonNegative a, NonNegative b) -> fromNatural (fromInteger a) + fromNatural (fromInteger b)) 181 | 182 | semiringFromNaturalMapsTimes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 183 | semiringFromNaturalMapsTimes _ = myForAllShrink True (const True) 184 | (\(NonNegative a, NonNegative b) -> ["a = " ++ show a, "b = " ++ show b]) 185 | "fromNatural (a * b)" 186 | (\(NonNegative a, NonNegative b) -> fromNatural (fromInteger (a * b)) :: a) 187 | "fromNatural a * fromNatural b" 188 | (\(NonNegative a, NonNegative b) -> fromNatural (fromInteger a) * fromNatural (fromInteger b)) 189 | 190 | #endif 191 | -------------------------------------------------------------------------------- /quickcheck-classes/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE DeriveFunctor #-} 7 | {-# LANGUAGE DeriveTraversable #-} 8 | 9 | #if HAVE_QUANTIFIED_CONSTRAINTS 10 | {-# LANGUAGE QuantifiedConstraints #-} 11 | #endif 12 | 13 | import Control.Monad 14 | import Control.Monad.Zip (MonadZip) 15 | import Control.Applicative 16 | #if defined(VERSION_aeson) 17 | import Data.Aeson (ToJSON,FromJSON) 18 | #endif 19 | import Data.Bits 20 | import Data.Foldable 21 | import Data.Map (Map) 22 | import qualified Data.Map as M 23 | #if MIN_VERSION_containers(0,5,9) 24 | import qualified Data.Map.Merge.Strict as MM 25 | #endif 26 | import Data.Traversable 27 | #if HAVE_SEMIGROUPOIDS 28 | import Data.Functor.Apply (Apply((<.>))) 29 | #endif 30 | #if HAVE_BINARY_LAWS 31 | import Data.Functor.Const (Const(..)) 32 | #endif 33 | #if HAVE_UNARY_LAWS 34 | import Data.Functor.Classes 35 | #endif 36 | import Data.Int 37 | import Data.Monoid (Sum(..),Monoid,mappend,mconcat,mempty) 38 | import Data.Orphans () 39 | import Data.Primitive 40 | import Data.Proxy 41 | import Data.Vector (Vector) 42 | import Data.Word 43 | import Foreign.Storable 44 | import Test.QuickCheck 45 | import Text.Show.Functions 46 | 47 | import qualified Data.Vector as V 48 | import qualified Data.Foldable as F 49 | 50 | import Test.QuickCheck.Classes 51 | import qualified Spec.ShowRead 52 | 53 | main :: IO () 54 | main = do 55 | #if HAVE_SEMIGROUPOIDS 56 | #if MIN_VERSION_containers(0,5,9) 57 | quickCheck prop_map_apply_equals 58 | #endif 59 | #endif 60 | lawsCheckMany allPropsApplied 61 | 62 | allPropsApplied :: [(String,[Laws])] 63 | allPropsApplied = M.toList . M.fromListWith (++) $ 64 | [ ("Int",allLaws (Proxy :: Proxy Int)) 65 | , ("Int64",allLaws (Proxy :: Proxy Int64)) 66 | , ("Word",allLaws (Proxy :: Proxy Word)) 67 | #if HAVE_BINARY_LAWS 68 | , ("Tuple" 69 | , [ bitraversableLaws (Proxy :: Proxy (,)) 70 | , bifoldableLaws (Proxy :: Proxy (,)) 71 | ] 72 | ) 73 | , ("Const" 74 | , [ bifoldableLaws (Proxy :: Proxy Const) 75 | , bitraversableLaws (Proxy :: Proxy Const) 76 | ] 77 | ) 78 | , ("Either" 79 | , [ bitraversableLaws (Proxy :: Proxy Either) 80 | , bifoldableLaws (Proxy :: Proxy Either) 81 | ] 82 | ) 83 | #endif 84 | #if HAVE_UNARY_LAWS 85 | , ("Maybe",allHigherLaws (Proxy1 :: Proxy1 Maybe)) 86 | , ("List",allHigherLaws (Proxy1 :: Proxy1 [])) 87 | -- , ("BadList",allHigherLaws (Proxy1 :: Proxy1 BadList)) 88 | #endif 89 | #if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS) 90 | #if MIN_VERSION_base(4,9,0) && MIN_VERSION_containers(0,5,9) 91 | , ("Map", someHigherLaws (Proxy1 :: Proxy1 (Map Int))) 92 | , ("Pound", someHigherLaws (Proxy1 :: Proxy1 (Pound Int))) 93 | #endif 94 | #endif 95 | #if MIN_VERSION_base(4,7,0) 96 | , ("Vector", 97 | [ isListLaws (Proxy :: Proxy (Vector Word)) 98 | #if HAVE_VECTOR 99 | , muvectorLaws (Proxy :: Proxy Word8) 100 | , muvectorLaws (Proxy :: Proxy (Int, Word)) 101 | #endif 102 | ]) 103 | #endif 104 | ] 105 | ++ Spec.ShowRead.lawsApplied 106 | 107 | allLaws :: forall a. 108 | ( Integral a 109 | , Num a 110 | , Prim a 111 | , Storable a 112 | , Ord a 113 | , Arbitrary a 114 | , Show a 115 | , Read a 116 | , Enum a 117 | , Bounded a 118 | #if defined(VERSION_aeson) 119 | , ToJSON a 120 | , FromJSON a 121 | #endif 122 | #if MIN_VERSION_base(4,7,0) 123 | , FiniteBits a 124 | #endif 125 | ) => Proxy a -> [Laws] 126 | allLaws p = 127 | [ primLaws p 128 | , storableLaws p 129 | , semigroupLaws (Proxy :: Proxy (Sum a)) 130 | , monoidLaws (Proxy :: Proxy (Sum a)) 131 | , boundedEnumLaws p 132 | #if defined(VERSION_aeson) 133 | , jsonLaws p 134 | #endif 135 | , eqLaws p 136 | , ordLaws p 137 | , numLaws p 138 | , integralLaws p 139 | #if MIN_VERSION_base(4,7,0) 140 | , bitsLaws p 141 | #endif 142 | ] 143 | 144 | foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b 145 | foldlMapM f = foldlM (\b a -> liftM (mappend b) (f a)) mempty 146 | 147 | #if HAVE_UNARY_LAWS 148 | allHigherLaws :: 149 | (Traversable f, MonadZip f, MonadPlus f, Applicative f, 150 | #if HAVE_QUANTIFIED_CONSTRAINTS 151 | forall a. Eq a => Eq (f a), forall a. Arbitrary a => Arbitrary (f a), 152 | forall a. Show a => Show (f a) 153 | #else 154 | Eq1 f, Arbitrary1 f, Show1 f 155 | #endif 156 | ) => proxy f -> [Laws] 157 | allHigherLaws p = 158 | [ functorLaws p 159 | , applicativeLaws p 160 | , monadLaws p 161 | , monadPlusLaws p 162 | , monadZipLaws p 163 | , foldableLaws p 164 | , traversableLaws p 165 | ] 166 | #endif 167 | 168 | #if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS) 169 | someHigherLaws :: 170 | (Apply f, 171 | #if HAVE_QUANTIFIED_CONSTRAINTS 172 | forall a. Eq a => Eq (f a), forall a. Arbitrary a => Arbitrary (f a), 173 | forall a. Show a => Show (f a) 174 | #else 175 | Eq1 f, Arbitrary1 f, Show1 f 176 | #endif 177 | ) => proxy f -> [Laws] 178 | someHigherLaws p = 179 | [ applyLaws p 180 | ] 181 | #endif 182 | 183 | -- This type fails the laws for the strict functions 184 | -- in Foldable. It is used just to confirm that 185 | -- those property tests actually work. 186 | newtype Rogue a = Rogue [a] 187 | deriving 188 | ( Eq, Show, Arbitrary 189 | #if HAVE_UNARY_LAWS 190 | , Arbitrary1 191 | , Eq1 192 | , Show1 193 | #endif 194 | ) 195 | 196 | -- Note: when using base < 4.6, the Rogue type does 197 | -- not really test anything. 198 | instance Foldable Rogue where 199 | foldMap f (Rogue xs) = F.foldMap f xs 200 | foldl f x (Rogue xs) = F.foldl f x xs 201 | #if MIN_VERSION_base(4,6,0) 202 | foldl' f x (Rogue xs) = F.foldl f x xs 203 | foldr' f x (Rogue xs) = F.foldr f x xs 204 | #endif 205 | 206 | newtype BadList a = BadList [a] 207 | deriving 208 | ( Eq, Show, Arbitrary 209 | , Arbitrary1, Eq1, Show1 210 | , Traversable, Functor, MonadZip, Monad, Applicative, MonadPlus, Alternative 211 | ) 212 | 213 | instance Foldable BadList where 214 | foldMap f (BadList xs) = F.foldMap f xs 215 | fold (BadList xs) = fold (reverse xs) 216 | 217 | newtype Pound k v = Pound { getPound :: Map k v } 218 | deriving 219 | ( Eq, Functor, Show, Arbitrary 220 | #if HAVE_UNARY_LAWS 221 | , Arbitrary1 222 | -- The following instances are only available for the variants 223 | -- of the type classes in base, not for those in transformers. 224 | #if MIN_VERSION_base(4,9,0) && MIN_VERSION_containers(0,5,9) 225 | , Eq1 226 | , Show1 227 | #endif 228 | #endif 229 | ) 230 | 231 | #if HAVE_SEMIGROUPOIDS 232 | #if MIN_VERSION_containers(0,5,9) 233 | instance Ord k => Apply (Pound k) where 234 | Pound m1 <.> Pound m2 = Pound $ 235 | MM.merge 236 | MM.dropMissing 237 | MM.dropMissing 238 | (MM.zipWithMatched (\_ f a -> f a)) 239 | m1 240 | m2 241 | #endif 242 | #endif 243 | 244 | #if HAVE_SEMIGROUPOIDS 245 | #if MIN_VERSION_containers(0,5,9) 246 | prop_map_apply_equals :: Map Int (Int -> Int) 247 | -> Map Int Int 248 | -> Bool 249 | prop_map_apply_equals mf ma = 250 | let pf = Pound mf 251 | pa = Pound ma 252 | m = mf <.> ma 253 | p = pf <.> pa 254 | in m == (getPound p) 255 | #endif 256 | #endif 257 | 258 | ------------------- 259 | -- Orphan Instances 260 | ------------------- 261 | 262 | instance Arbitrary a => Arbitrary (Vector a) where 263 | arbitrary = V.fromList <$> arbitrary 264 | shrink v = map V.fromList (shrink (V.toList v)) 265 | 266 | #if !MIN_VERSION_QuickCheck(2,8,2) 267 | instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where 268 | arbitrary = M.fromList <$> arbitrary 269 | shrink m = map M.fromList (shrink (M.toList m)) 270 | #endif 271 | 272 | #if !MIN_VERSION_QuickCheck(2,9,0) 273 | instance Arbitrary a => Arbitrary (Sum a) where 274 | arbitrary = Sum <$> arbitrary 275 | shrink = map Sum . shrink . getSum 276 | #endif 277 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Bits.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | {-# OPTIONS_GHC -Wall #-} 6 | 7 | module Test.QuickCheck.Classes.Bits 8 | ( 9 | #if MIN_VERSION_base(4,7,0) 10 | bitsLaws 11 | #endif 12 | ) where 13 | 14 | import Data.Bits 15 | import Data.Proxy (Proxy) 16 | import Test.QuickCheck hiding ((.&.)) 17 | 18 | import qualified Data.Set as S 19 | 20 | import Test.QuickCheck.Classes.Internal (Laws(..), myForAllShrink) 21 | 22 | -- | Tests the following properties: 23 | -- 24 | -- [/Conjunction Idempotence/] 25 | -- @n .&. n ≡ n@ 26 | -- [/Disjunction Idempotence/] 27 | -- @n .|. n ≡ n@ 28 | -- [/Double Complement/] 29 | -- @complement (complement n) ≡ n@ 30 | -- [/Set Bit/] 31 | -- @setBit n i ≡ n .|. bit i@ 32 | -- [/Clear Bit/] 33 | -- @clearBit n i ≡ n .&. complement (bit i)@ 34 | -- [/Complement Bit/] 35 | -- @complementBit n i ≡ xor n (bit i)@ 36 | -- [/Clear Zero/] 37 | -- @clearBit zeroBits i ≡ zeroBits@ 38 | -- [/Set Zero/] 39 | -- @setBit zeroBits i ≡ bit i@ 40 | -- [/Test Zero/] 41 | -- @testBit zeroBits i ≡ False@ 42 | -- [/Pop Zero/] 43 | -- @popCount zeroBits ≡ 0@ 44 | -- [/Right Rotation/] 45 | -- @no sign extension → (rotateR n i ≡ (shiftR n i) .|. (shiftL n (finiteBitSize ⊥ - i)))@ 46 | -- [/Left Rotation/] 47 | -- @no sign extension → (rotateL n i ≡ (shiftL n i) .|. (shiftR n (finiteBitSize ⊥ - i)))@ 48 | -- [/Count Leading Zeros of Zero/] 49 | -- @countLeadingZeros zeroBits ≡ finiteBitSize ⊥@ 50 | -- [/Count Trailing Zeros of Zero/] 51 | -- @countTrailingZeros zeroBits ≡ finiteBitSize ⊥@ 52 | -- 53 | -- All of the useful instances of the 'Bits' typeclass 54 | -- also have 'FiniteBits' instances, so these property 55 | -- tests actually require that instance as well. 56 | -- 57 | -- /Note:/ This property test is only available when 58 | -- using @base-4.7@ or newer. 59 | #if MIN_VERSION_base(4,7,0) 60 | bitsLaws :: (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Laws 61 | bitsLaws p = Laws "Bits" 62 | [ ("Conjunction Idempotence", bitsConjunctionIdempotence p) 63 | , ("Disjunction Idempotence", bitsDisjunctionIdempotence p) 64 | , ("Double Complement", bitsDoubleComplement p) 65 | , ("Set Bit", bitsSetBit p) 66 | , ("Clear Bit", bitsClearBit p) 67 | , ("Complement Bit", bitsComplementBit p) 68 | , ("Clear Zero", bitsClearZero p) 69 | , ("Set Zero", bitsSetZero p) 70 | , ("Test Zero", bitsTestZero p) 71 | , ("Pop Zero", bitsPopZero p) 72 | , ("Right Rotation", bitsRightRotation p) 73 | , ("Left Rotation", bitsLeftRotation p) 74 | #if MIN_VERSION_base(4,8,0) 75 | , ("Count Leading Zeros of Zero", bitsCountLeadingZeros p) 76 | , ("Count Trailing Zeros of Zero", bitsCountTrailingZeros p) 77 | #endif 78 | ] 79 | #endif 80 | 81 | #if MIN_VERSION_base(4,7,0) 82 | newtype BitIndex a = BitIndex Int 83 | 84 | instance FiniteBits a => Arbitrary (BitIndex a) where 85 | arbitrary = let n = finiteBitSize (undefined :: a) in if n > 0 86 | then fmap BitIndex (choose (0,n - 1)) 87 | else return (BitIndex 0) 88 | shrink (BitIndex x) = if x > 0 then map BitIndex (S.toList (S.fromList [x - 1, div x 2, 0])) else [] 89 | 90 | bitsConjunctionIdempotence :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property 91 | bitsConjunctionIdempotence _ = myForAllShrink False (const True) 92 | (\(n :: a) -> ["n = " ++ show n]) 93 | "n .&. n" 94 | (\n -> n .&. n) 95 | "n" 96 | (\n -> n) 97 | 98 | bitsDisjunctionIdempotence :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property 99 | bitsDisjunctionIdempotence _ = myForAllShrink False (const True) 100 | (\(n :: a) -> ["n = " ++ show n]) 101 | "n .|. n" 102 | (\n -> n .|. n) 103 | "n" 104 | (\n -> n) 105 | 106 | bitsDoubleComplement :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property 107 | bitsDoubleComplement _ = myForAllShrink False (const True) 108 | (\(n :: a) -> ["n = " ++ show n]) 109 | "complement (complement n)" 110 | (\n -> complement (complement n)) 111 | "n" 112 | (\n -> n) 113 | 114 | bitsSetBit :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property 115 | bitsSetBit _ = myForAllShrink True (const True) 116 | (\(n :: a, BitIndex i :: BitIndex a) -> ["n = " ++ show n, "i = " ++ show i]) 117 | "setBit n i" 118 | (\(n,BitIndex i) -> setBit n i) 119 | "n .|. bit i" 120 | (\(n,BitIndex i) -> n .|. bit i) 121 | 122 | bitsClearBit :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property 123 | bitsClearBit _ = myForAllShrink True (const True) 124 | (\(n :: a, BitIndex i :: BitIndex a) -> ["n = " ++ show n, "i = " ++ show i]) 125 | "clearBit n i" 126 | (\(n,BitIndex i) -> clearBit n i) 127 | "n .&. complement (bit i)" 128 | (\(n,BitIndex i) -> n .&. complement (bit i)) 129 | 130 | bitsComplementBit :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property 131 | bitsComplementBit _ = myForAllShrink True (const True) 132 | (\(n :: a, BitIndex i :: BitIndex a) -> ["n = " ++ show n, "i = " ++ show i]) 133 | "complementBit n i" 134 | (\(n,BitIndex i) -> complementBit n i) 135 | "xor n (bit i)" 136 | (\(n,BitIndex i) -> xor n (bit i)) 137 | 138 | bitsClearZero :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property 139 | bitsClearZero _ = myForAllShrink False (const True) 140 | (\(BitIndex n :: BitIndex a) -> ["n = " ++ show n]) 141 | "clearBit zeroBits n" 142 | (\(BitIndex n) -> clearBit zeroBits n :: a) 143 | "zeroBits" 144 | (\_ -> zeroBits) 145 | 146 | bitsSetZero :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property 147 | bitsSetZero _ = myForAllShrink True (const True) 148 | (\(BitIndex i :: BitIndex a) -> ["i = " ++ show i]) 149 | "setBit zeroBits i" 150 | (\(BitIndex i) -> setBit (zeroBits :: a) i) 151 | "bit i" 152 | (\(BitIndex i) -> bit i) 153 | 154 | bitsTestZero :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property 155 | bitsTestZero _ = myForAllShrink True (const True) 156 | (\(BitIndex i :: BitIndex a) -> ["i = " ++ show i]) 157 | "testBit zeroBits i" 158 | (\(BitIndex i) -> testBit (zeroBits :: a) i) 159 | "False" 160 | (\_ -> False) 161 | 162 | bitsPopZero :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property 163 | bitsPopZero _ = myForAllShrink True (const True) 164 | (\() -> []) 165 | "popCount zeroBits" 166 | (\() -> popCount (zeroBits :: a)) 167 | "0" 168 | (\() -> 0) 169 | 170 | bitsRightRotation :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property 171 | bitsRightRotation _ = myForAllShrink True 172 | (\(n :: a, BitIndex _ :: BitIndex a) -> 173 | not (testBit (shiftR n 1) (finiteBitSize (undefined :: a) - 1)) 174 | ) 175 | (\(n, BitIndex i) -> ["n = " ++ show n, "i = " ++ show i]) 176 | "rotateR n i" 177 | (\(n,BitIndex i) -> rotateR n i) 178 | "shiftR n i .|. shiftL n (finiteBitSize ⊥ - i)" 179 | (\(n,BitIndex i) -> shiftR n i .|. shiftL n (finiteBitSize (undefined :: a) - i)) 180 | 181 | bitsLeftRotation :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property 182 | bitsLeftRotation _ = myForAllShrink True 183 | (\(n :: a, BitIndex _ :: BitIndex a) -> 184 | not (testBit (shiftR n 1) (finiteBitSize (undefined :: a) - 1)) 185 | ) 186 | (\(n, BitIndex i) -> ["n = " ++ show n, "i = " ++ show i]) 187 | "rotateL n i" 188 | (\(n,BitIndex i) -> rotateL n i) 189 | "shiftL n i .|. shiftR n (finiteBitSize ⊥ - i)" 190 | (\(n,BitIndex i) -> shiftL n i .|. shiftR n (finiteBitSize (undefined :: a) - i)) 191 | #endif 192 | 193 | #if MIN_VERSION_base(4,8,0) 194 | bitsCountLeadingZeros :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property 195 | bitsCountLeadingZeros _ = myForAllShrink True (const True) 196 | (\() -> []) 197 | "countLeadingZeros zeroBits" 198 | (\() -> countLeadingZeros (zeroBits :: a)) 199 | "finiteBitSize undefined" 200 | (\() -> finiteBitSize (undefined :: a)) 201 | 202 | bitsCountTrailingZeros :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property 203 | bitsCountTrailingZeros _ = myForAllShrink True (const True) 204 | (\() -> []) 205 | "countTrailingZeros zeroBits" 206 | (\() -> countTrailingZeros (zeroBits :: a)) 207 | "finiteBitSize undefined" 208 | (\() -> finiteBitSize (undefined :: a)) 209 | #endif 210 | -------------------------------------------------------------------------------- /quickcheck-classes/changelog.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | All notable changes to this project will be documented in this file. 3 | 4 | The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) 5 | and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). 6 | 7 | Note that since `quickcheck-classes` reexports larges parts of 8 | `quickcheck-classes-base`, changelog entries that deal with any of the 9 | classes from `base` are duplicated across the two changelogs. 10 | 11 | ## [0.6.5.0] - 2021-04-12 12 | ### Added 13 | - Laws for `abs` and `signum` 14 | - Storable Set-Set Law (resolves issue 101). 15 | - Add laws for `quotRem` and `divMod`. 16 | - Use non-commutative monoid for bifoldable tests (resolves issue 98) 17 | - `substitutiveEqLaws`, which tests for Eq substitutivity. 18 | - Negation law check for `Eq`. 19 | - Document that users can provide their own `Laws`. 20 | 21 | ## [0.6.4.0] - 2019-09-13 22 | ### Changed 23 | - Use newer semirings 24 | 25 | ## [0.6.3.0] - 2019-08-08 26 | ### Added 27 | - `gcdDomainLaws` 28 | - `euclideanLaws` 29 | ### Changed 30 | - Replaces 0.6.2.2. That release should have been a minor version 31 | bump since it added new features. 32 | - Support `primitive-0.6.4.0`. 33 | - Extend `semiringLaws` to cover `fromNatural` 34 | - Factor out a subset of laws tests into `quickcheck-classes-base` 35 | and depend on this library. 36 | 37 | ## [0.6.2.2] - 2019-06-18 38 | ### Added 39 | - `numLaws` 40 | - `bitraversableLaws` 41 | 42 | ## [0.6.2.1] - 2019-05-23 43 | ### Fixed 44 | - Removal of BadList test that was causing the test suite to fail 45 | 46 | ## [0.6.2.0] - 2019-05-23 47 | ### Added 48 | - `ixLaws` 49 | - `contravariantLaws` 50 | - `semigroupMonoidLaws` 51 | ### Changed 52 | - extend `mvectorLaws` 53 | - extend `applyLaws` to include associativity 54 | ### Fixed 55 | - bug in `foldableLaws` which could fail to catch implementations of `foldMap` or `fold` 56 | that evaluate in the wrong order 57 | 58 | ## [0.6.1.0] - 2019-01-12 59 | ### Change 60 | - `genericLaws` and `generic1Laws` were not exported. Now they are. 61 | ### Added 62 | - Add `muvectorLaws`. 63 | 64 | ## [0.6.0.0] - 2018-12-24 65 | ### Change 66 | - Support QuickCheck 2.7 and 2.8. This adds `Arbitrary` orphan instances 67 | to the test suite. 68 | - Fix CPP that caused build failures on GHC 7.10 and some old 69 | package versions. 70 | - Fix compiling the test suite without semigroupoids and compiling with old 71 | versions of transformers. 72 | - Add lower bound for semigroups to make sure the `stimes` method is available. 73 | - The laws `commutativeSemigroupLaws` and `commutativeMonoidLaws` no longer 74 | check any property other than commutativity. They must now be used in conjunction 75 | with, rather than in place of, `semigroupLaws` and `monoidLaws`. This is a breaking 76 | change. 77 | - Fix the right distribution law for semirings. 78 | - The function `lawsCheckMany` now terminates with exit code 1 if a 79 | test fails. 80 | - Extend `showReadLaws` with new properties for `showsPrec`, `readsPrec`, 81 | `showList` and `readList`. 82 | - Prettify JSON partial isomorphism test failure. 83 | ### Added 84 | - Add `genericLaws` and `generic1Laws` 85 | - Add property tests for special classes of semigroups. This includes: 86 | commutative, idempotent, rectangular band, and exponential. 87 | - `bifoldableLaws`, `bifoldableFunctorLaws` 88 | - Add `showLaws`. 89 | 90 | ## [0.5.0.0] - 2018-09-25 91 | ### Change 92 | - When compiling with GHC 8.6 and newer, use `QuantifiedConstraints` instead 93 | of `Eq1`, `Show1`, `Arbitrary1`, `Eq2`, `Show`, and `Arbitrary2`. 94 | 95 | ## [0.4.14.3] - 2018-09-21 96 | ### Change 97 | - Fix a CPP conditional import problem that caused build failures on GHC 7.10 98 | - Set an explicit lower bound for containers 99 | 100 | ## [0.4.14.2] - 2018-09-12 101 | ### Change 102 | - Support QuickCheck-2.12 103 | - Fix compilation for containers<0.5.9 104 | - Fix compilation with QuickCheck-2.9 105 | 106 | ## [0.4.14.1] - 2018-07-24 107 | ### Change 108 | - Build correctly when dependency on semigroupoids is disabled. 109 | 110 | ## [0.4.14] - 2018-07-23 111 | ### Added 112 | - commutativeSemigroupLaws 113 | - the following typeclasses: 114 | `Data.Semigroupoid.Semigroupoid` (semigroupoids) 115 | `Data.Functor.Plus.Plus` (semigroupoids) 116 | 117 | ### Change 118 | - semiringLaws were never exported, we now export them. 119 | - make documentation for `MonadPlus` and `Alternative` consistent. 120 | - bump semirings to 0.2.0.0 121 | - deprecate `Test.QuickCheck.Classes.specialisedLawsCheckMany` 122 | in favour of `Test.QuickCheck.Classes.lawsCheckOne` 123 | 124 | ## [0.4.13] - 2018-07-18 125 | ### Added 126 | - Laws for `Enum` typeclass. 127 | - Laws for `Category` typeclass. 128 | 129 | ## [0.4.12] - 2018-06-07 130 | ### Added 131 | - Remaining laws for `Storable` typeclass. 132 | - Laws for `Prim` typeclass requiring `setByteArray` and `setOffAddr` to 133 | match the behavior that would result from manually iterating over the 134 | array and writing the value element-by-element. 135 | ### Change 136 | - Correct the law from the `Bits` typeclass that relates `clearBit` 137 | and `zeroBits`. 138 | - Limit the size of the lists that are used when testing that 139 | `mconcat` and `sconcat` have behaviors that match their default 140 | implementations. For some data structures, concatenating the 141 | elements in a list of several dozen arbitrary values does not 142 | finish in a reasonable amount of time. So, the size of these 143 | has been limited to 6. 144 | - Make library build against `primitive-0.6.1.0`. 145 | 146 | ## [0.4.11.1] - 2018-05-25 147 | ### Change 148 | - Fix compatibility with older GHCs when `semigroupoids` support 149 | is disabled. 150 | 151 | ## [0.4.11] - 2018-05-24 152 | ### Added 153 | - Greatly improved documentation 154 | - `specialisedLawsCheckMany` function, a shorter way for the user 155 | to use `lawsCheckMany` on a single type. 156 | 157 | ### Change 158 | - Some internal names, making it more clear what it is that they do. 159 | 160 | ## [0.4.10] - 2018-05-03 161 | ### Added 162 | - Property tests for `mconcat`, `sconcat`, and `stimes`. It isn't 163 | common to override the defaults for these, but when you do, it's 164 | nice to check that they agree with what they are supposed to do. 165 | 166 | ## [0.4.9] - 2018-04-06 167 | ### Change 168 | - Be more careful with import of `Data.Primitive`. There is a 169 | branch of `primitive` that adds `PrimArray`. The implementation 170 | of `PrimArray` in this library should eventually be removed, but 171 | for now it will be sufficient to ensure that it does not create 172 | a conflicting import problem with the one in the branch. 173 | 174 | ## [0.4.8] - 2018-03-29 175 | ### Change 176 | - Fix compilation regression for older versions of transformers. 177 | 178 | ## [0.4.7] - 2018-03-29 179 | ### Change 180 | - Split up monolithic module into hidden internal modules. 181 | - Fix compilation regression for older GHCs. 182 | 183 | ## [0.4.6] - 2018-03-29 184 | ### Added 185 | - Property test the naturality law for `MonadZip`. There is another law 186 | that instances should satisfy (the Information Preservation law), but 187 | it's more difficult to write a test for. It has been omitted for now. 188 | - Property tests for all `MonadPlus` laws. 189 | - Several additional property tests for list-like containers: mapMaybe, 190 | replicate, filter. 191 | 192 | ## [0.4.5] - 2018-03-26 193 | ### Added 194 | - Property tests for list-like containers that have `IsList` instances. 195 | These are useful for things that are nearly `Foldable` or nearly `Traversable` 196 | but are either constrained in their element type or totally monomorphic 197 | in it. 198 | 199 | ## [0.4.4] - 2018-03-23 200 | ### Added 201 | - Cabal flags for controlling whether or not `aeson` and `semigroupoids` 202 | are used. These are mostly provided to accelerate builds `primitive`'s 203 | test suite. 204 | 205 | ## [0.4.3] - 2018-03-23 206 | ### Added 207 | - Property tests for `foldl1` and `foldr1`. 208 | - Property tests for `Traversable`. 209 | 210 | ## [0.4.2] - 2018-03-22 211 | ### Changed 212 | - Made compatible with `transformers-0.3`. Tests for higher-kinded 213 | typeclasses are unavailable when built with a sufficiently old 214 | version of both `transformers` and `base`. This is because `Eq1` 215 | and `Show1` are unavailable in this situation. 216 | 217 | ## [0.4.1] - 2018-03-21 218 | ### Changed 219 | - Made compatible with `transformers-0.4`. 220 | 221 | ## [0.4.0] - 2018-03-20 222 | ### Added 223 | - Property tests for `Bifunctor` and `Alternative`. 224 | ### Changed 225 | - Made compatible with older GHCs all the way back to 7.8.4. 226 | - Lower dependency footprint. Eliminate the dependency on `prim-array` 227 | and inline the relevant functions and types from it into 228 | `Test.QuickCheck.Classes`. None of these are exported. 229 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | 4 | {-# OPTIONS_GHC -Wall #-} 5 | 6 | {-| This library provides sets of properties that should hold for common 7 | typeclasses. 8 | 9 | /Note:/ on GHC < 8.6, this library uses the higher-kinded typeclasses 10 | ('Data.Functor.Classes.Show1', 'Data.Functor.Classes.Eq1', 'Data.Functor.Classes.Ord1', etc.), 11 | but on GHC >= 8.6, it uses @-XQuantifiedConstraints@ to express these 12 | constraints more cleanly. 13 | -} 14 | module Test.QuickCheck.Classes.Base 15 | ( -- * Running 16 | lawsCheck 17 | , lawsCheckWith 18 | , lawsCheckMany 19 | , lawsCheckWithMany 20 | , lawsCheckOne 21 | , lawsCheckWithOne 22 | -- * Properties 23 | -- ** Ground types 24 | #if MIN_VERSION_base(4,7,0) 25 | , bitsLaws 26 | #endif 27 | , eqLaws 28 | , substitutiveEqLaws 29 | , numLaws 30 | , integralLaws 31 | , ixLaws 32 | #if MIN_VERSION_base(4,7,0) 33 | , isListLaws 34 | #endif 35 | , monoidLaws 36 | , commutativeMonoidLaws 37 | , semigroupMonoidLaws 38 | , ordLaws 39 | , enumLaws 40 | , boundedEnumLaws 41 | , semigroupLaws 42 | , commutativeSemigroupLaws 43 | , exponentialSemigroupLaws 44 | , idempotentSemigroupLaws 45 | , rectangularBandSemigroupLaws 46 | , showLaws 47 | , showReadLaws 48 | , storableLaws 49 | #if MIN_VERSION_base(4,5,0) 50 | , genericLaws 51 | , generic1Laws 52 | #endif 53 | #if HAVE_UNARY_LAWS 54 | -- ** Unary type constructors 55 | , alternativeLaws 56 | , applicativeLaws 57 | , contravariantLaws 58 | , foldableLaws 59 | , functorLaws 60 | , monadLaws 61 | , monadPlusLaws 62 | , monadZipLaws 63 | , traversableLaws 64 | #endif 65 | #if HAVE_BINARY_LAWS 66 | -- ** Binary type constructors 67 | , bifoldableLaws 68 | , bifunctorLaws 69 | , bitraversableLaws 70 | , categoryLaws 71 | , commutativeCategoryLaws 72 | #endif 73 | -- * Types 74 | , Laws(..) 75 | , Proxy1(..) 76 | , Proxy2(..) 77 | ) where 78 | 79 | -- 80 | -- re-exports 81 | -- 82 | 83 | -- Ground Types 84 | import Test.QuickCheck.Classes.Bits 85 | import Test.QuickCheck.Classes.Enum 86 | import Test.QuickCheck.Classes.Eq 87 | import Test.QuickCheck.Classes.Num 88 | import Test.QuickCheck.Classes.Integral 89 | import Test.QuickCheck.Classes.Ix 90 | #if MIN_VERSION_base(4,7,0) 91 | import Test.QuickCheck.Classes.Base.IsList 92 | #endif 93 | import Test.QuickCheck.Classes.Monoid 94 | import Test.QuickCheck.Classes.Ord 95 | import Test.QuickCheck.Classes.Semigroup 96 | import Test.QuickCheck.Classes.Show 97 | import Test.QuickCheck.Classes.ShowRead 98 | import Test.QuickCheck.Classes.Storable 99 | #if MIN_VERSION_base(4,5,0) 100 | import Test.QuickCheck.Classes.Generic 101 | #endif 102 | -- Unary type constructors 103 | #if HAVE_UNARY_LAWS 104 | import Test.QuickCheck.Classes.Alternative 105 | import Test.QuickCheck.Classes.Applicative 106 | import Test.QuickCheck.Classes.Contravariant 107 | import Test.QuickCheck.Classes.Foldable 108 | import Test.QuickCheck.Classes.Functor 109 | import Test.QuickCheck.Classes.Monad 110 | import Test.QuickCheck.Classes.MonadPlus 111 | import Test.QuickCheck.Classes.MonadZip 112 | import Test.QuickCheck.Classes.Traversable 113 | #endif 114 | 115 | -- Binary type constructors 116 | #if HAVE_BINARY_LAWS 117 | import Test.QuickCheck.Classes.Bifunctor 118 | import Test.QuickCheck.Classes.Bifoldable 119 | import Test.QuickCheck.Classes.Bitraversable 120 | import Test.QuickCheck.Classes.Category 121 | #if HAVE_SEMIGROUPOIDS 122 | import Test.QuickCheck.Classes.Semigroupoid 123 | #endif 124 | #endif 125 | 126 | -- 127 | -- used below 128 | -- 129 | import Test.QuickCheck 130 | import Test.QuickCheck.Classes.Internal (foldMapA, Laws(..)) 131 | import Control.Monad 132 | import Data.Foldable 133 | import Data.Monoid (Monoid(..)) 134 | import Data.Proxy (Proxy(..)) 135 | import Data.Semigroup (Semigroup) 136 | import System.Exit (exitFailure) 137 | import qualified Data.List as List 138 | import qualified Data.Semigroup as SG 139 | 140 | -- | A convenience function for testing properties in GHCi. 141 | -- For example, at GHCi: 142 | -- 143 | -- >>> lawsCheck (monoidLaws (Proxy :: Proxy Ordering)) 144 | -- Monoid: Associative +++ OK, passed 100 tests. 145 | -- Monoid: Left Identity +++ OK, passed 100 tests. 146 | -- Monoid: Right Identity +++ OK, passed 100 tests. 147 | -- 148 | -- Assuming that the 'Arbitrary' instance for 'Ordering' is good, we now 149 | -- have confidence that the 'Monoid' instance for 'Ordering' satisfies 150 | -- the monoid laws. 151 | lawsCheck :: Laws -> IO () 152 | lawsCheck = lawsCheckWith stdArgs 153 | 154 | lawsCheckWith :: Args -> Laws -> IO () 155 | lawsCheckWith args (Laws className properties) = do 156 | flip foldMapA properties $ \(name,p) -> do 157 | putStr (className ++ ": " ++ name ++ " ") 158 | quickCheckWith args p 159 | 160 | -- | A convenience function that allows one to check many typeclass 161 | -- instances of the same type. 162 | -- 163 | -- >>> specialisedLawsCheckMany (Proxy :: Proxy Word) [jsonLaws, showReadLaws] 164 | -- ToJSON/FromJSON: Encoding Equals Value +++ OK, passed 100 tests. 165 | -- ToJSON/FromJSON: Partial Isomorphism +++ OK, passed 100 tests. 166 | -- Show/Read: Partial Isomorphism +++ OK, passed 100 tests. 167 | lawsCheckOne :: Proxy a -> [Proxy a -> Laws] -> IO () 168 | lawsCheckOne = lawsCheckWithOne stdArgs 169 | 170 | lawsCheckWithOne :: Args -> Proxy a -> [Proxy a -> Laws] -> IO () 171 | lawsCheckWithOne args p ls = foldlMapM (lawsCheckWith args . ($ p)) ls 172 | 173 | -- | A convenience function for checking multiple typeclass instances 174 | -- of multiple types. Consider the following Haskell source file: 175 | -- 176 | -- @ 177 | -- import Data.Proxy (Proxy(..)) 178 | -- import Data.Map (Map) 179 | -- import Data.Set (Set) 180 | -- 181 | -- -- A 'Proxy' for 'Set' 'Int'. 182 | -- setInt :: Proxy (Set Int) 183 | -- setInt = Proxy 184 | -- 185 | -- -- A 'Proxy' for 'Map' 'Int' 'Int'. 186 | -- mapInt :: Proxy (Map Int Int) 187 | -- mapInt = Proxy 188 | -- 189 | -- myLaws :: Proxy a -> [Laws] 190 | -- myLaws p = [eqLaws p, monoidLaws p] 191 | -- 192 | -- namedTests :: [(String, [Laws])] 193 | -- namedTests = 194 | -- [ ("Set Int", myLaws setInt) 195 | -- , ("Map Int Int", myLaws mapInt) 196 | -- ] 197 | -- @ 198 | -- 199 | -- Now, in GHCi: 200 | -- 201 | -- >>> lawsCheckMany namedTests 202 | -- 203 | -- @ 204 | -- Testing properties for common typeclasses 205 | -- ------------- 206 | -- -- Set Int -- 207 | -- ------------- 208 | -- 209 | -- Eq: Transitive +++ OK, passed 100 tests. 210 | -- Eq: Symmetric +++ OK, passed 100 tests. 211 | -- Eq: Reflexive +++ OK, passed 100 tests. 212 | -- Monoid: Associative +++ OK, passed 100 tests. 213 | -- Monoid: Left Identity +++ OK, passed 100 tests. 214 | -- Monoid: Right Identity +++ OK, passed 100 tests. 215 | -- Monoid: Concatenation +++ OK, passed 100 tests. 216 | -- 217 | -- ----------------- 218 | -- -- Map Int Int -- 219 | -- ----------------- 220 | -- 221 | -- Eq: Transitive +++ OK, passed 100 tests. 222 | -- Eq: Symmetric +++ OK, passed 100 tests. 223 | -- Eq: Reflexive +++ OK, passed 100 tests. 224 | -- Monoid: Associative +++ OK, passed 100 tests. 225 | -- Monoid: Left Identity +++ OK, passed 100 tests. 226 | -- Monoid: Right Identity +++ OK, passed 100 tests. 227 | -- Monoid: Concatenation +++ OK, passed 100 tests. 228 | -- @ 229 | -- 230 | -- In the case of a failing test, the program terminates with 231 | -- exit code 1. 232 | lawsCheckMany :: 233 | [(String,[Laws])] -- ^ Element is type name paired with typeclass laws 234 | -> IO () 235 | lawsCheckMany = lawsCheckWithMany stdArgs 236 | 237 | lawsCheckWithMany :: 238 | Args 239 | -> [(String,[Laws])] -- ^ Element is type name paired with typeclass laws 240 | -> IO () 241 | lawsCheckWithMany args xs = do 242 | putStrLn "Testing properties for common typeclasses" 243 | r <- flip foldMapA xs $ \(typeName,laws) -> do 244 | putStrLn $ List.replicate (length typeName + 6) '-' 245 | putStrLn $ "-- " ++ typeName ++ " --" 246 | putStrLn $ List.replicate (length typeName + 6) '-' 247 | flip foldMapA laws $ \(Laws typeClassName properties) -> do 248 | flip foldMapA properties $ \(name,p) -> do 249 | putStr (typeClassName ++ ": " ++ name ++ " ") 250 | r <- quickCheckWithResult args p 251 | return $ case r of 252 | Success{} -> Good 253 | _ -> Bad 254 | putStrLn "" 255 | case r of 256 | Good -> putStrLn "All tests succeeded" 257 | Bad -> do 258 | putStrLn "One or more tests failed" 259 | exitFailure 260 | 261 | data Status = Bad | Good 262 | 263 | instance Semigroup Status where 264 | Good <> x = x 265 | Bad <> _ = Bad 266 | 267 | instance Monoid Status where 268 | mempty = Good 269 | mappend = (SG.<>) 270 | 271 | -- | In older versions of GHC, Proxy is not poly-kinded, 272 | -- so we provide Proxy1. 273 | data Proxy1 (f :: * -> *) = Proxy1 274 | 275 | -- | In older versions of GHC, Proxy is not poly-kinded, 276 | -- so we provide Proxy2. 277 | data Proxy2 (f :: * -> * -> *) = Proxy2 278 | 279 | -- This is used internally to work around a missing Monoid 280 | -- instance for IO on older GHCs. 281 | foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b 282 | foldlMapM f = foldlM (\b a -> liftM (mappend b) (f a)) mempty 283 | -------------------------------------------------------------------------------- /quickcheck-classes-base/src/Test/QuickCheck/Classes/Base/IsList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | {-| 11 | 12 | This module provides property tests for functions that operate on 13 | list-like data types. If your data type is fully polymorphic in its 14 | element type, is it recommended that you use @foldableLaws@ and 15 | @traversableLaws@ from @Test.QuickCheck.Classes@. However, if your 16 | list-like data type is either monomorphic in its element type 17 | (like @Text@ or @ByteString@) or if it requires a typeclass 18 | constraint on its element (like @Data.Vector.Unboxed@), the properties 19 | provided here can be helpful for testing that your functions have 20 | the expected behavior. All properties in this module require your data 21 | type to have an 'IsList' instance. 22 | 23 | -} 24 | module Test.QuickCheck.Classes.Base.IsList 25 | ( 26 | #if MIN_VERSION_base(4,7,0) 27 | isListLaws 28 | , foldrProp 29 | , foldlProp 30 | , foldlMProp 31 | , mapProp 32 | , imapProp 33 | , imapMProp 34 | , traverseProp 35 | , generateProp 36 | , generateMProp 37 | , replicateProp 38 | , replicateMProp 39 | , filterProp 40 | , filterMProp 41 | , mapMaybeProp 42 | , mapMaybeMProp 43 | #endif 44 | ) where 45 | 46 | #if MIN_VERSION_base(4,7,0) 47 | import Control.Applicative 48 | import Control.Monad.ST (ST,runST) 49 | import Control.Monad (mapM,filterM,replicateM) 50 | import Control.Applicative (liftA2) 51 | import GHC.Exts (IsList,Item,toList,fromList,fromListN) 52 | import Data.Maybe (mapMaybe,catMaybes) 53 | import Data.Proxy (Proxy) 54 | import Data.Foldable (foldlM) 55 | import Data.Traversable (traverse) 56 | import Test.QuickCheck (Property,Arbitrary,CoArbitrary,(===),property, 57 | NonNegative(..)) 58 | #if MIN_VERSION_QuickCheck(2,10,0) 59 | import Test.QuickCheck.Function (Function,Fun,applyFun,applyFun2) 60 | #else 61 | import Test.QuickCheck.Function (Function,Fun,apply) 62 | #endif 63 | import qualified Data.List as L 64 | 65 | import Test.QuickCheck.Classes.Internal (Laws(..), myForAllShrink) 66 | 67 | -- | Tests the following properties: 68 | -- 69 | -- [/Partial Isomorphism/] 70 | -- @fromList . toList ≡ id@ 71 | -- [/Length Preservation/] 72 | -- @fromList xs ≡ fromListN (length xs) xs@ 73 | -- 74 | -- /Note:/ This property test is only available when 75 | -- using @base-4.7@ or newer. 76 | isListLaws :: (IsList a, Show a, Show (Item a), Arbitrary a, Arbitrary (Item a), Eq a) => Proxy a -> Laws 77 | isListLaws p = Laws "IsList" 78 | [ ("Partial Isomorphism", isListPartialIsomorphism p) 79 | , ("Length Preservation", isListLengthPreservation p) 80 | ] 81 | 82 | isListPartialIsomorphism :: forall a. (IsList a, Show a, Arbitrary a, Eq a) => Proxy a -> Property 83 | isListPartialIsomorphism _ = myForAllShrink False (const True) 84 | (\(a :: a) -> ["a = " ++ show a]) 85 | "fromList (toList a)" 86 | (\a -> fromList (toList a)) 87 | "a" 88 | (\a -> a) 89 | 90 | isListLengthPreservation :: forall a. (IsList a, Show (Item a), Arbitrary (Item a), Eq a) => Proxy a -> Property 91 | isListLengthPreservation _ = property $ \(xs :: [Item a]) -> 92 | (fromList xs :: a) == fromListN (length xs) xs 93 | 94 | foldrProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, CoArbitrary a, Function a) 95 | => Proxy a -- ^ input element type 96 | -> (forall b. (a -> b -> b) -> b -> c -> b) -- ^ foldr function 97 | -> Property 98 | foldrProp _ f = property $ \c (b0 :: Integer) func -> 99 | let g = applyFun2 func in 100 | L.foldr g b0 (toList c) === f g b0 c 101 | 102 | foldlProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, CoArbitrary a, Function a) 103 | => Proxy a -- ^ input element type 104 | -> (forall b. (b -> a -> b) -> b -> c -> b) -- ^ foldl function 105 | -> Property 106 | foldlProp _ f = property $ \c (b0 :: Integer) func -> 107 | let g = applyFun2 func in 108 | L.foldl g b0 (toList c) === f g b0 c 109 | 110 | foldlMProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, CoArbitrary a, Function a) 111 | => Proxy a -- ^ input element type 112 | -> (forall s b. (b -> a -> ST s b) -> b -> c -> ST s b) -- ^ monadic foldl function 113 | -> Property 114 | foldlMProp _ f = property $ \c (b0 :: Integer) func -> 115 | runST (foldlM (stApplyFun2 func) b0 (toList c)) === runST (f (stApplyFun2 func) b0 c) 116 | 117 | mapProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a) 118 | => Proxy a -- ^ input element type 119 | -> Proxy b -- ^ output element type 120 | -> ((a -> b) -> c -> d) -- ^ map function 121 | -> Property 122 | mapProp _ _ f = property $ \c func -> 123 | fromList (map (applyFun func) (toList c)) === f (applyFun func) c 124 | 125 | imapProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a) 126 | => Proxy a -- ^ input element type 127 | -> Proxy b -- ^ output element type 128 | -> ((Int -> a -> b) -> c -> d) -- ^ indexed map function 129 | -> Property 130 | imapProp _ _ f = property $ \c func -> 131 | fromList (imapList (applyFun2 func) (toList c)) === f (applyFun2 func) c 132 | 133 | imapMProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a) 134 | => Proxy a -- ^ input element type 135 | -> Proxy b -- ^ output element type 136 | -> (forall s. (Int -> a -> ST s b) -> c -> ST s d) -- ^ monadic indexed map function 137 | -> Property 138 | imapMProp _ _ f = property $ \c func -> 139 | fromList (runST (imapMList (stApplyFun2 func) (toList c))) === runST (f (stApplyFun2 func) c) 140 | 141 | traverseProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a) 142 | => Proxy a -- ^ input element type 143 | -> Proxy b -- ^ output element type 144 | -> (forall s. (a -> ST s b) -> c -> ST s d) -- ^ traverse function 145 | -> Property 146 | traverseProp _ _ f = property $ \c func -> 147 | fromList (runST (mapM (return . applyFun func) (toList c))) === runST (f (return . applyFun func) c) 148 | 149 | -- | Property for the @generate@ function, which builds a container 150 | -- of a given length by applying a function to each index. 151 | generateProp :: (Item c ~ a, Eq c, Show c, IsList c, Arbitrary a, Show a) 152 | => Proxy a -- ^ input element type 153 | -> (Int -> (Int -> a) -> c) -- generate function 154 | -> Property 155 | generateProp _ f = property $ \(NonNegative len) func -> 156 | fromList (generateList len (applyFun func)) === f len (applyFun func) 157 | 158 | generateMProp :: (Item c ~ a, Eq c, Show c, IsList c, Arbitrary a, Show a) 159 | => Proxy a -- ^ input element type 160 | -> (forall s. Int -> (Int -> ST s a) -> ST s c) -- monadic generate function 161 | -> Property 162 | generateMProp _ f = property $ \(NonNegative len) func -> 163 | fromList (runST (stGenerateList len (stApplyFun func))) === runST (f len (stApplyFun func)) 164 | 165 | replicateProp :: (Item c ~ a, Eq c, Show c, IsList c, Arbitrary a, Show a) 166 | => Proxy a -- ^ input element type 167 | -> (Int -> a -> c) -- replicate function 168 | -> Property 169 | replicateProp _ f = property $ \(NonNegative len) a -> 170 | fromList (replicate len a) === f len a 171 | 172 | replicateMProp :: (Item c ~ a, Eq c, Show c, IsList c, Arbitrary a, Show a) 173 | => Proxy a -- ^ input element type 174 | -> (forall s. Int -> ST s a -> ST s c) -- replicate function 175 | -> Property 176 | replicateMProp _ f = property $ \(NonNegative len) a -> 177 | fromList (runST (replicateM len (return a))) === runST (f len (return a)) 178 | 179 | -- | Property for the @filter@ function, which keeps elements for which 180 | -- the predicate holds true. 181 | filterProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, Eq c, CoArbitrary a, Function a) 182 | => Proxy a -- ^ element type 183 | -> ((a -> Bool) -> c -> c) -- ^ map function 184 | -> Property 185 | filterProp _ f = property $ \c func -> 186 | fromList (filter (applyFun func) (toList c)) === f (applyFun func) c 187 | 188 | -- | Property for the @filterM@ function, which keeps elements for which 189 | -- the predicate holds true in an applicative context. 190 | filterMProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, Eq c, CoArbitrary a, Function a) 191 | => Proxy a -- ^ element type 192 | -> (forall s. (a -> ST s Bool) -> c -> ST s c) -- ^ traverse function 193 | -> Property 194 | filterMProp _ f = property $ \c func -> 195 | fromList (runST (filterM (return . applyFun func) (toList c))) === runST (f (return . applyFun func) c) 196 | 197 | -- | Property for the @mapMaybe@ function, which keeps elements for which 198 | -- the predicate holds true. 199 | mapMaybeProp :: (IsList c, Item c ~ a, Item d ~ b, Eq d, IsList d, Arbitrary b, Show d, Show b, Arbitrary c, Show c, Show a, Eq c, CoArbitrary a, Function a) 200 | => Proxy a -- ^ input element type 201 | -> Proxy b -- ^ output element type 202 | -> ((a -> Maybe b) -> c -> d) -- ^ map function 203 | -> Property 204 | mapMaybeProp _ _ f = property $ \c func -> 205 | fromList (mapMaybe (applyFun func) (toList c)) === f (applyFun func) c 206 | 207 | mapMaybeMProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a) 208 | => Proxy a -- ^ input element type 209 | -> Proxy b -- ^ output element type 210 | -> (forall s. (a -> ST s (Maybe b)) -> c -> ST s d) -- ^ traverse function 211 | -> Property 212 | mapMaybeMProp _ _ f = property $ \c func -> 213 | fromList (runST (mapMaybeMList (return . applyFun func) (toList c))) === runST (f (return . applyFun func) c) 214 | 215 | imapList :: (Int -> a -> b) -> [a] -> [b] 216 | imapList f xs = map (uncurry f) (zip (enumFrom 0) xs) 217 | 218 | imapMList :: (Int -> a -> ST s b) -> [a] -> ST s [b] 219 | imapMList f = go 0 where 220 | go !_ [] = return [] 221 | go !ix (x : xs) = liftA2 (:) (f ix x) (go (ix + 1) xs) 222 | 223 | mapMaybeMList :: Applicative f => (a -> f (Maybe b)) -> [a] -> f [b] 224 | mapMaybeMList f = fmap catMaybes . traverse f 225 | 226 | generateList :: Int -> (Int -> a) -> [a] 227 | generateList len f = go 0 where 228 | go !ix = if ix < len 229 | then f ix : go (ix + 1) 230 | else [] 231 | 232 | stGenerateList :: Int -> (Int -> ST s a) -> ST s [a] 233 | stGenerateList len f = go 0 where 234 | go !ix = if ix < len 235 | then liftA2 (:) (f ix) (go (ix + 1)) 236 | else return [] 237 | 238 | stApplyFun :: Fun a b -> a -> ST s b 239 | stApplyFun f a = return (applyFun f a) 240 | 241 | stApplyFun2 :: Fun (a,b) c -> a -> b -> ST s c 242 | stApplyFun2 f a b = return (applyFun2 f a b) 243 | 244 | #if !MIN_VERSION_QuickCheck(2,10,0) 245 | applyFun :: Fun a b -> (a -> b) 246 | applyFun = apply 247 | 248 | applyFun2 :: Fun (a, b) c -> (a -> b -> c) 249 | applyFun2 = curry . apply 250 | #endif 251 | #endif 252 | -------------------------------------------------------------------------------- /quickcheck-classes/src/Test/QuickCheck/Classes/Prim.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE PackageImports #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE UnboxedTuples #-} 8 | 9 | {-# OPTIONS_GHC -Wall #-} 10 | 11 | module Test.QuickCheck.Classes.Prim 12 | ( primLaws 13 | ) where 14 | 15 | import Control.Applicative 16 | import Control.Monad.Primitive (PrimMonad, PrimState,primitive,primitive_) 17 | import Control.Monad.ST 18 | import Data.Proxy (Proxy) 19 | import Data.Primitive.ByteArray 20 | import Data.Primitive.Types (Prim(..)) 21 | import "primitive-addr" Data.Primitive.Addr 22 | import Foreign.Marshal.Alloc 23 | import GHC.Exts 24 | (State#,Int#,Addr#,Int(I#),(*#),(+#),(<#),newByteArray#,unsafeFreezeByteArray#, 25 | copyMutableByteArray#,copyByteArray#,quotInt#,sizeofByteArray#) 26 | 27 | #if MIN_VERSION_base(4,7,0) 28 | import GHC.Exts (IsList(fromList,toList,fromListN),Item, 29 | copyByteArrayToAddr#,copyAddrToByteArray#) 30 | #endif 31 | 32 | import GHC.Ptr (Ptr(..)) 33 | import System.IO.Unsafe 34 | import Test.QuickCheck hiding ((.&.)) 35 | 36 | import qualified Data.List as L 37 | import qualified Data.Primitive as P 38 | 39 | import Test.QuickCheck.Classes.Internal (Laws(..),isTrue#) 40 | 41 | -- | Test that a 'Prim' instance obey the several laws. 42 | primLaws :: (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws 43 | primLaws p = Laws "Prim" 44 | [ ("ByteArray Put-Get (you get back what you put in)", primPutGetByteArray p) 45 | , ("ByteArray Get-Put (putting back what you got out has no effect)", primGetPutByteArray p) 46 | , ("ByteArray Put-Put (putting twice is same as putting once)", primPutPutByteArray p) 47 | , ("ByteArray Set Range", primSetByteArray p) 48 | #if MIN_VERSION_base(4,7,0) 49 | , ("ByteArray List Conversion Roundtrips", primListByteArray p) 50 | #endif 51 | , ("Addr Put-Get (you get back what you put in)", primPutGetAddr p) 52 | , ("Addr Get-Put (putting back what you got out has no effect)", primGetPutAddr p) 53 | , ("Addr Set Range", primSetOffAddr p) 54 | , ("Addr List Conversion Roundtrips", primListAddr p) 55 | ] 56 | 57 | primListAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 58 | primListAddr _ = property $ \(as :: [a]) -> unsafePerformIO $ do 59 | let len = L.length as 60 | ptr@(Ptr addr#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a)) 61 | let addr = Addr addr# 62 | let go :: Int -> [a] -> IO () 63 | go !ix xs = case xs of 64 | [] -> return () 65 | (x : xsNext) -> do 66 | writeOffAddr addr ix x 67 | go (ix + 1) xsNext 68 | go 0 as 69 | let rebuild :: Int -> IO [a] 70 | rebuild !ix = if ix < len 71 | then (:) <$> readOffAddr addr ix <*> rebuild (ix + 1) 72 | else return [] 73 | asNew <- rebuild 0 74 | free ptr 75 | return (as == asNew) 76 | 77 | primPutGetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 78 | primPutGetByteArray _ = property $ \(a :: a) len -> (len > 0) ==> do 79 | ix <- choose (0,len - 1) 80 | return $ runST $ do 81 | arr <- newPrimArray len 82 | writePrimArray arr ix a 83 | a' <- readPrimArray arr ix 84 | return (a == a') 85 | 86 | primGetPutByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 87 | primGetPutByteArray _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do 88 | let arr1 = primArrayFromList as :: PrimArray a 89 | len = L.length as 90 | ix <- choose (0,len - 1) 91 | arr2 <- return $ runST $ do 92 | marr <- newPrimArray len 93 | copyPrimArray marr 0 arr1 0 len 94 | a <- readPrimArray marr ix 95 | writePrimArray marr ix a 96 | unsafeFreezePrimArray marr 97 | return (arr1 == arr2) 98 | 99 | primPutPutByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 100 | primPutPutByteArray _ = property $ \(a :: a) (as :: [a]) -> (not (L.null as)) ==> do 101 | let arr1 = primArrayFromList as :: PrimArray a 102 | len = L.length as 103 | ix <- choose (0,len - 1) 104 | (arr2,arr3) <- return $ runST $ do 105 | marr2 <- newPrimArray len 106 | copyPrimArray marr2 0 arr1 0 len 107 | writePrimArray marr2 ix a 108 | marr3 <- newPrimArray len 109 | copyMutablePrimArray marr3 0 marr2 0 len 110 | arr2 <- unsafeFreezePrimArray marr2 111 | writePrimArray marr3 ix a 112 | arr3 <- unsafeFreezePrimArray marr3 113 | return (arr2,arr3) 114 | return (arr2 == arr3) 115 | 116 | primPutGetAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 117 | primPutGetAddr _ = property $ \(a :: a) len -> (len > 0) ==> do 118 | ix <- choose (0,len - 1) 119 | return $ unsafePerformIO $ do 120 | ptr@(Ptr addr#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a)) 121 | let addr = Addr addr# 122 | writeOffAddr addr ix a 123 | a' <- readOffAddr addr ix 124 | free ptr 125 | return (a == a') 126 | 127 | primGetPutAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 128 | primGetPutAddr _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do 129 | let arr1 = primArrayFromList as :: PrimArray a 130 | len = L.length as 131 | ix <- choose (0,len - 1) 132 | arr2 <- return $ unsafePerformIO $ do 133 | ptr@(Ptr addr#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a)) 134 | let addr = Addr addr# 135 | copyPrimArrayToPtr ptr arr1 0 len 136 | a :: a <- readOffAddr addr ix 137 | writeOffAddr addr ix a 138 | marr <- newPrimArray len 139 | copyPtrToMutablePrimArray marr 0 ptr len 140 | free ptr 141 | unsafeFreezePrimArray marr 142 | return (arr1 == arr2) 143 | 144 | primSetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 145 | primSetByteArray _ = property $ \(as :: [a]) (z :: a) -> do 146 | let arr1 = primArrayFromList as :: PrimArray a 147 | len = L.length as 148 | x <- choose (0,len) 149 | y <- choose (0,len) 150 | let lo = min x y 151 | hi = max x y 152 | return $ runST $ do 153 | marr2 <- newPrimArray len 154 | copyPrimArray marr2 0 arr1 0 len 155 | marr3 <- newPrimArray len 156 | copyPrimArray marr3 0 arr1 0 len 157 | setPrimArray marr2 lo (hi - lo) z 158 | internalDefaultSetPrimArray marr3 lo (hi - lo) z 159 | arr2 <- unsafeFreezePrimArray marr2 160 | arr3 <- unsafeFreezePrimArray marr3 161 | return (arr2 == arr3) 162 | 163 | primSetOffAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 164 | primSetOffAddr _ = property $ \(as :: [a]) (z :: a) -> do 165 | let arr1 = primArrayFromList as :: PrimArray a 166 | len = L.length as 167 | x <- choose (0,len) 168 | y <- choose (0,len) 169 | let lo = min x y 170 | hi = max x y 171 | return $ unsafePerformIO $ do 172 | ptrA@(Ptr addrA#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a)) 173 | let addrA = Addr addrA# 174 | copyPrimArrayToPtr ptrA arr1 0 len 175 | ptrB@(Ptr addrB#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a)) 176 | let addrB = Addr addrB# 177 | copyPrimArrayToPtr ptrB arr1 0 len 178 | setOffAddr addrA lo (hi - lo) z 179 | internalDefaultSetOffAddr addrB lo (hi - lo) z 180 | marrA <- newPrimArray len 181 | copyPtrToMutablePrimArray marrA 0 ptrA len 182 | free ptrA 183 | marrB <- newPrimArray len 184 | copyPtrToMutablePrimArray marrB 0 ptrB len 185 | free ptrB 186 | arrA <- unsafeFreezePrimArray marrA 187 | arrB <- unsafeFreezePrimArray marrB 188 | return (arrA == arrB) 189 | 190 | -- byte array with phantom variable that specifies element type 191 | data PrimArray a = PrimArray ByteArray# 192 | data MutablePrimArray s a = MutablePrimArray (MutableByteArray# s) 193 | 194 | instance (Eq a, Prim a) => Eq (PrimArray a) where 195 | a1 == a2 = sizeofPrimArray a1 == sizeofPrimArray a2 && loop (sizeofPrimArray a1 - 1) 196 | where 197 | loop !i | i < 0 = True 198 | | otherwise = indexPrimArray a1 i == indexPrimArray a2 i && loop (i-1) 199 | 200 | #if MIN_VERSION_base(4,7,0) 201 | instance Prim a => IsList (PrimArray a) where 202 | type Item (PrimArray a) = a 203 | fromList = primArrayFromList 204 | fromListN = primArrayFromListN 205 | toList = primArrayToList 206 | #endif 207 | 208 | indexPrimArray :: forall a. Prim a => PrimArray a -> Int -> a 209 | indexPrimArray (PrimArray arr#) (I# i#) = indexByteArray# arr# i# 210 | 211 | sizeofPrimArray :: forall a. Prim a => PrimArray a -> Int 212 | sizeofPrimArray (PrimArray arr#) = I# (quotInt# (sizeofByteArray# arr#) (P.sizeOf# (undefined :: a))) 213 | 214 | newPrimArray :: forall m a. (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a) 215 | newPrimArray (I# n#) 216 | = primitive (\s# -> 217 | case newByteArray# (n# *# sizeOf# (undefined :: a)) s# of 218 | (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #) 219 | ) 220 | 221 | readPrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> m a 222 | readPrimArray (MutablePrimArray arr#) (I# i#) 223 | = primitive (readByteArray# arr# i#) 224 | 225 | writePrimArray :: 226 | (Prim a, PrimMonad m) 227 | => MutablePrimArray (PrimState m) a 228 | -> Int 229 | -> a 230 | -> m () 231 | writePrimArray (MutablePrimArray arr#) (I# i#) x 232 | = primitive_ (writeByteArray# arr# i# x) 233 | 234 | unsafeFreezePrimArray 235 | :: PrimMonad m => MutablePrimArray (PrimState m) a -> m (PrimArray a) 236 | unsafeFreezePrimArray (MutablePrimArray arr#) 237 | = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of 238 | (# s'#, arr'# #) -> (# s'#, PrimArray arr'# #)) 239 | 240 | #if !MIN_VERSION_base(4,7,0) 241 | ptrToAddr :: Ptr a -> Addr 242 | ptrToAddr (Ptr x) = Addr x 243 | 244 | generateM_ :: Monad m => Int -> (Int -> m a) -> m () 245 | generateM_ n f = go 0 where 246 | go !ix = if ix < n 247 | then f ix >> go (ix + 1) 248 | else return () 249 | #endif 250 | 251 | copyPrimArrayToPtr :: forall m a. (PrimMonad m, Prim a) 252 | => Ptr a -- ^ destination pointer 253 | -> PrimArray a -- ^ source array 254 | -> Int -- ^ offset into source array 255 | -> Int -- ^ number of prims to copy 256 | -> m () 257 | #if MIN_VERSION_base(4,7,0) 258 | copyPrimArrayToPtr (Ptr addr#) (PrimArray ba#) (I# soff#) (I# n#) = 259 | primitive (\ s# -> 260 | let s'# = copyByteArrayToAddr# ba# (soff# *# siz#) addr# (n# *# siz#) s# 261 | in (# s'#, () #)) 262 | where siz# = sizeOf# (undefined :: a) 263 | #else 264 | copyPrimArrayToPtr addr ba soff n = 265 | generateM_ n $ \ix -> writeOffAddr (ptrToAddr addr) ix (indexPrimArray ba (ix + soff)) 266 | #endif 267 | 268 | copyPtrToMutablePrimArray :: forall m a. (PrimMonad m, Prim a) 269 | => MutablePrimArray (PrimState m) a 270 | -> Int 271 | -> Ptr a 272 | -> Int 273 | -> m () 274 | #if MIN_VERSION_base(4,7,0) 275 | copyPtrToMutablePrimArray (MutablePrimArray ba#) (I# doff#) (Ptr addr#) (I# n#) = 276 | primitive (\ s# -> 277 | let s'# = copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#) s# 278 | in (# s'#, () #)) 279 | where siz# = sizeOf# (undefined :: a) 280 | #else 281 | copyPtrToMutablePrimArray ba doff addr n = 282 | generateM_ n $ \ix -> do 283 | x <- readOffAddr (ptrToAddr addr) ix 284 | writePrimArray ba (doff + ix) x 285 | #endif 286 | 287 | copyMutablePrimArray :: forall m a. 288 | (PrimMonad m, Prim a) 289 | => MutablePrimArray (PrimState m) a -- ^ destination array 290 | -> Int -- ^ offset into destination array 291 | -> MutablePrimArray (PrimState m) a -- ^ source array 292 | -> Int -- ^ offset into source array 293 | -> Int -- ^ number of bytes to copy 294 | -> m () 295 | copyMutablePrimArray (MutablePrimArray dst#) (I# doff#) (MutablePrimArray src#) (I# soff#) (I# n#) 296 | = primitive_ (copyMutableByteArray# 297 | src# 298 | (soff# *# (sizeOf# (undefined :: a))) 299 | dst# 300 | (doff# *# (sizeOf# (undefined :: a))) 301 | (n# *# (sizeOf# (undefined :: a))) 302 | ) 303 | 304 | copyPrimArray :: forall m a. 305 | (PrimMonad m, Prim a) 306 | => MutablePrimArray (PrimState m) a -- ^ destination array 307 | -> Int -- ^ offset into destination array 308 | -> PrimArray a -- ^ source array 309 | -> Int -- ^ offset into source array 310 | -> Int -- ^ number of bytes to copy 311 | -> m () 312 | copyPrimArray (MutablePrimArray dst#) (I# doff#) (PrimArray src#) (I# soff#) (I# n#) 313 | = primitive_ (copyByteArray# 314 | src# 315 | (soff# *# (sizeOf# (undefined :: a))) 316 | dst# 317 | (doff# *# (sizeOf# (undefined :: a))) 318 | (n# *# (sizeOf# (undefined :: a))) 319 | ) 320 | 321 | setPrimArray 322 | :: (Prim a, PrimMonad m) 323 | => MutablePrimArray (PrimState m) a -- ^ array to fill 324 | -> Int -- ^ offset into array 325 | -> Int -- ^ number of values to fill 326 | -> a -- ^ value to fill with 327 | -> m () 328 | setPrimArray (MutablePrimArray dst#) (I# doff#) (I# sz#) x 329 | = primitive_ (P.setByteArray# dst# doff# sz# x) 330 | 331 | primArrayFromList :: Prim a => [a] -> PrimArray a 332 | primArrayFromList xs = primArrayFromListN (L.length xs) xs 333 | 334 | primArrayFromListN :: forall a. Prim a => Int -> [a] -> PrimArray a 335 | primArrayFromListN len vs = runST run where 336 | run :: forall s. ST s (PrimArray a) 337 | run = do 338 | arr <- newPrimArray len 339 | let go :: [a] -> Int -> ST s () 340 | go !xs !ix = case xs of 341 | [] -> return () 342 | a : as -> do 343 | writePrimArray arr ix a 344 | go as (ix + 1) 345 | go vs 0 346 | unsafeFreezePrimArray arr 347 | 348 | primArrayToList :: forall a. Prim a => PrimArray a -> [a] 349 | primArrayToList arr = go 0 where 350 | !len = sizeofPrimArray arr 351 | go :: Int -> [a] 352 | go !ix = if ix < len 353 | then indexPrimArray arr ix : go (ix + 1) 354 | else [] 355 | 356 | #if MIN_VERSION_base(4,7,0) 357 | primListByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property 358 | primListByteArray _ = property $ \(as :: [a]) -> 359 | as == toList (fromList as :: PrimArray a) 360 | #endif 361 | 362 | setOffAddr :: forall a. Prim a => Addr -> Int -> Int -> a -> IO () 363 | setOffAddr addr ix len a = setAddr (plusAddr addr (P.sizeOf (undefined :: a) * ix)) len a 364 | 365 | internalDefaultSetPrimArray :: Prim a 366 | => MutablePrimArray s a -> Int -> Int -> a -> ST s () 367 | internalDefaultSetPrimArray (MutablePrimArray arr) (I# i) (I# len) ident = 368 | primitive_ (internalDefaultSetByteArray# arr i len ident) 369 | 370 | internalDefaultSetByteArray# :: Prim a 371 | => MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s 372 | internalDefaultSetByteArray# arr# i# len# ident = go 0# 373 | where 374 | go ix# s0 = if isTrue# (ix# <# len#) 375 | then case writeByteArray# arr# (i# +# ix#) ident s0 of 376 | s1 -> go (ix# +# 1#) s1 377 | else s0 378 | 379 | internalDefaultSetOffAddr :: Prim a => Addr -> Int -> Int -> a -> IO () 380 | internalDefaultSetOffAddr (Addr addr) (I# ix) (I# len) a = primitive_ 381 | (internalDefaultSetOffAddr# addr ix len a) 382 | 383 | internalDefaultSetOffAddr# :: Prim a => Addr# -> Int# -> Int# -> a -> State# s -> State# s 384 | internalDefaultSetOffAddr# addr# i# len# ident = go 0# 385 | where 386 | go ix# s0 = if isTrue# (ix# <# len#) 387 | then case writeOffAddr# addr# (i# +# ix#) ident s0 of 388 | s1 -> go (ix# +# 1#) s1 389 | else s0 390 | --------------------------------------------------------------------------------