vulkan-tutorial/src/GraphicsPipeline.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
module GraphicsPipeline where

import Linear
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource
import Data.Bits
import qualified Data.ByteString as BS
import qualified Data.Vector as V
import Foreign.C.Types (CInt)
import qualified Vulkan as Vk
import qualified Vulkan.Zero as Vk

loadShader
  :: (MonadResource m)
  => Vk.Device
  -> FilePath
  -> m Vk.ShaderModule
loadShader logicalDevice shaderPath = do
  shaderSource <- liftIO $ BS.readFile shaderPath

  let createInfo = Vk.zero
        { Vk.code = shaderSource
        }

  snd <$> allocate
    (Vk.createShaderModule logicalDevice createInfo Nothing)
    (\shaderModule -> do
      putStrLn "destroying shader module"
      Vk.destroyShaderModule logicalDevice shaderModule Nothing
      )

createGraphicsPipeline
  :: (MonadResource m)
  => Vk.ShaderModule
  -> Vk.ShaderModule
  -> BS.ByteString
  -> V2 CInt
  -> Vk.Device
  -> m Vk.Pipeline
createGraphicsPipeline
  vertexShaderModule
  fragmentShaderModule
  stageName
  (V2 width height)
  logicalDevice
  = do

    let vertexShaderStageCreateInfo = Vk.zero
          { Vk.stage   = Vk.SHADER_STAGE_VERTEX_BIT
          , Vk.module' = vertexShaderModule
          , Vk.name    = stageName
          }
        fragmentShaderStageCreateInfo = Vk.zero
          { Vk.stage   = Vk.SHADER_STAGE_FRAGMENT_BIT
          , Vk.module' = fragmentShaderModule
          , Vk.name    = stageName
          }
        pipelineStagesCreateInfos =
          V.fromList
            [ vertexShaderStageCreateInfo
            , fragmentShaderStageCreateInfo
            ]
        dynamicStates =
          V.fromList
            [ Vk.DYNAMIC_STATE_VIEWPORT
            , Vk.DYNAMIC_STATE_SCISSOR
            ]
        dynamicStateCreateInfo = Vk.zero
          { Vk.dynamicStates = dynamicStates
          }
        vertexInputCreateInfo = Vk.zero
          { Vk.vertexBindingDescriptions   = V.empty -- Fill me?
          , Vk.vertexAttributeDescriptions = V.empty -- Fill me?
          }
        inputAssemblyStateCreateInfo = Vk.zero
          { Vk.topology               = Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST
          , Vk.primitiveRestartEnable = False
          }
        viewport = Vk.Viewport
          { Vk.x        = 0
          , Vk.y        = 0
          , Vk.width    = fromIntegral width
          , Vk.height   = fromIntegral height
          , Vk.minDepth = 0
          , Vk.maxDepth = 1
          }
        scissor = Vk.Rect2D
          { Vk.offset = Vk.Offset2D 0 0
          , Vk.extent = Vk.Extent2D (fromIntegral width) (fromIntegral height)
          }
        pipelineViewportStateCreateInfo = Vk.zero
          { Vk.viewports = V.singleton viewport
          , Vk.scissors  = V.singleton scissor
          }
        pipelineRasterizationStateCreateInfo = Vk.zero
          { Vk.depthClampEnable        = False
          , Vk.rasterizerDiscardEnable = False
          , Vk.polygonMode             = Vk.POLYGON_MODE_FILL
          , Vk.lineWidth               = 1
          , Vk.cullMode                = Vk.CULL_MODE_BACK_BIT
          , Vk.frontFace               = Vk.FRONT_FACE_CLOCKWISE
          , Vk.depthBiasEnable         = False
          , Vk.depthBiasConstantFactor = 0
          , Vk.depthBiasClamp          = 0
          , Vk.depthBiasSlopeFactor    = 0
          }
        multisamplingCreateInfo = Vk.zero
          { Vk.sampleShadingEnable  = False
          , Vk.rasterizationSamples = Vk.SAMPLE_COUNT_1_BIT
          }
        colorBlendAttachment = Vk.zero
          { Vk.colorWriteMask      =
            Vk.COLOR_COMPONENT_R_BIT .|.
            Vk.COLOR_COMPONENT_G_BIT .|.
            Vk.COLOR_COMPONENT_B_BIT .|.
            Vk.COLOR_COMPONENT_A_BIT
          , Vk.blendEnable         = True
          , Vk.srcColorBlendFactor = Vk.BLEND_FACTOR_ONE
          , Vk.dstColorBlendFactor = Vk.BLEND_FACTOR_ONE_MINUS_SRC_ALPHA
          , Vk.colorBlendOp        = Vk.BLEND_OP_ADD
          , Vk.srcAlphaBlendFactor = Vk.BLEND_FACTOR_ONE
          , Vk.dstAlphaBlendFactor = Vk.BLEND_FACTOR_ZERO
          , Vk.alphaBlendOp        = Vk.BLEND_OP_ADD
          }
        colorBlendStateCreateInfo = Vk.zero
          { Vk.logicOpEnable = False
          , Vk.attachments = V.singleton colorBlendAttachment
          }
        pipelineLayoutCreateInfo = Vk.zero

    pipelineLayout <- snd <$> allocate
      (Vk.createPipelineLayout logicalDevice pipelineLayoutCreateInfo Nothing)
      (\pipelineLayout -> do
        putStrLn "destroying pipeline layout"
        Vk.destroyPipelineLayout logicalDevice pipelineLayout Nothing
        )

    error "createGraphicsPipeline: implementation invomplete"