module Resource.CommandBuffer
  ( allocatePools
  , withPools
  , oneshot_
  ) where

import RIO

import Data.Vector qualified as Vector
import UnliftIO.Resource (MonadResource)
import UnliftIO.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk
import Vulkan.CStruct.Extends (SomeStruct(..))
import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..))
import Vulkan.Zero (zero)

import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, Queues(..))

allocatePools
  :: (HasVulkan context, Resource.MonadResource m)
  => context
  -> m (Resource.ReleaseKey, Queues Vk.CommandPool)
allocatePools :: forall context (m :: * -> *).
(HasVulkan context, MonadResource m) =>
context -> m (ReleaseKey, Queues CommandPool)
allocatePools context
context = do
  -- context <- ask
  Queues (ReleaseKey, CommandPool)
bootstrapQueues <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall a. HasVulkan a => a -> Queues (QueueFamilyIndex, Queue)
getQueues context
context) \(QueueFamilyIndex Word32
ix, Queue
_queue) -> do
    let
      commandPoolCI :: CommandPoolCreateInfo
commandPoolCI = Vk.CommandPoolCreateInfo
        { $sel:flags:CommandPoolCreateInfo :: CommandPoolCreateFlags
flags            = forall a. Zero a => a
zero
        , $sel:queueFamilyIndex:CommandPoolCreateInfo :: Word32
queueFamilyIndex = Word32
ix
        }
    forall (io :: * -> *) r.
MonadIO io =>
Device
-> CommandPoolCreateInfo
-> Maybe AllocationCallbacks
-> (io CommandPool -> (CommandPool -> io ()) -> r)
-> r
Vk.withCommandPool (forall a. HasVulkan a => a -> Device
getDevice context
context) CommandPoolCreateInfo
commandPoolCI forall a. Maybe a
Nothing forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate

  ReleaseKey
bqKey <- forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
Resource.release forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Queues (ReleaseKey, CommandPool)
bootstrapQueues
  pure (ReleaseKey
bqKey, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Queues (ReleaseKey, CommandPool)
bootstrapQueues)

withPools
  :: (MonadVulkan env m, MonadResource m)
  => (Queues Vk.CommandPool -> m a)
  -> m a
withPools :: forall env (m :: * -> *) a.
(MonadVulkan env m, MonadResource m) =>
(Queues CommandPool -> m a) -> m a
withPools Queues CommandPool -> m a
action = do
  env
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (forall context (m :: * -> *).
(HasVulkan context, MonadResource m) =>
context -> m (ReleaseKey, Queues CommandPool)
allocatePools env
context) (forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
Resource.release forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (Queues CommandPool -> m a
action forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)

-- | Scratch command buffer for transfer operations.
-- The simple fence makes it unusable for rendering.
oneshot_
  :: (HasVulkan context, MonadUnliftIO m)
  => context
  -> Queues Vk.CommandPool
  -> (forall a . Queues a -> a)
  -> (Vk.CommandBuffer -> m ())
  -> m ()
oneshot_ :: forall context (m :: * -> *).
(HasVulkan context, MonadUnliftIO m) =>
context
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> m ())
-> m ()
oneshot_ context
context Queues CommandPool
pools forall a. Queues a -> a
pickQueue CommandBuffer -> m ()
action =
  forall (io :: * -> *) r.
MonadIO io =>
Device
-> CommandBufferAllocateInfo
-> (io (Vector CommandBuffer)
    -> (Vector CommandBuffer -> io ()) -> r)
-> r
Vk.withCommandBuffers Device
device CommandBufferAllocateInfo
commandBufferAllocateInfo forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket \case
    (forall a. Vector a -> [a]
Vector.toList -> [CommandBuffer
buf]) -> do
      let
        oneTime :: Vk.CommandBufferBeginInfo '[]
        oneTime :: CommandBufferBeginInfo '[]
oneTime = forall a. Zero a => a
zero
          { $sel:flags:CommandBufferBeginInfo :: CommandBufferUsageFlags
Vk.flags = CommandBufferUsageFlags
Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT
          }

      forall (a :: [*]) (io :: * -> *) r.
(Extendss CommandBufferBeginInfo a, PokeChain a, MonadIO io) =>
CommandBuffer -> CommandBufferBeginInfo a -> io r -> io r
Vk.useCommandBuffer CommandBuffer
buf CommandBufferBeginInfo '[]
oneTime forall a b. (a -> b) -> a -> b
$ CommandBuffer -> m ()
action CommandBuffer
buf

      forall (a :: [*]) (io :: * -> *) r.
(Extendss FenceCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> FenceCreateInfo a
-> Maybe AllocationCallbacks
-> (io Fence -> (Fence -> io ()) -> r)
-> r
Vk.withFence Device
device forall a. Zero a => a
zero forall a. Maybe a
Nothing forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket \Fence
fence -> do
        forall (io :: * -> *).
MonadIO io =>
Queue
-> ("submits" ::: Vector (SomeStruct SubmitInfo)) -> Fence -> io ()
Vk.queueSubmit Queue
queue (CommandBuffer -> "submits" ::: Vector (SomeStruct SubmitInfo)
wrap CommandBuffer
buf) Fence
fence
        forall (io :: * -> *).
MonadIO io =>
Device
-> ("fences" ::: Vector Fence)
-> ("waitAll" ::: Bool)
-> ("timeout" ::: Word64)
-> io Result
Vk.waitForFences Device
device (forall (f :: * -> *) a. Applicative f => a -> f a
pure Fence
fence) "waitAll" ::: Bool
True forall a. Bounded a => a
maxBound forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Result
Vk.SUCCESS ->
            -- traceM "oneshot_: queue finished"
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Result
err ->
            forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"oneshot_ failed: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Result
err
    Vector CommandBuffer
_ ->
      forall a. HasCallStack => [Char] -> a
error [Char]
"assert: exactly the requested buffer was given"
  where
    device :: Device
device = forall a. HasVulkan a => a -> Device
getDevice context
context
    queue :: Queue
queue = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Queues a -> a
pickQueue forall a b. (a -> b) -> a -> b
$ forall a. HasVulkan a => a -> Queues (QueueFamilyIndex, Queue)
getQueues context
context

    commandBufferAllocateInfo :: Vk.CommandBufferAllocateInfo
    commandBufferAllocateInfo :: CommandBufferAllocateInfo
commandBufferAllocateInfo = forall a. Zero a => a
zero
      { $sel:commandPool:CommandBufferAllocateInfo :: CommandPool
Vk.commandPool        = forall a. Queues a -> a
pickQueue Queues CommandPool
pools
      , $sel:level:CommandBufferAllocateInfo :: CommandBufferLevel
Vk.level              = CommandBufferLevel
Vk.COMMAND_BUFFER_LEVEL_PRIMARY
      , $sel:commandBufferCount:CommandBufferAllocateInfo :: Word32
Vk.commandBufferCount = Word32
1
      }

    wrap :: CommandBuffer -> "submits" ::: Vector (SomeStruct SubmitInfo)
wrap CommandBuffer
buf = forall a. a -> Vector a
Vector.singleton forall a b. (a -> b) -> a -> b
$ forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct forall a. Zero a => a
zero
      { $sel:commandBuffers:SubmitInfo :: Vector (Ptr CommandBuffer_T)
Vk.commandBuffers =
          forall a. a -> Vector a
Vector.singleton (CommandBuffer -> Ptr CommandBuffer_T
Vk.commandBufferHandle CommandBuffer
buf)
      }