{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedRecordDot #-}

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 (SwapchainInfo -> Extent2D)
-> (SwapchainResources -> SwapchainInfo)
-> SwapchainResources
-> Extent2D
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwapchainResources -> SwapchainInfo
srInfo
  getSurfaceFormat :: SwapchainResources -> Format
getSurfaceFormat  = SwapchainInfo -> Format
siSurfaceFormat (SwapchainInfo -> Format)
-> (SwapchainResources -> SwapchainInfo)
-> SwapchainResources
-> Format
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwapchainResources -> SwapchainInfo
srInfo
  getDepthFormat :: SwapchainResources -> Format
getDepthFormat    = SwapchainInfo -> Format
siDepthFormat (SwapchainInfo -> Format)
-> (SwapchainResources -> SwapchainInfo)
-> SwapchainResources
-> Format
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwapchainResources -> SwapchainInfo
srInfo
  getMultisample :: SwapchainResources -> SampleCountFlagBits
getMultisample    = SwapchainInfo -> SampleCountFlagBits
siMultisample (SwapchainInfo -> SampleCountFlagBits)
-> (SwapchainResources -> SwapchainInfo)
-> SwapchainResources
-> SampleCountFlagBits
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwapchainResources -> SwapchainInfo
srInfo
  getAnisotropy :: SwapchainResources -> Float
getAnisotropy     = SwapchainInfo -> Float
siAnisotropy (SwapchainInfo -> Float)
-> (SwapchainResources -> SwapchainInfo)
-> SwapchainResources
-> Float
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 (SwapchainInfo -> Word32)
-> (SwapchainResources -> SwapchainInfo)
-> SwapchainResources
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwapchainResources -> SwapchainInfo
srInfo
  getImageCount :: SwapchainResources -> Word32
getImageCount     = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32)
-> (SwapchainResources -> Int) -> SwapchainResources -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Image -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
V.length (Vector Image -> Int)
-> (SwapchainResources -> Vector Image)
-> SwapchainResources
-> Int
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
     )
  => Maybe Khr.PresentModeKHR
  -> Vk.SampleCountFlagBits
  -> 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) =>
Maybe PresentModeKHR
-> SampleCountFlagBits
-> SwapchainKHR
-> Extent2D
-> SurfaceKHR
-> Var Extent2D
-> RIO env SwapchainResources
allocSwapchainResources Maybe PresentModeKHR
present SampleCountFlagBits
msaa SwapchainKHR
oldSwapchain Extent2D
windowSize SurfaceKHR
surface Var Extent2D
screenVar = do
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Allocating swapchain resources"

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

  -- XXX: Get all the swapchain images, and create views for them
  (Result
_, Vector Image
swapchainImages) <- Device -> SwapchainKHR -> RIO env (Result, Vector Image)
forall (io :: * -> *).
MonadIO io =>
Device -> SwapchainKHR -> io (Result, Vector Image)
Khr.getSwapchainImagesKHR Device
device SwapchainKHR
siSwapchain
  Vector (ReleaseKey, ImageView)
res <- Vector Image
-> (Image -> RIO env (ReleaseKey, ImageView))
-> RIO env (Vector (ReleaseKey, ImageView))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Vector Image
swapchainImages ((Image -> RIO env (ReleaseKey, ImageView))
 -> RIO env (Vector (ReleaseKey, ImageView)))
-> (Image -> RIO env (ReleaseKey, ImageView))
-> RIO env (Vector (ReleaseKey, ImageView))
forall a b. (a -> b) -> a -> b
$
    Format -> Image -> RIO env (ReleaseKey, ImageView)
forall (m :: * -> *) env.
(MonadResource m, MonadVulkan env m) =>
Format -> Image -> m (ReleaseKey, ImageView)
createImageView Format
siSurfaceFormat
  let (Vector ReleaseKey
imageViewKeys, Vector ImageView
imageViews) = Vector (ReleaseKey, ImageView)
-> (Vector ReleaseKey, Vector ImageView)
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 <- RIO env () -> RIO env (IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (RIO env () -> RIO env (IO ())) -> RIO env () -> RIO env (IO ())
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Releasing swapchain resources"
  RefCounted
releaseResources <- IO () -> RIO env RefCounted
forall (m :: * -> *). MonadIO m => IO () -> m RefCounted
newRefCounted (IO () -> RIO env RefCounted) -> IO () -> RIO env RefCounted
forall a b. (a -> b) -> a -> b
$ do
    IO ()
releaseDebug
    (ReleaseKey -> IO ()) -> Vector ReleaseKey -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ReleaseKey -> IO ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release Vector ReleaseKey
imageViewKeys
    ReleaseKey -> IO ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
siSwapchainReleaseKey

  Var Extent2D
-> (GetInput (Var Extent2D) -> GetInput (Var Extent2D))
-> RIO env ()
forall (m :: * -> *) var.
(MonadIO m, HasInput var) =>
var -> (GetInput var -> GetInput var) -> m ()
Worker.pushInput Var Extent2D
screenVar ((GetInput (Var Extent2D) -> GetInput (Var Extent2D))
 -> RIO env ())
-> (GetInput (Var Extent2D) -> GetInput (Var Extent2D))
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ Extent2D -> Extent2D -> Extent2D
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
     )
  => Maybe Khr.PresentModeKHR
  -> Vk.SampleCountFlagBits
  -> Vk.Extent2D
  -> SwapchainResources
  -- ^ The reference to these resources will be dropped
  -> RIO env SwapchainResources
