{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE MagicHash                  #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE UnboxedTuples              #-}

-- for pinnedByteArrayFromListN
{-# OPTIONS_GHC -Wno-missing-local-signatures #-}
module Cardano.Crypto.PinnedSizedBytes
  (
    PinnedSizedBytes,
    -- * Initialization
    psbZero,
    -- * Conversions
    psbFromBytes,
    psbToBytes,
    psbFromByteString,
    psbFromByteStringCheck,
    psbToByteString,
    -- * C usage
    psbUseAsCPtr,
    psbUseAsSizedPtr,
    psbCreate,
    psbCreateSized,
    ptrPsbToSizedPtr,
  ) where

import Control.DeepSeq (NFData)
import Control.Monad.ST (runST)
import Control.Monad.Primitive  (primitive_)
import Data.Char (ord)
import Data.Primitive.ByteArray
          ( ByteArray (..)
          , MutableByteArray (..)
          , copyByteArrayToAddr
          , newPinnedByteArray
          , unsafeFreezeByteArray
          , foldrByteArray
          , byteArrayContents
          , writeByteArray
          , mutableByteArrayContents
          )
import Data.Proxy (Proxy (..))
import Data.String (IsString (..))
import Data.Word (Word8)
import Foreign.C.Types (CSize)
import Foreign.Ptr (FunPtr, castPtr)
import Foreign.Storable (Storable (..))
import GHC.TypeLits (KnownNat, Nat, natVal)
import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))
import Numeric (showHex)
import System.IO.Unsafe (unsafeDupablePerformIO)

import GHC.Exts (Int (..))
import GHC.Prim (copyAddrToByteArray#)
import GHC.Ptr (Ptr (..))

import qualified Data.Primitive as Prim
import qualified Data.ByteString as BS

import Cardano.Foreign
import Cardano.Crypto.Libsodium.C (c_sodium_compare)

-- $setup
-- >>> :set -XDataKinds -XTypeApplications -XOverloadedStrings
-- >>> import Cardano.Crypto.PinnedSizedBytes

-- | @n@ bytes. 'Storable'.
--
-- We have two @*Bytes@ types:
--
-- * @PinnedSizedBytes@ is backed by pinned ByteArray.
-- * @MLockedSizedBytes@ is backed by ForeignPtr to @mlock@-ed memory region.
--
-- The 'ByteString' is pinned datatype, but it's represented by
-- 'ForeignPtr' + offset (and size).
--
-- I'm sorry for adding more types for bytes. :(
--
newtype PinnedSizedBytes (n :: Nat) = PSB ByteArray
  deriving Context -> PinnedSizedBytes n -> IO (Maybe ThunkInfo)
Proxy (PinnedSizedBytes n) -> String
(Context -> PinnedSizedBytes n -> IO (Maybe ThunkInfo))
-> (Context -> PinnedSizedBytes n -> IO (Maybe ThunkInfo))
-> (Proxy (PinnedSizedBytes n) -> String)
-> NoThunks (PinnedSizedBytes n)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (n :: Nat).
Context -> PinnedSizedBytes n -> IO (Maybe ThunkInfo)
forall (n :: Nat). Proxy (PinnedSizedBytes n) -> String
showTypeOf :: Proxy (PinnedSizedBytes n) -> String
$cshowTypeOf :: forall (n :: Nat). Proxy (PinnedSizedBytes n) -> String
wNoThunks :: Context -> PinnedSizedBytes n -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (n :: Nat).
Context -> PinnedSizedBytes n -> IO (Maybe ThunkInfo)
noThunks :: Context -> PinnedSizedBytes n -> IO (Maybe ThunkInfo)
$cnoThunks :: forall (n :: Nat).
Context -> PinnedSizedBytes n -> IO (Maybe ThunkInfo)
NoThunks via OnlyCheckWhnfNamed "PinnedSizedBytes" (PinnedSizedBytes n)
  deriving PinnedSizedBytes n -> ()
(PinnedSizedBytes n -> ()) -> NFData (PinnedSizedBytes n)
forall a. (a -> ()) -> NFData a
forall (n :: Nat). PinnedSizedBytes n -> ()
rnf :: PinnedSizedBytes n -> ()
$crnf :: forall (n :: Nat). PinnedSizedBytes n -> ()
NFData

instance Show (PinnedSizedBytes n) where
    showsPrec :: Int -> PinnedSizedBytes n -> ShowS
showsPrec Int
_ (PSB ByteArray
ba)
        = Char -> ShowS
showChar Char
'"'
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> ShowS -> ShowS) -> ShowS -> ByteArray -> ShowS
forall a b. Prim a => (a -> b -> b) -> b -> ByteArray -> b
foldrByteArray (\Word8
w ShowS
acc -> Word8 -> ShowS
show8 Word8
w ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
acc) ShowS
forall a. a -> a
id ByteArray
ba
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'"'
      where
        show8 :: Word8 -> ShowS
        show8 :: Word8 -> ShowS
