a little cleanup

src/CommandBuffer.hs

@@ -34,7 +34,7 @@ createCommandPool physicalDevice logicalDevice = do
   commandPool <- snd <$> allocate
     (Vk.createCommandPool logicalDevice poolCreateInfo Nothing)
     (\commandPool -> do
-      putStrLn "destroying comman pool"
+      putStrLn "destroying command pool"
       Vk.destroyCommandPool logicalDevice commandPool Nothing
       )
 

src/Draw.hs

@@ -6,8 +6,6 @@ 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)
-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
@@ -16,81 +14,77 @@ import qualified Vulkan.Zero as Vk
 -- internal imports
 
 import CommandBuffer
+import Types
 
 drawFrame
   :: (MonadResource m)
-  => Vk.Device
+  => EngineData
-  -> Khr.SwapchainKHR
-  -> Vk.Queue
-  -> V.Vector Vk.CommandBuffer
-  -> Vk.RenderPass
-  -> V.Vector Vk.Framebuffer
-  -> V2 CInt
-  -> V.Vector Vk.Pipeline
-  -> Vk.Fence
-  -> Vk.Semaphore
-  -> Vk.Semaphore
   -> m ()
-drawFrame
+drawFrame engineData = do
-  logicalDevice
-  swapchain
-  graphicsQueue
-  commandBuffers
-  renderPass
-  framebuffers
-  dimensions
-  pipelines
-  inFlightFence
-  imageAvailableSemaphore
-  renderFinishedSemaphore
-  = do
 
-    unless (all (V.length commandBuffers ==)
+  unless (all (V.length (engineCommandBuffers engineData) ==)
-      [V.length commandBuffers, V.length framebuffers, V.length pipelines]) $
+    [ V.length (engineCommandBuffers engineData)
-        error ("Numbers of elements mismatch: command buffers " <> show (V.length commandBuffers) <>
+    , V.length (engineFramebuffers engineData)
-          ", frame buffers " <> show (V.length framebuffers) <>
+    , V.length (enginePipelines engineData)
-          ", pipelines " <> show (V.length pipelines))
+    ]) $
+      error ("Numbers of elements mismatch: command buffers " <>
+        show (V.length $ engineCommandBuffers engineData) <>
+        ", frame buffers " <> show (V.length $ engineFramebuffers engineData) <>
+        ", pipelines " <> show (V.length $ enginePipelines engineData))
 
-    let fences = V.singleton inFlightFence
+  let fences = V.singleton $ engineInFlightFence engineData
 
-    void $ Vk.waitForFences logicalDevice fences True maxBound
+  void $ Vk.waitForFences (engineLogicalDevice engineData) fences True maxBound
-    Vk.resetFences logicalDevice fences
+  Vk.resetFences (engineLogicalDevice engineData) fences
 
-    (imageResult, index) <-
+  (imageResult, index) <-
-      Khr.acquireNextImageKHR logicalDevice swapchain maxBound imageAvailableSemaphore Vk.NULL_HANDLE
+    Khr.acquireNextImageKHR
+      (engineLogicalDevice engineData)
+      (engineSwapchain engineData)
+      maxBound
+      (engineImageAvailableSemaphore engineData)
+      Vk.NULL_HANDLE
 
-    unless (imageResult == Vk.SUCCESS) $
+  unless (imageResult == Vk.SUCCESS) $
-      error "drawFrame: Failed acquiring next image from swapchain"
+    error "drawFrame: Failed acquiring next image from swapchain"
 
-    liftIO $ putStrLn "resetting command buffer"
+  -- liftIO $ putStrLn "resetting command buffer"
-    Vk.resetCommandBuffer (commandBuffers V.! fromIntegral index) (Vk.CommandBufferResetFlagBits 0)
+  Vk.resetCommandBuffer
+    (engineCommandBuffers engineData V.! fromIntegral index) (Vk.CommandBufferResetFlagBits 0)
 
