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

module Gpu.Vulkan.ImageView.Middle.Internal (
	I, null, CreateInfo(..), create, recreate, recreate', destroy,

	group, create', destroy', lookup, Group,

	iToCore
	) where

import Prelude hiding (null, lookup)

import Foreign.Ptr
import Foreign.Marshal
import Foreign.Storable
import Foreign.Storable.PeekPoke
import Control.Concurrent.STM
import Control.Concurrent.STM.TSem
import Data.TypeLevel.Maybe qualified as TMaybe
import Data.TypeLevel.ParMaybe qualified as TPMaybe
import Data.Map qualified as M
import Data.IORef

import Gpu.Vulkan.Enum
import Gpu.Vulkan.Exception.Middle.Internal
import Gpu.Vulkan.Exception.Enum
import Gpu.Vulkan.Component.Middle.Internal
import Gpu.Vulkan.ImageView.Enum

import Gpu.Vulkan.AllocationCallbacks.Middle.Internal
	qualified as AllocationCallbacks
import qualified Gpu.Vulkan.Device.Middle.Types as Device
import qualified Gpu.Vulkan.Image.Middle.Internal as Image
import qualified Gpu.Vulkan.ImageView.Core as C

import Gpu.Vulkan.Base.Middle.Internal

data CreateInfo mn = CreateInfo {
	forall (mn :: Maybe (*)). CreateInfo mn -> M mn
createInfoNext :: TMaybe.M mn,
	forall (mn :: Maybe (*)). CreateInfo mn -> CreateFlags
createInfoFlags :: CreateFlags,
	forall (mn :: Maybe (*)). CreateInfo mn -> I
createInfoImage :: Image.I,
	forall (mn :: Maybe (*)). CreateInfo mn -> Type
createInfoViewType :: Type,
	forall (mn :: Maybe (*)). CreateInfo mn -> Format
createInfoFormat :: Format,
	forall (mn :: Maybe (*)). CreateInfo mn -> Mapping
createInfoComponents :: Mapping,
	forall (mn :: Maybe (*)). CreateInfo mn -> SubresourceRange
createInfoSubresourceRange :: Image.SubresourceRange }

createInfoToCore :: WithPoked (TMaybe.M mn) =>
	CreateInfo mn -> (Ptr C.CreateInfo -> IO a) -> IO ()
createInfoToCore :: forall (mn :: Maybe (*)) a.
WithPoked (M mn) =>
CreateInfo mn -> (Ptr CreateInfo -> IO a) -> IO ()
createInfoToCore CreateInfo {
	createInfoNext :: forall (mn :: Maybe (*)). CreateInfo mn -> M mn
createInfoNext = M mn
mnxt,
	createInfoFlags :: forall (mn :: Maybe (*)). CreateInfo mn -> CreateFlags
createInfoFlags = CreateFlagBits Word32
flgs,
	createInfoImage :: forall (mn :: Maybe (*)). CreateInfo mn -> I
createInfoImage = Image.I IORef (Extent3d, I)
rimg,
	createInfoViewType :: forall (mn :: Maybe (*)). CreateInfo mn -> Type
createInfoViewType = Type Word32
tp,
	createInfoFormat :: forall (mn :: Maybe (*)). CreateInfo mn -> Format
createInfoFormat = Format Word32
fmt,
	createInfoComponents :: forall (mn :: Maybe (*)). CreateInfo mn -> Mapping
createInfoComponents = Mapping
cpns,
	createInfoSubresourceRange :: forall (mn :: Maybe (*)). CreateInfo mn -> SubresourceRange
createInfoSubresourceRange = SubresourceRange
srr
	} Ptr CreateInfo -> IO a
