creating image views complete

src/Devices.hs

@@ -87,53 +87,91 @@ createSwapchain
   -> V.Vector Vk.SurfaceFormatKHR
   -> V2 CInt
   -> Vk.Device
-  -> m Vk.SwapchainKHR
+  -> m (Vk.SwapchainKHR, Vk.SurfaceFormatKHR)
 createSwapchain surface surfaceFormats windowDimension logicalDevice = do
 
   liftIO $ do
     print ("available formats:" :: String)
     print surfaceFormats
 
+  (surfaceFormat, colorSpace) <-
+    if
+      V.any
+        (\a ->
+          (Vk.format :: Vk.SurfaceFormatKHR -> Vk.Format) a ==
+            Vk.FORMAT_B8G8R8A8_SRGB
+          && (Vk.colorSpace :: Vk.SurfaceFormatKHR -> Vk.ColorSpaceKHR) a ==
+            Vk.COLOR_SPACE_SRGB_NONLINEAR_KHR)
+        surfaceFormats
+    then
+      return (Vk.FORMAT_B8G8R8A8_SRGB, Vk.COLOR_SPACE_SRGB_NONLINEAR_KHR)
+    else
+      error ("createSwapchain: No suitable surface formats available" :: String)
+
+  liftIO $ do
+    print ("picking following format and color space:" :: String)
+    print (surfaceFormat, colorSpace)
+
   let createInfo = Vk.zero
-        { Vk.surface = surface
-        , Vk.minImageCount = 4
-        , Vk.imageFormat = Vk.FORMAT_B8G8R8A8_SRGB
-        , Vk.imageColorSpace = Vk.COLOR_SPACE_SRGB_NONLINEAR_KHR
-        , Vk.imageExtent =
+        { Vk.surface          = surface
+        , Vk.minImageCount    = 4
+        , Vk.imageFormat      = surfaceFormat
+        , Vk.imageColorSpace  = colorSpace
+        , Vk.imageExtent      =
             (\(V2 w h) -> Vk.Extent2D (fromIntegral w) (fromIntegral h)) windowDimension
         , Vk.imageArrayLayers = 1
-        , 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_OPAQUE_BIT_KHR
-        , Vk.clipped = True
+        , 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_OPAQUE_BIT_KHR
+        , Vk.clipped          = True
         }
 
-  snd <$> allocate
+  swapchain <- snd <$> allocate
     (Vk.createSwapchainKHR logicalDevice createInfo Nothing)
     (\swapchain -> do
-      print ("destroying Swapchain" :: String)
+      print ("destroying swapchain" :: String)
       Vk.destroySwapchainKHR logicalDevice swapchain Nothing
       )
 
+  return (swapchain, Vk.SurfaceFormatKHR surfaceFormat colorSpace)
+
 getImageViewHandles
   :: (MonadResource m)
   => Vk.SwapchainKHR
+  -> Vk.SurfaceFormatKHR
   -> Vk.Device
   -> m (V.Vector Vk.ImageView)
-getImageViewHandles swapchain logicalDevice = do
+getImageViewHandles swapchain surfaceFormat logicalDevice = do
   (result, handles) <- Vk.getSwapchainImagesKHR logicalDevice swapchain
   when (result /= Vk.SUCCESS) $
     error "getImageHandles: Failed acquiring images from swapchain"
 
-  imageViews <- V.mapM
+  V.mapM
     (\image -> do
       let createInfo = Vk.zero
-            { Vk.image = image
-            , Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D
+            { Vk.image            = image
+            , Vk.viewType         = Vk.IMAGE_VIEW_TYPE_2D
+            , Vk.format           = (Vk.format :: Vk.SurfaceFormatKHR -> Vk.Format) surfaceFormat
+            , Vk.components       = Vk.ComponentMapping
+              { Vk.r = Vk.COMPONENT_SWIZZLE_IDENTITY
+              , Vk.g = Vk.COMPONENT_SWIZZLE_IDENTITY
+              , Vk.b = Vk.COMPONENT_SWIZZLE_IDENTITY
+              , Vk.a = Vk.COMPONENT_SWIZZLE_IDENTITY
+              }
+            , Vk.subresourceRange = Vk.ImageSubresourceRange
+              { aspectMask     = Vk.IMAGE_ASPECT_COLOR_BIT
+              , baseMipLevel   = 0
+              , levelCount     = 1
+              , baseArrayLayer = 0
+              , layerCount     = 1
+              }
             }
-      return ()
+      snd <$> allocate
+        (Vk.createImageView logicalDevice createInfo Nothing)
+        (\imageView -> do
+          print ("destrying image view" :: String)
+          Vk.destroyImageView logicalDevice imageView Nothing
+          )
       )
-    V.empty
-
-  error "getImageHandles: Not yet implemented"
+    handles

src/Init.hs

@@ -4,22 +4,13 @@
 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
 
@@ -72,7 +63,7 @@ initVulkan window = do
       SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
       )
     (\vulkanSurface -> do
-      print ("destroying Surface" :: String)
+      print ("destroying surface" :: String)
       Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
       )
 
@@ -80,7 +71,7 @@ initVulkan window = do
   (vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface
 
   dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
-  swapchain <- createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice
-  images <- getImageViewHandles swapchain vulkanLogicalDevice
+  (swapchain, surfaceFormat) <- createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice
+  imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice
 
-  return (vulkanSurface, vulkanInstance, swapchain, images)
+  return (vulkanSurface, vulkanInstance, swapchain, imageViews)

src/Main.hs

@@ -8,24 +8,15 @@ 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 Init
-import Devices
-import Instance
 
 main :: IO ()
 main = runResourceT $ do