{-# LANGUAGE OverloadedLists #-}

{-| The classic render-pass drawing path: a 'Vk.RenderPass' over one or more
colour attachments (and an optional depth attachment), framebuffers over the
swapchain image views, and a vanilla pipeline that targets the render pass.

This is one of two self-contained alternatives — see
"Vulkan.Utils.DynamicRendering" for the @VK_KHR_dynamic_rendering@ path, which
needs neither a render pass nor framebuffers. Pick one and import only it.
-}
module Vulkan.Utils.RenderPass
  ( -- * Render pass
    allocateRenderPass
  , allocateColorRenderPass

    -- * Pipeline
  , PipelineConfig (..)
  , allocatePipeline
  , allocatePipelineFromShaders
  ) where

import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, allocate)
import Data.Bits ((.|.))
import Data.ByteString (ByteString)
import Data.Maybe (fromMaybe, isJust)
import Data.Vector (Vector)
import qualified Data.Vector as V
import Vulkan.CStruct.Extends (SomeStruct (..))
import qualified Vulkan.Core10 as Vk
import Vulkan.Utils.DynamicState (defaultDynamicStatesFor)
import Vulkan.Utils.Pipeline.Internal (basePipelineCreateInfo, buildColorPipeline, withCompiledStages)
import Vulkan.Utils.Pipeline.Specialization (Specialization)
import Vulkan.Zero (Zero (..))

{- | A render pass with @colors@ colour attachments (each @(format, finalLayout)@)
and an optional depth attachment, all cleared on load and stored on completion, in
a single graphics subpass. Attachment indices are the colours @0..N-1@ then the
depth attachment at @N@ — the colour-then-depth order the framebuffer's
@attachments@ must follow. The external
dependency synchronizes colour output and, when present, the
depth fragment tests.
-}
allocateRenderPass
  :: (MonadResource m)
  => Vk.Device
  -> Vector (Vk.Format, Vk.ImageLayout)
  -- ^ Colour attachments: @(format, finalLayout)@.
  -> Maybe Vk.Format
  -- ^ Optional depth attachment format.
  -> m (ReleaseKey, Vk.RenderPass)
allocateRenderPass :: forall (m :: * -> *).
MonadResource m =>
Device
-> Vector (Format, ImageLayout)
-> Maybe Format
-> m (ReleaseKey, RenderPass)
allocateRenderPass Device
dev Vector (Format, ImageLayout)
colors Maybe Format
depth =
  Device
-> RenderPassCreateInfo '[]
-> Maybe AllocationCallbacks
-> (IO RenderPass
    -> (RenderPass -> IO ()) -> m (ReleaseKey, RenderPass))
-> m (ReleaseKey, RenderPass)
forall (a :: [*]) (io :: * -> *) r.
(Extendss RenderPassCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> RenderPassCreateInfo a
-> Maybe AllocationCallbacks
-> (io RenderPass -> (RenderPass -> io ()) -> r)
-> r
Vk.withRenderPass
    Device
dev
    RenderPassCreateInfo '[]
forall a. Zero a => a
zero
      { Vk.attachments = colorDescriptions <> depthDescriptions
      , Vk.subpasses = [subpass]
      , Vk.dependencies = [subpassDependency]
      }
    Maybe AllocationCallbacks
forall a. Maybe a
Nothing
    IO RenderPass
-> (RenderPass -> IO ()) -> m (ReleaseKey, RenderPass)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
  where
    colorCount :: Int
colorCount = Vector (Format, ImageLayout) -> Int
forall a. Vector a -> Int
V.length Vector (Format, ImageLayout)
colors
    hasColor :: Bool
hasColor = Int
colorCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    hasDepth :: Bool
hasDepth = Maybe Format -> Bool
forall a. Maybe a -> Bool
isJust Maybe Format
depth

    colorDescriptions :: Vector Vk.AttachmentDescription
    colorDescriptions :: Vector AttachmentDescription
colorDescriptions = ((Format, ImageLayout) -> AttachmentDescription)
-> Vector (Format, ImageLayout) -> Vector AttachmentDescription
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Format -> ImageLayout -> AttachmentDescription)
-> (Format, ImageLayout) -> AttachmentDescription
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Format -> ImageLayout -> AttachmentDescription
colorAttachmentDescription) Vector (Format, ImageLayout)
colors

    depthDescriptions :: Vector Vk.AttachmentDescription
    depthDescriptions :: Vector AttachmentDescription