recreateSwapchainResources :: forall env.
(MonadResource (RIO env), HasVulkan env, HasLogFunc env) =>
Maybe PresentModeKHR
-> SampleCountFlagBits
-> Extent2D
-> SwapchainResources
-> RIO env SwapchainResources
recreateSwapchainResources Maybe PresentModeKHR
present SampleCountFlagBits
msaa Extent2D
windowSize SwapchainResources
oldResources = do
  SwapchainResources
sr <- Maybe PresentModeKHR
-> SampleCountFlagBits
-> SwapchainKHR
-> Extent2D
-> SurfaceKHR
-> Var Extent2D
-> RIO env SwapchainResources
forall env.
(MonadResource (RIO env), HasVulkan env, HasLogFunc env) =>
Maybe PresentModeKHR
-> SampleCountFlagBits
-> SwapchainKHR
-> Extent2D
-> SurfaceKHR
-> Var Extent2D
-> RIO env SwapchainResources
allocSwapchainResources
    Maybe PresentModeKHR
present
    SampleCountFlagBits
msaa
    (SwapchainInfo -> SwapchainKHR
siSwapchain (SwapchainInfo -> SwapchainKHR) -> SwapchainInfo -> SwapchainKHR
forall a b. (a -> b) -> a -> b
$ SwapchainResources -> SwapchainInfo
srInfo SwapchainResources
oldResources)
    Extent2D
windowSize
    (SwapchainInfo -> SurfaceKHR
siSurface (SwapchainInfo -> SurfaceKHR) -> SwapchainInfo -> SurfaceKHR
forall a b. (a -> b) -> a -> b
$ SwapchainResources -> SwapchainInfo
srInfo SwapchainResources
oldResources)
    (SwapchainResources -> Var Extent2D
srScreenVar SwapchainResources
oldResources)
  RefCounted -> RIO env ()
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
     )
  => Maybe Khr.PresentModeKHR
  -> Vk.SampleCountFlagBits
  -> 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) =>
Maybe PresentModeKHR
-> SampleCountFlagBits
-> SwapchainKHR
-> Extent2D
-> SurfaceKHR
-> m SwapchainInfo
createSwapchain Maybe PresentModeKHR
present SampleCountFlagBits
msaa SwapchainKHR
oldSwapchain Extent2D
explicitSize SurfaceKHR
surf = do
  PhysicalDevice
physical <- (env -> PhysicalDevice) -> m PhysicalDevice
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> PhysicalDevice
forall a. HasVulkan a => a -> PhysicalDevice
getPhysicalDevice
  Device
device <- (env -> Device) -> m Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Device
forall a. HasVulkan a => a -> Device
getDevice
  PhysicalDeviceProperties
props <- (env -> PhysicalDeviceProperties) -> m PhysicalDeviceProperties
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((env -> PhysicalDeviceProperties) -> m PhysicalDeviceProperties)
-> (env -> PhysicalDeviceProperties) -> m PhysicalDeviceProperties
forall a b. (a -> b) -> a -> b
$ PhysicalDeviceInfo -> PhysicalDeviceProperties
pdiProperties (PhysicalDeviceInfo -> PhysicalDeviceProperties)
-> (env -> PhysicalDeviceInfo) -> env -> PhysicalDeviceProperties
forall b c a. (b -> c) -> (a -> b) -> a -> c
. env -> PhysicalDeviceInfo
forall a. HasVulkan a => a -> PhysicalDeviceInfo
getPhysicalDeviceInfo
  SurfaceCapabilitiesKHR
