vulkan-tutorial/src/Init.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
module Init where

import Control.Monad
import Control.Monad.Loops
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.Bits
import qualified Data.ByteString as BS
import qualified Data.Vector as V
import Data.Word
import qualified SDL hiding (V2)
import qualified SDL.Video.Vulkan as SDL
import qualified Control.Concurrent.STM as STM
import Foreign.C.Types (CInt)
import Foreign.Ptr
import Linear
import qualified Vulkan as Vk
import qualified Vulkan.Zero as Vk
import qualified Vulkan.CStruct.Extends as Vk

-- internal imports

import Instance
import Devices

initEngine
  :: MonadResource m
  => m (SDL.Window, Vk.Instance, Vk.SurfaceKHR, Vk.SwapchainKHR, V.Vector Vk.ImageView)
initEngine = do
  -- initialize SDL2 with all subsystems
  void $ allocate_
    SDL.initializeAll
    (do
      print ("This is the end!" :: String)
      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 $ print ("destroying window" :: String)
        SDL.destroyWindow window
        )

  -- create vulkan surface and vulkan instance from window
  (surface, inst, swapchain, images) <- initVulkan window
  return (window, inst, surface, swapchain, images)

initVulkan
  :: MonadResource m
  => SDL.Window
  -> m (Vk.SurfaceKHR, Vk.Instance, Vk.SwapchainKHR, V.Vector Vk.ImageView)
initVulkan window = do

  vulkanInstance <- createInstance window

  (_, vulkanSurface) <- allocate
    (Vk.SurfaceKHR <$>
      SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
      )
    (\vulkanSurface -> do
      print ("destroying Surface" :: String)
      Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
      )

  vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
  (vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface

  dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
  swapchain <- createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice
  images <- getImageViewHandles swapchain vulkanLogicalDevice

  return (vulkanSurface, vulkanInstance, swapchain, images)