packages feed

quickcheck-classes-base (empty) → 0.6.0.0

raw patch · 33 files changed

+3904/−0 lines, 33 filesdep +QuickCheckdep +basedep +base-orphans

Dependencies added: QuickCheck, base, base-orphans, bifunctors, containers, contravariant, fail, ghc-prim, semigroups, tagged, transformers

Files

+ LICENSE view
@@ -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.
+ changelog.md view
@@ -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.
+ quickcheck-classes-base.cabal view
@@ -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
+ src/Test/QuickCheck/Classes/Alternative.hs view
@@ -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
+ src/Test/QuickCheck/Classes/Applicative.hs view
@@ -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
+ src/Test/QuickCheck/Classes/Base.hs view
@@ -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
+ src/Test/QuickCheck/Classes/Base/IsList.hs view
@@ -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
+ src/Test/QuickCheck/Classes/Bifoldable.hs view
@@ -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
+ src/Test/QuickCheck/Classes/Bifunctor.hs view
@@ -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
+ src/Test/QuickCheck/Classes/Bitraversable.hs view
@@ -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
+ src/Test/QuickCheck/Classes/Bits.hs view
@@ -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
+ src/Test/QuickCheck/Classes/Category.hs view
@@ -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
+ src/Test/QuickCheck/Classes/Contravariant.hs view
@@ -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
+ src/Test/QuickCheck/Classes/Enum.hs view
@@ -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)+
+ src/Test/QuickCheck/Classes/Eq.hs view
@@ -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
+ src/Test/QuickCheck/Classes/Foldable.hs view
@@ -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
+ src/Test/QuickCheck/Classes/Functor.hs view
@@ -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+
+ src/Test/QuickCheck/Classes/Generic.hs view
@@ -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
+ src/Test/QuickCheck/Classes/Integral.hs view
@@ -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)
+ src/Test/QuickCheck/Classes/Internal.hs view
@@ -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+
+ src/Test/QuickCheck/Classes/Ix.hs view
@@ -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))++
+ src/Test/QuickCheck/Classes/Monad.hs view
@@ -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
+ src/Test/QuickCheck/Classes/MonadFail.hs view
@@ -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
+ src/Test/QuickCheck/Classes/MonadPlus.hs view
@@ -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
+ src/Test/QuickCheck/Classes/MonadZip.hs view
@@ -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
+ src/Test/QuickCheck/Classes/Monoid.hs view
@@ -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)
+ src/Test/QuickCheck/Classes/Num.hs view
@@ -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)
+ src/Test/QuickCheck/Classes/Ord.hs view
@@ -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
+ src/Test/QuickCheck/Classes/Semigroup.hs view
@@ -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)
+ src/Test/QuickCheck/Classes/Show.hs view
@@ -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)
+ src/Test/QuickCheck/Classes/ShowRead.hs view
@@ -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 "")+
+ src/Test/QuickCheck/Classes/Storable.hs view
@@ -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
+ src/Test/QuickCheck/Classes/Traversable.hs view
@@ -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