{-# 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 qualified SDL hiding (V2) import qualified SDL.Video.Vulkan as SDL 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 , Vk.Device , Khr.SwapchainKHR , Vk.Queue , V.Vector Vk.CommandBuffer , 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 , Vk.Device , Khr.SwapchainKHR , Vk.Queue , V.Vector Vk.CommandBuffer , 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" fragmentShader <- loadShader vulkanLogicalDevice "shadersrc/shader.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 , vulkanLogicalDevice , swapchain , graphicsQueue , commandBuffer , inFlightFence , imageAvailableSemaphore , renderFinishedSemaphore )