module Resource.Image where

import RIO

import Data.Bits (shiftR, (.|.))
import RIO.Vector qualified as Vector
import Vulkan.Core10 qualified as Vk
import Vulkan.CStruct.Extends (SomeStruct(..))
import Vulkan.NamedType ((:::))
import Vulkan.Utils.Debug qualified as Debug
import Vulkan.Zero (zero)
import VulkanMemoryAllocator qualified as VMA

import Engine.Vulkan.Types (HasVulkan(..), HasSwapchain(..), Queues(..))
import Resource.CommandBuffer (oneshot_)

data AllocatedImage = AllocatedImage
  { AllocatedImage -> Allocation
aiAllocation :: VMA.Allocation
  , AllocatedImage -> Image
aiImage      :: Vk.Image
  , AllocatedImage -> ImageView
aiImageView  :: Vk.ImageView
  }
  deriving (Int -> AllocatedImage -> ShowS
[AllocatedImage] -> ShowS
AllocatedImage -> String
(Int -> AllocatedImage -> ShowS)
-> (AllocatedImage -> String)
-> ([AllocatedImage] -> ShowS)
-> Show AllocatedImage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AllocatedImage] -> ShowS
$cshowList :: [AllocatedImage] -> ShowS
show :: AllocatedImage -> String
$cshow :: AllocatedImage -> String
showsPrec :: Int -> AllocatedImage -> ShowS
$cshowsPrec :: Int -> AllocatedImage -> ShowS
Show)

createColorResource
  :: ( MonadIO io
     , HasVulkan ctx
     , HasSwapchain ctx
     )
  => ctx
  -> Vk.Extent2D
  -> io AllocatedImage
createColorResource :: ctx -> Extent2D -> io AllocatedImage
createColorResource ctx
context Vk.Extent2D{Word32
$sel:width:Extent2D :: Extent2D -> Word32
width :: Word32
width, Word32
$sel:height:Extent2D :: Extent2D -> Word32
height :: Word32
height} = do
  let
    device :: Device
device    = ctx -> Device
forall a. HasVulkan a => a -> Device
getDevice ctx
context
    allocator :: Allocator
allocator = ctx -> Allocator
forall a. HasVulkan a => a -> Allocator
getAllocator ctx
context
    format :: Format
format    = ctx -> Format
forall a. HasSwapchain a => a -> Format
getSurfaceFormat ctx
context
    msaa :: SampleCountFlagBits
msaa      = ctx -> SampleCountFlagBits
forall a. HasSwapchain a => a -> SampleCountFlagBits
getMultisample ctx
context

  (Image
image, Allocation
allocation, AllocationInfo
_info) <- Allocator
-> ImageCreateInfo '[]
-> AllocationCreateInfo
-> io (Image, Allocation, AllocationInfo)
forall (a :: [*]) (io :: * -> *).
(Extendss ImageCreateInfo a, PokeChain a, MonadIO io) =>
Allocator
-> ImageCreateInfo a
-> AllocationCreateInfo
-> io (Image, Allocation, AllocationInfo)
VMA.createImage
    Allocator
allocator
    (Format -> SampleCountFlagBits -> ImageCreateInfo '[]
imageCI Format
format SampleCountFlagBits
msaa)
    AllocationCreateInfo
imageAllocationCI
  Device -> Image -> ByteString -> io ()
forall a (m :: * -> *).
(HasObjectType a, MonadIO m) =>
Device -> a -> ByteString -> m ()
Debug.nameObject Device
device Image
image ByteString
"ColorResource.image"

  ImageView
