it draws, but it's flashy and ugly

shell.nix

@@ -3,5 +3,16 @@
 let
   vulkanTutorial = pkgs.haskellPackages.callCabal2nix "vulkan-tutorial" (gitignore ./.) {};
   gitignore = src: pkgs.nix-gitignore.gitignoreSource [] src;
+  hpkgs = pkgs.haskellPackages.override {
+    overrides = final: prev: {
+      vulkanTutorial = vulkanTutorial;
+    };
+  };
 in
-  vulkanTutorial.env
+  hpkgs.shellFor {
+    packages = p: [
+      p.vulkanTutorial
+    ];
+    buildInputs =
+      vulkanTutorial.buildInputs ++ [ pkgs.shaderc ];
+  }

src/CommandBuffer.hs

@@ -14,6 +14,7 @@ import qualified Vulkan.Zero as Vk
 -- internal imports
 
 import Devices
+import GHC.IO.Handle.Text (commitBuffer')
 
 createCommandPool
   :: (MonadResource m)
@@ -85,7 +86,7 @@ recordCommandBuffer commandBuffer renderPass frameBuffer (V2 width height) graph
             , Vk.height = fromIntegral height
             }
           }
-        , Vk.clearValues = V.singleton (Vk.Color $ Vk.Float32 0 0 0 1)
+        , Vk.clearValues = V.replicate 4 (Vk.Color $ Vk.Float32 0 0 0 1)
         }
 
   Vk.cmdBeginRenderPass commandBuffer renderPassInfo Vk.SUBPASS_CONTENTS_INLINE
@@ -118,6 +119,7 @@ recordCommandBuffer commandBuffer renderPass frameBuffer (V2 width height) graph
 
   Vk.cmdEndRenderPass commandBuffer
 
+  Vk.endCommandBuffer commandBuffer
 
 createSyncObjects
   :: (MonadResource m, MonadFail m)
@@ -138,6 +140,11 @@ createSyncObjects logicalDevice = do
         Vk.destroySemaphore logicalDevice semaphore Nothing
         )
       )
-  inFlightFence <- Vk.createFence logicalDevice fenceCreateInfo Nothing
+  inFlightFence <- snd <$> allocate
+    (Vk.createFence logicalDevice fenceCreateInfo Nothing)
+    (\fence -> do
+      putStrLn "destroying fence"
+      Vk.destroyFence logicalDevice fence Nothing
+      )
 
   return (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence)

src/Devices.hs

