{-# LANGUAGE AllowAmbiguousTypes #-}
{-# 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

  , bind

  , HasVertexInputBindings(..)
  , vertexFormat
  , instanceFormat
  ) where

import RIO
import GHC.Generics

import Data.Bits ((.|.))
import Data.Kind (Type)
import Data.List qualified as List
import Data.Tagged (Tagged(..))
import Data.Type.Equality (type (~))
import Data.Vector qualified as Vector
import Geomancy (Transform)
import GHC.Stack (withFrozenCallStack)
import UnliftIO.Resource (MonadResource, ReleaseKey)
import Vulkan.Core10 qualified as Vk
import Vulkan.CStruct.Extends (SomeStruct(..))
import Vulkan.NamedType ((:::))
import Vulkan.Zero (Zero(..))

import Engine.SpirV.Reflect (Reflect)
import Engine.Vulkan.DescSets (Bound(..), Compatible)
import Engine.Vulkan.Format (HasVkFormat(..), formatSize)
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, DsLayoutBindings, getPipelineCache)
import Render.Code (Code)
import Resource.Vulkan.DescriptorLayout qualified as Layout
import Resource.Vulkan.Named qualified as Named

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
(Stages a -> Stages a -> Bool)
-> (Stages a -> Stages a -> Bool) -> Eq (Stages a)
forall a. Eq a => Stages a -> Stages a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: Stages a -> Stages a -> Bool
Eq, Eq (Stages a)
Eq (Stages a)
-> (Stages a -> Stages a -> Ordering)
-> (Stages a -> Stages a -> Bool)
-> (Stages a -> Stages a -> Bool)
-> (Stages a -> Stages a -> Bool)
-> (Stages a -> Stages a -> Bool)
-> (Stages a -> Stages a -> Stages a)
-> (Stages a -> Stages a -> Stages a)
-> Ord (Stages a)
Stages a -> Stages a -> Bool
Stages a -> Stages a -> Ordering
Stages a -> Stages a -> Stages a
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
$ccompare :: forall a. Ord a => Stages a -> Stages a -> Ordering
compare :: Stages a -> Stages a -> Ordering
$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
>= :: Stages a -> Stages a -> Bool
$cmax :: forall a. Ord a => Stages a -> Stages a -> Stages a
max :: Stages a -> Stages a -> Stages a
$cmin :: forall a. Ord a => Stages a -> Stages a -> Stages a
min :: Stages a -> Stages a -> Stages a
Ord, Int -> Stages a -> ShowS
[Stages a] -> ShowS
Stages a -> String
(Int -> Stages a -> ShowS)
-> (Stages a -> String) -> ([Stages a] -> ShowS) -> Show (Stages a)
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
$cshowsPrec :: forall a. Show a => Int -> Stages a -> ShowS
showsPrec :: Int -> Stages a -> ShowS
$cshow :: forall a. Show a => Stages a -> String
show :: Stages a -> String
$cshowList :: forall a. Show a => [Stages a] -> ShowS
showList :: [Stages a] -> ShowS
Show, (forall a b. (a -> b) -> Stages a -> Stages b)
-> (forall a b. a -> Stages b -> Stages a) -> Functor Stages
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
$cfmap :: forall a b. (a -> b) -> Stages a -> Stages b
fmap :: forall a b. (a -> b) -> Stages a -> Stages b
$c<$ :: forall a b. a -> Stages b -> Stages a
<$ :: forall a b. a -> Stages b -> Stages a
Functor, (forall m. Monoid m => Stages m -> m)
-> (forall m a. Monoid m => (a -> m) -> Stages a -> m)
-> (forall m a. Monoid m => (a -> m) -> Stages a -> m)
-> (forall a b. (a -> b -> b) -> b -> Stages a -> b)
-> (forall a b. (a -> b -> b) -> b -> Stages a -> b)
-> (forall b a. (b -> a -> b) -> b -> Stages a -> b)
-> (forall b a. (b -> a -> b) -> b -> Stages a -> b)
-> (forall a. (a -> a -> a) -> Stages a -> a)
-> (forall a. (a -> a -> a) -> Stages a -> a)
-> (forall a. Stages a -> [a])
-> (forall a. Stages a -> Bool)
-> (forall a. Stages a -> Int)
-> (forall a. Eq a => a -> Stages a -> Bool)
-> (forall a. Ord a => Stages a -> a)
-> (forall a. Ord a => Stages a -> a)
-> (forall a. Num a => Stages a -> a)
-> (forall a. Num a => Stages a -> a)
-> Foldable Stages
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
$cfold :: forall m. Monoid m => Stages m -> m
fold :: forall m. Monoid m => Stages m -> 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
foldMap' :: forall m a. Monoid m => (a -> m) -> Stages a -> m
$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
foldr' :: forall a b. (a -> b -> 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
foldl' :: forall b a. (b -> a -> b) -> b -> Stages a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Stages a -> a
foldr1 :: forall a. (a -> a -> a) -> Stages a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Stages a -> a
foldl1 :: forall a. (a -> a -> a) -> Stages a -> a
$ctoList :: forall a. Stages a -> [a]
toList :: forall a. Stages a -> [a]
$cnull :: forall a. Stages a -> Bool
null :: forall a. Stages a -> Bool
$clength :: forall a. Stages a -> Int
length :: forall a. Stages a -> Int
$celem :: forall a. Eq a => a -> Stages a -> Bool
elem :: forall a. Eq a => a -> Stages a -> Bool
$cmaximum :: forall a. Ord a => Stages a -> a
maximum :: forall a. Ord a => Stages a -> a
$cminimum :: forall a. Ord a => Stages a -> a
minimum :: forall a. Ord a => Stages a -> a
$csum :: forall a. Num a => Stages a -> a
sum :: forall a. Num a => Stages a -> a
$cproduct :: forall a. Num a => Stages a -> a
product :: forall a. Num a => Stages a -> a
Foldable, Functor Stages
Foldable Stages
Functor Stages
-> Foldable Stages
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Stages a -> f (Stages b))
-> (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 (m :: * -> *) a.
    Monad m =>
    Stages (m a) -> m (Stages a))
