primitive 0.6.4.0 → 0.7.0.0

raw patch · 40 files changed

+3548/−967 lines, 40 filesdep +QuickCheckdep +base-orphansdep +faildep ~basedep ~ghc-primdep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, base-orphans, fail, primitive, semigroups, tagged, tasty, tasty-quickcheck, transformers-compat

Dependency ranges changed: base, ghc-prim, transformers

API changes (from Hackage documentation)

Files

• Control/Monad/Primitive.hs +40/−5
• Data/Primitive.hs +3/−4
• Data/Primitive/Addr.hs +0/−133
• Data/Primitive/Array.hs +67/−15
• Data/Primitive/ByteArray.hs +15/−14
• Data/Primitive/Internal/Operations.hs +9/−3
• Data/Primitive/MachDeps.hs +1/−1
• Data/Primitive/MutVar.hs +4/−4
• Data/Primitive/PrimArray.hs +10/−11
• Data/Primitive/Ptr.hs +2/−2
• Data/Primitive/SmallArray.hs +6/−0
• Data/Primitive/Types.hs +57/−36
• Data/Primitive/UnliftedArray.hs +0/−638
• changelog.md +37/−1
• primitive.cabal +56/−8
• test/main.hs +123/−47
• test/primitive-tests.cabal +0/−45
• test/src/PrimLawsWIP.hs +387/−0
• test/src/Test/QuickCheck/Classes.hs +253/−0
• test/src/Test/QuickCheck/Classes/Alternative.hs +80/−0
• test/src/Test/QuickCheck/Classes/Applicative.hs +114/−0
• test/src/Test/QuickCheck/Classes/Common.hs +464/−0
• test/src/Test/QuickCheck/Classes/Compat.hs +64/−0
• test/src/Test/QuickCheck/Classes/Enum.hs +77/−0
• test/src/Test/QuickCheck/Classes/Eq.hs +50/−0
• test/src/Test/QuickCheck/Classes/Foldable.hs +186/−0
• test/src/Test/QuickCheck/Classes/Functor.hs +86/−0
• test/src/Test/QuickCheck/Classes/Generic.hs +112/−0
• test/src/Test/QuickCheck/Classes/Integral.hs +52/−0
• test/src/Test/QuickCheck/Classes/IsList.hs +251/−0
• test/src/Test/QuickCheck/Classes/Monad.hs +114/−0
• test/src/Test/QuickCheck/Classes/MonadPlus.hs +104/−0
• test/src/Test/QuickCheck/Classes/MonadZip.hs +65/−0
• test/src/Test/QuickCheck/Classes/Monoid.hs +85/−0
• test/src/Test/QuickCheck/Classes/Ord.hs +49/−0
• test/src/Test/QuickCheck/Classes/Semigroup.hs +145/−0
• test/src/Test/QuickCheck/Classes/Show.hs +48/−0
• test/src/Test/QuickCheck/Classes/ShowRead.hs +86/−0
• test/src/Test/QuickCheck/Classes/Storable.hs +150/−0
• test/src/Test/QuickCheck/Classes/Traversable.hs +96/−0

