{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE BlockArguments, TupleSections #-}
{-# LANGUAGe ScopedTypeVariables, RankNTypes, TypeApplications #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Gpu.Vulkan.Image.Middle.Internal (

	-- * CREATE AND DESTROY

	create, recreate, recreate', destroy, I(..), CreateInfo(..),

	-- ** Image Group

	Group, group, create', destroy', lookup,

	-- * GET MEMORY REQUIREMENTS AND BIND MEMORY

	getMemoryRequirements, bindMemory,

	-- * MEMORY BARRIER

	MemoryBarrier(..), memoryBarrierToCore,
	SubresourceRange(..), subresourceRangeToCore,

	-- * BLIT

	Blit(..), blitToCore,
	SubresourceLayers(..), subresourceLayersToCore,

	-- * OTHERS

	Subresource(..), subresourceToCore

	) where

import Prelude hiding (lookup)
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 Control.Concurrent.STM
import Control.Concurrent.STM.TSem
import Data.TypeLevel.Maybe qualified as TMaybe
import Data.TypeLevel.ParMaybe qualified as TPMaybe
import Data.Map qualified as M
import Data.IORef
import Data.Word

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

import Gpu.Vulkan.AllocationCallbacks.Middle.Internal
	qualified as AllocationCallbacks
import qualified Gpu.Vulkan.Device.Middle.Types as Device
import qualified Gpu.Vulkan.Memory.Middle.Internal as Memory
import qualified Gpu.Vulkan.Image.Core as C
import qualified Gpu.Vulkan.Sample.Enum as Sample
import qualified Gpu.Vulkan.QueueFamily.EnumManual as QueueFamily

data SubresourceRange = SubresourceRange {
	SubresourceRange -> AspectFlags
subresourceRangeAspectMask :: AspectFlags,
	SubresourceRange -> Word32
subresourceRangeBaseMipLevel :: Word32,
	SubresourceRange -> Word32
subresourceRangeLevelCount :: Word32,
	SubresourceRange -> Word32
subresourceRangeBaseArrayLayer :: Word32,
	SubresourceRange -> Word32
subresourceRangeLayerCount :: Word32 }
	deriving Int -> SubresourceRange -> ShowS
[SubresourceRange] -> ShowS
SubresourceRange -> String
(Int -> SubresourceRange -> ShowS)
-> (SubresourceRange -> String)
-> ([SubresourceRange] -> ShowS)
-> Show SubresourceRange
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SubresourceRange -> ShowS
showsPrec :: Int -> SubresourceRange -> ShowS
$cshow :: SubresourceRange -> String
show :: SubresourceRange -> String
$cshowList :: [SubresourceRange] -> ShowS
showList :: [SubresourceRange] -> ShowS
Show

subresourceRangeToCore :: SubresourceRange -> C.SubresourceRange
subresourceRangeToCore :: SubresourceRange -> SubresourceRange
subresourceRangeToCore SubresourceRange {
	subresourceRangeAspectMask :: SubresourceRange -> AspectFlags
subresourceRangeAspectMask = AspectFlagBits Word32
am,
	subresourceRangeBaseMipLevel :: SubresourceRange -> Word32
subresourceRangeBaseMipLevel = Word32
bmlv,
	subresourceRangeLevelCount :: SubresourceRange -> Word32
subresourceRangeLevelCount = Word32
lvc,
	subresourceRangeBaseArrayLayer :: SubresourceRange -> Word32
subresourceRangeBaseArrayLayer = Word32
baly,
	subresourceRangeLayerCount :: SubresourceRange -> Word32
subresourceRangeLayerCount = Word32
lyc } = C.SubresourceRange {
		subresourceRangeAspectMask :: Word32
C.subresourceRangeAspectMask = Word32
am,
		subresourceRangeBaseMipLevel :: Word32
C.subresourceRangeBaseMipLevel = Word32
bmlv,
		subresourceRangeLevelCount :: Word32
C.subresourceRangeLevelCount = Word32
lvc,
		subresourceRangeBaseArrayLayer :: Word32
C.subresourceRangeBaseArrayLayer = Word32
baly,
		subresourceRangeLayerCount :: Word32
C.subresourceRangeLayerCount = Word32
lyc }

newtype I = I (IORef (Extent3d, C.I))

data CreateInfo mn = 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 -> Type
createInfoImageType :: Type,
	forall (mn :: Maybe (*)). CreateInfo mn -> Format
createInfoFormat :: Format,
	forall (mn :: Maybe (*)). CreateInfo mn -> Extent3d
createInfoExtent :: Extent3d,
	forall (mn :: Maybe (*)). CreateInfo mn -> Word32
createInfoMipLevels :: Word32,
	forall (mn :: Maybe (*)). CreateInfo mn -> Word32
createInfoArrayLayers :: Word32,
	forall (mn :: Maybe (*)). CreateInfo mn -> CountFlagBits
createInfoSamples :: Sample.CountFlagBits,
	forall (mn :: Maybe (*)). CreateInfo mn -> Tiling
createInfoTiling :: Tiling,
	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],
	forall (mn :: Maybe (*)). CreateInfo mn -> Layout
