Use data-array-byte package to provide ByteArray for GHC < 9.4

Author: Bodigrim

Data/Primitive/ByteArray.hs

@@ -77,91 +77,11 @@ import Data.Word ( Word8 )
 import qualified GHC.Exts as Exts
 import GHC.Exts hiding (setByteArray#)
 
-#if MIN_VERSION_base(4,17,0)
-
-import Data.Array.Byte (ByteArray(..), MutableByteArray(..))
-
-#else
-
-import Control.DeepSeq
-import Data.Bits ( (.&.), unsafeShiftR )
-import GHC.Show ( intToDigit )
-import Data.Typeable ( Typeable )
-import Data.Data ( Data(..), mkNoRepType )
-import qualified Language.Haskell.TH.Syntax as TH
-import qualified Language.Haskell.TH.Lib as TH
-import qualified Data.Semigroup as SG
-import qualified Data.Foldable as F
-import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO)
-
--- | 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 )
-
--- | Respects array pinnedness for GHC >= 8.2
-instance TH.Lift ByteArray where
-#if MIN_VERSION_template_haskell(2,17,0)
-  liftTyped ba = TH.unsafeCodeCoerce (TH.lift ba)
-#elif MIN_VERSION_template_haskell(2,16,0)
-  liftTyped ba = TH.unsafeTExpCoerce (TH.lift ba)
+#if __GLASGOW_HASKELL__ < 804
+import System.IO.Unsafe (unsafeDupablePerformIO)
 #endif
 
