{-# LANGUAGE OverloadedLists #-}

module Engine.Vulkan.Swapchain
  ( SwapchainResources(..)
  , SwapchainInfo(..)
  , allocSwapchainResources
  , recreateSwapchainResources
  , createSwapchain
  , threwSwapchainError

  , HasSwapchain(..)

  , setDynamic
  , setDynamicFullscreen
  ) where

import RIO

import Data.Bits (zeroBits, (.&.), (.|.))
import RIO.Vector qualified as V
import UnliftIO.Resource (MonadResource, allocate, release)
import UnliftIO.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk
import Vulkan.Exception (VulkanException(..))
import Vulkan.Extensions.VK_KHR_surface qualified as Khr
import Vulkan.Extensions.VK_KHR_swapchain qualified as Khr
import Vulkan.Utils.Misc ((.&&.))
import Vulkan.NamedType ((:::))
import Vulkan.Zero (zero)

import Engine.Types.RefCounted (RefCounted, newRefCounted, releaseRefCounted)
import Engine.Vulkan.Types (MonadVulkan, HasVulkan(..), HasSwapchain(..), pdiProperties)
import Engine.Worker qualified as Worker

data SwapchainResources = SwapchainResources
  { SwapchainResources -> SwapchainInfo
srInfo       :: SwapchainInfo
  , SwapchainResources -> Vector ImageView
srImageViews :: Vector Vk.ImageView
  , SwapchainResources -> Vector Image
srImages     :: Vector Vk.Image
  , SwapchainResources -> RefCounted
srRelease    :: RefCounted
  , SwapchainResources -> Var Extent2D
srScreenVar  :: Worker.Var Vk.Extent2D
  }

data SwapchainInfo = SwapchainInfo
  { SwapchainInfo -> SwapchainKHR
siSwapchain           :: Khr.SwapchainKHR
  , SwapchainInfo -> ReleaseKey
siSwapchainReleaseKey :: Resource.ReleaseKey
  , SwapchainInfo -> PresentModeKHR
siPresentMode         :: Khr.PresentModeKHR
  , SwapchainInfo -> Word32
siMinImageCount       :: Word32
  , SwapchainInfo -> Format
siSurfaceFormat       :: Vk.Format
  , SwapchainInfo -> ColorSpaceKHR
siSurfaceColorspace   :: Khr.ColorSpaceKHR
  , SwapchainInfo -> Format
siDepthFormat         :: Vk.Format
  , SwapchainInfo -> SampleCountFlagBits
siMultisample         :: Vk.SampleCountFlagBits
  , SwapchainInfo -> Float
siAnisotropy          :: Float
  , SwapchainInfo -> Extent2D
siImageExtent         :: Vk.Extent2D
  , SwapchainInfo -> SurfaceKHR
siSurface             :: Khr.SurfaceKHR
  }

instance HasSwapchain SwapchainResources where
  getSurfaceExtent :: SwapchainResources -> Extent2D
getSurfaceExtent  = SwapchainInfo -> Extent2D
siImageExtent forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwapchainResources -> SwapchainInfo
srInfo
  getSurfaceFormat :: SwapchainResources -> Format
getSurfaceFormat  = SwapchainInfo -> Format
siSurfaceFormat forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwapchainResources -> SwapchainInfo
srInfo
  getDepthFormat :: SwapchainResources -> Format
getDepthFormat    = SwapchainInfo -> Format
siDepthFormat forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwapchainResources -> SwapchainInfo
srInfo
  getMultisample :: SwapchainResources -> SampleCountFlagBits
getMultisample    = SwapchainInfo -> SampleCountFlagBits
siMultisample forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwapchainResources -> SwapchainInfo
srInfo
  getAnisotropy :: SwapchainResources -> Float
getAnisotropy     = SwapchainInfo -> Float
siAnisotropy forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwapchainResources -> SwapchainInfo
srInfo
  getSwapchainViews :: SwapchainResources -> Vector ImageView
getSwapchainViews = SwapchainResources -> Vector ImageView
srImageViews
  getMinImageCount :: SwapchainResources -> Word32
getMinImageCount  = SwapchainInfo -> Word32
siMinImageCount forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwapchainResources -> SwapchainInfo
srInfo
  getImageCount :: SwapchainResources -> Word32
getImageCount     = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) a. Vector v a => v a -> Int
V.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwapchainResources -> Vector Image
srImages

-- | Allocate everything which depends on the swapchain
allocSwapchainResources
  :: ( MonadResource (RIO env)
     , HasVulkan env
     , HasLogFunc env
     )
  => Khr.SwapchainKHR
  -- ^ Previous swapchain, can be NULL_HANDLE
  -> Vk.Extent2D
  -- ^ If the swapchain size determines the surface size, use this size
  -> Khr.SurfaceKHR
  -> Worker.Var Vk.Extent2D
  -> RIO env SwapchainResources
  -- -> ResourceT (RIO env) SwapchainResources
