vulkan-tutorial/src/Init.hs

{-# 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
    , V.Vector 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
    , V.Vector 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)
      (length imageViews)

  frameBuffers <- createFramebuffer vulkanLogicalDevice renderPass imageViews dimensions

  (commandPool, graphicsQueue) <- createCommandPool vulkanPhysicalDevice vulkanLogicalDevice
  commandBuffer <- createCommandBuffer vulkanLogicalDevice commandPool (length frameBuffers)

  (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) <-
    createSyncObjects vulkanLogicalDevice

  return
    ( window
    , dimensions
    , vulkanLogicalDevice
    , swapchain
    , graphicsQueue
    , commandBuffer
    , frameBuffers
    , pipelines
    , renderPass
    , inFlightFence
    , imageAvailableSemaphore
    , renderFinishedSemaphore
    )