vulkan-tutorial/src/Init.hs

78 lines
2.2 KiB
Haskell
Raw Normal View History

{-# 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 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
2022-07-11 12:01:04 +00:00
print ("destroying surface" :: String)
Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
)
vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
(vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface
dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
2022-07-11 12:01:04 +00:00
(swapchain, surfaceFormat) <- createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice
imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice
2022-07-11 12:01:04 +00:00
return (vulkanSurface, vulkanInstance, swapchain, imageViews)