packages feed

quickcheck-classes 0.3.3 → 0.4.0

raw patch · 3 files changed

+442/−78 lines, 3 filesdep +bifunctorsdep +semigroupoidsdep +semigroupsdep −prim-arraydep ~basedep ~primitive

Dependencies added: bifunctors, semigroupoids, semigroups, tagged

Dependencies removed: prim-array

Dependency ranges changed: base, primitive

Files

quickcheck-classes.cabal view
@@ -1,5 +1,5 @@ name: quickcheck-classes-version: 0.3.3+version: 0.4.0 synopsis: QuickCheck common typeclasses description:   This library provides quickcheck properties to@@ -27,13 +27,16 @@   exposed-modules:     Test.QuickCheck.Classes   build-depends:-      base >= 4.7 && < 5+      base >= 4.5 && < 5+    , bifunctors      , QuickCheck >= 2.9     , transformers     , primitive >= 0.6.1-    , prim-array     , aeson     , containers+    , semigroups+    , tagged+    , semigroupoids    default-language: Haskell2010  test-suite test@@ -47,6 +50,8 @@     , primitive     , aeson     , vector+    , transformers+    , tagged   default-language: Haskell2010  source-repository head
src/Test/QuickCheck/Classes.hs view
@@ -3,8 +3,11 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}  {-# OPTIONS_GHC -Wall #-} @@ -35,54 +38,76 @@   , lawsCheckMany     -- * Properties     -- ** Ground Types-  , semigroupLaws-  , monoidLaws   , commutativeMonoidLaws   , eqLaws   , ordLaws   , showReadLaws   , jsonLaws-  , isListLaws+  , integralLaws+  , jsonLaws+  , monoidLaws+  , ordLaws   , primLaws+  , semigroupLaws+  , showReadLaws   , storableLaws   , integralLaws+#if MIN_VERSION_base(4,7,0)   , bitsLaws+  , isListLaws+#endif #if MIN_VERSION_QuickCheck(2,10,0)     -- ** Higher-Kinded Types-  , functorLaws+  , altLaws +  , alternativeLaws    , applicativeLaws-  , monadLaws+  , bifunctorLaws    , foldableLaws+  , functorLaws+  , monadLaws #endif     -- * Types   , Laws(..)   ) where -import Control.Applicative (liftA2)+import Data.Functor ((<$))+import Control.Applicative (liftA2,(<*>),pure,Applicative,(<$>),Alternative(..)) import Control.Monad.ST import Data.Aeson (FromJSON(..),ToJSON(..))+import Data.Bifunctor (Bifunctor(..)) import Data.Bits-import Data.Foldable (foldMap)+import Data.Foldable (foldMap,Foldable)+import Data.Monoid (Monoid,mconcat,mempty,mappend) import Data.Primitive hiding (sizeOf,newArray,copyArray) import Data.Primitive.Addr (Addr(..))-import Data.Primitive.PrimArray import Data.Proxy import Data.Semigroup (Semigroup)+import Data.Functor.Alt hiding (Apply) import Foreign.Marshal.Alloc import Foreign.Marshal.Array import Foreign.Storable-import GHC.Exts (IsList(fromList,toList,fromListN),Item)+import GHC.Exts (Int(I#),(*#),newByteArray#,unsafeFreezeByteArray#,+  copyMutableByteArray#,copyByteArray#,quotInt#,sizeofByteArray#) import GHC.Ptr (Ptr(..)) import System.IO.Unsafe import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property(..))-import Text.Read (readMaybe)+import Control.Monad.Primitive (PrimMonad,PrimState,primitive,primitive_) import qualified Data.Aeson as AE import qualified Data.Primitive as P import qualified Data.Semigroup as SG-import qualified GHC.OldList as L+import qualified Data.List as L import qualified Data.Set as S +#if MIN_VERSION_base(4,6,0)+import Text.Read (readMaybe)+#endif++#if MIN_VERSION_base(4,7,0)+import GHC.Exts (IsList(fromList,toList,fromListN),Item,+  copyByteArrayToAddr#,copyAddrToByteArray#)+#endif+ #if MIN_VERSION_QuickCheck(2,10,0) import Control.Exception (ErrorCall,try,evaluate) import Control.Monad (ap)@@ -135,20 +160,24 @@  data Status = Bad | Good +instance Semigroup Status where+  Good <> x = x+  Bad <> _ = Bad+ instance Monoid Status where   mempty = Good-  mappend Good x = x-  mappend Bad _ = Bad+  mappend = (SG.<>)  newtype Ap f a = Ap { getAp :: f a } -instance (Applicative f, Monoid a) => Monoid (Ap f a) where-  {-# INLINE mempty #-}+instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where+  Ap x <> Ap y = Ap $ liftA2 (SG.<>) x y++instance (Applicative f, Monoid a, Semigroup a) => Monoid (Ap f a) where   mempty = Ap $ pure mempty-  {-# INLINE mappend #-}-  mappend (Ap x) (Ap y) = Ap $ liftA2 mappend x y+  mappend = (SG.<>) -foldMapA :: (Foldable t, Monoid m, Applicative f) => (a -> f m) -> t a -> f m+foldMapA :: (Foldable t, Monoid m, Semigroup m, Applicative f) => (a -> f m) -> t a -> f m foldMapA f = getAp . foldMap (Ap . f)  -- | Tests the following properties:@@ -172,11 +201,16 @@ --   @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.+#if MIN_VERSION_base(4,7,0) 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)   ]+#endif  showReadLaws :: (Show a, Read a, Eq a, Arbitrary a) => Proxy a -> Laws showReadLaws p = Laws "Show/Read"@@ -214,14 +248,17 @@  -- | Tests the following properties: ----- [/Transitive/]+-- [/Antisymmetry/]+--   @a ≤ b ∧ b ≤ a ⇒ a = b  +-- [/Transitivity/] --   @a ≤ b ∧ b ≤ c ⇒ a ≤ c@--- [/Comparable/]+-- [/Totality/] --   @a ≤ b ∨ a > b@ ordLaws :: (Ord a, Arbitrary a, Show a) => Proxy a -> Laws ordLaws p = Laws "Ord"-  [ ("Transitive", ordTransitive p)-  , ("Comparable", ordComparable p)+  [ ("Antisymmetry", ordAntisymmetric p)+  , ("Transitivity", ordTransitive p)+  , ("Totality", ordTotal p)   ]  -- | Tests the following properties:@@ -257,7 +294,7 @@ -- [/Integer Roundtrip/] --   @fromInteger (toInteger x) ≡ x@ integralLaws :: (Integral a, Arbitrary a, Show a) => Proxy a -> Laws-integralLaws p = Laws "Monoid"+integralLaws p = Laws "Integral"   [ ("Quotient Remainder", integralQuotientRemainder p)   , ("Division Modulus", integralDivisionModulus p)   , ("Integer Roundtrip", integralIntegerRoundtrip p)@@ -285,10 +322,18 @@ --   @testBit zeroBits i ≡ False@ -- [/Pop Zero/] --   @popCount zeroBits ≡ 0@+-- [/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)@@ -301,7 +346,12 @@   , ("Set Zero", bitsSetZero p)   , ("Test Zero", bitsTestZero p)   , ("Pop Zero", bitsPopZero p)+#if MIN_VERSION_base(4,8,0)+  , ("Count Leading Zeros of Zero", bitsCountLeadingZeros p)+  , ("Count Trailing Zeros of Zero", bitsCountTrailingZeros p)+#endif   ]+#endif  -- | Test that a 'Prim' instance obey the several laws. primLaws :: (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws@@ -309,7 +359,9 @@   [ ("ByteArray Set-Get (you get back what you put in)", primSetGetByteArray p)   , ("ByteArray Get-Set (putting back what you got out has no effect)", primGetSetByteArray p)   , ("ByteArray Set-Set (setting twice is same as setting once)", primSetSetByteArray p)+#if MIN_VERSION_base(4,7,0)   , ("ByteArray List Conversion Roundtrips", primListByteArray p)+#endif   , ("Addr Set-Get (you get back what you put in)", primSetGetAddr p)   , ("Addr Get-Set (putting back what you got out has no effect)", primGetSetAddr p)   , ("Addr List Conversion Roundtrips", primListAddr p)@@ -322,6 +374,7 @@   , ("List Conversion Roundtrips", storableList p)   ] +#if MIN_VERSION_base(4,7,0) isListPartialIsomorphism :: forall a. (IsList a, Show a, Arbitrary a, Eq a) => Proxy a -> Property isListPartialIsomorphism _ = myForAllShrink False (const True)   (\(a :: a) -> ["a = " ++ show a])@@ -333,10 +386,15 @@ 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+#endif  showReadPartialIsomorphism :: forall a. (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property showReadPartialIsomorphism _ = property $ \(a :: a) ->+#if MIN_VERSION_base(4,6,0)   readMaybe (show a) == Just a+#else+  read (show a) == a+#endif  -- TODO: improve the quality of the error message if -- something does not pass this test.@@ -359,6 +417,12 @@     True -> a /= c     False -> True +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.@@ -374,8 +438,8 @@   (GT,EQ) -> a > c   (GT,GT) -> a > c -ordComparable :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property-ordComparable _ = property $ \(a :: a) b -> a > b || b >= a+--ordComparable :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property+--ordComparable _ = property $ \(a :: a) b -> a > b || b >= a  eqSymmetric :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property eqSymmetric _ = property $ \(a :: a) b -> case a == b of@@ -412,6 +476,7 @@   "a"   (\a -> a) +#if MIN_VERSION_base(4,7,0) bitsConjunctionIdempotence :: forall a. (Bits a, Arbitrary a, Show a) => Proxy a -> Property bitsConjunctionIdempotence _ = myForAllShrink False (const True)   (\(n :: a) -> ["n = " ++ show n])@@ -491,7 +556,26 @@   (\() -> popCount (zeroBits :: a))   "0"   (\() -> 0)+#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+ 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])@@ -524,9 +608,11 @@   "mappend b a"   (\(a,b) -> mappend b a) +#if MIN_VERSION_base(4,7,0) primListByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property primListByteArray _ = property $ \(as :: [a]) ->   as == toList (fromList as :: PrimArray a)+#endif  primListAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property primListAddr _ = property $ \(as :: [a]) -> unsafePerformIO $ do@@ -559,7 +645,7 @@  primGetSetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property primGetSetByteArray _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do-  let arr1 = fromList as :: PrimArray a+  let arr1 = primArrayFromList as :: PrimArray a       len = L.length as   ix <- choose (0,len - 1)   arr2 <- return $ runST $ do@@ -572,7 +658,7 @@  primSetSetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property primSetSetByteArray _ = property $ \(a :: a) (as :: [a]) -> (not (L.null as)) ==> do-  let arr1 = fromList as :: PrimArray a+  let arr1 = primArrayFromList as :: PrimArray a       len = L.length as   ix <- choose (0,len - 1)   (arr2,arr3) <- return $ runST $ do@@ -600,7 +686,7 @@  primGetSetAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property primGetSetAddr _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do-  let arr1 = fromList as :: PrimArray a+  let arr1 = primArrayFromList as :: PrimArray a       len = L.length as   ix <- choose (0,len - 1)   arr2 <- return $ unsafePerformIO $ do@@ -664,7 +750,7 @@     else return True  #if MIN_VERSION_QuickCheck(2,10,0)--- | Tests the following applicative properties:+-- | Tests the following functor properties: -- -- [/Identity/] --   @'fmap' 'id' ≡ 'id'@@@ -672,13 +758,26 @@ --   @fmap (f . g) ≡ 'fmap' f . 'fmap' g@ -- [/Const/] --   @(<$) ≡ 'fmap' 'const'@-functorLaws :: (Functor f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Laws+functorLaws :: (Functor f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Laws functorLaws p = Laws "Functor"   [ ("Identity", functorIdentity p)   , ("Composition", functorComposition p)   , ("Const", functorConst p)   ] +-- | Tests the following alternative properties:+--+-- [/Identity/]+--   @'empty' '<|>' x ≡ x@+--   @x '<|>' 'empty' ≡ x@+-- [/Associativity/]+--   @a '<|>' (b '<|>' c) ≡ (a '<|>' b) '<|>' c)@ +alternativeLaws :: (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Laws+alternativeLaws p = Laws "Alternative"+  [ ("Identity", alternativeIdentity p)+  , ("Associativity", alternativeAssociativity p)+  ]+ -- | Tests the following applicative properties: -- -- [/Identity/]@@ -691,7 +790,7 @@ --   @u '<*>' 'pure' y ≡ 'pure' ('$' y) '<*>' u@ -- [/LiftA2 (1)/] --   @('<*>') ≡ 'liftA2' 'id'@-applicativeLaws :: (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Laws+applicativeLaws :: (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Laws applicativeLaws p = Laws "Applicative"   [ ("Identity", applicativeIdentity p)   , ("Composition", applicativeComposition p)@@ -701,6 +800,17 @@     -- todo: liftA2 part 2, we need an equation of two variables for this   ] +-- | Tests the following alt properties:+--+-- [/Associativity/]+--   @(a '<!>' b) '<!>' c ≡ a '<!>' (b '<!>' c)@+-- [/Left Distributivity/]+--   @f '<$>' (a '<!>' b) = (f '<$>' a) '<!>' (f '<$>' b)+altLaws :: (Alt f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Laws+altLaws p = Laws "Alt"+  [ ("Associativity", altAssociative p)+  , ("Left Distributivity", altLeftDistributive p)+  ]  -- | Tests the following monadic properties: --@@ -714,7 +824,7 @@ --   @'pure' ≡ 'return'@ -- [/Ap/] --   @('<*>') ≡ 'ap'@-monadLaws :: (Monad f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Laws+monadLaws :: (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Laws monadLaws p = Laws "Monad"   [ ("Left Identity", monadLeftIdentity p)   , ("Right Identity", monadRightIdentity p)@@ -723,6 +833,24 @@   , ("Ap", monadAp p)   ] +-- | 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@ +bifunctorLaws :: (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) => proxy f -> Laws+bifunctorLaws p = Laws "Bifunctor"+  [ ("Identity", bifunctorIdentity p)+  , ("First Identity", bifunctorFirstIdentity p)+  , ("Second Identity", bifunctorSecondIdentity p)+  , ("Bifunctor Composition", bifunctorComposition p)+  ]+ -- | Tests the following 'Foldable' properties: -- -- [/fold/]@@ -746,33 +874,35 @@ -- -- Note that this checks to ensure that @foldl\'@ and @foldr\'@ -- are suitably strict.-foldableLaws :: (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Laws+foldableLaws :: (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Laws foldableLaws = foldableLawsInternal -foldableLawsInternal :: forall f. (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Laws+foldableLawsInternal :: forall proxy f. (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Laws foldableLawsInternal p = Laws "Foldable"   [ (,) "fold" $ property $ \(Apply (a :: f (SG.Sum Integer))) ->       F.fold a == F.foldMap id a   , (,) "foldMap" $ property $ \(Apply (a :: f Integer)) (e :: Equation) ->       let f = SG.Sum . runEquation e-       in foldMap f a == foldr (mappend . f) mempty a+       in F.foldMap f a == F.foldr (mappend . f) mempty a   , (,) "foldr" $ property $ \(e :: EquationTwo) (z :: Integer) (Apply (t :: f Integer)) ->       let f = runEquationTwo e-       in foldr f z t == SG.appEndo (foldMap (SG.Endo . f) t) z+       in F.foldr f z t == SG.appEndo (foldMap (SG.Endo . f) t) z   , (,) "foldr'" (foldableFoldr' p)   , (,) "foldl" $ property $ \(e :: EquationTwo) (z :: Integer) (Apply (t :: f Integer)) ->       let f = runEquationTwo e-       in foldl f z t == SG.appEndo (SG.getDual (foldMap (SG.Dual . SG.Endo . flip f) t)) z+       in F.foldl f z t == SG.appEndo (SG.getDual (F.foldMap (SG.Dual . SG.Endo . flip f) t)) z   , (,) "foldl'" (foldableFoldl' p)   , (,) "toList" $ property $ \(Apply (t :: f Integer)) ->-      eq1 (F.toList t) (foldr (:) [] t)+      eq1 (F.toList t) (F.foldr (:) [] t)+#if MIN_VERSION_base(4,8,0)   , (,) "null" $ property $ \(Apply (t :: f Integer)) ->-      null t == foldr (const (const False)) True t+      null t == F.foldr (const (const False)) True t   , (,) "length" $ property $ \(Apply (t :: f Integer)) ->-      length t == SG.getSum (foldMap (const (SG.Sum 1)) t)+      F.length t == SG.getSum (F.foldMap (const (SG.Sum 1)) t)+#endif   ] -foldableFoldl' :: forall f. (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property+foldableFoldl' :: forall proxy f. (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property foldableFoldl' _ = property $ \(_ :: ChooseSecond) (_ :: LastNothing) (Apply (xs :: f (Bottom Integer))) ->   monadicIO $ do     let f :: Integer -> Bottom Integer -> Integer@@ -795,7 +925,7 @@         Right i -> return (Just i)     return (r1 == r2) -foldableFoldr' :: forall f. (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property+foldableFoldr' :: forall proxy f. (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property foldableFoldr' _ = property $ \(_ :: ChooseFirst) (_ :: LastNothing) (Apply (xs :: f (Bottom Integer))) ->   monadicIO $ do     let f :: Bottom Integer -> Integer -> Integer@@ -865,11 +995,31 @@ maybeToBottom Nothing = BottomUndefined maybeToBottom (Just a) = BottomValue a -data Apply f a = Apply { getApply :: f a }+newtype Apply f a = Apply { getApply :: f a } +newtype Apply2 f a b = Apply2 { getApply2 :: f a b }+ instance (Eq1 f, Eq a) => Eq (Apply f a) where   Apply a == Apply b = eq1 a b +instance (Eq2 f, Eq a, Eq b) => Eq (Apply2 f a b) where+  Apply2 a == Apply2 b = eq2 a b++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.<>)++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++ data LinearEquation = LinearEquation   { _linearEquationLinear :: Integer   , _linearEquationConstant :: Integer@@ -944,7 +1094,7 @@ data EquationTwo = EquationTwo Integer Integer   deriving (Eq) --- This show instance is does not actually provide a+-- This show instance does not actually provide a -- way to create an EquationTwo. Instead, it makes it look -- like a lambda that takes two variables. instance Show EquationTwo where@@ -971,7 +1121,7 @@   arbitrary = fmap Apply arbitrary1   shrink = map Apply . shrink1 . getApply -functorIdentity :: forall f. (Functor f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property+functorIdentity :: forall proxy f. (Functor f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property functorIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (fmap id a) a  func1 :: Integer -> (Integer,Integer)@@ -980,62 +1130,89 @@ func2 :: (Integer,Integer) -> (Bool,Either Ordering Integer) func2 (a,b) = (odd a, if even a then Left (compare a b) else Right (b + 2)) -functorComposition :: forall f. (Functor f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property+functorComposition :: forall proxy f. (Functor f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property functorComposition _ = property $ \(Apply (a :: f Integer)) ->   eq1 (fmap func2 (fmap func1 a)) (fmap (func2 . func1) a) -functorConst :: forall f. (Functor f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property+functorConst :: forall proxy f. (Functor f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property functorConst _ = property $ \(Apply (a :: f Integer)) ->   eq1 (fmap (const 'X') a) ('X' <$ a) -applicativeIdentity :: forall f. (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property+altAssociative :: forall proxy f. (Alt f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property+altAssociative _ = property $ \(Apply (a :: f Integer)) (Apply (b :: f Integer)) (Apply (c :: f Integer)) -> eq1 ((a <!> b) <!> c) (a <!> (b <!> c))++altLeftDistributive :: forall proxy f. (Alt f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property+altLeftDistributive _ = property $ \(Apply (a :: f Integer)) (Apply (b :: f Integer)) -> eq1 (id <$> (a <!> b)) ((id <$> a) <!> (id <$> b))++alternativeIdentity :: forall proxy f. (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property+alternativeIdentity _ = property $ \(Apply (a :: f Integer)) -> (eq1 (empty <|> a) a) && (eq1 a (empty <|> a))++alternativeAssociativity :: forall proxy f. (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property+alternativeAssociativity _ = property $ \(Apply (a :: f Integer)) (Apply (b :: f Integer)) (Apply (c :: f Integer)) -> eq1 (a <|> (b <|> c)) ((a <|> b) <|> c)++applicativeIdentity :: forall proxy f. (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property applicativeIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (pure id <*> a) a -applicativeComposition :: forall f. (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property+applicativeComposition :: forall proxy f. (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property applicativeComposition _ = property $ \(Apply (u' :: f Equation)) (Apply (v' :: f Equation)) (Apply (w :: f Integer)) ->   let u = fmap runEquation u'       v = fmap runEquation v'    in eq1 (pure (.) <*> u <*> v <*> w) (u <*> (v <*> w)) -applicativeHomomorphism :: forall f. (Applicative f, Eq1 f, Show1 f) => Proxy f -> Property+applicativeHomomorphism :: forall proxy f. (Applicative f, Eq1 f, Show1 f) => proxy f -> Property applicativeHomomorphism _ = property $ \(e :: Equation) (a :: Integer) ->   let f = runEquation e    in eq1 (pure f <*> pure a) (pure (f a) :: f Integer) -applicativeInterchange :: forall f. (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property+applicativeInterchange :: forall proxy f. (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property applicativeInterchange _ = property $ \(Apply (u' :: f Equation)) (y :: Integer) ->   let u = fmap runEquation u'    in eq1 (u <*> pure y) (pure ($ y) <*> u) -applicativeLiftA2_1 :: forall f. (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property+applicativeLiftA2_1 :: forall proxy f. (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property applicativeLiftA2_1 _ = property $ \(Apply (f' :: f Equation)) (Apply (x :: f Integer)) ->    let f = fmap runEquation f'    in eq1 (liftA2 id f x) (f <*> x) -monadLeftIdentity :: forall f. (Monad f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property+monadLeftIdentity :: forall proxy f. (Monad f, Functor f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property monadLeftIdentity _ = property $ \(k' :: LinearEquationM f) (a :: Integer) ->    let k = runLinearEquationM k'    in eq1 (return a >>= k) (k a) -monadRightIdentity :: forall f. (Monad f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property+monadRightIdentity :: forall proxy f. (Monad f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property monadRightIdentity _ = property $ \(Apply (m :: f Integer)) ->    eq1 (m >>= return) m -monadAssociativity :: forall f. (Monad f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property+monadAssociativity :: forall proxy f. (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => 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 f. (Monad f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property+monadReturn :: forall proxy f. (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property monadReturn _ = property $ \(x :: Integer) ->   eq1 (return x) (pure x :: f Integer) -monadAp :: forall f. (Monad f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property+monadAp :: forall proxy f. (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) => proxy f -> Property monadAp _ = property $ \(Apply (f' :: f Equation)) (Apply (x :: f Integer)) ->    let f = fmap runEquation f'    in eq1 (ap f x) (f <*> x) +bifunctorIdentity :: forall proxy f. (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) => proxy f -> Property+bifunctorIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq2 (bimap id id x) x++bifunctorFirstIdentity :: forall proxy f. (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) => proxy f -> Property+bifunctorFirstIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq2 (first id x) x++bifunctorSecondIdentity :: forall proxy f. (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f) => proxy f -> Property+bifunctorSecondIdentity _ = property $ \(Apply2 (x :: f Integer Integer)) -> eq2 (second id x) x++bifunctorComposition+  :: forall proxy f.+     (Bifunctor f, Eq2 f, Show2 f, Arbitrary2 f)+  => proxy f -> Property+bifunctorComposition _ = property $ \(Apply2 (z :: f Integer Integer)) -> eq2 (bimap id id z) ((first id . second id) z)+ #endif  myForAllShrink :: (Arbitrary a, Show b, Eq b) => Bool -> (a -> Bool) -> (a -> [String]) -> String -> (a -> b) -> String -> (a -> b) -> Property@@ -1053,6 +1230,7 @@           err = description ++ "\n" ++ unlines (map ("  " ++) (showInputs x')) ++ "  " ++ name1 ++ " = " ++ sb1 ++ (if displayRhs then "\n  " ++ name2 ++ " = " ++ sb2 else "")        in isValid x' ==> counterexample err (b1 == b2) +#if MIN_VERSION_base(4,7,0) newtype BitIndex a = BitIndex Int  instance FiniteBits a => Arbitrary (BitIndex a) where@@ -1060,4 +1238,158 @@     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 []+#endif++-- byte array with phantom variable that specifies element type+data PrimArray a = PrimArray ByteArray#+data MutablePrimArray s a = MutablePrimArray (MutableByteArray# s)++instance (Eq a, Prim a) => Eq (PrimArray a) where+  a1 == a2 = sizeofPrimArray a1 == sizeofPrimArray a2 && loop (sizeofPrimArray a1 - 1)+    where +    loop !i | i < 0 = True+            | otherwise = indexPrimArray a1 i == indexPrimArray a2 i && loop (i-1)++#if MIN_VERSION_base(4,7,0)+instance Prim a => IsList (PrimArray a) where+  type Item (PrimArray a) = a+  fromList = primArrayFromList+  fromListN = primArrayFromListN+  toList = primArrayToList+#endif++indexPrimArray :: forall a. Prim a => PrimArray a -> Int -> a+indexPrimArray (PrimArray arr#) (I# i#) = indexByteArray# arr# i#++sizeofPrimArray :: forall a. Prim a => PrimArray a -> Int+sizeofPrimArray (PrimArray arr#) = I# (quotInt# (sizeofByteArray# arr#) (sizeOf# (undefined :: a)))++newPrimArray :: forall m a. (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a)+newPrimArray (I# n#)+  = primitive (\s# -> +      case newByteArray# (n# *# sizeOf# (undefined :: a)) s# of+        (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #)+    )++readPrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> m a+readPrimArray (MutablePrimArray arr#) (I# i#)+  = primitive (readByteArray# arr# i#)++writePrimArray ::+     (Prim a, PrimMonad m)+  => MutablePrimArray (PrimState m) a+  -> Int+  -> a+  -> m ()+writePrimArray (MutablePrimArray arr#) (I# i#) x+  = primitive_ (writeByteArray# arr# i# x)++unsafeFreezePrimArray+  :: PrimMonad m => MutablePrimArray (PrimState m) a -> m (PrimArray a)+unsafeFreezePrimArray (MutablePrimArray arr#)+  = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of+                        (# s'#, arr'# #) -> (# s'#, PrimArray arr'# #))+++copyPrimArrayToPtr :: forall m a. (PrimMonad m, Prim a)+  => Ptr a       -- ^ destination pointer+  -> PrimArray a -- ^ source array+  -> Int         -- ^ offset into source array+  -> Int         -- ^ number of prims to copy+  -> m ()+copyPrimArrayToPtr addr@(Ptr addr#) ba@(PrimArray ba#) soff@(I# soff#) n@(I# n#) =+#if MIN_VERSION_base(4,7,0)+  primitive (\ s# ->+      let s'# = copyByteArrayToAddr# ba# (soff# *# siz#) addr# (n# *# siz#) s#+      in (# s'#, () #))+  where siz# = sizeOf# (undefined :: a)+#else+  generateM_ n $ \ix -> writeOffAddr (ptrToAddr addr) ix (indexPrimArray ba (ix + soff))+#endif++ptrToAddr :: Ptr a -> Addr+ptrToAddr (Ptr x) = Addr x++generateM_ :: Monad m => Int -> (Int -> m a) -> m ()+generateM_ n f = go 0 where+  go !ix = if ix < n+    then f ix >> go (ix + 1)+    else return ()++copyPtrToMutablePrimArray :: forall m a. (PrimMonad m, Prim a)+  => MutablePrimArray (PrimState m) a+  -> Int+  -> Ptr a+  -> Int+  -> m ()+copyPtrToMutablePrimArray ba@(MutablePrimArray ba#) doff@(I# doff#) addr@(Ptr addr#) n@(I# n#) = +#if MIN_VERSION_base(4,7,0)+  primitive (\ s# ->+      let s'# = copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#) s#+      in (# s'#, () #))+  where siz# = sizeOf# (undefined :: a)+#else+  generateM_ n $ \ix -> do+    x <- readOffAddr (ptrToAddr addr) ix+    writePrimArray ba (doff + ix) x+#endif++copyMutablePrimArray :: forall m a.+     (PrimMonad m, Prim a)+  => MutablePrimArray (PrimState m) a -- ^ destination array+  -> Int -- ^ offset into destination array+  -> MutablePrimArray (PrimState m) a -- ^ source array+  -> Int -- ^ offset into source array+  -> Int -- ^ number of bytes to copy+  -> m ()+copyMutablePrimArray (MutablePrimArray dst#) (I# doff#) (MutablePrimArray src#) (I# soff#) (I# n#)+  = primitive_ (copyMutableByteArray#+      src# +      (soff# *# (sizeOf# (undefined :: a)))+      dst#+      (doff# *# (sizeOf# (undefined :: a)))+      (n# *# (sizeOf# (undefined :: a)))+    )++copyPrimArray :: forall m a.+     (PrimMonad m, Prim a)+  => MutablePrimArray (PrimState m) a -- ^ destination array+  -> Int -- ^ offset into destination array+  -> PrimArray a -- ^ source array+  -> Int -- ^ offset into source array+  -> Int -- ^ number of bytes to copy+  -> m ()+copyPrimArray (MutablePrimArray dst#) (I# doff#) (PrimArray src#) (I# soff#) (I# n#)+  = primitive_ (copyByteArray#+      src# +      (soff# *# (sizeOf# (undefined :: a)))+      dst#+      (doff# *# (sizeOf# (undefined :: a)))+      (n# *# (sizeOf# (undefined :: a)))+    )++primArrayFromList :: Prim a => [a] -> PrimArray a+primArrayFromList xs = primArrayFromListN (L.length xs) xs++primArrayFromListN :: forall a. Prim a => Int -> [a] -> PrimArray a+primArrayFromListN len vs = runST run where+  run :: forall s. ST s (PrimArray a)+  run = do+    arr <- newPrimArray len+    let go :: [a] -> Int -> ST s ()+        go !xs !ix = case xs of+          [] -> return ()+          a : as -> do+            writePrimArray arr ix a+            go as (ix + 1)+    go vs 0+    unsafeFreezePrimArray arr++primArrayToList :: forall a. Prim a => PrimArray a -> [a]+primArrayToList arr = go 0 where+  !len = sizeofPrimArray arr+  go :: Int -> [a]+  go !ix = if ix < len+    then indexPrimArray arr ix : go (ix + 1)+    else []
test/Spec.hs view
@@ -1,42 +1,63 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -import Test.QuickCheck-import Data.Proxy-import Data.Word-import Data.Int import Control.Monad-import Data.Primitive+import Control.Applicative+import Data.Aeson (ToJSON,FromJSON)+import Data.Bits import Data.Foldable-import Data.Monoid (Sum)-import Foreign.Storable import Data.Functor.Classes-import Data.Aeson (ToJSON,FromJSON)+import Data.Int+import Data.Monoid (Sum,Monoid,mappend,mconcat,mempty)+import Data.Primitive+import Data.Proxy import Data.Vector (Vector)-import Data.Bits (FiniteBits)+import Data.Word+import Foreign.Storable+import Test.QuickCheck  import qualified Data.Vector as V+import qualified Data.Foldable as F  import Test.QuickCheck.Classes  main :: IO () main = lawsCheckMany allPropsApplied +-- Only needed to make GHC 7.4 content.+data Proxy1 (f :: * -> *) = Proxy1+ allPropsApplied :: [(String,[Laws])] allPropsApplied =    [ ("Int",allLaws (Proxy :: Proxy Int))   , ("Int64",allLaws (Proxy :: Proxy Int64))   , ("Word",allLaws (Proxy :: Proxy Word)) #if MIN_VERSION_QuickCheck(2,10,0)-  , ("Maybe",allHigherLaws (Proxy :: Proxy Maybe))-  , ("List",allHigherLaws (Proxy :: Proxy []))+  , ("Maybe",allHigherLaws (Proxy1 :: Proxy1 Maybe))+  , ("List",allHigherLaws (Proxy1 :: Proxy1 [])) #endif+#if MIN_VERSION_base(4,7,0)   , ("Vector",[isListLaws (Proxy :: Proxy (Vector Word))])+#endif   ] -allLaws :: forall a. (FiniteBits a, Integral a, Prim a, Storable a, Ord a, Arbitrary a, Show a, Read a, ToJSON a, FromJSON a) => Proxy a -> [Laws]+allLaws :: forall a.+  ( Integral a+  , Prim a+  , Storable a+  , Ord a+  , Arbitrary a+  , Show a+  , Read a+  , ToJSON a+  , FromJSON a+#if MIN_VERSION_base(4,7,0)+  , FiniteBits a+#endif+  ) => Proxy a -> [Laws] allLaws p =    [ primLaws p   , storableLaws p@@ -46,14 +67,16 @@   , eqLaws p   , ordLaws p   , integralLaws p+#if MIN_VERSION_base(4,7,0)   , bitsLaws p+#endif   ]  foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b-foldlMapM f = foldlM (\b a -> fmap (mappend b) (f a)) mempty+foldlMapM f = foldlM (\b a -> liftM (mappend b) (f a)) mempty  #if MIN_VERSION_QuickCheck(2,10,0)-allHigherLaws :: (Foldable f, Monad f, Eq1 f, Arbitrary1 f, Show1 f) => Proxy f -> [Laws]+allHigherLaws :: (Foldable f, Monad f, Applicative f, Eq1 f, Arbitrary1 f, Show1 f) => proxy f -> [Laws] allHigherLaws p =    [ functorLaws p   , applicativeLaws p@@ -72,11 +95,15 @@   deriving (Eq,Show,Arbitrary,Eq1,Show1) #endif +-- Note: when using base < 4.6, the Rouge type does+-- not really test anything.  instance Foldable Rouge where-  foldMap f (Rouge xs) = foldMap f xs-  foldl f x (Rouge xs) = foldl f x xs-  foldl' f x (Rouge xs) = foldl f x xs-  foldr' f x (Rouge xs) = foldr f x xs+  foldMap f (Rouge xs) = F.foldMap f xs+  foldl f x (Rouge xs) = F.foldl f x xs+#if MIN_VERSION_base(4,6,0)+  foldl' f x (Rouge xs) = F.foldl f x xs+  foldr' f x (Rouge xs) = F.foldr f x xs+#endif  ------------------- -- Orphan Instances