-    liftIO $ putStrLn "recording command buffer"
+  -- liftIO $ putStrLn "recording command buffer"
-    recordCommandBuffer
+  recordCommandBuffer
-      (commandBuffers V.! fromIntegral index)
+    (engineCommandBuffers engineData V.! fromIntegral index)
-      renderPass
+    (engineRenderPass engineData)
-      (framebuffers V.! fromIntegral index)
+    (engineFramebuffers engineData V.! fromIntegral index)
-      dimensions
+    (engineWindowDimensions engineData)
-      (pipelines V.! fromIntegral index)
+    (enginePipelines engineData V.! fromIntegral index)
 
-    let submitInfo = Vk.zero
+  let submitInfo = Vk.zero
-          { Vk.waitSemaphores = V.singleton imageAvailableSemaphore
+        { Vk.waitSemaphores =
-          , Vk.waitDstStageMask = V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
+          V.singleton $ engineImageAvailableSemaphore engineData
-          , Vk.commandBuffers = V.singleton (Vk.commandBufferHandle $ commandBuffers V.! fromIntegral index)
+        , Vk.waitDstStageMask =
-          , Vk.signalSemaphores = V.singleton renderFinishedSemaphore
+          V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
-          }
+        , Vk.commandBuffers =
+          V.singleton (Vk.commandBufferHandle $ engineCommandBuffers engineData V.! fromIntegral index)
+        , Vk.signalSemaphores =
+          V.singleton $ engineRenderFinishedSemaphore engineData
+        }
 
-    liftIO $ putStrLn "submitting to queue"
+  -- liftIO $ putStrLn "submitting to queue"
-    Vk.queueSubmit graphicsQueue (V.singleton (Vk.SomeStruct submitInfo)) inFlightFence
+  Vk.queueSubmit
+    (engineQueue engineData)
+    (V.singleton (Vk.SomeStruct submitInfo))
+    (engineInFlightFence engineData)
 
-    let presentInfo = Vk.zero
+  let presentInfo = Vk.zero
-          { Khr.waitSemaphores = V.singleton renderFinishedSemaphore
+        { Khr.waitSemaphores = V.singleton $ engineRenderFinishedSemaphore engineData
-          , Khr.swapchains = V.singleton swapchain
+        , Khr.swapchains = V.singleton $ engineSwapchain engineData
-          , Khr.imageIndices = V.singleton index
+        , Khr.imageIndices = V.singleton index
-          }
+        }
 
-    liftIO $ putStrLn "presenting queue"
+  -- liftIO $ putStrLn "presenting queue"
-    presentResult <- Khr.queuePresentKHR graphicsQueue presentInfo
+  presentResult <- Khr.queuePresentKHR (engineQueue engineData) presentInfo
 
-    unless (presentResult == Vk.SUCCESS) $
+  unless (presentResult == Vk.SUCCESS) $
-      error "drawFrame: presentation failed"
+    error "drawFrame: presentation failed"

src/GraphicsPipeline.hs

@@ -17,6 +17,9 @@ import qualified Vulkan.Zero as Vk
 import qualified Vulkan.CStruct.Extends as Vk
 import qualified Vulkan.Utils.ShaderQQ.GLSL.Shaderc as Vk
 
+-- internal imports
+import Types
+
 loadShader
   :: (MonadResource m)
   => Vk.Device
@@ -49,34 +52,86 @@ loadShader logicalDevice shaderPath stage = do
       Vk.destroyShaderModule logicalDevice shaderModule Nothing
       )
 