f = M mn -> (forall s. PtrS s (M mn) -> IO ()) -> IO ()
forall a b.
WithPoked a =>
a -> (forall s. PtrS s a -> IO b) -> IO b
forall b. M mn -> (forall s. PtrS s (M mn) -> IO b) -> IO b
withPoked' M mn
mnxt \PtrS s (M mn)
pnxt -> PtrS s (M mn) -> (Ptr (M mn) -> IO a) -> IO ()
forall s a b. PtrS s a -> (Ptr a -> IO b) -> IO ()
withPtrS PtrS s (M mn)
pnxt \(Ptr (M mn) -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr -> Ptr ()
pnxt') ->
	IORef (Extent3d, I) -> IO (Extent3d, I)
forall a. IORef a -> IO a
readIORef IORef (Extent3d, I)
rimg IO (Extent3d, I) -> ((Extent3d, I) -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Extent3d
_, I
img) -> let ci :: CreateInfo
ci = C.CreateInfo {
		createInfoSType :: ()
C.createInfoSType = (),
		createInfoPNext :: Ptr ()
C.createInfoPNext = Ptr ()
pnxt',
		createInfoFlags :: Word32
C.createInfoFlags = Word32
flgs,
		createInfoImage :: I
C.createInfoImage = I
img,
		createInfoViewType :: Word32
C.createInfoViewType = Word32
tp,
		createInfoFormat :: Word32
C.createInfoFormat = Word32
fmt,
		createInfoComponents :: Mapping
C.createInfoComponents = Mapping -> Mapping
mappingToCore Mapping
cpns,
		createInfoSubresourceRange :: SubresourceRange
C.createInfoSubresourceRange =
			SubresourceRange -> SubresourceRange
Image.subresourceRangeToCore SubresourceRange
srr } in
	CreateInfo -> (Ptr CreateInfo -> IO a) -> IO a
forall a b. Pokable a => a -> (Ptr a -> IO b) -> IO b
withPoked CreateInfo
ci Ptr CreateInfo -> IO a
f

newtype I = I (IORef C.I)

null :: IO I
null :: IO I
null = IORef I -> I
I (IORef I -> I) -> IO (IORef I) -> IO I
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> I -> IO (IORef I)
forall a. a -> IO (IORef a)
newIORef I
forall a. Ptr a
NullHandle

instance Show I where show :: I -> String
show I
_ = String
"Vk.ImageView.I"

iToCore :: I -> IO C.I
iToCore :: I -> IO I
iToCore (I IORef I
i) = IORef I -> IO I
forall a. IORef a -> IO a
readIORef IORef I
i

iFromCore :: C.I -> IO I
iFromCore :: I -> IO I
iFromCore I
i = IORef I -> I
I (IORef I -> I) -> IO (IORef I) -> IO I
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> I -> IO (IORef I)
forall a. a -> IO (IORef a)
newIORef I
i

create :: WithPoked (TMaybe.M mn) =>
	Device.D -> CreateInfo mn -> TPMaybe.M AllocationCallbacks.A mc -> IO I
create :: forall (mn :: Maybe (*)) (mc :: Maybe (*)).
WithPoked (M mn) =>
D -> CreateInfo mn -> M A mc -> IO I
create (Device.D D
dvc) CreateInfo mn
ci M A mc
mac = I -> IO I
iFromCore (I -> IO I) -> IO I -> IO I
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Ptr I -> IO I) -> IO I
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr I
pView -> do
	CreateInfo mn -> (Ptr CreateInfo -> IO ()) -> IO ()
forall (mn :: Maybe (*)) a.
WithPoked (M mn) =>
CreateInfo mn -> (Ptr CreateInfo -> IO a) -> IO ()
createInfoToCore CreateInfo mn
ci \Ptr CreateInfo
pci ->
		M A mc -> (Ptr A -> IO ()) -> IO ()
forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO ()
AllocationCallbacks.mToCore M A mc
mac \Ptr A
pac -> do
			r <- D -> Ptr CreateInfo -> Ptr A -> Ptr I -> IO Int32
C.create D
dvc Ptr CreateInfo
pci Ptr A
pac Ptr I
pView
			throwUnlessSuccess $ Result r
	Ptr I -> IO I
forall a. Storable a => Ptr a -> IO a
peek Ptr I
pView

group :: Device.D -> TPMaybe.M AllocationCallbacks.A mc ->
	(forall s . Group s k -> IO a) -> IO a
group :: forall (mc :: Maybe (*)) k a.
D -> M A mc -> (forall s. Group s k -> IO a) -> IO a
group D
dvc M A mc
mac forall s. Group s k -> IO a
f = do
	(sem, mng) <- STM (TSem, TVar (Map k I)) -> IO (TSem, TVar (Map k I))