allocSwapchainResources :: forall env.
(MonadResource (RIO env), HasVulkan env, HasLogFunc env) =>
SwapchainKHR
-> Extent2D
-> SurfaceKHR
-> Var Extent2D
-> RIO env SwapchainResources
allocSwapchainResources SwapchainKHR
oldSwapchain Extent2D
windowSize SurfaceKHR
surface Var Extent2D
screenVar = do
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Allocating swapchain resources"

  Device
device <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice
  info :: SwapchainInfo
info@SwapchainInfo{Float
Word32
ReleaseKey
Format
SampleCountFlagBits
Extent2D
SurfaceKHR
ColorSpaceKHR
PresentModeKHR
SwapchainKHR
siSurface :: SurfaceKHR
siImageExtent :: Extent2D
siAnisotropy :: Float
siMultisample :: SampleCountFlagBits
siDepthFormat :: Format
siSurfaceColorspace :: ColorSpaceKHR
siSurfaceFormat :: Format
siMinImageCount :: Word32
siPresentMode :: PresentModeKHR
siSwapchainReleaseKey :: ReleaseKey
siSwapchain :: SwapchainKHR
$sel:siSurface:SwapchainInfo :: SwapchainInfo -> SurfaceKHR
$sel:siImageExtent:SwapchainInfo :: SwapchainInfo -> Extent2D
$sel:siAnisotropy:SwapchainInfo :: SwapchainInfo -> Float
$sel:siMultisample:SwapchainInfo :: SwapchainInfo -> SampleCountFlagBits
$sel:siDepthFormat:SwapchainInfo :: SwapchainInfo -> Format
$sel:siSurfaceColorspace:SwapchainInfo :: SwapchainInfo -> ColorSpaceKHR
$sel:siSurfaceFormat:SwapchainInfo :: SwapchainInfo -> Format
$sel:siMinImageCount:SwapchainInfo :: SwapchainInfo -> Word32
$sel:siPresentMode:SwapchainInfo :: SwapchainInfo -> PresentModeKHR
$sel:siSwapchainReleaseKey:SwapchainInfo :: SwapchainInfo -> ReleaseKey
$sel:siSwapchain:SwapchainInfo :: SwapchainInfo -> SwapchainKHR
..} <- forall (m :: * -> *) env.
(MonadResource m, MonadVulkan env m, HasLogFunc env) =>
SwapchainKHR -> Extent2D -> SurfaceKHR -> m SwapchainInfo
createSwapchain SwapchainKHR
oldSwapchain Extent2D
windowSize SurfaceKHR
surface

  -- XXX: Get all the swapchain images, and create views for them
  (Result
_, Vector Image
swapchainImages) <- forall (io :: * -> *).
MonadIO io =>
Device -> SwapchainKHR -> io (Result, Vector Image)
Khr.getSwapchainImagesKHR Device
device SwapchainKHR
siSwapchain
  Vector (ReleaseKey, ImageView)
res <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Vector Image
swapchainImages forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) env.
(MonadResource m, MonadVulkan env m) =>
Format -> Image -> m (ReleaseKey, ImageView)
createImageView Format
siSurfaceFormat
  let (Vector ReleaseKey
imageViewKeys, Vector ImageView
imageViews) = forall (v :: * -> *) a b.
(Vector v a, Vector v b, Vector v (a, b)) =>
v (a, b) -> (v a, v b)
V.unzip Vector (ReleaseKey, ImageView)
res

  -- XXX: This refcount is released in 'recreateSwapchainResources'
  IO ()
releaseDebug <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Releasing swapchain resources"
  RefCounted
releaseResources <- forall (m :: * -> *). MonadIO m => IO () -> m RefCounted
newRefCounted forall a b. (a -> b) -> a -> b
$ do
    IO ()
releaseDebug
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release Vector ReleaseKey
imageViewKeys
    forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
siSwapchainReleaseKey

  forall (m :: * -> *) var.
(MonadIO m, HasInput var) =>
var -> (GetInput var -> GetInput var) -> m ()
Worker.pushInput Var Extent2D
screenVar forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Extent2D
windowSize

  pure SwapchainResources
    { $sel:srInfo:SwapchainResources :: SwapchainInfo
srInfo       = SwapchainInfo
info
    , $sel:srImageViews:SwapchainResources :: Vector ImageView
srImageViews = Vector ImageView
imageViews
    , $sel:srImages:SwapchainResources :: Vector Image
srImages     = Vector Image
swapchainImages
    , $sel:srRelease:SwapchainResources :: RefCounted
srRelease    = RefCounted
releaseResources
    , $sel:srScreenVar:SwapchainResources :: Var Extent2D
srScreenVar  = Var Extent2D
screenVar
    }