imageView <- Device
-> ImageViewCreateInfo '[]
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ImageView
forall (a :: [*]) (io :: * -> *).
(Extendss ImageViewCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> ImageViewCreateInfo a
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ImageView
Vk.createImageView
    Device
device
    (Image -> Format -> ImageViewCreateInfo '[]
imageViewCI Image
image Format
format)
    "allocator" ::: Maybe AllocationCallbacks
forall a. Maybe a
Nothing
  Device -> Image -> ByteString -> io ()
forall a (m :: * -> *).
(HasObjectType a, MonadIO m) =>
Device -> a -> ByteString -> m ()
Debug.nameObject Device
device Image
image ByteString
"ColorResource.view"

  pure AllocatedImage :: Allocation -> Image -> ImageView -> AllocatedImage
AllocatedImage
    { $sel:aiAllocation:AllocatedImage :: Allocation
aiAllocation = Allocation
allocation
    , $sel:aiImage:AllocatedImage :: Image
aiImage      = Image
image
    , $sel:aiImageView:AllocatedImage :: ImageView
aiImageView  = ImageView
imageView
    }
  where
    imageCI :: Format -> SampleCountFlagBits -> ImageCreateInfo '[]
imageCI Format
format SampleCountFlagBits
msaa = ImageCreateInfo '[]
forall a. Zero a => a
zero
      { $sel:imageType:ImageCreateInfo :: ImageType
Vk.imageType     = ImageType
Vk.IMAGE_TYPE_2D
      , $sel:format:ImageCreateInfo :: Format
Vk.format        = Format
format
      , $sel:extent:ImageCreateInfo :: Extent3D
Vk.extent        = Word32 -> Word32 -> Word32 -> Extent3D
Vk.Extent3D Word32
width Word32
height Word32
1
      , $sel:mipLevels:ImageCreateInfo :: Word32
Vk.mipLevels     = Word32
1
      , $sel:arrayLayers:ImageCreateInfo :: Word32
Vk.arrayLayers   = Word32
1
      , $sel:tiling:ImageCreateInfo :: ImageTiling
Vk.tiling        = ImageTiling
Vk.IMAGE_TILING_OPTIMAL
      , $sel:initialLayout:ImageCreateInfo :: ImageLayout
Vk.initialLayout = ImageLayout
Vk.IMAGE_LAYOUT_UNDEFINED
      , $sel:usage:ImageCreateInfo :: ImageUsageFlags
Vk.usage         = ImageUsageFlags
Vk.IMAGE_USAGE_TRANSIENT_ATTACHMENT_BIT ImageUsageFlags -> ImageUsageFlags -> ImageUsageFlags
forall a. Bits a => a -> a -> a
.|. ImageUsageFlags
Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT
      , $sel:sharingMode:ImageCreateInfo :: SharingMode
Vk.sharingMode   = SharingMode
Vk.SHARING_MODE_EXCLUSIVE
      , $sel:samples:ImageCreateInfo :: SampleCountFlagBits
Vk.samples       = SampleCountFlagBits
msaa
      }

    imageAllocationCI :: AllocationCreateInfo
imageAllocationCI = AllocationCreateInfo
forall a. Zero a => a
zero
      { $sel:usage:AllocationCreateInfo :: MemoryUsage
VMA.usage         = MemoryUsage
VMA.MEMORY_USAGE_GPU_ONLY
      , $sel:requiredFlags:AllocationCreateInfo :: MemoryPropertyFlags
VMA.requiredFlags = MemoryPropertyFlags
Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT
      }

    imageViewCI :: Image -> Format -> ImageViewCreateInfo '[]
imageViewCI Image
image Format
format = ImageViewCreateInfo '[]
forall a. Zero a => a
zero
      { $sel:image:ImageViewCreateInfo :: Image
Vk.image            = Image
image
      , $sel:viewType:ImageViewCreateInfo :: ImageViewType
Vk.viewType         = ImageViewType
Vk.IMAGE_VIEW_TYPE_2D
      , $sel:format:ImageViewCreateInfo :: Format
Vk.format           = Format
format
      , $sel:components:ImageViewCreateInfo :: ComponentMapping
Vk.components       = ComponentMapping
forall a. Zero a => a
zero
      , $sel:subresourceRange:ImageViewCreateInfo :: ImageSubresourceRange
Vk.subresourceRange = ImageSubresourceRange
subr
      }

    subr :: ImageSubresourceRange
subr = ImageSubresourceRange
forall a. Zero a => a
zero
      { $sel:aspectMask:ImageSubresourceRange :: ImageAspectFlags
Vk.aspectMask     = ImageAspectFlags
Vk.IMAGE_ASPECT_COLOR_BIT
      , $sel:baseMipLevel:ImageSubresourceRange :: Word32
Vk.baseMipLevel   = Word32
0
      , $sel:levelCount:ImageSubresourceRange :: Word32
Vk.levelCount     = Word32
1
      , $sel:baseArrayLayer:ImageSubresourceRange :: Word32
Vk.baseArrayLayer = Word32
0
      , $sel:layerCount:ImageSubresourceRange :: Word32
Vk.layerCount     = Word32
1
      }

createDepthResource
  :: ( MonadIO io
     , HasVulkan context
     , HasSwapchain context
     )
  => context
  -> Vk.Extent2D
  -> "shadowmap layers" ::: Maybe Word32
  -> io AllocatedImage
createDepthResource :: context
-> Extent2D
-> ("shadowmap layers" ::: Maybe Word32)
-> io AllocatedImage
createDepthResource context
context Vk.Extent2D{Word32
width :: Word32
$sel:width:Extent2D :: Extent2D -> Word32
width, Word32
height :: Word32
$sel:height:Extent2D :: Extent2D -> Word32
height} "shadowmap layers" ::: Maybe Word32
depthLayers = do
  let
    device :: Device
device    = context -> Device
forall a. HasVulkan a => a -> Device
getDevice context
context
    allocator :: Allocator
allocator = context -> Allocator
forall a. HasVulkan a => a -> Allocator
getAllocator context
context

    depthFormat :: Format
depthFormat = context -> Format
forall a. HasSwapchain a => a -> Format
getDepthFormat context
context
    msaa :: SampleCountFlagBits
msaa        = context -> SampleCountFlagBits
forall a. HasSwapchain a => a -> SampleCountFlagBits
getMultisample context
context

    (SampleCountFlagBits
samples, ImageUsageFlags
usage, Word32
numLayers) =
      case "shadowmap layers" ::: Maybe Word32
depthLayers of
        "shadowmap layers" ::: Maybe Word32
Nothing ->
          ( SampleCountFlagBits
msaa
          , ImageUsageFlags
Vk.IMAGE_USAGE_DEPTH_STENCIL_ATTACHMENT_BIT
          , Word32
1
          )
        Just Word32
nl ->
          ( SampleCountFlagBits
Vk.SAMPLE_COUNT_1_BIT
          , ImageUsageFlags
Vk.IMAGE_USAGE_DEPTH_STENCIL_ATTACHMENT_BIT ImageUsageFlags -> ImageUsageFlags -> ImageUsageFlags
forall a. Bits a => a -> a -> a
.|.
            ImageUsageFlags
Vk.IMAGE_USAGE_SAMPLED_BIT
          , Word32
nl
          )

  (Image
image, Allocation
allocation, AllocationInfo
_info) <- Allocator
-> ImageCreateInfo '[]
-> AllocationCreateInfo
-> io (Image, Allocation, AllocationInfo)
forall (a :: [*]) (io :: * -> *).
(Extendss ImageCreateInfo a, PokeChain a, MonadIO io) =>
Allocator
-> ImageCreateInfo a
-> AllocationCreateInfo
-> io (Image, Allocation, AllocationInfo)
VMA.createImage
    Allocator
allocator
    (Format
-> ImageUsageFlags
-> SampleCountFlagBits
-> Word32
-> ImageCreateInfo '[]
imageCI Format
depthFormat ImageUsageFlags
usage SampleCountFlagBits
samples Word32
numLayers)
    AllocationCreateInfo
imageAllocationCI
  Device -> Image -> ByteString -> io ()
forall a (m :: * -> *).
(HasObjectType a, MonadIO m) =>
Device -> a -> ByteString -> m ()
Debug.nameObject Device
device Image
image ByteString
"DepthResource.image"

  ImageView
imageView <- Device
-> ImageViewCreateInfo '[]
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ImageView
forall (a :: [*]) (io :: * -> *).
(Extendss ImageViewCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> ImageViewCreateInfo a
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ImageView
Vk.createImageView
    Device
device
    (Format -> Image -> Word32 -> ImageViewCreateInfo '[]
imageViewCI Format
depthFormat Image
image Word32
numLayers)
    "allocator" ::: Maybe AllocationCallbacks
forall a. Maybe a
Nothing
  Device -> Image -> ByteString -> io ()
forall a (m :: * -> *).
(HasObjectType a, MonadIO m) =>
Device -> a -> ByteString -> m ()
Debug.nameObject Device
device Image
image ByteString
"DepthResource.view"

  pure AllocatedImage :: Allocation -> Image -> ImageView -> AllocatedImage
AllocatedImage
    { $sel:aiAllocation:AllocatedImage :: Allocation
aiAllocation = Allocation
allocation
    , $sel:aiImage:AllocatedImage :: Image
aiImage      = Image
image
    , $sel:aiImageView:AllocatedImage :: ImageView
aiImageView  = ImageView
imageView
    }
  where
    imageCI :: Format
-> ImageUsageFlags
-> SampleCountFlagBits
-> Word32
-> ImageCreateInfo '[]
imageCI Format
format ImageUsageFlags
usage SampleCountFlagBits
samples Word32
numLayers = ImageCreateInfo '[]
forall a. Zero a => a
zero
      { $sel:imageType:ImageCreateInfo :: ImageType
Vk.imageType     = ImageType
Vk.IMAGE_TYPE_2D
      , $sel:format:ImageCreateInfo :: Format
Vk.format        = Format
format
      , $sel:extent:ImageCreateInfo :: Extent3D
Vk.extent        = Word32 -> Word32 -> Word32 -> Extent3D
Vk.Extent3D Word32
width Word32
height Word32
1
      , $sel:mipLevels:ImageCreateInfo :: Word32
Vk.mipLevels     = Word32
1
      , $sel:arrayLayers:ImageCreateInfo :: Word32
Vk.arrayLayers   = Word32
numLayers
      , $sel:tiling:ImageCreateInfo :: ImageTiling
Vk.tiling        = ImageTiling
Vk.IMAGE_TILING_OPTIMAL
      , $sel:initialLayout:ImageCreateInfo :: ImageLayout
Vk.initialLayout = ImageLayout
Vk.IMAGE_LAYOUT_UNDEFINED
      , $sel:usage:ImageCreateInfo :: ImageUsageFlags
Vk.usage         = ImageUsageFlags
usage
      , $sel:sharingMode:ImageCreateInfo :: SharingMode
Vk.sharingMode   = SharingMode
Vk.SHARING_MODE_EXCLUSIVE
      , $sel:samples:ImageCreateInfo :: SampleCountFlagBits
Vk.samples       = SampleCountFlagBits
samples
      }

    imageAllocationCI :: AllocationCreateInfo
imageAllocationCI = AllocationCreateInfo
forall a. Zero a => a
zero
      { $sel:usage:AllocationCreateInfo :: MemoryUsage
VMA.usage         = MemoryUsage
VMA.MEMORY_USAGE_GPU_ONLY
      , $sel:requiredFlags:AllocationCreateInfo :: MemoryPropertyFlags
VMA.requiredFlags = MemoryPropertyFlags
Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT
      }

    imageViewCI :: Format -> Image -> Word32 -> ImageViewCreateInfo '[]
imageViewCI Format
format Image
image Word32
numLayers = ImageViewCreateInfo '[]
forall a. Zero a => a
zero
      { $sel:image:ImageViewCreateInfo :: Image
Vk.image            = Image
image
      , $sel:viewType:ImageViewCreateInfo :: ImageViewType
Vk.viewType         = ImageViewType
viewType
      , $sel:format:ImageViewCreateInfo :: Format
Vk.format           = Format
format
      , $sel:components:ImageViewCreateInfo :: ComponentMapping
Vk.components       = ComponentMapping
forall a. Zero a => a
zero
      , $sel:subresourceRange:ImageViewCreateInfo :: ImageSubresourceRange
Vk.subresourceRange = Word32 -> ImageSubresourceRange
subr Word32
numLayers
      }
      where
        viewType :: ImageViewType
viewType =
          if Word32
numLayers Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
1 then
            ImageViewType
Vk.IMAGE_VIEW_TYPE_2D_ARRAY
          else
            ImageViewType
Vk.IMAGE_VIEW_TYPE_2D

    subr :: Word32 -> ImageSubresourceRange
subr Word32
numLayers = ImageSubresourceRange
forall a. Zero a => a
zero
      { $sel:aspectMask:ImageSubresourceRange :: ImageAspectFlags
Vk.aspectMask     = ImageAspectFlags
Vk.IMAGE_ASPECT_DEPTH_BIT
      , $sel:baseMipLevel:ImageSubresourceRange :: Word32
Vk.baseMipLevel   = Word32
0
      , $sel:levelCount:ImageSubresourceRange :: Word32
Vk.levelCount     = Word32
1
      , $sel:baseArrayLayer:ImageSubresourceRange :: Word32
Vk.baseArrayLayer = Word32
0
      , $sel:layerCount:ImageSubresourceRange :: Word32
Vk.layerCount     = Word32
numLayers
      }

destroyAllocatedImage
  :: ( MonadIO io
     , HasVulkan context
     )
  => context
  -> AllocatedImage
  -> io ()
destroyAllocatedImage :: context -> AllocatedImage -> io ()
destroyAllocatedImage context
context AllocatedImage{Image
ImageView
Allocation
aiImageView :: ImageView
aiImage :: Image
aiAllocation :: Allocation
$sel:aiImageView:AllocatedImage :: AllocatedImage -> ImageView
$sel:aiImage:AllocatedImage :: AllocatedImage -> Image
$sel:aiAllocation:AllocatedImage :: AllocatedImage -> Allocation
..} = do
  -- traceM "destroyAllocatedImage"
  Device
-> ImageView
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ()
forall (io :: * -> *).
MonadIO io =>
Device
-> ImageView
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ()
Vk.destroyImageView (context -> Device
forall a. HasVulkan a => a -> Device
getDevice context
context) ImageView
aiImageView "allocator" ::: Maybe AllocationCallbacks
forall a. Maybe a
Nothing
  Allocator -> Image -> Allocation -> io ()
forall (io :: * -> *).
MonadIO io =>
Allocator -> Image -> Allocation -> io ()
VMA.destroyImage (context -> Allocator
forall a. HasVulkan a => a -> Allocator
getAllocator context
context) Image
aiImage Allocation
aiAllocation

--------------------------------------------

transitionImageLayout
  :: (HasVulkan context)
  => context
  -> Queues Vk.CommandPool
  -> Vk.Image
  -> "mip levels" ::: Word32
  -> "layer count" ::: Word32
  -> Vk.Format
  -> ("old" ::: Vk.ImageLayout)
  -> ("new" ::: Vk.ImageLayout)
  -> RIO env ()
transitionImageLayout :: context
-> Queues CommandPool
-> Image
-> Word32
-> Word32
-> Format
-> ImageLayout
-> ImageLayout
-> RIO env ()
transitionImageLayout context
ctx Queues CommandPool
pool Image
image Word32
mipLevels Word32
layerCount Format
format ImageLayout
old ImageLayout
new =
  case (ImageLayout
old, ImageLayout
new) of
    (ImageLayout
Vk.IMAGE_LAYOUT_UNDEFINED, ImageLayout
Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL) ->
      context
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> RIO env ())
-> RIO env ()
forall context (m :: * -> *).
(HasVulkan context, MonadUnliftIO m) =>
context
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> m ())
-> m ()
oneshot_ context
ctx Queues CommandPool
pool forall a. Queues a -> a
qTransfer \CommandBuffer
buf ->
        CommandBuffer
