{-# LANGUAGE OverloadedRecordDot #-}

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.Core10.CommandBuffer qualified as CommandBuffer
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 <- Queues (QueueFamilyIndex, Queue)
-> ((QueueFamilyIndex, Queue) -> m (ReleaseKey, CommandPool))
-> m (Queues (ReleaseKey, CommandPool))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (context -> Queues (QueueFamilyIndex, Queue)
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            = CommandPoolCreateFlags
forall a. Zero a => a
zero
        , $sel:queueFamilyIndex:CommandPoolCreateInfo :: Word32
queueFamilyIndex = Word32
ix
        }
    Device
-> CommandPoolCreateInfo
-> Maybe AllocationCallbacks
-> (IO CommandPool
    -> (CommandPool -> IO ()) -> m (ReleaseKey, CommandPool))
-> m (ReleaseKey, CommandPool)
forall (io :: * -> *) r.
MonadIO io =>
Device
-> CommandPoolCreateInfo
-> Maybe AllocationCallbacks
-> (io CommandPool -> (CommandPool -> io ()) -> r)
-> r
Vk.withCommandPool (context -> Device
forall a. HasVulkan a => a -> Device
getDevice context
context) CommandPoolCreateInfo
commandPoolCI Maybe AllocationCallbacks
forall a. Maybe a
Nothing IO CommandPool
-> (CommandPool -> IO ()) -> m (ReleaseKey, CommandPool)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate

  ReleaseKey
bqKey <- IO () -> m ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register (IO () -> m ReleaseKey) -> IO () -> m ReleaseKey
forall a b. (a -> b) -> a -> b
$
    ((ReleaseKey, CommandPool) -> IO ())
-> Queues (ReleaseKey, CommandPool) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ReleaseKey -> IO ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
Resource.release (ReleaseKey -> IO ())
-> ((ReleaseKey, CommandPool) -> ReleaseKey)
-> (ReleaseKey, CommandPool)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReleaseKey, CommandPool) -> ReleaseKey
forall a b. (a, b) -> a
fst) Queues (ReleaseKey, CommandPool)
bootstrapQueues
  pure (ReleaseKey
bqKey, ((ReleaseKey, CommandPool) -> CommandPool)
-> Queues (ReleaseKey, CommandPool) -> Queues CommandPool
forall a b. (a -> b) -> Queues a -> Queues b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ReleaseKey, CommandPool) -> CommandPool
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 <- m env
forall r (m :: * -> *). MonadReader r m => m r
ask
  m (ReleaseKey, Queues CommandPool)
-> ((ReleaseKey, Queues CommandPool) -> m ())
-> ((ReleaseKey, Queues CommandPool) -> m a)
-> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (env -> m (ReleaseKey, Queues CommandPool)
forall context (m :: * -> *).
(HasVulkan context, MonadResource m) =>
context -> m (ReleaseKey, Queues CommandPool)
allocatePools env
context) (ReleaseKey -> m ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
Resource.release (ReleaseKey -> m ())
-> ((ReleaseKey, Queues CommandPool) -> ReleaseKey)
-> (ReleaseKey, Queues CommandPool)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReleaseKey, Queues CommandPool) -> ReleaseKey
forall a b. (a, b) -> a
fst) (Queues CommandPool -> m a
action (Queues CommandPool -> m a)
-> ((ReleaseKey, Queues CommandPool) -> Queues CommandPool)
-> (ReleaseKey, Queues CommandPool)
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReleaseKey, Queues CommandPool) -> Queues CommandPool
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 =
  Device
-> CommandBufferAllocateInfo
-> (m (Vector CommandBuffer)
    -> (Vector CommandBuffer -> m ())
    -> (Vector CommandBuffer -> m ())
    -> m ())
-> (Vector CommandBuffer -> m ())
-> m ()
forall (io :: * -> *) r.
MonadIO io =>
Device
-> CommandBufferAllocateInfo
-> (io (Vector CommandBuffer)
    -> (Vector CommandBuffer -> io ()) -> r)
-> r
Vk.withCommandBuffers Device
device CommandBufferAllocateInfo
commandBufferAllocateInfo m (Vector CommandBuffer)
-> (Vector CommandBuffer -> m ())
-> (Vector CommandBuffer -> m ())
-> m ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket \case
    (Vector CommandBuffer -> [CommandBuffer]
forall a. Vector a -> [a]
Vector.toList -> [CommandBuffer
buf]) -> do
      let
        oneTime :: CommandBufferBeginInfo '[]
oneTime = CommandBufferBeginInfo '[]
forall a. Zero a => a
zero
          { $sel:flags:CommandBufferBeginInfo :: CommandBufferUsageFlags
CommandBuffer.flags = CommandBufferUsageFlags
Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT
          }

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

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

    commandBufferAllocateInfo :: Vk.CommandBufferAllocateInfo
    commandBufferAllocateInfo :: CommandBufferAllocateInfo
commandBufferAllocateInfo = CommandBufferAllocateInfo
forall a. Zero a => a
zero
      { $sel:commandPool:CommandBufferAllocateInfo :: CommandPool
Vk.commandPool        = Queues CommandPool -> 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 = SomeStruct SubmitInfo
-> "submits" ::: Vector (SomeStruct SubmitInfo)
forall a. a -> Vector a
Vector.singleton (SomeStruct SubmitInfo
 -> "submits" ::: Vector (SomeStruct SubmitInfo))
-> SomeStruct SubmitInfo
-> "submits" ::: Vector (SomeStruct SubmitInfo)
forall a b. (a -> b) -> a -> b
$ SubmitInfo '[] -> SomeStruct SubmitInfo
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct SubmitInfo '[]
forall a. Zero a => a
zero
      { $sel:commandBuffers:SubmitInfo :: Vector (Ptr CommandBuffer_T)
Vk.commandBuffers =
          Ptr CommandBuffer_T -> Vector (Ptr CommandBuffer_T)
forall a. a -> Vector a
Vector.singleton (CommandBuffer -> Ptr CommandBuffer_T
Vk.commandBufferHandle CommandBuffer
buf)
      }