createInfoInitialLayout :: Layout }

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,
	createInfoImageType :: forall (mn :: Maybe (*)). CreateInfo mn -> Type
createInfoImageType = Type Word32
tp,
	createInfoFormat :: forall (mn :: Maybe (*)). CreateInfo mn -> Format
createInfoFormat = Format Word32
fmt,
	createInfoExtent :: forall (mn :: Maybe (*)). CreateInfo mn -> Extent3d
createInfoExtent = Extent3d
ext,
	createInfoMipLevels :: forall (mn :: Maybe (*)). CreateInfo mn -> Word32
createInfoMipLevels = Word32
mls,
	createInfoArrayLayers :: forall (mn :: Maybe (*)). CreateInfo mn -> Word32
createInfoArrayLayers = Word32
als,
	createInfoSamples :: forall (mn :: Maybe (*)). CreateInfo mn -> CountFlagBits
createInfoSamples = Sample.CountFlagBits Word32
smpls,
	createInfoTiling :: forall (mn :: Maybe (*)). CreateInfo mn -> Tiling
createInfoTiling = Tiling Word32
tlng,
	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),
	createInfoInitialLayout :: forall (mn :: Maybe (*)). CreateInfo mn -> Layout
createInfoInitialLayout = Layout Word32
lyt } Ptr CreateInfo -> 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') ->
	Int -> (Ptr Word32 -> IO a) -> IO a
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
		let	ci :: CreateInfo
ci = C.CreateInfo {
				createInfoSType :: ()
C.createInfoSType = (),
				createInfoPNext :: Ptr ()
C.createInfoPNext = Ptr ()
pnxt',
				createInfoFlags :: Word32
C.createInfoFlags = Word32
flgs,
				createInfoImageType :: Word32
C.createInfoImageType = Word32
tp,
				createInfoFormat :: Word32
C.createInfoFormat = Word32
fmt,
				createInfoExtent :: Extent3d
C.createInfoExtent = Extent3d
ext,
				createInfoMipLevels :: Word32
C.createInfoMipLevels = Word32
mls,
				createInfoArrayLayers :: Word32
C.createInfoArrayLayers = Word32
als,
				createInfoSamples :: Word32
C.createInfoSamples = Word32
smpls,
				createInfoTiling :: Word32
C.createInfoTiling = Word32
tlng,
				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,
				createInfoInitialLayout :: Word32
C.createInfoInitialLayout = Word32
lyt }
		CreateInfo -> (Ptr CreateInfo -> IO a) -> IO a
forall a b. Pokable a => a -> (Ptr a -> IO b) -> IO b
withPoked CreateInfo
ci Ptr CreateInfo -> IO a
f

create :: WithPoked (TMaybe.M mn) =>
	Device.D -> CreateInfo mn -> TPMaybe.M AllocationCallbacks.A mc -> IO I
create :: forall (mn :: Maybe (*)) (mc :: Maybe (*)).
WithPoked (M mn) =>
D -> CreateInfo mn -> M A mc -> IO I
create (Device.D D
dvc) CreateInfo mn
ci M A mc
mac = IORef (Extent3d, I) -> I
I (IORef (Extent3d, I) -> I) -> IO (IORef (Extent3d, I)) -> IO I
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr I -> IO (IORef (Extent3d, I))) -> IO (IORef (Extent3d, I))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr I
pimg -> 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 I -> IO Int32
C.create D
dvc Ptr CreateInfo
pci Ptr A
pac Ptr I
pimg
	(Extent3d, I) -> IO (IORef (Extent3d, I))
