{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures, TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Gpu.Vulkan.BufferView.Internal (

	-- * CREATE

	create, B(..), CreateInfo(..), FormatOf,

	-- ** Buffer View Group
	Group, group, create', unsafeDestroy, lookup

	) where

import Prelude hiding (lookup)

import GHC.TypeLits
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.Map qualified as Map
import Data.HeteroParList qualified as HeteroParList
import Gpu.Vulkan.Object qualified as VObj

import Gpu.Vulkan.AllocationCallbacks qualified as AllocationCallbacks
import Gpu.Vulkan.AllocationCallbacks.Type qualified as AllocationCallbacks
import Gpu.Vulkan.Device qualified as Device
import Gpu.Vulkan.Device.Type qualified as Device
import Gpu.Vulkan.Device.Middle qualified as Device.M
import Gpu.Vulkan.TypeEnum qualified as TEnum
import Gpu.Vulkan.Buffer.Type qualified as Buffer
import Gpu.Vulkan.BufferView.Middle qualified as M

newtype B s (nm :: Symbol) t = B M.B deriving Int -> B s nm t -> ShowS
[B s nm t] -> ShowS
B s nm t -> String
(Int -> B s nm t -> ShowS)
-> (B s nm t -> String) -> ([B s nm t] -> ShowS) -> Show (B s nm t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s (nm :: Symbol) t. Int -> B s nm t -> ShowS
forall s (nm :: Symbol) t. [B s nm t] -> ShowS
forall s (nm :: Symbol) t. B s nm t -> String
$cshowsPrec :: forall s (nm :: Symbol) t. Int -> B s nm t -> ShowS
showsPrec :: Int -> B s nm t -> ShowS
$cshow :: forall s (nm :: Symbol) t. B s nm t -> String
show :: B s nm t -> String
$cshowList :: forall s (nm :: Symbol) t. [B s nm t] -> ShowS
showList :: [B s nm t] -> ShowS
Show

create :: (
	WithPoked (TMaybe.M mn),
	TEnum.FormatToValue (FormatOf t),
	VObj.OffsetOfList t nm objs,
	AllocationCallbacks.ToMiddle mscc ) =>
	Device.D sd -> CreateInfo mn t nm '(sm, sb, bnm, objs) ->
	TPMaybe.M (U2 AllocationCallbacks.A) mscc ->
	(forall s . B s nm t -> IO a) -> IO a
create :: forall (mn :: Maybe (*)) t (nm :: Symbol) (objs :: [O])
       (mscc :: Maybe (*, *)) sd sm sb (bnm :: Symbol) a.
(WithPoked (M mn), FormatToValue (FormatOf t),
 OffsetOfList t nm objs, ToMiddle mscc) =>
D sd
-> CreateInfo mn t nm '(sm, sb, bnm, objs)
-> M (U2 A) mscc
-> (forall s. B s nm t -> IO a)
-> IO a
create (Device.D D
dvc) CreateInfo mn t nm '(sm, sb, bnm, objs)
ci
	(M (U2 A) mscc -> M A (Snd mscc)
forall (msa :: Maybe (*, *)).
ToMiddle msa =>
M (U2 A) msa -> M A (Snd msa)
AllocationCallbacks.toMiddle -> M A (Snd mscc)
macc) forall s. B s nm t -> IO a
f = IO B -> (B -> IO ()) -> (B -> 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 mscc) -> IO B
forall (mn :: Maybe (*)) (mc :: Maybe (*)).
WithPoked (M mn) =>
D -> CreateInfo mn -> M A mc -> IO B
M.create D
dvc (CreateInfo mn t nm '(sm, sb, bnm, objs) -> CreateInfo mn
forall (n :: Maybe (*)) t (nm :: Symbol) sm sb (bnm :: Symbol)
       (objs :: [O]).
(FormatToValue (FormatOf t), OffsetOfList t nm objs) =>
CreateInfo n t nm '(sm, sb, bnm, objs) -> CreateInfo n
createInfoToMiddle CreateInfo mn t nm '(sm, sb, bnm, objs)
ci) M A (Snd mscc)
macc)
	(\B
b -> D -> B -> M A (Snd mscc) -> IO ()
forall (md :: Maybe (*)). D -> B -> M A md -> IO ()
M.destroy D
dvc B
b M A (Snd mscc)
macc) (B Any nm t -> IO a
forall s. B s nm t -> IO a
f (B Any nm t -> IO a) -> (B -> B Any nm t) -> B -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. B -> B Any nm t
forall s (nm :: Symbol) t. B -> B s nm t
B)

data CreateInfo mn t (nm :: Symbol) snmobjs = CreateInfo {
	forall (mn :: Maybe (*)) t (nm :: Symbol)
       (snmobjs :: (*, *, Symbol, [O])).
CreateInfo mn t nm snmobjs -> M mn
createInfoNext :: TMaybe.M mn,
	forall (mn :: Maybe (*)) t (nm :: Symbol)
       (snmobjs :: (*, *, Symbol, [O])).
CreateInfo mn t nm snmobjs -> CreateFlags
createInfoFlags :: M.CreateFlags,
	forall (mn :: Maybe (*)) t (nm :: Symbol)
       (snmobjs :: (*, *, Symbol, [O])).
CreateInfo mn t nm snmobjs -> U4 Binded snmobjs
createInfoBuffer :: U4 Buffer.Binded snmobjs }

createInfoToMiddle :: forall n t nm sm sb bnm objs . (
	TEnum.FormatToValue (FormatOf t),
	VObj.OffsetOfList t nm objs ) =>
	CreateInfo n t nm '(sm, sb, bnm, objs) -> M.CreateInfo n
createInfoToMiddle :: forall (n :: Maybe (*)) t (nm :: Symbol) sm sb (bnm :: Symbol)
       (objs :: [O]).
(FormatToValue (FormatOf t), OffsetOfList t nm objs) =>
CreateInfo n t nm '(sm, sb, bnm, objs) -> CreateInfo n
createInfoToMiddle CreateInfo {
	createInfoNext :: forall (mn :: Maybe (*)) t (nm :: Symbol)
       (snmobjs :: (*, *, Symbol, [O])).
CreateInfo mn t nm snmobjs -> M mn
createInfoNext = M n
mnxt,
	createInfoFlags :: forall (mn :: Maybe (*)) t (nm :: Symbol)
       (snmobjs :: (*, *, Symbol, [O])).
CreateInfo mn t nm snmobjs -> CreateFlags
createInfoFlags = CreateFlags
flgs,
	createInfoBuffer :: forall (mn :: Maybe (*)) t (nm :: Symbol)
       (snmobjs :: (*, *, Symbol, [O])).
CreateInfo mn t nm snmobjs -> U4 Binded snmobjs
createInfoBuffer = U4 (Buffer.Binded PL Length s4
lns B
b) } = M.CreateInfo {
	createInfoNext :: M n
M.createInfoNext = M n
mnxt,
	createInfoFlags :: CreateFlags
M.createInfoFlags = CreateFlags
flgs,
	createInfoBuffer :: B
M.createInfoBuffer = B
b,
	createInfoFormat :: Format
M.createInfoFormat = forall (t :: Format). FormatToValue t => Format
TEnum.formatToValue @(FormatOf t),
	createInfoOffset :: Size
M.createInfoOffset = Size
ost, createInfoRange :: Size
M.createInfoRange = Size
rng }
	where
	(Size
ost, Size
rng) = forall t (nm :: Symbol) (objs :: [O]).
OffsetOfList t nm objs =>
PL Length objs -> (Size, Size)
offsetRange @t @nm PL Length s4
lns

type family FormatOf t :: TEnum.Format

offsetRange :: forall t nm objs .
	VObj.OffsetOfList t nm objs =>
	HeteroParList.PL VObj.Length objs -> (Device.M.Size, Device.M.Size)
offsetRange :: forall t (nm :: Symbol) (objs :: [O]).
OffsetOfList t nm objs =>
PL Length objs -> (Size, Size)
offsetRange = forall {k} (v :: k) (onm :: Symbol) (vs :: [O]).
OffsetOfList v onm vs =>
PL Length vs -> (Size, Size)
forall t (nm :: Symbol) (objs :: [O]).
OffsetOfList t nm objs =>
PL Length objs -> (Size, Size)
VObj.offsetOfList @t @nm

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

data Group ma s k nm t = Group
	(TPMaybe.M (U2 AllocationCallbacks.A) ma)
	TSem (TVar (Map.Map k (B s nm t)))

create' :: (
	Ord k,
	WithPoked (TMaybe.M mn),
	TEnum.FormatToValue (FormatOf t),
	VObj.OffsetOfList t nm objs,
	AllocationCallbacks.ToMiddle mscc ) =>
	Device.D sd -> Group mscc s k nm t -> k ->
	CreateInfo mn t nm '(sm, sb, bnm, objs) -> IO (Either String (B s nm t))