-> ("srcStageMask" ::: PipelineStageFlags)
-> ("srcStageMask" ::: PipelineStageFlags)
-> DependencyFlags
-> ("memoryBarriers" ::: Vector MemoryBarrier)
-> ("bufferMemoryBarriers" ::: Vector BufferMemoryBarrier)
-> ("imageMemoryBarriers"
    ::: Vector (SomeStruct ImageMemoryBarrier))
-> RIO env ()
forall (io :: * -> *).
MonadIO io =>
CommandBuffer
-> ("srcStageMask" ::: PipelineStageFlags)
-> ("srcStageMask" ::: PipelineStageFlags)
-> DependencyFlags
-> ("memoryBarriers" ::: Vector MemoryBarrier)
-> ("bufferMemoryBarriers" ::: Vector BufferMemoryBarrier)
-> ("imageMemoryBarriers"
    ::: Vector (SomeStruct ImageMemoryBarrier))
-> io ()
Vk.cmdPipelineBarrier
          CommandBuffer
buf
          "srcStageMask" ::: PipelineStageFlags
Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT
          "srcStageMask" ::: PipelineStageFlags
Vk.PIPELINE_STAGE_TRANSFER_BIT
          DependencyFlags
forall a. Zero a => a
zero
          "memoryBarriers" ::: Vector MemoryBarrier