recreateSwapchainResources
  :: ( MonadResource (RIO env)
     , HasVulkan env
     , HasLogFunc env
     )
  => Vk.Extent2D
  -> SwapchainResources
  -- ^ The reference to these resources will be dropped
  -> RIO env SwapchainResources
recreateSwapchainResources :: forall env.
(MonadResource (RIO env), HasVulkan env, HasLogFunc env) =>
Extent2D -> SwapchainResources -> RIO env SwapchainResources
recreateSwapchainResources Extent2D
windowSize SwapchainResources
oldResources = do
  SwapchainResources
sr <- forall env.
(MonadResource (RIO env), HasVulkan env, HasLogFunc env) =>
SwapchainKHR
-> Extent2D
-> SurfaceKHR
-> Var Extent2D
-> RIO env SwapchainResources
allocSwapchainResources
    (SwapchainInfo -> SwapchainKHR
siSwapchain forall a b. (a -> b) -> a -> b
$ SwapchainResources -> SwapchainInfo
srInfo SwapchainResources
oldResources)
    Extent2D
windowSize
    (SwapchainInfo -> SurfaceKHR
siSurface forall a b. (a -> b) -> a -> b
$ SwapchainResources -> SwapchainInfo
srInfo SwapchainResources
oldResources)
    (SwapchainResources -> Var Extent2D
srScreenVar SwapchainResources
oldResources)
  forall (m :: * -> *). MonadIO m => RefCounted -> m ()
releaseRefCounted (SwapchainResources -> RefCounted
srRelease SwapchainResources
oldResources)
  pure SwapchainResources
sr

-- | Create a swapchain from a 'SurfaceKHR'
createSwapchain
  :: ( MonadResource m
     , MonadVulkan env m
     , HasLogFunc env
     )
  => Khr.SwapchainKHR
  -- ^ Old swapchain, can be NULL_HANDLE
  -> Vk.Extent2D
  -- ^ If the swapchain size determines the surface size, use this size
  -> Khr.SurfaceKHR
  -> m SwapchainInfo
createSwapchain :: forall (m :: * -> *) env.
(MonadResource m, MonadVulkan env m, HasLogFunc env) =>
SwapchainKHR -> Extent2D -> SurfaceKHR -> m SwapchainInfo
createSwapchain SwapchainKHR
oldSwapchain Extent2D
explicitSize SurfaceKHR
surf = do
  PhysicalDevice
physical <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> PhysicalDevice
getPhysicalDevice
  Device
device <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice
  PhysicalDeviceProperties
props <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ PhysicalDeviceInfo -> PhysicalDeviceProperties
pdiProperties forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasVulkan a => a -> PhysicalDeviceInfo
getPhysicalDeviceInfo
  SurfaceCapabilitiesKHR
surfaceCaps <- forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> SurfaceKHR -> io SurfaceCapabilitiesKHR
Khr.getPhysicalDeviceSurfaceCapabilitiesKHR PhysicalDevice
physical SurfaceKHR
surf

  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Utf8Builder
displayShow SurfaceCapabilitiesKHR
surfaceCaps

  -- Check flags
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ImageUsageFlagBits]
requiredUsageFlags \ImageUsageFlagBits
flag ->
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SurfaceCapabilitiesKHR -> ImageUsageFlagBits
Khr.supportedUsageFlags SurfaceCapabilitiesKHR
surfaceCaps forall a. Bits a => a -> a -> Bool
.&&. ImageUsageFlagBits
flag) do
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Surface images do not support " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow ImageUsageFlagBits
flag
      forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString forall a b. (a -> b) -> a -> b
$ String
"Surface images do not support " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ImageUsageFlagBits
flag

  -- Select a present mode
  (Result
_, "presentModes" ::: Vector PresentModeKHR
availablePresentModes) <- forall (io :: * -> *).
MonadIO io =>
PhysicalDevice
-> SurfaceKHR
-> io (Result, "presentModes" ::: Vector PresentModeKHR)
Khr.getPhysicalDeviceSurfacePresentModesKHR PhysicalDevice
physical SurfaceKHR
surf
  PresentModeKHR
presentMode                <-
    case forall a. (a -> Bool) -> [a] -> [a]
filter (forall (v :: * -> *) a. (Vector v a, Eq a) => a -> v a -> Bool
`V.elem` "presentModes" ::: Vector PresentModeKHR
availablePresentModes) [PresentModeKHR]
desiredPresentModes of
      [] -> do
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Unable to find a suitable present mode for swapchain"
        forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"Unable to find a suitable present mode for swapchain"
      PresentModeKHR
