quickcheck-classes-base-0.6.2.0/0000755000000000000000000000000007346545000014523 5ustar0000000000000000quickcheck-classes-base-0.6.2.0/LICENSE0000644000000000000000000000276207346545000015537 0ustar0000000000000000Copyright Andrew Martin (c) 2017 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Andrew Martin nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.quickcheck-classes-base-0.6.2.0/changelog.md0000755000000000000000000000250707346545000017003 0ustar0000000000000000# Changelog All notable changes to this project will be documented in this file. The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). Note that since `quickcheck-classes` reexports larges parts of `quickcheck-classes-base`, changelog entries that deal with any of the classes from `base` are duplicated across the two changelogs. ## [0.6.2.0] - 2021-04-12 - Storable Set-Set Law (resolves issue 101). - Trim unneeded dependencies (tagged, base-orphans) - Trim unneeded dependencies on newer GHCs (bifunctors, contravariant) ## [0.6.1.0] - 2020-09-09 ### Added - Laws for `abs` and `signum` - Storable Set-Set Law (resolves issue 101). - Add laws for `quotRem` and `divMod`. - Use non-commutative monoid for bifoldable tests (resolves issue 98) - `substitutiveEqLaws`, which tests for Eq substitutivity. - Negation law check for `Eq`. - Document that users can provide their own `Laws`. ## [0.6.0.0] - 2019-08-08 ### Added - Initial release. This factor out a subset of laws tests from `quickcheck-classes` and depend on this library that have a more minimal dependency footprint. - Add laws for left rotate and right rotate. - Add law that checks that subtraction is the same thing as adding the negation of a number. quickcheck-classes-base-0.6.2.0/quickcheck-classes-base.cabal0000644000000000000000000000733507346545000022174 0ustar0000000000000000cabal-version: 2.4 name: quickcheck-classes-base version: 0.6.2.0 synopsis: QuickCheck common typeclasses from `base` description: This libary is a minimal variant of `quickcheck-classes` that only provides laws for typeclasses from `base`. The main purpose of splitting this out is so that `primitive` can depend on `quickcheck-classes-base` in its test suite, avoiding the circular dependency that arises if `quickcheck-classes` is used instead. . This library provides QuickCheck properties to ensure that typeclass instances adhere to the set of laws that they are supposed to. There are other libraries that do similar things, such as `genvalidity-hspec` and `checkers`. This library differs from other solutions by not introducing any new typeclasses that the user needs to learn. . /Note:/ on GHC < 8.5, this library uses the higher-kinded typeclasses ('Data.Functor.Classes.Show1', 'Data.Functor.Classes.Eq1', 'Data.Functor.Classes.Ord1', etc.), but on GHC >= 8.5, it uses `-XQuantifiedConstraints` to express these constraints more cleanly. homepage: https://github.com/andrewthad/quickcheck-classes#readme license: BSD-3-Clause license-file: LICENSE author: Andrew Martin, chessai maintainer: andrew.thaddeus@gmail.com copyright: 2019 Andrew Martin category: Testing build-type: Simple extra-source-files: changelog.md flag unary-laws description: Include infrastructure for testing class laws of unary type constructors. default: True manual: True flag binary-laws description: Include infrastructure for testing class laws of binary type constructors. Disabling `unary-laws` while keeping `binary-laws` enabled is an unsupported configuration. default: True manual: True library default-language: Haskell2010 hs-source-dirs: src exposed-modules: Test.QuickCheck.Classes.Base Test.QuickCheck.Classes.Base.IsList Test.QuickCheck.Classes.Internal other-modules: Test.QuickCheck.Classes.Alternative Test.QuickCheck.Classes.Applicative Test.QuickCheck.Classes.Bifoldable Test.QuickCheck.Classes.Bifunctor Test.QuickCheck.Classes.Bitraversable Test.QuickCheck.Classes.Bits Test.QuickCheck.Classes.Category Test.QuickCheck.Classes.Contravariant Test.QuickCheck.Classes.Enum Test.QuickCheck.Classes.Eq Test.QuickCheck.Classes.Foldable Test.QuickCheck.Classes.Functor Test.QuickCheck.Classes.Generic Test.QuickCheck.Classes.Integral Test.QuickCheck.Classes.Ix Test.QuickCheck.Classes.Monad Test.QuickCheck.Classes.MonadFail Test.QuickCheck.Classes.MonadPlus Test.QuickCheck.Classes.MonadZip Test.QuickCheck.Classes.Monoid Test.QuickCheck.Classes.Num Test.QuickCheck.Classes.Ord Test.QuickCheck.Classes.Semigroup Test.QuickCheck.Classes.Show Test.QuickCheck.Classes.ShowRead Test.QuickCheck.Classes.Storable Test.QuickCheck.Classes.Traversable build-depends: , base >= 4.5 && < 5 , QuickCheck >= 2.7 , transformers >= 0.3 && < 0.6 , containers >= 0.4.2.1 if impl(ghc < 8.6) build-depends: contravariant if impl(ghc < 8.2) build-depends: bifunctors if impl(ghc < 8.0) build-depends: , semigroups >= 0.17 , fail if impl(ghc < 7.8) build-depends: tagged if impl(ghc > 7.4) && impl(ghc < 7.6) build-depends: ghc-prim if impl(ghc > 8.5) cpp-options: -DHAVE_QUANTIFIED_CONSTRAINTS if flag(unary-laws) build-depends: , transformers >= 0.4.0 , QuickCheck >= 2.10.0 cpp-options: -DHAVE_UNARY_LAWS if flag(binary-laws) build-depends: , transformers >= 0.5.0 , QuickCheck >= 2.10.0 cpp-options: -DHAVE_BINARY_LAWS source-repository head type: git location: https://github.com/andrewthad/quickcheck-classes quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/0000755000000000000000000000000007346545000021640 5ustar0000000000000000quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Alternative.hs0000644000000000000000000000461407346545000024457 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Alternative ( #if HAVE_UNARY_LAWS alternativeLaws #endif ) where import Control.Applicative (Alternative(..)) import Test.QuickCheck hiding ((.&.)) #if HAVE_UNARY_LAWS import Test.QuickCheck.Arbitrary (Arbitrary1(..)) import Data.Functor.Classes (Eq1,Show1) #endif import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal #if HAVE_UNARY_LAWS -- | Tests the following alternative properties: -- -- [/Left Identity/] -- @'empty' '<|>' x ≡ x@ -- [/Right Identity/] -- @x '<|>' 'empty' ≡ x@ -- [/Associativity/] -- @a '<|>' (b '<|>' c) ≡ (a '<|>' b) '<|>' c)@ alternativeLaws :: #if HAVE_QUANTIFIED_CONSTRAINTS (Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws alternativeLaws p = Laws "Alternative" [ ("Left Identity", alternativeLeftIdentity p) , ("Right Identity", alternativeRightIdentity p) , ("Associativity", alternativeAssociativity p) ] alternativeLeftIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property alternativeLeftIdentity _ = property $ \(Apply (a :: f Integer)) -> (eq1 (empty <|> a) a) alternativeRightIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property alternativeRightIdentity _ = property $ \(Apply (a :: f Integer)) -> (eq1 a (empty <|> a)) alternativeAssociativity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property alternativeAssociativity _ = property $ \(Apply (a :: f Integer)) (Apply (b :: f Integer)) (Apply (c :: f Integer)) -> eq1 (a <|> (b <|> c)) ((a <|> b) <|> c) #endif quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Applicative.hs0000644000000000000000000000726507346545000024447 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Applicative ( #if HAVE_UNARY_LAWS applicativeLaws #endif ) where import Control.Applicative import Test.QuickCheck hiding ((.&.)) #if HAVE_UNARY_LAWS import Test.QuickCheck.Arbitrary (Arbitrary1(..)) import Data.Functor.Classes (Eq1,Show1) #endif import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal #if HAVE_UNARY_LAWS -- | Tests the following applicative properties: -- -- [/Identity/] -- @'pure' 'id' '<*>' v ≡ v@ -- [/Composition/] -- @'pure' ('.') '<*>' u '<*>' v '<*>' w ≡ u '<*>' (v '<*>' w)@ -- [/Homomorphism/] -- @'pure' f '<*>' 'pure' x ≡ 'pure' (f x)@ -- [/Interchange/] -- @u '<*>' 'pure' y ≡ 'pure' ('$' y) '<*>' u@ -- [/LiftA2 (1)/] -- @('<*>') ≡ 'liftA2' 'id'@ applicativeLaws :: #if HAVE_QUANTIFIED_CONSTRAINTS (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws applicativeLaws p = Laws "Applicative" [ ("Identity", applicativeIdentity p) , ("Composition", applicativeComposition p) , ("Homomorphism", applicativeHomomorphism p) , ("Interchange", applicativeInterchange p) , ("LiftA2 Part 1", applicativeLiftA2_1 p) -- todo: liftA2 part 2, we need an equation of two variables for this ] applicativeIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property applicativeIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (pure id <*> a) a applicativeComposition :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property applicativeComposition _ = property $ \(Apply (u' :: f QuadraticEquation)) (Apply (v' :: f QuadraticEquation)) (Apply (w :: f Integer)) -> let u = fmap runQuadraticEquation u' v = fmap runQuadraticEquation v' in eq1 (pure (.) <*> u <*> v <*> w) (u <*> (v <*> w)) applicativeHomomorphism :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a)) #else (Applicative f, Eq1 f, Show1 f) #endif => proxy f -> Property applicativeHomomorphism _ = property $ \(e :: QuadraticEquation) (a :: Integer) -> let f = runQuadraticEquation e in eq1 (pure f <*> pure a) (pure (f a) :: f Integer) applicativeInterchange :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property applicativeInterchange _ = property $ \(Apply (u' :: f QuadraticEquation)) (y :: Integer) -> let u = fmap runQuadraticEquation u' in eq1 (u <*> pure y) (pure ($ y) <*> u) applicativeLiftA2_1 :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property applicativeLiftA2_1 _ = property $ \(Apply (f' :: f QuadraticEquation)) (Apply (x :: f Integer)) -> let f = fmap runQuadraticEquation f' in eq1 (liftA2 id f x) (f <*> x) #endif quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Base.hs0000644000000000000000000001644107346545000023054 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# OPTIONS_GHC -Wall #-} {-| This library provides sets of properties that should hold for common typeclasses. /Note:/ on GHC < 8.6, this library uses the higher-kinded typeclasses ('Data.Functor.Classes.Show1', 'Data.Functor.Classes.Eq1', 'Data.Functor.Classes.Ord1', etc.), but on GHC >= 8.6, it uses @-XQuantifiedConstraints@ to express these constraints more cleanly. -} module Test.QuickCheck.Classes.Base ( -- * Running lawsCheck , lawsCheckMany , lawsCheckOne -- * Properties -- ** Ground types #if MIN_VERSION_base(4,7,0) , bitsLaws #endif , eqLaws , substitutiveEqLaws , numLaws , integralLaws , ixLaws #if MIN_VERSION_base(4,7,0) , isListLaws #endif , monoidLaws , commutativeMonoidLaws , semigroupMonoidLaws , ordLaws , enumLaws , boundedEnumLaws , semigroupLaws , commutativeSemigroupLaws , exponentialSemigroupLaws , idempotentSemigroupLaws , rectangularBandSemigroupLaws , showLaws , showReadLaws , storableLaws #if MIN_VERSION_base(4,5,0) , genericLaws , generic1Laws #endif #if HAVE_UNARY_LAWS -- ** Unary type constructors , alternativeLaws , applicativeLaws , contravariantLaws , foldableLaws , functorLaws , monadLaws , monadPlusLaws , monadZipLaws , traversableLaws #endif #if HAVE_BINARY_LAWS -- ** Binary type constructors , bifoldableLaws , bifunctorLaws , bitraversableLaws , categoryLaws , commutativeCategoryLaws #endif -- * Types , Laws(..) , Proxy1(..) , Proxy2(..) ) where -- -- re-exports -- -- Ground Types import Test.QuickCheck.Classes.Bits import Test.QuickCheck.Classes.Enum import Test.QuickCheck.Classes.Eq import Test.QuickCheck.Classes.Num import Test.QuickCheck.Classes.Integral import Test.QuickCheck.Classes.Ix #if MIN_VERSION_base(4,7,0) import Test.QuickCheck.Classes.Base.IsList #endif import Test.QuickCheck.Classes.Monoid import Test.QuickCheck.Classes.Ord import Test.QuickCheck.Classes.Semigroup import Test.QuickCheck.Classes.Show import Test.QuickCheck.Classes.ShowRead import Test.QuickCheck.Classes.Storable #if MIN_VERSION_base(4,5,0) import Test.QuickCheck.Classes.Generic #endif -- Unary type constructors #if HAVE_UNARY_LAWS import Test.QuickCheck.Classes.Alternative import Test.QuickCheck.Classes.Applicative import Test.QuickCheck.Classes.Contravariant import Test.QuickCheck.Classes.Foldable import Test.QuickCheck.Classes.Functor import Test.QuickCheck.Classes.Monad import Test.QuickCheck.Classes.MonadPlus import Test.QuickCheck.Classes.MonadZip import Test.QuickCheck.Classes.Traversable #endif -- Binary type constructors #if HAVE_BINARY_LAWS import Test.QuickCheck.Classes.Bifunctor import Test.QuickCheck.Classes.Bifoldable import Test.QuickCheck.Classes.Bitraversable import Test.QuickCheck.Classes.Category #if HAVE_SEMIGROUPOIDS import Test.QuickCheck.Classes.Semigroupoid #endif #endif -- -- used below -- import Test.QuickCheck import Test.QuickCheck.Classes.Internal (foldMapA, Laws(..)) import Control.Monad import Data.Foldable import Data.Monoid (Monoid(..)) import Data.Proxy (Proxy(..)) import Data.Semigroup (Semigroup) import System.Exit (exitFailure) import qualified Data.List as List import qualified Data.Semigroup as SG -- | A convenience function for testing properties in GHCi. -- For example, at GHCi: -- -- >>> lawsCheck (monoidLaws (Proxy :: Proxy Ordering)) -- Monoid: Associative +++ OK, passed 100 tests. -- Monoid: Left Identity +++ OK, passed 100 tests. -- Monoid: Right Identity +++ OK, passed 100 tests. -- -- Assuming that the 'Arbitrary' instance for 'Ordering' is good, we now -- have confidence that the 'Monoid' instance for 'Ordering' satisfies -- the monoid laws. lawsCheck :: Laws -> IO () lawsCheck (Laws className properties) = do flip foldMapA properties $ \(name,p) -> do putStr (className ++ ": " ++ name ++ " ") quickCheck p -- | A convenience function that allows one to check many typeclass -- instances of the same type. -- -- >>> specialisedLawsCheckMany (Proxy :: Proxy Word) [jsonLaws, showReadLaws] -- ToJSON/FromJSON: Encoding Equals Value +++ OK, passed 100 tests. -- ToJSON/FromJSON: Partial Isomorphism +++ OK, passed 100 tests. -- Show/Read: Partial Isomorphism +++ OK, passed 100 tests. lawsCheckOne :: Proxy a -> [Proxy a -> Laws] -> IO () lawsCheckOne p ls = foldlMapM (lawsCheck . ($ p)) ls -- | A convenience function for checking multiple typeclass instances -- of multiple types. Consider the following Haskell source file: -- -- @ -- import Data.Proxy (Proxy(..)) -- import Data.Map (Map) -- import Data.Set (Set) -- -- -- A 'Proxy' for 'Set' 'Int'. -- setInt :: Proxy (Set Int) -- setInt = Proxy -- -- -- A 'Proxy' for 'Map' 'Int' 'Int'. -- mapInt :: Proxy (Map Int Int) -- mapInt = Proxy -- -- myLaws :: Proxy a -> [Laws] -- myLaws p = [eqLaws p, monoidLaws p] -- -- namedTests :: [(String, [Laws])] -- namedTests = -- [ ("Set Int", myLaws setInt) -- , ("Map Int Int", myLaws mapInt) -- ] -- @ -- -- Now, in GHCi: -- -- >>> lawsCheckMany namedTests -- -- @ -- Testing properties for common typeclasses -- ------------- -- -- Set Int -- -- ------------- -- -- Eq: Transitive +++ OK, passed 100 tests. -- Eq: Symmetric +++ OK, passed 100 tests. -- Eq: Reflexive +++ OK, passed 100 tests. -- Monoid: Associative +++ OK, passed 100 tests. -- Monoid: Left Identity +++ OK, passed 100 tests. -- Monoid: Right Identity +++ OK, passed 100 tests. -- Monoid: Concatenation +++ OK, passed 100 tests. -- -- ----------------- -- -- Map Int Int -- -- ----------------- -- -- Eq: Transitive +++ OK, passed 100 tests. -- Eq: Symmetric +++ OK, passed 100 tests. -- Eq: Reflexive +++ OK, passed 100 tests. -- Monoid: Associative +++ OK, passed 100 tests. -- Monoid: Left Identity +++ OK, passed 100 tests. -- Monoid: Right Identity +++ OK, passed 100 tests. -- Monoid: Concatenation +++ OK, passed 100 tests. -- @ -- -- In the case of a failing test, the program terminates with -- exit code 1. lawsCheckMany :: [(String,[Laws])] -- ^ Element is type name paired with typeclass laws -> IO () lawsCheckMany xs = do putStrLn "Testing properties for common typeclasses" r <- flip foldMapA xs $ \(typeName,laws) -> do putStrLn $ List.replicate (length typeName + 6) '-' putStrLn $ "-- " ++ typeName ++ " --" putStrLn $ List.replicate (length typeName + 6) '-' flip foldMapA laws $ \(Laws typeClassName properties) -> do flip foldMapA properties $ \(name,p) -> do putStr (typeClassName ++ ": " ++ name ++ " ") r <- quickCheckResult p return $ case r of Success{} -> Good _ -> Bad putStrLn "" case r of Good -> putStrLn "All tests succeeded" Bad -> do putStrLn "One or more tests failed" exitFailure data Status = Bad | Good instance Semigroup Status where Good <> x = x Bad <> _ = Bad instance Monoid Status where mempty = Good mappend = (SG.<>) -- | In older versions of GHC, Proxy is not poly-kinded, -- so we provide Proxy1. data Proxy1 (f :: * -> *) = Proxy1 -- | In older versions of GHC, Proxy is not poly-kinded, -- so we provide Proxy2. data Proxy2 (f :: * -> * -> *) = Proxy2 -- This is used internally to work around a missing Monoid -- instance for IO on older GHCs. foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b foldlMapM f = foldlM (\b a -> liftM (mappend b) (f a)) mempty quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Base/0000755000000000000000000000000007346545000022512 5ustar0000000000000000quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Base/IsList.hs0000644000000000000000000002335207346545000024262 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-} {-| This module provides property tests for functions that operate on list-like data types. If your data type is fully polymorphic in its element type, is it recommended that you use @foldableLaws@ and @traversableLaws@ from @Test.QuickCheck.Classes@. However, if your list-like data type is either monomorphic in its element type (like @Text@ or @ByteString@) or if it requires a typeclass constraint on its element (like @Data.Vector.Unboxed@), the properties provided here can be helpful for testing that your functions have the expected behavior. All properties in this module require your data type to have an 'IsList' instance. -} module Test.QuickCheck.Classes.Base.IsList ( #if MIN_VERSION_base(4,7,0) isListLaws , foldrProp , foldlProp , foldlMProp , mapProp , imapProp , imapMProp , traverseProp , generateProp , generateMProp , replicateProp , replicateMProp , filterProp , filterMProp , mapMaybeProp , mapMaybeMProp #endif ) where #if MIN_VERSION_base(4,7,0) import Control.Applicative import Control.Monad.ST (ST,runST) import Control.Monad (mapM,filterM,replicateM) import Control.Applicative (liftA2) import GHC.Exts (IsList,Item,toList,fromList,fromListN) import Data.Maybe (mapMaybe,catMaybes) import Data.Proxy (Proxy) import Data.Foldable (foldlM) import Data.Traversable (traverse) import Test.QuickCheck (Property,Arbitrary,CoArbitrary,(===),property, NonNegative(..)) #if MIN_VERSION_QuickCheck(2,10,0) import Test.QuickCheck.Function (Function,Fun,applyFun,applyFun2) #else import Test.QuickCheck.Function (Function,Fun,apply) #endif import qualified Data.List as L import Test.QuickCheck.Classes.Internal (Laws(..), myForAllShrink) -- | Tests the following properties: -- -- [/Partial Isomorphism/] -- @fromList . toList ≡ id@ -- [/Length Preservation/] -- @fromList xs ≡ fromListN (length xs) xs@ -- -- /Note:/ This property test is only available when -- using @base-4.7@ or newer. isListLaws :: (IsList a, Show a, Show (Item a), Arbitrary a, Arbitrary (Item a), Eq a) => Proxy a -> Laws isListLaws p = Laws "IsList" [ ("Partial Isomorphism", isListPartialIsomorphism p) , ("Length Preservation", isListLengthPreservation p) ] isListPartialIsomorphism :: forall a. (IsList a, Show a, Arbitrary a, Eq a) => Proxy a -> Property isListPartialIsomorphism _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "fromList (toList a)" (\a -> fromList (toList a)) "a" (\a -> a) isListLengthPreservation :: forall a. (IsList a, Show (Item a), Arbitrary (Item a), Eq a) => Proxy a -> Property isListLengthPreservation _ = property $ \(xs :: [Item a]) -> (fromList xs :: a) == fromListN (length xs) xs foldrProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> (forall b. (a -> b -> b) -> b -> c -> b) -- ^ foldr function -> Property foldrProp _ f = property $ \c (b0 :: Integer) func -> let g = applyFun2 func in L.foldr g b0 (toList c) === f g b0 c foldlProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> (forall b. (b -> a -> b) -> b -> c -> b) -- ^ foldl function -> Property foldlProp _ f = property $ \c (b0 :: Integer) func -> let g = applyFun2 func in L.foldl g b0 (toList c) === f g b0 c foldlMProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> (forall s b. (b -> a -> ST s b) -> b -> c -> ST s b) -- ^ monadic foldl function -> Property foldlMProp _ f = property $ \c (b0 :: Integer) func -> runST (foldlM (stApplyFun2 func) b0 (toList c)) === runST (f (stApplyFun2 func) b0 c) mapProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> Proxy b -- ^ output element type -> ((a -> b) -> c -> d) -- ^ map function -> Property mapProp _ _ f = property $ \c func -> fromList (map (applyFun func) (toList c)) === f (applyFun func) c imapProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> Proxy b -- ^ output element type -> ((Int -> a -> b) -> c -> d) -- ^ indexed map function -> Property imapProp _ _ f = property $ \c func -> fromList (imapList (applyFun2 func) (toList c)) === f (applyFun2 func) c imapMProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> Proxy b -- ^ output element type -> (forall s. (Int -> a -> ST s b) -> c -> ST s d) -- ^ monadic indexed map function -> Property imapMProp _ _ f = property $ \c func -> fromList (runST (imapMList (stApplyFun2 func) (toList c))) === runST (f (stApplyFun2 func) c) traverseProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> Proxy b -- ^ output element type -> (forall s. (a -> ST s b) -> c -> ST s d) -- ^ traverse function -> Property traverseProp _ _ f = property $ \c func -> fromList (runST (mapM (return . applyFun func) (toList c))) === runST (f (return . applyFun func) c) -- | Property for the @generate@ function, which builds a container -- of a given length by applying a function to each index. generateProp :: (Item c ~ a, Eq c, Show c, IsList c, Arbitrary a, Show a) => Proxy a -- ^ input element type -> (Int -> (Int -> a) -> c) -- generate function -> Property generateProp _ f = property $ \(NonNegative len) func -> fromList (generateList len (applyFun func)) === f len (applyFun func) generateMProp :: (Item c ~ a, Eq c, Show c, IsList c, Arbitrary a, Show a) => Proxy a -- ^ input element type -> (forall s. Int -> (Int -> ST s a) -> ST s c) -- monadic generate function -> Property generateMProp _ f = property $ \(NonNegative len) func -> fromList (runST (stGenerateList len (stApplyFun func))) === runST (f len (stApplyFun func)) replicateProp :: (Item c ~ a, Eq c, Show c, IsList c, Arbitrary a, Show a) => Proxy a -- ^ input element type -> (Int -> a -> c) -- replicate function -> Property replicateProp _ f = property $ \(NonNegative len) a -> fromList (replicate len a) === f len a replicateMProp :: (Item c ~ a, Eq c, Show c, IsList c, Arbitrary a, Show a) => Proxy a -- ^ input element type -> (forall s. Int -> ST s a -> ST s c) -- replicate function -> Property replicateMProp _ f = property $ \(NonNegative len) a -> fromList (runST (replicateM len (return a))) === runST (f len (return a)) -- | Property for the @filter@ function, which keeps elements for which -- the predicate holds true. filterProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, Eq c, CoArbitrary a, Function a) => Proxy a -- ^ element type -> ((a -> Bool) -> c -> c) -- ^ map function -> Property filterProp _ f = property $ \c func -> fromList (filter (applyFun func) (toList c)) === f (applyFun func) c -- | Property for the @filterM@ function, which keeps elements for which -- the predicate holds true in an applicative context. filterMProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, Eq c, CoArbitrary a, Function a) => Proxy a -- ^ element type -> (forall s. (a -> ST s Bool) -> c -> ST s c) -- ^ traverse function -> Property filterMProp _ f = property $ \c func -> fromList (runST (filterM (return . applyFun func) (toList c))) === runST (f (return . applyFun func) c) -- | Property for the @mapMaybe@ function, which keeps elements for which -- the predicate holds true. mapMaybeProp :: (IsList c, Item c ~ a, Item d ~ b, Eq d, IsList d, Arbitrary b, Show d, Show b, Arbitrary c, Show c, Show a, Eq c, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> Proxy b -- ^ output element type -> ((a -> Maybe b) -> c -> d) -- ^ map function -> Property mapMaybeProp _ _ f = property $ \c func -> fromList (mapMaybe (applyFun func) (toList c)) === f (applyFun func) c mapMaybeMProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> Proxy b -- ^ output element type -> (forall s. (a -> ST s (Maybe b)) -> c -> ST s d) -- ^ traverse function -> Property mapMaybeMProp _ _ f = property $ \c func -> fromList (runST (mapMaybeMList (return . applyFun func) (toList c))) === runST (f (return . applyFun func) c) imapList :: (Int -> a -> b) -> [a] -> [b] imapList f xs = map (uncurry f) (zip (enumFrom 0) xs) imapMList :: (Int -> a -> ST s b) -> [a] -> ST s [b] imapMList f = go 0 where go !_ [] = return [] go !ix (x : xs) = liftA2 (:) (f ix x) (go (ix + 1) xs) mapMaybeMList :: Applicative f => (a -> f (Maybe b)) -> [a] -> f [b] mapMaybeMList f = fmap catMaybes . traverse f generateList :: Int -> (Int -> a) -> [a] generateList len f = go 0 where go !ix = if ix < len then f ix : go (ix + 1) else [] stGenerateList :: Int -> (Int -> ST s a) -> ST s [a] stGenerateList len f = go 0 where go !ix = if ix < len then liftA2 (:) (f ix) (go (ix + 1)) else return [] stApplyFun :: Fun a b -> a -> ST s b stApplyFun f a = return (applyFun f a) stApplyFun2 :: Fun (a,b) c -> a -> b -> ST s c stApplyFun2 f a b = return (applyFun2 f a b) #if !MIN_VERSION_QuickCheck(2,10,0) applyFun :: Fun a b -> (a -> b) applyFun = apply applyFun2 :: Fun (a, b) c -> (a -> b -> c) applyFun2 = curry . apply #endif #endif quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Bifoldable.hs0000644000000000000000000001154707346545000024227 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Bifoldable ( #if HAVE_BINARY_LAWS bifoldableLaws , bifoldableFunctorLaws #endif ) where #if HAVE_BINARY_LAWS import Data.Bifoldable(Bifoldable(..)) import Data.Bifunctor (Bifunctor(..)) import Test.QuickCheck hiding ((.&.)) import Data.Functor.Classes (Eq2,Show2) import Test.QuickCheck.Property (Property) import Data.Monoid import Test.QuickCheck.Classes.Internal #endif #if HAVE_BINARY_LAWS -- | Tests the following 'Bifunctor' properties: -- -- [/Bifold Identity/] -- @'bifold' ≡ 'bifoldMap' 'id' 'id'@ -- [/BifoldMap Identity/] -- @'bifoldMap' f g ≡ 'bifoldr' ('mappend' '.' f) ('mappend' '.' g) 'mempty'@ -- [/Bifoldr Identity/] -- @'bifoldr' f g z t ≡ 'appEndo' ('bifoldMap' ('Endo' '.' f) ('Endo' '.' g) t) z@ -- -- /Note/: This property test is only available when this package is built with -- @base-4.10+@ or @transformers-0.5+@. bifoldableLaws :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Bifoldable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) #else (Bifoldable f, Eq2 f, Show2 f, Arbitrary2 f) #endif => proxy f -> Laws bifoldableLaws p = Laws "Bifoldable" [ ("Bifold Identity", bifoldIdentity p) , ("BifoldMap Identity", bifoldMapIdentity p) , ("Bifoldr Identity", bifoldrIdentity p) ] -- | Tests the following 'Bifunctor'/'Bifoldable' properties: -- -- [/Bifold Identity/] -- @'bifoldMap' f g ≡ 'bifold' '.' 'bimap' f g@ -- [/BifoldMap Identity/] -- @'bifoldMap' f g '.' 'bimap' h i ≡ 'bifoldMap' (f '.' h) (g '.' i)@ -- -- /Note/: This property test is only available when this package is built with -- @base-4.10+@ or @transformers-0.5+@. bifoldableFunctorLaws :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Bifoldable f, Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) #else (Bifoldable f, Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) #endif => proxy f -> Laws bifoldableFunctorLaws p = Laws "Bifoldable/Bifunctor" [ ("Bifoldable Bifunctor Law", bifoldableFunctorLaw p) , ("Bifoldable Bifunctor Law Implication", bifoldableFunctorImplication p) ] bifoldableFunctorLaw :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Bifoldable f, Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) #else (Bifoldable f, Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) #endif => proxy f -> Property bifoldableFunctorLaw _ = property $ \(Apply2 (x :: f Integer Integer)) -> bifoldMap mkMonoid mkMonoid x == (bifold (bimap mkMonoid mkMonoid x)) bifoldableFunctorImplication :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Bifoldable f, Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) #else (Bifoldable f, Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) #endif => proxy f -> Property bifoldableFunctorImplication _ = property $ \(Apply2 (x :: f Integer Integer)) -> bifoldMap mkMonoid mkMonoid (bimap mkMonoid mkMonoid x) == bifoldMap (mkMonoid . mkMonoid) (mkMonoid . mkMonoid) x bifoldIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Bifoldable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) #else (Bifoldable f, Eq2 f, Show2 f, Arbitrary2 f) #endif => proxy f -> Property bifoldIdentity _ = property $ \(Apply2 (x :: f [Integer] [Integer])) -> (bifold x) == (bifoldMap id id x) bifoldMapIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Bifoldable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) #else (Bifoldable f, Eq2 f, Show2 f, Arbitrary2 f) #endif => proxy f -> Property bifoldMapIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> bifoldMap mkMonoid mkMonoid x == bifoldr (mappend . mkMonoid) (mappend . mkMonoid) mempty x bifoldrIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Bifoldable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) #else (Bifoldable f, Eq2 f, Show2 f, Arbitrary2 f) #endif => proxy f -> Property bifoldrIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> let f _ _ = mempty g _ _ = mempty in bifoldr f g (mempty :: [Integer]) x == appEndo (bifoldMap (Endo . f) (Endo . g) x) mempty mkMonoid :: a -> [a] mkMonoid x = [x] #endif quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Bifunctor.hs0000644000000000000000000000613007346545000024127 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Bifunctor ( #if HAVE_BINARY_LAWS bifunctorLaws #endif ) where import Data.Bifunctor(Bifunctor(..)) import Test.QuickCheck hiding ((.&.)) #if HAVE_BINARY_LAWS import Data.Functor.Classes (Eq2,Show2) #endif import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal #if HAVE_BINARY_LAWS -- | Tests the following 'Bifunctor' properties: -- -- [/Identity/] -- @'bimap' 'id' 'id' ≡ 'id'@ -- [/First Identity/] -- @'first' 'id' ≡ 'id'@ -- [/Second Identity/] -- @'second' 'id' ≡ 'id'@ -- [/Bifunctor Composition/] -- @'bimap' f g ≡ 'first' f '.' 'second' g@ -- -- /Note/: This property test is only available when this package is built with -- @base-4.9+@ or @transformers-0.5+@. bifunctorLaws :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) #else (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) #endif => proxy f -> Laws bifunctorLaws p = Laws "Bifunctor" [ ("Identity", bifunctorIdentity p) , ("First Identity", bifunctorFirstIdentity p) , ("Second Identity", bifunctorSecondIdentity p) , ("Bifunctor Composition", bifunctorComposition p) ] bifunctorIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) #else (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) #endif => proxy f -> Property bifunctorIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq2 (bimap id id x) x bifunctorFirstIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) #else (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) #endif => proxy f -> Property bifunctorFirstIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq2 (first id x) x bifunctorSecondIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) #else (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) #endif => proxy f -> Property bifunctorSecondIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq2 (second id x) x bifunctorComposition :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) #else (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) #endif => proxy f -> Property bifunctorComposition _ = property $ \(Apply2 (z :: f Integer Integer)) -> eq2 (bimap id id z) ((first id . second id) z) #endif quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Bitraversable.hs0000644000000000000000000000637507346545000024774 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Bitraversable ( #if HAVE_BINARY_LAWS bitraversableLaws #endif ) where import Data.Bitraversable(Bitraversable(..)) import Test.QuickCheck hiding ((.&.)) #if HAVE_BINARY_LAWS import Data.Functor.Compose (Compose(..)) import Data.Functor.Identity (Identity(..)) import Data.Functor.Classes (Eq2,Show2) #endif import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal #if HAVE_BINARY_LAWS -- | Tests the following 'Bitraversable' properties: -- -- [/Naturality/] -- @'bitraverse' (t '.' f) (t '.' g) ≡ t '.' 'bitraverse' f g@ for every applicative transformation @t@ -- [/Identity/] -- @'bitraverse' 'Identity' 'Identity' ≡ 'Identity'@ -- [/Composition/] -- @'Compose' '.' 'fmap' ('bitraverse' g1 g2) '.' 'bitraverse' f1 f2 ≡ 'bitraverse' ('Compose' '.' 'fmap' g1 g2 '.' f1) ('Compose' '.' 'fmap' g2 '.' f2)@ -- -- /Note/: This property test is only available when this package is built with -- @base-4.9+@ or @transformers-0.5+@. bitraversableLaws :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Bitraversable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) #else (Bitraversable f, Eq2 f, Show2 f, Arbitrary2 f) #endif => proxy f -> Laws bitraversableLaws p = Laws "Bitraversable" [ ("Naturality", bitraversableNaturality p) , ("Identity", bitraversableIdentity p) , ("Composition", bitraversableComposition p) ] bitraversableNaturality :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Bitraversable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) #else (Bitraversable f, Eq2 f, Show2 f, Arbitrary2 f) #endif => proxy f -> Property bitraversableNaturality _ = property $ \(Apply2 (x :: f Integer Integer)) -> let t = apTrans f = func4 g = func4 x' = bitraverse (t . f) (t . g) x y' = t (bitraverse f g x) in eq1_2 x' y' bitraversableIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Bitraversable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) #else (Bitraversable f, Eq2 f, Show2 f, Arbitrary2 f) #endif => proxy f -> Property bitraversableIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq1_2 (bitraverse Identity Identity x) (Identity x) bitraversableComposition :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Bitraversable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) #else (Bitraversable f, Eq2 f, Show2 f, Arbitrary2 f) #endif => proxy f -> Property bitraversableComposition _ = property $ \(Apply2 (x :: f Integer Integer)) -> let f1 = func6 f2 = func5 g1 = func4 g2 = func4 x' = Compose . fmap (bitraverse g1 g2) . bitraverse f1 f2 $ x y' = bitraverse (Compose . fmap g1 . f1) (Compose . fmap g2 . f2) x in eq1_2 x' y' #endif quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Bits.hs0000644000000000000000000001630707346545000023104 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Bits ( #if MIN_VERSION_base(4,7,0) bitsLaws #endif ) where import Data.Bits import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import qualified Data.Set as S import Test.QuickCheck.Classes.Internal (Laws(..), myForAllShrink) -- | Tests the following properties: -- -- [/Conjunction Idempotence/] -- @n .&. n ≡ n@ -- [/Disjunction Idempotence/] -- @n .|. n ≡ n@ -- [/Double Complement/] -- @complement (complement n) ≡ n@ -- [/Set Bit/] -- @setBit n i ≡ n .|. bit i@ -- [/Clear Bit/] -- @clearBit n i ≡ n .&. complement (bit i)@ -- [/Complement Bit/] -- @complementBit n i ≡ xor n (bit i)@ -- [/Clear Zero/] -- @clearBit zeroBits i ≡ zeroBits@ -- [/Set Zero/] -- @setBit zeroBits i ≡ bit i@ -- [/Test Zero/] -- @testBit zeroBits i ≡ False@ -- [/Pop Zero/] -- @popCount zeroBits ≡ 0@ -- [/Right Rotation/] -- @no sign extension → (rotateR n i ≡ (shiftR n i) .|. (shiftL n (finiteBitSize ⊥ - i)))@ -- [/Left Rotation/] -- @no sign extension → (rotateL n i ≡ (shiftL n i) .|. (shiftR n (finiteBitSize ⊥ - i)))@ -- [/Count Leading Zeros of Zero/] -- @countLeadingZeros zeroBits ≡ finiteBitSize ⊥@ -- [/Count Trailing Zeros of Zero/] -- @countTrailingZeros zeroBits ≡ finiteBitSize ⊥@ -- -- All of the useful instances of the 'Bits' typeclass -- also have 'FiniteBits' instances, so these property -- tests actually require that instance as well. -- -- /Note:/ This property test is only available when -- using @base-4.7@ or newer. #if MIN_VERSION_base(4,7,0) bitsLaws :: (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Laws bitsLaws p = Laws "Bits" [ ("Conjunction Idempotence", bitsConjunctionIdempotence p) , ("Disjunction Idempotence", bitsDisjunctionIdempotence p) , ("Double Complement", bitsDoubleComplement p) , ("Set Bit", bitsSetBit p) , ("Clear Bit", bitsClearBit p) , ("Complement Bit", bitsComplementBit p) , ("Clear Zero", bitsClearZero p) , ("Set Zero", bitsSetZero p) , ("Test Zero", bitsTestZero p) , ("Pop Zero", bitsPopZero p) , ("Right Rotation", bitsRightRotation p) , ("Left Rotation", bitsLeftRotation p) #if MIN_VERSION_base(4,8,0) , ("Count Leading Zeros of Zero", bitsCountLeadingZeros p) , ("Count Trailing Zeros of Zero", bitsCountTrailingZeros p) #endif ] #endif #if MIN_VERSION_base(4,7,0) newtype BitIndex a = BitIndex Int instance FiniteBits a => Arbitrary (BitIndex a) where arbitrary = let n = finiteBitSize (undefined :: a) in if n > 0 then fmap BitIndex (choose (0,n - 1)) else return (BitIndex 0) shrink (BitIndex x) = if x > 0 then map BitIndex (S.toList (S.fromList [x - 1, div x 2, 0])) else [] bitsConjunctionIdempotence :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property bitsConjunctionIdempotence _ = myForAllShrink False (const True) (\(n :: a) -> ["n = " ++ show n]) "n .&. n" (\n -> n .&. n) "n" (\n -> n) bitsDisjunctionIdempotence :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property bitsDisjunctionIdempotence _ = myForAllShrink False (const True) (\(n :: a) -> ["n = " ++ show n]) "n .|. n" (\n -> n .|. n) "n" (\n -> n) bitsDoubleComplement :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property bitsDoubleComplement _ = myForAllShrink False (const True) (\(n :: a) -> ["n = " ++ show n]) "complement (complement n)" (\n -> complement (complement n)) "n" (\n -> n) bitsSetBit :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property bitsSetBit _ = myForAllShrink True (const True) (\(n :: a, BitIndex i :: BitIndex a) -> ["n = " ++ show n, "i = " ++ show i]) "setBit n i" (\(n,BitIndex i) -> setBit n i) "n .|. bit i" (\(n,BitIndex i) -> n .|. bit i) bitsClearBit :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property bitsClearBit _ = myForAllShrink True (const True) (\(n :: a, BitIndex i :: BitIndex a) -> ["n = " ++ show n, "i = " ++ show i]) "clearBit n i" (\(n,BitIndex i) -> clearBit n i) "n .&. complement (bit i)" (\(n,BitIndex i) -> n .&. complement (bit i)) bitsComplementBit :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property bitsComplementBit _ = myForAllShrink True (const True) (\(n :: a, BitIndex i :: BitIndex a) -> ["n = " ++ show n, "i = " ++ show i]) "complementBit n i" (\(n,BitIndex i) -> complementBit n i) "xor n (bit i)" (\(n,BitIndex i) -> xor n (bit i)) bitsClearZero :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property bitsClearZero _ = myForAllShrink False (const True) (\(BitIndex n :: BitIndex a) -> ["n = " ++ show n]) "clearBit zeroBits n" (\(BitIndex n) -> clearBit zeroBits n :: a) "zeroBits" (\_ -> zeroBits) bitsSetZero :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property bitsSetZero _ = myForAllShrink True (const True) (\(BitIndex i :: BitIndex a) -> ["i = " ++ show i]) "setBit zeroBits i" (\(BitIndex i) -> setBit (zeroBits :: a) i) "bit i" (\(BitIndex i) -> bit i) bitsTestZero :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property bitsTestZero _ = myForAllShrink True (const True) (\(BitIndex i :: BitIndex a) -> ["i = " ++ show i]) "testBit zeroBits i" (\(BitIndex i) -> testBit (zeroBits :: a) i) "False" (\_ -> False) bitsPopZero :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property bitsPopZero _ = myForAllShrink True (const True) (\() -> []) "popCount zeroBits" (\() -> popCount (zeroBits :: a)) "0" (\() -> 0) bitsRightRotation :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property bitsRightRotation _ = myForAllShrink True (\(n :: a, BitIndex _ :: BitIndex a) -> not (testBit (shiftR n 1) (finiteBitSize (undefined :: a) - 1)) ) (\(n, BitIndex i) -> ["n = " ++ show n, "i = " ++ show i]) "rotateR n i" (\(n,BitIndex i) -> rotateR n i) "shiftR n i .|. shiftL n (finiteBitSize ⊥ - i)" (\(n,BitIndex i) -> shiftR n i .|. shiftL n (finiteBitSize (undefined :: a) - i)) bitsLeftRotation :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property bitsLeftRotation _ = myForAllShrink True (\(n :: a, BitIndex _ :: BitIndex a) -> not (testBit (shiftR n 1) (finiteBitSize (undefined :: a) - 1)) ) (\(n, BitIndex i) -> ["n = " ++ show n, "i = " ++ show i]) "rotateL n i" (\(n,BitIndex i) -> rotateL n i) "shiftL n i .|. shiftR n (finiteBitSize ⊥ - i)" (\(n,BitIndex i) -> shiftL n i .|. shiftR n (finiteBitSize (undefined :: a) - i)) #endif #if MIN_VERSION_base(4,8,0) bitsCountLeadingZeros :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property bitsCountLeadingZeros _ = myForAllShrink True (const True) (\() -> []) "countLeadingZeros zeroBits" (\() -> countLeadingZeros (zeroBits :: a)) "finiteBitSize undefined" (\() -> finiteBitSize (undefined :: a)) bitsCountTrailingZeros :: forall a. (FiniteBits a, Arbitrary a, Show a) => Proxy a -> Property bitsCountTrailingZeros _ = myForAllShrink True (const True) (\() -> []) "countTrailingZeros zeroBits" (\() -> countTrailingZeros (zeroBits :: a)) "finiteBitSize undefined" (\() -> finiteBitSize (undefined :: a)) #endif quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Category.hs0000644000000000000000000000740507346545000023757 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Category ( #if HAVE_BINARY_LAWS categoryLaws , commutativeCategoryLaws #endif ) where import Prelude hiding (id, (.)) import Control.Category (Category(..)) import Test.QuickCheck hiding ((.&.)) #if HAVE_BINARY_LAWS import Data.Functor.Classes (Eq2,Show2) #endif import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal #if HAVE_BINARY_LAWS -- | Tests the following 'Category' properties: -- -- [/Right Identity/] -- @f '.' 'id' ≡ f@ -- [/Left Identity/] -- @'id' '.' f ≡ f@ -- [/Associativity/] -- @f '.' (g '.' h) ≡ (f '.' g) '.' h@ -- -- /Note/: This property test is only available when this package is built with -- @base-4.9+@ or @transformers-0.5+@. categoryLaws :: forall proxy c. #if HAVE_QUANTIFIED_CONSTRAINTS (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b)) #else (Category c, Eq2 c, Show2 c, Arbitrary2 c) #endif => proxy c -> Laws categoryLaws p = Laws "Category" [ ("Right Identity", categoryRightIdentity p) , ("Left Identity", categoryLeftIdentity p) , ("Associativity", categoryAssociativity p) ] -- | Test everything from 'categoryLaws' plus the following: -- -- [/Commutative/] -- @f '.' g ≡ g '.' f@ -- -- /Note/: This property test is only available when this package is built with -- @base-4.9+@ or @transformers-0.5+@. commutativeCategoryLaws :: forall proxy c. #if HAVE_QUANTIFIED_CONSTRAINTS (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b)) #else (Category c, Eq2 c, Show2 c, Arbitrary2 c) #endif => proxy c -> Laws commutativeCategoryLaws p = Laws "Commutative Category" $ lawsProperties (categoryLaws p) ++ [ ("Commutative", categoryCommutativity p) ] categoryRightIdentity :: forall proxy c. #if HAVE_QUANTIFIED_CONSTRAINTS (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b)) #else (Category c, Eq2 c, Show2 c, Arbitrary2 c) #endif => proxy c -> Property categoryRightIdentity _ = property $ \(Apply2 (x :: c Integer Integer)) -> eq2 (x . id) x categoryLeftIdentity :: forall proxy c. #if HAVE_QUANTIFIED_CONSTRAINTS (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b)) #else (Category c, Eq2 c, Show2 c, Arbitrary2 c) #endif => proxy c -> Property categoryLeftIdentity _ = property $ \(Apply2 (x :: c Integer Integer)) -> eq2 (id . x) x categoryAssociativity :: forall proxy c. #if HAVE_QUANTIFIED_CONSTRAINTS (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b)) #else (Category c, Eq2 c, Show2 c, Arbitrary2 c) #endif => proxy c -> Property categoryAssociativity _ = property $ \(Apply2 (f :: c Integer Integer)) (Apply2 (g :: c Integer Integer)) (Apply2 (h :: c Integer Integer)) -> eq2 (f . (g . h)) ((f . g) . h) categoryCommutativity :: forall proxy c. #if HAVE_QUANTIFIED_CONSTRAINTS (Category c, forall a b. (Eq a, Eq b) => Eq (c a b), forall a b. (Show a, Show b) => Show (c a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (c a b)) #else (Category c, Eq2 c, Show2 c, Arbitrary2 c) #endif => proxy c -> Property categoryCommutativity _ = property $ \(Apply2 (f :: c Integer Integer)) (Apply2 (g :: c Integer Integer)) -> eq2 (f . g) (g . f) #endif quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Contravariant.hs0000644000000000000000000000413107346545000025006 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Contravariant ( #if HAVE_UNARY_LAWS contravariantLaws #endif ) where import Data.Functor.Contravariant import Test.QuickCheck hiding ((.&.)) #if HAVE_UNARY_LAWS import Test.QuickCheck.Arbitrary (Arbitrary1(..)) import Data.Functor.Classes (Eq1,Show1) #endif import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal #if HAVE_UNARY_LAWS -- | Tests the following contravariant properties: -- -- [/Identity/] -- @'contramap' 'id' ≡ 'id'@ -- [/Composition/] -- @'contramap' f '.' 'contramap' g ≡ 'contramap' (g '.' f)@ contravariantLaws :: #if HAVE_QUANTIFIED_CONSTRAINTS (Contravariant f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Contravariant f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws contravariantLaws p = Laws "Contravariant" [ ("Identity", contravariantIdentity p) , ("Composition", contravariantComposition p) ] contravariantIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Contravariant f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Contravariant f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property contravariantIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (contramap id a) a contravariantComposition :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Contravariant f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Contravariant f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property contravariantComposition _ = property $ \(Apply (a :: f Integer)) (f' :: QuadraticEquation) (g' :: QuadraticEquation) -> do let f = runQuadraticEquation f' g = runQuadraticEquation g' eq1 (contramap f (contramap g a)) (contramap (g . f) a) #endif quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Enum.hs0000644000000000000000000000476607346545000023115 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Enum ( enumLaws , boundedEnumLaws ) where import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal (Laws(..), myForAllShrink) -- | Tests the following properties: -- -- [/Succ Pred Identity/] -- @'succ' ('pred' x) ≡ x@ -- [/Pred Succ Identity/] -- @'pred' ('succ' x) ≡ x@ -- -- This only works for @Enum@ types that are not bounded, meaning -- that 'succ' and 'pred' must be total. This means that these property -- tests work correctly for types like 'Integer' but not for 'Int'. -- -- Sadly, there is not a good way to test 'fromEnum' and 'toEnum', -- since many types that have reasonable implementations for 'succ' -- and 'pred' have more inhabitants than 'Int' does. enumLaws :: (Enum a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws enumLaws p = Laws "Enum" [ ("Succ Pred Identity", succPredIdentity p) , ("Pred Succ Identity", predSuccIdentity p) ] -- | Tests the same properties as 'enumLaws' except that it requires -- the type to have a 'Bounded' instance. These tests avoid taking the -- successor of the maximum element or the predecessor of the minimal -- element. boundedEnumLaws :: (Enum a, Bounded a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws boundedEnumLaws p = Laws "Enum" [ ("Succ Pred Identity", succPredBoundedIdentity p) , ("Pred Succ Identity", predSuccBoundedIdentity p) ] succPredIdentity :: forall a. (Enum a, Eq a, Arbitrary a, Show a) => Proxy a -> Property succPredIdentity _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "succ (pred x)" (\a -> succ (pred a)) "x" (\a -> a) predSuccIdentity :: forall a. (Enum a, Eq a, Arbitrary a, Show a) => Proxy a -> Property predSuccIdentity _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "pred (succ x)" (\a -> pred (succ a)) "x" (\a -> a) succPredBoundedIdentity :: forall a. (Enum a, Bounded a, Eq a, Arbitrary a, Show a) => Proxy a -> Property succPredBoundedIdentity _ = myForAllShrink False (\a -> a /= minBound) (\(a :: a) -> ["a = " ++ show a]) "succ (pred x)" (\a -> succ (pred a)) "x" (\a -> a) predSuccBoundedIdentity :: forall a. (Enum a, Bounded a, Eq a, Arbitrary a, Show a) => Proxy a -> Property predSuccBoundedIdentity _ = myForAllShrink False (\a -> a /= maxBound) (\(a :: a) -> ["a = " ++ show a]) "pred (succ x)" (\a -> pred (succ a)) "x" (\a -> a) quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Eq.hs0000644000000000000000000000422407346545000022543 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Eq ( eqLaws , substitutiveEqLaws ) where import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Function import Test.QuickCheck.Classes.Internal (Laws(..)) -- | Tests the following properties: -- -- [/Transitive/] -- @a '==' b ∧ b '==' c ⇒ a '==' c@ -- [/Symmetric/] -- @a '==' b ⇒ b '==' a@ -- [/Reflexive/] -- @a '==' a@ -- [/Negation/] -- @x '/=' y '==' 'not' (x '==' y)@ -- -- Some of these properties involve implication. In the case that -- the left hand side of the implication arrow does not hold, we -- do not retry. Consequently, these properties only end up being -- useful when the data type has a small number of inhabitants. eqLaws :: (Eq a, Arbitrary a, Show a) => Proxy a -> Laws eqLaws p = Laws "Eq" [ ("Transitive", eqTransitive p) , ("Symmetric", eqSymmetric p) , ("Reflexive", eqReflexive p) ] eqTransitive :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property eqTransitive _ = property $ \(a :: a) b c -> case a == b of True -> case b == c of True -> a == c False -> a /= c False -> case b == c of True -> a /= c False -> True eqSymmetric :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property eqSymmetric _ = property $ \(a :: a) b -> case a == b of True -> b == a False -> b /= a eqReflexive :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property eqReflexive _ = property $ \(a :: a) -> a == a eqNegation :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property eqNegation _ = property $ \(x :: a) y -> (x /= y) == not (x == y) -- | Tests the following properties: -- -- [/Substitutive/] -- @x '==' y ⇒ f x '==' f y@ -- -- /Note/: This does not test `eqLaws`. -- If you want to use this, You should use it in addition to `eqLaws`. substitutiveEqLaws :: forall a. (Eq a, Arbitrary a, CoArbitrary a, Function a, Show a) => Proxy a -> Laws substitutiveEqLaws _ = Laws "Eq" [ ("Substitutivity" , property $ \(x :: a) y (f :: Fun a Integer) -> x == y ==> applyFun f x == applyFun f y ) ] quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Foldable.hs0000644000000000000000000001432107346545000023705 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Foldable ( #if HAVE_UNARY_LAWS foldableLaws #endif ) where import Data.Monoid import Data.Foldable import Test.QuickCheck hiding ((.&.)) import Control.Exception (ErrorCall,try,evaluate) import Control.Monad.Trans.Class (lift) #if HAVE_UNARY_LAWS import Test.QuickCheck.Arbitrary (Arbitrary1(..)) #endif import Test.QuickCheck.Monadic (monadicIO) #if HAVE_UNARY_LAWS import Data.Functor.Classes (Eq1,Show1) #endif import Test.QuickCheck.Property (Property) import qualified Data.Foldable as F import qualified Data.Semigroup as SG import Test.QuickCheck.Classes.Internal #if HAVE_UNARY_LAWS -- | Tests the following 'Foldable' properties: -- -- [/fold/] -- @'fold' ≡ 'foldMap' 'id'@ -- [/foldMap/] -- @'foldMap' f ≡ 'foldr' ('mappend' . f) 'mempty'@ -- [/foldr/] -- @'foldr' f z t ≡ 'appEndo' ('foldMap' ('Endo' . f) t ) z@ -- [/foldr'/] -- @'foldr'' f z0 xs ≡ let f\' k x z = k '$!' f x z in 'foldl' f\' 'id' xs z0@ -- [/foldr1/] -- @'foldr1' f t ≡ let 'Just' (xs,x) = 'unsnoc' ('toList' t) in 'foldr' f x xs@ -- [/foldl/] -- @'foldl' f z t ≡ 'appEndo' ('getDual' ('foldMap' ('Dual' . 'Endo' . 'flip' f) t)) z@ -- [/foldl'/] -- @'foldl'' f z0 xs ≡ let f' x k z = k '$!' f z x in 'foldr' f\' 'id' xs z0@ -- [/foldl1/] -- @'foldl1' f t ≡ let x : xs = 'toList' t in 'foldl' f x xs@ -- [/toList/] -- @'F.toList' ≡ 'foldr' (:) []@ -- [/null/] -- @'null' ≡ 'foldr' ('const' ('const' 'False')) 'True'@ -- [/length/] -- @'length' ≡ 'getSum' . 'foldMap' ('const' ('Sum' 1))@ -- -- Note that this checks to ensure that @foldl\'@ and @foldr\'@ -- are suitably strict. foldableLaws :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Foldable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws foldableLaws = foldableLawsInternal foldableLawsInternal :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Foldable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws foldableLawsInternal p = Laws "Foldable" [ (,) "fold" $ property $ \(Apply (a :: f (VerySmallList Integer))) -> F.fold a == F.foldMap id a , (,) "foldMap" $ property $ \(Apply (a :: f Integer)) (e :: QuadraticEquation) -> let f = VerySmallList . return . runQuadraticEquation e in F.foldMap f a == F.foldr (mappend . f) mempty a , (,) "foldr" $ property $ \(e :: LinearEquationTwo) (z :: Integer) (Apply (t :: f Integer)) -> let f = runLinearEquationTwo e in F.foldr f z t == SG.appEndo (foldMap (SG.Endo . f) t) z , (,) "foldr'" (foldableFoldr' p) , (,) "foldl" $ property $ \(e :: LinearEquationTwo) (z :: Integer) (Apply (t :: f Integer)) -> let f = runLinearEquationTwo e in F.foldl f z t == SG.appEndo (SG.getDual (F.foldMap (SG.Dual . SG.Endo . flip f) t)) z , (,) "foldl'" (foldableFoldl' p) , (,) "foldl1" $ property $ \(e :: LinearEquationTwo) (Apply (t :: f Integer)) -> case compatToList t of [] -> True x : xs -> let f = runLinearEquationTwo e in F.foldl1 f t == F.foldl f x xs , (,) "foldr1" $ property $ \(e :: LinearEquationTwo) (Apply (t :: f Integer)) -> case unsnoc (compatToList t) of Nothing -> True Just (xs,x) -> let f = runLinearEquationTwo e in F.foldr1 f t == F.foldr f x xs , (,) "toList" $ property $ \(Apply (t :: f Integer)) -> eq1 (F.toList t) (F.foldr (:) [] t) #if MIN_VERSION_base(4,8,0) , (,) "null" $ property $ \(Apply (t :: f Integer)) -> null t == F.foldr (const (const False)) True t , (,) "length" $ property $ \(Apply (t :: f Integer)) -> F.length t == SG.getSum (F.foldMap (const (SG.Sum 1)) t) #endif ] unsnoc :: [a] -> Maybe ([a],a) unsnoc [] = Nothing unsnoc [x] = Just ([],x) unsnoc (x:y:xs) = fmap (\(bs,b) -> (x:bs,b)) (unsnoc (y : xs)) compatToList :: Foldable f => f a -> [a] compatToList = foldMap (\x -> [x]) foldableFoldl' :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Foldable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property foldableFoldl' _ = property $ \(_ :: ChooseSecond) (_ :: LastNothing) (Apply (xs :: f (Bottom Integer))) -> monadicIO $ do let f :: Integer -> Bottom Integer -> Integer f a b = case b of BottomUndefined -> error "foldableFoldl' example" BottomValue v -> if even v then a else v z0 = 0 r1 <- lift $ do let f' x k z = k $! f z x e <- try (evaluate (F.foldr f' id xs z0)) case e of Left (_ :: ErrorCall) -> return Nothing Right i -> return (Just i) r2 <- lift $ do e <- try (evaluate (F.foldl' f z0 xs)) case e of Left (_ :: ErrorCall) -> return Nothing Right i -> return (Just i) return (r1 == r2) foldableFoldr' :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Foldable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property foldableFoldr' _ = property $ \(_ :: ChooseFirst) (_ :: LastNothing) (Apply (xs :: f (Bottom Integer))) -> monadicIO $ do let f :: Bottom Integer -> Integer -> Integer f a b = case a of BottomUndefined -> error "foldableFoldl' example" BottomValue v -> if even v then v else b z0 = 0 r1 <- lift $ do let f' k x z = k $! f x z e <- try (evaluate (F.foldl f' id xs z0)) case e of Left (_ :: ErrorCall) -> return Nothing Right i -> return (Just i) r2 <- lift $ do e <- try (evaluate (F.foldr' f z0 xs)) case e of Left (_ :: ErrorCall) -> return Nothing Right i -> return (Just i) return (r1 == r2) #endif quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Functor.hs0000644000000000000000000000437707346545000023627 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Functor ( #if HAVE_UNARY_LAWS functorLaws #endif ) where import Data.Functor import Test.QuickCheck hiding ((.&.)) #if HAVE_UNARY_LAWS import Test.QuickCheck.Arbitrary (Arbitrary1(..)) import Data.Functor.Classes (Eq1,Show1) #endif import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal #if HAVE_UNARY_LAWS -- | Tests the following functor properties: -- -- [/Identity/] -- @'fmap' 'id' ≡ 'id'@ -- [/Composition/] -- @'fmap' (f '.' g) ≡ 'fmap' f '.' 'fmap' g@ -- [/Const/] -- @('<$') ≡ 'fmap' 'const'@ functorLaws :: #if HAVE_QUANTIFIED_CONSTRAINTS (Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Functor f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws functorLaws p = Laws "Functor" [ ("Identity", functorIdentity p) , ("Composition", functorComposition p) , ("Const", functorConst p) ] functorIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Functor f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property functorIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (fmap id a) a functorComposition :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Functor f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property functorComposition _ = property $ \(Apply (a :: f Integer)) -> eq1 (fmap func2 (fmap func1 a)) (fmap (func2 . func1) a) functorConst :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Functor f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property functorConst _ = property $ \(Apply (a :: f Integer)) -> eq1 (fmap (const 'X') a) ('X' <$ a) #endif quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Generic.hs0000644000000000000000000000702007346545000023547 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Generic ( #if MIN_VERSION_base(4,5,0) genericLaws #if HAVE_UNARY_LAWS , generic1Laws #endif #endif ) where #if MIN_VERSION_base(4,5,0) import Control.Applicative import Data.Semigroup as SG import Data.Monoid as MD import GHC.Generics #if HAVE_UNARY_LAWS import Data.Functor.Classes #endif import Data.Proxy (Proxy(Proxy)) import Test.QuickCheck import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal (Laws(..), Apply(..)) -- | Tests the following properties: -- -- [/From-To Inverse/] -- @'from' '.' 'to' ≡ 'id'@ -- [/To-From Inverse/] -- @'to' '.' 'from' ≡ 'id'@ -- -- /Note:/ This property test is only available when -- using @base-4.5@ or newer. -- -- /Note:/ 'from' and 'to' don't actually care about -- the type variable @x@ in @'Rep' a x@, so here we instantiate -- it to @'()'@ by default. If you would like to instantiate @x@ -- as something else, please file a bug report. genericLaws :: (Generic a, Eq a, Arbitrary a, Show a, Show (Rep a ()), Arbitrary (Rep a ()), Eq (Rep a ())) => Proxy a -> Laws genericLaws pa = Laws "Generic" [ ("From-To inverse", fromToInverse pa (Proxy :: Proxy ())) , ("To-From inverse", toFromInverse pa) ] toFromInverse :: forall proxy a. (Generic a, Eq a, Arbitrary a, Show a) => proxy a -> Property toFromInverse _ = property $ \(v :: a) -> (to . from $ v) == v fromToInverse :: forall proxy a x. (Generic a, Show (Rep a x), Arbitrary (Rep a x), Eq (Rep a x)) => proxy a -> proxy x -> Property fromToInverse _ _ = property $ \(r :: Rep a x) -> r == (from (to r :: a)) #if HAVE_UNARY_LAWS -- | Tests the following properties: -- -- [/From-To Inverse/] -- @'from1' '.' 'to1' ≡ 'id'@ -- [/To-From Inverse/] -- @'to1' '.' 'from1' ≡ 'id'@ -- -- /Note:/ This property test is only available when -- using @base-4.9@ or newer. generic1Laws :: (Generic1 f, Eq1 f, Arbitrary1 f, Show1 f, Eq1 (Rep1 f), Show1 (Rep1 f), Arbitrary1 (Rep1 f)) => proxy f -> Laws generic1Laws p = Laws "Generic1" [ ("From1-To1 inverse", fromToInverse1 p) , ("To1-From1 inverse", toFromInverse1 p) ] -- hack for quantified constraints: under base >= 4.12, -- our usual 'Apply' wrapper has Eq, Show, and Arbitrary -- instances that are incompatible. newtype GApply f a = GApply { getGApply :: f a } instance (Applicative f, Semigroup a) => Semigroup (GApply f a) where GApply x <> GApply y = GApply $ liftA2 (SG.<>) x y instance (Applicative f, Monoid a) => Monoid (GApply f a) where mempty = GApply $ pure mempty mappend (GApply x) (GApply y) = GApply $ liftA2 (MD.<>) x y instance (Eq1 f, Eq a) => Eq (GApply f a) where GApply a == GApply b = eq1 a b instance (Show1 f, Show a) => Show (GApply f a) where showsPrec p = showsPrec1 p . getGApply instance (Arbitrary1 f, Arbitrary a) => Arbitrary (GApply f a) where arbitrary = fmap GApply arbitrary1 shrink = map GApply . shrink1 . getGApply toFromInverse1 :: forall proxy f. (Generic1 f, Eq1 f, Arbitrary1 f, Show1 f) => proxy f -> Property toFromInverse1 _ = property $ \(GApply (v :: f Integer)) -> eq1 v (to1 . from1 $ v) fromToInverse1 :: forall proxy f. (Generic1 f, Eq1 (Rep1 f), Arbitrary1 (Rep1 f), Show1 (Rep1 f)) => proxy f -> Property fromToInverse1 _ = property $ \(GApply (r :: Rep1 f Integer)) -> eq1 r (from1 ((to1 $ r) :: f Integer)) #endif #endif quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Integral.hs0000644000000000000000000000500007346545000023734 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Integral ( integralLaws ) where import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal (Laws(..), myForAllShrink) -- | Tests the following properties: -- -- [/Quotient Remainder/] -- @(quot x y) * y + (rem x y) ≡ x@ -- [/Division Modulus/] -- @(div x y) * y + (mod x y) ≡ x@ -- [/Integer Roundtrip/] -- @fromInteger (toInteger x) ≡ x@ -- [/QuotRem is (Quot, Rem)/] -- @quotRem x y ≡ (quot x y, rem x y)@ -- [/DivMod is (Div, Mod)/] -- @divMod x y ≡ (div x y, mod x y)@ integralLaws :: (Integral a, Arbitrary a, Show a) => Proxy a -> Laws integralLaws p = Laws "Integral" [ ("Quotient Remainder", integralQuotientRemainder p) , ("Division Modulus", integralDivisionModulus p) , ("Integer Roundtrip", integralIntegerRoundtrip p) , ("QuotRem is (Quot, Rem)", integralQuotRem p) , ("DivMod is (Div, Mod)", integralDivMod p) ] integralQuotientRemainder :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property integralQuotientRemainder _ = myForAllShrink False (\(_,y) -> y /= 0) (\(x :: a, y) -> ["x = " ++ show x, "y = " ++ show y]) "(quot x y) * y + (rem x y)" (\(x,y) -> (quot x y) * y + (rem x y)) "x" (\(x,_) -> x) integralDivisionModulus :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property integralDivisionModulus _ = myForAllShrink False (\(_,y) -> y /= 0) (\(x :: a, y) -> ["x = " ++ show x, "y = " ++ show y]) "(div x y) * y + (mod x y)" (\(x,y) -> (div x y) * y + (mod x y)) "x" (\(x,_) -> x) integralIntegerRoundtrip :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property integralIntegerRoundtrip _ = myForAllShrink False (const True) (\(x :: a) -> ["x = " ++ show x]) "fromInteger (toInteger x)" (\x -> fromInteger (toInteger x)) "x" (\x -> x) integralQuotRem :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property integralQuotRem _ = myForAllShrink False (\(_,y) -> y /= 0) (\(x :: a, y) -> ["x = " ++ show x, "y = " ++ show y]) "quotRem x y" (\(x,y) -> quotRem x y) "(quot x y, rem x y)" (\(x,y) -> (quot x y, rem x y)) integralDivMod :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property integralDivMod _ = myForAllShrink False (\(_,y) -> y /= 0) (\(x :: a, y) -> ["x = " ++ show x, "y = " ++ show y]) "divMod x y" (\(x,y) -> divMod x y) "(div x y, mod x y)" (\(x,y) -> (div x y, mod x y)) quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Internal.hs0000644000000000000000000004310307346545000023751 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_HADDOCK hide #-} -- | This module is exported, but it is not part of the stable -- public API and is not subject to PVP. It is used by other -- modules in @quickcheck-classes-base@ and by modules in the -- @quickcheck-classes@ library as well. Functions and types -- in this module are either auxiliary functions that are reused -- by many different laws tests, or they are compatibility shims -- that make it possible to build with older versions GHC and -- transformers. module Test.QuickCheck.Classes.Internal ( -- * Common Types and Functions Laws(..) , foldMapA , myForAllShrink -- Modifiers , SmallList(..) , VerySmallList(..) , ShowReadPrecedence(..) -- only used for higher-kinded types , Apply(..) #if HAVE_BINARY_LAWS , Apply2(..) #endif , Triple(..) , ChooseFirst(..) , ChooseSecond(..) , LastNothing(..) , Bottom(..) , LinearEquation(..) #if HAVE_UNARY_LAWS , LinearEquationM(..) #endif , QuadraticEquation(..) , LinearEquationTwo(..) #if HAVE_UNARY_LAWS , nestedEq1 , propNestedEq1 , toSpecialApplicative #endif , flipPair #if HAVE_UNARY_LAWS , apTrans #endif , func1 , func2 , func3 #if HAVE_UNARY_LAWS , func4 #endif , func5 , func6 , reverseTriple , runLinearEquation #if HAVE_UNARY_LAWS , runLinearEquationM #endif , runQuadraticEquation , runLinearEquationTwo -- * Compatibility Shims , isTrue# #if HAVE_UNARY_LAWS , eq1 #endif #if HAVE_BINARY_LAWS , eq2 , eq1_2 #endif , readMaybe ) where import Control.Applicative import Control.Monad import Data.Foldable import Data.Traversable import Data.Monoid #if defined(HAVE_UNARY_LAWS) import Data.Functor.Classes (Eq1(..),Show1(..),showsPrec1) import Data.Functor.Compose #endif #if defined(HAVE_BINARY_LAWS) import Data.Functor.Classes (Eq2(..),Show2(..),showsPrec2) #endif import Data.Semigroup (Semigroup) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property(..)) import qualified Control.Monad.Trans.Writer.Lazy as WL import qualified Data.List as L import qualified Data.Monoid as MND import qualified Data.Semigroup as SG import qualified Data.Set as S #if MIN_VERSION_base(4,6,0) import Text.Read (readMaybe) #else import Text.ParserCombinators.ReadP (skipSpaces) import Text.ParserCombinators.ReadPrec (lift, minPrec, readPrec_to_S) import Text.Read (readPrec) #endif #if MIN_VERSION_base(4,7,0) import GHC.Exts (isTrue#) #endif #if defined(HAVE_UNARY_LAWS) || defined(HAVE_BINARY_LAWS) import qualified Data.Functor.Classes as C #endif -- | A set of laws associated with a typeclass. -- -- /Note/: Most of the top-level functions provided -- by this library have the shape -- `forall a. (Ctx a) => Proxy a -> Laws`. You can just -- as easily provide your own `Laws` in libraries/test suites -- using regular QuickCheck machinery. data Laws = Laws { lawsTypeclass :: String -- ^ Name of the typeclass whose laws are tested , lawsProperties :: [(String,Property)] -- ^ Pairs of law name and property } myForAllShrink :: (Arbitrary a, Show b, Eq b) => Bool -- Should we show the RHS. It's better not to show it -- if the RHS is equal to the input. -> (a -> Bool) -- is the value a valid input -> (a -> [String]) -- show the 'a' values -> String -- show the LHS -> (a -> b) -- the function that makes the LHS -> String -- show the RHS -> (a -> b) -- the function that makes the RHS -> Property myForAllShrink displayRhs isValid showInputs name1 calc1 name2 calc2 = #if MIN_VERSION_QuickCheck(2,9,0) again $ #endif MkProperty $ arbitrary >>= \x -> unProperty $ shrinking shrink x $ \x' -> let b1 = calc1 x' b2 = calc2 x' sb1 = show b1 sb2 = show b2 description = " Description: " ++ name1 ++ " = " ++ name2 err = description ++ "\n" ++ unlines (map (" " ++) (showInputs x')) ++ " " ++ name1 ++ " = " ++ sb1 ++ (if displayRhs then "\n " ++ name2 ++ " = " ++ sb2 else "") in isValid x' ==> counterexample err (b1 == b2) #if HAVE_UNARY_LAWS -- the Functor constraint is needed for transformers-0.4 #if HAVE_QUANTIFIED_CONSTRAINTS nestedEq1 :: (forall x. Eq x => Eq (f x), forall x. Eq x => Eq (g x), Eq a) => f (g a) -> f (g a) -> Bool nestedEq1 = (==) #else nestedEq1 :: (Eq1 f, Eq1 g, Eq a, Functor f) => f (g a) -> f (g a) -> Bool nestedEq1 x y = C.eq1 (Compose x) (Compose y) #endif #if HAVE_QUANTIFIED_CONSTRAINTS propNestedEq1 :: (forall x. Eq x => Eq (f x), forall x. Eq x => Eq (g x), Eq a, forall x. Show x => Show (f x), forall x. Show x => Show (g x), Show a) => f (g a) -> f (g a) -> Property propNestedEq1 = (===) #else propNestedEq1 :: (Eq1 f, Eq1 g, Eq a, Show1 f, Show1 g, Show a, Functor f) => f (g a) -> f (g a) -> Property propNestedEq1 x y = Compose x === Compose y #endif toSpecialApplicative :: Compose Triple ((,) (S.Set Integer)) Integer -> Compose Triple (WL.Writer (S.Set Integer)) Integer toSpecialApplicative (Compose (Triple a b c)) = Compose (Triple (WL.writer (flipPair a)) (WL.writer (flipPair b)) (WL.writer (flipPair c))) #endif flipPair :: (a,b) -> (b,a) flipPair (x,y) = (y,x) #if HAVE_UNARY_LAWS -- Reverse the list and accumulate the writers. We cannot -- use Sum or Product or else it wont actually be a valid -- applicative transformation. apTrans :: Compose Triple (WL.Writer (S.Set Integer)) a -> Compose (WL.Writer (S.Set Integer)) Triple a apTrans (Compose xs) = Compose (sequenceA (reverseTriple xs)) #endif func1 :: Integer -> (Integer,Integer) func1 i = (div (i + 5) 3, i * i - 2 * i + 1) func2 :: (Integer,Integer) -> (Bool,Either Ordering Integer) func2 (a,b) = (odd a, if even a then Left (compare a b) else Right (b + 2)) func3 :: Integer -> SG.Sum Integer func3 i = SG.Sum (3 * i * i - 7 * i + 4) #if HAVE_UNARY_LAWS func4 :: Integer -> Compose Triple (WL.Writer (S.Set Integer)) Integer func4 i = Compose $ Triple (WL.writer (i * i, S.singleton (i * 7 + 5))) (WL.writer (i + 2, S.singleton (i * i + 3))) (WL.writer (i * 7, S.singleton 4)) #endif func5 :: Integer -> Triple Integer func5 i = Triple (i + 2) (i * 3) (i * i) func6 :: Integer -> Triple Integer func6 i = Triple (i * i * i) (4 * i - 7) (i * i * i) data Triple a = Triple a a a deriving (Show,Eq) tripleLiftEq :: (a -> b -> Bool) -> Triple a -> Triple b -> Bool tripleLiftEq p (Triple a1 b1 c1) (Triple a2 b2 c2) = p a1 a2 && p b1 b2 && p c1 c2 #if HAVE_UNARY_LAWS instance Eq1 Triple where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) liftEq = tripleLiftEq #else eq1 = tripleLiftEq (==) #endif #endif tripleLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Triple a -> ShowS tripleLiftShowsPrec elemShowsPrec _ p (Triple a b c) = showParen (p > 10) $ showString "Triple " . elemShowsPrec 11 a . showString " " . elemShowsPrec 11 b . showString " " . elemShowsPrec 11 c #if HAVE_UNARY_LAWS instance Show1 Triple where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) liftShowsPrec = tripleLiftShowsPrec #else showsPrec1 = tripleLiftShowsPrec showsPrec showList #endif #endif #if HAVE_UNARY_LAWS instance Arbitrary1 Triple where liftArbitrary x = Triple <$> x <*> x <*> x instance Arbitrary a => Arbitrary (Triple a) where arbitrary = liftArbitrary arbitrary #else instance Arbitrary a => Arbitrary (Triple a) where arbitrary = Triple <$> arbitrary <*> arbitrary <*> arbitrary #endif instance Functor Triple where fmap f (Triple a b c) = Triple (f a) (f b) (f c) instance Applicative Triple where pure a = Triple a a a Triple f g h <*> Triple a b c = Triple (f a) (g b) (h c) instance Foldable Triple where foldMap f (Triple a b c) = f a MND.<> f b MND.<> f c instance Traversable Triple where traverse f (Triple a b c) = Triple <$> f a <*> f b <*> f c reverseTriple :: Triple a -> Triple a reverseTriple (Triple a b c) = Triple c b a data ChooseSecond = ChooseSecond deriving (Eq) data ChooseFirst = ChooseFirst deriving (Eq) data LastNothing = LastNothing deriving (Eq) data Bottom a = BottomUndefined | BottomValue a deriving (Eq) instance Show ChooseFirst where show ChooseFirst = "\\a b -> if even a then a else b" instance Show ChooseSecond where show ChooseSecond = "\\a b -> if even b then a else b" instance Show LastNothing where show LastNothing = "0" instance Show a => Show (Bottom a) where show x = case x of BottomUndefined -> "undefined" BottomValue a -> show a instance Arbitrary ChooseSecond where arbitrary = pure ChooseSecond instance Arbitrary ChooseFirst where arbitrary = pure ChooseFirst instance Arbitrary LastNothing where arbitrary = pure LastNothing instance Arbitrary a => Arbitrary (Bottom a) where arbitrary = fmap maybeToBottom arbitrary shrink x = map maybeToBottom (shrink (bottomToMaybe x)) bottomToMaybe :: Bottom a -> Maybe a bottomToMaybe BottomUndefined = Nothing bottomToMaybe (BottomValue a) = Just a maybeToBottom :: Maybe a -> Bottom a maybeToBottom Nothing = BottomUndefined maybeToBottom (Just a) = BottomValue a newtype Apply f a = Apply { getApply :: f a } instance (Applicative f, Monoid a) => Semigroup (Apply f a) where Apply x <> Apply y = Apply $ liftA2 mappend x y instance (Applicative f, Monoid a) => Monoid (Apply f a) where mempty = Apply $ pure mempty mappend = (SG.<>) #if HAVE_UNARY_LAWS #if HAVE_QUANTIFIED_CONSTRAINTS deriving instance (forall x. Eq x => Eq (f x), Eq a) => Eq (Apply f a) deriving instance (forall x. Arbitrary x => Arbitrary (f x), Arbitrary a) => Arbitrary (Apply f a) deriving instance (forall x. Show x => Show (f x), Show a) => Show (Apply f a) #else instance (Eq1 f, Eq a) => Eq (Apply f a) where Apply a == Apply b = eq1 a b -- This show instance is intentionally a little bit wrong. -- We don't wrap the result in Apply since the end user -- should not be made aware of the Apply wrapper anyway. instance (Show1 f, Show a) => Show (Apply f a) where showsPrec p = showsPrec1 p . getApply instance (Arbitrary1 f, Arbitrary a) => Arbitrary (Apply f a) where arbitrary = fmap Apply arbitrary1 shrink = map Apply . shrink1 . getApply #endif #endif foldMapA :: (Foldable t, Monoid m, Semigroup m, Applicative f) => (a -> f m) -> t a -> f m foldMapA f = getApply . foldMap (Apply . f) #if HAVE_BINARY_LAWS newtype Apply2 f a b = Apply2 { getApply2 :: f a b } #if HAVE_QUANTIFIED_CONSTRAINTS deriving instance (forall x y. (Eq x, Eq y) => Eq (f x y), Eq a, Eq b) => Eq (Apply2 f a b) deriving instance (forall x y. (Arbitrary x, Arbitrary y) => Arbitrary (f x y), Arbitrary a, Arbitrary b) => Arbitrary (Apply2 f a b) deriving instance (forall x y. (Show x, Show y) => Show (f x y), Show a, Show b) => Show (Apply2 f a b) #else instance (Eq2 f, Eq a, Eq b) => Eq (Apply2 f a b) where Apply2 a == Apply2 b = C.eq2 a b instance (Show2 f, Show a, Show b) => Show (Apply2 f a b) where showsPrec p = showsPrec2 p . getApply2 instance (Arbitrary2 f, Arbitrary a, Arbitrary b) => Arbitrary (Apply2 f a b) where arbitrary = fmap Apply2 arbitrary2 shrink = fmap Apply2 . shrink2 . getApply2 #endif #endif data LinearEquation = LinearEquation { _linearEquationLinear :: Integer , _linearEquationConstant :: Integer } deriving (Eq) instance Show LinearEquation where showsPrec = showLinear showList = showLinearList runLinearEquation :: LinearEquation -> Integer -> Integer runLinearEquation (LinearEquation a b) x = a * x + b showLinear :: Int -> LinearEquation -> ShowS showLinear _ (LinearEquation a b) = shows a . showString " * x + " . shows b showLinearList :: [LinearEquation] -> ShowS showLinearList xs = SG.appEndo $ mconcat $ [SG.Endo (showChar '[')] ++ L.intersperse (SG.Endo (showChar ',')) (map (SG.Endo . showLinear 0) xs) ++ [SG.Endo (showChar ']')] #if HAVE_UNARY_LAWS data LinearEquationM m = LinearEquationM (m LinearEquation) (m LinearEquation) runLinearEquationM :: Monad m => LinearEquationM m -> Integer -> m Integer runLinearEquationM (LinearEquationM e1 e2) i = if odd i then liftM (flip runLinearEquation i) e1 else liftM (flip runLinearEquation i) e2 #if HAVE_QUANTIFIED_CONSTRAINTS deriving instance (forall x. Eq x => Eq (m x)) => Eq (LinearEquationM m) instance (forall a. Show a => Show (m a)) => Show (LinearEquationM m) where show (LinearEquationM a b) = (\f -> f "") $ showString "\\x -> if odd x then " . showsPrec 0 a . showString " else " . showsPrec 0 b instance (forall a. Arbitrary a => Arbitrary (m a)) => Arbitrary (LinearEquationM m) where arbitrary = liftA2 LinearEquationM arbitrary arbitrary shrink (LinearEquationM a b) = L.concat [ map (\x -> LinearEquationM x b) (shrink a) , map (\x -> LinearEquationM a x) (shrink b) ] #else instance Eq1 m => Eq (LinearEquationM m) where LinearEquationM a1 b1 == LinearEquationM a2 b2 = eq1 a1 a2 && eq1 b1 b2 instance Show1 m => Show (LinearEquationM m) where show (LinearEquationM a b) = (\f -> f "") $ showString "\\x -> if odd x then " . showsPrec1 0 a . showString " else " . showsPrec1 0 b instance Arbitrary1 m => Arbitrary (LinearEquationM m) where arbitrary = liftA2 LinearEquationM arbitrary1 arbitrary1 shrink (LinearEquationM a b) = L.concat [ map (\x -> LinearEquationM x b) (shrink1 a) , map (\x -> LinearEquationM a x) (shrink1 b) ] #endif #endif instance Arbitrary LinearEquation where arbitrary = do (a,b) <- arbitrary return (LinearEquation (abs a) (abs b)) shrink (LinearEquation a b) = let xs = shrink (a,b) in map (\(x,y) -> LinearEquation (abs x) (abs y)) xs -- this is a quadratic equation data QuadraticEquation = QuadraticEquation { _quadraticEquationQuadratic :: Integer , _quadraticEquationLinear :: Integer , _quadraticEquationConstant :: Integer } deriving (Eq) -- This show instance is does not actually provide a -- way to create an equation. Instead, it makes it look -- like a lambda. instance Show QuadraticEquation where show (QuadraticEquation a b c) = "\\x -> " ++ show a ++ " * x ^ 2 + " ++ show b ++ " * x + " ++ show c instance Arbitrary QuadraticEquation where arbitrary = do (a,b,c) <- arbitrary return (QuadraticEquation (abs a) (abs b) (abs c)) shrink (QuadraticEquation a b c) = let xs = shrink (a,b,c) in map (\(x,y,z) -> QuadraticEquation (abs x) (abs y) (abs z)) xs runQuadraticEquation :: QuadraticEquation -> Integer -> Integer runQuadraticEquation (QuadraticEquation a b c) x = a * x ^ (2 :: Integer) + b * x + c data LinearEquationTwo = LinearEquationTwo { _linearEquationTwoX :: Integer , _linearEquationTwoY :: Integer } deriving (Eq) -- This show instance does not actually provide a -- way to create a LinearEquationTwo. Instead, it makes it look -- like a lambda that takes two variables. instance Show LinearEquationTwo where show (LinearEquationTwo a b) = "\\x y -> " ++ show a ++ " * x + " ++ show b ++ " * y" instance Arbitrary LinearEquationTwo where arbitrary = do (a,b) <- arbitrary return (LinearEquationTwo (abs a) (abs b)) shrink (LinearEquationTwo a b) = let xs = shrink (a,b) in map (\(x,y) -> LinearEquationTwo (abs x) (abs y)) xs runLinearEquationTwo :: LinearEquationTwo -> Integer -> Integer -> Integer runLinearEquationTwo (LinearEquationTwo a b) x y = a * x + b * y newtype SmallList a = SmallList { getSmallList :: [a] } deriving (Eq,Show) instance Arbitrary a => Arbitrary (SmallList a) where arbitrary = do n <- choose (0,6) xs <- vector n return (SmallList xs) shrink = map SmallList . shrink . getSmallList newtype VerySmallList a = VerySmallList { getVerySmallList :: [a] } deriving (Eq, Show, Semigroup, Monoid) instance Arbitrary a => Arbitrary (VerySmallList a) where arbitrary = do n <- choose (0,2) xs <- vector n return (VerySmallList xs) shrink = map VerySmallList . shrink . getVerySmallList -- Haskell uses the operator precedences 0..9, the special function application -- precedence 10 and the precedence 11 for function arguments. Both show and -- read instances have to accept this range. According to the Haskell Language -- Report, the output of derived show instances in precedence context 11 has to -- be an atomic expression. showReadPrecedences :: [Int] showReadPrecedences = [0..11] newtype ShowReadPrecedence = ShowReadPrecedence Int deriving (Eq,Ord,Show) instance Arbitrary ShowReadPrecedence where arbitrary = ShowReadPrecedence <$> elements showReadPrecedences shrink (ShowReadPrecedence p) = [ ShowReadPrecedence p' | p' <- showReadPrecedences, p' < p ] #if !MIN_VERSION_base(4,6,0) readMaybe :: Read a => String -> Maybe a readMaybe s = case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of [x] -> Just x _ -> Nothing where read' = do x <- readPrec lift skipSpaces return x #endif #if !MIN_VERSION_base(4,7,0) isTrue# :: Bool -> Bool isTrue# b = b #endif #if HAVE_UNARY_LAWS #if HAVE_QUANTIFIED_CONSTRAINTS eq1 :: (forall x. Eq x => Eq (f x), Eq a) => f a -> f a -> Bool eq1 = (==) #else eq1 :: (C.Eq1 f, Eq a) => f a -> f a -> Bool eq1 = C.eq1 #endif #endif #if HAVE_UNARY_LAWS #if HAVE_QUANTIFIED_CONSTRAINTS eq1_2 :: (forall a. Eq a => Eq (f a), forall a b. (Eq a, Eq b) => Eq (g a b), Eq x, Eq y) => f (g x y) -> f (g x y) -> Bool eq1_2 = (==) #else eq1_2 :: (C.Eq1 f, C.Eq2 g, Eq a, Eq b) => f (g a b) -> f (g a b) -> Bool eq1_2 = C.liftEq C.eq2 #endif #endif #if HAVE_BINARY_LAWS #if HAVE_QUANTIFIED_CONSTRAINTS eq2 :: (forall a. (Eq a, Eq b) => Eq (f a b), Eq a, Eq b) => f a b -> f a b -> Bool eq2 = (==) #else eq2 :: (C.Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool eq2 = C.eq2 #endif #endif quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Ix.hs0000644000000000000000000000315607346545000022561 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Ix ( ixLaws ) where import Data.Ix (Ix(..)) import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal (Laws(..)) -- | Tests the various 'Ix' properties: -- -- @'inRange' (l,u) i '==' 'elem' i ('range' (l,u))@ -- -- @'range' (l,u) '!!' 'index' (l,u) i '==' i@, when @'inRange' (l,u) i@ -- -- @'map' ('index' (l,u)) ('range' (l,u)) '==' [0 .. 'rangeSize' (l,u) - 1]@ -- -- @'rangeSize' (l,u) '==' 'length' ('range' (l,u))@ ixLaws :: (Ix a, Arbitrary a, Show a) => Proxy a -> Laws ixLaws p = Laws "Ix" [ ("InRange", ixInRange p) , ("RangeIndex", ixRangeIndex p) , ("MapIndexRange", ixMapIndexRange p) , ("RangeSize", ixRangeSize p) ] ixInRange :: forall a. (Show a, Ix a, Arbitrary a) => Proxy a -> Property ixInRange _ = property $ \(l :: a) (u :: a) (i :: a) -> (l <= u) ==> do inRange (l,u) i == elem i (range (l,u)) ixRangeIndex :: forall a. (Show a, Ix a, Arbitrary a) => Proxy a -> Property ixRangeIndex _ = property $ \(l :: a) (u :: a) (i :: a) -> ((l <= u) && (i >= l && i <= u)) ==> do range (l,u) !! index (l,u) i == i ixMapIndexRange :: forall a. (Show a, Ix a, Arbitrary a) => Proxy a -> Property ixMapIndexRange _ = property $ \(l :: a) (u :: a) -> (l <= u) ==> do map (index (l,u)) (range (l,u)) == [0 .. rangeSize (l,u) - 1] ixRangeSize :: forall a. (Show a, Ix a, Arbitrary a) => Proxy a -> Property ixRangeSize _ = property $ \(l :: a) (u :: a) -> (l <= u) ==> do rangeSize (l,u) == length (range (l,u)) quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Monad.hs0000644000000000000000000000663407346545000023243 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Monad ( #if HAVE_UNARY_LAWS monadLaws #endif ) where import Control.Applicative import Test.QuickCheck hiding ((.&.)) import Control.Monad (ap) #if HAVE_UNARY_LAWS import Test.QuickCheck.Arbitrary (Arbitrary1(..)) import Data.Functor.Classes (Eq1,Show1) #endif import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal #if HAVE_UNARY_LAWS -- | Tests the following monadic properties: -- -- [/Left Identity/] -- @'return' a '>>=' k ≡ k a@ -- [/Right Identity/] -- @m '>>=' 'return' ≡ m@ -- [/Associativity/] -- @m '>>=' (\\x -> k x '>>=' h) ≡ (m '>>=' k) '>>=' h@ -- [/Return/] -- @'pure' ≡ 'return'@ -- [/Ap/] -- @('<*>') ≡ 'ap'@ monadLaws :: #if HAVE_QUANTIFIED_CONSTRAINTS (Monad f, Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws monadLaws p = Laws "Monad" [ ("Left Identity", monadLeftIdentity p) , ("Right Identity", monadRightIdentity p) , ("Associativity", monadAssociativity p) , ("Return", monadReturn p) , ("Ap", monadAp p) ] monadLeftIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Monad f, Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Monad f, Functor f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadLeftIdentity _ = property $ \(k' :: LinearEquationM f) (a :: Integer) -> let k = runLinearEquationM k' in eq1 (return a >>= k) (k a) monadRightIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Monad f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Monad f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadRightIdentity _ = property $ \(Apply (m :: f Integer)) -> eq1 (m >>= return) m monadAssociativity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Monad f, Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Monad f, Functor f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadAssociativity _ = property $ \(Apply (m :: f Integer)) (k' :: LinearEquationM f) (h' :: LinearEquationM f) -> let k = runLinearEquationM k' h = runLinearEquationM h' in eq1 (m >>= (\x -> k x >>= h)) ((m >>= k) >>= h) monadReturn :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Monad f, Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadReturn _ = property $ \(x :: Integer) -> eq1 (return x) (pure x :: f Integer) monadAp :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Monad f, Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadAp _ = property $ \(Apply (f' :: f QuadraticEquation)) (Apply (x :: f Integer)) -> let f = fmap runQuadraticEquation f' in eq1 (ap f x) (f <*> x) #endif quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/MonadFail.hs0000644000000000000000000000275307346545000024035 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.MonadFail ( #if HAVE_UNARY_LAWS monadFailLaws #endif ) where #if HAVE_UNARY_LAWS import Control.Applicative import Test.QuickCheck hiding ((.&.)) import Control.Monad (ap) import Test.QuickCheck.Arbitrary (Arbitrary1(..)) import Data.Functor.Classes (Eq1,Show1) import Prelude hiding (fail) import Control.Monad.Fail (MonadFail(..)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal -- | Tests the following 'MonadFail' properties: -- -- [/Left Zero/] -- @'fail' s '>>=' f ≡ 'fail' s@ monadFailLaws :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (MonadFail f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadFail f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws monadFailLaws p = Laws "Monad" [ ("Left Zero", monadFailLeftZero p) ] monadFailLeftZero :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (MonadFail f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadFail f, Functor f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadFailLeftZero _ = property $ \(k' :: LinearEquationM f) (s :: String) -> let k = runLinearEquationM k' in eq1 (fail s >>= k) (fail s) #endif quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/MonadPlus.hs0000644000000000000000000000643607346545000024107 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.MonadPlus ( #if HAVE_UNARY_LAWS monadPlusLaws #endif ) where import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal import Control.Monad (MonadPlus(mzero,mplus)) #if HAVE_UNARY_LAWS import Test.QuickCheck.Arbitrary (Arbitrary1(..)) import Data.Functor.Classes (Eq1,Show1) #endif #if HAVE_UNARY_LAWS -- | Tests the following monad plus properties: -- -- [/Left Identity/] -- @'mplus' 'mzero' x ≡ x@ -- [/Right Identity/] -- @'mplus' x 'mzero' ≡ x@ -- [/Associativity/] -- @'mplus' a ('mplus' b c) ≡ 'mplus' ('mplus' a b) c)@ -- [/Left Zero/] -- @'mzero' '>>=' f ≡ 'mzero'@ -- [/Right Zero/] -- @m '>>' 'mzero' ≡ 'mzero'@ monadPlusLaws :: #if HAVE_QUANTIFIED_CONSTRAINTS (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws monadPlusLaws p = Laws "MonadPlus" [ ("Left Identity", monadPlusLeftIdentity p) , ("Right Identity", monadPlusRightIdentity p) , ("Associativity", monadPlusAssociativity p) , ("Left Zero", monadPlusLeftZero p) , ("Right Zero", monadPlusRightZero p) ] monadPlusLeftIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadPlusLeftIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (mplus mzero a) a monadPlusRightIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadPlusRightIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (mplus a mzero) a monadPlusAssociativity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadPlusAssociativity _ = property $ \(Apply (a :: f Integer)) (Apply (b :: f Integer)) (Apply (c :: f Integer)) -> eq1 (mplus a (mplus b c)) (mplus (mplus a b) c) monadPlusLeftZero :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadPlusLeftZero _ = property $ \(k' :: LinearEquationM f) -> eq1 (mzero >>= runLinearEquationM k') mzero monadPlusRightZero :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadPlusRightZero _ = property $ \(Apply (a :: f Integer)) -> eq1 (a >> (mzero :: f Integer)) mzero #endif quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/MonadZip.hs0000644000000000000000000000341607346545000023721 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.MonadZip ( #if HAVE_UNARY_LAWS monadZipLaws #endif ) where import Control.Applicative import Control.Arrow (Arrow(..)) import Control.Monad.Zip (MonadZip(mzip)) import Test.QuickCheck hiding ((.&.)) import Control.Monad (liftM) #if HAVE_UNARY_LAWS import Test.QuickCheck.Arbitrary (Arbitrary1(..)) import Data.Functor.Classes (Eq1,Show1) #endif import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal #if HAVE_UNARY_LAWS -- | Tests the following monadic zipping properties: -- -- [/Naturality/] -- @'liftM' (f '***' g) ('mzip' ma mb) = 'mzip' ('liftM' f ma) ('liftM' g mb)@ -- -- In the laws above, the infix function @'***'@ refers to a typeclass -- method of 'Arrow'. monadZipLaws :: #if HAVE_QUANTIFIED_CONSTRAINTS (MonadZip f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadZip f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws monadZipLaws p = Laws "MonadZip" [ ("Naturality", monadZipNaturality p) ] monadZipNaturality :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (MonadZip f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadZip f, Functor f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadZipNaturality _ = property $ \(f' :: LinearEquation) (g' :: LinearEquation) (Apply (ma :: f Integer)) (Apply (mb :: f Integer)) -> let f = runLinearEquation f' g = runLinearEquation g' in eq1 (liftM (f *** g) (mzip ma mb)) (mzip (liftM f ma) (liftM g mb)) #endif quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Monoid.hs0000644000000000000000000000644507346545000023432 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Monoid ( monoidLaws , commutativeMonoidLaws , semigroupMonoidLaws ) where import Data.Semigroup import Data.Monoid import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal (Laws(..), SmallList(..), myForAllShrink) -- | Tests the following properties: -- -- [/Associative/] -- @mappend a (mappend b c) ≡ mappend (mappend a b) c@ -- [/Left Identity/] -- @mappend mempty a ≡ a@ -- [/Right Identity/] -- @mappend a mempty ≡ a@ -- [/Concatenation/] -- @mconcat as ≡ foldr mappend mempty as@ monoidLaws :: (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws monoidLaws p = Laws "Monoid" [ ("Associative", monoidAssociative p) , ("Left Identity", monoidLeftIdentity p) , ("Right Identity", monoidRightIdentity p) , ("Concatenation", monoidConcatenation p) ] -- | Tests the following properties: -- -- [/Commutative/] -- @mappend a b ≡ mappend b a@ -- -- Note that this does not test associativity or identity. Make sure to use -- 'monoidLaws' in addition to this set of laws. commutativeMonoidLaws :: (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws commutativeMonoidLaws p = Laws "Commutative Monoid" [ ("Commutative", monoidCommutative p) ] semigroupMonoidLaws :: forall a. (Semigroup a, Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws semigroupMonoidLaws p = Laws "Semigroup/Monoid" [ ("mappend == <>", semigroupMonoid p) ] semigroupMonoid :: forall a. (Semigroup a, Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semigroupMonoid _ = myForAllShrink True (const True) (\(a :: a,b) -> ["a = " ++ show a, "b = " ++ show b]) "mappend a b" (\(a,b) -> mappend a b) "a <> b" (\(a,b) -> a Data.Semigroup.<> b) monoidConcatenation :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property monoidConcatenation _ = myForAllShrink True (const True) (\(SmallList (as :: [a])) -> ["as = " ++ show as]) "mconcat as" (\(SmallList as) -> mconcat as) "foldr mappend mempty as" (\(SmallList as) -> foldr mappend mempty as) monoidAssociative :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property monoidAssociative _ = myForAllShrink True (const True) (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) "mappend a (mappend b c)" (\(a,b,c) -> mappend a (mappend b c)) "mappend (mappend a b) c" (\(a,b,c) -> mappend (mappend a b) c) monoidLeftIdentity :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property monoidLeftIdentity _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "mappend mempty a" (\a -> mappend mempty a) "a" (\a -> a) monoidRightIdentity :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property monoidRightIdentity _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "mappend a mempty" (\a -> mappend a mempty) "a" (\a -> a) monoidCommutative :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property monoidCommutative _ = myForAllShrink True (const True) (\(a :: a,b) -> ["a = " ++ show a, "b = " ++ show b]) "mappend a b" (\(a,b) -> mappend a b) "mappend b a" (\(a,b) -> mappend b a) quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Num.hs0000644000000000000000000001401207346545000022731 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Num ( numLaws ) where import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal (Laws(..), myForAllShrink) -- | Tests the following properties: -- -- [/Additive Commutativity/] -- @a + b ≡ b + a@ -- [/Additive Left Identity/] -- @0 + a ≡ a@ -- [/Additive Right Identity/] -- @a + 0 ≡ a@ -- [/Multiplicative Associativity/] -- @a * (b * c) ≡ (a * b) * c@ -- [/Multiplicative Left Identity/] -- @1 * a ≡ a@ -- [/Multiplicative Right Identity/] -- @a * 1 ≡ a@ -- [/Multiplication Left Distributes Over Addition/] -- @a * (b + c) ≡ (a * b) + (a * c)@ -- [/Multiplication Right Distributes Over Addition/] -- @(a + b) * c ≡ (a * c) + (b * c)@ -- [/Multiplicative Left Annihilation/] -- @0 * a ≡ 0@ -- [/Multiplicative Right Annihilation/] -- @a * 0 ≡ 0@ -- [/Additive Inverse/] -- @'negate' a '+' a ≡ 0@ -- [/Subtraction/] -- @a '+' 'negate' b ≡ a '-' b@ -- [/Abs Is Idempotent/] -- @'abs' ('abs' a) ≡ 'abs' a -- [/Signum Is Idempotent/] -- @'signum' ('signum' a) ≡ 'signum' a -- [/Product Of Abs And Signum Is Id/] -- @'abs' a * 'signum' a ≡ a@ numLaws :: (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws numLaws p = Laws "Num" [ ("Additive Commutativity", numCommutativePlus p) , ("Additive Left Identity", numLeftIdentityPlus p) , ("Additive Right Identity", numRightIdentityPlus p) , ("Multiplicative Associativity", numAssociativeTimes p) , ("Multiplicative Left Identity", numLeftIdentityTimes p) , ("Multiplicative Right Identity", numRightIdentityTimes p) , ("Multiplication Left Distributes Over Addition", numLeftMultiplicationDistributes p) , ("Multiplication Right Distributes Over Addition", numRightMultiplicationDistributes p) , ("Multiplicative Left Annihilation", numLeftAnnihilation p) , ("Multiplicative Right Annihilation", numRightAnnihilation p) , ("Additive Inverse", numAdditiveInverse p) , ("Subtraction", numSubtraction p) , ("Abs Is Idempotent", absIdempotence p) , ("Signum Is Idempotent", signumIdempotence p) , ("Product Of Abs And Signum Is Id", absSignumId p) ] numLeftMultiplicationDistributes :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property numLeftMultiplicationDistributes _ = myForAllShrink True (const True) (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) "a * (b + c)" (\(a,b,c) -> a * (b + c)) "(a * b) + (a * c)" (\(a,b,c) -> (a * b) + (a * c)) numRightMultiplicationDistributes :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property numRightMultiplicationDistributes _ = myForAllShrink True (const True) (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) "(a + b) * c" (\(a,b,c) -> (a + b) * c) "(a * c) + (b * c)" (\(a,b,c) -> (a * c) + (b * c)) numLeftIdentityPlus :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property numLeftIdentityPlus _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "0 + a" (\a -> 0 + a) "a" (\a -> a) numRightIdentityPlus :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property numRightIdentityPlus _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "a + 0" (\a -> a + 0) "a" (\a -> a) numRightIdentityTimes :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property numRightIdentityTimes _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "a * 1" (\a -> a * 1) "a" (\a -> a) numLeftIdentityTimes :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property numLeftIdentityTimes _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "1 * a" (\a -> 1 * a) "a" (\a -> a) numLeftAnnihilation :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property numLeftAnnihilation _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "0 * a" (\a -> 0 * a) "0" (\_ -> 0) numRightAnnihilation :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property numRightAnnihilation _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "a * 0" (\a -> a * 0) "0" (\_ -> 0) numCommutativePlus :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property numCommutativePlus _ = myForAllShrink True (const True) (\(a :: a,b) -> ["a = " ++ show a, "b = " ++ show b]) "a + b" (\(a,b) -> a + b) "b + a" (\(a,b) -> b + a) numAssociativeTimes :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property numAssociativeTimes _ = myForAllShrink True (const True) (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) "a * (b * c)" (\(a,b,c) -> a * (b * c)) "(a * b) * c" (\(a,b,c) -> (a * b) * c) numAdditiveInverse :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property numAdditiveInverse _ = myForAllShrink True (const True) (\(a :: a) -> ["a = " ++ show a]) "negate a + a" (\a -> (-a) + a) "0" (const 0) numSubtraction :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property numSubtraction _ = myForAllShrink True (const True) (\(a :: a, b :: a) -> ["a = " ++ show a, "b = " ++ show b]) "a + negate b" (\(a,b) -> a + negate b) "a - b" (\(a,b) -> a - b) absIdempotence :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property absIdempotence _ = myForAllShrink True (const True) (\(a :: a) -> ["a = " ++ show a]) "abs (abs a)" (abs . abs) "abs a" abs signumIdempotence :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property signumIdempotence _ = myForAllShrink True (const True) (\(a :: a) -> ["a = " ++ show a]) "signum (signum a)" (signum . signum) "signum a" signum absSignumId :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> Property absSignumId _ = myForAllShrink True (const True) (\(a :: a) -> ["a = " ++ show a]) "abs a * signum a" (\a -> abs a * signum a) "a" id quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Ord.hs0000644000000000000000000000273307346545000022725 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Ord ( ordLaws ) where import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal (Laws(..)) -- | Tests the following properties: -- -- [/Antisymmetry/] -- @a ≤ b ∧ b ≤ a ⇒ a = b@ -- [/Transitivity/] -- @a ≤ b ∧ b ≤ c ⇒ a ≤ c@ -- [/Totality/] -- @a ≤ b ∨ a > b@ ordLaws :: (Ord a, Arbitrary a, Show a) => Proxy a -> Laws ordLaws p = Laws "Ord" [ ("Antisymmetry", ordAntisymmetric p) , ("Transitivity", ordTransitive p) , ("Totality", ordTotal p) ] ordAntisymmetric :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property ordAntisymmetric _ = property $ \(a :: a) b -> ((a <= b) && (b <= a)) == (a == b) ordTotal :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property ordTotal _ = property $ \(a :: a) b -> ((a <= b) || (b <= a)) == True -- Technically, this tests something a little stronger than it is supposed to. -- But that should be alright since this additional strength is implied by -- the rest of the Ord laws. ordTransitive :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property ordTransitive _ = property $ \(a :: a) b c -> case (compare a b, compare b c) of (LT,LT) -> a < c (LT,EQ) -> a < c (LT,GT) -> True (EQ,LT) -> a < c (EQ,EQ) -> a == c (EQ,GT) -> a > c (GT,LT) -> True (GT,EQ) -> a > c (GT,GT) -> a > c quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Semigroup.hs0000644000000000000000000001164207346545000024152 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Semigroup ( -- * Laws semigroupLaws , commutativeSemigroupLaws , exponentialSemigroupLaws , idempotentSemigroupLaws , rectangularBandSemigroupLaws ) where import Prelude hiding (foldr1) import Data.Semigroup (Semigroup(..)) import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal (Laws(..), SmallList(..), myForAllShrink) import Data.Foldable (foldr1,toList) import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List as L -- | Tests the following properties: -- -- [/Associative/] -- @a '<>' (b '<>' c) ≡ (a '<>' b) '<>' c@ -- [/Concatenation/] -- @'sconcat' as ≡ 'foldr1' ('<>') as@ -- [/Times/] -- @'stimes' n a ≡ 'foldr1' ('<>') ('replicate' n a)@ semigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws semigroupLaws p = Laws "Semigroup" [ ("Associative", semigroupAssociative p) , ("Concatenation", semigroupConcatenation p) , ("Times", semigroupTimes p) ] -- | Tests the following properties: -- -- [/Commutative/] -- @a '<>' b ≡ b '<>' a@ -- -- Note that this does not test associativity. Make sure to use -- 'semigroupLaws' in addition to this set of laws. commutativeSemigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws commutativeSemigroupLaws p = Laws "Commutative Semigroup" [ ("Commutative", semigroupCommutative p) ] -- | Tests the following properties: -- -- [/Idempotent/] -- @a '<>' a ≡ a@ -- -- Note that this does not test associativity. Make sure to use -- 'semigroupLaws' in addition to this set of laws. In literature, -- this class of semigroup is known as a band. idempotentSemigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws idempotentSemigroupLaws p = Laws "Idempotent Semigroup" [ ("Idempotent", semigroupIdempotent p) ] -- | Tests the following properties: -- -- [/Rectangular Band/] -- @a '<>' b '<>' a ≡ a@ -- -- Note that this does not test associativity. Make sure to use -- 'semigroupLaws' in addition to this set of laws. rectangularBandSemigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws rectangularBandSemigroupLaws p = Laws "Rectangular Band Semigroup" [ ("Rectangular Band", semigroupRectangularBand p) ] -- | Tests the following properties: -- -- [/Exponential/] -- @'stimes' n (a '<>' b) ≡ 'stimes' n a '<>' 'stimes' n b@ -- -- Note that this does not test associativity. Make sure to use -- 'semigroupLaws' in addition to this set of laws. exponentialSemigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws exponentialSemigroupLaws p = Laws "Exponential Semigroup" [ ("Exponential", semigroupExponential p) ] semigroupAssociative :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semigroupAssociative _ = myForAllShrink True (const True) (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) "a <> (b <> c)" (\(a,b,c) -> a <> (b <> c)) "(a <> b) <> c" (\(a,b,c) -> (a <> b) <> c) semigroupCommutative :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semigroupCommutative _ = myForAllShrink True (const True) (\(a :: a,b) -> ["a = " ++ show a, "b = " ++ show b]) "a <> b" (\(a,b) -> a <> b) "b <> a" (\(a,b) -> b <> a) semigroupConcatenation :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semigroupConcatenation _ = myForAllShrink True (const True) (\(a, SmallList (as :: [a])) -> ["as = " ++ show (a :| as)]) "sconcat as" (\(a, SmallList as) -> sconcat (a :| as)) "foldr1 (<>) as" (\(a, SmallList as) -> foldr1 (<>) (a :| as)) semigroupTimes :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semigroupTimes _ = myForAllShrink True (\(_,n) -> n > 0) (\(a :: a, n :: Int) -> ["a = " ++ show a, "n = " ++ show n]) "stimes n a" (\(a,n) -> stimes n a) "foldr1 (<>) (replicate n a)" (\(a,n) -> foldr1 (<>) (replicate n a)) semigroupExponential :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semigroupExponential _ = myForAllShrink True (\(_,_,n) -> n > 0) (\(a :: a, b, n :: Int) -> ["a = " ++ show a, "b = " ++ show b, "n = " ++ show n]) "stimes n (a <> b)" (\(a,b,n) -> stimes n (a <> b)) "stimes n a <> stimes n b" (\(a,b,n) -> stimes n a <> stimes n b) semigroupIdempotent :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semigroupIdempotent _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "a <> a" (\a -> a <> a) "a" (\a -> a) semigroupRectangularBand :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semigroupRectangularBand _ = myForAllShrink False (const True) (\(a :: a, b) -> ["a = " ++ show a, "b = " ++ show b]) "a <> b <> a" (\(a,b) -> a <> b <> a) "a" (\(a,_) -> a) quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Show.hs0000644000000000000000000000300407346545000023111 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} {-| Module : Test.QuickCheck.Classes.Show Description : Properties for testing the properties of the Show type class. -} module Test.QuickCheck.Classes.Show ( showLaws ) where import Data.Proxy (Proxy) import Test.QuickCheck (Arbitrary, Property, property) import Test.QuickCheck.Classes.Internal (Laws(..), ShowReadPrecedence(..)) -- | Tests the following properties: -- -- [/Show/] -- @'show' a ≡ 'showsPrec' 0 a ""@ -- [/Equivariance: 'showsPrec'/] -- @'showsPrec' p a r '++' s ≡ 'showsPrec' p a (r '++' s)@ -- [/Equivariance: 'showList'/] -- @'showList' as r '++' s ≡ 'showList' as (r '++' s)@ -- showLaws :: (Show a, Arbitrary a) => Proxy a -> Laws showLaws p = Laws "Show" [ ("Show", showShowsPrecZero p) , ("Equivariance: showsPrec", equivarianceShowsPrec p) , ("Equivariance: showList", equivarianceShowList p) ] showShowsPrecZero :: forall a. (Show a, Arbitrary a) => Proxy a -> Property showShowsPrecZero _ = property $ \(a :: a) -> show a == showsPrec 0 a "" equivarianceShowsPrec :: forall a. (Show a, Arbitrary a) => Proxy a -> Property equivarianceShowsPrec _ = property $ \(ShowReadPrecedence p) (a :: a) (r :: String) (s :: String) -> showsPrec p a r ++ s == showsPrec p a (r ++ s) equivarianceShowList :: forall a. (Show a, Arbitrary a) => Proxy a -> Property equivarianceShowList _ = property $ \(as :: [a]) (r :: String) (s :: String) -> showList as r ++ s == showList as (r ++ s) quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/ShowRead.hs0000644000000000000000000000616507346545000023720 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} {-| Module : Test.QuickCheck.Classes.ShowRead Description : Properties for testing the interaction between the Show and Read type classes. -} module Test.QuickCheck.Classes.ShowRead ( showReadLaws ) where import Data.Proxy (Proxy) import Test.QuickCheck import Text.Read (readListDefault) import Text.Show (showListWith) import Test.QuickCheck.Classes.Internal (Laws(..), ShowReadPrecedence(..), SmallList(..), myForAllShrink,readMaybe) -- | Tests the following properties: -- -- [/Partial Isomorphism: 'show' \/ 'read'/] -- @'readMaybe' ('show' a) ≡ 'Just' a@ -- [/Partial Isomorphism: 'show' \/ 'read' with initial space/] -- @'readMaybe' (" " ++ 'show' a) ≡ 'Just' a@ -- [/Partial Isomorphism: 'showsPrec' \/ 'readsPrec'/] -- @(a,"") \`elem\` 'readsPrec' p ('showsPrec' p a "")@ -- [/Partial Isomorphism: 'showList' \/ 'readList'/] -- @(as,"") \`elem\` 'readList' ('showList' as "")@ -- [/Partial Isomorphism: 'showListWith' 'shows' \/ 'readListDefault'/] -- @(as,"") \`elem\` 'readListDefault' ('showListWith' 'shows' as "")@ -- -- /Note:/ When using @base-4.5@ or older, a shim implementation -- of 'readMaybe' is used. -- showReadLaws :: (Show a, Read a, Eq a, Arbitrary a) => Proxy a -> Laws showReadLaws p = Laws "Show/Read" [ ("Partial Isomorphism: show/read", showReadPartialIsomorphism p) , ("Partial Isomorphism: show/read with initial space", showReadSpacePartialIsomorphism p) , ("Partial Isomorphism: showsPrec/readsPrec", showsPrecReadsPrecPartialIsomorphism p) , ("Partial Isomorphism: showList/readList", showListReadListPartialIsomorphism p) , ("Partial Isomorphism: showListWith shows / readListDefault", showListWithShowsReadListDefaultPartialIsomorphism p) ] showReadPartialIsomorphism :: forall a. (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property showReadPartialIsomorphism _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) ("readMaybe (show a)") (\a -> readMaybe (show a)) ("Just a") (\a -> Just a) showReadSpacePartialIsomorphism :: forall a. (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property showReadSpacePartialIsomorphism _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) ("readMaybe (\" \" ++ show a)") (\a -> readMaybe (" " ++ show a)) ("Just a") (\a -> Just a) showsPrecReadsPrecPartialIsomorphism :: forall a. (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property showsPrecReadsPrecPartialIsomorphism _ = property $ \(a :: a) (ShowReadPrecedence p) -> (a,"") `elem` readsPrec p (showsPrec p a "") showListReadListPartialIsomorphism :: forall a. (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property showListReadListPartialIsomorphism _ = property $ \(SmallList (as :: [a])) -> (as,"") `elem` readList (showList as "") showListWithShowsReadListDefaultPartialIsomorphism :: forall a. (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property showListWithShowsReadListDefaultPartialIsomorphism _ = property $ \(SmallList (as :: [a])) -> (as,"") `elem` readListDefault (showListWith shows as "") quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Storable.hs0000644000000000000000000001076507346545000023760 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Storable ( storableLaws ) where import Control.Applicative import Control.Monad import Data.Proxy (Proxy) import Foreign.Marshal.Alloc import Foreign.Marshal.Array import Foreign.Storable import GHC.Ptr (Ptr(..), plusPtr) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Classes.Internal (Laws(..)) -- | Tests the following 'Storable' properties: -- -- [/Set-Get/] -- @('pokeElemOff' ptr ix a >> 'peekElemOff' ptr ix') ≡ 'pure' a@ -- [/Get-Set/] -- @('peekElemOff' ptr ix >> 'pokeElemOff' ptr ix a) ≡ 'pure' a@ storableLaws :: (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws storableLaws p = Laws "Storable" [ ("Set-Get (you get back what you put in)", storableSetGet p) , ("Get-Set (putting back what you got out has no effect)", storableGetSet p) , ("Set-Set (if you set something twice, the first set is inconsequential", storableSetSet p) , ("List Conversion Roundtrips", storableList p) , ("peekElemOff a i ≡ peek (plusPtr a (i * sizeOf undefined))", storablePeekElem p) , ("peekElemOff a i x ≡ poke (plusPtr a (i * sizeOf undefined)) x ≡ id ", storablePokeElem p) , ("peekByteOff a i ≡ peek (plusPtr a i)", storablePeekByte p) , ("peekByteOff a i x ≡ poke (plusPtr a i) x ≡ id ", storablePokeByte p) ] arrayArbitrary :: forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a) arrayArbitrary = newArray <=< generate . vector storablePeekElem :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property storablePeekElem _ = property $ \(Positive len) ix' -> ioProperty $ do let ix = ix' `mod` len addr :: Ptr a <- arrayArbitrary len x <- peekElemOff addr ix y <- peek (addr `advancePtr` ix) free addr return (x ==== y) storablePokeElem :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property storablePokeElem _ = property $ \(Positive len) (x :: a) ix' -> ioProperty $ do let ix = ix' `mod` len addr <- arrayArbitrary len pokeElemOff addr ix x u <- peekElemOff addr ix poke (addr `advancePtr` ix) x v <- peekElemOff addr ix free addr return (u ==== v) storablePeekByte :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property storablePeekByte _ = property $ \(Positive len) off' -> ioProperty $ do let off = (off' `mod` len) * sizeOf (undefined :: a) addr :: Ptr a <- arrayArbitrary len x :: a <- peekByteOff addr off y :: a <- peek (addr `plusPtr` off) free addr return (x ==== y) storablePokeByte :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property storablePokeByte _ = property $ \(Positive len) (x :: a) off' -> ioProperty $ do let off = (off' `mod` len) * sizeOf (undefined :: a) addr :: Ptr a <- arrayArbitrary len pokeByteOff addr off x u :: a <- peekByteOff addr off poke (addr `plusPtr` off) x v :: a <- peekByteOff addr off free addr return (u ==== v) storableSetGet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property storableSetGet _ = property $ \(a :: a) (Positive len) ix' -> ioProperty $ do let ix = ix' `mod` len ptr <- arrayArbitrary len pokeElemOff ptr ix a a' <- peekElemOff ptr ix free ptr return (a ==== a') storableGetSet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property storableGetSet _ = property $ \(NonEmpty (as :: [a])) ix' -> ioProperty $ do let len = length as ix = ix' `mod` len ptrA <- newArray as ptrB <- arrayArbitrary len copyArray ptrB ptrA len a <- peekElemOff ptrA ix pokeElemOff ptrA ix a arrA <- peekArray len ptrA arrB <- peekArray len ptrB free ptrA free ptrB return $ conjoin $ zipWith (===) arrA arrB storableSetSet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property storableSetSet _ = property $ \(x :: a) (y :: a) (Positive len) ix' -> ioProperty $ do let ix = ix' `mod` len ptr <- arrayArbitrary len pokeElemOff ptr ix x pokeElemOff ptr ix y atIx <- peekElemOff ptr ix free ptr return $ atIx ==== y storableList :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property storableList _ = property $ \(as :: [a]) -> ioProperty $ do let len = length as ptr <- newArray as let rebuild !ix = if ix < len then (:) <$> peekElemOff ptr ix <*> rebuild (ix + 1) else return [] asNew <- rebuild 0 free ptr return (as ==== asNew) (====) :: (Eq a, Show a) => a -> a -> Property x ==== y | x /= x && y /= y = discard | otherwise = x === y quickcheck-classes-base-0.6.2.0/src/Test/QuickCheck/Classes/Traversable.hs0000644000000000000000000000674107346545000024456 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Traversable ( #if HAVE_UNARY_LAWS traversableLaws #endif ) where import Data.Foldable (foldMap) import Data.Traversable (Traversable,fmapDefault,foldMapDefault,sequenceA,traverse) import Test.QuickCheck hiding ((.&.)) #if HAVE_UNARY_LAWS import Test.QuickCheck.Arbitrary (Arbitrary1(..)) import Data.Functor.Classes (Eq1,Show1) #endif import Data.Functor.Compose import Data.Functor.Identity import qualified Data.Set as S import Test.QuickCheck.Classes.Internal #if HAVE_UNARY_LAWS -- | Tests the following 'Traversable' properties: -- -- [/Naturality/] -- @t '.' 'traverse' f ≡ 'traverse' (t '.' f)@ -- for every applicative transformation @t@ -- [/Identity/] -- @'traverse' 'Identity' ≡ 'Identity'@ -- [/Composition/] -- @'traverse' ('Compose' '.' 'fmap' g '.' f) ≡ 'Compose' '.' 'fmap' ('traverse' g) '.' 'traverse' f@ -- [/Sequence Naturality/] -- @t '.' 'sequenceA' ≡ 'sequenceA' '.' 'fmap' t@ -- for every applicative transformation @t@ -- [/Sequence Identity/] -- @'sequenceA' '.' 'fmap' 'Identity' ≡ 'Identity'@ -- [/Sequence Composition/] -- @'sequenceA' '.' 'fmap' 'Compose' ≡ 'Compose' '.' 'fmap' 'sequenceA' '.' 'sequenceA'@ -- [/foldMap/] -- @'foldMap' ≡ 'foldMapDefault'@ -- [/fmap/] -- @'fmap' ≡ 'fmapDefault'@ -- -- Where an /applicative transformation/ is a function -- -- @t :: (Applicative f, Applicative g) => f a -> g a@ -- -- preserving the 'Applicative' operations, i.e. -- -- * Identity: @t ('pure' x) ≡ 'pure' x@ -- * Distributivity: @t (x '<*>' y) ≡ t x '<*>' t y@ traversableLaws :: #if HAVE_QUANTIFIED_CONSTRAINTS (Traversable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Traversable f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws traversableLaws = traversableLawsInternal traversableLawsInternal :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Traversable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Traversable f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws traversableLawsInternal _ = Laws "Traversable" [ (,) "Naturality" $ property $ \(Apply (a :: f Integer)) -> propNestedEq1 (apTrans (traverse func4 a)) (traverse (apTrans . func4) a) , (,) "Identity" $ property $ \(Apply (t :: f Integer)) -> nestedEq1 (traverse Identity t) (Identity t) , (,) "Composition" $ property $ \(Apply (t :: f Integer)) -> nestedEq1 (traverse (Compose . fmap func5 . func6) t) (Compose (fmap (traverse func5) (traverse func6 t))) , (,) "Sequence Naturality" $ property $ \(Apply (x :: f (Compose Triple ((,) (S.Set Integer)) Integer))) -> let a = fmap toSpecialApplicative x in propNestedEq1 (apTrans (sequenceA a)) (sequenceA (fmap apTrans a)) , (,) "Sequence Identity" $ property $ \(Apply (t :: f Integer)) -> nestedEq1 (sequenceA (fmap Identity t)) (Identity t) , (,) "Sequence Composition" $ property $ \(Apply (t :: f (Triple (Triple Integer)))) -> nestedEq1 (sequenceA (fmap Compose t)) (Compose (fmap sequenceA (sequenceA t))) , (,) "foldMap" $ property $ \(Apply (t :: f Integer)) -> foldMap func3 t == foldMapDefault func3 t , (,) "fmap" $ property $ \(Apply (t :: f Integer)) -> eq1 (fmap func3 t) (fmapDefault func3 t) ] #endif