{-# LINE 1 "src/Gpu/Vulkan/Buffer/Middle/Internal.hsc" #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Gpu.Vulkan.Buffer.Middle.Internal (
	B(..), CreateInfo(..), create, destroy,
	bindMemory, getMemoryRequirements,

	ImageCopy(..), imageCopyToCore,
	MemoryBarrier(..), memoryBarrierToCore',

	C.Copy, pattern C.Copy, C.copySrcOffset, C.copyDstOffset, C.copySize
	) where

import Foreign.Ptr
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Storable
import Foreign.Storable.PeekPoke (WithPoked, withPoked, withPoked', withPtrS)
import Control.Arrow
import Control.Monad.Trans
import Control.Monad.Cont
import Data.Kind
import Data.TypeLevel.Maybe qualified as TMaybe
import Data.TypeLevel.ParMaybe qualified as TPMaybe
import Data.Word
import Data.IORef

import Gpu.Vulkan.Core
import Gpu.Vulkan.Enum
import Gpu.Vulkan.Exception.Middle.Internal
import Gpu.Vulkan.Exception.Enum
import Gpu.Vulkan.Buffer.Enum

import Gpu.Vulkan.AllocationCallbacks.Middle.Internal qualified as
	AllocationCallbacks (A, mToCore)
import qualified Gpu.Vulkan.Device.Middle.Internal as Device
import qualified Gpu.Vulkan.Buffer.Core as C
import qualified Gpu.Vulkan.Memory.Middle.Internal as Memory
import qualified Gpu.Vulkan.QueueFamily.EnumManual as QueueFamily
import qualified Gpu.Vulkan.Image.Middle.Internal as Image



data CreateInfo (mn :: Maybe Type) = CreateInfo {
	forall (mn :: Maybe (*)). CreateInfo mn -> M mn
createInfoNext :: TMaybe.M mn,
	forall (mn :: Maybe (*)). CreateInfo mn -> CreateFlags
createInfoFlags :: CreateFlags,
	forall (mn :: Maybe (*)). CreateInfo mn -> Size
createInfoSize :: Device.Size,
	forall (mn :: Maybe (*)). CreateInfo mn -> UsageFlags
createInfoUsage :: UsageFlags,
	forall (mn :: Maybe (*)). CreateInfo mn -> SharingMode
createInfoSharingMode :: SharingMode,
	forall (mn :: Maybe (*)). CreateInfo mn -> [Index]
createInfoQueueFamilyIndices :: [QueueFamily.Index] }

deriving instance Show (TMaybe.M mn) => Show (CreateInfo mn)

createInfoToCore ::
	WithPoked (TMaybe.M mn) => CreateInfo mn -> (Ptr C.CreateInfo -> IO a) -> IO ()
createInfoToCore :: forall (mn :: Maybe (*)) a.
WithPoked (M mn) =>
CreateInfo mn -> (Ptr CreateInfo -> IO a) -> IO ()
createInfoToCore CreateInfo {
	createInfoNext :: forall (mn :: Maybe (*)). CreateInfo mn -> M mn
createInfoNext = M mn
mnxt,
	createInfoFlags :: forall (mn :: Maybe (*)). CreateInfo mn -> CreateFlags
createInfoFlags = CreateFlagBits Word32
flgs,
	createInfoSize :: forall (mn :: Maybe (*)). CreateInfo mn -> Size
createInfoSize = Device.Size Word64
sz,
	createInfoUsage :: forall (mn :: Maybe (*)). CreateInfo mn -> UsageFlags
createInfoUsage = UsageFlagBits Word32
usg,
	createInfoSharingMode :: forall (mn :: Maybe (*)). CreateInfo mn -> SharingMode
createInfoSharingMode = SharingMode Word32
sm,
	createInfoQueueFamilyIndices :: forall (mn :: Maybe (*)). CreateInfo mn -> [Index]
createInfoQueueFamilyIndices =
		[Index] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Index] -> Int)
-> ([Index] -> [Word32]) -> [Index] -> (Int, [Word32])
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Index -> Word32
QueueFamily.unIndex (Index -> Word32) -> [Index] -> [Word32]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) -> (Int
qfic, [Word32]
qfis) } Ptr CreateInfo -> IO a
f =
	Int -> (Ptr Word32 -> IO ()) -> IO ()
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
qfic \Ptr Word32
pqfis -> do
	Ptr Word32 -> [Word32] -> IO ()
forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray Ptr Word32
pqfis [Word32]
qfis
	M mn -> (forall s. PtrS s (M mn) -> IO ()) -> IO ()
forall a b.
WithPoked a =>
a -> (forall s. PtrS s a -> IO b) -> IO b
forall b. M mn -> (forall s. PtrS s (M mn) -> IO b) -> IO b
withPoked' M mn
mnxt \PtrS s (M mn)
pnxt -> PtrS s (M mn) -> (Ptr (M mn) -> IO a) -> IO ()
forall s a b. PtrS s a -> (Ptr a -> IO b) -> IO ()
withPtrS PtrS s (M mn)
pnxt \(Ptr (M mn) -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr -> Ptr ()
pnxt') -> do
		CreateInfo -> (Ptr CreateInfo -> IO a) -> IO a
forall a b. Pokable a => a -> (Ptr a -> IO b) -> IO b
withPoked C.CreateInfo {
				createInfoSType :: ()
C.createInfoSType = (),
				createInfoPNext :: Ptr ()
C.createInfoPNext = Ptr ()
pnxt',
				createInfoFlags :: Word32
C.createInfoFlags = Word32
flgs,
				createInfoSize :: Word64
C.createInfoSize = Word64
sz,
				createInfoUsage :: Word32
C.createInfoUsage = Word32
usg,
				createInfoSharingMode :: Word32
C.createInfoSharingMode = Word32
sm,
				createInfoQueueFamilyIndexCount :: Word32
C.createInfoQueueFamilyIndexCount = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
qfic,
				createInfoPQueueFamilyIndices :: Ptr Word32
C.createInfoPQueueFamilyIndices = Ptr Word32
pqfis } Ptr CreateInfo -> IO a
f

newtype B = B C.B deriving (Int -> B -> ShowS
[B] -> ShowS
B -> String
(Int -> B -> ShowS) -> (B -> String) -> ([B] -> ShowS) -> Show B
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> B -> ShowS
showsPrec :: Int -> B -> ShowS
$cshow :: B -> String
show :: B -> String
$cshowList :: [B] -> ShowS
showList :: [B] -> ShowS
Show, B -> B -> Bool
(B -> B -> Bool) -> (B -> B -> Bool) -> Eq B
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: B -> B -> Bool
== :: B -> B -> Bool
$c/= :: B -> B -> Bool
/= :: B -> B -> Bool
Eq, Ptr B -> IO B
Ptr B -> Int -> IO B
Ptr B -> Int -> B -> IO ()
Ptr B -> B -> IO ()
B -> Int
(B -> Int)
-> (B -> Int)
-> (Ptr B -> Int -> IO B)
-> (Ptr B -> Int -> B -> IO ())
-> (forall b. Ptr b -> Int -> IO B)
-> (forall b. Ptr b -> Int -> B -> IO ())
-> (Ptr B -> IO B)
-> (Ptr B -> B -> IO ())
-> Storable B
forall b. Ptr b -> Int -> IO B
forall b. Ptr b -> Int -> B -> IO ()
forall a.
(a -> Int)
-> (a -> Int)
-> (Ptr a -> Int -> IO a)
-> (Ptr a -> Int -> a -> IO ())
-> (forall b. Ptr b -> Int -> IO a)
-> (forall b. Ptr b -> Int -> a -> IO ())
-> (Ptr a -> IO a)
-> (Ptr a -> a -> IO ())
-> Storable a
$csizeOf :: B -> Int
sizeOf :: B -> Int
$calignment :: B -> Int
alignment :: B -> Int
$cpeekElemOff :: Ptr B -> Int -> IO B
peekElemOff :: Ptr B -> Int -> IO B
$cpokeElemOff :: Ptr B -> Int -> B -> IO ()
pokeElemOff :: Ptr B -> Int -> B -> IO ()
$cpeekByteOff :: forall b. Ptr b -> Int -> IO B
peekByteOff :: forall b. Ptr b -> Int -> IO B
$cpokeByteOff :: forall b. Ptr b -> Int -> B -> IO ()
pokeByteOff :: forall b. Ptr b -> Int -> B -> IO ()
$cpeek :: Ptr B -> IO B
peek :: Ptr B -> IO B
$cpoke :: Ptr B -> B -> IO ()
poke :: Ptr B -> B -> IO ()
Storable)

create :: WithPoked (TMaybe.M mn) =>
	Device.D -> CreateInfo mn -> TPMaybe.M AllocationCallbacks.A mc -> IO B
create :: forall (mn :: Maybe (*)) (mc :: Maybe (*)).
WithPoked (M mn) =>
D -> CreateInfo mn -> M A mc -> IO B
create (Device.D D
dvc) CreateInfo mn
ci M A mc
mac = B -> B
B (B -> B) -> IO B -> IO B
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr B -> IO B) -> IO B
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr B
pb -> do
	CreateInfo mn -> (Ptr CreateInfo -> IO ()) -> IO ()
