-- XXX: TypeError in Compatible generates unused constraint argument
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Engine.Vulkan.Pipeline
  ( Pipeline(..)
  , Config(..)
  , allocate
  , bind

  , pushPlaceholder

  , vertexInput
  , attrBindings
  , formatSize
  ) where

import RIO

import Data.Bits ((.|.))
import Data.Kind (Type)
import Data.List qualified as List
import Data.Tagged (Tagged(..))
import Data.Vector qualified as Vector
import GHC.Stack (callStack, getCallStack, srcLocModule, withFrozenCallStack)
import UnliftIO.Resource (MonadResource, ReleaseKey)
import UnliftIO.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk
import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing qualified as Vk12
import Vulkan.CStruct.Extends (SomeStruct(..), pattern (:&), pattern (::&))
import Vulkan.NamedType ((:::))
import Vulkan.Utils.Debug qualified as Debug
import Vulkan.Zero (Zero(..))

import Engine.Vulkan.DescSets (Bound(..), Compatible)
import Engine.Vulkan.Types (HasVulkan(..), HasRenderPass(..), MonadVulkan, DsBindings, DsLayouts, getPipelineCache)

data Pipeline (dsl :: [Type]) vertices instances = Pipeline
  { Pipeline dsl vertices instances -> Pipeline
pipeline     :: Vk.Pipeline
  , Pipeline dsl vertices instances -> Tagged dsl PipelineLayout
pLayout      :: Tagged dsl Vk.PipelineLayout
  , Pipeline dsl vertices instances -> Tagged dsl DsLayouts
pDescLayouts :: Tagged dsl DsLayouts
  }

-- * Pipeline

data Config (dsl :: [Type]) vertices instances = Config
  { Config dsl vertices instances -> Maybe ByteString
cVertexCode         :: Maybe ByteString
  , Config dsl vertices instances -> Maybe ByteString
cFragmentCode       :: Maybe ByteString
  , Config dsl vertices instances
-> SomeStruct PipelineVertexInputStateCreateInfo
cVertexInput        :: SomeStruct Vk.PipelineVertexInputStateCreateInfo
  , Config dsl vertices instances -> Tagged dsl [DsBindings]
cDescLayouts        :: Tagged dsl [DsBindings]
  , Config dsl vertices instances -> Vector PushConstantRange
cPushConstantRanges :: Vector Vk.PushConstantRange
  , Config dsl vertices instances -> Bool
cBlend              :: Bool
  , Config dsl vertices instances -> Bool
cDepthWrite         :: Bool
  , Config dsl vertices instances -> Bool
cDepthTest          :: Bool
  , Config dsl vertices instances -> PrimitiveTopology
cTopology           :: Vk.PrimitiveTopology
  , Config dsl vertices instances -> CullModeFlagBits
cCull               :: Vk.CullModeFlagBits
  , Config dsl vertices instances
-> Maybe ("constant" ::: Float, "constant" ::: Float)
cDepthBias          :: Maybe ("constant" ::: Float, "slope" ::: Float)
  }

instance Zero (Config dsl vertices instances) where
  zero :: Config dsl vertices instances
zero = Config :: forall (dsl :: [*]) vertices instances.
Maybe ByteString
-> Maybe ByteString
-> SomeStruct PipelineVertexInputStateCreateInfo
-> Tagged dsl [DsBindings]
-> Vector PushConstantRange
-> Bool
-> Bool
-> Bool
-> PrimitiveTopology
-> CullModeFlagBits
-> Maybe ("constant" ::: Float, "constant" ::: Float)
-> Config dsl vertices instances
Config
    { $sel:cVertexCode:Config :: Maybe ByteString
cVertexCode         = Maybe ByteString
forall a. Maybe a
Nothing
    , $sel:cFragmentCode:Config :: Maybe ByteString
cFragmentCode       = Maybe ByteString
forall a. Maybe a
Nothing
    , $sel:cVertexInput:Config :: SomeStruct PipelineVertexInputStateCreateInfo
cVertexInput        = SomeStruct PipelineVertexInputStateCreateInfo
forall a. Zero a => a
zero
    , $sel:cDescLayouts:Config :: Tagged dsl [DsBindings]
cDescLayouts        = [DsBindings] -> Tagged dsl [DsBindings]
forall k (s :: k) b. b -> Tagged s b
Tagged [] -- FIXME: unsafe wrt. "dsl"
    , $sel:cPushConstantRanges:Config :: Vector PushConstantRange
cPushConstantRanges = Vector PushConstantRange
forall a. Monoid a => a
mempty
    , $sel:cBlend:Config :: Bool
cBlend              = Bool
False
    , $sel:cDepthWrite:Config :: Bool
cDepthWrite         = Bool
True
    , $sel:cDepthTest:Config :: Bool
cDepthTest          = Bool
True
    , $sel:cTopology:Config :: PrimitiveTopology
cTopology           = PrimitiveTopology
Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST
    , $sel:cCull:Config :: CullModeFlagBits
cCull               = CullModeFlagBits
Vk.CULL_MODE_BACK_BIT
    , $sel:cDepthBias:Config :: Maybe ("constant" ::: Float, "constant" ::: Float)
cDepthBias          = Maybe ("constant" ::: Float, "constant" ::: Float)
forall a. Maybe a
Nothing
    }

-- XXX: consider using instance attrs or uniforms
pushPlaceholder :: Vk.PushConstantRange
pushPlaceholder :: PushConstantRange
pushPlaceholder = PushConstantRange :: ShaderStageFlags -> Word32 -> Word32 -> PushConstantRange
Vk.PushConstantRange
  { $sel:stageFlags:PushConstantRange :: ShaderStageFlags
Vk.stageFlags = ShaderStageFlags
Vk.SHADER_STAGE_VERTEX_BIT ShaderStageFlags -> ShaderStageFlags -> ShaderStageFlags
forall a. Bits a => a -> a -> a
.|. ShaderStageFlags
Vk.SHADER_STAGE_FRAGMENT_BIT
  , $sel:offset:PushConstantRange :: Word32
Vk.offset     = Word32
0
  , $sel:size:PushConstantRange :: Word32
Vk.size       = Word32
4 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
dwords
  }
  where
    -- XXX: each 4 word32s eat up one register (on AMD)
    dwords :: Word32
dwords = Word32
4

allocate
  :: ( MonadVulkan env m
     , MonadResource m
     , HasRenderPass renderpass
     , HasCallStack
     )
  => Maybe Vk.Extent2D
  -> Vk.SampleCountFlagBits
  -> Config dsl vertices instances
  -> renderpass
  -> m (ReleaseKey, Pipeline dsl vertices instances)
allocate :: Maybe Extent2D
-> SampleCountFlagBits
-> Config dsl vertices instances
-> renderpass
-> m (ReleaseKey, Pipeline dsl vertices instances)
allocate Maybe Extent2D
extent SampleCountFlagBits
msaa Config dsl vertices instances
config renderpass
renderpass = (HasCallStack => m (ReleaseKey, Pipeline dsl vertices instances))
-> m (ReleaseKey, Pipeline dsl vertices instances)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
  env
