primitive 0.6.3.0 → 0.6.4.0

raw patch · 16 files changed

+3387/−372 lines, 16 filesdep −primitivedep ~basedep ~ghc-prim

Dependencies removed: primitive

Dependency ranges changed: base, ghc-prim

Files

• Control/Monad/Primitive.hs +27/−0
• Data/Primitive.hs +66/−6
• Data/Primitive/Addr.hs +33/−2
• Data/Primitive/Array.hs +405/−167
• Data/Primitive/ByteArray.hs +255/−52
• Data/Primitive/MVar.hs +155/−0
• Data/Primitive/PrimArray.hs +969/−0
• Data/Primitive/Ptr.hs +125/−0
• Data/Primitive/SmallArray.hs +445/−117
• Data/Primitive/Types.hs +189/−1
• Data/Primitive/UnliftedArray.hs +280/−7
• changelog.md +61/−0
• primitive.cabal +9/−14
• test/LICENSE +30/−0
• test/main.hs +293/−6
• test/primitive-tests.cabal +45/−0

@@ -1,6 +1,7 @@ {-# LANGUAGE CPP, MagicHash, UnboxedTuples, TypeFamilies #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}  -- | -- Module      : Control.Monad.Primitive@@ -77,6 +78,8 @@ -- Unlike 'PrimMonad', this typeclass requires that the @Monad@ be fully -- expressed as a state transformer, therefore disallowing other monad -- transformers on top of the base @IO@ or @ST@.+--+-- @since 0.6.0.0 class PrimMonad m => PrimBase m where   -- | Expose the internal structure of the monad   internal :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #)@@ -97,41 +100,52 @@   internal (IO p) = p   {-# INLINE internal #-} +-- | @since 0.6.3.0 instance PrimMonad m => PrimMonad (ContT r m) where   type PrimState (ContT r m) = PrimState m   primitive = lift . primitive   {-# INLINE primitive #-}+ instance PrimMonad m => PrimMonad (IdentityT m) where   type PrimState (IdentityT m) = PrimState m   primitive = lift . primitive   {-# INLINE primitive #-}++-- | @since 0.6.2.0 instance PrimBase m => PrimBase (IdentityT m) where   internal (IdentityT m) = internal m   {-# INLINE internal #-}+ instance PrimMonad m => PrimMonad (ListT m) where   type PrimState (ListT m) = PrimState m   primitive = lift . primitive   {-# INLINE primitive #-}+ instance PrimMonad m => PrimMonad (MaybeT m) where   type PrimState (MaybeT m) = PrimState m   primitive = lift . primitive   {-# INLINE primitive #-}+ instance (Error e, PrimMonad m) => PrimMonad (ErrorT e m) where   type PrimState (ErrorT e m) = PrimState m   primitive = lift . primitive   {-# INLINE primitive #-}+ instance PrimMonad m => PrimMonad (ReaderT r m) where   type PrimState (ReaderT r m) = PrimState m   primitive = lift . primitive   {-# INLINE primitive #-}+ instance PrimMonad m => PrimMonad (StateT s m) where   type PrimState (StateT s m) = PrimState m   primitive = lift . primitive   {-# INLINE primitive #-}+ instance (Monoid w, PrimMonad m) => PrimMonad (WriterT w m) where   type PrimState (WriterT w m) = PrimState m   primitive = lift . primitive   {-# INLINE primitive #-}+ instance (Monoid w, PrimMonad m) => PrimMonad (RWST r w s m) where   type PrimState (RWST r w s m) = PrimState m   primitive = lift . primitive@@ -145,6 +159,7 @@ #endif  #if MIN_VERSION_transformers(0,5,3)+-- | @since 0.6.3.0 instance ( Monoid w          , PrimMonad m # if !(MIN_VERSION_base(4,8,0))@@ -164,10 +179,12 @@   type PrimState (Strict.StateT s m) = PrimState m   primitive = lift . primitive   {-# INLINE primitive #-}+ instance (Monoid w, PrimMonad m) => PrimMonad (Strict.WriterT w m) where   type PrimState (Strict.WriterT w m) = PrimState m   primitive = lift . primitive   {-# INLINE primitive #-}+ instance (Monoid w, PrimMonad m) => PrimMonad (Strict.RWST r w s m) where   type PrimState (Strict.RWST r w s m) = PrimState m   primitive = lift . primitive@@ -205,11 +222,15 @@ primToST = primToPrim  -- | Convert an 'IO' action to a 'PrimMonad'.+-- +-- @since 0.6.2.0 ioToPrim :: (PrimMonad m, PrimState m ~ RealWorld) => IO a -> m a {-# INLINE ioToPrim #-} ioToPrim = primToPrim  -- | Convert an 'ST' action to a 'PrimMonad'.+--+-- @since 0.6.2.0 stToPrim :: PrimMonad m => ST (PrimState m) a -> m a {-# INLINE stToPrim #-} stToPrim = primToPrim@@ -233,12 +254,16 @@  -- | Convert an 'ST' action with an arbitraty state token to any 'PrimMonad'. -- This operation is highly unsafe!+-- +-- @since 0.6.2.0 unsafeSTToPrim :: PrimMonad m => ST s a -> m a {-# INLINE unsafeSTToPrim #-} unsafeSTToPrim = unsafePrimToPrim  -- | Convert an 'IO' action to any 'PrimMonad'. This operation is highly -- unsafe!+--+-- @since 0.6.2.0 unsafeIOToPrim :: PrimMonad m => IO a -> m a {-# INLINE unsafeIOToPrim #-} unsafeIOToPrim = unsafePrimToPrim@@ -261,6 +286,8 @@         $ (primitive (\s -> case touch# x s of { s' -> (# s', () #) }) :: IO ())  -- | Create an action to force a value; generalizes 'Control.Exception.evaluate'+--+-- @since 0.6.2.0 evalPrim :: forall a m . PrimMonad m => a -> m a #if MIN_VERSION_base(4,4,0) evalPrim a = primitive (\s -> seq# a s)

@@ -11,15 +11,75 @@ -- Reexports all primitive operations -- module Data.Primitive (-  module Data.Primitive.Types,-  module Data.Primitive.Array,-  module Data.Primitive.ByteArray,-  module Data.Primitive.Addr,--  sizeOf, alignment+  -- * Re-exports+  module Data.Primitive.Types+  ,module Data.Primitive.Array+  ,module Data.Primitive.ByteArray+  ,module Data.Primitive.Addr+  ,module Data.Primitive.SmallArray+  ,module Data.Primitive.UnliftedArray+  ,module Data.Primitive.PrimArray+  ,module Data.Primitive.MutVar+  -- * Naming Conventions+  -- $namingConventions ) where  import Data.Primitive.Types import Data.Primitive.Array import Data.Primitive.ByteArray import Data.Primitive.Addr+import Data.Primitive.SmallArray+import Data.Primitive.UnliftedArray+import Data.Primitive.PrimArray+import Data.Primitive.MutVar++{- $namingConventions+For historical reasons, this library embraces the practice of suffixing+the name of a function with the type it operates on. For example, three+of the variants of the array indexing function are:++> indexArray      ::           Array      a -> Int -> a+> indexSmallArray ::           SmallArray a -> Int -> a+> indexPrimArray  :: Prim a => PrimArray  a -> Int -> a++In a few places, where the language sounds more natural, the array type+is instead used as a prefix. For example, @Data.Primitive.SmallArray@+exports @smallArrayFromList@, which would sound unnatural if it used+@SmallArray@ as a suffix instead.++This library provides several functions traversing, building, and filtering+arrays. These functions are suffixed with an additional character to+indicate their the nature of their effectfulness:++* No suffix: A non-effectful pass over the array.+* @-A@ suffix: An effectful pass over the array, where the effect is 'Applicative'.+* @-P@ suffix: An effectful pass over the array, where the effect is 'PrimMonad'.++Additionally, an apostrophe can be used to indicate strictness in the elements.+The variants with an apostrophe are used in @Data.Primitive.Array@ but not+in @Data.Primitive.PrimArray@ since the array type it provides is always strict in the element.+For example, there are three variants of the function that filters elements+from a primitive array.++> filterPrimArray  :: (Prim a               ) => (a ->   Bool) -> PrimArray a ->    PrimArray a+> filterPrimArrayA :: (Prim a, Applicative f) => (a -> f Bool) -> PrimArray a -> f (PrimArray a)+> filterPrimArrayP :: (Prim a, PrimMonad   m) => (a -> m Bool) -> PrimArray a -> m (PrimArray a)++As long as the effectful context is a monad that is sufficiently affine+the behaviors of the 'Applicative' and 'PrimMonad' variants produce the same results+and differ only in their strictness. Monads that are sufficiently affine+include:++* 'IO' and 'ST'+* Any combination of 'MaybeT', 'ExceptT', 'StateT' and 'Writer' on top+  of another sufficiently affine monad.++There is one situation where the names deviate from effectful suffix convention+described above. Throughout the haskell ecosystem, the 'Applicative' variant of+'map' is known as 'traverse', not @mapA@. Consequently, we adopt the following+naming convention for mapping:++> mapPrimArray :: (Prim a, Prim b) => (a -> b) -> PrimArray a -> PrimArray b+> traversePrimArray :: (Applicative f, Prim a, Prim b) => (a -> f b) -> PrimArray a -> f (PrimArray b)+> traversePrimArrayP :: (PrimMonad m, Prim a, Prim b) => (a -> m b) -> PrimArray a -> m (PrimArray b)+-}

@@ -1,4 +1,4 @@-{-# LANGUAGE MagicHash, UnboxedTuples #-}+{-# LANGUAGE MagicHash, UnboxedTuples, CPP #-}  -- | -- Module      : Data.Primitive.Addr@@ -22,11 +22,21 @@   indexOffAddr, readOffAddr, writeOffAddr,    -- * Block operations-  copyAddr, moveAddr, setAddr+  copyAddr,+#if __GLASGOW_HASKELL__ >= 708+  copyAddrToByteArray,+#endif+  moveAddr, setAddr,++  -- * Conversion+  addrToInt ) where  import Control.Monad.Primitive import Data.Primitive.Types+#if __GLASGOW_HASKELL__ >= 708+import Data.Primitive.ByteArray+#endif  import GHC.Base ( Int(..) ) import GHC.Prim@@ -84,6 +94,23 @@ copyAddr (Addr dst#) (Addr src#) n   = unsafePrimToPrim $ copyBytes (Ptr dst#) (Ptr src#) n +#if __GLASGOW_HASKELL__ >= 708+-- | Copy the given number of bytes from the 'Addr' to the 'MutableByteArray'.+--   The areas may not overlap. This function is only available when compiling+--   with GHC 7.8 or newer.+--   +--   @since 0.6.4.0+copyAddrToByteArray :: PrimMonad m+  => MutableByteArray (PrimState m) -- ^ destination+  -> Int -- ^ offset into the destination array+  -> Addr -- ^ source+  -> Int -- ^ number of bytes to copy+  -> m ()+{-# INLINE copyAddrToByteArray #-}+copyAddrToByteArray (MutableByteArray marr) (I# off) (Addr addr) (I# len) =+  primitive_ $ copyAddrToByteArray# addr marr off len+#endif+ -- | Copy the given number of bytes from the second 'Addr' to the first. The -- areas may overlap. moveAddr :: PrimMonad m => Addr         -- ^ destination address@@ -100,3 +127,7 @@ {-# INLINE setAddr #-} setAddr (Addr addr#) (I# n#) x = primitive_ (setOffAddr# addr# 0# n# x) +-- | Convert an 'Addr' to an 'Int'.+addrToInt :: Addr -> Int+{-# INLINE addrToInt #-}+addrToInt (Addr addr#) = I# (addr2Int# addr#)

@@ -16,13 +16,15 @@ module Data.Primitive.Array (   Array(..), MutableArray(..), -  newArray, readArray, writeArray, indexArray, indexArrayM,-  freezeArray, thawArray,+  newArray, readArray, writeArray, indexArray, indexArrayM, indexArray##,+  freezeArray, thawArray, runArray,   unsafeFreezeArray, unsafeThawArray, sameMutableArray,   copyArray, copyMutableArray,   cloneArray, cloneMutableArray,   sizeofArray, sizeofMutableArray,-  fromListN, fromList+  fromListN, fromList,+  mapArray',+  traverseArrayP ) where  import Control.Monad.Primitive@@ -42,7 +44,7 @@ import Control.Monad.ST(ST,runST)  import Control.Applicative-import Control.Monad (MonadPlus(..))+import Control.Monad (MonadPlus(..), when) import Control.Monad.Fix #if MIN_VERSION_base(4,4,0) import Control.Monad.Zip@@ -53,31 +55,35 @@ import Data.Monoid #endif #if MIN_VERSION_base(4,9,0)+import qualified GHC.ST as GHCST import qualified Data.Foldable as F import Data.Semigroup #endif+#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity+#endif+#if MIN_VERSION_base(4,10,0)+import GHC.Exts (runRW#)+#elif MIN_VERSION_base(4,9,0)+import GHC.Base (runRW#)+#endif  import Text.ParserCombinators.ReadP +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..))+#endif+ -- | Boxed arrays data Array a = Array-             { array# :: Array# a-#if (__GLASGOW_HASKELL__ < 702)-             , sizeofArray :: {-# UNPACK #-} !Int-#endif-             }+  { array# :: Array# a }   deriving ( Typeable )  -- | Mutable boxed arrays associated with a primitive state token. data MutableArray s a = MutableArray-                      { marray# :: MutableArray# s a-#if (__GLASGOW_HASKELL__ < 702)-                      , sizeofMutableArray :: {-# UNPACK #-} !Int-#endif-                      }+  { marray# :: MutableArray# s a }   deriving ( Typeable ) -#if (__GLASGOW_HASKELL__ >= 702) sizeofArray :: Array a -> Int sizeofArray a = I# (sizeofArray# (array# a)) {-# INLINE sizeofArray #-}@@ -85,7 +91,6 @@ sizeofMutableArray :: MutableArray s a -> Int sizeofMutableArray a = I# (sizeofMutableArray# (marray# a)) {-# INLINE sizeofMutableArray #-}-#endif  -- | Create a new mutable array of the specified size and initialise all -- elements with the given value.@@ -95,9 +100,6 @@    (\s# -> case newArray# n# x s# of              (# s'#, arr# #) ->                let ma = MutableArray arr#-#if (__GLASGOW_HASKELL__ < 702)-                          (I# n#)-#endif                in (# s'# , ma #))  -- | Read a value from the array at the given index.@@ -115,6 +117,13 @@ {-# INLINE indexArray #-} indexArray arr (I# i#) = case indexArray# (array# arr) i# of (# x #) -> x +-- | Read a value from the immutable array at the given index, returning+-- the result in an unboxed unary tuple. This is currently used to implement+-- folds.+indexArray## :: Array a -> Int -> (# a #)+indexArray## arr (I# i) = indexArray# (array# arr) i+{-# INLINE indexArray## #-}+ -- | Monadically read a value from the immutable array at the given index. -- 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@@ -154,16 +163,9 @@   -> Int                          -- ^ length   -> m (Array a) {-# INLINE freezeArray #-}-#if (__GLASGOW_HASKELL__ >= 702) freezeArray (MutableArray ma#) (I# off#) (I# len#) =   primitive $ \s -> case freezeArray# ma# off# len# s of     (# s', a# #) -> (# s', Array a# #)-#else-freezeArray src off len = do-  dst <- newArray len (die "freezeArray" "impossible")-  copyMutableArray dst 0 src off len-  unsafeFreezeArray dst-#endif  -- | Convert a mutable array to an immutable one without copying. The -- array should not be modified after the conversion.@@ -173,9 +175,6 @@   = primitive (\s# -> case unsafeFreezeArray# (marray# arr) s# of                         (# s'#, arr'# #) ->                           let a = Array arr'#-#if (__GLASGOW_HASKELL__ < 702)-                                    (sizeofMutableArray arr)-#endif                           in (# s'#, a #))  -- | Create a mutable array from a slice of an immutable array.@@ -189,16 +188,9 @@   -> Int     -- ^ length   -> m (MutableArray (PrimState m) a) {-# INLINE thawArray #-}-#if (__GLASGOW_HASKELL__ >= 702) thawArray (Array a#) (I# off#) (I# len#) =   primitive $ \s -> case thawArray# a# off# len# s of     (# s', ma# #) -> (# s', MutableArray ma# #)-#else-thawArray src off len = do-  dst <- newArray len (die "thawArray" "impossible")-  copyArray dst 0 src off len-  return dst-#endif  -- | Convert an immutable array to an mutable one without copying. The -- immutable array should not be used after the conversion.@@ -208,9 +200,6 @@   = primitive (\s# -> case unsafeThawArray# (array# a) s# of                         (# s'#, arr'# #) ->                           let ma = MutableArray arr'#-#if (__GLASGOW_HASKELL__ < 702)-                                     (sizeofArray a)-#endif                           in (# s'#, ma #))  -- | Check whether the two arrays refer to the same memory block.@@ -275,15 +264,8 @@            -> Int     -- ^ number of elements to copy            -> Array a {-# INLINE cloneArray #-}-#if __GLASGOW_HASKELL__ >= 702 cloneArray (Array arr#) (I# off#) (I# len#)   = case cloneArray# arr# off# len# of arr'# -> Array arr'#-#else-cloneArray arr off len = runST $ do-    marr2 <- newArray len $ die "cloneArray" "impossible"-    copyArray marr2 0 arr off len-    unsafeFreezeArray marr2-#endif  -- | Return a newly allocated MutableArray. with the specified subrange of -- the provided MutableArray. The provided MutableArray should contain the@@ -294,112 +276,209 @@         -> Int                          -- ^ number of elements to copy         -> m (MutableArray (PrimState m) a) {-# INLINE cloneMutableArray #-}-#if __GLASGOW_HASKELL__ >= 702 cloneMutableArray (MutableArray arr#) (I# off#) (I# len#) = primitive    (\s# -> case cloneMutableArray# arr# off# len# s# of              (# s'#, arr'# #) -> (# s'#, MutableArray arr'# #))-#else-cloneMutableArray marr off len = do-        marr2 <- newArray len $ die "cloneMutableArray" "impossible"-        let go !i !j c-                | c >= len = return marr2-                | otherwise = do-                    b <- readArray marr i-                    writeArray marr2 j b-                    go (i+1) (j+1) (c+1)-        go off 0 0-#endif  emptyArray :: Array a emptyArray =   runST $ newArray 0 (die "emptyArray" "impossible") >>= unsafeFreezeArray {-# NOINLINE emptyArray #-} +#if !MIN_VERSION_base(4,9,0) createArray   :: Int   -> a   -> (forall s. MutableArray s a -> ST s ())   -> Array a createArray 0 _ _ = emptyArray-createArray n x f = runST $ do-  ma <- newArray n x-  f ma-  unsafeFreezeArray ma+createArray n x f = runArray $ do+  mary <- newArray n x+  f mary+  pure mary +runArray+  :: (forall s. ST s (MutableArray s a))+  -> Array a+runArray m = runST $ m >>= unsafeFreezeArray++#else /* Below, runRW# is available. */++-- This low-level business is designed to work with GHC's worker-wrapper+-- transformation. A lot of the time, we don't actually need an Array+-- constructor. By putting it on the outside, and being careful about+-- how we special-case the empty array, we can make GHC smarter about this.+-- The only downside is that separately created 0-length arrays won't share+-- their Array constructors, although they'll share their underlying+-- Array#s.+createArray+  :: Int+  -> a+  -> (forall s. MutableArray s a -> ST s ())+  -> Array a+createArray 0 _ _ = Array (emptyArray# (# #))+createArray n x f = runArray $ do+  mary <- newArray n x+  f mary+  pure mary++runArray+  :: (forall s. ST s (MutableArray s a))+  -> Array a+runArray m = Array (runArray# m)++runArray#+  :: (forall s. ST s (MutableArray s a))+  -> Array# a+runArray# m = case runRW# $ \s ->+  case unST m s of { (# s', MutableArray mary# #) ->+  unsafeFreezeArray# mary# s'} of (# _, ary# #) -> ary#++unST :: ST s a -> State# s -> (# State# s, a #)+unST (GHCST.ST f) = f++emptyArray# :: (# #) -> Array# a+emptyArray# _ = case emptyArray of Array ar -> ar+{-# NOINLINE emptyArray# #-}+#endif++ die :: String -> String -> a die fun problem = error $ "Data.Primitive.Array." ++ fun ++ ": " ++ problem +arrayLiftEq :: (a -> b -> Bool) -> Array a -> Array b -> Bool+arrayLiftEq p a1 a2 = sizeofArray a1 == sizeofArray a2 && loop (sizeofArray a1 - 1)+  where loop i | i < 0     = True+               | (# x1 #) <- indexArray## a1 i+               , (# x2 #) <- indexArray## a2 i+               , otherwise = p x1 x2 && loop (i-1)+ instance Eq a => Eq (Array a) where-  a1 == a2 = sizeofArray a1 == sizeofArray a2 && loop (sizeofArray a1 - 1)-   where loop i | i < 0     = True-                | otherwise = indexArray a1 i == indexArray a2 i && loop (i-1)+  a1 == a2 = arrayLiftEq (==) a1 a2 +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+-- | @since 0.6.4.0+instance Eq1 Array where+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)+  liftEq = arrayLiftEq+#else+  eq1 = arrayLiftEq (==)+#endif+#endif+ instance Eq (MutableArray s a) where   ma1 == ma2 = isTrue# (sameMutableArray# (marray# ma1) (marray# ma2)) +arrayLiftCompare :: (a -> b -> Ordering) -> Array a -> Array b -> Ordering+arrayLiftCompare elemCompare a1 a2 = loop 0+  where+  mn = sizeofArray a1 `min` sizeofArray a2+  loop i+    | i < mn+    , (# x1 #) <- indexArray## a1 i+    , (# x2 #) <- indexArray## a2 i+    = elemCompare x1 x2 `mappend` loop (i+1)+    | otherwise = compare (sizeofArray a1) (sizeofArray a2)++-- | Lexicographic ordering. Subject to change between major versions. instance Ord a => Ord (Array a) where-  compare a1 a2 = loop 0-   where-   mn = sizeofArray a1 `min` sizeofArray a2-   loop i-     | i < mn    = compare (indexArray a1 i) (indexArray a2 i) `mappend` loop (i+1)-     | otherwise = compare (sizeofArray a1) (sizeofArray a2)+  compare a1 a2 = arrayLiftCompare compare a1 a2 +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+-- | @since 0.6.4.0+instance Ord1 Array where+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)+  liftCompare = arrayLiftCompare+#else+  compare1 = arrayLiftCompare compare+#endif+#endif+ instance Foldable Array where-  foldr f z a = go 0-   where go i | i < sizeofArray a = f (indexArray a i) (go $ i+1)-              | otherwise         = z+  -- Note: we perform the array lookups eagerly so we won't+  -- create thunks to perform lookups even if GHC can't see+  -- that the folding function is strict.+  foldr f = \z !ary ->+    let+      !sz = sizeofArray ary+      go i+        | i == sz = z+        | (# x #) <- indexArray## ary i+        = f x (go (i+1))+    in go 0   {-# INLINE foldr #-}-  foldl f z a = go (sizeofArray a - 1)-   where go i | i < 0     = z-              | otherwise = f (go $ i-1) (indexArray a i)+  foldl f = \z !ary ->+    let+      go i+        | i < 0 = z+        | (# x #) <- indexArray## ary i+        = f (go (i-1)) x+    in go (sizeofArray ary - 1)   {-# INLINE foldl #-}-  foldr1 f a | sz < 0    = die "foldr1" "empty array"-             | otherwise = go 0-   where sz = sizeofArray a - 1-         z = indexArray a sz-         go i | i < sz    = f (indexArray a i) (go $ i+1)-              | otherwise = z+  foldr1 f = \ !ary ->+    let+      !sz = sizeofArray ary - 1+      go i =+        case indexArray## ary i of+          (# x #) | i == sz -> x+                  | otherwise -> f x (go (i+1))+    in if sz < 0+       then die "foldr1" "empty array"+       else go 0   {-# INLINE foldr1 #-}-  foldl1 f a | sz == 0   = die "foldl1" "empty array"-             | otherwise = go $ sz-1-   where sz = sizeofArray a-         z = indexArray a 0-         go i | i < 1     = f (go $ i-1) (indexArray a i)-              | otherwise = z+  foldl1 f = \ !ary ->+    let+      !sz = sizeofArray ary - 1+      go i =+        case indexArray## ary i of+          (# x #) | i == 0 -> x+                  | otherwise -> f (go (i - 1)) x+    in if sz < 0+       then die "foldl1" "empty array"+       else go sz   {-# INLINE foldl1 #-} #if MIN_VERSION_base(4,6,0)-  foldr' f z a = go (sizeofArray a - 1) z-   where go i !acc | i < 0     = acc-                   | otherwise = go (i-1) (f (indexArray a i) acc)+  foldr' f = \z !ary ->+    let+      go i !acc+        | i == -1 = acc+        | (# x #) <- indexArray## ary i+        = go (i-1) (f x acc)+    in go (sizeofArray ary - 1) z   {-# INLINE foldr' #-}-  foldl' f z a = go 0 z-   where go i !acc | i < sizeofArray a = go (i+1) (f acc $ indexArray a i)-                   | otherwise         = acc+  foldl' f = \z !ary ->+    let+      !sz = sizeofArray ary+      go i !acc+        | i == sz = acc+        | (# x #) <- indexArray## ary i+        = go (i+1) (f acc x)+    in go 0 z   {-# INLINE foldl' #-} #endif #if MIN_VERSION_base(4,8,0)-  toList a = Exts.build $ \c z -> let-      sz = sizeofArray a-      go i | i < sz    = c (indexArray a i) (go $ i+1)-           | otherwise = z-    in go 0-  {-# INLINE toList #-}   null a = sizeofArray a == 0   {-# INLINE null #-}   length = sizeofArray   {-# INLINE length #-}-  maximum a | sz == 0   = die "maximum" "empty array"-            | otherwise = go 1 (indexArray a 0)-   where sz = sizeofArray a-         go i !e | i < sz    = go (i+1) (max e $ indexArray a i)-                 | otherwise = e+  maximum ary | sz == 0   = die "maximum" "empty array"+              | (# frst #) <- indexArray## ary 0+              = go 1 frst+   where+     sz = sizeofArray ary+     go i !e+       | i == sz = e+       | (# x #) <- indexArray## ary i+       = go (i+1) (max e x)   {-# INLINE maximum #-}-  minimum a | sz == 0   = die "minimum" "empty array"-            | otherwise = go 1 (indexArray a 0)-   where sz = sizeofArray a-         go i !e | i < sz    = go (i+1) (min e $ indexArray a i)-                 | otherwise = e+  minimum ary | sz == 0   = die "minimum" "empty array"+              | (# frst #) <- indexArray## ary 0+              = go 1 frst+   where sz = sizeofArray ary+         go i !e+           | i == sz = e+           | (# x #) <- indexArray## ary i+           = go (i+1) (min e x)   {-# INLINE minimum #-}   sum = foldl' (+) 0   {-# INLINE sum #-}@@ -407,56 +486,155 @@   {-# INLINE product #-} #endif +newtype STA a = STA {_runSTA :: forall s. MutableArray# s a -> ST s (Array a)}++runSTA :: Int -> STA a -> Array a+runSTA !sz = \ (STA m) -> runST $ newArray_ sz >>= \ ar -> m (marray# ar)+{-# INLINE runSTA #-}++newArray_ :: Int -> ST s (MutableArray s a)+newArray_ !n = newArray n badTraverseValue++badTraverseValue :: a+badTraverseValue = die "traverse" "bad indexing"+{-# NOINLINE badTraverseValue #-}+ instance Traversable Array where-  traverse f a =-    fromListN (sizeofArray a)-      <$> traverse (f . indexArray a) [0 .. sizeofArray a - 1]+  traverse f = traverseArray f+  {-# INLINE traverse #-} +traverseArray+  :: Applicative f+  => (a -> f b)+  -> Array a+  -> f (Array b)+traverseArray f = \ !ary ->+  let+    !len = sizeofArray ary+    go !i+      | i == len = pure $ STA $ \mary -> unsafeFreezeArray (MutableArray mary)+      | (# x #) <- indexArray## ary i+      = liftA2 (\b (STA m) -> STA $ \mary ->+                  writeArray (MutableArray mary) i b >> m mary)+               (f x) (go (i + 1))+  in if len == 0+     then pure emptyArray+     else runSTA len <$> go 0+{-# INLINE [1] traverseArray #-}++{-# RULES+"traverse/ST" forall (f :: a -> ST s b). traverseArray f =+   traverseArrayP f+"traverse/IO" forall (f :: a -> IO b). traverseArray f =+   traverseArrayP f+ #-}+#if MIN_VERSION_base(4,8,0)+{-# RULES+"traverse/Id" forall (f :: a -> Identity b). traverseArray f =+   (coerce :: (Array a -> Array (Identity b))+           -> Array a -> Identity (Array b)) (fmap f)+ #-}+#endif++-- | This is the fastest, most straightforward way to traverse+-- an array, but it only works correctly with a sufficiently+-- "affine" 'PrimMonad' instance. In particular, it must only produce+-- *one* result array. 'Control.Monad.Trans.List.ListT'-transformed+-- monads, for example, will not work right at all.+traverseArrayP+  :: PrimMonad m+  => (a -> m b)+  -> Array a+  -> m (Array b)+traverseArrayP f = \ !ary ->+  let+    !sz = sizeofArray ary+    go !i !mary+      | i == sz+      = unsafeFreezeArray mary+      | otherwise+      = do+          a <- indexArrayM ary i+          b <- f a+          writeArray mary i b+          go (i + 1) mary+  in do+    mary <- newArray sz badTraverseValue+    go 0 mary+{-# INLINE traverseArrayP #-}++-- | Strict map over the elements of the array.+mapArray' :: (a -> b) -> Array a -> Array b+mapArray' f a =+  createArray (sizeofArray a) (die "mapArray'" "impossible") $ \mb ->+    let go i | i == sizeofArray a+             = return ()+             | otherwise+             = do x <- indexArrayM a i+                  -- We use indexArrayM here so that we will perform the+                  -- indexing eagerly even if f is lazy.+                  let !y = f x+                  writeArray mb i y >> go (i+1)+     in go 0+{-# INLINE mapArray' #-}++arrayFromListN :: Int -> [a] -> Array a+arrayFromListN n l =+  createArray n (die "fromListN" "uninitialized element") $ \sma ->+    let go !ix [] = if ix == n+          then return ()+          else die "fromListN" "list length less than specified size"+        go !ix (x : xs) = if ix < n+          then do+            writeArray sma ix x+            go (ix+1) xs+          else die "fromListN" "list length greater than specified size"+    in go 0 l++arrayFromList :: [a] -> Array a+arrayFromList l = arrayFromListN (length l) l+ #if MIN_VERSION_base(4,7,0) instance Exts.IsList (Array a) where   type Item (Array a) = a-  fromListN n l =-    createArray n (die "fromListN" "mismatched size and list") $ \mi ->-      let go i (x:xs) = writeArray mi i x >> go (i+1) xs-          go _ [    ] = return ()-       in go 0 l-  fromList l = Exts.fromListN (length l) l+  fromListN = arrayFromListN+  fromList = arrayFromList   toList = toList #else fromListN :: Int -> [a] -> Array a-fromListN n l =-  createArray n (die "fromListN" "mismatched size and list") $ \mi ->-    let go i (x:xs) = writeArray mi i x >> go (i+1) xs-        go _ [    ] = return ()-     in go 0 l+fromListN = arrayFromListN  fromList :: [a] -> Array a-fromList l = fromListN (length l) l+fromList = arrayFromList #endif  instance Functor Array where   fmap f a =     createArray (sizeofArray a) (die "fmap" "impossible") $ \mb ->-      let go i | i < sizeofArray a = return ()-               | otherwise         = writeArray mb i (f $ indexArray a i)-                                  >> go (i+1)+      let go i | i == sizeofArray a+               = return ()+               | otherwise+               = do x <- indexArrayM a i+                    writeArray mb i (f x) >> go (i+1)        in go 0 #if MIN_VERSION_base(4,8,0)-  e <$ a = runST $ newArray (sizeofArray a) e >>= unsafeFreezeArray+  e <$ a = createArray (sizeofArray a) e (\ !_ -> pure ()) #endif  instance Applicative Array where-  pure x = runST $ newArray 1 x >>= unsafeFreezeArray-  ab <*> a = runST $ do-    mb <- newArray (szab*sza) $ die "<*>" "impossible"-    let go1 i-          | i < szab  = go2 (i*sza) (indexArray ab i) 0 >> go1 (i+1)-          | otherwise = return ()-        go2 off f j-          | j < sza   = writeArray mb (off + j) (f $ indexArray a j)-          | otherwise = return ()-    go1 0-    unsafeFreezeArray mb+  pure x = runArray $ newArray 1 x+  ab <*> a = createArray (szab*sza) (die "<*>" "impossible") $ \mb ->+    let go1 i = when (i < szab) $+            do+              f <- indexArrayM ab i+              go2 (i*sza) f 0+              go1 (i+1)+        go2 off f j = when (j < sza) $+            do+              x <- indexArrayM a j+              writeArray mb (off + j) (f x)+              go2 off f (j + 1)+    in go1 0    where szab = sizeofArray ab ; sza = sizeofArray a   a *> b = createArray (sza*szb) (die "*>" "impossible") $ \mb ->     let go i | i < sza   = copyArray mb (i * szb) b 0 szb@@ -466,7 +644,9 @@   a <* b = createArray (sza*szb) (die "<*" "impossible") $ \ma ->     let fill off i e | i < szb   = writeArray ma (off+i) e >> fill off (i+1) e                      | otherwise = return ()-        go i | i < sza   = fill (i*szb) 0 (indexArray a i) >> go (i+1)+        go i | i < sza+             = do x <- indexArrayM a i+                  fill (i*szb) 0 x >> go (i+1)              | otherwise = return ()      in go 0    where sza = sizeofArray a ; szb = sizeofArray b@@ -481,20 +661,36 @@   many a | sizeofArray a == 0 = pure []          | otherwise = die "many" "infinite arrays are not well defined" +data ArrayStack a+  = PushArray !(Array a) !(ArrayStack a)+  | EmptyStack+-- See the note in SmallArray about how we might improve this.+ instance Monad Array where   return = pure   (>>) = (*>)-  a >>= f = push 0 [] (sizeofArray a - 1)++  ary >>= f = collect 0 EmptyStack (la-1)    where-   push !sz bs i-     | i < 0 = build sz bs-     | otherwise = let b = f $ indexArray a i-                    in push (sz + sizeofArray b) (b:bs) (i+1)+   la = sizeofArray ary+   collect sz stk i+     | i < 0 = createArray sz (die ">>=" "impossible") $ fill 0 stk+     | (# x #) <- indexArray## ary i+     , let sb = f x+           lsb = sizeofArray sb+       -- If we don't perform this check, we could end up allocating+       -- a stack full of empty arrays if someone is filtering most+       -- things out. So we refrain from pushing empty arrays.+     = if lsb == 0+       then collect sz stk (i - 1)+       else collect (sz + lsb) (PushArray sb stk) (i-1) -   build sz stk = createArray sz (die ">>=" "impossible") $ \mb ->-     let go off (b:bs) = copyArray mb off b 0 (sizeofArray b) >> go (off + sizeofArray b) bs-         go _   [    ] = return ()-      in go 0 stk+   fill _   EmptyStack         _   = return ()+   fill off (PushArray sb sbs) smb+     | let lsb = sizeofArray sb+     = copyArray smb off sb 0 (lsb)+         *> fill (off + lsb) sbs smb+   fail _ = empty  instance MonadPlus Array where@@ -503,10 +699,13 @@  zipW :: String -> (a -> b -> c) -> Array a -> Array b -> Array c zipW s f aa ab = createArray mn (die s "impossible") $ \mc ->-  let go i-        | i < mn    = writeArray mc i (f (indexArray aa i) (indexArray ab i))-                   >> go (i+1)-        | otherwise = return ()+  let go i | i < mn+           = do+               x <- indexArrayM aa i+               y <- indexArrayM ab i+               writeArray mc i (f x y)+               go (i+1)+           | otherwise = return ()    in go 0  where mn = sizeofArray aa `min` sizeofArray ab {-# INLINE zipW #-}@@ -520,7 +719,7 @@     ma <- newArray sz (die "munzip" "impossible")     mb <- newArray sz (die "munzip" "impossible")     let go i | i < sz = do-          let (a, b) = indexArray aab i+          (a, b) <- indexArrayM aab i           writeArray ma i a           writeArray mb i b           go (i+1)@@ -530,9 +729,17 @@ #endif  instance MonadFix Array where-  mfix f = let l = mfix (toList . f) in fromListN (length l) l+  mfix f = createArray (sizeofArray (f err))+                       (die "mfix" "impossible") $ flip fix 0 $+    \r !i !mary -> when (i < sz) $ do+                      writeArray mary i (fix (\xi -> f xi `indexArray` i))+                      r (i + 1) mary+    where+      sz = sizeofArray (f err)+      err = error "mfix for Data.Primitive.Array applied to strict function."  #if MIN_VERSION_base(4,9,0)+-- | @since 0.6.3.0 instance Semigroup (Array a) where   (<>) = (<|>)   sconcat = mconcat . F.toList@@ -550,19 +757,50 @@      in go 0 l    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)++-- this need to be included for older ghcs+listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS+listLiftShowsPrec _ sl _ = sl+ instance Show a => Show (Array a) where-  showsPrec p a = showParen (p > 10) $-    showString "fromListN " . shows (sizeofArray a) . showString " "-      . shows (toList a)+  showsPrec p a = arrayLiftShowsPrec showsPrec showList p a +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+-- | @since 0.6.4.0+instance Show1 Array where+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)+  liftShowsPrec = arrayLiftShowsPrec+#else+  showsPrec1 = arrayLiftShowsPrec showsPrec showList+#endif+#endif++arrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Array a)+arrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do+  () <$ string "fromListN"+  skipSpaces+  n <- readS_to_P reads+  skipSpaces+  l <- readS_to_P listReadsPrec+  return $ arrayFromListN n l+ instance Read a => Read (Array a) where-  readsPrec p = readParen (p > 10) . readP_to_S $ do-    () <$ string "fromListN"-    skipSpaces-    n <- readS_to_P reads-    skipSpaces-    l <- readS_to_P reads-    return $ fromListN n l+  readsPrec = arrayLiftReadsPrec readsPrec readList++#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+-- | @since 0.6.4.0+instance Read1 Array where+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)+  liftReadsPrec = arrayLiftReadsPrec+#else+  readsPrec1 = arrayLiftReadsPrec readsPrec readList+#endif+#endif+  arrayDataType :: DataType arrayDataType = mkDataType "Data.Primitive.Array.Array" [fromListConstr]

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, MagicHash, UnboxedTuples, UnliftedFFITypes, DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, UnliftedFFITypes, DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -19,10 +19,14 @@    -- * Allocation   newByteArray, newPinnedByteArray, newAlignedPinnedByteArray,+  resizeMutableByteArray,    -- * Element access   readByteArray, writeByteArray, indexByteArray, +  -- * Constructing+  byteArrayFromList, byteArrayFromListN,+   -- * Folding   foldrByteArray, @@ -30,17 +34,25 @@   unsafeFreezeByteArray, unsafeThawByteArray,    -- * Block operations-  copyByteArray, copyMutableByteArray, moveByteArray,+  copyByteArray, copyMutableByteArray,+#if __GLASGOW_HASKELL__ >= 708+  copyByteArrayToAddr, copyMutableByteArrayToAddr,+#endif+  moveByteArray,   setByteArray, fillByteArray,    -- * Information-  sizeofByteArray, sizeofMutableByteArray, sameMutableByteArray,+  sizeofByteArray,+  sizeofMutableByteArray, getSizeofMutableByteArray, sameMutableByteArray,+#if __GLASGOW_HASKELL__ >= 802+  isByteArrayPinned, isMutableByteArrayPinned,+#endif   byteArrayContents, mutableByteArrayContents+ ) where  import Control.Monad.Primitive import Control.Monad.ST-import Control.Monad ( zipWithM_ ) import Data.Primitive.Types  import Foreign.C.Types@@ -58,8 +70,26 @@ import Data.Data ( Data(..) ) import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType ) import Numeric-import System.IO.Unsafe +#if MIN_VERSION_base(4,9,0)+import qualified Data.Semigroup as SG+import qualified Data.Foldable as F+#endif++#if !(MIN_VERSION_base(4,8,0))+import Data.Monoid (Monoid(..))+#endif++#if __GLASGOW_HASKELL__ >= 802+import GHC.Exts as Exts (isByteArrayPinned#,isMutableByteArrayPinned#)+#endif++#if __GLASGOW_HASKELL__ >= 804+import GHC.Exts (compareByteArrays#)+#else+import System.IO.Unsafe (unsafeDupablePerformIO)+#endif+ -- | Byte arrays data ByteArray = ByteArray ByteArray# deriving ( Typeable ) @@ -83,9 +113,12 @@                         (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #))  -- | Create a /pinned/ byte array of the specified size in bytes and with the--- give alignment. The garbage collector is guaranteed not to move it.+-- given alignment. The garbage collector is guaranteed not to move it. newAlignedPinnedByteArray-  :: PrimMonad m => Int -> Int -> m (MutableByteArray (PrimState m))+  :: PrimMonad m+  => Int  -- ^ size+  -> Int  -- ^ alignment+  -> m (MutableByteArray (PrimState m)) {-# INLINE newAlignedPinnedByteArray #-} newAlignedPinnedByteArray (I# n#) (I# k#)   = primitive (\s# -> case newAlignedPinnedByteArray# n# k# s# of@@ -112,6 +145,47 @@ sameMutableByteArray (MutableByteArray arr#) (MutableByteArray brr#)   = isTrue# (sameMutableByteArray# arr# brr#) +-- | Resize a mutable byte array. The new size is given in bytes.+--+-- This will either resize the array in-place or, if not possible, allocate the+-- contents into a new, unpinned array and copy the original array's contents.+--+-- To avoid undefined behaviour, the original 'MutableByteArray' shall not be+-- accessed anymore after a 'resizeMutableByteArray' has been performed.+-- Moreover, no reference to the old one should be kept in order to allow+-- garbage collection of the original 'MutableByteArray' in case a new+-- 'MutableByteArray' had to be allocated.+--+-- @since 0.6.4.0+resizeMutableByteArray+  :: PrimMonad m => MutableByteArray (PrimState m) -> Int+                 -> m (MutableByteArray (PrimState m))+{-# INLINE resizeMutableByteArray #-}+#if __GLASGOW_HASKELL__ >= 710+resizeMutableByteArray (MutableByteArray arr#) (I# n#)+  = primitive (\s# -> case resizeMutableByteArray# arr# n# s# of+                        (# s'#, arr'# #) -> (# s'#, MutableByteArray arr'# #))+#else+resizeMutableByteArray arr n+  = do arr' <- newByteArray n+       copyMutableByteArray arr' 0 arr 0 (min (sizeofMutableByteArray arr) n)+       return arr'+#endif++-- | Get the size of a byte array in bytes. Unlike 'sizeofMutableByteArray',+-- this function ensures sequencing in the presence of resizing.+getSizeofMutableByteArray+  :: PrimMonad m => MutableByteArray (PrimState m) -> m Int+{-# INLINE getSizeofMutableByteArray #-}+#if __GLASGOW_HASKELL__ >= 801+getSizeofMutableByteArray (MutableByteArray arr#)+  = primitive (\s# -> case getSizeofMutableByteArray# arr# s# of+                        (# s'#, n# #) -> (# s'#, I# n# #))+#else+getSizeofMutableByteArray arr+  = return (sizeofMutableByteArray arr)+#endif+ -- | Convert a mutable byte array to an immutable one without copying. The -- array should not be modified after the conversion. unsafeFreezeByteArray@@ -134,11 +208,35 @@ {-# INLINE sizeofByteArray #-} sizeofByteArray (ByteArray arr#) = I# (sizeofByteArray# arr#) --- | Size of the mutable byte array in bytes.+-- | Size of the mutable byte array in bytes. This function\'s behavior +-- is undefined if 'resizeMutableByteArray' is ever called on the mutable+-- byte array given as the argument. Consequently, use of this function+-- is discouraged. Prefer 'getSizeofMutableByteArray', which ensures correct+-- sequencing in the presence of resizing. sizeofMutableByteArray :: MutableByteArray s -> Int {-# INLINE sizeofMutableByteArray #-} sizeofMutableByteArray (MutableByteArray arr#) = I# (sizeofMutableByteArray# arr#) +#if __GLASGOW_HASKELL__ >= 802+-- | Check whether or not the byte array is pinned. Pinned byte arrays cannot+--   be moved by the garbage collector. It is safe to use 'byteArrayContents'+--   on such byte arrays. This function is only available when compiling with+--   GHC 8.2 or newer.+--+--   @since 0.6.4.0+isByteArrayPinned :: ByteArray -> Bool+{-# INLINE isByteArrayPinned #-}+isByteArrayPinned (ByteArray arr#) = isTrue# (Exts.isByteArrayPinned# arr#)++-- | Check whether or not the mutable byte array is pinned. This function is+--   only available when compiling with GHC 8.2 or newer.+--+--   @since 0.6.4.0+isMutableByteArrayPinned :: MutableByteArray s -> Bool+{-# INLINE isMutableByteArrayPinned #-}+isMutableByteArrayPinned (MutableByteArray marr#) = isTrue# (Exts.isMutableByteArrayPinned# marr#)+#endif+ -- | Read a primitive value from the byte array. The offset is given in -- elements of type @a@ rather than in bytes. indexByteArray :: Prim a => ByteArray -> Int -> a@@ -168,18 +266,27 @@     go i       | sizeofByteArray arr > i * sz = f (indexByteArray arr i) (go (i+1))       | otherwise                    = z-    sz = sizeofByteArray arr+    sz = sizeOf (undefined :: a) -fromListN :: Prim a => Int -> [a] -> ByteArray-fromListN n xs = runST $ do-    marr <- newByteArray (n * sizeOf (head xs))-    zipWithM_ (writeByteArray marr) [0..n] xs+byteArrayFromList :: Prim a => [a] -> ByteArray+byteArrayFromList xs = byteArrayFromListN (length xs) xs++byteArrayFromListN :: Prim a => Int -> [a] -> ByteArray+byteArrayFromListN n ys = runST $ do+    marr <- newByteArray (n * sizeOf (head ys))+    let go !ix [] = if ix == n+          then return ()+          else die "byteArrayFromListN" "list length less than specified size"+        go !ix (x : xs) = if ix < n+          then do+            writeByteArray marr ix x+            go (ix + 1) xs+          else die "byteArrayFromListN" "list length greater than specified size"+    go 0 ys     unsafeFreezeByteArray marr -#if __GLASGOW_HASKELL__ >= 702 unI# :: Int -> Int# unI# (I# n#) = n#-#endif  -- | Copy a slice of an immutable byte array to a mutable byte array. copyByteArray@@ -192,13 +299,7 @@                  -> m () {-# INLINE copyByteArray #-} copyByteArray (MutableByteArray dst#) doff (ByteArray src#) soff sz-#if __GLASGOW_HASKELL__ >= 702   = primitive_ (copyByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz))-#else-  = unsafePrimToPrim-  $ memcpy_ba dst# (fromIntegral doff) src# (fromIntegral soff)-                 (fromIntegral sz)-#endif  -- | Copy a slice of a mutable byte array into another array. The two slices -- may not overlap.@@ -214,12 +315,40 @@ {-# INLINE copyMutableByteArray #-} copyMutableByteArray (MutableByteArray dst#) doff                      (MutableByteArray src#) soff sz-#if __GLASGOW_HASKELL__ >= 702   = primitive_ (copyMutableByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz))-#else-  = unsafePrimToPrim-  $ memcpy_mba dst# (fromIntegral doff) src# (fromIntegral soff)-                    (fromIntegral sz)++#if __GLASGOW_HASKELL__ >= 708+-- | Copy a slice of a byte array to an unmanaged address. These must not+--   overlap. This function is only available when compiling with GHC 7.8+--   or newer.+--+--   @since 0.6.4.0+copyByteArrayToAddr+  :: PrimMonad m+  => Addr -- ^ destination+  -> ByteArray -- ^ source array+  -> Int -- ^ offset into source array+  -> Int -- ^ number of bytes to copy+  -> m ()+{-# INLINE copyByteArrayToAddr #-}+copyByteArrayToAddr (Addr dst#) (ByteArray src#) soff sz+  = primitive_ (copyByteArrayToAddr# src# (unI# soff) dst# (unI# sz))++-- | Copy a slice of a mutable byte array to an unmanaged address. These must+--   not overlap. This function is only available when compiling with GHC 7.8+--   or newer.+--+--   @since 0.6.4.0+copyMutableByteArrayToAddr+  :: PrimMonad m+  => Addr -- ^ destination+  -> MutableByteArray (PrimState m) -- ^ source array+  -> Int -- ^ offset into source array+  -> Int -- ^ number of bytes to copy+  -> m ()+{-# INLINE copyMutableByteArrayToAddr #-}+copyMutableByteArrayToAddr (Addr dst#) (MutableByteArray src#) soff sz+  = primitive_ (copyMutableByteArrayToAddr# src# (unI# soff) dst# (unI# sz)) #endif  -- | Copy a slice of a mutable byte array into another, potentially@@ -263,18 +392,6 @@ {-# INLINE fillByteArray #-} fillByteArray = setByteArray -#if __GLASGOW_HASKELL__ < 702-foreign import ccall unsafe "primitive-memops.h hsprimitive_memcpy"-  memcpy_mba :: MutableByteArray# s -> CInt-             -> MutableByteArray# s -> CInt-             -> CSize -> IO ()--foreign import ccall unsafe "primitive-memops.h hsprimitive_memcpy"-  memcpy_ba :: MutableByteArray# s -> CInt-            -> ByteArray# -> CInt-            -> CSize -> IO ()-#endif- foreign import ccall unsafe "primitive-memops.h hsprimitive_memmove"   memmove_mba :: MutableByteArray# s -> CInt               -> MutableByteArray# s -> CInt@@ -290,6 +407,7 @@   gunfold _ _ = error "gunfold"   dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.MutableByteArray" +-- | @since 0.6.3.0 instance Show ByteArray where   showsPrec _ ba =       showString "[" . go 0@@ -301,9 +419,25 @@           comma | i == 0    = id                 | otherwise = showString ", " ++compareByteArrays :: ByteArray -> ByteArray -> Int -> Ordering+{-# INLINE compareByteArrays #-}+#if __GLASGOW_HASKELL__ >= 804+compareByteArrays (ByteArray ba1#) (ByteArray ba2#) (I# n#) =+  compare (I# (compareByteArrays# ba1# 0# ba2# 0# n#)) 0+#else+-- Emulate GHC 8.4's 'GHC.Prim.compareByteArrays#'+compareByteArrays (ByteArray ba1#) (ByteArray ba2#) (I# n#)+    = compare (fromCInt (unsafeDupablePerformIO (memcmp_ba ba1# ba2# n))) 0+  where+    n = fromIntegral (I# n#) :: CSize+    fromCInt = fromIntegral :: CInt -> Int+ foreign import ccall unsafe "primitive-memops.h hsprimitive_memcmp"   memcmp_ba :: ByteArray# -> ByteArray# -> CSize -> IO CInt+#endif + sameByteArray :: ByteArray# -> ByteArray# -> Bool sameByteArray ba1 ba2 =     case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of@@ -314,33 +448,102 @@       0# -> False #endif +-- | @since 0.6.3.0 instance Eq ByteArray where   ba1@(ByteArray ba1#) == ba2@(ByteArray ba2#)-    | sameByteArray ba1# ba2#                    = True-    | sizeofByteArray ba1 /= sizeofByteArray ba2 = False-    | otherwise =-        case unsafeDupablePerformIO $ memcmp_ba ba1# ba2# (fromIntegral $ sizeofByteArray ba1) of-          0 -> True-          _ -> False+    | sameByteArray ba1# ba2# = True+    | n1 /= n2 = False+    | otherwise = compareByteArrays ba1 ba2 n1 == EQ+    where+      n1 = sizeofByteArray ba1+      n2 = sizeofByteArray ba2 +-- | Non-lexicographic ordering. This compares the lengths of+-- the byte arrays first and uses a lexicographic ordering if+-- the lengths are equal. Subject to change between major versions.+-- +-- @since 0.6.3.0 instance Ord ByteArray where   ba1@(ByteArray ba1#) `compare` ba2@(ByteArray ba2#)     | sameByteArray ba1# ba2# = EQ-    | n1 /= n2                = n1 `compare` n2-    | otherwise =-        case unsafeDupablePerformIO $ memcmp_ba ba1# ba2# (fromIntegral n1) of-          x | x >  0 -> GT-            | x == 0 -> EQ-            | otherwise -> LT+    | n1 /= n2 = n1 `compare` n2+    | otherwise = compareByteArrays ba1 ba2 n1     where       n1 = sizeofByteArray ba1       n2 = sizeofByteArray ba2+-- Note: On GHC 8.4, the primop compareByteArrays# performs a check for pointer+-- equality as a shortcut, so the check here is actually redundant. However, it+-- is included here because it is likely better to check for pointer equality+-- before checking for length equality. Getting the length requires deferencing+-- the pointers, which could cause accesses to memory that is not in the cache.+-- By contrast, a pointer equality check is always extremely cheap. +appendByteArray :: ByteArray -> ByteArray -> ByteArray+appendByteArray a b = runST $ do+  marr <- newByteArray (sizeofByteArray a + sizeofByteArray b)+  copyByteArray marr 0 a 0 (sizeofByteArray a)+  copyByteArray marr (sizeofByteArray a) b 0 (sizeofByteArray b)+  unsafeFreezeByteArray marr++concatByteArray :: [ByteArray] -> ByteArray+concatByteArray arrs = runST $ do+  let len = calcLength arrs 0+  marr <- newByteArray len+  pasteByteArrays marr 0 arrs+  unsafeFreezeByteArray marr++pasteByteArrays :: MutableByteArray s -> Int -> [ByteArray] -> ST s ()+pasteByteArrays !_ !_ [] = return ()+pasteByteArrays !marr !ix (x : xs) = do+  copyByteArray marr ix x 0 (sizeofByteArray x)+  pasteByteArrays marr (ix + sizeofByteArray x) xs++calcLength :: [ByteArray] -> Int -> Int+calcLength [] !n = n+calcLength (x : xs) !n = calcLength xs (sizeofByteArray x + n)++emptyByteArray :: ByteArray+emptyByteArray = runST (newByteArray 0 >>= unsafeFreezeByteArray)++replicateByteArray :: Int -> ByteArray -> ByteArray+replicateByteArray n arr = runST $ do+  marr <- newByteArray (n * sizeofByteArray arr)+  let go i = if i < n+        then do+          copyByteArray marr (i * sizeofByteArray arr) arr 0 (sizeofByteArray arr)+          go (i + 1)+        else return ()+  go 0+  unsafeFreezeByteArray marr++#if MIN_VERSION_base(4,9,0)+instance SG.Semigroup ByteArray where+  (<>) = appendByteArray+  sconcat = mconcat . F.toList+  stimes i arr+    | itgr < 1 = emptyByteArray+    | itgr <= (fromIntegral (maxBound :: Int)) = replicateByteArray (fromIntegral itgr) arr+    | otherwise = error "Data.Primitive.ByteArray#stimes: cannot allocate the requested amount of memory"+    where itgr = toInteger i :: Integer+#endif++instance Monoid ByteArray where+  mempty = emptyByteArray+#if !(MIN_VERSION_base(4,11,0))+  mappend = appendByteArray+#endif+  mconcat = concatByteArray+ #if __GLASGOW_HASKELL__ >= 708+-- | @since 0.6.3.0 instance Exts.IsList ByteArray where   type Item ByteArray = Word8    toList = foldrByteArray (:) []-  fromList xs = fromListN (length xs) xs-  fromListN = fromListN+  fromList xs = byteArrayFromListN (length xs) xs+  fromListN = byteArrayFromListN #endif++die :: String -> String -> a+die fun problem = error $ "Data.Primitive.ByteArray." ++ fun ++ ": " ++ problem+

@@ -0,0 +1,155 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++-- |+-- Module      : Data.Primitive.MVar+-- License     : BSD2+-- Portability : non-portable+--+-- Primitive operations on @MVar@. This module provides a similar interface+-- to "Control.Concurrent.MVar". However, the functions are generalized to+-- work in any 'PrimMonad' instead of only working in 'IO'. Note that all+-- of the functions here are completely deterministic. Users of 'MVar' are+-- responsible for designing abstractions that guarantee determinism in+-- the presence of multi-threading.+--+-- @since 0.6.4.0+module Data.Primitive.MVar+  ( MVar(..)+  , newMVar+  , isEmptyMVar+  , newEmptyMVar+  , putMVar+  , readMVar+  , takeMVar+  , tryPutMVar+  , tryReadMVar+  , tryTakeMVar+  ) where++import Control.Monad.Primitive+import Data.Primitive.Internal.Compat (isTrue#)+import GHC.Exts (MVar#,newMVar#,takeMVar#,sameMVar#,putMVar#,tryTakeMVar#,+  isEmptyMVar#,tryPutMVar#,(/=#))++#if __GLASGOW_HASKELL__ >= 708+import GHC.Exts (readMVar#,tryReadMVar#)+#endif++data MVar s a = MVar (MVar# s a)++instance Eq (MVar s a) where+  MVar mvar1# == MVar mvar2# = isTrue# (sameMVar# mvar1# mvar2#)++-- | Create a new 'MVar' that is initially empty.+newEmptyMVar :: PrimMonad m => m (MVar (PrimState m) a)+newEmptyMVar = primitive $ \ s# ->+  case newMVar# s# of+    (# s2#, svar# #) -> (# s2#, MVar svar# #)+++-- | Create a new 'MVar' that holds the supplied argument.+newMVar :: PrimMonad m => a -> m (MVar (PrimState m) a)+newMVar value =+  newEmptyMVar >>= \ mvar ->+  putMVar mvar value >>+  return mvar++-- | Return the contents of the 'MVar'.  If the 'MVar' is currently+-- empty, 'takeMVar' will wait until it is full.  After a 'takeMVar',+-- the 'MVar' is left empty.+takeMVar :: PrimMonad m => MVar (PrimState m) a -> m a+takeMVar (MVar mvar#) = primitive $ \ s# -> takeMVar# mvar# s#++-- | Atomically read the contents of an 'MVar'.  If the 'MVar' is+-- currently empty, 'readMVar' will wait until it is full.+-- 'readMVar' is guaranteed to receive the next 'putMVar'.+--+-- /Multiple Wakeup:/ 'readMVar' is multiple-wakeup, so when multiple readers+-- are blocked on an 'MVar', all of them are woken up at the same time.+--+-- /Compatibility note:/ On GHCs prior to 7.8, 'readMVar' is a combination+-- of 'takeMVar' and 'putMVar'. Consequently, its behavior differs in the+-- following ways:+--+-- * It is single-wakeup instead of multiple-wakeup.+-- * It might not receive the value from the next call to 'putMVar' if+--   there is already a pending thread blocked on 'takeMVar'.+-- * If another thread puts a value in the 'MVar' in between the+--   calls to 'takeMVar' and 'putMVar', that value may be overridden.+readMVar :: PrimMonad m => MVar (PrimState m) a -> m a+#if __GLASGOW_HASKELL__ >= 708+readMVar (MVar mvar#) = primitive $ \ s# -> readMVar# mvar# s#+#else+readMVar mv = do+  a <- takeMVar mv+  putMVar mv a+  return a+#endif++-- |Put a value into an 'MVar'.  If the 'MVar' is currently full,+-- 'putMVar' will wait until it becomes empty.+putMVar :: PrimMonad m => MVar (PrimState m) a -> a -> m ()+putMVar (MVar mvar#) x = primitive_ (putMVar# mvar# x)++-- |A non-blocking version of 'takeMVar'.  The 'tryTakeMVar' function+-- returns immediately, with 'Nothing' if the 'MVar' was empty, or+-- @'Just' a@ if the 'MVar' was full with contents @a@.  After 'tryTakeMVar',+-- the 'MVar' is left empty.+tryTakeMVar :: PrimMonad m => MVar (PrimState m) a -> m (Maybe a)+tryTakeMVar (MVar m) = primitive $ \ s ->+  case tryTakeMVar# m s of+    (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty+    (# s', _,  a #) -> (# s', Just a  #) -- MVar is full+++-- |A non-blocking version of 'putMVar'.  The 'tryPutMVar' function+-- attempts to put the value @a@ into the 'MVar', returning 'True' if+-- it was successful, or 'False' otherwise.+tryPutMVar :: PrimMonad m => MVar (PrimState m) a -> a -> m Bool+tryPutMVar (MVar mvar#) x = primitive $ \ s# ->+    case tryPutMVar# mvar# x s# of+        (# s, 0# #) -> (# s, False #)+        (# s, _  #) -> (# s, True #)++-- | A non-blocking version of 'readMVar'.  The 'tryReadMVar' function+-- returns immediately, with 'Nothing' if the 'MVar' was empty, or+-- @'Just' a@ if the 'MVar' was full with contents @a@.+--+-- /Compatibility note:/ On GHCs prior to 7.8, 'tryReadMVar' is a combination+-- of 'tryTakeMVar' and 'putMVar'. Consequently, its behavior differs in the+-- following ways:+--+-- * It is single-wakeup instead of multiple-wakeup.+-- * In the presence of other threads calling 'putMVar', 'tryReadMVar'+--   may block.+-- * If another thread puts a value in the 'MVar' in between the+--   calls to 'tryTakeMVar' and 'putMVar', that value may be overridden.+tryReadMVar :: PrimMonad m => MVar (PrimState m) a -> m (Maybe a)+#if __GLASGOW_HASKELL__ >= 708+tryReadMVar (MVar m) = primitive $ \ s ->+    case tryReadMVar# m s of+        (# s', 0#, _ #) -> (# s', Nothing #)      -- MVar is empty+        (# s', _,  a #) -> (# s', Just a  #)      -- MVar is full+#else+tryReadMVar mv = do+  ma <- tryTakeMVar mv+  case ma of+    Just a -> do+      putMVar mv a+      return (Just a)+    Nothing -> return Nothing+#endif++-- | Check whether a given 'MVar' is empty.+--+-- Notice that the boolean value returned  is just a snapshot of+-- the state of the MVar. By the time you get to react on its result,+-- the MVar may have been filled (or emptied) - so be extremely+-- careful when using this operation.   Use 'tryTakeMVar' instead if possible.+isEmptyMVar :: PrimMonad m => MVar (PrimState m) a -> m Bool+isEmptyMVar (MVar mv#) = primitive $ \ s# ->+  case isEmptyMVar# mv# s# of+    (# s2#, flg #) -> (# s2#, isTrue# (flg /=# 0#) #)

@@ -0,0 +1,969 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}++{-# OPTIONS_GHC -Wall #-}++-- |+-- Module      : Data.Primitive.PrimArray+-- Copyright   : (c) Roman Leshchinskiy 2009-2012+-- License     : BSD-style+--+-- Maintainer  : Roman Leshchinskiy <rl@cse.unsw.edu.au>+-- Portability : non-portable+--+-- Arrays of unboxed primitive types. The function provided by this module+-- match the behavior of those provided by @Data.Primitive.ByteArray@, and+-- the underlying types and primops that back them are the same.+-- However, the type constructors 'PrimArray' and 'MutablePrimArray' take one additional+-- argument than their respective counterparts 'ByteArray' and 'MutableByteArray'.+-- This argument is used to designate the type of element in the array.+-- Consequently, all function this modules accepts length and incides in+-- terms of elements, not bytes.+--+-- @since 0.6.4.0+module Data.Primitive.PrimArray+  ( -- * Types+    PrimArray(..)+  , MutablePrimArray(..)+    -- * Allocation+  , newPrimArray+  , resizeMutablePrimArray+#if __GLASGOW_HASKELL__ >= 710+  , shrinkMutablePrimArray+#endif+    -- * Element Access+  , readPrimArray+  , writePrimArray+  , indexPrimArray+    -- * Freezing and Thawing+  , unsafeFreezePrimArray+  , unsafeThawPrimArray+    -- * Block Operations+  , copyPrimArray+  , copyMutablePrimArray+#if __GLASGOW_HASKELL__ >= 708+  , copyPrimArrayToPtr+  , copyMutablePrimArrayToPtr+#endif+  , setPrimArray+    -- * Information+  , sameMutablePrimArray+  , getSizeofMutablePrimArray+  , sizeofMutablePrimArray+  , sizeofPrimArray+    -- * List Conversion+  , primArrayToList+  , primArrayFromList+  , primArrayFromListN+    -- * Folding+  , foldrPrimArray+  , foldrPrimArray'+  , foldlPrimArray+  , foldlPrimArray'+  , foldlPrimArrayM'+    -- * Effectful Folding+  , traversePrimArray_+  , itraversePrimArray_+    -- * Map/Create+  , mapPrimArray+  , imapPrimArray+  , generatePrimArray+  , replicatePrimArray+  , filterPrimArray+  , mapMaybePrimArray+    -- * Effectful Map/Create+    -- $effectfulMapCreate+    -- ** Lazy Applicative+  , traversePrimArray+  , itraversePrimArray+  , generatePrimArrayA+  , replicatePrimArrayA+  , filterPrimArrayA+  , mapMaybePrimArrayA+    -- ** Strict Primitive Monadic+  , traversePrimArrayP+  , itraversePrimArrayP+  , generatePrimArrayP+  , replicatePrimArrayP+  , filterPrimArrayP+  , mapMaybePrimArrayP+  ) where++import GHC.Prim+import GHC.Base ( Int(..) )+import GHC.Exts (build)+import GHC.Ptr+import Data.Primitive.Internal.Compat (isTrue#)+import Data.Primitive.Types+import Data.Primitive.ByteArray (ByteArray(..))+import Data.Monoid (Monoid(..),(<>))+import Control.Applicative+import Control.Monad.Primitive+import Control.Monad.ST+import qualified Data.List as L+import qualified Data.Primitive.ByteArray as PB+import qualified Data.Primitive.Types as PT++#if MIN_VERSION_base(4,7,0)+import GHC.Exts (IsList(..))+#endif++#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (Semigroup)+import qualified Data.Semigroup as SG+#endif++-- | Arrays of unboxed elements. This accepts types like 'Double', 'Char',+-- 'Int', and 'Word', as well as their fixed-length variants ('Word8',+-- 'Word16', etc.). Since the elements are unboxed, a 'PrimArray' is strict+-- in its elements. This differs from the behavior of 'Array', which is lazy+-- in its elements.+data PrimArray a = PrimArray ByteArray#++-- | Mutable primitive arrays associated with a primitive state token.+-- These can be written to and read from in a monadic context that supports+-- sequencing such as 'IO' or 'ST'. Typically, a mutable primitive array will+-- be built and then convert to an immutable primitive array using+-- 'unsafeFreezePrimArray'. However, it is also acceptable to simply discard+-- a mutable primitive array since it lives in managed memory and will be+-- garbage collected when no longer referenced.+data MutablePrimArray s a = MutablePrimArray (MutableByteArray# s)++sameByteArray :: ByteArray# -> ByteArray# -> Bool+sameByteArray ba1 ba2 =+    case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of+#if __GLASGOW_HASKELL__ >= 708+      r -> isTrue# r+#else+      1# -> True+      _ -> False+#endif++-- | @since 0.6.4.0+instance (Eq a, Prim a) => Eq (PrimArray a) where+  a1@(PrimArray ba1#) == a2@(PrimArray ba2#)+    | sameByteArray ba1# ba2# = True+    | sz1 /= sz2 = False+    | otherwise = loop (quot sz1 (sizeOf (undefined :: 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+    -- calculate the size in elements.+    sz1 = PB.sizeofByteArray (ByteArray ba1#)+    sz2 = PB.sizeofByteArray (ByteArray ba2#)+    loop !i+      | i < 0 = True+      | otherwise = indexPrimArray a1 i == indexPrimArray a2 i && loop (i-1)++-- | Lexicographic ordering. Subject to change between major versions.+-- +--   @since 0.6.4.0+instance (Ord a, Prim a) => Ord (PrimArray a) where+  compare a1@(PrimArray ba1#) a2@(PrimArray ba2#)+    | sameByteArray ba1# ba2# = EQ+    | otherwise = loop 0+    where+    sz1 = PB.sizeofByteArray (ByteArray ba1#)+    sz2 = PB.sizeofByteArray (ByteArray ba2#)+    sz = quot (min sz1 sz2) (sizeOf (undefined :: a))+    loop !i+      | i < sz = compare (indexPrimArray a1 i) (indexPrimArray a2 i) <> loop (i+1)+      | otherwise = compare sz1 sz2++#if MIN_VERSION_base(4,7,0)+-- | @since 0.6.4.0+instance Prim a => IsList (PrimArray a) where+  type Item (PrimArray a) = a+  fromList = primArrayFromList+  fromListN = primArrayFromListN+  toList = primArrayToList+#endif++-- | @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)++die :: String -> String -> a+die fun problem = error $ "Data.Primitive.PrimArray." ++ fun ++ ": " ++ problem++primArrayFromList :: Prim a => [a] -> PrimArray a+primArrayFromList vs = primArrayFromListN (L.length vs) vs++primArrayFromListN :: forall a. Prim a => Int -> [a] -> PrimArray a+primArrayFromListN len vs = runST run where+  run :: forall s. ST s (PrimArray a)+  run = do+    arr <- newPrimArray len+    let go :: [a] -> Int -> ST s ()+        go [] !ix = if ix == len+          then return ()+          else die "fromListN" "list length less than specified size"+        go (a : as) !ix = if ix < len+          then do+            writePrimArray arr ix a+            go as (ix + 1)+          else die "fromListN" "list length greater than specified size"+    go vs 0+    unsafeFreezePrimArray arr++-- | Convert the primitive array to a list.+{-# INLINE primArrayToList #-}+primArrayToList :: forall a. Prim a => PrimArray a -> [a]+primArrayToList xs = build (\c n -> foldrPrimArray c n xs)++primArrayToByteArray :: PrimArray a -> PB.ByteArray+primArrayToByteArray (PrimArray x) = PB.ByteArray x++byteArrayToPrimArray :: ByteArray -> PrimArray a+byteArrayToPrimArray (PB.ByteArray x) = PrimArray x++#if MIN_VERSION_base(4,9,0)+-- | @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))+#endif++-- | @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))+#endif+  mconcat = byteArrayToPrimArray . mconcat . map primArrayToByteArray++-- | The empty primitive array.+emptyPrimArray :: PrimArray a+{-# NOINLINE emptyPrimArray #-}+emptyPrimArray = runST $ primitive $ \s0# -> case newByteArray# 0# s0# of+  (# s1#, arr# #) -> case unsafeFreezeByteArray# arr# s1# of+    (# s2#, arr'# #) -> (# s2#, PrimArray arr'# #)++-- | Create a new mutable primitive array of the given length. The+-- underlying memory is left uninitialized.+newPrimArray :: forall m a. (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a)+{-# INLINE newPrimArray #-}+newPrimArray (I# n#)+  = primitive (\s# -> +      case newByteArray# (n# *# sizeOf# (undefined :: a)) s# of+        (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #)+    )++-- | Resize a mutable primitive array. The new size is given in elements.+--+-- This will either resize the array in-place or, if not possible, allocate the+-- contents into a new, unpinned array and copy the original array\'s contents.+--+-- To avoid undefined behaviour, the original 'MutablePrimArray' shall not be+-- accessed anymore after a 'resizeMutablePrimArray' has been performed.+-- Moreover, no reference to the old one should be kept in order to allow+-- garbage collection of the original 'MutablePrimArray' in case a new+-- 'MutablePrimArray' had to be allocated.+resizeMutablePrimArray :: forall m a. (PrimMonad m, Prim a)+  => MutablePrimArray (PrimState m) a+  -> Int -- ^ new size+  -> m (MutablePrimArray (PrimState m) a)+{-# INLINE resizeMutablePrimArray #-}+#if __GLASGOW_HASKELL__ >= 710+resizeMutablePrimArray (MutablePrimArray arr#) (I# n#)+  = primitive (\s# -> case resizeMutableByteArray# arr# (n# *# sizeOf# (undefined :: a)) s# of+                        (# s'#, arr'# #) -> (# s'#, MutablePrimArray arr'# #))+#else+resizeMutablePrimArray arr n+  = do arr' <- newPrimArray n+       copyMutablePrimArray arr' 0 arr 0 (min (sizeofMutablePrimArray arr) n)+       return arr'+#endif++-- Although it is possible to shim resizeMutableByteArray for old GHCs, this+-- is not the case with shrinkMutablePrimArray.+#if __GLASGOW_HASKELL__ >= 710+-- | Shrink a mutable primitive array. The new size is given in elements.+-- It must be smaller than the old size. The array will be resized in place.+-- This function is only available when compiling with GHC 7.10 or newer.+shrinkMutablePrimArray :: forall m a. (PrimMonad m, Prim a)+  => MutablePrimArray (PrimState m) a+  -> Int -- ^ new size+  -> m ()+{-# INLINE shrinkMutablePrimArray #-}+shrinkMutablePrimArray (MutablePrimArray arr#) (I# n#)+  = primitive_ (shrinkMutableByteArray# arr# (n# *# sizeOf# (undefined :: a)))+#endif++readPrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> m a+{-# INLINE readPrimArray #-}+readPrimArray (MutablePrimArray arr#) (I# i#)+  = primitive (readByteArray# arr# i#)++-- | Write an element to the given index.+writePrimArray ::+     (Prim a, PrimMonad m)+  => MutablePrimArray (PrimState m) a -- ^ array+  -> Int -- ^ index+  -> a -- ^ element+  -> m ()+{-# INLINE writePrimArray #-}+writePrimArray (MutablePrimArray arr#) (I# i#) x+  = primitive_ (writeByteArray# arr# i# x)++-- | Copy part of a mutable array into another mutable array.+--   In the case that the destination and+--   source arrays are the same, the regions may overlap.+copyMutablePrimArray :: forall m a.+     (PrimMonad m, Prim a)+  => MutablePrimArray (PrimState m) a -- ^ destination array+  -> Int -- ^ offset into destination array+  -> MutablePrimArray (PrimState m) a -- ^ source array+  -> Int -- ^ offset into source array+  -> Int -- ^ number of elements to copy+  -> m ()+{-# INLINE copyMutablePrimArray #-}+copyMutablePrimArray (MutablePrimArray dst#) (I# doff#) (MutablePrimArray src#) (I# soff#) (I# n#)+  = primitive_ (copyMutableByteArray#+      src# +      (soff# *# (sizeOf# (undefined :: a)))+      dst#+      (doff# *# (sizeOf# (undefined :: a)))+      (n# *# (sizeOf# (undefined :: a)))+    )++-- | Copy part of an array into another mutable array.+copyPrimArray :: forall m a.+     (PrimMonad m, Prim a)+  => MutablePrimArray (PrimState m) a -- ^ destination array+  -> Int -- ^ offset into destination array+  -> PrimArray a -- ^ source array+  -> Int -- ^ offset into source array+  -> Int -- ^ number of elements to copy+  -> m ()+{-# INLINE copyPrimArray #-}+copyPrimArray (MutablePrimArray dst#) (I# doff#) (PrimArray src#) (I# soff#) (I# n#)+  = primitive_ (copyByteArray#+      src# +      (soff# *# (sizeOf# (undefined :: a)))+      dst#+      (doff# *# (sizeOf# (undefined :: a)))+      (n# *# (sizeOf# (undefined :: a)))+    )++#if __GLASGOW_HASKELL__ >= 708+-- | Copy a slice of an immutable primitive array to an address.+--   The offset and length are given in elements of type @a@.+--   This function assumes that the 'Prim' instance of @a@+--   agrees with the 'Storable' instance. This function is only+--   available when building with GHC 7.8 or newer.+copyPrimArrayToPtr :: forall m a. (PrimMonad m, Prim a)+  => Ptr a -- ^ destination pointer+  -> PrimArray a -- ^ source array+  -> Int -- ^ offset into source array+  -> Int -- ^ number of prims to copy+  -> m ()+{-# INLINE copyPrimArrayToPtr #-}+copyPrimArrayToPtr (Ptr addr#) (PrimArray ba#) (I# soff#) (I# n#) =+    primitive (\ s# ->+        let s'# = copyByteArrayToAddr# ba# (soff# *# siz#) addr# (n# *# siz#) s#+        in (# s'#, () #))+  where siz# = sizeOf# (undefined :: a)++-- | Copy a slice of an immutable primitive array to an address.+--   The offset and length are given in elements of type @a@.+--   This function assumes that the 'Prim' instance of @a@+--   agrees with the 'Storable' instance. This function is only+--   available when building with GHC 7.8 or newer.+copyMutablePrimArrayToPtr :: forall m a. (PrimMonad m, Prim a)+  => Ptr a -- ^ destination pointer+  -> MutablePrimArray (PrimState m) a -- ^ source array+  -> Int -- ^ offset into source array+  -> Int -- ^ number of prims to copy+  -> m ()+{-# INLINE copyMutablePrimArrayToPtr #-}+copyMutablePrimArrayToPtr (Ptr addr#) (MutablePrimArray mba#) (I# soff#) (I# n#) =+    primitive (\ s# ->+        let s'# = copyMutableByteArrayToAddr# mba# (soff# *# siz#) addr# (n# *# siz#) s#+        in (# s'#, () #))+  where siz# = sizeOf# (undefined :: a)+#endif++-- | Fill a slice of a mutable primitive array with a value.+setPrimArray+  :: (Prim a, PrimMonad m)+  => MutablePrimArray (PrimState m) a -- ^ array to fill+  -> Int -- ^ offset into array+  -> Int -- ^ number of values to fill+  -> a -- ^ value to fill with+  -> m ()+{-# INLINE setPrimArray #-}+setPrimArray (MutablePrimArray dst#) (I# doff#) (I# sz#) x+  = primitive_ (PT.setByteArray# dst# doff# sz# x)++-- | Get the size of a mutable primitive array in elements. Unlike 'sizeofMutablePrimArray',+-- this function ensures sequencing in the presence of resizing.+getSizeofMutablePrimArray :: forall m a. (PrimMonad m, Prim a)+  => MutablePrimArray (PrimState m) a -- ^ array+  -> m Int+{-# INLINE getSizeofMutablePrimArray #-}+#if __GLASGOW_HASKELL__ >= 801+getSizeofMutablePrimArray (MutablePrimArray arr#)+  = primitive (\s# -> +      case getSizeofMutableByteArray# arr# s# of+        (# s'#, sz# #) -> (# s'#, I# (quotInt# sz# (sizeOf# (undefined :: a))) #)+    )+#else+-- On older GHCs, it is not possible to resize a byte array, so+-- this provides behavior consistent with the implementation for+-- newer GHCs.+getSizeofMutablePrimArray arr+  = return (sizeofMutablePrimArray arr)+#endif++-- | 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'.+sizeofMutablePrimArray :: forall s a. Prim a => MutablePrimArray s a -> Int+{-# INLINE sizeofMutablePrimArray #-}+sizeofMutablePrimArray (MutablePrimArray arr#) =+  I# (quotInt# (sizeofMutableByteArray# arr#) (sizeOf# (undefined :: a)))++-- | Check if the two arrays refer to the same memory block.+sameMutablePrimArray :: MutablePrimArray s a -> MutablePrimArray s a -> Bool+{-# INLINE sameMutablePrimArray #-}+sameMutablePrimArray (MutablePrimArray arr#) (MutablePrimArray brr#)+  = isTrue# (sameMutableByteArray# arr# brr#)++-- | Convert a mutable byte array to an immutable one without copying. The+-- array should not be modified after the conversion.+unsafeFreezePrimArray+  :: PrimMonad m => MutablePrimArray (PrimState m) a -> m (PrimArray a)+{-# INLINE unsafeFreezePrimArray #-}+unsafeFreezePrimArray (MutablePrimArray arr#)+  = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of+                        (# s'#, arr'# #) -> (# s'#, PrimArray arr'# #))++-- | Convert an immutable array to a mutable one without copying. The+-- original array should not be used after the conversion.+unsafeThawPrimArray+  :: PrimMonad m => PrimArray a -> m (MutablePrimArray (PrimState m) a)+{-# INLINE unsafeThawPrimArray #-}+unsafeThawPrimArray (PrimArray arr#)+  = primitive (\s# -> (# s#, MutablePrimArray (unsafeCoerce# arr#) #))++-- | Read a primitive value from the primitive array.+indexPrimArray :: forall a. Prim a => PrimArray a -> Int -> a+{-# INLINE indexPrimArray #-}+indexPrimArray (PrimArray arr#) (I# i#) = indexByteArray# arr# i#++-- | 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)))++-- | Lazy right-associated fold over the elements of a 'PrimArray'.+{-# INLINE foldrPrimArray #-}+foldrPrimArray :: forall a b. Prim a => (a -> b -> b) -> b -> PrimArray a -> b+foldrPrimArray f z arr = go 0+  where+    !sz = sizeofPrimArray arr+    go !i+      | sz > i = f (indexPrimArray arr i) (go (i+1))+      | otherwise = z++-- | Strict right-associated fold over the elements of a 'PrimArray'.+{-# INLINE foldrPrimArray' #-}+foldrPrimArray' :: forall a b. Prim a => (a -> b -> b) -> b -> PrimArray a -> b+foldrPrimArray' f z0 arr = go (sizeofPrimArray arr - 1) z0+  where+    go !i !acc+      | i < 0 = acc+      | otherwise = go (i - 1) (f (indexPrimArray arr i) acc)++-- | Lazy left-associated fold over the elements of a 'PrimArray'.+{-# INLINE foldlPrimArray #-}+foldlPrimArray :: forall a b. Prim a => (b -> a -> b) -> b -> PrimArray a -> b+foldlPrimArray f z arr = go (sizeofPrimArray arr - 1)+  where+    go !i+      | i < 0 = z+      | otherwise = f (go (i - 1)) (indexPrimArray arr i)++-- | Strict left-associated fold over the elements of a 'PrimArray'.+{-# INLINE foldlPrimArray' #-}+foldlPrimArray' :: forall a b. Prim a => (b -> a -> b) -> b -> PrimArray a -> b+foldlPrimArray' f z0 arr = go 0 z0+  where+    !sz = sizeofPrimArray arr+    go !i !acc+      | i < sz = go (i + 1) (f acc (indexPrimArray arr i))+      | otherwise = acc++-- | Strict left-associated fold over the elements of a 'PrimArray'.+{-# INLINE foldlPrimArrayM' #-}+foldlPrimArrayM' :: (Prim a, Monad m) => (b -> a -> m b) -> b -> PrimArray a -> m b+foldlPrimArrayM' f z0 arr = go 0 z0+  where+    !sz = sizeofPrimArray arr+    go !i !acc1+      | i < sz = do+          acc2 <- f acc1 (indexPrimArray arr i)+          go (i + 1) acc2+      | otherwise = return acc1++-- | Traverse a primitive array. The traversal forces the resulting values and+-- writes them to the new primitive array as it performs the monadic effects.+-- Consequently:+--+-- >>> traversePrimArrayP (\x -> print x $> bool x undefined (x == 2)) (fromList [1, 2, 3 :: Int])+-- 1+-- 2+-- *** Exception: Prelude.undefined+--+-- In many situations, 'traversePrimArrayP' can replace 'traversePrimArray',+-- changing the strictness characteristics of the traversal but typically improving+-- the performance. Consider the following short-circuiting traversal:+--+-- > incrPositiveA :: PrimArray Int -> Maybe (PrimArray Int)+-- > incrPositiveA xs = traversePrimArray (\x -> bool Nothing (Just (x + 1)) (x > 0)) xs+--+-- This can be rewritten using 'traversePrimArrayP'. To do this, we must+-- change the traversal context to @MaybeT (ST s)@, which has a 'PrimMonad'+-- instance:+--+-- > incrPositiveB :: PrimArray Int -> Maybe (PrimArray Int)+-- > incrPositiveB xs = runST $ runMaybeT $ traversePrimArrayP+-- >   (\x -> bool (MaybeT (return Nothing)) (MaybeT (return (Just (x + 1)))) (x > 0))+-- >   xs+-- +-- Benchmarks demonstrate that the second implementation runs 150 times+-- faster than the first. It also results in fewer allocations.+{-# INLINE traversePrimArrayP #-}+traversePrimArrayP :: (PrimMonad m, Prim a, Prim b)+  => (a -> m b)+  -> PrimArray a+  -> m (PrimArray b)+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 ()+  go 0+  unsafeFreezePrimArray marr++-- | Filter the primitive array, keeping the elements for which the monadic+-- predicate evaluates true.+{-# INLINE filterPrimArrayP #-}+filterPrimArrayP :: (PrimMonad m, Prim a)+  => (a -> m Bool)+  -> PrimArray a+  -> m (PrimArray a)+filterPrimArrayP f arr = do+  let !sz = sizeofPrimArray arr+  marr <- newPrimArray sz+  let go !ixSrc !ixDst = if ixSrc < sz+        then do+          let a = indexPrimArray arr ixSrc+          b <- f a+          if b+            then do+              writePrimArray marr ixDst a+              go (ixSrc + 1) (ixDst + 1)+            else go (ixSrc + 1) ixDst+        else return ixDst+  lenDst <- go 0 0+  marr' <- resizeMutablePrimArray marr lenDst+  unsafeFreezePrimArray marr'++-- | Map over the primitive array, keeping the elements for which the monadic+-- predicate provides a 'Just'.+{-# INLINE mapMaybePrimArrayP #-}+mapMaybePrimArrayP :: (PrimMonad m, Prim a, Prim b)+  => (a -> m (Maybe b))+  -> PrimArray a+  -> m (PrimArray b)+mapMaybePrimArrayP f arr = do+  let !sz = sizeofPrimArray arr+  marr <- newPrimArray sz+  let go !ixSrc !ixDst = if ixSrc < sz+        then do+          let a = indexPrimArray arr ixSrc+          mb <- f a+          case mb of+            Just b -> do+              writePrimArray marr ixDst b+              go (ixSrc + 1) (ixDst + 1)+            Nothing -> go (ixSrc + 1) ixDst+        else return ixDst+  lenDst <- go 0 0+  marr' <- resizeMutablePrimArray marr lenDst+  unsafeFreezePrimArray marr'++-- | Generate a primitive array by evaluating the monadic generator function+-- at each index.+{-# INLINE generatePrimArrayP #-}+generatePrimArrayP :: (PrimMonad m, Prim a)+  => Int -- ^ length+  -> (Int -> m a) -- ^ generator+  -> 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 ()+  go 0+  unsafeFreezePrimArray marr++-- | Execute the monadic action the given number of times and store the+-- results in a primitive array.+{-# INLINE replicatePrimArrayP #-}+replicatePrimArrayP :: (PrimMonad m, Prim a)+  => Int+  -> m a+  -> 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 ()+  go 0+  unsafeFreezePrimArray marr+++-- | Map over the elements of a primitive array.+{-# INLINE mapPrimArray #-}+mapPrimArray :: (Prim a, Prim b)+  => (a -> b)+  -> PrimArray a+  -> PrimArray b+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 ()+  go 0+  unsafeFreezePrimArray marr++-- | Indexed map over the elements of a primitive array.+{-# INLINE imapPrimArray #-}+imapPrimArray :: (Prim a, Prim b)+  => (Int -> a -> b)+  -> PrimArray a+  -> PrimArray b+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 ()+  go 0+  unsafeFreezePrimArray marr++-- | Filter elements of a primitive array according to a predicate.+{-# INLINE filterPrimArray #-}+filterPrimArray :: Prim a+  => (a -> Bool)+  -> PrimArray a+  -> PrimArray a+filterPrimArray p arr = runST $ do+  let !sz = sizeofPrimArray arr+  marr <- newPrimArray sz+  let go !ixSrc !ixDst = if ixSrc < sz+        then do+          let !a = indexPrimArray arr ixSrc+          if p a+            then do+              writePrimArray marr ixDst a+              go (ixSrc + 1) (ixDst + 1)+            else go (ixSrc + 1) ixDst+        else return ixDst+  dstLen <- go 0 0+  marr' <- resizeMutablePrimArray marr dstLen+  unsafeFreezePrimArray marr'++-- | Filter the primitive array, keeping the elements for which the monadic+-- predicate evaluates true.+filterPrimArrayA ::+     (Applicative f, Prim a)+  => (a -> f Bool) -- ^ mapping function+  -> PrimArray a -- ^ primitive array+  -> f (PrimArray a)+filterPrimArrayA f = \ !ary ->+  let+    !len = sizeofPrimArray ary+    go !ixSrc+      | ixSrc == len = pure $ IxSTA $ \ixDst _ -> return ixDst+      | otherwise = let x = indexPrimArray ary ixSrc in+          liftA2+            (\keep (IxSTA m) -> IxSTA $ \ixDst mary -> if keep+              then writePrimArray (MutablePrimArray mary) ixDst x >> m (ixDst + 1) mary+              else m ixDst mary+            )+            (f x)+            (go (ixSrc + 1))+  in if len == 0+     then pure emptyPrimArray+     else runIxSTA len <$> go 0++-- | Map over the primitive array, keeping the elements for which the applicative+-- predicate provides a 'Just'.+mapMaybePrimArrayA ::+     (Applicative f, Prim a, Prim b)+  => (a -> f (Maybe b)) -- ^ mapping function+  -> PrimArray a -- ^ primitive array+  -> f (PrimArray b)+mapMaybePrimArrayA f = \ !ary ->+  let+    !len = sizeofPrimArray ary+    go !ixSrc+      | ixSrc == len = pure $ IxSTA $ \ixDst _ -> return ixDst+      | otherwise = let x = indexPrimArray ary ixSrc in+          liftA2+            (\mb (IxSTA m) -> IxSTA $ \ixDst mary -> case mb of+              Just b -> writePrimArray (MutablePrimArray mary) ixDst b >> m (ixDst + 1) mary+              Nothing -> m ixDst mary+            )+            (f x)+            (go (ixSrc + 1))+  in if len == 0+     then pure emptyPrimArray+     else runIxSTA len <$> go 0++-- | Map over a primitive array, optionally discarding some elements. This+--   has the same behavior as @Data.Maybe.mapMaybe@.+{-# INLINE mapMaybePrimArray #-}+mapMaybePrimArray :: (Prim a, Prim b)+  => (a -> Maybe b)+  -> PrimArray a+  -> PrimArray b+mapMaybePrimArray p arr = runST $ do+  let !sz = sizeofPrimArray arr+  marr <- newPrimArray sz+  let go !ixSrc !ixDst = if ixSrc < sz+        then do+          let !a = indexPrimArray arr ixSrc+          case p a of+            Just b -> do+              writePrimArray marr ixDst b+              go (ixSrc + 1) (ixDst + 1)+            Nothing -> go (ixSrc + 1) ixDst+        else return ixDst+  dstLen <- go 0 0+  marr' <- resizeMutablePrimArray marr dstLen+  unsafeFreezePrimArray marr'+++-- | Traverse a primitive array. The traversal performs all of the applicative+-- effects /before/ forcing the resulting values and writing them to the new+-- primitive array. Consequently:+--+-- >>> traversePrimArray (\x -> print x $> bool x undefined (x == 2)) (fromList [1, 2, 3 :: Int])+-- 1+-- 2+-- 3+-- *** Exception: Prelude.undefined+--+-- The function 'traversePrimArrayP' always outperforms this function, but it+-- requires a 'PrimAffineMonad' constraint, and it forces the values as+-- it performs the effects.+traversePrimArray ::+     (Applicative f, Prim a, Prim b)+  => (a -> f b) -- ^ mapping function+  -> PrimArray a -- ^ primitive array+  -> f (PrimArray b)+traversePrimArray f = \ !ary ->+  let+    !len = sizeofPrimArray ary+    go !i+      | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary)+      | x <- indexPrimArray ary i+      = liftA2 (\b (STA m) -> STA $ \mary ->+                  writePrimArray (MutablePrimArray mary) i b >> m mary)+               (f x) (go (i + 1))+  in if len == 0+     then pure emptyPrimArray+     else runSTA len <$> go 0++-- | Traverse a primitive array with the index of each element.+itraversePrimArray ::+     (Applicative f, Prim a, Prim b)+  => (Int -> a -> f b)+  -> PrimArray a+  -> f (PrimArray b)+itraversePrimArray f = \ !ary ->+  let+    !len = sizeofPrimArray ary+    go !i+      | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary)+      | x <- indexPrimArray ary i+      = liftA2 (\b (STA m) -> STA $ \mary ->+                  writePrimArray (MutablePrimArray mary) i b >> m mary)+               (f i x) (go (i + 1))+  in if len == 0+     then pure emptyPrimArray+     else runSTA len <$> go 0++-- | Traverse a primitive array with the indices. The traversal forces the+-- resulting values and writes them to the new primitive array as it performs+-- the monadic effects.+{-# INLINE itraversePrimArrayP #-}+itraversePrimArrayP :: (Prim a, Prim b, PrimMonad m)+  => (Int -> a -> m b)+  -> PrimArray a+  -> m (PrimArray b)+itraversePrimArrayP f arr = do+  let !sz = sizeofPrimArray arr+  marr <- newPrimArray sz+  let go !ix+        | ix < sz = do+            writePrimArray marr ix =<< f ix (indexPrimArray arr ix)+            go (ix + 1)+        | otherwise = return ()+  go 0+  unsafeFreezePrimArray marr++-- | Generate a primitive array.+{-# INLINE generatePrimArray #-}+generatePrimArray :: Prim a+  => Int -- ^ length+  -> (Int -> a) -- ^ element from index+  -> 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 ()+  go 0+  unsafeFreezePrimArray marr++-- | Create a primitive array by copying the element the given+-- number of times.+{-# INLINE replicatePrimArray #-}+replicatePrimArray :: Prim a+  => Int -- ^ length+  -> a -- ^ element+  -> PrimArray a+replicatePrimArray len a = runST $ do+  marr <- newPrimArray len+  setPrimArray marr 0 len a+  unsafeFreezePrimArray marr++-- | Generate a primitive array by evaluating the applicative generator+-- function at each index.+{-# INLINE generatePrimArrayA #-}+generatePrimArrayA ::+     (Applicative f, Prim a)+  => Int -- ^ length+  -> (Int -> f a) -- ^ element from index+  -> f (PrimArray a)+generatePrimArrayA len f =+  let+    go !i+      | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary)+      | otherwise+      = liftA2 (\b (STA m) -> STA $ \mary ->+                  writePrimArray (MutablePrimArray mary) i b >> m mary)+               (f i) (go (i + 1))+  in if len == 0+     then pure emptyPrimArray+     else runSTA len <$> go 0++-- | Execute the applicative action the given number of times and store the+-- results in a vector.+{-# INLINE replicatePrimArrayA #-}+replicatePrimArrayA ::+     (Applicative f, Prim a)+  => Int -- ^ length+  -> f a -- ^ applicative element producer+  -> f (PrimArray a)+replicatePrimArrayA len f =+  let+    go !i+      | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary)+      | otherwise+      = liftA2 (\b (STA m) -> STA $ \mary ->+                  writePrimArray (MutablePrimArray mary) i b >> m mary)+               f (go (i + 1))+  in if len == 0+     then pure emptyPrimArray+     else runSTA len <$> go 0++-- | Traverse the primitive array, discarding the results. There+-- is no 'PrimMonad' variant of this function since it would not provide+-- any performance benefit.+traversePrimArray_ ::+     (Applicative f, Prim a)+  => (a -> f b)+  -> PrimArray a+  -> 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 ()++-- | Traverse the primitive array with the indices, discarding the results.+-- There is no 'PrimMonad' variant of this function since it would not+-- provide any performance benefit.+itraversePrimArray_ ::+     (Applicative f, Prim a)+  => (Int -> a -> f b)+  -> PrimArray a+  -> 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 ()++newtype IxSTA a = IxSTA {_runIxSTA :: forall s. Int -> MutableByteArray# s -> ST s Int}++runIxSTA :: forall a. Prim a+  => Int -- maximum possible size+  -> IxSTA a+  -> PrimArray a+runIxSTA !szUpper = \ (IxSTA m) -> runST $ do+  ar :: MutablePrimArray s a <- newPrimArray szUpper+  sz <- m 0 (unMutablePrimArray ar)+  ar' <- resizeMutablePrimArray ar sz+  unsafeFreezePrimArray ar'+{-# INLINE runIxSTA #-}++newtype STA a = STA {_runSTA :: forall s. MutableByteArray# s -> ST s (PrimArray a)}++runSTA :: forall a. Prim a => Int -> STA a -> PrimArray a+runSTA !sz = \ (STA m) -> runST $ newPrimArray sz >>= \ (ar :: MutablePrimArray s a) -> m (unMutablePrimArray ar)+{-# INLINE runSTA #-}++unMutablePrimArray :: MutablePrimArray s a -> MutableByteArray# s+unMutablePrimArray (MutablePrimArray m) = m++{- $effectfulMapCreate+The naming conventions adopted in this section are explained in the+documentation of the @Data.Primitive@ module.+-}++

@@ -0,0 +1,125 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      : Data.Primitive.Ptr+-- Copyright   : (c) Roman Leshchinskiy 2009-2012+-- License     : BSD-style+--+-- Maintainer  : Roman Leshchinskiy <rl@cse.unsw.edu.au>+-- Portability : non-portable+--+-- Primitive operations on machine addresses+--+-- @since 0.6.4.0++module Data.Primitive.Ptr (+  -- * Types+  Ptr(..),++  -- * Address arithmetic+  nullPtr, advancePtr, subtractPtr,++  -- * Element access+  indexOffPtr, readOffPtr, writeOffPtr,++  -- * Block operations+  copyPtr, movePtr, setPtr++#if __GLASGOW_HASKELL__ >= 708+  , copyPtrToMutablePrimArray+#endif+) where++import Control.Monad.Primitive+import Data.Primitive.Types+#if __GLASGOW_HASKELL__ >= 708+import Data.Primitive.PrimArray (MutablePrimArray(..))+#endif++import GHC.Base ( Int(..) )+import GHC.Prim++import GHC.Ptr+import Foreign.Marshal.Utils+++-- | 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)))++-- | 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)))++-- | 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+-- elements of type @a@ rather than in bytes.+indexOffPtr :: Prim a => Ptr a -> Int -> a+{-# INLINE indexOffPtr #-}+indexOffPtr (Ptr addr#) (I# i#) = indexOffAddr# addr# i#++-- | Read a value from a memory position given by an address and an offset.+-- The offset is in elements of type @a@ rather than in bytes.+readOffPtr :: (Prim a, PrimMonad m) => Ptr a -> Int -> m a+{-# INLINE readOffPtr #-}+readOffPtr (Ptr addr#) (I# i#) = primitive (readOffAddr# addr# i#)++-- | Write a value to a memory position given by an address and an offset.+-- The offset is in elements of type @a@ rather than in bytes.+writeOffPtr :: (Prim a, PrimMonad m) => Ptr a -> Int -> a -> m ()+{-# INLINE writeOffPtr #-}+writeOffPtr (Ptr addr#) (I# i#) x = primitive_ (writeOffAddr# addr# i# x)++-- | Copy the given number of elements from the second 'Ptr' to the first. The+-- areas may not overlap.+copyPtr :: forall m a. (PrimMonad m, Prim a)+  => Ptr a -- ^ destination pointer+  -> Ptr a -- ^ source pointer+  -> Int -- ^ number of elements+  -> m ()+{-# INLINE copyPtr #-}+copyPtr (Ptr dst#) (Ptr src#) n+  = unsafePrimToPrim $ copyBytes (Ptr dst#) (Ptr src#) (n * sizeOf (undefined :: a))++-- | Copy the given number of elements from the second 'Ptr' to the first. The+-- areas may overlap.+movePtr :: forall m a. (PrimMonad m, Prim a)+  => Ptr a -- ^ destination address+  -> Ptr a -- ^ source address+  -> Int -- ^ number of elements+  -> m ()+{-# INLINE movePtr #-}+movePtr (Ptr dst#) (Ptr src#) n+  = unsafePrimToPrim $ moveBytes (Ptr dst#) (Ptr src#) (n * sizeOf (undefined :: a))++-- | Fill a memory block with the given value. The length is in+-- elements of type @a@ rather than in bytes.+setPtr :: (Prim a, PrimMonad m) => Ptr a -> Int -> a -> m ()+{-# INLINE setPtr #-}+setPtr (Ptr addr#) (I# n#) x = primitive_ (setOffAddr# addr# 0# n# x)+++#if __GLASGOW_HASKELL__ >= 708+-- | Copy from a pointer to a mutable primitive array.+-- The offset and length are given in elements of type @a@.+-- This function is only available when building with GHC 7.8+-- or newer.+copyPtrToMutablePrimArray :: forall m a. (PrimMonad m, Prim a)+  => MutablePrimArray (PrimState m) a -- ^ destination array+  -> Int -- ^ destination offset+  -> Ptr a -- ^ source pointer+  -> Int -- ^ number of elements+  -> m ()+{-# INLINE copyPtrToMutablePrimArray #-}+copyPtrToMutablePrimArray (MutablePrimArray ba#) (I# doff#) (Ptr addr#) (I# n#) = +  primitive_ (copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#))+  where+  siz# = sizeOf# (undefined :: a)+#endif

@@ -6,6 +6,7 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns #-}  -- | -- Module : Data.Primitive.SmallArray@@ -45,14 +46,20 @@   , copySmallMutableArray   , indexSmallArray   , indexSmallArrayM+  , indexSmallArray##   , cloneSmallArray   , cloneSmallMutableArray   , freezeSmallArray   , unsafeFreezeSmallArray   , thawSmallArray+  , runSmallArray   , unsafeThawSmallArray   , sizeofSmallArray   , sizeofSmallMutableArray+  , smallArrayFromList+  , smallArrayFromListN+  , mapSmallArray'+  , traverseSmallArrayP   ) where  @@ -70,25 +77,34 @@ import Control.Monad.Fix import Control.Monad.Primitive import Control.Monad.ST-#if MIN_VERSION_base(4,4,0) import Control.Monad.Zip-#endif import Data.Data-import Data.Foldable+import Data.Foldable as Foldable import Data.Functor.Identity+#if !(MIN_VERSION_base(4,10,0)) import Data.Monoid+#endif #if MIN_VERSION_base(4,9,0)+import qualified GHC.ST as GHCST import qualified Data.Semigroup as Sem #endif-import Text.ParserCombinators.ReadPrec-import Text.Read-import Text.Read.Lex+import Text.ParserCombinators.ReadP+#if MIN_VERSION_base(4,10,0)+import GHC.Exts (runRW#)+#elif MIN_VERSION_base(4,9,0)+import GHC.Base (runRW#)+#endif  #if !(HAVE_SMALL_ARRAY) import Data.Primitive.Array import Data.Traversable+import qualified Data.Primitive.Array as Array #endif +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..))+#endif+ #if HAVE_SMALL_ARRAY data SmallArray a = SmallArray (SmallArray# a)   deriving Typeable@@ -105,12 +121,16 @@   , Alternative   , Monad   , MonadPlus-#if MIN_VERSION_base(4,4,0)   , MonadZip-#endif   , MonadFix   , Monoid   , Typeable+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+  , Eq1+  , Ord1+  , Show1+  , Read1+#endif   )  #if MIN_VERSION_base(4,7,0)@@ -118,7 +138,7 @@   type Item (SmallArray a) = a   fromListN n l = SmallArray (fromListN n l)   fromList l = SmallArray (fromList l)-  toList (SmallArray a) = toList a+  toList a = Foldable.toList a #endif #endif @@ -223,6 +243,17 @@ #endif {-# INLINE indexSmallArray #-} +-- | Read a value from the immutable array at the given index, returning+-- the result in an unboxed unary tuple. This is currently used to implement+-- folds.+indexSmallArray## :: SmallArray a -> Int -> (# a #)+#if HAVE_SMALL_ARRAY+indexSmallArray## (SmallArray ary) (I# i) = indexSmallArray# ary i+#else+indexSmallArray## (SmallArray a) = indexArray## a+#endif+{-# INLINE indexSmallArray## #-}+ -- | Create a copy of a slice of an immutable array. cloneSmallArray   :: SmallArray a -- ^ source@@ -378,7 +409,106 @@ #endif {-# INLINE sizeofSmallMutableArray #-} +-- | This is the fastest, most straightforward way to traverse+-- an array, but it only works correctly with a sufficiently+-- "affine" 'PrimMonad' instance. In particular, it must only produce+-- *one* result array. 'Control.Monad.Trans.List.ListT'-transformed+-- monads, for example, will not work right at all.+traverseSmallArrayP+  :: PrimMonad m+  => (a -> m b)+  -> SmallArray a+  -> m (SmallArray b) #if HAVE_SMALL_ARRAY+traverseSmallArrayP f = \ !ary ->+  let+    !sz = sizeofSmallArray ary+    go !i !mary+      | i == sz+      = unsafeFreezeSmallArray mary+      | otherwise+      = do+          a <- indexSmallArrayM ary i+          b <- f a+          writeSmallArray mary i b+          go (i + 1) mary+  in do+    mary <- newSmallArray sz badTraverseValue+    go 0 mary+#else+traverseSmallArrayP f (SmallArray ar) = SmallArray `liftM` traverseArrayP f ar+#endif+{-# INLINE traverseSmallArrayP #-}++-- | Strict map over the elements of the array.+mapSmallArray' :: (a -> b) -> SmallArray a -> SmallArray b+#if HAVE_SMALL_ARRAY+mapSmallArray' f sa = createSmallArray (length sa) (die "mapSmallArray'" "impossible") $ \smb ->+  fix ? 0 $ \go i ->+    when (i < length sa) $ do+      x <- indexSmallArrayM sa i+      let !y = f x+      writeSmallArray smb i y *> go (i+1)+#else+mapSmallArray' f (SmallArray ar) = SmallArray (mapArray' f ar)+#endif+{-# INLINE mapSmallArray' #-}++#ifndef HAVE_SMALL_ARRAY+runSmallArray+  :: (forall s. ST s (SmallMutableArray s a))+  -> SmallArray a+runSmallArray m = SmallArray $ runArray $+  m >>= \(SmallMutableArray mary) -> return mary++#elif !MIN_VERSION_base(4,9,0)+runSmallArray+  :: (forall s. ST s (SmallMutableArray s a))+  -> SmallArray a+runSmallArray m = runST $ m >>= unsafeFreezeSmallArray++#else+-- This low-level business is designed to work with GHC's worker-wrapper+-- transformation. A lot of the time, we don't actually need an Array+-- constructor. By putting it on the outside, and being careful about+-- how we special-case the empty array, we can make GHC smarter about this.+-- The only downside is that separately created 0-length arrays won't share+-- their Array constructors, although they'll share their underlying+-- Array#s.+runSmallArray+  :: (forall s. ST s (SmallMutableArray s a))+  -> SmallArray a+runSmallArray m = SmallArray (runSmallArray# m)++runSmallArray#+  :: (forall s. ST s (SmallMutableArray s a))+  -> SmallArray# a+runSmallArray# m = case runRW# $ \s ->+  case unST m s of { (# s', SmallMutableArray mary# #) ->+  unsafeFreezeSmallArray# mary# s'} of (# _, ary# #) -> ary#++unST :: ST s a -> State# s -> (# State# s, a #)+unST (GHCST.ST f) = f++#endif++#if HAVE_SMALL_ARRAY+-- See the comment on runSmallArray for why we use emptySmallArray#.+createSmallArray+  :: Int+  -> a+  -> (forall s. SmallMutableArray s a -> ST s ())+  -> SmallArray a+createSmallArray 0 _ _ = SmallArray (emptySmallArray# (# #))+createSmallArray n x f = runSmallArray $ do+  mary <- newSmallArray n x+  f mary+  pure mary++emptySmallArray# :: (# #) -> SmallArray# a+emptySmallArray# _ = case emptySmallArray of SmallArray ar -> ar+{-# NOINLINE emptySmallArray# #-}+ die :: String -> String -> a die fun problem = error $ "Data.Primitive.SmallArray." ++ fun ++ ": " ++ problem @@ -388,12 +518,6 @@             >>= unsafeFreezeSmallArray {-# NOINLINE emptySmallArray #-} -createSmallArray-  :: Int -> a -> (forall s. SmallMutableArray s a -> ST s ()) -> SmallArray a-createSmallArray 0 _ _ = emptySmallArray-createSmallArray i x k =-  runST $ newSmallArray i x >>= \sa -> k sa *> unsafeFreezeSmallArray sa-{-# INLINE createSmallArray #-}  infixl 1 ? (?) :: (a -> b -> c) -> (b -> a -> c)@@ -403,82 +527,197 @@ noOp :: a -> ST s () noOp = const $ pure () +smallArrayLiftEq :: (a -> b -> Bool) -> SmallArray a -> SmallArray b -> Bool+smallArrayLiftEq p sa1 sa2 = length sa1 == length sa2 && loop (length sa1 - 1)+  where+  loop i+    | i < 0+    = True+    | (# x #) <- indexSmallArray## sa1 i+    , (# y #) <- indexSmallArray## sa2 i+    = p x y && loop (i-1)++#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+-- | @since 0.6.4.0+instance Eq1 SmallArray where+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)+  liftEq = smallArrayLiftEq+#else+  eq1 = smallArrayLiftEq (==)+#endif+#endif+ instance Eq a => Eq (SmallArray a) where-  sa1 == sa2 = length sa1 == length sa2 && loop (length sa1 - 1)-   where-   loop i-     | i < 0     = True-     | otherwise = indexSmallArray sa1 i == indexSmallArray sa2 i && loop (i-1)+  sa1 == sa2 = smallArrayLiftEq (==) sa1 sa2  instance Eq (SmallMutableArray s a) where   SmallMutableArray sma1# == SmallMutableArray sma2# =     isTrue# (sameSmallMutableArray# sma1# sma2#) +smallArrayLiftCompare :: (a -> b -> Ordering) -> SmallArray a -> SmallArray b -> Ordering+smallArrayLiftCompare elemCompare a1 a2 = loop 0+  where+  mn = length a1 `min` length a2+  loop i+    | i < mn+    , (# x1 #) <- indexSmallArray## a1 i+    , (# x2 #) <- indexSmallArray## a2 i+    = elemCompare x1 x2 `mappend` loop (i+1)+    | otherwise = compare (length a1) (length a2)++#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+-- | @since 0.6.4.0+instance Ord1 SmallArray where+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)+  liftCompare = smallArrayLiftCompare+#else+  compare1 = smallArrayLiftCompare compare+#endif+#endif++-- | Lexicographic ordering. Subject to change between major versions. instance Ord a => Ord (SmallArray a) where-  compare sl sr = fix ? 0 $ \go i ->-    if i < l-      then compare (indexSmallArray sl i) (indexSmallArray sr i) <> go (i+1)-      else compare (length sl) (length sr)-   where l = length sl `min` length sr+  compare sa1 sa2 = smallArrayLiftCompare compare sa1 sa2  instance Foldable SmallArray where-  foldr f z sa = fix ? 0 $ \go i ->-    if i < length sa-      then f (indexSmallArray sa i) (go $ i+1)-      else z+  -- Note: we perform the array lookups eagerly so we won't+  -- create thunks to perform lookups even if GHC can't see+  -- that the folding function is strict.+  foldr f = \z !ary ->+    let+      !sz = sizeofSmallArray ary+      go i+        | i == sz = z+        | (# x #) <- indexSmallArray## ary i+        = f x (go (i+1))+    in go 0   {-# INLINE foldr #-}--  foldr' f z sa = fix ? z ? length sa - 1 $ \go acc i ->-    if i < 0-      then acc-      else go (f (indexSmallArray sa i) acc) (i-1)-  {-# INLINE foldr' #-}--  foldl f z sa = fix ? length sa - 1 $ \go i ->-    if i < 0-      then z-      else f (go $ i-1) $ indexSmallArray sa i+  foldl f = \z !ary ->+    let+      go i+        | i < 0 = z+        | (# x #) <- indexSmallArray## ary i+        = f (go (i-1)) x+    in go (sizeofSmallArray ary - 1)   {-# INLINE foldl #-}--  foldl' f z sa = fix ? z ? 0 $ \go acc i ->-    if i < length sa-      then go (f acc $ indexSmallArray sa i) (i+1)-      else acc-  {-# INLINE foldl' #-}--  foldr1 f sa-    | sz == 0   = die "foldr1" "empty list"-    | otherwise = fix ? 0 $ \go i ->-        if i < sz-1-          then f (indexSmallArray sa i) (go $ i+1)-          else indexSmallArray sa $ sz-1-   where sz = sizeofSmallArray sa+  foldr1 f = \ !ary ->+    let+      !sz = sizeofSmallArray ary - 1+      go i =+        case indexSmallArray## ary i of+          (# x #) | i == sz -> x+                  | otherwise -> f x (go (i+1))+    in if sz < 0+       then die "foldr1" "Empty SmallArray"+       else go 0   {-# INLINE foldr1 #-}--  foldl1 f sa-    | sz == 0   = die "foldl1" "empty list"-    | otherwise = fix ? sz-1 $ \go i ->-        if i < 1-        then indexSmallArray sa 0-        else f (go $ i-1) (indexSmallArray sa i)-   where sz = sizeofSmallArray sa+  foldl1 f = \ !ary ->+    let+      !sz = sizeofSmallArray ary - 1+      go i =+        case indexSmallArray## ary i of+          (# x #) | i == 0 -> x+                  | otherwise -> f (go (i - 1)) x+    in if sz < 0+       then die "foldl1" "Empty SmallArray"+       else go sz   {-# INLINE foldl1 #-}--  null sa = sizeofSmallArray sa == 0+  foldr' f = \z !ary ->+    let+      go i !acc+        | i == -1 = acc+        | (# x #) <- indexSmallArray## ary i+        = go (i-1) (f x acc)+    in go (sizeofSmallArray ary - 1) z+  {-# INLINE foldr' #-}+  foldl' f = \z !ary ->+    let+      !sz = sizeofSmallArray ary+      go i !acc+        | i == sz = acc+        | (# x #) <- indexSmallArray## ary i+        = go (i+1) (f acc x)+    in go 0 z+  {-# INLINE foldl' #-}+  null a = sizeofSmallArray a == 0   {-# INLINE null #-}-   length = sizeofSmallArray   {-# INLINE length #-}+  maximum ary | sz == 0   = die "maximum" "Empty SmallArray"+              | (# frst #) <- indexSmallArray## ary 0+              = go 1 frst+   where+     sz = sizeofSmallArray ary+     go i !e+       | i == sz = e+       | (# x #) <- indexSmallArray## ary i+       = go (i+1) (max e x)+  {-# INLINE maximum #-}+  minimum ary | sz == 0   = die "minimum" "Empty SmallArray"+              | (# frst #) <- indexSmallArray## ary 0+              = go 1 frst+   where sz = sizeofSmallArray ary+         go i !e+           | i == sz = e+           | (# x #) <- indexSmallArray## ary i+           = go (i+1) (min e x)+  {-# INLINE minimum #-}+  sum = foldl' (+) 0+  {-# INLINE sum #-}+  product = foldl' (*) 1+  {-# INLINE product #-} +newtype STA a = STA {_runSTA :: forall s. SmallMutableArray# s a -> ST s (SmallArray a)}++runSTA :: Int -> STA a -> SmallArray a+runSTA !sz = \ (STA m) -> runST $ newSmallArray_ sz >>=+                        \ (SmallMutableArray ar#) -> m ar#+{-# INLINE runSTA #-}++newSmallArray_ :: Int -> ST s (SmallMutableArray s a)+newSmallArray_ !n = newSmallArray n badTraverseValue++badTraverseValue :: a+badTraverseValue = die "traverse" "bad indexing"+{-# NOINLINE badTraverseValue #-}+ instance Traversable SmallArray where-  traverse f sa = fromListN l <$> traverse (f . indexSmallArray sa) [0..l-1]-   where l = length sa+  traverse f = traverseSmallArray f+  {-# INLINE traverse #-} +traverseSmallArray+  :: Applicative f+  => (a -> f b) -> SmallArray a -> f (SmallArray b)+traverseSmallArray f = \ !ary ->+  let+    !len = sizeofSmallArray ary+    go !i+      | i == len+      = pure $ STA $ \mary -> unsafeFreezeSmallArray (SmallMutableArray mary)+      | (# x #) <- indexSmallArray## ary i+      = liftA2 (\b (STA m) -> STA $ \mary ->+                  writeSmallArray (SmallMutableArray mary) i b >> m mary)+               (f x) (go (i + 1))+  in if len == 0+     then pure emptySmallArray+     else runSTA len <$> go 0+{-# INLINE [1] traverseSmallArray #-}++{-# RULES+"traverse/ST" forall (f :: a -> ST s b). traverseSmallArray f = traverseSmallArrayP f+"traverse/IO" forall (f :: a -> IO b). traverseSmallArray f = traverseSmallArrayP f+"traverse/Id" forall (f :: a -> Identity b). traverseSmallArray f =+   (coerce :: (SmallArray a -> SmallArray (Identity b))+           -> SmallArray a -> Identity (SmallArray b)) (fmap f)+ #-}++ instance Functor SmallArray where   fmap f sa = createSmallArray (length sa) (die "fmap" "impossible") $ \smb ->     fix ? 0 $ \go i ->-      when (i < length sa) $-        writeSmallArray smb i (f $ indexSmallArray sa i) *> go (i+1)+      when (i < length sa) $ do+        x <- indexSmallArrayM sa i+        writeSmallArray smb i (f x) *> go (i+1)   {-# INLINE fmap #-}    x <$ sa = createSmallArray (length sa) x noOp@@ -493,26 +732,29 @@    where    la = length sa ; lb = length sb -  sa <* sb = createSmallArray (la*lb) (indexSmallArray sa $ la-1) $ \sma ->-    fix ? 0 $ \outer i -> when (i < la-1) $ do-      let a = indexSmallArray sa i-      fix ? 0 $ \inner j ->-        when (j < lb) $-          writeSmallArray sma (la*i + j) a *> inner (j+1)-      outer $ i+1-   where-   la = length sa ; lb = length sb+  a <* b = createSmallArray (sza*szb) (die "<*" "impossible") $ \ma ->+    let fill off i e = when (i < szb) $+                         writeSmallArray ma (off+i) e >> fill off (i+1) e+        go i = when (i < sza) $ do+                 x <- indexSmallArrayM a i+                 fill (i*szb) 0 x+                 go (i+1)+     in go 0+   where sza = sizeofSmallArray a ; szb = sizeofSmallArray b -  sf <*> sx = createSmallArray (lf*lx) (die "<*>" "impossible") $ \smb ->-    fix ? 0 $ \outer i -> when (i < lf) $ do-      let f = indexSmallArray sf i-      fix ? 0 $ \inner j ->-        when (j < lx) $-          writeSmallArray smb (lf*i + j) (f $ indexSmallArray sx j)-            *> inner (j+1)-      outer $ i+1-   where-   lf = length sf ; lx = length sx+  ab <*> a = createSmallArray (szab*sza) (die "<*>" "impossible") $ \mb ->+    let go1 i = when (i < szab) $+            do+              f <- indexSmallArrayM ab i+              go2 (i*sza) f 0+              go1 (i+1)+        go2 off f j = when (j < sza) $+            do+              x <- indexSmallArrayM a j+              writeSmallArray mb (off + j) (f x)+              go2 off f (j + 1)+    in go1 0+   where szab = sizeofSmallArray ab ; sza = sizeofSmallArray a  instance Alternative SmallArray where   empty = emptySmallArray@@ -528,20 +770,41 @@   some sa | null sa   = emptySmallArray           | otherwise = die "some" "infinite arrays are not well defined" +data ArrayStack a+  = PushArray !(SmallArray a) !(ArrayStack a)+  | EmptyStack+-- TODO: This isn't terribly efficient. It would be better to wrap+-- ArrayStack with a type like+--+-- data NES s a = NES !Int !(SmallMutableArray s a) !(ArrayStack a)+--+-- We'd copy incoming arrays into the mutable array until we would+-- overflow it. Then we'd freeze it, push it on the stack, and continue.+-- Any sufficiently large incoming arrays would go straight on the stack.+-- Such a scheme would make the stack much more compact in the case+-- of many small arrays.+ instance Monad SmallArray where   return = pure   (>>) = (*>) -  sa >>= f = collect 0 [] (la-1)+  sa >>= f = collect 0 EmptyStack (la-1)    where    la = length sa    collect sz stk i      | i < 0 = createSmallArray sz (die ">>=" "impossible") $ fill 0 stk-     | otherwise = let sb = f $ indexSmallArray sa i in-         collect (sz + length sb) (sb:stk) (i-1)+     | (# x #) <- indexSmallArray## sa i+     , let sb = f x+           lsb = length sb+       -- If we don't perform this check, we could end up allocating+       -- a stack full of empty arrays if someone is filtering most+       -- things out. So we refrain from pushing empty arrays.+     = if lsb == 0+       then collect sz stk (i-1)+       else collect (sz + lsb) (PushArray sb stk) (i-1) -   fill _   [      ] _   = return ()-   fill off (sb:sbs) smb =+   fill _ EmptyStack _ = return ()+   fill off (PushArray sb sbs) smb =      copySmallArray smb off sb 0 (length sb)        *> fill (off + length sb) sbs smb @@ -554,9 +817,11 @@ zipW :: String -> (a -> b -> c) -> SmallArray a -> SmallArray b -> SmallArray c zipW nm = \f sa sb -> let mn = length sa `min` length sb in   createSmallArray mn (die nm "impossible") $ \mc ->-    fix ? 0 $ \go i -> when (i < mn) $-      writeSmallArray mc i (f (indexSmallArray sa i) (indexSmallArray sb i))-        *> go (i+1)+    fix ? 0 $ \go i -> when (i < mn) $ do+      x <- indexSmallArrayM sa i+      y <- indexSmallArrayM sb i+      writeSmallArray mc i (f x y)+      go (i+1) {-# INLINE zipW #-}  instance MonadZip SmallArray where@@ -576,9 +841,17 @@         <*> unsafeFreezeSmallArray smb  instance MonadFix SmallArray where-  mfix f = fromList . mfix $ toList . f+  mfix f = createSmallArray (sizeofSmallArray (f err))+                            (die "mfix" "impossible") $ flip fix 0 $+    \r !i !mary -> when (i < sz) $ do+                      writeSmallArray mary i (fix (\xi -> f xi `indexSmallArray` i))+                      r (i + 1) mary+    where+      sz = sizeofSmallArray (f err)+      err = error "mfix for Data.Primitive.SmallArray applied to strict function."  #if MIN_VERSION_base(4,9,0)+-- | @since 0.6.3.0 instance Sem.Semigroup (SmallArray a) where   (<>) = (<|>)   sconcat = mconcat . toList@@ -589,34 +862,65 @@ #if !(MIN_VERSION_base(4,11,0))   mappend = (<|>) #endif-  mconcat sas = createSmallArray n (die "mconcat" "impossible") $ \sma ->-    fix ? 0 ? sas $ \go off l -> case l of-      [] -> return ()-      sa:stk -> copySmallArray sma off sa 0 (length sa) *> go (off+1) stk-   where n = sum . fmap length $ sas+  mconcat l = createSmallArray n (die "mconcat" "impossible") $ \ma ->+    let go !_  [    ] = return ()+        go off (a:as) =+          copySmallArray ma off a 0 (sizeofSmallArray a) >> go (off + sizeofSmallArray a) as+     in go 0 l+   where n = sum . fmap length $ l  instance IsList (SmallArray a) where   type Item (SmallArray a) = a-  fromListN n l =-    createSmallArray n (die "fromListN" "mismatched size and list") $ \sma ->-      fix ? 0 ? l $ \go i li -> case li of-        [] -> pure ()-        x:xs -> writeSmallArray sma i x *> go (i+1) xs-  fromList l = fromListN (length l) l-  toList sa = indexSmallArray sa <$> [0 .. length sa - 1]+  fromListN = smallArrayFromListN+  fromList = smallArrayFromList+  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)++-- this need to be included for older ghcs+listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS+listLiftShowsPrec _ sl _ = sl+ instance Show a => Show (SmallArray a) where-  showsPrec p sa = showParen (p > 10) $-    showString "fromListN " . shows (length sa) . showString " "-      . shows (toList sa)+  showsPrec p sa = smallArrayLiftShowsPrec showsPrec showList p sa +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+-- | @since 0.6.4.0+instance Show1 SmallArray where+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)+  liftShowsPrec = smallArrayLiftShowsPrec+#else+  showsPrec1 = smallArrayLiftShowsPrec showsPrec showList+#endif+#endif++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+ instance Read a => Read (SmallArray a) where-  readPrec = parens . prec 10 $ do-    Symbol "fromListN" <- lexP-    Number nu <- lexP-    n <- maybe empty pure $ numberToInteger nu-    fromListN (fromIntegral n) <$> readPrec+  readsPrec = smallArrayLiftReadsPrec readsPrec readList +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+-- | @since 0.6.4.0+instance Read1 SmallArray where+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)+  liftReadsPrec = smallArrayLiftReadsPrec+#else+  readsPrec1 = smallArrayLiftReadsPrec readsPrec readList+#endif+#endif+++ smallArrayDataType :: DataType smallArrayDataType =   mkDataType "Data.Primitive.SmallArray.SmallArray" [fromListConstr]@@ -637,3 +941,27 @@   gunfold _ _ = die "gunfold" "SmallMutableArray"   dataTypeOf _ = mkNoRepType "Data.Primitive.SmallArray.SmallMutableArray" #endif++-- | Create a 'SmallArray' from a list of a known length. If the length+--   of the list does not match the given length, this throws an exception.+smallArrayFromListN :: Int -> [a] -> SmallArray a+#if HAVE_SMALL_ARRAY+smallArrayFromListN n l =+  createSmallArray n+      (die "smallArrayFromListN" "uninitialized element") $ \sma ->+  let go !ix [] = if ix == n+        then return ()+        else die "smallArrayFromListN" "list length less than specified size"+      go !ix (x : xs) = if ix < n+        then do+          writeSmallArray sma ix x+          go (ix+1) xs+        else die "smallArrayFromListN" "list length greater than specified size"+  in go 0 l+#else+smallArrayFromListN n l = SmallArray (Array.fromListN n l)+#endif++-- | Create a 'SmallArray' from a list.+smallArrayFromList :: [a] -> SmallArray a+smallArrayFromList l = smallArrayFromListN (length l) l

@@ -1,5 +1,12 @@ {-# LANGUAGE CPP, UnboxedTuples, MagicHash, DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE TypeInType #-}+#endif +#include "HsBaseConfig.h"+ -- | -- Module      : Data.Primitive.Types -- Copyright   : (c) Roman Leshchinskiy 2009-2012@@ -13,14 +20,17 @@  module Data.Primitive.Types (   Prim(..),-  sizeOf, alignment,+  sizeOf, alignment, defaultSetByteArray#, defaultSetOffAddr#,    Addr(..),+  PrimStorable(..) ) where  import Control.Monad.Primitive import Data.Primitive.MachDeps import Data.Primitive.Internal.Operations+import Foreign.C.Types+import System.Posix.Types  import GHC.Base (     Int(..), Char(..),@@ -47,10 +57,18 @@ import Data.Typeable ( Typeable ) import Data.Data ( Data(..) ) import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType )+import Foreign.Storable (Storable)+import Numeric +import qualified Foreign.Storable as FS+ -- | A machine address data Addr = Addr Addr# deriving ( Typeable ) +instance Show Addr where+  showsPrec _ (Addr a) =+    showString "0x" . showHex (fromIntegral (I# (addr2Int# a)) :: Word)+ instance Eq Addr where   Addr a# == Addr b# = isTrue# (eqAddr# a# b#)   Addr a# /= Addr b# = isTrue# (neAddr# a# b#)@@ -110,13 +128,87 @@   setOffAddr# :: Addr# -> Int# -> Int# -> a -> State# s -> State# s  -- | Size of values of type @a@. The argument is not used.+--+-- 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.+--+-- 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) +-- | 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+-- to broadcast a value to contiguous memory. It is typically used+-- alongside 'defaultSetOffAddr#'. For example:+--+-- > data Trip = Trip Int Int Int+-- >+-- > instance Prim Trip+-- >   sizeOf# _ = 3# *# sizeOf# (undefined :: Int)+-- >   alignment# _ = alignment# (undefined :: Int)+-- >   indexByteArray# arr# i# = ...+-- >   readByteArray# arr# i# = ...+-- >   writeByteArray# arr# i# (Trip a b c) =+-- >     \s0 -> case writeByteArray# arr# (3# *# i#) a s0 of+-- >        s1 -> case writeByteArray# arr# ((3# *# i#) +# 1#) b s1 of+-- >          s2 -> case writeByteArray# arr# ((3# *# i#) +# 2# ) c s2 of+-- >            s3 -> s3+-- >   setByteArray# = defaultSetByteArray#+-- >   indexOffAddr# addr# i# = ...+-- >   readOffAddr# addr# i# = ...+-- >   writeOffAddr# addr# i# (Trip a b c) =+-- >     \s0 -> case writeOffAddr# addr# (3# *# i#) a s0 of+-- >        s1 -> case writeOffAddr# addr# ((3# *# i#) +# 1#) b s1 of+-- >          s2 -> case writeOffAddr# addr# ((3# *# i#) +# 2# ) c s2 of+-- >            s3 -> s3+-- >   setOffAddr# = defaultSetOffAddr#+defaultSetByteArray# :: Prim a => MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s+defaultSetByteArray# arr# i# len# ident = go 0#+  where+  go ix# s0 = if isTrue# (ix# <# len#)+    then case writeByteArray# arr# (i# +# ix#) ident s0 of+      s1 -> go (ix# +# 1#) s1+    else s0++-- | An implementation of 'setOffAddr#' that calls 'writeOffAddr#'+-- to set each element. The documentation of 'defaultSetByteArray#'+-- provides an example of how to use this.+defaultSetOffAddr# :: Prim a => Addr# -> Int# -> Int# -> a -> State# s -> State# s+defaultSetOffAddr# addr# i# len# ident = go 0#+  where+  go ix# s0 = if isTrue# (ix# <# len#)+    then case writeOffAddr# addr# (i# +# ix#) ident s0 of+      s1 -> go (ix# +# 1#) s1+    else s0++-- | Newtype that uses a 'Prim' instance to give rise to a 'Storable' instance.+-- This type is intended to be used with the @DerivingVia@ extension available+-- in GHC 8.6 and up. For example, consider a user-defined 'Prim' instance for+-- a multi-word data type.+--+-- > data Uuid = Uuid Word64 Word64+-- >   deriving Storable via (PrimStorable Uuid)+-- > instance Prim Uuid where ...+--+-- Writing the 'Prim' instance is tedious and unavoidable, but the 'Storable'+-- instance comes for free once the 'Prim' instance is written.+newtype PrimStorable a = PrimStorable { getPrimStorable :: a }++instance Prim a => Storable (PrimStorable a) where+  sizeOf _ = sizeOf (undefined :: a)+  alignment _ = alignment (undefined :: a)+  peekElemOff (Ptr addr#) (I# i#) =+    primitive $ \s0# -> case readOffAddr# addr# i# s0# of+      (# s1, x #) -> (# s1, PrimStorable x #)+  pokeElemOff (Ptr addr#) (I# i#) (PrimStorable a) = primitive_ $ \s# ->+    writeOffAddr# addr# i# a s#+ #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                                           \@@ -205,3 +297,99 @@ derivePrim(FunPtr a, FunPtr, sIZEOF_PTR, aLIGNMENT_PTR,            indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#,            indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#)++-- Prim instances for newtypes in Foreign.C.Types+deriving instance Prim CChar+deriving instance Prim CSChar+deriving instance Prim CUChar+deriving instance Prim CShort+deriving instance Prim CUShort+deriving instance Prim CInt+deriving instance Prim CUInt+deriving instance Prim CLong+deriving instance Prim CULong+deriving instance Prim CPtrdiff+deriving instance Prim CSize+deriving instance Prim CWchar+deriving instance Prim CSigAtomic+deriving instance Prim CLLong+deriving instance Prim CULLong+#if MIN_VERSION_base(4,10,0)+deriving instance Prim CBool+#endif+deriving instance Prim CIntPtr+deriving instance Prim CUIntPtr+deriving instance Prim CIntMax+deriving instance Prim CUIntMax+deriving instance Prim CClock+deriving instance Prim CTime+deriving instance Prim CUSeconds+deriving instance Prim CSUSeconds+deriving instance Prim CFloat+deriving instance Prim CDouble++-- Prim instances for newtypes in System.Posix.Types+#if defined(HTYPE_DEV_T)+deriving instance Prim CDev+#endif+#if defined(HTYPE_INO_T)+deriving instance Prim CIno+#endif+#if defined(HTYPE_MODE_T)+deriving instance Prim CMode+#endif+#if defined(HTYPE_OFF_T)+deriving instance Prim COff+#endif+#if defined(HTYPE_PID_T)+deriving instance Prim CPid+#endif+#if defined(HTYPE_SSIZE_T)+deriving instance Prim CSsize+#endif+#if defined(HTYPE_GID_T)+deriving instance Prim CGid+#endif+#if defined(HTYPE_NLINK_T)+deriving instance Prim CNlink+#endif+#if defined(HTYPE_UID_T)+deriving instance Prim CUid+#endif+#if defined(HTYPE_CC_T)+deriving instance Prim CCc+#endif+#if defined(HTYPE_SPEED_T)+deriving instance Prim CSpeed+#endif+#if defined(HTYPE_TCFLAG_T)+deriving instance Prim CTcflag+#endif+#if defined(HTYPE_RLIM_T)+deriving instance Prim CRLim+#endif+#if defined(HTYPE_BLKSIZE_T)+deriving instance Prim CBlkSize+#endif+#if defined(HTYPE_BLKCNT_T)+deriving instance Prim CBlkCnt+#endif+#if defined(HTYPE_CLOCKID_T)+deriving instance Prim CClockId+#endif+#if defined(HTYPE_FSBLKCNT_T)+deriving instance Prim CFsBlkCnt+#endif+#if defined(HTYPE_FSFILCNT_T)+deriving instance Prim CFsFilCnt+#endif+#if defined(HTYPE_ID_T)+deriving instance Prim CId+#endif+#if defined(HTYPE_KEY_T)+deriving instance Prim CKey+#endif+#if defined(HTYPE_TIMER_T)+deriving instance Prim CTimer+#endif+deriving instance Prim Fd

@@ -1,6 +1,11 @@+{-# Language BangPatterns #-}+{-# Language CPP #-}+{-# Language DeriveDataTypeable #-} {-# Language MagicHash #-}+{-# Language RankNTypes #-}+{-# Language ScopedTypeVariables #-}+{-# Language TypeFamilies #-} {-# Language UnboxedTuples #-}-{-# Language DeriveDataTypeable #-}  -- | -- Module      : Data.Primitive.UnliftedArray@@ -39,9 +44,11 @@ -- that are eligible to be stored.  module Data.Primitive.UnliftedArray-  ( UnliftedArray(..)+  ( -- * Types+    UnliftedArray(..)   , MutableUnliftedArray(..)   , PrimUnlifted(..)+    -- * Operations   , unsafeNewUnliftedArray   , newUnliftedArray   , setUnliftedArray@@ -54,33 +61,68 @@   , unsafeFreezeUnliftedArray   , freezeUnliftedArray   , thawUnliftedArray+  , runUnliftedArray   , sameMutableUnliftedArray   , copyUnliftedArray   , copyMutableUnliftedArray   , cloneUnliftedArray   , cloneMutableUnliftedArray+    -- * List Conversion+  , unliftedArrayToList+  , unliftedArrayFromList+  , unliftedArrayFromListN+    -- * Folding+  , foldrUnliftedArray+  , foldrUnliftedArray'+  , foldlUnliftedArray+  , foldlUnliftedArray'+    -- * Mapping+  , mapUnliftedArray -- Missing operations: --  , unsafeThawUnliftedArray   ) where  import Data.Typeable+import Control.Applicative  import GHC.Prim-import GHC.Base (Int(..))+import GHC.Base (Int(..),build)  import Control.Monad.Primitive -import Control.Monad.ST (runST)+import Control.Monad.ST (runST,ST) +import Data.Monoid (Monoid,mappend) import Data.Primitive.Internal.Compat ( isTrue# ) +import qualified Data.List as L import           Data.Primitive.Array (Array) import qualified Data.Primitive.Array as A import           Data.Primitive.ByteArray (ByteArray) import qualified Data.Primitive.ByteArray as BA+import qualified Data.Primitive.PrimArray as PA import qualified Data.Primitive.SmallArray as SA import qualified Data.Primitive.MutVar as MV+import qualified Data.Monoid+import qualified GHC.MVar as GM (MVar(..))+import qualified GHC.Conc as GC (TVar(..))+import qualified GHC.Stable as GSP (StablePtr(..))+import qualified GHC.Weak as GW (Weak(..))+import qualified GHC.Conc.Sync as GCS (ThreadId(..))+import qualified GHC.Exts as E+import qualified GHC.ST as GHCST +#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (Semigroup)+import qualified Data.Semigroup+#endif++#if MIN_VERSION_base(4,10,0)+import GHC.Exts (runRW#)+#elif MIN_VERSION_base(4,9,0)+import GHC.Base (runRW#)+#endif+ -- | Immutable arrays that efficiently store types that are simple wrappers -- around unlifted primitive types. The values of the unlifted type are -- stored directly, eliminating a layer of indirection.@@ -125,6 +167,16 @@   toArrayArray# (BA.MutableByteArray mba#) = unsafeCoerce# mba#   fromArrayArray# aa# = BA.MutableByteArray (unsafeCoerce# aa#) +-- | @since 0.6.4.0+instance PrimUnlifted (PA.PrimArray a) where+  toArrayArray# (PA.PrimArray ba#) = unsafeCoerce# ba#+  fromArrayArray# aa# = PA.PrimArray (unsafeCoerce# aa#)++-- | @since 0.6.4.0+instance PrimUnlifted (PA.MutablePrimArray s a) where+  toArrayArray# (PA.MutablePrimArray mba#) = unsafeCoerce# mba#+  fromArrayArray# aa# = PA.MutablePrimArray (unsafeCoerce# aa#)+ instance PrimUnlifted (SA.SmallArray a) where   toArrayArray# (SA.SmallArray sa#) = unsafeCoerce# sa#   fromArrayArray# aa# = SA.SmallArray (unsafeCoerce# aa#)@@ -137,8 +189,38 @@   toArrayArray# (MV.MutVar mv#) = unsafeCoerce# mv#   fromArrayArray# aa# = MV.MutVar (unsafeCoerce# aa#) --- | Creates a new 'MutableUnliftedArray'. This function is unsafe, because it--- allows access to the raw contents of the underlying 'ArrayArray#'.+-- | @since 0.6.4.0+instance PrimUnlifted (GM.MVar a) where+  toArrayArray# (GM.MVar mv#) = unsafeCoerce# mv#+  fromArrayArray# mv# = GM.MVar (unsafeCoerce# mv#)++-- | @since 0.6.4.0+instance PrimUnlifted (GC.TVar a) where+  toArrayArray# (GC.TVar tv#) = unsafeCoerce# tv#+  fromArrayArray# tv# = GC.TVar (unsafeCoerce# tv#)++-- | @since 0.6.4.0+instance PrimUnlifted (GSP.StablePtr a) where+  toArrayArray# (GSP.StablePtr tv#) = unsafeCoerce# tv#+  fromArrayArray# tv# = GSP.StablePtr (unsafeCoerce# tv#)++-- | @since 0.6.4.0+instance PrimUnlifted (GW.Weak a) where+  toArrayArray# (GW.Weak tv#) = unsafeCoerce# tv#+  fromArrayArray# tv# = GW.Weak (unsafeCoerce# tv#)++-- | @since 0.6.4.0+instance PrimUnlifted GCS.ThreadId where+  toArrayArray# (GCS.ThreadId tv#) = unsafeCoerce# tv#+  fromArrayArray# tv# = GCS.ThreadId (unsafeCoerce# tv#)++die :: String -> String -> a+die fun problem = error $ "Data.Primitive.UnliftedArray." ++ fun ++ ": " ++ problem++-- | Creates a new 'MutableUnliftedArray'. This function is unsafe because it+-- initializes all elements of the array as pointers to the array itself. Attempting+-- to read one of these elements before writing to it is in effect an unsafe+-- coercion from the @MutableUnliftedArray s a@ to the element type. unsafeNewUnliftedArray   :: (PrimMonad m)   => Int -- ^ size@@ -329,6 +411,63 @@   return dst {-# inline thawUnliftedArray #-} +#if !MIN_VERSION_base(4,9,0)+unsafeCreateUnliftedArray+  :: Int+  -> (forall s. MutableUnliftedArray s a -> ST s ())+  -> UnliftedArray a+unsafeCreateUnliftedArray 0 _ = emptyUnliftedArray+unsafeCreateUnliftedArray n f = runUnliftedArray $ do+  mary <- unsafeNewUnliftedArray n+  f mary+  pure mary++-- | Execute a stateful computation and freeze the resulting array.+runUnliftedArray+  :: (forall s. ST s (MutableUnliftedArray s a))+  -> UnliftedArray a+runUnliftedArray m = runST $ m >>= unsafeFreezeUnliftedArray++#else /* Below, runRW# is available. */++-- This low-level business is designed to work with GHC's worker-wrapper+-- transformation. A lot of the time, we don't actually need an Array+-- constructor. By putting it on the outside, and being careful about+-- how we special-case the empty array, we can make GHC smarter about this.+-- The only downside is that separately created 0-length arrays won't share+-- their Array constructors, although they'll share their underlying+-- Array#s.+unsafeCreateUnliftedArray+  :: Int+  -> (forall s. MutableUnliftedArray s a -> ST s ())+  -> UnliftedArray a+unsafeCreateUnliftedArray 0 _ = UnliftedArray (emptyArrayArray# (# #))+unsafeCreateUnliftedArray n f = runUnliftedArray $ do+  mary <- unsafeNewUnliftedArray n+  f mary+  pure mary++-- | Execute a stateful computation and freeze the resulting array.+runUnliftedArray+  :: (forall s. ST s (MutableUnliftedArray s a))+  -> UnliftedArray a+runUnliftedArray m = UnliftedArray (runUnliftedArray# m)++runUnliftedArray#+  :: (forall s. ST s (MutableUnliftedArray s a))+  -> ArrayArray#+runUnliftedArray# m = case runRW# $ \s ->+  case unST m s of { (# s', MutableUnliftedArray mary# #) ->+  unsafeFreezeArrayArray# mary# s'} of (# _, ary# #) -> ary#++unST :: ST s a -> State# s -> (# State# s, a #)+unST (GHCST.ST f) = f++emptyArrayArray# :: (# #) -> ArrayArray#+emptyArrayArray# _ = case emptyUnliftedArray of UnliftedArray ar -> ar+{-# NOINLINE emptyArrayArray# #-}+#endif+ -- | Creates a copy of a portion of an 'UnliftedArray' cloneUnliftedArray   :: UnliftedArray a -- ^ source@@ -336,7 +475,7 @@   -> Int -- ^ length   -> UnliftedArray a cloneUnliftedArray src off len =-  runST $ thawUnliftedArray src off len >>= unsafeFreezeUnliftedArray+  runUnliftedArray (thawUnliftedArray src off len) {-# inline cloneUnliftedArray #-}  -- | Creates a new 'MutableUnliftedArray' containing a copy of a portion of@@ -363,3 +502,137 @@    loop i      | i < 0 = True      | otherwise = indexUnliftedArray aa1 i == indexUnliftedArray aa2 i && loop (i-1)++-- | Lexicographic ordering. Subject to change between major versions.+--+--   @since 0.6.4.0+instance (Ord a, PrimUnlifted a) => Ord (UnliftedArray a) where+  compare a1 a2 = loop 0+    where+    mn = sizeofUnliftedArray a1 `min` sizeofUnliftedArray a2+    loop i+      | i < mn+      , x1 <- indexUnliftedArray a1 i+      , x2 <- indexUnliftedArray a2 i+      = compare x1 x2 `mappend` loop (i+1)+      | otherwise = compare (sizeofUnliftedArray a1) (sizeofUnliftedArray a2)++-- | @since 0.6.4.0+instance (Show a, PrimUnlifted a) => Show (UnliftedArray a) where+  showsPrec p a = showParen (p > 10) $+    showString "fromListN " . shows (sizeofUnliftedArray a) . showString " "+      . shows (unliftedArrayToList a)++#if MIN_VERSION_base(4,9,0)+-- | @since 0.6.4.0+instance PrimUnlifted a => Semigroup (UnliftedArray a) where+  (<>) = concatUnliftedArray+#endif++-- | @since 0.6.4.0+instance PrimUnlifted a => Monoid (UnliftedArray a) where+  mempty = emptyUnliftedArray+#if !(MIN_VERSION_base(4,11,0))+  mappend = concatUnliftedArray+#endif++emptyUnliftedArray :: UnliftedArray a+emptyUnliftedArray = runUnliftedArray (unsafeNewUnliftedArray 0)+{-# NOINLINE emptyUnliftedArray #-}++concatUnliftedArray :: UnliftedArray a -> UnliftedArray a -> UnliftedArray a+concatUnliftedArray x y = unsafeCreateUnliftedArray (sizeofUnliftedArray x + sizeofUnliftedArray y) $ \m -> do+  copyUnliftedArray m 0 x 0 (sizeofUnliftedArray x)+  copyUnliftedArray m (sizeofUnliftedArray x) y 0 (sizeofUnliftedArray y)++-- | Lazy right-associated fold over the elements of an 'UnliftedArray'.+{-# INLINE foldrUnliftedArray #-}+foldrUnliftedArray :: forall a b. PrimUnlifted a => (a -> b -> b) -> b -> UnliftedArray a -> b+foldrUnliftedArray f z arr = go 0+  where+    !sz = sizeofUnliftedArray arr+    go !i+      | sz > i = f (indexUnliftedArray arr i) (go (i+1))+      | otherwise = z++-- | Strict right-associated fold over the elements of an 'UnliftedArray.+{-# INLINE foldrUnliftedArray' #-}+foldrUnliftedArray' :: forall a b. PrimUnlifted a => (a -> b -> b) -> b -> UnliftedArray a -> b+foldrUnliftedArray' f z0 arr = go (sizeofUnliftedArray arr - 1) z0+  where+    go !i !acc+      | i < 0 = acc+      | otherwise = go (i - 1) (f (indexUnliftedArray arr i) acc)++-- | Lazy left-associated fold over the elements of an 'UnliftedArray'.+{-# INLINE foldlUnliftedArray #-}+foldlUnliftedArray :: forall a b. PrimUnlifted a => (b -> a -> b) -> b -> UnliftedArray a -> b+foldlUnliftedArray f z arr = go (sizeofUnliftedArray arr - 1)+  where+    go !i+      | i < 0 = z+      | otherwise = f (go (i - 1)) (indexUnliftedArray arr i)++-- | Strict left-associated fold over the elements of an 'UnliftedArray'.+{-# INLINE foldlUnliftedArray' #-}+foldlUnliftedArray' :: forall a b. PrimUnlifted a => (b -> a -> b) -> b -> UnliftedArray a -> b+foldlUnliftedArray' f z0 arr = go 0 z0+  where+    !sz = sizeofUnliftedArray arr+    go !i !acc+      | i < sz = go (i + 1) (f acc (indexUnliftedArray arr i))+      | otherwise = acc++-- | Map over the elements of an 'UnliftedArray'.+{-# INLINE mapUnliftedArray #-}+mapUnliftedArray :: (PrimUnlifted a, PrimUnlifted b)+  => (a -> b)+  -> UnliftedArray a+  -> UnliftedArray b+mapUnliftedArray f arr = unsafeCreateUnliftedArray sz $ \marr -> do+  let go !ix = if ix < sz+        then do+          let b = f (indexUnliftedArray arr ix)+          writeUnliftedArray marr ix b+          go (ix + 1)+        else return ()+  go 0+  where+  !sz = sizeofUnliftedArray arr++-- | Convert the unlifted array to a list.+{-# INLINE unliftedArrayToList #-}+unliftedArrayToList :: PrimUnlifted a => UnliftedArray a -> [a]+unliftedArrayToList xs = build (\c n -> foldrUnliftedArray c n xs)++unliftedArrayFromList :: PrimUnlifted a => [a] -> UnliftedArray a+unliftedArrayFromList xs = unliftedArrayFromListN (L.length xs) xs++unliftedArrayFromListN :: forall a. PrimUnlifted a => Int -> [a] -> UnliftedArray a+unliftedArrayFromListN len vs = unsafeCreateUnliftedArray len run where+  run :: forall s. MutableUnliftedArray s a -> ST s ()+  run arr = do+    let go :: [a] -> Int -> ST s ()+        go [] !ix = if ix == len+          -- The size check is mandatory since failure to initialize all elements+          -- introduces the possibility of a segfault happening when someone attempts+          -- to read the unitialized element. See the docs for unsafeNewUnliftedArray.+          then return ()+          else die "unliftedArrayFromListN" "list length less than specified size"+        go (a : as) !ix = if ix < len+          then do+            writeUnliftedArray arr ix a+            go as (ix + 1)+          else die "unliftedArrayFromListN" "list length greater than specified size"+    go vs 0+++#if MIN_VERSION_base(4,7,0)+-- | @since 0.6.4.0+instance PrimUnlifted a => E.IsList (UnliftedArray a) where+  type Item (UnliftedArray a) = a+  fromList = unliftedArrayFromList+  fromListN = unliftedArrayFromListN+  toList = unliftedArrayToList+#endif+

@@ -1,3 +1,64 @@+## Changes in version 0.6.4.0++ * Introduce `Data.Primitive.PrimArray`, which offers types and function+   for dealing with a `ByteArray` tagged with a phantom type variable for+   tracking the element type.++ * Implement `isByteArrayPinned` and `isMutableByteArrayPinned`.++ * Add `Eq1`, `Ord1`, `Show1`, and `Read1` instances for `Array` and+   `SmallArray`.++ * Improve the test suite. This includes having property tests for+   typeclasses from `base` such as `Eq`, `Ord`, `Functor`, `Applicative`,+   `Monad`, `IsList`, `Monoid`, `Foldable`, and `Traversable`.++ * Fix the broken `IsList` instance for `ByteArray`. The old definition+   would allocate a byte array of the correct size and then leave the+   memory unitialized instead of writing the list elements to it.++ * Fix the broken `Functor` instance for `Array`. The old definition+   would allocate an array of the correct size with thunks for erroring+   installed at every index. It failed to replace these thunks with+   the result of the function applied to the elements of the argument array.++ * Fix the broken `Applicative` instances of `Array` and `SmallArray`.+   The old implementation of `<*>` for `Array` failed to initialize+   some elements but correctly initialized others in the resulting+   `Array`. It is unclear what the old behavior of `<*>` was for+   `SmallArray`, but it was incorrect.++ * Fix the broken `Monad` instances for `Array` and `SmallArray`.++ * Fix the implementation of `foldl1` in the `Foldable` instances for+   `Array` and `SmallArray`. In both cases, the old implementation+   simply returned the first element of the array and made no use of+   the other elements in the array.++ * Fix the implementation of `mconcat` in the `Monoid` instance for+   `SmallArray`.+ + * Implement `Data.Primitive.Ptr`, implementations of `Ptr` functions+   that require a `Prim` constraint instead of a `Storable` constraint.+++ * Add `PrimUnlifted` instances for `TVar` and `MVar`.++ * Use `compareByteArrays#` for the `Eq` and `Ord` instances of+   `ByteArray` when building with GHC 8.4 and newer.++ * Add `Prim` instances for lots of types in `Foreign.C.Types` and+   `System.Posix.Types`.++ * Reexport `Data.Primitive.SmallArray` and `Data.Primitive.UnliftedArray`+   from `Data.Primitive`.++ * Add fold functions and map function to `Data.Primitive.UnliftedArray`.+   Add typeclass instances for `IsList`, `Ord`, and `Show`.++ * Add `defaultSetByteArray#` and `defaultSetOffAddr#` to+   `Data.Primitive.Types`.+ ## Changes in version 0.6.3.0   * Add `PrimMonad` instances for `ContT`, `AccumT`, and `SelectT` from

@@ -1,5 +1,5 @@ Name:           primitive-Version:        0.6.3.0+Version:        0.6.4.0 License:        BSD3 License-File:   LICENSE @@ -15,6 +15,9 @@ Description:    This package provides various primitive memory-related operations.  Extra-Source-Files: changelog.md+                    test/*.hs+                    test/LICENSE+                    test/primitive-tests.cabal  Tested-With:   GHC == 7.4.2,@@ -23,7 +26,7 @@   GHC == 7.10.3,   GHC == 8.0.2,   GHC == 8.2.2,-  GHC == 8.4.1+  GHC == 8.4.2  Library   Default-Language: Haskell2010@@ -38,10 +41,13 @@         Data.Primitive.Types         Data.Primitive.Array         Data.Primitive.ByteArray+        Data.Primitive.PrimArray         Data.Primitive.SmallArray         Data.Primitive.UnliftedArray         Data.Primitive.Addr+        Data.Primitive.Ptr         Data.Primitive.MutVar+        Data.Primitive.MVar    Other-Modules:         Data.Primitive.Internal.Compat@@ -51,27 +57,16 @@                , ghc-prim >= 0.2 && < 0.6                , transformers >= 0.2 && < 0.6 -  Ghc-Options: -O2 -Wall+  Ghc-Options: -O2    Include-Dirs: cbits   Install-Includes: primitive-memops.h   includes: primitive-memops.h   c-sources: cbits/primitive-memops.c-  cc-options: -O3 -fomit-frame-pointer -Wall   if !os(solaris)       cc-options: -ftree-vectorize   if arch(i386) || arch(x86_64)       cc-options: -msse2--test-suite test-  Default-Language: Haskell2010-  hs-source-dirs: test-  main-is: main.hs-  type: exitcode-stdio-1.0-  build-depends: base-               , ghc-prim-               , primitive-  ghc-options: -O2  source-repository head   type:     git

@@ -0,0 +1,30 @@+Copyright (c) 2008-2009, Roman Leshchinskiy+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.+

@@ -1,26 +1,228 @@-{-# LANGUAGE MagicHash, UnboxedTuples #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ScopedTypeVariables #-} +import Control.Applicative import Control.Monad+import Control.Monad.Fix (fix) import Control.Monad.Primitive import Control.Monad.ST+import Data.Monoid import Data.Primitive import Data.Primitive.Array import Data.Primitive.ByteArray import Data.Primitive.Types+import Data.Primitive.SmallArray+import Data.Primitive.PrimArray import Data.Word+import Data.Proxy (Proxy(..)) import GHC.Int import GHC.IO import GHC.Prim+import Data.Function (on)+#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (stimes)+#endif --- Since we only have two test cases right now, I'm going to avoid the--- issue of choosing a test framework for the moment. This also keeps the--- package as a whole light on dependencies.+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 as QCC+import qualified Test.QuickCheck.Classes.IsList as QCCL+import qualified Data.List as L  main :: IO () main = do-    testArray-    testByteArray+  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)))+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+      , 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))+#endif+#if MIN_VERSION_base(4,7,0)+      , lawsToTest (QCC.isListLaws (Proxy :: Proxy (Array Int)))+      , TQC.testProperty "mapArray'" (QCCL.mapProp int16 int32 mapArray')+#endif+      ]+    , 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)))+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+      , 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))+#endif+#if MIN_VERSION_base(4,7,0)+      , lawsToTest (QCC.isListLaws (Proxy :: Proxy (SmallArray Int)))+      , TQC.testProperty "mapSmallArray'" (QCCL.mapProp int16 int32 mapSmallArray')+#endif+      ]+    , testGroup "ByteArray"+      [ testGroup "Ordering"+        [ TQC.testProperty "equality" byteArrayEqProp+        , TQC.testProperty "compare" byteArrayCompareProp+        ]+      , testGroup "Resize"+        [ TQC.testProperty "shrink" byteArrayShrinkProp+        , TQC.testProperty "grow" byteArrayGrowProp+        ]+      , lawsToTest (QCC.eqLaws (Proxy :: Proxy ByteArray))+      , lawsToTest (QCC.ordLaws (Proxy :: Proxy ByteArray))+      , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))+#if MIN_VERSION_base(4,7,0)+      , lawsToTest (QCC.isListLaws (Proxy :: Proxy ByteArray))+#endif+      ]+    , testGroup "PrimArray"+      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (PrimArray Word16)))+      , lawsToTest (QCC.ordLaws (Proxy :: Proxy (PrimArray Word16)))+      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (PrimArray Word16)))+#if MIN_VERSION_base(4,7,0)+      , 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)+#endif+      ]+    , testGroup "UnliftedArray"+      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16))))+      , lawsToTest (QCC.ordLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16))))+      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16))))+#if MIN_VERSION_base(4,7,0)+      , lawsToTest (QCC.isListLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16))))+      , TQC.testProperty "mapUnliftedArray" (QCCL.mapProp arrInt16 arrInt32 mapUnliftedArray)+      , TQC.testProperty "foldrUnliftedArray" (QCCL.foldrProp arrInt16 foldrUnliftedArray)+      , TQC.testProperty "foldrUnliftedArray'" (QCCL.foldrProp arrInt16 foldrUnliftedArray')+      , TQC.testProperty "foldlUnliftedArray" (QCCL.foldlProp arrInt16 foldlUnliftedArray)+      , TQC.testProperty "foldlUnliftedArray'" (QCCL.foldlProp arrInt16 foldlUnliftedArray')+#endif+      ]+    , testGroup "DefaultSetMethod"+      [ lawsToTest (QCC.primLaws (Proxy :: Proxy DefaultSetMethod))+      ]+    -- , testGroup "PrimStorable"+    --   [ lawsToTest (QCC.storableLaws (Proxy :: Proxy Derived))+    --   ]+    ] +int16 :: Proxy Int16+int16 = Proxy++int32 :: Proxy Int32+int32 = Proxy++arrInt16 :: Proxy (PrimArray Int16)+arrInt16 = Proxy++arrInt32 :: Proxy (PrimArray Int16)+arrInt32 = Proxy++-- Tests that using resizeByteArray to shrink a byte array produces+-- the same results as calling Data.List.take on the list that the+-- byte array corresponds to.+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++-- 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)+ testArray :: IO () testArray = do     arr <- newArray 1 'A'@@ -41,15 +243,100 @@     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])     when (show arr1 /= "[0xde, 0xad, 0xbe, 0xef]") $         fail $ "ByteArray Show incorrect: "++show arr1     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"+#if MIN_VERSION_base(4,9,0)+    unless (stimes (3 :: Int) arr4 == (arr4 <> arr4 <> arr4)) $+        fail $ "ByteArray Semigroup stimes incorrect"+#endif  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 (Arbitrary a, PrimUnlifted a) => Arbitrary (UnliftedArray a) where+  arbitrary = do+    xs <- QC.vector =<< QC.choose (0,3)+    return (unliftedArrayFromList xs)++instance (Prim a, CoArbitrary a) => CoArbitrary (PrimArray a) where+  coarbitrary x = QC.coarbitrary (primArrayToList x)++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#++-- TODO: Uncomment this out when GHC 8.6 is release. Also, uncomment+-- the corresponding PrimStorable test group above.+--+-- newtype Derived = Derived Int16+--   deriving newtype (Prim)+--   deriving Storable via (PrimStorable Derived)+++

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