diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright 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. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,14 @@ +# 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/). + +## [0.6.0.0] - 2019-08-07 +### 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. diff --git a/quickcheck-classes-base.cabal b/quickcheck-classes-base.cabal new file mode 100644 --- /dev/null +++ b/quickcheck-classes-base.cabal @@ -0,0 +1,110 @@ +name: quickcheck-classes-base +version: 0.6.0.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: BSD3 +license-file: LICENSE +author: Andrew Martin, chessai +maintainer: andrew.thaddeus@gmail.com +copyright: 2019 Andrew Martin +category: Testing +build-type: Simple +cabal-version: >=1.10 +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 + , base-orphans >= 0.1 + , bifunctors + , contravariant + , QuickCheck >= 2.7 + , transformers >= 0.3 && < 0.6 + , containers >= 0.4.2.1 + , semigroups >= 0.17 + , tagged + , fail + 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 diff --git a/src/Test/QuickCheck/Classes/Alternative.hs b/src/Test/QuickCheck/Classes/Alternative.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Alternative.hs @@ -0,0 +1,77 @@ +{-# 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 diff --git a/src/Test/QuickCheck/Classes/Applicative.hs b/src/Test/QuickCheck/Classes/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Applicative.hs @@ -0,0 +1,111 @@ +{-# 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 diff --git a/src/Test/QuickCheck/Classes/Base.hs b/src/Test/QuickCheck/Classes/Base.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Base.hs @@ -0,0 +1,266 @@ +{-# 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 + , 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 diff --git a/src/Test/QuickCheck/Classes/Base/IsList.hs b/src/Test/QuickCheck/Classes/Base/IsList.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Base/IsList.hs @@ -0,0 +1,251 @@ +{-# 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 diff --git a/src/Test/QuickCheck/Classes/Bifoldable.hs b/src/Test/QuickCheck/Classes/Bifoldable.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Bifoldable.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +#if HAVE_QUANTIFIED_CONSTRAINTS +{-# LANGUAGE QuantifiedConstraints #-} +#endif + +{-# OPTIONS_GHC -Wall #-} + +module Test.QuickCheck.Classes.Bifoldable + ( +#if HAVE_BINARY_LAWS + bifoldableLaws + , bifoldableFunctorLaws +#endif + ) where + +#if HAVE_BINARY_LAWS +import Data.Bifoldable(Bifoldable(..)) +import Data.Bifunctor (Bifunctor(..)) +import Test.QuickCheck hiding ((.&.)) +import Data.Functor.Classes (Eq2,Show2) +import Test.QuickCheck.Property (Property) +import Data.Monoid +import Data.Orphans () +import Test.QuickCheck.Classes.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 Sum Sum x == (bifold (bimap Sum Sum x)) + +bifoldableFunctorImplication :: forall proxy f. +#if HAVE_QUANTIFIED_CONSTRAINTS + (Bifoldable f, Bifunctor f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) +#else + (Bifoldable f, Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) +#endif + => proxy f -> Property +bifoldableFunctorImplication _ = property $ \(Apply2 (x :: f Integer Integer)) -> bifoldMap Sum Sum (bimap Product Product x) == bifoldMap (Sum . Product) (Sum . Product) x + +bifoldIdentity :: forall proxy f. +#if HAVE_QUANTIFIED_CONSTRAINTS + (Bifoldable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) +#else + (Bifoldable f, Eq2 f, Show2 f, Arbitrary2 f) +#endif + => proxy f -> Property +bifoldIdentity _ = property $ \(Apply2 (x :: f (Sum Integer) (Sum Integer))) -> (bifold x) == (bifoldMap id id x) + +bifoldMapIdentity :: forall proxy f. +#if HAVE_QUANTIFIED_CONSTRAINTS + (Bifoldable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) +#else + (Bifoldable f, Eq2 f, Show2 f, Arbitrary2 f) +#endif + => proxy f -> Property +bifoldMapIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> bifoldMap Sum Sum x == bifoldr (mappend . Sum) (mappend . Sum) mempty x + +bifoldrIdentity :: forall proxy f. +#if HAVE_QUANTIFIED_CONSTRAINTS + (Bifoldable f, forall a b. (Eq a, Eq b) => Eq (f a b), forall a b. (Show a, Show b) => Show (f a b), forall a b. (Arbitrary a, Arbitrary b) => Arbitrary (f a b)) +#else + (Bifoldable f, Eq2 f, Show2 f, Arbitrary2 f) +#endif + => proxy f -> Property +bifoldrIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> + let f _ _ = mempty + g _ _ = mempty + in bifoldr f g (mempty :: Sum Integer) x == appEndo (bifoldMap (Endo . f) (Endo . g) x) mempty + +#endif diff --git a/src/Test/QuickCheck/Classes/Bifunctor.hs b/src/Test/QuickCheck/Classes/Bifunctor.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Bifunctor.hs @@ -0,0 +1,91 @@ +{-# 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 diff --git a/src/Test/QuickCheck/Classes/Bitraversable.hs b/src/Test/QuickCheck/Classes/Bitraversable.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Bitraversable.hs @@ -0,0 +1,94 @@ +{-# 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 diff --git a/src/Test/QuickCheck/Classes/Bits.hs b/src/Test/QuickCheck/Classes/Bits.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Bits.hs @@ -0,0 +1,210 @@ +{-# 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 diff --git a/src/Test/QuickCheck/Classes/Category.hs b/src/Test/QuickCheck/Classes/Category.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Category.hs @@ -0,0 +1,108 @@ +{-# 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 diff --git a/src/Test/QuickCheck/Classes/Contravariant.hs b/src/Test/QuickCheck/Classes/Contravariant.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Contravariant.hs @@ -0,0 +1,71 @@ +{-# 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 diff --git a/src/Test/QuickCheck/Classes/Enum.hs b/src/Test/QuickCheck/Classes/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Enum.hs @@ -0,0 +1,77 @@ +{-# 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) + diff --git a/src/Test/QuickCheck/Classes/Eq.hs b/src/Test/QuickCheck/Classes/Eq.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Eq.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wall #-} + +module Test.QuickCheck.Classes.Eq + ( eqLaws + ) where + +import Data.Proxy (Proxy) +import Test.QuickCheck hiding ((.&.)) +import Test.QuickCheck.Property (Property) + +import Test.QuickCheck.Classes.Internal (Laws(..)) + +-- | Tests the following properties: +-- +-- [/Transitive/] +-- @a == b ∧ b == c ⇒ a == c@ +-- [/Symmetric/] +-- @a == b ⇒ b == a@ +-- [/Reflexive/] +-- @a == a@ +-- +-- Some of these properties involve implication. In the case that +-- the left hand side of the implication arrow does not hold, we +-- do not retry. Consequently, these properties only end up being +-- useful when the data type has a small number of inhabitants. +eqLaws :: (Eq a, Arbitrary a, Show a) => Proxy a -> Laws +eqLaws p = Laws "Eq" + [ ("Transitive", eqTransitive p) + , ("Symmetric", eqSymmetric p) + , ("Reflexive", eqReflexive p) + ] + +eqTransitive :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property +eqTransitive _ = property $ \(a :: a) b c -> case a == b of + True -> case b == c of + True -> a == c + False -> a /= c + False -> case b == c of + True -> a /= c + False -> True + +eqSymmetric :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property +eqSymmetric _ = property $ \(a :: a) b -> case a == b of + True -> b == a + False -> b /= a + +eqReflexive :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property +eqReflexive _ = property $ \(a :: a) -> a == a diff --git a/src/Test/QuickCheck/Classes/Foldable.hs b/src/Test/QuickCheck/Classes/Foldable.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Foldable.hs @@ -0,0 +1,184 @@ +{-# 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 diff --git a/src/Test/QuickCheck/Classes/Functor.hs b/src/Test/QuickCheck/Classes/Functor.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Functor.hs @@ -0,0 +1,83 @@ +{-# 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 + diff --git a/src/Test/QuickCheck/Classes/Generic.hs b/src/Test/QuickCheck/Classes/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Generic.hs @@ -0,0 +1,112 @@ +{-# 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 diff --git a/src/Test/QuickCheck/Classes/Integral.hs b/src/Test/QuickCheck/Classes/Integral.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Integral.hs @@ -0,0 +1,52 @@ +{-# 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@ +integralLaws :: (Integral a, Arbitrary a, Show a) => Proxy a -> Laws +integralLaws p = Laws "Integral" + [ ("Quotient Remainder", integralQuotientRemainder p) + , ("Division Modulus", integralDivisionModulus p) + , ("Integer Roundtrip", integralIntegerRoundtrip p) + ] + +integralQuotientRemainder :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property +integralQuotientRemainder _ = myForAllShrink False (\(_,y) -> y /= 0) + (\(x :: a, y) -> ["x = " ++ show x, "y = " ++ show y]) + "(quot x y) * y + (rem x y)" + (\(x,y) -> (quot x y) * y + (rem x y)) + "x" + (\(x,_) -> x) + +integralDivisionModulus :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property +integralDivisionModulus _ = myForAllShrink False (\(_,y) -> y /= 0) + (\(x :: a, y) -> ["x = " ++ show x, "y = " ++ show y]) + "(div x y) * y + (mod x y)" + (\(x,y) -> (div x y) * y + (mod x y)) + "x" + (\(x,_) -> x) + +integralIntegerRoundtrip :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property +integralIntegerRoundtrip _ = myForAllShrink False (const True) + (\(x :: a) -> ["x = " ++ show x]) + "fromInteger (toInteger x)" + (\x -> fromInteger (toInteger x)) + "x" + (\x -> x) diff --git a/src/Test/QuickCheck/Classes/Internal.hs b/src/Test/QuickCheck/Classes/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Internal.hs @@ -0,0 +1,583 @@ +{-# 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. +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 + diff --git a/src/Test/QuickCheck/Classes/Ix.hs b/src/Test/QuickCheck/Classes/Ix.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Ix.hs @@ -0,0 +1,49 @@ +{-# 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)) + + diff --git a/src/Test/QuickCheck/Classes/Monad.hs b/src/Test/QuickCheck/Classes/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Monad.hs @@ -0,0 +1,111 @@ +{-# 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 diff --git a/src/Test/QuickCheck/Classes/MonadFail.hs b/src/Test/QuickCheck/Classes/MonadFail.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/MonadFail.hs @@ -0,0 +1,56 @@ +{-# 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 diff --git a/src/Test/QuickCheck/Classes/MonadPlus.hs b/src/Test/QuickCheck/Classes/MonadPlus.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/MonadPlus.hs @@ -0,0 +1,101 @@ +{-# 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 diff --git a/src/Test/QuickCheck/Classes/MonadZip.hs b/src/Test/QuickCheck/Classes/MonadZip.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/MonadZip.hs @@ -0,0 +1,62 @@ +{-# 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 diff --git a/src/Test/QuickCheck/Classes/Monoid.hs b/src/Test/QuickCheck/Classes/Monoid.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Monoid.hs @@ -0,0 +1,100 @@ +{-# 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) diff --git a/src/Test/QuickCheck/Classes/Num.hs b/src/Test/QuickCheck/Classes/Num.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Num.hs @@ -0,0 +1,151 @@ +{-# 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@ +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) + ] + +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) diff --git a/src/Test/QuickCheck/Classes/Ord.hs b/src/Test/QuickCheck/Classes/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Ord.hs @@ -0,0 +1,49 @@ +{-# 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 diff --git a/src/Test/QuickCheck/Classes/Semigroup.hs b/src/Test/QuickCheck/Classes/Semigroup.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Semigroup.hs @@ -0,0 +1,145 @@ +{-# 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) diff --git a/src/Test/QuickCheck/Classes/Show.hs b/src/Test/QuickCheck/Classes/Show.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Show.hs @@ -0,0 +1,48 @@ +{-# 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) diff --git a/src/Test/QuickCheck/Classes/ShowRead.hs b/src/Test/QuickCheck/Classes/ShowRead.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/ShowRead.hs @@ -0,0 +1,85 @@ +{-# 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 "") + diff --git a/src/Test/QuickCheck/Classes/Storable.hs b/src/Test/QuickCheck/Classes/Storable.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Storable.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} + +{-# OPTIONS_GHC -Wall #-} + +module Test.QuickCheck.Classes.Storable + ( storableLaws + ) where + +import Control.Applicative +import Data.Proxy (Proxy) +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.Storable + +import GHC.Ptr (Ptr(..), plusPtr) +import System.IO.Unsafe +import Test.QuickCheck hiding ((.&.)) +import Test.QuickCheck.Property (Property) + +import qualified Data.List as L + +import Test.QuickCheck.Classes.Internal (Laws(..)) + +-- | Tests the following alternative properties: +-- +-- [/Set-Get/] +-- @('pokeElemOff' ptr ix a >> 'peekElemOff' ptr ix') ≡ 'pure' a@ +-- [/Get-Set/] +-- @('peekElemOff' ptr ix >> 'pokeElemOff' ptr ix a) ≡ 'pure' a@ +storableLaws :: (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws +storableLaws p = Laws "Storable" + [ ("Set-Get (you get back what you put in)", storableSetGet p) + , ("Get-Set (putting back what you got out has no effect)", storableGetSet p) + , ("List Conversion Roundtrips", storableList p) + , ("peekElemOff a i ≡ peek (plusPtr a (i * sizeOf undefined))", storablePeekElem p) + , ("peekElemOff a i x ≡ poke (plusPtr a (i * sizeOf undefined)) x ≡ id ", storablePokeElem p) + , ("peekByteOff a i ≡ peek (plusPtr a i)", storablePeekByte p) + , ("peekByteOff a i x ≡ poke (plusPtr a i) x ≡ id ", storablePokeByte p) + ] + +arrayArbitrary :: forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a) +arrayArbitrary len = do + let go ix xs = if ix == len + then pure xs + else do + x <- generate (arbitrary :: Gen a) + go (ix + 1) (x : xs) + as <- go 0 [] + newArray as + +storablePeekElem :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property +storablePeekElem _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do + let len = L.length as + ix <- choose (0, len - 1) + return $ unsafePerformIO $ do + addr :: Ptr a <- arrayArbitrary len + x <- peekElemOff addr ix + y <- peek (addr `plusPtr` (ix * sizeOf (undefined :: a))) + free addr + return (x == y) + +storablePokeElem :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property +storablePokeElem _ = property $ \(as :: [a]) (x :: a) -> (not (L.null as)) ==> do + let len = L.length as + ix <- choose (0, len - 1) + return $ unsafePerformIO $ do + addr :: Ptr a <- arrayArbitrary len + pokeElemOff addr ix x + u <- peekElemOff addr ix + poke (addr `plusPtr` (ix * sizeOf x)) x + v <- peekElemOff addr ix + free addr + return (u == v) + +storablePeekByte :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property +storablePeekByte _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do + let len = L.length as + off <- choose (0, len - 1) + return $ unsafePerformIO $ do + addr :: Ptr a <- arrayArbitrary len + x :: a <- peekByteOff addr off + y :: a <- peek (addr `plusPtr` off) + free addr + return (x == y) + +storablePokeByte :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property +storablePokeByte _ = property $ \(as :: [a]) (x :: a) -> (not (L.null as)) ==> do + let len = L.length as + off <- choose (0, len - 1) + return $ unsafePerformIO $ do + addr :: Ptr a <- arrayArbitrary len + pokeByteOff addr off x + u :: a <- peekByteOff addr off + poke (addr `plusPtr` off) x + v :: a <- peekByteOff addr off + free addr + return (u == v) + +storableSetGet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property +storableSetGet _ = property $ \(a :: a) len -> (len > 0) ==> do + ix <- choose (0,len - 1) + return $ unsafePerformIO $ do + ptr :: Ptr a <- arrayArbitrary len + pokeElemOff ptr ix a + a' <- peekElemOff ptr ix + free ptr + return (a == a') + +storableGetSet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property +storableGetSet _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do + let len = L.length as + ix <- choose (0,len - 1) + return $ unsafePerformIO $ do + ptrA <- newArray as + ptrB <- arrayArbitrary len + copyArray ptrB ptrA len + a <- peekElemOff ptrA ix + pokeElemOff ptrA ix a + res <- arrayEq ptrA ptrB len + free ptrA + free ptrB + return res + +storableList :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property +storableList _ = property $ \(as :: [a]) -> unsafePerformIO $ do + let len = L.length as + ptr <- newArray as + let rebuild :: Int -> IO [a] + rebuild !ix = if ix < len + then (:) <$> peekElemOff ptr ix <*> rebuild (ix + 1) + else return [] + asNew <- rebuild 0 + free ptr + return (as == asNew) + +arrayEq :: forall a. (Storable a, Eq a) => Ptr a -> Ptr a -> Int -> IO Bool +arrayEq ptrA ptrB len = go 0 where + go !i = if i < len + then do + a <- peekElemOff ptrA i + b <- peekElemOff ptrB i + if a == b + then go (i + 1) + else return False + else return True diff --git a/src/Test/QuickCheck/Classes/Traversable.hs b/src/Test/QuickCheck/Classes/Traversable.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Classes/Traversable.hs @@ -0,0 +1,99 @@ +{-# 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