depthDescriptions = Vector AttachmentDescription
-> (Format -> Vector AttachmentDescription)
-> Maybe Format
-> Vector AttachmentDescription
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (AttachmentDescription -> Vector AttachmentDescription
forall a. a -> Vector a
V.singleton (AttachmentDescription -> Vector AttachmentDescription)
-> (Format -> AttachmentDescription)
-> Format
-> Vector AttachmentDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format -> AttachmentDescription
depthAttachmentDescription) Maybe Format
depth

    colorReferences :: Vector Vk.AttachmentReference
    colorReferences :: Vector AttachmentReference
colorReferences =
      (Int -> (Format, ImageLayout) -> AttachmentReference)
-> Vector (Format, ImageLayout) -> Vector AttachmentReference
forall a b. (Int -> a -> b) -> Vector a -> Vector b
V.imap
        ( \Int
i (Format, ImageLayout)
_ ->
            AttachmentReference
forall a. Zero a => a
zero
              { Vk.attachment = fromIntegral i
              , Vk.layout = Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL
              }
        )
        Vector (Format, ImageLayout)
colors

    depthReference :: Maybe Vk.AttachmentReference
    depthReference :: Maybe AttachmentReference
depthReference
      | Bool
hasDepth =
          AttachmentReference -> Maybe AttachmentReference
forall a. a -> Maybe a
Just
            AttachmentReference
forall a. Zero a => a
zero
              { Vk.attachment = fromIntegral colorCount
              , Vk.layout = Vk.IMAGE_LAYOUT_DEPTH_ATTACHMENT_OPTIMAL
              }
      | Bool
otherwise = Maybe AttachmentReference
forall a. Maybe a
Nothing

    subpass :: Vk.SubpassDescription
    subpass :: SubpassDescription
subpass =
      SubpassDescription
forall a. Zero a => a
zero
        { Vk.pipelineBindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS
        , Vk.colorAttachments = colorReferences
        , Vk.depthStencilAttachment = depthReference
        }

    subpassDependency :: Vk.SubpassDependency
    subpassDependency :: SubpassDependency
subpassDependency =
      SubpassDependency
forall a. Zero a => a
zero
        { Vk.srcSubpass = Vk.SUBPASS_EXTERNAL
        , Vk.dstSubpass = 0
        , Vk.srcStageMask = stageMask
        , Vk.srcAccessMask = zero
        , Vk.dstStageMask = stageMask
        , Vk.dstAccessMask = accessMask
        }

    stageMask :: PipelineStageFlagBits
stageMask =
      (if Bool
hasColor then PipelineStageFlagBits
Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT else PipelineStageFlagBits
forall a. Zero a => a
zero)
        PipelineStageFlagBits
-> PipelineStageFlagBits -> PipelineStageFlagBits
forall a. Bits a => a -> a -> a
.|. ( if Bool
hasDepth
                then
                  PipelineStageFlagBits
Vk.PIPELINE_STAGE_EARLY_FRAGMENT_TESTS_BIT
                    PipelineStageFlagBits
-> PipelineStageFlagBits -> PipelineStageFlagBits
forall a. Bits a => a -> a -> a
.|. PipelineStageFlagBits
Vk.PIPELINE_STAGE_LATE_FRAGMENT_TESTS_BIT
                else PipelineStageFlagBits
forall a. Zero a => a
zero
            )
    accessMask :: AccessFlagBits