forall a. STM a -> IO a
atomically (STM (TSem, TVar (Map k I)) -> IO (TSem, TVar (Map k I)))
-> STM (TSem, TVar (Map k I)) -> IO (TSem, TVar (Map k I))
forall a b. (a -> b) -> a -> b
$ (,) (TSem -> TVar (Map k I) -> (TSem, TVar (Map k I)))
-> STM TSem -> STM (TVar (Map k I) -> (TSem, TVar (Map k I)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> STM TSem
newTSem Integer
1 STM (TVar (Map k I) -> (TSem, TVar (Map k I)))
-> STM (TVar (Map k I)) -> STM (TSem, TVar (Map k I))
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 I -> STM (TVar (Map k I))
forall a. a -> STM (TVar a)
newTVar Map k I
forall k a. Map k a
M.empty
	rtn <- f $ Group sem mng
	((\I
iv -> D -> I -> M A mc -> IO ()
forall (md :: Maybe (*)). D -> I -> M A md -> IO ()
destroy D
dvc I
iv M A mc
mac) `mapM_`) =<< atomically (readTVar mng)
	pure rtn

data Group s k = Group TSem (TVar (M.Map k I))

create' :: (Ord k, WithPoked (TMaybe.M mn)) =>
	Device.D -> Group sm k -> k ->
	CreateInfo mn -> TPMaybe.M AllocationCallbacks.A mc -> IO (Either String I)
create' :: forall k (mn :: Maybe (*)) sm (mc :: Maybe (*)).
(Ord k, WithPoked (M mn)) =>
D
-> Group sm k
-> k
-> CreateInfo mn
-> M A mc
-> IO (Either String I)
create' (Device.D D
dvc) (Group TSem
sem TVar (Map k I)
is) k
k CreateInfo mn
ci M A mc
mac = do
	ok <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically do
		mx <- (k -> Map k I -> Maybe I
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k) (Map k I -> Maybe I) -> STM (Map k I) -> STM (Maybe I)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k I) -> STM (Map k I)
forall a. TVar a -> STM a
readTVar TVar (Map k I)
is
		case mx of
			Maybe I
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 I
_ -> Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
	if ok
	then do	i <- iFromCore =<< alloca \Ptr I
pView -> do
			CreateInfo mn -> (Ptr CreateInfo -> IO ()) -> IO ()
forall (mn :: Maybe (*)) a.
WithPoked (M mn) =>
CreateInfo mn -> (Ptr CreateInfo -> IO a) -> IO ()
createInfoToCore CreateInfo mn
ci \Ptr CreateInfo
pci ->
				M A mc -> (Ptr A -> IO ()) -> IO ()
forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO ()
AllocationCallbacks.mToCore M A mc
mac \Ptr A
pac -> do
					r <- D -> Ptr CreateInfo -> Ptr A -> Ptr I -> IO Int32
C.create D
dvc Ptr CreateInfo
pci Ptr A
pac Ptr I
pView
					throwUnlessSuccess $ Result r
			Ptr I -> IO I
forall a. Storable a => Ptr a -> IO a
peek Ptr I
pView
		atomically $ modifyTVar is (M.insert k i) >> signalTSem sem
		pure $ Right i
	else pure . Left $ "Gpu.Vulkan.ImageView.create': The key already exist"

destroy' :: Ord k => Device.D ->
	Group sm k -> k -> TPMaybe.M AllocationCallbacks.A mc -> IO (Either String ())
destroy' :: forall k sm (mc :: Maybe (*)).
Ord k =>
D -> Group sm k -> k -> M A mc -> IO (Either String ())
destroy' D
dvc (Group TSem
sem TVar (Map k I)
is) k
k M A mc
mac = do
	mi <- STM (Maybe I) -> IO (Maybe I)
forall a. STM a -> IO a
atomically do
		mx <- (k -> Map k I -> Maybe I
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k) (Map k I -> Maybe I) -> STM (Map k I) -> STM (Maybe I)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k I) -> STM (Map k I)
forall a. TVar a -> STM a
readTVar TVar (Map k I)
is
		case mx of
			Maybe I
Nothing -> Maybe I -> STM (Maybe I)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe I
forall a. Maybe a
Nothing
			Just I
_ -> TSem -> STM ()
waitTSem TSem
sem STM () -> STM (Maybe I) -> STM (Maybe I)
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe I -> STM (Maybe I)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe I
mx
	case mi of
		Maybe I
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.ImageView.destroy: No such key"
		Just I
i -> do
			D -> I -> M A mc -> IO ()
forall (md :: Maybe (*)). D -> I -> M A md -> IO ()
destroy D
dvc I
i M A mc
mac
			STM (Either String ()) -> IO (Either String ())
forall a. STM a -> IO a
atomically do
				TVar (Map k I) -> (Map k I -> Map k I) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map k I)
