trying to make implementation a little more flexible

src/Devices.hs

@@ -4,6 +4,7 @@
 module Devices where
 
 import Control.Monad
+import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Resource
 import qualified Data.Vector as V
 import Foreign.C.Types (CInt)
@@ -33,7 +34,7 @@ pickPhysicalDevice vkInstance = do
           Vk.geometryShader devFeatures
           )
         devicesWithPropsAndFeatures
-      maxMemdiscretePhysDevice = (\(x, _, _) -> x) $ V.foldl
+      (maxMemdiscretePhysDevice, props,_ ) = V.foldl
         (\acc@(_, devProp1, _) ndev@(_, devProp2, _) ->
           let dimension = Vk.maxImageDimension2D . Vk.limits
           in
@@ -44,13 +45,18 @@ pickPhysicalDevice vkInstance = do
         (V.head discretePhysDevices)
         discretePhysDevices
 
+  liftIO $ do
+    print ("picked the following device:" :: String)
+    print (Vk.deviceName props)
+
   return maxMemdiscretePhysDevice
 
 createLogicalDevice
   :: (MonadResource m)
   => Vk.PhysicalDevice
-  -> m Vk.Device
-createLogicalDevice physDevice = do
+  -> Vk.SurfaceKHR
+  -> m (Vk.Device, V.Vector Vk.SurfaceFormatKHR)
+createLogicalDevice physDevice surface = do
   let priorities = V.singleton 1
       extensionNames = V.singleton Vk.KHR_SWAPCHAIN_EXTENSION_NAME
       queueCreateInfo = Vk.zero
@@ -69,15 +75,25 @@ createLogicalDevice physDevice = do
       Vk.destroyDevice logDevice Nothing
       )
 
-  return logDevice
+  (result, formats) <- Vk.getPhysicalDeviceSurfaceFormatsKHR physDevice surface
+  unless (result == Vk.SUCCESS) $
+    error "Failed retrieving surface image formats"
+
+  return (logDevice, formats)
 
 createSwapchain
   :: (MonadResource m)
   => Vk.SurfaceKHR
+  -> V.Vector Vk.SurfaceFormatKHR
   -> V2 CInt
   -> Vk.Device
   -> m Vk.SwapchainKHR
-createSwapchain surface windowDimension logicalDevice = do
+createSwapchain surface surfaceFormats windowDimension logicalDevice = do
+
+  liftIO $ do
+    print ("available formats:" :: String)
+    print surfaceFormats
+
   let createInfo = Vk.zero
         { Vk.surface = surface
         , Vk.minImageCount = 4
@@ -89,7 +105,8 @@ createSwapchain surface windowDimension logicalDevice = do
         , Vk.imageUsage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT
         , Vk.presentMode = Vk.PRESENT_MODE_MAILBOX_KHR
         , Vk.preTransform = Vk.SURFACE_TRANSFORM_IDENTITY_BIT_KHR
-        , Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_INHERIT_BIT_KHR
+        , Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_OPAQUE_BIT_KHR
+        , Vk.clipped = True
         }
 
   snd <$> allocate
@@ -99,13 +116,24 @@ createSwapchain surface windowDimension logicalDevice = do
       Vk.destroySwapchainKHR logicalDevice swapchain Nothing
       )
 
-getImageHandles
+getImageViewHandles
   :: (MonadResource m)
   => Vk.SwapchainKHR
   -> Vk.Device
-  -> m (V.Vector Vk.Image)
-getImageHandles swapchain logicalDevice = do
+  -> m (V.Vector Vk.ImageView)
+getImageViewHandles swapchain logicalDevice = do
   (result, handles) <- Vk.getSwapchainImagesKHR logicalDevice swapchain
   when (result /= Vk.SUCCESS) $
     error "getImageHandles: Failed acquiring images from swapchain"
-  return handles
+
+  imageViews <- V.mapM
+    (\image -> do
+      let createInfo = Vk.zero
+            { Vk.image = image
+            , Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D
+            }
+      return ()
+      )
+    V.empty
+
+  error "getImageHandles: Not yet implemented"

src/Init.hs

@@ -28,7 +28,7 @@ import Devices
 
 initEngine
   :: MonadResource m
-  => m (SDL.Window, Vk.Instance, Vk.SurfaceKHR, Vk.SwapchainKHR, V.Vector Vk.Image)
+  => m (SDL.Window, Vk.Instance, Vk.SurfaceKHR, Vk.SwapchainKHR, V.Vector Vk.ImageView)
 initEngine = do
   -- initialize SDL2 with all subsystems
   void $ allocate_
@@ -62,14 +62,11 @@ initEngine = do
 initVulkan
   :: MonadResource m
   => SDL.Window
-  -> m (Vk.SurfaceKHR, Vk.Instance, Vk.SwapchainKHR, V.Vector Vk.Image)
+  -> m (Vk.SurfaceKHR, Vk.Instance, Vk.SwapchainKHR, V.Vector Vk.ImageView)
 initVulkan window = do
 
   vulkanInstance <- createInstance window
 
-  vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
-  vulkanLogicalDevice <- createLogicalDevice vulkanPhysicalDevice
-
   (_, vulkanSurface) <- allocate
     (Vk.SurfaceKHR <$>
       SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
@@ -79,8 +76,11 @@ initVulkan window = do
       Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
       )
 
+  vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
+  (vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface
+
   dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
-  swapchain <- createSwapchain vulkanSurface dimensions vulkanLogicalDevice
-  images <- getImageHandles swapchain vulkanLogicalDevice
+  swapchain <- createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice
+  images <- getImageViewHandles swapchain vulkanLogicalDevice
 
   return (vulkanSurface, vulkanInstance, swapchain, images)