{-# LANGUAGE OverloadedLists #-}

module Engine.Render where

import RIO
import Vulkan.Exception (VulkanException(..))

import Control.Monad.Trans.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk
import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore qualified as Vk12
import Vulkan.CStruct.Extends (SomeStruct(..), pattern (:&), pattern (::&))
import Vulkan.Extensions.VK_KHR_swapchain qualified as Khr
import Vulkan.NamedType ((:::))
import Vulkan.Zero (zero)

import Engine.Frame qualified as Frame
import Engine.Types (Frame(..), RecycledResources(..), StageFrameRIO)
import Engine.Types.RefCounted (resourceTRefCount)
import Engine.Vulkan.Swapchain (SwapchainInfo(..), SwapchainResources(..))
import Engine.Vulkan.Types (HasVulkan(..), RenderPass(..), Queues(..))

renderFrame
  :: RenderPass rp
  => (rr -> StageFrameRIO rp p rr st ())
  -> (Vk.CommandBuffer -> rr -> "image index" ::: Word32 -> StageFrameRIO rp p rr st ())
  -> StageFrameRIO rp p rr st ()
renderFrame :: forall rp rr p st.
RenderPass rp =>
(rr -> StageFrameRIO rp p rr st ())
-> (CommandBuffer
    -> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ())
-> StageFrameRIO rp p rr st ()
renderFrame rr -> StageFrameRIO rp p rr st ()
updateBuffers CommandBuffer
-> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ()
recordCommandBuffer = do
  Frame{rp
p
Word64
(ReleaseKey, InternalState)
(RefCounted, InternalState)
IORef [GPUWork]
Window
Semaphore
SurfaceKHR
SwapchainResources
RecycledResources rr
$sel:fRecycledResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> RecycledResources resources
$sel:fResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (ReleaseKey, InternalState)
$sel:fGPUWork:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> IORef [GPUWork]
$sel:fStageResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (RefCounted, InternalState)
$sel:fRenderFinishedHostSemaphore:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Semaphore
$sel:fPipelines:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> pipelines
$sel:fRenderpass:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> renderpass
$sel:fSwapchainResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
$sel:fSurface:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SurfaceKHR
$sel:fWindow:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Window
$sel:fIndex:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Word64
fRecycledResources :: RecycledResources rr
fResources :: (ReleaseKey, InternalState)
fGPUWork :: IORef [GPUWork]
fStageResources :: (RefCounted, InternalState)
fRenderFinishedHostSemaphore :: Semaphore
fPipelines :: p
fRenderpass :: rp
fSwapchainResources :: SwapchainResources
fSurface :: SurfaceKHR
fWindow :: Window
fIndex :: Word64
..} <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a, b) -> b
snd
  let stageRecycled :: rr
stageRecycled = forall a. RecycledResources a -> a
rrData RecycledResources rr
fRecycledResources
  Device
device <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice

  let oneSecondKhr :: Word64
oneSecondKhr = Word64
1e9
  let
    RecycledResources{rr
Semaphore
Queues CommandPool
$sel:rrQueues:RecycledResources :: forall a. RecycledResources a -> Queues CommandPool
$sel:rrRenderFinishedSemaphore:RecycledResources :: forall a. RecycledResources a -> Semaphore
$sel:rrImageAvailableSemaphore:RecycledResources :: forall a. RecycledResources a -> Semaphore
rrData :: rr
rrQueues :: Queues CommandPool
rrRenderFinishedSemaphore :: Semaphore
rrImageAvailableSemaphore :: Semaphore
$sel:rrData:RecycledResources :: forall a. RecycledResources a -> a
..}  = RecycledResources rr
fRecycledResources
    SwapchainResources{Var Extent2D
Vector Image
Vector ImageView
RefCounted
SwapchainInfo
$sel:srScreenVar:SwapchainResources :: SwapchainResources -> Var Extent2D
$sel:srRelease:SwapchainResources :: SwapchainResources -> RefCounted
$sel:srImages:SwapchainResources :: SwapchainResources -> Vector Image
$sel:srImageViews:SwapchainResources :: SwapchainResources -> Vector ImageView
$sel:srInfo:SwapchainResources :: SwapchainResources -> SwapchainInfo
srScreenVar :: Var Extent2D
srRelease :: RefCounted
srImages :: Vector Image
srImageViews :: Vector ImageView
srInfo :: SwapchainInfo
..} = SwapchainResources
fSwapchainResources
    SwapchainInfo{Float
"image index" ::: Word32
ReleaseKey
Format
SampleCountFlagBits
Extent2D
SurfaceKHR
ColorSpaceKHR
PresentModeKHR
SwapchainKHR
$sel:siSurface:SwapchainInfo :: SwapchainInfo -> SurfaceKHR
$sel:siImageExtent:SwapchainInfo :: SwapchainInfo -> Extent2D
$sel:siAnisotropy:SwapchainInfo :: SwapchainInfo -> Float
$sel:siMultisample:SwapchainInfo :: SwapchainInfo -> SampleCountFlagBits
$sel:siDepthFormat:SwapchainInfo :: SwapchainInfo -> Format
$sel:siSurfaceColorspace:SwapchainInfo :: SwapchainInfo -> ColorSpaceKHR
$sel:siSurfaceFormat:SwapchainInfo :: SwapchainInfo -> Format
$sel:siMinImageCount:SwapchainInfo :: SwapchainInfo -> "image index" ::: Word32
$sel:siPresentMode:SwapchainInfo :: SwapchainInfo -> PresentModeKHR
$sel:siSwapchainReleaseKey:SwapchainInfo :: SwapchainInfo -> ReleaseKey
$sel:siSwapchain:SwapchainInfo :: SwapchainInfo -> SwapchainKHR
siSurface :: SurfaceKHR
siImageExtent :: Extent2D
siAnisotropy :: Float
siMultisample :: SampleCountFlagBits
siDepthFormat :: Format
siSurfaceColorspace :: ColorSpaceKHR
siSurfaceFormat :: Format
siMinImageCount :: "image index" ::: Word32
siPresentMode :: PresentModeKHR
siSwapchainReleaseKey :: ReleaseKey
siSwapchain :: SwapchainKHR
..}      = SwapchainInfo
srInfo

  forall (f :: * -> *). MonadResource f => RefCounted -> f ()