@@ -20,10 +20,10 @@   liftPrim, primToPrim, primToIO, primToST, ioToPrim, stToPrim,   unsafePrimToPrim, unsafePrimToIO, unsafePrimToST, unsafeIOToPrim,   unsafeSTToPrim, unsafeInlinePrim, unsafeInlineIO, unsafeInlineST,-  touch, evalPrim+  touch, evalPrim, unsafeInterleave, unsafeDupableInterleave, noDuplicate ) where -import GHC.Prim   ( State#, RealWorld, touch# )+import GHC.Exts   ( State#, RealWorld, noDuplicate#, touch# ) import GHC.Base   ( unsafeCoerce#, realWorld# ) #if MIN_VERSION_base(4,4,0) import GHC.Base   ( seq# )@@ -61,6 +61,11 @@ import Control.Monad.Trans.Select   ( SelectT  ) #endif +#if MIN_VERSION_transformers(0,5,6)+import qualified Control.Monad.Trans.Writer.CPS as CPS+import qualified Control.Monad.Trans.RWS.CPS as CPS+#endif+ import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   ) import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT ) import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )@@ -146,11 +151,25 @@   primitive = lift . primitive   {-# INLINE primitive #-} +#if MIN_VERSION_transformers(0,5,6)+instance (Monoid w, PrimMonad m) => PrimMonad (CPS.WriterT w m) where+  type PrimState (CPS.WriterT w m) = PrimState m+  primitive = lift . primitive+  {-# INLINE primitive #-}+#endif+ instance (Monoid w, PrimMonad m) => PrimMonad (RWST r w s m) where   type PrimState (RWST r w s m) = PrimState m   primitive = lift . primitive   {-# INLINE primitive #-} +#if MIN_VERSION_transformers(0,5,6)+instance (Monoid w, PrimMonad m) => PrimMonad (CPS.RWST r w s m) where+  type PrimState (CPS.RWST r w s m) = PrimState m+  primitive = lift . primitive+  {-# INLINE primitive #-}+#endif+ #if MIN_VERSION_transformers(0,4,0) instance PrimMonad m => PrimMonad (ExceptT e m) where   type PrimState (ExceptT e m) = PrimState m@@ -222,7 +241,7 @@ primToST = primToPrim  -- | Convert an 'IO' action to a 'PrimMonad'.--- +-- -- @since 0.6.2.0 ioToPrim :: (PrimMonad m, PrimState m ~ RealWorld) => IO a -> m a {-# INLINE ioToPrim #-}@@ -252,9 +271,9 @@ {-# INLINE unsafePrimToIO #-} unsafePrimToIO = unsafePrimToPrim --- | Convert an 'ST' action with an arbitraty state token to any 'PrimMonad'.+-- | Convert an 'ST' action with an arbitrary state token to any 'PrimMonad'. -- This operation is highly unsafe!--- +-- -- @since 0.6.2.0 unsafeSTToPrim :: PrimMonad m => ST s a -> m a {-# INLINE unsafeSTToPrim #-}@@ -296,3 +315,19 @@ {-# NOINLINE evalPrim #-} evalPrim a = unsafePrimToPrim (evaluate a :: IO a) #endif++noDuplicate :: PrimMonad m => m ()+#if __GLASGOW_HASKELL__ >= 802+noDuplicate = primitive $ \ s -> (# noDuplicate# s, () #)+#else+-- noDuplicate# was limited to RealWorld+noDuplicate = unsafeIOToPrim $ primitive $ \s -> (# noDuplicate# s, () #)+#endif++unsafeInterleave, unsafeDupableInterleave :: PrimBase m => m a -> m a+unsafeInterleave x = unsafeDupableInterleave (noDuplicate >> x)+unsafeDupableInterleave x = primitive $ \ s -> let r' = case internal x s of (# _, r #) -> r in (# s, r' #)+{-# INLINE unsafeInterleave #-}+{-# NOINLINE unsafeDupableInterleave #-}+-- See Note [unsafeDupableInterleaveIO should not be inlined]+-- in GHC.IO.Unsafe

@@ -15,9 +15,7 @@   module Data.Primitive.Types   ,module Data.Primitive.Array   ,module Data.Primitive.ByteArray-  ,module Data.Primitive.Addr   ,module Data.Primitive.SmallArray-  ,module Data.Primitive.UnliftedArray   ,module Data.Primitive.PrimArray   ,module Data.Primitive.MutVar   -- * Naming Conventions@@ -27,9 +25,7 @@ import Data.Primitive.Types import Data.Primitive.Array import Data.Primitive.ByteArray-import Data.Primitive.Addr import Data.Primitive.SmallArray-import Data.Primitive.UnliftedArray import Data.Primitive.PrimArray import Data.Primitive.MutVar @@ -73,6 +69,9 @@ * 'IO' and 'ST' * Any combination of 'MaybeT', 'ExceptT', 'StateT' and 'Writer' on top   of another sufficiently affine monad.+* Any Monad which does not include backtracking or other mechanism where an effect can+happen more than once is an Affine Monad in the sense we care about. ContT, LogicT, ListT are all+examples of search/control monads which are NOT affine: they can run a sub computation more than once.  There is one situation where the names deviate from effectful suffix convention described above. Throughout the haskell ecosystem, the 'Applicative' variant of

@@ -1,133 +0,0 @@-{-# LANGUAGE MagicHash, UnboxedTuples, CPP #-}---- |--- Module      : Data.Primitive.Addr--- Copyright   : (c) Roman Leshchinskiy 2009-2012--- License     : BSD-style------ Maintainer  : Roman Leshchinskiy <rl@cse.unsw.edu.au>--- Portability : non-portable------ Primitive operations on machine addresses-----module Data.Primitive.Addr (-  -- * Types-  Addr(..),--  -- * Address arithmetic-  nullAddr, plusAddr, minusAddr, remAddr,--  -- * Element access-  indexOffAddr, readOffAddr, writeOffAddr,--  -- * Block operations-  copyAddr,-#if __GLASGOW_HASKELL__ >= 708-  copyAddrToByteArray,-#endif-  moveAddr, setAddr,--  -- * Conversion-  addrToInt-) where--import Control.Monad.Primitive-import Data.Primitive.Types-#if __GLASGOW_HASKELL__ >= 708-import Data.Primitive.ByteArray-#endif--import GHC.Base ( Int(..) )-import GHC.Prim--import GHC.Ptr-import Foreign.Marshal.Utils----- | The null address-nullAddr :: Addr-nullAddr = Addr nullAddr#--infixl 6 `plusAddr`, `minusAddr`-infixl 7 `remAddr`---- | Offset an address by the given number of bytes-plusAddr :: Addr -> Int -> Addr-plusAddr (Addr a#) (I# i#) = Addr (plusAddr# a# i#)---- | Distance in bytes between two addresses. The result is only valid if the--- difference fits in an 'Int'.-minusAddr :: Addr -> Addr -> Int-minusAddr (Addr a#) (Addr b#) = I# (minusAddr# a# b#)---- | The remainder of the address and the integer.-remAddr :: Addr -> Int -> Int-remAddr (Addr a#) (I# i#) = I# (remAddr# a# i#)---- | Read a value from a memory position given by an address and an offset.--- The memory block the address refers to must be immutable. The offset is in--- elements of type @a@ rather than in bytes.-indexOffAddr :: Prim a => Addr -> Int -> a-{-# INLINE indexOffAddr #-}-indexOffAddr (Addr addr#) (I# i#) = indexOffAddr# addr# i#---- | Read a value from a memory position given by an address and an offset.--- The offset is in elements of type @a@ rather than in bytes.-readOffAddr :: (Prim a, PrimMonad m) => Addr -> Int -> m a-{-# INLINE readOffAddr #-}-readOffAddr (Addr addr#) (I# i#) = primitive (readOffAddr# addr# i#)---- | Write a value to a memory position given by an address and an offset.--- The offset is in elements of type @a@ rather than in bytes.-writeOffAddr :: (Prim a, PrimMonad m) => Addr -> Int -> a -> m ()-{-# INLINE writeOffAddr #-}-writeOffAddr (Addr addr#) (I# i#) x = primitive_ (writeOffAddr# addr# i# x)---- | Copy the given number of bytes from the second 'Addr' to the first. The--- areas may not overlap.-copyAddr :: PrimMonad m => Addr         -- ^ destination address-                        -> Addr         -- ^ source address-                        -> Int          -- ^ number of bytes-                        -> m ()-{-# INLINE copyAddr #-}-copyAddr (Addr dst#) (Addr src#) n-  = unsafePrimToPrim $ copyBytes (Ptr dst#) (Ptr src#) n--#if __GLASGOW_HASKELL__ >= 708--- | Copy the given number of bytes from the 'Addr' to the 'MutableByteArray'.---   The areas may not overlap. This function is only available when compiling---   with GHC 7.8 or newer.---   ---   @since 0.6.4.0-copyAddrToByteArray :: PrimMonad m-  => MutableByteArray (PrimState m) -- ^ destination-  -> Int -- ^ offset into the destination array-  -> Addr -- ^ source-  -> Int -- ^ number of bytes to copy-  -> m ()-{-# INLINE copyAddrToByteArray #-}-copyAddrToByteArray (MutableByteArray marr) (I# off) (Addr addr) (I# len) =-  primitive_ $ copyAddrToByteArray# addr marr off len-#endif---- | Copy the given number of bytes from the second 'Addr' to the first. The--- areas may overlap.-moveAddr :: PrimMonad m => Addr         -- ^ destination address-                        -> Addr         -- ^ source address-                        -> Int          -- ^ number of bytes-                        -> m ()-{-# INLINE moveAddr #-}-moveAddr (Addr dst#) (Addr src#) n-  = unsafePrimToPrim $ moveBytes (Ptr dst#) (Ptr src#) n---- | Fill a memory block of with the given value. The length is in--- elements of type @a@ rather than in bytes.-setAddr :: (Prim a, PrimMonad m) => Addr -> Int -> a -> m ()-{-# INLINE setAddr #-}-setAddr (Addr addr#) (I# n#) x = primitive_ (setOffAddr# addr# 0# n# x)---- | Convert an 'Addr' to an 'Int'.-addrToInt :: Addr -> Int-{-# INLINE addrToInt #-}-addrToInt (Addr addr#) = I# (addr2Int# addr#)

@@ -30,7 +30,10 @@ import Control.Monad.Primitive  import GHC.Base  ( Int(..) )-import GHC.Prim+import GHC.Exts+#if (MIN_VERSION_base(4,7,0))+  hiding (toList)+#endif import qualified GHC.Exts as Exts #if (MIN_VERSION_base(4,7,0)) import GHC.Exts (fromListN, fromList)@@ -45,6 +48,7 @@  import Control.Applicative import Control.Monad (MonadPlus(..), when)+import qualified Control.Monad.Fail as Fail import Control.Monad.Fix #if MIN_VERSION_base(4,4,0) import Control.Monad.Zip@@ -68,11 +72,15 @@ import GHC.Base (runRW#) #endif +import Text.Read (Read (..), parens, prec)+import Text.ParserCombinators.ReadPrec (ReadPrec)+import qualified Text.ParserCombinators.ReadPrec as RdPrc import Text.ParserCombinators.ReadP  #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..)) #endif+import Control.Monad (liftM2)  -- | Boxed arrays data Array a = Array@@ -231,8 +239,12 @@          | otherwise = return () #endif --- | Copy a slice of a mutable array to another array. The two arrays may--- not be the same.+-- | Copy a slice of a mutable array to another array. The two arrays must+-- 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+-- has the source first while this wrapper has the destination first. copyMutableArray :: PrimMonad m           => MutableArray (PrimState m) a    -- ^ destination array           -> Int                             -- ^ offset into destination array@@ -241,7 +253,7 @@           -> Int                             -- ^ number of elements to copy           -> m () {-# INLINE copyMutableArray #-}-#if __GLASGOW_HASKELL__ >= 706+#if __GLASGOW_HASKELL__ > 706 -- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier copyMutableArray (MutableArray dst#) (I# doff#)                  (MutableArray src#) (I# soff#) (I# len#)@@ -691,6 +703,11 @@      = copyArray smb off sb 0 (lsb)          *> fill (off + lsb) sbs smb +#if !(MIN_VERSION_base(4,13,0))+  fail = Fail.fail+#endif++instance Fail.MonadFail Array where   fail _ = empty  instance MonadPlus Array where@@ -779,26 +796,61 @@ #endif #endif -arrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Array a)-arrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do-  () <$ string "fromListN"-  skipSpaces-  n <- readS_to_P reads-  skipSpaces-  l <- readS_to_P listReadsPrec-  return $ arrayFromListN n l- instance Read a => Read (Array a) where-  readsPrec = arrayLiftReadsPrec readsPrec readList+  readPrec = arrayLiftReadPrec readPrec readListPrec  #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -- | @since 0.6.4.0 instance Read1 Array where-#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)+#if MIN_VERSION_base(4,10,0)+  liftReadPrec = arrayLiftReadPrec+#elif MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)   liftReadsPrec = arrayLiftReadsPrec #else   readsPrec1 = arrayLiftReadsPrec readsPrec readList #endif+#endif++-- We're really forgiving here. We accept+-- "[1,2,3]", "fromList [1,2,3]", and "fromListN 3 [1,2,3]".+-- We consider fromListN with an invalid length to be an+-- error, rather than a parse failure, because doing otherwise+-- seems weird and likely to make debugging difficult.+arrayLiftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (Array a)+arrayLiftReadPrec _ read_list = parens $ prec app_prec $ RdPrc.lift skipSpaces >>+    ((fromList <$> read_list) RdPrc.++++      do+        tag <- RdPrc.lift lexTag+        case tag of+          FromListTag -> fromList <$> read_list+          FromListNTag -> liftM2 fromListN readPrec read_list)+   where+     app_prec = 10++data Tag = FromListTag | FromListNTag++-- Why don't we just use lexP? The general problem with lexP is that+-- it doesn't always fail as fast as we might like. It will+-- happily read to the end of an absurdly long lexeme (e.g., a 200MB string+-- literal) before returning, at which point we'll immediately discard+-- the result because it's not an identifier. Doing the job ourselves, we+-- can see very quickly when we've run into a problem. We should also get+-- a slight efficiency boost by going through the string just once.+lexTag :: ReadP Tag+lexTag = do+  _ <- string "fromList"+  s <- look+  case s of+    'N':c:_+      | '0' <= c && c <= '9'+      -> fail "" -- We have fromListN3 or similar+      | otherwise -> FromListNTag <$ get -- Skip the 'N'+    _ -> return FromListTag++#if !MIN_VERSION_base(4,10,0)+arrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Array a)+arrayLiftReadsPrec reads_prec list_reads_prec = RdPrc.readPrec_to_S $+  arrayLiftReadPrec (RdPrc.readS_to_Prec reads_prec) (RdPrc.readS_to_Prec (const list_reads_prec)) #endif  

@@ -61,7 +61,7 @@ #if __GLASGOW_HASKELL__ >= 708 import qualified GHC.Exts as Exts ( IsList(..) ) #endif-import GHC.Prim+import GHC.Exts #if __GLASGOW_HASKELL__ >= 706     hiding (setByteArray#) #endif@@ -127,17 +127,17 @@ -- | Yield a pointer to the array's data. This operation is only safe on -- /pinned/ byte arrays allocated by 'newPinnedByteArray' or -- 'newAlignedPinnedByteArray'.-byteArrayContents :: ByteArray -> Addr+byteArrayContents :: ByteArray -> Ptr Word8 {-# INLINE byteArrayContents #-}-byteArrayContents (ByteArray arr#) = Addr (byteArrayContents# arr#)+byteArrayContents (ByteArray 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'.-mutableByteArrayContents :: MutableByteArray s -> Addr+mutableByteArrayContents :: MutableByteArray s -> Ptr Word8 {-# INLINE mutableByteArrayContents #-} mutableByteArrayContents (MutableByteArray arr#)-  = Addr (byteArrayContents# (unsafeCoerce# arr#))+  = Ptr (byteArrayContents# (unsafeCoerce# arr#))  -- | Check if the two arrays refer to the same memory block. sameMutableByteArray :: MutableByteArray s -> MutableByteArray s -> Bool@@ -208,7 +208,7 @@ {-# INLINE sizeofByteArray #-} sizeofByteArray (ByteArray arr#) = I# (sizeofByteArray# arr#) --- | Size of the mutable byte array in bytes. This function\'s behavior +-- | Size of the mutable byte array in bytes. This function\'s behavior -- is undefined if 'resizeMutableByteArray' is ever called on the mutable -- byte array given as the argument. Consequently, use of this function -- is discouraged. Prefer 'getSizeofMutableByteArray', which ensures correct@@ -261,12 +261,13 @@  -- | Right-fold over the elements of a 'ByteArray'. foldrByteArray :: forall a b. (Prim a) => (a -> b -> b) -> b -> ByteArray -> b+{-# INLINE foldrByteArray #-} foldrByteArray f z arr = go 0   where     go i-      | sizeofByteArray arr > i * sz = f (indexByteArray arr i) (go (i+1))-      | otherwise                    = z-    sz = sizeOf (undefined :: a)+      | i < maxI  = f (indexByteArray arr i) (go (i+1))+      | otherwise = z+    maxI = sizeofByteArray arr `quot` sizeOf (undefined :: a)  byteArrayFromList :: Prim a => [a] -> ByteArray byteArrayFromList xs = byteArrayFromListN (length xs) xs@@ -325,13 +326,13 @@ --   @since 0.6.4.0 copyByteArrayToAddr   :: PrimMonad m-  => Addr -- ^ destination+  => Ptr Word8 -- ^ destination   -> ByteArray -- ^ source array   -> Int -- ^ offset into source array   -> Int -- ^ number of bytes to copy   -> m () {-# INLINE copyByteArrayToAddr #-}-copyByteArrayToAddr (Addr dst#) (ByteArray src#) soff sz+copyByteArrayToAddr (Ptr dst#) (ByteArray src#) soff sz   = primitive_ (copyByteArrayToAddr# src# (unI# soff) dst# (unI# sz))  -- | Copy a slice of a mutable byte array to an unmanaged address. These must@@ -341,13 +342,13 @@ --   @since 0.6.4.0 copyMutableByteArrayToAddr   :: PrimMonad m-  => Addr -- ^ destination+  => Ptr Word8 -- ^ destination   -> MutableByteArray (PrimState m) -- ^ source array   -> Int -- ^ offset into source array   -> Int -- ^ number of bytes to copy   -> m () {-# INLINE copyMutableByteArrayToAddr #-}-copyMutableByteArrayToAddr (Addr dst#) (MutableByteArray src#) soff sz+copyMutableByteArrayToAddr (Ptr dst#) (MutableByteArray src#) soff sz   = primitive_ (copyMutableByteArrayToAddr# src# (unI# soff) dst# (unI# sz)) #endif @@ -461,7 +462,7 @@ -- | Non-lexicographic ordering. This compares the lengths of -- the byte arrays first and uses a lexicographic ordering if -- the lengths are equal. Subject to change between major versions.--- +-- -- @since 0.6.3.0 instance Ord ByteArray where   ba1@(ByteArray ba1#) `compare` ba2@(ByteArray ba2#)

@@ -17,18 +17,20 @@   setWord64Array#, setWordArray#,   setInt8Array#, setInt16Array#, setInt32Array#,   setInt64Array#, setIntArray#,-  setAddrArray#, setFloatArray#, setDoubleArray#, setWideCharArray#,+  setAddrArray#, setStablePtrArray#, setFloatArray#, setDoubleArray#,+  setWideCharArray#,    setWord8OffAddr#, setWord16OffAddr#, setWord32OffAddr#,   setWord64OffAddr#, setWordOffAddr#,   setInt8OffAddr#, setInt16OffAddr#, setInt32OffAddr#,   setInt64OffAddr#, setIntOffAddr#,-  setAddrOffAddr#, setFloatOffAddr#, setDoubleOffAddr#, setWideCharOffAddr#+  setAddrOffAddr#, setFloatOffAddr#, setDoubleOffAddr#, setWideCharOffAddr#,+  setStablePtrOffAddr# ) where  import Data.Primitive.MachDeps (Word64_#, Int64_#) import Foreign.C.Types-import GHC.Prim+import GHC.Exts  foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8"   setWord8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO ()@@ -52,6 +54,8 @@   setIntArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr"   setAddrArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Addr# -> IO ()+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr"+  setStablePtrArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> StablePtr# a -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float"   setFloatArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Float# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double"@@ -81,6 +85,8 @@   setIntOffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr"   setAddrOffAddr# :: Addr# -> CPtrdiff -> CSize -> Addr# -> IO ()+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr"+  setStablePtrOffAddr# :: Addr# -> CPtrdiff -> CSize -> StablePtr# a -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float"   setFloatOffAddr# :: Addr# -> CPtrdiff -> CSize -> Float# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double"

@@ -14,7 +14,7 @@  #include "MachDeps.h" -import GHC.Prim+import GHC.Exts  sIZEOF_CHAR,  aLIGNMENT_CHAR,

@@ -1,4 +1,4 @@-{-# LANGUAGE MagicHash, UnboxedTuples, DeriveDataTypeable #-}+{-# LANGUAGE MagicHash, UnboxedTuples, DeriveDataTypeable, CPP #-}  -- | -- Module      : Data.Primitive.MutVar@@ -25,7 +25,7 @@ ) where  import Control.Monad.Primitive ( PrimMonad(..), primitive_ )-import GHC.Prim ( MutVar#, sameMutVar#, newMutVar#,+import GHC.Exts ( MutVar#, sameMutVar#, newMutVar#,                   readMutVar#, writeMutVar#, atomicModifyMutVar# ) import Data.Primitive.Internal.Compat ( isTrue# ) import Data.Typeable ( Typeable )@@ -68,7 +68,8 @@   b <- atomicModifyMutVar mv force   b `seq` return b   where-    force x = let (a, b) = f x in (a, a `seq` b)+    force x = case f x of+                v@(x',_) -> x' `seq` v  -- | Mutate the contents of a 'MutVar' modifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m ()@@ -83,4 +84,3 @@ modifyMutVar' (MutVar mv#) g = primitive_ $ \s# ->   case readMutVar# mv# s# of     (# s'#, a #) -> let a' = g a in a' `seq` writeMutVar# mv# a' s'#-

@@ -6,7 +6,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -Wall #-}  -- | -- Module      : Data.Primitive.PrimArray@@ -94,10 +93,8 @@   , mapMaybePrimArrayP   ) where -import GHC.Prim+import GHC.Exts import GHC.Base ( Int(..) )-import GHC.Exts (build)-import GHC.Ptr import Data.Primitive.Internal.Compat (isTrue#) import Data.Primitive.Types import Data.Primitive.ByteArray (ByteArray(..))@@ -159,9 +156,10 @@     loop !i       | i < 0 = True       | otherwise = indexPrimArray a1 i == indexPrimArray a2 i && loop (i-1)+  {-# INLINE (==) #-}  -- | Lexicographic ordering. Subject to change between major versions.--- +-- --   @since 0.6.4.0 instance (Ord a, Prim a) => Ord (PrimArray a) where   compare a1@(PrimArray ba1#) a2@(PrimArray ba2#)@@ -174,6 +172,7 @@     loop !i       | i < sz = compare (indexPrimArray a1 i) (indexPrimArray a2 i) <> loop (i+1)       | otherwise = compare sz1 sz2+  {-# INLINE compare #-}  #if MIN_VERSION_base(4,7,0) -- | @since 0.6.4.0@@ -252,7 +251,7 @@ newPrimArray :: forall m a. (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a) {-# INLINE newPrimArray #-} newPrimArray (I# n#)-  = primitive (\s# -> +  = primitive (\s# ->       case newByteArray# (n# *# sizeOf# (undefined :: a)) s# of         (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #)     )@@ -328,7 +327,7 @@ {-# INLINE copyMutablePrimArray #-} copyMutablePrimArray (MutablePrimArray dst#) (I# doff#) (MutablePrimArray src#) (I# soff#) (I# n#)   = primitive_ (copyMutableByteArray#-      src# +      src#       (soff# *# (sizeOf# (undefined :: a)))       dst#       (doff# *# (sizeOf# (undefined :: a)))@@ -347,7 +346,7 @@ {-# INLINE copyPrimArray #-} copyPrimArray (MutablePrimArray dst#) (I# doff#) (PrimArray src#) (I# soff#) (I# n#)   = primitive_ (copyByteArray#-      src# +      src#       (soff# *# (sizeOf# (undefined :: a)))       dst#       (doff# *# (sizeOf# (undefined :: a)))@@ -412,7 +411,7 @@ {-# INLINE getSizeofMutablePrimArray #-} #if __GLASGOW_HASKELL__ >= 801 getSizeofMutablePrimArray (MutablePrimArray arr#)-  = primitive (\s# -> +  = primitive (\s# ->       case getSizeofMutableByteArray# arr# s# of         (# s'#, sz# #) -> (# s'#, I# (quotInt# sz# (sizeOf# (undefined :: a))) #)     )@@ -539,7 +538,7 @@ -- > incrPositiveB xs = runST $ runMaybeT $ traversePrimArrayP -- >   (\x -> bool (MaybeT (return Nothing)) (MaybeT (return (Just (x + 1)))) (x > 0)) -- >   xs--- +-- -- Benchmarks demonstrate that the second implementation runs 150 times -- faster than the first. It also results in fewer allocations. {-# INLINE traversePrimArrayP #-}@@ -785,7 +784,7 @@ -- *** Exception: Prelude.undefined -- -- The function 'traversePrimArrayP' always outperforms this function, but it--- requires a 'PrimAffineMonad' constraint, and it forces the values as+-- requires a 'PrimMonad' constraint, and it forces the values as -- it performs the effects. traversePrimArray ::      (Applicative f, Prim a, Prim b)

@@ -40,7 +40,7 @@ #endif  import GHC.Base ( Int(..) )-import GHC.Prim+import GHC.Exts  import GHC.Ptr import Foreign.Marshal.Utils@@ -118,7 +118,7 @@   -> Int -- ^ number of elements   -> m () {-# INLINE copyPtrToMutablePrimArray #-}-copyPtrToMutablePrimArray (MutablePrimArray ba#) (I# doff#) (Ptr addr#) (I# n#) = +copyPtrToMutablePrimArray (MutablePrimArray ba#) (I# doff#) (Ptr addr#) (I# n#) =   primitive_ (copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#))   where   siz# = sizeOf# (undefined :: a)

@@ -74,6 +74,7 @@  import Control.Applicative import Control.Monad+import qualified Control.Monad.Fail as Fail import Control.Monad.Fix import Control.Monad.Primitive import Control.Monad.ST@@ -808,6 +809,11 @@      copySmallArray smb off sb 0 (length sb)        *> fill (off + length sb) sbs smb +#if !(MIN_VERSION_base(4,13,0))+  fail = Fail.fail+#endif++instance Fail.MonadFail SmallArray where   fail _ = emptySmallArray  instance MonadPlus SmallArray where

@@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TypeInType #-}+{-# LANGUAGE DeriveGeneric #-} #endif  #include "HsBaseConfig.h"@@ -19,11 +20,10 @@ --  module Data.Primitive.Types (-  Prim(..),-  sizeOf, alignment, defaultSetByteArray#, defaultSetOffAddr#,--  Addr(..),-  PrimStorable(..)+  Prim(..)+  ,sizeOf, alignment, defaultSetByteArray#, defaultSetOffAddr#+  ,PrimStorable(..)+  ,Ptr(..) ) where  import Control.Monad.Primitive@@ -48,44 +48,40 @@ import GHC.Ptr (     Ptr(..), FunPtr(..)   )+import GHC.Stable (+    StablePtr(..)+  ) -import GHC.Prim+import GHC.Exts #if __GLASGOW_HASKELL__ >= 706     hiding (setByteArray#) #endif -import Data.Typeable ( Typeable )-import Data.Data ( Data(..) )-import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType )++import Data.Primitive.Internal.Compat ( isTrue# ) import Foreign.Storable (Storable)-import Numeric -import qualified Foreign.Storable as FS --- | A machine address-data Addr = Addr Addr# deriving ( Typeable )--instance Show Addr where-  showsPrec _ (Addr a) =-    showString "0x" . showHex (fromIntegral (I# (addr2Int# a)) :: Word)--instance Eq Addr where-  Addr a# == Addr b# = isTrue# (eqAddr# a# b#)-  Addr a# /= Addr b# = isTrue# (neAddr# a# b#)--instance Ord Addr where-  Addr a# > Addr b# = isTrue# (gtAddr# a# b#)-  Addr a# >= Addr b# = isTrue# (geAddr# a# b#)-  Addr a# < Addr b# = isTrue# (ltAddr# a# b#)-  Addr a# <= Addr b# = isTrue# (leAddr# a# b#)--instance Data Addr where-  toConstr _ = error "toConstr"-  gunfold _ _ = error "gunfold"-  dataTypeOf _ = mkNoRepType "Data.Primitive.Types.Addr"+import qualified Foreign.Storable as FS +import Control.Applicative (Const(..))+#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity(..))+import qualified Data.Monoid as Monoid+#endif+#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down(..))+#else+import GHC.Exts (Down(..))+#endif+#if MIN_VERSION_base(4,9,0)+import qualified Data.Semigroup as Semigroup+#endif --- | Class of types supporting primitive array operations+-- | Class of types supporting primitive array operations. This includes+-- interfacing with GC-managed memory (functions suffixed with @ByteArray#@)+-- and interfacing with unmanaged memory (functions suffixed with @Addr#@).+-- Endianness is platform-dependent. class Prim a where    -- | Size of values of type @a@. The argument is not used.@@ -288,12 +284,12 @@ derivePrim(Char, C#, sIZEOF_CHAR, aLIGNMENT_CHAR,            indexWideCharArray#, readWideCharArray#, writeWideCharArray#, setWideCharArray#,            indexWideCharOffAddr#, readWideCharOffAddr#, writeWideCharOffAddr#, setWideCharOffAddr#)-derivePrim(Addr, Addr, sIZEOF_PTR, aLIGNMENT_PTR,-           indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#,-           indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#) derivePrim(Ptr a, Ptr, sIZEOF_PTR, aLIGNMENT_PTR,            indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#,            indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#)+derivePrim(StablePtr a, StablePtr, sIZEOF_PTR, aLIGNMENT_PTR,+           indexStablePtrArray#, readStablePtrArray#, writeStablePtrArray#, setStablePtrArray#,+           indexStablePtrOffAddr#, readStablePtrOffAddr#, writeStablePtrOffAddr#, setStablePtrOffAddr#) derivePrim(FunPtr a, FunPtr, sIZEOF_PTR, aLIGNMENT_PTR,            indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#,            indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#)@@ -393,3 +389,28 @@ deriving instance Prim CTimer #endif deriving instance Prim Fd++-- | @since 0.6.5.0+deriving instance Prim a => Prim (Const a b)+-- | @since 0.6.5.0+deriving instance Prim a => Prim (Down a)+#if MIN_VERSION_base(4,8,0)+-- | @since 0.6.5.0+deriving instance Prim a => Prim (Identity a)+-- | @since 0.6.5.0+deriving instance Prim a => Prim (Monoid.Dual a)+-- | @since 0.6.5.0+deriving instance Prim a => Prim (Monoid.Sum a)+-- | @since 0.6.5.0+deriving instance Prim a => Prim (Monoid.Product a)+#endif+#if MIN_VERSION_base(4,9,0)+-- | @since 0.6.5.0+deriving instance Prim a => Prim (Semigroup.First a)+-- | @since 0.6.5.0+deriving instance Prim a => Prim (Semigroup.Last a)+-- | @since 0.6.5.0+deriving instance Prim a => Prim (Semigroup.Min a)+-- | @since 0.6.5.0+deriving instance Prim a => Prim (Semigroup.Max a)+#endif

@@ -1,638 +0,0 @@-{-# Language BangPatterns #-}-{-# Language CPP #-}-{-# Language DeriveDataTypeable #-}-{-# Language MagicHash #-}-{-# Language RankNTypes #-}-{-# Language ScopedTypeVariables #-}-{-# Language TypeFamilies #-}-{-# Language UnboxedTuples #-}---- |--- Module      : Data.Primitive.UnliftedArray--- Copyright   : (c) Dan Doel 2016--- License     : BSD-style------ Maintainer  : Libraries <libraries@haskell.org>--- Portability : non-portable------ GHC contains three general classes of value types:------   1. Unboxed types: values are machine values made up of fixed numbers of bytes---   2. Unlifted types: values are pointers, but strictly evaluated---   3. Lifted types: values are pointers, lazily evaluated------ The first category can be stored in a 'ByteArray', and this allows types in--- category 3 that are simple wrappers around category 1 types to be stored--- more efficiently using a 'ByteArray'. This module provides the same facility--- for category 2 types.------ GHC has two primitive types, 'ArrayArray#' and 'MutableArrayArray#'. These--- are arrays of pointers, but of category 2 values, so they are known to not--- be bottom. This allows types that are wrappers around such types to be stored--- in an array without an extra level of indirection.------ The way that the 'ArrayArray#' API works is that one can read and write--- 'ArrayArray#' values to the positions. This works because all category 2--- types share a uniform representation, unlike unboxed values which are--- represented by varying (by type) numbers of bytes. However, using the--- this makes the internal API very unsafe to use, as one has to coerce values--- to and from 'ArrayArray#'.------ The API presented by this module is more type safe. 'UnliftedArray' and--- 'MutableUnliftedArray' are parameterized by the type of arrays they contain, and--- the coercions necessary are abstracted into a class, 'PrimUnlifted', of things--- that are eligible to be stored.--module Data.Primitive.UnliftedArray-  ( -- * Types-    UnliftedArray(..)-  , MutableUnliftedArray(..)-  , PrimUnlifted(..)-    -- * Operations-  , unsafeNewUnliftedArray-  , newUnliftedArray-  , setUnliftedArray-  , sizeofUnliftedArray-  , sizeofMutableUnliftedArray-  , readUnliftedArray-  , writeUnliftedArray-  , indexUnliftedArray-  , indexUnliftedArrayM-  , unsafeFreezeUnliftedArray-  , freezeUnliftedArray-  , thawUnliftedArray-  , runUnliftedArray-  , sameMutableUnliftedArray-  , copyUnliftedArray-  , copyMutableUnliftedArray-  , cloneUnliftedArray-  , cloneMutableUnliftedArray-    -- * List Conversion-  , unliftedArrayToList-  , unliftedArrayFromList-  , unliftedArrayFromListN-    -- * Folding-  , foldrUnliftedArray-  , foldrUnliftedArray'-  , foldlUnliftedArray-  , foldlUnliftedArray'-    -- * Mapping-  , mapUnliftedArray--- Missing operations:---  , unsafeThawUnliftedArray-  ) where--import Data.Typeable-import Control.Applicative--import GHC.Prim-import GHC.Base (Int(..),build)--import Control.Monad.Primitive--import Control.Monad.ST (runST,ST)--import Data.Monoid (Monoid,mappend)-import Data.Primitive.Internal.Compat ( isTrue# )--import qualified Data.List as L-import           Data.Primitive.Array (Array)-import qualified Data.Primitive.Array as A-import           Data.Primitive.ByteArray (ByteArray)-import qualified Data.Primitive.ByteArray as BA-import qualified Data.Primitive.PrimArray as PA-import qualified Data.Primitive.SmallArray as SA-import qualified Data.Primitive.MutVar as MV-import qualified Data.Monoid-import qualified GHC.MVar as GM (MVar(..))-import qualified GHC.Conc as GC (TVar(..))-import qualified GHC.Stable as GSP (StablePtr(..))-import qualified GHC.Weak as GW (Weak(..))-import qualified GHC.Conc.Sync as GCS (ThreadId(..))-import qualified GHC.Exts as E-import qualified GHC.ST as GHCST--#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup)-import qualified Data.Semigroup-#endif--#if MIN_VERSION_base(4,10,0)-import GHC.Exts (runRW#)-#elif MIN_VERSION_base(4,9,0)-import GHC.Base (runRW#)-#endif---- | Immutable arrays that efficiently store types that are simple wrappers--- around unlifted primitive types. The values of the unlifted type are--- stored directly, eliminating a layer of indirection.-data UnliftedArray e = UnliftedArray ArrayArray#-  deriving (Typeable)---- | Mutable arrays that efficiently store types that are simple wrappers--- around unlifted primitive types. The values of the unlifted type are--- stored directly, eliminating a layer of indirection.-data MutableUnliftedArray s e = MutableUnliftedArray (MutableArrayArray# s)-  deriving (Typeable)---- | Classifies the types that are able to be stored in 'UnliftedArray' and--- 'MutableUnliftedArray'. These should be types that are just liftings of the--- unlifted pointer types, so that their internal contents can be safely coerced--- into an 'ArrayArray#'.-class PrimUnlifted a where-  toArrayArray# :: a -> ArrayArray#-  fromArrayArray# :: ArrayArray# -> a--instance PrimUnlifted (UnliftedArray e) where-  toArrayArray# (UnliftedArray aa#) = aa#-  fromArrayArray# aa# = UnliftedArray aa#--instance PrimUnlifted (MutableUnliftedArray s e) where-  toArrayArray# (MutableUnliftedArray maa#) = unsafeCoerce# maa#-  fromArrayArray# aa# = MutableUnliftedArray (unsafeCoerce# aa#)--instance PrimUnlifted (Array a) where-  toArrayArray# (A.Array a#) = unsafeCoerce# a#-  fromArrayArray# aa# = A.Array (unsafeCoerce# aa#)--instance PrimUnlifted (A.MutableArray s a) where-  toArrayArray# (A.MutableArray ma#) = unsafeCoerce# ma#-  fromArrayArray# aa# = A.MutableArray (unsafeCoerce# aa#)--instance PrimUnlifted ByteArray where-  toArrayArray# (BA.ByteArray ba#) = unsafeCoerce# ba#-  fromArrayArray# aa# = BA.ByteArray (unsafeCoerce# aa#)--instance PrimUnlifted (BA.MutableByteArray s) where-  toArrayArray# (BA.MutableByteArray mba#) = unsafeCoerce# mba#-  fromArrayArray# aa# = BA.MutableByteArray (unsafeCoerce# aa#)---- | @since 0.6.4.0-instance PrimUnlifted (PA.PrimArray a) where-  toArrayArray# (PA.PrimArray ba#) = unsafeCoerce# ba#-  fromArrayArray# aa# = PA.PrimArray (unsafeCoerce# aa#)---- | @since 0.6.4.0-instance PrimUnlifted (PA.MutablePrimArray s a) where-  toArrayArray# (PA.MutablePrimArray mba#) = unsafeCoerce# mba#-  fromArrayArray# aa# = PA.MutablePrimArray (unsafeCoerce# aa#)--instance PrimUnlifted (SA.SmallArray a) where-  toArrayArray# (SA.SmallArray sa#) = unsafeCoerce# sa#-  fromArrayArray# aa# = SA.SmallArray (unsafeCoerce# aa#)--instance PrimUnlifted (SA.SmallMutableArray s a) where-  toArrayArray# (SA.SmallMutableArray sma#) = unsafeCoerce# sma#-  fromArrayArray# aa# = SA.SmallMutableArray (unsafeCoerce# aa#)--instance PrimUnlifted (MV.MutVar s a) where-  toArrayArray# (MV.MutVar mv#) = unsafeCoerce# mv#-  fromArrayArray# aa# = MV.MutVar (unsafeCoerce# aa#)---- | @since 0.6.4.0-instance PrimUnlifted (GM.MVar a) where-  toArrayArray# (GM.MVar mv#) = unsafeCoerce# mv#-  fromArrayArray# mv# = GM.MVar (unsafeCoerce# mv#)---- | @since 0.6.4.0-instance PrimUnlifted (GC.TVar a) where-  toArrayArray# (GC.TVar tv#) = unsafeCoerce# tv#-  fromArrayArray# tv# = GC.TVar (unsafeCoerce# tv#)---- | @since 0.6.4.0-instance PrimUnlifted (GSP.StablePtr a) where-  toArrayArray# (GSP.StablePtr tv#) = unsafeCoerce# tv#-  fromArrayArray# tv# = GSP.StablePtr (unsafeCoerce# tv#)---- | @since 0.6.4.0-instance PrimUnlifted (GW.Weak a) where-  toArrayArray# (GW.Weak tv#) = unsafeCoerce# tv#-  fromArrayArray# tv# = GW.Weak (unsafeCoerce# tv#)---- | @since 0.6.4.0-instance PrimUnlifted GCS.ThreadId where-  toArrayArray# (GCS.ThreadId tv#) = unsafeCoerce# tv#-  fromArrayArray# tv# = GCS.ThreadId (unsafeCoerce# tv#)--die :: String -> String -> a-die fun problem = error $ "Data.Primitive.UnliftedArray." ++ fun ++ ": " ++ problem---- | Creates a new 'MutableUnliftedArray'. This function is unsafe because it--- initializes all elements of the array as pointers to the array itself. Attempting--- to read one of these elements before writing to it is in effect an unsafe--- coercion from the @MutableUnliftedArray s a@ to the element type.-unsafeNewUnliftedArray-  :: (PrimMonad m)-  => Int -- ^ size-  -> m (MutableUnliftedArray (PrimState m) a)-unsafeNewUnliftedArray (I# i#) = primitive $ \s -> case newArrayArray# i# s of-  (# s', maa# #) -> (# s', MutableUnliftedArray maa# #)-{-# inline unsafeNewUnliftedArray #-}---- | Sets all the positions in an unlifted array to the designated value.-setUnliftedArray-  :: (PrimMonad m, PrimUnlifted a)-  => MutableUnliftedArray (PrimState m) a -- ^ destination-  -> a -- ^ value to fill with-  -> m ()-setUnliftedArray mua v = loop $ sizeofMutableUnliftedArray mua - 1- where- loop i | i < 0     = return ()-        | otherwise = writeUnliftedArray mua i v >> loop (i-1)-{-# inline setUnliftedArray #-}---- | Creates a new 'MutableUnliftedArray' with the specified value as initial--- contents. This is slower than 'unsafeNewUnliftedArray', but safer.-newUnliftedArray-  :: (PrimMonad m, PrimUnlifted a)-  => Int -- ^ size-  -> a -- ^ initial value-  -> m (MutableUnliftedArray (PrimState m) a)-newUnliftedArray len v =-  unsafeNewUnliftedArray len >>= \mua -> setUnliftedArray mua v >> return mua-{-# inline newUnliftedArray #-}---- | Yields the length of an 'UnliftedArray'.-sizeofUnliftedArray :: UnliftedArray e -> Int-sizeofUnliftedArray (UnliftedArray aa#) = I# (sizeofArrayArray# aa#)-{-# inline sizeofUnliftedArray #-}---- | Yields the length of a 'MutableUnliftedArray'.-sizeofMutableUnliftedArray :: MutableUnliftedArray s e -> Int-sizeofMutableUnliftedArray (MutableUnliftedArray maa#)-  = I# (sizeofMutableArrayArray# maa#)-{-# inline sizeofMutableUnliftedArray #-}---- Internal indexing function.------ Note: ArrayArray# is strictly evaluated, so this should have similar--- consequences to indexArray#, where matching on the unboxed single causes the--- array access to happen.-indexUnliftedArrayU-  :: PrimUnlifted a-  => UnliftedArray a-  -> Int-  -> (# a #)-indexUnliftedArrayU (UnliftedArray src#) (I# i#)-  = case indexArrayArrayArray# src# i# of-      aa# -> (# fromArrayArray# aa# #)-{-# inline indexUnliftedArrayU #-}---- | Gets the value at the specified position of an 'UnliftedArray'.-indexUnliftedArray-  :: PrimUnlifted a-  => UnliftedArray a -- ^ source-  -> Int -- ^ index-  -> a-indexUnliftedArray ua i-  = case indexUnliftedArrayU ua i of (# v #) -> v-{-# inline indexUnliftedArray #-}---- | Gets the value at the specified position of an 'UnliftedArray'.--- The purpose of the 'Monad' is to allow for being eager in the--- 'UnliftedArray' value without having to introduce a data dependency--- directly on the result value.------ It should be noted that this is not as much of a problem as with a normal--- 'Array', because elements of an 'UnliftedArray' are guaranteed to not--- be exceptional. This function is provided in case it is more desirable--- than being strict in the result value.-indexUnliftedArrayM-  :: (PrimUnlifted a, Monad m)-  => UnliftedArray a -- ^ source-  -> Int -- ^ index-  -> m a-indexUnliftedArrayM ua i-  = case indexUnliftedArrayU ua i of-      (# v #) -> return v-{-# inline indexUnliftedArrayM #-}---- | Gets the value at the specified position of a 'MutableUnliftedArray'.-readUnliftedArray-  :: (PrimMonad m, PrimUnlifted a)-  => MutableUnliftedArray (PrimState m) a -- ^ source-  -> Int -- ^ index-  -> m a-readUnliftedArray (MutableUnliftedArray maa#) (I# i#)-  = primitive $ \s -> case readArrayArrayArray# maa# i# s of-      (# s', aa# #) -> (# s',  fromArrayArray# aa# #)-{-# inline readUnliftedArray #-}---- | Sets the value at the specified position of a 'MutableUnliftedArray'.-writeUnliftedArray-  :: (PrimMonad m, PrimUnlifted a)-  => MutableUnliftedArray (PrimState m) a -- ^ destination-  -> Int -- ^ index-  -> a -- ^ value-  -> m ()-writeUnliftedArray (MutableUnliftedArray maa#) (I# i#) a-  = primitive_ (writeArrayArrayArray# maa# i# (toArrayArray# a))-{-# inline writeUnliftedArray #-}---- | Freezes a 'MutableUnliftedArray', yielding an 'UnliftedArray'. This simply--- marks the array as frozen in place, so it should only be used when no further--- modifications to the mutable array will be performed.-unsafeFreezeUnliftedArray-  :: (PrimMonad m)-  => MutableUnliftedArray (PrimState m) a-  -> m (UnliftedArray a)-unsafeFreezeUnliftedArray (MutableUnliftedArray maa#)-  = primitive $ \s -> case unsafeFreezeArrayArray# maa# s of-      (# s', aa# #) -> (# s', UnliftedArray aa# #)-{-# inline unsafeFreezeUnliftedArray #-}---- | Determines whether two 'MutableUnliftedArray' values are the same. This is--- object/pointer identity, not based on the contents.-sameMutableUnliftedArray-  :: MutableUnliftedArray s a-  -> MutableUnliftedArray s a-  -> Bool-sameMutableUnliftedArray (MutableUnliftedArray maa1#) (MutableUnliftedArray maa2#)-  = isTrue# (sameMutableArrayArray# maa1# maa2#)-{-# inline sameMutableUnliftedArray #-}---- | Copies the contents of an immutable array into a mutable array.-copyUnliftedArray-  :: (PrimMonad m)-  => MutableUnliftedArray (PrimState m) a -- ^ destination-  -> Int -- ^ offset into destination-  -> UnliftedArray a -- ^ source-  -> Int -- ^ offset into source-  -> Int -- ^ number of elements to copy-  -> m ()-copyUnliftedArray-  (MutableUnliftedArray dst) (I# doff)-  (UnliftedArray src) (I# soff) (I# ln) =-    primitive_ $ copyArrayArray# src soff dst doff ln-{-# inline copyUnliftedArray #-}---- | Copies the contents of one mutable array into another.-copyMutableUnliftedArray-  :: (PrimMonad m)-  => MutableUnliftedArray (PrimState m) a -- ^ destination-  -> Int -- ^ offset into destination-  -> MutableUnliftedArray (PrimState m) a -- ^ source-  -> Int -- ^ offset into source-  -> Int -- ^ number of elements to copy-  -> m ()-copyMutableUnliftedArray-  (MutableUnliftedArray dst) (I# doff)-  (MutableUnliftedArray src) (I# soff) (I# ln) =-    primitive_ $ copyMutableArrayArray# src soff dst doff ln-{-# inline copyMutableUnliftedArray #-}---- | Freezes a portion of a 'MutableUnliftedArray', yielding an 'UnliftedArray'.--- This operation is safe, in that it copies the frozen portion, and the--- existing mutable array may still be used afterward.-freezeUnliftedArray-  :: (PrimMonad m)-  => MutableUnliftedArray (PrimState m) a -- ^ source-  -> Int -- ^ offset-  -> Int -- ^ length-  -> m (UnliftedArray a)-freezeUnliftedArray src off len = do-  dst <- unsafeNewUnliftedArray len-  copyMutableUnliftedArray dst 0 src off len-  unsafeFreezeUnliftedArray dst-{-# inline freezeUnliftedArray #-}---- | Thaws a portion of an 'UnliftedArray', yielding a 'MutableUnliftedArray'.--- This copies the thawed portion, so mutations will not affect the original--- array.-thawUnliftedArray-  :: (PrimMonad m)-  => UnliftedArray a -- ^ source-  -> Int -- ^ offset-  -> Int -- ^ length-  -> m (MutableUnliftedArray (PrimState m) a)-thawUnliftedArray src off len = do-  dst <- unsafeNewUnliftedArray len-  copyUnliftedArray dst 0 src off len-  return dst-{-# inline thawUnliftedArray #-}--#if !MIN_VERSION_base(4,9,0)-unsafeCreateUnliftedArray-  :: Int-  -> (forall s. MutableUnliftedArray s a -> ST s ())-  -> UnliftedArray a-unsafeCreateUnliftedArray 0 _ = emptyUnliftedArray-unsafeCreateUnliftedArray n f = runUnliftedArray $ do-  mary <- unsafeNewUnliftedArray n-  f mary-  pure mary---- | Execute a stateful computation and freeze the resulting array.-runUnliftedArray-  :: (forall s. ST s (MutableUnliftedArray s a))-  -> UnliftedArray a-runUnliftedArray m = runST $ m >>= unsafeFreezeUnliftedArray--#else /* Below, runRW# is available. */---- This low-level business is designed to work with GHC's worker-wrapper--- transformation. A lot of the time, we don't actually need an Array--- constructor. By putting it on the outside, and being careful about--- how we special-case the empty array, we can make GHC smarter about this.--- The only downside is that separately created 0-length arrays won't share--- their Array constructors, although they'll share their underlying--- Array#s.-unsafeCreateUnliftedArray-  :: Int-  -> (forall s. MutableUnliftedArray s a -> ST s ())-  -> UnliftedArray a-unsafeCreateUnliftedArray 0 _ = UnliftedArray (emptyArrayArray# (# #))-unsafeCreateUnliftedArray n f = runUnliftedArray $ do-  mary <- unsafeNewUnliftedArray n-  f mary-  pure mary---- | Execute a stateful computation and freeze the resulting array.-runUnliftedArray-  :: (forall s. ST s (MutableUnliftedArray s a))-  -> UnliftedArray a-runUnliftedArray m = UnliftedArray (runUnliftedArray# m)--runUnliftedArray#-  :: (forall s. ST s (MutableUnliftedArray s a))-  -> ArrayArray#-runUnliftedArray# m = case runRW# $ \s ->-  case unST m s of { (# s', MutableUnliftedArray mary# #) ->-  unsafeFreezeArrayArray# mary# s'} of (# _, ary# #) -> ary#--unST :: ST s a -> State# s -> (# State# s, a #)-unST (GHCST.ST f) = f--emptyArrayArray# :: (# #) -> ArrayArray#-emptyArrayArray# _ = case emptyUnliftedArray of UnliftedArray ar -> ar-{-# NOINLINE emptyArrayArray# #-}-#endif---- | Creates a copy of a portion of an 'UnliftedArray'-cloneUnliftedArray-  :: UnliftedArray a -- ^ source-  -> Int -- ^ offset-  -> Int -- ^ length-  -> UnliftedArray a-cloneUnliftedArray src off len =-  runUnliftedArray (thawUnliftedArray src off len)-{-# inline cloneUnliftedArray #-}---- | Creates a new 'MutableUnliftedArray' containing a copy of a portion of--- another mutable array.-cloneMutableUnliftedArray-  :: (PrimMonad m)-  => MutableUnliftedArray (PrimState m) a -- ^ source-  -> Int -- ^ offset-  -> Int -- ^ length-  -> m (MutableUnliftedArray (PrimState m) a)-cloneMutableUnliftedArray src off len = do-  dst <- unsafeNewUnliftedArray len-  copyMutableUnliftedArray dst 0 src off len-  return dst-{-# inline cloneMutableUnliftedArray #-}--instance Eq (MutableUnliftedArray s a) where-  (==) = sameMutableUnliftedArray--instance (Eq a, PrimUnlifted a) => Eq (UnliftedArray a) where-  aa1 == aa2 = sizeofUnliftedArray aa1 == sizeofUnliftedArray aa2-            && loop (sizeofUnliftedArray aa1 - 1)-   where-   loop i-     | i < 0 = True-     | otherwise = indexUnliftedArray aa1 i == indexUnliftedArray aa2 i && loop (i-1)---- | Lexicographic ordering. Subject to change between major versions.------   @since 0.6.4.0-instance (Ord a, PrimUnlifted a) => Ord (UnliftedArray a) where-  compare a1 a2 = loop 0-    where-    mn = sizeofUnliftedArray a1 `min` sizeofUnliftedArray a2-    loop i-      | i < mn-      , x1 <- indexUnliftedArray a1 i-      , x2 <- indexUnliftedArray a2 i-      = compare x1 x2 `mappend` loop (i+1)-      | otherwise = compare (sizeofUnliftedArray a1) (sizeofUnliftedArray a2)---- | @since 0.6.4.0-instance (Show a, PrimUnlifted a) => Show (UnliftedArray a) where-  showsPrec p a = showParen (p > 10) $-    showString "fromListN " . shows (sizeofUnliftedArray a) . showString " "-      . shows (unliftedArrayToList a)--#if MIN_VERSION_base(4,9,0)--- | @since 0.6.4.0-instance PrimUnlifted a => Semigroup (UnliftedArray a) where-  (<>) = concatUnliftedArray-#endif---- | @since 0.6.4.0-instance PrimUnlifted a => Monoid (UnliftedArray a) where-  mempty = emptyUnliftedArray-#if !(MIN_VERSION_base(4,11,0))-  mappend = concatUnliftedArray-#endif--emptyUnliftedArray :: UnliftedArray a-emptyUnliftedArray = runUnliftedArray (unsafeNewUnliftedArray 0)-{-# NOINLINE emptyUnliftedArray #-}--concatUnliftedArray :: UnliftedArray a -> UnliftedArray a -> UnliftedArray a-concatUnliftedArray x y = unsafeCreateUnliftedArray (sizeofUnliftedArray x + sizeofUnliftedArray y) $ \m -> do-  copyUnliftedArray m 0 x 0 (sizeofUnliftedArray x)-  copyUnliftedArray m (sizeofUnliftedArray x) y 0 (sizeofUnliftedArray y)---- | Lazy right-associated fold over the elements of an 'UnliftedArray'.-{-# INLINE foldrUnliftedArray #-}-foldrUnliftedArray :: forall a b. PrimUnlifted a => (a -> b -> b) -> b -> UnliftedArray a -> b-foldrUnliftedArray f z arr = go 0-  where-    !sz = sizeofUnliftedArray arr-    go !i-      | sz > i = f (indexUnliftedArray arr i) (go (i+1))-      | otherwise = z---- | Strict right-associated fold over the elements of an 'UnliftedArray.-{-# INLINE foldrUnliftedArray' #-}-foldrUnliftedArray' :: forall a b. PrimUnlifted a => (a -> b -> b) -> b -> UnliftedArray a -> b-foldrUnliftedArray' f z0 arr = go (sizeofUnliftedArray arr - 1) z0-  where-    go !i !acc-      | i < 0 = acc-      | otherwise = go (i - 1) (f (indexUnliftedArray arr i) acc)---- | Lazy left-associated fold over the elements of an 'UnliftedArray'.-{-# INLINE foldlUnliftedArray #-}-foldlUnliftedArray :: forall a b. PrimUnlifted a => (b -> a -> b) -> b -> UnliftedArray a -> b-foldlUnliftedArray f z arr = go (sizeofUnliftedArray arr - 1)-  where-    go !i-      | i < 0 = z-      | otherwise = f (go (i - 1)) (indexUnliftedArray arr i)---- | Strict left-associated fold over the elements of an 'UnliftedArray'.-{-# INLINE foldlUnliftedArray' #-}-foldlUnliftedArray' :: forall a b. PrimUnlifted a => (b -> a -> b) -> b -> UnliftedArray a -> b-foldlUnliftedArray' f z0 arr = go 0 z0-  where-    !sz = sizeofUnliftedArray arr-    go !i !acc-      | i < sz = go (i + 1) (f acc (indexUnliftedArray arr i))-      | otherwise = acc---- | Map over the elements of an 'UnliftedArray'.-{-# INLINE mapUnliftedArray #-}-mapUnliftedArray :: (PrimUnlifted a, PrimUnlifted b)-  => (a -> b)-  -> UnliftedArray a-  -> UnliftedArray b-mapUnliftedArray f arr = unsafeCreateUnliftedArray sz $ \marr -> do-  let go !ix = if ix < sz-        then do-          let b = f (indexUnliftedArray arr ix)-          writeUnliftedArray marr ix b-          go (ix + 1)-        else return ()-  go 0-  where-  !sz = sizeofUnliftedArray arr---- | Convert the unlifted array to a list.-{-# INLINE unliftedArrayToList #-}-unliftedArrayToList :: PrimUnlifted a => UnliftedArray a -> [a]-unliftedArrayToList xs = build (\c n -> foldrUnliftedArray c n xs)--unliftedArrayFromList :: PrimUnlifted a => [a] -> UnliftedArray a-unliftedArrayFromList xs = unliftedArrayFromListN (L.length xs) xs--unliftedArrayFromListN :: forall a. PrimUnlifted a => Int -> [a] -> UnliftedArray a-unliftedArrayFromListN len vs = unsafeCreateUnliftedArray len run where-  run :: forall s. MutableUnliftedArray s a -> ST s ()-  run arr = do-    let go :: [a] -> Int -> ST s ()-        go [] !ix = if ix == len-          -- The size check is mandatory since failure to initialize all elements-          -- introduces the possibility of a segfault happening when someone attempts-          -- to read the unitialized element. See the docs for unsafeNewUnliftedArray.-          then return ()-          else die "unliftedArrayFromListN" "list length less than specified size"-        go (a : as) !ix = if ix < len-          then do-            writeUnliftedArray arr ix a-            go as (ix + 1)-          else die "unliftedArrayFromListN" "list length greater than specified size"-    go vs 0---#if MIN_VERSION_base(4,7,0)--- | @since 0.6.4.0-instance PrimUnlifted a => E.IsList (UnliftedArray a) where-  type Item (UnliftedArray a) = a-  fromList = unliftedArrayFromList-  fromListN = unliftedArrayFromListN-  toList = unliftedArrayToList-#endif-

@@ -1,3 +1,34 @@+## Changes in version 0.7.0.0++  * Remove `Addr` data type, lifted code should use `Ptr a` now++  * Define `MonadFail` instances for `Array` and `SmallArray`.++  * Define `unsafeInterleave`.++  * Add a `Prim` instance for `StablePtr`++  * Remove `UnliftedArray` and related type classes++  * Add a lot more tests for `PrimArray`.++  * Added PrimMonad instance for CPS Writer and RWS monads from Transformers++  * Remove useless accidental laziness in `atomicModifyMutVar`, making it match+    `atomicModifyIORef`. The semantics should be the same.++  * lots of little documentation twiddles.++## Changes in version 0.6.4.1++ * Add instances for the following newtypes from `base`:+   `Const`, `Identity`, `Down`, `Dual`, `Sum`, `Product`,+   `First`, `Last`, `Min`, `Max`++ * Add `base-orphans` dependency to test suite to accomodate+   older versions of GHC not having instances of `Show` and `Eq`+   for some of the above newtypes.+ ## Changes in version 0.6.4.0   * Introduce `Data.Primitive.PrimArray`, which offers types and function@@ -37,7 +68,7 @@   * Fix the implementation of `mconcat` in the `Monoid` instance for    `SmallArray`.- +  * Implement `Data.Primitive.Ptr`, implementations of `Ptr` functions    that require a `Prim` constraint instead of a `Storable` constraint. @@ -58,6 +89,11 @@   * Add `defaultSetByteArray#` and `defaultSetOffAddr#` to    `Data.Primitive.Types`.++ * Add `Data.Primitive.MVar`, a replacement for `Control.Concurrent.MVar`+   that can run in any `PrimMonad` instead of just `IO`. It is not a full+   replacement. Notably, it's missing masking functions and support for+   adding finalizers.  ## Changes in version 0.6.3.0 

@@ -1,6 +1,7 @@+Cabal-Version: 2.2 Name:           primitive-Version:        0.6.4.0-License:        BSD3+Version:        0.7.0.0+License:        BSD-3-Clause License-File:   LICENSE  Author:         Roman Leshchinskiy <rl@cse.unsw.edu.au>@@ -10,14 +11,12 @@ Bug-Reports:    https://github.com/haskell/primitive/issues Category:       Data Synopsis:       Primitive memory-related operations-Cabal-Version:  >= 1.10 Build-Type:     Simple Description:    This package provides various primitive memory-related operations.  Extra-Source-Files: changelog.md                     test/*.hs                     test/LICENSE-                    test/primitive-tests.cabal  Tested-With:   GHC == 7.4.2,@@ -26,7 +25,9 @@   GHC == 7.10.3,   GHC == 8.0.2,   GHC == 8.2.2,-  GHC == 8.4.2+  GHC == 8.4.4,+  GHC == 8.6.5,+  GHC == 8.8.1  Library   Default-Language: Haskell2010@@ -43,8 +44,6 @@         Data.Primitive.ByteArray         Data.Primitive.PrimArray         Data.Primitive.SmallArray-        Data.Primitive.UnliftedArray-        Data.Primitive.Addr         Data.Primitive.Ptr         Data.Primitive.MutVar         Data.Primitive.MVar@@ -53,9 +52,11 @@         Data.Primitive.Internal.Compat         Data.Primitive.Internal.Operations -  Build-Depends: base >= 4.5 && < 4.12+  Build-Depends: base >= 4.5 && < 4.14                , ghc-prim >= 0.2 && < 0.6                , transformers >= 0.2 && < 0.6+  if !impl(ghc >= 8.0)+    Build-Depends: fail == 4.9.*    Ghc-Options: -O2 @@ -67,6 +68,53 @@       cc-options: -ftree-vectorize   if arch(i386) || arch(x86_64)       cc-options: -msse2++test-suite test-qc+  Default-Language: Haskell2010+  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+  type: exitcode-stdio-1.0+  build-depends: base+               , base-orphans+               , ghc-prim+               , primitive+               , QuickCheck ^>= 2.13+               , tasty ^>= 1.2+               , tasty-quickcheck+               , tagged+               , transformers >=0.4+               , transformers-compat+               , semigroups++  cpp-options:   -DHAVE_UNARY_LAWS+  ghc-options: -O2++  source-repository head   type:     git

@@ -5,28 +5,52 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} -import Control.Applicative+{-# OPTIONS_GHC -fno-warn-orphans #-}++#if __GLASGOW_HASKELL__ >= 805+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE TypeInType #-}+#endif+ import Control.Monad-import Control.Monad.Fix (fix)-import Control.Monad.Primitive import Control.Monad.ST-import Data.Monoid import Data.Primitive-import Data.Primitive.Array-import Data.Primitive.ByteArray-import Data.Primitive.Types-import Data.Primitive.SmallArray-import Data.Primitive.PrimArray import Data.Word import Data.Proxy (Proxy(..)) import GHC.Int import GHC.IO-import GHC.Prim+import GHC.Exts import Data.Function (on)+import Control.Applicative (Const(..))+import PrimLawsWIP (primLaws)++#if !(MIN_VERSION_base(4,8,0))+import Data.Monoid (Monoid(..))+#endif+#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity(..))+import qualified Data.Monoid as Monoid+#endif+#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down(..))+#else+import GHC.Exts (Down(..))+#endif #if MIN_VERSION_base(4,9,0) import Data.Semigroup (stimes)+import qualified Data.Semigroup as Semigroup #endif+#if !(MIN_VERSION_base(4,11,0))+import Data.Monoid ((<>))+#endif+#if __GLASGOW_HASKELL__ >= 805+import Foreign.Storable (Storable)+#endif+import Data.Orphans ()  import Test.Tasty (defaultMain,testGroup,TestTree) import Test.QuickCheck (Arbitrary,Arbitrary1,Gen,(===),CoArbitrary,Function)@@ -89,6 +113,7 @@       , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int))) #if MIN_VERSION_base(4,7,0)       , lawsToTest (QCC.isListLaws (Proxy :: Proxy ByteArray))+      , TQC.testProperty "foldrByteArray" (QCCL.foldrProp word8 foldrByteArray) #endif       ]     , testGroup "PrimArray"@@ -122,39 +147,67 @@       , TQC.testProperty "mapMaybePrimArrayP" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayP) #endif       ]-    , testGroup "UnliftedArray"-      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16))))-      , lawsToTest (QCC.ordLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16))))-      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16))))-#if MIN_VERSION_base(4,7,0)-      , lawsToTest (QCC.isListLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16))))-      , TQC.testProperty "mapUnliftedArray" (QCCL.mapProp arrInt16 arrInt32 mapUnliftedArray)-      , TQC.testProperty "foldrUnliftedArray" (QCCL.foldrProp arrInt16 foldrUnliftedArray)-      , TQC.testProperty "foldrUnliftedArray'" (QCCL.foldrProp arrInt16 foldrUnliftedArray')-      , TQC.testProperty "foldlUnliftedArray" (QCCL.foldlProp arrInt16 foldlUnliftedArray)-      , TQC.testProperty "foldlUnliftedArray'" (QCCL.foldlProp arrInt16 foldlUnliftedArray')-#endif++++     ,testGroup "DefaultSetMethod"+      [ lawsToTest (primLaws (Proxy :: Proxy DefaultSetMethod))       ]-    , testGroup "DefaultSetMethod"-      [ lawsToTest (QCC.primLaws (Proxy :: Proxy DefaultSetMethod))+#if __GLASGOW_HASKELL__ >= 805+    ,testGroup "PrimStorable"+      [ lawsToTest (QCC.storableLaws (Proxy :: Proxy Derived))       ]-    -- , testGroup "PrimStorable"-    --   [ lawsToTest (QCC.storableLaws (Proxy :: Proxy Derived))-    --   ]+#endif+     ,testGroup "Prim"+      [ renameLawsToTest "Word" (primLaws (Proxy :: Proxy Word))+      , renameLawsToTest "Word8" (primLaws (Proxy :: Proxy Word8))+      , renameLawsToTest "Word16" (primLaws (Proxy :: Proxy Word16))+      , renameLawsToTest "Word32" (primLaws (Proxy :: Proxy Word32))+      , renameLawsToTest "Word64" (primLaws (Proxy :: Proxy Word64))+      , renameLawsToTest "Int" (primLaws (Proxy :: Proxy Int))+      , renameLawsToTest "Int8" (primLaws (Proxy :: Proxy Int8))+      , renameLawsToTest "Int16" (primLaws (Proxy :: Proxy Int16))+      , renameLawsToTest "Int32" (primLaws (Proxy :: Proxy Int32))+      , renameLawsToTest "Int64" (primLaws (Proxy :: Proxy Int64))+      , renameLawsToTest "Const" (primLaws (Proxy :: Proxy (Const Int16 Int16)))+      , renameLawsToTest "Down" (primLaws (Proxy :: Proxy (Down Int16)))+#if MIN_VERSION_base(4,8,0)+      , renameLawsToTest "Identity" (primLaws (Proxy :: Proxy (Identity Int16)))+      , renameLawsToTest "Dual" (primLaws (Proxy :: Proxy (Monoid.Dual Int16)))+      , renameLawsToTest "Sum" (primLaws (Proxy :: Proxy (Monoid.Sum Int16)))+      , renameLawsToTest "Product" (primLaws (Proxy :: Proxy (Monoid.Product Int16)))+#endif+#if MIN_VERSION_base(4,9,0)+      , renameLawsToTest "First" (primLaws (Proxy :: Proxy (Semigroup.First Int16)))+      , renameLawsToTest "Last" (primLaws (Proxy :: Proxy (Semigroup.Last Int16)))+      , renameLawsToTest "Min" (primLaws (Proxy :: Proxy (Semigroup.Min Int16)))+      , renameLawsToTest "Max" (primLaws (Proxy :: Proxy (Semigroup.Max Int16)))+#endif++      ]+     ] +deriving instance Arbitrary a => Arbitrary (Down a)+-- Const, Dual, Sum, Product: all have Arbitrary instances defined+-- in QuickCheck itself+#if MIN_VERSION_base(4,9,0)+deriving instance Arbitrary a => Arbitrary (Semigroup.First a)+deriving instance Arbitrary a => Arbitrary (Semigroup.Last a)+deriving instance Arbitrary a => Arbitrary (Semigroup.Min a)+deriving instance Arbitrary a => Arbitrary (Semigroup.Max a)+#endif++word8 :: Proxy Word8+word8 = Proxy+ int16 :: Proxy Int16 int16 = Proxy  int32 :: Proxy Int32 int32 = Proxy -arrInt16 :: Proxy (PrimArray Int16)-arrInt16 = Proxy -arrInt32 :: Proxy (PrimArray Int16)-arrInt32 = Proxy- -- 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.@@ -197,6 +250,32 @@         unsafeFreezeByteArray mzs1    in expected === actual +-- Tests that writing stable ptrs to a PrimArray, reading them back+-- out, and then dereferencing them gives correct results.+--stablePtrPrimProp :: QC.Property+--stablePtrPrimProp = QC.property $ \(xs :: [Integer]) -> unsafePerformIO $ do+--  ptrs <- mapM newStablePtr xs+--  let ptrs' = primArrayToList (primArrayFromList ptrs)+--  ys <- mapM deRefStablePtr ptrs'+--  mapM_ freeStablePtr ptrs'+--  return (xs === ys)++--stablePtrPrimBlockProp :: QC.Property+--stablePtrPrimBlockProp = QC.property $ \(x :: Word) (QC.NonNegative (len :: Int)) -> unsafePerformIO $ do+--  ptr <- newStablePtr x+--  let ptrs' = replicatePrimArray len ptr+--  let go ix = if ix < len+--        then do+--          n <- deRefStablePtr (indexPrimArray ptrs' ix)+--          ns <- go (ix + 1)+--          return (n : ns)+--        else return []+--  ys <- go 0+--  freeStablePtr ptr+--  return (L.replicate len x === ys)+++ -- Provide the non-negative integers up to the bound. For example: -- -- >>> intsLessThan 5@@ -205,7 +284,7 @@ intsLessThan i = if i < 1   then []   else (i - 1) : intsLessThan (i - 1)-  + byteArrayCompareProp :: QC.Property byteArrayCompareProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) ->   compareLengthFirst xs ys === compare (byteArrayFromList xs) (byteArrayFromList ys)@@ -223,6 +302,9 @@ lawsToTest :: QCC.Laws -> TestTree lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs) +renameLawsToTest :: String -> QCC.Laws -> TestTree+renameLawsToTest name (QCC.Laws _ pairs) = testGroup name (map (uncurry TQC.testProperty) pairs)+ testArray :: IO () testArray = do     arr <- newArray 1 'A'@@ -265,7 +347,7 @@ mkByteArray :: Prim a => [a] -> ByteArray mkByteArray xs = runST $ do     marr <- newByteArray (length xs * sizeOf (head xs))-    sequence $ zipWith (writeByteArray marr) [0..] xs+    sequence_ $ zipWith (writeByteArray marr) [0..] xs     unsafeFreezeByteArray marr  instance Arbitrary1 Array where@@ -298,11 +380,8 @@         writePrimArray a ix x       unsafeFreezePrimArray a -instance (Arbitrary a, PrimUnlifted a) => Arbitrary (UnliftedArray a) where-  arbitrary = do-    xs <- QC.vector =<< QC.choose (0,3)-    return (unliftedArrayFromList xs) + instance (Prim a, CoArbitrary a) => CoArbitrary (PrimArray a) where   coarbitrary x = QC.coarbitrary (primArrayToList x) @@ -331,12 +410,9 @@   writeOffAddr# addr off (DefaultSetMethod n) s0 = writeOffAddr# addr off n s0   setOffAddr# = defaultSetOffAddr# --- TODO: Uncomment this out when GHC 8.6 is release. Also, uncomment--- the corresponding PrimStorable test group above.------ newtype Derived = Derived Int16---   deriving newtype (Prim)---   deriving Storable via (PrimStorable Derived)---+#if __GLASGOW_HASKELL__ >= 805+newtype Derived = Derived Int16+  deriving stock (Eq, Show)+  deriving newtype (Arbitrary, Prim)+  deriving Storable via (PrimStorable Derived)+#endif

@@ -1,45 +0,0 @@-Name:           primitive-tests-Version:        0.1-License:        BSD3-License-File:   LICENSE--Author:         Roman Leshchinskiy <rl@cse.unsw.edu.au>-Maintainer:     libraries@haskell.org-Copyright:      (c) Roman Leshchinskiy 2009-2012-Homepage:       https://github.com/haskell/primitive-Bug-Reports:    https://github.com/haskell/primitive/issues-Category:       Data-Synopsis:       primitive tests-Cabal-Version:  >= 1.10-Build-Type:     Simple-Description:    @primitive@ tests--Tested-With:-  GHC == 7.4.2,-  GHC == 7.6.3,-  GHC == 7.8.4,-  GHC == 7.10.3,-  GHC == 8.0.2,-  GHC == 8.2.2,-  GHC == 8.4.2--test-suite test-  Default-Language: Haskell2010-  hs-source-dirs: .-  main-is: main.hs-  type: exitcode-stdio-1.0-  build-depends: base >= 4.5 && < 4.12-               , ghc-prim-               , primitive-               , QuickCheck-               , tasty-               , tasty-quickcheck-               , tagged-               , transformers >= 0.3-               , quickcheck-classes >= 0.4.11.1-  ghc-options: -O2--source-repository head-  type:     git-  location: https://github.com/haskell/primitive-  subdir:   test

@@ -0,0 +1,387 @@+{-# 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

@@ -0,0 +1,253 @@+{-# 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

@@ -0,0 +1,80 @@+{-# 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

@@ -0,0 +1,114 @@+{-# 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

@@ -0,0 +1,464 @@+{-# 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 ]

@@ -0,0 +1,64 @@+{-# 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++++

@@ -0,0 +1,77 @@+{-# 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)+

@@ -0,0 +1,50 @@+{-# 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

@@ -0,0 +1,186 @@+{-# 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

@@ -0,0 +1,86 @@+{-# 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+

@@ -0,0 +1,112 @@+{-# 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

@@ -0,0 +1,52 @@+{-# 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)

@@ -0,0 +1,251 @@+{-# 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

@@ -0,0 +1,114 @@+{-# 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

@@ -0,0 +1,104 @@+{-# 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

@@ -0,0 +1,65 @@+{-# 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

@@ -0,0 +1,85 @@+{-# 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)

@@ -0,0 +1,49 @@+{-# 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

@@ -0,0 +1,145 @@+{-# 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)

@@ -0,0 +1,48 @@+{-# 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)

@@ -0,0 +1,86 @@+{-# 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 "")+

@@ -0,0 +1,150 @@+{-# 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

@@ -0,0 +1,96 @@+{-# 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