{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UnboxedTuples #-}

{- FOURMOLU_DISABLE -}
module Cardano.Crypto.PackedBytes
  ( PackedBytes(..)
  , packBytes
  , packBytesMaybe
  , packPinnedBytes
  , unpackBytes
  , unpackPinnedBytes
  , xorPackedBytes
  ) where

import Codec.Serialise (Serialise(..))
import Codec.Serialise.Decoding (decodeBytes)
import Codec.Serialise.Encoding (encodeBytes)
import Control.DeepSeq (NFData(..))
import Control.Monad (guard)
import Control.Monad.Primitive (primitive_)
import Control.Monad.Reader (MonadReader(ask), MonadTrans(lift))
import Control.Monad.State.Strict (MonadState(state))
import Data.Bits
import Data.ByteString
import Data.ByteString.Internal as BS (accursedUnutterablePerformIO,
                                       fromForeignPtr, toForeignPtr)
import Data.ByteString.Short.Internal as SBS
import Data.MemPack (guardAdvanceUnpack, st_, MemPack(..), Pack(Pack))
import Data.MemPack.Buffer (Buffer(buffer), byteArrayToShortByteString, pinnedByteArrayToForeignPtr)
import Data.Primitive.ByteArray
import Data.Primitive.PrimArray (PrimArray(..), imapPrimArray, indexPrimArray)
import Data.Typeable
import Foreign.ForeignPtr
import Foreign.Ptr (castPtr)
import Foreign.Storable (peekByteOff)
import GHC.Exts
#if MIN_VERSION_base(4,15,0)
import GHC.ForeignPtr (unsafeWithForeignPtr)
#endif
import GHC.ST
import GHC.TypeLits
import GHC.Word
import NoThunks.Class

#include "MachDeps.h"


data PackedBytes (n :: Nat) where
  PackedBytes8  :: {-# UNPACK #-} !Word64
                -> PackedBytes 8
  PackedBytes28 :: {-# UNPACK #-} !Word64
                -> {-# UNPACK #-} !Word64
                -> {-# UNPACK #-} !Word64
                -> {-# UNPACK #-} !Word32
                -> PackedBytes 28
  PackedBytes32 :: {-# UNPACK #-} !Word64
                -> {-# UNPACK #-} !Word64
                -> {-# UNPACK #-} !Word64
                -> {-# UNPACK #-} !Word64
                -> PackedBytes 32
  PackedBytes# :: ByteArray# -> PackedBytes n

deriving via OnlyCheckWhnfNamed "PackedBytes" (PackedBytes n) instance NoThunks (PackedBytes n)

instance Eq (PackedBytes n) where
  PackedBytes8 Word64
x == :: PackedBytes n -> PackedBytes n -> Bool
== PackedBytes8 Word64
y = Word64
x forall a. Eq a => a -> a -> Bool
== Word64
y
  PackedBytes28 Word64
x0 Word64
x1 Word64
x2 Word32
x3 == PackedBytes28 Word64
y0 Word64
y1 Word64
y2 Word32
y3 =
    Word64
x0 forall a. Eq a => a -> a -> Bool
== Word64
y0 Bool -> Bool -> Bool
&& Word64
x1 forall a. Eq a => a -> a -> Bool
== Word64
y1 Bool -> Bool -> Bool
&& Word64
x2 forall a. Eq a => a -> a -> Bool
== Word64
y2 Bool -> Bool -> Bool
&& Word32
x3 forall a. Eq a => a -> a -> Bool
== Word32
y3
  PackedBytes32 Word64
x0 Word64
x1 Word64
x2 Word64
x3 == PackedBytes32 Word64
y0 Word64
y1 Word64
y2 Word64
y3 =
    Word64
x0 forall a. Eq a => a -> a -> Bool
== Word64
y0 Bool -> Bool -> Bool
&& Word64
x1 forall a. Eq a => a -> a -> Bool
== Word64
y1 Bool -> Bool -> Bool
&& Word64
x2 forall a. Eq a => a -> a -> Bool
== Word64
y2 Bool -> Bool -> Bool
&& Word64
x3 forall a. Eq a => a -> a -> Bool
== Word64
y3
  PackedBytes n
x1 == PackedBytes n
x2 = forall (n :: Nat). PackedBytes n -> ShortByteString
unpackBytes PackedBytes n
x1 forall a. Eq a => a -> a -> Bool
== forall (n :: Nat). PackedBytes n -> ShortByteString
unpackBytes PackedBytes n
x2
  {-# INLINE (==) #-}

instance Ord (PackedBytes n) where
  compare :: PackedBytes n -> PackedBytes n -> Ordering
compare (PackedBytes8 Word64
x) (PackedBytes8 Word64
y) = forall a. Ord a => a -> a -> Ordering
compare Word64
x Word64
y
  compare (PackedBytes28 Word64
x0 Word64
x1 Word64
x2 Word32
x3) (PackedBytes28 Word64
y0 Word64
y1 Word64
y2 Word32
y3) =
    forall a. Ord a => a -> a -> Ordering
compare Word64
x0 Word64
y0 forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> a -> Ordering
compare Word64
x1 Word64
y1 forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> a -> Ordering
compare Word64
x2 Word64
y2 forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> a -> Ordering
compare Word32
x3 Word32
y3
  compare (PackedBytes32 Word64
x0 Word64
x1 Word64
x2 Word64
x3) (PackedBytes32 Word64
y0 Word64
y1 Word64
y2 Word64
y3) =
    forall a. Ord a => a -> a -> Ordering
compare Word64
x0 Word64
y0 forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> a -> Ordering
compare Word64
x1 Word64
y1 forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> a -> Ordering
compare Word64
x2 Word64
y2 forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> a -> Ordering
compare Word64
x3 Word64
y3
  compare PackedBytes n
x1 PackedBytes n
x2 = forall a. Ord a => a -> a -> Ordering
compare (forall (n :: Nat). PackedBytes n -> ShortByteString
unpackBytes PackedBytes n
x1) (forall (n :: Nat). PackedBytes n -> ShortByteString
unpackBytes PackedBytes n
x2)
  {-# INLINE compare #-}

instance NFData (PackedBytes n) where
  rnf :: PackedBytes n -> ()
rnf PackedBytes8  {} = ()
  rnf PackedBytes28 {} = ()
  rnf PackedBytes32 {} = ()
  rnf PackedBytes#  {} = ()

instance KnownNat n => MemPack (PackedBytes n) where
  packedByteCount :: PackedBytes n -> Int
packedByteCount = forall a. Num a => Integer -> a
fromInteger @Int forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal
  {-# INLINE packedByteCount #-}
  packM :: forall s. PackedBytes n -> Pack s ()
packM PackedBytes n
pb = do
    let !len :: Int
len@(I# Int#
len#) = forall a. MemPack a => a -> Int
packedByteCount PackedBytes n
pb
    i :: Int
i@(I# Int#
i#) <- forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state forall a b. (a -> b) -> a -> b
$ \Int
i -> (Int
i, Int
i forall a. Num a => a -> a -> a
+ Int
len)
    mba :: MutableByteArray s
mba@(MutableByteArray MutableByteArray# s
mba#) <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall s a. (MutableByteArray s -> StateT Int (ST s) a) -> Pack s a
Pack forall a b. (a -> b) -> a -> b
$ \MutableByteArray s
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ case PackedBytes n
pb of
      PackedBytes8 Word64
w -> forall s. MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE MutableByteArray s
mba Int
i Word64
w
      PackedBytes28 Word64
w0 Word64
w1 Word64
w2 Word32
w3 -> do
        forall s. MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE MutableByteArray s
mba Int
i        Word64
w0
        forall s. MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE MutableByteArray s
mba (Int
i forall a. Num a => a -> a -> a
+ Int
8)  Word64
w1
        forall s. MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE MutableByteArray s
mba (Int
i forall a. Num a => a -> a -> a
+ Int
16) Word64
w2
        forall s. MutableByteArray s -> Int -> Word32 -> ST s ()
writeWord32BE MutableByteArray s
mba (Int
i forall a. Num a => a -> a -> a
+ Int
24) Word32
w3
      PackedBytes32 Word64
w0 Word64
w1 Word64
w2 Word64
w3 -> do
        forall s. MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE MutableByteArray s
mba Int
i        Word64
w0
        forall s. MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE MutableByteArray s
mba (Int
i forall a. Num a => a -> a -> a
+ Int
8)  Word64
w1
        forall s. MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE MutableByteArray s
mba (Int
i forall a. Num a => a -> a -> a
+ Int
16) Word64
w2
        forall s. MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE MutableByteArray s
mba (Int
i forall a. Num a => a -> a -> a
+ Int
24) Word64
w3
      PackedBytes# ByteArray#
ba# ->
        forall s. (State# s -> State# s) -> ST s ()
st_ (forall d.
ByteArray#
-> Int#
-> MutableByteArray# d
-> Int#
-> Int#
-> State# d
-> State# d
copyByteArray# ByteArray#
ba# Int#
0# MutableByteArray# s
mba# Int#
i# Int#
len#)
  {-# INLINE packM #-}
  unpackM :: forall b. Buffer b => Unpack b (PackedBytes n)
unpackM = do
    let !len :: Int
len = forall a. Num a => Integer -> a
fromInteger @Int forall a b. (a -> b) -> a -> b
$ forall (n :: Nat). KnownNat n => Proxy# n -> Integer
natVal' (forall {k} (a :: k). Proxy# a
proxy# :: Proxy# n)
    curPos :: Int
curPos@(I# Int#
curPos#) <- forall b. Buffer b => Int -> Unpack b Int
guardAdvanceUnpack Int
len
    b
buf <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall b a. Buffer b => b -> (ByteArray# -> a) -> (Addr# -> a) -> a
buffer b
buf
      (\ByteArray#
ba# -> forall (n :: Nat).
KnownNat n =>
ShortByteString -> Int -> PackedBytes n
packBytes (ByteArray# -> ShortByteString
SBS.SBS ByteArray#
ba#) Int
curPos)
      -- Usage of `accursedUnutterablePerformIO` is safe below because there are no memory
      -- allocations happening that depend on the IO monad that we are excaping here. All
      -- IO actions are morally pure reads using pointers into the immutable
      -- memory. Furthermore, in the place where ByteArray is allocated in
      -- `packPinnedPtrN`, mutation and freezing are encapsulated with `runST` and is not
      -- related to the `IO` we are escaping.
      (\Addr#
addr# -> forall a. IO a -> a
accursedUnutterablePerformIO forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) a. KnownNat n => Ptr a -> IO (PackedBytes n)
packPinnedPtr (forall a. Addr# -> Ptr a
Ptr (Addr#
addr# Addr# -> Int# -> Addr#
`plusAddr#` Int#
curPos#)))
  {-# INLINE unpackM #-}

instance KnownNat n => Serialise (PackedBytes n) where
  encode :: PackedBytes n -> Encoding
encode = ByteString -> Encoding
encodeBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat). PackedBytes n -> ByteString
unpackPinnedBytes
  decode :: forall s. Decoder s (PackedBytes n)
decode = forall (n :: Nat). KnownNat n => ByteString -> PackedBytes n
packPinnedBytes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s ByteString
decodeBytes

xorPackedBytes :: PackedBytes n -> PackedBytes n -> PackedBytes n
xorPackedBytes :: forall (n :: Nat). PackedBytes n -> PackedBytes n -> PackedBytes n
xorPackedBytes (PackedBytes8 Word64
x) (PackedBytes8 Word64
y) = Word64 -> PackedBytes 8
PackedBytes8 (Word64
x forall a. Bits a => a -> a -> a
`xor` Word64
y)
xorPackedBytes (PackedBytes28 Word64
x0 Word64
x1 Word64
x2 Word32
x3) (PackedBytes28 Word64
y0 Word64
y1 Word64
y2 Word32
y3) =
  Word64 -> Word64 -> Word64 -> Word32 -> PackedBytes 28
PackedBytes28 (Word64
x0 forall a. Bits a => a -> a -> a
`xor` Word64
y0) (Word64
x1 forall a. Bits a => a -> a -> a
`xor` Word64
y1) (Word64
x2 forall a. Bits a => a -> a -> a
`xor` Word64
y2) (Word32
x3 forall a. Bits a => a -> a -> a
`xor` Word32
y3)
xorPackedBytes (PackedBytes32 Word64
x0 Word64
x1 Word64
x2 Word64
x3) (PackedBytes32 Word64
y0 Word64
y1 Word64
y2 Word64
y3) =
  Word64 -> Word64 -> Word64 -> Word64 -> PackedBytes 32
PackedBytes32 (Word64
x0 forall a. Bits a => a -> a -> a
`xor` Word64
y0) (Word64
x1 forall a. Bits a => a -> a -> a
`xor` Word64
y1) (Word64
x2 forall a. Bits a => a -> a -> a
`xor` Word64
y2) (Word64
x3 forall a. Bits a => a -> a -> a
`xor` Word64
y3)
xorPackedBytes (PackedBytes# ByteArray#
ba1#) (PackedBytes# ByteArray#
ba2#) =
  let pa1 :: PrimArray Word8
pa1 = forall a. ByteArray# -> PrimArray a
PrimArray ByteArray#
ba1# :: PrimArray Word8
      pa2 :: PrimArray Word8
pa2 = forall a. ByteArray# -> PrimArray a
PrimArray ByteArray#
ba2# :: PrimArray Word8
   in case forall a b.
(Prim a, Prim b) =>
(Int -> a -> b) -> PrimArray a -> PrimArray b
imapPrimArray (forall a. Bits a => a -> a -> a
xor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Word8
pa1) PrimArray Word8
pa2 of
        PrimArray ByteArray#
pa# -> forall (n :: Nat). ByteArray# -> PackedBytes n
PackedBytes# ByteArray#
pa#
xorPackedBytes PackedBytes n
_ PackedBytes n
_ =
  forall a. HasCallStack => String -> a
error String
"Impossible case. GHC can't figure out that pattern match is exhaustive."
{-# INLINE xorPackedBytes #-}


withMutableByteArray :: Int -> (forall s . MutableByteArray s -> ST s ()) -> ByteArray
withMutableByteArray :: Int -> (forall s. MutableByteArray s -> ST s ()) -> ByteArray
withMutableByteArray Int
n forall s. MutableByteArray s -> ST s ()
f = do
  forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
    MutableByteArray s
mba <- forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray Int
n
    forall s. MutableByteArray s -> ST s ()
f MutableByteArray s
mba
    forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray s
mba
{-# INLINE withMutableByteArray #-}

withPinnedMutableByteArray :: Int -> (forall s . MutableByteArray s -> ST s ()) -> ByteArray
withPinnedMutableByteArray :: Int -> (forall s. MutableByteArray s -> ST s ()) -> ByteArray
withPinnedMutableByteArray Int
n forall s. MutableByteArray s -> ST s ()
f = do
  forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
    MutableByteArray s
mba <- forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newPinnedByteArray Int
n
    forall s. MutableByteArray s -> ST s ()
f MutableByteArray s
mba
    forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray s
mba
{-# INLINE withPinnedMutableByteArray #-}

unpackBytes :: PackedBytes n -> ShortByteString
unpackBytes :: forall (n :: Nat). PackedBytes n -> ShortByteString
unpackBytes = ByteArray -> ShortByteString
byteArrayToShortByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat).
(Int -> (forall s. MutableByteArray s -> ST s ()) -> ByteArray)
-> PackedBytes n -> ByteArray
unpackBytesWith Int -> (forall s. MutableByteArray s -> ST s ()) -> ByteArray
withMutableByteArray
{-# INLINE unpackBytes #-}

unpackPinnedBytes :: PackedBytes n -> ByteString
unpackPinnedBytes :: forall (n :: Nat). PackedBytes n -> ByteString
unpackPinnedBytes = ByteArray -> ByteString
byteArrayToByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat).
(Int -> (forall s. MutableByteArray s -> ST s ()) -> ByteArray)
-> PackedBytes n -> ByteArray
unpackBytesWith Int -> (forall s. MutableByteArray s -> ST s ()) -> ByteArray
withPinnedMutableByteArray
{-# INLINE unpackPinnedBytes #-}


unpackBytesWith ::
     (Int -> (forall s. MutableByteArray s -> ST s ()) -> ByteArray)
  -> PackedBytes n
  -> ByteArray
unpackBytesWith :: forall (n :: Nat).
(Int -> (forall s. MutableByteArray s -> ST s ()) -> ByteArray)
-> PackedBytes n -> ByteArray
unpackBytesWith Int -> (forall s. MutableByteArray s -> ST s ()) -> ByteArray
allocate (PackedBytes8 Word64
w) =
  Int -> (forall s. MutableByteArray s -> ST s ()) -> ByteArray
allocate Int
8  forall a b. (a -> b) -> a -> b
$ \MutableByteArray s
mba -> forall s. MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE MutableByteArray s
mba Int
0 Word64
w
unpackBytesWith Int -> (forall s. MutableByteArray s -> ST s ()) -> ByteArray
allocate (PackedBytes28 Word64
w0 Word64
w1 Word64
w2 Word32
w3) =
  Int -> (forall s. MutableByteArray s -> ST s ()) -> ByteArray
allocate Int
28 forall a b. (a -> b) -> a -> b
$ \MutableByteArray s
mba -> do
    forall s. MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE MutableByteArray s
mba Int
0  Word64
w0
    forall s. MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE MutableByteArray s
mba Int
8  Word64
w1
    forall s. MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE MutableByteArray s
mba Int
16 Word64
w2
    forall s. MutableByteArray s -> Int -> Word32 -> ST s ()
writeWord32BE MutableByteArray s
mba Int
24 Word32
w3
unpackBytesWith Int -> (forall s. MutableByteArray s -> ST s ()) -> ByteArray
allocate (PackedBytes32 Word64
w0 Word64
w1 Word64
w2 Word64
w3) =
  Int -> (forall s. MutableByteArray s -> ST s ()) -> ByteArray
allocate Int
32 forall a b. (a -> b) -> a -> b
$ \MutableByteArray s
mba -> do
    forall s. MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE MutableByteArray s
mba Int
0  Word64
w0
    forall s. MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE MutableByteArray s
mba Int
8  Word64
w1
    forall s. MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE MutableByteArray s
mba Int
16 Word64
w2
    forall s. MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE MutableByteArray s
mba Int
24 Word64
w3
unpackBytesWith Int -> (forall s. MutableByteArray s -> ST s ()) -> ByteArray
_ (PackedBytes# ByteArray#
ba#) = ByteArray# -> ByteArray
ByteArray ByteArray#
ba#
{-# INLINE unpackBytesWith #-}


packBytes8 :: ShortByteString -> Int -> PackedBytes 8
packBytes8 :: ShortByteString -> Int -> PackedBytes 8
packBytes8 (SBS ByteArray#
ba#) Int
offset =
  let ba :: ByteArray
ba = ByteArray# -> ByteArray
ByteArray ByteArray#
ba#
   in Word64 -> PackedBytes 8
PackedBytes8 (ByteArray -> Int -> Word64
indexWord64BE ByteArray
ba Int
offset)
{-# INLINE packBytes8 #-}

packBytes28 :: ShortByteString -> Int -> PackedBytes 28
packBytes28 :: ShortByteString -> Int -> PackedBytes 28
packBytes28 (SBS ByteArray#
ba#) Int
offset =
  let ba :: ByteArray
ba = ByteArray# -> ByteArray
ByteArray ByteArray#
ba#
  in Word64 -> Word64 -> Word64 -> Word32 -> PackedBytes 28
PackedBytes28
       (ByteArray -> Int -> Word64
indexWord64BE ByteArray
ba Int
offset)
       (ByteArray -> Int -> Word64
indexWord64BE ByteArray
ba (Int
offset forall a. Num a => a -> a -> a
+ Int
8))
       (ByteArray -> Int -> Word64
indexWord64BE ByteArray
ba (Int
offset forall a. Num a => a -> a -> a
+ Int
16))
       (ByteArray -> Int -> Word32
indexWord32BE ByteArray
ba (Int
offset forall a. Num a => a -> a -> a
+ Int
24))
{-# INLINE packBytes28 #-}

packBytes32 :: ShortByteString -> Int -> PackedBytes 32
packBytes32 :: ShortByteString -> Int -> PackedBytes 32
packBytes32 (SBS ByteArray#
ba#) Int
offset =
  let ba :: ByteArray
ba = ByteArray# -> ByteArray
ByteArray ByteArray#
ba#
  in Word64 -> Word64 -> Word64 -> Word64 -> PackedBytes 32
PackedBytes32
       (ByteArray -> Int -> Word64
indexWord64BE ByteArray
ba Int
offset)
       (ByteArray -> Int -> Word64
indexWord64BE ByteArray
ba (Int
offset forall a. Num a => a -> a -> a
+ Int
8))
       (ByteArray -> Int -> Word64
indexWord64BE ByteArray
ba (Int
offset forall a. Num a => a -> a -> a
+ Int
16))
       (ByteArray -> Int -> Word64
indexWord64BE ByteArray
ba (Int
offset forall a. Num a => a -> a -> a
+ Int
24))
{-# INLINE packBytes32 #-}

packBytes :: forall n . KnownNat n => ShortByteString -> Int -> PackedBytes n
packBytes :: forall (n :: Nat).
KnownNat n =>
ShortByteString -> Int -> PackedBytes n
packBytes sbs :: ShortByteString
sbs@(SBS ByteArray#
ba#) Int
offset =
  let px :: Proxy n
px = forall {k} (t :: k). Proxy t
Proxy :: Proxy n
      n :: Int
n = forall a. Num a => Integer -> a
fromInteger (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal Proxy n
px)
      ba :: ByteArray
ba = ByteArray# -> ByteArray
ByteArray ByteArray#
ba#
   in case forall (a :: Nat) (b :: Nat) (proxy1 :: Nat -> *)
       (proxy2 :: Nat -> *).
(KnownNat a, KnownNat b) =>
proxy1 a -> proxy2 b -> Maybe (a :~: b)
sameNat Proxy n
px (forall {k} (t :: k). Proxy t
Proxy :: Proxy 8) of
        Just n :~: 8
Refl -> ShortByteString -> Int -> PackedBytes 8
packBytes8 ShortByteString
sbs Int
offset
        Maybe (n :~: 8)
Nothing -> case forall (a :: Nat) (b :: Nat) (proxy1 :: Nat -> *)
       (proxy2 :: Nat -> *).
(KnownNat a, KnownNat b) =>
proxy1 a -> proxy2 b -> Maybe (a :~: b)
sameNat Proxy n
px (forall {k} (t :: k). Proxy t
Proxy :: Proxy 28) of
          Just n :~: 28
Refl -> ShortByteString -> Int -> PackedBytes 28
packBytes28 ShortByteString
sbs Int
offset
          Maybe (n :~: 28)
Nothing -> case forall (a :: Nat) (b :: Nat) (proxy1 :: Nat -> *)
       (proxy2 :: Nat -> *).
(KnownNat a, KnownNat b) =>
proxy1 a -> proxy2 b -> Maybe (a :~: b)
sameNat Proxy n
px (forall {k} (t :: k). Proxy t
Proxy :: Proxy 32) of
            Just n :~: 32
Refl -> ShortByteString -> Int -> PackedBytes 32
packBytes32 ShortByteString
sbs Int
offset
            Maybe (n :~: 32)
Nothing
              | Int
offset forall a. Eq a => a -> a -> Bool
== Int
0
              , ByteArray -> Int
sizeofByteArray ByteArray
ba forall a. Eq a => a -> a -> Bool
== Int
n -> forall (n :: Nat). ByteArray# -> PackedBytes n
PackedBytes# ByteArray#
ba#
            Maybe (n :~: 32)
Nothing ->
              let !(ByteArray ByteArray#
slice#) = ByteArray -> Int -> Int -> ByteArray
cloneByteArray ByteArray
ba Int
offset Int
n
               in forall (n :: Nat). ByteArray# -> PackedBytes n
PackedBytes# ByteArray#
slice#
{-# INLINE[1] packBytes #-}

{-# RULES
"packBytes8"  packBytes = packBytes8
"packBytes28" packBytes = packBytes28
"packBytes32" packBytes = packBytes32
  #-}

-- | Construct `PackedBytes` from a `ShortByteString` and a non-negative offset
-- in number of bytes from the beginning. This function is safe.
packBytesMaybe :: forall n . KnownNat n => ShortByteString -> Int -> Maybe (PackedBytes n)
packBytesMaybe :: forall (n :: Nat).
KnownNat n =>
ShortByteString -> Int -> Maybe (PackedBytes n)
packBytesMaybe ShortByteString
bs Int
offset = do
  let bufferSize :: Int
bufferSize = ShortByteString -> Int
SBS.length ShortByteString
bs
      size :: Int
size = forall a. Num a => Integer -> a
fromInteger (forall (n :: Nat). KnownNat n => Proxy# n -> Integer
natVal' (forall {k} (a :: k). Proxy# a
proxy# @n))
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
offset forall a. Ord a => a -> a -> Bool
>= Int
0)
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
size forall a. Ord a => a -> a -> Bool
<= Int
bufferSize forall a. Num a => a -> a -> a
- Int
offset)
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (n :: Nat).
KnownNat n =>
ShortByteString -> Int -> PackedBytes n
packBytes ShortByteString
bs Int
offset
{-# INLINE packBytesMaybe #-}


packPinnedPtr8 :: Ptr a -> IO (PackedBytes 8)
packPinnedPtr8 :: forall a. Ptr a -> IO (PackedBytes 8)
packPinnedPtr8 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> PackedBytes 8
PackedBytes8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Ptr a -> Int -> IO Word64
`peekWord64BE` Int
0)
{-# INLINE packPinnedPtr8 #-}

packPinnedPtr28 :: Ptr a -> IO (PackedBytes 28)
packPinnedPtr28 :: forall a. Ptr a -> IO (PackedBytes 28)
packPinnedPtr28 Ptr a
ptr =
  Word64 -> Word64 -> Word64 -> Word32 -> PackedBytes 28
PackedBytes28
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ptr a -> Int -> IO Word64
peekWord64BE Ptr a
ptr Int
0
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Ptr a -> Int -> IO Word64
peekWord64BE Ptr a
ptr Int
8
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Ptr a -> Int -> IO Word64
peekWord64BE Ptr a
ptr Int
16
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Ptr a -> Int -> IO Word32
peekWord32BE Ptr a
ptr Int
24
{-# INLINE packPinnedPtr28 #-}

packPinnedPtr32 :: Ptr a -> IO (PackedBytes 32)
packPinnedPtr32 :: forall a. Ptr a -> IO (PackedBytes 32)
packPinnedPtr32 Ptr a
ptr =
  Word64 -> Word64 -> Word64 -> Word64 -> PackedBytes 32
PackedBytes32 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ptr a -> Int -> IO Word64
peekWord64BE Ptr a
ptr Int
0
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Ptr a -> Int -> IO Word64
peekWord64BE Ptr a
ptr Int
8
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Ptr a -> Int -> IO Word64
peekWord64BE Ptr a
ptr Int
16
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Ptr a -> Int -> IO Word64
peekWord64BE Ptr a
ptr Int
24
{-# INLINE packPinnedPtr32 #-}

packPinnedPtrN :: forall n a. KnownNat n => Ptr a -> IO (PackedBytes n)
packPinnedPtrN :: forall (n :: Nat) a. KnownNat n => Ptr a -> IO (PackedBytes n)
packPinnedPtrN (Ptr Addr#
addr#) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall (n :: Nat). ByteArray# -> PackedBytes n
PackedBytes# ByteArray#
ba#
  where
    !(ByteArray ByteArray#
ba#) = Int -> (forall s. MutableByteArray s -> ST s ()) -> ByteArray
withMutableByteArray Int
len forall a b. (a -> b) -> a -> b
$ \(MutableByteArray MutableByteArray# s
mba#) ->
           forall s. (State# s -> State# s) -> ST s ()
st_ (forall d.
Addr#
-> MutableByteArray# d -> Int# -> Int# -> State# d -> State# d
copyAddrToByteArray# Addr#
addr# MutableByteArray# s
mba# Int#
0# Int#
len#)
    !len :: Int
len@(I# Int#
len#) = forall a. Num a => Integer -> a
fromInteger (forall (n :: Nat). KnownNat n => Proxy# n -> Integer
natVal' (forall {k} (a :: k). Proxy# a
proxy# :: Proxy# n))
{-# INLINE packPinnedPtrN #-}

packPinnedPtr :: forall n a. KnownNat n => Ptr a -> IO (PackedBytes n)
packPinnedPtr :: forall (n :: Nat) a. KnownNat n => Ptr a -> IO (PackedBytes n)
packPinnedPtr Ptr a
bs =
  let px :: Proxy n
px = forall {k} (t :: k). Proxy t
Proxy :: Proxy n
   in case forall (a :: Nat) (b :: Nat) (proxy1 :: Nat -> *)
       (proxy2 :: Nat -> *).
(KnownNat a, KnownNat b) =>
proxy1 a -> proxy2 b -> Maybe (a :~: b)
sameNat Proxy n
px (forall {k} (t :: k). Proxy t
Proxy :: Proxy 8) of
        Just n :~: 8
Refl -> forall a. Ptr a -> IO (PackedBytes 8)
packPinnedPtr8 Ptr a
bs
        Maybe (n :~: 8)
Nothing -> case forall (a :: Nat) (b :: Nat) (proxy1 :: Nat -> *)
       (proxy2 :: Nat -> *).
(KnownNat a, KnownNat b) =>
proxy1 a -> proxy2 b -> Maybe (a :~: b)
sameNat Proxy n
px (forall {k} (t :: k). Proxy t
Proxy :: Proxy 28) of
          Just n :~: 28
Refl -> forall a. Ptr a -> IO (PackedBytes 28)
packPinnedPtr28 Ptr a
bs
          Maybe (n :~: 28)
Nothing -> case forall (a :: Nat) (b :: Nat) (proxy1 :: Nat -> *)
       (proxy2 :: Nat -> *).
(KnownNat a, KnownNat b) =>
proxy1 a -> proxy2 b -> Maybe (a :~: b)
sameNat Proxy n
px (forall {k} (t :: k). Proxy t
Proxy :: Proxy 32) of
            Just n :~: 32
Refl -> forall a. Ptr a -> IO (PackedBytes 32)
packPinnedPtr32 Ptr a
bs
            Maybe (n :~: 32)
Nothing   -> forall (n :: Nat) a. KnownNat n => Ptr a -> IO (PackedBytes n)
packPinnedPtrN Ptr a
bs
{-# INLINE[1] packPinnedPtr #-}
{-# RULES
"packPinnedPtr8"  packPinnedPtr = packPinnedPtr8
"packPinnedPtr28" packPinnedPtr = packPinnedPtr28
"packPinnedPtr32" packPinnedPtr = packPinnedPtr32
  #-}

packPinnedBytes :: forall n . KnownNat n => ByteString -> PackedBytes n
packPinnedBytes :: forall (n :: Nat). KnownNat n => ByteString -> PackedBytes n
packPinnedBytes ByteString
bs = forall b a. ByteString -> (Ptr b -> IO a) -> a
unsafeWithByteStringPtr ByteString
bs forall (n :: Nat) a. KnownNat n => Ptr a -> IO (PackedBytes n)
packPinnedPtr
{-# INLINE packPinnedBytes #-}


--- Primitive architecture agnostic helpers

#if WORD_SIZE_IN_BITS == 64

indexWord64BE :: ByteArray -> Int -> Word64
indexWord64BE :: ByteArray -> Int -> Word64
indexWord64BE (ByteArray ByteArray#
ba#) (I# Int#
i#) =
#ifdef WORDS_BIGENDIAN
  W64# (indexWord8ArrayAsWord64# ba# i#)
#else
  Word# -> Word64
W64# (Word# -> Word#
byteSwap64# (ByteArray# -> Int# -> Word#
indexWord8ArrayAsWord64# ByteArray#
ba# Int#
i#))
#endif
{-# INLINE indexWord64BE #-}

peekWord64BE :: Ptr a -> Int -> IO Word64
peekWord64BE :: forall a. Ptr a -> Int -> IO Word64
peekWord64BE Ptr a
ptr Int
i =
#ifndef WORDS_BIGENDIAN
  Word64 -> Word64
byteSwap64 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
#endif
  forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff (forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr) Int
i
{-# INLINE peekWord64BE #-}


writeWord64BE :: MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE :: forall s. MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE (MutableByteArray MutableByteArray# s
mba#) (I# Int#
i#) (W64# Word#
w#) =
  forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ (forall d.
MutableByteArray# d -> Int# -> Word# -> State# d -> State# d
writeWord8ArrayAsWord64# MutableByteArray# s
mba# Int#
i# Word#
wbe#)
  where
#ifdef WORDS_BIGENDIAN
    !wbe# = w#
#else
    !wbe# :: Word#
wbe# = Word# -> Word#
byteSwap64# Word#
w#
#endif
{-# INLINE writeWord64BE #-}

#elif WORD_SIZE_IN_BITS == 32

indexWord64BE :: ByteArray -> Int -> Word64
indexWord64BE ba i =
  (fromIntegral (indexWord32BE ba i) `shiftL` 32) .|. fromIntegral (indexWord32BE ba (i + 4))
{-# INLINE indexWord64BE #-}

peekWord64BE :: Ptr a -> Int -> IO Word64
peekWord64BE ptr i = do
  u <- peekWord32BE ptr i
  l <- peekWord32BE ptr (i + 4)
  pure ((fromIntegral u `shiftL` 32) .|. fromIntegral l)
{-# INLINE peekWord64BE #-}

writeWord64BE :: MutableByteArray s -> Int -> Word64 -> ST s ()
writeWord64BE mba i w64 = do
  writeWord32BE mba i (fromIntegral (w64 `shiftR` 32))
  writeWord32BE mba (i + 4) (fromIntegral w64)
{-# INLINE writeWord64BE #-}

#else
#error "Unsupported architecture"
#endif


indexWord32BE :: ByteArray -> Int -> Word32
indexWord32BE :: ByteArray -> Int -> Word32
indexWord32BE (ByteArray ByteArray#
ba#) (I# Int#
i#) =
#ifdef WORDS_BIGENDIAN
  w32
#else
  Word32 -> Word32
byteSwap32 Word32
w32
#endif
  where
    w32 :: Word32
w32 = Word32# -> Word32
W32# (ByteArray# -> Int# -> Word32#
indexWord8ArrayAsWord32# ByteArray#
ba# Int#
i#)
{-# INLINE indexWord32BE #-}

peekWord32BE :: Ptr a -> Int -> IO Word32
peekWord32BE :: forall a. Ptr a -> Int -> IO Word32
peekWord32BE Ptr a
ptr Int
i =
#ifndef WORDS_BIGENDIAN
  Word32 -> Word32
byteSwap32 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
#endif
  forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff (forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr) Int
i
{-# INLINE peekWord32BE #-}


writeWord32BE :: MutableByteArray s -> Int -> Word32 -> ST s ()
writeWord32BE :: forall s. MutableByteArray s -> Int -> Word32 -> ST s ()
writeWord32BE (MutableByteArray MutableByteArray# s
mba#) (I# Int#
i#) Word32
w =
  forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ (forall d.
MutableByteArray# d -> Int# -> Word32# -> State# d -> State# d
writeWord8ArrayAsWord32# MutableByteArray# s
mba# Int#
i# Word32#
w#)
  where
#ifdef WORDS_BIGENDIAN
    !(W32# w#) = w
#else
    !(W32# Word32#
w#) = Word32 -> Word32
byteSwap32 Word32
w
#endif
{-# INLINE writeWord32BE #-}

byteArrayToByteString :: ByteArray -> ByteString
byteArrayToByteString :: ByteArray -> ByteString
byteArrayToByteString ba :: ByteArray
ba@(ByteArray ByteArray#
ba#)
  | ByteArray -> Bool
isByteArrayPinned ByteArray
ba =
    ForeignPtr Word8 -> Int -> Int -> ByteString
BS.fromForeignPtr (forall a. ByteArray# -> ForeignPtr a
pinnedByteArrayToForeignPtr ByteArray#
ba#) Int
0 (ByteArray -> Int
sizeofByteArray ByteArray
ba)
  | Bool
otherwise = ShortByteString -> ByteString
SBS.fromShort (ByteArray -> ShortByteString
byteArrayToShortByteString ByteArray
ba)
{-# INLINE byteArrayToByteString #-}

-- Usage of `accursedUnutterablePerformIO` here is safe because we only use it
-- for indexing into an immutable `ByteString`, which is analogous to
-- `Data.ByteString.index`.  Make sure you know what you are doing before using
-- this function.
unsafeWithByteStringPtr :: ByteString -> (Ptr b -> IO a) -> a
unsafeWithByteStringPtr :: forall b a. ByteString -> (Ptr b -> IO a) -> a
unsafeWithByteStringPtr ByteString
bs Ptr b -> IO a
f =
  forall a. IO a -> a
accursedUnutterablePerformIO forall a b. (a -> b) -> a -> b
$
    case ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr ByteString
bs of
      (ForeignPtr Word8
fp, Int
offset, Int
_) ->
        forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr (forall a b. ForeignPtr a -> Int -> ForeignPtr b
plusForeignPtr ForeignPtr Word8
fp Int
offset) Ptr b -> IO a
f
{-# INLINE unsafeWithByteStringPtr #-}

#if !MIN_VERSION_base(4,15,0)
-- | A compatibility wrapper for 'GHC.ForeignPtr.unsafeWithForeignPtr' provided
-- by GHC 9.0.1 and later.
unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr = withForeignPtr
{-# INLINE unsafeWithForeignPtr #-}
#endif