ctx <- m env
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO (Pipeline dsl vertices instances)
-> (Pipeline dsl vertices instances -> IO ())
-> m (ReleaseKey, Pipeline dsl vertices instances)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
    (env
-> Maybe Extent2D
-> SampleCountFlagBits
-> renderpass
-> Config dsl vertices instances
-> IO (Pipeline dsl vertices instances)
forall (io :: * -> *) ctx renderpass (dsl :: [*]) vertices
       instances.
(MonadIO io, HasVulkan ctx, HasRenderPass renderpass,
 HasCallStack) =>
ctx
-> Maybe Extent2D
-> SampleCountFlagBits
-> renderpass
-> Config dsl vertices instances
-> io (Pipeline dsl vertices instances)
create env
ctx Maybe Extent2D
extent SampleCountFlagBits
msaa renderpass
renderpass Config dsl vertices instances
config)
    (env -> Pipeline dsl vertices instances -> IO ()
forall (io :: * -> *) ctx (dsl :: [*]) vertices instances.
(MonadIO io, HasVulkan ctx) =>
ctx -> Pipeline dsl vertices instances -> io ()
destroy env
ctx)

create
  :: (MonadIO io, HasVulkan ctx, HasRenderPass renderpass, HasCallStack)
  => ctx
  -> Maybe Vk.Extent2D
  -> Vk.SampleCountFlagBits
  -> renderpass
  -> Config dsl vertices instances
  -> io (Pipeline dsl vertices instances)
create :: ctx
-> Maybe Extent2D
-> SampleCountFlagBits
-> renderpass
-> Config dsl vertices instances
-> io (Pipeline dsl vertices instances)
create ctx
context Maybe Extent2D
mextent SampleCountFlagBits
msaa renderpass
renderpass Config{Bool
Maybe ("constant" ::: Float, "constant" ::: Float)
Maybe ByteString
Vector PushConstantRange
CullModeFlagBits
PrimitiveTopology
SomeStruct PipelineVertexInputStateCreateInfo
Tagged dsl [DsBindings]
cDepthBias :: Maybe ("constant" ::: Float, "constant" ::: Float)
cCull :: CullModeFlagBits
cTopology :: PrimitiveTopology
cDepthTest :: Bool
cDepthWrite :: Bool
cBlend :: Bool
cPushConstantRanges :: Vector PushConstantRange
cDescLayouts :: Tagged dsl [DsBindings]
cVertexInput :: SomeStruct PipelineVertexInputStateCreateInfo
cFragmentCode :: Maybe ByteString
cVertexCode :: Maybe ByteString
$sel:cDepthBias:Config :: forall (dsl :: [*]) vertices instances.
Config dsl vertices instances
-> Maybe ("constant" ::: Float, "constant" ::: Float)
$sel:cCull:Config :: forall (dsl :: [*]) vertices instances.
Config dsl vertices instances -> CullModeFlagBits
$sel:cTopology:Config :: forall (dsl :: [*]) vertices instances.
Config dsl vertices instances -> PrimitiveTopology
$sel:cDepthTest:Config :: forall (dsl :: [*]) vertices instances.
Config dsl vertices instances -> Bool
$sel:cDepthWrite:Config :: forall (dsl :: [*]) vertices instances.
Config dsl vertices instances -> Bool
$sel:cBlend:Config :: forall (dsl :: [*]) vertices instances.
Config dsl vertices instances -> Bool
$sel:cPushConstantRanges:Config :: forall (dsl :: [*]) vertices instances.
Config dsl vertices instances -> Vector PushConstantRange
$sel:cDescLayouts:Config :: forall (dsl :: [*]) vertices instances.
Config dsl vertices instances -> Tagged dsl [DsBindings]
$sel:cVertexInput:Config :: forall (dsl :: [*]) vertices instances.
Config dsl vertices instances
-> SomeStruct PipelineVertexInputStateCreateInfo
$sel:cFragmentCode:Config :: forall (dsl :: [*]) vertices instances.
Config dsl vertices instances -> Maybe ByteString
$sel:cVertexCode:Config :: forall (dsl :: [*]) vertices instances.
Config dsl vertices instances -> Maybe ByteString
..} = do
  let
    originModule :: ByteString
originModule =
      String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString)
