vulkan-tutorial/src/Init.hs

142 lines
3.6 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
module Init where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import qualified Data.Vector as V
import Linear (V2)
import qualified SDL hiding (V2)
import qualified SDL.Video.Vulkan as SDL
import Foreign.C.Types (CInt)
import Foreign.Ptr
import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
import qualified Vulkan.Extensions.VK_KHR_surface as Khr
-- internal imports
import Instance
import Devices
import GraphicsPipeline
import Framebuffers
import CommandBuffer
initEngine
:: (MonadResource m, MonadFail m)
=> m
( SDL.Window
, V2 CInt
, Vk.Device
, Khr.SwapchainKHR
, Vk.Queue
, V.Vector Vk.CommandBuffer
, Vk.Framebuffer
, V.Vector Vk.Pipeline
, Vk.RenderPass
, Vk.Fence
, Vk.Semaphore
, Vk.Semaphore
)
initEngine = do
-- initialize SDL2 with all subsystems
void $ allocate_
SDL.initializeAll
(do
putStrLn "This is the end!"
SDL.quit
)
-- create a window configuration
let windowConfig = SDL.defaultWindow
{ SDL.windowGraphicsContext = SDL.VulkanContext -- enable Vulkan support
}
-- load vulkan library
SDL.vkLoadLibrary Nothing
-- create the window
(_, window) <-
allocate
(SDL.createWindow "Haskell ❤️ Vulkan" windowConfig)
(\window -> do
liftIO $ putStrLn "destroying window"
SDL.destroyWindow window
)
-- initialize viúlkan data structures
initVulkan window
initVulkan
:: (MonadResource m, MonadFail m)
=> SDL.Window
-> m
( SDL.Window
, V2 CInt
, Vk.Device
, Khr.SwapchainKHR
, Vk.Queue
, V.Vector Vk.CommandBuffer
, Vk.Framebuffer
, V.Vector Vk.Pipeline
, Vk.RenderPass
, Vk.Fence
, Vk.Semaphore
, Vk.Semaphore
)
initVulkan window = do
vulkanInstance <- createInstance window
(_, vulkanSurface) <- allocate
(Khr.SurfaceKHR <$>
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
)
(\vulkanSurface -> do
putStrLn "destroying surface"
Khr.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
)
vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
(vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface
dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
(swapchain, surfaceFormat) <-
createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice
imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice
vertexShader <- loadShader vulkanLogicalDevice "shadersrc/shader.vert" "vert"
fragmentShader <- loadShader vulkanLogicalDevice "shadersrc/shader.frag" "frag"
(pipelines, renderPass) <-
createGraphicsPipelines
vulkanLogicalDevice
vertexShader
fragmentShader
"main"
dimensions
(Khr.format surfaceFormat)
frameBuffer <- createFramebuffer vulkanLogicalDevice renderPass imageViews dimensions
(commandPool, graphicsQueue) <- createCommandPool vulkanPhysicalDevice vulkanLogicalDevice
commandBuffer <- createCommandBuffer vulkanLogicalDevice commandPool
(imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) <-
createSyncObjects vulkanLogicalDevice
return
( window
, dimensions
, vulkanLogicalDevice
, swapchain
, graphicsQueue
, commandBuffer
, frameBuffer
, pipelines
, renderPass
, inFlightFence
, imageAvailableSemaphore
, renderFinishedSemaphore
)