@@ -153,7 +153,7 @@ createSwapchain surface surfaceFormats windowDimension logicalDevice = do
             (\(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.presentMode      = Vk.PRESENT_MODE_FIFO_KHR
         , Vk.preTransform     = Vk.SURFACE_TRANSFORM_IDENTITY_BIT_KHR
         , Vk.compositeAlpha   = Vk.COMPOSITE_ALPHA_OPAQUE_BIT_KHR
         , Vk.clipped          = True

src/Draw.hs

@@ -5,11 +5,16 @@ module Draw where
 import Control.Monad
 import Control.Monad.Trans.Resource
 import qualified Data.Vector as V
+import Foreign.C.Types (CInt)
+import Linear (V2(..))
 import qualified Vulkan.Core10 as Vk
 import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
 import qualified Vulkan.CStruct.Extends as Vk
 import qualified Vulkan.Zero as Vk
 
+-- internal imports
+
+import CommandBuffer
 
 drawFrame
   :: (MonadResource m)
@@ -17,6 +22,10 @@ drawFrame
   -> Khr.SwapchainKHR
   -> Vk.Queue
   -> Vk.CommandBuffer
+  -> Vk.RenderPass
+  -> Vk.Framebuffer
+  -> V2 CInt
+  -> Vk.Pipeline
   -> Vk.Fence
   -> Vk.Semaphore
   -> Vk.Semaphore
@@ -26,6 +35,10 @@ drawFrame
   swapchain
   graphicsQueue
   commandBuffer
+  renderPass
+  framebuffer
+  dimensions
+  pipeline
   inFlightFence
   imageAvailableSemaphore
   renderFinishedSemaphore
@@ -37,13 +50,15 @@ drawFrame
     Vk.resetFences logicalDevice fences
 
     (imageResult, index) <-
-      Khr.acquireNextImageKHR logicalDevice swapchain maxBound imageAvailableSemaphore inFlightFence
+      Khr.acquireNextImageKHR logicalDevice swapchain maxBound imageAvailableSemaphore Vk.NULL_HANDLE
 
     unless (imageResult == Vk.SUCCESS) $
       error "drawFrame: Failed acquiring next image from swapchain"
 
     Vk.resetCommandBuffer commandBuffer (Vk.CommandBufferResetFlagBits 0)
 
+    recordCommandBuffer commandBuffer renderPass framebuffer dimensions pipeline
+
     let submitInfo = Vk.zero
           { Vk.waitSemaphores = V.singleton imageAvailableSemaphore
           , Vk.waitDstStageMask = V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT

src/GraphicsPipeline.hs

@@ -8,23 +8,38 @@ import Control.Monad (unless)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Resource
 import Data.Bits
-import qualified Data.ByteString as BS
+-- import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS
 import qualified Data.Vector as V
 import Foreign.C.Types (CInt)
 import qualified Vulkan.Core10 as Vk
 import qualified Vulkan.Zero as Vk
 import qualified Vulkan.CStruct.Extends as Vk
+import qualified Vulkan.Utils.ShaderQQ.GLSL.Shaderc as Vk
 
 loadShader
   :: (MonadResource m)
   => Vk.Device
   -> FilePath
+  -> String
   -> m Vk.ShaderModule
-loadShader logicalDevice shaderPath = do
+loadShader logicalDevice shaderPath stage = do
   shaderSource <- liftIO $ BS.readFile shaderPath
 
+  (warnings, eShader) <- Vk.compileShader Nothing Nothing stage (BS.unpack shaderSource)
+  unless (null warnings) $ liftIO $ do
+    putStrLn "loadShader: Shader compilation warnings:"
+    print warnings
+  shader <- either
+    (\errors -> do
+      error ("loadShader: Compilation errors:" <> "\n" <> show errors)
+      )
+    return
+    eShader
+
+
   let createInfo = Vk.zero
-        { Vk.code = shaderSource
+        { Vk.code = shader
         }
 
   snd <$> allocate
@@ -164,10 +179,13 @@ createGraphicsPipelines
           { Vk.srcSubpass    = Vk.SUBPASS_EXTERNAL
           , Vk.dstSubpass    = 0
           , Vk.srcStageMask  = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
+          , Vk.dstStageMask  = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
           , Vk.srcAccessMask = Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
+          , Vk.dstAccessMask =
+            Vk.ACCESS_COLOR_ATTACHMENT_READ_BIT .|. Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
           }
         renderPassCreateInfo = Vk.zero
-          { Vk.attachments  = V.singleton colorAttachmentDescription
+          { Vk.attachments  = V.replicate 4 colorAttachmentDescription
           , Vk.subpasses    = V.singleton subpassDescriptor
           , Vk.dependencies = V.singleton subpassDependency
           } :: Vk.RenderPassCreateInfo '[]

src/Init.hs

@@ -7,8 +7,10 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Resource
 import qualified Data.Vector as V
+import Linear (V2)
 import qualified SDL hiding (V2)
 import qualified SDL.Video.Vulkan as SDL
+import Foreign.C.Types (CInt)
 import Foreign.Ptr
 import qualified Vulkan.Core10 as Vk
 import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
@@ -26,10 +28,14 @@ initEngine
   :: (MonadResource m, MonadFail m)
   => m
     ( SDL.Window
+    , V2 CInt
     , Vk.Device
     , Khr.SwapchainKHR
     , Vk.Queue
     , V.Vector Vk.CommandBuffer
+    , Vk.Framebuffer
+    , V.Vector Vk.Pipeline
+    , Vk.RenderPass
     , Vk.Fence
     , Vk.Semaphore
     , Vk.Semaphore
@@ -68,10 +74,14 @@ initVulkan
   => SDL.Window
   -> m
     ( SDL.Window
+    , V2 CInt
     , Vk.Device
     , Khr.SwapchainKHR
     , Vk.Queue
     , V.Vector Vk.CommandBuffer
+    , Vk.Framebuffer
+    , V.Vector Vk.Pipeline
+    , Vk.RenderPass
     , Vk.Fence
     , Vk.Semaphore
     , Vk.Semaphore
@@ -96,8 +106,8 @@ initVulkan window = do
   (swapchain, surfaceFormat) <-
     createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice
   imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice
-  vertexShader <- loadShader vulkanLogicalDevice "shadersrc/shader.vert"
+  vertexShader <- loadShader vulkanLogicalDevice "shadersrc/shader.vert" "vert"
-  fragmentShader <- loadShader vulkanLogicalDevice "shadersrc/shader.frag"
+  fragmentShader <- loadShader vulkanLogicalDevice "shadersrc/shader.frag" "frag"
   (pipelines, renderPass) <-
     createGraphicsPipelines
       vulkanLogicalDevice
@@ -117,10 +127,14 @@ initVulkan window = do
 
   return
     ( window
+    , dimensions
     , vulkanLogicalDevice
     , swapchain
     , graphicsQueue
     , commandBuffer
+    , frameBuffer
+    , pipelines
+    , renderPass
     , inFlightFence
     , imageAvailableSemaphore
     , renderFinishedSemaphore

src/Main.hs

@@ -22,7 +22,7 @@ import Draw (drawFrame)
 
 main :: IO ()
 main = runResourceT $ do
-  (window, logicalDevice, swapchain, graphicsQueue, commandBuffer, inFlightFence, imageAvailableSemaphore, renderFinishedSemaphore) <- initEngine
+  (window, dimensions, logicalDevice, swapchain, graphicsQueue, commandBuffer, framebuffer, pipelines, renderPass, inFlightFence, imageAvailableSemaphore, renderFinishedSemaphore) <- initEngine
 
   SDL.showWindow window
 
@@ -40,6 +40,10 @@ main = runResourceT $ do
         swapchain
         graphicsQueue
         (V.head commandBuffer)
+        renderPass
+        framebuffer
+        dimensions
+        (V.head pipelines)
         inFlightFence
         imageAvailableSemaphore
         renderFinishedSemaphore
@@ -55,6 +59,8 @@ main = runResourceT $ do
         evs
     )
 
+  Vk.deviceWaitIdle logicalDevice
+
 createBufferView
   :: (MonadResource m)
   => Vk.Device

vulkan-tutorial.cabal

@@ -38,7 +38,6 @@ executable vulkan-tutorial
                     , sdl2
                     , vulkan
                     , vulkan-utils
-                    , VulkanMemoryAllocator
                     , linear
                     , monad-loops
                     , stm