x : [PresentModeKHR]
_rest ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure PresentModeKHR
x

  -- Select a surface format
  -- getPhysicalDeviceSurfaceFormatsKHR doesn't return an empty list
  -- (_, availableFormats) <- Khr.getPhysicalDeviceSurfaceFormatsKHR physical surf
  SurfaceFormatKHR
surfaceFormatKhr <- forall (io :: * -> *).
MonadIO io =>
PhysicalDevice
-> SurfaceKHR -> SurfaceFormatKHR -> io SurfaceFormatKHR
getSurfaceFormatKhr PhysicalDevice
physical SurfaceKHR
surf SurfaceFormatKHR
preferSrgb

  Format
depthFormat <- forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> [Format] -> io [Format]
getDepthFormats PhysicalDevice
physical [Format]
preferStenciledDepth forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Format
fmt : [Format]
_rest ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Format
fmt
    [Format]
_none ->
      forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"Unable to find a suitable depth format"

  -- Calculate the extent
  let
    imageExtent :: Extent2D
imageExtent =
      case SurfaceCapabilitiesKHR -> Extent2D
Khr.currentExtent (SurfaceCapabilitiesKHR
surfaceCaps :: Khr.SurfaceCapabilitiesKHR) of
        Vk.Extent2D Word32
w Word32
h | Word32
w forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
maxBound, Word32
h forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
maxBound ->
          Extent2D
explicitSize
        Extent2D
extent ->
          Extent2D
extent

  let
    minImageCount :: Word32
minImageCount =
      let
        limit :: Word32
limit = case SurfaceCapabilitiesKHR -> Word32
Khr.maxImageCount (SurfaceCapabilitiesKHR
surfaceCaps :: Khr.SurfaceCapabilitiesKHR) of
          Word32
0 -> forall a. Bounded a => a
maxBound
          Word32
n -> Word32
n
        -- Request one additional image to prevent us having to wait for
        -- the driver to finish
        buffer :: Word32
buffer = Word32
1
        desired :: Word32
desired =
          Word32
buffer forall a. Num a => a -> a -> a
+ SurfaceCapabilitiesKHR -> Word32
Khr.minImageCount (SurfaceCapabilitiesKHR
surfaceCaps :: Khr.SurfaceCapabilitiesKHR)
      in
        forall a. Ord a => a -> a -> a
min Word32
limit Word32
desired

  let compositeAlphaMode :: CompositeAlphaFlagBitsKHR
compositeAlphaMode = CompositeAlphaFlagBitsKHR
Khr.COMPOSITE_ALPHA_OPAQUE_BIT_KHR
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CompositeAlphaFlagBitsKHR
compositeAlphaMode forall a. Bits a => a -> a -> Bool
.&&. SurfaceCapabilitiesKHR -> CompositeAlphaFlagBitsKHR
Khr.supportedCompositeAlpha SurfaceCapabilitiesKHR
surfaceCaps) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString forall a b. (a -> b) -> a -> b
$ String
"Surface doesn't support " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show CompositeAlphaFlagBitsKHR
compositeAlphaMode

  let
    Khr.SurfaceFormatKHR{$sel:colorSpace:SurfaceFormatKHR :: SurfaceFormatKHR -> ColorSpaceKHR
colorSpace=ColorSpaceKHR
surfaceColorspace, $sel:format:SurfaceFormatKHR :: SurfaceFormatKHR -> Format
format=Format
surfaceFormat} = SurfaceFormatKHR
surfaceFormatKhr
    swapchainCreateInfo :: SwapchainCreateInfoKHR '[]
