quickcheck-classes 0.6.0.0 → 0.6.1.0
raw patch · 8 files changed
+371/−31 lines, 8 filesdep ~primitivedep ~semiringsdep ~vector
Dependency ranges changed: primitive, semirings, vector
Files
- changelog.md +7/−1
- quickcheck-classes.cabal +29/−13
- src/Test/QuickCheck/Classes.hs +27/−12
- src/Test/QuickCheck/Classes/MVector.hs +255/−0
- src/Test/QuickCheck/Classes/MonadPlus.hs +2/−3
- src/Test/QuickCheck/Classes/Ring.hs +43/−0
- src/Test/QuickCheck/Classes/Semigroup.hs +1/−1
- test/Spec.hs +7/−1
changelog.md view
@@ -4,7 +4,13 @@ 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] - TBA+## [0.6.1.0] - 2019-01-12+### Change+- `genericLaws` and `generic1Laws` were not exported. Now they are.+### Added+- Add `muvectorLaws`.++## [0.6.0.0] - 2018-12-24 ### Change - Support QuickCheck 2.7 and 2.8. This adds `Arbitrary` orphan instances to the test suite.
quickcheck-classes.cabal view
@@ -1,5 +1,5 @@ name: quickcheck-classes-version: 0.6.0.0+version: 0.6.1.0 synopsis: QuickCheck common typeclasses description: This library provides QuickCheck properties to ensure@@ -46,14 +46,22 @@ You can disable the use of the `semirings` package using `-f-semirings`. . This may be useful for accelerating builds in sandboxes for expert users.- default: True- manual: True+ default: True+ manual: True +flag vector+ description:+ You can disable the use of the `vector` package using `-f-vector`.+ .+ This may be useful for accelerating builds in sandboxes for expert users.+ default: True+ manual: True+ flag unary-laws description: Include infrastructure for testing class laws of unary type constructors. default: True- manual: False+ manual: True flag binary-laws description:@@ -61,7 +69,7 @@ Disabling `unary-laws` while keeping `binary-laws` enabled is an unsupported configuration. default: True- manual: False+ manual: True library default-language: Haskell2010@@ -93,8 +101,9 @@ Test.QuickCheck.Classes.MonadPlus Test.QuickCheck.Classes.MonadZip Test.QuickCheck.Classes.Monoid+ Test.QuickCheck.Classes.MVector Test.QuickCheck.Classes.Ord- Test.QuickCheck.Classes.Plus + Test.QuickCheck.Classes.Plus Test.QuickCheck.Classes.Prim Test.QuickCheck.Classes.Semigroup Test.QuickCheck.Classes.Semigroupoid@@ -102,11 +111,12 @@ Test.QuickCheck.Classes.Show Test.QuickCheck.Classes.ShowRead Test.QuickCheck.Classes.Storable+ Test.QuickCheck.Classes.Ring Test.QuickCheck.Classes.Traversable build-depends: base >= 4.5 && < 5 , base-orphans >= 0.1- , bifunctors + , bifunctors , QuickCheck >= 2.7 , transformers >= 0.3 && < 0.6 , primitive >= 0.6.1 && < 0.7@@ -132,16 +142,19 @@ build-depends: aeson >= 0.9 cpp-options: -DHAVE_AESON if flag(semigroupoids)- build-depends: semigroupoids + build-depends: semigroupoids cpp-options: -DHAVE_SEMIGROUPOIDS if flag(semirings)- build-depends: semirings >= 0.2.1.1+ build-depends: semirings >= 0.3.1.1 cpp-options: -DHAVE_SEMIRINGS+ if flag(vector)+ build-depends: vector >= 0.12+ cpp-options: -DHAVE_VECTOR -- The basic test suite is compatible with all the versions of GHC that -- this library supports. It is useful for confirming whether the laws tests -- behave correct. Additionally, it helps catch CPP mistakes.-test-suite basic +test-suite basic type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs@@ -152,7 +165,7 @@ , base-orphans >= 0.5 , quickcheck-classes , QuickCheck- , containers + , containers , primitive , vector , transformers@@ -169,6 +182,9 @@ if flag(semigroupoids) build-depends: semigroupoids cpp-options: -DHAVE_SEMIGROUPOIDS+ if flag(vector)+ build-depends: vector >= 0.12+ cpp-options: -DHAVE_VECTOR default-language: Haskell2010 -- The advanced test suite only builds with the newest version@@ -176,7 +192,7 @@ -- base. It check instances for a number of types in base. It also checks -- a bunch of derived instances for data types of varying sizes. And it -- does some tests on UnboxedSums.-test-suite advanced +test-suite advanced type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Advanced.hs@@ -185,7 +201,7 @@ QuickCheck , base >= 4.12 , base-orphans >= 0.5- , containers + , containers , primitive , quickcheck-classes , tagged
src/Test/QuickCheck/Classes.hs view
@@ -12,7 +12,7 @@ constraints more cleanly. -} module Test.QuickCheck.Classes- ( -- * Running + ( -- * Running lawsCheck , lawsCheckMany , lawsCheckOne@@ -30,7 +30,7 @@ , jsonLaws #endif , monoidLaws- , commutativeMonoidLaws + , commutativeMonoidLaws , ordLaws , enumLaws , boundedEnumLaws@@ -42,10 +42,15 @@ , rectangularBandSemigroupLaws #if HAVE_SEMIRINGS , semiringLaws+ , ringLaws #endif , showLaws , showReadLaws , storableLaws+#if MIN_VERSION_base(4,5,0)+ , genericLaws+ , generic1Laws+#endif #if HAVE_UNARY_LAWS -- ** Unary type constructors , alternativeLaws@@ -74,7 +79,10 @@ , semigroupoidLaws , commutativeSemigroupoidLaws #endif+#if HAVE_VECTOR+ , muvectorLaws #endif+#endif -- * Types , Laws(..) , Proxy1(..)@@ -102,11 +110,14 @@ import Test.QuickCheck.Classes.Semigroup #if HAVE_SEMIRINGS import Test.QuickCheck.Classes.Semiring+import Test.QuickCheck.Classes.Ring #endif 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@@ -135,6 +146,10 @@ #endif #endif +#if HAVE_VECTOR+import Test.QuickCheck.Classes.MVector+#endif+ -- -- used below --@@ -184,14 +199,14 @@ -- import Data.Map (Map) -- import Data.Set (Set) ----- -- A 'Proxy' for 'Set' 'Int'. +-- -- 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] --@@ -201,7 +216,7 @@ -- , ("Map Int Int", myLaws mapInt) -- ] -- @--- +-- -- Now, in GHCi: -- -- >>> lawsCheckMany namedTests@@ -211,7 +226,7 @@ -- ------------- -- -- Set Int -- -- ---------------- +-- -- Eq: Transitive +++ OK, passed 100 tests. -- Eq: Symmetric +++ OK, passed 100 tests. -- Eq: Reflexive +++ OK, passed 100 tests.@@ -219,11 +234,11 @@ -- 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.@@ -253,9 +268,9 @@ _ -> Bad putStrLn "" case r of- Good -> putStrLn "All tests succeeded" + Good -> putStrLn "All tests succeeded" Bad -> do- putStrLn "One or more tests failed" + putStrLn "One or more tests failed" exitFailure data Status = Bad | Good
+ src/Test/QuickCheck/Classes/MVector.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall #-}++#if !HAVE_VECTOR+module Test.QuickCheck.Classes.MVector where+#else++module Test.QuickCheck.Classes.MVector+ ( muvectorLaws+ ) where++import Control.Applicative+import Control.Monad (when)+import Control.Monad.ST+import Data.Functor+import Data.Proxy (Proxy)+import qualified Data.Vector.Generic.Mutable as MU (basicInitialize)+import qualified Data.Vector.Unboxed.Mutable as MU++import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Property (Property)++import Test.QuickCheck.Classes.Common (Laws(..))++-- | Test that a 'Vector.Unboxed.MVector' instance obey several laws.+muvectorLaws :: (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Laws+muvectorLaws p = Laws "Vector.Unboxed.MVector"+ [ ("New-Length", newLength p)+ , ("Replicate-Length", replicateLength p)+ , ("Slice-Length", sliceLength p)+ , ("Grow-Length", growLength p)++ , ("Write-Read", writeRead p)+ , ("Set-Read", setRead p)+ , ("Replicate-Read", replicateRead p)++ , ("Slice-Overlaps", sliceOverlaps p)++ , ("Write-Copy-Read", writeCopyRead p)+ , ("Write-Move-Read", writeMoveRead p)+ , ("Write-Grow-Read", writeGrowRead p)+ , ("Sliced-Write-Copy-Read", slicedWriteCopyRead p)+ , ("Sliced-Write-Move-Read", slicedWriteMoveRead p)+ , ("Sliced-Write-Grow-Read", slicedWriteGrowRead p)++ , ("Write-InitializeAround-Read", writeInitializeAroundRead p)+ , ("Write-ClearAround-Read", writeClearAroundRead p)+ , ("Write-SetAround-Read", writeSetAroundRead p)+ , ("Write-WriteAround-Read", writeWriteAroundRead p)+ , ("Write-CopyAround-Read", writeCopyAroundRead p)+ , ("Write-MoveAround-Read", writeMoveAroundRead p)+ ]++-------------------------------------------------------------------------------+-- Length++newLength :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+newLength _ = property $ \(NonNegative len) -> do+ (=== len) (runST $ MU.length <$> (MU.new len :: ST s (MU.MVector s a)))++replicateLength :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+replicateLength _ = property $ \(a :: a) (NonNegative len) -> do+ (=== len) (runST $ MU.length <$> MU.replicate len a)++sliceLength :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+sliceLength _ = property $ \(NonNegative ix) (NonNegative subLen) (Positive excess) -> do+ (=== subLen) (runST $ MU.length . MU.slice ix subLen <$> (MU.new (ix + subLen + excess) :: ST s (MU.MVector s a)))++growLength :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+growLength _ = property $ \(Positive len) (Positive by) -> do+ (=== len + by) $ runST $ do+ arr <- MU.new len :: ST s (MU.MVector s a)+ MU.length <$> MU.grow arr by++-------------------------------------------------------------------------------+-- Read++writeRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+ (=== a) $ runST $ do+ arr <- MU.new (ix + excess)+ MU.write arr ix a+ MU.read arr ix++setRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+setRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+ (=== a) $ runST $ do+ arr <- MU.new (ix + excess)+ MU.set arr a+ MU.read arr ix++replicateRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+replicateRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+ (=== a) $ runST $ do+ arr <- MU.replicate (ix + excess) a+ MU.read arr ix++-------------------------------------------------------------------------------+-- Overlaps++sliceOverlaps :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+sliceOverlaps _ = property $ \(NonNegative i) (NonNegative ij) (NonNegative jk) (NonNegative kl) (NonNegative lm) -> do+ let j = i + ij+ k = j + jk+ l = k + kl+ m = l + lm+ property $ runST $ do+ arr <- MU.new (m + 1) :: ST s (MU.MVector s a)+ let slice1 = MU.slice i (k - i + 1) arr+ slice2 = MU.slice j (l - j + 1) arr+ pure $ MU.overlaps slice1 slice2++-------------------------------------------------------------------------------+-- Write + copy/move/grow++writeCopyRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeCopyRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+ (=== a) $ runST $ do+ src <- MU.new (ix + excess)+ MU.write src ix a+ dst <- MU.new (ix + excess)+ MU.copy dst src+ MU.clear src+ MU.read dst ix++writeMoveRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeMoveRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+ (=== a) $ runST $ do+ src <- MU.new (ix + excess)+ MU.write src ix a+ dst <- MU.new (ix + excess)+ MU.move dst src+ MU.clear src+ MU.read dst ix++writeGrowRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeGrowRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) (Positive by) -> do+ (=== a) $ runST $ do+ src <- MU.new (ix + excess)+ MU.write src ix a+ dst <- MU.grow src by+ MU.clear src+ MU.read dst ix++slicedWriteCopyRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+slicedWriteCopyRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) beforeSrc afterSrc beforeDst afterDst -> do+ (=== a) $ runST $ do+ src <- newSlice beforeSrc afterSrc (ix + excess)+ MU.write src ix a+ dst <- newSlice beforeDst afterDst (ix + excess)+ MU.copy dst src+ MU.clear src+ MU.read dst ix++slicedWriteMoveRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+slicedWriteMoveRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) beforeSrc afterSrc beforeDst afterDst -> do+ (=== a) $ runST $ do+ src <- newSlice beforeSrc afterSrc (ix + excess)+ MU.write src ix a+ dst <- newSlice beforeDst afterDst (ix + excess)+ MU.move dst src+ MU.clear src+ MU.read dst ix++slicedWriteGrowRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+slicedWriteGrowRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) (Positive by) beforeSrc afterSrc -> do+ (=== a) $ runST $ do+ src <- newSlice beforeSrc afterSrc (ix + excess)+ MU.write src ix a+ dst <- MU.grow src by+ MU.clear src+ MU.read dst ix++-------------------------------------------------------------------------------+-- Write + overwrite around++writeInitializeAroundRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeInitializeAroundRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+ (=== a) $ runST $ do+ arr <- MU.new (ix + excess)+ MU.write arr ix a+ when (ix > 0) $+ MU.basicInitialize (MU.slice 0 ix arr)+ when (excess > 1) $+ MU.basicInitialize (MU.slice (ix + 1) (excess - 1) arr)+ MU.read arr ix++writeClearAroundRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeClearAroundRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+ (=== a) $ runST $ do+ arr <- MU.new (ix + excess)+ MU.write arr ix a+ when (ix > 0) $+ MU.clear (MU.slice 0 ix arr)+ when (excess > 1) $+ MU.clear (MU.slice (ix + 1) (excess - 1) arr)+ MU.read arr ix++writeSetAroundRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeSetAroundRead _ = property $ \(a :: a) (b :: a) (NonNegative ix) (Positive excess) -> do+ (=== a) $ runST $ do+ arr <- MU.new (ix + excess)+ MU.write arr ix a+ when (ix > 0) $+ MU.set (MU.slice 0 ix arr) b+ when (excess > 1) $+ MU.set (MU.slice (ix + 1) (excess - 1) arr) b+ MU.read arr ix++writeWriteAroundRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeWriteAroundRead _ = property $ \(a :: a) (b :: a) (NonNegative ix) (Positive excess) -> do+ (=== a) $ runST $ do+ arr <- MU.new (ix + excess)+ MU.write arr ix a+ when (ix > 0) $+ MU.write arr (ix - 1) b+ when (excess > 1) $+ MU.write arr (ix + 1) b+ MU.read arr ix++writeCopyAroundRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeCopyAroundRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+ (=== a) $ runST $ do+ src <- MU.new (ix + excess)+ dst <- MU.new (ix + excess)+ MU.write dst ix a+ when (ix > 0) $+ MU.copy (MU.slice 0 ix dst) (MU.slice 0 ix src)+ when (excess > 1) $+ MU.copy (MU.slice (ix + 1) (excess - 1) dst) (MU.slice (ix + 1) (excess - 1) src)+ MU.read dst ix++writeMoveAroundRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeMoveAroundRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) -> do+ (=== a) $ runST $ do+ src <- MU.new (ix + excess)+ dst <- MU.new (ix + excess)+ MU.write dst ix a+ when (ix > 0) $+ MU.move (MU.slice 0 ix dst) (MU.slice 0 ix src)+ when (excess > 1) $+ MU.move (MU.slice (ix + 1) (excess - 1) dst) (MU.slice (ix + 1) (excess - 1) src)+ MU.read dst ix++-------------------------------------------------------------------------------+-- Utils++newSlice :: MU.Unbox a => NonNegative Int -> NonNegative Int -> Int -> ST s (MU.MVector s a)+newSlice (NonNegative before) (NonNegative after) len = do+ arr <- MU.new (before + len + after)+ pure $ MU.slice before len arr++#endif
src/Test/QuickCheck/Classes/MonadPlus.hs view
@@ -20,7 +20,6 @@ #if HAVE_UNARY_LAWS import Test.QuickCheck.Classes.Compat (eq1) #endif-import Control.Applicative(Alternative(empty)) import Control.Monad (MonadPlus(mzero,mplus)) #if HAVE_UNARY_LAWS@@ -33,9 +32,9 @@ -- | Tests the following monad plus properties: -- -- [/Left Identity/]--- @'mplus' 'empty' x ≡ x@+-- @'mplus' 'mzero' x ≡ x@ -- [/Right Identity/]--- @'mplus' x 'empty' ≡ x@+-- @'mplus' x 'mzero' ≡ x@ -- [/Associativity/] -- @'mplus' a ('mplus' b c) ≡ 'mplus' ('mplus' a b) c)@ -- [/Left Zero/]
+ src/Test/QuickCheck/Classes/Ring.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall #-}++module Test.QuickCheck.Classes.Ring+ ( +#if HAVE_SEMIRINGS+ ringLaws+#endif+ ) where++#if HAVE_SEMIRINGS+import Data.Semiring+import Prelude hiding (Num(..))+#endif++import Data.Proxy (Proxy)+import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Property (Property)++import Test.QuickCheck.Classes.Common (Laws(..), myForAllShrink)++#if HAVE_SEMIRINGS+-- | Tests the following properties:+--+-- [/Additive Inverse/]+-- @'negate' a '+' a ≡ 0@+--+-- Note that this does not test any of the laws tested by 'Test.QuickCheck.Classes.Semiring.semiringLaws'.+ringLaws :: (Ring a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws+ringLaws p = Laws "Ring"+ [ ("Additive Inverse", ringAdditiveInverse p)+ ]++ringAdditiveInverse :: forall a. (Ring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+ringAdditiveInverse _ = myForAllShrink True (const True)+ (\(a :: a) -> ["a = " ++ show a])+ "negate a + a"+ (\a -> negate a + a)+ "0"+ (const zero)+#endif
src/Test/QuickCheck/Classes/Semigroup.hs view
@@ -85,7 +85,7 @@ -- '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"- [ ("Rectangular Band", semigroupExponential p)+ [ ("Exponential", semigroupExponential p) ] semigroupAssociative :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property
test/Spec.hs view
@@ -71,7 +71,13 @@ #endif #endif #if MIN_VERSION_base(4,7,0)- , ("Vector",[isListLaws (Proxy :: Proxy (Vector Word))])+ , ("Vector",+ [ isListLaws (Proxy :: Proxy (Vector Word))+#if HAVE_VECTOR+ , muvectorLaws (Proxy :: Proxy Word8)+ , muvectorLaws (Proxy :: Proxy (Int, Word))+#endif+ ]) #endif ] ++ Spec.ShowRead.lawsApplied