forall (mn :: Maybe (*)) a.
WithPoked (M mn) =>
CreateInfo mn -> (Ptr CreateInfo -> IO a) -> IO ()
createInfoToCore CreateInfo mn
ci \Ptr CreateInfo
pci ->
		M A mc -> (Ptr A -> IO ()) -> IO ()
forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO ()
AllocationCallbacks.mToCore M A mc
mac \Ptr A
pac ->
			Result -> IO ()
throwUnlessSuccess (Result -> IO ()) -> (Int32 -> Result) -> Int32 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Result
Result (Int32 -> IO ()) -> IO Int32 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< D -> Ptr CreateInfo -> Ptr A -> Ptr B -> IO Int32
C.create D
dvc Ptr CreateInfo
pci Ptr A
pac Ptr B
pb
	Ptr B -> IO B
forall a. Storable a => Ptr a -> IO a
peek Ptr B
pb

destroy :: Device.D -> B -> TPMaybe.M AllocationCallbacks.A md -> IO ()
destroy :: forall (md :: Maybe (*)). D -> B -> M A md -> IO ()
destroy (Device.D D
dvc) (B B
b) M A md
mac =
	M A md -> (Ptr A -> IO ()) -> IO ()
forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO ()
AllocationCallbacks.mToCore M A md
mac ((Ptr A -> IO ()) -> IO ()) -> (Ptr A -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ D -> B -> Ptr A -> IO ()
C.destroy D
dvc B
b

getMemoryRequirements :: Device.D -> B -> IO Memory.Requirements
getMemoryRequirements :: D -> B -> IO Requirements
getMemoryRequirements (Device.D D
dvc) (B B
b) =
	(Requirements -> Requirements
Memory.requirementsFromCore (Requirements -> Requirements)
-> IO Requirements -> IO Requirements
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (IO Requirements -> IO Requirements)
-> (((Requirements -> IO Requirements) -> IO Requirements)
    -> IO Requirements)
-> ((Requirements -> IO Requirements) -> IO Requirements)
-> IO Requirements
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Requirements -> IO Requirements) -> IO Requirements)
-> (Requirements -> IO Requirements) -> IO Requirements
forall a b. (a -> b) -> a -> b
$ Requirements -> IO Requirements
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (((Requirements -> IO Requirements) -> IO Requirements)
 -> IO Requirements)
-> ((Requirements -> IO Requirements) -> IO Requirements)
-> IO Requirements
forall a b. (a -> b) -> a -> b
$ ContT Requirements IO Requirements
-> (Requirements -> IO Requirements) -> IO Requirements
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT do
		Ptr Requirements
pr <- ((Ptr Requirements -> IO Requirements) -> IO Requirements)
-> ContT Requirements IO (Ptr Requirements)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (Ptr Requirements -> IO Requirements) -> IO Requirements
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca
		IO Requirements -> ContT Requirements IO Requirements
forall (m :: * -> *) a. Monad m => m a -> ContT Requirements m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift do	D -> B -> Ptr Requirements -> IO ()
C.getMemoryRequirements D
dvc B
b Ptr Requirements
pr
			Ptr Requirements -> IO Requirements
forall a. Storable a => Ptr a -> IO a
peek Ptr Requirements
pr