forall a. Monoid a => a
mempty
          "bufferMemoryBarriers" ::: Vector BufferMemoryBarrier
forall a. Monoid a => a
mempty
          ( SomeStruct ImageMemoryBarrier
-> "imageMemoryBarriers" ::: Vector (SomeStruct ImageMemoryBarrier)
forall (v :: * -> *) a. Vector v a => a -> v a
Vector.singleton (SomeStruct ImageMemoryBarrier
 -> "imageMemoryBarriers"
    ::: Vector (SomeStruct ImageMemoryBarrier))
-> SomeStruct ImageMemoryBarrier
-> "imageMemoryBarriers" ::: Vector (SomeStruct ImageMemoryBarrier)
forall a b. (a -> b) -> a -> b
$
              ImageAspectFlags
-> AccessFlags -> AccessFlags -> SomeStruct ImageMemoryBarrier
barrier ImageAspectFlags
Vk.IMAGE_ASPECT_COLOR_BIT AccessFlags
forall a. Zero a => a
zero AccessFlags
Vk.ACCESS_TRANSFER_WRITE_BIT
          )
    (ImageLayout
Vk.IMAGE_LAYOUT_UNDEFINED, ImageLayout
Vk.IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL) ->
      context
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> RIO env ())
-> RIO env ()
forall context (m :: * -> *).
(HasVulkan context, MonadUnliftIO m) =>
context
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> m ())
-> m ()
oneshot_ context
ctx Queues CommandPool
pool forall a. Queues a -> a
qTransfer \CommandBuffer
buf ->
        CommandBuffer
