module Resource.Vulkan.DescriptorPool
  ( allocate

  , allocateSetsFrom
  ) where

import RIO

import Data.Vector qualified as Vector
import UnliftIO.Resource (MonadResource, ReleaseKey)
import UnliftIO.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk
import Vulkan.Zero (zero)

import Engine.Vulkan.Types (MonadVulkan, getDevice)
import Resource.Vulkan.Named qualified as Named

allocate
  :: ( MonadVulkan env m
    , MonadResource m
    )
  => Maybe Text
  -> Word32
  -> [(Vk.DescriptorType, Word32)]
  -> m  (ReleaseKey, Vk.DescriptorPool)
allocate :: forall env (m :: * -> *).
(MonadVulkan env m, MonadResource m) =>
Maybe Text
-> Word32
-> [(DescriptorType, Word32)]
-> m (ReleaseKey, DescriptorPool)
allocate Maybe Text
name Word32
maxSets [(DescriptorType, Word32)]
sizes = do
  Device
device <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice
  (ReleaseKey, DescriptorPool)
res <- forall (a :: [*]) (io :: * -> *) r.
(Extendss DescriptorPoolCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> DescriptorPoolCreateInfo a
-> Maybe AllocationCallbacks
-> (io DescriptorPool -> (DescriptorPool -> io ()) -> r)
-> r
Vk.withDescriptorPool
    Device
device
    DescriptorPoolCreateInfo '[]
poolCI
    forall a. Maybe a
Nothing
    forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Text
name forall a b. (a -> b) -> a -> b
$
    forall env (m :: * -> *) a.
(MonadVulkan env m, HasObjectType a) =>
a -> Text -> m ()
Named.object (forall a b. (a, b) -> b
snd (ReleaseKey, DescriptorPool)
res)
  pure (ReleaseKey, DescriptorPool)
res
  where
    poolCI :: DescriptorPoolCreateInfo '[]
poolCI = forall a. Zero a => a
zero
      { $sel:maxSets:DescriptorPoolCreateInfo :: Word32
Vk.maxSets =
          Word32
maxSets
      , $sel:poolSizes:DescriptorPoolCreateInfo :: Vector DescriptorPoolSize
Vk.poolSizes =
          forall a. [a] -> Vector a
Vector.fromList forall a b. (a -> b) -> a -> b
$
            forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry DescriptorType -> Word32 -> DescriptorPoolSize
Vk.DescriptorPoolSize) [(DescriptorType, Word32)]
sizes
      }

-- TODO: extract to Resource.Vulkan.DescriptorSets ?
allocateSetsFrom
  :: MonadVulkan env m
  => Vk.DescriptorPool
  -> Maybe Text
  -> Vector Vk.DescriptorSetLayout
  -> m (Vector Vk.DescriptorSet)
allocateSetsFrom :: forall env (m :: * -> *).
MonadVulkan env m =>
DescriptorPool
-> Maybe Text
-> Vector DescriptorSetLayout
-> m (Vector DescriptorSet)
allocateSetsFrom DescriptorPool
pool Maybe Text
name Vector DescriptorSetLayout
layouts = do
  Device
device <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice
  Vector DescriptorSet
descSets <- forall (a :: [*]) (io :: * -> *).
(Extendss DescriptorSetAllocateInfo a, PokeChain a, MonadIO io) =>
Device -> DescriptorSetAllocateInfo a -> io (Vector DescriptorSet)
Vk.allocateDescriptorSets Device
device forall a. Zero a => a
zero
    { $sel:descriptorPool:DescriptorSetAllocateInfo :: DescriptorPool
Vk.descriptorPool = DescriptorPool
pool
    , $sel:setLayouts:DescriptorSetAllocateInfo :: Vector DescriptorSetLayout
Vk.setLayouts     = Vector DescriptorSetLayout
layouts
    }
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Text
name \Text
prefix ->
    forall (m :: * -> *) a b.
Monad m =>
Vector a -> (Int -> a -> m b) -> m ()
Vector.iforM_ Vector DescriptorSet
descSets \Int
ix DescriptorSet
ds ->
      forall env (m :: * -> *) a.
(MonadVulkan env m, HasObjectType a) =>
a -> Text -> m ()
Named.object DescriptorSet
ds forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
        [ Text
prefix
        , Text
"(set=", forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show Int
ix), Text
")"
        ]
  pure Vector DescriptorSet
descSets