bindMemory :: Device.D -> B -> Memory.M -> Device.Size -> IO ()
bindMemory :: D -> B -> M -> Size -> IO ()
bindMemory (Device.D D
dvc) (B B
b) (Memory.M IORef M
mem) (Device.Size Word64
sz) = do
	M
m <- IORef M -> IO M
forall a. IORef a -> IO a
readIORef IORef M
mem
	Result -> IO ()
throwUnlessSuccess (Result -> IO ()) -> (Int32 -> Result) -> Int32 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Result
Result (Int32 -> IO ()) -> IO Int32 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< D -> B -> M -> Word64 -> IO Int32
C.bindMemory D
dvc B
b M
m Word64
sz

data MemoryBarrier mn = MemoryBarrier {
	forall (mn :: Maybe (*)). MemoryBarrier mn -> M mn
memoryBarrierNext :: TMaybe.M mn,
	forall (mn :: Maybe (*)). MemoryBarrier mn -> AccessFlags
memoryBarrierSrcAccessMask :: AccessFlags,
	forall (mn :: Maybe (*)). MemoryBarrier mn -> AccessFlags
memoryBarrierDstAccessMask :: AccessFlags,
	forall (mn :: Maybe (*)). MemoryBarrier mn -> Index
memoryBarrierSrcQueueFamilyIndex :: QueueFamily.Index,
	forall (mn :: Maybe (*)). MemoryBarrier mn -> Index
memoryBarrierDstQueueFamilyIndex :: QueueFamily.Index,
	forall (mn :: Maybe (*)). MemoryBarrier mn -> B
memoryBarrierBuffer :: B,
	forall (mn :: Maybe (*)). MemoryBarrier mn -> Size
memoryBarrierOffset :: Device.Size,
	forall (mn :: Maybe (*)). MemoryBarrier mn -> Size
memoryBarrierSize :: Device.Size }

deriving instance Show (TMaybe.M mn) => Show (MemoryBarrier mn)

memoryBarrierToCore' :: WithPoked (TMaybe.M mn) =>
	MemoryBarrier mn -> (C.MemoryBarrier -> IO a) -> IO ()
memoryBarrierToCore' :: forall (mn :: Maybe (*)) a.
WithPoked (M mn) =>
MemoryBarrier mn -> (MemoryBarrier -> IO a) -> IO ()
memoryBarrierToCore' MemoryBarrier {
	memoryBarrierNext :: forall (mn :: Maybe (*)). MemoryBarrier mn -> M mn
memoryBarrierNext = M mn
mnxt,
	memoryBarrierSrcAccessMask :: forall (mn :: Maybe (*)). MemoryBarrier mn -> AccessFlags
memoryBarrierSrcAccessMask = AccessFlagBits Word32
sam,
	memoryBarrierDstAccessMask :: forall (mn :: Maybe (*)). MemoryBarrier mn -> AccessFlags
memoryBarrierDstAccessMask = AccessFlagBits Word32
dam,
	memoryBarrierSrcQueueFamilyIndex :: forall (mn :: Maybe (*)). MemoryBarrier mn -> Index
memoryBarrierSrcQueueFamilyIndex = QueueFamily.Index Word32
sqfi,
	memoryBarrierDstQueueFamilyIndex :: forall (mn :: Maybe (*)). MemoryBarrier mn -> Index
memoryBarrierDstQueueFamilyIndex = QueueFamily.Index Word32
dqfi,
	memoryBarrierBuffer :: forall (mn :: Maybe (*)). MemoryBarrier mn -> B
memoryBarrierBuffer = B B
b,
	memoryBarrierOffset :: forall (mn :: Maybe (*)). MemoryBarrier mn -> Size
memoryBarrierOffset = Device.Size Word64
ofst,
	memoryBarrierSize :: forall (mn :: Maybe (*)). MemoryBarrier mn -> Size
memoryBarrierSize = Device.Size Word64
sz } MemoryBarrier -> IO a
f =
	M mn -> (forall s. PtrS s (M mn) -> IO ()) -> IO ()