swapchainCreateInfo = Khr.SwapchainCreateInfoKHR
      { $sel:surface:SwapchainCreateInfoKHR :: SurfaceKHR
surface            = SurfaceKHR
surf
      , $sel:next:SwapchainCreateInfoKHR :: Chain '[]
next               = ()
      , $sel:flags:SwapchainCreateInfoKHR :: SwapchainCreateFlagsKHR
flags              = forall a. Zero a => a
zero
      , $sel:queueFamilyIndices:SwapchainCreateInfoKHR :: Vector Word32
queueFamilyIndices = forall a. Monoid a => a
mempty -- No need to specify when not using concurrent access
      , $sel:minImageCount:SwapchainCreateInfoKHR :: Word32
minImageCount      = Word32
minImageCount
      , $sel:imageFormat:SwapchainCreateInfoKHR :: Format
imageFormat        = Format
surfaceFormat
      , $sel:imageColorSpace:SwapchainCreateInfoKHR :: ColorSpaceKHR
imageColorSpace    = ColorSpaceKHR
surfaceColorspace
      , $sel:imageExtent:SwapchainCreateInfoKHR :: Extent2D
imageExtent        = Extent2D
imageExtent
      , $sel:imageArrayLayers:SwapchainCreateInfoKHR :: Word32
imageArrayLayers   = Word32
1
      , $sel:imageUsage:SwapchainCreateInfoKHR :: ImageUsageFlagBits
imageUsage         = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Bits a => a -> a -> a
(.|.) forall a. Zero a => a
zero [ImageUsageFlagBits]
requiredUsageFlags
      , $sel:imageSharingMode:SwapchainCreateInfoKHR :: SharingMode
imageSharingMode   = SharingMode
Vk.SHARING_MODE_EXCLUSIVE
      , $sel:preTransform:SwapchainCreateInfoKHR :: SurfaceTransformFlagBitsKHR
preTransform       = SurfaceCapabilitiesKHR -> SurfaceTransformFlagBitsKHR
Khr.currentTransform (SurfaceCapabilitiesKHR
surfaceCaps :: Khr.SurfaceCapabilitiesKHR)
      , $sel:compositeAlpha:SwapchainCreateInfoKHR :: CompositeAlphaFlagBitsKHR
compositeAlpha     = CompositeAlphaFlagBitsKHR
compositeAlphaMode
      , $sel:presentMode:SwapchainCreateInfoKHR :: PresentModeKHR
presentMode        = PresentModeKHR
presentMode
      , $sel:clipped:SwapchainCreateInfoKHR :: Bool
clipped            = Bool
True
      , $sel:oldSwapchain:SwapchainCreateInfoKHR :: SwapchainKHR
oldSwapchain       = SwapchainKHR
oldSwapchain
      }

  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Creating swapchain from " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SwapchainCreateInfoKHR '[]
swapchainCreateInfo
  (ReleaseKey
key, SwapchainKHR
swapchain) <- forall (a :: [*]) (io :: * -> *) r.
(Extendss SwapchainCreateInfoKHR a, PokeChain a, MonadIO io) =>
Device
-> SwapchainCreateInfoKHR a
-> Maybe AllocationCallbacks
-> (io SwapchainKHR -> (SwapchainKHR -> io ()) -> r)
-> r
Khr.withSwapchainKHR Device
device SwapchainCreateInfoKHR '[]
swapchainCreateInfo forall a. Maybe a
Nothing forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate

  pure SwapchainInfo
    { $sel:siSwapchain:SwapchainInfo :: SwapchainKHR
siSwapchain           = SwapchainKHR
swapchain
    , $sel:siSwapchainReleaseKey:SwapchainInfo :: ReleaseKey
siSwapchainReleaseKey = ReleaseKey
key
    , $sel:siPresentMode:SwapchainInfo :: PresentModeKHR
siPresentMode         = PresentModeKHR
presentMode
    , $sel:siMinImageCount:SwapchainInfo :: Word32
siMinImageCount       = Word32
minImageCount
    , $sel:siSurface:SwapchainInfo :: SurfaceKHR
siSurface             = SurfaceKHR
surf
    , $sel:siSurfaceFormat:SwapchainInfo :: Format
siSurfaceFormat       = Format
surfaceFormat
    , $sel:siSurfaceColorspace:SwapchainInfo :: ColorSpaceKHR
siSurfaceColorspace   = ColorSpaceKHR
surfaceColorspace
    , $sel:siDepthFormat:SwapchainInfo :: Format
siDepthFormat         = Format
depthFormat
    , $sel:siMultisample:SwapchainInfo :: SampleCountFlagBits
siMultisample         = PhysicalDeviceProperties -> SampleCountFlagBits
msaaSamples PhysicalDeviceProperties
props
    , $sel:siAnisotropy:SwapchainInfo :: Float
siAnisotropy          = PhysicalDeviceLimits -> Float
Vk.maxSamplerAnisotropy (PhysicalDeviceProperties -> PhysicalDeviceLimits
Vk.limits PhysicalDeviceProperties
props)
    , $sel:siImageExtent:SwapchainInfo :: Extent2D
siImageExtent         = Extent2D
imageExtent
    }

-- -- The vector passed will have at least one element
-- selectSurfaceFormat :: Vector Khr.SurfaceFormatKHR -> Khr.SurfaceFormatKHR
-- selectSurfaceFormat = V.maximumBy (comparing surfaceFormatScore)
--   where
--     -- An ordered list of formats to choose for the swapchain images, if none
--     -- match then the first available format will be chosen.
--     surfaceFormatScore :: Khr.SurfaceFormatKHR -> Int
--     surfaceFormatScore = \case
--       _ -> 0

getSurfaceFormatKhr
  :: MonadIO io
  => Vk.PhysicalDevice
  -> Khr.SurfaceKHR
  -> Khr.SurfaceFormatKHR
  -> io Khr.SurfaceFormatKHR
