{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Engine.Vulkan.DescSets
( HasDescSet(..)
, Bound(..)
, withBoundDescriptorSets0
, Compatible
, Extend
, extendDS
, Tagged(..)
) where
import RIO
import Data.Kind (Constraint, Type)
import Data.Tagged (Tagged(..))
import GHC.TypeLits as Type
import Vulkan.Core10 qualified as Vk
import Engine.Types (Frame(fRecycledResources), RecycledResources(rrData))
import Engine.Vulkan.Types (Bound(..))
class HasDescSet tag a where
getDescSet :: a -> Tagged tag Vk.DescriptorSet
instance HasDescSet tag rr => HasDescSet tag (RecycledResources rr) where
{-# INLINE getDescSet #-}
getDescSet :: RecycledResources rr -> Tagged tag DescriptorSet
getDescSet = rr -> Tagged tag DescriptorSet
forall {k} (tag :: k) a.
HasDescSet tag a =>
a -> Tagged tag DescriptorSet
getDescSet (rr -> Tagged tag DescriptorSet)
-> (RecycledResources rr -> rr)
-> RecycledResources rr
-> Tagged tag DescriptorSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecycledResources rr -> rr
forall a. RecycledResources a -> a
rrData
instance HasDescSet tag rr => HasDescSet tag (Frame rp p rr) where
{-# INLINE getDescSet #-}
getDescSet :: Frame rp p rr -> Tagged tag DescriptorSet
getDescSet = RecycledResources rr -> Tagged tag DescriptorSet
forall {k} (tag :: k) a.
HasDescSet tag a =>
a -> Tagged tag DescriptorSet
getDescSet (RecycledResources rr -> Tagged tag DescriptorSet)
-> (Frame rp p rr -> RecycledResources rr)
-> Frame rp p rr
-> Tagged tag DescriptorSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Frame rp p rr -> RecycledResources rr
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> RecycledResources resources
fRecycledResources
instance HasDescSet tag rr => HasDescSet tag (env, Frame rp p rr) where
{-# INLINE getDescSet #-}
getDescSet :: (env, Frame rp p rr) -> Tagged tag DescriptorSet
getDescSet = Frame rp p rr -> Tagged tag DescriptorSet
forall {k} (tag :: k) a.
HasDescSet tag a =>
a -> Tagged tag DescriptorSet
getDescSet (Frame rp p rr -> Tagged tag DescriptorSet)
-> ((env, Frame rp p rr) -> Frame rp p rr)
-> (env, Frame rp p rr)
-> Tagged tag DescriptorSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (env, Frame rp p rr) -> Frame rp p rr
forall a b. (a, b) -> b
snd
{-# INLINE withBoundDescriptorSets0 #-}
withBoundDescriptorSets0
:: MonadIO m
=> Vk.CommandBuffer
-> Vk.PipelineBindPoint
-> Tagged dsl Vk.PipelineLayout
-> Tagged dsl (Vector Vk.DescriptorSet)
-> Bound dsl Void Void m b
-> m b
withBoundDescriptorSets0 :: forall (m :: * -> *) (dsl :: [*]) b.
MonadIO m =>
CommandBuffer
-> PipelineBindPoint
-> Tagged dsl PipelineLayout
-> Tagged dsl (Vector DescriptorSet)
-> Bound dsl Void Void m b
-> m b
withBoundDescriptorSets0 CommandBuffer
cb PipelineBindPoint
pbp (Tagged PipelineLayout
layout) (Tagged Vector DescriptorSet
descriptorSets) (Bound m b
action) = do
CommandBuffer
-> PipelineBindPoint
-> PipelineLayout
-> Word32
-> Vector DescriptorSet
-> Vector Word32
-> m ()
forall (io :: * -> *).
MonadIO io =>
CommandBuffer
-> PipelineBindPoint
-> PipelineLayout
-> Word32
-> Vector DescriptorSet
-> Vector Word32
-> io ()
Vk.cmdBindDescriptorSets
CommandBuffer
cb
PipelineBindPoint
pbp
PipelineLayout
layout
Word32
0
Vector DescriptorSet
descriptorSets
Vector Word32
forall a. Monoid a => a
mempty
m b
action
type Compatible (smaller :: [Type]) (larger :: [Type]) = Compatible' smaller larger smaller larger
type family Compatible' (xs :: [Type]) (ys :: [Type]) (a :: [Type]) (b :: [Type]) :: Constraint where
Compatible' '[] _ _ _ = ()
Compatible' (x : xs) (x : ys) a b = Compatible' xs ys a b
Compatible' _ _ a b = TypeError
( 'ShowType a ':<>: 'Text " isn't compatible prefix of " ':<>: 'ShowType b
)
type family Extend (xs :: [Type]) y :: [Type] where
Extend '[] y = '[y]
Extend (x ': xs) y = x ': Extend xs y
extendDS
:: Tagged (as :: [Type]) (Vector Vk.DescriptorSet)
-> Tagged b Vk.DescriptorSet
-> Tagged (Extend as b) (Vector Vk.DescriptorSet)
extendDS :: forall (as :: [*]) b.
Tagged as (Vector DescriptorSet)
-> Tagged b DescriptorSet
-> Tagged (Extend as b) (Vector DescriptorSet)
extendDS (Tagged Vector DescriptorSet
xs) (Tagged DescriptorSet
y) = Vector DescriptorSet -> Tagged (Extend as b) (Vector DescriptorSet)
forall {k} (s :: k) b. b -> Tagged s b
Tagged (Vector DescriptorSet
xs Vector DescriptorSet
-> Vector DescriptorSet -> Vector DescriptorSet
forall a. Semigroup a => a -> a -> a
<> [Item (Vector DescriptorSet)
DescriptorSet
y])