packages feed

primitive 0.7.0.1 → 0.7.1.0

raw patch · 37 files changed

+871/−3181 lines, 37 filesdep +deepseqdep +quickcheck-classes-basedep ~QuickCheckdep ~basedep ~ghc-primnew-uploader

Dependencies added: deepseq, quickcheck-classes-base

Dependency ranges changed: QuickCheck, base, ghc-prim

Files

Control/Monad/Primitive.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP, MagicHash, UnboxedTuples, TypeFamilies #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}  -- |@@ -17,6 +18,8 @@ module Control.Monad.Primitive (   PrimMonad(..), RealWorld, primitive_,   PrimBase(..),+  MonadPrim,+  MonadPrimBase,   liftPrim, primToPrim, primToIO, primToST, ioToPrim, stToPrim,   unsafePrimToPrim, unsafePrimToIO, unsafePrimToST, unsafeIOToPrim,   unsafeSTToPrim, unsafeInlinePrim, unsafeInlineIO, unsafeInlineST,@@ -28,6 +31,8 @@ import GHC.IO     ( IO(..) ) import GHC.ST     ( ST(..) ) +import qualified Control.Monad.ST.Lazy as L+ import Control.Monad.Trans.Class (lift) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid)@@ -208,6 +213,35 @@   internal (ST p) = p   {-# INLINE internal #-} +-- see https://gitlab.haskell.org/ghc/ghc/commit/2f5cb3d44d05e581b75a47fec222577dfa7a533e+-- for why we only support an instance for ghc >= 8.2+#if __GLASGOW_HASKELL__ >= 802+-- @since 0.7.1.0+instance PrimMonad (L.ST s) where+  type PrimState (L.ST s) = s+  primitive = L.strictToLazyST . primitive+  {-# INLINE primitive #-}++-- @since 0.7.1.0+instance PrimBase (L.ST s) where+  internal = internal . L.lazyToStrictST+  {-# INLINE internal #-}+#endif++-- | 'PrimMonad''s state token type can be annoying to handle+--   in constraints. This typeclass lets users (visually) notice+--   'PrimState' equality constraints less, by witnessing that+--   @s ~ 'PrimState' m@.+class (PrimMonad m, s ~ PrimState m) => MonadPrim s m+instance (PrimMonad m, s ~ PrimState m) => MonadPrim s m++-- | 'PrimBase''s state token type can be annoying to handle+--   in constraints. This typeclass lets users (visually) notice+--   'PrimState' equality constraints less, by witnessing that+--   @s ~ 'PrimState' m@.+class (PrimBase m, MonadPrim s m) => MonadPrimBase s m+instance (PrimBase m, MonadPrim s m) => MonadPrimBase s m+ -- | Lifts a 'PrimBase' into another 'PrimMonad' with the same underlying state -- token type. liftPrim@@ -278,14 +312,23 @@ {-# INLINE unsafeIOToPrim #-} unsafeIOToPrim = unsafePrimToPrim +-- | See 'unsafeInlineIO'. This function is not recommended for the same+-- reasons. unsafeInlinePrim :: PrimBase m => m a -> a {-# INLINE unsafeInlinePrim #-} unsafeInlinePrim m = unsafeInlineIO (unsafePrimToIO m) +-- | Generally, do not use this function. It is the same as+-- @accursedUnutterablePerformIO@ from @bytestring@ and is well behaved under+-- narrow conditions. See the documentation of that function to get an idea+-- of when this is sound. In most cases @GHC.IO.Unsafe.unsafeDupablePerformIO@+-- should be preferred. unsafeInlineIO :: IO a -> a {-# INLINE unsafeInlineIO #-} unsafeInlineIO m = case internal m realWorld# of (# _, r #) -> r +-- | See 'unsafeInlineIO'. This function is not recommended for the same+-- reasons. Prefer @runST@ when @s@ is free. unsafeInlineST :: ST s a -> a {-# INLINE unsafeInlineST #-} unsafeInlineST = unsafeInlinePrim
Data/Primitive/Array.hs view
@@ -23,11 +23,14 @@   cloneArray, cloneMutableArray,   sizeofArray, sizeofMutableArray,   fromListN, fromList,+  arrayFromListN, arrayFromList,   mapArray',   traverseArrayP ) where +import Control.DeepSeq import Control.Monad.Primitive+import Data.Data (mkNoRepType)  import GHC.Base  ( Int(..) ) import GHC.Exts@@ -42,7 +45,7 @@ import Data.Typeable ( Typeable ) import Data.Data   (Data(..), DataType, mkDataType, Constr, mkConstr, Fixity(..), constrIndex)-import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType )+import Data.Primitive.Internal.Compat ( isTrue# )  import Control.Monad.ST(ST,runST) @@ -50,6 +53,7 @@ import Control.Monad (MonadPlus(..), when) import qualified Control.Monad.Fail as Fail import Control.Monad.Fix+import qualified Data.Foldable as Foldable #if MIN_VERSION_base(4,4,0) import Control.Monad.Zip #endif@@ -87,6 +91,14 @@   { array# :: Array# a }   deriving ( Typeable ) +#if MIN_VERSION_deepseq(1,4,3)+instance NFData1 Array where+  liftRnf r = Foldable.foldl' (\_ -> r) ()+#endif++instance NFData a => NFData (Array a) where+  rnf = Foldable.foldl' (\_ -> rnf) ()+ -- | Mutable boxed arrays associated with a primitive state token. data MutableArray s a = MutableArray   { marray# :: MutableArray# s a }@@ -102,6 +114,8 @@  -- | Create a new mutable array of the specified size and initialise all -- elements with the given value.+--+-- /Note:/ this function does not check if the input is non-negative. newArray :: PrimMonad m => Int -> a -> m (MutableArray (PrimState m) a) {-# INLINE newArray #-} newArray (I# n#) x = primitive@@ -111,16 +125,22 @@                in (# s'# , ma #))  -- | Read a value from the array at the given index.+--+-- /Note:/ this function does not do bounds checking. readArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> m a {-# INLINE readArray #-} readArray arr (I# i#) = primitive (readArray# (marray# arr) i#)  -- | Write a value to the array at the given index.+--+-- /Note:/ this function does not do bounds checking. writeArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> a -> m () {-# INLINE writeArray #-} writeArray arr (I# i#) x = primitive_ (writeArray# (marray# arr) i# x)  -- | Read a value from the immutable array at the given index.+--+-- /Note:/ this function does not do bounds checking. indexArray :: Array a -> Int -> a {-# INLINE indexArray #-} indexArray arr (I# i#) = case indexArray# (array# arr) i# of (# x #) -> x@@ -128,6 +148,8 @@ -- | Read a value from the immutable array at the given index, returning -- the result in an unboxed unary tuple. This is currently used to implement -- folds.+--+-- /Note:/ this function does not do bounds checking. indexArray## :: Array a -> Int -> (# a #) indexArray## arr (I# i) = indexArray# (array# arr) i {-# INLINE indexArray## #-}@@ -155,6 +177,7 @@ -- Now, indexing is executed immediately although the returned element is -- still not evaluated. --+-- /Note:/ this function does not do bounds checking. indexArrayM :: Monad m => Array a -> Int -> m a {-# INLINE indexArrayM #-} indexArrayM arr (I# i#)@@ -217,6 +240,8 @@   = isTrue# (sameMutableArray# (marray# arr) (marray# brr))  -- | Copy a slice of an immutable array to a mutable array.+--+-- /Note:/ this function does not do bounds or overlap checking. copyArray :: PrimMonad m           => MutableArray (PrimState m) a    -- ^ destination array           -> Int                             -- ^ offset into destination array@@ -243,8 +268,10 @@ -- not be the same when using this library with GHC versions 7.6 and older. -- In GHC 7.8 and newer, overlapping arrays will behave correctly. ----- Note: The order of arguments is different from that of 'copyMutableArray#'. The primop+-- /Note:/ The order of arguments is different from that of 'copyMutableArray#'. The primop -- has the source first while this wrapper has the destination first.+--+-- /Note:/ this function does not do bounds or overlap checking. copyMutableArray :: PrimMonad m           => MutableArray (PrimState m) a    -- ^ destination array           -> Int                             -- ^ offset into destination array@@ -269,7 +296,9 @@ #endif  -- | Return a newly allocated Array with the specified subrange of the--- provided Array. The provided Array should contain the full subrange+-- provided Array.+--+-- /Note:/ The provided Array should contain the full subrange -- specified by the two Ints, but this is not checked. cloneArray :: Array a -- ^ source array            -> Int     -- ^ offset into destination array@@ -282,6 +311,9 @@ -- | Return a newly allocated MutableArray. with the specified subrange of -- the provided MutableArray. The provided MutableArray should contain the -- full subrange specified by the two Ints, but this is not checked.+--+-- /Note:/ The provided Array should contain the full subrange+-- specified by the two Ints, but this is not checked. cloneMutableArray :: PrimMonad m         => MutableArray (PrimState m) a -- ^ source array         -> Int                          -- ^ offset into destination array@@ -334,6 +366,8 @@   f mary   pure mary +-- |+-- Execute the monadic action(s) and freeze the resulting array. runArray   :: (forall s. ST s (MutableArray s a))   -> Array a@@ -590,6 +624,8 @@      in go 0 {-# INLINE mapArray' #-} +-- | Create an array from a list of a known length. If the length+--   of the list does not match the given length, this throws an exception. arrayFromListN :: Int -> [a] -> Array a arrayFromListN n l =   createArray n (die "fromListN" "uninitialized element") $ \sma ->@@ -603,6 +639,7 @@           else die "fromListN" "list length greater than specified size"     in go 0 l +-- | Create an array from a list. arrayFromList :: [a] -> Array a arrayFromList l = arrayFromListN (length l) l
Data/Primitive/ByteArray.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, UnliftedFFITypes, DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}  -- | -- Module      : Data.Primitive.ByteArray@@ -10,8 +11,11 @@ -- Maintainer  : Roman Leshchinskiy <rl@cse.unsw.edu.au> -- Portability : non-portable ----- Primitive operations on ByteArrays---+-- Primitive operations on byte arrays. Most functions in this module include+-- an element type in their type signature and interpret the unit for offsets+-- and lengths as that element. A few functions (e.g. 'copyByteArray',+-- 'freezeByteArray') do not include an element type. Such functions+-- interpret offsets and lengths as units of 8-bit words.  module Data.Primitive.ByteArray (   -- * Types@@ -20,6 +24,9 @@   -- * Allocation   newByteArray, newPinnedByteArray, newAlignedPinnedByteArray,   resizeMutableByteArray,+#if __GLASGOW_HASKELL__ >= 710+  shrinkMutableByteArray,+#endif    -- * Element access   readByteArray, writeByteArray, indexByteArray,@@ -30,16 +37,22 @@   -- * Folding   foldrByteArray, +  -- * Comparing+  compareByteArrays,+   -- * Freezing and thawing+  freezeByteArray,   unsafeFreezeByteArray, unsafeThawByteArray,    -- * Block operations   copyByteArray, copyMutableByteArray, #if __GLASGOW_HASKELL__ >= 708+  copyByteArrayToPtr, copyMutableByteArrayToPtr,   copyByteArrayToAddr, copyMutableByteArrayToAddr, #endif   moveByteArray,   setByteArray, fillByteArray,+  cloneByteArray, cloneMutableByteArray,    -- * Information   sizeofByteArray,@@ -53,8 +66,12 @@  import Control.Monad.Primitive import Control.Monad.ST+import Control.DeepSeq+import Data.Data (mkNoRepType) import Data.Primitive.Types +import qualified GHC.ST as GHCST+ import Foreign.C.Types import Data.Word ( Word8 ) import GHC.Base ( Int(..) )@@ -68,7 +85,7 @@  import Data.Typeable ( Typeable ) import Data.Data ( Data(..) )-import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType )+import Data.Primitive.Internal.Compat ( isTrue# ) import Numeric  #if MIN_VERSION_base(4,9,0)@@ -97,7 +114,15 @@ data MutableByteArray s = MutableByteArray (MutableByteArray# s)                                         deriving( Typeable ) +instance NFData ByteArray where+  rnf (ByteArray _) = ()++instance NFData (MutableByteArray s) where+  rnf (MutableByteArray _) = ()+ -- | Create a new mutable byte array of the specified size in bytes.+--+-- /Note:/ this function does not check if the input is non-negative. newByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m)) {-# INLINE newByteArray #-} newByteArray (I# n#)@@ -106,6 +131,8 @@  -- | Create a /pinned/ byte array of the specified size in bytes. The garbage -- collector is guaranteed not to move it.+--+-- /Note:/ this function does not check if the input is non-negative. newPinnedByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m)) {-# INLINE newPinnedByteArray #-} newPinnedByteArray (I# n#)@@ -114,6 +141,8 @@  -- | Create a /pinned/ byte array of the specified size in bytes and with the -- given alignment. The garbage collector is guaranteed not to move it.+--+-- /Note:/ this function does not check if the input is non-negative. newAlignedPinnedByteArray   :: PrimMonad m   => Int  -- ^ size@@ -186,6 +215,23 @@   = return (sizeofMutableByteArray arr) #endif +-- | Create an immutable copy of a slice of a byte array. The offset and+-- length are given in bytes.+--+-- This operation makes a copy of the specified section, so it is safe to+-- continue using the mutable array afterward.+freezeByteArray+  :: PrimMonad m+  => MutableByteArray (PrimState m) -- ^ source+  -> Int                            -- ^ offset in bytes+  -> Int                            -- ^ length in bytes+  -> m ByteArray+{-# INLINE freezeByteArray #-}+freezeByteArray !src !off !len = do+  dst <- newByteArray len+  copyMutableByteArray dst 0 src off len+  unsafeFreezeByteArray dst+ -- | Convert a mutable byte array to an immutable one without copying. The -- array should not be modified after the conversion. unsafeFreezeByteArray@@ -217,6 +263,23 @@ {-# INLINE sizeofMutableByteArray #-} sizeofMutableByteArray (MutableByteArray arr#) = I# (sizeofMutableByteArray# arr#) +-- Although it is possible to shim resizeMutableByteArray for old GHCs, this+-- is not the case with shrinkMutableByteArray.+#if __GLASGOW_HASKELL__ >= 710+-- | Shrink a mutable byte array. The new size is given in bytes.+-- It must be smaller than the old size. The array will be resized in place.+-- This function is only available when compiling with GHC 7.10 or newer.+--+-- @since 0.7.1.0+shrinkMutableByteArray :: PrimMonad m+  => MutableByteArray (PrimState m)+  -> Int -- ^ new size+  -> m ()+{-# INLINE shrinkMutableByteArray #-}+shrinkMutableByteArray (MutableByteArray arr#) (I# n#)+  = primitive_ (shrinkMutableByteArray# arr# n#)+#endif+ #if __GLASGOW_HASKELL__ >= 802 -- | Check whether or not the byte array is pinned. Pinned byte arrays cannot --   be moved by the garbage collector. It is safe to use 'byteArrayContents'@@ -239,12 +302,16 @@  -- | Read a primitive value from the byte array. The offset is given in -- elements of type @a@ rather than in bytes.+--+-- /Note:/ this function does not do bounds checking. indexByteArray :: Prim a => ByteArray -> Int -> a {-# INLINE indexByteArray #-} indexByteArray (ByteArray arr#) (I# i#) = indexByteArray# arr# i#  -- | Read a primitive value from the byte array. The offset is given in -- elements of type @a@ rather than in bytes.+--+-- /Note:/ this function does not do bounds checking. readByteArray   :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> m a {-# INLINE readByteArray #-}@@ -253,6 +320,8 @@  -- | Write a primitive value to the byte array. The offset is given in -- elements of type @a@ rather than in bytes.+--+-- /Note:/ this function does not do bounds checking. writeByteArray   :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> a -> m () {-# INLINE writeByteArray #-}@@ -269,9 +338,14 @@       | otherwise = z     maxI = sizeofByteArray arr `quot` sizeOf (undefined :: a) +-- | Create a 'ByteArray' from a list.+--+-- @byteArrayFromList xs = `byteArrayFromListN` (length xs) xs@ byteArrayFromList :: Prim a => [a] -> ByteArray byteArrayFromList xs = byteArrayFromListN (length xs) xs +-- | Create a 'ByteArray' from a list of a known length. If the length+--   of the list does not match the given length, this throws an exception. byteArrayFromListN :: Prim a => Int -> [a] -> ByteArray byteArrayFromListN n ys = runST $ do     marr <- newByteArray (n * sizeOf (head ys))@@ -290,6 +364,8 @@ unI# (I# n#) = n#  -- | Copy a slice of an immutable byte array to a mutable byte array.+--+-- /Note:/ this function does not do bounds or overlap checking. copyByteArray   :: PrimMonad m => MutableByteArray (PrimState m)                                         -- ^ destination array@@ -304,6 +380,8 @@  -- | Copy a slice of a mutable byte array into another array. The two slices -- may not overlap.+--+-- /Note:/ this function does not do bounds or overlap checking. copyMutableByteArray   :: PrimMonad m => MutableByteArray (PrimState m)                                         -- ^ destination array@@ -319,10 +397,57 @@   = primitive_ (copyMutableByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz))  #if __GLASGOW_HASKELL__ >= 708+-- | Copy a slice of a byte array to an unmanaged Pointer Address. These must not+--   overlap. The offset and length given in elements, not in bytes. This function+--   is only available when compiling with GHC 7.8 or newer.+--+--   /Note:/ this function does not do bounds or overlap checking.+--+--   @since 0.7.1.0+copyByteArrayToPtr+  :: forall m a. (PrimMonad m, Prim a)+  => Ptr a -- ^ destination+  -> ByteArray -- ^ source array+  -> Int -- ^ offset into source array, interpreted as elements of type @a@+  -> Int -- ^ number of elements to copy+  -> m ()+{-# INLINE copyByteArrayToPtr #-}+copyByteArrayToPtr (Ptr dst#) (ByteArray src#) soff sz+  = primitive_ (copyByteArrayToAddr# src# (unI# soff *# siz# ) dst# (unI# sz))+  where+  siz# = sizeOf# (undefined :: a)++-- | Copy a slice of a mutable byte array to an unmanaged Pointer address.+--   These must not overlap. The offset and length given in elements, not+--   in bytes. This function is only available when compiling with GHC 7.8+--   or newer.+--+--   /Note:/ this function does not do bounds or overlap checking.+--+--   @since 0.7.1.0+copyMutableByteArrayToPtr+  :: forall m a. (PrimMonad m, Prim a)+  => Ptr a -- ^ destination+  -> MutableByteArray (PrimState m) -- ^ source array+  -> Int -- ^ offset into source array, interpreted as elements of type @a@+  -> Int -- ^ number of elements to copy+  -> m ()+{-# INLINE copyMutableByteArrayToPtr #-}+copyMutableByteArrayToPtr (Ptr dst#) (MutableByteArray src#) soff sz+  = primitive_ (copyMutableByteArrayToAddr# src# (unI# soff *# siz# ) dst# (unI# sz))+  where+  siz# = sizeOf# (undefined :: a)++------+--- These latter two should be DEPRECATED+-----+ -- | Copy a slice of a byte array to an unmanaged address. These must not --   overlap. This function is only available when compiling with GHC 7.8 --   or newer. --+--   Note: This function is just 'copyByteArrayToPtr' where @a@ is 'Word8'.+-- --   @since 0.6.4.0 copyByteArrayToAddr   :: PrimMonad m@@ -339,6 +464,8 @@ --   not overlap. This function is only available when compiling with GHC 7.8 --   or newer. --+--   Note: This function is just 'copyMutableByteArrayToPtr' where @a@ is 'Word8'.+-- --   @since 0.6.4.0 copyMutableByteArrayToAddr   :: PrimMonad m@@ -372,6 +499,8 @@  -- | Fill a slice of a mutable byte array with a value. The offset and length -- are given in elements of type @a@ rather than in bytes.+--+-- /Note:/ this function does not do bounds checking. setByteArray   :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -- ^ array to fill                            -> Int                 -- ^ offset into array@@ -383,6 +512,8 @@   = primitive_ (setByteArray# dst# doff# sz# x)  -- | Fill a slice of a mutable byte array with a byte.+--+-- /Note:/ this function does not do bounds checking. fillByteArray   :: PrimMonad m => MutableByteArray (PrimState m)                                         -- ^ array to fill@@ -394,10 +525,13 @@ fillByteArray = setByteArray  foreign import ccall unsafe "primitive-memops.h hsprimitive_memmove"-  memmove_mba :: MutableByteArray# s -> CInt-              -> MutableByteArray# s -> CInt+  memmove_mba :: MutableByteArray# s -> CPtrdiff+              -> MutableByteArray# s -> CPtrdiff               -> CSize -> IO () +instance Eq (MutableByteArray s) where+  (==) = sameMutableByteArray+ instance Data ByteArray where   toConstr _ = error "toConstr"   gunfold _ _ = error "gunfold"@@ -421,15 +555,16 @@                 | otherwise = showString ", "  -compareByteArrays :: ByteArray -> ByteArray -> Int -> Ordering-{-# INLINE compareByteArrays #-}+-- Only used internally+compareByteArraysFromBeginning :: ByteArray -> ByteArray -> Int -> Ordering+{-# INLINE compareByteArraysFromBeginning #-} #if __GLASGOW_HASKELL__ >= 804-compareByteArrays (ByteArray ba1#) (ByteArray ba2#) (I# n#) =-  compare (I# (compareByteArrays# ba1# 0# ba2# 0# n#)) 0+compareByteArraysFromBeginning (ByteArray ba1#) (ByteArray ba2#) (I# n#)+  = compare (I# (compareByteArrays# ba1# 0# ba2# 0# n#)) 0 #else -- Emulate GHC 8.4's 'GHC.Prim.compareByteArrays#'-compareByteArrays (ByteArray ba1#) (ByteArray ba2#) (I# n#)-    = compare (fromCInt (unsafeDupablePerformIO (memcmp_ba ba1# ba2# n))) 0+compareByteArraysFromBeginning (ByteArray ba1#) (ByteArray ba2#) (I# n#)+  = compare (fromCInt (unsafeDupablePerformIO (memcmp_ba ba1# ba2# n))) 0   where     n = fromIntegral (I# n#) :: CSize     fromCInt = fromIntegral :: CInt -> Int@@ -438,7 +573,32 @@   memcmp_ba :: ByteArray# -> ByteArray# -> CSize -> IO CInt #endif +-- | Lexicographic comparison of equal-length slices into two byte arrays.+-- This wraps the @compareByteArrays#@ primop, which wraps @memcmp@.+compareByteArrays ::+     ByteArray -- ^ Array A+  -> Int -- ^ Offset A, given in bytes+  -> ByteArray -- ^ Array B+  -> Int -- ^ Offset B, given in bytes+  -> Int -- ^ Length of slice, given in bytes+  -> Ordering+{-# INLINE compareByteArrays #-}+#if __GLASGOW_HASKELL__ >= 804+compareByteArrays (ByteArray ba1#) (I# off1#) (ByteArray ba2#) (I# off2#) (I# n#)+  = compare (I# (compareByteArrays# ba1# off1# ba2# off2# n#)) 0+#else+-- Emulate GHC 8.4's 'GHC.Prim.compareByteArrays#'+compareByteArrays (ByteArray ba1#) (I# off1#) (ByteArray ba2#) (I# off2#) (I# n#)+  = compare (fromCInt (unsafeDupablePerformIO (memcmp_ba_offs ba1# off1# ba2# off2# n))) 0+  where+    n = fromIntegral (I# n#) :: CSize+    fromCInt = fromIntegral :: CInt -> Int +foreign import ccall unsafe "primitive-memops.h hsprimitive_memcmp_offset"+  memcmp_ba_offs :: ByteArray# -> Int# -> ByteArray# -> Int# -> CSize -> IO CInt+#endif++ sameByteArray :: ByteArray# -> ByteArray# -> Bool sameByteArray ba1 ba2 =     case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of@@ -454,7 +614,7 @@   ba1@(ByteArray ba1#) == ba2@(ByteArray ba2#)     | sameByteArray ba1# ba2# = True     | n1 /= n2 = False-    | otherwise = compareByteArrays ba1 ba2 n1 == EQ+    | otherwise = compareByteArraysFromBeginning ba1 ba2 n1 == EQ     where       n1 = sizeofByteArray ba1       n2 = sizeofByteArray ba2@@ -468,7 +628,7 @@   ba1@(ByteArray ba1#) `compare` ba2@(ByteArray ba2#)     | sameByteArray ba1# ba2# = EQ     | n1 /= n2 = n1 `compare` n2-    | otherwise = compareByteArrays ba1 ba2 n1+    | otherwise = compareByteArraysFromBeginning ba1 ba2 n1     where       n1 = sizeofByteArray ba1       n2 = sizeofByteArray ba2@@ -548,3 +708,52 @@ die :: String -> String -> a die fun problem = error $ "Data.Primitive.ByteArray." ++ fun ++ ": " ++ problem +-- | Return a newly allocated array with the specified subrange of the+-- provided array. The provided array should contain the full subrange+-- specified by the two Ints, but this is not checked.+cloneByteArray ::+     ByteArray -- ^ source array+  -> Int       -- ^ offset into destination array+  -> Int       -- ^ number of bytes to copy+  -> ByteArray+{-# INLINE cloneByteArray #-}+cloneByteArray src off n = runByteArray $ do+  dst <- newByteArray n+  copyByteArray dst 0 src off n+  return dst++-- | Return a newly allocated mutable array with the specified subrange of+-- the provided mutable array. The provided mutable array should contain the+-- full subrange specified by the two Ints, but this is not checked.+cloneMutableByteArray :: PrimMonad m+  => MutableByteArray (PrimState m) -- ^ source array+  -> Int -- ^ offset into destination array+  -> Int -- ^ number of bytes to copy+  -> m (MutableByteArray (PrimState m))+{-# INLINE cloneMutableByteArray #-}+cloneMutableByteArray src off n = do+  dst <- newByteArray n+  copyMutableByteArray dst 0 src off n+  return dst++#if MIN_VERSION_base(4,10,0) /* In new GHCs, runRW# is available. */+runByteArray+  :: (forall s. ST s (MutableByteArray s))+  -> ByteArray+runByteArray m = ByteArray (runByteArray# m)++runByteArray#+  :: (forall s. ST s (MutableByteArray s))+  -> ByteArray#+runByteArray# m = case runRW# $ \s ->+  case unST m s of { (# s', MutableByteArray mary# #) ->+  unsafeFreezeByteArray# mary# s'} of (# _, ary# #) -> ary#++unST :: ST s a -> State# s -> (# State# s, a #)+unST (GHCST.ST f) = f+#else /* In older GHCs, runRW# is not available. */+runByteArray+  :: (forall s. ST s (MutableByteArray s))+  -> ByteArray+runByteArray m = runST $ m >>= unsafeFreezeByteArray+#endif
Data/Primitive/Internal/Compat.hs view
@@ -13,23 +13,10 @@  module Data.Primitive.Internal.Compat (     isTrue#-  , mkNoRepType   ) where -#if MIN_VERSION_base(4,2,0)-import Data.Data (mkNoRepType)-#else-import Data.Data (mkNorepType)-#endif- #if MIN_VERSION_base(4,7,0) import GHC.Exts (isTrue#)-#endif----#if !MIN_VERSION_base(4,2,0)-mkNoRepType = mkNorepType #endif  #if !MIN_VERSION_base(4,7,0)
Data/Primitive/PrimArray.hs view
@@ -31,6 +31,8 @@   , MutablePrimArray(..)     -- * Allocation   , newPrimArray+  , newPinnedPrimArray+  , newAlignedPinnedPrimArray   , resizeMutablePrimArray #if __GLASGOW_HASKELL__ >= 710   , shrinkMutablePrimArray@@ -40,6 +42,7 @@   , writePrimArray   , indexPrimArray     -- * Freezing and Thawing+  , freezePrimArray   , unsafeFreezePrimArray   , unsafeThawPrimArray     -- * Block Operations@@ -49,12 +52,20 @@   , copyPrimArrayToPtr   , copyMutablePrimArrayToPtr #endif+  , clonePrimArray+  , cloneMutablePrimArray   , setPrimArray     -- * Information   , sameMutablePrimArray   , getSizeofMutablePrimArray   , sizeofMutablePrimArray   , sizeofPrimArray+  , primArrayContents+  , mutablePrimArrayContents+#if __GLASGOW_HASKELL__ >= 802+  , isPrimArrayPinned+  , isMutablePrimArrayPinned+#endif     -- * List Conversion   , primArrayToList   , primArrayFromList@@ -100,11 +111,13 @@ import Data.Primitive.ByteArray (ByteArray(..)) import Data.Monoid (Monoid(..),(<>)) import Control.Applicative+import Control.DeepSeq import Control.Monad.Primitive import Control.Monad.ST import qualified Data.List as L import qualified Data.Primitive.ByteArray as PB import qualified Data.Primitive.Types as PT+import qualified GHC.ST as GHCST  #if MIN_VERSION_base(4,7,0) import GHC.Exts (IsList(..))@@ -115,6 +128,10 @@ import qualified Data.Semigroup as SG #endif +#if __GLASGOW_HASKELL__ >= 802+import qualified GHC.Exts as Exts+#endif+ -- | Arrays of unboxed elements. This accepts types like 'Double', 'Char', -- 'Int', and 'Word', as well as their fixed-length variants ('Word8', -- 'Word16', etc.). Since the elements are unboxed, a 'PrimArray' is strict@@ -122,6 +139,9 @@ -- in its elements. data PrimArray a = PrimArray ByteArray# +instance NFData (PrimArray a) where+  rnf (PrimArray _) = ()+ -- | Mutable primitive arrays associated with a primitive state token. -- These can be written to and read from in a monadic context that supports -- sequencing such as 'IO' or 'ST'. Typically, a mutable primitive array will@@ -131,6 +151,12 @@ -- garbage collected when no longer referenced. data MutablePrimArray s a = MutablePrimArray (MutableByteArray# s) +instance Eq (MutablePrimArray s a) where+  (==) = sameMutablePrimArray++instance NFData (MutablePrimArray s a) where+  rnf (MutablePrimArray _) = ()+ sameByteArray :: ByteArray# -> ByteArray# -> Bool sameByteArray ba1 ba2 =     case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of@@ -192,9 +218,14 @@ die :: String -> String -> a die fun problem = error $ "Data.Primitive.PrimArray." ++ fun ++ ": " ++ problem +-- | Create a 'PrimArray' from a list.+--+-- @primArrayFromList vs = `byteArrayFromListN` (length vs) vs@ primArrayFromList :: Prim a => [a] -> PrimArray a primArrayFromList vs = primArrayFromListN (L.length vs) vs +-- | Create a 'PrimArray' from a list of a known length. If the length+--   of the list does not match the given length, this throws an exception. primArrayFromListN :: forall a. Prim a => Int -> [a] -> PrimArray a primArrayFromListN len vs = runST run where   run :: forall s. ST s (PrimArray a)@@ -248,6 +279,8 @@  -- | Create a new mutable primitive array of the given length. The -- underlying memory is left uninitialized.+--+-- /Note:/ this function does not check if the input is non-negative. newPrimArray :: forall m a. (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a) {-# INLINE newPrimArray #-} newPrimArray (I# n#)@@ -297,12 +330,17 @@   = primitive_ (shrinkMutableByteArray# arr# (n# *# sizeOf# (undefined :: a))) #endif +-- | Read a value from the array at the given index.+--+-- /Note:/ this function does not do bounds checking. readPrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> m a {-# INLINE readPrimArray #-} readPrimArray (MutablePrimArray arr#) (I# i#)   = primitive (readByteArray# arr# i#)  -- | Write an element to the given index.+--+-- /Note:/ this function does not do bounds checking. writePrimArray ::      (Prim a, PrimMonad m)   => MutablePrimArray (PrimState m) a -- ^ array@@ -316,6 +354,8 @@ -- | Copy part of a mutable array into another mutable array. --   In the case that the destination and --   source arrays are the same, the regions may overlap.+--+-- /Note:/ this function does not do bounds or overlap checking. copyMutablePrimArray :: forall m a.      (PrimMonad m, Prim a)   => MutablePrimArray (PrimState m) a -- ^ destination array@@ -335,6 +375,8 @@     )  -- | Copy part of an array into another mutable array.+--+-- /Note:/ this function does not do bounds or overlap checking. copyPrimArray :: forall m a.      (PrimMonad m, Prim a)   => MutablePrimArray (PrimState m) a -- ^ destination array@@ -359,6 +401,8 @@ --   This function assumes that the 'Prim' instance of @a@ --   agrees with the 'Storable' instance. This function is only --   available when building with GHC 7.8 or newer.+--+-- /Note:/ this function does not do bounds or overlap checking. copyPrimArrayToPtr :: forall m a. (PrimMonad m, Prim a)   => Ptr a -- ^ destination pointer   -> PrimArray a -- ^ source array@@ -377,6 +421,8 @@ --   This function assumes that the 'Prim' instance of @a@ --   agrees with the 'Storable' instance. This function is only --   available when building with GHC 7.8 or newer.+--+-- /Note:/ this function does not do bounds or overlap checking. copyMutablePrimArrayToPtr :: forall m a. (PrimMonad m, Prim a)   => Ptr a -- ^ destination pointer   -> MutablePrimArray (PrimState m) a -- ^ source array@@ -392,6 +438,8 @@ #endif  -- | Fill a slice of a mutable primitive array with a value.+--+-- /Note:/ this function does not do bounds checking. setPrimArray   :: (Prim a, PrimMonad m)   => MutablePrimArray (PrimState m) a -- ^ array to fill@@ -437,6 +485,23 @@ sameMutablePrimArray (MutablePrimArray arr#) (MutablePrimArray brr#)   = isTrue# (sameMutableByteArray# arr# brr#) +-- | Create an immutable copy of a slice of a primitive array. The offset and+-- length are given in elements.+--+-- This operation makes a copy of the specified section, so it is safe to+-- continue using the mutable array afterward.+freezePrimArray+  :: (PrimMonad m, Prim a)+  => MutablePrimArray (PrimState m) a -- ^ source+  -> Int                              -- ^ offset in elements+  -> Int                              -- ^ length in elements+  -> m (PrimArray a)+{-# INLINE freezePrimArray #-}+freezePrimArray !src !off !len = do+  dst <- newPrimArray len+  copyMutablePrimArray dst 0 src off len+  unsafeFreezePrimArray dst+ -- | Convert a mutable byte array to an immutable one without copying. The -- array should not be modified after the conversion. unsafeFreezePrimArray@@ -455,6 +520,8 @@   = primitive (\s# -> (# s#, MutablePrimArray (unsafeCoerce# arr#) #))  -- | Read a primitive value from the primitive array.+--+-- /Note:/ this function does not do bounds checking. indexPrimArray :: forall a. Prim a => PrimArray a -> Int -> a {-# INLINE indexPrimArray #-} indexPrimArray (PrimArray arr#) (I# i#) = indexByteArray# arr# i#@@ -464,6 +531,26 @@ {-# INLINE sizeofPrimArray #-} sizeofPrimArray (PrimArray arr#) = I# (quotInt# (sizeofByteArray# arr#) (sizeOf# (undefined :: a))) +#if __GLASGOW_HASKELL__ >= 802+-- | Check whether or not the byte array is pinned. Pinned primitive arrays cannot+--   be moved by the garbage collector. It is safe to use 'primArrayContents'+--   on such byte arrays. This function is only available when compiling with+--   GHC 8.2 or newer.+--+--   @since 0.7.1.0+isPrimArrayPinned :: PrimArray a -> Bool+{-# INLINE isPrimArrayPinned #-}+isPrimArrayPinned (PrimArray arr#) = isTrue# (Exts.isByteArrayPinned# arr#)++-- | Check whether or not the mutable primitive array is pinned. This function is+--   only available when compiling with GHC 8.2 or newer.+--+--   @since 0.7.1.0+isMutablePrimArrayPinned :: MutablePrimArray s a -> Bool+{-# INLINE isMutablePrimArrayPinned #-}+isMutablePrimArrayPinned (MutablePrimArray marr#) = isTrue# (Exts.isMutableByteArrayPinned# marr#)+#endif+ -- | Lazy right-associated fold over the elements of a 'PrimArray'. {-# INLINE foldrPrimArray #-} foldrPrimArray :: forall a b. Prim a => (a -> b -> b) -> b -> PrimArray a -> b@@ -965,4 +1052,94 @@ documentation of the @Data.Primitive@ module. -} +-- | Create a /pinned/ primitive array of the specified size in elements. The garbage+-- collector is guaranteed not to move it.+--+-- @since 0.7.1.0+newPinnedPrimArray :: forall m a. (PrimMonad m, Prim a)+  => Int -> m (MutablePrimArray (PrimState m) a)+{-# INLINE newPinnedPrimArray #-}+newPinnedPrimArray (I# n#)+  = primitive (\s# -> case newPinnedByteArray# (n# *# sizeOf# (undefined :: a)) s# of+                        (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #)) +-- | Create a /pinned/ primitive array of the specified size in elements and+-- with the alignment given by its 'Prim' instance. The garbage collector is+-- guaranteed not to move it.+--+-- @since 0.7.0.0+newAlignedPinnedPrimArray :: forall m a. (PrimMonad m, Prim a)+  => Int -> m (MutablePrimArray (PrimState m) a)+{-# INLINE newAlignedPinnedPrimArray #-}+newAlignedPinnedPrimArray (I# n#)+  = primitive (\s# -> case newAlignedPinnedByteArray# (n# *# sizeOf# (undefined :: a)) (alignment# (undefined :: a)) s# of+                        (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #))++-- | Yield a pointer to the array's data. This operation is only safe on+-- /pinned/ prim arrays allocated by 'newPinnedByteArray' or+-- 'newAlignedPinnedByteArray'.+--+-- @since 0.7.1.0+primArrayContents :: PrimArray a -> Ptr a+{-# INLINE primArrayContents #-}+primArrayContents (PrimArray arr#) = Ptr (byteArrayContents# arr#)++-- | Yield a pointer to the array's data. This operation is only safe on+-- /pinned/ byte arrays allocated by 'newPinnedByteArray' or+-- 'newAlignedPinnedByteArray'.+--+-- @since 0.7.1.0+mutablePrimArrayContents :: MutablePrimArray s a -> Ptr a+{-# INLINE mutablePrimArrayContents #-}+mutablePrimArrayContents (MutablePrimArray arr#)+  = Ptr (byteArrayContents# (unsafeCoerce# arr#))++-- | Return a newly allocated array with the specified subrange of the+-- provided array. The provided array should contain the full subrange+-- specified by the two Ints, but this is not checked.+clonePrimArray :: Prim a+  => PrimArray a -- ^ source array+  -> Int     -- ^ offset into destination array+  -> Int     -- ^ number of elements to copy+  -> PrimArray a+{-# INLINE clonePrimArray #-}+clonePrimArray src off n = runPrimArray $ do+  dst <- newPrimArray n+  copyPrimArray dst 0 src off n+  return dst++-- | Return a newly allocated mutable array with the specified subrange of+-- the provided mutable array. The provided mutable array should contain the+-- full subrange specified by the two Ints, but this is not checked.+cloneMutablePrimArray :: (PrimMonad m, Prim a)+  => MutablePrimArray (PrimState m) a -- ^ source array+  -> Int -- ^ offset into destination array+  -> Int -- ^ number of elements to copy+  -> m (MutablePrimArray (PrimState m) a)+{-# INLINE cloneMutablePrimArray #-}+cloneMutablePrimArray src off n = do+  dst <- newPrimArray n+  copyMutablePrimArray dst 0 src off n+  return dst++#if MIN_VERSION_base(4,10,0) /* In new GHCs, runRW# is available. */+runPrimArray+  :: (forall s. ST s (MutablePrimArray s a))+  -> PrimArray a+runPrimArray m = PrimArray (runPrimArray# m)++runPrimArray#+  :: (forall s. ST s (MutablePrimArray s a))+  -> ByteArray#+runPrimArray# m = case runRW# $ \s ->+  case unST m s of { (# s', MutablePrimArray mary# #) ->+  unsafeFreezeByteArray# mary# s'} of (# _, ary# #) -> ary#++unST :: ST s a -> State# s -> (# State# s, a #)+unST (GHCST.ST f) = f+#else /* In older GHCs, runRW# is not available. */+runPrimArray+  :: (forall s. ST s (MutablePrimArray s a))+  -> PrimArray a+runPrimArray m = runST $ m >>= unsafeFreezePrimArray+#endif
Data/Primitive/Ptr.hs view
@@ -30,6 +30,7 @@  #if __GLASGOW_HASKELL__ >= 708   , copyPtrToMutablePrimArray+  , copyPtrToMutableByteArray #endif ) where @@ -37,6 +38,7 @@ import Data.Primitive.Types #if __GLASGOW_HASKELL__ >= 708 import Data.Primitive.PrimArray (MutablePrimArray(..))+import Data.Primitive.ByteArray (MutableByteArray(..)) #endif  import GHC.Base ( Int(..) )@@ -119,6 +121,22 @@   -> m () {-# INLINE copyPtrToMutablePrimArray #-} copyPtrToMutablePrimArray (MutablePrimArray ba#) (I# doff#) (Ptr addr#) (I# n#) =+  primitive_ (copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#))+  where+  siz# = sizeOf# (undefined :: a)++-- | Copy from a pointer to a mutable byte array.+-- The offset and length are given in elements of type @a@.+-- This function is only available when building with GHC 7.8+-- or newer.+copyPtrToMutableByteArray :: forall m a. (PrimMonad m, Prim a)+  => MutableByteArray (PrimState m) -- ^ destination array+  -> Int   -- ^ destination offset given in elements of type @a@+  -> Ptr a -- ^ source pointer+  -> Int   -- ^ number of elements+  -> m ()+{-# INLINE copyPtrToMutableByteArray #-}+copyPtrToMutableByteArray (MutableByteArray ba#) (I# doff#) (Ptr addr#) (I# n#) =   primitive_ (copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#))   where   siz# = sizeOf# (undefined :: a)
Data/Primitive/SmallArray.hs view
@@ -56,6 +56,9 @@   , unsafeThawSmallArray   , sizeofSmallArray   , sizeofSmallMutableArray+#if MIN_VERSION_base(4,14,0)+  , shrinkSmallMutableArray+#endif   , smallArrayFromList   , smallArrayFromListN   , mapSmallArray'@@ -73,6 +76,7 @@ #endif  import Control.Applicative+import Control.DeepSeq import Control.Monad import qualified Control.Monad.Fail as Fail import Control.Monad.Fix@@ -125,6 +129,10 @@   , MonadZip   , MonadFix   , Monoid+  , NFData+#if MIN_VERSION_deepseq(1,4,3)+  , NFData1+#endif   , Typeable #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)   , Eq1@@ -144,6 +152,16 @@ #endif  #if HAVE_SMALL_ARRAY+#if MIN_VERSION_deepseq(1,4,3)+instance NFData1 SmallArray where+  liftRnf r = foldl' (\_ -> r) ()+#endif++instance NFData a => NFData (SmallArray a) where+  rnf = foldl' (\_ -> rnf) ()+#endif++#if HAVE_SMALL_ARRAY data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a)   deriving Typeable #else@@ -152,6 +170,8 @@ #endif  -- | Create a new small mutable array.+--+-- /Note:/ this function does not check if the input is non-negative. newSmallArray   :: PrimMonad m   => Int -- ^ size@@ -167,6 +187,8 @@ {-# INLINE newSmallArray #-}  -- | Read the element at a given index in a mutable array.+--+-- /Note:/ this function does not do bounds checking. readSmallArray   :: PrimMonad m   => SmallMutableArray (PrimState m) a -- ^ array@@ -181,6 +203,8 @@ {-# INLINE readSmallArray #-}  -- | Write an element at the given idex in a mutable array.+--+-- /Note:/ this function does not do bounds checking. writeSmallArray   :: PrimMonad m   => SmallMutableArray (PrimState m) a -- ^ array@@ -218,6 +242,8 @@ -- -- Note that 'Identity' is not adequate for this use, as it is a newtype, and -- cannot be evaluated without evaluating the element.+--+-- /Note:/ this function does not do bounds checking. indexSmallArrayM   :: Monad m   => SmallArray a -- ^ array@@ -233,6 +259,8 @@ {-# INLINE indexSmallArrayM #-}  -- | Look up an element in an immutable array.+--+-- /Note:/ this function does not do bounds checking. indexSmallArray   :: SmallArray a -- ^ array   -> Int          -- ^ index@@ -256,6 +284,9 @@ {-# INLINE indexSmallArray## #-}  -- | Create a copy of a slice of an immutable array.+--+-- /Note:/ The provided Array should contain the full subrange+-- specified by the two Ints, but this is not checked. cloneSmallArray   :: SmallArray a -- ^ source   -> Int          -- ^ offset@@ -270,6 +301,9 @@ {-# INLINE cloneSmallArray #-}  -- | Create a copy of a slice of a mutable array.+--+-- /Note:/ The provided Array should contain the full subrange+-- specified by the two Ints, but this is not checked. cloneSmallMutableArray   :: PrimMonad m   => SmallMutableArray (PrimState m) a -- ^ source@@ -355,6 +389,8 @@ {-# INLINE unsafeThawSmallArray #-}  -- | Copy a slice of an immutable array into a mutable array.+--+-- /Note:/ this function does not do bounds or overlap checking. copySmallArray   :: PrimMonad m   => SmallMutableArray (PrimState m) a -- ^ destination@@ -373,6 +409,8 @@ {-# INLINE copySmallArray #-}  -- | Copy a slice of one mutable array into another.+--+-- /Note:/ this function does not do bounds or overlap checking. copySmallMutableArray   :: PrimMonad m   => SmallMutableArray (PrimState m) a -- ^ destination@@ -971,3 +1009,17 @@ -- | Create a 'SmallArray' from a list. smallArrayFromList :: [a] -> SmallArray a smallArrayFromList l = smallArrayFromListN (length l) l++#if MIN_VERSION_base(4,14,0)+-- | Shrink the mutable array in place. The size given must be equal to+-- or less than the current size of the array. This is not checked.+shrinkSmallMutableArray :: PrimMonad m+  => SmallMutableArray (PrimState m) a+  -> Int+  -> m ()+{-# inline shrinkSmallMutableArray #-}+shrinkSmallMutableArray (SmallMutableArray x) (I# n) = primitive+  (\s0 -> case GHC.Exts.shrinkSmallMutableArray# x n s0 of+    s1 -> (# s1, () #)+  )+#endif
Data/Primitive/Types.hs view
@@ -29,6 +29,8 @@ import Control.Monad.Primitive import Data.Primitive.MachDeps import Data.Primitive.Internal.Operations+import Foreign.Ptr (IntPtr,intPtrToPtr,ptrToIntPtr)+import Foreign.Ptr (WordPtr,wordPtrToPtr,ptrToWordPtr) import Foreign.C.Types import System.Posix.Types @@ -64,6 +66,12 @@  import qualified Foreign.Storable as FS +#if __GLASGOW_HASKELL__ >= 710+import GHC.IO (IO(..))+import qualified GHC.Exts+#endif++ import Control.Applicative (Const(..)) #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity(..))@@ -242,6 +250,20 @@ ; {-# INLINE setOffAddr# #-}                                    \ } +#if __GLASGOW_HASKELL__ >= 710+liberate# :: State# s -> State# r+liberate# = unsafeCoerce#+shimmedSetWord8Array# :: MutableByteArray# s -> Int -> Int -> Word# -> IO ()+shimmedSetWord8Array# m (I# off) (I# len) w = IO (\s -> (# liberate# (GHC.Exts.setByteArray# m off len (GHC.Exts.word2Int# w) (liberate# s)), () #))+shimmedSetInt8Array# :: MutableByteArray# s -> Int -> Int -> Int# -> IO ()+shimmedSetInt8Array# m (I# off) (I# len) i = IO (\s -> (# liberate# (GHC.Exts.setByteArray# m off len i (liberate# s)), () #))+#else+shimmedSetWord8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO ()+shimmedSetWord8Array# = setWord8Array#+shimmedSetInt8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO ()+shimmedSetInt8Array# = setInt8Array#+#endif+ unI# :: Int -> Int# unI# (I# n#) = n# @@ -249,7 +271,7 @@            indexWordArray#, readWordArray#, writeWordArray#, setWordArray#,            indexWordOffAddr#, readWordOffAddr#, writeWordOffAddr#, setWordOffAddr#) derivePrim(Word8, W8#, sIZEOF_WORD8, aLIGNMENT_WORD8,-           indexWord8Array#, readWord8Array#, writeWord8Array#, setWord8Array#,+           indexWord8Array#, readWord8Array#, writeWord8Array#, shimmedSetWord8Array#,            indexWord8OffAddr#, readWord8OffAddr#, writeWord8OffAddr#, setWord8OffAddr#) derivePrim(Word16, W16#, sIZEOF_WORD16, aLIGNMENT_WORD16,            indexWord16Array#, readWord16Array#, writeWord16Array#, setWord16Array#,@@ -264,7 +286,7 @@            indexIntArray#, readIntArray#, writeIntArray#, setIntArray#,            indexIntOffAddr#, readIntOffAddr#, writeIntOffAddr#, setIntOffAddr#) derivePrim(Int8, I8#, sIZEOF_INT8, aLIGNMENT_INT8,-           indexInt8Array#, readInt8Array#, writeInt8Array#, setInt8Array#,+           indexInt8Array#, readInt8Array#, writeInt8Array#, shimmedSetInt8Array#,            indexInt8OffAddr#, readInt8OffAddr#, writeInt8OffAddr#, setInt8OffAddr#) derivePrim(Int16, I16#, sIZEOF_INT16, aLIGNMENT_INT16,            indexInt16Array#, readInt16Array#, writeInt16Array#, setInt16Array#,@@ -389,6 +411,43 @@ deriving instance Prim CTimer #endif deriving instance Prim Fd++-- Andrew Martin: The instances for WordPtr and IntPtr are written out by+-- hand in a tedious way. We cannot use GND because the data constructors for+-- these types were not available before GHC 8.2. The CPP for generating code+-- for the Int and Word types does not work here. There is a way to clean this+-- up a little with CPP, and if anyone wants to do that, go for it. In the+-- meantime, I am going to ship this with the instances written out by hand.++-- | @since 0.7.1.0+instance Prim WordPtr where+  sizeOf# _ = sizeOf# (undefined :: Ptr ()) +  alignment# _ = alignment# (undefined :: Ptr ()) +  indexByteArray# a i = ptrToWordPtr (indexByteArray# a i)+  readByteArray# a i s0 = case readByteArray# a i s0 of+    (# s1, p #) -> (# s1, ptrToWordPtr p #)+  writeByteArray# a i wp = writeByteArray# a i (wordPtrToPtr wp)+  setByteArray# a i n wp = setByteArray# a i n (wordPtrToPtr wp)+  indexOffAddr# a i = ptrToWordPtr (indexOffAddr# a i)+  readOffAddr# a i s0 = case readOffAddr# a i s0 of+    (# s1, p #) -> (# s1, ptrToWordPtr p #)+  writeOffAddr# a i wp = writeOffAddr# a i (wordPtrToPtr wp)+  setOffAddr# a i n wp = setOffAddr# a i n (wordPtrToPtr wp)+  +-- | @since 0.7.1.0+instance Prim IntPtr where+  sizeOf# _ = sizeOf# (undefined :: Ptr ()) +  alignment# _ = alignment# (undefined :: Ptr ()) +  indexByteArray# a i = ptrToIntPtr (indexByteArray# a i)+  readByteArray# a i s0 = case readByteArray# a i s0 of+    (# s1, p #) -> (# s1, ptrToIntPtr p #)+  writeByteArray# a i wp = writeByteArray# a i (intPtrToPtr wp)+  setByteArray# a i n wp = setByteArray# a i n (intPtrToPtr wp)+  indexOffAddr# a i = ptrToIntPtr (indexOffAddr# a i)+  readOffAddr# a i s0 = case readOffAddr# a i s0 of+    (# s1, p #) -> (# s1, ptrToIntPtr p #)+  writeOffAddr# a i wp = writeOffAddr# a i (intPtrToPtr wp)+  setOffAddr# a i n wp = setOffAddr# a i n (intPtrToPtr wp)  -- | @since 0.6.5.0 deriving instance Prim a => Prim (Const a b)
cbits/primitive-memops.c view
@@ -40,6 +40,11 @@   return memcmp( s1, s2, n ); } +int hsprimitive_memcmp_offset( HsWord8 *s1, HsInt off1, HsWord8 *s2, HsInt off2, size_t n )+{+  return memcmp( s1 + off1, s2 + off2, n );+}+ void hsprimitive_memset_Word8 (HsWord8 *p, ptrdiff_t off, size_t n, HsWord x) {   memset( (char *)(p+off), x, n );
cbits/primitive-memops.h view
@@ -1,13 +1,16 @@ #ifndef haskell_primitive_memops_h #define haskell_primitive_memops_h +// N.B. GHC RTS headers want to come first, lest things break on Windows.+#include <HsFFI.h>+ #include <stdlib.h> #include <stddef.h>-#include <HsFFI.h>  void hsprimitive_memcpy( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len ); void hsprimitive_memmove( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len ); int  hsprimitive_memcmp( HsWord8 *s1, HsWord8 *s2, size_t n );+int  hsprimitive_memcmp_offset( HsWord8 *s1, HsInt off1, HsWord8 *s2, HsInt off2, size_t n );  void hsprimitive_memset_Word8 (HsWord8 *, ptrdiff_t, size_t, HsWord); void hsprimitive_memset_Word16 (HsWord16 *, ptrdiff_t, size_t, HsWord);
changelog.md view
@@ -1,6 +1,47 @@+## Changes in version 0.7.1.0++  * Introduce convenience class `MonadPrim` and `MonadPrimBase`.++  * Add `PrimMonad` and `PrimBase` instances for `Lazy.ST` (GHC >= 8.2).+    thanks to Avi Dessauer (@Avi-D-coder) for this first contribution++  * Add `freezeByteArray` and `freezePrimArray`.++  * Add `compareByteArrays`.++  * Add `shrinkMutableByteArray`.++  * Add `Eq` instances for `MutableByteArray` and `MutablePrimArray`.+    by Andrew Martin++  * Add functions for manipulating pinned Prim Arrays+    by Andrew Martin++  * Add `copyPtrToMutableByteArray`.++  * Add `NFData` instances for `ByteArray`, `MutableByteArray`,+    `PrimArray` and `MutablePrimArray`.+    by Callan McGill+    +  * Add `shrinkSmallMutableArray`.++  * Add `clonePrimArray` and `cloneMutablePrimArray`.++  * Add `cloneMutableByteArray` and `cloneByteArray`.++  * Add `Prim` instances for `WordPtr` and `IntPtr`.++  * Add `NFData` instances for `Array` and `SmallArray`.+    by Callan McGill++  * Add `copyByteArrayToPtr` and `copyMutableByteArrayToPtr`.++  * Export `arrayFromList` and `arrayFromListN`.+ ## Changes in version 0.7.0.1 - * Allow building with GHC 8.12.+  * Allow building with GHC 8.12.+    Thanks Ryan GL Scott for this and every compat patch over time.  ## Changes in version 0.7.0.0
primitive.cabal view
@@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name:           primitive-Version:        0.7.0.1+Version:        0.7.1.0 License:        BSD-3-Clause License-File:   LICENSE @@ -54,7 +54,7 @@         Data.Primitive.Internal.Operations    Build-Depends: base >= 4.5 && < 4.15-               , ghc-prim >= 0.2 && < 0.7+               , deepseq >= 1.1 && < 1.5                , transformers >= 0.2 && < 0.6   if !impl(ghc >= 8.0)     Build-Depends: fail == 4.9.*@@ -75,35 +75,13 @@   hs-source-dirs: test                   test/src   main-is: main.hs-  Other-Modules:-        PrimLawsWIP-        Test.QuickCheck.Classes-        Test.QuickCheck.Classes.Alternative-        Test.QuickCheck.Classes.Applicative-        Test.QuickCheck.Classes.Common-        Test.QuickCheck.Classes.Compat-        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.IsList-        Test.QuickCheck.Classes.Monad-        Test.QuickCheck.Classes.MonadPlus-        Test.QuickCheck.Classes.MonadZip-        Test.QuickCheck.Classes.Monoid-        Test.QuickCheck.Classes.Ord-        Test.QuickCheck.Classes.Semigroup-        Test.QuickCheck.Classes.Show-        Test.QuickCheck.Classes.ShowRead-        Test.QuickCheck.Classes.Storable-        Test.QuickCheck.Classes.Traversable+  Other-Modules: PrimLaws   type: exitcode-stdio-1.0   build-depends: base                , base-orphans                , ghc-prim                , primitive+               , quickcheck-classes-base >=0.6 && <0.7                , QuickCheck ^>= 2.13                , tasty ^>= 1.2                , tasty-quickcheck
test/main.hs view
@@ -26,7 +26,7 @@ import GHC.Exts import Data.Function (on) import Control.Applicative (Const(..))-import PrimLawsWIP (primLaws)+import PrimLaws (primLaws)  #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (Monoid(..))@@ -53,11 +53,11 @@ import Data.Orphans ()  import Test.Tasty (defaultMain,testGroup,TestTree)-import Test.QuickCheck (Arbitrary,Arbitrary1,Gen,(===),CoArbitrary,Function)+import Test.QuickCheck (Arbitrary,Arbitrary1,Gen,CoArbitrary,Function,(===),(==>)) import qualified Test.Tasty.QuickCheck as TQC import qualified Test.QuickCheck as QC-import qualified Test.QuickCheck.Classes as QCC-import qualified Test.QuickCheck.Classes.IsList as QCCL+import qualified Test.QuickCheck.Classes.Base as QCC+import qualified Test.QuickCheck.Classes.Base.IsList as QCCL import qualified Data.List as L  main :: IO ()@@ -103,7 +103,19 @@       [ testGroup "Ordering"         [ TQC.testProperty "equality" byteArrayEqProp         , TQC.testProperty "compare" byteArrayCompareProp+      , testGroup "Filling"+        [ TQC.testProperty "Int8" (setByteArrayProp (Proxy :: Proxy Int8))+        , TQC.testProperty "Int16" (setByteArrayProp (Proxy :: Proxy Int16))+        , TQC.testProperty "Int32" (setByteArrayProp (Proxy :: Proxy Int32))+        , TQC.testProperty "Int64" (setByteArrayProp (Proxy :: Proxy Int64))+        , TQC.testProperty "Int" (setByteArrayProp (Proxy :: Proxy Int))+        , TQC.testProperty "Word8" (setByteArrayProp (Proxy :: Proxy Word8))+        , TQC.testProperty "Word16" (setByteArrayProp (Proxy :: Proxy Word16))+        , TQC.testProperty "Word32" (setByteArrayProp (Proxy :: Proxy Word32))+        , TQC.testProperty "Word64" (setByteArrayProp (Proxy :: Proxy Word64))+        , TQC.testProperty "Word" (setByteArrayProp (Proxy :: Proxy Word))         ]+      ]       , testGroup "Resize"         [ TQC.testProperty "shrink" byteArrayShrinkProp         , TQC.testProperty "grow" byteArrayGrowProp@@ -208,6 +220,24 @@ int32 = Proxy  +setByteArrayProp :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> QC.Property+setByteArrayProp _ = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (off :: Int)) (QC.NonNegative (len :: Int)) (x :: a) (y :: a) ->+  (off < n && off + len <= n) ==>+  -- We use PrimArray in this test because it makes it easier to+  -- get the element-vs-byte distinction right.+  let actual = runST $ do+        m <- newPrimArray n+        forM_ (enumFromTo 0 (n - 1)) $ \ix -> writePrimArray m ix x+        setPrimArray m off len y+        unsafeFreezePrimArray m+      expected = runST $ do+        m <- newPrimArray n+        forM_ (enumFromTo 0 (n - 1)) $ \ix -> writePrimArray m ix x+        forM_ (enumFromTo off (off + len - 1)) $ \ix -> writePrimArray m ix y+        unsafeFreezePrimArray m+   in expected === actual++ -- Tests that using resizeByteArray to shrink a byte array produces -- the same results as calling Data.List.take on the list that the -- byte array corresponds to.@@ -329,6 +359,12 @@         arr5 = mkByteArray ([0xde, 0xad, 0xbe, 0xef, 0xde, 0xad, 0xbe, 0xdd] :: [Word8])     when (show arr1 /= "[0xde, 0xad, 0xbe, 0xef]") $         fail $ "ByteArray Show incorrect: "++show arr1+    when (compareByteArrays arr3 1 arr4 1 3 /= GT) $+        fail $ "arr3[1,3] should be greater than arr4[1,3]"+    when (compareByteArrays arr3 0 arr4 1 3 /= GT) $+        fail $ "arr3[0,3] should be greater than arr4[1,3]"+    when (compareByteArrays arr5 1 arr2 1 3 /= EQ) $+        fail $ "arr3[1,3] should be equal to than arr4[1,3]"     unless (arr1 > arr3) $         fail $ "ByteArray Ord incorrect"     unless (arr1 == arr2) $
+ test/src/PrimLaws.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}++{-# OPTIONS_GHC -Wall #-}++-- This module is almost an exact copy of the unexported module+-- Test.QuickCheck.Classes.Prim from quickcheck-classes. We cannot depend+-- on quickcheck-classes in the test suite since that would imply a circular+-- dependency between primitive and quickcheck-classes. Instead, we copy+-- this one module and then depend on quickcheck-classes-base to get+-- everything else we need.+module PrimLaws+  ( primLaws+  ) where++import Control.Applicative+import Control.Monad.Primitive (primitive_)+import Control.Monad.ST+import Data.Proxy (Proxy)+import Data.Primitive.PrimArray+import Data.Primitive.ByteArray+import Data.Primitive.Types+import Data.Primitive.Ptr+import Foreign.Marshal.Alloc+import GHC.Exts (State#,Int#,Int(I#),(+#),(<#))++#if MIN_VERSION_base(4,7,0)+import GHC.Exts (IsList(fromList,toList))+#endif++import System.IO.Unsafe+import Test.QuickCheck hiding ((.&.))++import qualified Data.List as L+import qualified Data.Primitive as P++import Test.QuickCheck.Classes.Base (Laws(..))+import Test.QuickCheck.Classes.Internal (isTrue#)++-- | 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"+  [ ("ByteArray Put-Get (you get back what you put in)", primPutGetByteArray p)+  , ("ByteArray Get-Put (putting back what you got out has no effect)", primGetPutByteArray p)+  , ("ByteArray Put-Put (putting twice is same as putting once)", primPutPutByteArray p)+  , ("ByteArray Set Range", primSetByteArray p)+#if MIN_VERSION_base(4,7,0)+  , ("ByteArray List Conversion Roundtrips", primListByteArray p)+#endif+  , ("Ptr Put-Get (you get back what you put in)", primPutGetAddr p)+  , ("Ptr List Conversion Roundtrips", primListAddr p)+  ]++primListAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primListAddr _ = property $ \(as :: [a]) -> unsafePerformIO $ do+  let len = L.length as+  ptr :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))+  let go :: Int -> [a] -> IO ()+      go !ix xs = case xs of+        [] -> return ()+        (x : xsNext) -> do+          writeOffPtr ptr ix x+          go (ix + 1) xsNext+  go 0 as+  let rebuild :: Int -> IO [a]+      rebuild !ix = if ix < len+        then (:) <$> readOffPtr ptr ix <*> rebuild (ix + 1)+        else return []+  asNew <- rebuild 0+  free ptr+  return (as == asNew)++primPutGetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primPutGetByteArray _ = property $ \(a :: a) len -> (len > 0) ==> do+  ix <- choose (0,len - 1)+  return $ runST $ do+    arr <- newPrimArray len+    writePrimArray arr ix a+    a' <- readPrimArray arr ix+    return (a == a')++primGetPutByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primGetPutByteArray _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do+  let arr1 = primArrayFromList as :: PrimArray a+      len = L.length as+  ix <- choose (0,len - 1)+  arr2 <- return $ runST $ do+    marr <- newPrimArray len+    copyPrimArray marr 0 arr1 0 len+    a <- readPrimArray marr ix+    writePrimArray marr ix a+    unsafeFreezePrimArray marr+  return (arr1 == arr2)++primPutPutByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primPutPutByteArray _ = property $ \(a :: a) (as :: [a]) -> (not (L.null as)) ==> do+  let arr1 = primArrayFromList as :: PrimArray a+      len = L.length as+  ix <- choose (0,len - 1)+  (arr2,arr3) <- return $ runST $ do+    marr2 <- newPrimArray len+    copyPrimArray marr2 0 arr1 0 len+    writePrimArray marr2 ix a+    marr3 <- newPrimArray len+    copyMutablePrimArray marr3 0 marr2 0 len+    arr2 <- unsafeFreezePrimArray marr2+    writePrimArray marr3 ix a+    arr3 <- unsafeFreezePrimArray marr3+    return (arr2,arr3)+  return (arr2 == arr3)++primPutGetAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primPutGetAddr _ = property $ \(a :: a) len -> (len > 0) ==> do+  ix <- choose (0,len - 1)+  return $ unsafePerformIO $ do+    ptr :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))+    writeOffPtr ptr ix a+    a' <- readOffPtr ptr ix+    free ptr+    return (a == a')++primSetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primSetByteArray _ = property $ \(as :: [a]) (z :: a) -> do+  let arr1 = primArrayFromList as :: PrimArray a+      len = L.length as+  x <- choose (0,len)+  y <- choose (0,len)+  let lo = min x y+      hi = max x y+  return $ runST $ do+    marr2 <- newPrimArray len+    copyPrimArray marr2 0 arr1 0 len+    marr3 <- newPrimArray len+    copyPrimArray marr3 0 arr1 0 len+    setPrimArray marr2 lo (hi - lo) z+    internalDefaultSetPrimArray marr3 lo (hi - lo) z+    arr2 <- unsafeFreezePrimArray marr2+    arr3 <- unsafeFreezePrimArray marr3+    return (arr2 == arr3)++#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++internalDefaultSetPrimArray :: Prim a+  => MutablePrimArray s a -> Int -> Int -> a -> ST s ()+internalDefaultSetPrimArray (MutablePrimArray arr) (I# i) (I# len) ident =+  primitive_ (internalDefaultSetByteArray# arr i len ident)++internalDefaultSetByteArray# :: Prim a+  => MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s+internalDefaultSetByteArray# arr# i# len# ident = go 0#+  where+  go ix# s0 = if isTrue# (ix# <# len#)+    then case writeByteArray# arr# (i# +# ix#) ident s0 of+      s1 -> go (ix# +# 1#) s1+    else s0
− test/src/PrimLawsWIP.hs 
@@ -1,387 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnboxedTuples #-}--{-# OPTIONS_GHC -Wall #-}--module PrimLawsWIP-  ( primLaws-  ) where--import Control.Applicative-import Control.Monad.Primitive (PrimMonad, PrimState,primitive,primitive_)-import Control.Monad.ST-import Data.Proxy (Proxy)-import Data.Primitive.ByteArray-import Data.Primitive.Types-import Data.Primitive.Ptr-import Foreign.Marshal.Alloc-import GHC.Exts-  (State#,Int#,Addr#,Int(I#),(*#),(+#),(<#),newByteArray#,unsafeFreezeByteArray#,-   copyMutableByteArray#,copyByteArray#,quotInt#,sizeofByteArray#)--#if MIN_VERSION_base(4,7,0)-import GHC.Exts (IsList(fromList,toList,fromListN),Item,-  copyByteArrayToAddr#,copyAddrToByteArray#)-#endif--import GHC.Ptr (Ptr(..))-import System.IO.Unsafe-import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Property (Property)--import qualified Data.List as L-import qualified Data.Primitive as P--import Test.QuickCheck.Classes.Common (Laws(..))-import Test.QuickCheck.Classes.Compat (isTrue#)---- | 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"-  [ ("ByteArray Put-Get (you get back what you put in)", primPutGetByteArray p)-  , ("ByteArray Get-Put (putting back what you got out has no effect)", primGetPutByteArray p)-  , ("ByteArray Put-Put (putting twice is same as putting once)", primPutPutByteArray p)-  , ("ByteArray Set Range", primSetByteArray p)-#if MIN_VERSION_base(4,7,0)-  , ("ByteArray List Conversion Roundtrips", primListByteArray p)-#endif-  , ("Addr Put-Get (you get back what you put in)", primPutGetAddr p)-  , ("Addr Get-Put (putting back what you got out has no effect)", primGetPutAddr p)-  , ("Addr Set Range", primSetOffAddr p)-  , ("Addr List Conversion Roundtrips", primListAddr p)-  ]--primListAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-primListAddr _ = property $ \(as :: [a]) -> unsafePerformIO $ do-  let len = L.length as-  ptr :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))-  let go :: Int -> [a] -> IO ()-      go !ix xs = case xs of-        [] -> return ()-        (x : xsNext) -> do-          writeOffPtr ptr ix x-          go (ix + 1) xsNext-  go 0 as-  let rebuild :: Int -> IO [a]-      rebuild !ix = if ix < len-        then (:) <$> readOffPtr ptr ix <*> rebuild (ix + 1)-        else return []-  asNew <- rebuild 0-  free ptr-  return (as == asNew)--primPutGetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-primPutGetByteArray _ = property $ \(a :: a) len -> (len > 0) ==> do-  ix <- choose (0,len - 1)-  return $ runST $ do-    arr <- newPrimArray len-    writePrimArray arr ix a-    a' <- readPrimArray arr ix-    return (a == a')--primGetPutByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-primGetPutByteArray _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do-  let arr1 = primArrayFromList as :: PrimArray a-      len = L.length as-  ix <- choose (0,len - 1)-  arr2 <- return $ runST $ do-    marr <- newPrimArray len-    copyPrimArray marr 0 arr1 0 len-    a <- readPrimArray marr ix-    writePrimArray marr ix a-    unsafeFreezePrimArray marr-  return (arr1 == arr2)--primPutPutByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-primPutPutByteArray _ = property $ \(a :: a) (as :: [a]) -> (not (L.null as)) ==> do-  let arr1 = primArrayFromList as :: PrimArray a-      len = L.length as-  ix <- choose (0,len - 1)-  (arr2,arr3) <- return $ runST $ do-    marr2 <- newPrimArray len-    copyPrimArray marr2 0 arr1 0 len-    writePrimArray marr2 ix a-    marr3 <- newPrimArray len-    copyMutablePrimArray marr3 0 marr2 0 len-    arr2 <- unsafeFreezePrimArray marr2-    writePrimArray marr3 ix a-    arr3 <- unsafeFreezePrimArray marr3-    return (arr2,arr3)-  return (arr2 == arr3)--primPutGetAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-primPutGetAddr _ = property $ \(a :: a) len -> (len > 0) ==> do-  ix <- choose (0,len - 1)-  return $ unsafePerformIO $ do-    ptr :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))-    writeOffPtr ptr ix a-    a' <- readOffPtr ptr ix-    free ptr-    return (a == a')--primGetPutAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-primGetPutAddr _ =  property $ True- --property $ \(as :: [a]) -> (not (L.null as)) ==> do- -- let arr1 = primArrayFromList as :: PrimArray a- --     len = L.length as- -- ix <- choose (0,len - 1)- -- arr2 <- return $ unsafePerformIO $ do- --   ptr:: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))- --   copyPrimArrayToPtr ptr arr1 0 len- --   a <- readOffPtr ptr ix- --   writeOffPtr ptr ix a- --   marr <- newPrimArray len- --   copyPtrToMutablePrimArray marr 0 ptr len- --   free ptr- --   unsafeFreezePrimArray marr- -- return (arr1 == arr2)--primSetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-primSetByteArray _ = property $ \(as :: [a]) (z :: a) -> do-  let arr1 = primArrayFromList as :: PrimArray a-      len = L.length as-  x <- choose (0,len)-  y <- choose (0,len)-  let lo = min x y-      hi = max x y-  return $ runST $ do-    marr2 <- newPrimArray len-    copyPrimArray marr2 0 arr1 0 len-    marr3 <- newPrimArray len-    copyPrimArray marr3 0 arr1 0 len-    setPrimArray marr2 lo (hi - lo) z-    internalDefaultSetPrimArray marr3 lo (hi - lo) z-    arr2 <- unsafeFreezePrimArray marr2-    arr3 <- unsafeFreezePrimArray marr3-    return (arr2 == arr3)---- having trouble getting this to type check AND as written its really unsafe-primSetOffAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property-primSetOffAddr _ =   property $ True---primSetOffAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property---primSetOffAddr _ = property $ \(as :: [a]) (z :: a) -> do---  let arr1 = primArrayFromList as :: PrimArray a---      len = L.length as---  x <- choose (0,len)---  y <- choose (0,len)---  let lo = min x y---      hi = max x y---  return $ unsafePerformIO $ do---    ptrA@(Ptr addrA#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))----    copyPrimArrayToPtr ptrA arr1 0 len---    ptrB@(Ptr addrB#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))----    copyPrimArrayToPtr ptrB arr1 0 len---    setPtr ptrA lo (hi - lo) z---    internalDefaultSetOffAddr ptrB lo (hi - lo) z---    marrA <- newPrimArray len---    copyPtrToMutablePrimArray marrA 0 ptrA len---    free ptrA---    marrB <- newPrimArray len---    copyPtrToMutablePrimArray marrB 0 ptrB len---    free ptrB---    arrA <- unsafeFreezePrimArray marrA---    arrB <- unsafeFreezePrimArray marrB---    return (arrA == arrB)---- 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#) (P.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'# #))----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 ()---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 ()-#if MIN_VERSION_base(4,7,0)-copyPrimArrayToPtr (Ptr addr#) (PrimArray ba#) (I# soff#) (I# n#) =-  primitive (\ s# ->-      let s'# = copyByteArrayToAddr# ba# (soff# *# siz#) addr# (n# *# siz#) s#-      in (# s'#, () #))-  where siz# = sizeOf# (undefined :: a)-#else-copyPrimArrayToPtr ptr  ba soff n =-  generateM_ n $ \ix -> writeOffPtr ptr  ix (indexPrimArray ba (ix + soff))-#endif-{--copyPtrToMutablePrimArray :: forall m a. (PrimMonad m, Prim a)-  => MutablePrimArray (PrimState m) a-  -> Int-  -> Ptr a-  -> Int-  -> m ()-#if MIN_VERSION_base(4,7,0)-copyPtrToMutablePrimArray (MutablePrimArray ba#) (I# doff#) (Ptr addr#) (I# n#) =-  primitive (\ s# ->-      let s'# = copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#) s#-      in (# s'#, () #))-  where siz# = sizeOf# (undefined :: a)-#else-copyPtrToMutablePrimArray ba doff addr n =-  generateM_ n $ \ix -> do-    x <- readOffAddr (ptrToAddr addr) ix-    writePrimArray ba (doff + ix) x-#endif--}-copyMutablePrimArray :: forall m s a.-     (PrimMonad m, s ~ PrimState m , Prim a)-  => MutablePrimArray s a -- ^ destination array-  -> Int -- ^ offset into destination array-  -> MutablePrimArray s  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)))-    )--setPrimArray-  :: (Prim a, PrimMonad m)-  => MutablePrimArray (PrimState m) a -- ^ array to fill-  -> Int -- ^ offset into array-  -> Int -- ^ number of values to fill-  -> a -- ^ value to fill with-  -> m ()-setPrimArray (MutablePrimArray dst#) (I# doff#) (I# sz#) x-  = primitive_ (P.setByteArray# dst# doff# sz# x)--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 []--#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---internalDefaultSetPrimArray :: Prim a-  => MutablePrimArray s a -> Int -> Int -> a -> ST s ()-internalDefaultSetPrimArray (MutablePrimArray arr) (I# i) (I# len) ident =-  primitive_ (internalDefaultSetByteArray# arr i len ident)--internalDefaultSetByteArray# :: Prim a-  => MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s-internalDefaultSetByteArray# arr# i# len# ident = go 0#-  where-  go ix# s0 = if isTrue# (ix# <# len#)-    then case writeByteArray# arr# (i# +# ix#) ident s0 of-      s1 -> go (ix# +# 1#) s1-    else s0--internalDefaultSetOffAddr :: Prim a => Ptr a -> Int -> Int -> a -> IO ()-internalDefaultSetOffAddr (Ptr addr) (I# ix) (I# len) a = primitive_-  (internalDefaultSetOffAddr# addr ix len a)--internalDefaultSetOffAddr# :: Prim a => Addr# -> Int# -> Int# -> a -> State# s -> State# s-internalDefaultSetOffAddr# addr# i# len# ident = go 0#-  where-  go ix# s0 = if isTrue# (ix# <# len#)-    then case writeOffAddr# addr# (i# +# ix#) ident s0 of-      s1 -> go (ix# +# 1#) s1-    else s0
− test/src/Test/QuickCheck/Classes.hs 
@@ -1,253 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE KindSignatures #-}--{-# OPTIONS_GHC -Wall #-}--{-| This library provides sets of properties that should hold for common-    typeclasses.--    /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.--}-module Test.QuickCheck.Classes-  ( -- * Running-    lawsCheck-  , lawsCheckMany-  , lawsCheckOne-    -- * Properties-    -- ** Ground types-    -- * Laws-  , eqLaws-  , integralLaws-#if MIN_VERSION_base(4,7,0)-  , isListLaws-#endif-  , monoidLaws-  , commutativeMonoidLaws-  , ordLaws-  , enumLaws-  , boundedEnumLaws-#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-#if HAVE_SEMIGROUPOIDS-  , altLaws-  , applyLaws-#endif-  , applicativeLaws-  , foldableLaws-  , functorLaws-  , monadLaws-  , monadPlusLaws-  , monadZipLaws-#if HAVE_SEMIGROUPOIDS-  , plusLaws-  , extendedPlusLaws-#endif-  , traversableLaws-#endif-    -- * Types-  , Laws(..)-  , Proxy1(..)-  , Proxy2(..)-  ) where------- re-exports------- Ground Types-import Test.QuickCheck.Classes.Enum-import Test.QuickCheck.Classes.Eq-import Test.QuickCheck.Classes.Integral-#if MIN_VERSION_base(4,7,0)-import Test.QuickCheck.Classes.IsList-#endif--import Test.QuickCheck.Classes.Monoid-import Test.QuickCheck.Classes.Ord--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-#if HAVE_SEMIGROUPOIDS-import Test.QuickCheck.Classes.Alt-import Test.QuickCheck.Classes.Apply-#endif-import Test.QuickCheck.Classes.Applicative-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-#if HAVE_SEMIGROUPOIDS-import Test.QuickCheck.Classes.Plus-#endif-import Test.QuickCheck.Classes.Traversable-#endif-------- used below----import Test.QuickCheck-import Test.QuickCheck.Classes.Common (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
− test/src/Test/QuickCheck/Classes/Alternative.hs 
@@ -1,80 +0,0 @@-{-# 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.Common-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1)-#endif--#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
− test/src/Test/QuickCheck/Classes/Applicative.hs 
@@ -1,114 +0,0 @@-{-# 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.Common-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1)-#endif--#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
− test/src/Test/QuickCheck/Classes/Common.hs 
@@ -1,464 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Common-  ( Laws(..)-  , foldMapA-  , myForAllShrink-  -- Modifiers-  , SmallList(..)-  , ShowReadPrecedence(..)--  -- only used for higher-kinded types-  , Apply(..)--  , 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-  ) 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(..),eq1,showsPrec1)-import Data.Functor.Compose-#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---- | 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 = 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)-----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---- 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 ]
− test/src/Test/QuickCheck/Classes/Compat.hs 
@@ -1,64 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}--#if HAVE_QUANTIFIED_CONSTRAINTS-{-# LANGUAGE QuantifiedConstraints #-}-#endif--module Test.QuickCheck.Classes.Compat-  ( isTrue#-  , eq1--  , readMaybe-  ) where--#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--import qualified Data.Functor.Classes as C---#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_QUANTIFIED_CONSTRAINTS-eq1 :: (forall a. Eq a => Eq (f a), Eq a) => f a -> f a -> Bool-eq1 = (==)-#else-eq1 :: (C.Eq1 f, Eq a) => f a -> f a -> Bool-#if   !(MIN_VERSION_transformers(0,5,0))- -- checking for transformers 0.4 by another name-eq1 = C.eq1-#else-eq1 = C.liftEq (==)-#endif-#endif----
− test/src/Test/QuickCheck/Classes/Enum.hs 
@@ -1,77 +0,0 @@-{-# 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.Common (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)-
− test/src/Test/QuickCheck/Classes/Eq.hs 
@@ -1,50 +0,0 @@-{-# 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.Common (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
− test/src/Test/QuickCheck/Classes/Foldable.hs 
@@ -1,186 +0,0 @@-{-# LANGUAGE CPP #-}-{-# 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.Common-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1)-#endif--#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 (SG.Sum Integer))) ->-      F.fold a == F.foldMap id a-  , (,) "foldMap" $ property $ \(Apply (a :: f Integer)) (e :: QuadraticEquation) ->-      let f = SG.Sum . 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
− test/src/Test/QuickCheck/Classes/Functor.hs 
@@ -1,86 +0,0 @@-{-# 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.Common-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1)-#endif--#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-
− test/src/Test/QuickCheck/Classes/Generic.hs 
@@ -1,112 +0,0 @@-{-# 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.Common (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
− test/src/Test/QuickCheck/Classes/Integral.hs 
@@ -1,52 +0,0 @@-{-# 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.Common (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)
− test/src/Test/QuickCheck/Classes/IsList.hs 
@@ -1,251 +0,0 @@-{-# 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.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.Common (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
− test/src/Test/QuickCheck/Classes/Monad.hs 
@@ -1,114 +0,0 @@-{-# 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.Common-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1)-#endif--#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
− test/src/Test/QuickCheck/Classes/MonadPlus.hs 
@@ -1,104 +0,0 @@-{-# 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.Common-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1)-#endif-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
− test/src/Test/QuickCheck/Classes/MonadZip.hs 
@@ -1,65 +0,0 @@-{-# 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.Common-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1)-#endif--#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
− test/src/Test/QuickCheck/Classes/Monoid.hs 
@@ -1,85 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wall #-}--module Test.QuickCheck.Classes.Monoid-  ( monoidLaws-  , commutativeMonoidLaws-  ) where--import Data.Monoid-import Data.Proxy (Proxy)-import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Property (Property)--import Test.QuickCheck.Classes.Common (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)-  ]--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)
− test/src/Test/QuickCheck/Classes/Ord.hs 
@@ -1,49 +0,0 @@-{-# 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.Common (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
− test/src/Test/QuickCheck/Classes/Semigroup.hs 
@@ -1,145 +0,0 @@-{-# 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.Common (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)
− test/src/Test/QuickCheck/Classes/Show.hs 
@@ -1,48 +0,0 @@-{-# 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.Common (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)
− test/src/Test/QuickCheck/Classes/ShowRead.hs 
@@ -1,86 +0,0 @@-{-# 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.Common (Laws(..), ShowReadPrecedence(..),-  SmallList(..), myForAllShrink)-import Test.QuickCheck.Classes.Compat (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 "")-
− test/src/Test/QuickCheck/Classes/Storable.hs 
@@ -1,150 +0,0 @@-{-# 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.Common (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
− test/src/Test/QuickCheck/Classes/Traversable.hs 
@@ -1,96 +0,0 @@-{-# 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 Test.QuickCheck.Classes.Common-#if HAVE_UNARY_LAWS-import Test.QuickCheck.Classes.Compat (eq1)-#endif--#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"-  [-   (,) "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 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