{-# 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 {-# SOURCE #-} 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
	(sem, 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
	rtn <- f $ Group mac sem 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) `mapM_`) =<< atomically (readTVar m)
	pure 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
	ok <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically do
		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 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 ok
	then do	d <- M.create phd ci mmac
		let	d' = D -> D sd
forall s. D -> D s
D D
d
		atomically $ modifyTVar ds (Map.insert k d') >> signalTSem sem
		pure $ Right d'
	else pure . Left $ "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
	md <- STM (Maybe (D sd)) -> IO (Maybe (D sd))
forall a. STM a -> IO a
atomically do
		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 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 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