resourceTRefCount RefCounted
srRelease
  forall (f :: * -> *). MonadResource f => RefCounted -> f ()
resourceTRefCount (forall a b. (a, b) -> a
fst (RefCounted, InternalState)
fStageResources)
  forall a env.
(RenderPass a, MonadResource (RIO env)) =>
a -> RIO env ()
refcountRenderpass rp
fRenderpass

  rr -> StageFrameRIO rp p rr st ()
updateBuffers rr
stageRecycled

  (Result
res, "image index" ::: Word32
imageIndex) <- forall (io :: * -> *).
MonadIO io =>
Device
-> SwapchainKHR
-> Word64
-> Semaphore
-> Fence
-> io (Result, "image index" ::: Word32)
Khr.acquireNextImageKHRSafe
    Device
device
    SwapchainKHR
siSwapchain
    Word64
oneSecondKhr
    Semaphore
rrImageAvailableSemaphore
    forall a. IsHandle a => a
Vk.NULL_HANDLE

  let
    proceed :: StageFrameRIO rp p rr st ()
proceed = do
      -- Allocate a command buffer and populate it
      let
        commandBufferAI :: CommandBufferAllocateInfo
commandBufferAI = forall a. Zero a => a
zero
          { $sel:commandPool:CommandBufferAllocateInfo :: CommandPool
Vk.commandPool        = forall q. Queues q -> q
qGraphics Queues CommandPool
rrQueues
          , $sel:level:CommandBufferAllocateInfo :: CommandBufferLevel
Vk.level              = CommandBufferLevel
Vk.COMMAND_BUFFER_LEVEL_PRIMARY
          , $sel:commandBufferCount:CommandBufferAllocateInfo :: "image index" ::: Word32
Vk.commandBufferCount = "image index" ::: Word32
1
          }
      CommandBuffer
commandBuffer <- forall (io :: * -> *) r.
MonadIO io =>
Device
-> CommandBufferAllocateInfo
-> (io (Vector CommandBuffer)
    -> (Vector CommandBuffer -> io ()) -> r)
-> r
Vk.withCommandBuffers Device
device CommandBufferAllocateInfo
commandBufferAI forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (ReleaseKey
_key, [Item (Vector CommandBuffer)
one]) ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure Item (Vector CommandBuffer)
one
        (ReleaseKey, Vector CommandBuffer)
_ ->
          forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"assert: 1 buffer allocated as requested"

      let
        commandBufferBI :: CommandBufferBeginInfo '[]
commandBufferBI = forall a. Zero a => a
zero
          { $sel:flags:CommandBufferBeginInfo :: CommandBufferUsageFlags
Vk.flags = CommandBufferUsageFlags
Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT
          } :: Vk.CommandBufferBeginInfo '[]
      forall (a :: [*]) (io :: * -> *) r.
(Extendss CommandBufferBeginInfo a, PokeChain a, MonadIO io) =>
CommandBuffer -> CommandBufferBeginInfo a -> io r -> io r
Vk.useCommandBuffer CommandBuffer
commandBuffer CommandBufferBeginInfo '[]
commandBufferBI forall a b. (a -> b) -> a -> b
$
        CommandBuffer
-> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ()
recordCommandBuffer CommandBuffer
commandBuffer rr
stageRecycled "image index" ::: Word32
imageIndex

      let
        submitInfo :: SubmitInfo '[TimelineSemaphoreSubmitInfo]
submitInfo =
          forall a. Zero a => a
