feat(third_party/bazel): Check in rules_haskell from Tweag

third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Addr.hs

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

third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Array.hs

@@ -0,0 +1,822 @@
+{-# LANGUAGE CPP, MagicHash, UnboxedTuples, DeriveDataTypeable, BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- |
+-- Module      : Data.Primitive.Array
+-- Copyright   : (c) Roman Leshchinskiy 2009-2012
+-- License     : BSD-style
+--
+-- Maintainer  : Roman Leshchinskiy <rl@cse.unsw.edu.au>
+-- Portability : non-portable
+--
+-- Primitive arrays of boxed values.
+--
+
+module Data.Primitive.Array (
+  Array(..), MutableArray(..),
+
+  newArray, readArray, writeArray, indexArray, indexArrayM, indexArray##,
+  freezeArray, thawArray, runArray,
+  unsafeFreezeArray, unsafeThawArray, sameMutableArray,
+  copyArray, copyMutableArray,
+  cloneArray, cloneMutableArray,
+  sizeofArray, sizeofMutableArray,
+  fromListN, fromList,
+  mapArray',
+  traverseArrayP
+) where
+
+import Control.Monad.Primitive
+
+import GHC.Base  ( Int(..) )
+import GHC.Prim
+import qualified GHC.Exts as Exts
+#if (MIN_VERSION_base(4,7,0))
+import GHC.Exts (fromListN, fromList)
+#endif
+
+import Data.Typeable ( Typeable )
+import Data.Data
+  (Data(..), DataType, mkDataType, Constr, mkConstr, Fixity(..), constrIndex)
+import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType )
+
+import Control.Monad.ST(ST,runST)
+
+import Control.Applicative
+import Control.Monad (MonadPlus(..), when)
+import Control.Monad.Fix
+#if MIN_VERSION_base(4,4,0)
+import Control.Monad.Zip
+#endif
+import Data.Foldable (Foldable(..), toList)
+#if !(MIN_VERSION_base(4,8,0))
+import Data.Traversable (Traversable(..))
+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 }
+  deriving ( Typeable )
+
+-- | Mutable boxed arrays associated with a primitive state token.
+data MutableArray s a = MutableArray
+  { marray# :: MutableArray# s a }
+  deriving ( Typeable )
+
+sizeofArray :: Array a -> Int
+sizeofArray a = I# (sizeofArray# (array# a))
+{-# INLINE sizeofArray #-}
+
+sizeofMutableArray :: MutableArray s a -> Int
+sizeofMutableArray a = I# (sizeofMutableArray# (marray# a))
+{-# INLINE sizeofMutableArray #-}
+
+-- | Create a new mutable array of the specified size and initialise all
+-- elements with the given value.
+newArray :: PrimMonad m => Int -> a -> m (MutableArray (PrimState m) a)
+{-# INLINE newArray #-}
+newArray (I# n#) x = primitive
+   (\s# -> case newArray# n# x s# of
+             (# s'#, arr# #) ->
+               let ma = MutableArray arr#
+               in (# s'# , ma #))
+
+-- | Read a value from the array at the given index.
+readArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> m a
+{-# INLINE readArray #-}
+readArray arr (I# i#) = primitive (readArray# (marray# arr) i#)
+
+-- | Write a value to the array at the given index.
+writeArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> a -> m ()
+{-# INLINE writeArray #-}
+writeArray arr (I# i#) x = primitive_ (writeArray# (marray# arr) i# x)
+
+-- | Read a value from the immutable array at the given index.
+indexArray :: Array a -> Int -> a
+{-# 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
+-- copy an array. We could do something like this:
+--
+-- > copy marr arr ... = do ...
+-- >                        writeArray marr i (indexArray arr i) ...
+-- >                        ...
+--
+-- But since primitive arrays are lazy, the calls to 'indexArray' will not be
+-- evaluated. Rather, @marr@ will be filled with thunks each of which would
+-- retain a reference to @arr@. This is definitely not what we want!
+--
+-- With 'indexArrayM', we can instead write
+--
+-- > copy marr arr ... = do ...
+-- >                        x <- indexArrayM arr i
+-- >                        writeArray marr i x
+-- >                        ...
+--
+-- Now, indexing is executed immediately although the returned element is
+-- still not evaluated.
+--
+indexArrayM :: Monad m => Array a -> Int -> m a
+{-# INLINE indexArrayM #-}
+indexArrayM arr (I# i#)
+  = case indexArray# (array# arr) i# of (# x #) -> return x
+
+-- | Create an immutable copy of a slice of an array.
+--
+-- This operation makes a copy of the specified section, so it is safe to
+-- continue using the mutable array afterward.
+freezeArray
+  :: PrimMonad m
+  => MutableArray (PrimState m) a -- ^ source
+  -> Int                          -- ^ offset
+  -> Int                          -- ^ length
+  -> m (Array a)
+{-# INLINE freezeArray #-}
+freezeArray (MutableArray ma#) (I# off#) (I# len#) =
+  primitive $ \s -> case freezeArray# ma# off# len# s of
+    (# s', a# #) -> (# s', Array a# #)
+
+-- | Convert a mutable array to an immutable one without copying. The
+-- array should not be modified after the conversion.
+unsafeFreezeArray :: PrimMonad m => MutableArray (PrimState m) a -> m (Array a)
+{-# INLINE unsafeFreezeArray #-}
+unsafeFreezeArray arr
+  = primitive (\s# -> case unsafeFreezeArray# (marray# arr) s# of
+                        (# s'#, arr'# #) ->
+                          let a = Array arr'#
+                          in (# s'#, a #))
+
+-- | Create a mutable array from a slice of an immutable array.
+--
+-- This operation makes a copy of the specified slice, so it is safe to use the
+-- immutable array afterward.
+thawArray
+  :: PrimMonad m
+  => Array a -- ^ source
+  -> Int     -- ^ offset
+  -> Int     -- ^ length
+  -> m (MutableArray (PrimState m) a)
+{-# INLINE thawArray #-}
+thawArray (Array a#) (I# off#) (I# len#) =
+  primitive $ \s -> case thawArray# a# off# len# s of
+    (# s', ma# #) -> (# s', MutableArray ma# #)
+
+-- | Convert an immutable array to an mutable one without copying. The
+-- immutable array should not be used after the conversion.
+unsafeThawArray :: PrimMonad m => Array a -> m (MutableArray (PrimState m) a)
+{-# INLINE unsafeThawArray #-}
+unsafeThawArray a
+  = primitive (\s# -> case unsafeThawArray# (array# a) s# of
+                        (# s'#, arr'# #) ->
+                          let ma = MutableArray arr'#
+                          in (# s'#, ma #))
+
+-- | Check whether the two arrays refer to the same memory block.
+sameMutableArray :: MutableArray s a -> MutableArray s a -> Bool
+{-# INLINE sameMutableArray #-}
+sameMutableArray arr brr
+  = isTrue# (sameMutableArray# (marray# arr) (marray# brr))
+
+-- | Copy a slice of an immutable array to a mutable array.
+copyArray :: PrimMonad m
+          => MutableArray (PrimState m) a    -- ^ destination array
+          -> Int                             -- ^ offset into destination array
+          -> Array a                         -- ^ source array
+          -> Int                             -- ^ offset into source array
+          -> Int                             -- ^ number of elements to copy
+          -> m ()
+{-# INLINE copyArray #-}
+#if __GLASGOW_HASKELL__ > 706
+-- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier
+copyArray (MutableArray dst#) (I# doff#) (Array src#) (I# soff#) (I# len#)
+  = primitive_ (copyArray# src# soff# dst# doff# len#)
+#else
+copyArray !dst !doff !src !soff !len = go 0
+  where
+    go i | i < len = do
+                       x <- indexArrayM src (soff+i)
+                       writeArray dst (doff+i) x
+                       go (i+1)
+         | otherwise = return ()
+#endif
+
+-- | Copy a slice of a mutable array to another array. The two arrays may
+-- not be the same.
+copyMutableArray :: PrimMonad m
+          => MutableArray (PrimState m) a    -- ^ destination array
+          -> Int                             -- ^ offset into destination array
+          -> MutableArray (PrimState m) a    -- ^ source array
+          -> Int                             -- ^ offset into source array
+          -> Int                             -- ^ number of elements to copy
+          -> m ()
+{-# INLINE copyMutableArray #-}
+#if __GLASGOW_HASKELL__ >= 706
+-- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier
+copyMutableArray (MutableArray dst#) (I# doff#)
+                 (MutableArray src#) (I# soff#) (I# len#)
+  = primitive_ (copyMutableArray# src# soff# dst# doff# len#)
+#else
+copyMutableArray !dst !doff !src !soff !len = go 0
+  where
+    go i | i < len = do
+                       x <- readArray src (soff+i)
+                       writeArray dst (doff+i) x
+                       go (i+1)
+         | otherwise = return ()
+#endif
+
+-- | Return a newly allocated Array with the specified subrange of the
+-- provided Array. The provided Array should contain the full subrange
+-- specified by the two Ints, but this is not checked.
+cloneArray :: Array a -- ^ source array
+           -> Int     -- ^ offset into destination array
+           -> Int     -- ^ number of elements to copy
+           -> Array a
+{-# INLINE cloneArray #-}
+cloneArray (Array arr#) (I# off#) (I# len#)
+  = case cloneArray# arr# off# len# of arr'# -> Array arr'#
+
+-- | Return a newly allocated MutableArray. with the specified subrange of
+-- the provided MutableArray. The provided MutableArray should contain the
+-- full subrange specified by the two Ints, but this is not checked.
+cloneMutableArray :: PrimMonad m
+        => MutableArray (PrimState m) a -- ^ source array
+        -> Int                          -- ^ offset into destination array
+        -> Int                          -- ^ number of elements to copy
+        -> m (MutableArray (PrimState m) a)
+{-# INLINE cloneMutableArray #-}
+cloneMutableArray (MutableArray arr#) (I# off#) (I# len#) = primitive
+   (\s# -> case cloneMutableArray# arr# off# len# s# of
+             (# s'#, arr'# #) -> (# s'#, MutableArray arr'# #))
+
+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 = 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 = 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 = 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
+  -- 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 !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 = \ !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 = \ !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 !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 !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)
+  null a = sizeofArray a == 0
+  {-# INLINE null #-}
+  length = sizeofArray
+  {-# INLINE length #-}
+  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 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 #-}
+  product = foldl' (*) 1
+  {-# 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 = 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 = arrayFromListN
+  fromList = arrayFromList
+  toList = toList
+#else
+fromListN :: Int -> [a] -> Array a
+fromListN = arrayFromListN
+
+fromList :: [a] -> Array a
+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
+               = 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 = createArray (sizeofArray a) e (\ !_ -> pure ())
+#endif
+
+instance Applicative Array where
+  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
+             | otherwise = return ()
+     in go 0
+   where sza = sizeofArray a ; szb = sizeofArray b
+  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
+             = 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
+
+instance Alternative Array where
+  empty = emptyArray
+  a1 <|> a2 = createArray (sza1 + sza2) (die "<|>" "impossible") $ \ma ->
+    copyArray ma 0 a1 0 sza1 >> copyArray ma sza1 a2 0 sza2
+   where sza1 = sizeofArray a1 ; sza2 = sizeofArray a2
+  some a | sizeofArray a == 0 = emptyArray
+         | otherwise = die "some" "infinite arrays are not well defined"
+  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
+  (>>) = (*>)
+
+  ary >>= f = collect 0 EmptyStack (la-1)
+   where
+   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)
+
+   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
+  mzero = empty
+  mplus = (<|>)
+
+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
+           = 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 #-}
+
+#if MIN_VERSION_base(4,4,0)
+instance MonadZip Array where
+  mzip aa ab = zipW "mzip" (,) aa ab
+  mzipWith f aa ab = zipW "mzipWith" f aa ab
+  munzip aab = runST $ do
+    let sz = sizeofArray aab
+    ma <- newArray sz (die "munzip" "impossible")
+    mb <- newArray sz (die "munzip" "impossible")
+    let go i | i < sz = do
+          (a, b) <- indexArrayM aab i
+          writeArray ma i a
+          writeArray mb i b
+          go (i+1)
+        go _ = return ()
+    go 0
+    (,) <$> unsafeFreezeArray ma <*> unsafeFreezeArray mb
+#endif
+
+instance MonadFix Array where
+  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
+#endif
+
+instance Monoid (Array a) where
+  mempty = empty
+#if !(MIN_VERSION_base(4,11,0))
+  mappend = (<|>)
+#endif
+  mconcat l = createArray sz (die "mconcat" "impossible") $ \ma ->
+    let go !_  [    ] = return ()
+        go off (a:as) =
+          copyArray ma off a 0 (sizeofArray a) >> go (off + sizeofArray a) as
+     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 = 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 = 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]
+
+fromListConstr :: Constr
+fromListConstr = mkConstr arrayDataType "fromList" [] Prefix
+
+instance Data a => Data (Array a) where
+  toConstr _ = fromListConstr
+  dataTypeOf _ = arrayDataType
+  gunfold k z c = case constrIndex c of
+    1 -> k (z fromList)
+    _ -> error "gunfold"
+  gfoldl f z m = z fromList `f` toList m
+
+instance (Typeable s, Typeable a) => Data (MutableArray s a) where
+  toConstr _ = error "toConstr"
+  gunfold _ _ = error "gunfold"
+  dataTypeOf _ = mkNoRepType "Data.Primitive.Array.MutableArray"

third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/ByteArray.hs

@@ -0,0 +1,549 @@
+{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, UnliftedFFITypes, DeriveDataTypeable #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- |
+-- Module      : Data.Primitive.ByteArray
+-- Copyright   : (c) Roman Leshchinskiy 2009-2012
+-- License     : BSD-style
+--
+-- Maintainer  : Roman Leshchinskiy <rl@cse.unsw.edu.au>
+-- Portability : non-portable
+--
+-- Primitive operations on ByteArrays
+--
+
+module Data.Primitive.ByteArray (
+  -- * Types
+  ByteArray(..), MutableByteArray(..), ByteArray#, MutableByteArray#,
+
+  -- * Allocation
+  newByteArray, newPinnedByteArray, newAlignedPinnedByteArray,
+  resizeMutableByteArray,
+
+  -- * Element access
+  readByteArray, writeByteArray, indexByteArray,
+
+  -- * Constructing
+  byteArrayFromList, byteArrayFromListN,
+
+  -- * Folding
+  foldrByteArray,
+
+  -- * Freezing and thawing
+  unsafeFreezeByteArray, unsafeThawByteArray,
+
+  -- * Block operations
+  copyByteArray, copyMutableByteArray,
+#if __GLASGOW_HASKELL__ >= 708
+  copyByteArrayToAddr, copyMutableByteArrayToAddr,
+#endif
+  moveByteArray,
+  setByteArray, fillByteArray,
+
+  -- * Information
+  sizeofByteArray,
+  sizeofMutableByteArray, getSizeofMutableByteArray, sameMutableByteArray,
+#if __GLASGOW_HASKELL__ >= 802
+  isByteArrayPinned, isMutableByteArrayPinned,
+#endif
+  byteArrayContents, mutableByteArrayContents
+
+) where
+
+import Control.Monad.Primitive
+import Control.Monad.ST
+import Data.Primitive.Types
+
+import Foreign.C.Types
+import Data.Word ( Word8 )
+import GHC.Base ( Int(..) )
+#if __GLASGOW_HASKELL__ >= 708
+import qualified GHC.Exts as Exts ( IsList(..) )
+#endif
+import GHC.Prim
+#if __GLASGOW_HASKELL__ >= 706
+    hiding (setByteArray#)
+#endif
+
+import Data.Typeable ( Typeable )
+import Data.Data ( Data(..) )
+import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType )
+import Numeric
+
+#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 )
+
+-- | Mutable byte arrays associated with a primitive state token
+data MutableByteArray s = MutableByteArray (MutableByteArray# s)
+                                        deriving( Typeable )
+
+-- | Create a new mutable byte array of the specified size in bytes.
+newByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m))
+{-# INLINE newByteArray #-}
+newByteArray (I# n#)
+  = primitive (\s# -> case newByteArray# n# s# of
+                        (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #))
+
+-- | Create a /pinned/ byte array of the specified size in bytes. The garbage
+-- collector is guaranteed not to move it.
+newPinnedByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m))
+{-# INLINE newPinnedByteArray #-}
+newPinnedByteArray (I# n#)
+  = primitive (\s# -> case newPinnedByteArray# n# s# of
+                        (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #))
+
+-- | Create a /pinned/ byte array of the specified size in bytes and with the
+-- given alignment. The garbage collector is guaranteed not to move it.
+newAlignedPinnedByteArray
+  :: 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
+                        (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #))
+
+-- | Yield a pointer to the array's data. This operation is only safe on
+-- /pinned/ byte arrays allocated by 'newPinnedByteArray' or
+-- 'newAlignedPinnedByteArray'.
+byteArrayContents :: ByteArray -> Addr
+{-# INLINE byteArrayContents #-}
+byteArrayContents (ByteArray arr#) = Addr (byteArrayContents# arr#)
+
+-- | Yield a pointer to the array's data. This operation is only safe on
+-- /pinned/ byte arrays allocated by 'newPinnedByteArray' or
+-- 'newAlignedPinnedByteArray'.
+mutableByteArrayContents :: MutableByteArray s -> Addr
+{-# INLINE mutableByteArrayContents #-}
+mutableByteArrayContents (MutableByteArray arr#)
+  = Addr (byteArrayContents# (unsafeCoerce# arr#))
+
+-- | Check if the two arrays refer to the same memory block.
+sameMutableByteArray :: MutableByteArray s -> MutableByteArray s -> Bool
+{-# INLINE sameMutableByteArray #-}
+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
+  :: PrimMonad m => MutableByteArray (PrimState m) -> m ByteArray
+{-# INLINE unsafeFreezeByteArray #-}
+unsafeFreezeByteArray (MutableByteArray arr#)
+  = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of
+                        (# s'#, arr'# #) -> (# s'#, ByteArray arr'# #))
+
+-- | Convert an immutable byte array to a mutable one without copying. The
+-- original array should not be used after the conversion.
+unsafeThawByteArray
+  :: PrimMonad m => ByteArray -> m (MutableByteArray (PrimState m))
+{-# INLINE unsafeThawByteArray #-}
+unsafeThawByteArray (ByteArray arr#)
+  = primitive (\s# -> (# s#, MutableByteArray (unsafeCoerce# arr#) #))
+
+-- | Size of the byte array in bytes.
+sizeofByteArray :: ByteArray -> Int
+{-# INLINE sizeofByteArray #-}
+sizeofByteArray (ByteArray arr#) = I# (sizeofByteArray# arr#)
+
+-- | 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
+{-# INLINE indexByteArray #-}
+indexByteArray (ByteArray arr#) (I# i#) = indexByteArray# arr# i#
+
+-- | Read a primitive value from the byte array. The offset is given in
+-- elements of type @a@ rather than in bytes.
+readByteArray
+  :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> m a
+{-# INLINE readByteArray #-}
+readByteArray (MutableByteArray arr#) (I# i#)
+  = primitive (readByteArray# arr# i#)
+
+-- | Write a primitive value to the byte array. The offset is given in
+-- elements of type @a@ rather than in bytes.
+writeByteArray
+  :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> a -> m ()
+{-# INLINE writeByteArray #-}
+writeByteArray (MutableByteArray arr#) (I# i#) x
+  = primitive_ (writeByteArray# arr# i# x)
+
+-- | Right-fold over the elements of a 'ByteArray'.
+foldrByteArray :: forall a b. (Prim a) => (a -> b -> b) -> b -> ByteArray -> b
+foldrByteArray f z arr = go 0
+  where
+    go i
+      | sizeofByteArray arr > i * sz = f (indexByteArray arr i) (go (i+1))
+      | otherwise                    = z
+    sz = sizeOf (undefined :: a)
+
+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
+
+unI# :: Int -> Int#
+unI# (I# n#) = n#
+
+-- | Copy a slice of an immutable byte array to a mutable byte array.
+copyByteArray
+  :: PrimMonad m => MutableByteArray (PrimState m)
+                                        -- ^ destination array
+                 -> Int                 -- ^ offset into destination array
+                 -> ByteArray           -- ^ source array
+                 -> Int                 -- ^ offset into source array
+                 -> Int                 -- ^ number of bytes to copy
+                 -> m ()
+{-# INLINE copyByteArray #-}
+copyByteArray (MutableByteArray dst#) doff (ByteArray src#) soff sz
+  = primitive_ (copyByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz))
+
+-- | Copy a slice of a mutable byte array into another array. The two slices
+-- may not overlap.
+copyMutableByteArray
+  :: PrimMonad m => MutableByteArray (PrimState m)
+                                        -- ^ destination array
+                 -> Int                 -- ^ offset into destination array
+                 -> MutableByteArray (PrimState m)
+                                        -- ^ source array
+                 -> Int                 -- ^ offset into source array
+                 -> Int                 -- ^ number of bytes to copy
+                 -> m ()
+{-# INLINE copyMutableByteArray #-}
+copyMutableByteArray (MutableByteArray dst#) doff
+                     (MutableByteArray src#) soff sz
+  = primitive_ (copyMutableByteArray# src# (unI# soff) dst# (unI# doff) (unI# 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
+-- overlapping array.
+moveByteArray
+  :: PrimMonad m => MutableByteArray (PrimState m)
+                                        -- ^ destination array
+                 -> Int                 -- ^ offset into destination array
+                 -> MutableByteArray (PrimState m)
+                                        -- ^ source array
+                 -> Int                 -- ^ offset into source array
+                 -> Int                 -- ^ number of bytes to copy
+                 -> m ()
+{-# INLINE moveByteArray #-}
+moveByteArray (MutableByteArray dst#) doff
+              (MutableByteArray src#) soff sz
+  = unsafePrimToPrim
+  $ memmove_mba dst# (fromIntegral doff) src# (fromIntegral soff)
+                     (fromIntegral sz)
+
+-- | Fill a slice of a mutable byte array with a value. The offset and length
+-- are given in elements of type @a@ rather than in bytes.
+setByteArray
+  :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -- ^ array to fill
+                           -> Int                 -- ^ offset into array
+                           -> Int                 -- ^ number of values to fill
+                           -> a                   -- ^ value to fill with
+                           -> m ()
+{-# INLINE setByteArray #-}
+setByteArray (MutableByteArray dst#) (I# doff#) (I# sz#) x
+  = primitive_ (setByteArray# dst# doff# sz# x)
+
+-- | Fill a slice of a mutable byte array with a byte.
+fillByteArray
+  :: PrimMonad m => MutableByteArray (PrimState m)
+                                        -- ^ array to fill
+                 -> Int                 -- ^ offset into array
+                 -> Int                 -- ^ number of bytes to fill
+                 -> Word8               -- ^ byte to fill with
+                 -> m ()
+{-# INLINE fillByteArray #-}
+fillByteArray = setByteArray
+
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memmove"
+  memmove_mba :: MutableByteArray# s -> CInt
+              -> MutableByteArray# s -> CInt
+              -> CSize -> IO ()
+
+instance Data ByteArray where
+  toConstr _ = error "toConstr"
+  gunfold _ _ = error "gunfold"
+  dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.ByteArray"
+
+instance Typeable s => Data (MutableByteArray s) where
+  toConstr _ = error "toConstr"
+  gunfold _ _ = error "gunfold"
+  dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.MutableByteArray"
+
+-- | @since 0.6.3.0
+instance Show ByteArray where
+  showsPrec _ ba =
+      showString "[" . go 0
+    where
+      go i
+        | i < sizeofByteArray ba = comma . showString "0x" . showHex (indexByteArray ba i :: Word8) . go (i+1)
+        | otherwise              = showChar ']'
+        where
+          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
+#if __GLASGOW_HASKELL__ >= 708
+      r -> isTrue# r
+#else
+      1# -> True
+      0# -> False
+#endif
+
+-- | @since 0.6.3.0
+instance Eq ByteArray where
+  ba1@(ByteArray ba1#) == ba2@(ByteArray ba2#)
+    | 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 = 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 = byteArrayFromListN (length xs) xs
+  fromListN = byteArrayFromListN
+#endif
+
+die :: String -> String -> a
+die fun problem = error $ "Data.Primitive.ByteArray." ++ fun ++ ": " ++ problem
+

third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Compat.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE CPP, MagicHash #-}
+
+-- |
+-- Module      : Data.Primitive.Internal.Compat
+-- Copyright   : (c) Roman Leshchinskiy 2011-2012
+-- License     : BSD-style
+--
+-- Maintainer  : Roman Leshchinskiy <rl@cse.unsw.edu.au>
+-- Portability : non-portable
+--
+-- Compatibility functions
+--
+
+module Data.Primitive.Internal.Compat (
+    isTrue#
+  , mkNoRepType
+  ) where
+
+#if MIN_VERSION_base(4,2,0)
+import Data.Data (mkNoRepType)
+#else
+import Data.Data (mkNorepType)
+#endif
+
+#if MIN_VERSION_base(4,7,0)
+import GHC.Exts (isTrue#)
+#endif
+
+
+
+#if !MIN_VERSION_base(4,2,0)
+mkNoRepType = mkNorepType
+#endif
+
+#if !MIN_VERSION_base(4,7,0)
+isTrue# :: Bool -> Bool
+isTrue# b = b
+#endif

third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Operations.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE MagicHash, UnliftedFFITypes #-}
+
+-- |
+-- Module      : Data.Primitive.Internal.Operations
+-- Copyright   : (c) Roman Leshchinskiy 2011-2012
+-- License     : BSD-style
+--
+-- Maintainer  : Roman Leshchinskiy <rl@cse.unsw.edu.au>
+-- Portability : non-portable
+--
+-- Internal operations
+--
+
+
+module Data.Primitive.Internal.Operations (
+  setWord8Array#, setWord16Array#, setWord32Array#,
+  setWord64Array#, setWordArray#,
+  setInt8Array#, setInt16Array#, setInt32Array#,
+  setInt64Array#, setIntArray#,
+  setAddrArray#, setFloatArray#, setDoubleArray#, setWideCharArray#,
+
+  setWord8OffAddr#, setWord16OffAddr#, setWord32OffAddr#,
+  setWord64OffAddr#, setWordOffAddr#,
+  setInt8OffAddr#, setInt16OffAddr#, setInt32OffAddr#,
+  setInt64OffAddr#, setIntOffAddr#,
+  setAddrOffAddr#, setFloatOffAddr#, setDoubleOffAddr#, setWideCharOffAddr#
+) where
+
+import Data.Primitive.MachDeps (Word64_#, Int64_#)
+import Foreign.C.Types
+import GHC.Prim
+
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8"
+  setWord8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16"
+  setWord16Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32"
+  setWord32Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64"
+  setWord64Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word64_# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word"
+  setWordArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8"
+  setInt8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16"
+  setInt16Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32"
+  setInt32Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64"
+  setInt64Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int64_# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word"
+  setIntArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr"
+  setAddrArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Addr# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float"
+  setFloatArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Float# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double"
+  setDoubleArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Double# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char"
+  setWideCharArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Char# -> IO ()
+
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8"
+  setWord8OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16"
+  setWord16OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32"
+  setWord32OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64"
+  setWord64OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word64_# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word"
+  setWordOffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8"
+  setInt8OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16"
+  setInt16OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32"
+  setInt32OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64"
+  setInt64OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int64_# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word"
+  setIntOffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr"
+  setAddrOffAddr# :: Addr# -> CPtrdiff -> CSize -> Addr# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float"
+  setFloatOffAddr# :: Addr# -> CPtrdiff -> CSize -> Float# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double"
+  setDoubleOffAddr# :: Addr# -> CPtrdiff -> CSize -> Double# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char"
+  setWideCharOffAddr# :: Addr# -> CPtrdiff -> CSize -> Char# -> IO ()
+

third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MVar.hs

@@ -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#) #)

third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MachDeps.hs

@@ -0,0 +1,123 @@
+{-# LANGUAGE CPP, MagicHash #-}
+-- |
+-- Module      : Data.Primitive.MachDeps
+-- Copyright   : (c) Roman Leshchinskiy 2009-2012
+-- License     : BSD-style
+--
+-- Maintainer  : Roman Leshchinskiy <rl@cse.unsw.edu.au>
+-- Portability : non-portable
+--
+-- Machine-dependent constants
+--
+
+module Data.Primitive.MachDeps where
+
+#include "MachDeps.h"
+
+import GHC.Prim
+
+sIZEOF_CHAR,
+ aLIGNMENT_CHAR,
+
+ sIZEOF_INT,
+ aLIGNMENT_INT,
+
+ sIZEOF_WORD,
+ aLIGNMENT_WORD,
+
+ sIZEOF_DOUBLE,
+ aLIGNMENT_DOUBLE,
+
+ sIZEOF_FLOAT,
+ aLIGNMENT_FLOAT,
+
+ sIZEOF_PTR,
+ aLIGNMENT_PTR,
+
+ sIZEOF_FUNPTR,
+ aLIGNMENT_FUNPTR,
+
+ sIZEOF_STABLEPTR,
+ aLIGNMENT_STABLEPTR,
+
+ sIZEOF_INT8,
+ aLIGNMENT_INT8,
+
+ sIZEOF_WORD8,
+ aLIGNMENT_WORD8,
+
+ sIZEOF_INT16,
+ aLIGNMENT_INT16,
+
+ sIZEOF_WORD16,
+ aLIGNMENT_WORD16,
+
+ sIZEOF_INT32,
+ aLIGNMENT_INT32,
+
+ sIZEOF_WORD32,
+ aLIGNMENT_WORD32,
+
+ sIZEOF_INT64,
+ aLIGNMENT_INT64,
+
+ sIZEOF_WORD64,
+ aLIGNMENT_WORD64 :: Int
+
+
+sIZEOF_CHAR = SIZEOF_HSCHAR
+aLIGNMENT_CHAR = ALIGNMENT_HSCHAR
+
+sIZEOF_INT = SIZEOF_HSINT
+aLIGNMENT_INT = ALIGNMENT_HSINT
+
+sIZEOF_WORD = SIZEOF_HSWORD
+aLIGNMENT_WORD = ALIGNMENT_HSWORD
+
+sIZEOF_DOUBLE = SIZEOF_HSDOUBLE
+aLIGNMENT_DOUBLE = ALIGNMENT_HSDOUBLE
+
+sIZEOF_FLOAT = SIZEOF_HSFLOAT
+aLIGNMENT_FLOAT = ALIGNMENT_HSFLOAT
+
+sIZEOF_PTR = SIZEOF_HSPTR
+aLIGNMENT_PTR = ALIGNMENT_HSPTR
+
+sIZEOF_FUNPTR = SIZEOF_HSFUNPTR
+aLIGNMENT_FUNPTR = ALIGNMENT_HSFUNPTR
+
+sIZEOF_STABLEPTR = SIZEOF_HSSTABLEPTR
+aLIGNMENT_STABLEPTR = ALIGNMENT_HSSTABLEPTR
+
+sIZEOF_INT8 = SIZEOF_INT8
+aLIGNMENT_INT8 = ALIGNMENT_INT8
+
+sIZEOF_WORD8 = SIZEOF_WORD8
+aLIGNMENT_WORD8 = ALIGNMENT_WORD8
+
+sIZEOF_INT16 = SIZEOF_INT16
+aLIGNMENT_INT16 = ALIGNMENT_INT16
+
+sIZEOF_WORD16 = SIZEOF_WORD16
+aLIGNMENT_WORD16 = ALIGNMENT_WORD16
+
+sIZEOF_INT32 = SIZEOF_INT32
+aLIGNMENT_INT32 = ALIGNMENT_INT32
+
+sIZEOF_WORD32 = SIZEOF_WORD32
+aLIGNMENT_WORD32 = ALIGNMENT_WORD32
+
+sIZEOF_INT64 = SIZEOF_INT64
+aLIGNMENT_INT64 = ALIGNMENT_INT64
+
+sIZEOF_WORD64 = SIZEOF_WORD64
+aLIGNMENT_WORD64 = ALIGNMENT_WORD64
+
+#if WORD_SIZE_IN_BITS == 32
+type Word64_# = Word64#
+type Int64_# = Int64#
+#else
+type Word64_# = Word#
+type Int64_# = Int#
+#endif
+

third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MutVar.hs

@@ -0,0 +1,86 @@
+{-# LANGUAGE MagicHash, UnboxedTuples, DeriveDataTypeable #-}
+
+-- |
+-- Module      : Data.Primitive.MutVar
+-- Copyright   : (c) Justin Bonnar 2011, Roman Leshchinskiy 2011-2012
+-- License     : BSD-style
+--
+-- Maintainer  : Roman Leshchinskiy <rl@cse.unsw.edu.au>
+-- Portability : non-portable
+--
+-- Primitive boxed mutable variables
+--
+
+module Data.Primitive.MutVar (
+  MutVar(..),
+
+  newMutVar,
+  readMutVar,
+  writeMutVar,
+
+  atomicModifyMutVar,
+  atomicModifyMutVar',
+  modifyMutVar,
+  modifyMutVar'
+) where
+
+import Control.Monad.Primitive ( PrimMonad(..), primitive_ )
+import GHC.Prim ( MutVar#, sameMutVar#, newMutVar#,
+                  readMutVar#, writeMutVar#, atomicModifyMutVar# )
+import Data.Primitive.Internal.Compat ( isTrue# )
+import Data.Typeable ( Typeable )
+
+-- | A 'MutVar' behaves like a single-element mutable array associated
+-- with a primitive state token.
+data MutVar s a = MutVar (MutVar# s a)
+  deriving ( Typeable )
+
+instance Eq (MutVar s a) where
+  MutVar mva# == MutVar mvb# = isTrue# (sameMutVar# mva# mvb#)
+
+-- | Create a new 'MutVar' with the specified initial value
+newMutVar :: PrimMonad m => a -> m (MutVar (PrimState m) a)
+{-# INLINE newMutVar #-}
+newMutVar initialValue = primitive $ \s# ->
+  case newMutVar# initialValue s# of
+    (# s'#, mv# #) -> (# s'#, MutVar mv# #)
+
+-- | Read the value of a 'MutVar'
+readMutVar :: PrimMonad m => MutVar (PrimState m) a -> m a
+{-# INLINE readMutVar #-}
+readMutVar (MutVar mv#) = primitive (readMutVar# mv#)
+
+-- | Write a new value into a 'MutVar'
+writeMutVar :: PrimMonad m => MutVar (PrimState m) a -> a -> m ()
+{-# INLINE writeMutVar #-}
+writeMutVar (MutVar mv#) newValue = primitive_ (writeMutVar# mv# newValue)
+
+-- | Atomically mutate the contents of a 'MutVar'
+atomicModifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> (a,b)) -> m b
+{-# INLINE atomicModifyMutVar #-}
+atomicModifyMutVar (MutVar mv#) f = primitive $ atomicModifyMutVar# mv# f
+
+-- | Strict version of 'atomicModifyMutVar'. This forces both the value stored
+-- in the 'MutVar' as well as the value returned.
+atomicModifyMutVar' :: PrimMonad m => MutVar (PrimState m) a -> (a -> (a, b)) -> m b
+{-# INLINE atomicModifyMutVar' #-}
+atomicModifyMutVar' mv f = do
+  b <- atomicModifyMutVar mv force
+  b `seq` return b
+  where
+    force x = let (a, b) = f x in (a, a `seq` b)
+
+-- | Mutate the contents of a 'MutVar'
+modifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m ()
+{-# INLINE modifyMutVar #-}
+modifyMutVar (MutVar mv#) g = primitive_ $ \s# ->
+  case readMutVar# mv# s# of
+    (# s'#, a #) -> writeMutVar# mv# (g a) s'#
+
+-- | Strict version of 'modifyMutVar'
+modifyMutVar' :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m ()
+{-# INLINE modifyMutVar' #-}
+modifyMutVar' (MutVar mv#) g = primitive_ $ \s# ->
+  case readMutVar# mv# s# of
+    (# s'#, a #) -> let a' = g a in a' `seq` writeMutVar# mv# a' s'#
+

third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/PrimArray.hs

@@ -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.
+-}
+
+

third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Ptr.hs

@@ -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

third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/SmallArray.hs

@@ -0,0 +1,967 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE BangPatterns #-}
+
+-- |
+-- Module : Data.Primitive.SmallArray
+-- Copyright: (c) 2015 Dan Doel
+-- License: BSD3
+--
+-- Maintainer: libraries@haskell.org
+-- Portability: non-portable
+--
+-- Small arrays are boxed (im)mutable arrays.
+--
+-- The underlying structure of the 'Array' type contains a card table, allowing
+-- segments of the array to be marked as having been mutated. This allows the
+-- garbage collector to only re-traverse segments of the array that have been
+-- marked during certain phases, rather than having to traverse the entire
+-- array.
+--
+-- 'SmallArray' lacks this table. This means that it takes up less memory and
+-- has slightly faster writes. It is also more efficient during garbage
+-- collection so long as the card table would have a single entry covering the
+-- entire array. These advantages make them suitable for use as arrays that are
+-- known to be small.
+--
+-- The card size is 128, so for uses much larger than that, 'Array' would likely
+-- be superior.
+--
+-- The underlying type, 'SmallArray#', was introduced in GHC 7.10, so prior to
+-- that version, this module simply implements small arrays as 'Array'.
+
+module Data.Primitive.SmallArray
+  ( SmallArray(..)
+  , SmallMutableArray(..)
+  , newSmallArray
+  , readSmallArray
+  , writeSmallArray
+  , copySmallArray
+  , copySmallMutableArray
+  , indexSmallArray
+  , indexSmallArrayM
+  , indexSmallArray##
+  , cloneSmallArray
+  , cloneSmallMutableArray
+  , freezeSmallArray
+  , unsafeFreezeSmallArray
+  , thawSmallArray
+  , runSmallArray
+  , unsafeThawSmallArray
+  , sizeofSmallArray
+  , sizeofSmallMutableArray
+  , smallArrayFromList
+  , smallArrayFromListN
+  , mapSmallArray'
+  , traverseSmallArrayP
+  ) where
+
+
+#if (__GLASGOW_HASKELL__ >= 710)
+#define HAVE_SMALL_ARRAY 1
+#endif
+
+#if MIN_VERSION_base(4,7,0)
+import GHC.Exts hiding (toList)
+import qualified GHC.Exts
+#endif
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Fix
+import Control.Monad.Primitive
+import Control.Monad.ST
+import Control.Monad.Zip
+import Data.Data
+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.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
+#else
+newtype SmallArray a = SmallArray (Array a) deriving
+  ( Eq
+  , Ord
+  , Show
+  , Read
+  , Foldable
+  , Traversable
+  , Functor
+  , Applicative
+  , Alternative
+  , Monad
+  , MonadPlus
+  , MonadZip
+  , 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)
+instance IsList (SmallArray a) where
+  type Item (SmallArray a) = a
+  fromListN n l = SmallArray (fromListN n l)
+  fromList l = SmallArray (fromList l)
+  toList a = Foldable.toList a
+#endif
+#endif
+
+#if HAVE_SMALL_ARRAY
+data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a)
+  deriving Typeable
+#else
+newtype SmallMutableArray s a = SmallMutableArray (MutableArray s a)
+  deriving (Eq, Typeable)
+#endif
+
+-- | Create a new small mutable array.
+newSmallArray
+  :: PrimMonad m
+  => Int -- ^ size
+  -> a   -- ^ initial contents
+  -> m (SmallMutableArray (PrimState m) a)
+#if HAVE_SMALL_ARRAY
+newSmallArray (I# i#) x = primitive $ \s ->
+  case newSmallArray# i# x s of
+    (# s', sma# #) -> (# s', SmallMutableArray sma# #)
+#else
+newSmallArray n e = SmallMutableArray `liftM` newArray n e
+#endif
+{-# INLINE newSmallArray #-}
+
+-- | Read the element at a given index in a mutable array.
+readSmallArray
+  :: PrimMonad m
+  => SmallMutableArray (PrimState m) a -- ^ array
+  -> Int                               -- ^ index
+  -> m a
+#if HAVE_SMALL_ARRAY
+readSmallArray (SmallMutableArray sma#) (I# i#) =
+  primitive $ readSmallArray# sma# i#
+#else
+readSmallArray (SmallMutableArray a) = readArray a
+#endif
+{-# INLINE readSmallArray #-}
+
+-- | Write an element at the given idex in a mutable array.
+writeSmallArray
+  :: PrimMonad m
+  => SmallMutableArray (PrimState m) a -- ^ array
+  -> Int                               -- ^ index
+  -> a                                 -- ^ new element
+  -> m ()
+#if HAVE_SMALL_ARRAY
+writeSmallArray (SmallMutableArray sma#) (I# i#) x =
+  primitive_ $ writeSmallArray# sma# i# x
+#else
+writeSmallArray (SmallMutableArray a) = writeArray a
+#endif
+{-# INLINE writeSmallArray #-}
+
+-- | Look up an element in an immutable array.
+--
+-- The purpose of returning a result using a monad is to allow the caller to
+-- avoid retaining references to the array. Evaluating the return value will
+-- cause the array lookup to be performed, even though it may not require the
+-- element of the array to be evaluated (which could throw an exception). For
+-- instance:
+--
+-- > data Box a = Box a
+-- > ...
+-- >
+-- > f sa = case indexSmallArrayM sa 0 of
+-- >   Box x -> ...
+--
+-- 'x' is not a closure that references 'sa' as it would be if we instead
+-- wrote:
+--
+-- > let x = indexSmallArray sa 0
+--
+-- And does not prevent 'sa' from being garbage collected.
+--
+-- Note that 'Identity' is not adequate for this use, as it is a newtype, and
+-- cannot be evaluated without evaluating the element.
+indexSmallArrayM
+  :: Monad m
+  => SmallArray a -- ^ array
+  -> Int          -- ^ index
+  -> m a
+#if HAVE_SMALL_ARRAY
+indexSmallArrayM (SmallArray sa#) (I# i#) =
+  case indexSmallArray# sa# i# of
+    (# x #) -> pure x
+#else
+indexSmallArrayM (SmallArray a) = indexArrayM a
+#endif
+{-# INLINE indexSmallArrayM #-}
+
+-- | Look up an element in an immutable array.
+indexSmallArray
+  :: SmallArray a -- ^ array
+  -> Int          -- ^ index
+  -> a
+#if HAVE_SMALL_ARRAY
+indexSmallArray sa i = runIdentity $ indexSmallArrayM sa i
+#else
+indexSmallArray (SmallArray a) = indexArray a
+#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
+  -> Int          -- ^ offset
+  -> Int          -- ^ length
+  -> SmallArray a
+#if HAVE_SMALL_ARRAY
+cloneSmallArray (SmallArray sa#) (I# i#) (I# j#) =
+  SmallArray (cloneSmallArray# sa# i# j#)
+#else
+cloneSmallArray (SmallArray a) i j = SmallArray $ cloneArray a i j
+#endif
+{-# INLINE cloneSmallArray #-}
+
+-- | Create a copy of a slice of a mutable array.
+cloneSmallMutableArray
+  :: PrimMonad m
+  => SmallMutableArray (PrimState m) a -- ^ source
+  -> Int                               -- ^ offset
+  -> Int                               -- ^ length
+  -> m (SmallMutableArray (PrimState m) a)
+#if HAVE_SMALL_ARRAY
+cloneSmallMutableArray (SmallMutableArray sma#) (I# o#) (I# l#) =
+  primitive $ \s -> case cloneSmallMutableArray# sma# o# l# s of
+    (# s', smb# #) -> (# s', SmallMutableArray smb# #)
+#else
+cloneSmallMutableArray (SmallMutableArray ma) i j =
+  SmallMutableArray `liftM` cloneMutableArray ma i j
+#endif
+{-# INLINE cloneSmallMutableArray #-}
+
+-- | Create an immutable array corresponding to a slice of a mutable array.
+--
+-- This operation copies the portion of the array to be frozen.
+freezeSmallArray
+  :: PrimMonad m
+  => SmallMutableArray (PrimState m) a -- ^ source
+  -> Int                               -- ^ offset
+  -> Int                               -- ^ length
+  -> m (SmallArray a)
+#if HAVE_SMALL_ARRAY
+freezeSmallArray (SmallMutableArray sma#) (I# i#) (I# j#) =
+  primitive $ \s -> case freezeSmallArray# sma# i# j# s of
+    (# s', sa# #) -> (# s', SmallArray sa# #)
+#else
+freezeSmallArray (SmallMutableArray ma) i j =
+  SmallArray `liftM` freezeArray ma i j
+#endif
+{-# INLINE freezeSmallArray #-}
+
+-- | Render a mutable array immutable.
+--
+-- This operation performs no copying, so care must be taken not to modify the
+-- input array after freezing.
+unsafeFreezeSmallArray
+  :: PrimMonad m => SmallMutableArray (PrimState m) a -> m (SmallArray a)
+#if HAVE_SMALL_ARRAY
+unsafeFreezeSmallArray (SmallMutableArray sma#) =
+  primitive $ \s -> case unsafeFreezeSmallArray# sma# s of
+    (# s', sa# #) -> (# s', SmallArray sa# #)
+#else
+unsafeFreezeSmallArray (SmallMutableArray ma) =
+  SmallArray `liftM` unsafeFreezeArray ma
+#endif
+{-# INLINE unsafeFreezeSmallArray #-}
+
+-- | Create a mutable array corresponding to a slice of an immutable array.
+--
+-- This operation copies the portion of the array to be thawed.
+thawSmallArray
+  :: PrimMonad m
+  => SmallArray a -- ^ source
+  -> Int          -- ^ offset
+  -> Int          -- ^ length
+  -> m (SmallMutableArray (PrimState m) a)
+#if HAVE_SMALL_ARRAY
+thawSmallArray (SmallArray sa#) (I# o#) (I# l#) =
+  primitive $ \s -> case thawSmallArray# sa# o# l# s of
+    (# s', sma# #) -> (# s', SmallMutableArray sma# #)
+#else
+thawSmallArray (SmallArray a) off len =
+  SmallMutableArray `liftM` thawArray a off len
+#endif
+{-# INLINE thawSmallArray #-}
+
+-- | Render an immutable array mutable.
+--
+-- This operation performs no copying, so care must be taken with its use.
+unsafeThawSmallArray
+  :: PrimMonad m => SmallArray a -> m (SmallMutableArray (PrimState m) a)
+#if HAVE_SMALL_ARRAY
+unsafeThawSmallArray (SmallArray sa#) =
+  primitive $ \s -> case unsafeThawSmallArray# sa# s of
+    (# s', sma# #) -> (# s', SmallMutableArray sma# #)
+#else
+unsafeThawSmallArray (SmallArray a) = SmallMutableArray `liftM` unsafeThawArray a
+#endif
+{-# INLINE unsafeThawSmallArray #-}
+
+-- | Copy a slice of an immutable array into a mutable array.
+copySmallArray
+  :: PrimMonad m
+  => SmallMutableArray (PrimState m) a -- ^ destination
+  -> Int                               -- ^ destination offset
+  -> SmallArray a                      -- ^ source
+  -> Int                               -- ^ source offset
+  -> Int                               -- ^ length
+  -> m ()
+#if HAVE_SMALL_ARRAY
+copySmallArray
+  (SmallMutableArray dst#) (I# do#) (SmallArray src#) (I# so#) (I# l#) =
+    primitive_ $ copySmallArray# src# so# dst# do# l#
+#else
+copySmallArray (SmallMutableArray dst) i (SmallArray src) = copyArray dst i src
+#endif
+{-# INLINE copySmallArray #-}
+
+-- | Copy a slice of one mutable array into another.
+copySmallMutableArray
+  :: PrimMonad m
+  => SmallMutableArray (PrimState m) a -- ^ destination
+  -> Int                               -- ^ destination offset
+  -> SmallMutableArray (PrimState m) a -- ^ source
+  -> Int                               -- ^ source offset
+  -> Int                               -- ^ length
+  -> m ()
+#if HAVE_SMALL_ARRAY
+copySmallMutableArray
+  (SmallMutableArray dst#) (I# do#)
+  (SmallMutableArray src#) (I# so#)
+  (I# l#) =
+    primitive_ $ copySmallMutableArray# src# so# dst# do# l#
+#else
+copySmallMutableArray (SmallMutableArray dst) i (SmallMutableArray src) =
+  copyMutableArray dst i src
+#endif
+{-# INLINE copySmallMutableArray #-}
+
+sizeofSmallArray :: SmallArray a -> Int
+#if HAVE_SMALL_ARRAY
+sizeofSmallArray (SmallArray sa#) = I# (sizeofSmallArray# sa#)
+#else
+sizeofSmallArray (SmallArray a) = sizeofArray a
+#endif
+{-# INLINE sizeofSmallArray #-}
+
+sizeofSmallMutableArray :: SmallMutableArray s a -> Int
+#if HAVE_SMALL_ARRAY
+sizeofSmallMutableArray (SmallMutableArray sa#) =
+  I# (sizeofSmallMutableArray# sa#)
+#else
+sizeofSmallMutableArray (SmallMutableArray ma) = sizeofMutableArray ma
+#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
+
+emptySmallArray :: SmallArray a
+emptySmallArray =
+  runST $ newSmallArray 0 (die "emptySmallArray" "impossible")
+            >>= unsafeFreezeSmallArray
+{-# NOINLINE emptySmallArray #-}
+
+
+infixl 1 ?
+(?) :: (a -> b -> c) -> (b -> a -> c)
+(?) = flip
+{-# INLINE (?) #-}
+
+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 = 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 sa1 sa2 = smallArrayLiftCompare compare sa1 sa2
+
+instance Foldable SmallArray where
+  -- 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 #-}
+  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 #-}
+  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 = \ !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 #-}
+  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 = 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) $ do
+        x <- indexSmallArrayM sa i
+        writeSmallArray smb i (f x) *> go (i+1)
+  {-# INLINE fmap #-}
+
+  x <$ sa = createSmallArray (length sa) x noOp
+
+instance Applicative SmallArray where
+  pure x = createSmallArray 1 x noOp
+
+  sa *> sb = createSmallArray (la*lb) (die "*>" "impossible") $ \smb ->
+    fix ? 0 $ \go i ->
+      when (i < la) $
+        copySmallArray smb 0 sb 0 lb *> go (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
+
+  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
+
+  sl <|> sr =
+    createSmallArray (length sl + length sr) (die "<|>" "impossible") $ \sma ->
+      copySmallArray sma 0 sl 0 (length sl)
+        *> copySmallArray sma (length sl) sr 0 (length sr)
+
+  many sa | null sa   = pure []
+          | otherwise = die "many" "infinite arrays are not well defined"
+
+  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 EmptyStack (la-1)
+   where
+   la = length sa
+   collect sz stk i
+     | i < 0 = createSmallArray sz (die ">>=" "impossible") $ fill 0 stk
+     | (# 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 _ EmptyStack _ = return ()
+   fill off (PushArray sb sbs) smb =
+     copySmallArray smb off sb 0 (length sb)
+       *> fill (off + length sb) sbs smb
+
+  fail _ = emptySmallArray
+
+instance MonadPlus SmallArray where
+  mzero = empty
+  mplus = (<|>)
+
+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) $ do
+      x <- indexSmallArrayM sa i
+      y <- indexSmallArrayM sb i
+      writeSmallArray mc i (f x y)
+      go (i+1)
+{-# INLINE zipW #-}
+
+instance MonadZip SmallArray where
+  mzip = zipW "mzip" (,)
+  mzipWith = zipW "mzipWith"
+  {-# INLINE mzipWith #-}
+  munzip sab = runST $ do
+    let sz = length sab
+    sma <- newSmallArray sz $ die "munzip" "impossible"
+    smb <- newSmallArray sz $ die "munzip" "impossible"
+    fix ? 0 $ \go i ->
+      when (i < sz) $ case indexSmallArray sab i of
+        (x, y) -> do writeSmallArray sma i x
+                     writeSmallArray smb i y
+                     go $ i+1
+    (,) <$> unsafeFreezeSmallArray sma
+        <*> unsafeFreezeSmallArray smb
+
+instance MonadFix SmallArray where
+  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
+#endif
+
+instance Monoid (SmallArray a) where
+  mempty = empty
+#if !(MIN_VERSION_base(4,11,0))
+  mappend = (<|>)
+#endif
+  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 = 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 = 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
+  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]
+
+fromListConstr :: Constr
+fromListConstr = mkConstr smallArrayDataType "fromList" [] Prefix
+
+instance Data a => Data (SmallArray a) where
+  toConstr _ = fromListConstr
+  dataTypeOf _ = smallArrayDataType
+  gunfold k z c = case constrIndex c of
+    1 -> k (z fromList)
+    _ -> die "gunfold" "SmallArray"
+  gfoldl f z m = z fromList `f` toList m
+
+instance (Typeable s, Typeable a) => Data (SmallMutableArray s a) where
+  toConstr _ = die "toConstr" "SmallMutableArray"
+  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

third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Types.hs

@@ -0,0 +1,395 @@
+{-# 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
+-- License     : BSD-style
+--
+-- Maintainer  : Roman Leshchinskiy <rl@cse.unsw.edu.au>
+-- Portability : non-portable
+--
+-- Basic types and classes for primitive array operations
+--
+
+module Data.Primitive.Types (
+  Prim(..),
+  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(..),
+  )
+import GHC.Float (
+    Float(..), Double(..)
+  )
+import GHC.Word (
+    Word(..), Word8(..), Word16(..), Word32(..), Word64(..)
+  )
+import GHC.Int (
+    Int8(..), Int16(..), Int32(..), Int64(..)
+  )
+
+import GHC.Ptr (
+    Ptr(..), FunPtr(..)
+  )
+
+import GHC.Prim
+#if __GLASGOW_HASKELL__ >= 706
+    hiding (setByteArray#)
+#endif
+
+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#)
+
+instance Ord Addr where
+  Addr a# > Addr b# = isTrue# (gtAddr# a# b#)
+  Addr a# >= Addr b# = isTrue# (geAddr# a# b#)
+  Addr a# < Addr b# = isTrue# (ltAddr# a# b#)
+  Addr a# <= Addr b# = isTrue# (leAddr# a# b#)
+
+instance Data Addr where
+  toConstr _ = error "toConstr"
+  gunfold _ _ = error "gunfold"
+  dataTypeOf _ = mkNoRepType "Data.Primitive.Types.Addr"
+
+
+-- | Class of types supporting primitive array operations
+class Prim a where
+
+  -- | Size of values of type @a@. The argument is not used.
+  sizeOf#    :: a -> Int#
+
+  -- | Alignment of values of type @a@. The argument is not used.
+  alignment# :: a -> Int#
+
+  -- | Read a value from the array. The offset is in elements of type
+  -- @a@ rather than in bytes.
+  indexByteArray# :: ByteArray# -> Int# -> a
+
+  -- | Read a value from the mutable array. The offset is in elements of type
+  -- @a@ rather than in bytes.
+  readByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, a #)
+
+  -- | Write a value to the mutable array. The offset is in elements of type
+  -- @a@ rather than in bytes.
+  writeByteArray# :: MutableByteArray# s -> Int# -> a -> State# s -> State# s
+
+  -- | Fill a slice of the mutable array with a value. The offset and length
+  -- of the chunk are in elements of type @a@ rather than in bytes.
+  setByteArray# :: MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s
+
+  -- | Read a value from a memory position given by an address and an offset.
+  -- The memory block the address refers to must be immutable. The offset is in
+  -- elements of type @a@ rather than in bytes.
+  indexOffAddr# :: Addr# -> Int# -> a
+
+  -- | Read a value from a memory position given by an address and an offset.
+  -- The offset is in elements of type @a@ rather than in bytes.
+  readOffAddr# :: Addr# -> Int# -> State# s -> (# State# s, a #)
+
+  -- | Write a value to a memory position given by an address and an offset.
+  -- The offset is in elements of type @a@ rather than in bytes.
+  writeOffAddr# :: Addr# -> Int# -> a -> State# s -> State# s
+
+  -- | Fill a memory block given by an address, an offset and a length.
+  -- The offset and length are in elements of type @a@ rather than in bytes.
+  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                                           \
+; alignment# _ = unI# align                                     \
+; indexByteArray# arr# i# = ctr (idx_arr arr# i#)               \
+; readByteArray#  arr# i# s# = case rd_arr arr# i# s# of        \
+                        { (# s1#, x# #) -> (# s1#, ctr x# #) }  \
+; writeByteArray# arr# i# (ctr x#) s# = wr_arr arr# i# x# s#    \
+; setByteArray# arr# i# n# (ctr x#) s#                          \
+    = let { i = fromIntegral (I# i#)                            \
+          ; n = fromIntegral (I# n#)                            \
+          } in                                                  \
+      case unsafeCoerce# (internal (set_arr arr# i n x#)) s# of \
+        { (# s1#, _ #) -> s1# }                                 \
+                                                                \
+; indexOffAddr# addr# i# = ctr (idx_addr addr# i#)              \
+; readOffAddr#  addr# i# s# = case rd_addr addr# i# s# of       \
+                        { (# s1#, x# #) -> (# s1#, ctr x# #) }  \
+; writeOffAddr# addr# i# (ctr x#) s# = wr_addr addr# i# x# s#   \
+; setOffAddr# addr# i# n# (ctr x#) s#                           \
+    = let { i = fromIntegral (I# i#)                            \
+          ; n = fromIntegral (I# n#)                            \
+          } in                                                  \
+      case unsafeCoerce# (internal (set_addr addr# i n x#)) s# of \
+        { (# s1#, _ #) -> s1# }                                 \
+; {-# INLINE sizeOf# #-}                                        \
+; {-# INLINE alignment# #-}                                     \
+; {-# INLINE indexByteArray# #-}                                \
+; {-# INLINE readByteArray# #-}                                 \
+; {-# INLINE writeByteArray# #-}                                \
+; {-# INLINE setByteArray# #-}                                  \
+; {-# INLINE indexOffAddr# #-}                                  \
+; {-# INLINE readOffAddr# #-}                                   \
+; {-# INLINE writeOffAddr# #-}                                  \
+; {-# INLINE setOffAddr# #-}                                    \
+}
+
+unI# :: Int -> Int#
+unI# (I# n#) = n#
+
+derivePrim(Word, W#, sIZEOF_WORD, aLIGNMENT_WORD,
+           indexWordArray#, readWordArray#, writeWordArray#, setWordArray#,
+           indexWordOffAddr#, readWordOffAddr#, writeWordOffAddr#, setWordOffAddr#)
+derivePrim(Word8, W8#, sIZEOF_WORD8, aLIGNMENT_WORD8,
+           indexWord8Array#, readWord8Array#, writeWord8Array#, setWord8Array#,
+           indexWord8OffAddr#, readWord8OffAddr#, writeWord8OffAddr#, setWord8OffAddr#)
+derivePrim(Word16, W16#, sIZEOF_WORD16, aLIGNMENT_WORD16,
+           indexWord16Array#, readWord16Array#, writeWord16Array#, setWord16Array#,
+           indexWord16OffAddr#, readWord16OffAddr#, writeWord16OffAddr#, setWord16OffAddr#)
+derivePrim(Word32, W32#, sIZEOF_WORD32, aLIGNMENT_WORD32,
+           indexWord32Array#, readWord32Array#, writeWord32Array#, setWord32Array#,
+           indexWord32OffAddr#, readWord32OffAddr#, writeWord32OffAddr#, setWord32OffAddr#)
+derivePrim(Word64, W64#, sIZEOF_WORD64, aLIGNMENT_WORD64,
+           indexWord64Array#, readWord64Array#, writeWord64Array#, setWord64Array#,
+           indexWord64OffAddr#, readWord64OffAddr#, writeWord64OffAddr#, setWord64OffAddr#)
+derivePrim(Int, I#, sIZEOF_INT, aLIGNMENT_INT,
+           indexIntArray#, readIntArray#, writeIntArray#, setIntArray#,
+           indexIntOffAddr#, readIntOffAddr#, writeIntOffAddr#, setIntOffAddr#)
+derivePrim(Int8, I8#, sIZEOF_INT8, aLIGNMENT_INT8,
+           indexInt8Array#, readInt8Array#, writeInt8Array#, setInt8Array#,
+           indexInt8OffAddr#, readInt8OffAddr#, writeInt8OffAddr#, setInt8OffAddr#)
+derivePrim(Int16, I16#, sIZEOF_INT16, aLIGNMENT_INT16,
+           indexInt16Array#, readInt16Array#, writeInt16Array#, setInt16Array#,
+           indexInt16OffAddr#, readInt16OffAddr#, writeInt16OffAddr#, setInt16OffAddr#)
+derivePrim(Int32, I32#, sIZEOF_INT32, aLIGNMENT_INT32,
+           indexInt32Array#, readInt32Array#, writeInt32Array#, setInt32Array#,
+           indexInt32OffAddr#, readInt32OffAddr#, writeInt32OffAddr#, setInt32OffAddr#)
+derivePrim(Int64, I64#, sIZEOF_INT64, aLIGNMENT_INT64,
+           indexInt64Array#, readInt64Array#, writeInt64Array#, setInt64Array#,
+           indexInt64OffAddr#, readInt64OffAddr#, writeInt64OffAddr#, setInt64OffAddr#)
+derivePrim(Float, F#, sIZEOF_FLOAT, aLIGNMENT_FLOAT,
+           indexFloatArray#, readFloatArray#, writeFloatArray#, setFloatArray#,
+           indexFloatOffAddr#, readFloatOffAddr#, writeFloatOffAddr#, setFloatOffAddr#)
+derivePrim(Double, D#, sIZEOF_DOUBLE, aLIGNMENT_DOUBLE,
+           indexDoubleArray#, readDoubleArray#, writeDoubleArray#, setDoubleArray#,
+           indexDoubleOffAddr#, readDoubleOffAddr#, writeDoubleOffAddr#, setDoubleOffAddr#)
+derivePrim(Char, C#, sIZEOF_CHAR, aLIGNMENT_CHAR,
+           indexWideCharArray#, readWideCharArray#, writeWideCharArray#, setWideCharArray#,
+           indexWideCharOffAddr#, readWideCharOffAddr#, writeWideCharOffAddr#, setWideCharOffAddr#)
+derivePrim(Addr, Addr, sIZEOF_PTR, aLIGNMENT_PTR,
+           indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#,
+           indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#)
+derivePrim(Ptr a, Ptr, sIZEOF_PTR, aLIGNMENT_PTR,
+           indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#,
+           indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#)
+derivePrim(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

third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/UnliftedArray.hs

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