{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE UnliftedFFITypes #-}
module Graphics.Vulkan.Marshal.Internal
( VkStruct (..), unsafeFromByteArrayOffset
, VulkanMarshal (..)
, newVkData, mallocVkData, mallocVkDataArray, unsafePtr
, fromForeignPtr, toForeignPtr, toPlainForeignPtr, touchVkData
, StructFields, CUnionType, ReturnedOnly, StructExtends
, StructFieldNames, HasField, FieldRep, FieldType
, FieldOptional, FieldOffset
, FieldIsArray, FieldArrayLength
, CanReadField, CanWriteField
, CanReadFieldArray, CanWriteFieldArray
, fieldOptional, fieldOffset, fieldArrayLength
, getField, readField, writeField
, getFieldArrayUnsafe, readFieldArrayUnsafe, writeFieldArrayUnsafe
, getFieldArray, readFieldArray, writeFieldArray
, IndexInBounds
, VulkanStruct (..), VulkanField (..), VulkanFields (..), KnownBool (..)
, FieldMeta (..), StructMeta (..)
, withCStringField, unsafeCStringField
, getStringField, readStringField, writeStringField
, cmpCStrings, cmpCStringsN
) where
import Data.Kind (Constraint, Type)
import Data.Type.Equality
import Foreign.C.String (CString, peekCString)
import Foreign.C.Types (CChar, CInt (..), CSize (..))
import Foreign.ForeignPtr (ForeignPtr, newForeignPtr_)
import Foreign.Marshal.Array (pokeArray0)
import Foreign.Ptr (plusPtr)
import Foreign.Storable
import GHC.Base (Addr#, ByteArray#, IO (..), Int (..), Int#,
byteArrayContents#, copyAddrToByteArray#, eqAddr#,
isTrue#, minusAddr#, newAlignedPinnedByteArray#,
plusAddr#, touch#, unsafeCoerce#,
unsafeFreezeByteArray#, (*#), (+#), (>=#))
import GHC.Exts (Proxy#, proxy#)
import GHC.ForeignPtr (ForeignPtr (..), ForeignPtrContents (..))
import GHC.Ptr (Ptr (..))
import GHC.TypeLits
import System.IO.Unsafe (unsafeDupablePerformIO)
import Unsafe.Coerce (unsafeCoerce)
data VkStruct a = VkStruct
{ unsafeAddr :: Addr#
, unsafeByteArray :: ByteArray#
}
type family VkStruct' (a :: Type) :: Type where
VkStruct' (VkStruct a) = a
type IsVkStruct a = a ~ VkStruct (VkStruct' a)
unsafeFromByteArrayOffset :: Int# -> ByteArray# -> VkStruct a
unsafeFromByteArrayOffset off b
= VkStruct (plusAddr# (byteArrayContents# b) off) b
{-# INLINE unsafeFromByteArrayOffset #-}
data FieldMeta
= FieldMeta Symbol Type Bool Nat Nat Bool Bool
data StructMeta
= StructMeta Symbol Type Nat Nat [FieldMeta] Bool Bool [Type]
class KnownBool (b :: Bool) where
boolSing :: Bool
instance KnownBool 'True where boolSing = True
instance KnownBool 'False where boolSing = False
class (Show (FType m), Storable (FType m))
=> VulkanField (m :: FieldMeta) where
type FName m :: Symbol
type FType m :: Type
type FOptional m :: Bool
type FByteOffset m :: Nat
type FLength m :: Nat
type FCanRead m :: Bool
type FCanWrite m :: Bool
fName :: String
fOptional :: Bool
fByteOffset :: Int
fLength :: Int
fCanRead :: Bool
fCanWrite :: Bool
instance ( KnownSymbol fieldName
, Show t, Storable t
, KnownBool optional
, KnownNat byteOffset
, KnownNat length
, KnownBool canRead
, KnownBool canWrite
) => VulkanField ('FieldMeta fieldName t optional byteOffset length canRead canWrite) where
type FName ('FieldMeta fieldName t optional byteOffset length canRead canWrite) = fieldName
type FType ('FieldMeta fieldName t optional byteOffset length canRead canWrite) = t
type FOptional ('FieldMeta fieldName t optional byteOffset length canRead canWrite) = optional
type FByteOffset ('FieldMeta fieldName t optional byteOffset length canRead canWrite) = byteOffset
type FLength ('FieldMeta fieldName t optional byteOffset length canRead canWrite) = length
type FCanRead ('FieldMeta fieldName t optional byteOffset length canRead canWrite) = canRead
type FCanWrite ('FieldMeta fieldName t optional byteOffset length canRead canWrite) = canWrite
fName = symbolVal' @fieldName proxy#
fOptional = boolSing @optional
fByteOffset = fromInteger $ natVal' @byteOffset proxy#
fLength = fromInteger $ natVal' @length proxy#
fCanRead = boolSing @canRead
fCanWrite = boolSing @canWrite
type family GetFieldMeta (errMsg :: ErrorMessage) (fname :: Symbol) (ms :: [FieldMeta]) :: FieldMeta where
GetFieldMeta _ n ('FieldMeta n t o b l r w ': _) = 'FieldMeta n t o b l r w
GetFieldMeta e n (_ ': ms) = GetFieldMeta e n ms
GetFieldMeta e n '[] = TypeError e
class VulkanFields (ms :: [FieldMeta]) where
withField :: forall (fname :: Symbol) (r :: Type) (errMsg :: ErrorMessage)
. KnownSymbol fname
=> Proxy# fname
-> Proxy# errMsg
-> (VulkanField (GetFieldMeta errMsg fname ms) => r) -> r
enumerateFields :: forall (a :: Type)
. (forall (m :: FieldMeta) . VulkanField m
=> Proxy# m -> a -> a)
-> a -> a
instance VulkanFields '[] where
withField = error "VulkanFields.withField: unreachable code (no such field guarded by type family)."
enumerateFields _ = id
instance (VulkanField m, VulkanFields ms) => VulkanFields (m ': ms) where
withField pName pErr f
| symbolVal' pName == fName @m
, Refl <- proofm pName pErr = f
| Refl <- proofms pName pErr = withField @ms pName pErr f
where
proofm :: Proxy# fname -> Proxy# errMsg
-> (m :~: GetFieldMeta errMsg fname (m : ms))
proofm _ = unsafeCoerce Refl
proofms :: Proxy# fname -> Proxy# errMsg
-> (GetFieldMeta errMsg fname ms :~: GetFieldMeta errMsg fname (m : ms))
proofms _ = unsafeCoerce Refl
enumerateFields k = k (proxy# @_ @m) . enumerateFields @ms k
class VulkanFields (SFields m)
=> VulkanStruct (m :: StructMeta) where
type SName m :: Symbol
type SType m :: Type
type SSize m :: Nat
type SAlign m :: Nat
type SFields m :: [FieldMeta]
type SIsUnion m :: Bool
type SIsReturnedOnly m :: Bool
type SStructExtends m :: [Type]
sName :: String
sSize :: Int
sAlign :: Int
sIsUnion :: Bool
sIsReturnedOnly :: Bool
instance ( KnownSymbol structName
, KnownNat size
, KnownNat alignment
, VulkanFields fields
, KnownBool isUnion
, KnownBool isReturnedOnly
)
=> VulkanStruct
('StructMeta structName structType size alignment
fields isUnion isReturnedOnly structExtends) where
type SName ('StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends) = structName
type SType ('StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends) = structType
type SSize ('StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends) = size
type SAlign ('StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends) = alignment
type SFields ('StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends) = fields
type SIsUnion ('StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends) = isUnion
type SIsReturnedOnly ('StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends) = isReturnedOnly
type SStructExtends ('StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends) = structExtends
sName = symbolVal' @structName proxy#
sSize = fromInteger $ natVal' @size proxy#
sAlign = fromInteger $ natVal' @alignment proxy#
sIsUnion = boolSing @isUnion
sIsReturnedOnly = boolSing @isReturnedOnly
type StructFields a = SFields (StructRep a)
type CUnionType a = SIsUnion (StructRep a)
type ReturnedOnly a = SIsReturnedOnly (StructRep a)
type StructExtends a = SStructExtends (StructRep a)
class (VulkanStruct (StructRep a), IsVkStruct a)
=> VulkanMarshal a where
type StructRep a :: StructMeta
newVkData :: forall a . VulkanMarshal a => (Ptr a -> IO ()) -> IO a
newVkData f
| I# n <- sSize @(StructRep a)
, I# a <- sAlign @(StructRep a)
= IO
(\s0 -> case newAlignedPinnedByteArray# n a s0 of
(# s1, mba #) -> case unsafeFreezeByteArray# mba s1 of
(# s2, ba #) -> case f (Ptr (byteArrayContents# ba)) of
IO k -> case k s2 of
(# s3, () #) -> (# s3, unsafeFromByteArrayOffset 0# ba #)
)
{-# INLINE newVkData #-}
mallocVkData :: forall a . VulkanMarshal a => IO a
mallocVkData
| I# n <- sSize @(StructRep a)
, I# a <- sAlign @(StructRep a)
= IO
(\s0 -> case newAlignedPinnedByteArray# n a s0 of
(# s1, mba #) -> case unsafeFreezeByteArray# mba s1 of
(# s2, ba #) -> (# s2, unsafeFromByteArrayOffset 0# ba #)
)
{-# INLINE mallocVkData #-}
mallocVkDataArray :: forall a . VulkanMarshal a => Int -> IO (Ptr a, [a])
mallocVkDataArray (I# m)
| I# n <- sSize @(StructRep a)
, I# a <- sAlign @(StructRep a)
, nm <- n *# m
= IO
(\s0 -> case newAlignedPinnedByteArray# nm a s0 of
(# s1, mba #) -> case unsafeFreezeByteArray# mba s1 of
(# s2, ba #) ->
(# s2
, ( Ptr (byteArrayContents# ba)
, let go k | isTrue# (k >=# nm) = []
| otherwise = unsafeFromByteArrayOffset k ba
: go (k +# n)
in go 0#
)
#)
)
{-# INLINE mallocVkDataArray #-}
unsafePtr :: IsVkStruct a => a -> Ptr a
unsafePtr a = Ptr (unsafeAddr a)
{-# INLINE unsafePtr #-}
fromForeignPtr :: forall a . VulkanMarshal a => ForeignPtr a -> IO a
fromForeignPtr (ForeignPtr addr PlainForeignPtr{})
| I# n <- sSize @(StructRep a)
, I# a <- sAlign @(StructRep a)
= IO
(\s0 -> case newAlignedPinnedByteArray# n a s0 of
(# s1, mba #) -> case copyAddrToByteArray# addr mba 0# n s1 of
s2 -> case unsafeFreezeByteArray# mba s2 of
(# s3, ba #) -> (# s3, unsafeFromByteArrayOffset 0# ba #)
)
fromForeignPtr (ForeignPtr addr (MallocPtr mba _))
= IO
(\s0 -> case unsafeFreezeByteArray# mba s0 of
(# s1, ba #) -> (# s1, unsafeFromByteArrayOffset
(minusAddr# addr (byteArrayContents# ba)) ba #)
)
fromForeignPtr (ForeignPtr addr (PlainPtr mba))
= IO
(\s0 -> case unsafeFreezeByteArray# mba s0 of
(# s1, ba #) -> (# s1, unsafeFromByteArrayOffset
(minusAddr# addr (byteArrayContents# ba)) ba #)
)
{-# INLINE fromForeignPtr #-}
toForeignPtr :: IsVkStruct a => a -> IO (ForeignPtr a)
toForeignPtr x
| a <- unsafeAddr x
, b <- unsafeByteArray x = do
ForeignPtr _ (PlainForeignPtr r)
<- newForeignPtr_ (Ptr a)
IO (\s -> (# s, ForeignPtr a (MallocPtr (unsafeCoerce# b) r) #))
{-# INLINE toForeignPtr #-}
toPlainForeignPtr :: IsVkStruct a => a -> IO (ForeignPtr a)
toPlainForeignPtr (VkStruct a b) = IO
(\s -> (# s, ForeignPtr a (PlainPtr (unsafeCoerce# b)) #))
{-# INLINE toPlainForeignPtr #-}
touchVkData :: IsVkStruct a => a -> IO ()
touchVkData (VkStruct _ b) = IO (\s -> (# touch# b s, () #))
{-# INLINE touchVkData #-}
type StructFieldNames (a :: Type) = FieldNames (StructFields a)
type family FieldNames (ms :: [FieldMeta]) :: [Symbol] where
FieldNames '[] = '[]
FieldNames (m ': ms) = FName m ': FieldNames ms
type HasField (fname :: Symbol) (a :: Type)
= (VulkanMarshal a, VulkanField (FieldRep fname a))
type FieldRep (fname :: Symbol) (a :: Type)
= GetFieldMeta (ErrorNoSuchField fname a) fname (StructFields a)
type FieldType (fname :: Symbol) (a :: Type)
= FType (FieldRep fname a)
type FieldOptional (fname :: Symbol) (a :: Type)
= FOptional (FieldRep fname a)
type FieldOffset (fname :: Symbol) (a :: Type)
= FByteOffset (FieldRep fname a)
type FieldIsArray (fname :: Symbol) (a :: Type)
= IsArrayLen (FLength (FieldRep fname a))
type family IsArrayLen (l :: Nat) :: Bool where
IsArrayLen 1 = 'False
IsArrayLen _ = 'True
type FieldArrayLength (fname :: Symbol) (a :: Type)
= FLength (FieldRep fname a)
type CanReadField (fname :: Symbol) (a :: Type)
= ( HasField fname a
, IsTrue (ErrorNotReadableField fname a)
(FCanRead (FieldRep fname a))
, Storable (FieldType fname a))
type CanWriteField (fname :: Symbol) (a :: Type)
= ( HasField fname a
, IsTrue (ErrorNotWritableField fname a)
(FCanWrite (FieldRep fname a))
, Storable (FieldType fname a))
type CanReadFieldArray (fname :: Symbol) (a :: Type)
= CanReadField fname a
type CanWriteFieldArray (fname :: Symbol) (a :: Type)
= CanWriteField fname a
instance VulkanMarshal (VkStruct a)
=> Eq (VkStruct a) where
a == b = EQ == cmpBytes# (sizeOf a) (unsafeAddr a) (unsafeAddr b)
{-# INLINE (==) #-}
instance VulkanMarshal (VkStruct a)
=> Ord (VkStruct a) where
compare a b = cmpBytes# (sizeOf a) (unsafeAddr a) (unsafeAddr b)
{-# INLINE compare #-}
instance VulkanMarshal (VkStruct a)
=> Storable (VkStruct a) where
sizeOf ~_ = sSize @(StructRep (VkStruct a))
{-# INLINE sizeOf #-}
alignment ~_ = sAlign @(StructRep (VkStruct a))
{-# INLINE alignment #-}
peek (Ptr addr)
| I# n <- sSize @(StructRep (VkStruct a))
, I# a <- sAlign @(StructRep (VkStruct a))
= IO
(\s -> case newAlignedPinnedByteArray# n a s of
(# s1, mba #) -> case copyAddrToByteArray# addr mba 0# n s1 of
s2 -> case unsafeFreezeByteArray# mba s2 of
(# s3, ba #) -> (# s3, unsafeFromByteArrayOffset 0# ba #)
)
{-# INLINE peek #-}
poke (Ptr addr) x
= c_memcpy addr (unsafeAddr x) (fromIntegral $ sSize @(StructRep (VkStruct a)))
{-# INLINE poke #-}
instance VulkanMarshal (VkStruct a)
=> Show (VkStruct a) where
showsPrec d x
= showParen (d >= 11)
$ (.) (showString (sName @(StructRep (VkStruct a))) . showString " {")
$ (\(b, s) -> if b then dropIt . s else s )
$ enumerateFields @(StructFields (VkStruct a))
( \(_ :: Proxy# m) s -> case isThatField @m of
Refl ->
( True
, sepIt . showString (fName @m)
. showString " = " . showField @(FName m) @m
. snd s
)
) (False, showString "}")
where
(dropIt, sepIt) = if sIsUnion @(StructRep (VkStruct a))
then (drop 3, showString " | ")
else (drop 2, showString ", ")
isThatField :: m :~: FieldRep (FName m) (VkStruct a)
isThatField = unsafeCoerce (Refl :: m :~: m)
showField :: forall (fname :: Symbol) (m :: FieldMeta)
. ( VulkanField m
, fname ~ FName m
, m ~ FieldRep fname (VkStruct a)
)
=> ShowS
showField = case fLength @m of
0 -> showString "[]"
1 -> shows @(FType m) (getF 0)
m -> showChar '[' . drop 2
. foldr (\i s -> showString ", " . shows @(FType m) (getF i) . s)
id [0..m-1]
. showChar ']'
where
getF :: Int -> FType m
getF i = unsafeDupablePerformIO $
peekByteOff @(FType m) (unsafePtr x)
(fByteOffset @m + i * sizeOf @(FType m) undefined)
{-# NOINLINE getF #-}
fieldOptional :: forall (fname :: Symbol) (a :: Type)
. HasField fname a => Bool
fieldOptional = fOptional @(FieldRep fname a)
fieldOffset :: forall (fname :: Symbol) (a :: Type)
. HasField fname a => Int
fieldOffset = fByteOffset @(FieldRep fname a)
fieldArrayLength :: forall (fname :: Symbol) (a :: Type)
. HasField fname a => Int
fieldArrayLength = fLength @(FieldRep fname a)
getField :: forall (fname :: Symbol) (a :: Type)
. CanReadField fname a => a -> FieldType fname a
getField x = unsafeDupablePerformIO $
peekByteOff (unsafePtr x) (fieldOffset @fname @a)
{-# NOINLINE getField #-}
readField :: forall (fname :: Symbol) (a :: Type)
. CanReadField fname a => Ptr a -> IO (FieldType fname a)
readField p = peekByteOff p (fieldOffset @fname @a)
writeField :: forall (fname :: Symbol) (a :: Type)
. CanWriteField fname a => Ptr a -> FieldType fname a -> IO ()
writeField p = pokeByteOff p (fieldOffset @fname @a)
getFieldArrayUnsafe :: forall (fname :: Symbol) (a :: Type)
. CanReadFieldArray fname a => Int -> a -> FieldType fname a
getFieldArrayUnsafe i = f
where
off = fieldOffset @fname @a + i * sizeOf @(FieldType fname a) undefined
f x = unsafeDupablePerformIO (peekByteOff (unsafePtr x) off)
{-# NOINLINE f #-}
readFieldArrayUnsafe :: forall (fname :: Symbol) (a :: Type)
. CanReadFieldArray fname a => Int -> Ptr a -> IO (FieldType fname a)
readFieldArrayUnsafe i p = peekByteOff p off
where
off = fieldOffset @fname @a + i * sizeOf @(FieldType fname a) undefined
writeFieldArrayUnsafe :: forall (fname :: Symbol) (a :: Type)
. CanWriteFieldArray fname a
=> Int -> Ptr a -> FieldType fname a -> IO ()
writeFieldArrayUnsafe i p = pokeByteOff p off
where
off = fieldOffset @fname @a + i * sizeOf @(FieldType fname a) undefined
getFieldArray :: forall fname idx a
. (CanReadFieldArray fname a, IndexInBounds fname idx a, KnownNat idx)
=> a -> FieldType fname a
getFieldArray = getFieldArrayUnsafe @fname @a
(fromInteger $ natVal' (proxy# :: Proxy# idx))
{-# INLINE getFieldArray #-}
readFieldArray :: forall fname idx a
. (CanReadFieldArray fname a, IndexInBounds fname idx a, KnownNat idx)
=> Ptr a -> IO (FieldType fname a)
readFieldArray = readFieldArrayUnsafe @fname @a
(fromInteger $ natVal' (proxy# :: Proxy# idx))
{-# INLINE readFieldArray #-}
writeFieldArray :: forall fname idx a
. (CanWriteFieldArray fname a, IndexInBounds fname idx a, KnownNat idx)
=> Ptr a -> FieldType fname a -> IO ()
writeFieldArray = writeFieldArrayUnsafe @fname @a
(fromInteger $ natVal' (proxy# :: Proxy# idx))
{-# INLINE writeFieldArray #-}
type IndexInBounds (s :: Symbol) (i :: Nat) (a :: Type)
= IndexInBounds' s i a (CmpNat i (FieldArrayLength s a))
type family IndexInBounds' (s :: Symbol)
(i :: Nat)
(a :: Type) (r :: Ordering) :: Constraint where
IndexInBounds' _ _ _ 'LT = ()
IndexInBounds' s i a _ = TypeError ( ErrorIndexOutOfBounds s i a )
type family IsTrue (errMsg :: ErrorMessage) (bool :: Bool) :: Constraint where
IsTrue _ 'True = ()
IsTrue err 'False = TypeError err
type ErrorNoSuchField (s :: Symbol) (a :: Type)
= 'Text "Structure " ':<>: 'ShowType a
':<>: 'Text " does not have field " ':<>: 'ShowType s ':<>: 'Text "."
':$$: 'Text "Note, this structure has following fields: "
':<>: 'ShowType (StructFieldNames a)
type ErrorIndexOutOfBounds (s :: Symbol) (i :: Nat) (a :: Type)
= 'Text "Array index " ':<>: 'ShowType i ':<>:
'Text " is out of bounds for '" ':<>:
'Text s ':<>: 'Text "', member of type " ':<>: 'ShowType a ':<>: 'Text "."
':$$:
'Text "Note: the array size is "
':<>: 'ShowType (FieldArrayLength s a) ':<>: 'Text "."
type ErrorNotReadableField (s :: Symbol) (a :: Type)
= 'Text "Field " ':<>: 'ShowType s ':<>:
'Text " of structure " ':<>: 'ShowType a ':<>:
'Text " is not readable."
type ErrorNotWritableField (s :: Symbol) (a :: Type)
= 'Text "Field " ':<>: 'ShowType s ':<>:
'Text " of structure " ':<>: 'ShowType a ':<>:
'Text " is not writable."
withCStringField :: forall fname a b
. ( CanReadFieldArray fname a
, FieldType fname a ~ CChar
, VulkanMarshal a
)
=> a -> (CString -> IO b) -> IO b
withCStringField x f = do
r <- f (unsafeCStringField @fname @a x)
touchVkData x
pure r
unsafeCStringField :: forall fname a
. ( CanReadFieldArray fname a
, FieldType fname a ~ CChar
, VulkanMarshal a
)
=> a -> CString
unsafeCStringField x = unsafePtr x `plusPtr` fieldOffset @fname @a
getStringField :: forall fname a
. ( CanReadFieldArray fname a
, FieldType fname a ~ CChar
, VulkanMarshal a
)
=> a -> String
getStringField x
= case takeForce (fieldArrayLength @fname @a)
. unsafeDupablePerformIO
$ withCStringField @fname @a x peekCString of
((), s) -> s
readStringField :: forall fname a
. ( CanReadFieldArray fname a
, FieldType fname a ~ CChar
, VulkanMarshal a
)
=> Ptr a -> IO String
readStringField px = do
((), s) <- takeForce (fieldArrayLength @fname @a)
<$> peekCString (px `plusPtr` fieldOffset @fname @a)
return s
writeStringField :: forall fname a
. ( CanWriteFieldArray fname a
, FieldType fname a ~ CChar
, VulkanMarshal a
)
=> Ptr a -> String -> IO ()
writeStringField px =
pokeArray0 '\0' (px `plusPtr` fieldOffset @fname @a)
takeForce :: Int -> String -> ((), String)
takeForce 0 _ = ((), [])
takeForce _ [] = ((), [])
takeForce n (x:xs) = seq x $ (x:) <$> takeForce (n-1) xs
cmpCStrings :: CString -> CString -> Ordering
cmpCStrings a b
| a == b = EQ
| otherwise = c_strcmp a b `compare` 0
cmpCStringsN :: CString -> CString -> Int -> Ordering
cmpCStringsN a b n
| a == b = EQ
| otherwise = c_strncmp a b (fromIntegral n) `compare` 0
foreign import ccall unsafe "strncmp"
c_strncmp :: CString -> CString -> CSize -> CInt
foreign import ccall unsafe "strcmp"
c_strcmp :: CString -> CString -> CInt
cmpBytes# :: Int -> Addr# -> Addr# -> Ordering
cmpBytes# n a b
| isTrue# (eqAddr# a b) = EQ
| otherwise = c_memcmp a b (fromIntegral n) `compare` 0
foreign import ccall unsafe "memcmp"
c_memcmp :: Addr# -> Addr# -> CSize -> CInt
foreign import ccall unsafe "memcpy"
c_memcpy :: Addr# -> Addr# -> CSize -> IO ()