+createRenderPass
+  :: (MonadResource m)
+  => Vk.Device
+  -> Vk.Format
+  -> m Vk.RenderPass
+createRenderPass
+  logicalDevice
+  swapchainImageFormat
+  = do
+
+
+
+    let colorAttachmentDescription = (Vk.zero :: Vk.AttachmentDescription)
+          { Vk.format         = swapchainImageFormat
+          , Vk.samples        = Vk.SAMPLE_COUNT_1_BIT
+          , Vk.loadOp         = Vk.ATTACHMENT_LOAD_OP_CLEAR
+          , Vk.storeOp        = Vk.ATTACHMENT_STORE_OP_STORE
+          , Vk.stencilLoadOp  = Vk.ATTACHMENT_LOAD_OP_DONT_CARE
+          , Vk.stencilStoreOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE
+          , Vk.initialLayout  = Vk.IMAGE_LAYOUT_UNDEFINED
+          , Vk.finalLayout    = Vk.IMAGE_LAYOUT_PRESENT_SRC_KHR
+          }
+        colorAttachmentReference = (Vk.zero :: Vk.AttachmentReference)
+          { Vk.attachment = 0
+          , Vk.layout     = Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL
+          }
+        subpassDescriptor = (Vk.zero :: Vk.SubpassDescription)
+          { Vk.pipelineBindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS
+          , Vk.colorAttachments = V.singleton colorAttachmentReference
+          }
+        subpassDependency = Vk.zero
+          { 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.subpasses    = V.singleton subpassDescriptor
+          , Vk.dependencies = V.singleton subpassDependency
+          } :: Vk.RenderPassCreateInfo '[]
+
+    snd <$> allocate
+      (Vk.createRenderPass logicalDevice renderPassCreateInfo Nothing)
+      (\renderPass -> do
+        putStrLn "destroying render pass"
+        Vk.destroyRenderPass logicalDevice renderPass Nothing
+        )
+
+
 createGraphicsPipelines
   :: (MonadResource m)
   => Vk.Device
-  -> Vk.ShaderModule
+  -> Vk.RenderPass
-  -> Vk.ShaderModule
+  -> ShaderContainer
   -> BS.ByteString
   -> V2 CInt
-  -> Vk.Format
   -> Int
-  -> m (V.Vector Vk.Pipeline, Vk.RenderPass)
+  -> Vk.PipelineLayout
+  -> m (V.Vector Vk.Pipeline)
 createGraphicsPipelines
   logicalDevice
-  vertexShaderModule
+  renderPass
-  fragmentShaderModule
+  shaderContainer
   stageName
   (V2 width height)
-  swapchainImageFormat
   number
+  pipelineLayout
   = do
-
     let vertexShaderStageCreateInfo = Vk.zero
           { Vk.stage   = Vk.SHADER_STAGE_VERTEX_BIT
-          , Vk.module' = vertexShaderModule
+          , Vk.module' = containedVertexShader shaderContainer
           , Vk.name    = stageName
           }
         fragmentShaderStageCreateInfo = Vk.zero
           { Vk.stage   = Vk.SHADER_STAGE_FRAGMENT_BIT
-          , Vk.module' = fragmentShaderModule
+          , Vk.module' = containedFragmentShader shaderContainer
           , Vk.name    = stageName
           }
         pipelineStagesCreateInfos =
@@ -150,56 +205,7 @@ createGraphicsPipelines
           { Vk.logicOpEnable = False
           , Vk.attachments = V.singleton colorBlendAttachment
           }