-> ([String] -> String) -> [String] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"|" ([String] -> ByteString) -> [String] -> ByteString
forall a b. (a -> b) -> a -> b
$
        ((String, SrcLoc) -> String) -> [(String, SrcLoc)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (SrcLoc -> String
srcLocModule (SrcLoc -> String)
-> ((String, SrcLoc) -> SrcLoc) -> (String, SrcLoc) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd) (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack)

  DsLayouts
dsLayouts <- Vector DsBindings
-> (DsBindings -> io DescriptorSetLayout) -> io DsLayouts
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (a -> m b) -> m (Vector b)
Vector.forM ([DsBindings] -> Vector DsBindings
forall a. [a] -> Vector a
Vector.fromList ([DsBindings] -> Vector DsBindings)
-> [DsBindings] -> Vector DsBindings
forall a b. (a -> b) -> a -> b
$ Tagged dsl [DsBindings] -> [DsBindings]
forall k (s :: k) b. Tagged s b -> b
unTagged Tagged dsl [DsBindings]
cDescLayouts) \DsBindings
bindsFlags -> do
    let
      ([DescriptorSetLayoutBinding]
binds, [DescriptorBindingFlags]
flags) = DsBindings
-> ([DescriptorSetLayoutBinding], [DescriptorBindingFlags])
forall a b. [(a, b)] -> ([a], [b])
List.unzip DsBindings
bindsFlags

      setCI :: DescriptorSetLayoutCreateInfo
  '[DescriptorSetLayoutBindingFlagsCreateInfo]
setCI =
        DescriptorSetLayoutCreateInfo '[]
forall a. Zero a => a
zero
          { $sel:bindings:DescriptorSetLayoutCreateInfo :: Vector DescriptorSetLayoutBinding
Vk.bindings = [DescriptorSetLayoutBinding] -> Vector DescriptorSetLayoutBinding
forall a. [a] -> Vector a
Vector.fromList [DescriptorSetLayoutBinding]
binds
          }
        DescriptorSetLayoutCreateInfo '[]
-> Chain '[DescriptorSetLayoutBindingFlagsCreateInfo]
-> DescriptorSetLayoutCreateInfo
     '[DescriptorSetLayoutBindingFlagsCreateInfo]
forall (a :: [*] -> *) (es :: [*]) (es' :: [*]).
Extensible a =>
a es' -> Chain es -> a es
::& DescriptorSetLayoutBindingFlagsCreateInfo
forall a. Zero a => a
zero
          { $sel:bindingFlags:DescriptorSetLayoutBindingFlagsCreateInfo :: Vector DescriptorBindingFlags
Vk12.bindingFlags = [DescriptorBindingFlags] -> Vector DescriptorBindingFlags
forall a. [a] -> Vector a
Vector.fromList [DescriptorBindingFlags]
flags
          }
        DescriptorSetLayoutBindingFlagsCreateInfo
-> Chain '[] -> Chain '[DescriptorSetLayoutBindingFlagsCreateInfo]
forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ()

    Device
-> DescriptorSetLayoutCreateInfo
     '[DescriptorSetLayoutBindingFlagsCreateInfo]
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io DescriptorSetLayout
forall (a :: [*]) (io :: * -> *).
(Extendss DescriptorSetLayoutCreateInfo a, PokeChain a,
 MonadIO io) =>
Device
-> DescriptorSetLayoutCreateInfo a
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io DescriptorSetLayout
Vk.createDescriptorSetLayout Device
device DescriptorSetLayoutCreateInfo
  '[DescriptorSetLayoutBindingFlagsCreateInfo]
setCI "allocator" ::: Maybe AllocationCallbacks
forall a. Maybe a
Nothing

  -- TODO: get from outside
  PipelineLayout
layout <- Device
-> PipelineLayoutCreateInfo
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io PipelineLayout
forall (io :: * -> *).
MonadIO io =>
Device
-> PipelineLayoutCreateInfo
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io PipelineLayout
Vk.createPipelineLayout Device
device (DsLayouts -> PipelineLayoutCreateInfo
layoutCI DsLayouts
dsLayouts) "allocator" ::: Maybe AllocationCallbacks
forall a. Maybe a
Nothing
  Device -> PipelineLayout -> ByteString -> io ()
forall a (m :: * -> *).
(HasObjectType a, MonadIO m) =>
Device -> a -> ByteString -> m ()
Debug.nameObject Device
device PipelineLayout
layout ByteString
originModule

  let
    codeStages :: Vector (ShaderStageFlags, ByteString)
codeStages = [(ShaderStageFlags, ByteString)]
-> Vector (ShaderStageFlags, ByteString)
forall a. [a] -> Vector a
Vector.fromList ([(ShaderStageFlags, ByteString)]
 -> Vector (ShaderStageFlags, ByteString))
-> [(ShaderStageFlags, ByteString)]
-> Vector (ShaderStageFlags, ByteString)
forall a b. (a -> b) -> a -> b
$ case (Maybe ByteString
cVertexCode, Maybe ByteString
cFragmentCode) of
      (Just ByteString
vertCode, Just ByteString
fragCode) ->
        [ (ShaderStageFlags
Vk.SHADER_STAGE_VERTEX_BIT, ByteString
vertCode)
        , (ShaderStageFlags
Vk.SHADER_STAGE_FRAGMENT_BIT, ByteString
fragCode)
        ]

      (Just ByteString
vertCode, Maybe ByteString
Nothing) ->
        [ (ShaderStageFlags
Vk.SHADER_STAGE_VERTEX_BIT, ByteString
vertCode)
        ]

      (Maybe ByteString
Nothing, Just ByteString
fragCode) ->
        -- XXX: good luck
        [ (ShaderStageFlags
Vk.SHADER_STAGE_FRAGMENT_BIT, ByteString
fragCode)
        ]

      (Maybe ByteString
Nothing, Maybe ByteString
Nothing) ->
        []
  Shader
shader <- ctx -> Vector (ShaderStageFlags, ByteString) -> io Shader
forall (io :: * -> *) ctx.
(MonadIO io, HasVulkan ctx) =>
ctx -> Vector (ShaderStageFlags, ByteString) -> io Shader
createShader ctx
context Vector (ShaderStageFlags, ByteString)
codeStages

  let
    cis :: Vector (SomeStruct GraphicsPipelineCreateInfo)
cis = SomeStruct GraphicsPipelineCreateInfo
-> Vector (SomeStruct GraphicsPipelineCreateInfo)
forall a. a -> Vector a
Vector.singleton (SomeStruct GraphicsPipelineCreateInfo
 -> Vector (SomeStruct GraphicsPipelineCreateInfo))
-> (GraphicsPipelineCreateInfo '[]
    -> SomeStruct GraphicsPipelineCreateInfo)
-> GraphicsPipelineCreateInfo '[]
-> Vector (SomeStruct GraphicsPipelineCreateInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GraphicsPipelineCreateInfo '[]
-> SomeStruct GraphicsPipelineCreateInfo
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct (GraphicsPipelineCreateInfo '[]
 -> Vector (SomeStruct GraphicsPipelineCreateInfo))
-> GraphicsPipelineCreateInfo '[]
-> Vector (SomeStruct GraphicsPipelineCreateInfo)
forall a b. (a -> b) -> a -> b
$
      Vector (SomeStruct PipelineShaderStageCreateInfo)
-> PipelineLayout -> GraphicsPipelineCreateInfo '[]
pipelineCI (Shader -> Vector (SomeStruct PipelineShaderStageCreateInfo)
sPipelineStages Shader
shader) PipelineLayout
layout

  Device
-> PipelineCache
-> Vector (SomeStruct GraphicsPipelineCreateInfo)
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io (Result, "pipelines" ::: Vector Pipeline)
forall (io :: * -> *).
MonadIO io =>
Device
-> PipelineCache
-> Vector (SomeStruct GraphicsPipelineCreateInfo)
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io (Result, "pipelines" ::: Vector Pipeline)
Vk.createGraphicsPipelines Device
device PipelineCache
cache Vector (SomeStruct GraphicsPipelineCreateInfo)
cis "allocator" ::: Maybe AllocationCallbacks
forall a. Maybe a
Nothing io (Result, "pipelines" ::: Vector Pipeline)
-> ((Result, "pipelines" ::: Vector Pipeline)
    -> io (Pipeline dsl vertices instances))
-> io (Pipeline dsl vertices instances)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Result
Vk.SUCCESS, "pipelines" ::: Vector Pipeline
pipelines) ->
      case ("pipelines" ::: Vector Pipeline) -> [Pipeline]
forall a. Vector a -> [a]
Vector.toList "pipelines" ::: Vector Pipeline
pipelines of
        [Pipeline
one] -> do
          ctx -> Shader -> io ()
forall (io :: * -> *) ctx.
(MonadIO io, HasVulkan ctx) =>
ctx -> Shader -> io ()
destroyShader ctx
context Shader
shader
          Device -> Pipeline -> ByteString -> io ()
forall a (m :: * -> *).
(HasObjectType a, MonadIO m) =>
Device -> a -> ByteString -> m ()
Debug.nameObject Device
device Pipeline
one ByteString
originModule
          pure Pipeline :: forall (dsl :: [*]) vertices instances.
Pipeline
-> Tagged dsl PipelineLayout
-> Tagged dsl DsLayouts
-> Pipeline dsl vertices instances
Pipeline
            { $sel:pipeline:Pipeline :: Pipeline
pipeline     = Pipeline
one
            , $sel:pLayout:Pipeline :: Tagged dsl PipelineLayout
pLayout      = PipelineLayout -> Tagged dsl PipelineLayout
forall k (s :: k) b. b -> Tagged s b
Tagged PipelineLayout
layout
            , $sel:pDescLayouts:Pipeline :: Tagged dsl DsLayouts
pDescLayouts = DsLayouts -> Tagged dsl DsLayouts
forall k (s :: k) b. b -> Tagged s b
Tagged DsLayouts
dsLayouts
            }
        [Pipeline]
_ ->
          String -> io (Pipeline dsl vertices instances)
forall a. HasCallStack => String -> a
error String
"assert: exactly one pipeline requested"
    (Result
err, "pipelines" ::: Vector Pipeline
_) ->
      String -> io (Pipeline dsl vertices instances)
forall a. HasCallStack => String -> a
error (String -> io (Pipeline dsl vertices instances))
-> String -> io (Pipeline dsl vertices instances)
forall a b. (a -> b) -> a -> b
$ String
"createGraphicsPipelines: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Result -> String
forall a. Show a => a -> String
show Result
err
  where
    device :: Device
device = ctx -> Device
forall a. HasVulkan a => a -> Device
getDevice ctx
context
    cache :: PipelineCache
cache = ctx -> PipelineCache
forall ctx. ctx -> PipelineCache
getPipelineCache ctx
context

    layoutCI :: DsLayouts -> PipelineLayoutCreateInfo
layoutCI DsLayouts
dsLayouts = PipelineLayoutCreateInfo :: PipelineLayoutCreateFlags
-> DsLayouts
-> Vector PushConstantRange
-> PipelineLayoutCreateInfo
Vk.PipelineLayoutCreateInfo
      { $sel:flags:PipelineLayoutCreateInfo :: PipelineLayoutCreateFlags
flags              = PipelineLayoutCreateFlags
forall a. Zero a => a
zero
      , $sel:setLayouts:PipelineLayoutCreateInfo :: DsLayouts
setLayouts         = DsLayouts
dsLayouts
      , $sel:pushConstantRanges:PipelineLayoutCreateInfo :: Vector PushConstantRange
pushConstantRanges = Vector PushConstantRange
cPushConstantRanges
      }

    pipelineCI :: Vector (SomeStruct PipelineShaderStageCreateInfo)
-> PipelineLayout -> GraphicsPipelineCreateInfo '[]
pipelineCI Vector (SomeStruct PipelineShaderStageCreateInfo)
stages PipelineLayout
layout = GraphicsPipelineCreateInfo '[]
forall a. Zero a => a
zero
      { $sel:stages:GraphicsPipelineCreateInfo :: Vector (SomeStruct PipelineShaderStageCreateInfo)
Vk.stages             = Vector (SomeStruct PipelineShaderStageCreateInfo)
stages
      , $sel:vertexInputState:GraphicsPipelineCreateInfo :: Maybe (SomeStruct PipelineVertexInputStateCreateInfo)
Vk.vertexInputState   = SomeStruct PipelineVertexInputStateCreateInfo
-> Maybe (SomeStruct PipelineVertexInputStateCreateInfo)
forall a. a -> Maybe a
Just SomeStruct PipelineVertexInputStateCreateInfo
cVertexInput
      , $sel:inputAssemblyState:GraphicsPipelineCreateInfo :: Maybe PipelineInputAssemblyStateCreateInfo
Vk.inputAssemblyState = PipelineInputAssemblyStateCreateInfo
-> Maybe PipelineInputAssemblyStateCreateInfo
forall a. a -> Maybe a
Just PipelineInputAssemblyStateCreateInfo
inputAsembly
      , $sel:viewportState:GraphicsPipelineCreateInfo :: Maybe (SomeStruct PipelineViewportStateCreateInfo)
Vk.viewportState      = SomeStruct PipelineViewportStateCreateInfo
-> Maybe (SomeStruct PipelineViewportStateCreateInfo)
forall a. a -> Maybe a
Just (SomeStruct PipelineViewportStateCreateInfo
 -> Maybe (SomeStruct PipelineViewportStateCreateInfo))
-> SomeStruct PipelineViewportStateCreateInfo
-> Maybe (SomeStruct PipelineViewportStateCreateInfo)
forall a b. (a -> b) -> a -> b
$ PipelineViewportStateCreateInfo '[]
-> SomeStruct PipelineViewportStateCreateInfo
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct PipelineViewportStateCreateInfo '[]
viewportState
      , $sel:rasterizationState:GraphicsPipelineCreateInfo :: SomeStruct PipelineRasterizationStateCreateInfo
Vk.rasterizationState = PipelineRasterizationStateCreateInfo '[]
-> SomeStruct PipelineRasterizationStateCreateInfo
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct PipelineRasterizationStateCreateInfo '[]
rasterizationState
      , $sel:multisampleState:GraphicsPipelineCreateInfo :: Maybe (SomeStruct PipelineMultisampleStateCreateInfo)
Vk.multisampleState   = SomeStruct PipelineMultisampleStateCreateInfo
-> Maybe (SomeStruct PipelineMultisampleStateCreateInfo)
forall a. a -> Maybe a
Just (SomeStruct PipelineMultisampleStateCreateInfo
 -> Maybe (SomeStruct PipelineMultisampleStateCreateInfo))
-> SomeStruct PipelineMultisampleStateCreateInfo
-> Maybe (SomeStruct PipelineMultisampleStateCreateInfo)
forall a b. (a -> b) -> a -> b
$ PipelineMultisampleStateCreateInfo '[]
-> SomeStruct PipelineMultisampleStateCreateInfo
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct PipelineMultisampleStateCreateInfo '[]
multisampleState
      , $sel:depthStencilState:GraphicsPipelineCreateInfo :: Maybe PipelineDepthStencilStateCreateInfo
Vk.depthStencilState  = PipelineDepthStencilStateCreateInfo
-> Maybe PipelineDepthStencilStateCreateInfo
forall a. a -> Maybe a
Just PipelineDepthStencilStateCreateInfo
depthStencilState
      , $sel:colorBlendState:GraphicsPipelineCreateInfo :: Maybe (SomeStruct PipelineColorBlendStateCreateInfo)
Vk.colorBlendState    = SomeStruct PipelineColorBlendStateCreateInfo
-> Maybe (SomeStruct PipelineColorBlendStateCreateInfo)
forall a. a -> Maybe a
Just (SomeStruct PipelineColorBlendStateCreateInfo
 -> Maybe (SomeStruct PipelineColorBlendStateCreateInfo))
-> SomeStruct PipelineColorBlendStateCreateInfo
-> Maybe (SomeStruct PipelineColorBlendStateCreateInfo)
forall a b. (a -> b) -> a -> b
$ PipelineColorBlendStateCreateInfo '[]
-> SomeStruct PipelineColorBlendStateCreateInfo
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct PipelineColorBlendStateCreateInfo '[]
colorBlendState
      , $sel:dynamicState:GraphicsPipelineCreateInfo :: Maybe PipelineDynamicStateCreateInfo
Vk.dynamicState       = Maybe PipelineDynamicStateCreateInfo
dynamicState
      , $sel:layout:GraphicsPipelineCreateInfo :: PipelineLayout
Vk.layout             = PipelineLayout
layout
      , $sel:renderPass:GraphicsPipelineCreateInfo :: RenderPass
Vk.renderPass         = renderpass -> RenderPass
forall a. HasRenderPass a => a -> RenderPass
getRenderPass renderpass
renderpass
      , $sel:subpass:GraphicsPipelineCreateInfo :: Word32
Vk.subpass            = Word32
0
      , $sel:basePipelineHandle:GraphicsPipelineCreateInfo :: Pipeline
Vk.basePipelineHandle = Pipeline
forall a. Zero a => a
zero
      }
      where
        inputAsembly :: PipelineInputAssemblyStateCreateInfo
inputAsembly = PipelineInputAssemblyStateCreateInfo
forall a. Zero a => a
zero
          { $sel:topology:PipelineInputAssemblyStateCreateInfo :: PrimitiveTopology
Vk.topology               = PrimitiveTopology
cTopology
          , $sel:primitiveRestartEnable:PipelineInputAssemblyStateCreateInfo :: Bool
Vk.primitiveRestartEnable = Bool
restartable
          }

        restartable :: Bool
restartable = PrimitiveTopology -> [PrimitiveTopology] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem PrimitiveTopology
cTopology
          [ PrimitiveTopology
Vk.PRIMITIVE_TOPOLOGY_LINE_STRIP
          , PrimitiveTopology
Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_STRIP
          , PrimitiveTopology
Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_FAN
          ]

        (PipelineViewportStateCreateInfo '[]
viewportState, Maybe PipelineDynamicStateCreateInfo
dynamicState) = case Maybe Extent2D
mextent of
          Maybe Extent2D
Nothing ->
            ( PipelineViewportStateCreateInfo '[]
forall a. Zero a => a
zero
                { $sel:viewportCount:PipelineViewportStateCreateInfo :: Word32
Vk.viewportCount = Word32
1
                , $sel:scissorCount:PipelineViewportStateCreateInfo :: Word32
Vk.scissorCount = Word32
1
                }
            , PipelineDynamicStateCreateInfo
-> Maybe PipelineDynamicStateCreateInfo
forall a. a -> Maybe a
Just PipelineDynamicStateCreateInfo
forall a. Zero a => a
zero
                { $sel:dynamicStates:PipelineDynamicStateCreateInfo :: Vector DynamicState
Vk.dynamicStates = [DynamicState] -> Vector DynamicState
forall a. [a] -> Vector a
Vector.fromList
                    [ DynamicState
Vk.DYNAMIC_STATE_VIEWPORT
                    , DynamicState
Vk.DYNAMIC_STATE_SCISSOR
                    ]
                }
            )
          Just extent :: Extent2D
extent@Vk.Extent2D{Word32
$sel:width:Extent2D :: Extent2D -> Word32
width :: Word32
width, Word32
$sel:height:Extent2D :: Extent2D -> Word32
height :: Word32
height} ->
            ( PipelineViewportStateCreateInfo '[]
forall a. Zero a => a
zero
                { $sel:viewports:PipelineViewportStateCreateInfo :: Vector Viewport
Vk.viewports = [Viewport] -> Vector Viewport
forall a. [a] -> Vector a
Vector.fromList
                    [ Viewport :: ("constant" ::: Float)
-> ("constant" ::: Float)
-> ("constant" ::: Float)
-> ("constant" ::: Float)
-> ("constant" ::: Float)
-> ("constant" ::: Float)
-> Viewport
Vk.Viewport
                        { $sel:x:Viewport :: "constant" ::: Float
Vk.x        = "constant" ::: Float
0
                        , $sel:y:Viewport :: "constant" ::: Float
Vk.y        = "constant" ::: Float
0
                        , $sel:width:Viewport :: "constant" ::: Float
Vk.width    = Word32 -> "constant" ::: Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Word32
width
                        , $sel:height:Viewport :: "constant" ::: Float
Vk.height   = Word32 -> "constant" ::: Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Word32
height
                        , $sel:minDepth:Viewport :: "constant" ::: Float
Vk.minDepth = "constant" ::: Float
0
                        , $sel:maxDepth:Viewport :: "constant" ::: Float
Vk.maxDepth = "constant" ::: Float
1
                        }
                    ]
                , $sel:scissors:PipelineViewportStateCreateInfo :: Vector Rect2D
Vk.scissors = Rect2D -> Vector Rect2D
forall a. a -> Vector a
Vector.singleton Rect2D :: Offset2D -> Extent2D -> Rect2D
Vk.Rect2D
                    { $sel:offset:Rect2D :: Offset2D
Vk.offset = Int32 -> Int32 -> Offset2D
Vk.Offset2D Int32
0 Int32
0
                    , $sel:extent:Rect2D :: Extent2D
extent    = Extent2D
extent
                    }
                }
            , Maybe PipelineDynamicStateCreateInfo
forall a. Maybe a
Nothing
            )

        rasterizationState :: PipelineRasterizationStateCreateInfo '[]
rasterizationState = case Maybe ("constant" ::: Float, "constant" ::: Float)
cDepthBias of
          Maybe ("constant" ::: Float, "constant" ::: Float)
Nothing ->
            PipelineRasterizationStateCreateInfo '[]
rasterizationBase
          Just ("constant" ::: Float
constantFactor, "constant" ::: Float
slopeFactor) ->
            PipelineRasterizationStateCreateInfo '[]
rasterizationBase
              { $sel:depthBiasEnable:PipelineRasterizationStateCreateInfo :: Bool
Vk.depthBiasEnable         = Bool
True
              , $sel:depthBiasConstantFactor:PipelineRasterizationStateCreateInfo :: "constant" ::: Float
Vk.depthBiasConstantFactor = "constant" ::: Float
constantFactor
              , $sel:depthBiasSlopeFactor:PipelineRasterizationStateCreateInfo :: "constant" ::: Float
Vk.depthBiasSlopeFactor    = "constant" ::: Float
slopeFactor
              }

        rasterizationBase :: PipelineRasterizationStateCreateInfo '[]
rasterizationBase = PipelineRasterizationStateCreateInfo '[]
forall a. Zero a => a
zero
          { $sel:depthClampEnable:PipelineRasterizationStateCreateInfo :: Bool
Vk.depthClampEnable        = Bool
False
          , $sel:rasterizerDiscardEnable:PipelineRasterizationStateCreateInfo :: Bool
Vk.rasterizerDiscardEnable = Bool
False
          , $sel:lineWidth:PipelineRasterizationStateCreateInfo :: "constant" ::: Float
Vk.lineWidth               = "constant" ::: Float
1
          , $sel:polygonMode:PipelineRasterizationStateCreateInfo :: PolygonMode
Vk.polygonMode             = PolygonMode
Vk.POLYGON_MODE_FILL
          , $sel:cullMode:PipelineRasterizationStateCreateInfo :: CullModeFlagBits
Vk.cullMode                = CullModeFlagBits
cCull
          , $sel:frontFace:PipelineRasterizationStateCreateInfo :: FrontFace
Vk.frontFace               = FrontFace
Vk.FRONT_FACE_CLOCKWISE
          , $sel:depthBiasEnable:PipelineRasterizationStateCreateInfo :: Bool
Vk.depthBiasEnable         = Bool
False
          }

        multisampleState :: PipelineMultisampleStateCreateInfo '[]
multisampleState = PipelineMultisampleStateCreateInfo '[]
forall a. Zero a => a
zero
          { $sel:rasterizationSamples:PipelineMultisampleStateCreateInfo :: SampleCountFlagBits
Vk.rasterizationSamples = SampleCountFlagBits
msaa
          , $sel:sampleShadingEnable:PipelineMultisampleStateCreateInfo :: Bool
Vk.sampleShadingEnable  = Bool
enable
          , $sel:minSampleShading:PipelineMultisampleStateCreateInfo :: "constant" ::: Float
Vk.minSampleShading     = if Bool
enable then "constant" ::: Float
0.2 else "constant" ::: Float
1.0
          , $sel:sampleMask:PipelineMultisampleStateCreateInfo :: Vector Word32
Vk.sampleMask           = Word32 -> Vector Word32
forall a. a -> Vector a
Vector.singleton Word32
forall a. Bounded a => a
maxBound
          }
          where
            enable :: Bool
enable = Bool
True -- TODO: check and enable sample rate shading feature

        depthStencilState :: PipelineDepthStencilStateCreateInfo
depthStencilState = PipelineDepthStencilStateCreateInfo
forall a. Zero a => a
zero
          { $sel:depthTestEnable:PipelineDepthStencilStateCreateInfo :: Bool
Vk.depthTestEnable       = Bool
cDepthTest
          , $sel:depthWriteEnable:PipelineDepthStencilStateCreateInfo :: Bool
Vk.depthWriteEnable      = Bool
cDepthWrite
          , $sel:depthCompareOp:PipelineDepthStencilStateCreateInfo :: CompareOp
Vk.depthCompareOp        = CompareOp
Vk.COMPARE_OP_LESS
          , $sel:depthBoundsTestEnable:PipelineDepthStencilStateCreateInfo :: Bool
Vk.depthBoundsTestEnable = Bool
False
          , $sel:minDepthBounds:PipelineDepthStencilStateCreateInfo :: "constant" ::: Float
Vk.minDepthBounds        = "constant" ::: Float
0.0 -- Optional
          , $sel:maxDepthBounds:PipelineDepthStencilStateCreateInfo :: "constant" ::: Float
Vk.maxDepthBounds        = "constant" ::: Float
1.0 -- Optional
          , $sel:stencilTestEnable:PipelineDepthStencilStateCreateInfo :: Bool
Vk.stencilTestEnable     = Bool
False
          , $sel:front:PipelineDepthStencilStateCreateInfo :: StencilOpState
Vk.front                 = StencilOpState
forall a. Zero a => a
zero -- Optional
          , $sel:back:PipelineDepthStencilStateCreateInfo :: StencilOpState
Vk.back                  = StencilOpState
forall a. Zero a => a
zero -- Optional
          }

        colorBlendState :: PipelineColorBlendStateCreateInfo '[]
colorBlendState = PipelineColorBlendStateCreateInfo '[]
forall a. Zero a => a
zero
          { $sel:logicOpEnable:PipelineColorBlendStateCreateInfo :: Bool
Vk.logicOpEnable =
              Bool
False
          , $sel:attachments:PipelineColorBlendStateCreateInfo :: Vector PipelineColorBlendAttachmentState
Vk.attachments = PipelineColorBlendAttachmentState
-> Vector PipelineColorBlendAttachmentState
forall a. a -> Vector a
Vector.singleton PipelineColorBlendAttachmentState
forall a. Zero a => a
zero
              { $sel:blendEnable:PipelineColorBlendAttachmentState :: Bool
Vk.blendEnable         = Bool
cBlend
              , $sel:srcColorBlendFactor:PipelineColorBlendAttachmentState :: BlendFactor
Vk.srcColorBlendFactor = BlendFactor
Vk.BLEND_FACTOR_ONE
              , $sel:dstColorBlendFactor:PipelineColorBlendAttachmentState :: BlendFactor
Vk.dstColorBlendFactor = BlendFactor
Vk.BLEND_FACTOR_ONE_MINUS_SRC_ALPHA
              , $sel:colorBlendOp:PipelineColorBlendAttachmentState :: BlendOp
Vk.colorBlendOp        = BlendOp
Vk.BLEND_OP_ADD
              , $sel:srcAlphaBlendFactor:PipelineColorBlendAttachmentState :: BlendFactor
Vk.srcAlphaBlendFactor = BlendFactor
Vk.BLEND_FACTOR_ONE
              , $sel:dstAlphaBlendFactor:PipelineColorBlendAttachmentState :: BlendFactor
Vk.dstAlphaBlendFactor = BlendFactor
Vk.BLEND_FACTOR_ONE_MINUS_SRC_ALPHA
              , $sel:alphaBlendOp:PipelineColorBlendAttachmentState :: BlendOp
Vk.alphaBlendOp        = BlendOp
Vk.BLEND_OP_ADD
              , $sel:colorWriteMask:PipelineColorBlendAttachmentState :: ColorComponentFlags
Vk.colorWriteMask      = ColorComponentFlags
colorRgba
              }
          }

        colorRgba :: ColorComponentFlags
colorRgba =
          ColorComponentFlags
Vk.COLOR_COMPONENT_R_BIT ColorComponentFlags -> ColorComponentFlags -> ColorComponentFlags
forall a. Bits a => a -> a -> a
.|.
          ColorComponentFlags
Vk.COLOR_COMPONENT_G_BIT ColorComponentFlags -> ColorComponentFlags -> ColorComponentFlags
forall a. Bits a => a -> a -> a
.|.
          ColorComponentFlags
Vk.COLOR_COMPONENT_B_BIT ColorComponentFlags -> ColorComponentFlags -> ColorComponentFlags
forall a. Bits a => a -> a -> a
.|.
          ColorComponentFlags
Vk.COLOR_COMPONENT_A_BIT

destroy :: (MonadIO io, HasVulkan ctx) => ctx -> Pipeline dsl vertices instances -> io ()
destroy :: ctx -> Pipeline dsl vertices instances -> io ()
destroy ctx
context Pipeline{Pipeline
Tagged dsl DsLayouts
Tagged dsl PipelineLayout
pDescLayouts :: Tagged dsl DsLayouts
pLayout :: Tagged dsl PipelineLayout
pipeline :: Pipeline
$sel:pDescLayouts:Pipeline :: forall (dsl :: [*]) vertices instances.
Pipeline dsl vertices instances -> Tagged dsl DsLayouts
$sel:pLayout:Pipeline :: forall (dsl :: [*]) vertices instances.
Pipeline dsl vertices instances -> Tagged dsl PipelineLayout
$sel:pipeline:Pipeline :: forall (dsl :: [*]) vertices instances.
Pipeline dsl vertices instances -> Pipeline
..} = do
  DsLayouts -> (DescriptorSetLayout -> io ()) -> io ()
forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
Vector.forM_ (Tagged dsl DsLayouts -> DsLayouts
forall k (s :: k) b. Tagged s b -> b
unTagged Tagged dsl DsLayouts
pDescLayouts) \DescriptorSetLayout
dsLayout ->
    Device
-> DescriptorSetLayout
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ()
forall (io :: * -> *).
MonadIO io =>
Device
-> DescriptorSetLayout
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ()
Vk.destroyDescriptorSetLayout Device
device DescriptorSetLayout
dsLayout "allocator" ::: Maybe AllocationCallbacks
forall a. Maybe a
Nothing
  Device
-> Pipeline -> ("allocator" ::: Maybe AllocationCallbacks) -> io ()
forall (io :: * -> *).
MonadIO io =>
Device
-> Pipeline -> ("allocator" ::: Maybe AllocationCallbacks) -> io ()
Vk.destroyPipeline Device
device Pipeline
pipeline "allocator" ::: Maybe AllocationCallbacks
forall a. Maybe a
Nothing
  Device
-> PipelineLayout
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ()
forall (io :: * -> *).
MonadIO io =>
Device
-> PipelineLayout
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ()
Vk.destroyPipelineLayout Device
device (Tagged dsl PipelineLayout -> PipelineLayout
forall k (s :: k) b. Tagged s b -> b
unTagged Tagged dsl PipelineLayout
pLayout) "allocator" ::: Maybe AllocationCallbacks
forall a. Maybe a
Nothing
  where
    device :: Device
device = ctx -> Device
forall a. HasVulkan a => a -> Device
getDevice ctx
context

bind
  :: ( Compatible pipeLayout boundLayout
     , MonadIO m
     )
  => Vk.CommandBuffer
  -> Pipeline pipeLayout vertices instances
  -> Bound boundLayout vertices instances m ()
  -> Bound boundLayout oldVertices oldInstances m ()
bind :: CommandBuffer
-> Pipeline pipeLayout vertices instances
-> Bound boundLayout vertices instances m ()
-> Bound boundLayout oldVertices oldInstances m ()
bind CommandBuffer
cb Pipeline{Pipeline
pipeline :: Pipeline
$sel:pipeline:Pipeline :: forall (dsl :: [*]) vertices instances.
Pipeline dsl vertices instances -> Pipeline
pipeline} (Bound m ()
attrAction) = do
  m () -> Bound boundLayout oldVertices oldInstances m ()
forall (dsl :: [*]) vertices instances (m :: * -> *) a.
m a -> Bound dsl vertices instances m a
Bound (m () -> Bound boundLayout oldVertices oldInstances m ())
-> m () -> Bound boundLayout oldVertices oldInstances m ()
forall a b. (a -> b) -> a -> b
$ CommandBuffer -> PipelineBindPoint -> Pipeline -> m ()
forall (io :: * -> *).
MonadIO io =>
CommandBuffer -> PipelineBindPoint -> Pipeline -> io ()
Vk.cmdBindPipeline CommandBuffer
cb PipelineBindPoint
Vk.PIPELINE_BIND_POINT_GRAPHICS Pipeline
pipeline
  m () -> Bound boundLayout oldVertices oldInstances m ()
forall (dsl :: [*]) vertices instances (m :: * -> *) a.
m a -> Bound dsl vertices instances m a
Bound m ()
attrAction

vertexInput :: [(Vk.VertexInputRate, [Vk.Format])] -> SomeStruct Vk.PipelineVertexInputStateCreateInfo
vertexInput :: [(VertexInputRate, [Format])]
-> SomeStruct PipelineVertexInputStateCreateInfo
vertexInput [(VertexInputRate, [Format])]
bindings = PipelineVertexInputStateCreateInfo '[]
-> SomeStruct PipelineVertexInputStateCreateInfo
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct PipelineVertexInputStateCreateInfo '[]
forall a. Zero a => a
zero
  { $sel:vertexBindingDescriptions:PipelineVertexInputStateCreateInfo :: Vector VertexInputBindingDescription
Vk.vertexBindingDescriptions   = Vector VertexInputBindingDescription
binds
  , $sel:vertexAttributeDescriptions:PipelineVertexInputStateCreateInfo :: Vector VertexInputAttributeDescription
Vk.vertexAttributeDescriptions = Vector VertexInputAttributeDescription
attrs
  }
  where
    binds :: Vector VertexInputBindingDescription
binds = [VertexInputBindingDescription]
-> Vector VertexInputBindingDescription
forall a. [a] -> Vector a
Vector.fromList do
      (Word32
ix, (VertexInputRate
rate, [Format]
formats)) <- [Word32]
-> [(VertexInputRate, [Format])]
-> [(Word32, (VertexInputRate, [Format]))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
0..] [(VertexInputRate, [Format])]
bindings
      VertexInputBindingDescription -> [VertexInputBindingDescription]
forall (f :: * -> *) a. Applicative f => a -> f a
pure VertexInputBindingDescription :: Word32
-> Word32 -> VertexInputRate -> VertexInputBindingDescription
Vk.VertexInputBindingDescription
        { $sel:binding:VertexInputBindingDescription :: Word32
binding   = Word32
ix
        , $sel:stride:VertexInputBindingDescription :: Word32
stride    = [Word32] -> Word32
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Word32] -> Word32) -> [Word32] -> Word32
forall a b. (a -> b) -> a -> b
$ (Format -> Word32) -> [Format] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
map Format -> Word32
forall a. Integral a => Format -> a
formatSize [Format]
formats
        , $sel:inputRate:VertexInputBindingDescription :: VertexInputRate
inputRate = VertexInputRate
rate
        }

    attrs :: Vector VertexInputAttributeDescription
