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

module Gpu.Vulkan.Device.Internal (

	-- * CREATE

	create, D(..), CreateInfo(..),
	M.CreateFlags, M.QueueCreateInfo(..),

	-- ** Group

	group, Group, create', unsafeDestroy, lookup,

	-- * GET QUEUE AND WAIT IDLE

	getQueue, waitIdle,

	-- * SIZE

	M.Size

	) 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 Gpu.Vulkan
import Gpu.Vulkan.Device.Type

import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks
import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks
import qualified Gpu.Vulkan.PhysicalDevice as PhysicalDevice
import qualified Gpu.Vulkan.Device.Middle as M
import qualified Gpu.Vulkan.QueueFamily.Middle as QueueFamily
import qualified Gpu.Vulkan.Queue as Queue

import Data.HeteroParList qualified as HeteroParList

create :: (
	WithPoked (TMaybe.M mn),
	HeteroParList.ToListWithCM' WithPoked TMaybe.M qcis,
	AllocationCallbacks.ToMiddle mac ) =>
	PhysicalDevice.P -> CreateInfo mn qcis ->
	TPMaybe.M (U2 AllocationCallbacks.A) mac ->
	(forall s . D s -> IO a) -> IO a
create :: forall (mn :: Maybe (*)) (qcis :: [Maybe (*)])
       (mac :: Maybe (*, *)) a.