accessMask =
      ( if Bool
hasColor
          then AccessFlagBits
Vk.ACCESS_COLOR_ATTACHMENT_READ_BIT AccessFlagBits -> AccessFlagBits -> AccessFlagBits
forall a. Bits a => a -> a -> a
.|. AccessFlagBits
Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
          else AccessFlagBits
forall a. Zero a => a
zero
      )
        AccessFlagBits -> AccessFlagBits -> AccessFlagBits
forall a. Bits a => a -> a -> a
.|. (if Bool
hasDepth then AccessFlagBits
Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_WRITE_BIT else AccessFlagBits
forall a. Zero a => a
zero)

colorAttachmentDescription :: Vk.Format -> Vk.ImageLayout -> Vk.AttachmentDescription
colorAttachmentDescription :: Format -> ImageLayout -> AttachmentDescription
colorAttachmentDescription Format
imageFormat ImageLayout
finalLayout =
  AttachmentDescription
forall a. Zero a => a
zero
    { Vk.format = imageFormat
    , Vk.samples = Vk.SAMPLE_COUNT_1_BIT
    , Vk.loadOp = Vk.ATTACHMENT_LOAD_OP_CLEAR
    , Vk.storeOp = Vk.ATTACHMENT_STORE_OP_STORE
    , Vk.stencilLoadOp = Vk.ATTACHMENT_LOAD_OP_DONT_CARE
    , Vk.stencilStoreOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE
    , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED
    , Vk.finalLayout = finalLayout
    }

depthAttachmentDescription :: Vk.Format -> Vk.AttachmentDescription
depthAttachmentDescription :: Format -> AttachmentDescription
depthAttachmentDescription Format
imageFormat =
  AttachmentDescription
forall a. Zero a => a
zero
    { Vk.format = imageFormat
    , Vk.samples = Vk.SAMPLE_COUNT_1_BIT
    , Vk.loadOp = Vk.ATTACHMENT_LOAD_OP_CLEAR
    , Vk.storeOp = Vk.ATTACHMENT_STORE_OP_STORE
    , Vk.stencilLoadOp = Vk.ATTACHMENT_LOAD_OP_DONT_CARE
    , Vk.stencilStoreOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE
    , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED
    , Vk.finalLayout = Vk.IMAGE_LAYOUT_DEPTH_ATTACHMENT_OPTIMAL
    }

{- | The single-colour render pass: one attachment cleared on load and stored,
ending in @finalLayout@ (e.g. @PRESENT_SRC_KHR@ for swapchains,
@TRANSFER_SRC_OPTIMAL@ for offscreen images). The common special case of
'allocateRenderPass'.
-}
allocateColorRenderPass
  :: (MonadResource m)
  => Vk.Device
  -> Vk.Format
  -- ^ Color attachment format.
  -> Vk.ImageLayout
  -- ^ Final layout.
  -> m (ReleaseKey, Vk.RenderPass)
allocateColorRenderPass :: forall (m :: * -> *).
MonadResource m =>
Device -> Format -> ImageLayout -> m (ReleaseKey, RenderPass)
allocateColorRenderPass Device
dev Format
imageFormat ImageLayout
finalLayout =
  Device
-> Vector (Format, ImageLayout)
-> Maybe Format
-> m (ReleaseKey, RenderPass)
forall (m :: * -> *).
MonadResource m =>
Device
-> Vector (Format, ImageLayout)
-> Maybe Format
-> m (ReleaseKey, RenderPass)
allocateRenderPass Device
dev [(Format
imageFormat, ImageLayout
finalLayout)] Maybe Format
forall a. Maybe a
Nothing