attrs = [[Format]] -> Vector VertexInputAttributeDescription
attrBindings ([[Format]] -> Vector VertexInputAttributeDescription)
-> [[Format]] -> Vector VertexInputAttributeDescription
forall a b. (a -> b) -> a -> b
$ ((VertexInputRate, [Format]) -> [Format])
-> [(VertexInputRate, [Format])] -> [[Format]]
forall a b. (a -> b) -> [a] -> [b]
map (VertexInputRate, [Format]) -> [Format]
forall a b. (a, b) -> b
snd [(VertexInputRate, [Format])]
bindings

-- * Shader code

data Shader = Shader
  { Shader -> Vector ShaderModule
sModules        :: Vector Vk.ShaderModule
  , Shader -> Vector (SomeStruct PipelineShaderStageCreateInfo)
sPipelineStages :: Vector (SomeStruct Vk.PipelineShaderStageCreateInfo)
  }

createShader
  :: (MonadIO io, HasVulkan ctx)
  => ctx
  -> Vector (Vk.ShaderStageFlagBits, ByteString)
  -> io Shader
createShader :: ctx -> Vector (ShaderStageFlags, ByteString) -> io Shader
createShader ctx
context Vector (ShaderStageFlags, ByteString)
stages = do
  Vector (ShaderModule, SomeStruct PipelineShaderStageCreateInfo)
