{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Gpu.Vulkan.Pipeline.Compute.Middle.Internal (
	C(..),

	createCs, destroy, CreateInfo(..), CreateInfoListToCore ) where

import Prelude hiding (length)

import Foreign.Ptr
import Foreign.Marshal.Array
import Foreign.Storable.PeekPoke
import Foreign.Storable.HeteroList
import Data.TypeLevel.Maybe qualified as TMaybe
import Data.TypeLevel.ParMaybe qualified as TPMaybe
import Data.TypeLevel.Tuple.Uncurry
import Data.TypeLevel.List
import qualified Data.HeteroParList as HeteroParList
import Data.HeteroParList (pattern (:**))
import Data.Maybe
import Data.Int

import Language.SpirV.ShaderKind

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

import Gpu.Vulkan.AllocationCallbacks.Middle.Internal
	qualified as AllocationCallbacks
import qualified Gpu.Vulkan.Device.Middle.Internal as Device
import qualified Gpu.Vulkan.Pipeline.Enum as Pipeline
import qualified Gpu.Vulkan.Pipeline.Core as Pipeline.C
import qualified Gpu.Vulkan.PipelineCache.Middle.Internal as Cache
import qualified Gpu.Vulkan.Pipeline.Compute.Core as C
import qualified Gpu.Vulkan.Pipeline.ShaderStage.Middle.Internal as ShaderStage
import qualified Gpu.Vulkan.PipelineLayout.Middle.Internal as Pipeline.Layout

data CreateInfo mn ss sivs = CreateInfo {
	forall (mn :: Maybe (*)) (ss :: Maybe (*)) (sivs :: [*]).
CreateInfo mn ss sivs -> M mn
createInfoNext :: TMaybe.M mn,
	forall (mn :: Maybe (*)) (ss :: Maybe (*)) (sivs :: [*]).
CreateInfo mn ss sivs -> CreateFlags
createInfoFlags :: Pipeline.CreateFlags,
	forall (mn :: Maybe (*)) (ss :: Maybe (*)) (sivs :: [*]).
CreateInfo mn ss sivs -> CreateInfo ss 'GlslComputeShader sivs
createInfoStage :: ShaderStage.CreateInfo ss 'GlslComputeShader sivs,
	forall (mn :: Maybe (*)) (ss :: Maybe (*)) (sivs :: [*]).
CreateInfo mn ss sivs -> P
createInfoLayout :: Pipeline.Layout.P,
	forall (mn :: Maybe (*)) (ss :: Maybe (*)) (sivs :: [*]).
CreateInfo mn ss sivs -> Maybe C
createInfoBasePipelineHandle :: Maybe C,
	forall (mn :: Maybe (*)) (ss :: Maybe (*)) (sivs :: [*]).
CreateInfo mn ss sivs -> Maybe Int32
createInfoBasePipelineIndex :: Maybe Int32 }

deriving instance (
	Show (TMaybe.M mn), Show (ShaderStage.CreateInfo ss 'GlslComputeShader sivs) ) =>
	Show (CreateInfo mn ss sivs)

createInfoToCore ::
	(WithPoked (TMaybe.M mn), WithPoked (TMaybe.M n1), PokableList vs) =>
	CreateInfo mn n1 vs -> (C.CreateInfo -> IO r) -> IO ()
createInfoToCore :: forall (mn :: Maybe (*)) (n1 :: Maybe (*)) (vs :: [*]) r.
(WithPoked (M mn), WithPoked (M n1), PokableList vs) =>
CreateInfo mn n1 vs -> (CreateInfo -> IO r) -> IO ()
createInfoToCore CreateInfo {
	createInfoNext :: forall (mn :: Maybe (*)) (ss :: Maybe (*)) (sivs :: [*]).
CreateInfo mn ss sivs -> M mn
createInfoNext = M mn
mnxt,
	createInfoFlags :: forall (mn :: Maybe (*)) (ss :: Maybe (*)) (sivs :: [*]).
CreateInfo mn ss sivs -> CreateFlags
createInfoFlags = Pipeline.CreateFlagBits Word32
flgs,
	createInfoStage :: forall (mn :: Maybe (*)) (ss :: Maybe (*)) (sivs :: [*]).
CreateInfo mn ss sivs -> CreateInfo ss 'GlslComputeShader sivs
createInfoStage = CreateInfo n1 'GlslComputeShader vs
stg,
	createInfoLayout :: forall (mn :: Maybe (*)) (ss :: Maybe (*)) (sivs :: [*]).
CreateInfo mn ss sivs -> P
createInfoLayout = Pipeline.Layout.P P
lyt,
	createInfoBasePipelineHandle :: forall (mn :: Maybe (*)) (ss :: Maybe (*)) (sivs :: [*]).
CreateInfo mn ss sivs -> Maybe C
createInfoBasePipelineHandle = Ptr PTag -> (C -> Ptr PTag) -> Maybe C -> Ptr PTag
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Ptr PTag
forall a. Ptr a
NullPtr (\(C Ptr PTag
b) -> Ptr PTag
b) -> Ptr PTag
bph,
	createInfoBasePipelineIndex :: forall (mn :: Maybe (*)) (ss :: Maybe (*)) (sivs :: [*]).
CreateInfo mn ss sivs -> Maybe Int32
createInfoBasePipelineIndex = Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe (- Int32
1) -> Int32
idx } CreateInfo -> IO r
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 ()) -> 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') ->
	CreateInfo n1 'GlslComputeShader vs
-> (CreateInfo -> IO r) -> IO ()
forall (mn :: Maybe (*)) (sknd :: ShaderKind) (sivs :: [*]) r.
(WithPoked (M mn), PokableList sivs) =>
CreateInfo mn sknd sivs -> (CreateInfo -> IO r) -> IO ()
ShaderStage.createInfoToCore CreateInfo n1 'GlslComputeShader vs
stg \CreateInfo
stg' ->
	CreateInfo -> IO r
f C.CreateInfo {
		createInfoSType :: ()
C.createInfoSType = (),
		createInfoPNext :: Ptr ()
C.createInfoPNext = Ptr ()
pnxt',
		createInfoFlags :: Word32
C.createInfoFlags = Word32
flgs,
		createInfoStage :: CreateInfo
C.createInfoStage = CreateInfo
stg',
		createInfoLayout :: P
C.createInfoLayout = P
lyt,
		createInfoBasePipelineHandle :: Ptr PTag
C.createInfoBasePipelineHandle = Ptr PTag
bph,
		createInfoBasePipelineIndex :: Int32
C.createInfoBasePipelineIndex = Int32
idx }

class Length cias => CreateInfoListToCore cias where
	createInfoListToCore ::
		HeteroParList.PL (U3 CreateInfo) cias ->
		([C.CreateInfo] -> IO r) -> IO ()

instance CreateInfoListToCore '[] where
	createInfoListToCore :: forall r. PL (U3 CreateInfo) '[] -> ([CreateInfo] -> IO r) -> IO ()
createInfoListToCore PL (U3 CreateInfo) '[]
HeteroParList.Nil = (() () -> IO r -> IO ()
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (IO r -> IO ())
-> (([CreateInfo] -> IO r) -> IO r)
-> ([CreateInfo] -> IO r)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([CreateInfo] -> IO r) -> [CreateInfo] -> IO r
forall a b. (a -> b) -> a -> b
$ [])

instance (
	WithPoked (TMaybe.M mn), WithPoked (TMaybe.M ss), PokableList sivs,
	CreateInfoListToCore cias ) =>
	CreateInfoListToCore ('(mn, ss, sivs) ': cias) where
	createInfoListToCore :: forall r.
PL (U3 CreateInfo) ('(mn, ss, sivs) : cias)
-> ([CreateInfo] -> IO r) -> IO ()
createInfoListToCore (U3 CreateInfo s1 s2 s3
ci :** PL (U3 CreateInfo) ss1
cis) [CreateInfo] -> IO r
f =
		CreateInfo s1 s2 s3 -> (CreateInfo -> IO ()) -> IO ()
forall (mn :: Maybe (*)) (n1 :: Maybe (*)) (vs :: [*]) r.
(WithPoked (M mn), WithPoked (M n1), PokableList vs) =>
CreateInfo mn n1 vs -> (CreateInfo -> IO r) -> IO ()
createInfoToCore CreateInfo s1 s2 s3
ci \CreateInfo
cci ->
		PL (U3 CreateInfo) ss1 -> ([CreateInfo] -> IO r) -> IO ()
forall (cias :: [(Maybe (*), Maybe (*), [*])]) r.
CreateInfoListToCore cias =>
PL (U3 CreateInfo) cias -> ([CreateInfo] -> IO r) -> IO ()
forall r. PL (U3 CreateInfo) ss1 -> ([CreateInfo] -> IO r) -> IO ()
createInfoListToCore PL (U3 CreateInfo) ss1
cis \[CreateInfo]
ccis -> [CreateInfo] -> IO r
f ([CreateInfo] -> IO r) -> [CreateInfo] -> IO r
forall a b. (a -> b) -> a -> b
$ CreateInfo
cci CreateInfo -> [CreateInfo] -> [CreateInfo]
forall a. a -> [a] -> [a]
: [CreateInfo]
ccis

newtype C = C Pipeline.C.P deriving Int -> C -> ShowS
[C] -> ShowS
C -> String
(Int -> C -> ShowS) -> (C -> String) -> ([C] -> ShowS) -> Show C
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> C -> ShowS
showsPrec :: Int -> C -> ShowS
$cshow :: C -> String
show :: C -> String
$cshowList :: [C] -> ShowS
showList :: [C] -> ShowS
Show

createCs :: forall cias mc . CreateInfoListToCore cias =>
	Device.D -> Maybe Cache.P -> HeteroParList.PL (U3 CreateInfo) cias ->
	TPMaybe.M AllocationCallbacks.A mc -> IO [C]
createCs :: forall (cias :: [(Maybe (*), Maybe (*), [*])]) (mc :: Maybe (*)).
CreateInfoListToCore cias =>
D -> Maybe P -> PL (U3 CreateInfo) cias -> M A mc -> IO [C]
createCs (Device.D D
dvc) (Ptr PTag -> (P -> Ptr PTag) -> Maybe P -> Ptr PTag
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Ptr PTag
forall a. Ptr a
NullPtr (\(Cache.P Ptr PTag
c) -> Ptr PTag
c) -> Ptr PTag
cch) PL (U3 CreateInfo) cias
cis M A mc
mac =
	(Ptr PTag -> C
C (Ptr PTag -> C) -> [Ptr PTag] -> [C]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) ([Ptr PTag] -> [C]) -> IO [Ptr PTag] -> IO [C]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> (Ptr (Ptr PTag) -> IO [Ptr PTag]) -> IO [Ptr PTag]
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
ln \Ptr (Ptr PTag)
pps -> do
		PL (U3 CreateInfo) cias -> ([CreateInfo] -> IO ()) -> IO ()
forall (cias :: [(Maybe (*), Maybe (*), [*])]) r.
CreateInfoListToCore cias =>
PL (U3 CreateInfo) cias -> ([CreateInfo] -> IO r) -> IO ()
forall r.
PL (U3 CreateInfo) cias -> ([CreateInfo] -> IO r) -> IO ()
createInfoListToCore PL (U3 CreateInfo) cias
cis \[CreateInfo]
cis' ->
			Int -> (Ptr CreateInfo -> IO ()) -> IO ()
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
ln \Ptr CreateInfo
pcis ->
			Ptr CreateInfo -> [CreateInfo] -> IO ()
forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray Ptr CreateInfo
pcis [CreateInfo]
cis' IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
			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 ->
				Result -> IO ()
throwUnlessSuccess (Result -> IO ()) -> (Int32 -> Result) -> Int32 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Result
Result (Int32 -> IO ()) -> IO Int32 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< D
-> Ptr PTag
-> Word32
-> Ptr CreateInfo
-> Ptr A
-> Ptr (Ptr PTag)
-> IO Int32
C.createCs
					D
dvc Ptr PTag
cch (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ln) Ptr CreateInfo
pcis Ptr A
pac Ptr (Ptr PTag)
pps
		Int -> Ptr (Ptr PTag) -> IO [Ptr PTag]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
ln Ptr (Ptr PTag)
pps
	where ln :: Int
ln = forall k (as :: [k]) n. (Length as, Integral n) => n
length @_ @cias

destroy :: Device.D -> C -> TPMaybe.M AllocationCallbacks.A md -> IO ()
destroy :: forall (md :: Maybe (*)). D -> C -> M A md -> IO ()
destroy (Device.D D
dvc) (C Ptr PTag
p) M A md
mac =
	M A md -> (Ptr A -> IO ()) -> IO ()
forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO ()
AllocationCallbacks.mToCore M A md
mac ((Ptr A -> IO ()) -> IO ()) -> (Ptr A -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ D -> Ptr PTag -> Ptr A -> IO ()
Pipeline.C.destroy D
dvc Ptr PTag
p