getSurfaceFormatKhr :: forall (io :: * -> *).
MonadIO io =>
PhysicalDevice
-> SurfaceKHR -> SurfaceFormatKHR -> io SurfaceFormatKHR
getSurfaceFormatKhr PhysicalDevice
device SurfaceKHR
surface SurfaceFormatKHR
desiredFormat = do
  (Result
_res, "surfaceFormats" ::: Vector SurfaceFormatKHR
formats) <- forall (io :: * -> *).
MonadIO io =>
PhysicalDevice
-> SurfaceKHR
-> io (Result, "surfaceFormats" ::: Vector SurfaceFormatKHR)
Khr.getPhysicalDeviceSurfaceFormatsKHR PhysicalDevice
device SurfaceKHR
surface
  forall (f :: * -> *) a. Applicative f => a -> f a
pure case forall (t :: * -> *) a. Foldable t => t a -> [a]
toList "surfaceFormats" ::: Vector SurfaceFormatKHR
formats of
    [] ->
      SurfaceFormatKHR
desiredFormat
    [Khr.SurfaceFormatKHR Format
Vk.FORMAT_UNDEFINED ColorSpaceKHR
_colorSpace] ->
      SurfaceFormatKHR
desiredFormat
    [SurfaceFormatKHR]
candidates | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SurfaceFormatKHR -> Bool
cond [SurfaceFormatKHR]
candidates ->
      SurfaceFormatKHR
desiredFormat
    SurfaceFormatKHR
whatever : [SurfaceFormatKHR]
_rest ->
      SurfaceFormatKHR
whatever
  where
    cond :: SurfaceFormatKHR -> Bool
cond SurfaceFormatKHR
f =
      SurfaceFormatKHR -> Format
Khr.format SurfaceFormatKHR
f forall a. Eq a => a -> a -> Bool
== SurfaceFormatKHR -> Format
Khr.format SurfaceFormatKHR
desiredFormat Bool -> Bool -> Bool
&&
      SurfaceFormatKHR -> ColorSpaceKHR
Khr.colorSpace SurfaceFormatKHR
f forall a. Eq a => a -> a -> Bool
== SurfaceFormatKHR -> ColorSpaceKHR
Khr.colorSpace SurfaceFormatKHR
desiredFormat

preferSrgb :: Khr.SurfaceFormatKHR
preferSrgb :: SurfaceFormatKHR
preferSrgb =
  Format -> ColorSpaceKHR -> SurfaceFormatKHR
Khr.SurfaceFormatKHR
    Format
Vk.FORMAT_B8G8R8A8_SRGB
    ColorSpaceKHR
Khr.COLOR_SPACE_SRGB_NONLINEAR_KHR

getDepthFormats
  :: MonadIO io
  => Vk.PhysicalDevice
  -> [Vk.Format]
  -> io [Vk.Format]
getDepthFormats :: forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> [Format] -> io [Format]
getDepthFormats PhysicalDevice
device [Format]
desiredDepthFormats = do
  [FormatProperties]
properties <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> Format -> io FormatProperties
Vk.getPhysicalDeviceFormatProperties PhysicalDevice
device) [Format]
desiredDepthFormats
  pure do
    (Format
format, FormatProperties
props) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Format]
desiredDepthFormats [FormatProperties]
properties
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$
      FormatProperties -> FormatFeatureFlags
Vk.optimalTilingFeatures FormatProperties
props forall a. Bits a => a -> a -> Bool
.&&. FormatFeatureFlags
Vk.FORMAT_FEATURE_DEPTH_STENCIL_ATTACHMENT_BIT
    pure Format
format

preferStenciledDepth :: [Vk.Format]
preferStenciledDepth :: [Format]
preferStenciledDepth =
  [ Format
Vk.FORMAT_D32_SFLOAT_S8_UINT
  , Format
Vk.FORMAT_D24_UNORM_S8_UINT
  , Format
Vk.FORMAT_D32_SFLOAT
  ]

msaaSamples :: Vk.PhysicalDeviceProperties -> Vk.SampleCountFlagBits
msaaSamples :: PhysicalDeviceProperties -> SampleCountFlagBits
msaaSamples Vk.PhysicalDeviceProperties{PhysicalDeviceLimits
limits :: PhysicalDeviceLimits
$sel:limits:PhysicalDeviceProperties :: PhysicalDeviceProperties -> PhysicalDeviceLimits
limits} =
  case [SampleCountFlagBits]
samplesAvailable of
    [] ->
      SampleCountFlagBits
Vk.SAMPLE_COUNT_1_BIT
    SampleCountFlagBits
best : [SampleCountFlagBits]
_rest ->
      SampleCountFlagBits
