vulkan-tutorial/src/Draw.hs
2022-07-16 21:50:22 +02:00

91 lines
3.1 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Draw where
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource
import qualified Data.Vector as V
import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
import qualified Vulkan.CStruct.Extends as Vk
import qualified Vulkan.Zero as Vk
-- internal imports
import CommandBuffer
import Types
drawFrame
:: (MonadResource m)
=> EngineData
-> m ()
drawFrame engineData = do
unless (all (V.length (engineCommandBuffers engineData) ==)
[ V.length (engineCommandBuffers engineData)
, V.length (engineFramebuffers engineData)
, V.length (enginePipelines engineData)
]) $
error ("Numbers of elements mismatch: command buffers " <>
show (V.length $ engineCommandBuffers engineData) <>
", frame buffers " <> show (V.length $ engineFramebuffers engineData) <>
", pipelines " <> show (V.length $ enginePipelines engineData))
let fences = V.singleton $ engineInFlightFence engineData
void $ Vk.waitForFences (engineLogicalDevice engineData) fences True maxBound
Vk.resetFences (engineLogicalDevice engineData) fences
(imageResult, index) <-
Khr.acquireNextImageKHR
(engineLogicalDevice engineData)
(engineSwapchain engineData)
maxBound
(engineImageAvailableSemaphore engineData)
Vk.NULL_HANDLE
unless (imageResult == Vk.SUCCESS) $
error "drawFrame: Failed acquiring next image from swapchain"
-- liftIO $ putStrLn "resetting command buffer"
Vk.resetCommandBuffer
(engineCommandBuffers engineData V.! fromIntegral index) (Vk.CommandBufferResetFlagBits 0)
-- liftIO $ putStrLn "recording command buffer"
recordCommandBuffer
(engineCommandBuffers engineData V.! fromIntegral index)
(engineRenderPass engineData)
(engineFramebuffers engineData V.! fromIntegral index)
(engineWindowDimensions engineData)
(enginePipelines engineData V.! fromIntegral index)
let submitInfo = Vk.zero
{ Vk.waitSemaphores =
V.singleton $ engineImageAvailableSemaphore engineData
, Vk.waitDstStageMask =
V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
, Vk.commandBuffers =
V.singleton (Vk.commandBufferHandle $ engineCommandBuffers engineData V.! fromIntegral index)
, Vk.signalSemaphores =
V.singleton $ engineRenderFinishedSemaphore engineData
}
-- liftIO $ putStrLn "submitting to queue"
Vk.queueSubmit
(engineQueue engineData)
(V.singleton (Vk.SomeStruct submitInfo))
(engineInFlightFence engineData)
let presentInfo = Vk.zero
{ Khr.waitSemaphores = V.singleton $ engineRenderFinishedSemaphore engineData
, Khr.swapchains = V.singleton $ engineSwapchain engineData
, Khr.imageIndices = V.singleton index
}
-- liftIO $ putStrLn "presenting queue"
presentResult <- Khr.queuePresentKHR (engineQueue engineData) presentInfo
unless (presentResult == Vk.SUCCESS) $
error "drawFrame: presentation failed"