{- | Attachment + fixed-function knobs for a render-pass pipeline.

Construct with 'zero' and override what differs, e.g.
@zero { RenderPass.colorFormats = [fmt], RenderPass.depthFormat = Just d }@. The
attachment shape — 'colorFormats' count and whether 'depthFormat' is present — MUST
match the render pass; the formats themselves live in the render pass, so only the
count and depth presence are read here.
-}
data PipelineConfig = PipelineConfig
  { PipelineConfig -> [Format]
colorFormats :: [Vk.Format]
  -- ^ Colour attachment formats; only the count is read (must match the render pass).
  , PipelineConfig -> Maybe Format
depthFormat :: Maybe Vk.Format
  -- ^ Optional depth attachment; only its presence is read (must match the render pass).
  , PipelineConfig -> PipelineVertexInputStateCreateInfo '[]
vertexInput :: Vk.PipelineVertexInputStateCreateInfo '[]
  -- ^ Vertex input (bindings + attributes); 'zero' for none.
  , PipelineConfig -> Maybe (Vector DynamicState)
dynamicStates :: Maybe (Vector Vk.DynamicState)
  -- ^ Dynamic states; 'Nothing' defaults layout-aware (see "Vulkan.Utils.DynamicState").
  , PipelineConfig -> Maybe PipelineLayout
layout :: Maybe Vk.PipelineLayout
  {- ^ Pipeline layout for descriptor sets \/ push constants; 'Nothing' uses a
  transient empty layout (shaders take no resources). A supplied layout stays
  owned by the caller, who must keep it alive for the pipeline's lifetime.
  -}
  }

instance Zero PipelineConfig where
  zero :: PipelineConfig
zero =
    PipelineConfig
      { colorFormats :: [Format]
colorFormats = []
      , depthFormat :: Maybe Format
depthFormat = Maybe Format
forall a. Maybe a
Nothing
      , vertexInput :: PipelineVertexInputStateCreateInfo '[]
vertexInput = PipelineVertexInputStateCreateInfo '[]
forall a. Zero a => a
zero
      , dynamicStates :: Maybe (Vector DynamicState)
dynamicStates = Maybe (Vector DynamicState)
forall a. Maybe a
Nothing
      , layout :: Maybe PipelineLayout
layout = Maybe PipelineLayout
forall a. Maybe a
Nothing
      }

{- | A vanilla vertex+fragment pipeline targeting @renderPass@ (subpass 0). The
'PipelineConfig' attachment shape MUST match @renderPass@. Whatever dynamic state
is selected MUST be set before drawing. Intended to be used qualified, e.g.
@RenderPass.allocatePipeline@.
-}
allocatePipeline
  :: (MonadResource m, MonadFail m)
  => Vk.Device
  -> Vk.RenderPass
  -> PipelineConfig
  -> Vector (SomeStruct Vk.PipelineShaderStageCreateInfo)
  -> m (ReleaseKey, Vk.Pipeline)
allocatePipeline :: forall (m :: * -> *).
(MonadResource m, MonadFail m) =>
Device
-> RenderPass
-> PipelineConfig
-> Vector (SomeStruct PipelineShaderStageCreateInfo)
-> m (ReleaseKey, Pipeline)
allocatePipeline Device
dev RenderPass
renderPass PipelineConfig{[Format]
Maybe (Vector DynamicState)
Maybe Format
Maybe PipelineLayout
PipelineVertexInputStateCreateInfo '[]
colorFormats :: PipelineConfig -> [Format]
depthFormat :: PipelineConfig -> Maybe Format
vertexInput :: PipelineConfig -> PipelineVertexInputStateCreateInfo '[]
dynamicStates :: PipelineConfig -> Maybe (Vector DynamicState)
layout :: PipelineConfig -> Maybe PipelineLayout
colorFormats :: [Format]
depthFormat :: Maybe Format
vertexInput :: PipelineVertexInputStateCreateInfo '[]
dynamicStates :: Maybe (Vector DynamicState)
layout :: Maybe PipelineLayout
..} Vector (SomeStruct PipelineShaderStageCreateInfo)
stages =
  Device
-> Maybe PipelineLayout
-> (PipelineLayout -> SomeStruct GraphicsPipelineCreateInfo)
-> m (ReleaseKey, Pipeline)
forall (m :: * -> *).
(MonadResource m, MonadFail m) =>
Device
-> Maybe PipelineLayout
-> (PipelineLayout -> SomeStruct GraphicsPipelineCreateInfo)
-> m (ReleaseKey, Pipeline)
buildColorPipeline Device
dev Maybe PipelineLayout
layout ((PipelineLayout -> SomeStruct GraphicsPipelineCreateInfo)
 -> m (ReleaseKey, Pipeline))