best
  where
    counts :: SampleCountFlagBits
counts =
      PhysicalDeviceLimits -> SampleCountFlagBits
Vk.framebufferColorSampleCounts PhysicalDeviceLimits
limits forall a. Bits a => a -> a -> a
.&.
      PhysicalDeviceLimits -> SampleCountFlagBits
Vk.framebufferDepthSampleCounts PhysicalDeviceLimits
limits

    samplesAvailable :: [SampleCountFlagBits]
samplesAvailable = do
      SampleCountFlagBits
countBit <- [SampleCountFlagBits]
msaaCandidates
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ (SampleCountFlagBits
counts forall a. Bits a => a -> a -> a
.&. SampleCountFlagBits
countBit) forall a. Eq a => a -> a -> Bool
/= forall a. Bits a => a
zeroBits
      pure SampleCountFlagBits
countBit

msaaCandidates :: [Vk.SampleCountFlagBits]
msaaCandidates :: [SampleCountFlagBits]
msaaCandidates =
  {-
    XXX: Also possible, but not that impactful: 16x, 8x.

    Khronos MSAA best practice says:
      Use 4x MSAA if possible; it's not expensive and provides good image quality improvements.
  -}
  [ SampleCountFlagBits
Vk.SAMPLE_COUNT_4_BIT
  , SampleCountFlagBits
Vk.SAMPLE_COUNT_2_BIT
  ]

-- | An ordered list of the present mode to be chosen for the swapchain.
desiredPresentModes :: [Khr.PresentModeKHR]
desiredPresentModes :: [PresentModeKHR]
desiredPresentModes =
  [ PresentModeKHR
Khr.PRESENT_MODE_FIFO_RELAXED_KHR
  , PresentModeKHR
Khr.PRESENT_MODE_FIFO_KHR --  ^ This will always be present
  , PresentModeKHR
Khr.PRESENT_MODE_IMMEDIATE_KHR --  ^ Keep this here for easy swapping for testing
  ]

-- | The images in the swapchain must support these flags.
requiredUsageFlags :: [Vk.ImageUsageFlagBits]
requiredUsageFlags :: [ImageUsageFlagBits]
requiredUsageFlags =
  [ ImageUsageFlagBits
Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT
  -- , Vk.IMAGE_USAGE_STORAGE_BIT
  ]

-- | Catch an ERROR_OUT_OF_DATE_KHR exception and return 'True' if that happened
threwSwapchainError :: MonadUnliftIO f => f () -> f Bool
threwSwapchainError :: forall (f :: * -> *). MonadUnliftIO f => f () -> f Bool
threwSwapchainError = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. Either a b -> Bool
isLeft forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust VulkanException -> Maybe Result
swapchainError
 where
  swapchainError :: VulkanException -> Maybe Result
swapchainError = \case
    VulkanException e :: Result
e@Result
Vk.ERROR_OUT_OF_DATE_KHR ->
      forall a. a -> Maybe a
Just Result
e

    VulkanException Result
Vk.ERROR_SURFACE_LOST_KHR ->
      forall a. HasCallStack => String -> a
error String
"TODO: handle ERROR_SURFACE_LOST_KHR"

    VulkanException Result
_ ->
      forall a. Maybe a
Nothing

-- | Create a pretty vanilla ImageView covering the whole image
createImageView
  :: ( MonadResource m
     , MonadVulkan env m
     )
  => Vk.Format
  -> Vk.Image
  -> m (Resource.ReleaseKey, Vk.ImageView)
createImageView :: forall (m :: * -> *) env.
(MonadResource m, MonadVulkan env m) =>
Format -> Image -> m (ReleaseKey, ImageView)
createImageView Format
format Image
image = do
  Device
device <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice
  forall (a :: [*]) (io :: * -> *) r.
(Extendss ImageViewCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> ImageViewCreateInfo a
-> Maybe AllocationCallbacks
-> (io ImageView -> (ImageView -> io ()) -> r)
-> r
Vk.withImageView Device
device ImageViewCreateInfo '[]
imageViewCI forall a. Maybe a
Nothing forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
 where
  imageViewCI :: ImageViewCreateInfo '[]
imageViewCI = 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
    -- , Vk.components       = zero
    , $sel:subresourceRange:ImageViewCreateInfo :: ImageSubresourceRange
Vk.subresourceRange = 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
        }
    }

setDynamic
  :: MonadIO io
  => Vk.CommandBuffer
  -> "viewport" ::: Vk.Rect2D
  -> "scissor"  ::: Vk.Rect2D
  -> io ()