show8 Word8
w | Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
16    = Char -> ShowS
showChar Char
'0' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex Word8
w
                | Bool
otherwise = Word8 -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex Word8
w

-- | The comparison is done in constant time for a given size @n@.
instance KnownNat n => Eq (PinnedSizedBytes n) where
    PinnedSizedBytes n
x == :: PinnedSizedBytes n -> PinnedSizedBytes n -> Bool
== PinnedSizedBytes n
y = PinnedSizedBytes n -> PinnedSizedBytes n -> Ordering
forall a. Ord a => a -> a -> Ordering
compare PinnedSizedBytes n
x PinnedSizedBytes n
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

instance KnownNat n => Ord (PinnedSizedBytes n) where
    compare :: PinnedSizedBytes n -> PinnedSizedBytes n -> Ordering
compare (PSB ByteArray
x) (PSB ByteArray
y) = IO Ordering -> Ordering
forall a. IO a -> a
unsafeDupablePerformIO (IO Ordering -> Ordering) -> IO Ordering -> Ordering
forall a b. (a -> b) -> a -> b
$ do
        Int
res <- Ptr Word8 -> Ptr Word8 -> CSize -> IO Int
forall a. Ptr a -> Ptr a -> CSize -> IO Int
c_sodium_compare (ByteArray -> Ptr Word8
byteArrayContents ByteArray
x) (ByteArray -> Ptr Word8
byteArrayContents ByteArray
y) CSize
size
        Ordering -> IO Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
res Int
0)
      where
        size :: CSize
        size :: CSize
size = Integer -> CSize
forall a. Num a => Integer -> a
fromInteger (Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n))

-- |
--
-- If given 'String' is too long, it is truncated,
-- If it is too short, it is padded with zeros.
--
-- Padding and truncation make it behave like an integer mod @n*8@.
--
-- >>> "abcdef" :: PinnedSizedBytes 4
-- "63646566"
--
-- >>> "foo" :: PinnedSizedBytes 8
-- "0000000000666f6f"
--
-- Non-ASCII codepoints are silently truncated to 0..255 range.
--
-- >>> "\x1234\x5678" :: PinnedSizedBytes 2
-- "3478"
--
-- 'PinnedSizedBytes' created with 'fromString' contains /unpinned/
-- 'ByteArray'.
--
instance KnownNat n => IsString (PinnedSizedBytes n) where
    fromString :: String -> PinnedSizedBytes n
fromString String
s = [Word8] -> PinnedSizedBytes n
forall (n :: Nat). KnownNat n => [Word8] -> PinnedSizedBytes n
psbFromBytes ((Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) String
s)

-- | See 'psbFromBytes'.
psbToBytes :: PinnedSizedBytes n -> [Word8]
psbToBytes :: PinnedSizedBytes n -> [Word8]
psbToBytes (PSB ByteArray
ba) = (Word8 -> [Word8] -> [Word8]) -> [Word8] -> ByteArray -> [Word8]
forall a b. Prim a => (a -> b -> b) -> b -> ByteArray -> b
foldrByteArray (:) [] ByteArray
ba

psbToByteString :: PinnedSizedBytes n -> BS.ByteString
psbToByteString :: PinnedSizedBytes n -> ByteString
psbToByteString = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString)
-> (PinnedSizedBytes n -> [Word8])
-> PinnedSizedBytes n
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PinnedSizedBytes n -> [Word8]
forall (n :: Nat). PinnedSizedBytes n -> [Word8]
psbToBytes

-- | See @'IsString' ('PinnedSizedBytes' n)@ instance.
--
-- >>> psbToBytes . (id @(PinnedSizedBytes 4)) . psbFromBytes $ [1,2,3,4]
-- [1,2,3,4]
--
-- >>> psbToBytes . (id @(PinnedSizedBytes 4)) . psbFromBytes $ [1,2]
-- [0,0,1,2]
--
-- >>> psbToBytes . (id @(PinnedSizedBytes 4)) . psbFromBytes $ [1,2,3,4,5,6]
-- [3,4,5,6]
-- 
psbFromBytes :: forall n. KnownNat n => [Word8] -> PinnedSizedBytes n
psbFromBytes :: [Word8] -> PinnedSizedBytes n
psbFromBytes [Word8]
ws0 = ByteArray -> PinnedSizedBytes n
forall (n :: Nat). ByteArray -> PinnedSizedBytes n
PSB (Int -> [Word8] -> ByteArray
forall a. Prim a => Int -> [a] -> ByteArray
pinnedByteArrayFromListN Int
size [Word8]
ws)
  where
    size :: Int
    size :: Int
size = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n))

    ws :: [Word8]
    ws :: [Word8]
ws = [Word8] -> [Word8]
forall a. [a] -> [a]
reverse
        ([Word8] -> [Word8]) -> [Word8] -> [Word8]
forall a b. (a -> b) -> a -> b
$ Int -> [Word8] -> [Word8]
forall a. Int -> [a] -> [a]
take Int
size
        ([Word8] -> [Word8]) -> [Word8] -> [Word8]
forall a b. (a -> b) -> a -> b
$ ([Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ Word8 -> [Word8]
forall a. a -> [a]
repeat Word8
0)
        ([Word8] -> [Word8]) -> [Word8] -> [Word8]
forall a b. (a -> b) -> a -> b
$ [Word8] -> [Word8]
forall a. [a] -> [a]
reverse [Word8]
ws0

-- This is not efficient, but we don't use this in non-tests
psbFromByteString :: KnownNat n => BS.ByteString -> PinnedSizedBytes n
psbFromByteString :: ByteString -> PinnedSizedBytes n
psbFromByteString = [Word8] -> PinnedSizedBytes n
forall (n :: Nat). KnownNat n => [Word8] -> PinnedSizedBytes n
psbFromBytes ([Word8] -> PinnedSizedBytes n)
-> (ByteString -> [Word8]) -> ByteString -> PinnedSizedBytes n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack

psbFromByteStringCheck :: forall n. KnownNat n => BS.ByteString -> Maybe (PinnedSizedBytes n)
psbFromByteStringCheck :: ByteString -> Maybe (PinnedSizedBytes n)
psbFromByteStringCheck ByteString
bs 
    | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
size = PinnedSizedBytes n -> Maybe (PinnedSizedBytes n)
forall a. a -> Maybe a
Just (PinnedSizedBytes n -> Maybe (PinnedSizedBytes n))
-> PinnedSizedBytes n -> Maybe (PinnedSizedBytes n)
forall a b. (a -> b) -> a -> b
$ IO (PinnedSizedBytes n) -> PinnedSizedBytes n
forall a. IO a -> a
unsafeDupablePerformIO (IO (PinnedSizedBytes n) -> PinnedSizedBytes n)
-> IO (PinnedSizedBytes n) -> PinnedSizedBytes n
forall a b. (a -> b) -> a -> b
$
        ByteString
-> (CStringLen -> IO (PinnedSizedBytes n))
-> IO (PinnedSizedBytes n)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.useAsCStringLen ByteString
bs ((CStringLen -> IO (PinnedSizedBytes n))
 -> IO (PinnedSizedBytes n))
-> (CStringLen -> IO (PinnedSizedBytes n))
-> IO (PinnedSizedBytes n)
forall a b. (a -> b) -> a -> b
$ \(Ptr Addr#
addr#, Int
_) -> do
            marr :: MutableByteArray RealWorld
marr@(MutableByteArray MutableByteArray# RealWorld
marr#) <- Int -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newPinnedByteArray Int
size
            (State# (PrimState IO) -> State# (PrimState IO)) -> IO ()
forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ ((State# (PrimState IO) -> State# (PrimState IO)) -> IO ())
-> (State# (PrimState IO) -> State# (PrimState IO)) -> IO ()
forall a b. (a -> b) -> a -> b
$ Addr#
-> MutableByteArray# RealWorld
-> Int#
-> Int#
-> State# RealWorld
-> State# RealWorld
forall d.
Addr#
-> MutableByteArray# d -> Int# -> Int# -> State# d -> State# d
copyAddrToByteArray# Addr#
addr# MutableByteArray# RealWorld
marr# Int#
0# (case Int
size of I# Int#
s -> Int#
s)
            ByteArray
arr <- MutableByteArray (PrimState IO) -> IO ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
marr
            PinnedSizedBytes n -> IO (PinnedSizedBytes n)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteArray -> PinnedSizedBytes n
forall (n :: Nat). ByteArray -> PinnedSizedBytes n
PSB ByteArray
arr)
    | Bool
otherwise            = Maybe (PinnedSizedBytes n)
forall a. Maybe a
Nothing
  where
    size :: Int
    size :: Int
size = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n))

psbZero :: KnownNat n =>  PinnedSizedBytes n
psbZero :: PinnedSizedBytes n
psbZero = [Word8] -> PinnedSizedBytes n
forall (n :: Nat). KnownNat n => [Word8] -> PinnedSizedBytes n
psbFromBytes []

instance KnownNat n => Storable (PinnedSizedBytes n) where
    sizeOf :: PinnedSizedBytes n -> Int
sizeOf PinnedSizedBytes n
_          = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n))
    alignment :: PinnedSizedBytes n -> Int
