{-# 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
allocSwapchainResources
:: ( MonadResource (RIO env)
, HasVulkan env
, HasLogFunc env
)
=> Khr.SwapchainKHR
-> Vk.Extent2D
-> Khr.SurfaceKHR
-> Worker.Var Vk.Extent2D
-> 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
(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
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
-> 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
createSwapchain
:: ( MonadResource m
, MonadVulkan env m
, HasLogFunc env
)
=> Khr.SwapchainKHR
-> Vk.Extent2D
-> 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
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
(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
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"
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
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
, $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
}
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 =
[ SampleCountFlagBits
Vk.SAMPLE_COUNT_4_BIT
, SampleCountFlagBits
Vk.SAMPLE_COUNT_2_BIT
]
desiredPresentModes :: [Khr.PresentModeKHR]
desiredPresentModes :: [PresentModeKHR]
desiredPresentModes =
[ PresentModeKHR
Khr.PRESENT_MODE_FIFO_RELAXED_KHR
, PresentModeKHR
Khr.PRESENT_MODE_FIFO_KHR
, PresentModeKHR
Khr.PRESENT_MODE_IMMEDIATE_KHR
]
requiredUsageFlags :: [Vk.ImageUsageFlagBits]
requiredUsageFlags :: [ImageUsageFlagBits]
requiredUsageFlags =
[ ImageUsageFlagBits
Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT
]
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
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
, $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