create' :: forall k (mn :: Maybe (*)) t (nm :: Symbol) (objs :: [O])
       (mscc :: Maybe (*, *)) sd s sm sb (bnm :: Symbol).
(Ord k, WithPoked (M mn), FormatToValue (FormatOf t),
 OffsetOfList t nm objs, ToMiddle mscc) =>
D sd
-> Group mscc s k nm t
-> k
-> CreateInfo mn t nm '(sm, sb, bnm, objs)
-> IO (Either String (B s nm t))
create' (Device.D D
dvc)
	(Group (M (U2 A) mscc -> M A (Snd mscc)
forall (msa :: Maybe (*, *)).
ToMiddle msa =>
M (U2 A) msa -> M A (Snd msa)
AllocationCallbacks.toMiddle -> M A (Snd mscc)
mac) TSem
sem TVar (Map k (B s nm t))
bs) k
k CreateInfo mn t nm '(sm, sb, bnm, objs)
ci = do
	ok <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically do
		mx <- (k -> Map k (B s nm t) -> Maybe (B s nm t)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k) (Map k (B s nm t) -> Maybe (B s nm t))
-> STM (Map k (B s nm t)) -> STM (Maybe (B s nm t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (B s nm t)) -> STM (Map k (B s nm t))
forall a. TVar a -> STM a
readTVar TVar (Map k (B s nm t))
bs
		case mx of
			Maybe (B s nm t)
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 B s nm t
_ -> Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
	if ok
	then do	b <- M.create dvc (createInfoToMiddle ci) mac
		let	b' = B -> B s nm t
forall s (nm :: Symbol) t. B -> B s nm t
B B
b
		atomically $ modifyTVar bs (Map.insert k b') >> signalTSem sem
		pure $ Right b'
	else pure . Left $ "Gpu.Vulkan.BufferView.create': The key already exist"

unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) =>
	Device.D sd -> Group ma sg k nm t -> k -> IO (Either String ())
unsafeDestroy :: forall k (ma :: Maybe (*, *)) sd sg (nm :: Symbol) t.
(Ord k, ToMiddle ma) =>
D sd -> Group ma sg k nm t -> k -> IO (Either String ())
unsafeDestroy (Device.D D
mdvc)
	(Group (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 (B sg nm t))
bs) k
k = do
	mb <- STM (Maybe (B sg nm t)) -> IO (Maybe (B sg nm t))
forall a. STM a -> IO a
atomically do
		mx <- k -> Map k (B sg nm t) -> Maybe (B sg nm t)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k (Map k (B sg nm t) -> Maybe (B sg nm t))
-> STM (Map k (B sg nm t)) -> STM (Maybe (B sg nm t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (B sg nm t)) -> STM (Map k (B sg nm t))
forall a. TVar a -> STM a
readTVar TVar (Map k (B sg nm t))
bs
		case mx of
			Maybe (B sg nm t)
Nothing -> Maybe (B sg nm t) -> STM (Maybe (B sg nm t))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (B sg nm t)
forall a. Maybe a
Nothing
			Just B sg nm t
_ -> TSem -> STM ()
waitTSem TSem
sem STM () -> STM (Maybe (B sg nm t)) -> STM (Maybe (B sg nm t))
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (B sg nm t) -> STM (Maybe (B sg nm t))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (B sg nm t)
mx
	case mb of
		Maybe (B sg nm t)
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
"Gp[u.Vulkan.BufferView.unsafeDestroy: No such key"
		Just (B B
b) -> do
			D -> B -> M A (Snd ma) -> IO ()
forall (md :: Maybe (*)). D -> B -> M A md -> IO ()
M.destroy D
mdvc B
b M A (Snd ma)
ma
			STM (Either String ()) -> IO (Either String ())
forall a. STM a -> IO a
atomically do
				TVar (Map k (B sg nm t))
-> (Map k (B sg nm t) -> Map k (B sg nm t)) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map k (B sg nm t))
bs (k -> Map k (B sg nm t) -> Map k (B sg nm t)
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 md sg k nm t -> k -> IO (Maybe (B sg nm t))
lookup :: forall k (md :: Maybe (*, *)) sg (nm :: Symbol) t.
Ord k =>
Group md sg k nm t -> k -> IO (Maybe (B sg nm t))
lookup (Group M (U2 A) md
_ TSem
_sem TVar (Map k (B sg nm t))
bs) k
k = STM (Maybe (B sg nm t)) -> IO (Maybe (B sg nm t))
forall a. STM a -> IO a
atomically (STM (Maybe (B sg nm t)) -> IO (Maybe (B sg nm t)))
-> STM (Maybe (B sg nm t)) -> IO (Maybe (B sg nm t))
forall a b. (a -> b) -> a -> b
$ k -> Map k (B sg nm t) -> Maybe (B sg nm t)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k (Map k (B sg nm t) -> Maybe (B sg nm t))
-> STM (Map k (B sg nm t)) -> STM (Maybe (B sg nm t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (B sg nm t)) -> STM (Map k (B sg nm t))
forall a. TVar a -> STM a
readTVar TVar (Map k (B sg nm t))
bs