quickcheck-classes 0.3.2 → 0.3.3
raw patch · 3 files changed
+188/−43 lines, 3 filesdep +containersdep ~QuickCheckdep ~primitive
Dependencies added: containers
Dependency ranges changed: QuickCheck, primitive
Files
- quickcheck-classes.cabal +4/−3
- src/Test/QuickCheck/Classes.hs +176/−38
- test/Spec.hs +8/−2
quickcheck-classes.cabal view
@@ -1,5 +1,5 @@ name: quickcheck-classes-version: 0.3.2+version: 0.3.3 synopsis: QuickCheck common typeclasses description: This library provides quickcheck properties to@@ -28,11 +28,12 @@ Test.QuickCheck.Classes build-depends: base >= 4.7 && < 5- , QuickCheck+ , QuickCheck >= 2.9 , transformers- , primitive+ , primitive >= 0.6.1 , prim-array , aeson+ , containers default-language: Haskell2010 test-suite test
src/Test/QuickCheck/Classes.hs view
@@ -46,6 +46,7 @@ , primLaws , storableLaws , integralLaws+ , bitsLaws #if MIN_VERSION_QuickCheck(2,10,0) -- ** Higher-Kinded Types , functorLaws@@ -57,38 +58,39 @@ , Laws(..) ) where -import Test.QuickCheck-import Test.QuickCheck.Monadic (monadicIO)-import Test.QuickCheck.Property (Property(..))+import Control.Applicative (liftA2)+import Control.Monad.ST+import Data.Aeson (FromJSON(..),ToJSON(..))+import Data.Bits+import Data.Foldable (foldMap) import Data.Primitive hiding (sizeOf,newArray,copyArray)+import Data.Primitive.Addr (Addr(..)) import Data.Primitive.PrimArray import Data.Proxy-import Control.Monad.ST-import Control.Monad-import Data.Monoid (Endo(..),Sum(..),Dual(..))-import GHC.Ptr (Ptr(..))-import Data.Primitive.Addr (Addr(..))-import Foreign.Marshal.Alloc-import System.IO.Unsafe import Data.Semigroup (Semigroup)-import GHC.Exts (IsList(fromList,toList,fromListN),Item)+import Foreign.Marshal.Alloc import Foreign.Marshal.Array import Foreign.Storable+import GHC.Exts (IsList(fromList,toList,fromListN),Item)+import GHC.Ptr (Ptr(..))+import System.IO.Unsafe+import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Property (Property(..)) import Text.Read (readMaybe)-import Data.Aeson (FromJSON(..),ToJSON(..))-import Data.Functor.Classes-import Control.Applicative-import Data.Foldable (foldlM,fold,foldMap,foldl',foldr')-import Control.Exception (ErrorCall,evaluate,try)-import Control.Monad.Trans.Class (lift)-import qualified Data.Foldable as F 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.Set as S #if MIN_VERSION_QuickCheck(2,10,0)+import Control.Exception (ErrorCall,try,evaluate)+import Control.Monad (ap)+import Control.Monad.Trans.Class (lift)+import Data.Functor.Classes import Test.QuickCheck.Arbitrary (Arbitrary1(..))+import Test.QuickCheck.Monadic (monadicIO)+import qualified Data.Foldable as F #endif -- | A set of laws associated with a typeclass.@@ -104,7 +106,7 @@ -- integrate multiple properties into larger test suite. lawsCheck :: Laws -> IO () lawsCheck (Laws className properties) = do- flip foldlMapM properties $ \(name,p) -> do+ flip foldMapA properties $ \(name,p) -> do putStr (className ++ ": " ++ name ++ " ") quickCheck p @@ -115,12 +117,12 @@ -> IO () lawsCheckMany xs = do putStrLn "Testing properties for common typeclasses"- r <- flip foldlMapM xs $ \(typeName,laws) -> do+ r <- flip foldMapA xs $ \(typeName,laws) -> do putStrLn $ "------------" putStrLn $ "-- " ++ typeName putStrLn $ "------------"- flip foldlMapM laws $ \(Laws typeClassName properties) -> do- flip foldlMapM properties $ \(name,p) -> do+ flip foldMapA laws $ \(Laws typeClassName properties) -> do+ flip foldMapA properties $ \(name,p) -> do putStr (typeClassName ++ ": " ++ name ++ " ") r <- quickCheckResult p return $ case r of@@ -138,9 +140,17 @@ mappend Good x = x mappend Bad _ = Bad -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+newtype Ap f a = Ap { getAp :: f a } +instance (Applicative f, Monoid a) => Monoid (Ap f a) where+ {-# INLINE mempty #-}+ mempty = Ap $ pure mempty+ {-# INLINE mappend #-}+ mappend (Ap x) (Ap y) = Ap $ liftA2 mappend x y++foldMapA :: (Foldable t, Monoid m, Applicative f) => (a -> f m) -> t a -> f m+foldMapA f = getAp . foldMap (Ap . f)+ -- | Tests the following properties: -- -- [/Partial Isomorphism/]@@ -253,6 +263,46 @@ , ("Integer Roundtrip", integralIntegerRoundtrip p) ] +-- | 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@+--+-- All of the useful instances of the 'Bits' typeclass+-- also have 'FiniteBits' instances, so these property+-- tests actually require that instance as well.+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)+ ]+ -- | Test that a 'Prim' instance obey the several laws. primLaws :: (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws primLaws p = Laws "Prim"@@ -362,6 +412,86 @@ "a" (\a -> a) +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. (Bits a, Arbitrary a, Show a) => Proxy a -> Property+bitsClearZero _ = myForAllShrink False (const True)+ (\(n :: a) -> ["n = " ++ show n])+ "complement (complement n)"+ (\n -> complement (complement n))+ "n"+ (\n -> n)++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)+ 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])@@ -621,25 +751,25 @@ foldableLawsInternal :: forall f. (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Laws foldableLawsInternal p = Laws "Foldable"- [ (,) "fold" $ property $ \(Apply (a :: f (Sum Integer))) ->- fold a == foldMap id a+ [ (,) "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 = Sum . runEquation e+ let f = SG.Sum . runEquation e in foldMap f a == foldr (mappend . f) mempty a , (,) "foldr" $ property $ \(e :: EquationTwo) (z :: Integer) (Apply (t :: f Integer)) -> let f = runEquationTwo e- in foldr f z t == appEndo (foldMap (Endo . f) t) z+ in 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 == appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z+ in foldl f z t == SG.appEndo (SG.getDual (foldMap (SG.Dual . SG.Endo . flip f) t)) z , (,) "foldl'" (foldableFoldl' p) , (,) "toList" $ property $ \(Apply (t :: f Integer)) -> eq1 (F.toList t) (foldr (:) [] t) , (,) "null" $ property $ \(Apply (t :: f Integer)) -> null t == foldr (const (const False)) True t , (,) "length" $ property $ \(Apply (t :: f Integer)) ->- length t == getSum (foldMap (const (Sum 1)) t)+ length t == SG.getSum (foldMap (const (SG.Sum 1)) t) ] foldableFoldl' :: forall f. (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) => Proxy f -> Property@@ -654,12 +784,12 @@ z0 = 0 r1 <- lift $ do let f' x k z = k $! f z x- e <- try (evaluate (foldr f' id xs z0))+ 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 (foldl' f z0 xs))+ e <- try (evaluate (F.foldl' f z0 xs)) case e of Left (_ :: ErrorCall) -> return Nothing Right i -> return (Just i)@@ -677,12 +807,12 @@ z0 = 0 r1 <- lift $ do let f' k x z = k $! f x z- e <- try (evaluate (foldl f' id xs z0))+ 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 (foldr' f z0 xs))+ e <- try (evaluate (F.foldr' f z0 xs)) case e of Left (_ :: ErrorCall) -> return Nothing Right i -> return (Just i)@@ -762,10 +892,10 @@ showLinear _ (LinearEquation a b) = shows a . showString " * x + " . shows b showLinearList :: [LinearEquation] -> ShowS-showLinearList xs = appEndo $ mconcat- $ [Endo (showChar '[')]- ++ L.intersperse (Endo (showChar ',')) (map (Endo . showLinear 0) xs)- ++ [Endo (showChar ']')]+showLinearList xs = SG.appEndo $ mconcat+ $ [SG.Endo (showChar '[')]+ ++ L.intersperse (SG.Endo (showChar ',')) (map (SG.Endo . showLinear 0) xs)+ ++ [SG.Endo (showChar ']')] instance Show1 m => Show (LinearEquationM m) where show (LinearEquationM a b) = (\f -> f "")@@ -922,4 +1052,12 @@ 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)++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 []
test/Spec.hs view
@@ -15,6 +15,7 @@ import Data.Functor.Classes import Data.Aeson (ToJSON,FromJSON) import Data.Vector (Vector)+import Data.Bits (FiniteBits) import qualified Data.Vector as V @@ -35,7 +36,7 @@ , ("Vector",[isListLaws (Proxy :: Proxy (Vector Word))]) ] -allLaws :: forall 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. (FiniteBits a, Integral a, Prim a, Storable a, Ord a, Arbitrary a, Show a, Read a, ToJSON a, FromJSON a) => Proxy a -> [Laws] allLaws p = [ primLaws p , storableLaws p@@ -45,6 +46,7 @@ , eqLaws p , ordLaws p , integralLaws p+ , bitsLaws p ] foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b@@ -60,11 +62,15 @@ ] #endif --- This type is fails the laws for the strict functions+-- This type fails the laws for the strict functions -- in Foldable. It is used just to confirm that -- those property tests actually work. newtype Rouge a = Rouge [a]+#if MIN_VERSION_QuickCheck(2,10,0) deriving (Eq,Show,Arbitrary,Arbitrary1,Eq1,Show1)+#else+ deriving (Eq,Show,Arbitrary,Eq1,Show1)+#endif instance Foldable Rouge where foldMap f (Rouge xs) = foldMap f xs