{-# 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 :: 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])