add the module

src/CommandBuffer.hs

@@ -0,0 +1,122 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE DataKinds #-}
+module CommandBuffer where
+
+import Control.Monad
+import Control.Monad.Loops
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Resource
+import Data.Bits
+import qualified Data.Vector as V
+import Data.Word
+import Foreign.C.Types (CInt)
+import Linear
+import qualified SDL hiding (V2)
+import qualified Control.Concurrent.STM as STM
+import qualified Vulkan as Vk
+import qualified Vulkan.Zero as Vk
+
+-- internal imports
+
+import Devices
+import qualified Vulkan.Dynamic as Vk
+
+createCommandPool
+  :: (MonadResource m)
+  => Vk.PhysicalDevice
+  -> Vk.Device
+  -> m Vk.CommandPool
+createCommandPool physicalDevice logicalDevice = do
+
+  queueFamilyIndex <- getQueueFamily physicalDevice Vk.QUEUE_GRAPHICS_BIT
+
+  let poolCreateInfo = Vk.zero
+        { Vk.flags            = Vk.COMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BIT
+        , Vk.queueFamilyIndex = queueFamilyIndex
+        } :: Vk.CommandPoolCreateInfo
+
+  snd <$> allocate
+    (Vk.createCommandPool logicalDevice poolCreateInfo Nothing)
+    (\commandPool -> do
+      putStrLn "destroying comman pool"
+      Vk.destroyCommandPool logicalDevice commandPool Nothing
+      )
+
+createCommandBuffer
+  :: (MonadResource m)
+  => Vk.CommandPool
+  -> Vk.Device
+  -> m (V.Vector Vk.CommandBuffer)
+createCommandBuffer commandPool logicalDevice = do
+
+  let commandBufferAllocationInfo = Vk.zero
+        { Vk.commandPool        = commandPool
+        , Vk.level              = Vk.COMMAND_BUFFER_LEVEL_PRIMARY
+        , Vk.commandBufferCount = 1
+        }
+
+  Vk.allocateCommandBuffers logicalDevice commandBufferAllocationInfo
+
+recordCommandBuffer
+  :: (MonadResource m)
+  => Vk.CommandBuffer
+  -> Vk.RenderPass
+  -> Vk.Framebuffer
+  -> V2 CInt
+  -> Vk.Pipeline
+  -> m ()
+recordCommandBuffer commandBuffer renderPass frameBuffer (V2 width height) graphicsPipeline = do
+
+  let commandBufferBeginInfo = Vk.zero
+        { Vk.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT
+        , Vk.inheritanceInfo = Nothing
+        }
+
+  Vk.beginCommandBuffer commandBuffer commandBufferBeginInfo
+
+  let renderPassInfo = Vk.zero
+        { Vk.renderPass  = renderPass
+        , Vk.framebuffer = frameBuffer
+        , Vk.renderArea  = Vk.Rect2D
+          { offset = Vk.Offset2D
+            { Vk.x = 0
+            , Vk.y = 0
+            }
+          , extent = Vk.Extent2D
+            { Vk.width  = fromIntegral width
+            , Vk.height = fromIntegral height
+            }
+          }
+        , Vk.clearValues = V.singleton (Vk.Color $ Vk.Float32 0 0 0 1)
+        }
+
+  Vk.cmdBeginRenderPass commandBuffer renderPassInfo Vk.SUBPASS_CONTENTS_INLINE
+
+  Vk.cmdBindPipeline commandBuffer Vk.PIPELINE_BIND_POINT_GRAPHICS graphicsPipeline
+
+  let viewport = Vk.zero
+        { Vk.x        = 0
+        , Vk.y        = 0
+        , Vk.width    = fromIntegral width
+        , Vk.height   = fromIntegral height
+        , Vk.minDepth = 0
+        , Vk.maxDepth = 0
+        }
+      scissor = Vk.Rect2D
+        { Vk.offset = Vk.Offset2D
+          { Vk.x = 0
+          , Vk.y = 0
+          }
+        , Vk.extent = Vk.Extent2D
+          { Vk.width = fromIntegral width
+          , Vk.height = fromIntegral height
+          }
+        }
+
+  Vk.cmdSetViewport commandBuffer 0 (V.singleton viewport)
+  Vk.cmdSetScissor commandBuffer 0 (V.singleton scissor)
+
+  Vk.cmdDraw commandBuffer 3 1 0 0
+
+  Vk.cmdEndRenderPass commandBuffer