{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE ExplicitNamespaces    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MagicHash             #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE RoleAnnotations       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE Strict                #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UnboxedTuples         #-}
{-# LANGUAGE UndecidableInstances  #-}
-- | This module is not part of auto-generated code based on vk.xml.
--   It is also not included into `Graphics.Vulkan`.
--   It just provides convenient helpers for creation of vulkan structures.
module Graphics.Vulkan.Marshal.Create
    ( CreateVkStruct ()
    , createVk, (&*)
    , set, setAt, setVk, setVkRef, setStr, setStrRef, setStrListRef, setListRef
    , SetOptionalFields (..), HandleRemainingFields (..), HandleRemFields
    ) where

import           Data.Coerce
import           Data.Kind                        (Constraint, Type)
import           Data.Type.Bool                   (If, type (||))
import           Data.Type.Equality               (type (==))
import           Foreign.C.String                 (newCString)
import           Foreign.C.Types                  (CChar)
import           Foreign.Marshal.Alloc            (finalizerFree, free)
import           Foreign.Marshal.Array            (newArray, pokeArray0)
import           Foreign.Ptr                      (nullPtr, plusPtr)
import           Foreign.Storable                 (Storable)
import           GHC.Base                         (ByteArray#, IO (..),
                                                   RealWorld, State#, Weak#,
                                                   addCFinalizerToWeak#,
                                                   mkWeak#, mkWeakNoFinalizer#,
                                                   nullAddr#)
import           GHC.Ptr                          (FunPtr (..), Ptr (..))
import           GHC.TypeLits
import           System.IO.Unsafe                 (unsafeDupablePerformIO)

import           Graphics.Vulkan.Marshal
import           Graphics.Vulkan.Marshal.Internal
import           Graphics.Vulkan.Types.BaseTypes  (VkBool32)


-- | Safely fill-in a new vulkan structure
newtype CreateVkStruct x (fs :: [Symbol]) a
  = CreateVkStruct
    { CreateVkStruct x fs a -> Ptr x -> IO (([Ptr ()], [IO ()]), a)
unCreateVkStruct
      :: Ptr x  -- Reference to memory containing the struct
      -> IO ( ( [Ptr ()]
                -- Pointers to data that was allocated with malloc or alike.
                -- The memory is guaranteed to be freed by means of finalizerFree
                --  at some point.
              , [IO ()]
                -- A list of functions that have a chance to run on finalization.
                -- GHC sometimes does not run them, but they are still suitable
                -- for touching GHC-managed memory to ensure an object exists
                -- at least as long as the created structure.
              )

           , a)
    }

instance Functor (CreateVkStruct x fs) where
  fmap :: (a -> b) -> CreateVkStruct x fs a -> CreateVkStruct x fs b
fmap a -> b
f = (Ptr x -> IO (([Ptr ()], [IO ()]), b)) -> CreateVkStruct x fs b
forall x (fs :: [Symbol]) a.
(Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
CreateVkStruct ((Ptr x -> IO (([Ptr ()], [IO ()]), b)) -> CreateVkStruct x fs b)
-> (CreateVkStruct x fs a -> Ptr x -> IO (([Ptr ()], [IO ()]), b))
-> CreateVkStruct x fs a
-> CreateVkStruct x fs b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO (([Ptr ()], [IO ()]), a) -> IO (([Ptr ()], [IO ()]), b))
-> (Ptr x -> IO (([Ptr ()], [IO ()]), a))
-> Ptr x
-> IO (([Ptr ()], [IO ()]), b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((([Ptr ()], [IO ()]), a) -> (([Ptr ()], [IO ()]), b))
-> IO (([Ptr ()], [IO ()]), a) -> IO (([Ptr ()], [IO ()]), b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((([Ptr ()], [IO ()]), a) -> (([Ptr ()], [IO ()]), b))
 -> IO (([Ptr ()], [IO ()]), a) -> IO (([Ptr ()], [IO ()]), b))
-> ((([Ptr ()], [IO ()]), a) -> (([Ptr ()], [IO ()]), b))
-> IO (([Ptr ()], [IO ()]), a)
-> IO (([Ptr ()], [IO ()]), b)
forall a b. (a -> b) -> a -> b
$ (a -> b) -> (([Ptr ()], [IO ()]), a) -> (([Ptr ()], [IO ()]), b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) ((Ptr x -> IO (([Ptr ()], [IO ()]), a))
 -> Ptr x -> IO (([Ptr ()], [IO ()]), b))
-> (CreateVkStruct x fs a -> Ptr x -> IO (([Ptr ()], [IO ()]), a))
-> CreateVkStruct x fs a
-> Ptr x
-> IO (([Ptr ()], [IO ()]), b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CreateVkStruct x fs a -> Ptr x -> IO (([Ptr ()], [IO ()]), a)
forall x (fs :: [Symbol]) a.
CreateVkStruct x fs a -> Ptr x -> IO (([Ptr ()], [IO ()]), a)
unCreateVkStruct

instance Applicative (CreateVkStruct x fs) where
  pure :: a -> CreateVkStruct x fs a
pure = (Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
forall x (fs :: [Symbol]) a.
(Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
CreateVkStruct ((Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a)
-> (a -> Ptr x -> IO (([Ptr ()], [IO ()]), a))
-> a
-> CreateVkStruct x fs a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (([Ptr ()], [IO ()]), a) -> Ptr x -> IO (([Ptr ()], [IO ()]), a)
forall a b. a -> b -> a
const (IO (([Ptr ()], [IO ()]), a)
 -> Ptr x -> IO (([Ptr ()], [IO ()]), a))
-> (a -> IO (([Ptr ()], [IO ()]), a))
-> a
-> Ptr x
-> IO (([Ptr ()], [IO ()]), a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Ptr ()], [IO ()]), a) -> IO (([Ptr ()], [IO ()]), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((([Ptr ()], [IO ()]), a) -> IO (([Ptr ()], [IO ()]), a))
-> (a -> (([Ptr ()], [IO ()]), a))
-> a
-> IO (([Ptr ()], [IO ()]), a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) ([],[])
  CreateVkStruct x fs (a -> b)
csf <*> :: CreateVkStruct x fs (a -> b)
-> CreateVkStruct x fs a -> CreateVkStruct x fs b
<*> CreateVkStruct x fs a
csx = (Ptr x -> IO (([Ptr ()], [IO ()]), b)) -> CreateVkStruct x fs b
forall x (fs :: [Symbol]) a.
(Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
CreateVkStruct ((Ptr x -> IO (([Ptr ()], [IO ()]), b)) -> CreateVkStruct x fs b)
-> (Ptr x -> IO (([Ptr ()], [IO ()]), b)) -> CreateVkStruct x fs b
forall a b. (a -> b) -> a -> b
$ \Ptr x
ptr ->
      (([Ptr ()], [IO ()]), a -> b)
-> (([Ptr ()], [IO ()]), a) -> (([Ptr ()], [IO ()]), b)
forall a a t b.
(([a], [a]), t -> b) -> (([a], [a]), t) -> (([a], [a]), b)
g ((([Ptr ()], [IO ()]), a -> b)
 -> (([Ptr ()], [IO ()]), a) -> (([Ptr ()], [IO ()]), b))
-> IO (([Ptr ()], [IO ()]), a -> b)
-> IO ((([Ptr ()], [IO ()]), a) -> (([Ptr ()], [IO ()]), b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CreateVkStruct x fs (a -> b)
-> Ptr x -> IO (([Ptr ()], [IO ()]), a -> b)
forall x (fs :: [Symbol]) a.
CreateVkStruct x fs a -> Ptr x -> IO (([Ptr ()], [IO ()]), a)
unCreateVkStruct CreateVkStruct x fs (a -> b)
csf Ptr x
ptr IO ((([Ptr ()], [IO ()]), a) -> (([Ptr ()], [IO ()]), b))
-> IO (([Ptr ()], [IO ()]), a) -> IO (([Ptr ()], [IO ()]), b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CreateVkStruct x fs a -> Ptr x -> IO (([Ptr ()], [IO ()]), a)
forall x (fs :: [Symbol]) a.
CreateVkStruct x fs a -> Ptr x -> IO (([Ptr ()], [IO ()]), a)
unCreateVkStruct CreateVkStruct x fs a
csx Ptr x
ptr
    where
      g :: (([a], [a]), t -> b) -> (([a], [a]), t) -> (([a], [a]), b)
g (([a]
as1, [a]
as2), t -> b
f) (([a]
bs1, [a]
bs2), t
x) = (([a]
as1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
bs1, [a]
as2 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
bs2), t -> b
f t
x)

instance Monad (CreateVkStruct x fs) where
  return :: a -> CreateVkStruct x fs a
return = a -> CreateVkStruct x fs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  CreateVkStruct x fs a
csx >>= :: CreateVkStruct x fs a
-> (a -> CreateVkStruct x fs b) -> CreateVkStruct x fs b
>>= a -> CreateVkStruct x fs b
k = (Ptr x -> IO (([Ptr ()], [IO ()]), b)) -> CreateVkStruct x fs b
forall x (fs :: [Symbol]) a.
(Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
CreateVkStruct ((Ptr x -> IO (([Ptr ()], [IO ()]), b)) -> CreateVkStruct x fs b)
-> (Ptr x -> IO (([Ptr ()], [IO ()]), b)) -> CreateVkStruct x fs b
forall a b. (a -> b) -> a -> b
$ \Ptr x
ptr -> do
    (([Ptr ()]
as1, [IO ()]
as2), a
x) <- CreateVkStruct x fs a -> Ptr x -> IO (([Ptr ()], [IO ()]), a)
forall x (fs :: [Symbol]) a.
CreateVkStruct x fs a -> Ptr x -> IO (([Ptr ()], [IO ()]), a)
unCreateVkStruct CreateVkStruct x fs a
csx Ptr x
ptr
    (([Ptr ()]
bs1, [IO ()]
bs2), b
y) <- CreateVkStruct x fs b -> Ptr x -> IO (([Ptr ()], [IO ()]), b)
forall x (fs :: [Symbol]) a.
CreateVkStruct x fs a -> Ptr x -> IO (([Ptr ()], [IO ()]), a)
unCreateVkStruct (a -> CreateVkStruct x fs b
k a
x) Ptr x
ptr
    (([Ptr ()], [IO ()]), b) -> IO (([Ptr ()], [IO ()]), b)
forall (m :: * -> *) a. Monad m => a -> m a
return (([Ptr ()]
as1 [Ptr ()] -> [Ptr ()] -> [Ptr ()]
forall a. [a] -> [a] -> [a]
++ [Ptr ()]
bs1, [IO ()]
as2 [IO ()] -> [IO ()] -> [IO ()]
forall a. [a] -> [a] -> [a]
++ [IO ()]
bs2), b
y)


-- | Create a vulkan structure.
--
--   Use smart creation functions like `setVk`, `setStrRef`, `setListRef`, etc
--   to keep GC aware of references between dependent structures.
--
--   `createVk` produces at most one weak reference to a created structure
--     with a set of haskell and C finalizers.
--   These finalizers make sure all `malloc`ed memory is released and
--    no managed memory gets purged too early.
createVk :: ( VulkanMarshal x, VulkanMarshalPrim x
            , HandleRemFields x fs
            ) => CreateVkStruct x fs () -> x
createVk :: CreateVkStruct x fs () -> x
createVk CreateVkStruct x fs ()
a = IO x -> x
forall a. IO a -> a
unsafeDupablePerformIO (IO x -> x) -> IO x -> x
forall a b. (a -> b) -> a -> b
$ do
    x
x <- IO x
forall a. VulkanMarshal a => IO a
mallocVkData
    x -> (Ptr x -> IO ()) -> IO ()
forall a b. VulkanMarshal a => a -> (Ptr a -> IO b) -> IO b
withPtr x
x ((Ptr x -> IO ()) -> IO ()) -> (Ptr x -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr x
xptr -> do
      (([Ptr ()]
cDeps, [IO ()]
hFins), ()) <- CreateVkStruct x fs () -> Ptr x -> IO (([Ptr ()], [IO ()]), ())
forall x (fs :: [Symbol]) a.
CreateVkStruct x fs a -> Ptr x -> IO (([Ptr ()], [IO ()]), a)
unCreateVkStruct (CreateVkStruct x fs ()
a CreateVkStruct x fs ()
-> CreateVkStruct x fs () -> CreateVkStruct x fs ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CreateVkStruct x fs ()
forall x (fs :: [Symbol]) (isUnion :: Bool).
HandleRemainingFields x fs isUnion =>
CreateVkStruct x fs ()
handleRemFields) Ptr x
xptr
      (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 -> case (# [Ptr ()]
cDeps, [IO ()]
hFins #) of
        (# [], [] #) -> (# State# RealWorld
s0, () #)
        (# [Ptr ()]
_ , [IO ()]
_  #) -> case ByteArray#
-> [IO ()] -> State# RealWorld -> (# State# RealWorld, Weak# () #)
mkW (x -> ByteArray#
forall a. VulkanMarshalPrim a => a -> ByteArray#
unsafeByteArray x
x) [IO ()]
hFins State# RealWorld
s0 of
          (# State# RealWorld
s1, Weak# ()
w #) -> let go :: [Ptr ()] -> State# RealWorld -> (# State# RealWorld, () #)
go [] State# RealWorld
s = (# State# RealWorld
s, () #)
                             go xxs :: [Ptr ()]
xxs@(Ptr Addr#
c : [Ptr ()]
xs) State# RealWorld
s =
                               case Addr#
-> Addr#
-> Int#
-> Addr#
-> Weak# ()
-> State# RealWorld
-> (# State# RealWorld, Int# #)
forall b.
Addr#
-> Addr#
-> Int#
-> Addr#
-> Weak# b
-> State# RealWorld
-> (# State# RealWorld, Int# #)
addCFinalizerToWeak# Addr#
fp Addr#
c Int#
0# Addr#
nullAddr# Weak# ()
w State# RealWorld
s of
                                 (# State# RealWorld
s' , Int#
0# #) -> case (Ptr () -> IO ()) -> [Ptr ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Ptr () -> IO ()
forall a. Ptr a -> IO ()
free [Ptr ()]
xxs of
                                    IO State# RealWorld -> (# State# RealWorld, () #)
k -> State# RealWorld -> (# State# RealWorld, () #)
k State# RealWorld
s'
                                 (# State# RealWorld
s' , Int#
_  #) -> [Ptr ()] -> State# RealWorld -> (# State# RealWorld, () #)
go [Ptr ()]
xs State# RealWorld
s'
                         in [Ptr ()] -> State# RealWorld -> (# State# RealWorld, () #)
go [Ptr ()]
cDeps State# RealWorld
s1
    x -> IO x
forall (m :: * -> *) a. Monad m => a -> m a
return x
x
  where
    !(FunPtr Addr#
fp) = FunPtr (Ptr () -> IO ())
forall a. FinalizerPtr a
finalizerFree @()
    mkW :: ByteArray# -> [IO ()]
        -> State# RealWorld -> (# State# RealWorld, Weak# () #)
    mkW :: ByteArray#
-> [IO ()] -> State# RealWorld -> (# State# RealWorld, Weak# () #)
mkW ByteArray#
ba [] = ByteArray#
-> () -> State# RealWorld -> (# State# RealWorld, Weak# () #)
forall a b.
a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# ByteArray#
ba ()
    mkW ByteArray#
ba [IO ()]
xs = case [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
xs of
                  IO State# RealWorld -> (# State# RealWorld, () #)
k -> ByteArray#
-> ()
-> (State# RealWorld -> (# State# RealWorld, () #))
-> State# RealWorld
-> (# State# RealWorld, Weak# () #)
forall a b c.
a
-> b
-> (State# RealWorld -> (# State# RealWorld, c #))
-> State# RealWorld
-> (# State# RealWorld, Weak# b #)
mkWeak# ByteArray#
ba () State# RealWorld -> (# State# RealWorld, () #)
k
{-# NOINLINE createVk #-}

-- | `writeField` wrapped into `CreateVkStruct` monad.
set :: forall fname x
     . ( CanWriteField fname x
       )
    => FieldType fname x -> CreateVkStruct x '[fname] ()
set :: FieldType fname x -> CreateVkStruct x '[fname] ()
set FieldType fname x
v = (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall x (fs :: [Symbol]) a.
(Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
CreateVkStruct ((Ptr x -> IO (([Ptr ()], [IO ()]), ()))
 -> CreateVkStruct x '[fname] ())
-> (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall a b. (a -> b) -> a -> b
$ \Ptr x
p -> (,) ([],[]) (() -> (([Ptr ()], [IO ()]), ()))
-> IO () -> IO (([Ptr ()], [IO ()]), ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr x -> FieldType fname x -> IO ()
forall (fname :: Symbol) a.
CanWriteField fname a =>
Ptr a -> FieldType fname a -> IO ()
writeField @fname @x Ptr x
p FieldType fname x
v


-- | `writeFieldArray` wrapped into `CreateVkStruct` monad.
setAt :: forall fname i x
       . CanWriteFieldArray fname i x
      => FieldType fname x -> CreateVkStruct x '[fname] ()
setAt :: FieldType fname x -> CreateVkStruct x '[fname] ()
setAt FieldType fname x
v = (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall x (fs :: [Symbol]) a.
(Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
CreateVkStruct ((Ptr x -> IO (([Ptr ()], [IO ()]), ()))
 -> CreateVkStruct x '[fname] ())
-> (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall a b. (a -> b) -> a -> b
$ \Ptr x
p -> (,) ([],[]) (() -> (([Ptr ()], [IO ()]), ()))
-> IO () -> IO (([Ptr ()], [IO ()]), ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr x -> FieldType fname x -> IO ()
forall (fname :: Symbol) (idx :: Nat) a.
CanWriteFieldArray fname idx a =>
Ptr a -> FieldType fname a -> IO ()
writeFieldArray @fname @i @x Ptr x
p FieldType fname x
v

-- | Write fields of a member struct.
setVk :: forall fname x afs a
       . ( CanWriteField fname x
         , a ~ FieldType fname x
         , VulkanMarshal a
         , HandleRemFields a afs
         )
      => CreateVkStruct a afs ()
      -> CreateVkStruct x '[fname] ()
setVk :: CreateVkStruct a afs () -> CreateVkStruct x '[fname] ()
setVk CreateVkStruct a afs ()
ma = (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall x (fs :: [Symbol]) a.
(Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
CreateVkStruct ((Ptr x -> IO (([Ptr ()], [IO ()]), ()))
 -> CreateVkStruct x '[fname] ())
-> (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall a b. (a -> b) -> a -> b
$ \Ptr x
p ->
  CreateVkStruct a afs () -> Ptr a -> IO (([Ptr ()], [IO ()]), ())
forall x (fs :: [Symbol]) a.
CreateVkStruct x fs a -> Ptr x -> IO (([Ptr ()], [IO ()]), a)
unCreateVkStruct (CreateVkStruct a afs ()
ma CreateVkStruct a afs ()
-> CreateVkStruct a afs () -> CreateVkStruct a afs ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CreateVkStruct a afs ()
forall x (fs :: [Symbol]) (isUnion :: Bool).
HandleRemainingFields x fs isUnion =>
CreateVkStruct x fs ()
handleRemFields) (Ptr x -> Int -> Ptr a
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr x
p (HasField fname x => Int
forall (fname :: Symbol) a. HasField fname a => Int
fieldOffset @fname @x))

-- | Write a String into a vulkan struct in-place.
setStr :: forall fname x
        . ( CanWriteFieldArray fname 0 x
          , FieldType fname x ~ CChar
          )
       => String -> CreateVkStruct x '[fname] ()
setStr :: String -> CreateVkStruct x '[fname] ()
setStr String
v = (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall x (fs :: [Symbol]) a.
(Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
CreateVkStruct ((Ptr x -> IO (([Ptr ()], [IO ()]), ()))
 -> CreateVkStruct x '[fname] ())
-> (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall a b. (a -> b) -> a -> b
$ \Ptr x
p ->
  (,) ([],[]) (() -> (([Ptr ()], [IO ()]), ()))
-> IO () -> IO (([Ptr ()], [IO ()]), ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Ptr Char -> String -> IO ()
forall a. Storable a => a -> Ptr a -> [a] -> IO ()
pokeArray0 Char
'\0' (Ptr x
p Ptr x -> Int -> Ptr Char
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` HasField fname x => Int
forall (fname :: Symbol) a. HasField fname a => Int
fieldOffset @fname @x) String
v

-- | Allocate memory for a CString, store it,
--    and write a pointer to it into vulkan structure.
--
--   This function also attaches a reliable finalizer to the vulkan struct,
--    so that the allocated memory is freed when the structure is GCed.
setStrRef :: forall fname x
           . ( CanWriteField fname x
             , FieldType fname x ~ CString
             )
          => String -> CreateVkStruct x '[fname] ()
setStrRef :: String -> CreateVkStruct x '[fname] ()
setStrRef String
v = (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall x (fs :: [Symbol]) a.
(Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
CreateVkStruct ((Ptr x -> IO (([Ptr ()], [IO ()]), ()))
 -> CreateVkStruct x '[fname] ())
-> (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall a b. (a -> b) -> a -> b
$ \Ptr x
p -> do
  CString
sPtr <- String -> IO CString
newCString String
v
  (,) ([CString -> Ptr ()
coerce CString
sPtr],[]) (() -> (([Ptr ()], [IO ()]), ()))
-> IO () -> IO (([Ptr ()], [IO ()]), ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr x -> FieldType fname x -> IO ()
forall (fname :: Symbol) a.
CanWriteField fname a =>
Ptr a -> FieldType fname a -> IO ()
writeField @fname @x Ptr x
p CString
FieldType fname x
sPtr

-- | Allocate memory for an array of elements, store them,
--    and write a pointer to the array into vulkan structure.
--
--   This function also attaches a reliable finalizer to the vulkan struct,
--    so that the array memory is freed when the structure is GCed.
--
--   This function writes null pointer if used with an empty list.
setListRef :: forall fname x a
            . ( CanWriteField fname x
              , FieldType fname x ~ Ptr a
              , Storable a
              )
           => [a] -> CreateVkStruct x '[fname] ()
setListRef :: [a] -> CreateVkStruct x '[fname] ()
setListRef [] = (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall x (fs :: [Symbol]) a.
(Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
CreateVkStruct ((Ptr x -> IO (([Ptr ()], [IO ()]), ()))
 -> CreateVkStruct x '[fname] ())
-> (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall a b. (a -> b) -> a -> b
$ \Ptr x
p ->
  (,) ([],[]) (() -> (([Ptr ()], [IO ()]), ()))
-> IO () -> IO (([Ptr ()], [IO ()]), ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr x -> FieldType fname x -> IO ()
forall (fname :: Symbol) a.
CanWriteField fname a =>
Ptr a -> FieldType fname a -> IO ()
writeField @fname @x Ptr x
p FieldType fname x
forall a. Ptr a
nullPtr
setListRef [a]
v = (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall x (fs :: [Symbol]) a.
(Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
CreateVkStruct ((Ptr x -> IO (([Ptr ()], [IO ()]), ()))
 -> CreateVkStruct x '[fname] ())
-> (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall a b. (a -> b) -> a -> b
$ \Ptr x
p -> do
  Ptr a
aPtr <- [a] -> IO (Ptr a)
forall a. Storable a => [a] -> IO (Ptr a)
newArray [a]
v
  (,) ([Ptr a -> Ptr ()
coerce Ptr a
aPtr],[]) (() -> (([Ptr ()], [IO ()]), ()))
-> IO () -> IO (([Ptr ()], [IO ()]), ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr x -> FieldType fname x -> IO ()
forall (fname :: Symbol) a.
CanWriteField fname a =>
Ptr a -> FieldType fname a -> IO ()
writeField @fname @x Ptr x
p Ptr a
FieldType fname x
aPtr

-- | Allocate memory for an array of elements, store them,
--    and write a pointer to the array into vulkan structure.
--
--   This function also attaches a reliable finalizer to the vulkan struct,
--    so that the array memory is freed when the structure is GCed.
--
--   This function writes null pointer if used with an empty list.
setStrListRef :: forall fname x
              . ( CanWriteField fname x
                , FieldType fname x ~ Ptr CString
                )
              => [String] -> CreateVkStruct x '[fname] ()
setStrListRef :: [String] -> CreateVkStruct x '[fname] ()
setStrListRef [] = (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall x (fs :: [Symbol]) a.
(Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
CreateVkStruct ((Ptr x -> IO (([Ptr ()], [IO ()]), ()))
 -> CreateVkStruct x '[fname] ())
-> (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall a b. (a -> b) -> a -> b
$ \Ptr x
p ->
  (,) ([],[]) (() -> (([Ptr ()], [IO ()]), ()))
-> IO () -> IO (([Ptr ()], [IO ()]), ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr x -> FieldType fname x -> IO ()
forall (fname :: Symbol) a.
CanWriteField fname a =>
Ptr a -> FieldType fname a -> IO ()
writeField @fname @x Ptr x
p FieldType fname x
forall a. Ptr a
nullPtr
setStrListRef [String]
v = (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall x (fs :: [Symbol]) a.
(Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
CreateVkStruct ((Ptr x -> IO (([Ptr ()], [IO ()]), ()))
 -> CreateVkStruct x '[fname] ())
-> (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall a b. (a -> b) -> a -> b
$ \Ptr x
p -> do
  [CString]
strptrs <- (String -> IO CString) -> [String] -> IO [CString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO CString
newCString [String]
v
  Ptr CString
aPtr <- [CString] -> IO (Ptr CString)
forall a. Storable a => [a] -> IO (Ptr a)
newArray [CString]
strptrs
  (,) (Ptr CString -> Ptr ()
coerce Ptr CString
aPtr Ptr () -> [Ptr ()] -> [Ptr ()]
forall a. a -> [a] -> [a]
: [CString] -> [Ptr ()]
coerce [CString]
strptrs,[]) (() -> (([Ptr ()], [IO ()]), ()))
-> IO () -> IO (([Ptr ()], [IO ()]), ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr x -> FieldType fname x -> IO ()
forall (fname :: Symbol) a.
CanWriteField fname a =>
Ptr a -> FieldType fname a -> IO ()
writeField @fname @x Ptr x
p Ptr CString
FieldType fname x
aPtr

-- | Write a pointer to a vulkan structure - member of current structure
--    and make sure the member exists as long as this structure exists.
--
--   Prefer this function to using @unsafePtr a@, because the latter
--    does not keep the dependency information in GC, which results in
--    member structure being garbage-collected and the reference being invalid.
setVkRef :: forall fname x a
          . ( CanWriteField fname x
            , FieldType fname x ~ Ptr a
            , VulkanMarshal a
            )
         => a -> CreateVkStruct x '[fname] ()
setVkRef :: a -> CreateVkStruct x '[fname] ()
setVkRef a
v = (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall x (fs :: [Symbol]) a.
(Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
CreateVkStruct ((Ptr x -> IO (([Ptr ()], [IO ()]), ()))
 -> CreateVkStruct x '[fname] ())
-> (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x '[fname] ()
forall a b. (a -> b) -> a -> b
$ \Ptr x
p ->
  (,) ([],[a -> IO ()
forall a. VulkanMarshal a => a -> IO ()
touchVkData a
v]) (() -> (([Ptr ()], [IO ()]), ()))
-> IO () -> IO (([Ptr ()], [IO ()]), ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr x -> FieldType fname x -> IO ()
forall (fname :: Symbol) a.
CanWriteField fname a =>
Ptr a -> FieldType fname a -> IO ()
writeField @fname @x Ptr x
p (a -> Ptr a
forall a. VulkanMarshal a => a -> Ptr a
unsafePtr a
v)

-- | Combine multiple field writes.
infixl 1 &*
(&*) :: CreateVkStruct x as () -> CreateVkStruct x bs ()
     -> CreateVkStruct x (Union x as bs) ()
CreateVkStruct Ptr x -> IO (([Ptr ()], [IO ()]), ())
a &* :: CreateVkStruct x as ()
-> CreateVkStruct x bs () -> CreateVkStruct x (Union x as bs) ()
&* CreateVkStruct Ptr x -> IO (([Ptr ()], [IO ()]), ())
b = (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x (Union x as bs) ()
forall x (fs :: [Symbol]) a.
(Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
CreateVkStruct Ptr x -> IO (([Ptr ()], [IO ()]), ())
a CreateVkStruct x (Union x as bs) ()
-> CreateVkStruct x (Union x as bs) ()
-> CreateVkStruct x (Union x as bs) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x (Union x as bs) ()
forall x (fs :: [Symbol]) a.
(Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
CreateVkStruct Ptr x -> IO (([Ptr ()], [IO ()]), ())
b



type family Union (x :: Type) (as :: [Symbol]) (bs :: [Symbol]) :: [Symbol] where
  Union _ as '[] = as
  Union x '[] (b ': bs) = Union x '[b] bs
  Union x (a ': as) (a ': bs) = If (FieldIsArray a x)
    ( Union x as (a ': bs) )
    ( TypeError
      ( 'Text "The same field " ':<>: 'ShowType x
      ':<>: 'Text " should not be set twice."
      )
    )
  Union x (a ': as) (b ': bs) = a ': Union x as (b ': bs)

type family Difference (as :: [Symbol]) (bs :: [Symbol]) :: [Symbol] where
  Difference '[] _  = '[]
  Difference as '[] = as
  Difference as (b ': bs) = Difference (Delete b as) bs


type family Delete (a :: Symbol) (as :: [Symbol]) :: [Symbol] where
  Delete _ '[] = '[]
  Delete a (a ': as) = as
  Delete a (b ': bs) = b ': Delete a bs



-- | Notify user if some required fields are missing.
type HandleRemFields x fs = HandleRemainingFields x fs (CUnionType x)


-- | Notify user if some required fields are missing and fill in optional fields.
class CUnionType x ~ isUnion
      => HandleRemainingFields (x :: Type) (fs :: [Symbol]) (isUnion :: Bool) where
  handleRemFields :: CreateVkStruct x fs ()



type SetUnionMsg x =
   'Text "You have to set exactly one field for a union type " ':<>: 'ShowType x
   ':$$: 'Text "Note, this type has following fields: "
         ':<>: 'ShowType (StructFields x)

instance ( TypeError ( SetUnionMsg x )
         , CUnionType x ~ 'True
         ) => HandleRemainingFields x '[] 'True where
  handleRemFields :: CreateVkStruct x '[] ()
handleRemFields = () -> CreateVkStruct x '[] ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance CUnionType x ~ 'True => HandleRemainingFields x '[f] 'True where
  handleRemFields :: CreateVkStruct x '[f] ()
handleRemFields = () -> CreateVkStruct x '[f] ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance ( TypeError ( SetUnionMsg x )
         , CUnionType x ~ 'True
         ) => HandleRemainingFields x (a ': b ': fs) 'True where
  handleRemFields :: CreateVkStruct x (a : b : fs) ()
handleRemFields = () -> CreateVkStruct x (a : b : fs) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


instance ( SetOptionalFields x (Difference (StructFields x) fs)
         , CUnionType x ~ 'False
         ) => HandleRemainingFields x fs 'False where
  handleRemFields :: CreateVkStruct x fs ()
handleRemFields
    = ( CreateVkStruct x (Difference (StructFields x) fs) ()
-> CreateVkStruct x fs ()
coerce :: CreateVkStruct x (Difference (StructFields x) fs) ()
               -> CreateVkStruct x fs ()
      ) CreateVkStruct x (Difference (StructFields x) fs) ()
forall x (fs :: [Symbol]).
SetOptionalFields x fs =>
CreateVkStruct x fs ()
setOptionalFields




class SetOptionalFields (x :: Type) (fs :: [Symbol]) where
  setOptionalFields :: CreateVkStruct x fs ()

instance SetOptionalFields x '[] where
  setOptionalFields :: CreateVkStruct x '[] ()
setOptionalFields = () -> CreateVkStruct x '[] ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance ( SetOptionalFields x fs
         , FieldMustBeOptional f x
         , Storable (FieldType f x)
         , HasField f x
         ) => SetOptionalFields x (f ': fs) where
  setOptionalFields :: CreateVkStruct x (f : fs) ()
setOptionalFields = CreateVkStruct x fs () -> CreateVkStruct x (f : fs) ()
coerce (CreateVkStruct x fs () -> CreateVkStruct x (f : fs) ())
-> CreateVkStruct x fs () -> CreateVkStruct x (f : fs) ()
forall a b. (a -> b) -> a -> b
$ CreateVkStruct x fs ()
x CreateVkStruct x fs ()
-> CreateVkStruct x fs () -> CreateVkStruct x fs ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CreateVkStruct x fs ()
forall x (fs :: [Symbol]).
SetOptionalFields x fs =>
CreateVkStruct x fs ()
setOptionalFields
    where
      x :: CreateVkStruct x fs ()
      x :: CreateVkStruct x fs ()
x = (Ptr x -> IO (([Ptr ()], [IO ()]), ())) -> CreateVkStruct x fs ()
forall x (fs :: [Symbol]) a.
(Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
CreateVkStruct ((Ptr x -> IO (([Ptr ()], [IO ()]), ())) -> CreateVkStruct x fs ())
-> (Ptr x -> IO (([Ptr ()], [IO ()]), ()))
-> CreateVkStruct x fs ()
forall a b. (a -> b) -> a -> b
$
        \Ptr x
ptr -> (,) ([],[]) (() -> (([Ptr ()], [IO ()]), ()))
-> IO () -> IO (([Ptr ()], [IO ()]), ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                Ptr (FieldType f x) -> IO ()
forall a. Storable a => Ptr a -> IO ()
clearStorable ( Ptr x -> Int -> Ptr (FieldType f x)
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr x
ptr (HasField f x => Int
forall (fname :: Symbol) a. HasField fname a => Int
fieldOffset @f @x)
                                  :: Ptr (FieldType f x)
                              )

type family FieldMustBeOptional (f :: Symbol) (x :: Type) :: Constraint where
  FieldMustBeOptional f x
    = If (FieldOptional f x || FieldType f x == VkBool32) (() :: Constraint)
    ( TypeError
      ( 'Text "Non-optional field " ':<>: 'ShowType f
        ':<>: 'Text " of structure " ':<>: 'ShowType x
        ':<>: 'Text " is not set."
      )
    )