forall a. a -> IO (IORef a)
newIORef ((Extent3d, I) -> IO (IORef (Extent3d, I)))
-> (I -> (Extent3d, I)) -> I -> IO (IORef (Extent3d, I))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Extent3d
ex ,) (I -> IO (IORef (Extent3d, I))) -> IO I -> IO (IORef (Extent3d, I))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr I -> IO I
forall a. Storable a => Ptr a -> IO a
peek Ptr I
pimg
	where ex :: Extent3d
ex = CreateInfo mn -> Extent3d
forall (mn :: Maybe (*)). CreateInfo mn -> Extent3d
createInfoExtent CreateInfo mn
ci

group :: Device.D -> TPMaybe.M AllocationCallbacks.A md ->
	(forall s . Group s k -> IO a) -> IO a
group :: forall (md :: Maybe (*)) k a.
D -> M A md -> (forall s. Group s k -> IO a) -> IO a
group D
dvc M A md
mac forall s. Group s k -> IO a
f = do
	(sem, m) <- STM (TSem, TVar (Map k I)) -> IO (TSem, TVar (Map k I))
forall a. STM a -> IO a
atomically (STM (TSem, TVar (Map k I)) -> IO (TSem, TVar (Map k I)))
-> STM (TSem, TVar (Map k I)) -> IO (TSem, TVar (Map k I))
forall a b. (a -> b) -> a -> b
$ (,) (TSem -> TVar (Map k I) -> (TSem, TVar (Map k I)))
-> STM TSem -> STM (TVar (Map k I) -> (TSem, TVar (Map k I)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> STM TSem
newTSem Integer
1 STM (TVar (Map k I) -> (TSem, TVar (Map k I)))
-> STM (TVar (Map k I)) -> STM (TSem, TVar (Map k I))
forall a b. STM (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map k I -> STM (TVar (Map k I))
forall a. a -> STM (TVar a)
newTVar Map k I
forall k a. Map k a
M.empty
	rtn <- f $ Group sem m
	((\I
i -> D -> I -> M A md -> IO ()
forall (md :: Maybe (*)). D -> I -> M A md -> IO ()
destroy D
dvc I
i M A md
mac) `mapM_`) =<< atomically (readTVar m)
	pure rtn

create' :: (Ord k, WithPoked (TMaybe.M mn)) => Device.D ->
	Group sm k -> k -> CreateInfo mn ->
	TPMaybe.M AllocationCallbacks.A mc -> IO (Either String I)
create' :: forall k (mn :: Maybe (*)) sm (mc :: Maybe (*)).
(Ord k, WithPoked (M mn)) =>
D
-> Group sm k
-> k
-> CreateInfo mn
-> M A mc
-> IO (Either String I)
create' (Device.D D
dvc) (Group TSem
sem TVar (Map k I)
is) k
k CreateInfo mn
ci M A mc
mac = do
	ok <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically do
		mx <- (k -> Map k I -> Maybe I
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k) (Map k I -> Maybe I) -> STM (Map k I) -> STM (Maybe I)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k I) -> STM (Map k I)
forall a. TVar a -> STM a
readTVar TVar (Map k I)
is
		case mx of
			Maybe I
Nothing -> TSem -> STM ()
waitTSem TSem
sem STM () -> STM Bool -> STM Bool
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
			Just I
_ -> Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
	if ok
	then do	i <- I <$> alloca \Ptr I
pimg -> 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 I -> IO Int32
C.create D
dvc Ptr CreateInfo
pci Ptr A
pac Ptr I
pimg
			(Extent3d, I) -> IO (IORef (Extent3d, I))
forall a. a -> IO (IORef a)
newIORef ((Extent3d, I) -> IO (IORef (Extent3d, I)))
-> (I -> (Extent3d, I)) -> I -> IO (IORef (Extent3d, I))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Extent3d
ex ,) (I -> IO (IORef (Extent3d, I))) -> IO I -> IO (IORef (Extent3d, I))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr I -> IO I
forall a. Storable a => Ptr a -> IO a
peek Ptr I
pimg
		atomically $ modifyTVar is (M.insert k i) >> signalTSem sem
		pure $ Right i
	else pure . Left $ "Gpu.Vulkan.Image.create': The key already exist"
	where ex :: Extent3d