alignment PinnedSizedBytes n
_       = FunPtr (Int -> Int) -> Int
forall a. Storable a => a -> Int
alignment (FunPtr (Int -> Int)
forall a. HasCallStack => a
undefined :: FunPtr (Int -> Int))

    peek :: Ptr (PinnedSizedBytes n) -> IO (PinnedSizedBytes n)
peek (Ptr Addr#
addr#) = do
        let size :: Int
            size :: Int
size = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n))
        marr :: MutableByteArray RealWorld
marr@(MutableByteArray MutableByteArray# RealWorld
marr#) <- Int -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newPinnedByteArray Int
size
        (State# (PrimState IO) -> State# (PrimState IO)) -> IO ()
forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ ((State# (PrimState IO) -> State# (PrimState IO)) -> IO ())
-> (State# (PrimState IO) -> State# (PrimState IO)) -> IO ()
forall a b. (a -> b) -> a -> b
$ Addr#
-> MutableByteArray# RealWorld
-> Int#
-> Int#
-> State# RealWorld
-> State# RealWorld
forall d.
Addr#
-> MutableByteArray# d -> Int# -> Int# -> State# d -> State# d
copyAddrToByteArray# Addr#
addr# MutableByteArray# RealWorld
marr# Int#
0# (case Int
size of I# Int#
s -> Int#
s)
        ByteArray
arr <- MutableByteArray (PrimState IO) -> IO ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
marr
        PinnedSizedBytes n -> IO (PinnedSizedBytes n)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteArray -> PinnedSizedBytes n
forall (n :: Nat). ByteArray -> PinnedSizedBytes n
PSB ByteArray
arr)

    poke :: Ptr (PinnedSizedBytes n) -> PinnedSizedBytes n -> IO ()
poke Ptr (PinnedSizedBytes n)
p (PSB ByteArray
arr) = do
        let size :: Int
            size :: Int
size = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n))
        Ptr Word8 -> ByteArray -> Int -> Int -> IO ()
forall (m :: * -> *).
PrimMonad m =>
Ptr Word8 -> ByteArray -> Int -> Int -> m ()
copyByteArrayToAddr (Ptr (PinnedSizedBytes n) -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr (PinnedSizedBytes n)
p) ByteArray
arr Int
0 Int
size

psbUseAsCPtr :: PinnedSizedBytes n -> (Ptr Word8 -> IO r) -> IO r
psbUseAsCPtr :: PinnedSizedBytes n -> (Ptr Word8 -> IO r) -> IO r
psbUseAsCPtr (PSB ByteArray
ba) Ptr Word8 -> IO r
k = Ptr Word8 -> IO r
k (ByteArray -> Ptr Word8
byteArrayContents ByteArray
ba)

psbUseAsSizedPtr :: PinnedSizedBytes n -> (SizedPtr n -> IO r) -> IO r
psbUseAsSizedPtr :: PinnedSizedBytes n -> (SizedPtr n -> IO r) -> IO r
psbUseAsSizedPtr (PSB ByteArray
ba) SizedPtr n -> IO r
k = SizedPtr n -> IO r
k (Ptr Void -> SizedPtr n
forall (n :: Nat). Ptr Void -> SizedPtr n
SizedPtr (Ptr Void -> SizedPtr n) -> Ptr Void -> SizedPtr n
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> Ptr Void
forall a b. Ptr a -> Ptr b
castPtr (Ptr Word8 -> Ptr Void) -> Ptr Word8 -> Ptr Void
forall a b. (a -> b) -> a -> b
$ ByteArray -> Ptr Word8
byteArrayContents ByteArray
ba)

psbCreate :: forall n. KnownNat n => (Ptr Word8 -> IO ()) -> IO (PinnedSizedBytes n)
psbCreate :: (Ptr Word8 -> IO ()) -> IO (PinnedSizedBytes n)
psbCreate Ptr Word8 -> IO ()
k = do
    let size :: Int
        size :: Int
size = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n))
    MutableByteArray RealWorld