-> (PipelineLayout -> SomeStruct GraphicsPipelineCreateInfo)
-> m (ReleaseKey, Pipeline)
forall a b. (a -> b) -> a -> b
$ \PipelineLayout
resolvedLayout ->
    GraphicsPipelineCreateInfo '[]
-> SomeStruct GraphicsPipelineCreateInfo
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct
      ( PipelineLayout
-> Maybe RenderPass
-> Int
-> Bool
-> PipelineVertexInputStateCreateInfo '[]
-> Vector DynamicState
-> Vector (SomeStruct PipelineShaderStageCreateInfo)
-> GraphicsPipelineCreateInfo '[]
basePipelineCreateInfo
          PipelineLayout
resolvedLayout
          (RenderPass -> Maybe RenderPass
forall a. a -> Maybe a
Just RenderPass
renderPass)
          ([Format] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Format]
colorFormats)
          (Maybe Format -> Bool
forall a. Maybe a -> Bool
isJust Maybe Format
depthFormat)
          PipelineVertexInputStateCreateInfo '[]
vertexInput
          (Vector DynamicState
-> Maybe (Vector DynamicState) -> Vector DynamicState
forall a. a -> Maybe a -> a
fromMaybe (Bool -> Vector DynamicState
defaultDynamicStatesFor (Bool -> Bool
not ([Format] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Format]
colorFormats))) Maybe (Vector DynamicState)
dynamicStates)
          Vector (SomeStruct PipelineShaderStageCreateInfo)
stages
      )

{- | 'allocatePipeline' from @(stage, SPIR-V)@ pairs: compile each into a shader
module, build the pipeline, then release the now-redundant module handles.

@spec@ is one specialization shared by every stage (see
'Vulkan.Utils.Pipeline.Specialization'); pass @()@ for none.
-}
allocatePipelineFromShaders
  :: (MonadResource m, MonadUnliftIO m, MonadFail m, Specialization spec)
  => Vk.Device
  -> Vk.RenderPass
  -> PipelineConfig
  -> spec
  -- ^ Specialization shared by every stage; @()@ for none.
  -> [(Vk.ShaderStageFlagBits, ByteString)]
  -> m (ReleaseKey, Vk.Pipeline)
allocatePipelineFromShaders :: forall (m :: * -> *) spec.
(MonadResource m, MonadUnliftIO m, MonadFail m,
 Specialization spec) =>
Device
-> RenderPass
-> PipelineConfig
-> spec
-> [(ShaderStageFlagBits, ByteString)]
-> m (ReleaseKey, Pipeline)
allocatePipelineFromShaders Device
dev RenderPass
renderPass PipelineConfig
config spec
spec [(ShaderStageFlagBits, ByteString)]
shaders =
  Device
-> spec
-> [(ShaderStageFlagBits, ByteString)]
-> (Vector (SomeStruct PipelineShaderStageCreateInfo)
    -> m (ReleaseKey, Pipeline))
-> m (ReleaseKey, Pipeline)
forall (m :: * -> *) spec a.
(MonadResource m, MonadUnliftIO m, Specialization spec) =>
Device
-> spec
-> [(ShaderStageFlagBits, ByteString)]
-> (Vector (SomeStruct PipelineShaderStageCreateInfo) -> m a)
-> m a
withCompiledStages Device
dev spec
spec [(ShaderStageFlagBits, ByteString)]
shaders (Device
-> RenderPass
-> PipelineConfig
-> Vector (SomeStruct PipelineShaderStageCreateInfo)
-> m (ReleaseKey, Pipeline)
forall (m :: * -> *).
(MonadResource m, MonadFail m) =>
Device
-> RenderPass
-> PipelineConfig
-> Vector (SomeStruct PipelineShaderStageCreateInfo)
-> m (ReleaseKey, Pipeline)
allocatePipeline Device
dev RenderPass
renderPass PipelineConfig
config)