-        pipelineLayoutCreateInfo = Vk.zero
+        pipelineCreateInfo = Vk.zero
-
-    pipelineLayout <- snd <$> allocate
-      (Vk.createPipelineLayout logicalDevice pipelineLayoutCreateInfo Nothing)
-      (\pipelineLayout -> do
-        putStrLn "destroying pipeline layout"
-        Vk.destroyPipelineLayout logicalDevice pipelineLayout Nothing
-        )
-
-    let colorAttachmentDescription = (Vk.zero :: Vk.AttachmentDescription)
-          { Vk.format         = swapchainImageFormat
-          , Vk.samples        = Vk.SAMPLE_COUNT_1_BIT
-          , Vk.loadOp         = Vk.ATTACHMENT_LOAD_OP_CLEAR
-          , Vk.storeOp        = Vk.ATTACHMENT_STORE_OP_STORE
-          , Vk.stencilLoadOp  = Vk.ATTACHMENT_LOAD_OP_DONT_CARE
-          , Vk.stencilStoreOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE
-          , Vk.initialLayout  = Vk.IMAGE_LAYOUT_UNDEFINED
-          , Vk.finalLayout    = Vk.IMAGE_LAYOUT_PRESENT_SRC_KHR
-          }
-        colorAttachmentReference = (Vk.zero :: Vk.AttachmentReference)
-          { Vk.attachment = 0
-          , Vk.layout     = Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL
-          }
-        subpassDescriptor = (Vk.zero :: Vk.SubpassDescription)
-          { Vk.pipelineBindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS
-          , Vk.colorAttachments = V.singleton colorAttachmentReference
-          }
-        subpassDependency = Vk.zero
-          { 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.subpasses    = V.singleton subpassDescriptor
-          , Vk.dependencies = V.singleton subpassDependency
-          } :: Vk.RenderPassCreateInfo '[]
-
-    pipelineRenderPass <- snd <$> allocate
-      (Vk.createRenderPass logicalDevice renderPassCreateInfo Nothing)
-      (\renderPass -> do
-        putStrLn "destroying render pass"
-        Vk.destroyRenderPass logicalDevice renderPass Nothing
-        )
-
-    let pipelineCreateInfo = Vk.zero
           { Vk.stageCount         = 2
           , Vk.stages             = pipelineStagesCreateInfos
           , Vk.vertexInputState   = Just $ Vk.SomeStruct pipelineVertexInputCreateInfo
@@ -210,13 +216,13 @@ createGraphicsPipelines
           , Vk.colorBlendState    = Just $ Vk.SomeStruct pipelineColorBlendStateCreateInfo
           , Vk.dynamicState       = Just pipelineDynamicStateCreateInfo
           , Vk.layout             = pipelineLayout
-          , Vk.renderPass         = pipelineRenderPass
+          , Vk.renderPass         = renderPass
           , Vk.subpass            = 0
           , Vk.basePipelineHandle = Vk.NULL_HANDLE
           , Vk.basePipelineIndex  = -1
           }
 
-    pipelines <- snd <$> allocate
+    snd <$> allocate
       (do
         (result, pipelines) <- Vk.createGraphicsPipelines
           logicalDevice
@@ -235,4 +241,17 @@ createGraphicsPipelines
             )
           pipelines
         )
-    return (pipelines, pipelineRenderPass)
+
+createPipelineLayout
+  :: MonadResource m
+  => Vk.Device
+  -> m Vk.PipelineLayout
+createPipelineLayout logicalDevice = do
+  let pipelineLayoutCreateInfo = Vk.zero
+
+  snd <$> allocate
+    (Vk.createPipelineLayout logicalDevice pipelineLayoutCreateInfo Nothing)
+    (\pipelineLayout -> do
+      putStrLn "destroying pipeline layout"
+      Vk.destroyPipelineLayout logicalDevice pipelineLayout Nothing
+      )

src/Init.hs

@@ -6,11 +6,8 @@ module Init where
 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
@@ -23,23 +20,11 @@ import Devices
 import GraphicsPipeline
 import Framebuffers
 import CommandBuffer
+import Types
 
 initEngine
   :: (MonadResource m, MonadFail m)
-  => m
+  => m EngineData
-    ( SDL.Window
-    , V2 CInt
-    , Vk.Device
-    , Khr.SwapchainKHR
-    , Vk.Queue
-    , V.Vector Vk.CommandBuffer
-    , V.Vector Vk.Framebuffer
-    , V.Vector Vk.Pipeline
-    , Vk.RenderPass
-    , Vk.Fence
-    , Vk.Semaphore
-    , Vk.Semaphore
-    )
 initEngine = do
   -- initialize SDL2 with all subsystems
   void $ allocate_
@@ -72,20 +57,7 @@ initEngine = do
 initVulkan
   :: (MonadResource m, MonadFail m)
   => SDL.Window
