primitive 0.8.0.0 → 0.9.0.0

raw patch · 17 files changed

+995/−657 lines, 17 filesdep ~QuickCheckdep ~basedep ~tasty

Dependency ranges changed: QuickCheck, base, tasty

Files

• Control/Monad/Primitive.hs +47/−6
• Data/Primitive.hs +0/−3
• Data/Primitive/Array.hs +26/−49
• Data/Primitive/ByteArray.hs +59/−20
• Data/Primitive/Internal/Operations.hs +68/−1
• Data/Primitive/Internal/Read.hs +27/−0
• Data/Primitive/MVar.hs +0/−1
• Data/Primitive/PrimArray.hs +88/−78
• Data/Primitive/Ptr.hs +6/−5
• Data/Primitive/SmallArray.hs +83/−26
• Data/Primitive/Types.hs +109/−22
• bench/main.hs +1/−1
• changelog.md +32/−0
• primitive.cabal +5/−4
• test/Main.hs +440/−0
• test/main.hs +0/−434
• test/src/PrimLaws.hs +4/−7

@@ -2,6 +2,10 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds #-}+#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+#endif {-# OPTIONS_GHC -fno-warn-deprecations #-}  -- |@@ -22,14 +26,19 @@   liftPrim, primToPrim, primToIO, primToST, ioToPrim, stToPrim,   unsafePrimToPrim, unsafePrimToIO, unsafePrimToST, unsafeIOToPrim,   unsafeSTToPrim, unsafeInlinePrim, unsafeInlineIO, unsafeInlineST,-  touch, keepAlive, evalPrim, unsafeInterleave, unsafeDupableInterleave, noDuplicate+  touch, touchUnlifted,+  keepAlive, keepAliveUnlifted,+  evalPrim, unsafeInterleave, unsafeDupableInterleave, noDuplicate ) where +import Data.Kind (Type)+ import GHC.Exts   ( State#, RealWorld, noDuplicate#, touch#+                  , unsafeCoerce#, realWorld#, seq# )+import Data.Primitive.Internal.Operations (UnliftedType) #if defined(HAVE_KEEPALIVE)-                  , keepAlive#+import Data.Primitive.Internal.Operations (keepAliveLiftedLifted#,keepAliveUnliftedLifted#) #endif-                  , unsafeCoerce#, realWorld#, seq# ) import GHC.IO     ( IO(..) ) import GHC.ST     ( ST(..) ) @@ -335,18 +344,50 @@ {-# INLINE unsafeInlineST #-} unsafeInlineST = unsafeInlinePrim +-- | Ensure that the value is considered alive by the garbage collection.+-- Warning: GHC has optimization passes that can erase @touch@ if it is+-- certain that an exception is thrown afterward. Prefer 'keepAlive'. touch :: PrimMonad m => a -> m () {-# INLINE touch #-} touch x = unsafePrimToPrim         $ (primitive (\s -> case touch# x s of { s' -> (# s', () #) }) :: IO ()) -keepAlive :: PrimBase m => a -> (a -> m r) -> m r+-- | Variant of 'touch' that keeps a value of an unlifted type+-- (e.g. @MutableByteArray#@) alive.+touchUnlifted :: forall (m :: Type -> Type) (a :: UnliftedType). PrimMonad m => a -> m ()+{-# INLINE touchUnlifted #-}+touchUnlifted x = unsafePrimToPrim+        $ (primitive (\s -> case touch# x s of { s' -> (# s', () #) }) :: IO ())++-- | Keep value @x@ alive until computation @k@ completes.+-- Warning: This primop exists for completeness, but it is difficult to use+-- correctly. Prefer 'keepAliveUnlifted' if the value to keep alive is simply+-- a wrapper around an unlifted type (e.g. @ByteArray@).+keepAlive :: PrimBase m+  => a -- ^ Value @x@ to keep alive while computation @k@ runs.+  -> m r -- ^ Computation @k@+  -> m r #if defined(HAVE_KEEPALIVE) {-# INLINE keepAlive #-}-keepAlive x k = unsafeIOToPrim $ primitive $ \s0 -> keepAlive# x s0 $ internal $ unsafePrimToIO $ k x+keepAlive x k =+  primitive $ \s0 -> keepAliveLiftedLifted# x s0 (internal k)+ #else {-# NOINLINE keepAlive #-}-keepAlive x k = k x <* touch x+keepAlive x k = k <* touch x+#endif++-- | Variant of 'keepAlive' in which the value kept alive is of an unlifted+-- boxed type.+keepAliveUnlifted :: forall (m :: Type -> Type) (a :: UnliftedType) (r :: Type). PrimBase m => a -> m r -> m r+#if defined(HAVE_KEEPALIVE)+{-# INLINE keepAliveUnlifted #-}+keepAliveUnlifted x k =+  primitive $ \s0 -> keepAliveUnliftedLifted# x s0 (internal k)++#else+{-# NOINLINE keepAliveUnlifted #-}+keepAliveUnlifted x k = k <* touchUnlifted x #endif  -- | Create an action to force a value; generalizes 'Control.Exception.evaluate'

@@ -1,6 +1,3 @@-{-# LANGUAGE MagicHash #-}-{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}- -- | -- Module      : Data.Primitive -- Copyright   : (c) Roman Leshchinskiy 2009-2012

@@ -23,7 +23,6 @@   cloneArray, cloneMutableArray,   sizeofArray, sizeofMutableArray,   emptyArray,-  fromListN, fromList,   arrayFromListN, arrayFromList,   mapArray',   traverseArrayP@@ -31,6 +30,7 @@  import Control.DeepSeq import Control.Monad.Primitive+import Data.Primitive.Internal.Read (Tag(..),lexTag)  import GHC.Exts hiding (toList) import qualified GHC.Exts as Exts@@ -164,7 +164,7 @@ indexArray## arr (I# i) = indexArray# (array# arr) i {-# INLINE indexArray## #-} --- | Monadically read a value from the immutable array at the given index.+-- | Read a value from the immutable array at the given index using an applicative. -- This allows us to be strict in the array while remaining lazy in the read -- element which is very useful for collective operations. Suppose we want to -- copy an array. We could do something like this:@@ -188,10 +188,10 @@ -- still not evaluated. -- -- /Note:/ this function does not do bounds checking.-indexArrayM :: Monad m => Array a -> Int -> m a+indexArrayM :: Applicative m => Array a -> Int -> m a {-# INLINE indexArrayM #-} indexArrayM arr (I# i#)-  = case indexArray# (array# arr) i# of (# x #) -> return x+  = case indexArray# (array# arr) i# of (# x #) -> pure x  -- | Create an immutable copy of a slice of an array. --@@ -751,11 +751,9 @@     LT -> die "stimes" "negative multiplier"     EQ -> empty     GT -> createArray (n' * sizeofArray arr) (die "stimes" "impossible") $ \ma ->-      let go i = if i < n'-            then do-              copyArray ma (i * sizeofArray arr) arr 0 (sizeofArray arr)-              go (i + 1)-            else return ()+      let go i = when (i < n') $ do+            copyArray ma (i * sizeofArray arr) arr 0 (sizeofArray arr)+            go (i + 1)       in go 0     where n' = fromIntegral n :: Int @@ -772,9 +770,8 @@    where sz = sum . fmap sizeofArray $ l  arrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Array a -> ShowS-arrayLiftShowsPrec elemShowsPrec elemListShowsPrec p a = showParen (p > 10) $-  showString "fromListN " . shows (sizeofArray a) . showString " "-    . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList a)+arrayLiftShowsPrec elemShowsPrec elemListShowsPrec _ a =+  listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList a)  -- this need to be included for older ghcs listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS@@ -795,51 +792,31 @@ #if MIN_VERSION_base(4,10,0)   liftReadPrec = arrayLiftReadPrec #else-  liftReadsPrec = arrayLiftReadsPrec+  -- This is just the default implementation of liftReadsPrec, but+  -- it is not present in older versions of base.+  liftReadsPrec rp rl = RdPrc.readPrec_to_S $+    arrayLiftReadPrec (RdPrc.readS_to_Prec rp) (RdPrc.readS_to_Prec (const rl)) #endif +-- Note [Forgiving Array Read Instance] -- 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-+arrayLiftReadPrec _ read_list =+  ( RdPrc.lift skipSpaces >> fmap fromList read_list )+  RdPrc.++++  ( parens $ prec app_prec $ do+      RdPrc.lift skipSpaces+      tag <- RdPrc.lift lexTag+      case tag of+        FromListTag -> fromList <$> read_list+        FromListNTag -> liftM2 fromListN readPrec read_list+  )+  where+  app_prec = 10  arrayDataType :: DataType arrayDataType = mkDataType "Data.Primitive.Array.Array" [fromListConstr]