is (k -> Map k I -> Map k I
forall k a. Ord k => k -> Map k a -> Map k a
M.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 sm k -> k -> IO (Maybe I)
lookup :: forall k sm. Ord k => Group sm k -> k -> IO (Maybe I)
lookup (Group TSem
_sem TVar (Map k I)
is) k
k = STM (Maybe I) -> IO (Maybe I)
forall a. STM a -> IO a
atomically (STM (Maybe I) -> IO (Maybe I)) -> STM (Maybe I) -> IO (Maybe I)
forall a b. (a -> b) -> a -> b
$ k -> Map k I -> Maybe I
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k (Map k I -> Maybe I) -> STM (Map k I) -> STM (Maybe I)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k I) -> STM (Map k I)
forall a. TVar a -> STM a
readTVar TVar (Map k I)
is

recreate :: WithPoked (TMaybe.M mn) =>
	Device.D -> CreateInfo mn ->
	TPMaybe.M AllocationCallbacks.A mc -> TPMaybe.M AllocationCallbacks.A md ->
	I -> IO ()
recreate :: forall (mn :: Maybe (*)) (mc :: Maybe (*)) (md :: Maybe (*)).
WithPoked (M mn) =>
D -> CreateInfo mn -> M A mc -> M A md -> I -> IO ()
recreate (Device.D D
dvc) CreateInfo mn
ci M A mc
macc M A md
macd (I IORef I
ri) = (Ptr I -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr I
pView ->
	CreateInfo mn -> (Ptr CreateInfo -> IO ()) -> IO ()
forall (mn :: Maybe (*)) a.
WithPoked (M mn) =>
CreateInfo mn -> (Ptr CreateInfo -> IO a) -> IO ()
createInfoToCore CreateInfo mn
ci \Ptr CreateInfo
pci ->
	M A mc -> (Ptr A -> IO ()) -> IO ()
forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO ()
AllocationCallbacks.mToCore M A mc
macc \Ptr A
pac -> do
		r <- D -> Ptr CreateInfo -> Ptr A -> Ptr I -> IO Int32
C.create D
dvc Ptr CreateInfo
pci Ptr A
pac Ptr I
pView
		throwUnlessSuccess $ Result r
		io <- readIORef ri
		AllocationCallbacks.mToCore macd $ C.destroy dvc io
		writeIORef ri =<< peek pView

recreate' :: WithPoked (TMaybe.M mn) =>
	Device.D -> CreateInfo mn ->
	TPMaybe.M AllocationCallbacks.A mc -> TPMaybe.M AllocationCallbacks.A md ->
	I -> IO a -> IO ()
recreate' :: forall (mn :: Maybe (*)) (mc :: Maybe (*)) (md :: Maybe (*)) a.
WithPoked (M mn) =>
D -> CreateInfo mn -> M A mc -> M A md -> I -> IO a -> IO ()
recreate' (Device.D D
dvc) CreateInfo mn
ci M A mc
macc M A md
macd (I IORef I
ri) IO a
act = (Ptr I -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr I
pView ->
	CreateInfo mn -> (Ptr CreateInfo -> IO ()) -> IO ()
forall (mn :: Maybe (*)) a.
WithPoked (M mn) =>
CreateInfo mn -> (Ptr CreateInfo -> IO a) -> IO ()
createInfoToCore CreateInfo mn
ci \Ptr CreateInfo
pci ->
	M A mc -> (Ptr A -> IO a) -> IO ()
forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO ()
AllocationCallbacks.mToCore M A mc
macc \Ptr A
pac -> do
		r <- D -> Ptr CreateInfo -> Ptr A -> Ptr I -> IO Int32
C.create D
dvc Ptr CreateInfo
pci Ptr A
pac Ptr I
pView
		throwUnlessSuccess $ Result r
		io <- readIORef ri
		writeIORef ri =<< peek pView
		rtn <- act
		AllocationCallbacks.mToCore macd $ C.destroy dvc io
		pure rtn

destroy :: Device.D -> I -> TPMaybe.M AllocationCallbacks.A md -> IO ()
destroy :: forall (md :: Maybe (*)). D -> I -> M A md -> IO ()
destroy (Device.D D
dvc) I
iv M A md
mac = do
	iv' <- I -> IO I
iToCore I
iv
	AllocationCallbacks.mToCore mac $ C.destroy dvc iv'