mba <- Int -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newPinnedByteArray Int
size
    Ptr Word8 -> IO ()
k (MutableByteArray RealWorld -> Ptr Word8
forall s. MutableByteArray s -> Ptr Word8
mutableByteArrayContents MutableByteArray RealWorld
mba)
    ByteArray
arr <- MutableByteArray (PrimState IO) -> IO ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
mba
    PinnedSizedBytes n -> IO (PinnedSizedBytes n)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteArray -> PinnedSizedBytes n
forall (n :: Nat). ByteArray -> PinnedSizedBytes n
PSB ByteArray
arr)

psbCreateSized :: forall n. KnownNat n => (SizedPtr n -> IO ()) -> IO (PinnedSizedBytes n)
psbCreateSized :: (SizedPtr n -> IO ()) -> IO (PinnedSizedBytes n)
psbCreateSized SizedPtr n -> IO ()
k = (Ptr Word8 -> IO ()) -> IO (PinnedSizedBytes n)
forall (n :: Nat).
KnownNat n =>
(Ptr Word8 -> IO ()) -> IO (PinnedSizedBytes n)
psbCreate (SizedPtr n -> IO ()
k (SizedPtr n -> IO ())
-> (Ptr Word8 -> SizedPtr n) -> Ptr Word8 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Void -> SizedPtr n
forall (n :: Nat). Ptr Void -> SizedPtr n
SizedPtr (Ptr Void -> SizedPtr n)
-> (Ptr Word8 -> Ptr Void) -> Ptr Word8 -> SizedPtr n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Word8 -> Ptr Void
forall a b. Ptr a -> Ptr b
castPtr)

ptrPsbToSizedPtr :: Ptr (PinnedSizedBytes n) -> SizedPtr n
ptrPsbToSizedPtr :: Ptr (PinnedSizedBytes n) -> SizedPtr n
ptrPsbToSizedPtr = Ptr Void -> SizedPtr n
forall (n :: Nat). Ptr Void -> SizedPtr n
SizedPtr (Ptr Void -> SizedPtr n)
-> (Ptr (PinnedSizedBytes n) -> Ptr Void)
-> Ptr (PinnedSizedBytes n)
-> SizedPtr n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr (PinnedSizedBytes n) -> Ptr Void
forall a b. Ptr a -> Ptr b
castPtr

-------------------------------------------------------------------------------
-- derivative from primitive
-------------------------------------------------------------------------------

-- | Create a 'ByteArray' from a list of a known length. If the length
--   of the list does not match the given length, or if the length is zero,
--   then this throws an exception.
pinnedByteArrayFromListN :: forall a. Prim.Prim a => Int -> [a] -> ByteArray
pinnedByteArrayFromListN :: Int -> [a] -> ByteArray
pinnedByteArrayFromListN Int
0 [a]
_ =
    String -> String -> ByteArray
forall a. String -> String -> a
die String
"pinnedByteArrayFromListN" String
"list length zero"
pinnedByteArrayFromListN Int
n [a]
ys = (forall s. ST s ByteArray) -> ByteArray
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s ByteArray) -> ByteArray)
-> (forall s. ST s ByteArray) -> ByteArray
forall a b. (a -> b) -> a -> b
$ do
    MutableByteArray s
marr <- Int -> ST s (MutableByteArray (PrimState (ST s)))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newPinnedByteArray (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* a -> Int
forall a. Prim a => a -> Int
Prim.sizeOf ([a] -> a
forall a. [a] -> a
head [a]
ys))
    let go :: Int -> [a] -> ST s ()
go !Int
ix [] = if Int
ix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n
          then () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else String -> String -> ST s ()
forall a. String -> String -> a
die String
"pinnedByteArrayFromListN" String
"list length less than specified size"
        go !Int
ix (a
x : [a]
xs) = if Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n
          then do
            MutableByteArray (PrimState (ST s)) -> Int -> a -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray s
MutableByteArray (PrimState (ST s))
marr Int
ix a
x
            Int -> [a] -> ST s ()
go (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [a]
xs
          else String -> String -> ST s ()
forall a. String -> String -> a
die String
"pinnedByteArrayFromListN" String
"list length greater than specified size"
    Int -> [a] -> ST s ()
forall a. Prim a => Int -> [a] -> ST s ()
go Int
0 [a]
ys
    MutableByteArray (PrimState (ST s)) -> ST s ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray s
MutableByteArray (PrimState (ST s))
marr

die :: String -> String -> a
die :: String -> String -> a
die String
fun String
problem = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"PinnedSizedBytes." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fun String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
problem