surfaceCaps <- PhysicalDevice -> SurfaceKHR -> m SurfaceCapabilitiesKHR
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> SurfaceKHR -> io SurfaceCapabilitiesKHR
Khr.getPhysicalDeviceSurfaceCapabilitiesKHR PhysicalDevice
physical SurfaceKHR
surf

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

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

  -- Select a present mode
  [PresentModeKHR]
desiredPresentModes <- case Maybe PresentModeKHR
present of
    Maybe PresentModeKHR
Nothing -> do
      Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Using default present modes: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [PresentModeKHR] -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow [PresentModeKHR]
defaultPresentModes
      pure [PresentModeKHR]
defaultPresentModes
    Just PresentModeKHR
selected -> do
      Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Forcing selected present mode: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PresentModeKHR -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow PresentModeKHR
selected
      pure [Item [PresentModeKHR]
PresentModeKHR
selected]
  (Result
_, "presentModes" ::: Vector PresentModeKHR
availablePresentModes) <- PhysicalDevice
-> SurfaceKHR
-> m (Result, "presentModes" ::: Vector PresentModeKHR)
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice
-> SurfaceKHR
-> io (Result, "presentModes" ::: Vector PresentModeKHR)
Khr.getPhysicalDeviceSurfacePresentModesKHR PhysicalDevice
physical SurfaceKHR
surf
  PresentModeKHR
presentMode <-
    case (PresentModeKHR -> Bool) -> [PresentModeKHR] -> [PresentModeKHR]
forall a. (a -> Bool) -> [a] -> [a]
filter (PresentModeKHR
-> ("presentModes" ::: Vector PresentModeKHR) -> Bool
forall (v :: * -> *) a. (Vector v a, Eq a) => a -> v a -> Bool
`V.elem` "presentModes" ::: Vector PresentModeKHR
availablePresentModes) [PresentModeKHR]
desiredPresentModes of
      [] -> do
        Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Unable to find a suitable present mode for swapchain"
        String -> m PresentModeKHR
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"Unable to find a suitable present mode for swapchain"
      PresentModeKHR
x : [PresentModeKHR]
_rest ->
        PresentModeKHR -> m PresentModeKHR
forall a. a -> m a
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 <- PhysicalDevice
-> SurfaceKHR -> SurfaceFormatKHR -> m SurfaceFormatKHR
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice
-> SurfaceKHR -> SurfaceFormatKHR -> io SurfaceFormatKHR
getSurfaceFormatKhr PhysicalDevice
physical SurfaceKHR
surf SurfaceFormatKHR
preferSrgb

  Format
depthFormat <- PhysicalDevice -> [Format] -> m [Format]
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> [Format] -> io [Format]
getDepthFormats PhysicalDevice
physical [Format]
preferStenciledDepth m [Format] -> ([Format] -> m Format) -> m Format
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Format
fmt : [Format]
_rest ->
      Format -> m Format
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Format
fmt
    [Format]
_none ->
      String -> m Format
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 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
extent ->
          Extent2D
extent

  let
    minImageCount :: Word32
minImageCount =
      let
        limit :: Word32
limit = case SurfaceCapabilitiesKHR
surfaceCaps.maxImageCount of
          Word32
0 -> Word32
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 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ SurfaceCapabilitiesKHR
surfaceCaps.minImageCount
      in
        Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
min Word32
limit Word32
desired

  let compositeAlphaMode :: CompositeAlphaFlagBitsKHR
compositeAlphaMode = CompositeAlphaFlagBitsKHR
Khr.COMPOSITE_ALPHA_OPAQUE_BIT_KHR
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CompositeAlphaFlagBitsKHR
compositeAlphaMode CompositeAlphaFlagBitsKHR -> CompositeAlphaFlagBitsKHR -> Bool
forall a. Bits a => a -> a -> Bool
.&&. SurfaceCapabilitiesKHR -> CompositeAlphaFlagBitsKHR
Khr.supportedCompositeAlpha SurfaceCapabilitiesKHR
surfaceCaps) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    String -> m ()
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Surface doesn't support " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CompositeAlphaFlagBitsKHR -> String
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              = SwapchainCreateFlagsKHR
forall a. Zero a => a
zero
      , $sel:queueFamilyIndices:SwapchainCreateInfoKHR :: Vector Word32