-> ("srcStageMask" ::: PipelineStageFlags)
-> ("srcStageMask" ::: PipelineStageFlags)
-> DependencyFlags
-> ("memoryBarriers" ::: Vector MemoryBarrier)
-> ("bufferMemoryBarriers" ::: Vector BufferMemoryBarrier)
-> ("imageMemoryBarriers"
    ::: Vector (SomeStruct ImageMemoryBarrier))
-> RIO env ()
forall (io :: * -> *).
MonadIO io =>
CommandBuffer
-> ("srcStageMask" ::: PipelineStageFlags)
-> ("srcStageMask" ::: PipelineStageFlags)
-> DependencyFlags
-> ("memoryBarriers" ::: Vector MemoryBarrier)
-> ("bufferMemoryBarriers" ::: Vector BufferMemoryBarrier)
-> ("imageMemoryBarriers"
    ::: Vector (SomeStruct ImageMemoryBarrier))
-> io ()
Vk.cmdPipelineBarrier
          CommandBuffer
buf
          "srcStageMask" ::: PipelineStageFlags
Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT
          "srcStageMask" ::: PipelineStageFlags
Vk.PIPELINE_STAGE_EARLY_FRAGMENT_TESTS_BIT
          DependencyFlags
forall a. Zero a => a
zero
          "memoryBarriers" ::: Vector MemoryBarrier
