From e8e37f1cedac341f446bd9701d97079cd33613ff Mon Sep 17 00:00:00 2001
From: nek0 <nek0@nek0.eu>
Date: Mon, 16 Jan 2023 01:10:23 +0100
Subject: [PATCH] mew

---
 shadersrc/mesh.vert |  4 ++--
 src/Devices.hs      |  4 ++--
 src/Init.hs         | 19 +++++++++++++----
 src/Instance.hs     | 50 +++++++++++++++++++++++++++++++++++++++------
 src/Memory.hs       |  4 ++--
 src/Mesh.hs         |  4 +++-
 6 files changed, 68 insertions(+), 17 deletions(-)

diff --git a/shadersrc/mesh.vert b/shadersrc/mesh.vert
index 448df68..44ed6b9 100644
--- a/shadersrc/mesh.vert
+++ b/shadersrc/mesh.vert
@@ -1,9 +1,9 @@
 #version 450
 layout (location = 0) in vec3 vPosition;
 layout (location = 1) in vec3 vNormal;
-layout (location = 2) in vec3 vColor;
+layout (location = 2) in vec4 vColor;
 
-layout (location = 0) out vec3 outColor;
+layout (location = 0) out vec4 outColor;
 
 layout(set = 0, binding = 0) uniform  CameraBuffer{
 	mat4 view;
diff --git a/src/Devices.hs b/src/Devices.hs
index 509d602..38756bd 100644
--- a/src/Devices.hs
+++ b/src/Devices.hs
@@ -38,8 +38,8 @@ pickPhysicalDevice vkInstance = do
     physDevices
 
   let discretePhysDevices = V.filter
-        (\(_, _, devFeatures) ->
-          -- Vk.deviceType devProp == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU &&
+        (\(_, devProps, devFeatures) ->
+          Vk.deviceType devProps == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU &&
           Vk.geometryShader devFeatures
           )
         devicesWithPropsAndFeatures
diff --git a/src/Init.hs b/src/Init.hs
index b4a482c..bff19bf 100644
--- a/src/Init.hs
+++ b/src/Init.hs
@@ -5,6 +5,7 @@
 module Init where
 
 import qualified Control.Concurrent.STM as STM
+import Control.Exception
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Reader
@@ -55,7 +56,12 @@ initEngine = do
   -- create the window
   (_, window) <-
     allocate
-      (SDL.createWindow "Haskell ❤️ Vulkan" windowConfig)
+      (do
+        eexcept <- try (SDL.createWindow "Haskell ❤️ Vulkan" windowConfig)
+        case eexcept of
+          Left err -> error $ "here's your exception: " <> show (err :: SDL.SDLException)
+          Right a  -> return a
+        )
       (\window -> do
         liftIO $ putStrLn "destroying window"
         SDL.destroyWindow window
@@ -175,13 +181,18 @@ initDescriptors device = do
         , Vk.stageFlags      = Vk.SHADER_STAGE_VERTEX_BIT
         }
       setInfo = Vk.zero
-        { Vk.flags = bit 0
+        { Vk.flags = Vk.DESCRIPTOR_SET_LAYOUT_CREATE_UPDATE_AFTER_BIND_POOL_BIT
         , Vk.bindings = V.singleton cameraBufferBinding
         }
       poolInfo = Vk.zero
-        { Vk.flags     = bit 0
+        { Vk.flags     = Vk.DESCRIPTOR_POOL_CREATE_UPDATE_AFTER_BIND_BIT
         , Vk.maxSets   = 10
-        , Vk.poolSizes = V.singleton (Vk.DescriptorPoolSize Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER 10)
+        , Vk.poolSizes = V.singleton
+          ( Vk.zero
+            { Vk.type' = Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER
+            , Vk.descriptorCount = 1
+            }
+          )
         }
 
   (_, descriptorSetLayout) <- allocate
diff --git a/src/Instance.hs b/src/Instance.hs
index c865734..f1fe94b 100644
--- a/src/Instance.hs
+++ b/src/Instance.hs
@@ -10,29 +10,67 @@ import qualified Data.Vector as V
 import qualified SDL hiding (V2)
 import qualified SDL.Video.Vulkan as SDL
 import qualified Vulkan as Vk
+import qualified Vulkan.Requirement as Vk
 import qualified Vulkan.Zero as Vk
+import qualified Vulkan.Utils.Initialization as VkU
 
 createInstance :: MonadResource m => SDL.Window -> m Vk.Instance
 createInstance window = do
   windowExtensions <-
-    (++) [Vk.KHR_PUSH_DESCRIPTOR_EXTENSION_NAME, Vk.EXT_DEBUG_UTILS_EXTENSION_NAME] <$>
+    (++)
+      -- [ Vk.KHR_PUSH_DESCRIPTOR_EXTENSION_NAME
+      -- , Vk.EXT_DEBUG_UTILS_EXTENSION_NAME
+      -- ]
+      [ Vk.EXT_DEBUG_UTILS_EXTENSION_NAME
+      ]
+      <$>
       ((liftIO . mapM BS.packCString) =<< SDL.vkGetInstanceExtensions window)
-  liftIO $ do
-    putStrLn "activating followinfg extensions:"
-    print windowExtensions
+  -- liftIO $ do
+  --   putStrLn "activating followinfg extensions:"
+  --   print windowExtensions
   let createInfo = Vk.zero
         { Vk.applicationInfo       = Just Vk.zero
           { Vk.applicationName = Just "Haskell ❤️ Vulkan"
-          , Vk.apiVersion      = Vk.API_VERSION_1_3
+          , Vk.apiVersion      = Vk.API_VERSION_1_2
           }
           -- enable debug util extension for debugging purposes
         , Vk.enabledExtensionNames = V.fromList windowExtensions
           -- enable validation layer for debugging purposes
-        , Vk.enabledLayerNames     = V.singleton "VK_LAYER_KHRONOS_validation"
+        , Vk.enabledLayerNames     = V.fromList
+          [ "VK_LAYER_KHRONOS_validation"
+          ]
         }
+      requirements =
+        [ Vk.RequireInstanceExtension
+          { Vk.instanceExtensionLayerName  = Nothing
+          , Vk.instanceExtensionName       = Vk.KHR_GET_DISPLAY_PROPERTIES_2_EXTENSION_NAME
+          , Vk.instanceExtensionMinVersion = Vk.KHR_GET_DISPLAY_PROPERTIES_2_SPEC_VERSION
+          }
+        , Vk.RequireInstanceExtension
+          { Vk.instanceExtensionLayerName  = Nothing
+          , Vk.instanceExtensionName       = Vk.KHR_XLIB_SURFACE_EXTENSION_NAME
+          , Vk.instanceExtensionMinVersion = Vk.KHR_XLIB_SURFACE_SPEC_VERSION
+          }
+        , Vk.RequireInstanceExtension
+          { Vk.instanceExtensionLayerName  = Nothing
+          , Vk.instanceExtensionName       = Vk.KHR_DISPLAY_EXTENSION_NAME
+          , Vk.instanceExtensionMinVersion = Vk.KHR_DISPLAY_SPEC_VERSION
+          }
+        , Vk.RequireInstanceExtension
+          { Vk.instanceExtensionLayerName  = Nothing
+          , Vk.instanceExtensionName       = Vk.KHR_SURFACE_EXTENSION_NAME
+          , Vk.instanceExtensionMinVersion = Vk.KHR_SURFACE_SPEC_VERSION
+          }
+        , Vk.RequireInstanceExtension
+          { Vk.instanceExtensionLayerName  = Nothing
+          , Vk.instanceExtensionName       = Vk.KHR_PUSH_DESCRIPTOR_EXTENSION_NAME
+          , Vk.instanceExtensionMinVersion = Vk.KHR_PUSH_DESCRIPTOR_SPEC_VERSION
+          }
+        ]
 
   SDL.vkLoadLibrary Nothing
 
+  -- VkU.createDebugInstanceFromRequirements requirements [] createInfo
   (_, inst) <- allocate
     (Vk.createInstance createInfo Nothing)
     (\inst -> do
diff --git a/src/Memory.hs b/src/Memory.hs
index 5eff86c..7e22612 100644
--- a/src/Memory.hs
+++ b/src/Memory.hs
@@ -66,9 +66,9 @@ createAllocatedBuffer device allocator allocationSize usage memoryUsage = do
 
   (_, (buffer, newAllocation, _)) <- allocate
     (VMA.createBuffer allocator bufferInfo vmaAllocationInfo)
-    (\(buffer, _, _) -> do
+    (\(buffer, newAllocation, _) -> do
       putStrLn "destroying buffer"
-      Vk.destroyBuffer device buffer Nothing
+      VMA.destroyBuffer allocator buffer newAllocation
       )
 
   return $ AllocatedBuffer buffer newAllocation
diff --git a/src/Mesh.hs b/src/Mesh.hs
index 631c6e2..9675844 100644
--- a/src/Mesh.hs
+++ b/src/Mesh.hs
@@ -74,7 +74,9 @@ uploadMesh vertices allocator = do
 
   (dataReleaseKey, dataPtr) <- allocate
     (VMA.mapMemory allocator (bufferAllocation $ meshBuffer mesh))
-    (\_ -> VMA.unmapMemory allocator (bufferAllocation $ meshBuffer mesh))
+    (\_ -> do
+      VMA.unmapMemory allocator (bufferAllocation $ meshBuffer mesh)
+      )
 
   liftIO $ mapM_ (\(idx, vertex) ->
     poke (castPtr (dataPtr `plusPtr` (idx * sizeOf vertex))) vertex