{-# LANGUAGE DeriveGeneric #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}

{-| Swapchain creation, recreation, and the small helper for catching
swapchain-out-of-date exceptions thrown elsewhere.

Opinionated choices (storage-image usage, FIFO_RELAXED preference, surface
format selection) are exposed via 'SwapchainConfig'. 'defaultSwapchainConfig'
gives a color-attachment-only swapchain prefering FIFO_RELAXED then FIFO;
compute-shader callers add @IMAGE_USAGE_STORAGE_BIT@ etc.
-}
module Vulkan.Utils.Swapchain
  ( Swapchain (..)
  , SwapchainConfig (..)
  , defaultSwapchainConfig
  , allocateSwapchain
  , recreateSwapchain
  , threwSwapchainError
  ) where

import Control.Exception (throwIO, tryJust)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.Bits
import Data.Either (isLeft)
import Data.Foldable (for_, traverse_)
import Data.Vector (Vector)
import qualified Data.Vector as V
import GHC.Generics (Generic)
import Vulkan.CStruct.Extends (pattern (:&), pattern (::&))
import qualified Vulkan.Core10 as Vk
import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore (SemaphoreTypeCreateInfo (..), pattern SEMAPHORE_TYPE_BINARY)
import Vulkan.Exception (VulkanException (..))
import Vulkan.Extensions.VK_KHR_surface as SurfaceCapabilitiesKHR (SurfaceCapabilitiesKHR (..))
import Vulkan.Extensions.VK_KHR_surface as SurfaceFormatKHR (SurfaceFormatKHR (..))
import qualified Vulkan.Extensions.VK_KHR_surface as KHR
import qualified Vulkan.Extensions.VK_KHR_swapchain as KHR
import Vulkan.Utils.Misc ((.&&.))
import Vulkan.Utils.RefCounted (RefCounted, newRefCounted, releaseRefCounted)
import Vulkan.Zero (zero)

----------------------------------------------------------------
-- Config
----------------------------------------------------------------

{- | Opinionated knobs for swapchain creation. Use 'defaultSwapchainConfig' as
a starting point and override the bits you care about.
-}
data SwapchainConfig = SwapchainConfig
  { SwapchainConfig -> [ImageUsageFlagBits]
scRequiredUsageFlags :: [Vk.ImageUsageFlagBits]
  {- ^ Image usages every swapchain image must support. Default:
  @[IMAGE_USAGE_COLOR_ATTACHMENT_BIT]@. Compute-shader callers add
  @IMAGE_USAGE_STORAGE_BIT@.
  -}
  , SwapchainConfig -> [FormatFeatureFlagBits]
scRequiredFormatFeatures :: [Vk.FormatFeatureFlagBits]
  {- ^ Format-feature flags the chosen surface format's optimal tiling
  must satisfy. Default: @[]@. Set @FORMAT_FEATURE_STORAGE_IMAGE_BIT@ if
  using @IMAGE_USAGE_STORAGE_BIT@ — SRGB formats typically omit it.
  -}
  , SwapchainConfig -> [PresentModeKHR]
scDesiredPresentModes :: [KHR.PresentModeKHR]
  {- ^ Present-mode preference, best first. Default:
  @[FIFO_RELAXED, FIFO]@. The driver-guaranteed @FIFO@ is the safe
  fallback. Add @IMMEDIATE@ or @MAILBOX@ if your scheduler can tolerate
  them.
  -}
  , SwapchainConfig -> [SurfaceFormatKHR -> Bool]
scSurfaceFormatPreferences :: [KHR.SurfaceFormatKHR -> Bool]
  {- ^ Surface-format preference predicates, best first. For each predicate
  in order, the first format that matches both the predicate AND the
  feature requirements wins. If no preference matches, falls back to the
  first feature-satisfying format, then to the head. Default: @[]@.
  -}
  }
  deriving ((forall x. SwapchainConfig -> Rep SwapchainConfig x)
-> (forall x. Rep SwapchainConfig x -> SwapchainConfig)
-> Generic SwapchainConfig
forall x. Rep SwapchainConfig x -> SwapchainConfig
forall x. SwapchainConfig -> Rep SwapchainConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SwapchainConfig -> Rep SwapchainConfig x
from :: forall x. SwapchainConfig -> Rep SwapchainConfig x
$cto :: forall x. Rep SwapchainConfig x -> SwapchainConfig
to :: forall x. Rep SwapchainConfig x -> SwapchainConfig
Generic)

defaultSwapchainConfig :: SwapchainConfig
defaultSwapchainConfig :: SwapchainConfig
defaultSwapchainConfig =
  SwapchainConfig
    { scRequiredUsageFlags :: [ImageUsageFlagBits]
scRequiredUsageFlags = [ImageUsageFlagBits
Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT]
    , scRequiredFormatFeatures :: [FormatFeatureFlagBits]
scRequiredFormatFeatures = []
    , scDesiredPresentModes :: [PresentModeKHR]
scDesiredPresentModes =
        [ PresentModeKHR
KHR.PRESENT_MODE_FIFO_RELAXED_KHR
        , PresentModeKHR
KHR.PRESENT_MODE_FIFO_KHR
        ]
    , scSurfaceFormatPreferences :: [SurfaceFormatKHR -> Bool]
scSurfaceFormatPreferences = []
    }

----------------------------------------------------------------
-- Swapchain
----------------------------------------------------------------

data Swapchain = Swapchain
  { Swapchain -> SwapchainKHR
sSwapchain :: KHR.SwapchainKHR
  , Swapchain -> SurfaceKHR
sSurface :: KHR.SurfaceKHR
  , Swapchain -> SurfaceFormatKHR
sFormat :: KHR.SurfaceFormatKHR
  , Swapchain -> Extent2D
sExtent :: Vk.Extent2D
  , Swapchain -> PresentModeKHR
sPresentMode :: KHR.PresentModeKHR
  , Swapchain -> Vector Image
sImages :: Vector Vk.Image
  , Swapchain -> Vector ImageView
sImageViews :: Vector Vk.ImageView
  , Swapchain -> Vector Semaphore
sRenderFinished :: Vector Vk.Semaphore
  {- ^ Per-image present-wait binary semaphore, indexed by the acquired image
  index (@length == length sImages@). A frame's submit signals
  @sRenderFinished ! imageIndex@ and the present waits on it; reusing it is
  safe only once that image is re-acquired, which is why it lives here (per
  image) rather than in the per-frame 'RecycledResources'. Freed by 'sRelease'.
  -}
  , Swapchain -> RefCounted
sRelease :: RefCounted
  -- ^ Held until no in-flight frame still uses this swapchain.
  , Swapchain -> SwapchainConfig
sConfig :: SwapchainConfig
  -- ^ Retained so 'recreateSwapchain' can re-apply the same knobs.
  }
  deriving ((forall x. Swapchain -> Rep Swapchain x)
-> (forall x. Rep Swapchain x -> Swapchain) -> Generic Swapchain
forall x. Rep Swapchain x -> Swapchain
forall x. Swapchain -> Rep Swapchain x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Swapchain -> Rep Swapchain x
from :: forall x. Swapchain -> Rep Swapchain x
$cto :: forall x. Rep Swapchain x -> Swapchain
to :: forall x. Rep Swapchain x -> Swapchain
Generic)

----------------------------------------------------------------
-- Allocate / recreate
----------------------------------------------------------------

-- | Allocate a new swapchain plus its image views.
allocateSwapchain
  :: (MonadResource m)
  => Vk.PhysicalDevice
  -> Vk.Device
  -> SwapchainConfig
  -> KHR.SwapchainKHR
  -- ^ Previous swapchain ('NULL_HANDLE' for first)
  -> Vk.Extent2D
  -- ^ Fallback size when the surface lets us pick
  -> KHR.SurfaceKHR
  -> m Swapchain
allocateSwapchain :: forall (m :: * -> *).
MonadResource m =>
PhysicalDevice
-> Device
-> SwapchainConfig
-> SwapchainKHR
-> Extent2D
-> SurfaceKHR
-> m Swapchain
allocateSwapchain PhysicalDevice
phys Device
dev SwapchainConfig
cfg SwapchainKHR
oldSwapchain Extent2D
windowSize SurfaceKHR
surface = do
  (sSwapchain, sFormat, sExtent, sPresentMode, swapchainKey) <-
    PhysicalDevice
-> Device
-> SwapchainConfig
-> SwapchainKHR
-> Extent2D
-> SurfaceKHR
-> m (SwapchainKHR, SurfaceFormatKHR, Extent2D, PresentModeKHR,
      ReleaseKey)
forall (m :: * -> *).
MonadResource m =>
PhysicalDevice
-> Device
-> SwapchainConfig
-> SwapchainKHR
-> Extent2D
-> SurfaceKHR
-> m (SwapchainKHR, SurfaceFormatKHR, Extent2D, PresentModeKHR,
      ReleaseKey)
allocateSwapchainEx PhysicalDevice
phys Device
dev SwapchainConfig
cfg SwapchainKHR
oldSwapchain Extent2D
windowSize SurfaceKHR
surface

  (_, sImages) <- KHR.getSwapchainImagesKHR dev sSwapchain
  (imageViewKeys, sImageViews) <-
    fmap V.unzip . V.forM sImages $ \Image
image ->
      Device -> Format -> Image -> m (ReleaseKey, ImageView)
forall (m :: * -> *).
MonadResource m =>
Device -> Format -> Image -> m (ReleaseKey, ImageView)
allocateImageView Device
dev (SurfaceFormatKHR -> Format
SurfaceFormatKHR.format SurfaceFormatKHR
sFormat) Image
image

  -- One present-wait binary semaphore per swapchain image, indexed by the
  -- acquired image index (see 'sRenderFinished').
  (renderFinishedKeys, sRenderFinished) <-
    fmap V.unzip . V.forM sImages $ \Image
_image ->
      Device
-> SemaphoreCreateInfo '[SemaphoreTypeCreateInfo]
-> Maybe AllocationCallbacks
-> (IO Semaphore
    -> (Semaphore -> IO ()) -> m (ReleaseKey, Semaphore))
-> m (ReleaseKey, Semaphore)
forall (a :: [*]) (io :: * -> *) r.
(Extendss SemaphoreCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> SemaphoreCreateInfo a
-> Maybe AllocationCallbacks
-> (io Semaphore -> (Semaphore -> io ()) -> r)
-> r
Vk.withSemaphore
        Device
dev
        (SemaphoreCreateInfo '[]
forall a. Zero a => a
zero SemaphoreCreateInfo '[]
-> Chain '[SemaphoreTypeCreateInfo]
-> SemaphoreCreateInfo '[SemaphoreTypeCreateInfo]
forall (a :: [*] -> *) (es :: [*]) (es' :: [*]).
Extensible a =>
a es' -> Chain es -> a es
::& SemaphoreType -> Word64 -> SemaphoreTypeCreateInfo
SemaphoreTypeCreateInfo SemaphoreType
SEMAPHORE_TYPE_BINARY Word64
0 SemaphoreTypeCreateInfo
-> Chain '[] -> Chain '[SemaphoreTypeCreateInfo]
forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ())
        Maybe AllocationCallbacks
forall a. Maybe a
Nothing
        IO Semaphore -> (Semaphore -> IO ()) -> m (ReleaseKey, Semaphore)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate

  -- Released by the next 'recreateSwapchain' (when frames stop using it).
  sRelease <- newRefCounted $ do
    traverse_ release renderFinishedKeys
    traverse_ release imageViewKeys
    release swapchainKey

  pure Swapchain{sSurface = surface, sConfig = cfg, ..}

{- | Build a new swapchain at a new size, dropping the reference to the old
one so its resources can be released once in-flight frames complete.
-}
recreateSwapchain
  :: (MonadResource m)
  => Vk.PhysicalDevice
  -> Vk.Device
  -> Vk.Extent2D
  -- ^ New window size
  -> Swapchain
  -> m Swapchain
recreateSwapchain :: forall (m :: * -> *).
MonadResource m =>
PhysicalDevice -> Device -> Extent2D -> Swapchain -> m Swapchain
recreateSwapchain PhysicalDevice
phys Device
dev Extent2D
newSize Swapchain
old = do
  fresh <- PhysicalDevice
-> Device
-> SwapchainConfig
-> SwapchainKHR
-> Extent2D
-> SurfaceKHR
-> m Swapchain
forall (m :: * -> *).
MonadResource m =>
PhysicalDevice
-> Device
-> SwapchainConfig
-> SwapchainKHR
-> Extent2D
-> SurfaceKHR
-> m Swapchain
allocateSwapchain PhysicalDevice
phys Device
dev (Swapchain -> SwapchainConfig
sConfig Swapchain
old) (Swapchain -> SwapchainKHR
sSwapchain Swapchain
old) Extent2D
newSize (Swapchain -> SurfaceKHR
sSurface Swapchain
old)
  releaseRefCounted (sRelease old)
  pure fresh

----------------------------------------------------------------
-- Internals
----------------------------------------------------------------

allocateSwapchainEx
  :: (MonadResource m)
  => Vk.PhysicalDevice
  -> Vk.Device
  -> SwapchainConfig
  -> KHR.SwapchainKHR
  -> Vk.Extent2D
  -> KHR.SurfaceKHR
  -> m (KHR.SwapchainKHR, SurfaceFormatKHR, Vk.Extent2D, KHR.PresentModeKHR, ReleaseKey)
allocateSwapchainEx :: forall (m :: * -> *).
MonadResource m =>
PhysicalDevice
-> Device
-> SwapchainConfig
-> SwapchainKHR
-> Extent2D
-> SurfaceKHR
-> m (SwapchainKHR, SurfaceFormatKHR, Extent2D, PresentModeKHR,
      ReleaseKey)
allocateSwapchainEx PhysicalDevice
phys Device
dev SwapchainConfig
cfg SwapchainKHR
oldSwapchain Extent2D
explicitSize SurfaceKHR
surf = do
  surfaceCaps <- PhysicalDevice -> SurfaceKHR -> m SurfaceCapabilitiesKHR
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> SurfaceKHR -> io SurfaceCapabilitiesKHR
KHR.getPhysicalDeviceSurfaceCapabilitiesKHR PhysicalDevice
phys SurfaceKHR
surf

  -- Sanity-check that the surface advertises the usages we need.
  for_ (scRequiredUsageFlags cfg) $ \ImageUsageFlagBits
f ->
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SurfaceCapabilitiesKHR -> ImageUsageFlagBits
supportedUsageFlags SurfaceCapabilitiesKHR
surfaceCaps ImageUsageFlagBits -> ImageUsageFlagBits -> Bool
forall a. Bits a => a -> a -> Bool
.&&. ImageUsageFlagBits
f) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (IOError -> IO ()) -> (String -> IOError) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
userError (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
        String
"Surface images do not support " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ImageUsageFlagBits -> String
forall a. Show a => a -> String
show ImageUsageFlagBits
f

  -- Pick a present mode in our preference order.
  (_, availablePresentModes) <- KHR.getPhysicalDeviceSurfacePresentModesKHR phys surf
  presentMode <-
    case filter (`V.elem` availablePresentModes) (scDesiredPresentModes cfg) of
      [] -> IO PresentModeKHR -> m PresentModeKHR
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PresentModeKHR -> m PresentModeKHR)
-> (String -> IO PresentModeKHR) -> String -> m PresentModeKHR
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> IO PresentModeKHR
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (IOError -> IO PresentModeKHR)
-> (String -> IOError) -> String -> IO PresentModeKHR
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
userError (String -> m PresentModeKHR) -> String -> m PresentModeKHR
forall a b. (a -> b) -> a -> b
$ String
"Unable to find a suitable present mode for swapchain"
      PresentModeKHR
x : [PresentModeKHR]
_ -> PresentModeKHR -> m PresentModeKHR
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PresentModeKHR
x

  -- Pick a surface format. Vulkan guarantees at least one.
  (_, availableFormats) <- KHR.getPhysicalDeviceSurfaceFormatsKHR phys surf
  surfaceFormat <- selectSurfaceFormat phys cfg availableFormats

  -- Use the surface's reported extent unless it tells us we can pick.
  let imageExtent =
        case SurfaceCapabilitiesKHR -> Extent2D
currentExtent (SurfaceCapabilitiesKHR
surfaceCaps :: SurfaceCapabilitiesKHR) of
          Vk.Extent2D Word32
w Word32
h | Word32
w Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
forall a. Bounded a => a
maxBound, Word32
h Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
forall a. Bounded a => a
maxBound -> Extent2D
explicitSize
          Extent2D
e -> Extent2D
e

  let imageCount =
        let
          limit :: Word32
limit = case SurfaceCapabilitiesKHR -> Word32
maxImageCount (SurfaceCapabilitiesKHR
surfaceCaps :: SurfaceCapabilitiesKHR) of
            Word32
0 -> Word32
forall a. Bounded a => a
maxBound
            Word32
n -> Word32
n
          buffer :: a
buffer = a
1 -- request one extra to avoid waiting on the driver
          desired :: Word32
desired = Word32
forall {a}. Num a => a
buffer Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ SurfaceCapabilitiesKHR -> Word32
SurfaceCapabilitiesKHR.minImageCount SurfaceCapabilitiesKHR
surfaceCaps
        in
          Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
min Word32
limit Word32
desired

  compositeAlphaMode <-
    if KHR.COMPOSITE_ALPHA_OPAQUE_BIT_KHR .&&. supportedCompositeAlpha surfaceCaps
      then pure KHR.COMPOSITE_ALPHA_OPAQUE_BIT_KHR
      else liftIO . throwIO . userError $ "Surface doesn't support COMPOSITE_ALPHA_OPAQUE_BIT_KHR"

  let swapchainCreateInfo =
        KHR.SwapchainCreateInfoKHR
          { surface :: SurfaceKHR
surface = SurfaceKHR
surf
          , next :: Chain '[]
next = ()
          , flags :: SwapchainCreateFlagsKHR
flags = SwapchainCreateFlagsKHR
forall a. Zero a => a
zero
          , queueFamilyIndices :: Vector Word32
queueFamilyIndices = Vector Word32
forall a. Monoid a => a
mempty
          , minImageCount :: Word32
minImageCount = Word32
imageCount
          , imageFormat :: Format
imageFormat = SurfaceFormatKHR -> Format
SurfaceFormatKHR.format SurfaceFormatKHR
surfaceFormat
          , imageColorSpace :: ColorSpaceKHR
imageColorSpace = SurfaceFormatKHR -> ColorSpaceKHR
colorSpace SurfaceFormatKHR
surfaceFormat
          , imageExtent :: Extent2D
imageExtent = Extent2D
imageExtent
          , imageArrayLayers :: Word32
imageArrayLayers = Word32
1
          , imageUsage :: ImageUsageFlagBits
imageUsage = (ImageUsageFlagBits -> ImageUsageFlagBits -> ImageUsageFlagBits)
-> ImageUsageFlagBits -> [ImageUsageFlagBits] -> ImageUsageFlagBits
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ImageUsageFlagBits -> ImageUsageFlagBits -> ImageUsageFlagBits
forall a. Bits a => a -> a -> a
(.|.) ImageUsageFlagBits
forall a. Zero a => a
zero (SwapchainConfig -> [ImageUsageFlagBits]
scRequiredUsageFlags SwapchainConfig
cfg)
          , imageSharingMode :: SharingMode
imageSharingMode = SharingMode
Vk.SHARING_MODE_EXCLUSIVE
          , preTransform :: SurfaceTransformFlagBitsKHR
preTransform = SurfaceCapabilitiesKHR -> SurfaceTransformFlagBitsKHR
SurfaceCapabilitiesKHR.currentTransform SurfaceCapabilitiesKHR
surfaceCaps
          , compositeAlpha :: CompositeAlphaFlagBitsKHR
compositeAlpha = CompositeAlphaFlagBitsKHR
compositeAlphaMode
          , presentMode :: PresentModeKHR
presentMode = PresentModeKHR
presentMode
          , clipped :: Bool
clipped = Bool
True
          , oldSwapchain :: SwapchainKHR
oldSwapchain = SwapchainKHR
oldSwapchain
          }

  (key, swapchain) <- KHR.withSwapchainKHR dev swapchainCreateInfo Nothing allocate

  pure (swapchain, surfaceFormat, imageExtent, presentMode, key)

-- | 2D color image view covering the whole image.
allocateImageView
  :: (MonadResource m)
  => Vk.Device
  -> Vk.Format
  -> Vk.Image
  -> m (ReleaseKey, Vk.ImageView)
allocateImageView :: forall (m :: * -> *).
MonadResource m =>
Device -> Format -> Image -> m (ReleaseKey, ImageView)
allocateImageView Device
dev Format
format Image
image =
  Device
-> ImageViewCreateInfo '[]
-> Maybe AllocationCallbacks
-> (IO ImageView
    -> (ImageView -> IO ()) -> m (ReleaseKey, ImageView))
-> m (ReleaseKey, ImageView)
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
dev ImageViewCreateInfo '[]
imageViewCreateInfo Maybe AllocationCallbacks
forall a. Maybe a
Nothing IO ImageView -> (ImageView -> IO ()) -> m (ReleaseKey, ImageView)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
  where
    imageViewCreateInfo :: ImageViewCreateInfo '[]
imageViewCreateInfo =
      ImageViewCreateInfo '[]
forall a. Zero a => a
zero
        { Vk.image = image
        , Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D
        , Vk.format = format
        , Vk.components =
            zero
              { Vk.r = Vk.COMPONENT_SWIZZLE_IDENTITY
              , Vk.g = Vk.COMPONENT_SWIZZLE_IDENTITY
              , Vk.b = Vk.COMPONENT_SWIZZLE_IDENTITY
              , Vk.a = Vk.COMPONENT_SWIZZLE_IDENTITY
              }
        , Vk.subresourceRange =
            zero
              { Vk.aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT
              , Vk.baseMipLevel = 0
              , Vk.levelCount = 1
              , Vk.baseArrayLayer = 0
              , Vk.layerCount = 1
              }
        }

----------------------------------------------------------------
-- Format selection
----------------------------------------------------------------

{- | Prefer formats whose 'optimalTilingFeatures' satisfy
'scRequiredFormatFeatures' and additionally match one of
'scSurfaceFormatPreferences' (best preference first). Falls back to the
first feature-satisfying format, then to the head if all else fails.
-}
selectSurfaceFormat
  :: (MonadIO m)
  => Vk.PhysicalDevice
  -> SwapchainConfig
  -> Vector SurfaceFormatKHR
  -> m SurfaceFormatKHR
selectSurfaceFormat :: forall (m :: * -> *).
MonadIO m =>
PhysicalDevice
-> SwapchainConfig
-> ("surfaceFormats" ::: Vector SurfaceFormatKHR)
-> m SurfaceFormatKHR
selectSurfaceFormat PhysicalDevice
phys SwapchainConfig
cfg "surfaceFormats" ::: Vector SurfaceFormatKHR
fmts = do
  good <- (SurfaceFormatKHR -> m Bool)
-> ("surfaceFormats" ::: Vector SurfaceFormatKHR)
-> m ("surfaceFormats" ::: Vector SurfaceFormatKHR)
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> Vector a -> m (Vector a)
V.filterM SurfaceFormatKHR -> m Bool
featuresOK "surfaceFormats" ::: Vector SurfaceFormatKHR
fmts
  let fallback = if ("surfaceFormats" ::: Vector SurfaceFormatKHR) -> Bool
forall a. Vector a -> Bool
V.null "surfaceFormats" ::: Vector SurfaceFormatKHR
good then ("surfaceFormats" ::: Vector SurfaceFormatKHR) -> SurfaceFormatKHR
forall a. Vector a -> a
V.head "surfaceFormats" ::: Vector SurfaceFormatKHR
fmts else ("surfaceFormats" ::: Vector SurfaceFormatKHR) -> SurfaceFormatKHR
forall a. Vector a -> a
V.head "surfaceFormats" ::: Vector SurfaceFormatKHR
good
  pure $ pickPreference (scSurfaceFormatPreferences cfg) good fallback
  where
    featuresOK :: SurfaceFormatKHR -> m Bool
featuresOK SurfaceFormatKHR
f = do
      props <- PhysicalDevice -> Format -> m FormatProperties
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> Format -> io FormatProperties
Vk.getPhysicalDeviceFormatProperties PhysicalDevice
phys (SurfaceFormatKHR -> Format
SurfaceFormatKHR.format SurfaceFormatKHR
f)
      pure $ all (Vk.optimalTilingFeatures props .&&.) (scRequiredFormatFeatures cfg)

    pickPreference :: [t -> Bool] -> Vector t -> t -> t
pickPreference [] Vector t
_ t
fallback = t
fallback
    pickPreference (t -> Bool
p : [t -> Bool]
ps) Vector t
good t
fallback =
      case (t -> Bool) -> Vector t -> Maybe t
forall a. (a -> Bool) -> Vector a -> Maybe a
V.find t -> Bool
p Vector t
good of
        Just t
f -> t
f
        Maybe t
Nothing -> [t -> Bool] -> Vector t -> t -> t
pickPreference [t -> Bool]
ps Vector t
good t
fallback

----------------------------------------------------------------
-- Specifications
----------------------------------------------------------------

-- | Catch an 'ERROR_OUT_OF_DATE_KHR' exception and return 'True' when caught.
threwSwapchainError :: IO b -> IO Bool
threwSwapchainError :: forall b. IO b -> IO Bool
threwSwapchainError = (Either Result b -> Bool) -> IO (Either Result b) -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either Result b -> Bool
forall a b. Either a b -> Bool
isLeft (IO (Either Result b) -> IO Bool)
-> (IO b -> IO (Either Result b)) -> IO b -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VulkanException -> Maybe Result) -> IO b -> IO (Either Result b)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (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 -> Result -> Maybe Result
forall a. a -> Maybe a
Just Result
e
      VulkanException Result
_ -> Maybe Result
forall a. Maybe a
Nothing