{-# 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           #-}
-- | This module is not part of auto-generated code based on vk.xml.
--   Instead, it is hand-written to provide common types and classes.
--
--   DANGER!
--   This is an internal module; it can change a lot between package versions;
--   it provides low-level functions, most of which have user-friendly analogues.
module Graphics.Vulkan.Marshal.Internal
  ( VkStruct (..), unsafeFromByteArrayOffset
  , VulkanMarshal (..)
  , newVkData, mallocVkData, mallocVkDataArray, unsafePtr
  , fromForeignPtr, toForeignPtr, toPlainForeignPtr, touchVkData
    -- * Type-indexed access to struct members
  , 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
    -- * Type-level info about Structs
  , VulkanStruct (..), VulkanField (..), VulkanFields (..), KnownBool (..)
  , FieldMeta (..), StructMeta (..)
    -- * Utilities for string types
  , 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)



{- | Internal representation of all Vulkan structures:
     a pinned byte array and an address pointing to an area in this array.
 -}
data VkStruct a = VkStruct
  { forall a. VkStruct a -> Addr#
unsafeAddr      :: Addr#
    -- ^ Get address of vulkan structure.
    --   Note, the address is only valid as long as a given vulkan structure exists.
    --   Structures created with newVkData are stored in pinned byte arrays,
    --   so their memory is maintained by Haskell GC.
  , forall a. VkStruct a -> ByteArray#
unsafeByteArray :: ByteArray#
    -- ^ Get a @ByteArray#@ that keeps the data.
    --
    --   Note, the data structure does not necessarily starts at zero offset.
  }

-- | Get the type parameter of a `VkStruct`.
type family VkStruct' (a :: Type) :: Type where
    VkStruct' (VkStruct a) = a

-- | This type must be a `VkStruct`.
type IsVkStruct a = a ~ VkStruct (VkStruct' a)

-- | Combine a vulkan structure from ByteArray and an offset in this array.
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 #-}



{- |
@FieldMeta fieldName fieldType optional byteOffset length canRead canWrite@
represents a Vulkan structure field at the type level.
 -}
data FieldMeta
  = FieldMeta Symbol Type Bool Nat Nat Bool Bool

{- |
@StructMeta structName structType size alignment fields isUnion isReturnedOnly structExtends@
represents a Vulkan structure at the type level.
 -}
data StructMeta
  = StructMeta Symbol Type Nat Nat [FieldMeta] Bool Bool [Type]

-- | This class give a term-level boolean associated with a type-level boolean.
--
--   The same as `KnownNat` for integers.
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


-- | Descriptions of all fields of a vulkan struct
type StructFields a = SFields (StructRep a)
-- | Whether this type is a C union.
--   Otherwise this is a C structure.
type CUnionType a = SIsUnion (StructRep a)
-- | Notes that this struct or union is going to be filled in by the API,
--   rather than an application filling it out and passing it to the API.
type ReturnedOnly a = SIsReturnedOnly (StructRep a)
-- | Comma-separated list of structures whose "pNext" can include this type.
type StructExtends a = SStructExtends (StructRep a)

-- | All Vulkan structures are stored as-is in byte arrays to avoid any overheads
--   for wrapping and unwrapping haskell values.
--   VulkanMarshal provides an interfaces to write and read these structures
--   in an imperative way.
class (VulkanStruct (StructRep a), IsVkStruct a)
     => VulkanMarshal a where
    type StructRep a :: StructMeta

-- | Allocate a pinned aligned byte array to keep vulkan data structure
--   and fill it using a foreign function.
--
--   Note, the function is supposed to use `newAlignedPinnedByteArray#`
--   and does not guarantee to fill memory with zeroes.
--   Use `clearStorable` to make sure all bytes are set to zero.
--
--   Note, the memory is managed by GHC, thus no need for freeing it manually.
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 #-}

-- | Allocate a pinned aligned byte array to keep vulkan data structure.
--
--   Note, the function is supposed to use `newAlignedPinnedByteArray#`
--   and does not guarantee to fill memory with zeroes.
--   Use `clearStorable` to make sure all bytes are set to zero.
--
--   Note, the memory is managed by GHC, thus no need for freeing it manually.
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 #-}

-- | Allocate a pinned aligned byte array to keep vulkan data structures.
--   Returned `Ptr a` points to the first element in the contiguous array of
--   returned structures. Returned list elements point to the same memory area.
--   This function is unsafe in two ways:
--
--     * Several structures are stored next to each other, with no gaps;
--       it would break its alignment if the size is not multiple of alignment.
--     * Returned pointer is not tracked by GHC as a reference to the managed
--       memory. Thus, the array can be GCed if all references to the returned
--       list are lost.
--
--   Note, the function is supposed to use `newAlignedPinnedByteArray#`
--   and does not guarantee to fill memory with zeroes.
--   Use `clearStorable` to make sure all bytes are set to zero.
--
--   Note, the memory is managed by GHC, thus no need for freeing it manually.
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 #-}

-- | Get pointer to vulkan structure.
--   Note, the address is only valid as long as a given vulkan structure exists.
--   Structures created with newVkData are stored in pinned byte arrays,
--   so their memory is maintained by Haskell GC.
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 #-}

-- | Get vulkan structure referenced by a 'ForeignPtr' trying to avoid copying data.
--
--   This function does copy data if called on an unmanaged `ForeignPtr`
--   (i.e. one created from ordinary `Ptr` using something like `newForeignPtr`.).
--
--   This function does not copy data if called on a managed `ForeignPtr`
--   (i.e. one created using `mallocForeignPtr`, or `toForeignPtr`, or `toPlainForeignPtr`).
--
--   Note, `fromForeignPtr` does not copy finalizers of `ForeignPtr`.
--   Thus, if all references to original `ForeignPtr` are lost,
--     its attached finalizers may run even if the created structure is alive.
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 #-}


-- | Create a `ForeignPtr` referencing the structure without copying data.
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 #-}

-- | Create a `ForeignPtr` referencing the structure without copying data.
--   This version of a pointer carries no finalizers.
--
-- It is not possible to add a finalizer to a ForeignPtr created with
-- @toPlainForeignPtr@.
-- Attempts to add a finalizer to a ForeignPtr created this way, or to
-- finalize such a pointer, will throw an exception.
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 #-}

-- | Make sure this data is alive at a given point in a sequence of IO actions.
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

-- | A Constraint: a vulkan struct must have a field with a given name.
type HasField (fname :: Symbol) (a :: Type)
    = (VulkanMarshal a, VulkanField (FieldRep fname a))

-- | Type-level description of a Vulkan structure field.
type FieldRep (fname :: Symbol) (a :: Type)
    = GetFieldMeta (ErrorNoSuchField fname a) fname (StructFields a)

-- | Type of a field in a vulkan structure or union.
type FieldType (fname :: Symbol) (a :: Type)
    = FType (FieldRep fname a)

-- | Whether this field marked optional in vulkan specification.
--   Usually, this means that `VK_NULL` can be written in place
--   of this field.
type FieldOptional (fname :: Symbol) (a :: Type)
    = FOptional (FieldRep fname a)

-- | Offset of a field in bytes.
type FieldOffset (fname :: Symbol) (a :: Type)
    = FByteOffset (FieldRep fname a)

-- | Whether this field is a fixed-length array stored directly in a struct.
type FieldIsArray (fname :: Symbol) (a :: Type)
    = IsArrayLen (FLength (FieldRep fname a))

type family IsArrayLen (l :: Nat) :: Bool where
    IsArrayLen 1 = 'False
    IsArrayLen _ = 'True

-- | Length of an array that is a field of a structure or union
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 #-}



-- | Whether this field marked optional in vulkan specification.
--   Usually, this means that `VK_NULL` can be written in place
--   of this field.
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)

-- | Offset of a field in bytes.
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)

-- | Length of an array that is a field of a structure or union.
--
--   Returns @1@ if this field is not an array.
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)

-- | Index an array-type field. No bound checks.
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 #-}

-- | Read from an array-type field. No bound checks.
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

-- | Write to an array-type field. No bound checks.
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-level errors
--------------------------------------------------------------------------------

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."


--------------------------------------------------------------------------------
-- * Utilities for CString
--------------------------------------------------------------------------------

-- | Perform an action on a C string field.
--   The string pointers should not be used outside the callback.
--   It will point to a correct location only as long as the struct is alive.
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

-- | Get pointer to a memory location of the C string field in a structure.
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


-- | Check first if two CString point to the same memory location.
--   Otherwise, compare them using C @strcmp@ function.
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

-- | Check first if two CString point to the same memory location.
--   Otherwise, compare them using C @strncmp@ function.
--   It may be useful to provide maximum number of characters to compare.
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

-- | Internal function used to implement Eq and Ord instances for Vulkan structs.
--   Compares first n bytes of two memory areas.
--
--   Uses lexicographic ordering (c memcmp inside).
--
--   This is a helper that should be used in VulkanMarshal instances only.
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 ()