ex = CreateInfo mn -> Extent3d
forall (mn :: Maybe (*)). CreateInfo mn -> Extent3d
createInfoExtent CreateInfo mn
ci

data Group s k = Group TSem (TVar (M.Map k I))

destroy' :: Ord k => Device.D ->
	Group sm k -> k -> TPMaybe.M AllocationCallbacks.A mc ->
	IO (Either String ())
destroy' :: forall k sm (mc :: Maybe (*)).
Ord k =>
D -> Group sm k -> k -> M A mc -> IO (Either String ())
destroy' D
dvc (Group TSem
sem TVar (Map k I)
is) k
k M A mc
mac = do
	mi <- STM (Maybe I) -> IO (Maybe I)
forall a. STM a -> IO a
atomically do
		mx <- (k -> Map k I -> Maybe I
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k) (Map k I -> Maybe I) -> STM (Map k I) -> STM (Maybe I)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k I) -> STM (Map k I)
forall a. TVar a -> STM a
readTVar TVar (Map k I)
is
		case mx of
			Maybe I
Nothing -> Maybe I -> STM (Maybe I)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe I
forall a. Maybe a
Nothing
			Just I
_ -> TSem -> STM ()
waitTSem TSem
sem STM () -> STM (Maybe I) -> STM (Maybe I)
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe I -> STM (Maybe I)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe I
mx
	case mi of
		Maybe I
Nothing -> Either String () -> IO (Either String ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String () -> IO (Either String ()))
-> Either String () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left String
"Gpu.Vulkan.Image.destroy: No such key"
		Just I
i -> do
			D -> I -> M A mc -> IO ()
forall (md :: Maybe (*)). D -> I -> M A md -> IO ()
destroy D
dvc I
i M A mc
mac
			STM (Either String ()) -> IO (Either String ())
forall a. STM a -> IO a
atomically do
				TVar (Map k I) -> (Map k I -> Map k I) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map k I)
is (k -> Map k I -> Map k I
forall k a. Ord k => k -> Map k a -> Map k a
M.delete k
k)
				TSem -> STM ()
signalTSem TSem
sem
				Either String () -> STM (Either String ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String () -> STM (Either String ()))
-> Either String () -> STM (Either String ())
forall a b. (a -> b) -> a -> b
$ () -> Either String ()
forall a b. b -> Either a b
Right ()

lookup :: Ord k => Group sm k -> k -> IO (Maybe I)
lookup :: forall k sm. Ord k => Group sm k -> k -> IO (Maybe I)
lookup (Group TSem
_sem TVar (Map k I)
is) k
k = STM (Maybe I) -> IO (Maybe I)
forall a. STM a -> IO a
atomically (STM (Maybe I) -> IO (Maybe I)) -> STM (Maybe I) -> IO (Maybe I)
forall a b. (a -> b) -> a -> b
$ k -> Map k I -> Maybe I
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k (Map k I -> Maybe I) -> STM (Map k I) -> STM (Maybe I)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k I) -> STM (Map k I)
forall a. TVar a -> STM a
readTVar TVar (Map k I)
is

recreate :: WithPoked (TMaybe.M mn) =>
	Device.D -> CreateInfo mn ->
	TPMaybe.M AllocationCallbacks.A mc ->
	TPMaybe.M AllocationCallbacks.A md ->
	I -> IO ()
recreate :: forall (mn :: Maybe (*)) (mc :: Maybe (*)) (md :: Maybe (*)).
WithPoked (M mn) =>
D -> CreateInfo mn -> M A mc -> M A md -> I -> IO ()
recreate d :: D
d@(Device.D D
dvc) CreateInfo mn
ci M A mc
macc M A md
macd i :: I
i@(I IORef (Extent3d, I)
ri) = (Ptr I -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr I
pimg ->
	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
macc \Ptr A
pacc -> do
		r <- D -> Ptr CreateInfo -> Ptr A -> Ptr I -> IO Int32
C.create D
dvc Ptr CreateInfo
pci Ptr A
pacc Ptr I
pimg
		throwUnlessSuccess $ Result r
		destroy d i macd
		writeIORef ri . (ex ,) =<< peek pimg
	where ex :: Extent3d
ex = CreateInfo mn -> Extent3d
forall (mn :: Maybe (*)). CreateInfo mn -> Extent3d
createInfoExtent CreateInfo mn
ci

recreate' :: WithPoked (TMaybe.M mn) =>
	Device.D -> CreateInfo mn ->
	TPMaybe.M AllocationCallbacks.A mc ->
	TPMaybe.M AllocationCallbacks.A md ->
	I -> IO a -> IO ()
recreate' :: forall (mn :: Maybe (*)) (mc :: Maybe (*)) (md :: Maybe (*)) a.
WithPoked (M mn) =>
D -> CreateInfo mn -> M A mc -> M A md -> I -> IO a -> IO ()
recreate' (Device.D D
dvc) CreateInfo mn
ci M A mc
macc M A md
macd (I IORef (Extent3d, I)
ri) IO a
act = (Ptr I -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr I
pimg ->
	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
macc \Ptr A
pacc -> do
		r <- D -> Ptr CreateInfo -> Ptr A -> Ptr I -> IO Int32
C.create D
dvc Ptr CreateInfo
pci Ptr A
pacc Ptr I
pimg
		throwUnlessSuccess $ Result r
		(_, img) <- readIORef ri
		writeIORef ri . (ex ,) =<< peek pimg
		_ <- act
		AllocationCallbacks.mToCore macd $ C.destroy dvc img
	where ex :: Extent3d
ex = CreateInfo mn -> Extent3d
forall (mn :: Maybe (*)). CreateInfo mn -> Extent3d
createInfoExtent CreateInfo mn
ci

getMemoryRequirements :: Device.D -> I -> IO Memory.Requirements
getMemoryRequirements :: D -> I -> IO Requirements
getMemoryRequirements (Device.D D
dvc) (I IORef (Extent3d, I)
ri) =
	(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
		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
		lift do	(_, i) <- readIORef ri
			C.getMemoryRequirements dvc i pr
			peek pr

bindMemory :: Device.D -> I -> Memory.M -> Device.Size -> IO ()
bindMemory :: D -> I -> M -> Size -> IO ()
bindMemory (Device.D D
dvc) (I IORef (Extent3d, I)
rimg) M
mem (Device.Size Word64
ost) = do
	(_, img) <- IORef (Extent3d, I) -> IO (Extent3d, I)
forall a. IORef a -> IO a
readIORef IORef (Extent3d, I)
rimg
	cmem <- Memory.mToCore mem
	r <- C.bindMemory dvc img cmem ost
	throwUnlessSuccess $ Result r

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 -> Layout
memoryBarrierOldLayout :: Layout,
	forall (mn :: Maybe (*)). MemoryBarrier mn -> Layout
memoryBarrierNewLayout :: Layout,
	forall (mn :: Maybe (*)). MemoryBarrier mn -> Index
memoryBarrierSrcQueueFamilyIndex :: QueueFamily.Index,
	forall (mn :: Maybe (*)). MemoryBarrier mn -> Index
memoryBarrierDstQueueFamilyIndex :: QueueFamily.Index,
	forall (mn :: Maybe (*)). MemoryBarrier mn -> I
memoryBarrierImage :: I,
	forall (mn :: Maybe (*)). MemoryBarrier mn -> SubresourceRange
memoryBarrierSubresourceRange :: SubresourceRange }

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,
	memoryBarrierOldLayout :: forall (mn :: Maybe (*)). MemoryBarrier mn -> Layout
memoryBarrierOldLayout = Layout Word32
ol,
	memoryBarrierNewLayout :: forall (mn :: Maybe (*)). MemoryBarrier mn -> Layout
memoryBarrierNewLayout = Layout Word32
nl,
	memoryBarrierSrcQueueFamilyIndex :: forall (mn :: Maybe (*)). MemoryBarrier mn -> Index
memoryBarrierSrcQueueFamilyIndex = QueueFamily.Index Word32
sqfi,
	memoryBarrierDstQueueFamilyIndex :: forall (mn :: Maybe (*)). MemoryBarrier mn -> Index
memoryBarrierDstQueueFamilyIndex = QueueFamily.Index Word32
dqfi,
	memoryBarrierImage :: forall (mn :: Maybe (*)). MemoryBarrier mn -> I
memoryBarrierImage = I IORef (Extent3d, I)
rimg,
	memoryBarrierSubresourceRange :: forall (mn :: Maybe (*)). MemoryBarrier mn -> SubresourceRange
memoryBarrierSubresourceRange = SubresourceRange
srr } 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') ->
	IORef (Extent3d, I) -> IO (Extent3d, I)