forall a. Monoid a => a
mempty
          "bufferMemoryBarriers" ::: Vector BufferMemoryBarrier
forall a. Monoid a => a
mempty
          ( SomeStruct ImageMemoryBarrier
-> "imageMemoryBarriers" ::: Vector (SomeStruct ImageMemoryBarrier)
forall (v :: * -> *) a. Vector v a => a -> v a
Vector.singleton (SomeStruct ImageMemoryBarrier
 -> "imageMemoryBarriers"
    ::: Vector (SomeStruct ImageMemoryBarrier))
-> SomeStruct ImageMemoryBarrier
-> "imageMemoryBarriers" ::: Vector (SomeStruct ImageMemoryBarrier)
forall a b. (a -> b) -> a -> b
$
              ImageAspectFlags
-> AccessFlags -> AccessFlags -> SomeStruct ImageMemoryBarrier
barrier ImageAspectFlags
aspectMask AccessFlags
forall a. Zero a => a
zero (AccessFlags -> SomeStruct ImageMemoryBarrier)
-> AccessFlags -> SomeStruct ImageMemoryBarrier
forall a b. (a -> b) -> a -> b
$
                AccessFlags
Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_READ_BIT AccessFlags -> AccessFlags -> AccessFlags
forall a. Bits a => a -> a -> a
.|.
                AccessFlags
Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_WRITE_BIT
          )
        where
          aspectMask :: ImageAspectFlags
aspectMask =
            if Bool
hasStencilComponent then
              ImageAspectFlags
Vk.IMAGE_ASPECT_DEPTH_BIT ImageAspectFlags -> ImageAspectFlags -> ImageAspectFlags
forall a. Bits a => a -> a -> a
.|. ImageAspectFlags
Vk.IMAGE_ASPECT_STENCIL_BIT
            else
              ImageAspectFlags
Vk.IMAGE_ASPECT_DEPTH_BIT
          hasStencilComponent :: Bool
hasStencilComponent =
            Format
format Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
Vk.FORMAT_D32_SFLOAT_S8_UINT Bool -> Bool -> Bool
||
            Format
format Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
Vk.FORMAT_D24_UNORM_S8_UINT

    (ImageLayout
Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL, ImageLayout
Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL) ->
      context
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> RIO env ())
-> RIO env ()
forall context (m :: * -> *).
(HasVulkan context, MonadUnliftIO m) =>
context
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> m ())
-> m ()
oneshot_ context
ctx Queues CommandPool
pool forall a. Queues a -> a
qGraphics \CommandBuffer
buf ->
        CommandBuffer
-> ("srcStageMask" ::: PipelineStageFlags)
-> ("srcStageMask" ::: PipelineStageFlags)
-> DependencyFlags
-> ("memoryBarriers" ::: Vector MemoryBarrier)
-> ("bufferMemoryBarriers" ::: Vector BufferMemoryBarrier)
-> ("imageMemoryBarriers"
    ::: Vector (SomeStruct ImageMemoryBarrier))
-> RIO env ()
forall (io :: * -> *).
MonadIO io =>
CommandBuffer
-> ("srcStageMask" ::: PipelineStageFlags)
-> ("srcStageMask" ::: PipelineStageFlags)
-> DependencyFlags
-> ("memoryBarriers" ::: Vector MemoryBarrier)
-> ("bufferMemoryBarriers" ::: Vector BufferMemoryBarrier)
-> ("imageMemoryBarriers"
    ::: Vector (SomeStruct ImageMemoryBarrier))
-> io ()
Vk.cmdPipelineBarrier
          CommandBuffer
buf
          "srcStageMask" ::: PipelineStageFlags
Vk.PIPELINE_STAGE_TRANSFER_BIT
          "srcStageMask" ::: PipelineStageFlags
Vk.PIPELINE_STAGE_FRAGMENT_SHADER_BIT
          DependencyFlags