(WithPoked (M mn), ToListWithCM' WithPoked M qcis, ToMiddle mac) =>
P
-> CreateInfo mn qcis
-> M (U2 A) mac
-> (forall s. D s -> IO a)
-> IO a
create P
pd (CreateInfo mn qcis -> CreateInfo mn qcis
forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> CreateInfo mn qcis
createInfoToMiddle -> CreateInfo mn qcis
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. D s -> IO a
f =
	IO D -> (D -> IO ()) -> (D -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (P -> CreateInfo mn qcis -> M A (Snd mac) -> IO D
forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]) (mc :: Maybe (*)).
(WithPoked (M mn), ToListWithCM' WithPoked M qcis) =>
P -> CreateInfo mn qcis -> M A mc -> IO D
M.create P
pd CreateInfo mn qcis
ci M A (Snd mac)
mac) (D -> M A (Snd mac) -> IO ()
forall (md :: Maybe (*)). D -> M A md -> IO ()
`M.destroy` M A (Snd mac)
mac) (D Any -> IO a
forall s. D s -> IO a
f (D Any -> IO a) -> (D -> D Any) -> D -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. D -> D Any
forall s. D -> D s
D)

getQueue :: D sd -> QueueFamily.Index -> Queue.Index -> IO Queue.Q
getQueue :: forall sd. D sd -> Index -> Index -> IO Q
getQueue (D D
d) (QueueFamily.Index Index
qfi) Index
qi = D -> Index -> Index -> IO Q
M.getQueue D
d Index
qfi Index
qi

waitIdle :: D s -> IO ()
waitIdle :: forall s. D s -> IO ()
waitIdle (D D
d) = D -> IO ()
M.waitIdle D
d

data CreateInfo mn qcis = CreateInfo {
	forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> M mn
createInfoNext :: TMaybe.M mn,
	forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> CreateFlags
createInfoFlags :: M.CreateFlags,
	forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> PL QueueCreateInfo qcis
createInfoQueueCreateInfos :: HeteroParList.PL M.QueueCreateInfo qcis,
	forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> [LayerName]
createInfoEnabledLayerNames :: [LayerName],
	forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> [ExtensionName]
createInfoEnabledExtensionNames :: [PhysicalDevice.ExtensionName],
	forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> Maybe Features
createInfoEnabledFeatures :: Maybe PhysicalDevice.Features }

deriving instance (
	Show (TMaybe.M mn), Show (HeteroParList.PL M.QueueCreateInfo qcis) ) =>
	Show (CreateInfo mn qcis)

createInfoToMiddle :: CreateInfo mn qcis -> M.CreateInfo mn qcis
createInfoToMiddle :: forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> CreateInfo mn qcis
createInfoToMiddle CreateInfo {
	createInfoNext :: forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> M mn
createInfoNext = M mn
nxt,
	createInfoFlags :: forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> CreateFlags
createInfoFlags = CreateFlags
flgs,
	createInfoQueueCreateInfos :: forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> PL QueueCreateInfo qcis
createInfoQueueCreateInfos = PL QueueCreateInfo qcis
qcis,
	createInfoEnabledLayerNames :: forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> [LayerName]
createInfoEnabledLayerNames = ((\(LayerName Text
ln) -> Text
ln) (LayerName -> Text) -> [LayerName] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) -> [Text]
elnms,
	createInfoEnabledExtensionNames :: forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> [ExtensionName]
createInfoEnabledExtensionNames =
		((\(PhysicalDevice.ExtensionName Text
en) -> Text
en) (ExtensionName -> Text) -> [ExtensionName] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) ->[Text]
eenms,
	createInfoEnabledFeatures :: forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> Maybe Features
createInfoEnabledFeatures = Maybe Features
mef } = M.CreateInfo {
	createInfoNext :: M mn
M.createInfoNext = M mn
nxt,
	createInfoFlags :: CreateFlags
M.createInfoFlags = CreateFlags
flgs,
	createInfoQueueCreateInfos :: PL QueueCreateInfo qcis
M.createInfoQueueCreateInfos = PL QueueCreateInfo qcis
qcis,
	createInfoEnabledLayerNames :: [Text]
M.createInfoEnabledLayerNames = [Text]
elnms,
	createInfoEnabledExtensionNames :: [Text]
M.createInfoEnabledExtensionNames = [Text]
eenms,
	createInfoEnabledFeatures :: Maybe Features
M.createInfoEnabledFeatures = Maybe Features
mef }

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

group :: AllocationCallbacks.ToMiddle ma =>
	TPMaybe.M (U2 AllocationCallbacks.A) ma ->
	(forall sd . Group ma sd k -> IO a) -> IO a
group :: forall (ma :: Maybe (*, *)) k a.
ToMiddle ma =>
M (U2 A) ma -> (forall sd. Group ma sd k -> IO a) -> IO a
group 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 sd. Group ma sd k -> IO a
f = do
	(TSem
sem, TVar (Map k (D Any))
m) <- STM (TSem, TVar (Map k (D Any))) -> IO (TSem, TVar (Map k (D Any)))
forall a. STM a -> IO a
atomically (STM (TSem, TVar (Map k (D Any)))
 -> IO (TSem, TVar (Map k (D Any))))
-> STM (TSem, TVar (Map k (D Any)))
-> IO (TSem, TVar (Map k (D Any)))
forall a b. (a -> b) -> a -> b
$ (,) (TSem -> TVar (Map k (D Any)) -> (TSem, TVar (Map k (D Any))))
-> STM TSem
-> STM (TVar (Map k (D Any)) -> (TSem, TVar (Map k (D Any))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> STM TSem
newTSem Integer
1 STM (TVar (Map k (D Any)) -> (TSem, TVar (Map k (D Any))))
-> STM (TVar (Map k (D Any))) -> STM (TSem, TVar (Map k (D 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 (D Any) -> STM (TVar (Map k (D Any)))
forall a. a -> STM (TVar a)
newTVar Map k (D Any)
forall k a. Map k a
Map.empty
	a
rtn <- Group ma Any k -> IO a
forall sd. Group ma sd k -> IO a
f (Group ma Any k -> IO a) -> Group ma Any k -> IO a
forall a b. (a -> b) -> a -> b
$ M (U2 A) ma -> TSem -> TVar (Map k (D Any)) -> Group ma Any k
forall (ma :: Maybe (*, *)) sd k.
M (U2 A) ma -> TSem -> TVar (Map k (D sd)) -> Group ma sd k
Group M (U2 A) ma
mac TSem
sem TVar (Map k (D Any))
m
	((\(D D
d) -> D -> M A (Snd ma) -> IO ()
forall (md :: Maybe (*)). D -> M A md -> IO ()
M.destroy D
d M A (Snd ma)
mmac) (D Any -> IO ()) -> Map k (D Any) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_`) (Map k (D Any) -> IO ()) -> IO (Map k (D Any)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM (Map k (D Any)) -> IO (Map k (D Any))
forall a. STM a -> IO a
atomically (TVar (Map k (D Any)) -> STM (Map k (D Any))
forall a. TVar a -> STM a
readTVar TVar (Map k (D 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),
	HeteroParList.ToListWithCM' WithPoked TMaybe.M qcis,
	AllocationCallbacks.ToMiddle ma ) => PhysicalDevice.P ->
	Group ma sd k -> k -> CreateInfo mn qcis -> IO (Either String (D sd))
create' :: forall k (mn :: Maybe (*)) (qcis :: [Maybe (*)])
       (ma :: Maybe (*, *)) sd.
(Ord k, WithPoked (M mn), ToListWithCM' WithPoked M qcis,
 ToMiddle ma) =>
P
-> Group ma sd k
-> k
-> CreateInfo mn qcis
-> IO (Either String (D sd))
create' P
phd (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)
mmac) TSem
sem TVar (Map k (D sd))
ds) k
k
	(CreateInfo mn qcis -> CreateInfo mn qcis
forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> CreateInfo mn qcis
createInfoToMiddle -> CreateInfo mn qcis
ci) = do
	Bool
ok <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically do
		Maybe (D sd)
mx <- k -> Map k (D sd) -> Maybe (D sd)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k (Map k (D sd) -> Maybe (D sd))
-> STM (Map k (D sd)) -> STM (Maybe (D sd))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (D sd)) -> STM (Map k (D sd))
forall a. TVar a -> STM a
readTVar TVar (Map k (D sd))
ds
		case Maybe (D sd)
mx of
			Maybe (D sd)
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 D sd
_ -> Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
	if Bool
ok
	then do	D
d <- P -> CreateInfo mn qcis -> M A (Snd ma) -> IO D
forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]) (mc :: Maybe (*)).
(WithPoked (M mn), ToListWithCM' WithPoked M qcis) =>
P -> CreateInfo mn qcis -> M A mc -> IO D
M.create P
phd CreateInfo mn qcis
ci M A (Snd ma)
mmac
		let	d' :: D sd
d' = D -> D sd
forall s. D -> D s
D D
d
		STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map k (D sd)) -> (Map k (D sd) -> Map k (D sd)) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map k (D sd))
ds (k -> D sd -> Map k (D sd) -> Map k (D sd)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k D sd
d') 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 (D sd) -> IO (Either String (D sd))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (D sd) -> IO (Either String (D sd)))
-> Either String (D sd) -> IO (Either String (D sd))
forall a b. (a -> b) -> a -> b
$ D sd -> Either String (D sd)
forall a b. b -> Either a b
Right D sd
d'
	else Either String (D sd) -> IO (Either String (D sd))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (D sd) -> IO (Either String (D sd)))
-> (String -> Either String (D sd))
-> String
-> IO (Either String (D sd))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String (D sd)
forall a b. a -> Either a b
Left (String -> IO (Either String (D sd)))
-> String -> IO (Either String (D sd))
forall a b. (a -> b) -> a -> b
$ String
"Gpu.Vulkan.Device.create': The key already exist"

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