staged <- Vector (ShaderStageFlags, ByteString)
-> ((ShaderStageFlags, ByteString)
    -> io (ShaderModule, SomeStruct PipelineShaderStageCreateInfo))
-> io
     (Vector (ShaderModule, SomeStruct PipelineShaderStageCreateInfo))
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (a -> m b) -> m (Vector b)
Vector.forM Vector (ShaderStageFlags, ByteString)
stages \(ShaderStageFlags
stage, ByteString
code) -> do
    ShaderModule
module_ <- Device
-> ShaderModuleCreateInfo '[]
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ShaderModule
forall (a :: [*]) (io :: * -> *).
(Extendss ShaderModuleCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> ShaderModuleCreateInfo a
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ShaderModule
Vk.createShaderModule
      (ctx -> Device
forall a. HasVulkan a => a -> Device
getDevice ctx
context)
      ShaderModuleCreateInfo '[]
forall a. Zero a => a
zero
        { $sel:code:ShaderModuleCreateInfo :: ByteString
Vk.code = ByteString
code
        }
      "allocator" ::: Maybe AllocationCallbacks
forall a. Maybe a
Nothing
    pure
      ( ShaderModule
module_
      , PipelineShaderStageCreateInfo '[]
-> SomeStruct PipelineShaderStageCreateInfo
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct PipelineShaderStageCreateInfo '[]
forall a. Zero a => a
zero
          { $sel:stage:PipelineShaderStageCreateInfo :: ShaderStageFlags
Vk.stage   = ShaderStageFlags
stage
          , $sel:module':PipelineShaderStageCreateInfo :: ShaderModule
Vk.module' = ShaderModule
module_
          , $sel:name:PipelineShaderStageCreateInfo :: ByteString
Vk.name    = ByteString
"main"
          -- , Vk.specializationInfo = Nothing
          }
      )
  let (Vector ShaderModule
modules, Vector (SomeStruct PipelineShaderStageCreateInfo)
pStages) = Vector (ShaderModule, SomeStruct PipelineShaderStageCreateInfo)
-> (Vector ShaderModule,
    Vector (SomeStruct PipelineShaderStageCreateInfo))
forall a b. Vector (a, b) -> (Vector a, Vector b)
Vector.unzip Vector (ShaderModule, SomeStruct PipelineShaderStageCreateInfo)
staged
  Shader -> io Shader
forall (f :: * -> *) a. Applicative f => a -> f a
pure Shader :: Vector ShaderModule
-> Vector (SomeStruct PipelineShaderStageCreateInfo) -> Shader
Shader
    { $sel:sModules:Shader :: Vector ShaderModule
sModules        = Vector ShaderModule
modules
    , $sel:sPipelineStages:Shader :: Vector (SomeStruct PipelineShaderStageCreateInfo)
sPipelineStages = Vector (SomeStruct PipelineShaderStageCreateInfo)
pStages
    }

destroyShader :: (MonadIO io, HasVulkan ctx) => ctx -> Shader -> io ()
destroyShader :: ctx -> Shader -> io ()
destroyShader ctx
context Shader{Vector ShaderModule
sModules :: Vector ShaderModule
$sel:sModules:Shader :: Shader -> Vector ShaderModule
sModules} =
  Vector ShaderModule -> (ShaderModule -> io ()) -> io ()
forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
Vector.forM_ Vector ShaderModule
sModules \ShaderModule
module_ ->
    Device
-> ShaderModule
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ()
forall (io :: * -> *).
MonadIO io =>
Device
-> ShaderModule
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ()
Vk.destroyShaderModule (ctx -> Device
forall a. HasVulkan a => a -> Device
getDevice ctx
context) ShaderModule
module_ "allocator" ::: Maybe AllocationCallbacks
forall a. Maybe a
Nothing

-- * Utils

attrBindings :: [[Vk.Format]] -> Vector Vk.VertexInputAttributeDescription
attrBindings :: [[Format]] -> Vector VertexInputAttributeDescription
attrBindings [[Format]]
bindings = [Vector VertexInputAttributeDescription]
-> Vector VertexInputAttributeDescription
forall a. Monoid a => [a] -> a
mconcat ([Vector VertexInputAttributeDescription]
 -> Vector VertexInputAttributeDescription)
-> [Vector VertexInputAttributeDescription]
-> Vector VertexInputAttributeDescription
forall a b. (a -> b) -> a -> b
$ ((Word32, Int, [[Format]])
 -> Maybe
      (Vector VertexInputAttributeDescription,
       (Word32, Int, [[Format]])))
-> (Word32, Int, [[Format]])
-> [Vector VertexInputAttributeDescription]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
List.unfoldr (Word32, Int, [[Format]])
-> Maybe
     (Vector VertexInputAttributeDescription, (Word32, Int, [[Format]]))
shiftLocations (Word32
0, Int
0, [[Format]]
bindings)
  where
    shiftLocations :: (Word32, Int, [[Format]])
-> Maybe
     (Vector VertexInputAttributeDescription, (Word32, Int, [[Format]]))
shiftLocations = \case
      (Word32
_binding, Int
_lastLoc, [])           -> Maybe
  (Vector VertexInputAttributeDescription, (Word32, Int, [[Format]]))
forall a. Maybe a
Nothing
      (Word32
binding, Int
lastLoc, [Format]
formats : [[Format]]
rest) -> (Vector VertexInputAttributeDescription, (Word32, Int, [[Format]]))
-> Maybe
     (Vector VertexInputAttributeDescription, (Word32, Int, [[Format]]))
forall a. a -> Maybe a
Just (Vector VertexInputAttributeDescription
bound, (Word32, Int, [[Format]])
next)
        where
          bound :: Vector VertexInputAttributeDescription
bound = [VertexInputAttributeDescription]
-> Vector VertexInputAttributeDescription
forall a. [a] -> Vector a
Vector.fromList do
            (Int
ix, Format
format) <- [Int] -> [Format] -> [(Int, Format)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Format]
formats
            let offset :: Word32
offset = [Word32] -> Word32
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Word32] -> Word32)
-> ([Format] -> [Word32]) -> [Format] -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Format -> Word32) -> [Format] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
map Format -> Word32
forall a. Integral a => Format -> a
formatSize ([Format] -> Word32) -> [Format] -> Word32
forall a b. (a -> b) -> a -> b
$ Int -> [Format] -> [Format]
forall a. Int -> [a] -> [a]
take Int
ix [Format]
formats
            VertexInputAttributeDescription