forall a. Zero a => a
zero
          "memoryBarriers" ::: Vector MemoryBarrier
forall a. Monoid a => a
mempty
          "bufferMemoryBarriers" ::: Vector BufferMemoryBarrier
forall a. Monoid a => a
mempty
          ( SomeStruct ImageMemoryBarrier
-> "imageMemoryBarriers" ::: Vector (SomeStruct ImageMemoryBarrier)
forall (v :: * -> *) a. Vector v a => a -> v a
Vector.singleton (SomeStruct ImageMemoryBarrier
 -> "imageMemoryBarriers"
    ::: Vector (SomeStruct ImageMemoryBarrier))
-> SomeStruct ImageMemoryBarrier
-> "imageMemoryBarriers" ::: Vector (SomeStruct ImageMemoryBarrier)
forall a b. (a -> b) -> a -> b
$
              ImageAspectFlags
-> AccessFlags -> AccessFlags -> SomeStruct ImageMemoryBarrier
barrier
                ImageAspectFlags
Vk.IMAGE_ASPECT_COLOR_BIT
                AccessFlags
Vk.ACCESS_TRANSFER_WRITE_BIT
                AccessFlags
Vk.ACCESS_SHADER_READ_BIT
          )
    (ImageLayout, ImageLayout)
_ ->
      String -> RIO env ()
forall a. HasCallStack => String -> a
error (String -> RIO env ()) -> String -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String
"Unsupported image layout transfer: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (ImageLayout, ImageLayout) -> String
forall a. Show a => a -> String
show (ImageLayout
old, ImageLayout
new)
  where
    barrier :: ImageAspectFlags
-> AccessFlags -> AccessFlags -> SomeStruct ImageMemoryBarrier
barrier ImageAspectFlags
aspectMask AccessFlags
srcMask AccessFlags
dstMask = ImageMemoryBarrier '[] -> SomeStruct ImageMemoryBarrier
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct ImageMemoryBarrier '[]
forall a. Zero a => a
zero
      { $sel:srcAccessMask:ImageMemoryBarrier :: AccessFlags
Vk.srcAccessMask       = AccessFlags
srcMask
      , $sel:dstAccessMask:ImageMemoryBarrier :: AccessFlags
Vk.dstAccessMask       = AccessFlags
dstMask
      , $sel:oldLayout:ImageMemoryBarrier :: ImageLayout
Vk.oldLayout           = ImageLayout
old
      , $sel:newLayout:ImageMemoryBarrier :: ImageLayout
Vk.newLayout           = ImageLayout
new
      , $sel:srcQueueFamilyIndex:ImageMemoryBarrier :: Word32
Vk.srcQueueFamilyIndex = Word32
Vk.QUEUE_FAMILY_IGNORED
      , $sel:dstQueueFamilyIndex:ImageMemoryBarrier :: Word32
Vk.dstQueueFamilyIndex = Word32
Vk.QUEUE_FAMILY_IGNORED
      , $sel:image:ImageMemoryBarrier :: Image
Vk.image               = Image
image
      , $sel:subresourceRange:ImageMemoryBarrier :: ImageSubresourceRange
Vk.subresourceRange    = ImageAspectFlags -> Word32 -> Word32 -> ImageSubresourceRange
subresource ImageAspectFlags
aspectMask Word32
mipLevels Word32
layerCount
      }

subresource
  :: Vk.ImageAspectFlags
  -> "mip levels" ::: Word32
  -> "layer count" ::: Word32
  -> Vk.ImageSubresourceRange
subresource :: ImageAspectFlags -> Word32 -> Word32 -> ImageSubresourceRange
subresource ImageAspectFlags
aspectMask Word32
mipLevels Word32
layerCount = ImageSubresourceRange :: ImageAspectFlags
-> Word32 -> Word32 -> Word32 -> Word32 -> ImageSubresourceRange
Vk.ImageSubresourceRange
  { $sel:aspectMask:ImageSubresourceRange :: ImageAspectFlags
aspectMask     = ImageAspectFlags
aspectMask
  , $sel:baseMipLevel:ImageSubresourceRange :: Word32
baseMipLevel   = Word32
0
  , $sel:levelCount:ImageSubresourceRange :: Word32
levelCount     = Word32
mipLevels -- XXX: including base
  , $sel:baseArrayLayer:ImageSubresourceRange :: Word32
baseArrayLayer = Word32
0
  , $sel:layerCount:ImageSubresourceRange :: Word32
layerCount     = Word32
layerCount
  }

