{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE UndecidableInstances #-}

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

module Engine.Vulkan.Pipeline.Graphics
  ( Config(..)
  , baseConfig

  , Configure
  , Pipeline.Specialization

  , vertexInput
  , formatSize
  , pushPlaceholder

  , Stages(..)
  , stageNames
  , stageFlagBits
  , basicStages
  , vertexOnly
  , StageCode
  , StageSpirv
  , StageReflect

  , Pipeline(..)
  , allocate
  , create
  , Pipeline.destroy

  , bind
  ) 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.Generics (Generic1)
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.SpirV.Reflect (Reflect)
import Engine.Vulkan.DescSets (Bound(..), Compatible)
import Engine.Vulkan.Pipeline (Pipeline(..))
import Engine.Vulkan.Pipeline qualified as Pipeline
import Engine.Vulkan.Pipeline.Stages (StageInfo(..))
import Engine.Vulkan.Shader qualified as Shader
import Engine.Vulkan.Types (HasVulkan(..), HasRenderPass(..), MonadVulkan, DsBindings, getPipelineCache)
import Render.Code (Code)
import Resource.Collection (Generically1(..))

data Stages a = Stages
  { forall a. Stages a -> a
vert :: a -- ^ vertex
  , forall a. Stages a -> a
tesc :: a -- ^ tessellation control
  , forall a. Stages a -> a
tese :: a -- ^ tessellation evaluation
  , forall a. Stages a -> a
geom :: a -- ^ geometry
  , forall a. Stages a -> a
frag :: a -- ^ fragment
  }
  deriving (Stages a -> Stages a -> Bool
forall a. Eq a => Stages a -> Stages a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Stages a -> Stages a -> Bool
$c/= :: forall a. Eq a => Stages a -> Stages a -> Bool
== :: Stages a -> Stages a -> Bool
$c== :: forall a. Eq a => Stages a -> Stages a -> Bool
Eq, Stages a -> Stages a -> Bool
Stages a -> Stages a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Stages a)
forall a. Ord a => Stages a -> Stages a -> Bool
forall a. Ord a => Stages a -> Stages a -> Ordering
forall a. Ord a => Stages a -> Stages a -> Stages a
min :: Stages a -> Stages a -> Stages a
$cmin :: forall a. Ord a => Stages a -> Stages a -> Stages a
max :: Stages a -> Stages a -> Stages a
$cmax :: forall a. Ord a => Stages a -> Stages a -> Stages a
>= :: Stages a -> Stages a -> Bool
$c>= :: forall a. Ord a => Stages a -> Stages a -> Bool
> :: Stages a -> Stages a -> Bool
$c> :: forall a. Ord a => Stages a -> Stages a -> Bool
<= :: Stages a -> Stages a -> Bool
$c<= :: forall a. Ord a => Stages a -> Stages a -> Bool
< :: Stages a -> Stages a -> Bool
$c< :: forall a. Ord a => Stages a -> Stages a -> Bool
compare :: Stages a -> Stages a -> Ordering
$ccompare :: forall a. Ord a => Stages a -> Stages a -> Ordering
Ord, Int -> Stages a -> ShowS
forall a. Show a => Int -> Stages a -> ShowS
forall a. Show a => [Stages a] -> ShowS
forall a. Show a => Stages a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Stages a] -> ShowS
$cshowList :: forall a. Show a => [Stages a] -> ShowS
show :: Stages a -> String
$cshow :: forall a. Show a => Stages a -> String
showsPrec :: Int -> Stages a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Stages a -> ShowS
Show, forall a b. a -> Stages b -> Stages a
forall a b. (a -> b) -> Stages a -> Stages b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Stages b -> Stages a
$c<$ :: forall a b. a -> Stages b -> Stages a
fmap :: forall a b. (a -> b) -> Stages a -> Stages b
$cfmap :: forall a b. (a -> b) -> Stages a -> Stages b
Functor, forall a. Eq a => a -> Stages a -> Bool
forall a. Num a => Stages a -> a
forall a. Ord a => Stages a -> a
forall m. Monoid m => Stages m -> m
forall a. Stages a -> Bool
forall a. Stages a -> Int
forall a. Stages a -> [a]
forall a. (a -> a -> a) -> Stages a -> a
forall m a. Monoid m => (a -> m) -> Stages a -> m
forall b a. (b -> a -> b) -> b -> Stages a -> b
forall a b. (a -> b -> b) -> b -> Stages a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Stages a -> a
$cproduct :: forall a. Num a => Stages a -> a
sum :: forall a. Num a => Stages a -> a
$csum :: forall a. Num a => Stages a -> a
minimum :: forall a. Ord a => Stages a -> a
$cminimum :: forall a. Ord a => Stages a -> a
maximum :: forall a. Ord a => Stages a -> a
$cmaximum :: forall a. Ord a => Stages a -> a
elem :: forall a. Eq a => a -> Stages a -> Bool
$celem :: forall a. Eq a => a -> Stages a -> Bool
length :: forall a. Stages a -> Int
$clength :: forall a. Stages a -> Int
null :: forall a. Stages a -> Bool
$cnull :: forall a. Stages a -> Bool
toList :: forall a. Stages a -> [a]
$ctoList :: forall a. Stages a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Stages a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Stages a -> a
foldr1 :: forall a. (a -> a -> a) -> Stages a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Stages a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Stages a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Stages a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Stages a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Stages a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Stages a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Stages a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Stages a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Stages a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Stages a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Stages a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Stages a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Stages a -> m
fold :: forall m. Monoid m => Stages m -> m
$cfold :: forall m. Monoid m => Stages m -> m
Foldable, Functor Stages
Foldable Stages
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Stages (m a) -> m (Stages a)
forall (f :: * -> *) a.
Applicative f =>
Stages (f a) -> f (Stages a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Stages a -> m (Stages b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Stages a -> f (Stages b)
sequence :: forall (m :: * -> *) a. Monad m => Stages (m a) -> m (Stages a)
$csequence :: forall (m :: * -> *) a. Monad m => Stages (m a) -> m (Stages a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Stages a -> m (Stages b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Stages a -> m (Stages b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Stages (f a) -> f (Stages a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Stages (f a) -> f (Stages a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Stages a -> f (Stages b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Stages a -> f (Stages b)
Traversable, forall a. Rep1 Stages a -> Stages a
forall a. Stages a -> Rep1 Stages a
forall k (f :: k -> *).
(forall (a :: k). f a -> Rep1 f a)
-> (forall (a :: k). Rep1 f a -> f a) -> Generic1 f
$cto1 :: forall a. Rep1 Stages a -> Stages a
$cfrom1 :: forall a. Stages a -> Rep1 Stages a
Generic1)
  deriving Functor Stages
forall a. a -> Stages a
forall a b. Stages a -> Stages b -> Stages a
forall a b. Stages a -> Stages b -> Stages b
forall a b. Stages (a -> b) -> Stages a -> Stages b
forall a b c. (a -> b -> c) -> Stages a -> Stages b -> Stages c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Stages a -> Stages b -> Stages a
$c<* :: forall a b. Stages a -> Stages b -> Stages a
*> :: forall a b. Stages a -> Stages b -> Stages b
$c*> :: forall a b. Stages a -> Stages b -> Stages b
liftA2 :: forall a b c. (a -> b -> c) -> Stages a -> Stages b -> Stages c
$cliftA2 :: forall a b c. (a -> b -> c) -> Stages a -> Stages b -> Stages c
<*> :: forall a b. Stages (a -> b) -> Stages a -> Stages b
$c<*> :: forall a b. Stages (a -> b) -> Stages a -> Stages b
pure :: forall a. a -> Stages a
$cpure :: forall a. a -> Stages a
Applicative via (Generically1 Stages)

instance StageInfo Stages where
  stageNames :: forall label. IsString label => Stages label
stageNames = Stages
    { $sel:vert:Stages :: label
vert = label
"vert"
    , $sel:tesc:Stages :: label
tesc = label
"tesc"
    , $sel:tese:Stages :: label
tese = label
"tese"
    , $sel:geom:Stages :: label
geom = label
"geom"
    , $sel:frag:Stages :: label
frag = label
"frag"
    }

  stageFlagBits :: Stages ShaderStageFlags
stageFlagBits = Stages
    { $sel:vert:Stages :: ShaderStageFlags
vert = ShaderStageFlags
Vk.SHADER_STAGE_VERTEX_BIT
    , $sel:tesc:Stages :: ShaderStageFlags
tesc = ShaderStageFlags
Vk.SHADER_STAGE_TESSELLATION_CONTROL_BIT
    , $sel:tese:Stages :: ShaderStageFlags
tese = ShaderStageFlags
Vk.SHADER_STAGE_TESSELLATION_EVALUATION_BIT
    , $sel:geom:Stages :: ShaderStageFlags
geom = ShaderStageFlags
Vk.SHADER_STAGE_GEOMETRY_BIT
    , $sel:frag:Stages :: ShaderStageFlags
frag = ShaderStageFlags
Vk.SHADER_STAGE_FRAGMENT_BIT
    }

basicStages
  :: "vert" ::: a
  -> "frag" ::: a
  -> Stages (Maybe a)
basicStages :: forall a.
("vert" ::: a) -> ("vert" ::: a) -> Stages (Maybe ("vert" ::: a))
basicStages "vert" ::: a
v "vert" ::: a
f = (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
  { $sel:vert:Stages :: Maybe ("vert" ::: a)
vert = forall a. a -> Maybe a
Just "vert" ::: a
v
  , $sel:frag:Stages :: Maybe ("vert" ::: a)
frag = forall a. a -> Maybe a
Just "vert" ::: a
f
  }

vertexOnly
  :: "vert" ::: a
  -> Stages (Maybe a)
vertexOnly :: forall a. ("vert" ::: a) -> Stages (Maybe ("vert" ::: a))
vertexOnly "vert" ::: a
v = (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
  { $sel:vert:Stages :: Maybe ("vert" ::: a)
vert = forall a. a -> Maybe a
Just "vert" ::: a
v
  }

type StageCode = Stages (Maybe Code)
type StageSpirv = Stages (Maybe ByteString)
type StageReflect = Reflect Stages

type family Configure pipeline where
  Configure (Pipeline dsl vertices instances) =
    Config
      dsl
      vertices
      instances
      (Pipeline.Specialization (Pipeline dsl vertices instances))

data Config (dsl :: [Type]) vertices instances spec = Config
  { forall (dsl :: [*]) vertices instances spec.
Config dsl vertices instances spec -> StageSpirv
cStages             :: StageSpirv
  , forall (dsl :: [*]) vertices instances spec.
Config dsl vertices instances spec -> Maybe StageReflect
cReflect            :: Maybe StageReflect
  , forall (dsl :: [*]) vertices instances spec.
Config dsl vertices instances spec
-> SomeStruct PipelineVertexInputStateCreateInfo
cVertexInput        :: SomeStruct Vk.PipelineVertexInputStateCreateInfo
  , forall (dsl :: [*]) vertices instances spec.
Config dsl vertices instances spec -> Tagged dsl [DsBindings]
cDescLayouts        :: Tagged dsl [DsBindings]
  , forall (dsl :: [*]) vertices instances spec.
Config dsl vertices instances spec -> Vector PushConstantRange
cPushConstantRanges :: Vector Vk.PushConstantRange
  , forall (dsl :: [*]) vertices instances spec.
Config dsl vertices instances spec -> Bool
cBlend              :: Bool
  , forall (dsl :: [*]) vertices instances spec.
Config dsl vertices instances spec -> Bool
cDepthWrite         :: Bool
  , forall (dsl :: [*]) vertices instances spec.
Config dsl vertices instances spec -> Bool
cDepthTest          :: Bool
  , forall (dsl :: [*]) vertices instances spec.
Config dsl vertices instances spec -> CompareOp
cDepthCompare       :: Vk.CompareOp
  , forall (dsl :: [*]) vertices instances spec.
Config dsl vertices instances spec -> PrimitiveTopology
cTopology           :: Vk.PrimitiveTopology
  , forall (dsl :: [*]) vertices instances spec.
Config dsl vertices instances spec -> CullModeFlagBits
cCull               :: Vk.CullModeFlagBits
  , forall (dsl :: [*]) vertices instances spec.
Config dsl vertices instances spec
-> Maybe ("constant" ::: Float, "constant" ::: Float)
cDepthBias          :: Maybe ("constant" ::: Float, "slope" ::: Float)
  , forall (dsl :: [*]) vertices instances spec.
Config dsl vertices instances spec -> spec
cSpecialization     :: spec
  }

-- | Settings for generic triangle-rendering pipeline.
baseConfig :: Config '[] vertices instances ()
baseConfig :: forall vertices instances. Config '[] vertices instances ()
baseConfig = Config
  { $sel:cStages:Config :: StageSpirv
cStages             = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  , $sel:cVertexInput:Config :: SomeStruct PipelineVertexInputStateCreateInfo
cVertexInput        = forall a. Zero a => a
zero
  , $sel:cReflect:Config :: Maybe StageReflect
cReflect            = forall a. Maybe a
Nothing
  , $sel:cDescLayouts:Config :: Tagged '[] [DsBindings]
cDescLayouts        = forall {k} (s :: k) b. b -> Tagged s b
Tagged []
  , $sel:cPushConstantRanges:Config :: Vector PushConstantRange
cPushConstantRanges = 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:cDepthCompare:Config :: CompareOp
cDepthCompare       = CompareOp
Vk.COMPARE_OP_LESS
  , $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          = forall a. Maybe a
Nothing
  , $sel:cSpecialization:Config :: ()
cSpecialization     = ()
  }

-- XXX: consider using instance attrs or uniforms
pushPlaceholder :: Vk.PushConstantRange
pushPlaceholder :: PushConstantRange
pushPlaceholder = Vk.PushConstantRange
  { $sel:stageFlags:PushConstantRange :: ShaderStageFlags
Vk.stageFlags = ShaderStageFlags
Vk.SHADER_STAGE_VERTEX_BIT 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 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
  :: ( config ~ Configure pipeline
     , pipeline ~ Pipeline dsl vertices instances
     , spec ~ Pipeline.Specialization pipeline
     , Shader.Specialization spec
     , HasCallStack
     , MonadVulkan env m
     , MonadResource m
     , HasRenderPass renderpass
     )
  => Maybe Vk.Extent2D
  -> Vk.SampleCountFlagBits
  -> Config dsl vertices instances spec
  -> renderpass
  -> m (ReleaseKey, pipeline)
allocate :: forall config pipeline (dsl :: [*]) vertices instances spec env
       (m :: * -> *) renderpass.
(config ~ Configure pipeline,
 pipeline ~ Pipeline dsl vertices instances,
 spec ~ Specialization pipeline, Specialization spec, HasCallStack,
 MonadVulkan env m, MonadResource m, HasRenderPass renderpass) =>
Maybe Extent2D
-> SampleCountFlagBits
-> Config dsl vertices instances spec
-> renderpass
-> m (ReleaseKey, pipeline)
allocate Maybe Extent2D
extent SampleCountFlagBits
msaa Config dsl vertices instances spec
config renderpass
renderpass = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
  env
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
    (forall (io :: * -> *) ctx renderpass spec (dsl :: [*]) vertices
       instances.
(MonadUnliftIO io, HasVulkan ctx, HasRenderPass renderpass,
 Specialization spec, HasCallStack) =>
ctx
-> Maybe Extent2D
-> SampleCountFlagBits
-> renderpass
-> Config dsl vertices instances spec
-> io (Pipeline dsl vertices instances)
create env
ctx Maybe Extent2D
extent SampleCountFlagBits
msaa renderpass
renderpass Config dsl vertices instances spec
config)
    (forall (io :: * -> *) ctx (dsl :: [*]) vertices instances.
(MonadIO io, HasVulkan ctx) =>
ctx -> Pipeline dsl vertices instances -> io ()
Pipeline.destroy env
ctx)

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

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

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

    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 forall a. Maybe a
Nothing

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

  Shader
shader <- forall spec (m :: * -> *) a.
(Specialization spec, MonadUnliftIO m) =>
spec -> (Maybe SpecializationInfo -> m a) -> m a
Shader.withSpecialization spec
cSpecialization forall a b. (a -> b) -> a -> b
$
    forall (io :: * -> *) ctx (t :: * -> *).
(MonadIO io, HasVulkan ctx, StageInfo t) =>
ctx
-> t (Maybe ByteString) -> Maybe SpecializationInfo -> io Shader
Shader.create ctx
context StageSpirv
cStages

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

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

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

    pipelineCI :: Vector (SomeStruct PipelineShaderStageCreateInfo)
-> PipelineLayout -> GraphicsPipelineCreateInfo '[]
pipelineCI Vector (SomeStruct PipelineShaderStageCreateInfo)
stages PipelineLayout
layout = 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   = forall a. a -> Maybe a
Just SomeStruct PipelineVertexInputStateCreateInfo
cVertexInput
      , $sel:inputAssemblyState:GraphicsPipelineCreateInfo :: Maybe PipelineInputAssemblyStateCreateInfo
Vk.inputAssemblyState = forall a. a -> Maybe a
Just PipelineInputAssemblyStateCreateInfo
inputAsembly
      , $sel:viewportState:GraphicsPipelineCreateInfo :: Maybe (SomeStruct PipelineViewportStateCreateInfo)
Vk.viewportState      = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct PipelineViewportStateCreateInfo '[]
viewportState
      , $sel:rasterizationState:GraphicsPipelineCreateInfo :: Maybe (SomeStruct PipelineRasterizationStateCreateInfo)
Vk.rasterizationState = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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   = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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  = forall a. a -> Maybe a
Just PipelineDepthStencilStateCreateInfo
depthStencilState
      , $sel:colorBlendState:GraphicsPipelineCreateInfo :: Maybe (SomeStruct PipelineColorBlendStateCreateInfo)
Vk.colorBlendState    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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         = forall a. HasRenderPass a => a -> RenderPass
getRenderPass renderpass
renderpass
      , $sel:subpass:GraphicsPipelineCreateInfo :: Word32
Vk.subpass            = Word32
0
      , $sel:basePipelineHandle:GraphicsPipelineCreateInfo :: Pipeline
Vk.basePipelineHandle = forall a. Zero a => a
zero
      }
      where
        inputAsembly :: PipelineInputAssemblyStateCreateInfo
inputAsembly = 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 = forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem @Set 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 ->
            ( forall a. Zero a => a
zero
                { $sel:viewportCount:PipelineViewportStateCreateInfo :: Word32
Vk.viewportCount = Word32
1
                , $sel:scissorCount:PipelineViewportStateCreateInfo :: Word32
Vk.scissorCount = Word32
1
                }
            , forall a. a -> Maybe a
Just forall a. Zero a => a
zero
                { $sel:dynamicStates:PipelineDynamicStateCreateInfo :: Vector DynamicState
Vk.dynamicStates = 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} ->
            ( forall a. Zero a => a
zero
                { $sel:viewports:PipelineViewportStateCreateInfo :: Vector Viewport
Vk.viewports = forall a. [a] -> Vector a
Vector.fromList
                    [ 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    = forall a b. (Real a, Fractional b) => a -> b
realToFrac Word32
width
                        , $sel:height:Viewport :: "constant" ::: Float
Vk.height   = 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 = forall a. a -> Vector a
Vector.singleton Vk.Rect2D
                    { $sel:offset:Rect2D :: Offset2D
Vk.offset = Int32 -> Int32 -> Offset2D
Vk.Offset2D Int32
0 Int32
0
                    , $sel:extent:Rect2D :: Extent2D
extent    = Extent2D
extent
                    }
                }
            , 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 = 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 = 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           = forall a. a -> Vector a
Vector.singleton forall a. Bounded a => a
maxBound
          }
          where
            enable :: Bool
enable = Bool
True -- TODO: check and enable sample rate shading feature

        depthStencilState :: PipelineDepthStencilStateCreateInfo
depthStencilState = 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
cDepthCompare
          , $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                 = forall a. Zero a => a
zero -- Optional
          , $sel:back:PipelineDepthStencilStateCreateInfo :: StencilOpState
Vk.back                  = forall a. Zero a => a
zero -- Optional
          }

        colorBlendState :: PipelineColorBlendStateCreateInfo '[]
colorBlendState = forall a. Zero a => a
zero
          { $sel:logicOpEnable:PipelineColorBlendStateCreateInfo :: Bool
Vk.logicOpEnable =
              Bool
False
          , $sel:attachments:PipelineColorBlendStateCreateInfo :: Vector PipelineColorBlendAttachmentState
Vk.attachments = forall a. a -> Vector a
Vector.singleton 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 forall a. Bits a => a -> a -> a
.|.
          ColorComponentFlags
Vk.COLOR_COMPONENT_G_BIT forall a. Bits a => a -> a -> a
.|.
          ColorComponentFlags
Vk.COLOR_COMPONENT_B_BIT forall a. Bits a => a -> a -> a
.|.
          ColorComponentFlags
Vk.COLOR_COMPONENT_A_BIT

bind
  :: ( Compatible pipeLayout boundLayout
     , MonadIO m
     )
  => Vk.CommandBuffer
  -> Pipeline pipeLayout vertices instances
  -> Bound boundLayout vertices instances m ()
  -> Bound boundLayout oldVertices oldInstances m ()
bind :: forall (pipeLayout :: [*]) (boundLayout :: [*]) (m :: * -> *)
       vertices instances oldVertices oldInstances.
(Compatible pipeLayout boundLayout, MonadIO m) =>
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
  forall (dsl :: [*]) vertices instances (m :: * -> *) a.
m a -> Bound dsl vertices instances m a
Bound forall a b. (a -> b) -> a -> b
$ forall (io :: * -> *).
MonadIO io =>
CommandBuffer -> PipelineBindPoint -> Pipeline -> io ()
Vk.cmdBindPipeline CommandBuffer
cb PipelineBindPoint
Vk.PIPELINE_BIND_POINT_GRAPHICS Pipeline
pipeline
  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 = forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct 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 = forall a. [a] -> Vector a
Vector.fromList do
      (Word32
ix, (VertexInputRate
rate, [Format]
formats)) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
0..] [(VertexInputRate, [Format])]
bindings
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Vk.VertexInputBindingDescription
        { $sel:binding:VertexInputBindingDescription :: Word32
binding   = Word32
ix
        , $sel:stride:VertexInputBindingDescription :: Word32
stride    = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Integral a => Format -> a
formatSize [Format]
formats
        , $sel:inputRate:VertexInputBindingDescription :: VertexInputRate
inputRate = VertexInputRate
rate
        }

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

-- * Utils

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

formatSize :: Integral a => Vk.Format -> a
formatSize :: forall a. Integral a => 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 ->
    forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Format size unknown: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Format
format