forall a. IORef a -> IO a
readIORef IORef (Extent3d, I)
rimg IO (Extent3d, I) -> ((Extent3d, I) -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Extent3d
_, I
img) ->
	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,
		memoryBarrierOldLayout :: Word32
C.memoryBarrierOldLayout = Word32
ol,
		memoryBarrierNewLayout :: Word32
C.memoryBarrierNewLayout = Word32
nl,
		memoryBarrierSrcQueueFamilyIndex :: Word32
C.memoryBarrierSrcQueueFamilyIndex = Word32
sqfi,
		memoryBarrierDstQueueFamilyIndex :: Word32
C.memoryBarrierDstQueueFamilyIndex = Word32
dqfi,
		memoryBarrierImage :: I
C.memoryBarrierImage = I
img,
		memoryBarrierSubresourceRange :: SubresourceRange
C.memoryBarrierSubresourceRange = SubresourceRange -> SubresourceRange
subresourceRangeToCore SubresourceRange
srr }

data SubresourceLayers = SubresourceLayers {
	SubresourceLayers -> AspectFlags
subresourceLayersAspectMask :: AspectFlags,
	SubresourceLayers -> Word32
subresourceLayersMipLevel :: Word32,
	SubresourceLayers -> Word32
subresourceLayersBaseArrayLayer :: Word32,
	SubresourceLayers -> Word32
subresourceLayersLayerCount :: Word32 }
	deriving Int -> SubresourceLayers -> ShowS
[SubresourceLayers] -> ShowS
SubresourceLayers -> String
(Int -> SubresourceLayers -> ShowS)
-> (SubresourceLayers -> String)
-> ([SubresourceLayers] -> ShowS)
-> Show SubresourceLayers
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SubresourceLayers -> ShowS
showsPrec :: Int -> SubresourceLayers -> ShowS
$cshow :: SubresourceLayers -> String
show :: SubresourceLayers -> String
$cshowList :: [SubresourceLayers] -> ShowS
showList :: [SubresourceLayers] -> ShowS
Show

subresourceLayersToCore :: SubresourceLayers -> C.SubresourceLayers
subresourceLayersToCore :: SubresourceLayers -> SubresourceLayers
subresourceLayersToCore SubresourceLayers {
	subresourceLayersAspectMask :: SubresourceLayers -> AspectFlags
subresourceLayersAspectMask = AspectFlagBits Word32
am,
	subresourceLayersMipLevel :: SubresourceLayers -> Word32
subresourceLayersMipLevel = Word32
ml,
	subresourceLayersBaseArrayLayer :: SubresourceLayers -> Word32
subresourceLayersBaseArrayLayer = Word32
bal,
	subresourceLayersLayerCount :: SubresourceLayers -> Word32
subresourceLayersLayerCount = Word32
lc } = C.SubresourceLayers {
		subresourceLayersAspectMask :: Word32
C.subresourceLayersAspectMask = Word32
am,
		subresourceLayersMipLevel :: Word32
C.subresourceLayersMipLevel = Word32
ml,
		subresourceLayersBaseArrayLayer :: Word32
C.subresourceLayersBaseArrayLayer = Word32
bal,
		subresourceLayersLayerCount :: Word32
C.subresourceLayersLayerCount = Word32
lc }

destroy :: Device.D -> I -> TPMaybe.M AllocationCallbacks.A md -> IO ()
destroy :: forall (md :: Maybe (*)). D -> I -> M A md -> IO ()
destroy (Device.D D
dvc) (I IORef (Extent3d, I)
rimg) 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
pac -> do
		(_, img) <- IORef (Extent3d, I) -> IO (Extent3d, I)
