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 <- (env -> Device) -> m Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Device
forall a. HasVulkan a => a -> Device
getDevice
  (ReleaseKey, DescriptorPool)
res <- Device
-> DescriptorPoolCreateInfo '[]
-> Maybe AllocationCallbacks
-> (IO DescriptorPool
    -> (DescriptorPool -> IO ()) -> m (ReleaseKey, DescriptorPool))
-> m (ReleaseKey, DescriptorPool)
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
    Maybe AllocationCallbacks
forall a. Maybe a
Nothing
    IO DescriptorPool
-> (DescriptorPool -> IO ()) -> m (ReleaseKey, DescriptorPool)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
  Maybe Text -> (Text -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Text
name ((Text -> m ()) -> m ()) -> (Text -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
    DescriptorPool -> Text -> m ()
forall env (m :: * -> *) a.
(MonadVulkan env m, HasObjectType a) =>
a -> Text -> m ()
Named.object ((ReleaseKey, DescriptorPool) -> DescriptorPool
forall a b. (a, b) -> b
snd (ReleaseKey, DescriptorPool)
res)
  pure (ReleaseKey, DescriptorPool)
res
  where
    poolCI :: DescriptorPoolCreateInfo '[]
poolCI = DescriptorPoolCreateInfo '[]
forall a. Zero a => a
zero
      { $sel:maxSets:DescriptorPoolCreateInfo :: Word32
Vk.maxSets =
          Word32
maxSets
      , $sel:poolSizes:DescriptorPoolCreateInfo :: Vector DescriptorPoolSize
Vk.poolSizes =
          [DescriptorPoolSize] -> Vector DescriptorPoolSize
forall a. [a] -> Vector a
Vector.fromList ([DescriptorPoolSize] -> Vector DescriptorPoolSize)
-> [DescriptorPoolSize] -> Vector DescriptorPoolSize
forall a b. (a -> b) -> a -> b
$
            ((DescriptorType, Word32) -> DescriptorPoolSize)
-> [(DescriptorType, Word32)] -> [DescriptorPoolSize]
forall a b. (a -> b) -> [a] -> [b]
map ((DescriptorType -> Word32 -> DescriptorPoolSize)
-> (DescriptorType, Word32) -> DescriptorPoolSize
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 <- (env -> Device) -> m Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Device
forall a. HasVulkan a => a -> Device
getDevice
  Vector DescriptorSet
descSets <- Device -> DescriptorSetAllocateInfo '[] -> m (Vector DescriptorSet)
forall (a :: [*]) (io :: * -> *).
(Extendss DescriptorSetAllocateInfo a, PokeChain a, MonadIO io) =>
Device -> DescriptorSetAllocateInfo a -> io (Vector DescriptorSet)
Vk.allocateDescriptorSets Device
device DescriptorSetAllocateInfo '[]
forall a. Zero a => a
zero
    { $sel:descriptorPool:DescriptorSetAllocateInfo :: DescriptorPool
Vk.descriptorPool = DescriptorPool
pool
    , $sel:setLayouts:DescriptorSetAllocateInfo :: Vector DescriptorSetLayout
Vk.setLayouts     = Vector DescriptorSetLayout
layouts
    }
  Maybe Text -> (Text -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Text
name \Text
prefix ->
    Vector DescriptorSet -> (Int -> DescriptorSet -> m ()) -> m ()
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (Int -> a -> m b) -> m ()
Vector.iforM_ Vector DescriptorSet
descSets \Int
ix DescriptorSet
ds ->
      DescriptorSet -> Text -> m ()
forall env (m :: * -> *) a.
(MonadVulkan env m, HasObjectType a) =>
a -> Text -> m ()
Named.object DescriptorSet
ds (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
prefix
        , Text
"(set=", String -> Text
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show Int
ix), Text
")"
        ]
  pure Vector DescriptorSet
descSets