-  -> m
+  -> m EngineData
-    ( SDL.Window
-    , V2 CInt
-    , Vk.Device
-    , Khr.SwapchainKHR
-    , Vk.Queue
-    , V.Vector Vk.CommandBuffer
-    , V.Vector Vk.Framebuffer
-    , V.Vector Vk.Pipeline
-    , Vk.RenderPass
-    , Vk.Fence
-    , Vk.Semaphore
-    , Vk.Semaphore
-    )
 initVulkan window = do
 
   vulkanInstance <- createInstance window
@@ -108,15 +80,18 @@ initVulkan window = do
   imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice
   vertexShader <- loadShader vulkanLogicalDevice "shadersrc/shader.vert" "vert"
   fragmentShader <- loadShader vulkanLogicalDevice "shadersrc/shader.frag" "frag"
-  (pipelines, renderPass) <-
+  renderPass <- createRenderPass vulkanLogicalDevice (Khr.format surfaceFormat)
+  pipelineLayout <- createPipelineLayout vulkanLogicalDevice
+  let shaderContainer = ShaderContainer vertexShader fragmentShader
+  pipelines <-
     createGraphicsPipelines
       vulkanLogicalDevice
-      vertexShader
+      renderPass
-      fragmentShader
+      shaderContainer
       "main"
       dimensions
-      (Khr.format surfaceFormat)
       (length imageViews)
+      pipelineLayout
 
   frameBuffers <- createFramebuffer vulkanLogicalDevice renderPass imageViews dimensions
 
@@ -126,17 +101,17 @@ initVulkan window = do
   (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) <-
     createSyncObjects vulkanLogicalDevice
 
-  return
+  return $ EngineData
-    ( window
+    window
-    , dimensions
+    dimensions
-    , vulkanLogicalDevice
+    vulkanLogicalDevice
-    , swapchain
+    swapchain
-    , graphicsQueue
+    graphicsQueue
-    , commandBuffer
+    commandBuffer
-    , frameBuffers
+    frameBuffers
-    , pipelines
+    pipelines
-    , renderPass
+    renderPass
-    , inFlightFence
+    inFlightFence
-    , imageAvailableSemaphore
+    imageAvailableSemaphore
-    , renderFinishedSemaphore
+    renderFinishedSemaphore
-    )
+    

src/Main.hs

@@ -19,12 +19,13 @@ import qualified Vulkan.Zero as Vk
 
 import Init
 import Draw (drawFrame)
+import Types
 
 main :: IO ()
 main = runResourceT $ do
-  (window, dimensions, logicalDevice, swapchain, graphicsQueue, commandBuffers, framebuffers, pipelines, renderPass, inFlightFence, imageAvailableSemaphore, renderFinishedSemaphore) <- initEngine
+  engineData <- initEngine
 
-  SDL.showWindow window
+  SDL.showWindow $ engineWindow engineData
 
   -- create abort condition for upcoming lop
   quit <- liftIO $ STM.newTMVarIO True
@@ -35,18 +36,7 @@ main = runResourceT $ do
       )
     ( do
       -- draw
-      drawFrame
+      drawFrame engineData
-        logicalDevice
-        swapchain
-        graphicsQueue
-        commandBuffers
-        renderPass
-        framebuffers
-        dimensions
-        pipelines
-        inFlightFence
-        imageAvailableSemaphore
-        renderFinishedSemaphore
       -- poll events
       evs <- liftIO SDL.pollEvents
       -- flip abort condition on window close
@@ -59,7 +49,7 @@ main = runResourceT $ do
         evs
     )
 
-  Vk.deviceWaitIdle logicalDevice
+  Vk.deviceWaitIdle $ engineLogicalDevice engineData
 
 createBufferView
   :: (MonadResource m)

vulkan-tutorial.cabal

@@ -31,6 +31,7 @@ executable vulkan-tutorial
                       Framebuffers
                       CommandBuffer
                       Draw
+                      Types
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions: