{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
{-# LANGUAGE KindSignatures, TypeOperators #-}
{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Gpu.Vulkan.Framebuffer (

	-- * CREATE

	create, unsafeRecreate, F, CreateInfo(..),

	-- ** Group

	group, Group, create', unsafeDestroy, lookup,

	-- * ENUM

	module Gpu.Vulkan.Framebuffer.Enum

	) where

import Prelude hiding (lookup)
import Foreign.Storable.PeekPoke
import Control.Concurrent.STM
import Control.Concurrent.STM.TSem
import Control.Exception
import Data.TypeLevel.Tuple.Uncurry
import Data.TypeLevel.Maybe qualified as TMaybe
import Data.TypeLevel.ParMaybe qualified as TPMaybe
import Data.HeteroParList qualified as HeteroParList
import Data.Map qualified as Map
import Data.Word

import Gpu.Vulkan.Framebuffer.Enum
import Gpu.Vulkan.Framebuffer.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 qualified Gpu.Vulkan.RenderPass.Type as RenderPass
import qualified Gpu.Vulkan.ImageView as ImageView
import qualified Gpu.Vulkan.ImageView.Type as ImageView
import qualified Gpu.Vulkan.Framebuffer.Middle as M

data CreateInfo mn sr aargs = CreateInfo {
	forall (mn :: Maybe (*)) sr (aargs :: [(Symbol, Format, *)]).
CreateInfo mn sr aargs -> M mn
createInfoNext :: TMaybe.M mn,
	forall (mn :: Maybe (*)) sr (aargs :: [(Symbol, Format, *)]).
CreateInfo mn sr aargs -> CreateFlags
createInfoFlags :: CreateFlags,
	forall (mn :: Maybe (*)) sr (aargs :: [(Symbol, Format, *)]).
CreateInfo mn sr aargs -> R sr
createInfoRenderPass :: RenderPass.R sr,
	forall (mn :: Maybe (*)) sr (aargs :: [(Symbol, Format, *)]).
CreateInfo mn sr aargs -> PL (U3 I) aargs
createInfoAttachments :: HeteroParList.PL (U3 ImageView.I) aargs,
	forall (mn :: Maybe (*)) sr (aargs :: [(Symbol, Format, *)]).
CreateInfo mn sr aargs -> Word32
createInfoWidth :: Word32,
	forall (mn :: Maybe (*)) sr (aargs :: [(Symbol, Format, *)]).
CreateInfo mn sr aargs -> Word32
createInfoHeight :: Word32,
	forall (mn :: Maybe (*)) sr (aargs :: [(Symbol, Format, *)]).
CreateInfo mn sr aargs -> Word32
createInfoLayers :: Word32 }

type family MapThird (t :: [(j, k, l)]) where
	MapThird '[] = '[]
	MapThird ('(a, b, c) ': abcs) = c ': MapThird abcs

createInfoToMiddle :: CreateInfo n sr fmtmnsis -> M.CreateInfo n
createInfoToMiddle :: forall (n :: Maybe (*)) sr (fmtmnsis :: [(Symbol, Format, *)]).
CreateInfo n sr fmtmnsis -> CreateInfo n
createInfoToMiddle CreateInfo {
	createInfoNext :: forall (mn :: Maybe (*)) sr (aargs :: [(Symbol, Format, *)]).
CreateInfo mn sr aargs -> M mn
createInfoNext = M n
mnxt,
	createInfoFlags :: forall (mn :: Maybe (*)) sr (aargs :: [(Symbol, Format, *)]).
CreateInfo mn sr aargs -> CreateFlags
createInfoFlags = CreateFlags
flgs,
	createInfoRenderPass :: forall (mn :: Maybe (*)) sr (aargs :: [(Symbol, Format, *)]).
CreateInfo mn sr aargs -> R sr
createInfoRenderPass = RenderPass.R R
rp,
	createInfoAttachments :: forall (mn :: Maybe (*)) sr (aargs :: [(Symbol, Format, *)]).
CreateInfo mn sr aargs -> PL (U3 I) aargs
createInfoAttachments = (forall (s :: (Symbol, Format, *)). U3 I s -> I)
-> PL (U3 I) fmtmnsis -> [I]
forall k (t :: k -> *) a (ss :: [k]).
(forall (s :: k). t s -> a) -> PL t ss -> [a]
HeteroParList.toList (\(U3 (ImageView.I I
iv)) -> I
iv) -> [I]
ivs,
	createInfoWidth :: forall (mn :: Maybe (*)) sr (aargs :: [(Symbol, Format, *)]).
CreateInfo mn sr aargs -> Word32
createInfoWidth = Word32
w,
	createInfoHeight :: forall (mn :: Maybe (*)) sr (aargs :: [(Symbol, Format, *)]).
CreateInfo mn sr aargs -> Word32
createInfoHeight = Word32
h,
	createInfoLayers :: forall (mn :: Maybe (*)) sr (aargs :: [(Symbol, Format, *)]).
CreateInfo mn sr aargs -> Word32
createInfoLayers = Word32
lyrs } = M.CreateInfo {
		createInfoNext :: M n
M.createInfoNext = M n
mnxt,
		createInfoFlags :: CreateFlags
M.createInfoFlags = CreateFlags
flgs,
		createInfoRenderPass :: R
M.createInfoRenderPass = R
rp,
		createInfoAttachments :: [I]
M.createInfoAttachments = [I]
ivs,
		createInfoWidth :: Word32
M.createInfoWidth = Word32
w,
		createInfoHeight :: Word32
M.createInfoHeight = Word32
h,
		createInfoLayers :: Word32
M.createInfoLayers = Word32
lyrs }

create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac) =>
	Device.D sd -> CreateInfo mn sr aargs ->
	TPMaybe.M (U2 AllocationCallbacks.A) mac ->
	(forall s . F s -> IO a) -> IO a
create :: forall (mn :: Maybe (*)) (mac :: Maybe (*, *)) sd sr
       (aargs :: [(Symbol, Format, *)]) a.
(WithPoked (M mn), ToMiddle mac) =>
D sd
-> CreateInfo mn sr aargs
-> M (U2 A) mac
-> (forall s. F s -> IO a)
-> IO a
create (Device.D D
dvc) CreateInfo mn sr aargs
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)
macc) forall s. F s -> IO a
f = IO F -> (F -> IO ()) -> (F -> 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 F
forall (mn :: Maybe (*)) (mc :: Maybe (*)).
WithPoked (M mn) =>
D -> CreateInfo mn -> M A mc -> IO F
M.create D
dvc (CreateInfo mn sr aargs -> CreateInfo mn
forall (n :: Maybe (*)) sr (fmtmnsis :: [(Symbol, Format, *)]).
CreateInfo n sr fmtmnsis -> CreateInfo n
createInfoToMiddle CreateInfo mn sr aargs
ci) M A (Snd mac)
macc)
	(\F
fb -> D -> F -> M A (Snd mac) -> IO ()
forall (md :: Maybe (*)). D -> F -> M A md -> IO ()
M.destroy D
dvc F
fb M A (Snd mac)
macc) (F Any -> IO a
forall s. F s -> IO a
f (F Any -> IO a) -> (F -> F Any) -> F -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F -> F Any
forall s. F -> F s
F)

unsafeRecreate :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac) =>
	Device.D sd -> CreateInfo mn sr aargs ->
	TPMaybe.M (U2 AllocationCallbacks.A) mac ->
	F sf -> IO ()
unsafeRecreate :: forall (mn :: Maybe (*)) (mac :: Maybe (*, *)) sd sr
       (aargs :: [(Symbol, Format, *)]) sf.
(WithPoked (M mn), ToMiddle mac) =>
D sd -> CreateInfo mn sr aargs -> M (U2 A) mac -> F sf -> IO ()
unsafeRecreate (Device.D D
dvc) CreateInfo mn sr aargs
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)
macc) (F F
fb) =
	D -> CreateInfo mn -> M A (Snd mac) -> M A (Snd mac) -> F -> IO ()
forall (mn :: Maybe (*)) (mc :: Maybe (*)) (md :: Maybe (*)).
WithPoked (M mn) =>
D -> CreateInfo mn -> M A mc -> M A md -> F -> IO ()
M.recreate D
dvc (CreateInfo mn sr aargs -> CreateInfo mn
forall (n :: Maybe (*)) sr (fmtmnsis :: [(Symbol, Format, *)]).
CreateInfo n sr fmtmnsis -> CreateInfo n
createInfoToMiddle CreateInfo mn sr aargs
ci) M A (Snd mac)
macc M A (Snd mac)
macc F
fb

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

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

create' :: (
	Ord k, WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle ma) =>
	Group sd ma sf k -> k -> CreateInfo mn sr aargs -> IO (Either String (F sf))
create' :: forall k (mn :: Maybe (*)) (ma :: Maybe (*, *)) sd sf sr
       (aargs :: [(Symbol, Format, *)]).
(Ord k, WithPoked (M mn), ToMiddle ma) =>
Group sd ma sf k
-> k -> CreateInfo mn sr aargs -> IO (Either String (F sf))
create' (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)
mmac) TSem
sem TVar (Map k (F sf))
sf) k
k
	(CreateInfo mn sr aargs -> CreateInfo mn
forall (n :: Maybe (*)) sr (fmtmnsis :: [(Symbol, Format, *)]).
CreateInfo n sr fmtmnsis -> CreateInfo n
createInfoToMiddle -> CreateInfo mn
ci) = do
	ok <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically do
		mx <- k -> Map k (F sf) -> Maybe (F sf)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k (Map k (F sf) -> Maybe (F sf))
-> STM (Map k (F sf)) -> STM (Maybe (F sf))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (F sf)) -> STM (Map k (F sf))
forall a. TVar a -> STM a
readTVar TVar (Map k (F sf))
sf
		case mx of
			Maybe (F sf)
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 F sf
_ -> Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
	if ok
	then do	f <- M.create mdvc ci mmac
		let	f' = F -> F sf
forall s. F -> F s
F F
f
		atomically $ modifyTVar sf (Map.insert k f') >> signalTSem sem
		pure $ Right f'
	else pure . Left $
		"Gpu.Vulkan.Framebuffer.create': The key already exist"

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