{-# 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 #-}
module Graphics.Vulkan.Marshal.Create
( CreateVkStruct ()
, createVk, (&*)
, set, setAt, setVk, setVkRef, setStr, setStrRef
, setStrListRef, setStrListCountAndRef, setListRef, setListCountAndRef
, SetOptionalFields (..), HandleRemainingFields (..), HandleRemFields
, unsafeIOCreate
) 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)
newtype CreateVkStruct x (fs :: [Symbol]) a
= CreateVkStruct
{ forall x (fs :: [Symbol]) a.
CreateVkStruct x fs a -> Ptr x -> IO (([Ptr ()], [IO ()]), a)
unCreateVkStruct
:: Ptr x
-> IO ( ( [Ptr ()]
, [IO ()]
)
, a)
}
unsafeIOCreate :: (Ptr x -> IO a) -> CreateVkStruct x fs a
unsafeIOCreate :: forall x a (fs :: [Symbol]).
(Ptr x -> IO a) -> CreateVkStruct x fs a
unsafeIOCreate Ptr x -> IO a
k = (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)
-> (Ptr x -> IO (([Ptr ()], [IO ()]), a)) -> CreateVkStruct x fs a
forall a b. (a -> b) -> a -> b
$ (a -> (([Ptr ()], [IO ()]), a))
-> IO a -> IO (([Ptr ()], [IO ()]), a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) ([],[])) (IO a -> IO (([Ptr ()], [IO ()]), a))
-> (Ptr x -> IO a) -> Ptr x -> IO (([Ptr ()], [IO ()]), a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr x -> IO a
k
instance Functor (CreateVkStruct x fs) where
fmap :: forall a b.
(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 :: forall a. 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 <*> :: forall a b.
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 :: forall a. 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 >>= :: forall a b.
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)
createVk :: forall a fs .
( VulkanMarshal a
, HandleRemFields a fs
) => CreateVkStruct a fs () -> a
createVk :: forall a (fs :: [Symbol]).
(VulkanMarshal a, HandleRemFields a fs) =>
CreateVkStruct a fs () -> a
createVk CreateVkStruct a fs ()
a = IO a -> a
forall a. IO a -> a
unsafeDupablePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ do
a
x <- IO a
forall a. VulkanMarshal a => IO a
mallocVkData
a -> (Ptr a -> IO ()) -> IO ()
forall a b. VulkanMarshal a => a -> (Ptr a -> IO b) -> IO b
withPtr a
x ((Ptr a -> IO ()) -> IO ()) -> (Ptr a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr a
xptr -> do
(([Ptr ()]
cDeps, [IO ()]
hFins), ()) <- CreateVkStruct a fs () -> Ptr a -> IO (([Ptr ()], [IO ()]), ())
forall x (fs :: [Symbol]) a.
CreateVkStruct x fs a -> Ptr x -> IO (([Ptr ()], [IO ()]), a)
unCreateVkStruct (CreateVkStruct a fs ()
a CreateVkStruct a fs ()
-> CreateVkStruct a fs () -> CreateVkStruct a fs ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CreateVkStruct a fs ()
forall x (fs :: [Symbol]) (isUnion :: Bool).
HandleRemainingFields x fs isUnion =>
CreateVkStruct x fs ()
handleRemFields) Ptr a
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 (VkStruct (VkStruct' a) -> ByteArray#
forall a. VkStruct a -> ByteArray#
unsafeByteArray a
VkStruct (VkStruct' a)
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
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
where
!(FunPtr Addr#
fp) = 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# () #)
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# () #)
mkWeak# ByteArray#
ba () State# RealWorld -> (# State# RealWorld, () #)
k
{-# NOINLINE createVk #-}
set :: forall fname x . CanWriteField fname x
=> FieldType fname x -> CreateVkStruct x '[fname] ()
set :: forall (fname :: Symbol) x.
CanWriteField fname x =>
FieldType fname x -> CreateVkStruct x '[fname] ()
set FType
(GetFieldMeta
((((('Text "Structure " ':<>: 'ShowType x)
':<>: 'Text " does not have field ")
':<>: 'ShowType fname)
':<>: 'Text ".")
':$$: ('Text "Note, this structure has following fields: "
':<>: 'ShowType (FieldNames (SFields (StructRep x)))))
fname
(SFields (StructRep 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
<$> forall (fname :: Symbol) a.
CanWriteField fname a =>
Ptr a -> FieldType fname a -> IO ()
writeField @fname @x Ptr x
p FType
(GetFieldMeta
((((('Text "Structure " ':<>: 'ShowType x)
':<>: 'Text " does not have field ")
':<>: 'ShowType fname)
':<>: 'Text ".")
':$$: ('Text "Note, this structure has following fields: "
':<>: 'ShowType (FieldNames (SFields (StructRep x)))))
fname
(SFields (StructRep x)))
v
setAt :: forall fname i x
. ( CanWriteFieldArray fname x, IndexInBounds fname i x, KnownNat i)
=> FieldType fname x -> CreateVkStruct x '[fname] ()
setAt :: forall (fname :: Symbol) (i :: Nat) x.
(CanWriteFieldArray fname x, IndexInBounds fname i x,
KnownNat i) =>
FieldType fname x -> CreateVkStruct x '[fname] ()
setAt FType
(GetFieldMeta
((((('Text "Structure " ':<>: 'ShowType x)
':<>: 'Text " does not have field ")
':<>: 'ShowType fname)
':<>: 'Text ".")
':$$: ('Text "Note, this structure has following fields: "
':<>: 'ShowType (FieldNames (SFields (StructRep x)))))
fname
(SFields (StructRep 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
<$> forall (fname :: Symbol) (idx :: Nat) a.
(CanWriteFieldArray fname a, IndexInBounds fname idx a,
KnownNat idx) =>
Ptr a -> FieldType fname a -> IO ()
writeFieldArray @fname @i @x Ptr x
p FType
(GetFieldMeta
((((('Text "Structure " ':<>: 'ShowType x)
':<>: 'Text " does not have field ")
':<>: 'ShowType fname)
':<>: 'Text ".")
':$$: ('Text "Note, this structure has following fields: "
':<>: 'ShowType (FieldNames (SFields (StructRep x)))))
fname
(SFields (StructRep x)))
v
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 :: forall (fname :: Symbol) x (afs :: [Symbol]) a.
(CanWriteField fname x, a ~ FieldType fname x, VulkanMarshal a,
HandleRemFields a afs) =>
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 (forall (fname :: Symbol) a. HasField fname a => Int
fieldOffset @fname @x))
setStr :: forall fname x
. ( CanWriteFieldArray fname x
, FieldType fname x ~ CChar
)
=> String -> CreateVkStruct x '[fname] ()
setStr :: forall (fname :: Symbol) x.
(CanWriteFieldArray fname x, FieldType fname x ~ CChar) =>
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` forall (fname :: Symbol) a. HasField fname a => Int
fieldOffset @fname @x) String
v
setStrRef :: forall fname x
. ( CanWriteField fname x
, FieldType fname x ~ CString
)
=> String -> CreateVkStruct x '[fname] ()
setStrRef :: forall (fname :: Symbol) x.
(CanWriteField fname x, FieldType fname x ~ CString) =>
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
<$> forall (fname :: Symbol) a.
CanWriteField fname a =>
Ptr a -> FieldType fname a -> IO ()
writeField @fname @x Ptr x
p CString
FieldType fname x
sPtr
setListRef :: forall fname x a
. ( CanWriteField fname x
, FieldType fname x ~ Ptr a
, Storable a
)
=> [a] -> CreateVkStruct x '[fname] ()
setListRef :: forall (fname :: Symbol) x a.
(CanWriteField fname x, FieldType fname x ~ Ptr a, Storable a) =>
[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
<$> 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
<$> 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
setListCountAndRef :: forall countfname listfname x a
. ( CanWriteField countfname x
, CanWriteField listfname x
, FieldType countfname x ~ Word32
, FieldType listfname x ~ Ptr a
, Storable a
)
=> [a] -> CreateVkStruct x (Union x '[countfname] '[listfname]) ()
setListCountAndRef :: forall (countfname :: Symbol) (listfname :: Symbol) x a.
(CanWriteField countfname x, CanWriteField listfname x,
FieldType countfname x ~ Word32, FieldType listfname x ~ Ptr a,
Storable a) =>
[a] -> CreateVkStruct x (Union x '[countfname] '[listfname]) ()
setListCountAndRef [a]
list =
forall (fname :: Symbol) x.
CanWriteField fname x =>
FieldType fname x -> CreateVkStruct x '[fname] ()
set @countfname (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
list) CreateVkStruct x '[countfname] ()
-> CreateVkStruct x '[listfname] ()
-> CreateVkStruct x (Union x '[countfname] '[listfname]) ()
forall x (as :: [Symbol]) (bs :: [Symbol]).
CreateVkStruct x as ()
-> CreateVkStruct x bs () -> CreateVkStruct x (Union x as bs) ()
&*
forall (fname :: Symbol) x a.
(CanWriteField fname x, FieldType fname x ~ Ptr a, Storable a) =>
[a] -> CreateVkStruct x '[fname] ()
setListRef @listfname [a]
list
setStrListRef :: forall fname x
. ( CanWriteField fname x
, FieldType fname x ~ Ptr CString
)
=> [String] -> CreateVkStruct x '[fname] ()
setStrListRef :: forall (fname :: Symbol) x.
(CanWriteField fname x, FieldType fname x ~ Ptr CString) =>
[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
<$> 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
<$> 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
setStrListCountAndRef :: forall countfname listfname x
. ( CanWriteField countfname x
, CanWriteField listfname x
, FieldType countfname x ~ Word32
, FieldType listfname x ~ Ptr CString
)
=> [String] -> CreateVkStruct x (Union x '[countfname] '[listfname]) ()
setStrListCountAndRef :: forall (countfname :: Symbol) (listfname :: Symbol) x.
(CanWriteField countfname x, CanWriteField listfname x,
FieldType countfname x ~ Word32,
FieldType listfname x ~ Ptr CString) =>
[String]
-> CreateVkStruct x (Union x '[countfname] '[listfname]) ()
setStrListCountAndRef [String]
list =
forall (fname :: Symbol) x.
CanWriteField fname x =>
FieldType fname x -> CreateVkStruct x '[fname] ()
set @countfname (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
list) CreateVkStruct x '[countfname] ()
-> CreateVkStruct x '[listfname] ()
-> CreateVkStruct x (Union x '[countfname] '[listfname]) ()
forall x (as :: [Symbol]) (bs :: [Symbol]).
CreateVkStruct x as ()
-> CreateVkStruct x bs () -> CreateVkStruct x (Union x as bs) ()
&*
forall (fname :: Symbol) x.
(CanWriteField fname x, FieldType fname x ~ Ptr CString) =>
[String] -> CreateVkStruct x '[fname] ()
setStrListRef @listfname [String]
list
setVkRef :: forall fname x a
. ( CanWriteField fname x
, FieldType fname x ~ Ptr a
, VulkanMarshal a
)
=> a -> CreateVkStruct x '[fname] ()
setVkRef :: forall (fname :: Symbol) x a.
(CanWriteField fname x, FieldType fname x ~ Ptr a,
VulkanMarshal a) =>
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. IsVkStruct a => a -> IO ()
touchVkData a
v]) (() -> (([Ptr ()], [IO ()]), ()))
-> IO () -> IO (([Ptr ()], [IO ()]), ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (fname :: Symbol) a.
CanWriteField fname a =>
Ptr a -> FieldType fname a -> IO ()
writeField @fname @x Ptr x
p (a -> Ptr a
forall a. IsVkStruct a => a -> Ptr a
unsafePtr a
v)
infixl 1 &*
(&*) :: CreateVkStruct x as () -> CreateVkStruct x bs ()
-> CreateVkStruct x (Union x as bs) ()
CreateVkStruct Ptr x -> IO (([Ptr ()], [IO ()]), ())
a &* :: forall x (as :: [Symbol]) (bs :: [Symbol]).
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
type HandleRemFields x fs = HandleRemainingFields x fs (CUnionType x)
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 (StructFieldNames 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 (StructFieldNames x) fs)
, CUnionType x ~ 'False
) => HandleRemainingFields x fs 'False where
handleRemFields :: CreateVkStruct x fs ()
handleRemFields
= ( CreateVkStruct x (Difference (StructFieldNames x) fs) ()
-> CreateVkStruct x fs ()
coerce :: CreateVkStruct x (Difference (StructFieldNames x) fs) ()
-> CreateVkStruct x fs ()
) CreateVkStruct x (Difference (StructFieldNames 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 (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."
)
)