setDynamic :: forall (io :: * -> *).
MonadIO io =>
CommandBuffer
-> ("viewport" ::: Rect2D) -> ("viewport" ::: Rect2D) -> io ()
setDynamic CommandBuffer
cb "viewport" ::: Rect2D
viewrect "viewport" ::: Rect2D
scissor = do
  forall (io :: * -> *).
MonadIO io =>
CommandBuffer
-> Word32 -> ("viewports" ::: Vector Viewport) -> io ()
Vk.cmdSetViewport CommandBuffer
cb Word32
0 [Viewport
viewport]
  forall (io :: * -> *).
MonadIO io =>
CommandBuffer
-> Word32
-> ("scissors" ::: Vector ("viewport" ::: Rect2D))
-> io ()
Vk.cmdSetScissor CommandBuffer
cb Word32
0 ["viewport" ::: Rect2D
scissor]
  where
    viewport :: Viewport
viewport = Vk.Viewport
      { $sel:x:Viewport :: Float
x        = forall a b. (Real a, Fractional b) => a -> b
realToFrac Int32
x
      , $sel:y:Viewport :: Float
y        = forall a b. (Real a, Fractional b) => a -> b
realToFrac Int32
y
      , $sel:width:Viewport :: Float
width    = forall a b. (Real a, Fractional b) => a -> b
realToFrac Word32
width
      , $sel:height:Viewport :: Float
height   = forall a b. (Real a, Fractional b) => a -> b
realToFrac Word32
height
      , $sel:minDepth:Viewport :: Float
minDepth = Float
0
      , $sel:maxDepth:Viewport :: Float
maxDepth = Float
1
      }
      where
        Vk.Offset2D{Int32
$sel:x:Offset2D :: Offset2D -> Int32
x :: Int32
x, Int32
$sel:y:Offset2D :: Offset2D -> Int32
y :: Int32
y} = Offset2D
offset
        Vk.Extent2D{Word32
$sel:width:Extent2D :: Extent2D -> Word32
width :: Word32
width, Word32
$sel:height:Extent2D :: Extent2D -> Word32
height :: Word32
height} = Extent2D
extent
        Vk.Rect2D{Offset2D
$sel:offset:Rect2D :: ("viewport" ::: Rect2D) -> Offset2D
offset :: Offset2D
offset, Extent2D
$sel:extent:Rect2D :: ("viewport" ::: Rect2D) -> Extent2D
extent :: Extent2D
extent} = "viewport" ::: Rect2D
viewrect

setDynamicFullscreen :: MonadIO io => Vk.CommandBuffer -> SwapchainResources -> io ()
setDynamicFullscreen :: forall (io :: * -> *).
MonadIO io =>
CommandBuffer -> SwapchainResources -> io ()
setDynamicFullscreen CommandBuffer
cb SwapchainResources
sr = do
  forall (io :: * -> *).
MonadIO io =>
CommandBuffer
-> Word32 -> ("viewports" ::: Vector Viewport) -> io ()
Vk.cmdSetViewport CommandBuffer
cb
    Word32
0
    [ Vk.Viewport
        { $sel:x:Viewport :: Float
x        = Float
0
        , $sel:y:Viewport :: Float
y        = Float
0
        , $sel:width:Viewport :: Float
width    = forall a b. (Real a, Fractional b) => a -> b
realToFrac Word32
width
        , $sel:height:Viewport :: Float
height   = forall a b. (Real a, Fractional b) => a -> b
realToFrac Word32
height
        , $sel:minDepth:Viewport :: Float
minDepth = Float
0
        , $sel:maxDepth:Viewport :: Float
maxDepth = Float
1
        }
    ]
  forall (io :: * -> *).
MonadIO io =>
CommandBuffer
-> Word32
-> ("scissors" ::: Vector ("viewport" ::: Rect2D))
-> io ()
Vk.cmdSetScissor CommandBuffer
cb Word32
0
    [ Vk.Rect2D
        { $sel:offset:Rect2D :: Offset2D
offset = Int32 -> Int32 -> Offset2D
Vk.Offset2D Int32
0 Int32
0
        , $sel:extent:Rect2D :: Extent2D
extent = Extent2D
siImageExtent
        }
    ]
  where
    SwapchainResources{SwapchainInfo
srInfo :: SwapchainInfo
$sel:srInfo:SwapchainResources :: SwapchainResources -> SwapchainInfo
srInfo} = SwapchainResources
sr
    SwapchainInfo{Extent2D
siImageExtent :: Extent2D
$sel:siImageExtent:SwapchainInfo :: SwapchainInfo -> Extent2D
siImageExtent} = SwapchainInfo
srInfo
    Vk.Extent2D{Word32
width :: Word32
$sel:width:Extent2D :: Extent2D -> Word32
width, Word32
height :: Word32
$sel:height:Extent2D :: Extent2D -> Word32
height} = Extent2D
siImageExtent