queueFamilyIndices = Vector Word32
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         = (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 [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
      }

  Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Creating swapchain from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SwapchainCreateInfoKHR '[] -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow SwapchainCreateInfoKHR '[]
swapchainCreateInfo
  (ReleaseKey
key, SwapchainKHR
swapchain) <- Device
-> SwapchainCreateInfoKHR '[]
-> Maybe AllocationCallbacks
-> (IO SwapchainKHR
    -> (SwapchainKHR -> IO ()) -> m (ReleaseKey, SwapchainKHR))
-> m (ReleaseKey, SwapchainKHR)
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 Maybe AllocationCallbacks
forall a. Maybe a
Nothing IO SwapchainKHR
-> (SwapchainKHR -> IO ()) -> m (ReleaseKey, SwapchainKHR)
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         = SampleCountFlagBits
-> PhysicalDeviceProperties -> SampleCountFlagBits
msaaSamples SampleCountFlagBits
msaa 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) <- PhysicalDevice
-> SurfaceKHR
-> io (Result, "surfaceFormats" ::: Vector SurfaceFormatKHR)
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice
-> SurfaceKHR
-> io (Result, "surfaceFormats" ::: Vector SurfaceFormatKHR)
Khr.getPhysicalDeviceSurfaceFormatsKHR PhysicalDevice
device SurfaceKHR
surface
  SurfaceFormatKHR -> io SurfaceFormatKHR
forall a. a -> io a
forall (f :: * -> *) a. Applicative f => a -> f a
pure case ("surfaceFormats" ::: Vector SurfaceFormatKHR)
-> [SurfaceFormatKHR]
forall a. Vector a -> [a]
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 | (SurfaceFormatKHR -> Bool) -> [SurfaceFormatKHR] -> Bool
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 Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== SurfaceFormatKHR -> Format
Khr.format SurfaceFormatKHR
desiredFormat Bool -> Bool -> Bool
&&
      SurfaceFormatKHR -> ColorSpaceKHR
Khr.colorSpace SurfaceFormatKHR
f ColorSpaceKHR -> ColorSpaceKHR -> Bool
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 <- (Format -> io FormatProperties)
-> [Format] -> io [FormatProperties]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (PhysicalDevice -> Format -> io FormatProperties
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> Format -> io FormatProperties
Vk.getPhysicalDeviceFormatProperties PhysicalDevice
device) [Format]
desiredDepthFormats
  pure do
    (Format
format, FormatProperties
props) <- [Format] -> [FormatProperties] -> [(Format, FormatProperties)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Format]
desiredDepthFormats [FormatProperties]
properties
    Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$
      FormatProperties -> FormatFeatureFlags
Vk.optimalTilingFeatures FormatProperties
props FormatFeatureFlags -> FormatFeatureFlags -> Bool
forall a. Bits a => a -> a -> Bool
.&&. FormatFeatureFlags
Vk.FORMAT_FEATURE_DEPTH_STENCIL_ATTACHMENT_BIT
    pure Format
format

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

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

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

msaaCandidates :: [Vk.SampleCountFlagBits]
msaaCandidates :: [SampleCountFlagBits]
msaaCandidates =
  [ Item [SampleCountFlagBits]
SampleCountFlagBits
Vk.SAMPLE_COUNT_64_BIT -- XXX: extremely unrealistic?
  , Item [SampleCountFlagBits]
SampleCountFlagBits
Vk.SAMPLE_COUNT_32_BIT -- XXX: unrealistic?
  , Item [SampleCountFlagBits]
SampleCountFlagBits
Vk.SAMPLE_COUNT_16_BIT -- XXX: possible, but not that impactful
  , Item [SampleCountFlagBits]
SampleCountFlagBits
Vk.SAMPLE_COUNT_8_BIT
  , Item [SampleCountFlagBits]
SampleCountFlagBits
Vk.SAMPLE_COUNT_4_BIT -- XXX: Khronos-recommended for rasterizing
  , Item [SampleCountFlagBits]
SampleCountFlagBits
Vk.SAMPLE_COUNT_2_BIT
  , Item [SampleCountFlagBits]
SampleCountFlagBits
Vk.SAMPLE_COUNT_1_BIT -- XXX: i.e. "disable", always available
  ]

-- | An ordered list of the present mode to be chosen for the swapchain.
defaultPresentModes :: [Khr.PresentModeKHR]
defaultPresentModes :: [PresentModeKHR]
defaultPresentModes =
  [ Item [PresentModeKHR]
PresentModeKHR
Khr.PRESENT_MODE_FIFO_RELAXED_KHR
  , Item [PresentModeKHR]
PresentModeKHR
Khr.PRESENT_MODE_FIFO_KHR --  ^ This will always be present
  ]