zero
            { $sel:waitSemaphores:SubmitInfo :: Vector Semaphore
Vk.waitSemaphores =
                [ Semaphore
rrImageAvailableSemaphore
                ]
            , $sel:waitDstStageMask:SubmitInfo :: Vector PipelineStageFlags
Vk.waitDstStageMask =
                [ PipelineStageFlags
Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
                ]
            , $sel:commandBuffers:SubmitInfo :: Vector (Ptr CommandBuffer_T)
Vk.commandBuffers =
                [ CommandBuffer -> Ptr CommandBuffer_T
Vk.commandBufferHandle CommandBuffer
commandBuffer
                ]
            , $sel:signalSemaphores:SubmitInfo :: Vector Semaphore
Vk.signalSemaphores =
                [ Semaphore
rrRenderFinishedSemaphore
                , Semaphore
fRenderFinishedHostSemaphore
                ]
            }
          forall (a :: [*] -> *) (es :: [*]) (es' :: [*]).
Extensible a =>
a es' -> Chain es -> a es
::& forall a. Zero a => a
zero
            { $sel:waitSemaphoreValues:TimelineSemaphoreSubmitInfo :: Vector Word64
Vk12.waitSemaphoreValues   = [Word64
1]
            , $sel:signalSemaphoreValues:TimelineSemaphoreSubmitInfo :: Vector Word64
Vk12.signalSemaphoreValues = [Word64
1, Word64
fIndex]
            }
          forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ()

      -- traceM $ "Submitting frame " <> textDisplay fIndex <> " to image " <> textDisplay imageIndex
      Queues{$sel:qGraphics:Queues :: forall q. Queues q -> q
qGraphics=(QueueFamilyIndex
_family, Queue
graphicsPresentQueue)} <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Queues (QueueFamilyIndex, Queue)
getQueues
      forall env (m :: * -> *).
MonadVulkan env m =>
Queue
-> Vector (SomeStruct SubmitInfo)
-> IORef [GPUWork]
-> Semaphore
-> Word64
-> m ()
Frame.queueSubmit
        Queue
graphicsPresentQueue
        [forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct SubmitInfo '[TimelineSemaphoreSubmitInfo]
submitInfo]
        IORef [GPUWork]
fGPUWork
        Semaphore
fRenderFinishedHostSemaphore
        Word64
fIndex

      -- traceM $ "Presenting image " <> textDisplay imageIndex <> " from frame " <> textDisplay fIndex
      Result
presentRes <- forall (a :: [*]) (io :: * -> *).
(Extendss PresentInfoKHR a, PokeChain a, MonadIO io) =>
Queue -> PresentInfoKHR a -> io Result
Khr.queuePresentKHR Queue
graphicsPresentQueue forall a. Zero a => a
zero
        { $sel:waitSemaphores:PresentInfoKHR :: Vector Semaphore
Khr.waitSemaphores = [Semaphore
rrRenderFinishedSemaphore]
        , $sel:swapchains:PresentInfoKHR :: Vector SwapchainKHR
Khr.swapchains     = [SwapchainKHR
siSwapchain]
        , $sel:imageIndices:PresentInfoKHR :: Vector ("image index" ::: Word32)
Khr.imageIndices   = ["image index" ::: Word32
imageIndex]
        }
      case Result
presentRes of
        Result
Vk.SUCCESS ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Result
Vk.SUBOPTIMAL_KHR -> do
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"[present] Swapchain is suboptimal, forcing update."
          forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Result -> VulkanException
VulkanException Result
Vk.ERROR_OUT_OF_DATE_KHR
        Result
_ ->
          -- TODO: check for ERROR_OUT_OF_DATE_KHR
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Presenting wasn't quite successful: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow Result
presentRes

  case Result
res of
    Result
Vk.SUCCESS ->
      -- logDebug $ "Acquired next image ID: " <> displayShow imageIndex
      StageFrameRIO rp p rr st ()
proceed

    Result
Vk.TIMEOUT ->
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Timed out (1s) trying to acquire next image"

    Result
Vk.ERROR_OUT_OF_DATE_KHR -> do
      {- XXX:
        Throwing an exception for 'Engine.Vulkan.Swapchain.threwSwapchainError' to catch.
        See also: 'Engine.Run.step'.
      -}
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"[acquire] Swapchain out of date"
      forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Result -> VulkanException
VulkanException Result
res

    Result
Vk.SUBOPTIMAL_KHR -> do
      {- XXX:
        Converting 'Vk.SUBOPTIMAL_KHR' error to OOD to trigger swapchain update.
      -}
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"[acquire] Swapchain is suboptimal, forcing update."
      forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Result -> VulkanException
VulkanException Result
Vk.ERROR_OUT_OF_DATE_KHR

    Result
_ -> do
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$
        Utf8Builder
"Unexpected Result from acquireNextImageKHR: " forall a. Semigroup a => a -> a -> a
<>
        forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show Result
res)
      forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Result -> VulkanException
VulkanException Result
res