@@ -1,8 +1,8 @@-{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, UnliftedFFITypes, DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, UnliftedFFITypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskellQuotes #-}  -- | -- Module      : Data.Primitive.ByteArray@@ -62,13 +62,17 @@ #if __GLASGOW_HASKELL__ >= 802   isByteArrayPinned, isMutableByteArrayPinned, #endif-  byteArrayContents, mutableByteArrayContents+  byteArrayContents,+  withByteArrayContents,+  mutableByteArrayContents,+  withMutableByteArrayContents  ) where  import Control.Monad.Primitive import Control.Monad.ST import Data.Primitive.Types+import Data.Proxy  #if MIN_VERSION_base(4,10,0) import qualified GHC.ST as GHCST@@ -87,7 +91,10 @@  import Data.Array.Byte (ByteArray(..), MutableByteArray(..)) +import Data.Primitive.Internal.Operations (mutableByteArrayContentsShim)+ -- | Create a new mutable byte array of the specified size in bytes.+-- The underlying memory is left uninitialized. -- -- /Note:/ this function does not check if the input is non-negative. newByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m))@@ -97,7 +104,7 @@                         (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #))  -- | Create a /pinned/ byte array of the specified size in bytes. The garbage--- collector is guaranteed not to move it.+-- collector is guaranteed not to move it. The underlying memory is left uninitialized. -- -- /Note:/ this function does not check if the input is non-negative. newPinnedByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m))@@ -108,6 +115,7 @@  -- | Create a /pinned/ byte array of the specified size in bytes and with the -- given alignment. The garbage collector is guaranteed not to move it.+-- The underlying memory is left uninitialized. -- -- /Note:/ this function does not check if the input is non-negative. newAlignedPinnedByteArray@@ -121,20 +129,49 @@                         (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #))  -- | Yield a pointer to the array's data. This operation is only safe on--- /pinned/ byte arrays allocated by 'newPinnedByteArray' or--- 'newAlignedPinnedByteArray'.+-- /pinned/ byte arrays. Byte arrays allocated by 'newPinnedByteArray' and+-- 'newAlignedPinnedByteArray' are guaranteed to be pinned. Byte arrays+-- allocated by 'newByteArray' may or may not be pinned (use+-- 'isByteArrayPinned' to figure out).+--+-- Prefer 'withByteArrayContents', which ensures that the array is not+-- garbage collected while the pointer is being used. byteArrayContents :: ByteArray -> Ptr Word8 {-# INLINE byteArrayContents #-} byteArrayContents (ByteArray arr#) = Ptr (byteArrayContents# arr#) +-- | A composition of 'byteArrayContents' and 'keepAliveUnlifted'.+-- The callback function must not return the pointer. The argument byte+-- array must be /pinned/. See 'byteArrayContents' for an explanation+-- of which byte arrays are pinned.+--+-- Note: This could be implemented with 'keepAlive' instead of+-- 'keepAliveUnlifted', but 'keepAlive' here would cause GHC to materialize+-- the wrapper data constructor on the heap.+withByteArrayContents :: PrimBase m => ByteArray -> (Ptr Word8 -> m a) -> m a+{-# INLINE withByteArrayContents #-}+withByteArrayContents (ByteArray arr#) f =+  keepAliveUnlifted arr# (f (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'.+-- /pinned/ byte arrays. See 'byteArrayContents' for an explanation+-- of which byte arrays are pinned.+--+-- Prefer 'withByteArrayContents', which ensures that the array is not+-- garbage collected while the pointer is being used. mutableByteArrayContents :: MutableByteArray s -> Ptr Word8 {-# INLINE mutableByteArrayContents #-}-mutableByteArrayContents (MutableByteArray arr#)-  = Ptr (byteArrayContents# (unsafeCoerce# arr#))+mutableByteArrayContents (MutableByteArray arr#) = Ptr (mutableByteArrayContentsShim arr#) +-- | A composition of 'mutableByteArrayContents' and 'keepAliveUnlifted'.+-- The callback function must not return the pointer. The argument byte+-- array must be /pinned/. See 'byteArrayContents' for an explanation+-- of which byte arrays are pinned.+withMutableByteArrayContents :: PrimBase m => MutableByteArray (PrimState m) -> (Ptr Word8 -> m a) -> m a+{-# INLINE withMutableByteArrayContents #-}+withMutableByteArrayContents (MutableByteArray arr#) f =+  keepAliveUnlifted arr# (f (Ptr (mutableByteArrayContentsShim arr#)))+ -- | Check if the two arrays refer to the same memory block. sameMutableByteArray :: MutableByteArray s -> MutableByteArray s -> Bool {-# INLINE sameMutableByteArray #-}@@ -239,13 +276,15 @@ {-# 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 is deprecated and will be removed. Its 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--- sequencing in the presence of resizing.+-- byte array given as the argument. Prefer 'getSizeofMutableByteArray',+-- which ensures correct sequencing in the presence of resizing. sizeofMutableByteArray :: MutableByteArray s -> Int {-# INLINE sizeofMutableByteArray #-}+{-# DEPRECATED sizeofMutableByteArray "use getSizeofMutableByteArray instead" #-} sizeofMutableByteArray (MutableByteArray arr#) = I# (sizeofMutableByteArray# arr#)  -- | Shrink a mutable byte array. The new size is given in bytes.@@ -320,7 +359,7 @@     go i       | i < maxI  = f (indexByteArray arr i) (go (i + 1))       | otherwise = z-    maxI = sizeofByteArray arr `quot` sizeOf (undefined :: a)+    maxI = sizeofByteArray arr `quot` sizeOfType @a  -- | Create a 'ByteArray' from a list. --@@ -330,9 +369,9 @@  -- | Create a 'ByteArray' from a list of a known length. If the length -- of the list does not match the given length, this throws an exception.-byteArrayFromListN :: Prim a => Int -> [a] -> ByteArray+byteArrayFromListN :: forall a. Prim a => Int -> [a] -> ByteArray byteArrayFromListN n ys = runST $ do-    marr <- newByteArray (n * sizeOf (head ys))+    marr <- newByteArray (n * sizeOfType @a)     let go !ix [] = if ix == n           then return ()           else die "byteArrayFromListN" "list length less than specified size"@@ -396,7 +435,7 @@ copyByteArrayToPtr (Ptr dst#) (ByteArray src#) soff sz   = primitive_ (copyByteArrayToAddr# src# (unI# soff *# siz#) dst# (unI# sz *# siz#))   where-  siz# = sizeOf# (undefined :: a)+  siz# = sizeOfType# (Proxy :: Proxy a)  -- | Copy from an unmanaged pointer address to a byte array. These must not -- overlap. The offset and length are given in elements, not in bytes.@@ -412,7 +451,7 @@ copyPtrToMutableByteArray (MutableByteArray ba#) (I# doff#) (Ptr addr#) (I# n#) =   primitive_ (copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#))   where-  siz# = sizeOf# (undefined :: a)+  siz# = sizeOfType# (Proxy :: Proxy a)   -- | Copy a slice of a mutable byte array to an unmanaged pointer address.@@ -433,7 +472,7 @@ copyMutableByteArrayToPtr (Ptr dst#) (MutableByteArray src#) soff sz   = primitive_ (copyMutableByteArrayToAddr# src# (unI# soff *# siz#) dst# (unI# sz *# siz#))   where-  siz# = sizeOf# (undefined :: a)+  siz# = sizeOfType# (Proxy :: Proxy a)  ------ --- These latter two should be DEPRECATED

@@ -1,4 +1,9 @@-{-# LANGUAGE CPP, MagicHash, UnliftedFFITypes #-}+{-# LANGUAGE CPP, MagicHash, UnliftedFFITypes, UnboxedTuples #-}+{-# LANGUAGE RankNTypes, KindSignatures, ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-}+#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+#endif  -- | -- Module      : Data.Primitive.Internal.Operations@@ -24,13 +29,25 @@   setInt64OffAddr#, setIntOffAddr#,   setAddrOffAddr#, setFloatOffAddr#, setDoubleOffAddr#, setWideCharOffAddr#,   setStablePtrOffAddr#+++#if defined(HAVE_KEEPALIVE)+  , keepAliveLiftedLifted#+  , keepAliveUnliftedLifted#+#endif+  , mutableByteArrayContentsShim+  , UnliftedType ) where  import Data.Primitive.MachDeps (Word64_#, Int64_#) import Foreign.C.Types import GHC.Exts +#if defined(HAVE_KEEPALIVE)+import Data.Kind (Type)+#endif + #if __GLASGOW_HASKELL__ >= 902 foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8"   setWord8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word8# -> IO ()@@ -136,3 +153,53 @@   setDoubleOffAddr# :: Addr# -> CPtrdiff -> CSize -> Double# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char"   setWideCharOffAddr# :: Addr# -> CPtrdiff -> CSize -> Char# -> IO ()++#if defined(HAVE_KEEPALIVE)+keepAliveLiftedLifted# :: forall (s :: Type) (a :: Type) (b :: Type).+     a+  -> State# s+  -> (State# s -> (# State# s, b #))+  -> (# State# s, b #)+{-# inline keepAliveLiftedLifted# #-}+keepAliveLiftedLifted# x s0 f =+  (unsafeCoerce# :: (# State# RealWorld, b #) -> (# State# s, b #))+    ( keepAlive# x+      ((unsafeCoerce# :: State# s -> State# RealWorld) s0)+      ((unsafeCoerce# ::+         (State# s -> (# State# s, b #)) ->+         (State# RealWorld -> (# State# RealWorld, b #))+       ) f)+    )++keepAliveUnliftedLifted# :: forall (s :: Type) (a :: UnliftedType) (b :: Type).+     a+  -> State# s+  -> (State# s -> (# State# s, b #))+  -> (# State# s, b #)+{-# inline keepAliveUnliftedLifted# #-}+keepAliveUnliftedLifted# x s0 f =+  (unsafeCoerce# :: (# State# RealWorld, b #) -> (# State# s, b #))+    ( keepAlive# x+      ((unsafeCoerce# :: State# s -> State# RealWorld) s0)+      ((unsafeCoerce# ::+         (State# s -> (# State# s, b #)) ->+         (State# RealWorld -> (# State# RealWorld, b #))+       ) f)+    )+#endif++#if __GLASGOW_HASKELL__ < 802+type UnliftedType = TYPE 'PtrRepUnlifted+#elif __GLASGOW_HASKELL__ < 902+type UnliftedType = TYPE 'UnliftedRep+#endif++mutableByteArrayContentsShim :: MutableByteArray# s -> Addr#+{-# INLINE mutableByteArrayContentsShim #-}+mutableByteArrayContentsShim x =+#if __GLASGOW_HASKELL__ >= 902+  mutableByteArrayContents# x+#else+  byteArrayContents# (unsafeCoerce# x)+#endif+

@@ -0,0 +1,27 @@+module Data.Primitive.Internal.Read+  ( Tag(..)+  , lexTag+  ) where++import Data.Char (isDigit)+import Text.ParserCombinators.ReadP++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:_+      | isDigit c+      -> fail "" -- We have fromListN3 or similar+      | otherwise -> FromListNTag <$ get -- Skip the 'N'+    _ -> return FromListTag

@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-}

@@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE RoleAnnotations #-}@@ -62,7 +63,9 @@   , sizeofMutablePrimArray   , sizeofPrimArray   , primArrayContents+  , withPrimArrayContents   , mutablePrimArrayContents+  , withMutablePrimArrayContents #if __GLASGOW_HASKELL__ >= 802   , isPrimArrayPinned   , isMutablePrimArrayPinned@@ -110,13 +113,12 @@ import GHC.Exts import Data.Primitive.Types import Data.Primitive.ByteArray (ByteArray(..))-#if !MIN_VERSION_base(4,11,0)-import Data.Monoid ((<>))-#endif+import Data.Proxy #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) #endif import Control.DeepSeq+import Control.Monad (when) import Control.Monad.Primitive import Control.Monad.ST import qualified Data.List as L@@ -127,15 +129,14 @@ #endif import Language.Haskell.TH.Syntax (Lift (..)) -#if !MIN_VERSION_base(4,11,0)-import Data.Semigroup (Semigroup)-#endif-import qualified Data.Semigroup as SG+import Data.Semigroup  #if __GLASGOW_HASKELL__ >= 802 import qualified GHC.Exts as Exts #endif +import Data.Primitive.Internal.Operations (mutableByteArrayContentsShim)+ -- | Arrays of unboxed elements. This accepts types like 'Double', 'Char', -- 'Int' and 'Word', as well as their fixed-length variants ('Word8', -- 'Word16', etc.). Since the elements are unboxed, a 'PrimArray' is strict@@ -182,7 +183,7 @@   a1@(PrimArray ba1#) == a2@(PrimArray ba2#)     | sameByteArray ba1# ba2# = True     | sz1 /= sz2 = False-    | otherwise = loop (quot sz1 (sizeOf (undefined :: a)) - 1)+    | otherwise = loop (quot sz1 (sizeOfType @a) - 1)     where     -- Here, we take the size in bytes, not in elements. We do this     -- since it allows us to defer performing the division to@@ -204,7 +205,7 @@     where     sz1 = PB.sizeofByteArray (ByteArray ba1#)     sz2 = PB.sizeofByteArray (ByteArray ba2#)-    sz = quot (min sz1 sz2) (sizeOf (undefined :: a))+    sz = quot (min sz1 sz2) (sizeOfType @a)     loop !i       | i < sz = compare (indexPrimArray a1 i) (indexPrimArray a2 i) <> loop (i + 1)       | otherwise = compare sz1 sz2@@ -219,9 +220,7 @@  -- | @since 0.6.4.0 instance (Show a, Prim a) => Show (PrimArray a) where-  showsPrec p a = showParen (p > 10) $-    showString "fromListN " . shows (sizeofPrimArray a) . showString " "-      . shows (primArrayToList a)+  showsPrec _ a = shows (primArrayToList a)  die :: String -> String -> a die fun problem = error $ "Data.Primitive.PrimArray." ++ fun ++ ": " ++ problem@@ -264,15 +263,15 @@  -- | @since 0.6.4.0 instance Semigroup (PrimArray a) where-  x <> y = byteArrayToPrimArray (primArrayToByteArray x SG.<> primArrayToByteArray y)-  sconcat = byteArrayToPrimArray . SG.sconcat . fmap primArrayToByteArray-  stimes i arr = byteArrayToPrimArray (SG.stimes i (primArrayToByteArray arr))+  x <> y = byteArrayToPrimArray (primArrayToByteArray x <> primArrayToByteArray y)+  sconcat = byteArrayToPrimArray . sconcat . fmap primArrayToByteArray+  stimes i arr = byteArrayToPrimArray (stimes i (primArrayToByteArray arr))  -- | @since 0.6.4.0 instance Monoid (PrimArray a) where   mempty = emptyPrimArray #if !(MIN_VERSION_base(4,11,0))-  mappend x y = byteArrayToPrimArray (mappend (primArrayToByteArray x) (primArrayToByteArray y))+  mappend = (<>) #endif   mconcat = byteArrayToPrimArray . mconcat . map primArrayToByteArray @@ -291,7 +290,7 @@ {-# INLINE newPrimArray #-} newPrimArray (I# n#)   = primitive (\s# ->-      case newByteArray# (n# *# sizeOf# (undefined :: a)) s# of+      case newByteArray# (n# *# sizeOfType# (Proxy :: Proxy a)) s# of         (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #)     ) @@ -311,7 +310,7 @@   -> m (MutablePrimArray (PrimState m) a) {-# INLINE resizeMutablePrimArray #-} resizeMutablePrimArray (MutablePrimArray arr#) (I# n#)-  = primitive (\s# -> case resizeMutableByteArray# arr# (n# *# sizeOf# (undefined :: a)) s# of+  = primitive (\s# -> case resizeMutableByteArray# arr# (n# *# sizeOfType# (Proxy :: Proxy a)) s# of                         (# s'#, arr'# #) -> (# s'#, MutablePrimArray arr'# #))  -- | Shrink a mutable primitive array. The new size is given in elements.@@ -322,7 +321,7 @@   -> m () {-# INLINE shrinkMutablePrimArray #-} shrinkMutablePrimArray (MutablePrimArray arr#) (I# n#)-  = primitive_ (shrinkMutableByteArray# arr# (n# *# sizeOf# (undefined :: a)))+  = primitive_ (shrinkMutableByteArray# arr# (n# *# sizeOfType# (Proxy :: Proxy a)))  -- | Read a value from the array at the given index. --@@ -362,10 +361,10 @@ copyMutablePrimArray (MutablePrimArray dst#) (I# doff#) (MutablePrimArray src#) (I# soff#) (I# n#)   = primitive_ (copyMutableByteArray#       src#-      (soff# *# sizeOf# (undefined :: a))+      (soff# *# sizeOfType# (Proxy :: Proxy a))       dst#-      (doff# *# sizeOf# (undefined :: a))-      (n# *# sizeOf# (undefined :: a))+      (doff# *# sizeOfType# (Proxy :: Proxy a))+      (n# *# sizeOfType# (Proxy :: Proxy a))     )  -- | Copy part of an array into another mutable array.@@ -383,10 +382,10 @@ copyPrimArray (MutablePrimArray dst#) (I# doff#) (PrimArray src#) (I# soff#) (I# n#)   = primitive_ (copyByteArray#       src#-      (soff# *# sizeOf# (undefined :: a))+      (soff# *# sizeOfType# (Proxy :: Proxy a))       dst#-      (doff# *# sizeOf# (undefined :: a))-      (n# *# sizeOf# (undefined :: a))+      (doff# *# sizeOfType# (Proxy :: Proxy a))+      (n# *# sizeOfType# (Proxy :: Proxy a))     )  -- | Copy a slice of an immutable primitive array to a pointer.@@ -406,7 +405,7 @@     primitive (\ s# ->         let s'# = copyByteArrayToAddr# ba# (soff# *# siz#) addr# (n# *# siz#) s#         in (# s'#, () #))-  where siz# = sizeOf# (undefined :: a)+  where siz# = sizeOfType# (Proxy :: Proxy a)  -- | Copy a slice of a mutable primitive array to a pointer. -- The offset and length are given in elements of type @a@.@@ -425,7 +424,7 @@     primitive (\ s# ->         let s'# = copyMutableByteArrayToAddr# mba# (soff# *# siz#) addr# (n# *# siz#) s#         in (# s'#, () #))-  where siz# = sizeOf# (undefined :: a)+  where siz# = sizeOfType# (Proxy :: Proxy a)  -- | Copy from a pointer to a mutable primitive array. -- The offset and length are given in elements of type @a@.@@ -443,7 +442,7 @@ copyPtrToMutablePrimArray (MutablePrimArray ba#) (I# doff#) (Ptr addr#) (I# n#) =   primitive_ (copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#))   where-  siz# = sizeOf# (undefined :: a)+  siz# = sizeOfType# (Proxy :: Proxy a)  -- | Fill a slice of a mutable primitive array with a value. --@@ -469,7 +468,7 @@ getSizeofMutablePrimArray (MutablePrimArray arr#)   = primitive (\s# ->       case getSizeofMutableByteArray# arr# s# of-        (# s'#, sz# #) -> (# s'#, I# (quotInt# sz# (sizeOf# (undefined :: a))) #)+        (# s'#, sz# #) -> (# s'#, I# (quotInt# sz# (sizeOfType# (Proxy :: Proxy a))) #)     ) #else -- On older GHCs, it is not possible to resize a byte array, so@@ -482,10 +481,13 @@ -- | Size of the mutable primitive array in elements. This function shall not -- be used on primitive arrays that are an argument to or a result of -- 'resizeMutablePrimArray' or 'shrinkMutablePrimArray'.+--+-- This function is deprecated and will be removed. sizeofMutablePrimArray :: forall s a. Prim a => MutablePrimArray s a -> Int {-# INLINE sizeofMutablePrimArray #-}+{-# DEPRECATED sizeofMutablePrimArray "use getSizeofMutablePrimArray instead" #-} sizeofMutablePrimArray (MutablePrimArray arr#) =-  I# (quotInt# (sizeofMutableByteArray# arr#) (sizeOf# (undefined :: a)))+  I# (quotInt# (sizeofMutableByteArray# arr#) (sizeOfType# (Proxy :: Proxy a)))  -- | Check if the two arrays refer to the same memory block. sameMutablePrimArray :: MutablePrimArray s a -> MutablePrimArray s a -> Bool@@ -562,7 +564,7 @@ -- | Get the size, in elements, of the primitive array. sizeofPrimArray :: forall a. Prim a => PrimArray a -> Int {-# INLINE sizeofPrimArray #-}-sizeofPrimArray (PrimArray arr#) = I# (quotInt# (sizeofByteArray# arr#) (sizeOf# (undefined :: a)))+sizeofPrimArray (PrimArray arr#) = I# (quotInt# (sizeofByteArray# arr#) (sizeOfType# (Proxy :: Proxy a)))  #if __GLASGOW_HASKELL__ >= 802 -- | Check whether or not the primitive array is pinned. Pinned primitive arrays cannot@@ -669,12 +671,10 @@ traversePrimArrayP f arr = do   let !sz = sizeofPrimArray arr   marr <- newPrimArray sz-  let go !ix = if ix < sz-        then do-          b <- f (indexPrimArray arr ix)-          writePrimArray marr ix b-          go (ix + 1)-        else return ()+  let go !ix = when (ix < sz) $ do+        b <- f (indexPrimArray arr ix)+        writePrimArray marr ix b+        go (ix + 1)   go 0   unsafeFreezePrimArray marr @@ -735,12 +735,10 @@   -> m (PrimArray a) generatePrimArrayP sz f = do   marr <- newPrimArray sz-  let go !ix = if ix < sz-        then do-          b <- f ix-          writePrimArray marr ix b-          go (ix + 1)-        else return ()+  let go !ix = when (ix < sz) $ do+        b <- f ix+        writePrimArray marr ix b+        go (ix + 1)   go 0   unsafeFreezePrimArray marr @@ -753,12 +751,10 @@   -> m (PrimArray a) replicatePrimArrayP sz f = do   marr <- newPrimArray sz-  let go !ix = if ix < sz-        then do-          b <- f-          writePrimArray marr ix b-          go (ix + 1)-        else return ()+  let go !ix = when (ix < sz) $ do+        b <- f+        writePrimArray marr ix b+        go (ix + 1)   go 0   unsafeFreezePrimArray marr @@ -771,12 +767,10 @@ mapPrimArray f arr = runST $ do   let !sz = sizeofPrimArray arr   marr <- newPrimArray sz-  let go !ix = if ix < sz-        then do-          let b = f (indexPrimArray arr ix)-          writePrimArray marr ix b-          go (ix + 1)-        else return ()+  let go !ix = when (ix < sz) $ do+        let b = f (indexPrimArray arr ix)+        writePrimArray marr ix b+        go (ix + 1)   go 0   unsafeFreezePrimArray marr @@ -789,12 +783,10 @@ imapPrimArray f arr = runST $ do   let !sz = sizeofPrimArray arr   marr <- newPrimArray sz-  let go !ix = if ix < sz-        then do-          let b = f ix (indexPrimArray arr ix)-          writePrimArray marr ix b-          go (ix + 1)-        else return ()+  let go !ix = when (ix < sz) $ do+        let b = f ix (indexPrimArray arr ix)+        writePrimArray marr ix b+        go (ix + 1)   go 0   unsafeFreezePrimArray marr @@ -968,11 +960,9 @@   -> PrimArray a generatePrimArray len f = runST $ do   marr <- newPrimArray len-  let go !ix = if ix < len-        then do-          writePrimArray marr ix (f ix)-          go (ix + 1)-        else return ()+  let go !ix = when (ix < len) $ do+        writePrimArray marr ix (f ix)+        go (ix + 1)   go 0   unsafeFreezePrimArray marr @@ -1038,9 +1028,8 @@   -> f () traversePrimArray_ f a = go 0 where   !sz = sizeofPrimArray a-  go !ix = if ix < sz-    then f (indexPrimArray a ix) *> go (ix + 1)-    else pure ()+  go !ix = when (ix < sz) $+    f (indexPrimArray a ix) *> go (ix + 1)  -- | Traverse the primitive array with the indices, discarding the results. -- There is no 'PrimMonad' variant of this function, since it would not@@ -1052,9 +1041,8 @@   -> f () itraversePrimArray_ f a = go 0 where   !sz = sizeofPrimArray a-  go !ix = if ix < sz-    then f ix (indexPrimArray a ix) *> go (ix + 1)-    else pure ()+  go !ix = when (ix < sz) $+    f ix (indexPrimArray a ix) *> go (ix + 1)  newtype IxSTA a = IxSTA {_runIxSTA :: forall s. Int -> MutableByteArray# s -> ST s Int} @@ -1084,26 +1072,26 @@ -}  -- | Create a /pinned/ primitive array of the specified size (in elements). The garbage--- collector is guaranteed not to move it.+-- collector is guaranteed not to move it. The underlying memory is left uninitialized. -- -- @since 0.7.1.0 newPinnedPrimArray :: forall m a. (PrimMonad m, Prim a)   => Int -> m (MutablePrimArray (PrimState m) a) {-# INLINE newPinnedPrimArray #-} newPinnedPrimArray (I# n#)-  = primitive (\s# -> case newPinnedByteArray# (n# *# sizeOf# (undefined :: a)) s# of+  = primitive (\s# -> case newPinnedByteArray# (n# *# sizeOfType# (Proxy :: Proxy a)) s# of                         (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #))  -- | Create a /pinned/ primitive array of the specified size (in elements) and -- with the alignment given by its 'Prim' instance. The garbage collector is--- guaranteed not to move it.+-- guaranteed not to move it. The underlying memory is left uninitialized. -- -- @since 0.7.0.0 newAlignedPinnedPrimArray :: forall m a. (PrimMonad m, Prim a)   => Int -> m (MutablePrimArray (PrimState m) a) {-# INLINE newAlignedPinnedPrimArray #-} newAlignedPinnedPrimArray (I# n#)-  = primitive (\s# -> case newAlignedPinnedByteArray# (n# *# sizeOf# (undefined :: a)) (alignment# (undefined :: a)) s# of+  = primitive (\s# -> case newAlignedPinnedByteArray# (n# *# sizeOfType# (Proxy :: Proxy a)) (alignmentOfType# (Proxy :: Proxy a)) s# of                         (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #))  -- | Yield a pointer to the array's data. This operation is only safe on@@ -1122,8 +1110,8 @@ -- @since 0.7.1.0 mutablePrimArrayContents :: MutablePrimArray s a -> Ptr a {-# INLINE mutablePrimArrayContents #-}-mutablePrimArrayContents (MutablePrimArray arr#)-  = Ptr (byteArrayContents# (unsafeCoerce# arr#))+mutablePrimArrayContents (MutablePrimArray arr#) =+  Ptr (mutableByteArrayContentsShim arr#)  -- | Return a newly allocated array with the specified subrange of the -- provided array. The provided array should contain the full subrange@@ -1174,3 +1162,25 @@ #else /* In older GHCs, runRW# is not available. */ runPrimArray m = runST $ m >>= unsafeFreezePrimArray #endif++-- | A composition of 'primArrayContents' and 'keepAliveUnlifted'.+-- The callback function must not return the pointer. The argument+-- array must be /pinned/. See 'primArrayContents' for an explanation+-- of which primitive arrays are pinned.+--+-- Note: This could be implemented with 'keepAlive' instead of+-- 'keepAliveUnlifted', but 'keepAlive' here would cause GHC to materialize+-- the wrapper data constructor on the heap.+withPrimArrayContents :: PrimBase m => PrimArray a -> (Ptr a -> m a) -> m a+{-# INLINE withPrimArrayContents #-}+withPrimArrayContents (PrimArray arr#) f =+  keepAliveUnlifted arr# (f (Ptr (byteArrayContents# arr#)))++-- | A composition of 'mutablePrimArrayContents' and 'keepAliveUnlifted'.+-- The callback function must not return the pointer. The argument+-- array must be /pinned/. See 'primArrayContents' for an explanation+-- of which primitive arrays are pinned.+withMutablePrimArrayContents :: PrimBase m => MutablePrimArray (PrimState m) a -> (Ptr a -> m a) -> m a+{-# INLINE withMutablePrimArrayContents #-}+withMutablePrimArrayContents (MutablePrimArray arr#) f =+  keepAliveUnlifted arr# (f (Ptr (mutableByteArrayContentsShim arr#)))

@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}  -- | -- Module      : Data.Primitive.Ptr@@ -37,6 +37,7 @@ import Data.Primitive.PrimArray (copyPtrToMutablePrimArray) import Data.Primitive.ByteArray (copyPtrToMutableByteArray) +import Data.Proxy import GHC.Exts import GHC.Ptr import Foreign.Marshal.Utils@@ -45,14 +46,14 @@ -- | Offset a pointer by the given number of elements. advancePtr :: forall a. Prim a => Ptr a -> Int -> Ptr a {-# INLINE advancePtr #-}-advancePtr (Ptr a#) (I# i#) = Ptr (plusAddr# a# (i# *# sizeOf# (undefined :: a)))+advancePtr (Ptr a#) (I# i#) = Ptr (plusAddr# a# (i# *# sizeOfType# (Proxy :: Proxy a)))  -- | Subtract a pointer from another pointer. The result represents -- the number of elements of type @a@ that fit in the contiguous -- memory range bounded by these two pointers. subtractPtr :: forall a. Prim a => Ptr a -> Ptr a -> Int {-# INLINE subtractPtr #-}-subtractPtr (Ptr a#) (Ptr b#) = I# (quotInt# (minusAddr# a# b#) (sizeOf# (undefined :: a)))+subtractPtr (Ptr a#) (Ptr b#) = I# (quotInt# (minusAddr# a# b#) (sizeOfType# (Proxy :: Proxy a)))  -- | Read a value from a memory position given by a pointer and an offset. -- The memory block the address refers to must be immutable. The offset is in@@ -82,7 +83,7 @@   -> m () {-# INLINE copyPtr #-} copyPtr (Ptr dst#) (Ptr src#) n-  = unsafePrimToPrim $ copyBytes (Ptr dst#) (Ptr src#) (n * sizeOf (undefined :: a))+  = unsafePrimToPrim $ copyBytes (Ptr dst#) (Ptr src#) (n * sizeOfType @a)  -- | Copy the given number of elements from the second 'Ptr' to the first. The -- areas may overlap.@@ -93,7 +94,7 @@   -> m () {-# INLINE movePtr #-} movePtr (Ptr dst#) (Ptr src#) n-  = unsafePrimToPrim $ moveBytes (Ptr dst#) (Ptr src#) (n * sizeOf (undefined :: a))+  = unsafePrimToPrim $ moveBytes (Ptr dst#) (Ptr src#) (n * sizeOfType @a)  -- | Fill a memory block with the given value. The length is in -- elements of type @a@ rather than in bytes.

@@ -54,6 +54,7 @@   , runSmallArray   , createSmallArray   , sizeofSmallArray+  , getSizeofSmallMutableArray   , sizeofSmallMutableArray #if MIN_VERSION_base(4,14,0)   , shrinkSmallMutableArray@@ -80,9 +81,13 @@ import Data.Data import Data.Foldable as Foldable import Data.Functor.Identity+import Data.Primitive.Internal.Read (Tag(..),lexTag)+import Text.Read (Read (..), parens, prec) import qualified GHC.ST as GHCST-import qualified Data.Semigroup as Sem+import Data.Semigroup import Text.ParserCombinators.ReadP+import Text.ParserCombinators.ReadPrec (ReadPrec)+import qualified Text.ParserCombinators.ReadPrec as RdPrc #if !MIN_VERSION_base(4,10,0) import GHC.Base (runRW#) #endif@@ -174,7 +179,7 @@  -- | Look up an element in an immutable array. ----- The purpose of returning a result using a monad is to allow the caller to+-- The purpose of returning a result using an applicative is to allow the caller to -- avoid retaining references to the array. Evaluating the return value will -- cause the array lookup to be performed, even though it may not require the -- element of the array to be evaluated (which could throw an exception). For@@ -198,7 +203,7 @@ -- -- /Note:/ this function does not do bounds checking. indexSmallArrayM-  :: Monad m+  :: Applicative m   => SmallArray a -- ^ array   -> Int          -- ^ index   -> m a@@ -348,10 +353,54 @@ sizeofSmallArray (SmallArray sa#) = I# (sizeofSmallArray# sa#) {-# INLINE sizeofSmallArray #-} --- | The number of elements in a mutable array.+-- | Get the number of elements in a mutable array. Unlike+-- 'sizeofSmallMutableArray', this function will be sure to produce the correct+-- result if 'SmallMutableArray' has been shrunk in place. Consider the following:+--+-- @+-- do+--   sa <- 'newSmallArray' 10 x+--   print $ 'sizeofSmallMutableArray' sa+--   'shrinkSmallMutableArray' sa 5+--   print $ sizeofSmallMutableArray sa+-- @+--+-- The compiler is well within its rights to eliminate the second size check+-- and print @10@ twice. However, 'getSizeofSmallMutableArray' will check+-- the size each time it's /executed/ (not /evaluated/), so it won't have this+-- problem:+--+-- @+-- do+--   sa <- 'newSmallArray' 10 x+--   print =<< getSizeofSmallMutableArray sa+--   'shrinkSmallMutableArray' sa 5+--   print =<< getSizeofSmallMutableArray sa+-- @+--+-- will certainly print @10@ and then @5@.+getSizeofSmallMutableArray+  :: PrimMonad m+  => SmallMutableArray (PrimState m) a+  -> m Int+#if MIN_VERSION_base(4,14,0)+getSizeofSmallMutableArray (SmallMutableArray sa#) = primitive $ \s ->+  case getSizeofSmallMutableArray# sa# s of+    (# s', sz# #) -> (# s', I# sz# #)+#else+getSizeofSmallMutableArray sa = pure $! sizeofSmallMutableArray sa+#endif+{-# INLINE getSizeofSmallMutableArray #-}++-- | The number of elements in a mutable array. This should only be used+-- for arrays that are not shrunk in place.+--+-- This is deprecated and will be removed in a future release. Use+-- 'getSizeofSmallMutableArray' instead. sizeofSmallMutableArray :: SmallMutableArray s a -> Int sizeofSmallMutableArray (SmallMutableArray sa#) =   I# (sizeofSmallMutableArray# sa#)+{-# DEPRECATED sizeofSmallMutableArray "use getSizeofSmallMutableArray instead" #-} {-# INLINE sizeofSmallMutableArray #-}  -- | This is the fastest, most straightforward way to traverse@@ -777,25 +826,23 @@       err = error "mfix for Data.Primitive.SmallArray applied to strict function."  -- | @since 0.6.3.0-instance Sem.Semigroup (SmallArray a) where+instance Semigroup (SmallArray a) where   (<>) = (<|>)   sconcat = mconcat . toList   stimes n arr = case compare n 0 of     LT -> die "stimes" "negative multiplier"     EQ -> empty     GT -> createSmallArray (n' * sizeofSmallArray arr) (die "stimes" "impossible") $ \sma ->-      let go i = if i < n'-            then do-              copySmallArray sma (i * sizeofSmallArray arr) arr 0 (sizeofSmallArray arr)-              go (i + 1)-            else return ()+      let go i = when (i < n') $ do+            copySmallArray sma (i * sizeofSmallArray arr) arr 0 (sizeofSmallArray arr)+            go (i + 1)       in go 0     where n' = fromIntegral n :: Int  instance Monoid (SmallArray a) where   mempty = empty #if !(MIN_VERSION_base(4,11,0))-  mappend = (Sem.<>)+  mappend = (<>) #endif   mconcat l = createSmallArray n (die "mconcat" "impossible") $ \ma ->     let go !_  [    ] = return ()@@ -811,9 +858,8 @@   toList = Foldable.toList  smallArrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> SmallArray a -> ShowS-smallArrayLiftShowsPrec elemShowsPrec elemListShowsPrec p sa = showParen (p > 10) $-  showString "fromListN " . shows (length sa) . showString " "-    . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList sa)+smallArrayLiftShowsPrec elemShowsPrec elemListShowsPrec _ sa =+  listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList sa)  -- this need to be included for older ghcs listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS@@ -826,23 +872,34 @@ instance Show1 SmallArray where   liftShowsPrec = smallArrayLiftShowsPrec -smallArrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (SmallArray a)-smallArrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do-  () <$ string "fromListN"-  skipSpaces-  n <- readS_to_P reads-  skipSpaces-  l <- readS_to_P listReadsPrec-  return $ smallArrayFromListN n l+-- See Note [Forgiving Array Read Instance]+smallArrayLiftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (SmallArray a)+smallArrayLiftReadPrec _ read_list =+  ( RdPrc.lift skipSpaces >> fmap fromList read_list )+  RdPrc.++++  ( parens $ prec app_prec $ do+      RdPrc.lift skipSpaces+      tag <- RdPrc.lift lexTag+      case tag of+        FromListTag -> fromList <$> read_list+        FromListNTag -> liftM2 fromListN readPrec read_list+  )+  where+  app_prec = 10  instance Read a => Read (SmallArray a) where-  readsPrec = smallArrayLiftReadsPrec readsPrec readList+  readPrec = smallArrayLiftReadPrec readPrec readListPrec  -- | @since 0.6.4.0 instance Read1 SmallArray where-  liftReadsPrec = smallArrayLiftReadsPrec--+#if MIN_VERSION_base(4,10,0)+  liftReadPrec = smallArrayLiftReadPrec+#else+  -- This is just the default implementation of liftReadsPrec, but+  -- it is not present in older versions of base.+  liftReadsPrec rp rl = RdPrc.readPrec_to_S $+    smallArrayLiftReadPrec (RdPrc.readS_to_Prec rp) (RdPrc.readS_to_Prec (const rl))+#endif  smallArrayDataType :: DataType smallArrayDataType =

@@ -1,13 +1,11 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE MagicHash #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeApplications #-}  #if __GLASGOW_HASKELL__ < 906 {-# LANGUAGE TypeInType #-}@@ -27,7 +25,7 @@  module Data.Primitive.Types   ( Prim(..)-  , sizeOf, alignment, defaultSetByteArray#, defaultSetOffAddr#+  , sizeOf, sizeOfType, alignment, alignmentOfType, defaultSetByteArray#, defaultSetOffAddr#   , PrimStorable(..)   , Ptr(..)   ) where@@ -38,6 +36,7 @@ import Foreign.Ptr (IntPtr, intPtrToPtr, ptrToIntPtr, WordPtr, wordPtrToPtr, ptrToWordPtr) import Foreign.C.Types import System.Posix.Types+import Data.Complex  import GHC.Word (Word8(..), Word16(..), Word32(..), Word64(..)) import GHC.Int (Int8(..), Int16(..), Int32(..), Int64(..))@@ -54,11 +53,11 @@ import GHC.IO (IO(..)) import qualified GHC.Exts - import Control.Applicative (Const(..)) import Data.Functor.Identity (Identity(..)) import qualified Data.Monoid as Monoid import qualified Data.Semigroup as Semigroup+import Data.Proxy  #if !MIN_VERSION_base(4,13,0) import Data.Ord (Down(..))@@ -69,11 +68,31 @@ -- 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.+  -- We use `Proxy` instead of `Proxy#`, since the latter doesn't work with GND for GHC <= 8.8.++  -- | The size of values of type @a@ in bytes. This has to be used with TypeApplications: @sizeOfType \@a@.+  --+  -- @since 0.9.0.0+  sizeOfType# :: Proxy a -> Int#+  sizeOfType# _ = sizeOf# (dummy :: a)++  -- | The size of values of type @a@ in bytes. The argument is not used.+  --+  -- It is recommended to use 'sizeOfType#' instead.   sizeOf# :: a -> Int#+  sizeOf# _ = sizeOfType# (Proxy :: Proxy a) -  -- | Alignment of values of type @a@. The argument is not used.+  -- | The alignment of values of type @a@ in bytes. This has to be used with TypeApplications: @alignmentOfType \@a@.+  --+  -- @since 0.9.0.0+  alignmentOfType# :: Proxy a -> Int#+  alignmentOfType# _ = alignment# (dummy :: a)++  -- | The alignment of values of type @a@ in bytes. The argument is not used.+  --+  -- It is recommended to use 'alignmentOfType#' instead.   alignment# :: a -> Int#+  alignment# _ = alignmentOfType# (Proxy :: Proxy a)    -- | Read a value from the array. The offset is in elements of type   -- @a@ rather than in bytes.@@ -96,6 +115,7 @@     -> a     -> State# s     -> State# s+  setByteArray# = defaultSetByteArray#    -- | 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@@ -119,21 +139,88 @@     -> a     -> State# s     -> State# s+  setOffAddr# = defaultSetOffAddr# --- | Size of values of type @a@. The argument is not used.+  {-# MINIMAL (sizeOfType# | sizeOf#), (alignmentOfType# | alignment#), indexByteArray#, readByteArray#, writeByteArray#,+    indexOffAddr#, readOffAddr#, writeOffAddr# #-}++-- | A dummy value of type @a@.+dummy :: a+dummy = errorWithoutStackTrace "Data.Primitive.Types: implementation mistake in `Prim` instance"+{-# NOINLINE dummy #-}++-- | The size of values of type @a@ in bytes. This has to be used with TypeApplications: @sizeOfType \@a@. --+-- >>> :set -XTypeApplications+-- >>> import Data.Int (Int32)+-- >>> sizeOfType @Int32+-- 4+--+-- @since 0.9.0.0+sizeOfType :: forall a. Prim a => Int+sizeOfType = I# (sizeOfType# (Proxy :: Proxy a))++-- | The size of values of type @a@ in bytes. The argument is not used.+--+-- It is recommended to use 'sizeOfType' instead.+-- -- This function has existed since 0.1, but was moved from 'Data.Primitive' -- to 'Data.Primitive.Types' in version 0.6.3.0. sizeOf :: Prim a => a -> Int sizeOf x = I# (sizeOf# x) --- | Alignment of values of type @a@. The argument is not used.+-- | The alignment of values of type @a@ in bytes. This has to be used with TypeApplications: @alignmentOfType \@a@. --+-- @since 0.9.0.0+alignmentOfType :: forall a. Prim a => Int+alignmentOfType = I# (alignmentOfType# (Proxy :: Proxy a))++-- | The alignment of values of type @a@ in bytes. The argument is not used.+--+-- It is recommended to use 'alignmentOfType' instead.+-- -- This function has existed since 0.1, but was moved from 'Data.Primitive' -- to 'Data.Primitive.Types' in version 0.6.3.0. alignment :: Prim a => a -> Int alignment x = I# (alignment# x) +-- | @since 0.9.0.0+instance Prim a => Prim (Complex a) where+  sizeOf# _ = 2# *# sizeOf# (undefined :: a)+  alignment# _ = alignment# (undefined :: a)+  indexByteArray# arr# i# =+    let x = indexByteArray# arr# (2# *# i#)+        y = indexByteArray# arr# (2# *# i# +# 1#)+    in x :+ y+  readByteArray# arr# i# =+    \s0 -> case readByteArray# arr# (2# *# i#) s0 of+       (# s1#, x #) -> case readByteArray# arr# (2# *# i# +# 1#) s1# of+          (# s2#, y #) -> (# s2#, x :+ y #)+  writeByteArray# arr# i# (a :+ b) =+    \s0 -> case writeByteArray# arr# (2# *# i#) a s0 of+       s1 -> case writeByteArray# arr# (2# *# i# +# 1#) b s1 of+         s2 -> s2+  indexOffAddr# addr# i# =+    let x = indexOffAddr# addr# (2# *# i#)+        y = indexOffAddr# addr# (2# *# i# +# 1#)+    in x :+ y+  readOffAddr# addr# i# =+    \s0 -> case readOffAddr# addr# (2# *# i#) s0 of+       (# s1, x #) -> case readOffAddr# addr# (2# *# i# +# 1#) s1 of+         (# s2, y #) -> (# s2, x :+ y #)+  writeOffAddr# addr# i# (a :+ b) =+    \s0 -> case writeOffAddr# addr# (2# *# i#) a s0 of+       s1 -> case writeOffAddr# addr# (2# *# i# +# 1#) b s1 of+         s2 -> s2+  {-# INLINE sizeOf# #-}+  {-# INLINE alignment# #-}+  {-# INLINE indexByteArray# #-}+  {-# INLINE readByteArray# #-}+  {-# INLINE writeByteArray# #-}+  {-# INLINE indexOffAddr# #-}+  {-# INLINE readOffAddr# #-}+  {-# INLINE writeOffAddr# #-}+ -- | An implementation of 'setByteArray#' that calls 'writeByteArray#' -- to set each element. This is helpful when writing a 'Prim' instance -- for a multi-word data type for which there is no CPU-accelerated way@@ -143,8 +230,8 @@ -- > data Trip = Trip Int Int Int -- > -- > instance Prim Trip--- >   sizeOf# _ = 3# *# sizeOf# (undefined :: Int)--- >   alignment# _ = alignment# (undefined :: Int)+-- >   sizeOfType# _ = 3# *# sizeOfType# (proxy# :: Proxy# Int)+-- >   alignmentOfType# _ = alignmentOfType# (proxy# :: Proxy# Int) -- >   indexByteArray# arr# i# = ... -- >   readByteArray# arr# i# = ... -- >   writeByteArray# arr# i# (Trip a b c) =@@ -194,8 +281,8 @@ newtype PrimStorable a = PrimStorable { getPrimStorable :: a }  instance Prim a => Storable (PrimStorable a) where-  sizeOf _ = sizeOf (undefined :: a)-  alignment _ = alignment (undefined :: a)+  sizeOf _ = sizeOfType @a+  alignment _ = alignmentOfType @a   peekElemOff (Ptr addr#) (I# i#) =     primitive $ \s0# -> case readOffAddr# addr# i# s0# of       (# s1, x #) -> (# s1, PrimStorable x #)@@ -204,8 +291,8 @@  #define derivePrim(ty, ctr, sz, align, idx_arr, rd_arr, wr_arr, set_arr, idx_addr, rd_addr, wr_addr, set_addr) \ instance Prim (ty) where {                                        \-  sizeOf# _ = unI# sz                                             \-; alignment# _ = unI# align                                       \+  sizeOfType# _ = unI# sz                                         \+; alignmentOfType# _ = unI# align                                 \ ; indexByteArray# arr# i# = ctr (idx_arr arr# i#)                 \ ; readByteArray#  arr# i# s# = case rd_arr arr# i# s# of          \                         { (# s1#, x# #) -> (# s1#, ctr x# #) }    \@@ -227,8 +314,8 @@           } in                                                    \       case unsafeCoerce# (internal (set_addr addr# i n x#)) s# of \         { (# s1#, _ #) -> s1# }                                   \-; {-# INLINE sizeOf# #-}                                          \-; {-# INLINE alignment# #-}                                       \+; {-# INLINE sizeOfType# #-}                                      \+; {-# INLINE alignmentOfType# #-}                                 \ ; {-# INLINE indexByteArray# #-}                                  \ ; {-# INLINE readByteArray# #-}                                   \ ; {-# INLINE writeByteArray# #-}                                  \@@ -412,8 +499,8 @@  -- | @since 0.7.1.0 instance Prim WordPtr where-  sizeOf# _ = sizeOf# (undefined :: Ptr ())-  alignment# _ = alignment# (undefined :: Ptr ())+  sizeOfType# _ = sizeOfType# (Proxy :: Proxy (Ptr ()))+  alignmentOfType# _ = alignmentOfType# (Proxy :: Proxy (Ptr ()))   indexByteArray# a i = ptrToWordPtr (indexByteArray# a i)   readByteArray# a i s0 = case readByteArray# a i s0 of     (# s1, p #) -> (# s1, ptrToWordPtr p #)@@ -427,8 +514,8 @@  -- | @since 0.7.1.0 instance Prim IntPtr where-  sizeOf# _ = sizeOf# (undefined :: Ptr ())-  alignment# _ = alignment# (undefined :: Ptr ())+  sizeOfType# _ = sizeOfType# (Proxy :: Proxy (Ptr ()))+  alignmentOfType# _ = alignmentOfType# (Proxy :: Proxy (Ptr ()))   indexByteArray# a i = ptrToIntPtr (indexByteArray# a i)   readByteArray# a i s0 = case readByteArray# a i s0 of     (# s1, p #) -> (# s1, ptrToIntPtr p #)

@@ -66,4 +66,4 @@ cheap i = modify (\x -> x + i) >> return (i * i)  numbers :: Array Int-numbers = fromList (enumFromTo 0 10000)+numbers = arrayFromList (enumFromTo 0 10000)

@@ -1,3 +1,35 @@+## Changes in version 0.9.0.0++  * Add `withByteArrayContents`, `withMutableByteArrayContents`,+    `withPrimArrayContents`, `withMutablePrimArrayContents`.++  * Fix signature of `keepAlive`.++  * Remove re-export of `fromList` and `fromListN` from `Data.Primitive.Array`.++  * Use `mutableByteArrayContents#` in GHC 9.2+++  * Add `Prim` instance for `Complex`.++  * Add `getSizeofSmallMutableArray` that wraps `getSizeofSmallMutableArray#`+    from `GHC.Exts`.++  * Add default definitions for the `setByteArray#` and `setOffAddr#` methods,+    so they don't need to be defined explicitly anymore.++  * Add standalone `sizeOfType`/`alignmentOfType` (recommended over `sizeOf`/`alignment`)+    and `Prim` class methods `sizeOfType#`/`alignmentOfType#` (recommended over `sizeOf#`/`alignment#`)++  * Change `Show` instances of `PrimArray`, `Array`, and `SmallArray`. These+    previously used the `fromListN n [...]` form, but they now used the more+    terse `[...]` form.++  * Correct the `Read` instances of `Array` and `SmallArray`. These instances+    are supposed to be able to handle all three of these forms: `fromList [...]`,+    `fromListN n [...]`, and `[...]`. They had been rejected the last form, but+    this mistake was discovered by the test suite when the Show instances were+    changed.+ ## Changes in version 0.8.0.0    * Add `resizeSmallMutableArray` that wraps `resizeSmallMutableArray#` from

@@ -1,6 +1,6 @@ Cabal-Version:  2.0 Name:           primitive-Version:        0.8.0.0+Version:        0.9.0.0 License:        BSD3 License-File:   LICENSE @@ -53,9 +53,10 @@    Other-Modules:         Data.Primitive.Internal.Operations+        Data.Primitive.Internal.Read -  Build-Depends: base >= 4.9 && < 4.19-               , deepseq >= 1.1 && < 1.5+  Build-Depends: base >= 4.9 && < 4.20+               , deepseq >= 1.1 && < 1.6                , transformers >= 0.5 && < 0.7                , template-haskell >= 2.11 @@ -80,7 +81,7 @@   Default-Language: Haskell2010   hs-source-dirs: test                   test/src-  main-is: main.hs+  main-is: Main.hs   Other-Modules: PrimLaws   type: exitcode-stdio-1.0   build-depends: base

@@ -0,0 +1,440 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++#if __GLASGOW_HASKELL__ >= 805+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE TypeInType #-}+#endif++import Control.Monad+import Control.Monad.ST+import Data.Complex+import Data.Primitive+import Data.Word+import Data.Proxy (Proxy(..))+import GHC.Int+import GHC.IO+import GHC.Exts+import Data.Function (on)+import Control.Applicative (Const(..))+import PrimLaws (primLaws)++import Data.Functor.Identity (Identity(..))+import qualified Data.Monoid as Monoid+import Data.Ord (Down(..))+import Data.Semigroup (stimes, stimesMonoid)+import qualified Data.Semigroup as Semigroup+#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,(===),(==>))+import qualified Test.Tasty.QuickCheck as TQC+import qualified Test.QuickCheck as QC+import qualified Test.QuickCheck.Classes.Base as QCC+import qualified Test.QuickCheck.Classes.Base.IsList as QCCL+import qualified Data.List as L++main :: IO ()+main = do+  testArray+  testByteArray+  defaultMain $ testGroup "properties"+    [ testGroup "Array"+      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (Array Int)))+      , lawsToTest (QCC.ordLaws (Proxy :: Proxy (Array Int)))+      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (Array Int)))+      , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))+      , lawsToTest (QCC.functorLaws (Proxy :: Proxy Array))+      , lawsToTest (QCC.applicativeLaws (Proxy :: Proxy Array))+      , lawsToTest (QCC.alternativeLaws (Proxy :: Proxy Array))+      , lawsToTest (QCC.monadLaws (Proxy :: Proxy Array))+      , lawsToTest (QCC.monadZipLaws (Proxy :: Proxy Array))+      , lawsToTest (QCC.monadPlusLaws (Proxy :: Proxy Array))+      , lawsToTest (QCC.foldableLaws (Proxy :: Proxy Array))+      , lawsToTest (QCC.traversableLaws (Proxy :: Proxy Array))+      , lawsToTest (QCC.isListLaws (Proxy :: Proxy (Array Int)))+      , TQC.testProperty "mapArray'" (QCCL.mapProp int16 int32 mapArray')+      , TQC.testProperty "*>" $ \(xs :: Array Int) (ys :: Array Int) -> toList (xs *> ys) === (toList xs *> toList ys)+      , TQC.testProperty "<*" $ \(xs :: Array Int) (ys :: Array Int) -> toList (xs <* ys) === (toList xs <* toList ys)+      , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (Array Int)))+      , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: Array Int) -> stimes n xs == stimesMonoid n xs+      ]+    , testGroup "SmallArray"+      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SmallArray Int)))+      , lawsToTest (QCC.ordLaws (Proxy :: Proxy (SmallArray Int)))+      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (SmallArray Int)))+      , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))+      , lawsToTest (QCC.functorLaws (Proxy :: Proxy SmallArray))+      , lawsToTest (QCC.applicativeLaws (Proxy :: Proxy SmallArray))+      , lawsToTest (QCC.alternativeLaws (Proxy :: Proxy SmallArray))+      , lawsToTest (QCC.monadLaws (Proxy :: Proxy SmallArray))+      , lawsToTest (QCC.monadZipLaws (Proxy :: Proxy SmallArray))+      , lawsToTest (QCC.monadPlusLaws (Proxy :: Proxy SmallArray))+      , lawsToTest (QCC.foldableLaws (Proxy :: Proxy SmallArray))+      , lawsToTest (QCC.traversableLaws (Proxy :: Proxy SmallArray))+      , lawsToTest (QCC.isListLaws (Proxy :: Proxy (SmallArray Int)))+      , TQC.testProperty "mapSmallArray'" (QCCL.mapProp int16 int32 mapSmallArray')+      , TQC.testProperty "*>" $ \(xs :: SmallArray Int) (ys :: SmallArray Int) -> toList (xs *> ys) === (toList xs *> toList ys)+      , TQC.testProperty "<*" $ \(xs :: SmallArray Int) (ys :: SmallArray Int) -> toList (xs <* ys) === (toList xs <* toList ys)+      , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (SmallArray Int)))+      , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: SmallArray Int) -> stimes n xs == stimesMonoid n xs+      ]+    , testGroup "ByteArray"+      [ testGroup "Ordering"+        [ TQC.testProperty "equality" byteArrayEqProp+        , TQC.testProperty "compare" byteArrayCompareProp+      , testGroup "Filling"+        [ TQC.testProperty "Int8" (setByteArrayProp (Proxy :: Proxy Int8))+        , TQC.testProperty "Int16" (setByteArrayProp (Proxy :: Proxy Int16))+        , TQC.testProperty "Int32" (setByteArrayProp (Proxy :: Proxy Int32))+        , TQC.testProperty "Int64" (setByteArrayProp (Proxy :: Proxy Int64))+        , TQC.testProperty "Int" (setByteArrayProp (Proxy :: Proxy Int))+        , TQC.testProperty "Word8" (setByteArrayProp (Proxy :: Proxy Word8))+        , TQC.testProperty "Word16" (setByteArrayProp (Proxy :: Proxy Word16))+        , TQC.testProperty "Word32" (setByteArrayProp (Proxy :: Proxy Word32))+        , TQC.testProperty "Word64" (setByteArrayProp (Proxy :: Proxy Word64))+        , TQC.testProperty "Word" (setByteArrayProp (Proxy :: Proxy Word))+        ]+      ]+      , testGroup "Resize"+        [ TQC.testProperty "shrink" byteArrayShrinkProp+        , TQC.testProperty "grow" byteArrayGrowProp+        ]+      , lawsToTest (QCC.eqLaws (Proxy :: Proxy ByteArray))+      , lawsToTest (QCC.ordLaws (Proxy :: Proxy ByteArray))+      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy ByteArray))+      , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))+      , lawsToTest (QCC.isListLaws (Proxy :: Proxy ByteArray))+      , TQC.testProperty "foldrByteArray" (QCCL.foldrProp word8 foldrByteArray)+      , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy ByteArray))+      , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: ByteArray) -> stimes n xs == stimesMonoid n xs+      ]+    , testGroup "PrimArray"+      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (PrimArray Word16)))+      , lawsToTest (QCC.ordLaws (Proxy :: Proxy (PrimArray Word16)))+      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (PrimArray Word16)))+      , lawsToTest (QCC.isListLaws (Proxy :: Proxy (PrimArray Word16)))+      , TQC.testProperty "foldrPrimArray" (QCCL.foldrProp int16 foldrPrimArray)+      , TQC.testProperty "foldrPrimArray'" (QCCL.foldrProp int16 foldrPrimArray')+      , TQC.testProperty "foldlPrimArray" (QCCL.foldlProp int16 foldlPrimArray)+      , TQC.testProperty "foldlPrimArray'" (QCCL.foldlProp int16 foldlPrimArray')+      , TQC.testProperty "foldlPrimArrayM'" (QCCL.foldlMProp int16 foldlPrimArrayM')+      , TQC.testProperty "mapPrimArray" (QCCL.mapProp int16 int32 mapPrimArray)+      , TQC.testProperty "traversePrimArray" (QCCL.traverseProp int16 int32 traversePrimArray)+      , TQC.testProperty "traversePrimArrayP" (QCCL.traverseProp int16 int32 traversePrimArrayP)+      , TQC.testProperty "imapPrimArray" (QCCL.imapProp int16 int32 imapPrimArray)+      , TQC.testProperty "itraversePrimArray" (QCCL.imapMProp int16 int32 itraversePrimArray)+      , TQC.testProperty "itraversePrimArrayP" (QCCL.imapMProp int16 int32 itraversePrimArrayP)+      , TQC.testProperty "generatePrimArray" (QCCL.generateProp int16 generatePrimArray)+      , TQC.testProperty "generatePrimArrayA" (QCCL.generateMProp int16 generatePrimArrayA)+      , TQC.testProperty "generatePrimArrayP" (QCCL.generateMProp int16 generatePrimArrayP)+      , TQC.testProperty "replicatePrimArray" (QCCL.replicateProp int16 replicatePrimArray)+      , TQC.testProperty "replicatePrimArrayA" (QCCL.replicateMProp int16 replicatePrimArrayA)+      , TQC.testProperty "replicatePrimArrayP" (QCCL.replicateMProp int16 replicatePrimArrayP)+      , TQC.testProperty "filterPrimArray" (QCCL.filterProp int16 filterPrimArray)+      , TQC.testProperty "filterPrimArrayA" (QCCL.filterMProp int16 filterPrimArrayA)+      , TQC.testProperty "filterPrimArrayP" (QCCL.filterMProp int16 filterPrimArrayP)+      , TQC.testProperty "mapMaybePrimArray" (QCCL.mapMaybeProp int16 int32 mapMaybePrimArray)+      , TQC.testProperty "mapMaybePrimArrayA" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayA)+      , TQC.testProperty "mapMaybePrimArrayP" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayP)+      , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (PrimArray Word16)))+      , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: PrimArray Word16) -> stimes n xs == stimesMonoid n xs+      ]+    , testGroup "DefaultSetMethod"+      [ lawsToTest (primLaws (Proxy :: Proxy DefaultSetMethod))+      ]+#if __GLASGOW_HASKELL__ >= 805+    , 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)))+      , 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)))+      , 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)))+      , renameLawsToTest "Complex" (primLaws (Proxy :: Proxy (Complex Double)))+      ]+    ]++deriving instance Arbitrary a => Arbitrary (Down a)+-- Const, Dual, Sum, Product: all have Arbitrary instances defined+-- in QuickCheck itself+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)++word8 :: Proxy Word8+word8 = Proxy++int16 :: Proxy Int16+int16 = Proxy++int32 :: Proxy Int32+int32 = Proxy+++setByteArrayProp :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> QC.Property+setByteArrayProp _ = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (off :: Int)) (QC.NonNegative (len :: Int)) (x :: a) (y :: a) ->+  (off < n && off + len <= n) ==>+  -- We use PrimArray in this test because it makes it easier to+  -- get the element-vs-byte distinction right.+  let actual = runST $ do+        m <- newPrimArray n+        forM_ (enumFromTo 0 (n - 1)) $ \ix -> writePrimArray m ix x+        setPrimArray m off len y+        unsafeFreezePrimArray m+      expected = runST $ do+        m <- newPrimArray n+        forM_ (enumFromTo 0 (n - 1)) $ \ix -> writePrimArray m ix x+        forM_ (enumFromTo off (off + len - 1)) $ \ix -> writePrimArray m ix y+        unsafeFreezePrimArray m+   in expected === actual+++-- Tests that using resizeByteArray to shrink a byte array produces+-- the same results as calling Data.List.take on the list that the+-- byte array corresponds to.+byteArrayShrinkProp :: QC.Property+byteArrayShrinkProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) ->+  let large = max n m+      small = min n m+      xs = intsLessThan large+      ys = byteArrayFromList xs+      largeBytes = large * sizeOfType @Int+      smallBytes = small * sizeOfType @Int+      expected = byteArrayFromList (L.take small xs)+      actual = runST $ do+        mzs0 <- newByteArray largeBytes+        copyByteArray mzs0 0 ys 0 largeBytes+        mzs1 <- resizeMutableByteArray mzs0 smallBytes+        unsafeFreezeByteArray mzs1+   in expected === actual++-- Tests that using resizeByteArray with copyByteArray (to fill in the+-- new empty space) to grow a byte array produces the same results as+-- calling Data.List.++ on the lists corresponding to the original+-- byte array and the appended byte array.+byteArrayGrowProp :: QC.Property+byteArrayGrowProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) ->+  let large = max n m+      small = min n m+      xs1 = intsLessThan small+      xs2 = intsLessThan (large - small)+      ys1 = byteArrayFromList xs1+      ys2 = byteArrayFromList xs2+      largeBytes = large * sizeOfType @Int+      smallBytes = small * sizeOfType @Int+      expected = byteArrayFromList (xs1 ++ xs2)+      actual = runST $ do+        mzs0 <- newByteArray smallBytes+        copyByteArray mzs0 0 ys1 0 smallBytes+        mzs1 <- resizeMutableByteArray mzs0 largeBytes+        copyByteArray mzs1 smallBytes ys2 0 ((large - small) * sizeOfType @Int)+        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+-- [0,1,2,3,4]+intsLessThan :: Int -> [Int]+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)++byteArrayEqProp :: QC.Property+byteArrayEqProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) ->+  (compareLengthFirst xs ys == EQ) === (byteArrayFromList xs == byteArrayFromList ys)++compareLengthFirst :: [Word8] -> [Word8] -> Ordering+compareLengthFirst xs ys = (compare `on` length) xs ys <> compare xs ys++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'+    let unit =+            case writeArray arr 0 'B' of+                IO f ->+                    case f realWorld# of+                        (# _, _ #) -> ()+    c1 <- readArray arr 0+    return $! unit+    c2 <- readArray arr 0+    if c1 == 'A' && c2 == 'B'+        then return ()+        else error $ "Expected AB, got: " ++ show (c1, c2)++testByteArray :: IO ()+testByteArray = do+    let arr1 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8])+        arr2 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8])+        arr3 = mkByteArray ([0xde, 0xad, 0xbe, 0xee] :: [Word8])+        arr4 = mkByteArray ([0xde, 0xad, 0xbe, 0xdd] :: [Word8])+        arr5 = mkByteArray ([0xde, 0xad, 0xbe, 0xef, 0xde, 0xad, 0xbe, 0xdd] :: [Word8])+        arr6 = mkByteArray ([0xde, 0xad, 0x00, 0x01, 0xb0] :: [Word8])+    when (show arr1 /= "[0xde, 0xad, 0xbe, 0xef]") $+        fail $ "ByteArray Show incorrect: "++show arr1+    when (show arr6 /= "[0xde, 0xad, 0x00, 0x01, 0xb0]") $+        fail $ "ByteArray Show incorrect: "++ show arr6+    when (compareByteArrays arr3 1 arr4 1 3 /= GT) $+        fail $ "arr3[1,3] should be greater than arr4[1,3]"+    when (compareByteArrays arr3 0 arr4 1 3 /= GT) $+        fail $ "arr3[0,3] should be greater than arr4[1,3]"+    when (compareByteArrays arr5 1 arr2 1 3 /= EQ) $+        fail $ "arr3[1,3] should be equal to than arr4[1,3]"+    unless (arr1 > arr3) $+        fail $ "ByteArray Ord incorrect"+    unless (arr1 == arr2) $+        fail $ "ByteArray Eq incorrect"+    unless (mappend arr1 arr4 == arr5) $+        fail $ "ByteArray Monoid mappend incorrect"+    unless (mappend arr1 (mappend arr3 arr4) == mappend (mappend arr1 arr3) arr4) $+        fail $ "ByteArray Monoid mappend not associative"+    unless (mconcat [arr1,arr2,arr3,arr4,arr5] == (arr1 <> arr2 <> arr3 <> arr4 <> arr5)) $+        fail $ "ByteArray Monoid mconcat incorrect"+    unless (stimes (3 :: Int) arr4 == (arr4 <> arr4 <> arr4)) $+        fail $ "ByteArray Semigroup stimes incorrect"++mkByteArray :: forall a. Prim a => [a] -> ByteArray+mkByteArray xs = runST $ do+    marr <- newByteArray (length xs * sizeOfType @a)+    sequence_ $ zipWith (writeByteArray marr) [0..] xs+    unsafeFreezeByteArray marr++instance Arbitrary1 Array where+  liftArbitrary elemGen = fmap fromList (QC.liftArbitrary elemGen)++instance Arbitrary a => Arbitrary (Array a) where+  arbitrary = fmap fromList QC.arbitrary++instance Arbitrary1 SmallArray where+  liftArbitrary elemGen = fmap smallArrayFromList (QC.liftArbitrary elemGen)++instance Arbitrary a => Arbitrary (SmallArray a) where+  arbitrary = fmap smallArrayFromList QC.arbitrary++instance Arbitrary ByteArray where+  arbitrary = do+    xs <- QC.arbitrary :: Gen [Word8]+    return $ runST $ do+      a <- newByteArray (L.length xs)+      iforM_ xs $ \ix x -> do+        writeByteArray a ix x+      unsafeFreezeByteArray a++instance (Arbitrary a, Prim a) => Arbitrary (PrimArray a) where+  arbitrary = do+    xs <- QC.arbitrary :: Gen [a]+    return $ runST $ do+      a <- newPrimArray (L.length xs)+      iforM_ xs $ \ix x -> do+        writePrimArray a ix x+      unsafeFreezePrimArray a++++instance (Prim a, CoArbitrary a) => CoArbitrary (PrimArray a) where+  coarbitrary x = QC.coarbitrary (primArrayToList x)++instance (Prim a, Function a) => Function (PrimArray a) where+  function = QC.functionMap primArrayToList primArrayFromList++iforM_ :: Monad m => [a] -> (Int -> a -> m b) -> m ()+iforM_ xs0 f = go 0 xs0 where+  go !_ [] = return ()+  go !ix (x : xs) = f ix x >> go (ix + 1) xs++newtype DefaultSetMethod = DefaultSetMethod Int16+  deriving (Eq,Show,Arbitrary)++instance Prim DefaultSetMethod where+  sizeOfType# _ = sizeOfType# (Proxy :: Proxy Int16)+  alignmentOfType# _ = alignmentOfType# (Proxy :: Proxy Int16)+  indexByteArray# arr ix = DefaultSetMethod (indexByteArray# arr ix)+  readByteArray# arr ix s0 = case readByteArray# arr ix s0 of+    (# s1, n #) -> (# s1, DefaultSetMethod n #)+  writeByteArray# arr ix (DefaultSetMethod n) s0 = writeByteArray# arr ix n s0+  setByteArray# = defaultSetByteArray#+  indexOffAddr# addr off = DefaultSetMethod (indexOffAddr# addr off)+  readOffAddr# addr off s0 = case readOffAddr# addr off s0 of+    (# s1, n #) -> (# s1, DefaultSetMethod n #)+  writeOffAddr# addr off (DefaultSetMethod n) s0 = writeOffAddr# addr off n s0+  setOffAddr# = defaultSetOffAddr#++#if __GLASGOW_HASKELL__ >= 805+newtype Derived = Derived Int16+  deriving stock (Eq, Show)+  deriving newtype (Arbitrary, Prim)+  deriving Storable via (PrimStorable Derived)+#endif

@@ -1,434 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--#if __GLASGOW_HASKELL__ >= 805-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE TypeInType #-}-#endif--import Control.Monad-import Control.Monad.ST-import Data.Primitive-import Data.Word-import Data.Proxy (Proxy(..))-import GHC.Int-import GHC.IO-import GHC.Exts-import Data.Function (on)-import Control.Applicative (Const(..))-import PrimLaws (primLaws)--import Data.Functor.Identity (Identity(..))-import qualified Data.Monoid as Monoid-import Data.Ord (Down(..))-import Data.Semigroup (stimes, stimesMonoid)-import qualified Data.Semigroup as Semigroup-#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,(===),(==>))-import qualified Test.Tasty.QuickCheck as TQC-import qualified Test.QuickCheck as QC-import qualified Test.QuickCheck.Classes.Base as QCC-import qualified Test.QuickCheck.Classes.Base.IsList as QCCL-import qualified Data.List as L--main :: IO ()-main = do-  testArray-  testByteArray-  defaultMain $ testGroup "properties"-    [ testGroup "Array"-      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (Array Int)))-      , lawsToTest (QCC.ordLaws (Proxy :: Proxy (Array Int)))-      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (Array Int)))-      , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))-      , lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 Array))-      , lawsToTest (QCC.applicativeLaws (Proxy1 :: Proxy1 Array))-      , lawsToTest (QCC.monadLaws (Proxy1 :: Proxy1 Array))-      , lawsToTest (QCC.foldableLaws (Proxy1 :: Proxy1 Array))-      , lawsToTest (QCC.traversableLaws (Proxy1 :: Proxy1 Array))-      , lawsToTest (QCC.isListLaws (Proxy :: Proxy (Array Int)))-      , TQC.testProperty "mapArray'" (QCCL.mapProp int16 int32 mapArray')-      , TQC.testProperty "*>" $ \(xs :: Array Int) (ys :: Array Int) -> toList (xs *> ys) === (toList xs *> toList ys)-      , TQC.testProperty "<*" $ \(xs :: Array Int) (ys :: Array Int) -> toList (xs <* ys) === (toList xs <* toList ys)-      , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (Array Int)))-      , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: Array Int) -> stimes n xs == stimesMonoid n xs-      ]-    , testGroup "SmallArray"-      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SmallArray Int)))-      , lawsToTest (QCC.ordLaws (Proxy :: Proxy (SmallArray Int)))-      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (SmallArray Int)))-      , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))-      , lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 SmallArray))-      , lawsToTest (QCC.applicativeLaws (Proxy1 :: Proxy1 SmallArray))-      , lawsToTest (QCC.monadLaws (Proxy1 :: Proxy1 SmallArray))-      , lawsToTest (QCC.foldableLaws (Proxy1 :: Proxy1 SmallArray))-      , lawsToTest (QCC.traversableLaws (Proxy1 :: Proxy1 SmallArray))-      , lawsToTest (QCC.isListLaws (Proxy :: Proxy (SmallArray Int)))-      , TQC.testProperty "mapSmallArray'" (QCCL.mapProp int16 int32 mapSmallArray')-      , TQC.testProperty "*>" $ \(xs :: SmallArray Int) (ys :: SmallArray Int) -> toList (xs *> ys) === (toList xs *> toList ys)-      , TQC.testProperty "<*" $ \(xs :: SmallArray Int) (ys :: SmallArray Int) -> toList (xs <* ys) === (toList xs <* toList ys)-      , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (SmallArray Int)))-      , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: SmallArray Int) -> stimes n xs == stimesMonoid n xs-      ]-    , testGroup "ByteArray"-      [ testGroup "Ordering"-        [ TQC.testProperty "equality" byteArrayEqProp-        , TQC.testProperty "compare" byteArrayCompareProp-      , testGroup "Filling"-        [ TQC.testProperty "Int8" (setByteArrayProp (Proxy :: Proxy Int8))-        , TQC.testProperty "Int16" (setByteArrayProp (Proxy :: Proxy Int16))-        , TQC.testProperty "Int32" (setByteArrayProp (Proxy :: Proxy Int32))-        , TQC.testProperty "Int64" (setByteArrayProp (Proxy :: Proxy Int64))-        , TQC.testProperty "Int" (setByteArrayProp (Proxy :: Proxy Int))-        , TQC.testProperty "Word8" (setByteArrayProp (Proxy :: Proxy Word8))-        , TQC.testProperty "Word16" (setByteArrayProp (Proxy :: Proxy Word16))-        , TQC.testProperty "Word32" (setByteArrayProp (Proxy :: Proxy Word32))-        , TQC.testProperty "Word64" (setByteArrayProp (Proxy :: Proxy Word64))-        , TQC.testProperty "Word" (setByteArrayProp (Proxy :: Proxy Word))-        ]-      ]-      , testGroup "Resize"-        [ TQC.testProperty "shrink" byteArrayShrinkProp-        , TQC.testProperty "grow" byteArrayGrowProp-        ]-      , lawsToTest (QCC.eqLaws (Proxy :: Proxy ByteArray))-      , lawsToTest (QCC.ordLaws (Proxy :: Proxy ByteArray))-      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy ByteArray))-      , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))-      , lawsToTest (QCC.isListLaws (Proxy :: Proxy ByteArray))-      , TQC.testProperty "foldrByteArray" (QCCL.foldrProp word8 foldrByteArray)-      , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy ByteArray))-      , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: ByteArray) -> stimes n xs == stimesMonoid n xs-      ]-    , testGroup "PrimArray"-      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (PrimArray Word16)))-      , lawsToTest (QCC.ordLaws (Proxy :: Proxy (PrimArray Word16)))-      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (PrimArray Word16)))-      , lawsToTest (QCC.isListLaws (Proxy :: Proxy (PrimArray Word16)))-      , TQC.testProperty "foldrPrimArray" (QCCL.foldrProp int16 foldrPrimArray)-      , TQC.testProperty "foldrPrimArray'" (QCCL.foldrProp int16 foldrPrimArray')-      , TQC.testProperty "foldlPrimArray" (QCCL.foldlProp int16 foldlPrimArray)-      , TQC.testProperty "foldlPrimArray'" (QCCL.foldlProp int16 foldlPrimArray')-      , TQC.testProperty "foldlPrimArrayM'" (QCCL.foldlMProp int16 foldlPrimArrayM')-      , TQC.testProperty "mapPrimArray" (QCCL.mapProp int16 int32 mapPrimArray)-      , TQC.testProperty "traversePrimArray" (QCCL.traverseProp int16 int32 traversePrimArray)-      , TQC.testProperty "traversePrimArrayP" (QCCL.traverseProp int16 int32 traversePrimArrayP)-      , TQC.testProperty "imapPrimArray" (QCCL.imapProp int16 int32 imapPrimArray)-      , TQC.testProperty "itraversePrimArray" (QCCL.imapMProp int16 int32 itraversePrimArray)-      , TQC.testProperty "itraversePrimArrayP" (QCCL.imapMProp int16 int32 itraversePrimArrayP)-      , TQC.testProperty "generatePrimArray" (QCCL.generateProp int16 generatePrimArray)-      , TQC.testProperty "generatePrimArrayA" (QCCL.generateMProp int16 generatePrimArrayA)-      , TQC.testProperty "generatePrimArrayP" (QCCL.generateMProp int16 generatePrimArrayP)-      , TQC.testProperty "replicatePrimArray" (QCCL.replicateProp int16 replicatePrimArray)-      , TQC.testProperty "replicatePrimArrayA" (QCCL.replicateMProp int16 replicatePrimArrayA)-      , TQC.testProperty "replicatePrimArrayP" (QCCL.replicateMProp int16 replicatePrimArrayP)-      , TQC.testProperty "filterPrimArray" (QCCL.filterProp int16 filterPrimArray)-      , TQC.testProperty "filterPrimArrayA" (QCCL.filterMProp int16 filterPrimArrayA)-      , TQC.testProperty "filterPrimArrayP" (QCCL.filterMProp int16 filterPrimArrayP)-      , TQC.testProperty "mapMaybePrimArray" (QCCL.mapMaybeProp int16 int32 mapMaybePrimArray)-      , TQC.testProperty "mapMaybePrimArrayA" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayA)-      , TQC.testProperty "mapMaybePrimArrayP" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayP)-      , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (PrimArray Word16)))-      , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: PrimArray Word16) -> stimes n xs == stimesMonoid n xs-      ]-    , testGroup "DefaultSetMethod"-      [ lawsToTest (primLaws (Proxy :: Proxy DefaultSetMethod))-      ]-#if __GLASGOW_HASKELL__ >= 805-    , 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)))-      , 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)))-      , 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)))-      ]-    ]--deriving instance Arbitrary a => Arbitrary (Down a)--- Const, Dual, Sum, Product: all have Arbitrary instances defined--- in QuickCheck itself-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)--word8 :: Proxy Word8-word8 = Proxy--int16 :: Proxy Int16-int16 = Proxy--int32 :: Proxy Int32-int32 = Proxy---setByteArrayProp :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> QC.Property-setByteArrayProp _ = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (off :: Int)) (QC.NonNegative (len :: Int)) (x :: a) (y :: a) ->-  (off < n && off + len <= n) ==>-  -- We use PrimArray in this test because it makes it easier to-  -- get the element-vs-byte distinction right.-  let actual = runST $ do-        m <- newPrimArray n-        forM_ (enumFromTo 0 (n - 1)) $ \ix -> writePrimArray m ix x-        setPrimArray m off len y-        unsafeFreezePrimArray m-      expected = runST $ do-        m <- newPrimArray n-        forM_ (enumFromTo 0 (n - 1)) $ \ix -> writePrimArray m ix x-        forM_ (enumFromTo off (off + len - 1)) $ \ix -> writePrimArray m ix y-        unsafeFreezePrimArray m-   in expected === actual----- Tests that using resizeByteArray to shrink a byte array produces--- the same results as calling Data.List.take on the list that the--- byte array corresponds to.-byteArrayShrinkProp :: QC.Property-byteArrayShrinkProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) ->-  let large = max n m-      small = min n m-      xs = intsLessThan large-      ys = byteArrayFromList xs-      largeBytes = large * sizeOf (undefined :: Int)-      smallBytes = small * sizeOf (undefined :: Int)-      expected = byteArrayFromList (L.take small xs)-      actual = runST $ do-        mzs0 <- newByteArray largeBytes-        copyByteArray mzs0 0 ys 0 largeBytes-        mzs1 <- resizeMutableByteArray mzs0 smallBytes-        unsafeFreezeByteArray mzs1-   in expected === actual---- Tests that using resizeByteArray with copyByteArray (to fill in the--- new empty space) to grow a byte array produces the same results as--- calling Data.List.++ on the lists corresponding to the original--- byte array and the appended byte array.-byteArrayGrowProp :: QC.Property-byteArrayGrowProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) ->-  let large = max n m-      small = min n m-      xs1 = intsLessThan small-      xs2 = intsLessThan (large - small)-      ys1 = byteArrayFromList xs1-      ys2 = byteArrayFromList xs2-      largeBytes = large * sizeOf (undefined :: Int)-      smallBytes = small * sizeOf (undefined :: Int)-      expected = byteArrayFromList (xs1 ++ xs2)-      actual = runST $ do-        mzs0 <- newByteArray smallBytes-        copyByteArray mzs0 0 ys1 0 smallBytes-        mzs1 <- resizeMutableByteArray mzs0 largeBytes-        copyByteArray mzs1 smallBytes ys2 0 ((large - small) * sizeOf (undefined :: Int))-        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--- [0,1,2,3,4]-intsLessThan :: Int -> [Int]-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)--byteArrayEqProp :: QC.Property-byteArrayEqProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) ->-  (compareLengthFirst xs ys == EQ) === (byteArrayFromList xs == byteArrayFromList ys)--compareLengthFirst :: [Word8] -> [Word8] -> Ordering-compareLengthFirst xs ys = (compare `on` length) xs ys <> compare xs ys---- on GHC 7.4, Proxy is not polykinded, so we need this instead.-data Proxy1 (f :: * -> *) = Proxy1--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'-    let unit =-            case writeArray arr 0 'B' of-                IO f ->-                    case f realWorld# of-                        (# _, _ #) -> ()-    c1 <- readArray arr 0-    return $! unit-    c2 <- readArray arr 0-    if c1 == 'A' && c2 == 'B'-        then return ()-        else error $ "Expected AB, got: " ++ show (c1, c2)--testByteArray :: IO ()-testByteArray = do-    let arr1 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8])-        arr2 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8])-        arr3 = mkByteArray ([0xde, 0xad, 0xbe, 0xee] :: [Word8])-        arr4 = mkByteArray ([0xde, 0xad, 0xbe, 0xdd] :: [Word8])-        arr5 = mkByteArray ([0xde, 0xad, 0xbe, 0xef, 0xde, 0xad, 0xbe, 0xdd] :: [Word8])-        arr6 = mkByteArray ([0xde, 0xad, 0x00, 0x01, 0xb0] :: [Word8])-    when (show arr1 /= "[0xde, 0xad, 0xbe, 0xef]") $-        fail $ "ByteArray Show incorrect: "++show arr1-    when (show arr6 /= "[0xde, 0xad, 0x00, 0x01, 0xb0]") $-        fail $ "ByteArray Show incorrect: "++ show arr6-    when (compareByteArrays arr3 1 arr4 1 3 /= GT) $-        fail $ "arr3[1,3] should be greater than arr4[1,3]"-    when (compareByteArrays arr3 0 arr4 1 3 /= GT) $-        fail $ "arr3[0,3] should be greater than arr4[1,3]"-    when (compareByteArrays arr5 1 arr2 1 3 /= EQ) $-        fail $ "arr3[1,3] should be equal to than arr4[1,3]"-    unless (arr1 > arr3) $-        fail $ "ByteArray Ord incorrect"-    unless (arr1 == arr2) $-        fail $ "ByteArray Eq incorrect"-    unless (mappend arr1 arr4 == arr5) $-        fail $ "ByteArray Monoid mappend incorrect"-    unless (mappend arr1 (mappend arr3 arr4) == mappend (mappend arr1 arr3) arr4) $-        fail $ "ByteArray Monoid mappend not associative"-    unless (mconcat [arr1,arr2,arr3,arr4,arr5] == (arr1 <> arr2 <> arr3 <> arr4 <> arr5)) $-        fail $ "ByteArray Monoid mconcat incorrect"-    unless (stimes (3 :: Int) arr4 == (arr4 <> arr4 <> arr4)) $-        fail $ "ByteArray Semigroup stimes incorrect"--mkByteArray :: Prim a => [a] -> ByteArray-mkByteArray xs = runST $ do-    marr <- newByteArray (length xs * sizeOf (head xs))-    sequence_ $ zipWith (writeByteArray marr) [0..] xs-    unsafeFreezeByteArray marr--instance Arbitrary1 Array where-  liftArbitrary elemGen = fmap fromList (QC.liftArbitrary elemGen)--instance Arbitrary a => Arbitrary (Array a) where-  arbitrary = fmap fromList QC.arbitrary--instance Arbitrary1 SmallArray where-  liftArbitrary elemGen = fmap smallArrayFromList (QC.liftArbitrary elemGen)--instance Arbitrary a => Arbitrary (SmallArray a) where-  arbitrary = fmap smallArrayFromList QC.arbitrary--instance Arbitrary ByteArray where-  arbitrary = do-    xs <- QC.arbitrary :: Gen [Word8]-    return $ runST $ do-      a <- newByteArray (L.length xs)-      iforM_ xs $ \ix x -> do-        writeByteArray a ix x-      unsafeFreezeByteArray a--instance (Arbitrary a, Prim a) => Arbitrary (PrimArray a) where-  arbitrary = do-    xs <- QC.arbitrary :: Gen [a]-    return $ runST $ do-      a <- newPrimArray (L.length xs)-      iforM_ xs $ \ix x -> do-        writePrimArray a ix x-      unsafeFreezePrimArray a----instance (Prim a, CoArbitrary a) => CoArbitrary (PrimArray a) where-  coarbitrary x = QC.coarbitrary (primArrayToList x)--instance (Prim a, Function a) => Function (PrimArray a) where-  function = QC.functionMap primArrayToList primArrayFromList--iforM_ :: Monad m => [a] -> (Int -> a -> m b) -> m ()-iforM_ xs0 f = go 0 xs0 where-  go !_ [] = return ()-  go !ix (x : xs) = f ix x >> go (ix + 1) xs--newtype DefaultSetMethod = DefaultSetMethod Int16-  deriving (Eq,Show,Arbitrary)--instance Prim DefaultSetMethod where-  sizeOf# _ = sizeOf# (undefined :: Int16)-  alignment# _ = alignment# (undefined :: Int16)-  indexByteArray# arr ix = DefaultSetMethod (indexByteArray# arr ix)-  readByteArray# arr ix s0 = case readByteArray# arr ix s0 of-    (# s1, n #) -> (# s1, DefaultSetMethod n #)-  writeByteArray# arr ix (DefaultSetMethod n) s0 = writeByteArray# arr ix n s0-  setByteArray# = defaultSetByteArray#-  indexOffAddr# addr off = DefaultSetMethod (indexOffAddr# addr off)-  readOffAddr# addr off s0 = case readOffAddr# addr off s0 of-    (# s1, n #) -> (# s1, DefaultSetMethod n #)-  writeOffAddr# addr off (DefaultSetMethod n) s0 = writeOffAddr# addr off n s0-  setOffAddr# = defaultSetOffAddr#--#if __GLASGOW_HASKELL__ >= 805-newtype Derived = Derived Int16-  deriving stock (Eq, Show)-  deriving newtype (Arbitrary, Prim)-  deriving Storable via (PrimStorable Derived)-#endif

@@ -3,7 +3,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE TypeApplications #-}  {-# OPTIONS_GHC -Wall #-} @@ -17,7 +17,6 @@   ( primLaws   ) where -import Control.Applicative import Control.Monad.Primitive (primitive_) import Control.Monad.ST import Data.Proxy (Proxy)@@ -26,9 +25,7 @@ import Data.Primitive.Types import Data.Primitive.Ptr import Foreign.Marshal.Alloc-import GHC.Exts (State#,Int#,Int(I#),(+#),(<#))--import GHC.Exts (IsList(fromList,toList))+import GHC.Exts (State#, Int#, Int(I#), (+#), (<#), IsList(fromList,toList))  import System.IO.Unsafe import Test.QuickCheck hiding ((.&.))@@ -54,7 +51,7 @@ 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))+  ptr :: Ptr a <- mallocBytes (len * P.sizeOfType @a)   let go :: Int -> [a] -> IO ()       go !ix xs = case xs of         [] -> return ()@@ -113,7 +110,7 @@ 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))+    ptr :: Ptr a <- mallocBytes (len * P.sizeOfType @a)     writeOffPtr ptr ix a     a' <- readOffPtr ptr ix     free ptr