forall a b.
WithPoked a =>
a -> (forall s. PtrS s a -> IO b) -> IO b
forall b. M mn -> (forall s. PtrS s (M mn) -> IO b) -> IO b
withPoked' M mn
mnxt \PtrS s (M mn)
pnxt -> PtrS s (M mn) -> (Ptr (M mn) -> IO a) -> IO ()
forall s a b. PtrS s a -> (Ptr a -> IO b) -> IO ()
withPtrS PtrS s (M mn)
pnxt \(Ptr (M mn) -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr -> Ptr ()
pnxt') ->
	MemoryBarrier -> IO a
f C.MemoryBarrier {
		memoryBarrierSType :: ()
C.memoryBarrierSType = (),
		memoryBarrierPNext :: Ptr ()
C.memoryBarrierPNext = Ptr ()
pnxt',
		memoryBarrierSrcAccessMask :: Word32
C.memoryBarrierSrcAccessMask = Word32
sam,
		memoryBarrierDstAccessMask :: Word32
C.memoryBarrierDstAccessMask = Word32
dam,
		memoryBarrierSrcQueueFamilyIndex :: Word32
C.memoryBarrierSrcQueueFamilyIndex = Word32
sqfi,
		memoryBarrierDstQueueFamilyIndex :: Word32
C.memoryBarrierDstQueueFamilyIndex = Word32
dqfi,
		memoryBarrierBuffer :: B
C.memoryBarrierBuffer = B
b,
		memoryBarrierOffset :: Word64
C.memoryBarrierOffset = Word64
ofst,
		memoryBarrierSize :: Word64
C.memoryBarrierSize = Word64
sz }

data ImageCopy = ImageCopy {
	ImageCopy -> Size
imageCopyBufferOffset :: Device.Size,
	ImageCopy -> Word32
imageCopyBufferRowLength :: Word32,
	ImageCopy -> Word32
imageCopyBufferImageHeight :: Word32,
	ImageCopy -> SubresourceLayers
imageCopyImageSubresource :: Image.SubresourceLayers,
	ImageCopy -> Offset3d
imageCopyImageOffset :: Offset3d,
	ImageCopy -> Extent3d
imageCopyImageExtent :: Extent3d }
	deriving Int -> ImageCopy -> ShowS
[ImageCopy] -> ShowS
ImageCopy -> String
(Int -> ImageCopy -> ShowS)
-> (ImageCopy -> String)
-> ([ImageCopy] -> ShowS)
-> Show ImageCopy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ImageCopy -> ShowS
showsPrec :: Int -> ImageCopy -> ShowS
$cshow :: ImageCopy -> String
show :: ImageCopy -> String
$cshowList :: [ImageCopy] -> ShowS
showList :: [ImageCopy] -> ShowS
Show

imageCopyToCore :: ImageCopy -> C.ImageCopy
imageCopyToCore :: ImageCopy -> ImageCopy
imageCopyToCore ImageCopy {
	imageCopyBufferOffset :: ImageCopy -> Size
imageCopyBufferOffset = Device.Size Word64
bo,
	imageCopyBufferRowLength :: ImageCopy -> Word32
imageCopyBufferRowLength = Word32
brl,
	imageCopyBufferImageHeight :: ImageCopy -> Word32
imageCopyBufferImageHeight = Word32
bih,
	imageCopyImageSubresource :: ImageCopy -> SubresourceLayers
imageCopyImageSubresource = SubresourceLayers
isr,
	imageCopyImageOffset :: ImageCopy -> Offset3d
imageCopyImageOffset = Offset3d
io,
	imageCopyImageExtent :: ImageCopy -> Extent3d
imageCopyImageExtent = Extent3d
ie } = C.ImageCopy {
	imageCopyBufferOffset :: Word64
C.imageCopyBufferOffset = Word64
bo,
	imageCopyBufferRowLength :: Word32
C.imageCopyBufferRowLength = Word32
brl,
	imageCopyBufferImageHeight :: Word32
C.imageCopyBufferImageHeight = Word32
bih,
	imageCopyImageSubresource :: SubresourceLayers
C.imageCopyImageSubresource = SubresourceLayers -> SubresourceLayers
Image.subresourceLayersToCore SubresourceLayers
isr,
	imageCopyImageOffset :: Offset3d
C.imageCopyImageOffset = Offset3d
io,
	imageCopyImageExtent :: Extent3d
C.imageCopyImageExtent = Extent3d
ie }