-  lift ba =
-    TH.appE
-      (if small
-         then [| fromLitAddrSmall# pinned len |]
-         else [| fromLitAddrLarge# pinned len |])
-      (TH.litE (TH.stringPrimL (toList ba)))
-    where
-      -- Pin it if the original was pinned; otherwise don't. This seems more
-      -- logical to me than the alternatives. Anyone who wants a different
-      -- pinnedness can just copy the compile-time byte array to one that
-      -- matches what they want at run-time.
-#if __GLASGOW_HASKELL__ >= 802
-      pinned = isByteArrayPinned ba
-#else
-      pinned = True
-#endif
-      len = sizeofByteArray ba
-      small = len <= 2048
-
--- I don't think inlining these can be very helpful, so let's not
--- do it.
-{-# NOINLINE fromLitAddrSmall# #-}
-fromLitAddrSmall# :: Bool -> Int -> Addr# -> ByteArray
-fromLitAddrSmall# pinned len ptr = inline (fromLitAddr# True pinned len ptr)
-
-{-# NOINLINE fromLitAddrLarge# #-}
-fromLitAddrLarge# :: Bool -> Int -> Addr# -> ByteArray
-fromLitAddrLarge# pinned len ptr = inline (fromLitAddr# False pinned len ptr)
-
-fromLitAddr# :: Bool -> Bool -> Int -> Addr# -> ByteArray
-fromLitAddr# small pinned !len !ptr = upIO $ do
-  mba <- if pinned
-         then newPinnedByteArray len
-         else newByteArray len
-  copyPtrToMutableByteArray mba 0 (Ptr ptr :: Ptr Word8) len
-  unsafeFreezeByteArray mba
-  where
-    -- We don't care too much about duplication if the byte arrays are
-    -- small. If they're large, we do. Since we don't allocate while
-    -- we copy (we do it with a primop!), I don't believe the thunk
-    -- deduplication mechanism can help us if two threads just happen
-    -- to try to build the ByteArray at the same time.
-    upIO
-      | small = unsafeDupablePerformIO
-      | otherwise = unsafePerformIO
-
-instance NFData ByteArray where
-  rnf (ByteArray _) = ()
-
-instance NFData (MutableByteArray s) where
-  rnf (MutableByteArray _) = ()
-
-#endif
+import Data.Array.Byte (ByteArray(..), MutableByteArray(..))
 
 -- | Create a new mutable byte array of the specified size in bytes.
 --
@@ -599,65 +519,6 @@ foreign import ccall unsafe "primitive-memops.h hsprimitive_memmove"
               -> MutableByteArray# s -> CPtrdiff
               -> CSize -> IO ()
 
-#if !MIN_VERSION_base(4,17,0)
-
-instance Eq (MutableByteArray s) where
-  (==) = sameMutableByteArray
-
-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
---
--- Behavior changed in 0.7.2.0. Before 0.7.2.0, this instance rendered
--- 8-bit words less than 16 as a single hexadecimal digit (e.g. 13 was @0xD@).
--- Starting with 0.7.2.0, all 8-bit words are represented as two digits
--- (e.g. 13 is @0x0D@).
-instance Show ByteArray where
-  showsPrec _ ba =
-      showString "[" . go 0
-    where
-      showW8 :: Word8 -> String -> String
-      showW8 !w s =
-          '0'
-        : 'x'
-        : intToDigit (fromIntegral (unsafeShiftR w 4))
-        : intToDigit (fromIntegral (w .&. 0x0F))
-        : s
-      go i
-        | i < sizeofByteArray ba = comma . showW8 (indexByteArray ba i :: Word8) . go (i+1)
-        | otherwise              = showChar ']'
-        where
-          comma | i == 0    = id
-                | otherwise = showString ", "
-
--- Only used internally
-compareByteArraysFromBeginning :: ByteArray -> ByteArray -> Int -> Ordering
-{-# INLINE compareByteArraysFromBeginning #-}
-#if __GLASGOW_HASKELL__ >= 804
-compareByteArraysFromBeginning (ByteArray ba1#) (ByteArray ba2#) (I# n#)
-  = compare (I# (compareByteArrays# ba1# 0# ba2# 0# n#)) 0
-#else
--- Emulate GHC 8.4's 'GHC.Prim.compareByteArrays#'
-compareByteArraysFromBeginning (ByteArray ba1#) (ByteArray ba2#) (I# n#)
-  = compare (fromCInt (unsafeDupablePerformIO (memcmp_ba ba1# ba2# n))) 0
-  where
-    n = fromIntegral (I# n#) :: CSize
-    fromCInt = fromIntegral :: CInt -> Int
-
-foreign import ccall unsafe "primitive-memops.h hsprimitive_memcmp"
-  memcmp_ba :: ByteArray# -> ByteArray# -> CSize -> IO CInt
-#endif
-
-#endif
-
 -- | Lexicographic comparison of equal-length slices into two byte arrays.
 -- This wraps the @compareByteArrays#@ primop, which wraps @memcmp@.
 compareByteArrays
@@ -683,112 +544,11 @@ foreign import ccall unsafe "primitive-memops.h hsprimitive_memcmp_offset"
   memcmp_ba_offs :: ByteArray# -> Int# -> ByteArray# -> Int# -> CSize -> IO CInt
 #endif
 
-#if !MIN_VERSION_base(4,17,0)
-
-sameByteArray :: ByteArray# -> ByteArray# -> Bool
-sameByteArray ba1 ba2 =
-    case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of
-      r -> isTrue# r
-
--- | @since 0.6.3.0
-instance Eq ByteArray where
-  ba1@(ByteArray ba1#) == ba2@(ByteArray ba2#)
-    | sameByteArray ba1# ba2# = True
-    | n1 /= n2 = False
-    | otherwise = compareByteArraysFromBeginning 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 = compareByteArraysFromBeginning 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)
-
-#endif
-
 -- | The empty 'ByteArray'.
 emptyByteArray :: ByteArray
 {-# NOINLINE emptyByteArray #-}
 emptyByteArray = runST (newByteArray 0 >>= unsafeFreezeByteArray)
 
-#if !MIN_VERSION_base(4,17,0)
-
-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
-
-instance SG.Semigroup ByteArray where
-  (<>) = appendByteArray
-  sconcat = mconcat . F.toList
-  stimes n arr = case compare n 0 of
-    LT -> die "stimes" "negative multiplier"
-    EQ -> emptyByteArray
-    GT -> replicateByteArray (fromIntegral n) arr
-
-instance Monoid ByteArray where
-  mempty = emptyByteArray
-#if !(MIN_VERSION_base(4,11,0))
-  mappend = appendByteArray
-#endif
-  mconcat = concatByteArray
-
--- | @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
 

primitive.cabal

@@ -56,6 +56,9 @@ Library
                , transformers >= 0.5 && < 0.7
                , template-haskell >= 2.11
 
+  if impl(ghc < 9.4)
+    build-depends: data-array-byte >= 0.1 && < 0.1.1
+
   Ghc-Options: -O2
 
   Include-Dirs: cbits