forall a. IORef a -> IO a
readIORef IORef (Extent3d, I)
rimg
		C.destroy dvc img pac

data Blit = Blit {
	Blit -> SubresourceLayers
blitSrcSubresource :: SubresourceLayers,
	Blit -> Offset3d
blitSrcOffsetFrom :: Offset3d,
	Blit -> Offset3d
blitSrcOffsetTo :: Offset3d,
	Blit -> SubresourceLayers
blitDstSubresource :: SubresourceLayers,
	Blit -> Offset3d
blitDstOffsetFrom :: Offset3d,
	Blit -> Offset3d
blitDstOffsetTo :: Offset3d }
	deriving Int -> Blit -> ShowS
[Blit] -> ShowS
Blit -> String
(Int -> Blit -> ShowS)
-> (Blit -> String) -> ([Blit] -> ShowS) -> Show Blit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Blit -> ShowS
showsPrec :: Int -> Blit -> ShowS
$cshow :: Blit -> String
show :: Blit -> String
$cshowList :: [Blit] -> ShowS
showList :: [Blit] -> ShowS
Show

blitToCore :: Blit -> C.Blit
blitToCore :: Blit -> Blit
blitToCore Blit {
	blitSrcSubresource :: Blit -> SubresourceLayers
blitSrcSubresource = SubresourceLayers
ssr,
	blitSrcOffsetFrom :: Blit -> Offset3d
blitSrcOffsetFrom = Offset3d
sof,
	blitSrcOffsetTo :: Blit -> Offset3d
blitSrcOffsetTo = Offset3d
sot,
	blitDstSubresource :: Blit -> SubresourceLayers
blitDstSubresource = SubresourceLayers
dsr,
	blitDstOffsetFrom :: Blit -> Offset3d
blitDstOffsetFrom = Offset3d
dof,
	blitDstOffsetTo :: Blit -> Offset3d
blitDstOffsetTo = Offset3d
dot } = C.Blit {
	blitSrcSubresource :: SubresourceLayers
C.blitSrcSubresource = SubresourceLayers -> SubresourceLayers
subresourceLayersToCore SubresourceLayers
ssr,
	blitSrcOffsets :: ListOffset3d
C.blitSrcOffsets = [Offset3d
sof, Offset3d
sot],
	blitDstSubresource :: SubresourceLayers
C.blitDstSubresource = SubresourceLayers -> SubresourceLayers
subresourceLayersToCore SubresourceLayers
dsr,
	blitDstOffsets :: ListOffset3d
C.blitDstOffsets = [Offset3d
dof, Offset3d
dot] }

data Subresource = Subresource {
	Subresource -> AspectFlags
subresourceAspectMask :: AspectFlags,
	Subresource -> Word32
subresourceMipLevel :: Word32,
	Subresource -> Word32
subresourceArrayLayer :: Word32 }
	deriving Int -> Subresource -> ShowS
[Subresource] -> ShowS
Subresource -> String
(Int -> Subresource -> ShowS)
-> (Subresource -> String)
-> ([Subresource] -> ShowS)
-> Show Subresource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Subresource -> ShowS
showsPrec :: Int -> Subresource -> ShowS
$cshow :: Subresource -> String
show :: Subresource -> String
$cshowList :: [Subresource] -> ShowS
showList :: [Subresource] -> ShowS
Show

subresourceToCore :: Subresource -> C.Subresource
subresourceToCore :: Subresource -> Subresource
subresourceToCore Subresource {
	subresourceAspectMask :: Subresource -> AspectFlags
subresourceAspectMask = AspectFlagBits Word32
am,
	subresourceMipLevel :: Subresource -> Word32
subresourceMipLevel = Word32
ml, subresourceArrayLayer :: Subresource -> Word32
subresourceArrayLayer = Word32
al } = C.Subresource {
	subresourceAspectMask :: Word32
C.subresourceAspectMask = Word32
am,
	subresourceMipLevel :: Word32
C.subresourceMipLevel = Word32
ml, subresourceArrayLayer :: Word32
C.subresourceArrayLayer = Word32
al }