{-# 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#,
unsafeFreezeByteArray#, (*#), (+#), (>=#))
import GHC.Exts (Proxy#, proxy#, unsafeCoerce#)
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
{ forall a. VkStruct a -> Addr#
unsafeAddr :: Addr#
, forall a. VkStruct a -> ByteArray#
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 :: forall a. Int# -> ByteArray# -> VkStruct a
unsafeFromByteArrayOffset Int#
off ByteArray#
b
= Addr# -> ByteArray# -> VkStruct a
forall a. Addr# -> ByteArray# -> VkStruct a
VkStruct (Addr# -> Int# -> Addr#
plusAddr# (ByteArray# -> Addr#
byteArrayContents# ByteArray#
b) Int#
off) ByteArray#
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 :: Bool
boolSing = Bool
True
instance KnownBool 'False where boolSing :: Bool
boolSing = Bool
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 :: String
fName = forall (n :: Symbol). KnownSymbol n => Proxy# n -> String
symbolVal' @fieldName Proxy# fieldName
forall {k} (a :: k). Proxy# a
proxy#
fOptional :: Bool
fOptional = forall (b :: Bool). KnownBool b => Bool
boolSing @optional
fByteOffset :: Int
fByteOffset = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ forall (n :: Nat). KnownNat n => Proxy# n -> Integer
natVal' @byteOffset Proxy# byteOffset
forall {k} (a :: k). Proxy# a
proxy#
fLength :: Int
fLength = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ forall (n :: Nat). KnownNat n => Proxy# n -> Integer
natVal' @length Proxy# length
forall {k} (a :: k). Proxy# a
proxy#
fCanRead :: Bool
fCanRead = forall (b :: Bool). KnownBool b => Bool
boolSing @canRead
fCanWrite :: Bool
fCanWrite = forall (b :: Bool). KnownBool b => Bool
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 :: forall (fname :: Symbol) r (errMsg :: ErrorMessage).
KnownSymbol fname =>
Proxy# fname
-> Proxy# errMsg
-> (VulkanField (GetFieldMeta errMsg fname '[]) => r)
-> r
withField Proxy# fname
_ Proxy# errMsg
_ VulkanField (GetFieldMeta errMsg fname '[]) => r
_ = String -> r
forall a. HasCallStack => String -> a
error String
"VulkanFields.withField: unreachable code (no such field guarded by type family)."
enumerateFields :: forall a.
(forall (m :: FieldMeta). VulkanField m => Proxy# m -> a -> a)
-> a -> a
enumerateFields forall (m :: FieldMeta). VulkanField m => Proxy# m -> a -> a
_ = a -> a
forall a. a -> a
id
instance (VulkanField m, VulkanFields ms) => VulkanFields (m ': ms) where
withField :: forall (fname :: Symbol) r (errMsg :: ErrorMessage).
KnownSymbol fname =>
Proxy# fname
-> Proxy# errMsg
-> (VulkanField (GetFieldMeta errMsg fname (m : ms)) => r)
-> r
withField Proxy# fname
pName Proxy# errMsg
pErr VulkanField (GetFieldMeta errMsg fname (m : ms)) => r
f
| Proxy# fname -> String
forall (n :: Symbol). KnownSymbol n => Proxy# n -> String
symbolVal' Proxy# fname
pName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== forall (m :: FieldMeta). VulkanField m => String
fName @m
, m :~: GetFieldMeta errMsg fname (m : ms)
Refl <- Proxy# fname
-> Proxy# errMsg -> m :~: GetFieldMeta errMsg fname (m : ms)
forall (fname :: Symbol) (errMsg :: ErrorMessage).
Proxy# fname
-> Proxy# errMsg -> m :~: GetFieldMeta errMsg fname (m : ms)
proofm Proxy# fname
pName Proxy# errMsg
pErr = r
VulkanField (GetFieldMeta errMsg fname (m : ms)) => r
f
| GetFieldMeta errMsg fname ms :~: GetFieldMeta errMsg fname (m : ms)
Refl <- Proxy# fname
-> Proxy# errMsg
-> GetFieldMeta errMsg fname ms
:~: GetFieldMeta errMsg fname (m : ms)
forall (fname :: Symbol) (errMsg :: ErrorMessage).
Proxy# fname
-> Proxy# errMsg
-> GetFieldMeta errMsg fname ms
:~: GetFieldMeta errMsg fname (m : ms)
proofms Proxy# fname
pName Proxy# errMsg
pErr = forall (ms :: [FieldMeta]) (fname :: Symbol) r
(errMsg :: ErrorMessage).
(VulkanFields ms, KnownSymbol fname) =>
Proxy# fname
-> Proxy# errMsg
-> (VulkanField (GetFieldMeta errMsg fname ms) => r)
-> r
withField @ms Proxy# fname
pName Proxy# errMsg
pErr VulkanField (GetFieldMeta errMsg fname ms) => r
VulkanField (GetFieldMeta errMsg fname (m : ms)) => r
f
where
proofm :: Proxy# fname -> Proxy# errMsg
-> (m :~: GetFieldMeta errMsg fname (m : ms))
proofm :: forall (fname :: Symbol) (errMsg :: ErrorMessage).
Proxy# fname
-> Proxy# errMsg -> m :~: GetFieldMeta errMsg fname (m : ms)
proofm Proxy# fname
_ = (Any :~: Any)
-> Proxy# errMsg -> m :~: GetFieldMeta errMsg fname (m : ms)
forall a b. a -> b
unsafeCoerce Any :~: Any
forall {k} (a :: k). a :~: a
Refl
proofms :: Proxy# fname -> Proxy# errMsg
-> (GetFieldMeta errMsg fname ms :~: GetFieldMeta errMsg fname (m : ms))
proofms :: forall (fname :: Symbol) (errMsg :: ErrorMessage).
Proxy# fname
-> Proxy# errMsg
-> GetFieldMeta errMsg fname ms
:~: GetFieldMeta errMsg fname (m : ms)
proofms Proxy# fname
_ = (Any :~: Any)
-> Proxy# errMsg
-> GetFieldMeta errMsg fname ms
:~: GetFieldMeta errMsg fname (m : ms)
forall a b. a -> b
unsafeCoerce Any :~: Any
forall {k} (a :: k). a :~: a
Refl
enumerateFields :: forall a.
(forall (m :: FieldMeta). VulkanField m => Proxy# m -> a -> a)
-> a -> a
enumerateFields forall (m :: FieldMeta). VulkanField m => Proxy# m -> a -> a
k = Proxy# m -> a -> a
forall (m :: FieldMeta). VulkanField m => Proxy# m -> a -> a
k (Proxy# m
forall {k} (a :: k). Proxy# a
proxy# :: Proxy# m) (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (ms :: [FieldMeta]) a.
VulkanFields ms =>
(forall (m :: FieldMeta). VulkanField m => Proxy# m -> a -> a)
-> a -> a
enumerateFields @ms forall (m :: FieldMeta). VulkanField m => Proxy# m -> a -> a
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 :: String
sName = forall (n :: Symbol). KnownSymbol n => Proxy# n -> String
symbolVal' @structName Proxy# structName
forall {k} (a :: k). Proxy# a
proxy#
sSize :: Int
sSize = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ forall (n :: Nat). KnownNat n => Proxy# n -> Integer
natVal' @size Proxy# size
forall {k} (a :: k). Proxy# a
proxy#
sAlign :: Int
sAlign = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ forall (n :: Nat). KnownNat n => Proxy# n -> Integer
natVal' @alignment Proxy# alignment
forall {k} (a :: k). Proxy# a
proxy#
sIsUnion :: Bool
sIsUnion = forall (b :: Bool). KnownBool b => Bool
boolSing @isUnion
sIsReturnedOnly :: Bool
sIsReturnedOnly = forall (b :: Bool). KnownBool b => Bool
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 :: forall a. VulkanMarshal a => (Ptr a -> IO ()) -> IO a
newVkData Ptr a -> IO ()
f
| I# Int#
n <- forall (m :: StructMeta). VulkanStruct m => Int
sSize @(StructRep a)
, I# Int#
a <- forall (m :: StructMeta). VulkanStruct m => Int
sAlign @(StructRep a)
= (State# RealWorld
-> (# State# RealWorld, VkStruct (VkStruct' a) #))
-> IO (VkStruct (VkStruct' a))
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
(\State# RealWorld
s0 -> case Int#
-> Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d.
Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newAlignedPinnedByteArray# Int#
n Int#
a State# RealWorld
s0 of
(# State# RealWorld
s1, MutableByteArray# RealWorld
mba #) -> case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba State# RealWorld
s1 of
(# State# RealWorld
s2, ByteArray#
ba #) -> case Ptr a -> IO ()
f (Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr (ByteArray# -> Addr#
byteArrayContents# ByteArray#
ba)) of
IO State# RealWorld -> (# State# RealWorld, () #)
k -> case State# RealWorld -> (# State# RealWorld, () #)
k State# RealWorld
s2 of
(# State# RealWorld
s3, () #) -> (# State# RealWorld
s3, Int# -> ByteArray# -> VkStruct (VkStruct' a)
forall a. Int# -> ByteArray# -> VkStruct a
unsafeFromByteArrayOffset Int#
0# ByteArray#
ba #)
)
{-# INLINE newVkData #-}
mallocVkData :: forall a . VulkanMarshal a => IO a
mallocVkData :: forall a. VulkanMarshal a => IO a
mallocVkData
| I# Int#
n <- forall (m :: StructMeta). VulkanStruct m => Int
sSize @(StructRep a)
, I# Int#
a <- forall (m :: StructMeta). VulkanStruct m => Int
sAlign @(StructRep a)
= (State# RealWorld
-> (# State# RealWorld, VkStruct (VkStruct' a) #))
-> IO (VkStruct (VkStruct' a))
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
(\State# RealWorld
s0 -> case Int#
-> Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d.
Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newAlignedPinnedByteArray# Int#
n Int#
a State# RealWorld
s0 of
(# State# RealWorld
s1, MutableByteArray# RealWorld
mba #) -> case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba State# RealWorld
s1 of
(# State# RealWorld
s2, ByteArray#
ba #) -> (# State# RealWorld
s2, Int# -> ByteArray# -> VkStruct (VkStruct' a)
forall a. Int# -> ByteArray# -> VkStruct a
unsafeFromByteArrayOffset Int#
0# ByteArray#
ba #)
)
{-# INLINE mallocVkData #-}
mallocVkDataArray :: forall a . VulkanMarshal a => Int -> IO (Ptr a, [a])
mallocVkDataArray :: forall a. VulkanMarshal a => Int -> IO (Ptr a, [a])
mallocVkDataArray (I# Int#
m)
| I# Int#
n <- forall (m :: StructMeta). VulkanStruct m => Int
sSize @(StructRep a)
, I# Int#
a <- forall (m :: StructMeta). VulkanStruct m => Int
sAlign @(StructRep a)
, Int#
nm <- Int#
n Int# -> Int# -> Int#
*# Int#
m
= (State# RealWorld
-> (# State# RealWorld, (Ptr a, [VkStruct (VkStruct' a)]) #))
-> IO (Ptr a, [VkStruct (VkStruct' a)])
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
(\State# RealWorld
s0 -> case Int#
-> Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d.
Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newAlignedPinnedByteArray# Int#
nm Int#
a State# RealWorld
s0 of
(# State# RealWorld
s1, MutableByteArray# RealWorld
mba #) -> case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba State# RealWorld
s1 of
(# State# RealWorld
s2, ByteArray#
ba #) ->
(# State# RealWorld
s2
, ( Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr (ByteArray# -> Addr#
byteArrayContents# ByteArray#
ba)
, let go :: Int# -> [VkStruct (VkStruct' a)]
go Int#
k | Int# -> Bool
isTrue# (Int#
k Int# -> Int# -> Int#
>=# Int#
nm) = []
| Bool
otherwise = Int# -> ByteArray# -> VkStruct (VkStruct' a)
forall a. Int# -> ByteArray# -> VkStruct a
unsafeFromByteArrayOffset Int#
k ByteArray#
ba
VkStruct (VkStruct' a)
-> [VkStruct (VkStruct' a)] -> [VkStruct (VkStruct' a)]
forall a. a -> [a] -> [a]
: Int# -> [VkStruct (VkStruct' a)]
go (Int#
k Int# -> Int# -> Int#
+# Int#
n)
in Int# -> [VkStruct (VkStruct' a)]
go Int#
0#
)
#)
)
{-# INLINE mallocVkDataArray #-}
unsafePtr :: IsVkStruct a => a -> Ptr a
unsafePtr :: forall a. IsVkStruct a => a -> Ptr a
unsafePtr a
a = Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr (VkStruct (VkStruct' a) -> Addr#
forall a. VkStruct a -> Addr#
unsafeAddr a
VkStruct (VkStruct' a)
a)
{-# INLINE unsafePtr #-}
fromForeignPtr :: forall a . VulkanMarshal a => ForeignPtr a -> IO a
fromForeignPtr :: forall a. VulkanMarshal a => ForeignPtr a -> IO a
fromForeignPtr (ForeignPtr Addr#
addr PlainForeignPtr{})
| I# Int#
n <- forall (m :: StructMeta). VulkanStruct m => Int
sSize @(StructRep a)
, I# Int#
a <- forall (m :: StructMeta). VulkanStruct m => Int
sAlign @(StructRep a)
= (State# RealWorld
-> (# State# RealWorld, VkStruct (VkStruct' a) #))
-> IO (VkStruct (VkStruct' a))
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
(\State# RealWorld
s0 -> case Int#
-> Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d.
Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newAlignedPinnedByteArray# Int#
n Int#
a State# RealWorld
s0 of
(# State# RealWorld
s1, MutableByteArray# RealWorld
mba #) -> case 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
mba Int#
0# Int#
n State# RealWorld
s1 of
State# RealWorld
s2 -> case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba State# RealWorld
s2 of
(# State# RealWorld
s3, ByteArray#
ba #) -> (# State# RealWorld
s3, Int# -> ByteArray# -> VkStruct (VkStruct' a)
forall a. Int# -> ByteArray# -> VkStruct a
unsafeFromByteArrayOffset Int#
0# ByteArray#
ba #)
)
fromForeignPtr (ForeignPtr Addr#
addr (MallocPtr MutableByteArray# RealWorld
mba IORef Finalizers
_))
= (State# RealWorld
-> (# State# RealWorld, VkStruct (VkStruct' a) #))
-> IO (VkStruct (VkStruct' a))
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
(\State# RealWorld
s0 -> case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba State# RealWorld
s0 of
(# State# RealWorld
s1, ByteArray#
ba #) -> (# State# RealWorld
s1, Int# -> ByteArray# -> VkStruct (VkStruct' a)
forall a. Int# -> ByteArray# -> VkStruct a
unsafeFromByteArrayOffset
(Addr# -> Addr# -> Int#
minusAddr# Addr#
addr (ByteArray# -> Addr#
byteArrayContents# ByteArray#
ba)) ByteArray#
ba #)
)
fromForeignPtr (ForeignPtr Addr#
addr (PlainPtr MutableByteArray# RealWorld
mba))
= (State# RealWorld
-> (# State# RealWorld, VkStruct (VkStruct' a) #))
-> IO (VkStruct (VkStruct' a))
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
(\State# RealWorld
s0 -> case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba State# RealWorld
s0 of
(# State# RealWorld
s1, ByteArray#
ba #) -> (# State# RealWorld
s1, Int# -> ByteArray# -> VkStruct (VkStruct' a)
forall a. Int# -> ByteArray# -> VkStruct a
unsafeFromByteArrayOffset
(Addr# -> Addr# -> Int#
minusAddr# Addr#
addr (ByteArray# -> Addr#
byteArrayContents# ByteArray#
ba)) ByteArray#
ba #)
)
{-# INLINE fromForeignPtr #-}
toForeignPtr :: IsVkStruct a => a -> IO (ForeignPtr a)
toForeignPtr :: forall a. IsVkStruct a => a -> IO (ForeignPtr a)
toForeignPtr a
x
| Addr#
a <- VkStruct (VkStruct' a) -> Addr#
forall a. VkStruct a -> Addr#
unsafeAddr a
VkStruct (VkStruct' a)
x
, ByteArray#
b <- VkStruct (VkStruct' a) -> ByteArray#
forall a. VkStruct a -> ByteArray#
unsafeByteArray a
VkStruct (VkStruct' a)
x = do
ForeignPtr Addr#
_ (PlainForeignPtr IORef Finalizers
r)
<- Ptr Any -> IO (ForeignPtr Any)
forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ (Addr# -> Ptr Any
forall a. Addr# -> Ptr a
Ptr Addr#
a)
(State# RealWorld -> (# State# RealWorld, ForeignPtr a #))
-> IO (ForeignPtr a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s -> (# State# RealWorld
s, Addr# -> ForeignPtrContents -> ForeignPtr a
forall a. Addr# -> ForeignPtrContents -> ForeignPtr a
ForeignPtr Addr#
a (MutableByteArray# RealWorld
-> IORef Finalizers -> ForeignPtrContents
MallocPtr (ByteArray# -> MutableByteArray# RealWorld
unsafeCoerce# ByteArray#
b) IORef Finalizers
r) #))
{-# INLINE toForeignPtr #-}
toPlainForeignPtr :: IsVkStruct a => a -> IO (ForeignPtr a)
toPlainForeignPtr :: forall a. IsVkStruct a => a -> IO (ForeignPtr a)
toPlainForeignPtr (VkStruct Addr#
a ByteArray#
b) = (State# RealWorld -> (# State# RealWorld, ForeignPtr a #))
-> IO (ForeignPtr a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
(\State# RealWorld
s -> (# State# RealWorld
s, Addr# -> ForeignPtrContents -> ForeignPtr a
forall a. Addr# -> ForeignPtrContents -> ForeignPtr a
ForeignPtr Addr#
a (MutableByteArray# RealWorld -> ForeignPtrContents
PlainPtr (ByteArray# -> MutableByteArray# RealWorld
unsafeCoerce# ByteArray#
b)) #))
{-# INLINE toPlainForeignPtr #-}
touchVkData :: IsVkStruct a => a -> IO ()
touchVkData :: forall a. IsVkStruct a => a -> IO ()
touchVkData (VkStruct Addr#
_ ByteArray#
b) = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s -> (# ByteArray# -> State# RealWorld -> State# RealWorld
touch# ByteArray#
b State# RealWorld
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
VkStruct a
a == :: VkStruct a -> VkStruct a -> Bool
== VkStruct a
b = Ordering
EQ Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Addr# -> Addr# -> Ordering
cmpBytes# (VkStruct a -> Int
forall a. Storable a => a -> Int
sizeOf VkStruct a
a) (VkStruct a -> Addr#
forall a. VkStruct a -> Addr#
unsafeAddr VkStruct a
a) (VkStruct a -> Addr#
forall a. VkStruct a -> Addr#
unsafeAddr VkStruct a
b)
{-# INLINE (==) #-}
instance VulkanMarshal (VkStruct a)
=> Ord (VkStruct a) where
compare :: VkStruct a -> VkStruct a -> Ordering
compare VkStruct a
a VkStruct a
b = Int -> Addr# -> Addr# -> Ordering
cmpBytes# (VkStruct a -> Int
forall a. Storable a => a -> Int
sizeOf VkStruct a
a) (VkStruct a -> Addr#
forall a. VkStruct a -> Addr#
unsafeAddr VkStruct a
a) (VkStruct a -> Addr#
forall a. VkStruct a -> Addr#
unsafeAddr VkStruct a
b)
{-# INLINE compare #-}
instance VulkanMarshal (VkStruct a)
=> Storable (VkStruct a) where
sizeOf :: VkStruct a -> Int
sizeOf ~VkStruct a
_ = forall (m :: StructMeta). VulkanStruct m => Int
sSize @(StructRep (VkStruct a))
{-# INLINE sizeOf #-}
alignment :: VkStruct a -> Int
alignment ~VkStruct a
_ = forall (m :: StructMeta). VulkanStruct m => Int
sAlign @(StructRep (VkStruct a))
{-# INLINE alignment #-}
peek :: Ptr (VkStruct a) -> IO (VkStruct a)
peek (Ptr Addr#
addr)
| I# Int#
n <- forall (m :: StructMeta). VulkanStruct m => Int
sSize @(StructRep (VkStruct a))
, I# Int#
a <- forall (m :: StructMeta). VulkanStruct m => Int
sAlign @(StructRep (VkStruct a))
= (State# RealWorld -> (# State# RealWorld, VkStruct a #))
-> IO (VkStruct a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
(\State# RealWorld
s -> case Int#
-> Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d.
Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newAlignedPinnedByteArray# Int#
n Int#
a State# RealWorld
s of
(# State# RealWorld
s1, MutableByteArray# RealWorld
mba #) -> case 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
mba Int#
0# Int#
n State# RealWorld
s1 of
State# RealWorld
s2 -> case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba State# RealWorld
s2 of
(# State# RealWorld
s3, ByteArray#
ba #) -> (# State# RealWorld
s3, Int# -> ByteArray# -> VkStruct a
forall a. Int# -> ByteArray# -> VkStruct a
unsafeFromByteArrayOffset Int#
0# ByteArray#
ba #)
)
{-# INLINE peek #-}
poke :: Ptr (VkStruct a) -> VkStruct a -> IO ()
poke (Ptr Addr#
addr) VkStruct a
x
= Addr# -> Addr# -> CSize -> IO ()
c_memcpy Addr#
addr (VkStruct a -> Addr#
forall a. VkStruct a -> Addr#
unsafeAddr VkStruct a
x) (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CSize) -> Int -> CSize
forall a b. (a -> b) -> a -> b
$ forall (m :: StructMeta). VulkanStruct m => Int
sSize @(StructRep (VkStruct a)))
{-# INLINE poke #-}
instance VulkanMarshal (VkStruct a)
=> Show (VkStruct a) where
showsPrec :: Int -> VkStruct a -> ShowS
showsPrec Int
d VkStruct a
x
= Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11)
(ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (String -> ShowS
showString (forall (m :: StructMeta). VulkanStruct m => String
sName @(StructRep (VkStruct a))) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" {")
(ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (\(Bool
b, ShowS
s) -> if Bool
b then ShowS
dropIt ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
s else ShowS
s )
((Bool, ShowS) -> ShowS) -> (Bool, ShowS) -> ShowS
forall a b. (a -> b) -> a -> b
$ forall (ms :: [FieldMeta]) a.
VulkanFields ms =>
(forall (m :: FieldMeta). VulkanField m => Proxy# m -> a -> a)
-> a -> a
enumerateFields @(StructFields (VkStruct a))
( \(Proxy# m
_ :: Proxy# m) (Bool, ShowS)
s -> case forall (m :: FieldMeta). m :~: FieldRep (FName m) (VkStruct a)
isThatField @m of
m :~: FieldRep (FName m) (VkStruct a)
Refl ->
( Bool
True
, ShowS
sepIt ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (forall (m :: FieldMeta). VulkanField m => String
fName @m)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fname :: Symbol) (m :: FieldMeta).
(VulkanField m, fname ~ FName m,
m ~ FieldRep fname (VkStruct a)) =>
ShowS
showField @(FName m) @m
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, ShowS) -> ShowS
forall a b. (a, b) -> b
snd (Bool, ShowS)
s
)
) (Bool
False, String -> ShowS
showString String
"}")
where
(ShowS
dropIt, ShowS
sepIt) = if forall (m :: StructMeta). VulkanStruct m => Bool
sIsUnion @(StructRep (VkStruct a))
then (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
3, String -> ShowS
showString String
" | ")
else (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
2, String -> ShowS
showString String
", ")
isThatField :: m :~: FieldRep (FName m) (VkStruct a)
isThatField :: forall (m :: FieldMeta). m :~: FieldRep (FName m) (VkStruct a)
isThatField = (Any :~: Any)
-> m
:~: GetFieldMeta
((((('Text "Structure " ':<>: 'ShowType (VkStruct a))
':<>: 'Text " does not have field ")
':<>: 'ShowType (FName m))
':<>: 'Text ".")
':$$: ('Text "Note, this structure has following fields: "
':<>: 'ShowType (FieldNames (SFields (StructRep (VkStruct a))))))
(FName m)
(SFields (StructRep (VkStruct a)))
forall a b. a -> b
unsafeCoerce (forall {m}. m :~: m
forall {k} (a :: k). a :~: a
Refl :: m :~: m)
showField :: forall (fname :: Symbol) (m :: FieldMeta)
. ( VulkanField m
, fname ~ FName m
, m ~ FieldRep fname (VkStruct a)
)
=> ShowS
showField :: forall (fname :: Symbol) (m :: FieldMeta).
(VulkanField m, fname ~ FName m,
m ~ FieldRep fname (VkStruct a)) =>
ShowS
showField = case forall (m :: FieldMeta). VulkanField m => Int
fLength @m of
Int
0 -> String -> ShowS
showString String
"[]"
Int
1 -> forall a. Show a => a -> ShowS
shows @(FType m) (Int -> FType m
getF Int
0)
Int
m -> Char -> ShowS
showChar Char
'[' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
2
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> ShowS -> ShowS) -> ShowS -> [Int] -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Int
i ShowS
s -> String -> ShowS
showString String
", " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows @(FType m) (Int -> FType m
getF Int
i) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
s)
ShowS
forall a. a -> a
id [Int
0..Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
']'
where
getF :: Int -> FType m
getF :: Int -> FType m
getF Int
i = IO (FType m) -> FType m
forall a. IO a -> a
unsafeDupablePerformIO (IO (FType m) -> FType m) -> IO (FType m) -> FType m
forall a b. (a -> b) -> a -> b
$
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff @(FType m) (VkStruct a -> Ptr (VkStruct a)
forall a. IsVkStruct a => a -> Ptr a
unsafePtr VkStruct a
x)
(forall (m :: FieldMeta). VulkanField m => Int
fByteOffset @m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall a. Storable a => a -> Int
sizeOf @(FType m) FType m
forall a. HasCallStack => a
undefined)
{-# NOINLINE getF #-}
fieldOptional :: forall (fname :: Symbol) (a :: Type)
. HasField fname a => Bool
fieldOptional :: forall (fname :: Symbol) a. HasField fname a => Bool
fieldOptional = forall (m :: FieldMeta). VulkanField m => Bool
fOptional @(FieldRep fname a)
fieldOffset :: forall (fname :: Symbol) (a :: Type)
. HasField fname a => Int
fieldOffset :: forall (fname :: Symbol) a. HasField fname a => Int
fieldOffset = forall (m :: FieldMeta). VulkanField m => Int
fByteOffset @(FieldRep fname a)
fieldArrayLength :: forall (fname :: Symbol) (a :: Type)
. HasField fname a => Int
fieldArrayLength :: forall (fname :: Symbol) a. HasField fname a => Int
fieldArrayLength = forall (m :: FieldMeta). VulkanField m => Int
fLength @(FieldRep fname a)
getField :: forall (fname :: Symbol) (a :: Type)
. CanReadField fname a => a -> FieldType fname a
getField :: forall (fname :: Symbol) a.
CanReadField fname a =>
a -> FieldType fname a
getField a
x = IO
(FType
(GetFieldMeta
((((('Text "Structure " ':<>: 'ShowType a)
':<>: 'Text " does not have field ")
':<>: 'ShowType fname)
':<>: 'Text ".")
':$$: ('Text "Note, this structure has following fields: "
':<>: 'ShowType (FieldNames (SFields (StructRep a)))))
fname
(SFields (StructRep a))))
-> FType
(GetFieldMeta
((((('Text "Structure " ':<>: 'ShowType a)
':<>: 'Text " does not have field ")
':<>: 'ShowType fname)
':<>: 'Text ".")
':$$: ('Text "Note, this structure has following fields: "
':<>: 'ShowType (FieldNames (SFields (StructRep a)))))
fname
(SFields (StructRep a)))
forall a. IO a -> a
unsafeDupablePerformIO (IO
(FType
(GetFieldMeta
((((('Text "Structure " ':<>: 'ShowType a)
':<>: 'Text " does not have field ")
':<>: 'ShowType fname)
':<>: 'Text ".")
':$$: ('Text "Note, this structure has following fields: "
':<>: 'ShowType (FieldNames (SFields (StructRep a)))))
fname
(SFields (StructRep a))))
-> FType
(GetFieldMeta
((((('Text "Structure " ':<>: 'ShowType a)
':<>: 'Text " does not have field ")
':<>: 'ShowType fname)
':<>: 'Text ".")
':$$: ('Text "Note, this structure has following fields: "
':<>: 'ShowType (FieldNames (SFields (StructRep a)))))
fname
(SFields (StructRep a))))
-> IO
(FType
(GetFieldMeta
((((('Text "Structure " ':<>: 'ShowType a)
':<>: 'Text " does not have field ")
':<>: 'ShowType fname)
':<>: 'Text ".")
':$$: ('Text "Note, this structure has following fields: "
':<>: 'ShowType (FieldNames (SFields (StructRep a)))))
fname
(SFields (StructRep a))))
-> FType
(GetFieldMeta
((((('Text "Structure " ':<>: 'ShowType a)
':<>: 'Text " does not have field ")
':<>: 'ShowType fname)
':<>: 'Text ".")
':$$: ('Text "Note, this structure has following fields: "
':<>: 'ShowType (FieldNames (SFields (StructRep a)))))
fname
(SFields (StructRep a)))
forall a b. (a -> b) -> a -> b
$
Ptr a
-> Int
-> IO
(FType
(GetFieldMeta
((((('Text "Structure " ':<>: 'ShowType a)
':<>: 'Text " does not have field ")
':<>: 'ShowType fname)
':<>: 'Text ".")
':$$: ('Text "Note, this structure has following fields: "
':<>: 'ShowType (FieldNames (SFields (StructRep a)))))
fname
(SFields (StructRep a))))
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff (a -> Ptr a
forall a. IsVkStruct a => a -> Ptr a
unsafePtr a
x) (forall (fname :: Symbol) a. HasField fname a => Int
fieldOffset @fname @a)
{-# NOINLINE getField #-}
readField :: forall (fname :: Symbol) (a :: Type)
. CanReadField fname a => Ptr a -> IO (FieldType fname a)
readField :: forall (fname :: Symbol) a.
CanReadField fname a =>
Ptr a -> IO (FieldType fname a)
readField Ptr a
p = Ptr a
-> Int
-> IO
(FType
(GetFieldMeta
((((('Text "Structure " ':<>: 'ShowType a)
':<>: 'Text " does not have field ")
':<>: 'ShowType fname)
':<>: 'Text ".")
':$$: ('Text "Note, this structure has following fields: "
':<>: 'ShowType (FieldNames (SFields (StructRep a)))))
fname
(SFields (StructRep a))))
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
p (forall (fname :: Symbol) a. HasField fname a => Int
fieldOffset @fname @a)
writeField :: forall (fname :: Symbol) (a :: Type)
. CanWriteField fname a => Ptr a -> FieldType fname a -> IO ()
writeField :: forall (fname :: Symbol) a.
CanWriteField fname a =>
Ptr a -> FieldType fname a -> IO ()
writeField Ptr a
p = Ptr a
-> Int
-> FType
(GetFieldMeta
((((('Text "Structure " ':<>: 'ShowType a)
':<>: 'Text " does not have field ")
':<>: 'ShowType fname)
':<>: 'Text ".")
':$$: ('Text "Note, this structure has following fields: "
':<>: 'ShowType (FieldNames (SFields (StructRep a)))))
fname
(SFields (StructRep a)))
-> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
p (forall (fname :: Symbol) a. HasField fname a => Int
fieldOffset @fname @a)
getFieldArrayUnsafe :: forall (fname :: Symbol) (a :: Type)
. CanReadFieldArray fname a => Int -> a -> FieldType fname a
getFieldArrayUnsafe :: forall (fname :: Symbol) a.
CanReadFieldArray fname a =>
Int -> a -> FieldType fname a
getFieldArrayUnsafe Int
i = a -> FieldType fname a
f
where
off :: Int
off = forall (fname :: Symbol) a. HasField fname a => Int
fieldOffset @fname @a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall a. Storable a => a -> Int
sizeOf @(FieldType fname a) FieldType fname a
forall a. HasCallStack => a
undefined
f :: a -> FieldType fname a
f a
x = IO (FieldType fname a) -> FieldType fname a
forall a. IO a -> a
unsafeDupablePerformIO (Ptr a -> Int -> IO (FieldType fname a)
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff (a -> Ptr a
forall a. IsVkStruct a => a -> Ptr a
unsafePtr a
x) Int
off)
{-# NOINLINE f #-}
readFieldArrayUnsafe :: forall (fname :: Symbol) (a :: Type)
. CanReadFieldArray fname a => Int -> Ptr a -> IO (FieldType fname a)
readFieldArrayUnsafe :: forall (fname :: Symbol) a.
CanReadFieldArray fname a =>
Int -> Ptr a -> IO (FieldType fname a)
readFieldArrayUnsafe Int
i Ptr a
p = Ptr a -> Int -> IO (FieldType fname a)
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
p Int
off
where
off :: Int
off = forall (fname :: Symbol) a. HasField fname a => Int
fieldOffset @fname @a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall a. Storable a => a -> Int
sizeOf @(FieldType fname a) FieldType fname a
forall a. HasCallStack => a
undefined
writeFieldArrayUnsafe :: forall (fname :: Symbol) (a :: Type)
. CanWriteFieldArray fname a
=> Int -> Ptr a -> FieldType fname a -> IO ()
writeFieldArrayUnsafe :: forall (fname :: Symbol) a.
CanWriteFieldArray fname a =>
Int -> Ptr a -> FieldType fname a -> IO ()
writeFieldArrayUnsafe Int
i Ptr a
p = Ptr a -> Int -> FieldType fname a -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
p Int
off
where
off :: Int
off = forall (fname :: Symbol) a. HasField fname a => Int
fieldOffset @fname @a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall a. Storable a => a -> Int
sizeOf @(FieldType fname a) FieldType fname a
forall a. HasCallStack => a
undefined
getFieldArray :: forall fname idx a
. (CanReadFieldArray fname a, IndexInBounds fname idx a, KnownNat idx)
=> a -> FieldType fname a
getFieldArray :: forall (fname :: Symbol) (idx :: Nat) a.
(CanReadFieldArray fname a, IndexInBounds fname idx a,
KnownNat idx) =>
a -> FieldType fname a
getFieldArray = forall (fname :: Symbol) a.
CanReadFieldArray fname a =>
Int -> a -> FieldType fname a
getFieldArrayUnsafe @fname @a
(Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy# idx -> Integer
forall (n :: Nat). KnownNat n => Proxy# n -> Integer
natVal' (Proxy# idx
forall {k} (a :: k). Proxy# a
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 :: forall (fname :: Symbol) (idx :: Nat) a.
(CanReadFieldArray fname a, IndexInBounds fname idx a,
KnownNat idx) =>
Ptr a -> IO (FieldType fname a)
readFieldArray = forall (fname :: Symbol) a.
CanReadFieldArray fname a =>
Int -> Ptr a -> IO (FieldType fname a)
readFieldArrayUnsafe @fname @a
(Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy# idx -> Integer
forall (n :: Nat). KnownNat n => Proxy# n -> Integer
natVal' (Proxy# idx
forall {k} (a :: k). Proxy# a
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 :: forall (fname :: Symbol) (idx :: Nat) a.
(CanWriteFieldArray fname a, IndexInBounds fname idx a,
KnownNat idx) =>
Ptr a -> FieldType fname a -> IO ()
writeFieldArray = forall (fname :: Symbol) a.
CanWriteFieldArray fname a =>
Int -> Ptr a -> FieldType fname a -> IO ()
writeFieldArrayUnsafe @fname @a
(Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy# idx -> Integer
forall (n :: Nat). KnownNat n => Proxy# n -> Integer
natVal' (Proxy# idx
forall {k} (a :: k). Proxy# a
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 :: forall (fname :: Symbol) a b.
(CanReadFieldArray fname a, FieldType fname a ~ CChar,
VulkanMarshal a) =>
a -> (CString -> IO b) -> IO b
withCStringField a
x CString -> IO b
f = do
b
r <- CString -> IO b
f (forall (fname :: Symbol) a.
(CanReadFieldArray fname a, FieldType fname a ~ CChar,
VulkanMarshal a) =>
a -> CString
unsafeCStringField @fname @a a
x)
a -> IO ()
forall a. IsVkStruct a => a -> IO ()
touchVkData a
x
b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
r
unsafeCStringField :: forall fname a
. ( CanReadFieldArray fname a
, FieldType fname a ~ CChar
, VulkanMarshal a
)
=> a -> CString
unsafeCStringField :: forall (fname :: Symbol) a.
(CanReadFieldArray fname a, FieldType fname a ~ CChar,
VulkanMarshal a) =>
a -> CString
unsafeCStringField a
x = a -> Ptr a
forall a. IsVkStruct a => a -> Ptr a
unsafePtr a
x Ptr a -> Int -> CString
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall (fname :: Symbol) a. HasField fname a => Int
fieldOffset @fname @a
getStringField :: forall fname a
. ( CanReadFieldArray fname a
, FieldType fname a ~ CChar
, VulkanMarshal a
)
=> a -> String
getStringField :: forall (fname :: Symbol) a.
(CanReadFieldArray fname a, FieldType fname a ~ CChar,
VulkanMarshal a) =>
a -> String
getStringField a
x
= case Int -> String -> ((), String)
takeForce (forall (fname :: Symbol) a. HasField fname a => Int
fieldArrayLength @fname @a)
(String -> ((), String))
-> (IO String -> String) -> IO String -> ((), String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO String -> String
forall a. IO a -> a
unsafeDupablePerformIO
(IO String -> ((), String)) -> IO String -> ((), String)
forall a b. (a -> b) -> a -> b
$ forall (fname :: Symbol) a b.
(CanReadFieldArray fname a, FieldType fname a ~ CChar,
VulkanMarshal a) =>
a -> (CString -> IO b) -> IO b
withCStringField @fname @a a
x CString -> IO String
peekCString of
((), String
s) -> String
s
readStringField :: forall fname a
. ( CanReadFieldArray fname a
, FieldType fname a ~ CChar
, VulkanMarshal a
)
=> Ptr a -> IO String
readStringField :: forall (fname :: Symbol) a.
(CanReadFieldArray fname a, FieldType fname a ~ CChar,
VulkanMarshal a) =>
Ptr a -> IO String
readStringField Ptr a
px = do
((), String
s) <- Int -> String -> ((), String)
takeForce (forall (fname :: Symbol) a. HasField fname a => Int
fieldArrayLength @fname @a)
(String -> ((), String)) -> IO String -> IO ((), String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> IO String
peekCString (Ptr a
px Ptr a -> Int -> CString
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall (fname :: Symbol) a. HasField fname a => Int
fieldOffset @fname @a)
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
s
writeStringField :: forall fname a
. ( CanWriteFieldArray fname a
, FieldType fname a ~ CChar
, VulkanMarshal a
)
=> Ptr a -> String -> IO ()
writeStringField :: forall (fname :: Symbol) a.
(CanWriteFieldArray fname a, FieldType fname a ~ CChar,
VulkanMarshal a) =>
Ptr a -> String -> IO ()
writeStringField Ptr a
px =
Char -> Ptr Char -> String -> IO ()
forall a. Storable a => a -> Ptr a -> [a] -> IO ()
pokeArray0 Char
'\0' (Ptr a
px Ptr a -> Int -> Ptr Char
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall (fname :: Symbol) a. HasField fname a => Int
fieldOffset @fname @a)
takeForce :: Int -> String -> ((), String)
takeForce :: Int -> String -> ((), String)
takeForce Int
0 String
_ = ((), [])
takeForce Int
_ [] = ((), [])
takeForce Int
n (Char
x:String
xs) = Char -> ((), String) -> ((), String)
seq Char
x (((), String) -> ((), String)) -> ((), String) -> ((), String)
forall a b. (a -> b) -> a -> b
$ (Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ((), String) -> ((), String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> String -> ((), String)
takeForce (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) String
xs
cmpCStrings :: CString -> CString -> Ordering
cmpCStrings :: CString -> CString -> Ordering
cmpCStrings CString
a CString
b
| CString
a CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
b = Ordering
EQ
| Bool
otherwise = CString -> CString -> CInt
c_strcmp CString
a CString
b CInt -> CInt -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` CInt
0
cmpCStringsN :: CString -> CString -> Int -> Ordering
cmpCStringsN :: CString -> CString -> Int -> Ordering
cmpCStringsN CString
a CString
b Int
n
| CString
a CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
b = Ordering
EQ
| Bool
otherwise = CString -> CString -> CSize -> CInt
c_strncmp CString
a CString
b (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) CInt -> CInt -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` CInt
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# :: Int -> Addr# -> Addr# -> Ordering
cmpBytes# Int
n Addr#
a Addr#
b
| Int# -> Bool
isTrue# (Addr# -> Addr# -> Int#
eqAddr# Addr#
a Addr#
b) = Ordering
EQ
| Bool
otherwise = Addr# -> Addr# -> CSize -> CInt
c_memcmp Addr#
a Addr#
b (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) CInt -> CInt -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` CInt
0
foreign import ccall unsafe "memcmp"
c_memcmp :: Addr# -> Addr# -> CSize -> CInt
foreign import ccall unsafe "memcpy"
c_memcpy :: Addr# -> Addr# -> CSize -> IO ()