packages feed

quickcheck-classes 0.6.1.0 → 0.6.2.0

raw patch · 11 files changed

+300/−11 lines, 11 filesdep +contravariantdep +primitive-addrdep ~primitive

Dependencies added: contravariant, primitive-addr

Dependency ranges changed: primitive

Files

changelog.md view
@@ -4,6 +4,17 @@ 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.2.0] - TBA+### Added+- `ixLaws`+- `contravariantLaws`+- `semigroupMonoidLaws`+### Changed+- extend `mvectorLaws`+### Fixed+- bug in `foldableLaws` which could fail to catch implementations of `foldMap` or `fold`+  that evaluate in the wrong order+ ## [0.6.1.0] - 2019-01-12 ### Change - `genericLaws` and `generic1Laws` were not exported. Now they are.
quickcheck-classes.cabal view
@@ -1,5 +1,5 @@ name: quickcheck-classes-version: 0.6.1.0+version: 0.6.2.0 synopsis: QuickCheck common typeclasses description:   This library provides QuickCheck properties to ensure@@ -89,12 +89,14 @@     Test.QuickCheck.Classes.Category     Test.QuickCheck.Classes.Common     Test.QuickCheck.Classes.Compat+    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.Json     Test.QuickCheck.Classes.Monad     Test.QuickCheck.Classes.MonadFail@@ -117,9 +119,11 @@       base >= 4.5 && < 5     , base-orphans >= 0.1     , bifunctors+    , contravariant     , QuickCheck >= 2.7     , transformers >= 0.3 && < 0.6-    , primitive >= 0.6.1 && < 0.7+    , primitive >= 0.7 && < 0.8+    , primitive-addr >= 0.1 && < 0.2     , containers >= 0.4.2.1     , semigroups >= 0.17     , tagged
src/Test/QuickCheck/Classes.hs view
@@ -23,6 +23,7 @@ #endif   , eqLaws   , integralLaws+  , ixLaws #if MIN_VERSION_base(4,7,0)   , isListLaws #endif@@ -31,6 +32,7 @@ #endif   , monoidLaws   , commutativeMonoidLaws+  , semigroupMonoidLaws   , ordLaws   , enumLaws   , boundedEnumLaws@@ -59,6 +61,7 @@   , applyLaws #endif   , applicativeLaws+  , contravariantLaws    , foldableLaws   , functorLaws   , monadLaws@@ -98,6 +101,7 @@ import Test.QuickCheck.Classes.Enum import Test.QuickCheck.Classes.Eq import Test.QuickCheck.Classes.Integral+import Test.QuickCheck.Classes.Ix #if MIN_VERSION_base(4,7,0) import Test.QuickCheck.Classes.IsList #endif@@ -126,6 +130,7 @@ import Test.QuickCheck.Classes.Apply #endif 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
src/Test/QuickCheck/Classes/Apply.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}  #if HAVE_QUANTIFIED_CONSTRAINTS@@ -25,10 +26,20 @@ import Test.QuickCheck.Classes.Common import Test.QuickCheck.Classes.Compat (eq1) +type ApplyProp proxy f =+#if HAVE_QUANTIFIED_CONSTRAINTS+  (FunctorApply.Apply f, forall x. Eq x => Eq (f x), forall x. Show x => Show (f x), forall x. Arbitrary x => Arbitrary (f x)) +#else+  (FunctorApply.Apply f, Eq1 f, Show1 f, Arbitrary1 f)+#endif+  => proxy f -> Property+ -- | Tests the following alt properties: -- -- [/LiftF2 (1)/] --   @('FunctorApply.<.>') ≡ 'FunctorApply.liftF2' 'id'@+-- [/Associativity/]+--   @'fmap' ('.') u 'FunctorApply.<.>' v 'FunctorApply.<.>' w ≡ u 'FunctorApply.<.>' (v 'FunctorApply.<.>' w)@ applyLaws :: #if HAVE_QUANTIFIED_CONSTRAINTS   (FunctorApply.Apply f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))@@ -38,16 +49,18 @@   => proxy f -> Laws applyLaws p = Laws "Apply"   [ ("LiftF2 part 1", applyLiftF2_1 p)+  , ("Associativity", applyAssociativity p)   ] -applyLiftF2_1 :: forall proxy f. -#if HAVE_QUANTIFIED_CONSTRAINTS-  (FunctorApply.Apply f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))-#else-  (FunctorApply.Apply f, Eq1 f, Show1 f, Arbitrary1 f)-#endif-  => proxy f -> Property+applyLiftF2_1 :: forall proxy f. ApplyProp proxy f applyLiftF2_1 _ = property $ \(Apply (f' :: f QuadraticEquation)) (Apply (x :: f Integer)) ->   let f = fmap runQuadraticEquation f'   in eq1 (FunctorApply.liftF2 id f x) (f FunctorApply.<.> x)++applyAssociativity :: forall proxy f. ApplyProp proxy f+applyAssociativity _ = property $ \(Apply (u' :: f QuadraticEquation)) (Apply (v' :: f QuadraticEquation)) (Apply (w :: f Integer)) ->+  let u = fmap runQuadraticEquation u'+      v = fmap runQuadraticEquation v'+   in eq1 (fmap (.) u FunctorApply.<.> v FunctorApply.<.> w) (u FunctorApply.<.> (v FunctorApply.<.> w))+ #endif
src/Test/QuickCheck/Classes/Common.hs view
@@ -15,6 +15,7 @@   , myForAllShrink   -- Modifiers   , SmallList(..)+  , VerySmallList(..)   , ShowReadPrecedence(..)    -- only used for higher-kinded types@@ -468,6 +469,16 @@     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
+ src/Test/QuickCheck/Classes/Contravariant.hs view
@@ -0,0 +1,74 @@+{-# 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.Common+#if HAVE_UNARY_LAWS+import Test.QuickCheck.Classes.Compat (eq1)+#endif++#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/Foldable.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}  #if HAVE_QUANTIFIED_CONSTRAINTS@@ -82,10 +83,10 @@ #endif   => proxy f -> Laws foldableLawsInternal p = Laws "Foldable"-  [ (,) "fold" $ property $ \(Apply (a :: f (SG.Sum Integer))) ->+  [ (,) "fold" $ property $ \(Apply (a :: f (VerySmallList Integer))) ->       F.fold a == F.foldMap id a   , (,) "foldMap" $ property $ \(Apply (a :: f Integer)) (e :: QuadraticEquation) ->-      let f = SG.Sum . runQuadraticEquation e+      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
+ 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.Common (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/MVector.hs view
@@ -34,9 +34,12 @@    , ("Write-Read", writeRead p)   , ("Set-Read", setRead p)+  , ("Sliced-Set-Read", slicedSetRead p)   , ("Replicate-Read", replicateRead p)    , ("Slice-Overlaps", sliceOverlaps p)+  , ("Slice-Copy", sliceCopy p)+  , ("Slice-Move", sliceMove p)    , ("Write-Copy-Read", writeCopyRead p)   , ("Write-Move-Read", writeMoveRead p)@@ -51,6 +54,12 @@   , ("Write-WriteAround-Read", writeWriteAroundRead p)   , ("Write-CopyAround-Read", writeCopyAroundRead p)   , ("Write-MoveAround-Read", writeMoveAroundRead p)++  , ("Write-InitializeBetween-Read", writeInitializeBetweenRead p)+  , ("Write-ClearBetween-Read", writeClearBetweenRead p)+  , ("Write-SetBetween-Read", writeSetBetweenRead p)+  , ("Write-CopyBetween-Read", writeCopyBetweenRead p)+  , ("Write-MoveBetween-Read", writeMoveBetweenRead p)   ]  -------------------------------------------------------------------------------@@ -91,6 +100,13 @@     MU.set arr a     MU.read arr ix +slicedSetRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+slicedSetRead _ = property $ \(a :: a) (NonNegative ix) (Positive excess) before after -> do+  (=== a) $ runST $ do+    arr <- newSlice before after (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@@ -112,6 +128,33 @@         slice2 = MU.slice j (l - j + 1) arr     pure $ MU.overlaps slice1 slice2 +sliceCopy :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+sliceCopy _ = property $ \(a :: a) (NonNegative i) (NonNegative ix) (Positive excess) (NonNegative ij) (NonNegative jk) -> do+  let j = i + ix + excess + ij+      k = j + ix + excess + jk+  runST $ do+    arr <- MU.new k :: ST s (MU.MVector s a)+    let src = MU.slice i (ix + excess) arr+        dst = MU.slice j (ix + excess) arr+    if MU.overlaps src dst then pure (property True) else do+      MU.write src ix a+      MU.copy dst src+      valSrc <- MU.read src ix+      valDst <- MU.read dst ix+      pure (valSrc === a .&&. valDst === a)++sliceMove :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+sliceMove _ = property $ \(a :: a) (NonNegative i) (NonNegative ix) (Positive excess) (NonNegative ij) (NonNegative jk) -> do+  let j = i + ix + excess + ij+      k = j + ix + excess + jk+  (=== a) $ runST $ do+    arr <- MU.new k :: ST s (MU.MVector s a)+    let src = MU.slice i (ix + excess) arr+        dst = MU.slice j (ix + excess) arr+    MU.write src ix a+    MU.move dst src+    MU.read dst ix+ ------------------------------------------------------------------------------- -- Write + copy/move/grow @@ -243,6 +286,56 @@     when (excess > 1) $       MU.move (MU.slice (ix + 1) (excess - 1) dst) (MU.slice (ix + 1) (excess - 1) src)     MU.read dst ix++-------------------------------------------------------------------------------+-- Two writes + overwrite in between++writeInitializeBetweenRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeInitializeBetweenRead _ = property $ \(a :: a) (b :: a) (NonNegative ix) (Positive dix) (Positive excess) -> do+  (=== (a, b)) $ runST $ do+    arr <- MU.new (ix + dix + excess)+    MU.write arr ix a+    MU.write arr (ix + dix) b+    MU.basicInitialize (MU.slice (ix + 1) (dix - 1) arr)+    (,) <$> MU.read arr ix <*> MU.read arr (ix + dix)++writeClearBetweenRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeClearBetweenRead _ = property $ \(a :: a) (b :: a) (NonNegative ix) (Positive dix) (Positive excess) -> do+  (=== (a, b)) $ runST $ do+    arr <- MU.new (ix + dix + excess)+    MU.write arr ix a+    MU.write arr (ix + dix) b+    MU.clear (MU.slice (ix + 1) (dix - 1) arr)+    (,) <$> MU.read arr ix <*> MU.read arr (ix + dix)++writeSetBetweenRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeSetBetweenRead _ = property $ \(a :: a) (b :: a) (c :: a) (NonNegative ix) (Positive dix) (Positive excess) -> do+  (=== (a, b)) $ runST $ do+    arr <- MU.new (ix + dix + excess)+    MU.write arr ix a+    MU.write arr (ix + dix) b+    MU.set (MU.slice (ix + 1) (dix - 1) arr) c+    (,) <$> MU.read arr ix <*> MU.read arr (ix + dix)++writeCopyBetweenRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeCopyBetweenRead _ = property $ \(a :: a) (b :: a) (NonNegative ix) (Positive dix) (Positive excess) -> do+  (=== (a, b)) $ runST $ do+    src <- MU.new (ix + dix + excess)+    dst <- MU.new (ix + dix + excess)+    MU.write dst ix a+    MU.write dst (ix + dix) b+    MU.copy (MU.slice (ix + 1) (dix - 1) dst) (MU.slice (ix + 1) (dix - 1) src)+    (,) <$> MU.read dst ix <*> MU.read dst (ix + dix)++writeMoveBetweenRead :: forall a. (Eq a, MU.Unbox a, Arbitrary a, Show a) => Proxy a -> Property+writeMoveBetweenRead _ = property $ \(a :: a) (b :: a) (NonNegative ix) (Positive dix) (Positive excess) -> do+  (=== (a, b)) $ runST $ do+    src <- MU.new (ix + dix + excess)+    dst <- MU.new (ix + dix + excess)+    MU.write dst ix a+    MU.write dst (ix + dix) b+    MU.move (MU.slice (ix + 1) (dix - 1) dst) (MU.slice (ix + 1) (dix - 1) src)+    (,) <$> MU.read dst ix <*> MU.read dst (ix + dix)  ------------------------------------------------------------------------------- -- Utils
src/Test/QuickCheck/Classes/Monoid.hs view
@@ -5,8 +5,10 @@ module Test.QuickCheck.Classes.Monoid   ( monoidLaws   , commutativeMonoidLaws+  , semigroupMonoidLaws   ) where +import Data.Semigroup import Data.Monoid import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.))@@ -43,6 +45,19 @@ 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)
test/Spec.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}  #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-}@@ -63,6 +64,7 @@ #if HAVE_UNARY_LAWS   , ("Maybe",allHigherLaws (Proxy1 :: Proxy1 Maybe))   , ("List",allHigherLaws (Proxy1 :: Proxy1 []))+  , ("BadList",allHigherLaws (Proxy1 :: Proxy1 BadList)) #endif #if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS) #if MIN_VERSION_base(4,9,0) && MIN_VERSION_containers(0,5,9)@@ -178,6 +180,17 @@   foldl' f x (Rogue xs) = F.foldl f x xs   foldr' f x (Rogue xs) = F.foldr f x xs #endif++newtype BadList a = BadList [a]+  deriving+  ( Eq, Show, Arbitrary+  , Arbitrary1, Eq1, Show1+  , Traversable, Functor, MonadZip, Monad, Applicative, MonadPlus, Alternative+  )++instance Foldable BadList where+  foldMap f (BadList xs) = F.foldMap f xs+  fold (BadList xs) = fold (reverse xs)  newtype Pound k v = Pound { getPound :: Map k v }   deriving