-> [VertexInputAttributeDescription]
forall (f :: * -> *) a. Applicative f => a -> f a
pure VertexInputAttributeDescription
forall a. Zero a => a
zero
              { $sel:binding:VertexInputAttributeDescription :: Word32
Vk.binding  = Word32
binding
              , $sel:location:VertexInputAttributeDescription :: Word32
Vk.location = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int
lastLoc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ix
              , $sel:format:VertexInputAttributeDescription :: Format
Vk.format   = Format
format
              , $sel:offset:VertexInputAttributeDescription :: Word32
Vk.offset   = Word32
offset
              }

          next :: (Word32, Int, [[Format]])
next =
            ( Word32
binding Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1
            , Int
lastLoc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Vector VertexInputAttributeDescription -> Int
forall a. Vector a -> Int
Vector.length Vector VertexInputAttributeDescription
bound
            , [[Format]]
rest
            )

formatSize :: Integral a => Vk.Format -> a
formatSize :: Format -> a
formatSize = \case
  Format
Vk.FORMAT_R32G32B32A32_SFLOAT -> a
16
  Format
Vk.FORMAT_R32G32B32_SFLOAT    -> a
12
  Format
Vk.FORMAT_R32G32_SFLOAT       -> a
8
  Format
Vk.FORMAT_R32_SFLOAT          -> a
4

  Format
Vk.FORMAT_R32G32B32A32_UINT -> a
16
  Format
Vk.FORMAT_R32G32B32_UINT    -> a
12
  Format
Vk.FORMAT_R32G32_UINT       -> a
8
  Format
Vk.FORMAT_R32_UINT          -> a
4

  Format
Vk.FORMAT_R32G32B32A32_SINT -> a
16
  Format
Vk.FORMAT_R32G32B32_SINT    -> a
12
  Format
Vk.FORMAT_R32G32_SINT       -> a
8
  Format
Vk.FORMAT_R32_SINT          -> a
4

  Format
format ->
    String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Format size unknown: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Format -> String
forall a. Show a => a -> String
show Format
format