DescSets.hs

{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE UndecidableInstances #-}

-- XXX: TypeError in Compatible generates unused constraint argument
{-# 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 = getDescSet . rrData

instance HasDescSet tag rr => HasDescSet tag (Frame rp p rr) where
  {-# INLINE getDescSet #-}
  getDescSet = getDescSet . fRecycledResources

instance HasDescSet tag rr => HasDescSet tag (env, Frame rp p rr) where
  {-# INLINE getDescSet #-}
  getDescSet = getDescSet . 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 cb pbp (Tagged layout) (Tagged descriptorSets) (Bound action) = do
  Vk.cmdBindDescriptorSets
    cb
    pbp
    layout
    0
    descriptorSets
    mempty

  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 (Tagged xs) (Tagged y) = Tagged (xs <> [y])