-> Traversable 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)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Stages a -> f (Stages b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Stages a -> f (Stages b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Stages (f a) -> f (Stages a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Stages (f a) -> f (Stages a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Stages a -> m (Stages b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Stages a -> m (Stages b)
$csequence :: forall (m :: * -> *) a. Monad m => Stages (m a) -> m (Stages a)
sequence :: forall (m :: * -> *) a. Monad m => Stages (m a) -> m (Stages a)
Traversable, (forall a. Stages a -> Rep1 Stages a)
-> (forall a. Rep1 Stages a -> Stages a) -> Generic1 Stages
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
$cfrom1 :: forall a. Stages a -> Rep1 Stages a
from1 :: forall a. Stages a -> Rep1 Stages a
$cto1 :: forall a. Rep1 Stages a -> Stages a
to1 :: forall a. Rep1 Stages a -> Stages a
Generic1)
  deriving Functor Stages
Functor Stages
-> (forall a. a -> Stages a)
-> (forall a b. Stages (a -> b) -> Stages a -> Stages b)
-> (forall a b c.
    (a -> b -> c) -> Stages a -> Stages b -> Stages c)
-> (forall a b. Stages a -> Stages b -> Stages b)
-> (forall a b. Stages a -> Stages b -> Stages a)
-> Applicative 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
$cpure :: forall a. a -> Stages a
pure :: forall a. a -> Stages a
$c<*> :: forall a b. Stages (a -> b) -> Stages a -> Stages b
<*> :: forall a b. Stages (a -> b) -> Stages a -> Stages b
$cliftA2 :: forall a b c. (a -> b -> c) -> Stages a -> Stages b -> Stages c
liftA2 :: forall a b c. (a -> b -> c) -> Stages a -> Stages b -> Stages c
$c*> :: forall a b. Stages a -> Stages b -> Stages b
*> :: forall a b. Stages a -> Stages b -> Stages b
$c<* :: forall a b. Stages a -> Stages b -> Stages a
<* :: forall a b. Stages a -> Stages b -> 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 = (Maybe ("vert" ::: a) -> Stages (Maybe ("vert" ::: a))
forall a. a -> Stages a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ("vert" ::: a)
forall a. Maybe a
Nothing)
  { $sel:vert:Stages :: Maybe ("vert" ::: a)
vert = ("vert" ::: a) -> Maybe ("vert" ::: a)
forall a. a -> Maybe a
Just "vert" ::: a
v
  , $sel:frag:Stages :: Maybe ("vert" ::: a)
frag = ("vert" ::: a) -> Maybe ("vert" ::: a)
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 = (Maybe ("vert" ::: a) -> Stages (Maybe ("vert" ::: a))
forall a. a -> Stages a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ("vert" ::: a)
forall a. Maybe a
Nothing)
  { $sel:vert:Stages :: Maybe ("vert" ::: a)
vert = ("vert" ::: a) -> Maybe ("vert" ::: a)
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 {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> StageSpirv
cStages             :: StageSpirv
  , forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> Maybe StageReflect
cReflect            :: Maybe StageReflect
  , forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec
-> SomeStruct PipelineVertexInputStateCreateInfo
cVertexInput        :: SomeStruct Vk.PipelineVertexInputStateCreateInfo
  , forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> Tagged dsl [DsLayoutBindings]
cDescLayouts        :: Tagged dsl [DsLayoutBindings]
  , forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> Vector PushConstantRange
cPushConstantRanges :: Vector Vk.PushConstantRange
  , forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> Bool
cBlend              :: Bool
  , forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> Bool
cDepthWrite         :: Bool
  , forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> Bool
cDepthTest          :: Bool
  , forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> CompareOp
cDepthCompare       :: Vk.CompareOp
  , forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> PrimitiveTopology
cTopology           :: Vk.PrimitiveTopology
  , forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> CullModeFlagBits
cCull               :: Vk.CullModeFlagBits
  , forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec
-> Maybe ("constant" ::: Float, "constant" ::: Float)
cDepthBias          :: Maybe ("constant" ::: Float, "slope" ::: Float)
  , forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> spec
cSpecialization     :: spec
  }

-- | Settings for generic triangle-rendering pipeline.
baseConfig :: Config '[] vertices instances ()
baseConfig :: forall {k} {k} (vertices :: k) (instances :: k).
Config '[] vertices instances ()
baseConfig = Config
  { $sel:cStages:Config :: StageSpirv
cStages             = Maybe ByteString -> StageSpirv
forall a. a -> Stages a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
  , $sel:cVertexInput:Config :: SomeStruct PipelineVertexInputStateCreateInfo
cVertexInput        = SomeStruct PipelineVertexInputStateCreateInfo
forall a. Zero a => a
zero
  , $sel:cReflect:Config :: Maybe StageReflect
cReflect            = Maybe StageReflect
forall a. Maybe a
Nothing
  , $sel:cDescLayouts:Config :: Tagged '[] [DsLayoutBindings]
cDescLayouts        = [DsLayoutBindings] -> Tagged '[] [DsLayoutBindings]
forall {k} (s :: k) b. b -> Tagged s b
Tagged []
  , $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: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          = Maybe ("constant" ::: Float, "constant" ::: Float)
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 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
  :: ( 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 {k} {k} config pipeline (dsl :: [*]) (vertices :: k)
       (instances :: k) 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 =
  (HasCallStack => m (ReleaseKey, pipeline))
-> m (ReleaseKey, pipeline)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m (ReleaseKey, pipeline))
 -> m (ReleaseKey, pipeline))
-> (HasCallStack => m (ReleaseKey, pipeline))
-> m (ReleaseKey, pipeline)
forall a b. (a -> b) -> a -> b
$
    m (Pipeline dsl vertices instances)
-> m (ReleaseKey, Pipeline dsl vertices instances)
forall {k1} {k2} env (m :: * -> *) (dsl :: [*]) (vertices :: k1)
       (instances :: k2).
(MonadVulkan env m, MonadResource m) =>
m (Pipeline dsl vertices instances)
-> m (ReleaseKey, Pipeline dsl vertices instances)
Pipeline.allocateWith (m (Pipeline dsl vertices instances)
 -> m (ReleaseKey, Pipeline dsl vertices instances))
-> m (Pipeline dsl vertices instances)
-> m (ReleaseKey, Pipeline dsl vertices instances)
forall a b. (a -> b) -> a -> b
$ Maybe Extent2D
-> SampleCountFlagBits
-> renderpass
-> Config dsl vertices instances spec
-> m (Pipeline dsl vertices instances)
forall {k} {k1} env (io :: * -> *) renderpass spec (dsl :: [*])
       (vertices :: k) (instances :: k1).
(MonadVulkan env io, HasRenderPass renderpass, Specialization spec,
 HasCallStack) =>
Maybe Extent2D
-> SampleCountFlagBits
-> renderpass
-> Config dsl vertices instances spec
-> io (Pipeline dsl vertices instances)
create Maybe Extent2D
extent SampleCountFlagBits
msaa renderpass
renderpass Config dsl vertices instances spec
config

create
  :: ( MonadVulkan env io
     , HasRenderPass renderpass
     , Shader.Specialization spec
     , HasCallStack
     )
  => Maybe Vk.Extent2D
  -> Vk.SampleCountFlagBits
  -> renderpass
  -> Config dsl vertices instances spec
  -> io (Pipeline dsl vertices instances)
create :: forall {k} {k1} env (io :: * -> *) renderpass spec (dsl :: [*])
       (vertices :: k) (instances :: k1).
(MonadVulkan env io, HasRenderPass renderpass, Specialization spec,
 HasCallStack) =>
Maybe Extent2D
-> SampleCountFlagBits
-> renderpass
-> Config dsl vertices instances spec
-> io (Pipeline dsl vertices instances)
create Maybe Extent2D
mextent SampleCountFlagBits
msaa renderpass
renderpass Config{spec
Bool
Maybe ("constant" ::: Float, "constant" ::: Float)
Maybe StageReflect
Vector PushConstantRange
Tagged dsl [DsLayoutBindings]
PrimitiveTopology
CullModeFlagBits
CompareOp
SomeStruct PipelineVertexInputStateCreateInfo
StageSpirv
$sel:cStages:Config :: forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> StageSpirv
$sel:cReflect:Config :: forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> Maybe StageReflect
$sel:cVertexInput:Config :: forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec
-> SomeStruct PipelineVertexInputStateCreateInfo
$sel:cDescLayouts:Config :: forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> Tagged dsl [DsLayoutBindings]
$sel:cPushConstantRanges:Config :: forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> Vector PushConstantRange
$sel:cBlend:Config :: forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> Bool
$sel:cDepthWrite:Config :: forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> Bool
$sel:cDepthTest:Config :: forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> Bool
$sel:cDepthCompare:Config :: forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> CompareOp
$sel:cTopology:Config :: forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> PrimitiveTopology
$sel:cCull:Config :: forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> CullModeFlagBits
$sel:cDepthBias:Config :: forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec
-> Maybe ("constant" ::: Float, "constant" ::: Float)
$sel:cSpecialization:Config :: forall {k} {k} (dsl :: [*]) (vertices :: k) (instances :: k) spec.
Config dsl vertices instances spec -> spec
cStages :: StageSpirv
cReflect :: Maybe StageReflect
cVertexInput :: SomeStruct PipelineVertexInputStateCreateInfo
cDescLayouts :: Tagged dsl [DsLayoutBindings]
cPushConstantRanges :: Vector PushConstantRange
cBlend :: Bool
cDepthWrite :: Bool
cDepthTest :: Bool
cDepthCompare :: CompareOp
cTopology :: PrimitiveTopology
cCull :: CullModeFlagBits
cDepthBias :: Maybe ("constant" ::: Float, "constant" ::: Float)
cSpecialization :: spec
..} = (HasCallStack => io (Pipeline dsl vertices instances))
-> io (Pipeline dsl vertices instances)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
  -- TODO: get from outside
  Vector DescriptorSetLayout
dsLayouts <- Vector DsLayoutBindings -> io (Vector DescriptorSetLayout)
forall env (m :: * -> *).
MonadVulkan env m =>
Vector DsLayoutBindings -> m (Vector DescriptorSetLayout)
Layout.create (Vector DsLayoutBindings -> io (Vector DescriptorSetLayout))
-> Vector DsLayoutBindings -> io (Vector DescriptorSetLayout)
forall a b. (a -> b) -> a -> b
$ [DsLayoutBindings] -> Vector DsLayoutBindings
forall a. [a] -> Vector a
Vector.fromList (Tagged dsl [DsLayoutBindings] -> [DsLayoutBindings]
forall {k} (s :: k) b. Tagged s b -> b
unTagged Tagged dsl [DsLayoutBindings]
cDescLayouts)

  -- TODO: get from outside ?
  PipelineLayout
pipelineLayout <- Vector DescriptorSetLayout
-> Vector PushConstantRange -> io PipelineLayout
forall env (m :: * -> *).
MonadVulkan env m =>
Vector DescriptorSetLayout
-> Vector PushConstantRange -> m PipelineLayout
Layout.forPipeline
    Vector DescriptorSetLayout
dsLayouts
    Vector PushConstantRange
cPushConstantRanges
  PipelineLayout -> io ()
forall env (m :: * -> *) a.
(MonadVulkan env m, HasObjectType a, HasCallStack) =>
a -> m ()
Named.objectOrigin PipelineLayout
pipelineLayout

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

  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)
Shader.sPipelineStages Shader
shader) PipelineLayout
pipelineLayout

  Device
device <- (env -> Device) -> io Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Device
forall a. HasVulkan a => a -> Device
getDevice
  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 a b. io a -> (a -> io b) -> io b
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
        [Item [Pipeline]
pipeline] -> do
          Shader -> io ()
forall env (io :: * -> *). MonadVulkan env io => Shader -> io ()
Shader.destroy Shader
shader
          Pipeline -> io ()
forall env (m :: * -> *) a.
(MonadVulkan env m, HasObjectType a, HasCallStack) =>
a -> m ()
Named.objectOrigin Item [Pipeline]
Pipeline
pipeline
          pure Pipeline
            { $sel:pipeline:Pipeline :: Pipeline
pipeline     = Item [Pipeline]
Pipeline
pipeline
            , $sel:pLayout:Pipeline :: Tagged dsl PipelineLayout
pLayout      = PipelineLayout -> Tagged dsl PipelineLayout
forall {k} (s :: k) b. b -> Tagged s b
Tagged PipelineLayout
pipelineLayout
            , $sel:pDescLayouts:Pipeline :: Tagged dsl (Vector DescriptorSetLayout)
pDescLayouts = Vector DescriptorSetLayout
-> Tagged dsl (Vector DescriptorSetLayout)
forall {k} (s :: k) b. b -> Tagged s b
Tagged Vector DescriptorSetLayout
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 -> ShowS
forall a. Semigroup a => a -> a -> a
<> Result -> String
forall a. Show a => a -> String
show Result
err
  where
    cache :: PipelineCache
cache = Any -> PipelineCache
forall ctx. ctx -> PipelineCache
getPipelineCache Any
forall a. HasCallStack => a
undefined

    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 :: Maybe (SomeStruct PipelineRasterizationStateCreateInfo)
Vk.rasterizationState = SomeStruct PipelineRasterizationStateCreateInfo
-> Maybe (SomeStruct PipelineRasterizationStateCreateInfo)
forall a. a -> Maybe a
Just (SomeStruct PipelineRasterizationStateCreateInfo
 -> Maybe (SomeStruct PipelineRasterizationStateCreateInfo))
-> SomeStruct PipelineRasterizationStateCreateInfo
-> Maybe (SomeStruct PipelineRasterizationStateCreateInfo)
forall a b. (a -> b) -> a -> b
$ 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 = forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem @Set PrimitiveTopology
cTopology
          [ Item (Set PrimitiveTopology)
PrimitiveTopology
Vk.PRIMITIVE_TOPOLOGY_LINE_STRIP
          , Item (Set PrimitiveTopology)
PrimitiveTopology
Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_STRIP
          , Item (Set PrimitiveTopology)
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
                    [ Item [DynamicState]
DynamicState
Vk.DYNAMIC_STATE_VIEWPORT
                    , Item [DynamicState]
DynamicState
Vk.DYNAMIC_STATE_SCISSOR
                    ]
                }
            )
          Just extent :: Extent2D
extent@Vk.Extent2D{Word32
width :: Word32
$sel:width:Extent2D :: Extent2D -> Word32
width, Word32
height :: Word32
$sel:height:Extent2D :: Extent2D -> 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
                    [ 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 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
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                 = 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

bind
  :: ( Compatible pipeLayout boundLayout
     , MonadIO m
     )
  => Vk.CommandBuffer
  -> Pipeline pipeLayout vertices instances
  -> Bound boundLayout vertices instances m ()
  -> Bound boundLayout oldVertices oldInstances m ()
bind :: forall {k} {k1} {k} {k1} (pipeLayout :: [*]) (boundLayout :: [*])
       (m :: * -> *) (vertices :: k) (instances :: k1) (oldVertices :: k)
       (oldInstances :: k1).
(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
$sel:pipeline:Pipeline :: forall {k1} {k2} (dsl :: [*]) (vertices :: k1) (instances :: k2).
Pipeline dsl vertices instances -> Pipeline
pipeline :: Pipeline
pipeline} (Bound m ()
attrAction) = do
  m () -> Bound boundLayout oldVertices oldInstances m ()
forall {k} {k1} {k2} (dsl :: [*]) (vertices :: k) (instances :: k1)
       (m :: k2 -> *) (a :: k2).
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 {k} {k1} {k2} (dsl :: [*]) (vertices :: k) (instances :: k1)
       (m :: k2 -> *) (a :: k2).
m a -> Bound dsl vertices instances m a
Bound m ()
attrAction

vertexInput
  :: forall a pipeLayout vertices instances
  .  ( a ~ Pipeline pipeLayout vertices instances
     , HasVertexInputBindings vertices -- XXX: 0-2 of {positions, attrs} (e.g. position + uv)
     , HasVertexInputBindings instances -- XXX: 0+ of instance attrs (e.g. static params + dynamic transforms)
     )
  => SomeStruct Vk.PipelineVertexInputStateCreateInfo
vertexInput :: forall {k} {k} a (pipeLayout :: [*]) (vertices :: k)
       (instances :: k).
(a ~ Pipeline pipeLayout vertices instances,
 HasVertexInputBindings vertices,
 HasVertexInputBindings instances) =>
SomeStruct PipelineVertexInputStateCreateInfo
vertexInput = 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
Item [Word32]
0..] [(VertexInputRate, [Format])]
bindings
      VertexInputBindingDescription -> [VertexInputBindingDescription]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Vk.VertexInputBindingDescription
        { $sel:binding:VertexInputBindingDescription :: Word32
binding   = Word32
ix
        , $sel:stride:VertexInputBindingDescription :: Word32
stride    = [Word32] -> Word32
forall a. Num a => [a] -> a
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

    bindings :: [(VertexInputRate, [Format])]
bindings =
      ((VertexInputRate, [Format]) -> Bool)
-> [(VertexInputRate, [Format])] -> [(VertexInputRate, [Format])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((VertexInputRate, [Format]) -> Bool)
-> (VertexInputRate, [Format])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Format] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Format] -> Bool)
-> ((VertexInputRate, [Format]) -> [Format])
-> (VertexInputRate, [Format])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VertexInputRate, [Format]) -> [Format]
forall a b. (a, b) -> b
snd) ([(VertexInputRate, [Format])] -> [(VertexInputRate, [Format])])
-> [(VertexInputRate, [Format])] -> [(VertexInputRate, [Format])]
forall a b. (a -> b) -> a -> b
$
        forall (a :: k).
HasVertexInputBindings a =>
[(VertexInputRate, [Format])]
forall {k} (a :: k).
HasVertexInputBindings a =>
[(VertexInputRate, [Format])]
vertexInputBindings @vertices [(VertexInputRate, [Format])]
-> [(VertexInputRate, [Format])] -> [(VertexInputRate, [Format])]
forall a. Semigroup a => a -> a -> a
<>
        forall (a :: k).
HasVertexInputBindings a =>
[(VertexInputRate, [Format])]
forall {k} (a :: k).
HasVertexInputBindings a =>
[(VertexInputRate, [Format])]
vertexInputBindings @instances

-- * 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
Item [Int]
0..] [Format]
formats
            let offset :: Word32
offset = [Word32] -> Word32
forall a. Num a => [a] -> a
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 a. a -> [a]
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
            )

type VertexInputBinding = (Vk.VertexInputRate, [Vk.Format])

vertexFormat :: forall a . HasVkFormat a => VertexInputBinding
vertexFormat :: forall a. HasVkFormat a => (VertexInputRate, [Format])
vertexFormat = (VertexInputRate
Vk.VERTEX_INPUT_RATE_VERTEX, forall a. HasVkFormat a => [Format]
getVkFormat @a)

instanceFormat :: forall a . HasVkFormat a => VertexInputBinding
instanceFormat :: forall a. HasVkFormat a => (VertexInputRate, [Format])
instanceFormat = (VertexInputRate
Vk.VERTEX_INPUT_RATE_INSTANCE, forall a. HasVkFormat a => [Format]
getVkFormat @a)

class HasVertexInputBindings a where
  vertexInputBindings :: [VertexInputBinding]

instance HasVertexInputBindings () where
  vertexInputBindings :: [(VertexInputRate, [Format])]
vertexInputBindings = []

instance HasVertexInputBindings Transform where
  vertexInputBindings :: [(VertexInputRate, [Format])]
vertexInputBindings = [forall a. HasVkFormat a => (VertexInputRate, [Format])
instanceFormat @Transform]