{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Gpu.Vulkan.RenderPass.Internal (

	-- * CREATE

	create, R, CreateInfo(..),

	-- ** Group

	group, Group, create', unsafeDestroy, lookup,

	-- * BEGIN INFO

	BeginInfo(..), beginInfoToMiddle

	) where

import Prelude hiding (lookup)

import Foreign.Storable.PeekPoke
import Control.Concurrent.STM
import Control.Concurrent.STM.TSem
import Control.Exception
import Data.TypeLevel.Maybe qualified as TMaybe
import Data.TypeLevel.ParMaybe qualified as TPMaybe
import Data.TypeLevel.Tuple.Uncurry
import Data.Map qualified as Map
import Data.HeteroParList qualified as HeteroParList

import Gpu.Vulkan.RenderPass.Type

import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks
import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks
import qualified Gpu.Vulkan.Device.Type as Device
import Gpu.Vulkan.RenderPass.Enum
import qualified Gpu.Vulkan.RenderPass.Middle as M
import qualified Gpu.Vulkan.Attachment as Attachment

import qualified Gpu.Vulkan.Subpass.Middle as Subpass

import qualified Gpu.Vulkan.Framebuffer.Type as Framebuffer
import Gpu.Vulkan.Middle

-- CREATE

create :: (
	WithPoked (TMaybe.M mn), Attachment.DescriptionListToMiddle fmts,
	AllocationCallbacks.ToMiddle mac ) =>
	Device.D sd -> CreateInfo mn fmts ->
	TPMaybe.M (U2 AllocationCallbacks.A) mac ->
	(forall s . R s -> IO a) -> IO a
create :: forall (mn :: Maybe (*)) (fmts :: [Format]) (mac :: Maybe (*, *))
       sd a.
(WithPoked (M mn), DescriptionListToMiddle fmts, ToMiddle mac) =>
D sd
-> CreateInfo mn fmts
-> M (U2 A) mac
-> (forall s. R s -> IO a)
-> IO a
create (Device.D D
dvc) CreateInfo mn fmts
ci (M (U2 A) mac -> M A (Snd mac)
forall (msa :: Maybe (*, *)).
ToMiddle msa =>
M (U2 A) msa -> M A (Snd msa)
AllocationCallbacks.toMiddle -> M A (Snd mac)
mac) forall s. R s -> IO a
f = IO R -> (R -> IO ()) -> (R -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
	(D -> CreateInfo mn -> M A (Snd mac) -> IO R
forall (mn :: Maybe (*)) (mc :: Maybe (*)).
WithPoked (M mn) =>
D -> CreateInfo mn -> M A mc -> IO R
M.create D
dvc (CreateInfo mn fmts -> CreateInfo mn
forall (fmts :: [Format]) (n :: Maybe (*)).
DescriptionListToMiddle fmts =>
CreateInfo n fmts -> CreateInfo n
createInfoToMiddle CreateInfo mn fmts
ci) M A (Snd mac)
mac)
	(\R
r -> D -> R -> M A (Snd mac) -> IO ()
forall (md :: Maybe (*)). D -> R -> M A md -> IO ()
M.destroy D
dvc R
r M A (Snd mac)
mac) (R Any -> IO a
forall s. R s -> IO a
f (R Any -> IO a) -> (R -> R Any) -> R -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R -> R Any
forall s. R -> R s
R)

data CreateInfo mn fmts = CreateInfo {
	forall (mn :: Maybe (*)) (fmts :: [Format]).
CreateInfo mn fmts -> M mn
createInfoNext :: TMaybe.M mn,
	forall (mn :: Maybe (*)) (fmts :: [Format]).
CreateInfo mn fmts -> CreateFlags
createInfoFlags :: CreateFlags,
	forall (mn :: Maybe (*)) (fmts :: [Format]).
CreateInfo mn fmts -> PL Description fmts
createInfoAttachments ::
		HeteroParList.PL Attachment.Description fmts,
	forall (mn :: Maybe (*)) (fmts :: [Format]).
CreateInfo mn fmts -> [Description]
createInfoSubpasses :: [Subpass.Description],
	forall (mn :: Maybe (*)) (fmts :: [Format]).
CreateInfo mn fmts -> [Dependency]
createInfoDependencies :: [Subpass.Dependency] }

createInfoToMiddle :: Attachment.DescriptionListToMiddle fmts =>
	CreateInfo n fmts -> M.CreateInfo n
createInfoToMiddle :: forall (fmts :: [Format]) (n :: Maybe (*)).
DescriptionListToMiddle fmts =>
CreateInfo n fmts -> CreateInfo n
createInfoToMiddle CreateInfo {
	createInfoNext :: forall (mn :: Maybe (*)) (fmts :: [Format]).
CreateInfo mn fmts -> M mn
createInfoNext = M n
mnxt,
	createInfoFlags :: forall (mn :: Maybe (*)) (fmts :: [Format]).
CreateInfo mn fmts -> CreateFlags
createInfoFlags = CreateFlags
flgs,
	createInfoAttachments :: forall (mn :: Maybe (*)) (fmts :: [Format]).
CreateInfo mn fmts -> PL Description fmts
createInfoAttachments = PL Description fmts
atts,
	createInfoSubpasses :: forall (mn :: Maybe (*)) (fmts :: [Format]).
CreateInfo mn fmts -> [Description]
createInfoSubpasses = [Description]
spss,
	createInfoDependencies :: forall (mn :: Maybe (*)) (fmts :: [Format]).
CreateInfo mn fmts -> [Dependency]
createInfoDependencies = [Dependency]
dps } = M.CreateInfo {
	createInfoNext :: M n
M.createInfoNext = M n
mnxt,
	createInfoFlags :: CreateFlags
M.createInfoFlags = CreateFlags
flgs,
	createInfoAttachments :: [Description]
M.createInfoAttachments = PL Description fmts -> [Description]
forall (fmts :: [Format]).
DescriptionListToMiddle fmts =>
PL Description fmts -> [Description]
Attachment.descriptionListToMiddle PL Description fmts
atts,
	createInfoSubpasses :: [Description]
M.createInfoSubpasses = [Description]
spss,
	createInfoDependencies :: [Dependency]
M.createInfoDependencies = [Dependency]
dps }

-- Group

data Group sd ma sr k = Group (Device.D sd)
	(TPMaybe.M (U2 AllocationCallbacks.A) ma)
	TSem (TVar (Map.Map k (R sr)))

group :: AllocationCallbacks.ToMiddle ma =>
	Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma ->
	(forall sr . Group sd ma sr k -> IO a) -> IO a
group :: forall (ma :: Maybe (*, *)) sd k a.
ToMiddle ma =>
D sd
-> M (U2 A) ma -> (forall sr. Group sd ma sr k -> IO a) -> IO a
group dvc :: D sd
dvc@(Device.D D
mdvc) mac :: M (U2 A) ma
mac@(M (U2 A) ma -> M A (Snd ma)
forall (msa :: Maybe (*, *)).
ToMiddle msa =>
M (U2 A) msa -> M A (Snd msa)
AllocationCallbacks.toMiddle -> M A (Snd ma)
mmac) forall sr. Group sd ma sr k -> IO a
f = do
	(TSem
sem, TVar (Map k (R Any))
m) <- STM (TSem, TVar (Map k (R Any))) -> IO (TSem, TVar (Map k (R Any)))
forall a. STM a -> IO a
atomically (STM (TSem, TVar (Map k (R Any)))
 -> IO (TSem, TVar (Map k (R Any))))
-> STM (TSem, TVar (Map k (R Any)))
-> IO (TSem, TVar (Map k (R Any)))
forall a b. (a -> b) -> a -> b
$ (,) (TSem -> TVar (Map k (R Any)) -> (TSem, TVar (Map k (R Any))))
-> STM TSem
-> STM (TVar (Map k (R Any)) -> (TSem, TVar (Map k (R Any))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> STM TSem
newTSem Integer
1 STM (TVar (Map k (R Any)) -> (TSem, TVar (Map k (R Any))))
-> STM (TVar (Map k (R Any))) -> STM (TSem, TVar (Map k (R Any)))
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 (R Any) -> STM (TVar (Map k (R Any)))
forall a. a -> STM (TVar a)
newTVar Map k (R Any)
forall k a. Map k a
Map.empty
	a
rtn <- Group sd ma Any k -> IO a
forall sr. Group sd ma sr k -> IO a
f (Group sd ma Any k -> IO a) -> Group sd ma Any k -> IO a
forall a b. (a -> b) -> a -> b
$ D sd
-> M (U2 A) ma -> TSem -> TVar (Map k (R Any)) -> Group sd ma Any k
forall sd (ma :: Maybe (*, *)) sr k.
D sd
-> M (U2 A) ma -> TSem -> TVar (Map k (R sr)) -> Group sd ma sr k
Group D sd
dvc M (U2 A) ma
mac TSem
sem TVar (Map k (R Any))
m
	((\(R R
mr) -> D -> R -> M A (Snd ma) -> IO ()
forall (md :: Maybe (*)). D -> R -> M A md -> IO ()
M.destroy D
mdvc R
mr M A (Snd ma)
mmac) (R Any -> IO ()) -> Map k (R Any) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_`)
		(Map k (R Any) -> IO ()) -> IO (Map k (R Any)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM (Map k (R Any)) -> IO (Map k (R Any))
forall a. STM a -> IO a
atomically (TVar (Map k (R Any)) -> STM (Map k (R Any))
forall a. TVar a -> STM a
readTVar TVar (Map k (R Any))
m)
	a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
rtn

create' :: (
	Ord k, WithPoked (TMaybe.M mn), Attachment.DescriptionListToMiddle fmts,
	AllocationCallbacks.ToMiddle mac ) =>
	Group sd mac sr k -> k -> CreateInfo mn fmts ->
	IO (Either String (R sr))
create' :: forall k (mn :: Maybe (*)) (fmts :: [Format]) (mac :: Maybe (*, *))
       sd sr.
(Ord k, WithPoked (M mn), DescriptionListToMiddle fmts,
 ToMiddle mac) =>
Group sd mac sr k
-> k -> CreateInfo mn fmts -> IO (Either String (R sr))
create' (Group (Device.D D
mdvc)
	(M (U2 A) mac -> M A (Snd mac)
forall (msa :: Maybe (*, *)).
ToMiddle msa =>
M (U2 A) msa -> M A (Snd msa)
AllocationCallbacks.toMiddle -> M A (Snd mac)
mac) TSem
sem TVar (Map k (R sr))
rs) k
k CreateInfo mn fmts
ci = do
	Bool
ok <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically do
		Maybe (R sr)
mx <- k -> Map k (R sr) -> Maybe (R sr)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k (Map k (R sr) -> Maybe (R sr))
-> STM (Map k (R sr)) -> STM (Maybe (R sr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (R sr)) -> STM (Map k (R sr))
forall a. TVar a -> STM a
readTVar TVar (Map k (R sr))
rs
		case Maybe (R sr)
mx of
			Maybe (R sr)
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 R sr
_ -> Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
	if Bool
ok
	then do	R
r <- D -> CreateInfo mn -> M A (Snd mac) -> IO R
forall (mn :: Maybe (*)) (mc :: Maybe (*)).
WithPoked (M mn) =>
D -> CreateInfo mn -> M A mc -> IO R
M.create D
mdvc (CreateInfo mn fmts -> CreateInfo mn
forall (fmts :: [Format]) (n :: Maybe (*)).
DescriptionListToMiddle fmts =>
CreateInfo n fmts -> CreateInfo n
createInfoToMiddle CreateInfo mn fmts
ci) M A (Snd mac)
mac
		let r' :: R sr
r' = R -> R sr
forall s. R -> R s
R R
r
		STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map k (R sr)) -> (Map k (R sr) -> Map k (R sr)) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map k (R sr))
rs (k -> R sr -> Map k (R sr) -> Map k (R sr)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k R sr
r') STM () -> STM () -> STM ()
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TSem -> STM ()
signalTSem TSem
sem
		Either String (R sr) -> IO (Either String (R sr))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (R sr) -> IO (Either String (R sr)))
-> Either String (R sr) -> IO (Either String (R sr))
forall a b. (a -> b) -> a -> b
$ R sr -> Either String (R sr)
forall a b. b -> Either a b
Right R sr
r'
	else Either String (R sr) -> IO (Either String (R sr))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (R sr) -> IO (Either String (R sr)))
-> (String -> Either String (R sr))
-> String
-> IO (Either String (R sr))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String (R sr)
forall a b. a -> Either a b
Left (String -> IO (Either String (R sr)))
-> String -> IO (Either String (R sr))
forall a b. (a -> b) -> a -> b
$
		String
"Gpu.Vulkan.RenderPass.Internal.create': The key already exist"

unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) =>
	Group sd ma sr k -> k -> IO (Either String ())
unsafeDestroy :: forall k (ma :: Maybe (*, *)) sd sr.
(Ord k, ToMiddle ma) =>
Group sd ma sr k -> k -> IO (Either String ())
unsafeDestroy (Group (Device.D D
mdvc)
	(M (U2 A) ma -> M A (Snd ma)
forall (msa :: Maybe (*, *)).
ToMiddle msa =>
M (U2 A) msa -> M A (Snd msa)
AllocationCallbacks.toMiddle -> M A (Snd ma)
ma) TSem
sem TVar (Map k (R sr))
rs) k
k = do
	Maybe (R sr)
mr <- STM (Maybe (R sr)) -> IO (Maybe (R sr))
forall a. STM a -> IO a
atomically do
		Maybe (R sr)
mx <- k -> Map k (R sr) -> Maybe (R sr)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k (Map k (R sr) -> Maybe (R sr))
-> STM (Map k (R sr)) -> STM (Maybe (R sr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (R sr)) -> STM (Map k (R sr))
forall a. TVar a -> STM a
readTVar TVar (Map k (R sr))
rs
		case Maybe (R sr)
mx of
			Maybe (R sr)
Nothing -> Maybe (R sr) -> STM (Maybe (R sr))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (R sr)
forall a. Maybe a
Nothing
			Just R sr
_ -> TSem -> STM ()
waitTSem TSem
sem STM () -> STM (Maybe (R sr)) -> STM (Maybe (R sr))
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (R sr) -> STM (Maybe (R sr))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (R sr)
mx
	case Maybe (R sr)
mr of
		Maybe (R sr)
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.RenderPass.Internal.unsafeDestroy: No such key"
		Just (R R
r) -> do
			D -> R -> M A (Snd ma) -> IO ()
forall (md :: Maybe (*)). D -> R -> M A md -> IO ()
M.destroy D
mdvc R
r M A (Snd ma)
ma
			STM (Either String ()) -> IO (Either String ())
forall a. STM a -> IO a
atomically do
				TVar (Map k (R sr)) -> (Map k (R sr) -> Map k (R sr)) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map k (R sr))
rs ((Map k (R sr) -> Map k (R sr)) -> STM ())
-> (Map k (R sr) -> Map k (R sr)) -> STM ()
forall a b. (a -> b) -> a -> b
$ k -> Map k (R sr) -> Map k (R sr)
forall k a. Ord k => k -> Map k a -> Map k a
Map.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 sd ma sr k -> k -> IO (Maybe (R sr))
lookup :: forall k sd (ma :: Maybe (*, *)) sr.
Ord k =>
Group sd ma sr k -> k -> IO (Maybe (R sr))
lookup (Group D sd
_ M (U2 A) ma
_ TSem
_sem TVar (Map k (R sr))
rs) k
k = STM (Maybe (R sr)) -> IO (Maybe (R sr))
forall a. STM a -> IO a
atomically (STM (Maybe (R sr)) -> IO (Maybe (R sr)))
-> STM (Maybe (R sr)) -> IO (Maybe (R sr))
forall a b. (a -> b) -> a -> b
$ k -> Map k (R sr) -> Maybe (R sr)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k (Map k (R sr) -> Maybe (R sr))
-> STM (Map k (R sr)) -> STM (Maybe (R sr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (R sr)) -> STM (Map k (R sr))
forall a. TVar a -> STM a
readTVar TVar (Map k (R sr))
rs

-- BEGIN INFO

data BeginInfo mn sr sf cts = BeginInfo {
	forall (mn :: Maybe (*)) sr sf (cts :: [ClearType]).
BeginInfo mn sr sf cts -> M mn
beginInfoNext :: TMaybe.M mn,
	forall (mn :: Maybe (*)) sr sf (cts :: [ClearType]).
BeginInfo mn sr sf cts -> R sr
beginInfoRenderPass :: R sr,
	forall (mn :: Maybe (*)) sr sf (cts :: [ClearType]).
BeginInfo mn sr sf cts -> F sf
beginInfoFramebuffer :: Framebuffer.F sf,
	forall (mn :: Maybe (*)) sr sf (cts :: [ClearType]).
BeginInfo mn sr sf cts -> Rect2d
beginInfoRenderArea :: Rect2d,
	forall (mn :: Maybe (*)) sr sf (cts :: [ClearType]).
BeginInfo mn sr sf cts -> PL ClearValue cts
beginInfoClearValues :: HeteroParList.PL ClearValue cts }

beginInfoToMiddle :: BeginInfo n sr sf cts -> M.BeginInfo n cts
beginInfoToMiddle :: forall (n :: Maybe (*)) sr sf (cts :: [ClearType]).
BeginInfo n sr sf cts -> BeginInfo n cts
beginInfoToMiddle BeginInfo {
	beginInfoNext :: forall (mn :: Maybe (*)) sr sf (cts :: [ClearType]).
BeginInfo mn sr sf cts -> M mn
beginInfoNext = M n
mnxt,
	beginInfoRenderPass :: forall (mn :: Maybe (*)) sr sf (cts :: [ClearType]).
BeginInfo mn sr sf cts -> R sr
beginInfoRenderPass = R R
rp,
	beginInfoFramebuffer :: forall (mn :: Maybe (*)) sr sf (cts :: [ClearType]).
BeginInfo mn sr sf cts -> F sf
beginInfoFramebuffer = Framebuffer.F F
fb,
	beginInfoRenderArea :: forall (mn :: Maybe (*)) sr sf (cts :: [ClearType]).
BeginInfo mn sr sf cts -> Rect2d
beginInfoRenderArea = Rect2d
ra,
	beginInfoClearValues :: forall (mn :: Maybe (*)) sr sf (cts :: [ClearType]).
BeginInfo mn sr sf cts -> PL ClearValue cts
beginInfoClearValues = PL ClearValue cts
cvs } = M.BeginInfo {
		beginInfoNext :: M n
M.beginInfoNext = M n
mnxt,
		beginInfoRenderPass :: R
M.beginInfoRenderPass = R
rp,
		beginInfoFramebuffer :: F
M.beginInfoFramebuffer = F
fb,
		beginInfoRenderArea :: Rect2d
M.beginInfoRenderArea = Rect2d
ra,
		beginInfoClearValues :: PL ClearValue cts
M.beginInfoClearValues = PL ClearValue cts
cvs }