copyBufferToImage
  :: (HasVulkan context, Foldable t, Integral deviceSize)
  => context
  -> Queues Vk.CommandPool
  -> Vk.Buffer
  -> Vk.Image
  -> "base extent" ::: Vk.Extent3D
  -> "mip offsets" ::: t deviceSize
  -> "layer count" ::: Word32
  -> RIO env ()
copyBufferToImage :: context
-> Queues CommandPool
-> Buffer
-> Image
-> Extent3D
-> ("mip offsets" ::: t deviceSize)
-> Word32
-> RIO env ()
copyBufferToImage context
ctx Queues CommandPool
pool Buffer
src Image
dst Vk.Extent3D{Word32
$sel:width:Extent3D :: Extent3D -> Word32
$sel:height:Extent3D :: Extent3D -> Word32
$sel:depth:Extent3D :: Extent3D -> Word32
depth :: Word32
height :: Word32
width :: Word32
..} "mip offsets" ::: t deviceSize
mipOffsets Word32
layerCount =
  context
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> RIO env ())
-> RIO env ()
forall context (m :: * -> *).
(HasVulkan context, MonadUnliftIO m) =>
context
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> m ())
-> m ()
oneshot_ context
ctx Queues CommandPool
pool forall a. Queues a -> a
qTransfer \CommandBuffer
cmd ->
    CommandBuffer
-> Buffer
-> Image
-> ImageLayout
-> ("regions" ::: Vector BufferImageCopy)
-> RIO env ()
forall (io :: * -> *).
MonadIO io =>
CommandBuffer
-> Buffer
-> Image
-> ImageLayout
-> ("regions" ::: Vector BufferImageCopy)
-> io ()
Vk.cmdCopyBufferToImage CommandBuffer
cmd Buffer
src Image
dst ImageLayout
Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL (("regions" ::: Vector BufferImageCopy) -> RIO env ())
-> ("regions" ::: Vector BufferImageCopy) -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      [BufferImageCopy] -> "regions" ::: Vector BufferImageCopy
forall (v :: * -> *) a. Vector v a => [a] -> v a
Vector.fromList [BufferImageCopy]
copyRegions
  where
    copyRegions :: [BufferImageCopy]
copyRegions = do
      (deviceSize
offset, Int
mipLevel) <- [deviceSize] -> [Int] -> [(deviceSize, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (("mip offsets" ::: t deviceSize) -> [deviceSize]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList "mip offsets" ::: t deviceSize
mipOffsets) [Int
0..]
      BufferImageCopy -> [BufferImageCopy]
forall (f :: * -> *) a. Applicative f => a -> f a
pure BufferImageCopy :: DeviceSize
-> Word32
-> Word32
-> ImageSubresourceLayers
-> Offset3D
-> Extent3D
-> BufferImageCopy
Vk.BufferImageCopy
        { $sel:bufferOffset:BufferImageCopy :: DeviceSize
Vk.bufferOffset      = deviceSize -> DeviceSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral deviceSize
offset
        , $sel:bufferRowLength:BufferImageCopy :: Word32
Vk.bufferRowLength   = Word32
forall a. Zero a => a
zero -- XXX: "use extent width"
        , $sel:bufferImageHeight:BufferImageCopy :: Word32
Vk.bufferImageHeight = Word32
forall a. Zero a => a
zero -- XXX: "use extent height"
        , $sel:imageSubresource:BufferImageCopy :: ImageSubresourceLayers
Vk.imageSubresource = ImageSubresourceLayers :: ImageAspectFlags
-> Word32 -> Word32 -> Word32 -> ImageSubresourceLayers
Vk.ImageSubresourceLayers
            { $sel:aspectMask:ImageSubresourceLayers :: ImageAspectFlags
aspectMask     = ImageAspectFlags
Vk.IMAGE_ASPECT_COLOR_BIT
            , $sel:mipLevel:ImageSubresourceLayers :: Word32
mipLevel       = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mipLevel
            , $sel:baseArrayLayer:ImageSubresourceLayers :: Word32
baseArrayLayer = Word32
0
            , $sel:layerCount:ImageSubresourceLayers :: Word32
layerCount     = Word32
layerCount
            }
        , $sel:imageOffset:BufferImageCopy :: Offset3D
Vk.imageOffset = Offset3D
forall a. Zero a => a
zero
        , $sel:imageExtent:BufferImageCopy :: Extent3D
Vk.imageExtent = Extent3D :: Word32 -> Word32 -> Word32 -> Extent3D
Vk.Extent3D
            { $sel:width:Extent3D :: Word32
width  = Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
1 (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ Word32
width Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
mipLevel
            , $sel:height:Extent3D :: Word32
height = Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
1 (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ Word32
height Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
mipLevel
            , $sel:depth:Extent3D :: Word32
depth  = Word32
depth
            }
        }