-- | The images in the swapchain must support these flags.
requiredUsageFlags :: [Vk.ImageUsageFlagBits]
requiredUsageFlags :: [ImageUsageFlagBits]
requiredUsageFlags =
  [ Item [ImageUsageFlagBits]
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 = (Either Result () -> Bool) -> f (Either Result ()) -> f Bool
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either Result () -> Bool
forall a b. Either a b -> Bool
isLeft (f (Either Result ()) -> f Bool)
-> (f () -> f (Either Result ())) -> f () -> f Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VulkanException -> Maybe Result) -> f () -> f (Either Result ())
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 ->
      Result -> Maybe Result
forall a. a -> Maybe a
Just Result
e

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

    VulkanException Result
_ ->
      Maybe 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 <- (env -> Device) -> m Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Device
forall a. HasVulkan a => a -> Device
getDevice
  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
device ImageViewCreateInfo '[]
imageViewCI 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
  imageViewCI :: ImageViewCreateInfo '[]
imageViewCI = 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
    -- , Vk.components       = zero
    , $sel:subresourceRange:ImageViewCreateInfo :: ImageSubresourceRange
Vk.subresourceRange = 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
        }
    }

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
  CommandBuffer -> Word32 -> Vector Viewport -> io ()
forall (io :: * -> *).
MonadIO io =>
CommandBuffer -> Word32 -> Vector Viewport -> io ()
Vk.cmdSetViewport CommandBuffer
cb Word32
0 [Item (Vector Viewport)
Viewport
viewport]
  CommandBuffer -> Word32 -> Vector ("viewport" ::: Rect2D) -> io ()
forall (io :: * -> *).
MonadIO io =>
CommandBuffer -> Word32 -> Vector ("viewport" ::: Rect2D) -> io ()
Vk.cmdSetScissor CommandBuffer
cb Word32
0 [Item (Vector ("viewport" ::: Rect2D))
"viewport" ::: Rect2D
scissor]
  where
    viewport :: Viewport
viewport = Vk.Viewport
      { $sel:x:Viewport :: Float
x        = Int32 -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Int32
x
      , $sel:y:Viewport :: Float
y        = Int32 -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Int32
y
      , $sel:width:Viewport :: Float
width    = Word32 -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Word32
width
      , $sel:height:Viewport :: Float
height   = Word32 -> Float
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
x :: Int32
$sel:x:Offset2D :: Offset2D -> Int32
x, Int32
y :: Int32
$sel:y:Offset2D :: Offset2D -> Int32
y} = Offset2D
offset
        Vk.Extent2D{Word32
width :: Word32
$sel:width:Extent2D :: Extent2D -> Word32
width, Word32
height :: Word32
$sel:height:Extent2D :: Extent2D -> Word32
height} = Extent2D
extent
        Vk.Rect2D{Offset2D
offset :: Offset2D
$sel:offset:Rect2D :: ("viewport" ::: Rect2D) -> Offset2D
offset, Extent2D
extent :: Extent2D
$sel:extent:Rect2D :: ("viewport" ::: Rect2D) -> Extent2D
extent} = "viewport" ::: Rect2D
viewrect

setDynamicFullscreen
  :: ( HasSwapchain swapchain
     , MonadIO io
     )
  => Vk.CommandBuffer
  -> swapchain
  -> io ()
setDynamicFullscreen :: forall swapchain (io :: * -> *).
(HasSwapchain swapchain, MonadIO io) =>
CommandBuffer -> swapchain -> io ()
setDynamicFullscreen CommandBuffer
cb swapchain
swapchain = do
  CommandBuffer -> Word32 -> Vector Viewport -> io ()
forall (io :: * -> *).
MonadIO io =>
CommandBuffer -> Word32 -> 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    = Word32 -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Word32
width
        , $sel:height:Viewport :: Float
height   = Word32 -> Float
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
        }
    ]
  CommandBuffer -> Word32 -> Vector ("viewport" ::: Rect2D) -> io ()
forall (io :: * -> *).
MonadIO io =>
CommandBuffer -> Word32 -> Vector ("viewport" ::: Rect2D) -> io ()
Vk.cmdSetScissor CommandBuffer
cb Word32
0
    [ Vk.Rect2D
        { $sel:offset:Rect2D :: Offset2D
offset = Offset2D
forall a. Zero a => a
zero
        , $sel:extent:Rect2D :: Extent2D
extent = Extent2D
extent
        }
    ]
  where
    extent :: Extent2D
extent@Vk.Extent2D{Word32
$sel:width:Extent2D :: Extent2D -> Word32
width :: Word32
width, Word32
$sel:height:Extent2D :: Extent2D -> Word32
height :: Word32
height} =
      swapchain -> Extent2D
forall a. HasSwapchain a => a -> Extent2D
getSurfaceExtent swapchain
swapchain