vulkan-utils 0.5.10.6 → 0.5.11.0

raw patch · 45 files changed

+5560/−1905 lines, 45 filesdep +unagi-chandep +unliftio-coredep −dependent-mapdep −dependent-sumdep ~basedep ~vulkannew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: unagi-chan, unliftio-core

Dependencies removed: dependent-map, dependent-sum

Dependency ranges changed: base, vulkan

API changes (from Hackage documentation)

Files

• changelog.md +67/−1
• package.yaml +8/−7
• src/Vulkan/Utils/Barrier.hs +145/−0
• src/Vulkan/Utils/CommandCheck.hs +139/−123
• src/Vulkan/Utils/Debug.hs +17/−13
• src/Vulkan/Utils/Descriptors.hs +79/−0
• src/Vulkan/Utils/DynamicRendering.hs +230/−0
• src/Vulkan/Utils/DynamicState.hs +282/−0
• src/Vulkan/Utils/Frame.hs +502/−0
• src/Vulkan/Utils/Framebuffer.hs +34/−0
• src/Vulkan/Utils/FromGL.hs +127/−148
• src/Vulkan/Utils/Init/Headless.hs +22/−0
• src/Vulkan/Utils/Initialization.hs +263/−110
• src/Vulkan/Utils/Internal.hs +21/−17
• src/Vulkan/Utils/Misc.hs +60/−49
• src/Vulkan/Utils/Pipeline.hs +161/−0
• src/Vulkan/Utils/Pipeline/Internal.hs +185/−0
• src/Vulkan/Utils/Pipeline/Specialization.hs +234/−0
• src/Vulkan/Utils/PipelineLayout.hs +84/−0
• src/Vulkan/Utils/QueueAssignment.hs +193/−173
• src/Vulkan/Utils/Queues.hs +253/−0
• src/Vulkan/Utils/RefCounted.hs +60/−0
• src/Vulkan/Utils/RenderPass.hs +245/−0
• src/Vulkan/Utils/Requirements.hs +412/−318
• src/Vulkan/Utils/Requirements/TH.hs +241/−222
• src/Vulkan/Utils/Shader.hs +55/−0
• src/Vulkan/Utils/ShaderQQ/Backend/Glslang.hs +11/−9
• src/Vulkan/Utils/ShaderQQ/Backend/Glslang/Internal.hs +44/−39
• src/Vulkan/Utils/ShaderQQ/Backend/Internal.hs +4/−4
• src/Vulkan/Utils/ShaderQQ/Backend/Shaderc.hs +56/−54
• src/Vulkan/Utils/ShaderQQ/Backend/Shaderc/Internal.hs +41/−36
• src/Vulkan/Utils/ShaderQQ/GLSL.hs +48/−43
• src/Vulkan/Utils/ShaderQQ/GLSL/Glslang.hs +117/−100
• src/Vulkan/Utils/ShaderQQ/GLSL/Shaderc.hs +117/−100
• src/Vulkan/Utils/ShaderQQ/HLSL.hs +32/−30
• src/Vulkan/Utils/ShaderQQ/HLSL/Glslang.hs +114/−98
• src/Vulkan/Utils/ShaderQQ/HLSL/Shaderc.hs +114/−98
• src/Vulkan/Utils/ShaderQQ/Interpolate.hs +105/−97
• src/Vulkan/Utils/ShaderQQ/ShaderType.hs +1/−1
• src/Vulkan/Utils/Swapchain.hs +359/−0
• src/Vulkan/Utils/VulkanContext.hs +76/−0
• src/Vulkan/Utils/WindowAdapter.hs +30/−0
• src/Vulkan/Utils/WindowLoop.hs +135/−0
• test/doctest/Doctests.hs +6/−5
• vulkan-utils.cabal +31/−10

@@ -1,6 +1,72 @@ # Change Log -## WIP+## [0.5.11.0] - 2026-07-01++A large additive release: helpers for dynamic rendering, dynamic pipeline+state, specialization constants, synchronization, swapchain/frame management,+and window abstraction.++Resource-managing helpers follow the `create`/`with`/`allocate` naming+convention: anything that slots a `ResourceT.allocate` into a `withXxx` is named+`allocate*`. The three pre-existing `Initialization` helpers were renamed to+match, with the old names kept as deprecated aliases (see Deprecations); no+existing API was removed. The baseline is vulkan-3.27 and GHC-9.2.++### Pipelines and dynamic rendering+- `Vulkan.Utils.DynamicRendering`: `allocatePipeline` and+  `allocatePipelineFromShaders` for render-pass-less pipelines, plus+  `renderingInfo`, `colorAttachmentRenderingInfo`, and+  `dynamicRenderingRequirements`.+- `Vulkan.Utils.DynamicState`: a `DynamicState` record with+  `defaultDynamicState`, `dynamicStateFor`, and `applyDynamicStates`, plus named+  state sets (`allDynamicStates`, `minimalDynamicStates`, `noDynamicStates`,+  `preRasterizationStates`, `fragmentTestStates`, `fragmentOutputStates`,+  `depthOnlyDynamicStates`, `defaultDynamicStatesFor`) covering the dynamic+  states available without vendor or experimental extensions.+- `Vulkan.Utils.Pipeline.Specialization`: the `Specialization` and+  `SpecializationConst` classes with `withSpecialization` /+  `allocateSpecialization` for packing specialization constants.+- `Vulkan.Utils.RenderPass`: `allocateRenderPass`, `allocateColorRenderPass`, and+  a generic `allocatePipeline` / `allocatePipelineFromShaders`.+- `Vulkan.Utils.Framebuffer`: `allocateFramebuffer`.+- `Vulkan.Utils.Shader`: `shaderStage` and `shaderModuleStage`.++### Synchronization and descriptors+- `Vulkan.Utils.Barrier`: `imageBarrier`, `bufferBarrier`, and the common+  transitions `transitionColorAttachment`, `transitionDepthAttachment`, and+  `transitionPresent`.+- `Vulkan.Utils.Descriptors`: `bufferWrite` and `imageWrite` for common+  single-binding descriptor writes.+- `Vulkan.Utils.RefCounted`: a reference-counted release primitive+  (`newRefCounted`, `takeRefCounted`, `releaseRefCounted`,+  `resourceTRefCount`).++### Swapchain, frames, and windowing+- `Vulkan.Utils.Swapchain`: `Swapchain` and `SwapchainConfig` with+  `defaultSwapchainConfig`, `allocateSwapchain`, `recreateSwapchain`, and+  `threwSwapchainError`.+- `Vulkan.Utils.Frame`: a `Frame` record driving frames-in-flight —+  `advanceFrame`, `runFrame`, `recordCommands`, `queueSubmitFrame`,+  `acquireFrameImage`, `presentFrameImage`, `drainFrames`,+  `allocateTimelineSemaphore`, and the matching requirements helpers.+- `Vulkan.Utils.VulkanContext`: `VulkanContext` and `RecycledResources` with+  `mkVulkanContext`.+- `Vulkan.Utils.WindowAdapter`: a backend-agnostic `WindowAdapter` record (the+  `vulkan-init-sdl2` and `vulkan-init-glfw` packages provide instances).+- `Vulkan.Utils.WindowLoop`: `runWindowLoop` with the `WindowLoop` record and+  the `noWindowState` / `noOnFrame` / `noOnExit` defaults.+- `Vulkan.Utils.Queues`: a `Queues` record and `allocateDevice`.+- `Vulkan.Utils.Init.Headless`: `allocateInstance` for headless setup.++### Dependencies+- Now depends on `unagi-chan` and `unliftio-core`.++### Deprecations+- `Vulkan.Utils.Initialization`: `createInstanceFromRequirements`,+  `createDebugInstanceFromRequirements`, and `createDeviceFromRequirements` are+  renamed to `allocateInstanceFromRequirements`,+  `allocateDebugInstanceFromRequirements`, and `allocateDeviceFromRequirements`.+  The old names remain as deprecated aliases.  ## [0.5.10.6] - 2023-10-21 

@@ -1,9 +1,9 @@ name: vulkan-utils-version: "0.5.10.6"+version: "0.5.11.0" synopsis: Utils for the vulkan package category: Graphics-maintainer: Ellie Hermaszewska <live.long.and.prosper@monoid.al>-github: expipiplus1/vulkan+maintainer: IC Rainbow <aenor.realm@gmail.com>, Ellie Hermaszewska <live.long.and.prosper@monoid.al>+github: haskell-game/vulkan extra-source-files: - readme.md - changelog.md@@ -23,11 +23,9 @@   - Vulkan.Utils.ShaderQQ.HLSL    dependencies:-  - base <5+  - base >= 4.16 && <5   - bytestring   - containers-  - dependent-map-  - dependent-sum   - extra   - file-embed   - filepath@@ -37,9 +35,11 @@   - text   - transformers   - typed-process+  - unagi-chan+  - unliftio-core   - unordered-containers   - vector-  - vulkan >= 3.6.14 && < 3.27+  - vulkan >= 3.27 && < 3.28  tests:   doctests:@@ -80,6 +80,7 @@ - MagicHash - NamedFieldPuns - NoMonomorphismRestriction+- OverloadedRecordDot - OverloadedStrings - PartialTypeSignatures - PatternSynonyms

@@ -0,0 +1,145 @@+{-# LANGUAGE OverloadedLists #-}++{-| Whole-resource pipeline barriers. The @transition*@ helpers issue the+common swapchain-and-attachment transitions as complete+'Vk.cmdPipelineBarrier' calls; 'imageBarrier' is the building block behind+them, exposed for assembling barriers they don't cover (handing a rendered+image to a compute pass, a storage image to a blit, …) — combining several+into one 'Vk.cmdPipelineBarrier' call where the stage scopes allow.+'bufferBarrier' is its buffer-flavoured sibling (a compute-written vertex+SSBO handed to the vertex shader, …).+-}+module Vulkan.Utils.Barrier+  ( transitionColorAttachment+  , transitionPresent+  , transitionDepthAttachment+  , imageBarrier+  , bufferBarrier+  ) where++import Control.Monad.IO.Class (MonadIO)+import Data.Bits ((.|.))+import Vulkan.CStruct.Extends (SomeStruct (..))+import qualified Vulkan.Core10 as Vk+import Vulkan.Zero (zero)++transitionColorAttachment :: (MonadIO m) => Vk.CommandBuffer -> Vk.Image -> m ()+transitionColorAttachment cb image =+  Vk.cmdPipelineBarrier+    cb+    Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT+    Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT+    zero+    []+    []+    [ imageBarrier+        Vk.IMAGE_ASPECT_COLOR_BIT+        zero+        Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT+        Vk.IMAGE_LAYOUT_UNDEFINED+        Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL+        image+    ]++transitionPresent :: (MonadIO m) => Vk.CommandBuffer -> Vk.Image -> m ()+transitionPresent cb image =+  Vk.cmdPipelineBarrier+    cb+    Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT+    Vk.PIPELINE_STAGE_BOTTOM_OF_PIPE_BIT+    zero+    []+    []+    [ imageBarrier+        Vk.IMAGE_ASPECT_COLOR_BIT+        Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT+        zero+        Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL+        Vk.IMAGE_LAYOUT_PRESENT_SRC_KHR+        image+    ]++{- | Transition a depth image from @UNDEFINED@ (discarding any previous contents)+to @DEPTH_ATTACHMENT_OPTIMAL@, ready to be used as a depth attachment. Issue it+before rendering whenever the attachment is about to be cleared on load — every+frame, like the colour images.++The destination scope covers both fragment-test stages with read and write+access: the @loadOp@ clear and late depth writes are writes, the depth test+itself is a read, and all of them must see the transition.+-}+transitionDepthAttachment :: (MonadIO m) => Vk.CommandBuffer -> Vk.Image -> m ()+transitionDepthAttachment cb image =+  Vk.cmdPipelineBarrier+    cb+    Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT+    (Vk.PIPELINE_STAGE_EARLY_FRAGMENT_TESTS_BIT .|. Vk.PIPELINE_STAGE_LATE_FRAGMENT_TESTS_BIT)+    zero+    []+    []+    [ imageBarrier+        Vk.IMAGE_ASPECT_DEPTH_BIT+        zero+        ( Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_READ_BIT+            .|. Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_WRITE_BIT+        )+        Vk.IMAGE_LAYOUT_UNDEFINED+        Vk.IMAGE_LAYOUT_DEPTH_ATTACHMENT_OPTIMAL+        image+    ]++{- | A whole-image memory barrier over the given aspect, from one+(access mask, layout) scope to another, with no queue-family ownership+transfer. The execution scopes (stage masks) live on the enclosing+'Vk.cmdPipelineBarrier' call, shared by every barrier in it.+-}+imageBarrier+  :: Vk.ImageAspectFlags+  -> Vk.AccessFlags+  -- ^ Source access mask.+  -> Vk.AccessFlags+  -- ^ Destination access mask.+  -> Vk.ImageLayout+  -- ^ Old layout; @UNDEFINED@ discards the image's previous contents.+  -> Vk.ImageLayout+  -- ^ New layout.+  -> Vk.Image+  -> SomeStruct Vk.ImageMemoryBarrier+imageBarrier aspect srcAccessMask dstAccessMask oldLayout newLayout image =+  SomeStruct+    zero+      { Vk.srcAccessMask = srcAccessMask+      , Vk.dstAccessMask = dstAccessMask+      , Vk.oldLayout = oldLayout+      , Vk.newLayout = newLayout+      , Vk.image = image+      , Vk.subresourceRange =+          zero+            { Vk.aspectMask = aspect+            , Vk.baseMipLevel = 0+            , Vk.levelCount = 1+            , Vk.baseArrayLayer = 0+            , Vk.layerCount = 1+            }+      }++{- | A whole-buffer memory barrier from one access scope to another, with no+queue-family ownership transfer. As with 'imageBarrier', the execution+scopes (stage masks) live on the enclosing 'Vk.cmdPipelineBarrier' call.+-}+bufferBarrier+  :: Vk.AccessFlags+  -- ^ Source access mask.+  -> Vk.AccessFlags+  -- ^ Destination access mask.+  -> Vk.Buffer+  -> SomeStruct Vk.BufferMemoryBarrier+bufferBarrier srcAccessMask dstAccessMask buffer =+  SomeStruct+    zero+      { Vk.srcAccessMask = srcAccessMask+      , Vk.dstAccessMask = dstAccessMask+      , Vk.buffer = buffer+      , Vk.offset = 0+      , Vk.size = Vk.WHOLE_SIZE+      }

@@ -1,164 +1,180 @@-{-# language TemplateHaskell #-}-{-# language NoMonadComprehensions #-}-{-# language MultiWayIf #-}-{-# language QuasiQuotes #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoMonadComprehensions #-}  module Vulkan.Utils.CommandCheck   ( checkCommandsExp   ) where -import           Control.Applicative            ( (<|>) )-import           Control.Arrow                  ( (&&&) )-import           Data.Char-import           Data.Functor                   ( (<&>) )-import           Data.List                      ( isPrefixOf-                                                , isSuffixOf-                                                , nub-                                                )-import           Data.List.Extra                ( dropEnd )-import           Data.Maybe                     ( catMaybes )-import           Foreign.Ptr-import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax-import           Vulkan.Core10 (Instance(..), Device(..))-import           Vulkan.Dynamic+import Control.Applicative ((<|>))+import Control.Arrow ((&&&))+import Data.Char+import Data.Functor ((<&>))+import Data.List+  ( isPrefixOf+  , isSuffixOf+  , nub+  )+import Data.List.Extra (dropEnd)+import Data.Maybe (catMaybes)+import Foreign.Ptr+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Vulkan.Core10 (Device (..), Instance (..))+import Vulkan.Dynamic --- | Create an expression which checks the function pointers for all the Vulkan--- commands depended upon by the specified list of function names.------ It returns a list of function names corresponding to those functions with--- null pointers.------ Your program can use this function to fail early if a command couldn't be--- loaded for some reason (missing extension or layer for example).------ One can create a function called @checkCommands@ with the following:--- @--- [d| checkCommands = $(checkCommandsExp ['withInstance, 'cmdDraw, ...]) |]--- @------ It has the type @IsString a => Instance -> Device -> [a]@------ It looks basically like------ @--- \inst dev ->---   [ name---   | True <- [ nullFunPtr == pVkCreateDevice inst---             , nullFunPtr == pVkCreateFence dev---               ..---             ]---   | name <- [ "vkCreateDevice"---             , "vkCreateFence"---               ..---             ]---   ]--- @+{- | Create an expression which checks the function pointers for all the Vulkan+commands depended upon by the specified list of function names.++It returns a list of function names corresponding to those functions with+null pointers.++Your program can use this function to fail early if a command couldn't be+loaded for some reason (missing extension or layer for example).++One can create a function called @checkCommands@ with the following:+@+[d| checkCommands = $(checkCommandsExp ['withInstance, 'cmdDraw, ...]) |]+@++It has the type @IsString a => Instance -> Device -> [a]@++It looks basically like++@+\inst dev ->+  [ name+  | True <- [ nullFunPtr == pVkCreateDevice inst+            , nullFunPtr == pVkCreateFence dev+              ..+            ]+  | name <- [ "vkCreateDevice"+            , "vkCreateFence"+              ..+            ]+  ]+@+-} checkCommandsExp   :: [Name]-  -- ^ The names of functions from the @vulkan@ package. Unknown commands are-  -- ignored+  {- ^ The names of functions from the @vulkan@ package. Unknown commands are+  ignored+  -}   -> Q Exp checkCommandsExp requestedCommands = do-  instAccessors   <- accessorNames ''InstanceCmds+  instAccessors <- accessorNames ''InstanceCmds   deviceAccessors <- accessorNames ''DeviceCmds   let vkCommandNames =         nub . commandNames instAccessors deviceAccessors =<< requestedCommands-  inst   <- newName "inst"+  inst <- newName "inst"   device <- newName "device"   let isNull = \case         InstanceCmd i -> [|nullFunPtr == $(varE i) $(varE inst)|]-        DeviceCmd   i -> [|nullFunPtr == $(varE i) $(varE device)|]-  [| \(Instance _ $(varP inst)) (Device _ $(varP device)) ->+        DeviceCmd i -> [|nullFunPtr == $(varE i) $(varE device)|]+  [|+    \(Instance _ $(varP inst)) (Device _ $(varP device)) ->       [ name-      | (True, name) <- zip-          $(listE (isNull <$> vkCommandNames))-          $(lift (commandString <$> vkCommandNames))+      | (True, name) <-+          zip+            $(listE (isNull <$> vkCommandNames))+            $(lift (commandString <$> vkCommandNames))       ]     |] --- | Given instance and device accessors and a function, find the function--- pointer accessor names which it depends on------ >>> commandNames ['pVkCreateDevice, 'pVkDestroyDevice] ['pVkCreateFence] (mkName "withDevice")--- [InstanceCmd Vulkan.Dynamic.pVkCreateDevice,InstanceCmd Vulkan.Dynamic.pVkDestroyDevice]+{- | Given instance and device accessors and a function, find the function+pointer accessor names which it depends on++>>> commandNames ['pVkCreateDevice, 'pVkDestroyDevice] ['pVkCreateFence] (mkName "withDevice")+[InstanceCmd Vulkan.Dynamic.pVkCreateDevice,InstanceCmd Vulkan.Dynamic.pVkDestroyDevice]+-} commandNames :: [Name] -> [Name] -> Name -> [DeviceOrInstanceCommand] commandNames instAccessors deviceAccessors =-  let instNames   = (nameBase &&& id) <$> instAccessors-      deviceNames = (nameBase &&& id) <$> deviceAccessors-      findCommand :: String -> Maybe DeviceOrInstanceCommand-      findCommand command =-        (InstanceCmd <$> lookup command instNames)-          <|> (DeviceCmd <$> lookup command deviceNames)-  in  \n ->-        let candidates = commandCandidates (nameBase n)-        in  catMaybes $ findCommand <$> candidates+  let+    instNames = (nameBase &&& id) <$> instAccessors+    deviceNames = (nameBase &&& id) <$> deviceAccessors+    findCommand :: String -> Maybe DeviceOrInstanceCommand+    findCommand command =+      (InstanceCmd <$> lookup command instNames)+        <|> (DeviceCmd <$> lookup command deviceNames)+  in+    \n ->+      let candidates = commandCandidates (nameBase n)+      in catMaybes $ findCommand <$> candidates  data DeviceOrInstanceCommand   = DeviceCmd Name   | InstanceCmd Name   deriving (Eq, Show) --- | Get the C name of a function------ >>> commandString (DeviceCmd (mkName "pVkCreateInstance"))--- "vkCreateInstance"+{- | Get the C name of a function++>>> commandString (DeviceCmd (mkName "pVkCreateInstance"))+"vkCreateInstance"+-} commandString :: DeviceOrInstanceCommand -> String-commandString = unPtrName . nameBase . \case-  InstanceCmd n -> n-  DeviceCmd   n -> n+commandString =+  unPtrName . nameBase . \case+    InstanceCmd n -> n+    DeviceCmd n -> n --- | A list of potential sets of vulkan commands this name depends on, not all--- of them will be valid names.------ >>> commandCandidates "withDevice"--- ["pVkAllocateDevice","pVkFreeDevice","pVkCreateDevice","pVkDestroyDevice"]------ >>> commandCandidates "waitSemaphoresSafe"--- ["pVkWaitSemaphores"]------ >>> commandCandidates "useCmdBuffer"--- ["pVkBeginCmdBuffer","pVkEndCmdBuffer"]------ >>> commandCandidates "withSemaphore"--- ["pVkAllocateSemaphore","pVkFreeSemaphore","pVkCreateSemaphore","pVkDestroySemaphore"]+{- | A list of potential sets of vulkan commands this name depends on, not all+of them will be valid names.++>>> commandCandidates "withDevice"+["pVkAllocateDevice","pVkFreeDevice","pVkCreateDevice","pVkDestroyDevice"]++>>> commandCandidates "waitSemaphoresSafe"+["pVkWaitSemaphores"]++>>> commandCandidates "useCmdBuffer"+["pVkBeginCmdBuffer","pVkEndCmdBuffer"]++>>> commandCandidates "withSemaphore"+["pVkAllocateSemaphore","pVkFreeSemaphore","pVkCreateSemaphore","pVkDestroySemaphore"]+-} commandCandidates :: String -> [String]-commandCandidates n = if-  | "Safe" `isSuffixOf` n-  -> commandCandidates (dropEnd 4 n)-  | Just u <- stripPrefix "with"-  -> (<> u) <$> ["pVkAllocate", "pVkFree", "pVkCreate", "pVkDestroy"]-  | Just u <- stripPrefix "withMapped"-  -> (<> u) <$> ["pVkMap", "pVkUnmap"]-  | Just u <- stripPrefix "use"-  -> (<> u) <$> ["pVkBegin", "pVkEnd"]-  | Just u <- stripPrefix "cmdUse"-  -> (<> u) <$> ["pVkCmdBegin", "pVkCmdEnd"]-  | otherwise-  -> ["pVk" <> upperCaseFirst n]- where-  stripPrefix p = if p `isPrefixOf` n-    then Just (upperCaseFirst (drop (length p) n))-    else Nothing+commandCandidates n =+  if+    | "Safe" `isSuffixOf` n ->+        commandCandidates (dropEnd 4 n)+    | Just u <- stripPrefix "with" ->+        (<> u) <$> ["pVkAllocate", "pVkFree", "pVkCreate", "pVkDestroy"]+    | Just u <- stripPrefix "withMapped" ->+        (<> u) <$> ["pVkMap", "pVkUnmap"]+    | Just u <- stripPrefix "use" ->+        (<> u) <$> ["pVkBegin", "pVkEnd"]+    | Just u <- stripPrefix "cmdUse" ->+        (<> u) <$> ["pVkCmdBegin", "pVkCmdEnd"]+    | otherwise ->+        ["pVk" <> upperCaseFirst n]+  where+    stripPrefix p =+      if p `isPrefixOf` n+        then Just (upperCaseFirst (drop (length p) n))+        else Nothing --- | Get the record accessors of a type------ >>> $(lift . fmap show =<< accessorNames ''Device)--- ["Vulkan.Core10.Handles.deviceHandle","Vulkan.Core10.Handles.deviceCmds"]+{- | Get the record accessors of a type++>>> $(lift . fmap show =<< accessorNames ''Device)+["Vulkan.Core10.Handles.deviceHandle","Vulkan.Core10.Handles.deviceCmds"]+-} accessorNames :: Name -> Q [Name]-accessorNames record = reify record <&> \case-  TyConI (DataD _ _ _ _ [con] _)-    | RecC _ vars <- con       -> firstOfThree <$> vars-    | RecGadtC _ vars _ <- con -> firstOfThree <$> vars-  _ -> fail "Name wasn't a TyConI"-  where firstOfThree (a, _, _) = a+accessorNames record =+  reify record <&> \case+    TyConI (DataD _ _ _ _ [con] _)+      | RecC _ vars <- con -> firstOfThree <$> vars+      | RecGadtC _ vars _ <- con -> firstOfThree <$> vars+    _ -> fail "Name wasn't a TyConI"+  where+    firstOfThree (a, _, _) = a  unPtrName :: String -> String unPtrName = \case   'p' : 'V' : xs -> 'v' : xs-  s              -> s+  s -> s  upperCaseFirst :: String -> String upperCaseFirst = \case-  x:xs -> toUpper x : xs+  x : xs -> toUpper x : xs   [] -> []

@@ -4,25 +4,29 @@   , nameObject   ) where -import           Control.Monad.IO.Class-import           Data.ByteString+import Control.Monad.IO.Class+import Data.ByteString -import           Vulkan.Core10-import           Vulkan.Extensions.VK_EXT_debug_utils+import Vulkan.Core10+import Vulkan.Extensions.VK_EXT_debug_utils --- | A debug callback which prints the message prefixed with "Validation: " to--- stderr.+{- | A debug callback which prints the message prefixed with "Validation: " to+stderr.+-} foreign import ccall unsafe "DebugCallback.c &debugCallback"   debugCallbackPtr :: PFN_vkDebugUtilsMessengerCallbackEXT --- | A debug callback the same as 'debugCallbackPtr' except it will call--- @abort@ when @VK_DEBUG_UTILS_MESSAGE_SEVERITY_ERROR_BIT_EXT@ is set.+{- | A debug callback the same as 'debugCallbackPtr' except it will call+@abort@ when @VK_DEBUG_UTILS_MESSAGE_SEVERITY_ERROR_BIT_EXT@ is set.+-} foreign import ccall unsafe "DebugCallback.c &debugCallbackFatal"   debugCallbackFatalPtr :: PFN_vkDebugUtilsMessengerCallbackEXT --- | Assign a name to a handle using 'setDebugUtilsObjectNameEXT', note that--- the @VK_EXT_debug_utils@ extension must be enabled.+{- | Assign a name to a handle using 'setDebugUtilsObjectNameEXT', note that+the @VK_EXT_debug_utils@ extension must be enabled.+-} nameObject :: (HasObjectType a, MonadIO m) => Device -> a -> ByteString -> m ()-nameObject device object name = setDebugUtilsObjectNameEXT-  device-  (uncurry DebugUtilsObjectNameInfoEXT (objectTypeAndHandle object) (Just name))+nameObject device object name =+  setDebugUtilsObjectNameEXT+    device+    (uncurry DebugUtilsObjectNameInfoEXT (objectTypeAndHandle object) (Just name))

@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedLists #-}++{-| Single-resource descriptor writes for 'Vk.updateDescriptorSets'.+'bufferWrite' covers the whole-buffer case (a uniform or storage buffer+bound in its entirety); 'imageWrite' is its samplerless image sibling (a+storage image in @GENERAL@ layout, a sampled image in+@SHADER_READ_ONLY_OPTIMAL@, …); 'combinedImageSamplerWrite' binds an image+together with a sampler. Bindings needing partial buffer ranges or+descriptor arrays are out of scope — assemble those 'Vk.WriteDescriptorSet's+directly.+-}+module Vulkan.Utils.Descriptors+  ( bufferWrite+  , imageWrite+  , combinedImageSamplerWrite+  ) where++import Data.Word (Word32)+import Vulkan.CStruct.Extends (SomeStruct (..))+import qualified Vulkan.Core10 as Vk+import Vulkan.Zero (zero)++bufferWrite+  :: Vk.DescriptorSet+  -> Word32+  -- ^ Binding.+  -> Vk.DescriptorType+  -- ^ 'Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER', 'Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER', …+  -> Vk.Buffer+  -> SomeStruct Vk.WriteDescriptorSet+bufferWrite set binding descriptorType buffer =+  SomeStruct+    zero+      { Vk.dstSet = set+      , Vk.dstBinding = binding+      , Vk.descriptorType = descriptorType+      , Vk.descriptorCount = 1+      , Vk.bufferInfo = [Vk.DescriptorBufferInfo buffer 0 Vk.WHOLE_SIZE]+      }++imageWrite+  :: Vk.DescriptorSet+  -> Word32+  -- ^ Binding.+  -> Vk.DescriptorType+  -- ^ 'Vk.DESCRIPTOR_TYPE_STORAGE_IMAGE', 'Vk.DESCRIPTOR_TYPE_SAMPLED_IMAGE', …+  -> Vk.ImageLayout+  -- ^ The layout the image will be in when the set is bound.+  -> Vk.ImageView+  -> SomeStruct Vk.WriteDescriptorSet+imageWrite set binding descriptorType layout view =+  SomeStruct+    zero+      { Vk.dstSet = set+      , Vk.dstBinding = binding+      , Vk.descriptorType = descriptorType+      , Vk.descriptorCount = 1+      , Vk.imageInfo = [Vk.DescriptorImageInfo Vk.NULL_HANDLE view layout]+      }++-- | A combined image+sampler descriptor write ('Vk.DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER').+combinedImageSamplerWrite+  :: Vk.DescriptorSet+  -> Word32+  -- ^ Binding.+  -> Vk.Sampler+  -> Vk.ImageView+  -> Vk.ImageLayout+  -- ^ The layout the image will be in when the set is bound.+  -> SomeStruct Vk.WriteDescriptorSet+combinedImageSamplerWrite set binding sampler view layout =+  SomeStruct+    zero+      { Vk.dstSet = set+      , Vk.dstBinding = binding+      , Vk.descriptorType = Vk.DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER+      , Vk.descriptorCount = 1+      , Vk.imageInfo = [Vk.DescriptorImageInfo sampler view layout]+      }

@@ -0,0 +1,230 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}++{-| The @VK_KHR_dynamic_rendering@ (Vulkan 1.3 core) drawing path: no+'Vk.RenderPass' and no framebuffers. The swapchain image's layout transitions+are handled by explicit pipeline barriers, and the rendering region is opened+with 'Vk.cmdUseRendering' against a 'Vk.RenderingInfo' pointing straight at an+image view. The pipeline carries a @PipelineRenderingCreateInfo@ instead of a+render pass.++This is one of two self-contained alternatives — see "Vulkan.Utils.RenderPass"+for the classic path. Pick one and import only it. Callers must have enabled+the @dynamicRendering@ feature on the device.+-}+module Vulkan.Utils.DynamicRendering+  ( -- * Pipeline+    PipelineConfig (..)+  , allocatePipeline+  , allocatePipelineFromShaders++    -- * Device requirements+  , dynamicRenderingRequirements++    -- * Rendering+  , colorAttachmentRenderingInfo+  , renderingInfo+  , loadRenderingInfo+  ) where++import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Trans.Resource (MonadResource, ReleaseKey)+import Data.ByteString (ByteString)+import Data.Maybe (fromMaybe, isJust)+import Data.Vector (Vector)+import qualified Data.Vector as V+import Vulkan.CStruct.Extends (SomeStruct (..), pattern (:&), pattern (::&))+import qualified Vulkan.Core10 as Vk+import qualified Vulkan.Core13 as Vk+import Vulkan.Core13.Promoted_From_VK_KHR_dynamic_rendering (PhysicalDeviceDynamicRenderingFeatures, PipelineRenderingCreateInfo (..))+import Vulkan.Requirement (DeviceRequirement)+import Vulkan.Utils.DynamicState (defaultDynamicStatesFor)+import Vulkan.Utils.Pipeline.Internal (basePipelineCreateInfo, buildColorPipeline, withCompiledStages)+import Vulkan.Utils.Pipeline.Specialization (Specialization)+import qualified Vulkan.Utils.Requirements.TH as U+import Vulkan.Zero (Zero (..))++{- | The device requirements for this path: the @VK_KHR_dynamic_rendering@+extension (core since Vulkan 1.3) and the @dynamicRendering@ feature it gates.+Use it directly as — or append it to — a consumer's device requirements (e.g.+@WindowedBoot@'s @wcDeviceReqs@) so callers need not spell out the feature.+-}+dynamicRenderingRequirements :: [DeviceRequirement]+dynamicRenderingRequirements =+  [U.reqs|+    VK_KHR_dynamic_rendering+    PhysicalDeviceDynamicRenderingFeatures.dynamicRendering+  |]++{- | Attachment + fixed-function knobs for a dynamic-rendering pipeline.++Construct with 'zero' and override what differs, e.g.+@zero { Dynamic.colorFormats = [fmt], Dynamic.depthFormat = Just d }@.+-}+data PipelineConfig = PipelineConfig+  { colorFormats :: [Vk.Format]+  -- ^ Colour attachment formats (@0@..@N@); @[]@ for a depth-only pipeline.+  , depthFormat :: Maybe Vk.Format+  , vertexInput :: Vk.PipelineVertexInputStateCreateInfo '[]+  -- ^ Vertex input (bindings + attributes); 'zero' for none.+  , dynamicStates :: Maybe (Vector Vk.DynamicState)+  {- ^ Dynamic states; 'Nothing' defaults layout-aware to+  'Vulkan.Utils.DynamicState.depthOnlyDynamicStates' (no colour) or+  'allDynamicStates'. Drive with 'Vulkan.Utils.DynamicState.applyDynamicStates'.+  -}+  , layout :: Maybe Vk.PipelineLayout+  {- ^ Pipeline layout for descriptor sets \/ push constants; 'Nothing' uses a+  transient empty layout (shaders take no resources). A supplied layout stays+  owned by the caller, who must keep it alive for the pipeline's lifetime.+  -}+  }++instance Zero PipelineConfig where+  zero =+    PipelineConfig+      { colorFormats = []+      , depthFormat = Nothing+      , vertexInput = zero+      , dynamicStates = Nothing+      , layout = Nothing+      }++{- | Build a graphics pipeline for the dynamic-rendering path: no render pass, the+attachment formats carried in a 'PipelineRenderingCreateInfo' on the pNext chain.+The attachment shape — 'colorFormats' and 'depthFormat' — selects the pipeline kind:++  * @[fmt]@ + 'Nothing' — a single-colour pipeline (as the classic path).+  * @[fmt]@ + @Just d@ — colour + depth (depth driven dynamically).+  * @[]@ + @Just d@ — depth-only (e.g. a shadow map / z-prepass).+  * @[f0, f1, …]@ — multiple colour attachments (MRT / G-buffer).++Stencil is out of scope: no @stencilAttachmentFormat@ is declared, matching+'renderingInfo', which never supplies a stencil attachment (declaring one+without supplying it is invalid at draw time). For stencil, build the+'PipelineRenderingCreateInfo' and 'Vk.RenderingInfo' by hand. The formats MUST+match the views passed to 'Vk.cmdUseRendering' at draw time (see 'renderingInfo').+Intended to be used qualified, e.g. @Dynamic.allocatePipeline@.+-}+allocatePipeline+  :: (MonadResource m, MonadFail m)+  => Vk.Device+  -> PipelineConfig+  -> Vector (SomeStruct Vk.PipelineShaderStageCreateInfo)+  -> m (ReleaseKey, Vk.Pipeline)+allocatePipeline dev PipelineConfig{..} stages =+  buildColorPipeline dev layout $ \resolvedLayout ->+    SomeStruct $+      basePipelineCreateInfo+        resolvedLayout+        Nothing+        (length colorFormats)+        (isJust depthFormat)+        vertexInput+        (fromMaybe (defaultDynamicStatesFor (not (null colorFormats))) dynamicStates)+        stages+        ::& renderingCreateInfo+          :& ()+  where+    renderingCreateInfo :: PipelineRenderingCreateInfo+    renderingCreateInfo =+      zero+        { colorAttachmentFormats = V.fromList colorFormats+        , depthAttachmentFormat = fromMaybe Vk.FORMAT_UNDEFINED depthFormat+        }++{- | 'allocatePipeline' from @(stage, SPIR-V)@ pairs: compile each into a shader+module, build the pipeline, then release the now-redundant module handles.+-}+allocatePipelineFromShaders+  :: (MonadResource m, MonadUnliftIO m, MonadFail m, Specialization spec)+  => Vk.Device+  -> PipelineConfig+  -> spec+  -- ^ Specialization shared by every stage (see "Vulkan.Utils.Pipeline.Specialization"); @()@ for none.+  -> [(Vk.ShaderStageFlagBits, ByteString)]+  -> m (ReleaseKey, Vk.Pipeline)+allocatePipelineFromShaders dev config spec shaders =+  withCompiledStages dev spec shaders $+    allocatePipeline dev config++{- | A 'Vk.RenderingInfo' targeting a single color attachment that is cleared+on load and stored on completion. The attachment is expected to already be in+@IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL@ (e.g. via+'Vulkan.Utils.Barrier.transitionColorAttachment'). The single-colour special+case of 'renderingInfo'.+-}+colorAttachmentRenderingInfo+  :: Vk.Rect2D+  -- ^ Render area (typically the full swapchain extent).+  -> Vk.ImageView+  -- ^ Target color attachment view.+  -> Vk.ClearColorValue+  -- ^ Clear color applied by the @LOAD_OP_CLEAR@.+  -> Vk.RenderingInfo '[]+colorAttachmentRenderingInfo renderArea imageView clearColor =+  renderingInfo renderArea [(imageView, clearColor)] Nothing++{- | A 'Vk.RenderingInfo' over any number of colour attachments plus an optional+depth attachment, each cleared on load and stored on completion. Colour+attachments are expected in @IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL@ and the depth+attachment in @IMAGE_LAYOUT_DEPTH_ATTACHMENT_OPTIMAL@ (e.g. via+'Vulkan.Utils.Barrier.transitionColorAttachment' /+'Vulkan.Utils.Barrier.transitionDepthAttachment'). The attachment shape MUST+match the pipeline ('allocatePipeline'). No stencil attachment is supplied,+matching 'allocatePipeline' never declaring one.+-}+renderingInfo+  :: Vk.Rect2D+  -- ^ Render area (typically the full swapchain extent).+  -> Vector (Vk.ImageView, Vk.ClearColorValue)+  -- ^ Colour attachment views with the clear colour applied by @LOAD_OP_CLEAR@.+  -> Maybe (Vk.ImageView, Float)+  -- ^ Optional depth attachment view with the clear depth applied by @LOAD_OP_CLEAR@.+  -> Vk.RenderingInfo '[]+renderingInfo renderArea colorTargets depthTarget =+  attachmentsInfo+    renderArea+    (fmap (\(v, c) -> (v, Just (Vk.Color c))) colorTargets)+    (fmap (\(v, d) -> (v, Just (Vk.DepthStencil (Vk.ClearDepthStencilValue d 0)))) depthTarget)++{- | Continue over stored contents.++'renderingInfo' with @LOAD_OP_LOAD@ on every attachment — e.g. a second+geometry pass into the same targets. Layout expectations as in 'renderingInfo'.+-}+loadRenderingInfo+  :: Vk.Rect2D+  -- ^ Render area (typically the full swapchain extent).+  -> Vector Vk.ImageView+  -- ^ Colour attachment views, loaded.+  -> Maybe Vk.ImageView+  -- ^ Optional depth attachment view, loaded.+  -> Vk.RenderingInfo '[]+loadRenderingInfo renderArea colorTargets depthTarget =+  attachmentsInfo renderArea (fmap (\v -> (v, Nothing)) colorTargets) (fmap (\v -> (v, Nothing)) depthTarget)++-- | The shared assembly: an attachment clears when given a value, else loads.+attachmentsInfo+  :: Vk.Rect2D+  -> Vector (Vk.ImageView, Maybe Vk.ClearValue)+  -> Maybe (Vk.ImageView, Maybe Vk.ClearValue)+  -> Vk.RenderingInfo '[]+attachmentsInfo renderArea colorTargets depthTarget =+  zero+    { Vk.renderArea = renderArea+    , Vk.layerCount = 1+    , Vk.colorAttachments = fmap (attachment Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL) colorTargets+    , Vk.depthAttachment = fmap (attachment Vk.IMAGE_LAYOUT_DEPTH_ATTACHMENT_OPTIMAL) depthTarget+    }+  where+    attachment :: Vk.ImageLayout -> (Vk.ImageView, Maybe Vk.ClearValue) -> SomeStruct Vk.RenderingAttachmentInfo+    attachment layout (imageView, clear) =+      SomeStruct+        zero+          { Vk.imageView = imageView+          , Vk.imageLayout = layout+          , Vk.loadOp = maybe Vk.ATTACHMENT_LOAD_OP_LOAD (const Vk.ATTACHMENT_LOAD_OP_CLEAR) clear+          , Vk.storeOp = Vk.ATTACHMENT_STORE_OP_STORE+          , -- Ignored by @LOAD_OP_LOAD@; any value satisfies the struct.+            Vk.clearValue = fromMaybe (Vk.Color (Vk.Float32 0 0 0 0)) clear+          }

@@ -0,0 +1,282 @@+{-# LANGUAGE OverloadedLists #-}++{-| The Vulkan-1.3-core "always-on" dynamic state: the set of pipeline state+that can be made dynamic without any vendor or experimental extension, so a+single pipeline object serves every combination instead of permuting into one+'Vk.Pipeline' per variation. See 'Vulkan.Utils.RenderPass.allocatePipeline'+and 'Vulkan.Utils.DynamicRendering.allocatePipeline'.++Because these states are declared dynamic, the matching @cmdSet*@ MUST be issued+before each draw (an unset dynamic state is undefined behaviour). The+'DynamicState' record carries the whole set with safe defaults; amend it with+the per-frame situation (the swapchain extent via 'dynamicStateFor') and emit+the lot in one go with 'applyDynamicStates' over 'allDynamicStates'.++Defaults mirror Vulkan's zero-initialized values, deviating only where a+non-zero is required for validity ('lineWidth' @= 1@) or to match the pipeline's+baked topology class ('topology' @= TRIANGLE_LIST@). They are feature-free+(no @wideLines@, no @depthBounds@) and valid with a colour-only attachment (all+depth/stencil tests disabled).+-}+module Vulkan.Utils.DynamicState+  ( -- * The dynamic-state record+    DynamicState (..)+  , defaultDynamicState+  , dynamicStateFor++    -- * Applying it+  , applyDynamicStates++    -- * The state set (pipeline @dynamicStates@ ⇆ apply, single source of truth)+  , allDynamicStates+  , depthOnlyDynamicStates+  , defaultDynamicStatesFor+  , minimalDynamicStates+  , noDynamicStates+  , preRasterizationStates+  , fragmentTestStates+  , fragmentOutputStates++    -- * Whole-extent viewport/scissor+  , fullViewport+  , fullScissor+  ) where++import Control.Monad.IO.Class (MonadIO)+import Data.Foldable (traverse_)+import Data.Vector (Vector)+import qualified Data.Vector as V+import Data.Word (Word32)+import qualified Vulkan.Core10 as Rect2D (Rect2D (..))+import qualified Vulkan.Core10 as Viewport (Viewport (..))+import qualified Vulkan.Core10 as Vk+import qualified Vulkan.Core13 as Vk+import Vulkan.Zero (zero)++-- | A viewport covering the whole extent, with depth range @0@ to @1@.+fullViewport :: Vk.Extent2D -> Vk.Viewport+fullViewport (Vk.Extent2D w h) =+  zero+    { Viewport.width = realToFrac w+    , Viewport.height = realToFrac h+    , Viewport.maxDepth = 1+    }++-- | A scissor rectangle covering the whole extent (offset at the origin).+fullScissor :: Vk.Extent2D -> Vk.Rect2D+fullScissor extent = zero{Rect2D.extent = extent}++----------------------------------------------------------------+-- The record+----------------------------------------------------------------++{- | Every Vulkan-1.3-core always-on dynamic state, as plain values. Field types+match the @cmdSet*@ argument shapes. The stencil ops apply to+@STENCIL_FACE_FRONT_AND_BACK@.+-}+data DynamicState = DynamicState+  { -- Pre-rasterization+    viewports :: Vector Vk.Viewport+  , scissors :: Vector Vk.Rect2D+  , topology :: Vk.PrimitiveTopology+  , primitiveRestart :: Bool+  , cullMode :: Vk.CullModeFlags+  , frontFace :: Vk.FrontFace+  , rasterizerDiscard :: Bool+  , lineWidth :: Float+  -- ^ @/= 1@ requires the @wideLines@ feature.+  , depthBiasEnable :: Bool+  , depthBias :: (Float, Float, Float)+  -- ^ @(constantFactor, clamp, slopeFactor)@.+  , -- Fragment-shader depth/stencil tests+    depthTest :: Bool+  , depthWrite :: Bool+  , depthCompareOp :: Vk.CompareOp+  , depthBoundsTest :: Bool+  -- ^ Requires the @depthBounds@ feature.+  , depthBounds :: (Float, Float)+  -- ^ @(min, max)@.+  , stencilTest :: Bool+  , stencilFailOp :: Vk.StencilOp+  , stencilPassOp :: Vk.StencilOp+  , stencilDepthFailOp :: Vk.StencilOp+  , stencilCompareOp :: Vk.CompareOp+  , stencilCompareMask :: Word32+  , stencilWriteMask :: Word32+  , stencilReference :: Word32+  , -- Fragment-output+    blendConstants :: (Float, Float, Float, Float)+  }++{- | Safe, feature-free defaults (see module header). 'viewports' and 'scissors'+are empty — supply them with 'dynamicStateFor' or by record update before+applying.+-}+defaultDynamicState :: DynamicState+defaultDynamicState =+  DynamicState+    { viewports = V.empty+    , scissors = V.empty+    , topology = Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST+    , primitiveRestart = False+    , cullMode = Vk.CULL_MODE_NONE+    , frontFace = Vk.FRONT_FACE_COUNTER_CLOCKWISE+    , rasterizerDiscard = False+    , lineWidth = 1+    , depthBiasEnable = False+    , depthBias = (0, 0, 0)+    , depthTest = False+    , depthWrite = False+    , depthCompareOp = Vk.COMPARE_OP_NEVER+    , depthBoundsTest = False+    , depthBounds = (0, 0)+    , stencilTest = False+    , stencilFailOp = Vk.STENCIL_OP_KEEP+    , stencilPassOp = Vk.STENCIL_OP_KEEP+    , stencilDepthFailOp = Vk.STENCIL_OP_KEEP+    , stencilCompareOp = Vk.COMPARE_OP_NEVER+    , stencilCompareMask = 0+    , stencilWriteMask = 0+    , stencilReference = 0+    , blendConstants = (0, 0, 0, 0)+    }++{- | 'defaultDynamicState' with the whole-extent viewport and scissor filled in.+The common entry point; amend further by record update, e.g.++@+'applyDynamicStates' 'allDynamicStates' cb ('dynamicStateFor' ext){ 'cullMode' = Vk.CULL_MODE_BACK_BIT }+@+-}+dynamicStateFor :: Vk.Extent2D -> DynamicState+dynamicStateFor ext =+  defaultDynamicState+    { viewports = V.singleton (fullViewport ext)+    , scissors = V.singleton (fullScissor ext)+    }++----------------------------------------------------------------+-- The state set (single source of truth)+----------------------------------------------------------------++preRasterizationStates :: Vector Vk.DynamicState+preRasterizationStates =+  [ Vk.DYNAMIC_STATE_VIEWPORT_WITH_COUNT+  , Vk.DYNAMIC_STATE_SCISSOR_WITH_COUNT+  , Vk.DYNAMIC_STATE_PRIMITIVE_TOPOLOGY+  , Vk.DYNAMIC_STATE_PRIMITIVE_RESTART_ENABLE+  , Vk.DYNAMIC_STATE_CULL_MODE+  , Vk.DYNAMIC_STATE_FRONT_FACE+  , Vk.DYNAMIC_STATE_RASTERIZER_DISCARD_ENABLE+  , Vk.DYNAMIC_STATE_LINE_WIDTH+  , Vk.DYNAMIC_STATE_DEPTH_BIAS_ENABLE+  , Vk.DYNAMIC_STATE_DEPTH_BIAS+  ]++-- | Fragment-shader depth/stencil dynamic states.+fragmentTestStates :: Vector Vk.DynamicState+fragmentTestStates =+  [ Vk.DYNAMIC_STATE_DEPTH_TEST_ENABLE+  , Vk.DYNAMIC_STATE_DEPTH_WRITE_ENABLE+  , Vk.DYNAMIC_STATE_DEPTH_COMPARE_OP+  , Vk.DYNAMIC_STATE_DEPTH_BOUNDS_TEST_ENABLE+  , Vk.DYNAMIC_STATE_DEPTH_BOUNDS+  , Vk.DYNAMIC_STATE_STENCIL_TEST_ENABLE+  , Vk.DYNAMIC_STATE_STENCIL_OP+  , Vk.DYNAMIC_STATE_STENCIL_COMPARE_MASK+  , Vk.DYNAMIC_STATE_STENCIL_WRITE_MASK+  , Vk.DYNAMIC_STATE_STENCIL_REFERENCE+  ]++fragmentOutputStates :: Vector Vk.DynamicState+fragmentOutputStates = [Vk.DYNAMIC_STATE_BLEND_CONSTANTS]++{- | The whole always-on set: pass this (or 'Nothing', which resolves to it) to a+full-dynamic pipeline builder, and feed the same set to 'applyDynamicStates' so+the pipeline's @dynamicStates@ and the per-frame applies stay in lockstep.+-}+allDynamicStates :: Vector Vk.DynamicState+allDynamicStates =+  preRasterizationStates <> fragmentTestStates <> fragmentOutputStates++{- | The set for a depth-only pipeline (no colour attachment): everything in+'allDynamicStates' except 'fragmentOutputStates' ('Vk.DYNAMIC_STATE_BLEND_CONSTANTS'),+which has no colour attachment to act on. Pair it with a depth-only pipeline and+feed the same set to 'applyDynamicStates'.+-}+depthOnlyDynamicStates :: Vector Vk.DynamicState+depthOnlyDynamicStates = preRasterizationStates <> fragmentTestStates++{- | The default dynamic-state set for an attachment shape: 'allDynamicStates' when+there is at least one colour attachment, otherwise 'depthOnlyDynamicStates'. The+default a pipeline builder resolves @Nothing@ to.+-}+defaultDynamicStatesFor+  :: Bool+  -- ^ Whether the pipeline has any colour attachment.+  -> Vector Vk.DynamicState+defaultDynamicStatesFor hasColor+  | hasColor = allDynamicStates+  | otherwise = depthOnlyDynamicStates++{- | Just the (fixed-count) viewport and scissor. For pipelines that want only+those dynamic and set them with 'Vk.cmdSetViewport' / 'Vk.cmdSetScissor' (not the+with-count variants 'applyDynamicStates' issues for 'allDynamicStates').+-}+minimalDynamicStates :: Vector Vk.DynamicState+minimalDynamicStates =+  [Vk.DYNAMIC_STATE_VIEWPORT, Vk.DYNAMIC_STATE_SCISSOR]++{- | Declare /nothing/ dynamic: every state is baked into the pipeline, so no+@cmdSet*@ need be issued (skip 'applyDynamicStates' entirely). Pass it where a+builder takes @Maybe (Vector Vk.DynamicState)@.++The pipeline must then carry a complete static state — crucially a baked viewport+and scissor — so this suits a builder that bakes those (typically a fixed-size+offscreen target). The colour-pipeline builders here instead leave viewport and+scissor dynamic, so they pair with 'Nothing' / 'allDynamicStates', not this.+-}+noDynamicStates :: Maybe (Vector Vk.DynamicState)+noDynamicStates = Just V.empty++----------------------------------------------------------------+-- Applying+----------------------------------------------------------------++{- | Issue the @cmdSet*@ for exactly the given states, pulling values from the+record. Use the same set passed to the pipeline builder for exact lockstep.+States not modelled by 'DynamicState' are skipped (the caller must set those+themselves).+-}+applyDynamicStates+  :: (MonadIO m) => Vector Vk.DynamicState -> Vk.CommandBuffer -> DynamicState -> m ()+applyDynamicStates states cb s = traverse_ go states+  where+    DynamicState{..} = s+    bothFaces = Vk.STENCIL_FACE_FRONT_AND_BACK+    (biasConstant, biasClamp, biasSlope) = depthBias+    (minBound', maxBound') = depthBounds+    go = \case+      Vk.DYNAMIC_STATE_VIEWPORT_WITH_COUNT -> Vk.cmdSetViewportWithCount cb viewports+      Vk.DYNAMIC_STATE_SCISSOR_WITH_COUNT -> Vk.cmdSetScissorWithCount cb scissors+      Vk.DYNAMIC_STATE_PRIMITIVE_TOPOLOGY -> Vk.cmdSetPrimitiveTopology cb topology+      Vk.DYNAMIC_STATE_PRIMITIVE_RESTART_ENABLE -> Vk.cmdSetPrimitiveRestartEnable cb primitiveRestart+      Vk.DYNAMIC_STATE_CULL_MODE -> Vk.cmdSetCullMode cb cullMode+      Vk.DYNAMIC_STATE_FRONT_FACE -> Vk.cmdSetFrontFace cb frontFace+      Vk.DYNAMIC_STATE_RASTERIZER_DISCARD_ENABLE -> Vk.cmdSetRasterizerDiscardEnable cb rasterizerDiscard+      Vk.DYNAMIC_STATE_LINE_WIDTH -> Vk.cmdSetLineWidth cb lineWidth+      Vk.DYNAMIC_STATE_DEPTH_BIAS_ENABLE -> Vk.cmdSetDepthBiasEnable cb depthBiasEnable+      Vk.DYNAMIC_STATE_DEPTH_BIAS -> Vk.cmdSetDepthBias cb biasConstant biasClamp biasSlope+      Vk.DYNAMIC_STATE_DEPTH_TEST_ENABLE -> Vk.cmdSetDepthTestEnable cb depthTest+      Vk.DYNAMIC_STATE_DEPTH_WRITE_ENABLE -> Vk.cmdSetDepthWriteEnable cb depthWrite+      Vk.DYNAMIC_STATE_DEPTH_COMPARE_OP -> Vk.cmdSetDepthCompareOp cb depthCompareOp+      Vk.DYNAMIC_STATE_DEPTH_BOUNDS_TEST_ENABLE -> Vk.cmdSetDepthBoundsTestEnable cb depthBoundsTest+      Vk.DYNAMIC_STATE_DEPTH_BOUNDS -> Vk.cmdSetDepthBounds cb minBound' maxBound'+      Vk.DYNAMIC_STATE_STENCIL_TEST_ENABLE -> Vk.cmdSetStencilTestEnable cb stencilTest+      Vk.DYNAMIC_STATE_STENCIL_OP ->+        Vk.cmdSetStencilOp cb bothFaces stencilFailOp stencilPassOp stencilDepthFailOp stencilCompareOp+      Vk.DYNAMIC_STATE_STENCIL_COMPARE_MASK -> Vk.cmdSetStencilCompareMask cb bothFaces stencilCompareMask+      Vk.DYNAMIC_STATE_STENCIL_WRITE_MASK -> Vk.cmdSetStencilWriteMask cb bothFaces stencilWriteMask+      Vk.DYNAMIC_STATE_STENCIL_REFERENCE -> Vk.cmdSetStencilReference cb bothFaces stencilReference+      Vk.DYNAMIC_STATE_BLEND_CONSTANTS -> Vk.cmdSetBlendConstants cb blendConstants+      _ -> pure ()

@@ -0,0 +1,502 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++{-| Per-frame state and the recycling-Frame loop. Each frame owns a binary+image-available semaphore and a command pool — those are 'RecycledResources'+that get handed back to a channel in 'VulkanContext' once the frame's GPU work+has completed. (The present-wait/render-finished semaphore is per swapchain+image, on the 'Vulkan.Utils.Swapchain.Swapchain', because it is only safe to+reuse once its image is re-acquired — not when the frame's render finishes.)++The host-side timeline semaphore (@fHostTimeline@) lives across frames:+each frame increments it to its own 'fIndex' on the GPU, and the host+waits on it inside the spawned wait-and-recycle thread.++This module requires Vulkan 1.2-level timeline-semaphore support. See+'frameInstanceRequirements' / 'frameDeviceRequirements' for the+extension/feature requirements to merge into your boot sequence.+-}+module Vulkan.Utils.Frame+  ( Frame (..)+  , initialFrame+  , advanceFrame+  , runFrame+  , recordCommands+  , queueSubmitFrame+  , acquireFrameImage+  , presentFrameImage+  , drainFrames+  , allocateTimelineSemaphore+  , allocateCommandPool+  , allocatePrimary+  , SubmitExtras (..)+  , noExtras+  , frameSubmitExtras+  , waitTwice+  , frameInstanceRequirements+  , frameDeviceRequirements+  , syncDeviceRequirements+  , InitRecycledResources+  ) where++import Control.Concurrent (forkIO)+import Control.Exception (finally, mask_, throwIO)+import Control.Monad+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Resource+import Data.Foldable (for_, toList)+import Data.IORef+import Data.List (nub)+import qualified Data.Map.Strict as Map+import qualified Data.Vector as V+import Data.Word+import System.IO (hPutStrLn, stderr)+import Vulkan.CStruct.Extends (SomeStruct (..), pattern (:&), pattern (::&))+import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo (..))+import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo (..))+import qualified Vulkan.Core10 as Vk+import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore as Timeline+import Vulkan.Core13 (PhysicalDeviceSynchronization2Features)+import Vulkan.Core13.Enums.PipelineStageFlags2 (PipelineStageFlagBits2 (..), PipelineStageFlags2)+import Vulkan.Core13.Promoted_From_VK_KHR_synchronization2 (SubmitInfo2 (..), queueSubmit2)+import qualified Vulkan.Core13.Promoted_From_VK_KHR_synchronization2 as CommandBufferSubmitInfo (CommandBufferSubmitInfo (..))+import qualified Vulkan.Core13.Promoted_From_VK_KHR_synchronization2 as SemaphoreSubmitInfo (SemaphoreSubmitInfo (..))+import Vulkan.Exception (VulkanException (..))+import Vulkan.Extensions.VK_KHR_get_physical_device_properties2+import qualified Vulkan.Extensions.VK_KHR_swapchain as KHR+import Vulkan.Requirement (DeviceRequirement, InstanceRequirement (..))+import Vulkan.Utils.QueueAssignment (QueueFamilyIndex (..))+import Vulkan.Utils.Queues (Queues (..))+import Vulkan.Utils.RefCounted (resourceTRefCount)+import qualified Vulkan.Utils.Requirements.TH as U+import Vulkan.Utils.Swapchain (Swapchain (..), sRelease)+import Vulkan.Utils.VulkanContext (RecycledResources (..), VulkanContext (..))+import Vulkan.Zero (zero)++data Frame rr = Frame+  { fIndex :: Word64+  -- ^ Monotonic, used as the timeline-semaphore signal value for this frame.+  , fSwapchain :: Swapchain+  {- ^ The swapchain this frame targets. Held by reference so a frame+  in flight keeps its swapchain alive across recreation.+  -}+  , fRecycled :: RecycledResources rr+  {- ^ This frame's image-available semaphore + command pool — borrowed from+  the recycle channel; returned at retire time.+  -}+  , fHostTimeline :: Vk.Semaphore+  {- ^ Long-lived timeline semaphore. Each frame increments it to 'fIndex'+  on the GPU; the host wait thread blocks on this.+  -}+  , fGPUWork :: IORef [(Vk.Semaphore, Word64)]+  {- ^ (Timeline semaphore, value) pairs the host wait thread will block on.+  Appended to by 'queueSubmitFrame'.+  -}+  , fDeferredWork :: IORef [IO ()]+  {- ^ Host work the recycle thread runs before the 'fGPUWork' wait — e.g.+  a frame graph's host-pass tail, which blocks on its own timeline values+  and signals values listed in 'fGPUWork'. Runs in registration order, off+  the render thread.+  -}+  , fResources :: (ReleaseKey, InternalState)+  {- ^ ResourceT scope for frame-local allocations; closed when the frame+  retires. The 'ReleaseKey' lives in the outer ResourceT so the+  scope is freed cleanly even on early shutdown.+  -}+  }++{- | Instance-level requirements for the recycling 'Frame' machinery. Merge+with your application's other 'InstanceRequirement's at instance creation.++Required because checking @PhysicalDeviceTimelineSemaphoreFeatures@ at+physical-device pick time goes through @VkPhysicalDeviceFeatures2@, which+needs either Vulkan 1.1+ or this extension.+-}+frameInstanceRequirements :: [InstanceRequirement]+frameInstanceRequirements =+  [ RequireInstanceExtension+      Nothing+      KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME+      minBound+  ]++{- | Timeline semaphores and synchronization2.++The two primitives everything here synchronizes with: 'queueSubmitFrame' and+'allocateTimelineSemaphore', and any submit built by hand. Both are core in+1.3 and universally available in practice, so a headless boot wants them too+— 'frameDeviceRequirements' is these plus a swapchain.+-}+syncDeviceRequirements :: [DeviceRequirement]+syncDeviceRequirements =+  [U.reqs|+    VK_KHR_timeline_semaphore+    PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore+    VK_KHR_synchronization2+    PhysicalDeviceSynchronization2Features.synchronization2+  |]++{- | The device-level requirements needed by 'runFrame' / 'queueSubmitFrame' /+'allocateTimelineSemaphore'. Merge into your other 'DeviceRequirement's when+calling 'Vulkan.Utils.Initialization.allocateDeviceFromRequirements'.+-}+frameDeviceRequirements :: [DeviceRequirement]+frameDeviceRequirements = [U.reqs|VK_KHR_swapchain|] <> syncDeviceRequirements++----------------------------------------------------------------+-- Construction+----------------------------------------------------------------++type InitRecycledResources m rr = VulkanContext rr -> Int -> Queues Vk.CommandPool -> m rr++{- | Build the initial frame with one spare 'RecycledResources' seeded+into the recycle channel. That, plus the set attached to this frame,+caps max-in-flight at 2 (CPU recording + GPU executing the previous).+-}+initialFrame+  :: forall rr m+   . (MonadResource m)+  => VulkanContext rr+  -> Swapchain+  -> InitRecycledResources m rr+  -> m (Frame rr)+initialFrame vc fSwapchain mkRecycled = do+  fResources <- allocate createInternalState closeInternalState+  fRecycled <- mkRecycledResources vc $ mkRecycled vc 0+  spare <- mkRecycledResources vc $ mkRecycled vc 1+  liftIO (vcRecycleBin vc spare)+  (_, fHostTimeline) <- allocateTimelineSemaphore (vcDevice vc) 0+  fGPUWork <- liftIO $ newIORef mempty+  fDeferredWork <- liftIO $ newIORef mempty+  liftIO $ runInternalState (resourceTRefCount (sRelease fSwapchain)) (snd fResources)+  pure Frame{fIndex = 1, ..}++{- | Build the next frame, taking one set of recycled resources from the bin.+Caller passes the (possibly-recreated) 'Swapchain'.+-}+advanceFrame+  :: (MonadResource m)+  => VulkanContext rr+  -> Swapchain+  -- ^ Same as old, or freshly recreated+  -> Frame rr+  -- ^ The just-finished frame+  -> m (Frame rr)+advanceFrame vc sc f = do+  fResources <- allocate createInternalState closeInternalState+  fRecycled <-+    liftIO $+      vcRecycleNib vc >>= \case+        Left block -> block+        Right rr -> pure rr+  fGPUWork <- liftIO $ newIORef mempty+  fDeferredWork <- liftIO $ newIORef mempty+  liftIO $ runInternalState (resourceTRefCount (sRelease sc)) (snd fResources)+  pure+    Frame+      { fIndex = succ (fIndex f)+      , fSwapchain = sc+      , fRecycled+      , fHostTimeline = fHostTimeline f+      , fGPUWork+      , fDeferredWork+      , fResources+      }++----------------------------------------------------------------+-- Loop+----------------------------------------------------------------++{- | Run a per-frame action against this frame's per-frame ResourceT scope,+then asynchronously wait for the GPU work and recycle. The deferred host+work and the wait/recycle run in a forked thread so the next frame can+begin recording immediately.++Anything 'allocate'd inside @action@ is freed when the frame retires.+-}+runFrame :: VulkanContext rr -> Frame rr -> ResourceT IO a -> IO a+runFrame vc f action =+  runInternalState action (snd (fResources f))+    `finally` waitAndRecycle vc f++waitAndRecycle :: VulkanContext rr -> Frame rr -> IO ()+waitAndRecycle vc f = do+  waits <- readIORef (fGPUWork f)+  deferred <- readIORef (fDeferredWork f)+  void . forkIO $ do+    -- The frame's host work first: it blocks on its own timeline values and+    -- signals values the wait below (and in-flight submits) depend on.+    sequence_ (reverse deferred)+    unless (null waits) $ do+      let waitInfo =+            zero+              { semaphores = V.fromList (fst <$> waits)+              , values = V.fromList (snd <$> waits)+              }+      r <- waitTwice (vcDevice vc) waitInfo oneSecond+      case r of+        Vk.TIMEOUT -> hPutStrLn stderr "Frame wait timed out (1s) — GPU may be hung"+        _ -> pure ()+    -- Pool reuse: reset each distinct pool, dropping all recorded buffers.+    -- No RELEASE_RESOURCES: the point of recycling a pool is to keep its+    -- arena warm for the next frame's buffers.+    for_ (nub (toList (rrCommandPools (fRecycled f)))) $ \pool ->+      Vk.resetCommandPool (vcDevice vc) pool zero+    -- Free the per-frame ResourceT scope. Must precede the channel deposit so+    -- the deposit signals "all per-frame cleanup done" — otherwise the next+    -- frame could pick up the recycled pool while this frame's cleanup is+    -- still calling vkFreeCommandBuffers on it.+    release (fst (fResources f))+    -- Hand the borrowed resources back to whoever's waiting on them.+    vcRecycleBin vc (fRecycled f)+  where+    oneSecond :: Word64+    oneSecond = 1000000000++{- | Allocate a primary command buffer from this frame's recycled command pool,+begin it with 'Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT', run the caller's+recording action, end recording, and return the buffer ready to hand to+'queueSubmitFrame'.++For a non-standard begin shape (secondary level, different usage flags,+inheritance info) call 'Vk.withCommandBuffers' and 'Vk.useCommandBuffer'+directly.+-}+recordCommands+  :: (MonadResource m, MonadFail m)+  => VulkanContext rr+  -> Frame rr+  -> (Vk.CommandBuffer -> m ())+  -> m Vk.CommandBuffer+{-# INLINE recordCommands #-}+recordCommands vc Frame{fRecycled} record = do+  (_, [cb]) <-+    Vk.withCommandBuffers+      (vcDevice vc)+      zero+        { Vk.commandPool = qGraphics (rrCommandPools fRecycled)+        , Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY+        , Vk.commandBufferCount = 1+        }+      allocate+  Vk.useCommandBuffer cb zero{CommandBufferBeginInfo.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT} $+    record cb+  pure cb++{- | Submit a per-frame command buffer batch and record the timeline-wait+bookkeeping the host wait thread will block on.++Builds the standard frame submit from context/frame: waits on the frame's+image-available semaphore at @COLOR_ATTACHMENT_OUTPUT@, signals the+swapchain's per-image render-finished semaphore (at @imageIndex@) plus its+timeline value, and submits on the graphics queue.++For a non-standard submit shape (multiple submit infos, different wait+stage, extra signals), call 'queueSubmit2' directly and append+@(fHostTimeline f, fIndex f)@ to @fGPUWork f@.+-}+queueSubmitFrame+  :: (MonadIO m)+  => VulkanContext rr+  -> Frame rr+  -> Word32+  {- ^ Acquired image index (from 'acquireFrameImage'); selects the per-image+  present-wait semaphore to signal.+  -}+  -> V.Vector Vk.CommandBuffer+  -> m ()+{-# INLINE queueSubmitFrame #-}+queueSubmitFrame vc Frame{..} imageIndex cbs = liftIO . mask_ $ do+  queueSubmit2 gQ [SomeStruct submitInfo] Vk.NULL_HANDLE+  atomicModifyIORef' fGPUWork $ \jobs -> ((fHostTimeline, fIndex) : jobs, ())+  where+    gQ = snd (qGraphics (vcQueues vc))+    renderFinished = sRenderFinished fSwapchain V.! fromIntegral imageIndex+    -- The two WSI semaphores are binary (mandated: acquire signals one,+    -- present waits on one) and ignore their values; the timeline is ours.+    submitInfo =+      zero+        { waitSemaphoreInfos =+            [zero{SemaphoreSubmitInfo.semaphore = rrImageAvailable, SemaphoreSubmitInfo.stageMask = PIPELINE_STAGE_2_TOP_OF_PIPE_BIT}]+        , commandBufferInfos =+            fmap (\cb -> SomeStruct zero{CommandBufferSubmitInfo.commandBuffer = Vk.commandBufferHandle cb}) cbs+        , signalSemaphoreInfos =+            [ zero{SemaphoreSubmitInfo.semaphore = renderFinished, SemaphoreSubmitInfo.stageMask = PIPELINE_STAGE_2_ALL_COMMANDS_BIT}+            , zero{SemaphoreSubmitInfo.semaphore = fHostTimeline, SemaphoreSubmitInfo.stageMask = PIPELINE_STAGE_2_ALL_COMMANDS_BIT, SemaphoreSubmitInfo.value = fIndex}+            ]+        }+        :: SubmitInfo2 '[]+    RecycledResources{rrImageAvailable} = fRecycled++{- | Acquire the next swapchain image for this frame, signalling the frame's+image-available semaphore on completion.++The acquire result is returned alongside the image index so the caller can+thread it into 'presentFrameImage', which honours 'SUBOPTIMAL_KHR' from+either side by raising 'ERROR_OUT_OF_DATE_KHR' to drive a swapchain+recreation. Timeouts and unexpected results are also translated to+'ERROR_OUT_OF_DATE_KHR' — the main loop's swapchain-recreation path is the+right place to recover.+-}+acquireFrameImage :: (MonadIO m) => VulkanContext rr -> Frame rr -> m (Vk.Result, Word32)+{-# INLINE acquireFrameImage #-}+acquireFrameImage vc Frame{..} =+  liftIO $+    acquire >>= \case+      r@(Vk.SUCCESS, _) -> pure r+      r@(Vk.SUBOPTIMAL_KHR, _) -> pure r+      _ -> throwIO (VulkanException Vk.ERROR_OUT_OF_DATE_KHR)+  where+    acquire =+      KHR.acquireNextImageKHRSafe+        (vcDevice vc)+        (sSwapchain fSwapchain)+        oneSecond+        (rrImageAvailable fRecycled)+        Vk.NULL_HANDLE++    oneSecond :: Word64+    oneSecond = 1000000000++{- | Present this frame's acquired image, waiting on the swapchain's per-image+render-finished semaphore (at @imageIndex@). Presents on the graphics queue+(@qGraphics . vcQueues@).++If either the prior acquire (passed in) or this present reports+'SUBOPTIMAL_KHR', raises 'ERROR_OUT_OF_DATE_KHR' so the main loop+recreates the swapchain.+-}+presentFrameImage :: (MonadIO m) => VulkanContext rr -> Frame rr -> Vk.Result -> Word32 -> m ()+{-# INLINE presentFrameImage #-}+presentFrameImage vc f acquireResult imageIndex = liftIO $ do+  presentResult <-+    KHR.queuePresentKHR+      gQ+      zero+        { KHR.waitSemaphores = [renderFinished]+        , KHR.swapchains = [sSwapchain (fSwapchain f)]+        , KHR.imageIndices = [imageIndex]+        }+  when (acquireResult == Vk.SUBOPTIMAL_KHR || presentResult == Vk.SUBOPTIMAL_KHR) $+    throwIO (VulkanException Vk.ERROR_OUT_OF_DATE_KHR)+  where+    renderFinished = sRenderFinished (fSwapchain f) V.! fromIntegral imageIndex+    gQ = snd (qGraphics (vcQueues vc))++{- | Shutdown drain: spawn the unrendered current frame's wait/recycle thread,+then block on the recycle channel until both this frame's and the previous+in-flight frame's deposits have arrived. After this returns, every forked+wait thread has run its per-frame cleanup, so the outer 'ResourceT' is safe+to tear down GPU resources.++Assumes max-in-flight is 2 (see 'initialFrame').+-}+drainFrames :: VulkanContext rr -> Frame rr -> IO ()+drainFrames vc f = do+  waitAndRecycle vc f+  let take1 = vcRecycleNib vc >>= either id pure+  _ <- take1+  _ <- take1+  pure ()++----------------------------------------------------------------+-- Small helpers+----------------------------------------------------------------++-- | Allocate a timeline semaphore initialised to the given value.+allocateTimelineSemaphore :: (MonadResource m) => Vk.Device -> Word64 -> m (ReleaseKey, Vk.Semaphore)+allocateTimelineSemaphore dev initial =+  Vk.withSemaphore+    dev+    (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_TIMELINE initial :& ())+    Nothing+    allocate++----------------------------------------------------------------+-- Internals+----------------------------------------------------------------++{- | Build one set of recycled resources: a binary image-available semaphore++ a command pool keyed to the graphics queue family. (The present-wait+semaphore is per swapchain image, on the 'Swapchain', not here.)+-}+mkRecycledResources+  :: (MonadResource m)+  => VulkanContext rr+  -> (Queues Vk.CommandPool -> m rr)+  -> m (RecycledResources rr)+mkRecycledResources vc mkData = do+  (_, rrImageAvailable) <-+    Vk.withSemaphore+      dev+      (zero ::& SemaphoreTypeCreateInfo SEMAPHORE_TYPE_BINARY 0 :& ())+      Nothing+      allocate+  -- One pool per distinct family, shared by every role on it.+  byFamily <-+    fmap Map.fromList $+      traverse (\fam -> fmap (fam,) (allocateCommandPool dev fam)) (nub (toList families))+  let rrCommandPools = fmap (byFamily Map.!) families+  rrData <- mkData rrCommandPools+  pure RecycledResources{..}+  where+    dev = vcDevice vc+    families = fmap (\(QueueFamilyIndex fam, _) -> fam) (vcQueues vc)++-- | Allocate a command pool for the family, released with the scope.+allocateCommandPool :: (MonadResource m) => Vk.Device -> Word32 -> m Vk.CommandPool+allocateCommandPool dev family = do+  (_, pool) <- Vk.withCommandPool dev zero{CommandPoolCreateInfo.queueFamilyIndex = family} Nothing allocate+  pure pool++-- | Allocate a primary command buffer from the pool and begin it, one-time-submit.+allocatePrimary :: (MonadResource m) => Vk.Device -> Vk.CommandPool -> m Vk.CommandBuffer+allocatePrimary dev pool = do+  (_, cbs) <-+    Vk.withCommandBuffers+      dev+      zero{Vk.commandPool = pool, Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY, Vk.commandBufferCount = 1}+      allocate+  let cb = V.head cbs+  Vk.beginCommandBuffer cb zero{CommandBufferBeginInfo.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT}+  pure cb++{- | Frame-level waits and signals spliced into one submit.++Timeline semaphores carry their value; a binary semaphore's value is+ignored (pass 0).+-}+data SubmitExtras = SubmitExtras+  { waits :: [(Vk.Semaphore, PipelineStageFlags2, Word64)]+  , signals :: [(Vk.Semaphore, Word64)]+  }++noExtras :: SubmitExtras+noExtras = SubmitExtras [] []++{- | The canonical windowed frame extras.++Wait image-available; signal this image's render-finished and the host+timeline at the frame index — the shape 'queueSubmitFrame' hard-codes,+for drivers that assemble their own submits.+-}+frameSubmitExtras :: Frame rr -> Word32 -> SubmitExtras+frameSubmitExtras f imageIndex =+  SubmitExtras+    { waits = [(rrImageAvailable (fRecycled f), PIPELINE_STAGE_2_TOP_OF_PIPE_BIT, 0)]+    , signals =+        [ (sRenderFinished (fSwapchain f) V.! fromIntegral imageIndex, 0)+        , (fHostTimeline f, fIndex f)+        ]+    }++{- | Wait for some semaphores; if the wait times out, give the device one+more chance with a zero timeout. Catches the case where the host was+suspended during the wait and the GPU has actually finished.+-}+waitTwice :: Vk.Device -> SemaphoreWaitInfo -> Word64 -> IO Vk.Result+waitTwice dev waitInfo t =+  Timeline.waitSemaphoresSafe dev waitInfo t >>= \case+    Vk.TIMEOUT -> Timeline.waitSemaphores dev waitInfo 0+    r -> pure r

@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedLists #-}++{-| Tiny helpers for the boilerplate that each rendering example needs:+a framebuffer over a single image view, and a vanilla 2D color image view.+-}+module Vulkan.Utils.Framebuffer+  ( allocateFramebuffer+  ) where++import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, allocate)+import Vulkan.Core10 as Extent2D (Extent2D (..))+import qualified Vulkan.Core10 as Vk+import Vulkan.Zero (zero)++-- | Create a framebuffer covering the whole image with a single attachment.+allocateFramebuffer+  :: (MonadResource m)+  => Vk.Device+  -> Vk.RenderPass+  -> Vk.ImageView+  -> Vk.Extent2D+  -> m (ReleaseKey, Vk.Framebuffer)+allocateFramebuffer dev renderPass imageView Vk.Extent2D{width, height} =+  Vk.withFramebuffer dev framebufferCreateInfo Nothing allocate+  where+    framebufferCreateInfo :: Vk.FramebufferCreateInfo '[]+    framebufferCreateInfo =+      zero+        { Vk.renderPass = renderPass+        , Vk.attachments = [imageView]+        , Vk.width = width+        , Vk.height = height+        , Vk.layers = 1+        }

@@ -26,160 +26,143 @@  #include "gl_enums.h" --- | Convert an OpenGL format enum into a 'Vk.Format'------ >>> internalFormat GL_RGB8--- Just FORMAT_R8G8B8_UNORM+{- | Convert an OpenGL format enum into a 'Vk.Format'++>>> internalFormat GL_RGB8+Just FORMAT_R8G8B8_UNORM+-} internalFormat :: (Eq a, Num a) => a -> Maybe Vk.Format internalFormat = \case-  GL_R8    -> Just Vk.FORMAT_R8_UNORM       -- 1-component, 8-bit unsigned normalized-  GL_RG8   -> Just Vk.FORMAT_R8G8_UNORM     -- 2-component, 8-bit unsigned normalized-  GL_RGB8  -> Just Vk.FORMAT_R8G8B8_UNORM   -- 3-component, 8-bit unsigned normalized+  GL_R8 -> Just Vk.FORMAT_R8_UNORM -- 1-component, 8-bit unsigned normalized+  GL_RG8 -> Just Vk.FORMAT_R8G8_UNORM -- 2-component, 8-bit unsigned normalized+  GL_RGB8 -> Just Vk.FORMAT_R8G8B8_UNORM -- 3-component, 8-bit unsigned normalized   GL_RGBA8 -> Just Vk.FORMAT_R8G8B8A8_UNORM -- 4-component, 8-bit unsigned normalized--  GL_R8_SNORM    -> Just Vk.FORMAT_R8_SNORM       -- 1-component, 8-bit signed normalized-  GL_RG8_SNORM   -> Just Vk.FORMAT_R8G8_SNORM     -- 2-component, 8-bit signed normalized-  GL_RGB8_SNORM  -> Just Vk.FORMAT_R8G8B8_SNORM   -- 3-component, 8-bit signed normalized+  GL_R8_SNORM -> Just Vk.FORMAT_R8_SNORM -- 1-component, 8-bit signed normalized+  GL_RG8_SNORM -> Just Vk.FORMAT_R8G8_SNORM -- 2-component, 8-bit signed normalized+  GL_RGB8_SNORM -> Just Vk.FORMAT_R8G8B8_SNORM -- 3-component, 8-bit signed normalized   GL_RGBA8_SNORM -> Just Vk.FORMAT_R8G8B8A8_SNORM -- 4-component, 8-bit signed normalized--  GL_R8UI    -> Just Vk.FORMAT_R8_UINT       -- 1-component, 8-bit unsigned integer-  GL_RG8UI   -> Just Vk.FORMAT_R8G8_UINT     -- 2-component, 8-bit unsigned integer-  GL_RGB8UI  -> Just Vk.FORMAT_R8G8B8_UINT   -- 3-component, 8-bit unsigned integer+  GL_R8UI -> Just Vk.FORMAT_R8_UINT -- 1-component, 8-bit unsigned integer+  GL_RG8UI -> Just Vk.FORMAT_R8G8_UINT -- 2-component, 8-bit unsigned integer+  GL_RGB8UI -> Just Vk.FORMAT_R8G8B8_UINT -- 3-component, 8-bit unsigned integer   GL_RGBA8UI -> Just Vk.FORMAT_R8G8B8A8_UINT -- 4-component, 8-bit unsigned integer--  GL_R8I    -> Just Vk.FORMAT_R8_SINT       -- 1-component, 8-bit signed integer-  GL_RG8I   -> Just Vk.FORMAT_R8G8_SINT     -- 2-component, 8-bit signed integer-  GL_RGB8I  -> Just Vk.FORMAT_R8G8B8_SINT   -- 3-component, 8-bit signed integer+  GL_R8I -> Just Vk.FORMAT_R8_SINT -- 1-component, 8-bit signed integer+  GL_RG8I -> Just Vk.FORMAT_R8G8_SINT -- 2-component, 8-bit signed integer+  GL_RGB8I -> Just Vk.FORMAT_R8G8B8_SINT -- 3-component, 8-bit signed integer   GL_RGBA8I -> Just Vk.FORMAT_R8G8B8A8_SINT -- 4-component, 8-bit signed integer--  GL_SR8          -> Just Vk.FORMAT_R8_SRGB       -- 1-component, 8-bit sRGB-  GL_SRG8         -> Just Vk.FORMAT_R8G8_SRGB     -- 2-component, 8-bit sRGB-  GL_SRGB8        -> Just Vk.FORMAT_R8G8B8_SRGB   -- 3-component, 8-bit sRGB+  GL_SR8 -> Just Vk.FORMAT_R8_SRGB -- 1-component, 8-bit sRGB+  GL_SRG8 -> Just Vk.FORMAT_R8G8_SRGB -- 2-component, 8-bit sRGB+  GL_SRGB8 -> Just Vk.FORMAT_R8G8B8_SRGB -- 3-component, 8-bit sRGB   GL_SRGB8_ALPHA8 -> Just Vk.FORMAT_R8G8B8A8_SRGB -- 4-component, 8-bit sRGB    --   -- 16 bits per component   ---  GL_R16    -> Just Vk.FORMAT_R16_UNORM          -- 1-component, 16-bit unsigned normalized-  GL_RG16   -> Just Vk.FORMAT_R16G16_UNORM       -- 2-component, 16-bit unsigned normalized-  GL_RGB16  -> Just Vk.FORMAT_R16G16B16_UNORM    -- 3-component, 16-bit unsigned normalized+  GL_R16 -> Just Vk.FORMAT_R16_UNORM -- 1-component, 16-bit unsigned normalized+  GL_RG16 -> Just Vk.FORMAT_R16G16_UNORM -- 2-component, 16-bit unsigned normalized+  GL_RGB16 -> Just Vk.FORMAT_R16G16B16_UNORM -- 3-component, 16-bit unsigned normalized   GL_RGBA16 -> Just Vk.FORMAT_R16G16B16A16_UNORM -- 4-component, 16-bit unsigned normalized--  GL_R16_SNORM    -> Just Vk.FORMAT_R16_SNORM          -- 1-component, 16-bit signed normalized-  GL_RG16_SNORM   -> Just Vk.FORMAT_R16G16_SNORM       -- 2-component, 16-bit signed normalized-  GL_RGB16_SNORM  -> Just Vk.FORMAT_R16G16B16_SNORM    -- 3-component, 16-bit signed normalized+  GL_R16_SNORM -> Just Vk.FORMAT_R16_SNORM -- 1-component, 16-bit signed normalized+  GL_RG16_SNORM -> Just Vk.FORMAT_R16G16_SNORM -- 2-component, 16-bit signed normalized+  GL_RGB16_SNORM -> Just Vk.FORMAT_R16G16B16_SNORM -- 3-component, 16-bit signed normalized   GL_RGBA16_SNORM -> Just Vk.FORMAT_R16G16B16A16_SNORM -- 4-component, 16-bit signed normalized--  GL_R16UI    -> Just Vk.FORMAT_R16_UINT          -- 1-component, 16-bit unsigned integer-  GL_RG16UI   -> Just Vk.FORMAT_R16G16_UINT       -- 2-component, 16-bit unsigned integer-  GL_RGB16UI  -> Just Vk.FORMAT_R16G16B16_UINT    -- 3-component, 16-bit unsigned integer+  GL_R16UI -> Just Vk.FORMAT_R16_UINT -- 1-component, 16-bit unsigned integer+  GL_RG16UI -> Just Vk.FORMAT_R16G16_UINT -- 2-component, 16-bit unsigned integer+  GL_RGB16UI -> Just Vk.FORMAT_R16G16B16_UINT -- 3-component, 16-bit unsigned integer   GL_RGBA16UI -> Just Vk.FORMAT_R16G16B16A16_UINT -- 4-component, 16-bit unsigned integer--  GL_R16I    -> Just Vk.FORMAT_R16_SINT          -- 1-component, 16-bit signed integer-  GL_RG16I   -> Just Vk.FORMAT_R16G16_SINT       -- 2-component, 16-bit signed integer-  GL_RGB16I  -> Just Vk.FORMAT_R16G16B16_SINT    -- 3-component, 16-bit signed integer+  GL_R16I -> Just Vk.FORMAT_R16_SINT -- 1-component, 16-bit signed integer+  GL_RG16I -> Just Vk.FORMAT_R16G16_SINT -- 2-component, 16-bit signed integer+  GL_RGB16I -> Just Vk.FORMAT_R16G16B16_SINT -- 3-component, 16-bit signed integer   GL_RGBA16I -> Just Vk.FORMAT_R16G16B16A16_SINT -- 4-component, 16-bit signed integer--  GL_R16F    -> Just Vk.FORMAT_R16_SFLOAT          -- 1-component, 16-bit floating-point-  GL_RG16F   -> Just Vk.FORMAT_R16G16_SFLOAT       -- 2-component, 16-bit floating-point-  GL_RGB16F  -> Just Vk.FORMAT_R16G16B16_SFLOAT    -- 3-component, 16-bit floating-point+  GL_R16F -> Just Vk.FORMAT_R16_SFLOAT -- 1-component, 16-bit floating-point+  GL_RG16F -> Just Vk.FORMAT_R16G16_SFLOAT -- 2-component, 16-bit floating-point+  GL_RGB16F -> Just Vk.FORMAT_R16G16B16_SFLOAT -- 3-component, 16-bit floating-point   GL_RGBA16F -> Just Vk.FORMAT_R16G16B16A16_SFLOAT -- 4-component, 16-bit floating-point    --   -- 32 bits per component   ---  GL_R32UI    -> Just Vk.FORMAT_R32_UINT          -- 1-component, 32-bit unsigned integer-  GL_RG32UI   -> Just Vk.FORMAT_R32G32_UINT       -- 2-component, 32-bit unsigned integer-  GL_RGB32UI  -> Just Vk.FORMAT_R32G32B32_UINT    -- 3-component, 32-bit unsigned integer+  GL_R32UI -> Just Vk.FORMAT_R32_UINT -- 1-component, 32-bit unsigned integer+  GL_RG32UI -> Just Vk.FORMAT_R32G32_UINT -- 2-component, 32-bit unsigned integer+  GL_RGB32UI -> Just Vk.FORMAT_R32G32B32_UINT -- 3-component, 32-bit unsigned integer   GL_RGBA32UI -> Just Vk.FORMAT_R32G32B32A32_UINT -- 4-component, 32-bit unsigned integer--  GL_R32I    -> Just Vk.FORMAT_R32_SINT          -- 1-component, 32-bit signed integer-  GL_RG32I   -> Just Vk.FORMAT_R32G32_SINT       -- 2-component, 32-bit signed integer-  GL_RGB32I  -> Just Vk.FORMAT_R32G32B32_SINT    -- 3-component, 32-bit signed integer+  GL_R32I -> Just Vk.FORMAT_R32_SINT -- 1-component, 32-bit signed integer+  GL_RG32I -> Just Vk.FORMAT_R32G32_SINT -- 2-component, 32-bit signed integer+  GL_RGB32I -> Just Vk.FORMAT_R32G32B32_SINT -- 3-component, 32-bit signed integer   GL_RGBA32I -> Just Vk.FORMAT_R32G32B32A32_SINT -- 4-component, 32-bit signed integer--  GL_R32F    -> Just Vk.FORMAT_R32_SFLOAT          -- 1-component, 32-bit floating-point-  GL_RG32F   -> Just Vk.FORMAT_R32G32_SFLOAT       -- 2-component, 32-bit floating-point-  GL_RGB32F  -> Just Vk.FORMAT_R32G32B32_SFLOAT    -- 3-component, 32-bit floating-point+  GL_R32F -> Just Vk.FORMAT_R32_SFLOAT -- 1-component, 32-bit floating-point+  GL_RG32F -> Just Vk.FORMAT_R32G32_SFLOAT -- 2-component, 32-bit floating-point+  GL_RGB32F -> Just Vk.FORMAT_R32G32B32_SFLOAT -- 3-component, 32-bit floating-point   GL_RGBA32F -> Just Vk.FORMAT_R32G32B32A32_SFLOAT -- 4-component, 32-bit floating-point    --   -- Packed   ---  GL_R3_G3_B2       -> Nothing                                 -- 3-component 3:3:2,       unsigned normalized-  GL_RGB4           -> Nothing                                 -- 3-component 4:4:4,       unsigned normalized-  GL_RGB5           -> Just Vk.FORMAT_R5G5B5A1_UNORM_PACK16    -- 3-component 5:5:5,       unsigned normalized-  GL_RGB565         -> Just Vk.FORMAT_R5G6B5_UNORM_PACK16      -- 3-component 5:6:5,       unsigned normalized-  GL_RGB10          -> Just Vk.FORMAT_A2R10G10B10_UNORM_PACK32 -- 3-component 10:10:10,    unsigned normalized-  GL_RGB12          -> Nothing                                 -- 3-component 12:12:12,    unsigned normalized-  GL_RGBA2          -> Nothing                                 -- 4-component 2:2:2:2,     unsigned normalized-  GL_RGBA4          -> Just Vk.FORMAT_R4G4B4A4_UNORM_PACK16    -- 4-component 4:4:4:4,     unsigned normalized-  GL_RGBA12         -> Nothing                                 -- 4-component 12:12:12:12, unsigned normalized-  GL_RGB5_A1        -> Just Vk.FORMAT_A1R5G5B5_UNORM_PACK16    -- 4-component 5:5:5:1,     unsigned normalized-  GL_RGB10_A2       -> Just Vk.FORMAT_A2R10G10B10_UNORM_PACK32 -- 4-component 10:10:10:2,  unsigned normalized-  GL_RGB10_A2UI     -> Just Vk.FORMAT_A2R10G10B10_UINT_PACK32  -- 4-component 10:10:10:2,  unsigned integer-  GL_R11F_G11F_B10F -> Just Vk.FORMAT_B10G11R11_UFLOAT_PACK32  -- 3-component 11:11:10,    floating-point-  GL_RGB9_E5        -> Just Vk.FORMAT_E5B9G9R9_UFLOAT_PACK32   -- 3-component/exp 9:9:9/5, floating-point+  GL_R3_G3_B2 -> Nothing -- 3-component 3:3:2,       unsigned normalized+  GL_RGB4 -> Nothing -- 3-component 4:4:4,       unsigned normalized+  GL_RGB5 -> Just Vk.FORMAT_R5G5B5A1_UNORM_PACK16 -- 3-component 5:5:5,       unsigned normalized+  GL_RGB565 -> Just Vk.FORMAT_R5G6B5_UNORM_PACK16 -- 3-component 5:6:5,       unsigned normalized+  GL_RGB10 -> Just Vk.FORMAT_A2R10G10B10_UNORM_PACK32 -- 3-component 10:10:10,    unsigned normalized+  GL_RGB12 -> Nothing -- 3-component 12:12:12,    unsigned normalized+  GL_RGBA2 -> Nothing -- 4-component 2:2:2:2,     unsigned normalized+  GL_RGBA4 -> Just Vk.FORMAT_R4G4B4A4_UNORM_PACK16 -- 4-component 4:4:4:4,     unsigned normalized+  GL_RGBA12 -> Nothing -- 4-component 12:12:12:12, unsigned normalized+  GL_RGB5_A1 -> Just Vk.FORMAT_A1R5G5B5_UNORM_PACK16 -- 4-component 5:5:5:1,     unsigned normalized+  GL_RGB10_A2 -> Just Vk.FORMAT_A2R10G10B10_UNORM_PACK32 -- 4-component 10:10:10:2,  unsigned normalized+  GL_RGB10_A2UI -> Just Vk.FORMAT_A2R10G10B10_UINT_PACK32 -- 4-component 10:10:10:2,  unsigned integer+  GL_R11F_G11F_B10F -> Just Vk.FORMAT_B10G11R11_UFLOAT_PACK32 -- 3-component 11:11:10,    floating-point+  GL_RGB9_E5 -> Just Vk.FORMAT_E5B9G9R9_UFLOAT_PACK32 -- 3-component/exp 9:9:9/5, floating-point    --   -- S3TC/DXT/BC   -- -  GL_COMPRESSED_RGB_S3TC_DXT1_EXT  -> Just Vk.FORMAT_BC1_RGB_UNORM_BLOCK  -- line through 3D space, 4x4 blocks, unsigned normalized+  GL_COMPRESSED_RGB_S3TC_DXT1_EXT -> Just Vk.FORMAT_BC1_RGB_UNORM_BLOCK -- line through 3D space, 4x4 blocks, unsigned normalized   GL_COMPRESSED_RGBA_S3TC_DXT1_EXT -> Just Vk.FORMAT_BC1_RGBA_UNORM_BLOCK -- line through 3D space plus 1-bit alpha, 4x4 blocks, unsigned normalized-  GL_COMPRESSED_RGBA_S3TC_DXT3_EXT -> Just Vk.FORMAT_BC2_UNORM_BLOCK      -- line through 3D space plus line through 1D space, 4x4 blocks, unsigned normalized-  GL_COMPRESSED_RGBA_S3TC_DXT5_EXT -> Just Vk.FORMAT_BC3_UNORM_BLOCK      -- line through 3D space plus 4-bit alpha, 4x4 blocks, unsigned normalized--  GL_COMPRESSED_SRGB_S3TC_DXT1_EXT       -> Just Vk.FORMAT_BC1_RGB_SRGB_BLOCK  -- line through 3D space, 4x4 blocks, sRGB+  GL_COMPRESSED_RGBA_S3TC_DXT3_EXT -> Just Vk.FORMAT_BC2_UNORM_BLOCK -- line through 3D space plus line through 1D space, 4x4 blocks, unsigned normalized+  GL_COMPRESSED_RGBA_S3TC_DXT5_EXT -> Just Vk.FORMAT_BC3_UNORM_BLOCK -- line through 3D space plus 4-bit alpha, 4x4 blocks, unsigned normalized+  GL_COMPRESSED_SRGB_S3TC_DXT1_EXT -> Just Vk.FORMAT_BC1_RGB_SRGB_BLOCK -- line through 3D space, 4x4 blocks, sRGB   GL_COMPRESSED_SRGB_ALPHA_S3TC_DXT1_EXT -> Just Vk.FORMAT_BC1_RGBA_SRGB_BLOCK -- line through 3D space plus 1-bit alpha, 4x4 blocks, sRGB-  GL_COMPRESSED_SRGB_ALPHA_S3TC_DXT3_EXT -> Just Vk.FORMAT_BC2_SRGB_BLOCK      -- line through 3D space plus line through 1D space, 4x4 blocks, sRGB-  GL_COMPRESSED_SRGB_ALPHA_S3TC_DXT5_EXT -> Just Vk.FORMAT_BC3_SRGB_BLOCK      -- line through 3D space plus 4-bit alpha, 4x4 blocks, sRGB--  GL_COMPRESSED_LUMINANCE_LATC1_EXT              -> Just Vk.FORMAT_BC4_UNORM_BLOCK -- line through 1D space, 4x4 blocks, unsigned normalized-  GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT        -> Just Vk.FORMAT_BC5_UNORM_BLOCK -- two lines through 1D space, 4x4 blocks, unsigned normalized-  GL_COMPRESSED_SIGNED_LUMINANCE_LATC1_EXT       -> Just Vk.FORMAT_BC4_SNORM_BLOCK -- line through 1D space, 4x4 blocks, signed normalized+  GL_COMPRESSED_SRGB_ALPHA_S3TC_DXT3_EXT -> Just Vk.FORMAT_BC2_SRGB_BLOCK -- line through 3D space plus line through 1D space, 4x4 blocks, sRGB+  GL_COMPRESSED_SRGB_ALPHA_S3TC_DXT5_EXT -> Just Vk.FORMAT_BC3_SRGB_BLOCK -- line through 3D space plus 4-bit alpha, 4x4 blocks, sRGB+  GL_COMPRESSED_LUMINANCE_LATC1_EXT -> Just Vk.FORMAT_BC4_UNORM_BLOCK -- line through 1D space, 4x4 blocks, unsigned normalized+  GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT -> Just Vk.FORMAT_BC5_UNORM_BLOCK -- two lines through 1D space, 4x4 blocks, unsigned normalized+  GL_COMPRESSED_SIGNED_LUMINANCE_LATC1_EXT -> Just Vk.FORMAT_BC4_SNORM_BLOCK -- line through 1D space, 4x4 blocks, signed normalized   GL_COMPRESSED_SIGNED_LUMINANCE_ALPHA_LATC2_EXT -> Just Vk.FORMAT_BC5_SNORM_BLOCK -- two lines through 1D space, 4x4 blocks, signed normalized--  GL_COMPRESSED_RED_RGTC1        -> Just Vk.FORMAT_BC4_UNORM_BLOCK -- line through 1D space, 4x4 blocks, unsigned normalized-  GL_COMPRESSED_RG_RGTC2         -> Just Vk.FORMAT_BC5_UNORM_BLOCK -- two lines through 1D space, 4x4 blocks, unsigned normalized+  GL_COMPRESSED_RED_RGTC1 -> Just Vk.FORMAT_BC4_UNORM_BLOCK -- line through 1D space, 4x4 blocks, unsigned normalized+  GL_COMPRESSED_RG_RGTC2 -> Just Vk.FORMAT_BC5_UNORM_BLOCK -- two lines through 1D space, 4x4 blocks, unsigned normalized   GL_COMPRESSED_SIGNED_RED_RGTC1 -> Just Vk.FORMAT_BC4_SNORM_BLOCK -- line through 1D space, 4x4 blocks, signed normalized-  GL_COMPRESSED_SIGNED_RG_RGTC2  -> Just Vk.FORMAT_BC5_SNORM_BLOCK -- two lines through 1D space, 4x4 blocks, signed normalized-+  GL_COMPRESSED_SIGNED_RG_RGTC2 -> Just Vk.FORMAT_BC5_SNORM_BLOCK -- two lines through 1D space, 4x4 blocks, signed normalized   GL_COMPRESSED_RGB_BPTC_UNSIGNED_FLOAT -> Just Vk.FORMAT_BC6H_UFLOAT_BLOCK -- 3-component, 4x4 blocks, unsigned floating-point-  GL_COMPRESSED_RGB_BPTC_SIGNED_FLOAT   -> Just Vk.FORMAT_BC6H_SFLOAT_BLOCK -- 3-component, 4x4 blocks, signed floating-point-  GL_COMPRESSED_RGBA_BPTC_UNORM         -> Just Vk.FORMAT_BC7_UNORM_BLOCK   -- 4-component, 4x4 blocks, unsigned normalized-  GL_COMPRESSED_SRGB_ALPHA_BPTC_UNORM   -> Just Vk.FORMAT_BC7_SRGB_BLOCK    -- 4-component, 4x4 blocks, sRGB+  GL_COMPRESSED_RGB_BPTC_SIGNED_FLOAT -> Just Vk.FORMAT_BC6H_SFLOAT_BLOCK -- 3-component, 4x4 blocks, signed floating-point+  GL_COMPRESSED_RGBA_BPTC_UNORM -> Just Vk.FORMAT_BC7_UNORM_BLOCK -- 4-component, 4x4 blocks, unsigned normalized+  GL_COMPRESSED_SRGB_ALPHA_BPTC_UNORM -> Just Vk.FORMAT_BC7_SRGB_BLOCK -- 4-component, 4x4 blocks, sRGB    --   -- ETC   --   GL_ETC1_RGB8_OES -> Just Vk.FORMAT_ETC2_R8G8B8_UNORM_BLOCK -- 3-component ETC1, 4x4 blocks, unsigned normalized--  GL_COMPRESSED_RGB8_ETC2                     -> Just Vk.FORMAT_ETC2_R8G8B8_UNORM_BLOCK   -- 3-component ETC2, 4x4 blocks, unsigned normalized+  GL_COMPRESSED_RGB8_ETC2 -> Just Vk.FORMAT_ETC2_R8G8B8_UNORM_BLOCK -- 3-component ETC2, 4x4 blocks, unsigned normalized   GL_COMPRESSED_RGB8_PUNCHTHROUGH_ALPHA1_ETC2 -> Just Vk.FORMAT_ETC2_R8G8B8A1_UNORM_BLOCK -- 4-component ETC2 with 1-bit alpha, 4x4 blocks, unsigned normalized-  GL_COMPRESSED_RGBA8_ETC2_EAC                -> Just Vk.FORMAT_ETC2_R8G8B8A8_UNORM_BLOCK -- 4-component ETC2, 4x4 blocks, unsigned normalized--  GL_COMPRESSED_SRGB8_ETC2                     -> Just Vk.FORMAT_ETC2_R8G8B8_SRGB_BLOCK   -- 3-component ETC2, 4x4 blocks, sRGB+  GL_COMPRESSED_RGBA8_ETC2_EAC -> Just Vk.FORMAT_ETC2_R8G8B8A8_UNORM_BLOCK -- 4-component ETC2, 4x4 blocks, unsigned normalized+  GL_COMPRESSED_SRGB8_ETC2 -> Just Vk.FORMAT_ETC2_R8G8B8_SRGB_BLOCK -- 3-component ETC2, 4x4 blocks, sRGB   GL_COMPRESSED_SRGB8_PUNCHTHROUGH_ALPHA1_ETC2 -> Just Vk.FORMAT_ETC2_R8G8B8A1_SRGB_BLOCK -- 4-component ETC2 with 1-bit alpha, 4x4 blocks, sRGB-  GL_COMPRESSED_SRGB8_ALPHA8_ETC2_EAC          -> Just Vk.FORMAT_ETC2_R8G8B8A8_SRGB_BLOCK -- 4-component ETC2, 4x4 blocks, sRGB--  GL_COMPRESSED_R11_EAC         -> Just Vk.FORMAT_EAC_R11_UNORM_BLOCK    -- 1-component ETC, 4x4 blocks, unsigned normalized-  GL_COMPRESSED_RG11_EAC        -> Just Vk.FORMAT_EAC_R11G11_UNORM_BLOCK -- 2-component ETC, 4x4 blocks, unsigned normalized-  GL_COMPRESSED_SIGNED_R11_EAC  -> Just Vk.FORMAT_EAC_R11_SNORM_BLOCK    -- 1-component ETC, 4x4 blocks, signed normalized+  GL_COMPRESSED_SRGB8_ALPHA8_ETC2_EAC -> Just Vk.FORMAT_ETC2_R8G8B8A8_SRGB_BLOCK -- 4-component ETC2, 4x4 blocks, sRGB+  GL_COMPRESSED_R11_EAC -> Just Vk.FORMAT_EAC_R11_UNORM_BLOCK -- 1-component ETC, 4x4 blocks, unsigned normalized+  GL_COMPRESSED_RG11_EAC -> Just Vk.FORMAT_EAC_R11G11_UNORM_BLOCK -- 2-component ETC, 4x4 blocks, unsigned normalized+  GL_COMPRESSED_SIGNED_R11_EAC -> Just Vk.FORMAT_EAC_R11_SNORM_BLOCK -- 1-component ETC, 4x4 blocks, signed normalized   GL_COMPRESSED_SIGNED_RG11_EAC -> Just Vk.FORMAT_EAC_R11G11_SNORM_BLOCK -- 2-component ETC, 4x4 blocks, signed normalized    --   -- PVRTC   ---  GL_COMPRESSED_RGB_PVRTC_2BPPV1_IMG  -> Just Vk.FORMAT_PVRTC1_2BPP_UNORM_BLOCK_IMG -- 3-component PVRTC, 16x8 blocks, unsigned normalized-  GL_COMPRESSED_RGB_PVRTC_4BPPV1_IMG  -> Just Vk.FORMAT_PVRTC1_4BPP_UNORM_BLOCK_IMG -- 3-component PVRTC,  8x8 blocks, unsigned normalized+  GL_COMPRESSED_RGB_PVRTC_2BPPV1_IMG -> Just Vk.FORMAT_PVRTC1_2BPP_UNORM_BLOCK_IMG -- 3-component PVRTC, 16x8 blocks, unsigned normalized+  GL_COMPRESSED_RGB_PVRTC_4BPPV1_IMG -> Just Vk.FORMAT_PVRTC1_4BPP_UNORM_BLOCK_IMG -- 3-component PVRTC,  8x8 blocks, unsigned normalized   GL_COMPRESSED_RGBA_PVRTC_2BPPV1_IMG -> Just Vk.FORMAT_PVRTC1_2BPP_UNORM_BLOCK_IMG -- 4-component PVRTC, 16x8 blocks, unsigned normalized   GL_COMPRESSED_RGBA_PVRTC_4BPPV1_IMG -> Just Vk.FORMAT_PVRTC1_4BPP_UNORM_BLOCK_IMG -- 4-component PVRTC,  8x8 blocks, unsigned normalized   GL_COMPRESSED_RGBA_PVRTC_2BPPV2_IMG -> Just Vk.FORMAT_PVRTC2_2BPP_UNORM_BLOCK_IMG -- 4-component PVRTC,  8x4 blocks, unsigned normalized   GL_COMPRESSED_RGBA_PVRTC_4BPPV2_IMG -> Just Vk.FORMAT_PVRTC2_4BPP_UNORM_BLOCK_IMG -- 4-component PVRTC,  4x4 blocks, unsigned normalized--  GL_COMPRESSED_SRGB_PVRTC_2BPPV1_EXT       -> Just Vk.FORMAT_PVRTC1_2BPP_SRGB_BLOCK_IMG -- 3-component PVRTC, 16x8 blocks, sRGB-  GL_COMPRESSED_SRGB_PVRTC_4BPPV1_EXT       -> Just Vk.FORMAT_PVRTC1_4BPP_SRGB_BLOCK_IMG -- 3-component PVRTC,  8x8 blocks, sRGB+  GL_COMPRESSED_SRGB_PVRTC_2BPPV1_EXT -> Just Vk.FORMAT_PVRTC1_2BPP_SRGB_BLOCK_IMG -- 3-component PVRTC, 16x8 blocks, sRGB+  GL_COMPRESSED_SRGB_PVRTC_4BPPV1_EXT -> Just Vk.FORMAT_PVRTC1_4BPP_SRGB_BLOCK_IMG -- 3-component PVRTC,  8x8 blocks, sRGB   GL_COMPRESSED_SRGB_ALPHA_PVRTC_2BPPV1_EXT -> Just Vk.FORMAT_PVRTC1_2BPP_SRGB_BLOCK_IMG -- 4-component PVRTC, 16x8 blocks, sRGB   GL_COMPRESSED_SRGB_ALPHA_PVRTC_4BPPV1_EXT -> Just Vk.FORMAT_PVRTC1_4BPP_SRGB_BLOCK_IMG -- 4-component PVRTC,  8x8 blocks, sRGB   GL_COMPRESSED_SRGB_ALPHA_PVRTC_2BPPV2_IMG -> Just Vk.FORMAT_PVRTC2_2BPP_SRGB_BLOCK_IMG -- 4-component PVRTC,  8x4 blocks, sRGB@@ -188,36 +171,34 @@   --   -- ASTC   ---  GL_COMPRESSED_RGBA_ASTC_4x4_KHR   -> Just Vk.FORMAT_ASTC_4x4_UNORM_BLOCK   -- 4-component ASTC, 4x4 blocks, unsigned normalized-  GL_COMPRESSED_RGBA_ASTC_5x4_KHR   -> Just Vk.FORMAT_ASTC_5x4_UNORM_BLOCK   -- 4-component ASTC, 5x4 blocks, unsigned normalized-  GL_COMPRESSED_RGBA_ASTC_5x5_KHR   -> Just Vk.FORMAT_ASTC_5x5_UNORM_BLOCK   -- 4-component ASTC, 5x5 blocks, unsigned normalized-  GL_COMPRESSED_RGBA_ASTC_6x5_KHR   -> Just Vk.FORMAT_ASTC_6x5_UNORM_BLOCK   -- 4-component ASTC, 6x5 blocks, unsigned normalized-  GL_COMPRESSED_RGBA_ASTC_6x6_KHR   -> Just Vk.FORMAT_ASTC_6x6_UNORM_BLOCK   -- 4-component ASTC, 6x6 blocks, unsigned normalized-  GL_COMPRESSED_RGBA_ASTC_8x5_KHR   -> Just Vk.FORMAT_ASTC_8x5_UNORM_BLOCK   -- 4-component ASTC, 8x5 blocks, unsigned normalized-  GL_COMPRESSED_RGBA_ASTC_8x6_KHR   -> Just Vk.FORMAT_ASTC_8x6_UNORM_BLOCK   -- 4-component ASTC, 8x6 blocks, unsigned normalized-  GL_COMPRESSED_RGBA_ASTC_8x8_KHR   -> Just Vk.FORMAT_ASTC_8x8_UNORM_BLOCK   -- 4-component ASTC, 8x8 blocks, unsigned normalized-  GL_COMPRESSED_RGBA_ASTC_10x5_KHR  -> Just Vk.FORMAT_ASTC_10x5_UNORM_BLOCK  -- 4-component ASTC, 10x5 blocks, unsigned normalized-  GL_COMPRESSED_RGBA_ASTC_10x6_KHR  -> Just Vk.FORMAT_ASTC_10x6_UNORM_BLOCK  -- 4-component ASTC, 10x6 blocks, unsigned normalized-  GL_COMPRESSED_RGBA_ASTC_10x8_KHR  -> Just Vk.FORMAT_ASTC_10x8_UNORM_BLOCK  -- 4-component ASTC, 10x8 blocks, unsigned normalized+  GL_COMPRESSED_RGBA_ASTC_4x4_KHR -> Just Vk.FORMAT_ASTC_4x4_UNORM_BLOCK -- 4-component ASTC, 4x4 blocks, unsigned normalized+  GL_COMPRESSED_RGBA_ASTC_5x4_KHR -> Just Vk.FORMAT_ASTC_5x4_UNORM_BLOCK -- 4-component ASTC, 5x4 blocks, unsigned normalized+  GL_COMPRESSED_RGBA_ASTC_5x5_KHR -> Just Vk.FORMAT_ASTC_5x5_UNORM_BLOCK -- 4-component ASTC, 5x5 blocks, unsigned normalized+  GL_COMPRESSED_RGBA_ASTC_6x5_KHR -> Just Vk.FORMAT_ASTC_6x5_UNORM_BLOCK -- 4-component ASTC, 6x5 blocks, unsigned normalized+  GL_COMPRESSED_RGBA_ASTC_6x6_KHR -> Just Vk.FORMAT_ASTC_6x6_UNORM_BLOCK -- 4-component ASTC, 6x6 blocks, unsigned normalized+  GL_COMPRESSED_RGBA_ASTC_8x5_KHR -> Just Vk.FORMAT_ASTC_8x5_UNORM_BLOCK -- 4-component ASTC, 8x5 blocks, unsigned normalized+  GL_COMPRESSED_RGBA_ASTC_8x6_KHR -> Just Vk.FORMAT_ASTC_8x6_UNORM_BLOCK -- 4-component ASTC, 8x6 blocks, unsigned normalized+  GL_COMPRESSED_RGBA_ASTC_8x8_KHR -> Just Vk.FORMAT_ASTC_8x8_UNORM_BLOCK -- 4-component ASTC, 8x8 blocks, unsigned normalized+  GL_COMPRESSED_RGBA_ASTC_10x5_KHR -> Just Vk.FORMAT_ASTC_10x5_UNORM_BLOCK -- 4-component ASTC, 10x5 blocks, unsigned normalized+  GL_COMPRESSED_RGBA_ASTC_10x6_KHR -> Just Vk.FORMAT_ASTC_10x6_UNORM_BLOCK -- 4-component ASTC, 10x6 blocks, unsigned normalized+  GL_COMPRESSED_RGBA_ASTC_10x8_KHR -> Just Vk.FORMAT_ASTC_10x8_UNORM_BLOCK -- 4-component ASTC, 10x8 blocks, unsigned normalized   GL_COMPRESSED_RGBA_ASTC_10x10_KHR -> Just Vk.FORMAT_ASTC_10x10_UNORM_BLOCK -- 4-component ASTC, 10x10 blocks, unsigned normalized   GL_COMPRESSED_RGBA_ASTC_12x10_KHR -> Just Vk.FORMAT_ASTC_12x10_UNORM_BLOCK -- 4-component ASTC, 12x10 blocks, unsigned normalized   GL_COMPRESSED_RGBA_ASTC_12x12_KHR -> Just Vk.FORMAT_ASTC_12x12_UNORM_BLOCK -- 4-component ASTC, 12x12 blocks, unsigned normalized--  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_4x4_KHR   -> Just Vk.FORMAT_ASTC_4x4_SRGB_BLOCK   -- 4-component ASTC, 4x4 blocks, sRGB-  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_5x4_KHR   -> Just Vk.FORMAT_ASTC_5x4_SRGB_BLOCK   -- 4-component ASTC, 5x4 blocks, sRGB-  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_5x5_KHR   -> Just Vk.FORMAT_ASTC_5x5_SRGB_BLOCK   -- 4-component ASTC, 5x5 blocks, sRGB-  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_6x5_KHR   -> Just Vk.FORMAT_ASTC_6x5_SRGB_BLOCK   -- 4-component ASTC, 6x5 blocks, sRGB-  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_6x6_KHR   -> Just Vk.FORMAT_ASTC_6x6_SRGB_BLOCK   -- 4-component ASTC, 6x6 blocks, sRGB-  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_8x5_KHR   -> Just Vk.FORMAT_ASTC_8x5_SRGB_BLOCK   -- 4-component ASTC, 8x5 blocks, sRGB-  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_8x6_KHR   -> Just Vk.FORMAT_ASTC_8x6_SRGB_BLOCK   -- 4-component ASTC, 8x6 blocks, sRGB-  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_8x8_KHR   -> Just Vk.FORMAT_ASTC_8x8_SRGB_BLOCK   -- 4-component ASTC, 8x8 blocks, sRGB-  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_10x5_KHR  -> Just Vk.FORMAT_ASTC_10x5_SRGB_BLOCK  -- 4-component ASTC, 10x5 blocks, sRGB-  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_10x6_KHR  -> Just Vk.FORMAT_ASTC_10x6_SRGB_BLOCK  -- 4-component ASTC, 10x6 blocks, sRGB-  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_10x8_KHR  -> Just Vk.FORMAT_ASTC_10x8_SRGB_BLOCK  -- 4-component ASTC, 10x8 blocks, sRGB+  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_4x4_KHR -> Just Vk.FORMAT_ASTC_4x4_SRGB_BLOCK -- 4-component ASTC, 4x4 blocks, sRGB+  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_5x4_KHR -> Just Vk.FORMAT_ASTC_5x4_SRGB_BLOCK -- 4-component ASTC, 5x4 blocks, sRGB+  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_5x5_KHR -> Just Vk.FORMAT_ASTC_5x5_SRGB_BLOCK -- 4-component ASTC, 5x5 blocks, sRGB+  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_6x5_KHR -> Just Vk.FORMAT_ASTC_6x5_SRGB_BLOCK -- 4-component ASTC, 6x5 blocks, sRGB+  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_6x6_KHR -> Just Vk.FORMAT_ASTC_6x6_SRGB_BLOCK -- 4-component ASTC, 6x6 blocks, sRGB+  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_8x5_KHR -> Just Vk.FORMAT_ASTC_8x5_SRGB_BLOCK -- 4-component ASTC, 8x5 blocks, sRGB+  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_8x6_KHR -> Just Vk.FORMAT_ASTC_8x6_SRGB_BLOCK -- 4-component ASTC, 8x6 blocks, sRGB+  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_8x8_KHR -> Just Vk.FORMAT_ASTC_8x8_SRGB_BLOCK -- 4-component ASTC, 8x8 blocks, sRGB+  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_10x5_KHR -> Just Vk.FORMAT_ASTC_10x5_SRGB_BLOCK -- 4-component ASTC, 10x5 blocks, sRGB+  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_10x6_KHR -> Just Vk.FORMAT_ASTC_10x6_SRGB_BLOCK -- 4-component ASTC, 10x6 blocks, sRGB+  GL_COMPRESSED_SRGB8_ALPHA8_ASTC_10x8_KHR -> Just Vk.FORMAT_ASTC_10x8_SRGB_BLOCK -- 4-component ASTC, 10x8 blocks, sRGB   GL_COMPRESSED_SRGB8_ALPHA8_ASTC_10x10_KHR -> Just Vk.FORMAT_ASTC_10x10_SRGB_BLOCK -- 4-component ASTC, 10x10 blocks, sRGB   GL_COMPRESSED_SRGB8_ALPHA8_ASTC_12x10_KHR -> Just Vk.FORMAT_ASTC_12x10_SRGB_BLOCK -- 4-component ASTC, 12x10 blocks, sRGB   GL_COMPRESSED_SRGB8_ALPHA8_ASTC_12x12_KHR -> Just Vk.FORMAT_ASTC_12x12_SRGB_BLOCK -- 4-component ASTC, 12x12 blocks, sRGB-   GL_COMPRESSED_RGBA_ASTC_3x3x3_OES -> Nothing -- 4-component ASTC, 3x3x3 blocks, unsigned normalized   GL_COMPRESSED_RGBA_ASTC_4x3x3_OES -> Nothing -- 4-component ASTC, 4x3x3 blocks, unsigned normalized   GL_COMPRESSED_RGBA_ASTC_4x4x3_OES -> Nothing -- 4-component ASTC, 4x4x3 blocks, unsigned normalized@@ -228,7 +209,6 @@   GL_COMPRESSED_RGBA_ASTC_6x5x5_OES -> Nothing -- 4-component ASTC, 6x5x5 blocks, unsigned normalized   GL_COMPRESSED_RGBA_ASTC_6x6x5_OES -> Nothing -- 4-component ASTC, 6x6x5 blocks, unsigned normalized   GL_COMPRESSED_RGBA_ASTC_6x6x6_OES -> Nothing -- 4-component ASTC, 6x6x6 blocks, unsigned normalized-   GL_COMPRESSED_SRGB8_ALPHA8_ASTC_3x3x3_OES -> Nothing -- 4-component ASTC, 3x3x3 blocks, sRGB   GL_COMPRESSED_SRGB8_ALPHA8_ASTC_4x3x3_OES -> Nothing -- 4-component ASTC, 4x3x3 blocks, sRGB   GL_COMPRESSED_SRGB8_ALPHA8_ASTC_4x4x3_OES -> Nothing -- 4-component ASTC, 4x4x3 blocks, sRGB@@ -243,38 +223,37 @@   --   -- ATC   ---  GL_ATC_RGB_AMD                     -> Nothing -- 3-component, 4x4 blocks, unsigned normalized-  GL_ATC_RGBA_EXPLICIT_ALPHA_AMD     -> Nothing -- 4-component, 4x4 blocks, unsigned normalized+  GL_ATC_RGB_AMD -> Nothing -- 3-component, 4x4 blocks, unsigned normalized+  GL_ATC_RGBA_EXPLICIT_ALPHA_AMD -> Nothing -- 4-component, 4x4 blocks, unsigned normalized   GL_ATC_RGBA_INTERPOLATED_ALPHA_AMD -> Nothing -- 4-component, 4x4 blocks, unsigned normalized    --   -- Palletized   ---  GL_PALETTE4_RGB8_OES     -> Nothing -- 3-component 8:8:8,   4-bit palette, unsigned normalized-  GL_PALETTE4_RGBA8_OES    -> Nothing -- 4-component 8:8:8:8, 4-bit palette, unsigned normalized+  GL_PALETTE4_RGB8_OES -> Nothing -- 3-component 8:8:8,   4-bit palette, unsigned normalized+  GL_PALETTE4_RGBA8_OES -> Nothing -- 4-component 8:8:8:8, 4-bit palette, unsigned normalized   GL_PALETTE4_R5_G6_B5_OES -> Nothing -- 3-component 5:6:5,   4-bit palette, unsigned normalized-  GL_PALETTE4_RGBA4_OES    -> Nothing -- 4-component 4:4:4:4, 4-bit palette, unsigned normalized-  GL_PALETTE4_RGB5_A1_OES  -> Nothing -- 4-component 5:5:5:1, 4-bit palette, unsigned normalized-  GL_PALETTE8_RGB8_OES     -> Nothing -- 3-component 8:8:8,   8-bit palette, unsigned normalized-  GL_PALETTE8_RGBA8_OES    -> Nothing -- 4-component 8:8:8:8, 8-bit palette, unsigned normalized+  GL_PALETTE4_RGBA4_OES -> Nothing -- 4-component 4:4:4:4, 4-bit palette, unsigned normalized+  GL_PALETTE4_RGB5_A1_OES -> Nothing -- 4-component 5:5:5:1, 4-bit palette, unsigned normalized+  GL_PALETTE8_RGB8_OES -> Nothing -- 3-component 8:8:8,   8-bit palette, unsigned normalized+  GL_PALETTE8_RGBA8_OES -> Nothing -- 4-component 8:8:8:8, 8-bit palette, unsigned normalized   GL_PALETTE8_R5_G6_B5_OES -> Nothing -- 3-component 5:6:5,   8-bit palette, unsigned normalized-  GL_PALETTE8_RGBA4_OES    -> Nothing -- 4-component 4:4:4:4, 8-bit palette, unsigned normalized-  GL_PALETTE8_RGB5_A1_OES  -> Nothing -- 4-component 5:5:5:1, 8-bit palette, unsigned normalized+  GL_PALETTE8_RGBA4_OES -> Nothing -- 4-component 4:4:4:4, 8-bit palette, unsigned normalized+  GL_PALETTE8_RGB5_A1_OES -> Nothing -- 4-component 5:5:5:1, 8-bit palette, unsigned normalized    --   -- Depth/stencil   ---  GL_DEPTH_COMPONENT16     -> Just Vk.FORMAT_D16_UNORM-  GL_DEPTH_COMPONENT24     -> Just Vk.FORMAT_X8_D24_UNORM_PACK32-  GL_DEPTH_COMPONENT32     -> Nothing-  GL_DEPTH_COMPONENT32F    -> Just Vk.FORMAT_D32_SFLOAT+  GL_DEPTH_COMPONENT16 -> Just Vk.FORMAT_D16_UNORM+  GL_DEPTH_COMPONENT24 -> Just Vk.FORMAT_X8_D24_UNORM_PACK32+  GL_DEPTH_COMPONENT32 -> Nothing+  GL_DEPTH_COMPONENT32F -> Just Vk.FORMAT_D32_SFLOAT   GL_DEPTH_COMPONENT32F_NV -> Just Vk.FORMAT_D32_SFLOAT-  GL_STENCIL_INDEX1        -> Nothing-  GL_STENCIL_INDEX4        -> Nothing-  GL_STENCIL_INDEX8        -> Just Vk.FORMAT_S8_UINT-  GL_STENCIL_INDEX16       -> Nothing-  GL_DEPTH24_STENCIL8      -> Just Vk.FORMAT_D24_UNORM_S8_UINT-  GL_DEPTH32F_STENCIL8     -> Just Vk.FORMAT_D32_SFLOAT_S8_UINT-  GL_DEPTH32F_STENCIL8_NV  -> Just Vk.FORMAT_D32_SFLOAT_S8_UINT-+  GL_STENCIL_INDEX1 -> Nothing+  GL_STENCIL_INDEX4 -> Nothing+  GL_STENCIL_INDEX8 -> Just Vk.FORMAT_S8_UINT+  GL_STENCIL_INDEX16 -> Nothing+  GL_DEPTH24_STENCIL8 -> Just Vk.FORMAT_D24_UNORM_S8_UINT+  GL_DEPTH32F_STENCIL8 -> Just Vk.FORMAT_D32_SFLOAT_S8_UINT+  GL_DEPTH32F_STENCIL8_NV -> Just Vk.FORMAT_D32_SFLOAT_S8_UINT   _ -> Nothing

@@ -0,0 +1,22 @@+{-| Init helpers for headless applications — no window, no surface, no+window-system instance extensions.+-}+module Vulkan.Utils.Init.Headless+  ( allocateInstance+  ) where++import Control.Monad.Trans.Resource (MonadResource)+import Vulkan.Core10 (ApplicationInfo, Instance)+import Vulkan.Requirement (InstanceRequirement)+import Vulkan.Utils.Initialization (allocateVulkanInstance)++{- | Build a Vulkan 'Instance' for a headless application. Equivalent to+@'allocateVulkanInstance' 'mempty'@.+-}+allocateInstance+  :: (MonadResource m)+  => Maybe ApplicationInfo+  -> [InstanceRequirement]+  -> [InstanceRequirement]+  -> m Instance+allocateInstance = allocateVulkanInstance mempty

@@ -1,46 +1,72 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedLists #-}  module Vulkan.Utils.Initialization   ( -- * Instance creation-    createInstanceFromRequirements-  , createDebugInstanceFromRequirements+    allocateInstanceFromRequirements+  , allocateDebugInstanceFromRequirements+  , allocateVulkanInstance++    -- * macOS portability+  , portabilityRequirements+  , portabilityFlags+  , devicePortabilityRequirements+     -- * Device creation-  , createDeviceFromRequirements-  , -- * Physical device selection-    pickPhysicalDevice+  , allocateDeviceFromRequirements++    -- * Physical device selection+  , pickPhysicalDevice   , physicalDeviceName++    -- * Deprecated aliases+  , createInstanceFromRequirements+  , createDebugInstanceFromRequirements+  , createDeviceFromRequirements   ) where -import           Control.Monad.IO.Class-import           Control.Monad.Trans.Resource-import           Data.Bits-import           Data.Foldable-import           Data.Maybe-import           Data.Ord-import           Data.Text                      ( Text )-import           Data.Text.Encoding             ( decodeUtf8 )-import           Vulkan.CStruct.Extends-import           Vulkan.Core10-import qualified Vulkan.Core10 as Instance      ( InstanceCreateInfo(..) )-import           Vulkan.Extensions.VK_EXT_debug_utils-import           Vulkan.Extensions.VK_EXT_validation_features-import           Vulkan.Requirement-import           Vulkan.Utils.Debug-import           Vulkan.Utils.Internal-import           Vulkan.Utils.Requirements-import           Vulkan.Zero+import Control.Monad.IO.Class+import Control.Monad.Trans.Resource+import Data.Bits+import Data.ByteString (ByteString)+import Data.Foldable+import Data.Maybe+import Data.Ord+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8)+import Data.Vector (Vector)+import Vulkan.CStruct.Extends+import Vulkan.Core10+import qualified Vulkan.Core10 as Instance (InstanceCreateInfo (..))+import Vulkan.Extensions.VK_EXT_debug_utils+import Vulkan.Extensions.VK_EXT_validation_features+import Vulkan.Requirement+import Vulkan.Utils.Debug+import Vulkan.Utils.Internal+import Vulkan.Utils.Requirements+import Vulkan.Zero +#if defined(darwin_HOST_OS)+import           Vulkan.Core10.Enums.InstanceCreateFlagBits+                                                ( pattern INSTANCE_CREATE_ENUMERATE_PORTABILITY_BIT_KHR )+import           Vulkan.Extensions.VK_KHR_portability_enumeration+                                                ( pattern KHR_PORTABILITY_ENUMERATION_EXTENSION_NAME )+import           Vulkan.Extensions.VK_KHR_portability_subset+                                                ( pattern KHR_PORTABILITY_SUBSET_EXTENSION_NAME )+#endif+ ---------------------------------------------------------------- -- Instance ---------------------------------------------------------------- --- | Like 'createInstanceFromRequirements' except it will create a debug utils--- messenger (from the @VK_EXT_debug_utils@ extension).------ If the @VK_EXT_validation_features@ extension (from the--- @VK_LAYER_KHRONOS_validation@ layer) is available is it will be enabled and--- best practices messages enabled.-createDebugInstanceFromRequirements+{- | Like 'allocateInstanceFromRequirements' except it will create a debug utils+messenger (from the @VK_EXT_debug_utils@ extension).++If the @VK_EXT_validation_features@ extension (from the+@VK_LAYER_KHRONOS_validation@ layer) is available is it will be enabled and+best practices messages enabled.+-}+allocateDebugInstanceFromRequirements   :: forall m es    . (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es)   => [InstanceRequirement]@@ -49,55 +75,63 @@   -- ^ Optional   -> InstanceCreateInfo es   -> m Instance-createDebugInstanceFromRequirements required optional baseCreateInfo = do-  let debugMessengerCreateInfo = zero-        { messageSeverity = DEBUG_UTILS_MESSAGE_SEVERITY_WARNING_BIT_EXT-                              .|. DEBUG_UTILS_MESSAGE_SEVERITY_ERROR_BIT_EXT-        , messageType     = DEBUG_UTILS_MESSAGE_TYPE_GENERAL_BIT_EXT-                            .|. DEBUG_UTILS_MESSAGE_TYPE_VALIDATION_BIT_EXT-                            .|. DEBUG_UTILS_MESSAGE_TYPE_PERFORMANCE_BIT_EXT+allocateDebugInstanceFromRequirements required optional baseCreateInfo = do+  let+    debugMessengerCreateInfo =+      zero+        { messageSeverity =+            DEBUG_UTILS_MESSAGE_SEVERITY_WARNING_BIT_EXT+              .|. DEBUG_UTILS_MESSAGE_SEVERITY_ERROR_BIT_EXT+        , messageType =+            DEBUG_UTILS_MESSAGE_TYPE_GENERAL_BIT_EXT+              .|. DEBUG_UTILS_MESSAGE_TYPE_VALIDATION_BIT_EXT+              .|. DEBUG_UTILS_MESSAGE_TYPE_PERFORMANCE_BIT_EXT         , pfnUserCallback = debugCallbackPtr         }-      validationFeatures =-        ValidationFeaturesEXT [VALIDATION_FEATURE_ENABLE_BEST_PRACTICES_EXT] []-      instanceCreateInfo-        :: InstanceCreateInfo-             (DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es)-      instanceCreateInfo = baseCreateInfo-        { Instance.next = debugMessengerCreateInfo-                       :& validationFeatures-                       :& Instance.next baseCreateInfo+    validationFeatures =+      ValidationFeaturesEXT [VALIDATION_FEATURE_ENABLE_BEST_PRACTICES_EXT] []+    instanceCreateInfo+      :: InstanceCreateInfo+           (DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es)+    instanceCreateInfo =+      baseCreateInfo+        { Instance.next =+            debugMessengerCreateInfo+              :& validationFeatures+              :& Instance.next baseCreateInfo         }-      additionalRequirements =-        [ RequireInstanceExtension-            { instanceExtensionLayerName  = Nothing-            , instanceExtensionName       = EXT_DEBUG_UTILS_EXTENSION_NAME-            , instanceExtensionMinVersion = minBound-            }-        ]-      additionalOptionalRequirements =-        [ RequireInstanceLayer-          { instanceLayerName       = "VK_LAYER_KHRONOS_validation"+    additionalRequirements =+      [ RequireInstanceExtension+          { instanceExtensionLayerName = Nothing+          , instanceExtensionName = EXT_DEBUG_UTILS_EXTENSION_NAME+          , instanceExtensionMinVersion = minBound+          }+      ]+    additionalOptionalRequirements =+      [ RequireInstanceLayer+          { instanceLayerName = "VK_LAYER_KHRONOS_validation"           , instanceLayerMinVersion = minBound           }-        , RequireInstanceExtension-          { instanceExtensionLayerName  = Just "VK_LAYER_KHRONOS_validation"-          , instanceExtensionName       = EXT_VALIDATION_FEATURES_EXTENSION_NAME+      , RequireInstanceExtension+          { instanceExtensionLayerName = Just "VK_LAYER_KHRONOS_validation"+          , instanceExtensionName = EXT_VALIDATION_FEATURES_EXTENSION_NAME           , instanceExtensionMinVersion = minBound           }-        ]-  inst <- createInstanceFromRequirements-    (additionalRequirements <> toList required)-    (additionalOptionalRequirements <> toList optional)-    instanceCreateInfo+      ]+  inst <-+    allocateInstanceFromRequirements+      (additionalRequirements <> toList required)+      (additionalOptionalRequirements <> toList optional)+      instanceCreateInfo   _ <- withDebugUtilsMessengerEXT inst debugMessengerCreateInfo Nothing allocate   pure inst --- | Create an 'Instance from some requirements.------ Will throw an 'IOError in the case of unsatisfied non-optional requirements.--- Unsatisfied requirements will be listed on stderr.-createInstanceFromRequirements+{- | Create an 'Instance from some requirements.++Will throw an 'IOError in the case of unsatisfied non-optional requirements.+Unsatisfied requirements will be listed on stderr.+-}+allocateInstanceFromRequirements   :: (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es)   => [InstanceRequirement]   -- ^ Required@@ -105,26 +139,101 @@   -- ^ Optional   -> InstanceCreateInfo es   -> m Instance-createInstanceFromRequirements required optional baseCreateInfo = do-  (mbICI, rrs, ors) <- checkInstanceRequirements required-                                                 optional-                                                 baseCreateInfo+allocateInstanceFromRequirements required optional baseCreateInfo = do+  (mbICI, rrs, ors) <-+    checkInstanceRequirements+      required+      optional+      baseCreateInfo   traverse_ sayErr (requirementReport rrs ors)   case mbICI of-    Nothing  -> liftIO $ unsatisfiedConstraints "Failed to create instance"+    Nothing -> liftIO $ unsatisfiedConstraints "Failed to create instance"     Just ici -> snd <$> withInstance ici Nothing allocate  ----------------------------------------------------------------+-- macOS portability + windowing-friendly instance creation+----------------------------------------------------------------++portabilityRequirements :: [InstanceRequirement]++{- | Instance create flag bits that pair with 'portabilityRequirements'.+'zero' on every non-macOS platform.+-}+portabilityFlags :: InstanceCreateFlags++{- | Device requirements needed on macOS: the Vulkan spec mandates that+@VK_KHR_portability_subset@ be enabled whenever a physical device advertises+it (as MoltenVK does). Empty on every other platform.+-}+devicePortabilityRequirements :: [DeviceRequirement]++#if defined(darwin_HOST_OS)+portabilityRequirements =+  [ RequireInstanceExtension+      { instanceExtensionLayerName  = Nothing+      , instanceExtensionName       = KHR_PORTABILITY_ENUMERATION_EXTENSION_NAME+      , instanceExtensionMinVersion = minBound+      }+  ]+portabilityFlags = INSTANCE_CREATE_ENUMERATE_PORTABILITY_BIT_KHR+devicePortabilityRequirements =+  [ RequireDeviceExtension+      { deviceExtensionLayerName  = Nothing+      , deviceExtensionName       = KHR_PORTABILITY_SUBSET_EXTENSION_NAME+      , deviceExtensionMinVersion = minBound+      }+  ]+#else+portabilityRequirements = []+portabilityFlags        = zero+devicePortabilityRequirements = []+#endif++{- | Build a Vulkan 'Instance' from a backend-supplied extension list plus+caller-supplied requirements. Automatically merges 'portabilityRequirements'+into the required list and 'portabilityFlags' into the create flags so+macOS apps work without per-call plumbing.++Pass 'mempty' for the extension list when running headless; or call+'Vulkan.Utils.Init.Headless.allocateInstance' which does so.+-}+allocateVulkanInstance+  :: (MonadResource m)+  => Vector ByteString+  {- ^ Backend-required instance extensions (e.g. from+  @Vulkan.Utils.Init.SDL2.getRequiredInstanceExtensions@). 'mempty' for+  headless.+  -}+  -> Maybe ApplicationInfo+  -> [InstanceRequirement]+  -- ^ Caller's required requirements+  -> [InstanceRequirement]+  -- ^ Caller's optional requirements+  -> m Instance+allocateVulkanInstance exts appInfo reqs optReqs =+  allocateInstanceFromRequirements+    (portabilityRequirements <> reqs)+    optReqs+    zero+      { applicationInfo = appInfo+      , enabledExtensionNames = exts+      , flags = portabilityFlags+      }++----------------------------------------------------------------+ -- * Device creation+ ---------------------------------------------------------------- --- | Create a 'Device' from some requirements.------ Will throw an 'IOError in the case of unsatisfied non-optional requirements.--- Unsatisfied requirements will be listed on stderr.-createDeviceFromRequirements+{- | Create a 'Device' from some requirements.++Will throw an 'IOError in the case of unsatisfied non-optional requirements.+Unsatisfied requirements will be listed on stderr.+-}+allocateDeviceFromRequirements   :: forall m-   . MonadResource m+   . (MonadResource m)   => [DeviceRequirement]   -- ^ Required   -> [DeviceRequirement]@@ -132,62 +241,106 @@   -> PhysicalDevice   -> DeviceCreateInfo '[]   -> m Device-createDeviceFromRequirements required optional phys baseCreateInfo = do-  (mbDCI, rrs, ors) <- checkDeviceRequirements required-                                               optional-                                               phys-                                               baseCreateInfo+allocateDeviceFromRequirements required optional phys baseCreateInfo = do+  (mbDCI, rrs, ors) <-+    checkDeviceRequirements+      (devicePortabilityRequirements <> required)+      optional+      phys+      baseCreateInfo   traverse_ sayErr (requirementReport rrs ors)   case mbDCI of     Nothing -> liftIO $ unsatisfiedConstraints "Failed to create instance"     Just (SomeStruct dci) -> snd <$> withDevice phys dci Nothing allocate  ----------------------------------------------------------------+ -- * Physical device selection+ ---------------------------------------------------------------- --- | Get a single 'PhysicalDevice' deciding with a scoring function------ Pass a function which will extract any required values from a device in the--- spirit of parse-don't-validate. Also provide a function to compare these--- results for sorting multiple suitable devices.------ As an example, the suitability function could return a tuple of device--- memory and the compute queue family index, and the scoring function could be--- 'fst' to select devices based on their memory capacity. Consider using--- 'Vulkan.Utils.QueueAssignment.assignQueues' to find your desired queues in--- the suitability function.------ Pehaps also use the functionality in 'Vulkan.Utils.Requirements' and return--- the 'DeviceCreateInfo' too.------ If no devices are deemed suitable then a 'NoSuchThing' 'IOError' is thrown.+{- | Get a single 'PhysicalDevice' deciding with a scoring function++Pass a function which will extract any required values from a device in the+spirit of parse-don't-validate. Also provide a function to compare these+results for sorting multiple suitable devices.++As an example, the suitability function could return a tuple of device+memory and the compute queue family index, and the scoring function could be+'fst' to select devices based on their memory capacity. Consider using+'Vulkan.Utils.QueueAssignment.assignQueues' to find your desired queues in+the suitability function.++Pehaps also use the functionality in 'Vulkan.Utils.Requirements' and return+the 'DeviceCreateInfo' too.++If no devices are deemed suitable then a 'NoSuchThing' 'IOError' is thrown.+-} pickPhysicalDevice   :: (MonadIO m, Ord b)   => Instance   -> (PhysicalDevice -> m (Maybe a))-  -- ^ A suitability funcion for a 'PhysicalDevice', 'Nothing' if it is not to-  -- be chosen.+  {- ^ A suitability funcion for a 'PhysicalDevice', 'Nothing' if it is not to+  be chosen.+  -}   -> (a -> b)   -- ^ Scoring function to rate this result   -> m (Maybe (a, PhysicalDevice))   -- ^ The score and the device pickPhysicalDevice inst devInfo score = do   (_, devs) <- enumeratePhysicalDevices inst-  infos     <- catMaybes-    <$> sequence [ fmap (, d) <$> devInfo d | d <- toList devs ]-  pure $ maximumByMay (comparing (score . fst)) infos+  infos <-+    catMaybes+      <$> sequence+        [ do+            isCPU <-+              (PHYSICAL_DEVICE_TYPE_CPU ==) . deviceType+                <$> getPhysicalDeviceProperties d+            if isCPU then pure Nothing else fmap (,d) <$> devInfo d+        | d <- toList devs+        ]+  pure $ maximumBy_ (comparing (score . fst)) infos  -- | Extract the name of a 'PhysicalDevice' with 'getPhysicalDeviceProperties'-physicalDeviceName :: MonadIO m => PhysicalDevice -> m Text+physicalDeviceName :: (MonadIO m) => PhysicalDevice -> m Text physicalDeviceName =   fmap (decodeUtf8 . deviceName) . getPhysicalDeviceProperties - ---------------------------------------------------------------- -- Utils ---------------------------------------------------------------- -maximumByMay :: Foldable t => (a -> a -> Ordering) -> t a -> Maybe a-maximumByMay f xs = if null xs then Nothing else Just (maximumBy f xs)+maximumBy_ :: (Foldable t) => (a -> a -> Ordering) -> t a -> Maybe a+maximumBy_ f xs = if null xs then Nothing else Just (maximumBy f xs) +----------------------------------------------------------------+-- Deprecated aliases+----------------------------------------------------------------++{-# DEPRECATED createInstanceFromRequirements "Renamed to allocateInstanceFromRequirements" #-}+createInstanceFromRequirements+  :: (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es)+  => [InstanceRequirement]+  -> [InstanceRequirement]+  -> InstanceCreateInfo es+  -> m Instance+createInstanceFromRequirements = allocateInstanceFromRequirements++{-# DEPRECATED createDebugInstanceFromRequirements "Renamed to allocateDebugInstanceFromRequirements" #-}+createDebugInstanceFromRequirements+  :: (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es)+  => [InstanceRequirement]+  -> [InstanceRequirement]+  -> InstanceCreateInfo es+  -> m Instance+createDebugInstanceFromRequirements = allocateDebugInstanceFromRequirements++{-# DEPRECATED createDeviceFromRequirements "Renamed to allocateDeviceFromRequirements" #-}+createDeviceFromRequirements+  :: (MonadResource m)+  => [DeviceRequirement]+  -> [DeviceRequirement]+  -> PhysicalDevice+  -> DeviceCreateInfo '[]+  -> m Device+createDeviceFromRequirements = allocateDeviceFromRequirements

@@ -1,14 +1,16 @@ module Vulkan.Utils.Internal where -import           Control.Monad.IO.Class-import           GHC.IO                         ( throwIO )-import           GHC.IO.Exception               ( IOErrorType(..)-                                                , IOException(..)-                                                )-import           System.IO                      ( hPutStrLn-                                                , stderr-                                                )+import Control.Monad.IO.Class+import GHC.IO (throwIO)+import GHC.IO.Exception+  ( IOErrorType (..)+  , IOException (..)+  ) import Language.Haskell.TH.Quote+import System.IO+  ( hPutStrLn+  , stderr+  )  ---------------------------------------------------------------- -- Internal utils@@ -22,15 +24,17 @@ noSuchThing message =   throwIO $ IOError Nothing NoSuchThing "" message Nothing Nothing -sayErr :: MonadIO m => String -> m ()+sayErr :: (MonadIO m) => String -> m () sayErr = liftIO . hPutStrLn stderr  badQQ :: String -> QuasiQuoter-badQQ name = QuasiQuoter (bad "expression")-                         (bad "pattern")-                         (bad "type")-                         (bad "declaration")- where-  bad :: String -> a-  bad context =-    error $ "Can't use " <> name <> " quote in a " <> context <> " context"+badQQ name =+  QuasiQuoter+    (bad "expression")+    (bad "pattern")+    (bad "type")+    (bad "declaration")+  where+    bad :: String -> a+    bad context =+      error $ "Can't use " <> name <> " quote in a " <> context <> " context"

@@ -2,23 +2,26 @@   ( -- * Sorting things     partitionOptReq   , partitionOptReqIO+     -- * Bit Utils   , showBits   , (.&&.)   ) where -import           Control.Monad.IO.Class-import           Data.Bits-import           Data.Foldable-import           Data.List                      ( intercalate-                                                , partition-                                                )-import           Vulkan.Utils.Internal+import Control.Monad.IO.Class+import Data.Bits+import Data.Foldable+import Data.List+  ( intercalate+  , partition+  )+import Vulkan.Utils.Internal --- | From a list of things, take all the required things and as many optional--- things as possible.+{- | From a list of things, take all the required things and as many optional+things as possible.+-} partitionOptReq-  :: Eq a+  :: (Eq a)   => [a]   -- ^ What do we have available   -> [a]@@ -26,23 +29,27 @@   -> [a]   -- ^ Required desired elements   -> ([a], Either [a] [a])-  -- ^ (Missing optional elements, Either (missing required elements) or (all-  -- required elements and as many optional elements as possible)+  {- ^ (Missing optional elements, Either (missing required elements) or (all+  required elements and as many optional elements as possible)+  -} partitionOptReq available optional required =-  let (optHave, optMissing) = partition (`elem` available) optional-      (reqHave, reqMissing) = partition (`elem` available) required-  in  ( optMissing-      , case reqMissing of+  let+    (optHave, optMissing) = partition (`elem` available) optional+    (reqHave, reqMissing) = partition (`elem` available) required+  in+    ( optMissing+    , case reqMissing of         [] -> Right (reqHave <> optHave)         xs -> Left xs-      )+    ) --- | Like 'partitionOptReq'.------ Will throw an 'IOError in the case of missing things. Details on missing--- things will be reported in stderr.------ This is useful in dealing with layers and extensions.+{- | Like 'partitionOptReq'.++Will throw an 'IOError in the case of missing things. Details on missing+things will be reported in stderr.++This is useful in dealing with layers and extensions.+-} partitionOptReqIO   :: (Show a, Eq a, MonadIO m)   => String@@ -53,50 +60,54 @@   -- ^ Optional desired elements   -> [a]   -- ^ Required desired elements-  -> m ([a],[a])-  -- ^ All the required elements and as many optional elements as possible,-  --   as well as the missing optional elements.+  -> m ([a], [a])+  {- ^ All the required elements and as many optional elements as possible,+  as well as the missing optional elements.+  -} partitionOptReqIO type' available optional required = liftIO $ do   let (optMissing, exts) = partitionOptReq available optional required-  for_ optMissing-    $ \o -> sayErr $ "Missing optional " <> type' <> ": " <> show o+  for_ optMissing $+    \o -> sayErr $ "Missing optional " <> type' <> ": " <> show o   case exts of     Left reqMissing -> do-      for_ reqMissing-        $ \r -> sayErr $ "Missing required " <> type' <> ": " <> show r+      for_ reqMissing $+        \r -> sayErr $ "Missing required " <> type' <> ": " <> show r       noSuchThing $ "Don't have all required " <> type' <> "s"     Right xs -> pure (xs, optMissing)  ----------------------------------------------------------------+ -- * Bit utils+ ---------------------------------------------------------------- --- | Show valies as a union of their individual bits------ >>> showBits @Int 5--- "1 .|. 4"------ >>> showBits @Int 0--- "zeroBits"------ >>> import Vulkan.Core10.Enums.QueueFlagBits--- >>> showBits (QUEUE_COMPUTE_BIT .|. QUEUE_GRAPHICS_BIT)--- "QUEUE_GRAPHICS_BIT .|. QUEUE_COMPUTE_BIT"-showBits :: forall a . (Show a, FiniteBits a) => a -> String-showBits a = if a == zeroBits-  then "zeroBits"-  else intercalate " .|. " $ fmap show (setBits a)+{- | Show valies as a union of their individual bits --- | The list of bits which are set-setBits :: FiniteBits a => a -> [a]+>>> showBits @Int 5+"1 .|. 4"++>>> showBits @Int 0+"zeroBits"++>>> import Vulkan.Core10.Enums.QueueFlagBits+>>> showBits (QUEUE_COMPUTE_BIT .|. QUEUE_GRAPHICS_BIT)+"QUEUE_GRAPHICS_BIT .|. QUEUE_COMPUTE_BIT"+-}+showBits :: forall a. (Show a, FiniteBits a) => a -> String+showBits a =+  if a == zeroBits+    then "zeroBits"+    else intercalate " .|. " $ fmap show (setBits a)++setBits :: (FiniteBits a) => a -> [a] setBits a =   [ b   | -- lol, is this really necessary-    p <- [countTrailingZeros a .. finiteBitSize a - countLeadingZeros a - 1]+  p <- [countTrailingZeros a .. finiteBitSize a - countLeadingZeros a - 1]   , let b = bit p   , a .&&. b   ]  -- | Check if the intersection of bits is non-zero-(.&&.) :: Bits a => a -> a -> Bool+(.&&.) :: (Bits a) => a -> a -> Bool x .&&. y = (x .&. y) /= zeroBits

@@ -0,0 +1,161 @@+{-# LANGUAGE NoFieldSelectors #-}++{-| A pipeline bundled with everything needed to drive it.++'Layout' keeps, next to the created handles, the inputs they were created from:+the per-set 'Vk.DescriptorSetLayoutCreateInfo's and the push-constant ranges.+Descriptor-set allocation and push recording need exactly those — 'allocateSet'+sizes its pool from the kept set info and 'push' takes its stage flags and byte+count from the kept range — so neither is hand-counted at call sites, where it+drifts from the shaders. The infos can be hand written or reflected from SPIR-V+("Vulkan.Utils.SpirV.Pipeline" in @vulkan-utils-spirv@ produces these types).++Designed for qualified import:++@+import Vulkan.Utils.Pipeline (Pipeline)+import qualified Vulkan.Utils.Pipeline as Pipeline++Pipeline.bind cb pl+Pipeline.push cb pl params+set <- Pipeline.allocateSet dev pl 0+Pipeline.bindSet cb pl 0 set+@+-}+module Vulkan.Utils.Pipeline+  ( Pipeline (..)+  , allocateSet+  , bind+  , bindSet+  , push+  , Layout (..)+  , allocateLayout+  , set+  , Set (..)+  , allocateSetLayout+  , allocateDescriptorSet+  , allocateDescriptorSets+  ) where++import Control.Monad (guard, unless)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, allocate)+import qualified Data.Vector as V+import Data.Word (Word32)+import Foreign.Marshal.Utils (with)+import Foreign.Ptr (castPtr)+import Foreign.Storable (Storable, sizeOf)+import qualified Vulkan.Core10 as Vk+import Vulkan.Zero (zero)++-- | A pipeline with its bind point and 'Layout', ready to bind, push and feed sets.+data Pipeline = Pipeline+  { pipeline :: Vk.Pipeline+  , bindPoint :: Vk.PipelineBindPoint+  , layout :: Layout+  }++bind :: (MonadIO m) => Vk.CommandBuffer -> Pipeline -> m ()+bind cb pl = Vk.cmdBindPipeline cb pl.bindPoint pl.pipeline++-- | Bind one descriptor set at @setNo@, via the pipeline's bind point and layout.+bindSet :: (MonadIO m) => Vk.CommandBuffer -> Pipeline -> Word32 -> Vk.DescriptorSet -> m ()+bindSet cb pl setNo s =+  Vk.cmdBindDescriptorSets cb pl.bindPoint pl.layout.pipelineLayout setNo (V.singleton s) V.empty++{- | Push @a@ as the layout's single push-constant range: its stage flags, its size.++The range's size is what the layout accepts — often less than @a@'s 'Foreign.Storable.sizeOf'+(std430 blocks trailing-pad) — so exactly that many of @a@'s leading bytes are+pushed; a value too small to cover the range is an error, not an out-of-bounds+read. Layouts with several ranges (or a range off 0) need 'Vk.cmdPushConstants'+directly.+-}+push :: (Storable a, MonadIO m) => Vk.CommandBuffer -> Pipeline -> a -> m ()+push cb pl x = case pl.layout.pushRanges of+  [r]+    | r.offset == 0+    , fromIntegral r.size <= sizeOf x ->+        liftIO $ with x $ \p ->+          Vk.cmdPushConstants cb pl.layout.pipelineLayout r.stageFlags 0 r.size (castPtr p)+    | r.offset == 0 ->+        error ("Pipeline.push: the value's " <> show (sizeOf x) <> " bytes don't cover the " <> show r.size <> "-byte range")+  rs -> error ("Pipeline.push: expected a single range at offset 0, got " <> show rs)++-- | A descriptor set layout, kept with the info it was created from.+data Set = Set+  { layout :: Vk.DescriptorSetLayout+  , info :: Vk.DescriptorSetLayoutCreateInfo '[]+  }++-- | Create the set layout, keeping its info for 'allocateDescriptorSet' pool sizing.+allocateSetLayout :: (MonadResource m) => Vk.Device -> Vk.DescriptorSetLayoutCreateInfo '[] -> m Set+allocateSetLayout dev info = do+  (_, layout) <- Vk.withDescriptorSetLayout dev info Nothing allocate+  pure Set{layout, info}++{- | One descriptor set of the layout, from its own throwaway pool.++The pool is provisioned from the kept info's bindings, so it tracks whatever the+layout holds. It owns just this set and is released with @m@'s+'Control.Monad.Trans.Resource.ResourceT'.+-}+allocateDescriptorSet :: (MonadResource m) => Vk.Device -> Set -> m Vk.DescriptorSet+allocateDescriptorSet dev s = V.head . snd <$> allocateDescriptorSets dev s 1++{- | @count@ descriptor sets of the layout, from one throwaway pool.++The key releases the pool and with it every set — for sets bound to recreated+resources (a swapchain's image views).+-}+allocateDescriptorSets :: (MonadResource m) => Vk.Device -> Set -> Int -> m (ReleaseKey, V.Vector Vk.DescriptorSet)+allocateDescriptorSets dev s count = do+  (key, pool) <- Vk.withDescriptorPool dev zero{Vk.maxSets = fromIntegral count, Vk.poolSizes = poolSizes} Nothing allocate+  sets <- Vk.allocateDescriptorSets dev zero{Vk.descriptorPool = pool, Vk.setLayouts = V.replicate count s.layout}+  pure (key, sets)+  where+    -- Runtime-sized bindings reflect as count 0, and a zero pool size is invalid;+    -- variable-count allocation is out of scope here, so skip them.+    poolSizes = do+      b <- s.info.bindings+      guard (b.descriptorCount > 0)+      pure $ Vk.DescriptorPoolSize b.descriptorType (b.descriptorCount * fromIntegral count)++-- | A pipeline layout, kept with its sets (by set number) and push-constant ranges.+data Layout = Layout+  { pipelineLayout :: Vk.PipelineLayout+  , sets :: [(Word32, Set)]+  , pushRanges :: [Vk.PushConstantRange]+  }++{- | Create the pipeline layout over the sets' layouts and the ranges.++Sharing a 'Set' between layouts keeps them set-compatible on that number. Set+numbers must be contiguous from 0 (pad gaps with empty sets) — 'bindSet'+addresses sets by number, which has to agree with the layout's slot order — and+anything else 'fail's here rather than misbinding at record time.+-}+allocateLayout :: (MonadResource m, MonadFail m) => Vk.Device -> [(Word32, Set)] -> [Vk.PushConstantRange] -> m Layout+allocateLayout dev sets pushRanges = do+  unless (map fst sets == take (length sets) [0 ..]) $+    fail ("Pipeline.allocateLayout: set numbers must be contiguous from 0, got " <> show (map fst sets))+  (_, pipelineLayout) <-+    Vk.withPipelineLayout+      dev+      zero+        { Vk.setLayouts = V.fromList [s.layout | (_, s) <- sets]+        , Vk.pushConstantRanges = V.fromList pushRanges+        }+      Nothing+      allocate+  pure Layout{pipelineLayout, sets, pushRanges}++-- | The layout's set at @setNo@; 'fail's if there is none.+set :: (MonadFail m) => Layout -> Word32 -> m Set+set l setNo = case lookup setNo l.sets of+  Just s -> pure s+  Nothing -> fail ("Pipeline.set: no set " <> show setNo <> " in layout (sets: " <> show (map fst l.sets) <> ")")++-- | 'allocateDescriptorSet' for the pipeline's set @setNo@.+allocateSet :: (MonadResource m, MonadFail m) => Vk.Device -> Pipeline -> Word32 -> m Vk.DescriptorSet+allocateSet dev pl setNo = set pl.layout setNo >>= allocateDescriptorSet dev

@@ -0,0 +1,185 @@+{-# LANGUAGE OverloadedLists #-}++{-| Shared graphics-pipeline construction behind the two rendering paths,+"Vulkan.Utils.RenderPass" and "Vulkan.Utils.DynamicRendering". Not meant for+direct use — import one of those modules instead.++The only difference between the paths is whether the pipeline references a+'Vk.RenderPass' or carries a @PipelineRenderingCreateInfo@ in its pNext chain,+so everything else (the vanilla rasterizer/blend/dynamic-state config, the+transient empty layout, the shader-module lifetime) lives here once.+-}+module Vulkan.Utils.Pipeline.Internal+  ( basePipelineCreateInfo+  , buildColorPipeline+  , withCompiledStages+  ) where++import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, allocate, release)+import Data.Bits ((.|.))+import Data.ByteString (ByteString)+import Data.Foldable (traverse_)+import Data.Maybe (fromMaybe)+import Data.Vector (Vector)+import qualified Data.Vector as V+import Vulkan.CStruct.Extends (SomeStruct (..))+import qualified Vulkan.Core10 as Vk+import Vulkan.Utils.Pipeline.Specialization (Specialization, withSpecialization)+import Vulkan.Utils.Shader (shaderModuleStage)+import Vulkan.Zero (zero)++{- | The shared body of the vanilla graphics pipeline: the given @dynamicStates@,+@colorAttachmentCount@ identical non-blended color attachments, an optional+depth-stencil state, and empty vertex input. The static values left in the+create-info (cull mode, topology, …) are the baked defaults for any state not+listed dynamic; states that are listed dynamic ignore them, so callers MUST emit+the matching @cmdSet*@ before drawing.++The colour and depth shape MUST match the attachments the pipeline renders to —+the render pass (render-pass path) or the @PipelineRenderingCreateInfo@ formats+(dynamic-rendering path):++  * @colorAttachmentCount == 0@ omits @colorBlendState@ entirely (a depth-only+    pipeline); otherwise one RGBA, non-blended attachment per colour target.+  * @depth@ adds a zeroed @depthStencilState@ — present (non-NULL) is required+    whenever a depth attachment is used; the actual test config is dynamic, so a+    zeroed struct is correct.++Pass @Just@ the target render pass (render-pass path), or @Nothing@ and attach+a @PipelineRenderingCreateInfo@ to the returned struct's pNext chain+(dynamic-rendering path).+-}+basePipelineCreateInfo+  :: Vk.PipelineLayout+  -> Maybe Vk.RenderPass+  -> Int+  -- ^ Colour attachment count (blend attachments); @0@ for depth-only.+  -> Bool+  -- ^ Whether a depth attachment is present.+  -> Vk.PipelineVertexInputStateCreateInfo '[]+  -- ^ Vertex input (bindings + attributes); @zero@ for none.+  -> Vector Vk.DynamicState+  -> Vector (SomeStruct Vk.PipelineShaderStageCreateInfo)+  -> Vk.GraphicsPipelineCreateInfo '[]+basePipelineCreateInfo pipelineLayout renderPass colorAttachmentCount depth vertexInput dynamicStates' stages =+  zero+    { Vk.stages = stages+    , Vk.vertexInputState = Just (SomeStruct vertexInput)+    , Vk.inputAssemblyState =+        Just+          zero+            { Vk.topology = Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST+            , Vk.primitiveRestartEnable = False+            }+    , Vk.viewportState =+        Just $+          SomeStruct+            zero+              { -- The counts MUST be zero when the matching @*_WITH_COUNT@ state+                -- is dynamic (set then via @cmdSetViewportWithCount@); otherwise+                -- the static count stands (plain @VIEWPORT@/@SCISSOR@ only swap+                -- the values). VUID-VkGraphicsPipelineCreateInfo-pDynamicStates-03379/03380.+                Vk.viewportCount =+                  if Vk.DYNAMIC_STATE_VIEWPORT_WITH_COUNT `V.elem` dynamicStates' then 0 else 1+              , Vk.scissorCount =+                  if Vk.DYNAMIC_STATE_SCISSOR_WITH_COUNT `V.elem` dynamicStates' then 0 else 1+              }+    , Vk.rasterizationState =+        Just $+          SomeStruct+            zero+              { Vk.depthClampEnable = False+              , Vk.rasterizerDiscardEnable = False+              , Vk.lineWidth = 1+              , Vk.polygonMode = Vk.POLYGON_MODE_FILL+              , Vk.cullMode = Vk.CULL_MODE_NONE+              , Vk.frontFace = Vk.FRONT_FACE_COUNTER_CLOCKWISE+              , Vk.depthBiasEnable = False+              }+    , Vk.multisampleState =+        Just $+          SomeStruct+            zero+              { Vk.sampleShadingEnable = False+              , Vk.rasterizationSamples = Vk.SAMPLE_COUNT_1_BIT+              , Vk.minSampleShading = 1+              , Vk.sampleMask = [maxBound]+              }+    , Vk.depthStencilState =+        if depth then Just zero else Nothing+    , Vk.colorBlendState =+        if colorAttachmentCount == 0+          then Nothing+          else+            Just $+              SomeStruct+                zero+                  { Vk.logicOpEnable = False+                  , Vk.attachments = V.replicate colorAttachmentCount colorBlendAttachment+                  }+    , Vk.dynamicState = Just zero{Vk.dynamicStates = dynamicStates'}+    , Vk.layout = pipelineLayout+    , Vk.renderPass = fromMaybe Vk.NULL_HANDLE renderPass+    , Vk.subpass = 0+    , Vk.basePipelineHandle = zero+    }+  where+    colorBlendAttachment :: Vk.PipelineColorBlendAttachmentState+    colorBlendAttachment =+      zero+        { Vk.colorWriteMask =+            Vk.COLOR_COMPONENT_R_BIT+              .|. Vk.COLOR_COMPONENT_G_BIT+              .|. Vk.COLOR_COMPONENT_B_BIT+              .|. Vk.COLOR_COMPONENT_A_BIT+        , Vk.blendEnable = False+        }++{- | Build a single graphics pipeline from the given create-info builder. With+'Nothing', a transient empty pipeline layout is allocated and freed after the+build (the historical behaviour: no descriptor sets, no push constants); with+@Just layout@, the caller's layout is used and remains owned (and kept alive)+by the caller. The returned 'ReleaseKey' frees the pipeline.+-}+buildColorPipeline+  :: (MonadResource m, MonadFail m)+  => Vk.Device+  -> Maybe Vk.PipelineLayout+  -> (Vk.PipelineLayout -> SomeStruct Vk.GraphicsPipelineCreateInfo)+  -> m (ReleaseKey, Vk.Pipeline)+buildColorPipeline dev layout mkCreateInfo = case layout of+  Just pipelineLayout -> build pipelineLayout+  Nothing -> do+    (layoutKey, pipelineLayout) <- Vk.withPipelineLayout dev zero Nothing allocate+    built <- build pipelineLayout+    release layoutKey+    pure built+  where+    build pipelineLayout = do+      (key, (_, [pipeline])) <-+        Vk.withGraphicsPipelines dev zero [mkCreateInfo pipelineLayout] Nothing allocate+      pure (key, pipeline)++{- | Compile each @(stage, SPIR-V)@ pair into a shader module, run the+continuation with the resulting stages, then release the now-redundant+module handles. Shader modules are only needed during pipeline creation, so+the continuation typically returns the built pipeline.+-}+withCompiledStages+  :: (MonadResource m, MonadUnliftIO m, Specialization spec)+  => Vk.Device+  -> spec+  -> [(Vk.ShaderStageFlagBits, ByteString)]+  -> (Vector (SomeStruct Vk.PipelineShaderStageCreateInfo) -> m a)+  -> m a+withCompiledStages dev spec shaders k =+  withSpecialization spec $ \specializationInfo -> do+    compiled <-+      traverse+        (\(stage, code) -> shaderModuleStage dev stage specializationInfo code)+        shaders+    let (keys, stages) = unzip compiled+    result <- k (V.fromList stages)+    traverse_ release keys+    pure result

@@ -0,0 +1,234 @@+{-|+Specialization constants, normalized to stacks of 32-bit units.+++@+data MySpec = MySpec { width :: Word32, height :: Word32, scale :: Float }+instance Specialization MySpec where -- ... pack the fields++withSpecialization sp \\mSpec ->+  -- build a 'Vulkan.Core10.PipelineShaderStageCreateInfo' with+  --   specializationInfo = mSpec+  ...+@+-}+module Vulkan.Utils.Pipeline.Specialization+  ( withSpecialization+  , allocateSpecialization+  , Specialization (..)+  , SpecializationConst (..)+  ) where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)+import Control.Monad.Trans.Resource (MonadResource, allocate)+import Data.Bool (bool)+import Data.Int (Int32)+import Data.Vector (Vector)+import qualified Data.Vector as Vector+import qualified Data.Vector.Storable as Storable+import Data.Word (Word32)+import Foreign.Marshal.Alloc (free)+import Foreign.Marshal.Array (mallocArray, pokeArray)+import Foreign.Ptr (castPtr)+import GHC.Float (castFloatToWord32)+import qualified Vulkan.Core10 as Vk++{- | Provide a 'Vk.SpecializationInfo' describing @spec@ to the callback.++The info (and the buffer its @data'@ pointer references) is valid only for the+duration of the callback, which is exactly the window in which it needs to live:+pipeline creation copies the constant values out. Build and create the pipeline+inside the continuation.++An empty specialization (e.g. @()@ or an empty list) yields 'Nothing', so the+shader stage's @specializationInfo@ stays unset.+-}+withSpecialization+  :: (Specialization spec, MonadUnliftIO m)+  => spec+  -> (Maybe Vk.SpecializationInfo -> m a)+  -> m a+withSpecialization spec action =+  if Storable.null specData+    then+      action Nothing+    else withRunInIO $ \run ->+      Storable.unsafeWith specData $ \specPtr ->+        run . action $+          Just+            Vk.SpecializationInfo+              { Vk.mapEntries = mapEntries+              , Vk.dataSize = fromIntegral $ Storable.length specData * 4+              , Vk.data' = castPtr specPtr+              }+  where+    specData :: Storable.Vector Word32+    specData = Storable.fromList (specializationData spec)++    mapEntries :: Vector Vk.SpecializationMapEntry+    mapEntries = specializationMapEntries (Storable.length specData)++{- | Pack a specialization into a buffer tied to the current resource scope,+yielding the 'Vk.SpecializationInfo' to embed in a shader stage's+@specializationInfo@.++Unlike 'withSpecialization' this is not continuation-scoped: the backing buffer+lives until the surrounding 'Control.Monad.Trans.Resource.ResourceT' block ends,+so it survives a later pipeline creation. An empty specialization (e.g. @()@)+yields 'Nothing'.+-}+allocateSpecialization+  :: (Specialization spec, MonadResource m)+  => spec+  -> m (Maybe Vk.SpecializationInfo)+allocateSpecialization spec =+  case specializationData spec of+    [] ->+      pure Nothing+    ws -> do+      let n = length ws+      -- A C-malloc'd buffer is pointer-stable and freed at scope end; the+      -- pointer must stay valid until pipeline creation copies the values.+      (_key, ptr) <- allocate (mallocArray n) free+      liftIO $ pokeArray ptr ws+      pure $+        Just+          Vk.SpecializationInfo+            { Vk.mapEntries = specializationMapEntries n+            , Vk.dataSize = fromIntegral (n * 4)+            , Vk.data' = castPtr ptr+            }++-- | One 32-bit @constantID = offset/4@ entry per slot, counting from zero.+specializationMapEntries :: Int -> Vector Vk.SpecializationMapEntry+specializationMapEntries n =+  Vector.generate n $ \ix ->+    Vk.SpecializationMapEntry+      { Vk.constantID = fromIntegral ix+      , Vk.offset = fromIntegral (ix * 4)+      , Vk.size = 4+      }++{- | A value that flattens to a stack of 32-bit specialization constants, in+@constant_id@ order starting from zero.+-}+class Specialization a where+  specializationData :: a -> [Word32]++instance Specialization () where+  specializationData _ = []++-- | Pre-packed constants, used as-is.+instance Specialization [Word32] where+  specializationData = id++instance Specialization Word32 where+  specializationData x = [packConstData x]++instance Specialization Int32 where+  specializationData x = [packConstData x]++instance Specialization Float where+  specializationData x = [packConstData x]++instance Specialization Bool where+  specializationData x = [packConstData x]++{- | A single scalar specialization constant, reinterpreted into its 32-bit+representation.++Per the @GL_KHR_vulkan_glsl@ spec a @constant_id@ may only decorate a scalar+@int@, @float@ or @bool@; @uint@ works in practice too. All of these are 32 bits+wide.+-}+class SpecializationConst a where+  packConstData :: a -> Word32++instance SpecializationConst Word32 where+  packConstData = id++-- | Two's-complement bit pattern, preserved by 'fromIntegral' at the same width.+instance SpecializationConst Int32 where+  packConstData = fromIntegral++instance SpecializationConst Float where+  packConstData = castFloatToWord32++instance SpecializationConst Bool where+  packConstData = bool 0 1++instance+  ( SpecializationConst a+  , SpecializationConst b+  )+  => Specialization (a, b)+  where+  specializationData (a, b) =+    [ packConstData a+    , packConstData b+    ]++instance+  ( SpecializationConst a+  , SpecializationConst b+  , SpecializationConst c+  )+  => Specialization (a, b, c)+  where+  specializationData (a, b, c) =+    [ packConstData a+    , packConstData b+    , packConstData c+    ]++instance+  ( SpecializationConst a+  , SpecializationConst b+  , SpecializationConst c+  , SpecializationConst d+  )+  => Specialization (a, b, c, d)+  where+  specializationData (a, b, c, d) =+    [ packConstData a+    , packConstData b+    , packConstData c+    , packConstData d+    ]++instance+  ( SpecializationConst a+  , SpecializationConst b+  , SpecializationConst c+  , SpecializationConst d+  , SpecializationConst e+  )+  => Specialization (a, b, c, d, e)+  where+  specializationData (a, b, c, d, e) =+    [ packConstData a+    , packConstData b+    , packConstData c+    , packConstData d+    , packConstData e+    ]++instance+  ( SpecializationConst a+  , SpecializationConst b+  , SpecializationConst c+  , SpecializationConst d+  , SpecializationConst e+  , SpecializationConst f+  )+  => Specialization (a, b, c, d, e, f)+  where+  specializationData (a, b, c, d, e, f) =+    [ packConstData a+    , packConstData b+    , packConstData c+    , packConstData d+    , packConstData e+    , packConstData f+    ]

@@ -0,0 +1,84 @@+{-# LANGUAGE NoFieldSelectors #-}++{-| Assemble a pipeline's descriptor-set-layout bindings and push-constant ranges+from the per-stage contributions of several shaders.++A binding (or push-constant range) declared by more than one stage must become a+single entry whose 'Vk.stageFlags' is the OR of the contributing stages — that is+what a pipeline layout shared between, say, a vertex and a fragment shader needs.+'mergeDescriptorSetLayoutBindings' and 'mergePushConstantRanges' do that merge on+plain Vulkan values, independent of where the per-stage bindings came from (hand+written, or reflected — see @vulkan-utils-spirv@).+-}+module Vulkan.Utils.PipelineLayout+  ( mergeDescriptorSetLayoutBindings+  , mergePushConstantRanges+  , DescriptorBindingConflict (..)+  ) where++import Control.Monad (foldM)+import Data.Bits ((.|.))+import Data.Foldable (foldl')+import qualified Data.Map.Strict as Map+import Data.Word (Word32)+import qualified Vulkan.Core10 as Vk+import Vulkan.Zero (zero)++{- | Two stages declared the same binding number with different descriptor types,+which cannot be reconciled into one binding.+-}+data DescriptorBindingConflict = DescriptorBindingConflict+  { binding :: Word32+  -- ^ The binding number the stages disagree on.+  , types :: (Vk.DescriptorType, Vk.DescriptorType)+  -- ^ The two differing descriptor types.+  }+  deriving (Eq, Show)++{- | Merge the descriptor-set-layout bindings contributed by several stages for a+single descriptor set. Bindings sharing a binding number are combined: their+'Vk.stageFlags' are OR-ed and their 'Vk.descriptorCount's maxed. A+'Vk.descriptorType' disagreement is a 'Left'. The result is ascending by+binding number.++Each input binding should carry the one stage that declares it (its+'Vk.stageFlags' set to that stage); the merge turns the per-stage bindings+into one multi-stage binding per binding number.+-}+mergeDescriptorSetLayoutBindings+  :: (Foldable f)+  => f Vk.DescriptorSetLayoutBinding+  -> Either DescriptorBindingConflict [Vk.DescriptorSetLayoutBinding]+mergeDescriptorSetLayoutBindings bindings =+  fmap (fmap snd . Map.toAscList) (foldM step Map.empty bindings)+  where+    step acc b = case Map.lookup b.binding acc of+      Nothing -> Right (Map.insert b.binding b acc)+      Just b0 -> (\b' -> Map.insert b.binding b' acc) <$> combine b0 b++    combine b0 b1+      | t0 /= t1 = Left (DescriptorBindingConflict b0.binding (t0, t1))+      | otherwise =+          Right+            ( b0+                { Vk.stageFlags = b0.stageFlags .|. b1.stageFlags+                , Vk.descriptorCount = max b0.descriptorCount b1.descriptorCount+                }+            )+      where+        t0 = b0.descriptorType+        t1 = b1.descriptorType++{- | Merge the push-constant ranges contributed by several stages: ranges sharing+the same @(offset, size)@ have their 'Vk.stageFlags' OR-ed. The result is+ascending by offset.+-}+mergePushConstantRanges+  :: (Foldable f) => f Vk.PushConstantRange -> [Vk.PushConstantRange]+mergePushConstantRanges ranges =+  [ zero{Vk.stageFlags = stage, Vk.offset = off, Vk.size = sz}+  | ((off, sz), stage) <- Map.toAscList byRange+  ]+  where+    byRange = foldl' add Map.empty ranges+    add m r = Map.insertWith (.|.) (r.offset, r.size) r.stageFlags m

@@ -1,9 +1,10 @@ module Vulkan.Utils.QueueAssignment   ( assignQueues-  , QueueSpec(..)-  , QueueFamilyIndex(..)-  , QueueIndex(..)-  -- * Queue Family Predicates+  , QueueSpec (..)+  , QueueFamilyIndex (..)+  , QueueIndex (..)++    -- * Queue Family Predicates   , isComputeQueueFamily   , isGraphicsQueueFamily   , isTransferQueueFamily@@ -11,89 +12,91 @@   , isPresentQueueFamily   ) where -import           Control.Applicative-import           Control.Category               ( (>>>) )-import           Control.Monad                  ( filterM )-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Class      ( MonadTrans(lift) )-import           Control.Monad.Trans.Maybe-import           Control.Monad.Trans.State.Strict-                                                ( evalState-                                                , evalStateT-                                                , get-                                                , put-                                                )-import           Data.Bits-import           Data.Foldable-import           Data.Functor                   ( (<&>) )-import           Data.Traversable-import qualified Data.Vector                   as V-import           Data.Vector                    ( Vector )-import           Data.Word-import           GHC.Stack                      ( HasCallStack )-import           Vulkan.Core10-import           Vulkan.Extensions.VK_KHR_surface-                                                ( SurfaceKHR-                                                , getPhysicalDeviceSurfaceSupportKHR-                                                )-import           Vulkan.Utils.Misc-import           Vulkan.Zero+import Control.Applicative+import Control.Category ((>>>))+import Control.Monad (filterM)+import Control.Monad.IO.Class+import Control.Monad.Trans.Class (MonadTrans (lift))+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.State.Strict+  ( evalState+  , evalStateT+  , get+  , put+  )+import Data.Bits+import Data.Foldable+import Data.Functor ((<&>))+import Data.Traversable+import Data.Vector (Vector)+import qualified Data.Vector as V+import Data.Word+import GHC.Stack (HasCallStack)+import Vulkan.Core10+import Vulkan.Extensions.VK_KHR_surface+  ( SurfaceKHR+  , getPhysicalDeviceSurfaceSupportKHR+  )+import Vulkan.Utils.Misc+import Vulkan.Zero  ---------------------------------------------------------------- -- Device Queue creation ---------------------------------------------------------------- --- | Requirements for a 'Queue' to be assigned a family by 'assignQueues'.------ To assign to a specific queue family index @f@:------ @--- queueSpecFamilyPredicate = \i _ -> i == f--- @------ To assign to any queue family which supports compute operations:------ @--- let isComputeQueue q = QUEUE_COMPUTE_BIT .&&. queueFlags q--- in QueueSpec priority (\_index q -> pure (isComputeQueue q))--- @+{- | Requirements for a 'Queue' to be assigned a family by 'assignQueues'.++To assign to a specific queue family index @f@:++@+queueSpecFamilyPredicate = \i _ -> i == f+@++To assign to any queue family which supports compute operations:++@+let isComputeQueue q = QUEUE_COMPUTE_BIT .&&. queueFlags q+in QueueSpec priority (\_index q -> pure (isComputeQueue q))+@+-} data QueueSpec m = QueueSpec   { queueSpecQueuePriority :: Float   , queueSpecFamilyPredicate       :: QueueFamilyIndex -> QueueFamilyProperties -> m Bool   } -newtype QueueFamilyIndex = QueueFamilyIndex { unQueueFamilyIndex :: Word32 }+newtype QueueFamilyIndex = QueueFamilyIndex {unQueueFamilyIndex :: Word32}   deriving (Eq, Ord, Enum, Show) -newtype QueueIndex = QueueIndex { unQueueIndex :: Word32 }+newtype QueueIndex = QueueIndex {unQueueIndex :: Word32}   deriving (Eq, Ord, Enum, Show) --- | Given a 'PhysicalDevice' and a set of requirements for queues, calculate an--- assignment of queues to queue families and return information with which to--- create a 'Device' and also a function to extract the requested 'Queue's from--- the device.------ You may want to create a custom type with a 'Traversable' instance to store--- your queues like:------ @--- data MyQueues q = MyQueues---   { computeQueue            :: q---   , graphicsAndPresentQueue :: q---   , transferQueue           :: q---   }------ myQueueSpecs :: MyQueues QueueSpec--- myQueueSpecs = MyQueues---   { computeQueue            = QueueSpec 0.5 isComputeQueueFamily---   , graphicsAndPresentQueue = QueueSpec 1   isPresentQueueFamily---   , transferQueue           = QueueSpec 1   isTransferOnlyQueueFamily---   }--- @------ Note, this doesn't permit differentiating queue family assignment based on--- whether or not the queue is protected.+{- | Given a 'PhysicalDevice' and a set of requirements for queues, calculate an+assignment of queues to queue families and return information with which to+create a 'Device' and also a function to extract the requested 'Queue's from+the device.++You may want to create a custom type with a 'Traversable' instance to store+your queues like:++@+data MyQueues q = MyQueues+  { computeQueue            :: q+  , graphicsAndPresentQueue :: q+  , transferQueue           :: q+  }++myQueueSpecs :: MyQueues QueueSpec+myQueueSpecs = MyQueues+  { computeQueue            = QueueSpec 0.5 isComputeQueueFamily+  , graphicsAndPresentQueue = QueueSpec 1   isPresentQueueFamily+  , transferQueue           = QueueSpec 1   isTransferOnlyQueueFamily+  }+@++Note, this doesn't permit differentiating queue family assignment based on+whether or not the queue is protected.+-} assignQueues   :: forall f m n    . (Traversable f, MonadIO m, MonadIO n)@@ -106,84 +109,92 @@            , Device -> n (f (QueueFamilyIndex, Queue))            )        )-  -- ^-  -- - A set of 'DeviceQueueCreateInfo's to pass to 'createDevice'-  -- - A function to extract the requested 'Queue's from the 'Device' created-  --   with the 'DeviceQueueCreateInfo's-  ---  -- 'Nothing' if it wasn't possible to satisfy all the 'QueueSpec's+  {- ^+  - A set of 'DeviceQueueCreateInfo's to pass to 'createDevice'+  - A function to extract the requested 'Queue's from the 'Device' created+  with the 'DeviceQueueCreateInfo's++  'Nothing' if it wasn't possible to satisfy all the 'QueueSpec's+  -} assignQueues phys specs = runMaybeT $ do   queueFamilyProperties <-     zip [QueueFamilyIndex 0 ..]-    .   V.toList-    <$> getPhysicalDeviceQueueFamilyProperties phys+      . V.toList+      <$> getPhysicalDeviceQueueFamilyProperties phys    -- For each QueueSpec find the list of applicable families   specsWithFamilies <- for specs $ \spec -> do-    families <- filterM (lift . uncurry (queueSpecFamilyPredicate spec))-                        queueFamilyProperties+    families <-+      filterM+        (lift . uncurry (queueSpecFamilyPredicate spec))+        queueFamilyProperties     pure (spec, fst <$> families) -  let -- Get the number of available queues for each family-      familiesWithCapacities :: [(QueueFamilyIndex, Word32)]-      familiesWithCapacities =-        [ (i, queueCount)-        | (i, QueueFamilyProperties {..}) <- queueFamilyProperties-        ]+  let+    -- Get the number of available queues for each family+    familiesWithCapacities :: [(QueueFamilyIndex, Word32)]+    familiesWithCapacities =+      [ (i, queueCount)+      | (i, QueueFamilyProperties{..}) <- queueFamilyProperties+      ]    -- Assign each QueueSpec to a queue family-  specsWithFamily :: f (QueueSpec m, QueueFamilyIndex) <- headMay-    (assign-      familiesWithCapacities-      (specsWithFamilies <&> \(spec, indices) index ->-        if index `elem` indices then Just (spec, index) else Nothing+  specsWithFamily :: f (QueueSpec m, QueueFamilyIndex) <-+    headMay+      ( assign+          familiesWithCapacities+          ( specsWithFamilies <&> \(spec, indices) index ->+              if index `elem` indices then Just (spec, index) else Nothing+          )       )-    ) -  let maxFamilyIndex :: Maybe QueueFamilyIndex-      maxFamilyIndex = maximumMay (snd <$> toList specsWithFamily)+  let+    maxFamilyIndex :: Maybe QueueFamilyIndex+    maxFamilyIndex = maximumMay (snd <$> toList specsWithFamily) -      -- Assign each QueueSpec an index within its queue family-      specsWithQueueIndex :: f (QueueSpec m, QueueFamilyIndex, QueueIndex)-      specsWithQueueIndex =-        flip evalState (repeat (QueueIndex 0))-          $ for specsWithFamily-          $ \(spec, familyIndex) -> do-              indices <- get-              let (index, indices') =-                    incrementAt (unQueueFamilyIndex familyIndex) indices-              put indices'-              pure (spec, familyIndex, index)+    -- Assign each QueueSpec an index within its queue family+    specsWithQueueIndex :: f (QueueSpec m, QueueFamilyIndex, QueueIndex)+    specsWithQueueIndex =+      flip evalState (repeat (QueueIndex 0)) $+        for specsWithFamily $+          \(spec, familyIndex) -> do+            indices <- get+            let (index, indices') =+                  incrementAt (unQueueFamilyIndex familyIndex) indices+            put indices'+            pure (spec, familyIndex, index) -      -- Gather the priorities for each queue in each queue family-      queuePriorities :: [[Float]]-      queuePriorities = foldr-        (\(QueueSpec {..}, QueueFamilyIndex i) ps ->-          prependAt i queueSpecQueuePriority ps+    -- Gather the priorities for each queue in each queue family+    queuePriorities :: [[Float]]+    queuePriorities =+      foldr+        ( \(QueueSpec{..}, QueueFamilyIndex i) ps ->+            prependAt i queueSpecQueuePriority ps         )-        (replicate-          (maybe 0 (fromIntegral . unQueueFamilyIndex . succ) maxFamilyIndex)-          []+        ( replicate+            (maybe 0 (fromIntegral . unQueueFamilyIndex . succ) maxFamilyIndex)+            []         )         specsWithFamily -      -- Make 'DeviceQueueCreateInfo's for the required queue families and-      -- priorities.-      queueCreateInfos :: Vector (DeviceQueueCreateInfo '[])-      queueCreateInfos = V.fromList-        [ zero { queueFamilyIndex = familyIndex-               , queuePriorities  = V.fromList ps-               }+    -- Make 'DeviceQueueCreateInfo's for the required queue families and+    -- priorities.+    queueCreateInfos :: Vector (DeviceQueueCreateInfo '[])+    queueCreateInfos =+      V.fromList+        [ zero+            { queueFamilyIndex = familyIndex+            , queuePriorities = V.fromList ps+            }         | (familyIndex, ps) <- zip [0 ..] queuePriorities         , not (null ps)         ] -      -- Get-      extractQueues :: Device -> n (f (QueueFamilyIndex, Queue))-      extractQueues dev =-        for specsWithQueueIndex-          $ \(_, i@(QueueFamilyIndex familyIndex), QueueIndex index) ->-              (i, ) <$> getDeviceQueue dev familyIndex index+    extractQueues :: Device -> n (f (QueueFamilyIndex, Queue))+    extractQueues dev =+      for specsWithQueueIndex $+        \(_, i@(QueueFamilyIndex familyIndex), QueueIndex index) ->+          (i,) <$> getDeviceQueue dev familyIndex index    pure (queueCreateInfos, extractQueues) @@ -200,18 +211,19 @@ isTransferQueueFamily :: QueueFamilyProperties -> Bool isTransferQueueFamily q = QUEUE_TRANSFER_BIT .&&. queueFlags q --- | Does this queue have 'QUEUE_TRANSFER_BIT' set and not 'QUEUE_COMPUTE_BIT'--- or 'QUEUE_GRAPHICS_BIT'+{- | Does this queue have 'QUEUE_TRANSFER_BIT' set and not 'QUEUE_COMPUTE_BIT'+or 'QUEUE_GRAPHICS_BIT'+-} isTransferOnlyQueueFamily :: QueueFamilyProperties -> Bool isTransferOnlyQueueFamily q =-  (   queueFlags q-    .&. (QUEUE_TRANSFER_BIT .|. QUEUE_GRAPHICS_BIT .|. QUEUE_COMPUTE_BIT)-    )+  ( queueFlags q+      .&. (QUEUE_TRANSFER_BIT .|. QUEUE_GRAPHICS_BIT .|. QUEUE_COMPUTE_BIT)+  )     == QUEUE_TRANSFER_BIT  -- | Can this queue family present to this surface on this device isPresentQueueFamily-  :: MonadIO m => PhysicalDevice -> SurfaceKHR -> QueueFamilyIndex -> m Bool+  :: (MonadIO m) => PhysicalDevice -> SurfaceKHR -> QueueFamilyIndex -> m Bool isPresentQueueFamily phys surf (QueueFamilyIndex i) =   getPhysicalDeviceSurfaceSupportKHR phys i surf @@ -219,54 +231,61 @@ -- Helpers ---------------------------------------------------------------- --- | Find all possible valid assignments for elements of a 'Traversable' with--- some limited resources.------ >>> assign @[] @_ @() [("a", 1)] []--- [[]]------ >>> assign @[] [("hi", 1), ("foo", 3)] [Just, Just . reverse, Just . take 1 ]--- [["hi","oof","f"],["foo","ih","f"],["foo","oof","h"],["foo","oof","f"]]------ >>> assign @[] [("a", 1), ("b", 2)] [\case {"a" -> Just 1; "b" -> Just 2; _ -> Nothing}, \case {"b" -> Just 3; _ -> Nothing}, \case {"a" -> Just 4; _ -> Nothing}]--- [[2,3,4]]+{- | Find all possible valid assignments for elements of a 'Traversable' with+some limited resources.++>>> assign @[] @_ @() [("a", 1)] []+[[]]++>>> assign @[] [("hi", 1), ("foo", 3)] [Just, Just . reverse, Just . take 1 ]+[["hi","oof","f"],["foo","ih","f"],["foo","oof","h"],["foo","oof","f"]]++>>> assign @[] [("a", 1), ("b", 2)] [\case {"a" -> Just 1; "b" -> Just 2; _ -> Nothing}, \case {"b" -> Just 3; _ -> Nothing}, \case {"a" -> Just 4; _ -> Nothing}]+[[2,3,4]]+-} assign   :: forall f a b-   . Traversable f+   . (Traversable f)   => [(a, Word32)]   -- ^ How many of each 'a' are available   -> f (a -> Maybe b)   -- ^ Which 'a's can each element use   -> [f b]-  -- ^ A list of assignments, each element in this list has the length of the-  -- requirements list-assign capacities = flip evalStateT capacities . traverse-  (\p -> do-    cs            <- get-    (choice, cs') <- lift (select p cs)-    put cs'-    pure choice-  )+  {- ^ A list of assignments, each element in this list has the length of the+  requirements list+  -}+assign capacities =+  flip evalStateT capacities+    . traverse+      ( \p -> do+          cs <- get+          (choice, cs') <- lift (select p cs)+          put cs'+          pure choice+      ) --- | Select an element from the list according to some predicate, and return--- that element along with the decremented list.+{- | Select an element from the list according to some predicate, and return+that element along with the decremented list.+-} select :: (a -> Maybe b) -> [(a, Word32)] -> [(b, [(a, Word32)])] select p = \case   [] -> []   x : xs ->-    let hit b = (b, if snd x == 1 then xs else (pred <$> x) : xs)-        miss = do-          (selected, xs') <- select p xs-          pure (selected, x : xs')-    in  if snd x == 0-          then miss-          else case p (fst x) of-            Nothing -> miss-            Just b  -> hit b : miss+    let+      hit b = (b, if snd x == 1 then xs else (pred <$> x) : xs)+      miss = do+        (selected, xs') <- select p xs+        pure (selected, x : xs')+    in+      if snd x == 0+        then miss+        else case p (fst x) of+          Nothing -> miss+          Just b -> hit b : miss -headMay :: Alternative f => [a] -> f a+headMay :: (Alternative f) => [a] -> f a headMay = \case-  []    -> empty+  [] -> empty   x : _ -> pure x  maximumMay :: (Foldable f, Ord a) => f a -> Maybe a@@ -275,10 +294,11 @@ incrementAt :: (HasCallStack, Enum a) => Word32 -> [a] -> (a, [a]) incrementAt index = modAt index succ -prependAt :: HasCallStack => Word32 -> a -> [[a]] -> [[a]]+prependAt :: (HasCallStack) => Word32 -> a -> [[a]] -> [[a]] prependAt index p = snd . modAt index (p :) -modAt :: HasCallStack => Word32 -> (a -> a) -> [a] -> (a, [a])-modAt index f = splitAt (fromIntegral index) >>> \case-  (_ , []    ) -> error "modAt, out of bounds"-  (xs, y : ys) -> (y, xs <> (f y : ys))+modAt :: (HasCallStack) => Word32 -> (a -> a) -> [a] -> (a, [a])+modAt index f =+  splitAt (fromIntegral index) >>> \case+    (_, []) -> error "modAt, out of bounds"+    (xs, y : ys) -> (y, xs <> (f y : ys))

@@ -0,0 +1,253 @@+{-| A common physical-device + logical-device boot recipe: pick a device+that exposes a graphics/compute/transfer queue triple (with the graphics+family also presenting, when a surface is supplied), then create a logical+device with one 'Queue' allocated per slot.++This is the wheel every "draw a thing in Vulkan" application reinvents.+The recipe here is opinionated:++- The graphics slot doubles as the present queue.+- The compute slot prefers a compute-only queue family (async compute);+  falls back to aliasing the graphics family.+- The transfer slot prefers a transfer-only queue family (DMA-only+  hardware queue); falls back to aliasing the compute family.+- Priorities are 1.0 / 0.5 / 0.2 for graphics / compute / transfer.++When two slots target the same family, two distinct 'Queue' handles are+still allocated within that shared family with the requested priorities.++If you need a different shape (compute-only, multiple graphics queues,+custom priorities, …) reach for the lower-level+'Vulkan.Utils.QueueAssignment.assignQueues' directly.+-}+module Vulkan.Utils.Queues+  ( Queues (..)+  , allocateDevice+  ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Resource+import Data.Foldable (foldl', toList)+import Data.List (sortOn)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Traversable (mapAccumL)+import qualified Data.Vector as V+import Data.Word (Word32, Word64)+import Vulkan.CStruct.Extends (SomeStruct (..))+import qualified Vulkan.Core10 as Vk+import qualified Vulkan.Core10.DeviceInitialization as DI+import Vulkan.Extensions.VK_KHR_surface (SurfaceKHR)+import Vulkan.Requirement (DeviceRequirement)+import Vulkan.Utils.Initialization (allocateDeviceFromRequirements, pickPhysicalDevice)+import Vulkan.Utils.QueueAssignment (QueueFamilyIndex (..), QueueSpec (..), assignQueues, isComputeQueueFamily, isGraphicsQueueFamily, isPresentQueueFamily, isTransferOnlyQueueFamily)+import Vulkan.Zero (zero)++{- | The G/C/T queue kit. Parametric in the slot contents so the same+shape can carry priorities ('Float'), family indices ('QueueFamilyIndex'),+queue specs ('QueueSpec'), or fully-resolved @(QueueFamilyIndex, Queue)@+pairs.+-}+data Queues a = Queues+  { qGraphics :: a+  -- ^ graphics + present, priority 1.0+  , qCompute :: a+  -- ^ compute (prefers compute-only family), priority 0.5+  , qTransfer :: a+  -- ^ transfer (prefers transfer-only family), priority 0.2+  }+  deriving (Show, Functor, Foldable, Traversable)++-- | Elementwise zip — handy for combining priorities with family predicates.+instance Applicative Queues where+  pure x = Queues x x x+  Queues f g h <*> Queues x y z = Queues (f x) (g y) (h z)++{- | Pick a physical device that has the queue families needed for the+caller, then create a logical device exposing one queue per G/C/T slot.+Devices are scored by total memory.++Pass @'Just' surface@ for windowed callers — the graphics family must also+support presentation. Pass 'Nothing' for headless callers — any graphics+family will do.++Pass any extra device requirements (extensions, features, API version) in+the third argument; they are forwarded to 'allocateDeviceFromRequirements'.++Fails (via 'MonadFail') when no physical device satisfies the family+requirements.+-}+allocateDevice+  :: (MonadResource m, MonadFail m)+  => Vk.Instance+  -> Maybe SurfaceKHR+  -> [DeviceRequirement]+  -> m (Vk.PhysicalDevice, Vk.Device, Queues (QueueFamilyIndex, Vk.Queue))+allocateDevice inst mSurface extraReqs = do+  mPd <-+    pickPhysicalDevice+      inst+      (discoverFamilies mSurface)+      (snd :: (Queues QueueFamilyIndex, Word64) -> Word64)+  ((qFams, _score), phys) <- case mPd of+    Just x -> pure x+    Nothing -> fail "No physical device with the required G/C/T queue families"++  let+    prios = Queues 1.0 0.5 0.2+    mkSpec target prio = QueueSpec prio (\i _ -> pure (i == target))+    specs = mkSpec <$> qFams <*> prios++  -- Prefer 'assignQueues', which hands each slot its own queue for maximum+  -- parallelism. When the hardware can't supply that many distinct queues+  -- (e.g. a lone graphics+compute family exposing a single queue, as some+  -- mobile and translation-layer drivers do) fall back to sharing rather than+  -- failing: the triple still works, just with serialized submission.+  (qInfos, getQs) <-+    assignQueues phys specs >>= \case+      Just qs -> pure qs+      Nothing -> shareQueues phys ((,) <$> qFams <*> prios)++  dev <-+    allocateDeviceFromRequirements+      extraReqs+      []+      phys+      zero{Vk.queueCreateInfos = SomeStruct <$> qInfos}+  qs <- liftIO (getQs dev)+  pure (phys, dev, qs)++discoverFamilies+  :: (MonadIO m)+  => Maybe SurfaceKHR+  -> Vk.PhysicalDevice+  -> m (Maybe (Queues QueueFamilyIndex, Word64))+discoverFamilies mSurf phys = do+  qProps <- Vk.getPhysicalDeviceQueueFamilyProperties phys+  let+    withIndex = V.toList (V.indexed qProps)+    asQfi i = QueueFamilyIndex (fromIntegral i)++    graphicsFamilies =+      [asQfi i | (i, q) <- withIndex, isGraphicsQueueFamily q]+    asyncCompute =+      [ asQfi i+      | (i, q) <- withIndex+      , isComputeQueueFamily q && not (isGraphicsQueueFamily q)+      ]+    anyCompute =+      [asQfi i | (i, q) <- withIndex, isComputeQueueFamily q]+    dedicatedTransfer =+      [asQfi i | (i, q) <- withIndex, isTransferOnlyQueueFamily q]++  mGp <- case mSurf of+    Just surf -> do+      presentResults <-+        mapM+          (\qfi -> (qfi,) <$> isPresentQueueFamily phys surf qfi)+          graphicsFamilies+      pure $ case [qfi | (qfi, True) <- presentResults] of+        qfi : _ -> Just qfi+        [] -> Nothing+    Nothing ->+      pure $ case graphicsFamilies of+        qfi : _ -> Just qfi+        [] -> Nothing++  let mCp = case asyncCompute of+        qfi : _ -> Just qfi+        [] -> case anyCompute of+          qfi : _ -> Just qfi+          [] -> Nothing++  case (mGp, mCp) of+    (Just gp, Just cp) -> do+      let tf = case dedicatedTransfer of+            qfi : _ -> qfi+            [] -> cp+      heaps <- Vk.memoryHeaps <$> Vk.getPhysicalDeviceMemoryProperties phys+      let score = sum (DI.size <$> heaps) :: Word64+      pure (Just (Queues gp cp tf, score))+    _ -> pure Nothing++{- | Robust fallback for 'allocateDevice' when 'assignQueues' can't give every+slot its own queue. Allocates as many distinct queues per family as the+hardware exposes, then aliases the surplus slots onto them round-robin, so it+always succeeds.++A shared queue keeps every capability it was selected for — a graphics+compute+family also handles transfer — so the result is correct, just less concurrent.+Two slots that resolve to the same 'Vk.Queue' compare equal, so a caller who+cares can detect aliasing. Callers submitting from multiple threads must+externally synchronize a shared queue themselves; see+'Vulkan.Utils.QueueAssignment'.+-}+shareQueues+  :: (MonadIO m)+  => Vk.PhysicalDevice+  -> Queues (QueueFamilyIndex, Float)+  -- ^ The resolved family and queue priority for each slot.+  -> m+       ( V.Vector (Vk.DeviceQueueCreateInfo '[])+       , Vk.Device -> IO (Queues (QueueFamilyIndex, Vk.Queue))+       )+shareQueues phys famPrios = do+  capacities <- familyCapacities phys+  let+    capOf fam = Map.findWithDefault 0 fam capacities++    -- Hand each slot a queue index within its family, wrapping at the family's+    -- capacity so surplus slots reuse (alias) earlier queues.+    step counts (fam, prio) =+      let+        used = Map.findWithDefault 0 fam counts+        idx = used `mod` max 1 (capOf fam)+      in+        (Map.insert fam (used + 1) counts, (fam, prio, idx))++    slots :: Queues (QueueFamilyIndex, Float, Word32)+    slots = snd (mapAccumL step Map.empty famPrios)++    -- The highest requested priority wins for a queue shared by several slots.+    priorityAt :: Map (QueueFamilyIndex, Word32) Float+    priorityAt =+      foldl'+        (\acc (fam, prio, idx) -> Map.insertWith max (fam, idx) prio acc)+        Map.empty+        (toList slots)++    -- One create-info per family, priorities ordered by queue index.+    perFamily :: Map QueueFamilyIndex [(Word32, Float)]+    perFamily =+      Map.fromListWith+        (<>)+        [(fam, [(idx, prio)]) | ((fam, idx), prio) <- Map.toList priorityAt]++    createInfos =+      V.fromList+        [ zero+            { Vk.queueFamilyIndex = unQueueFamilyIndex fam+            , Vk.queuePriorities = V.fromList (snd <$> sortOn fst idxPrios)+            }+        | (fam, idxPrios) <- Map.toList perFamily+        ]++    getQueues dev =+      traverse+        ( \(fam, _, idx) ->+            (fam,) <$> Vk.getDeviceQueue dev (unQueueFamilyIndex fam) idx+        )+        slots++  pure (createInfos, getQueues)++-- | The number of queues each queue family of a 'Vk.PhysicalDevice' exposes.+familyCapacities+  :: (MonadIO m) => Vk.PhysicalDevice -> m (Map QueueFamilyIndex Word32)+familyCapacities phys = do+  props <- Vk.getPhysicalDeviceQueueFamilyProperties phys+  pure $+    Map.fromList+      [ (QueueFamilyIndex (fromIntegral i), Vk.queueCount qfp)+      | (i, qfp) <- zip [0 :: Int ..] (V.toList props)+      ]

@@ -0,0 +1,60 @@+{-| Lightweight reference counter that runs a release action when the count+hits zero. Useful for keeping a Vulkan object alive across an unknown number+of in-flight frames — bump the count when a frame starts using it, drop the+count when the frame retires, and the object is destroyed promptly after the+last frame finishes.+-}+module Vulkan.Utils.RefCounted+  ( RefCounted+  , newRefCounted+  , releaseRefCounted+  , takeRefCounted+  , resourceTRefCount+  ) where++import Control.Exception (mask, throwIO)+import Control.Monad+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Resource (MonadResource, allocate_)+import Data.IORef+import GHC.IO.Exception (IOErrorType (UserError), IOException (IOError))++-- | A 'RefCounted' will perform the specified action when the count reaches 0+data RefCounted = RefCounted+  { rcCount :: IORef Int+  , rcAction :: IO ()+  }++-- | Create a counter with a value of 1+newRefCounted :: (MonadIO m) => IO () -> m RefCounted+newRefCounted rcAction = do+  rcCount <- liftIO $ newIORef 1+  pure RefCounted{..}++{- | Decrement the value, the action will be run promptly and in+this thread if the counter reached 0.+-}+releaseRefCounted :: (MonadIO m) => RefCounted -> m ()+releaseRefCounted RefCounted{..} = liftIO $ mask $ \_ ->+  atomicModifyIORef' rcCount (\c -> (pred c, pred c)) >>= \case+    0 -> rcAction+    n+      | n < 0 ->+          liftIO . throwIO $+            IOError+              Nothing+              UserError+              ""+              "Ref counted value decremented below 0"+              Nothing+              Nothing+    _ -> pure ()++-- | Increment the counter by 1+takeRefCounted :: (MonadIO m) => RefCounted -> m ()+takeRefCounted RefCounted{..} =+  liftIO $ atomicModifyIORef' rcCount (\c -> (succ c, ()))++-- | Hold a reference for the duration of the 'MonadResource' action+resourceTRefCount :: (MonadResource f) => RefCounted -> f ()+resourceTRefCount r = void $ allocate_ (takeRefCounted r) (releaseRefCounted r)

@@ -0,0 +1,245 @@+{-# LANGUAGE OverloadedLists #-}++{-| The classic render-pass drawing path: a 'Vk.RenderPass' over one or more+colour attachments (and an optional depth attachment), framebuffers over the+swapchain image views, and a vanilla pipeline that targets the render pass.++This is one of two self-contained alternatives — see+"Vulkan.Utils.DynamicRendering" for the @VK_KHR_dynamic_rendering@ path, which+needs neither a render pass nor framebuffers. Pick one and import only it.+-}+module Vulkan.Utils.RenderPass+  ( -- * Render pass+    allocateRenderPass+  , allocateColorRenderPass++    -- * Pipeline+  , PipelineConfig (..)+  , allocatePipeline+  , allocatePipelineFromShaders+  ) where++import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, allocate)+import Data.Bits ((.|.))+import Data.ByteString (ByteString)+import Data.Maybe (fromMaybe, isJust)+import Data.Vector (Vector)+import qualified Data.Vector as V+import Vulkan.CStruct.Extends (SomeStruct (..))+import qualified Vulkan.Core10 as Vk+import Vulkan.Utils.DynamicState (defaultDynamicStatesFor)+import Vulkan.Utils.Pipeline.Internal (basePipelineCreateInfo, buildColorPipeline, withCompiledStages)+import Vulkan.Utils.Pipeline.Specialization (Specialization)+import Vulkan.Zero (Zero (..))++{- | A render pass with @colors@ colour attachments (each @(format, finalLayout)@)+and an optional depth attachment, all cleared on load and stored on completion, in+a single graphics subpass. Attachment indices are the colours @0..N-1@ then the+depth attachment at @N@ — the colour-then-depth order the framebuffer's+@attachments@ must follow. The external+dependency synchronizes colour output and, when present, the+depth fragment tests.+-}+allocateRenderPass+  :: (MonadResource m)+  => Vk.Device+  -> Vector (Vk.Format, Vk.ImageLayout)+  -- ^ Colour attachments: @(format, finalLayout)@.+  -> Maybe Vk.Format+  -- ^ Optional depth attachment format.+  -> m (ReleaseKey, Vk.RenderPass)+allocateRenderPass dev colors depth =+  Vk.withRenderPass+    dev+    zero+      { Vk.attachments = colorDescriptions <> depthDescriptions+      , Vk.subpasses = [subpass]+      , Vk.dependencies = [subpassDependency]+      }+    Nothing+    allocate+  where+    colorCount = V.length colors+    hasColor = colorCount > 0+    hasDepth = isJust depth++    colorDescriptions :: Vector Vk.AttachmentDescription+    colorDescriptions = fmap (uncurry colorAttachmentDescription) colors++    depthDescriptions :: Vector Vk.AttachmentDescription+    depthDescriptions = maybe [] (V.singleton . depthAttachmentDescription) depth++    colorReferences :: Vector Vk.AttachmentReference+    colorReferences =+      V.imap+        ( \i _ ->+            zero+              { Vk.attachment = fromIntegral i+              , Vk.layout = Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL+              }+        )+        colors++    depthReference :: Maybe Vk.AttachmentReference+    depthReference+      | hasDepth =+          Just+            zero+              { Vk.attachment = fromIntegral colorCount+              , Vk.layout = Vk.IMAGE_LAYOUT_DEPTH_ATTACHMENT_OPTIMAL+              }+      | otherwise = Nothing++    subpass :: Vk.SubpassDescription+    subpass =+      zero+        { Vk.pipelineBindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS+        , Vk.colorAttachments = colorReferences+        , Vk.depthStencilAttachment = depthReference+        }++    subpassDependency :: Vk.SubpassDependency+    subpassDependency =+      zero+        { Vk.srcSubpass = Vk.SUBPASS_EXTERNAL+        , Vk.dstSubpass = 0+        , Vk.srcStageMask = stageMask+        , Vk.srcAccessMask = zero+        , Vk.dstStageMask = stageMask+        , Vk.dstAccessMask = accessMask+        }++    stageMask =+      (if hasColor then Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT else zero)+        .|. ( if hasDepth+                then+                  Vk.PIPELINE_STAGE_EARLY_FRAGMENT_TESTS_BIT+                    .|. Vk.PIPELINE_STAGE_LATE_FRAGMENT_TESTS_BIT+                else zero+            )+    accessMask =+      ( if hasColor+          then Vk.ACCESS_COLOR_ATTACHMENT_READ_BIT .|. Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT+          else zero+      )+        .|. (if hasDepth then Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_WRITE_BIT else zero)++colorAttachmentDescription :: Vk.Format -> Vk.ImageLayout -> Vk.AttachmentDescription+colorAttachmentDescription imageFormat finalLayout =+  zero+    { Vk.format = imageFormat+    , Vk.samples = Vk.SAMPLE_COUNT_1_BIT+    , Vk.loadOp = Vk.ATTACHMENT_LOAD_OP_CLEAR+    , Vk.storeOp = Vk.ATTACHMENT_STORE_OP_STORE+    , Vk.stencilLoadOp = Vk.ATTACHMENT_LOAD_OP_DONT_CARE+    , Vk.stencilStoreOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE+    , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED+    , Vk.finalLayout = finalLayout+    }++depthAttachmentDescription :: Vk.Format -> Vk.AttachmentDescription+depthAttachmentDescription imageFormat =+  zero+    { Vk.format = imageFormat+    , Vk.samples = Vk.SAMPLE_COUNT_1_BIT+    , Vk.loadOp = Vk.ATTACHMENT_LOAD_OP_CLEAR+    , Vk.storeOp = Vk.ATTACHMENT_STORE_OP_STORE+    , Vk.stencilLoadOp = Vk.ATTACHMENT_LOAD_OP_DONT_CARE+    , Vk.stencilStoreOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE+    , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED+    , Vk.finalLayout = Vk.IMAGE_LAYOUT_DEPTH_ATTACHMENT_OPTIMAL+    }++{- | The single-colour render pass: one attachment cleared on load and stored,+ending in @finalLayout@ (e.g. @PRESENT_SRC_KHR@ for swapchains,+@TRANSFER_SRC_OPTIMAL@ for offscreen images). The common special case of+'allocateRenderPass'.+-}+allocateColorRenderPass+  :: (MonadResource m)+  => Vk.Device+  -> Vk.Format+  -- ^ Color attachment format.+  -> Vk.ImageLayout+  -- ^ Final layout.+  -> m (ReleaseKey, Vk.RenderPass)+allocateColorRenderPass dev imageFormat finalLayout =+  allocateRenderPass dev [(imageFormat, finalLayout)] Nothing++{- | Attachment + fixed-function knobs for a render-pass pipeline.++Construct with 'zero' and override what differs, e.g.+@zero { RenderPass.colorFormats = [fmt], RenderPass.depthFormat = Just d }@. The+attachment shape — 'colorFormats' count and whether 'depthFormat' is present — MUST+match the render pass; the formats themselves live in the render pass, so only the+count and depth presence are read here.+-}+data PipelineConfig = PipelineConfig+  { colorFormats :: [Vk.Format]+  -- ^ Colour attachment formats; only the count is read (must match the render pass).+  , depthFormat :: Maybe Vk.Format+  -- ^ Optional depth attachment; only its presence is read (must match the render pass).+  , vertexInput :: Vk.PipelineVertexInputStateCreateInfo '[]+  -- ^ Vertex input (bindings + attributes); 'zero' for none.+  , dynamicStates :: Maybe (Vector Vk.DynamicState)+  -- ^ Dynamic states; 'Nothing' defaults layout-aware (see "Vulkan.Utils.DynamicState").+  , layout :: Maybe Vk.PipelineLayout+  {- ^ Pipeline layout for descriptor sets \/ push constants; 'Nothing' uses a+  transient empty layout (shaders take no resources). A supplied layout stays+  owned by the caller, who must keep it alive for the pipeline's lifetime.+  -}+  }++instance Zero PipelineConfig where+  zero =+    PipelineConfig+      { colorFormats = []+      , depthFormat = Nothing+      , vertexInput = zero+      , dynamicStates = Nothing+      , layout = Nothing+      }++{- | A vanilla vertex+fragment pipeline targeting @renderPass@ (subpass 0). The+'PipelineConfig' attachment shape MUST match @renderPass@. Whatever dynamic state+is selected MUST be set before drawing. Intended to be used qualified, e.g.+@RenderPass.allocatePipeline@.+-}+allocatePipeline+  :: (MonadResource m, MonadFail m)+  => Vk.Device+  -> Vk.RenderPass+  -> PipelineConfig+  -> Vector (SomeStruct Vk.PipelineShaderStageCreateInfo)+  -> m (ReleaseKey, Vk.Pipeline)+allocatePipeline dev renderPass PipelineConfig{..} stages =+  buildColorPipeline dev layout $ \resolvedLayout ->+    SomeStruct+      ( basePipelineCreateInfo+          resolvedLayout+          (Just renderPass)+          (length colorFormats)+          (isJust depthFormat)+          vertexInput+          (fromMaybe (defaultDynamicStatesFor (not (null colorFormats))) dynamicStates)+          stages+      )++{- | 'allocatePipeline' from @(stage, SPIR-V)@ pairs: compile each into a shader+module, build the pipeline, then release the now-redundant module handles.++@spec@ is one specialization shared by every stage (see+'Vulkan.Utils.Pipeline.Specialization'); pass @()@ for none.+-}+allocatePipelineFromShaders+  :: (MonadResource m, MonadUnliftIO m, MonadFail m, Specialization spec)+  => Vk.Device+  -> Vk.RenderPass+  -> PipelineConfig+  -> spec+  -- ^ Specialization shared by every stage; @()@ for none.+  -> [(Vk.ShaderStageFlagBits, ByteString)]+  -> m (ReleaseKey, Vk.Pipeline)+allocatePipelineFromShaders dev renderPass config spec shaders =+  withCompiledStages dev spec shaders (allocatePipeline dev renderPass config)

@@ -1,80 +1,89 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}  module Vulkan.Utils.Requirements   ( -- * Instance requirements     checkInstanceRequirements-  , -- * Device requirements-    checkDeviceRequirements-  , -- * Results-    RequirementResult(..)-  , Unsatisfied(..)++    -- * Device requirements+  , checkDeviceRequirements++    -- * Results+  , RequirementResult (..)+  , Unsatisfied (..)   , requirementReport   , prettyRequirementResult   ) where -import           Control.Arrow                  ( Arrow((***)) )-import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.Trans.State-import           Data.Bifunctor-import           Data.ByteString                ( ByteString )-import qualified Data.Dependent.Map            as DMap-import           Data.Dependent.Map             ( DMap )-import           Data.Dependent.Sum             ( DSum((:=>)) )-import           Data.Foldable-import           Data.Functor.Product           ( Product(..) )-import qualified Data.HashMap.Strict           as Map-import           Data.Kind                      ( Type )-import           Data.List                      ( intercalate, intersect )-import           Data.List.Extra                ( nubOrd )-import           Data.Proxy-import           Data.Semigroup                 ( Endo(..) )-import           Data.Traversable-import           Data.Typeable                  ( eqT )-import qualified Data.Vector                   as V-import           Data.Vector                    ( Vector )-import           Data.Word-import           Foreign.Ptr                    ( FunPtr-                                                , Ptr-                                                , nullFunPtr-                                                )-import           GHC.Base                       ( Proxy# )-import           GHC.Exts                       ( proxy# )-import           Type.Reflection-import           Vulkan.CStruct                 ( FromCStruct-                                                , ToCStruct-                                                )-import           Vulkan.CStruct.Extends-import           Vulkan.Core10-import qualified Vulkan.Core10                as Device-                                                ( DeviceCreateInfo(..) )-import qualified Vulkan.Core10                as Extension-                                                ( ExtensionProperties(..) )-import qualified Vulkan.Core10                as Instance-                                                ( InstanceCreateInfo(..) )-import qualified Vulkan.Core10                as PhysicalDevice-                                                ( PhysicalDeviceProperties(..)-                                                , PhysicalDevice(instanceCmds) )-import           Vulkan.Core11.DeviceInitialization-import           Vulkan.Core11.Promoted_From_VK_KHR_get_physical_device_properties2-import qualified Vulkan.Core11.Promoted_From_VK_KHR_get_physical_device_properties2-                                              as PhysicalDevice-                                                ( PhysicalDeviceProperties2(..)-                                                , features )-import           Vulkan.Dynamic                 ( InstanceCmds-                                                  ( pVkGetPhysicalDeviceFeatures2-                                                  , pVkGetPhysicalDeviceProperties2-                                                  )-                                                )-import           Vulkan.NamedType-import           Vulkan.Requirement-import           Vulkan.Version-import           Vulkan.Zero                    ( Zero(..) )+import Control.Arrow (Arrow ((***)))+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.State+import Data.Bifunctor+import Data.ByteString (ByteString)+import Data.Foldable+import Data.Functor.Product (Product (..))+import qualified Data.HashMap.Strict as Map+import Data.Kind (Type)+import Data.List (intercalate, intersect)+import Data.List.Extra (nubOrd)+import qualified Data.Map.Strict as TRMap+import Data.Proxy+import Data.Semigroup (Endo (..))+import Data.Traversable+import Data.Typeable (eqT)+import Data.Vector (Vector)+import qualified Data.Vector as V+import Data.Word+import Foreign.Ptr+  ( FunPtr+  , Ptr+  , nullFunPtr+  )+import GHC.Base (Proxy#)+import GHC.Exts (proxy#)+import Type.Reflection+import Vulkan.CStruct+  ( FromCStruct+  , ToCStruct+  )+import Vulkan.CStruct.Extends+import Vulkan.Core10+import qualified Vulkan.Core10 as Device+  ( DeviceCreateInfo (..)+  )+import qualified Vulkan.Core10 as Extension+  ( ExtensionProperties (..)+  )+import qualified Vulkan.Core10 as Instance+  ( InstanceCreateInfo (..)+  )+import qualified Vulkan.Core10 as PhysicalDevice+  ( PhysicalDevice (instanceCmds)+  , PhysicalDeviceProperties (..)+  )+import Vulkan.Core11.DeviceInitialization+import Vulkan.Core11.Promoted_From_VK_KHR_get_physical_device_properties2+import qualified Vulkan.Core11.Promoted_From_VK_KHR_get_physical_device_properties2 as PhysicalDevice+  ( PhysicalDeviceProperties2 (..)+  , features+  )+import Vulkan.Dynamic+  ( InstanceCmds+      ( pVkGetPhysicalDeviceFeatures2+      , pVkGetPhysicalDeviceProperties2+      )+  )+import Vulkan.NamedType+import Vulkan.Requirement+import Vulkan.Version+import Vulkan.Zero (Zero (..))  ----------------------------------------------------------------+ -- * Instance Creation+ ----------------------------------------------------------------  checkInstanceRequirements@@ -85,24 +94,27 @@   -> o InstanceRequirement   -- ^ Optional requests   -> InstanceCreateInfo es-  -- ^ An 'InstanceCreateInfo', this will be returned appropriately modified by-  -- the requirements+  {- ^ An 'InstanceCreateInfo', this will be returned appropriately modified by+  the requirements+  -}   -> m        ( Maybe (InstanceCreateInfo es)        , r RequirementResult        , o RequirementResult        ) checkInstanceRequirements required optional baseCreateInfo = do-  let requiredList = toList required-      allAsList    = requiredList <> toList optional-  foundVersion    <- enumerateInstanceVersion+  let+    requiredList = toList required+    allAsList = requiredList <> toList optional+  foundVersion <- enumerateInstanceVersion   (_, layerProps) <- enumerateInstanceLayerProperties-  lookupExtension <- getLookupExtension-    layerProps-    Nothing-    [ instanceExtensionLayerName-    | RequireInstanceExtension { instanceExtensionLayerName } <- allAsList-    ]+  lookupExtension <-+    getLookupExtension+      layerProps+      Nothing+      [ instanceExtensionLayerName+      | RequireInstanceExtension{instanceExtensionLayerName} <- allAsList+      ]    (r, continue) <- flip runStateT True $ for required $ \r ->     case checkInstanceRequest foundVersion layerProps lookupExtension r of@@ -118,12 +130,15 @@    let ici = do         guard continue-        pure $ makeInstanceCreateInfo (requiredList <> goodOptions)-                                      baseCreateInfo+        pure $+          makeInstanceCreateInfo+            (requiredList <> goodOptions)+            baseCreateInfo   pure (ici, r, o) --- | Insert the settings of the requirements in to the provided instance create--- info+{- | Insert the settings of the requirements in to the provided instance create+info+-} makeInstanceCreateInfo   :: forall es    . [InstanceRequirement]@@ -131,58 +146,62 @@   -> InstanceCreateInfo es makeInstanceCreateInfo reqs baseCreateInfo =   let-    layers = [ instanceLayerName | RequireInstanceLayer {..} <- reqs ]+    layers = [instanceLayerName | RequireInstanceLayer{..} <- reqs]     extensions =-      [ instanceExtensionName | RequireInstanceExtension {..} <- reqs ]+      [instanceExtensionName | RequireInstanceExtension{..} <- reqs]   in     baseCreateInfo-      { Instance.enabledLayerNames     =-        Instance.enabledLayerNames baseCreateInfo-          <> V.fromList layers+      { Instance.enabledLayerNames =+          Instance.enabledLayerNames baseCreateInfo+            <> V.fromList layers       , Instance.enabledExtensionNames =-        Instance.enabledExtensionNames baseCreateInfo-          <> V.fromList extensions+          Instance.enabledExtensionNames baseCreateInfo+            <> V.fromList extensions       }  checkInstanceRequest   :: ("apiVersion" ::: Word32)   -> ("properties" ::: Vector LayerProperties)-  -> (  ("layerName" ::: Maybe ByteString)-     -> ByteString-     -> Maybe ExtensionProperties+  -> ( ("layerName" ::: Maybe ByteString)+       -> ByteString+       -> Maybe ExtensionProperties      )   -> InstanceRequirement   -> RequirementResult checkInstanceRequest foundVersion layerProps lookupExtension = \case-  RequireInstanceVersion minVersion -> if foundVersion >= minVersion-    then Satisfied-    else UnsatisfiedInstanceVersion (Unsatisfied minVersion foundVersion)--  RequireInstanceLayer { instanceLayerName, instanceLayerMinVersion }-    | Just props <- find ((== instanceLayerName) . layerName) layerProps-    , foundLayerVersion <- implementationVersion props-    -> if foundVersion >= instanceLayerMinVersion+  RequireInstanceVersion minVersion ->+    if foundVersion >= minVersion       then Satisfied-      else UnsatisfiedLayerVersion-        instanceLayerName-        (Unsatisfied instanceLayerMinVersion foundLayerVersion)-    | otherwise-    -> MissingLayer instanceLayerName--  RequireInstanceExtension { instanceExtensionLayerName, instanceExtensionName, instanceExtensionMinVersion }-    | Just eProps <- lookupExtension instanceExtensionLayerName-                                     instanceExtensionName-    -> let foundInstanceExtensionVersion =-             Extension.specVersion eProps-       in  if foundInstanceExtensionVersion >= instanceExtensionMinVersion+      else UnsatisfiedInstanceVersion (Unsatisfied minVersion foundVersion)+  RequireInstanceLayer{instanceLayerName, instanceLayerMinVersion}+    | Just props <- find ((== instanceLayerName) . layerName) layerProps+    , foundLayerVersion <- implementationVersion props ->+        if foundVersion >= instanceLayerMinVersion+          then Satisfied+          else+            UnsatisfiedLayerVersion+              instanceLayerName+              (Unsatisfied instanceLayerMinVersion foundLayerVersion)+    | otherwise ->+        MissingLayer instanceLayerName+  RequireInstanceExtension{instanceExtensionLayerName, instanceExtensionName, instanceExtensionMinVersion}+    | Just eProps <-+        lookupExtension+          instanceExtensionLayerName+          instanceExtensionName ->+        let foundInstanceExtensionVersion =+              Extension.specVersion eProps+        in if foundInstanceExtensionVersion >= instanceExtensionMinVersion              then Satisfied-             else UnsatisfiedInstanceExtensionVersion-               instanceExtensionName-               (Unsatisfied instanceExtensionMinVersion-                            foundInstanceExtensionVersion-               )-    | otherwise-    -> UnsatisfiedInstanceExtension instanceExtensionName+             else+               UnsatisfiedInstanceExtensionVersion+                 instanceExtensionName+                 ( Unsatisfied+                     instanceExtensionMinVersion+                     foundInstanceExtensionVersion+                 )+    | otherwise ->+        UnsatisfiedInstanceExtension instanceExtensionName  ---------------------------------------------------------------- -- Device@@ -197,17 +216,19 @@   -- ^ Optional requests   -> PhysicalDevice   -> DeviceCreateInfo '[]-  -- ^ A deviceCreateInfo with no extensions. If you need elements in the-  -- struct chain you can add them later with-  -- 'Vulkan.CStruct.Extends.extendSomeStruct'+  {- ^ A deviceCreateInfo with no extensions. If you need elements in the+  struct chain you can add them later with+  'Vulkan.CStruct.Extends.extendSomeStruct'+  -}   -> m        ( Maybe (SomeStruct DeviceCreateInfo)        , r RequirementResult        , o RequirementResult        ) checkDeviceRequirements required optional phys baseCreateInfo = do-  let requiredList = toList required-      allAsList    = requiredList <> toList optional+  let+    requiredList = toList required+    allAsList = requiredList <> toList optional    --   -- First collect the types and properties that we'll need to query using@@ -218,15 +239,16 @@       --       -- Fetch everything       ---      feats           <- getPhysicalDeviceFeaturesMaybe @fs phys-      props           <- getPhysicalDevicePropertiesMaybe @ps phys+      feats <- getPhysicalDeviceFeaturesMaybe @fs phys+      props <- getPhysicalDevicePropertiesMaybe @ps phys       (_, layerProps) <- enumerateDeviceLayerProperties phys-      lookupExtension <- getLookupExtension-        layerProps-        (Just phys)-        [ deviceExtensionLayerName-        | RequireDeviceExtension { deviceExtensionLayerName } <- allAsList-        ]+      lookupExtension <-+        getLookupExtension+          layerProps+          (Just phys)+          [ deviceExtensionLayerName+          | RequireDeviceExtension{deviceExtensionLayerName} <- allAsList+          ]        (r, continue) <- flip runStateT True $ for required $ \r ->         case checkDeviceRequest feats props lookupExtension r of@@ -245,56 +267,63 @@       --       let dci = do             guard continue-            pure $ makeDeviceCreateInfo (requiredList <> goodOptions)-                                        baseCreateInfo+            pure $+              makeDeviceCreateInfo+                (requiredList <> goodOptions)+                baseCreateInfo       pure (dci, r, o)  {-# ANN makeDeviceCreateInfo ("HLint: ignore Move guards forward" :: String) #-}--- | Generate 'DeviceCreateInfo' from some requirements.------ The returned struct chain will enable all required features and extensions.++{- | Generate 'DeviceCreateInfo' from some requirements.++The returned struct chain will enable all required features and extensions.+-} makeDeviceCreateInfo   :: [DeviceRequirement] -> DeviceCreateInfo '[] -> SomeStruct DeviceCreateInfo makeDeviceCreateInfo allReqs baseCreateInfo =   let-    featureSetters :: DMap TypeRep (Product (Has KnownFeatureStruct) Endo)-    featureSetters = DMap.fromListWithKey-      (\_ l r -> catProducts l r)-      [ typeRep :=> Pair Has (Endo enableFeature)-      | RequireDeviceFeature { enableFeature } <- allReqs-      ]+    featureSetters :: DMap (Product (Has KnownFeatureStruct) Endo)+    featureSetters =+      dmapFromListWith+        catProducts+        [ typeRep :=> Pair Has (Endo enableFeature)+        | RequireDeviceFeature{enableFeature} <- allReqs+        ]      makeZeroFeatureExts :: [Endo (SomeStruct DeviceCreateInfo)]     makeZeroFeatureExts =       [ Endo (extendSomeStruct s)-      | _ :=> Pair Has (f :: Endo s) <- DMap.toList featureSetters-      , ExtendedFeatureStruct        <- pure $ sFeatureStruct @s+      | _ :=> Pair Has (f :: Endo s) <- dmapToList featureSetters+      , ExtendedFeatureStruct <- pure $ sFeatureStruct @s       , let s = appEndo f zero       ]      addBasicFeatures :: Endo (SomeStruct DeviceCreateInfo)     addBasicFeatures =-      case DMap.lookup (typeRep @PhysicalDeviceFeatures) featureSetters of-        Nothing         -> mempty-        Just (Pair _ s) -> Endo-          (extendSomeStruct-            ((zero :: PhysicalDeviceFeatures2 '[]) { features = appEndo s zero }+      case dmapLookup (typeRep @PhysicalDeviceFeatures) featureSetters of+        Nothing -> mempty+        Just (Pair _ s) ->+          Endo+            ( extendSomeStruct+                ((zero :: PhysicalDeviceFeatures2 '[]){features = appEndo s zero})             )-          )      extensionNames :: [ByteString]     extensionNames =       [ deviceExtensionName-      | RequireDeviceExtension { deviceExtensionName } <- allReqs+      | RequireDeviceExtension{deviceExtensionName} <- allReqs       ]      newFeatures :: SomeStruct DeviceCreateInfo-    newFeatures = appEndo-      (fold (addBasicFeatures : makeZeroFeatureExts))-      (SomeStruct (baseCreateInfo :: DeviceCreateInfo '[])-        { Device.enabledExtensionNames = V.fromList extensionNames-        }-      )+    newFeatures =+      appEndo+        (fold (addBasicFeatures : makeZeroFeatureExts))+        ( SomeStruct+            (baseCreateInfo :: DeviceCreateInfo '[])+              { Device.enabledExtensionNames = V.fromList extensionNames+              }+        )   in     newFeatures @@ -303,53 +332,50 @@    . (KnownChain fs, KnownChain ps)   => Maybe (PhysicalDeviceFeatures2 fs)   -> Maybe (PhysicalDeviceProperties2 ps)-  -> (  ("layerName" ::: Maybe ByteString)-     -> ("extensionName" ::: ByteString)-     -> Maybe ExtensionProperties+  -> ( ("layerName" ::: Maybe ByteString)+       -> ("extensionName" ::: ByteString)+       -> Maybe ExtensionProperties      )   -- ^ Lookup an extension   -> DeviceRequirement-  -- ^ The requirement to test   -> RequirementResult-  -- ^ The result checkDeviceRequest mbFeats mbProps lookupExtension = \case   RequireDeviceVersion minVersion     | Just props <- mbProps-    , foundVersion <- PhysicalDevice.apiVersion (PhysicalDevice.properties props)-    -> if foundVersion >= minVersion-      then Satisfied-      else UnsatisfiedDeviceVersion (Unsatisfied minVersion foundVersion)-    | otherwise-    -> UnattemptedProperties "apiVersion"--  RequireDeviceFeature { featureName, checkFeature }+    , foundVersion <- PhysicalDevice.apiVersion (PhysicalDevice.properties props) ->+        if foundVersion >= minVersion+          then Satisfied+          else UnsatisfiedDeviceVersion (Unsatisfied minVersion foundVersion)+    | otherwise ->+        UnattemptedProperties "apiVersion"+  RequireDeviceFeature{featureName, checkFeature}     | Just feats <- mbFeats -> case getFeatureStruct feats of-      Nothing ->-        error "Impossible: didn't find requested feature in struct chain"-      Just s ->-        if checkFeature s then Satisfied else UnsatisfiedFeature featureName+        Nothing ->+          error "Impossible: didn't find requested feature in struct chain"+        Just s ->+          if checkFeature s then Satisfied else UnsatisfiedFeature featureName     | otherwise -> UnattemptedFeatures featureName--  RequireDeviceProperty { propertyName, checkProperty }+  RequireDeviceProperty{propertyName, checkProperty}     | Just props <- mbProps -> case getPropertyStruct props of-      Nothing ->-        error "Impossible: didn't find requested property in struct chain"-      Just s ->-        if checkProperty s then Satisfied else UnsatisfiedProperty propertyName+        Nothing ->+          error "Impossible: didn't find requested property in struct chain"+        Just s ->+          if checkProperty s then Satisfied else UnsatisfiedProperty propertyName     | otherwise -> UnattemptedProperties propertyName--  RequireDeviceExtension { deviceExtensionLayerName, deviceExtensionName, deviceExtensionMinVersion }-    | Just eProps <- lookupExtension deviceExtensionLayerName-                                     deviceExtensionName-    -> let foundVersion = Extension.specVersion eProps-       in  if foundVersion >= deviceExtensionMinVersion+  RequireDeviceExtension{deviceExtensionLayerName, deviceExtensionName, deviceExtensionMinVersion}+    | Just eProps <-+        lookupExtension+          deviceExtensionLayerName+          deviceExtensionName ->+        let foundVersion = Extension.specVersion eProps+        in if foundVersion >= deviceExtensionMinVersion              then Satisfied-             else UnsatisfiedDeviceExtensionVersion-               deviceExtensionName-               (Unsatisfied deviceExtensionMinVersion foundVersion)-    | otherwise-    -> UnsatisfiedDeviceExtension deviceExtensionName-+             else+               UnsatisfiedDeviceExtensionVersion+                 deviceExtensionName+                 (Unsatisfied deviceExtensionMinVersion foundVersion)+    | otherwise ->+        UnsatisfiedDeviceExtension deviceExtensionName  ---------------------------------------------------------------- -- Results@@ -358,62 +384,67 @@ -- TODO, better version reporting for extensions -- TODO, better reporting for properties data RequirementResult-  = Satisfied-    -- ^ All the requirements were met-  | UnattemptedProperties ByteString-    -- ^ Didn't attempt this check because it required-    -- getPhysicalDeviceProperties2 which wasn't loaded-  | UnattemptedFeatures ByteString-    -- ^ Didn't attempt this check because it required-    -- getPhysicalDeviceFeatures2 which wasn't loaded-  | MissingLayer ByteString-    -- ^ A Layer was not found-  | UnsatisfiedDeviceVersion (Unsatisfied Word32)-    -- ^ A device version didn't meet the minimum requested-  | UnsatisfiedInstanceVersion (Unsatisfied Word32)-    -- ^ The instance version didn't meet the minimum requested-  | UnsatisfiedLayerVersion ByteString (Unsatisfied Word32)-    -- ^ A layer version didn't meet the minimum requested-  | UnsatisfiedFeature ByteString-    -- ^ A feature was missing-  | UnsatisfiedProperty ByteString-    -- ^ A propery was not an appropriate value-  | UnsatisfiedDeviceExtension ByteString-    -- ^ A device extension was missing-  | UnsatisfiedDeviceExtensionVersion ByteString (Unsatisfied Word32)-    -- ^ A device extension was found but the version didn't meet requirements-  | UnsatisfiedInstanceExtension ByteString-    -- ^ An instance extension was missing-  | UnsatisfiedInstanceExtensionVersion ByteString (Unsatisfied Word32)-    -- ^ An instance extension was found but the version didn't meet requirements+  = -- | All the requirements were met+    Satisfied+  | {- | Didn't attempt this check because it required+    getPhysicalDeviceProperties2 which wasn't loaded+    -}+    UnattemptedProperties ByteString+  | {- | Didn't attempt this check because it required+    getPhysicalDeviceFeatures2 which wasn't loaded+    -}+    UnattemptedFeatures ByteString+  | -- | A Layer was not found+    MissingLayer ByteString+  | -- | A device version didn't meet the minimum requested+    UnsatisfiedDeviceVersion (Unsatisfied Word32)+  | -- | The instance version didn't meet the minimum requested+    UnsatisfiedInstanceVersion (Unsatisfied Word32)+  | -- | A layer version didn't meet the minimum requested+    UnsatisfiedLayerVersion ByteString (Unsatisfied Word32)+  | -- | A feature was missing+    UnsatisfiedFeature ByteString+  | -- | A propery was not an appropriate value+    UnsatisfiedProperty ByteString+  | -- | A device extension was missing+    UnsatisfiedDeviceExtension ByteString+  | -- | A device extension was found but the version didn't meet requirements+    UnsatisfiedDeviceExtensionVersion ByteString (Unsatisfied Word32)+  | -- | An instance extension was missing+    UnsatisfiedInstanceExtension ByteString+  | -- | An instance extension was found but the version didn't meet requirements+    UnsatisfiedInstanceExtensionVersion ByteString (Unsatisfied Word32)   deriving (Eq, Ord)  data Unsatisfied a = Unsatisfied   { unsatisfiedMinimum :: a-    -- ^ The minimum value to be accepted-  , unsatisfiedActual  :: a-    -- ^ The value we got, less than 'unsatisfiedMinumum'+  -- ^ The minimum value to be accepted+  , unsatisfiedActual :: a+  -- ^ The value we got, less than 'unsatisfiedMinumum'   }   deriving (Eq, Ord) --- | Generate a string describing which requirements were not met, if--- everything was satisfied return 'Nothing'.+{- | Generate a string describing which requirements were not met, if+everything was satisfied return 'Nothing'.+-} requirementReport   :: (Foldable r, Foldable o)   => r RequirementResult   -> o RequirementResult   -> Maybe String requirementReport required optional =-  let pList xs =-        nubOrd [ prettyRequirementResult r | r <- toList xs, r /= Satisfied ]-      reqStrings = pList required-      optStrings = pList optional-      withHeader s = \case-        [] -> []-        xs -> (s <> " requirements not met:") : (("  " <>) <$> xs)-      reportLines =-        withHeader "Required" reqStrings <> withHeader "Optional" optStrings-  in  if null reportLines then Nothing else Just $ unlines reportLines+  let+    pList xs =+      nubOrd [prettyRequirementResult r | r <- toList xs, r /= Satisfied]+    reqStrings = pList required+    optStrings = pList optional+    withHeader s = \case+      [] -> []+      xs -> (s <> " requirements not met:") : (("  " <>) <$> xs)+    reportLines =+      withHeader "Required" reqStrings <> withHeader "Optional" optStrings+  in+    if null reportLines then Nothing else Just $ unlines reportLines  prettyRequirementResult :: RequirementResult -> String prettyRequirementResult = \case@@ -426,12 +457,12 @@     "Did not attempt to check "       <> show n       <> " because the 'getPhysicalDeviceFeatures' function was not loaded"-  MissingLayer               n -> "Couldn't find layer: " <> show n+  MissingLayer n -> "Couldn't find layer: " <> show n   UnsatisfiedInstanceVersion u -> "Unsatisfied Instance version: " <> p u-  UnsatisfiedDeviceVersion   u -> "Unsatisfied Device version: " <> p u+  UnsatisfiedDeviceVersion u -> "Unsatisfied Device version: " <> p u   UnsatisfiedLayerVersion n u ->     "Unsatisfied layer version for " <> show n <> ": " <> p u-  UnsatisfiedFeature  n -> "Missing feature: " <> show n+  UnsatisfiedFeature n -> "Missing feature: " <> show n   UnsatisfiedProperty n -> "Unsatisfied property: " <> show n   UnsatisfiedInstanceExtension n ->     "Couldn't find instance extension: " <> show n@@ -440,11 +471,12 @@   UnsatisfiedDeviceExtension n -> "Couldn't find device extension: " <> show n   UnsatisfiedDeviceExtensionVersion n u ->     "Unsatisfied Device extension version " <> show n <> " " <> p u-  where p = prettyUnsatisfied showVersion+  where+    p = prettyUnsatisfied showVersion  -- How I'm feeling after writing all this type level nonsense prettyUnsatisfied :: (t -> String) -> Unsatisfied t -> String-prettyUnsatisfied s Unsatisfied {..} =+prettyUnsatisfied s Unsatisfied{..} =   "Wanted minimum of "     <> s unsatisfiedMinimum     <> ", got: "@@ -456,9 +488,11 @@  -- | Enough information to focus on any structure within a Vulkan structure chain. class (PeekChain xs, PokeChain xs) => KnownChain (xs :: [Type]) where-  -- | If the given structure can be found within a chain, return a lens to it.-  -- Otherwise, return 'Nothing'.-  has :: forall a. Typeable a => Proxy# a -> Maybe (Chain xs -> a, (a -> a) -> (Chain xs -> Chain xs))+  {- | If the given structure can be found within a chain, return a lens to it.+  Otherwise, return 'Nothing'.+  -}+  has :: forall a. (Typeable a) => Proxy# a -> Maybe (Chain xs -> a, (a -> a) -> (Chain xs -> Chain xs))+   -- | Is this chain empty?   knownChainNull :: Maybe (xs :~: '[]) @@ -467,8 +501,9 @@   knownChainNull = Just Refl  instance (Typeable x, ToCStruct x, FromCStruct x, KnownChain xs) => KnownChain (x ': xs) where-  has (px :: Proxy# a) | Just Refl <- eqT @a @x = Just (fst, first)-                       | otherwise = ((. snd) *** (second .)) <$> has px+  has (px :: Proxy# a)+    | Just Refl <- eqT @a @x = Just (fst, first)+    | otherwise = ((. snd) *** (second .)) <$> has px   knownChainNull = Nothing  getPropertyStruct@@ -478,7 +513,7 @@   -> Maybe s getPropertyStruct c = case eqT @PhysicalDeviceProperties @s of   Just Refl -> Just $ PhysicalDevice.properties c-  Nothing   -> getStruct c+  Nothing -> getStruct c  getFeatureStruct   :: forall s es@@ -487,7 +522,7 @@   -> Maybe s getFeatureStruct c = case eqT @PhysicalDeviceFeatures @s of   Just Refl -> Just $ PhysicalDevice.features c-  Nothing   -> getStruct c+  Nothing -> getStruct c  getStruct   :: forall s h es@@ -500,26 +535,31 @@ -- Helpers for 'Device' and 'Instance' extensions ---------------------------------------------------------------- --- | Make a lookup function for extensions in layers. Ignores layers not--- present in the instance/device+{- | Make a lookup function for extensions in layers. Ignores layers not+present in the instance/device+-} getLookupExtension-  :: MonadIO m+  :: (MonadIO m)   => Vector LayerProperties   -> Maybe PhysicalDevice-  -- ^ Pass 'Nothing' for 'Instance' extensions, pass a PhysicalDevice for-  -- 'Device' extensions.+  {- ^ Pass 'Nothing' for 'Instance' extensions, pass a PhysicalDevice for+  'Device' extensions.+  -}   -> ["layerName" ::: Maybe ByteString]   -> m-       (  ("layerName" ::: Maybe ByteString)-       -> ByteString-       -> Maybe ExtensionProperties+       ( ("layerName" ::: Maybe ByteString)+         -> ByteString+         -> Maybe ExtensionProperties        ) getLookupExtension layerProps mbPhys extensionLayers = do-  let enumerate = maybe enumerateInstanceExtensionProperties-                        enumerateDeviceExtensionProperties-                        mbPhys-      availableLayers = Nothing : ((Just . layerName) <$> V.toList layerProps)-      searchedLayers = availableLayers `intersect` extensionLayers+  let+    enumerate =+      maybe+        enumerateInstanceExtensionProperties+        enumerateDeviceExtensionProperties+        mbPhys+    availableLayers = Nothing : ((Just . layerName) <$> V.toList layerProps)+    searchedLayers = availableLayers `intersect` extensionLayers   extensions <- for searchedLayers $ \layer -> do     (_, props) <- enumerate layer     pure (layer, props)@@ -533,58 +573,58 @@ ----------------------------------------------------------------  withDevicePropertyStructs-  :: forall a . [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a+  :: forall a. [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a withDevicePropertyStructs = go @'[] []- where-  go-    :: forall (fs :: [Type])-     . DevicePropertyChain fs-    => [SomeTypeRep]-    -> [DeviceRequirement]-    -> ChainCont DevicePropertyChain a-    -> a-  go seen reqs f = case reqs of-    -- We've been through all the reqs, call the continuation with the types-    [] -> f (Proxy @fs)-    -- This is a device property, add it to the list if we've not seen it before-    (RequireDeviceProperty _ (_ :: s -> Bool)) : rs-      | ExtendedPropertyStruct <- sPropertyStruct @s-      , sRep <- SomeTypeRep (typeRep @s)-      , sRep `notElem` seen-      -> go @(s:fs) (sRep : seen) rs f-    -- Otherwise skip-    _ : rs -> go @fs seen rs f+  where+    go+      :: forall (fs :: [Type])+       . (DevicePropertyChain fs)+      => [SomeTypeRep]+      -> [DeviceRequirement]+      -> ChainCont DevicePropertyChain a+      -> a+    go seen reqs f = case reqs of+      -- We've been through all the reqs, call the continuation with the types+      [] -> f (Proxy @fs)+      -- This is a device property, add it to the list if we've not seen it before+      (RequireDeviceProperty _ (_ :: s -> Bool)) : rs+        | ExtendedPropertyStruct <- sPropertyStruct @s+        , sRep <- SomeTypeRep (typeRep @s)+        , sRep `notElem` seen ->+            go @(s : fs) (sRep : seen) rs f+      -- Otherwise skip+      _ : rs -> go @fs seen rs f  withDeviceFeatureStructs-  :: forall a . [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a+  :: forall a. [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a withDeviceFeatureStructs = go @'[] []- where-  go-    :: forall (fs :: [Type])-     . DeviceFeatureChain fs-    => [SomeTypeRep]-    -> [DeviceRequirement]-    -> ChainCont DeviceFeatureChain a-    -> a-  go seen reqs f = case reqs of-    -- We've been through all the reqs, call the continuation with the types-    [] -> f (Proxy @fs)-    -- This is a device feature, add it to the list if we've not seen it before-    (RequireDeviceFeature _ _ (_ :: s -> s)) : rs-      | ExtendedFeatureStruct <- sFeatureStruct @s-      , sRep <- SomeTypeRep (typeRep @s)-      , sRep `notElem` seen-      -> go @(s:fs) (sRep : seen) rs f-    -- Otherwise skip-    _ : rs -> go @fs seen rs f+  where+    go+      :: forall (fs :: [Type])+       . (DeviceFeatureChain fs)+      => [SomeTypeRep]+      -> [DeviceRequirement]+      -> ChainCont DeviceFeatureChain a+      -> a+    go seen reqs f = case reqs of+      -- We've been through all the reqs, call the continuation with the types+      [] -> f (Proxy @fs)+      -- This is a device feature, add it to the list if we've not seen it before+      (RequireDeviceFeature _ _ (_ :: s -> s)) : rs+        | ExtendedFeatureStruct <- sFeatureStruct @s+        , sRep <- SomeTypeRep (typeRep @s)+        , sRep `notElem` seen ->+            go @(s : fs) (sRep : seen) rs f+      -- Otherwise skip+      _ : rs -> go @fs seen rs f -class (KnownChain es, Extendss PhysicalDeviceFeatures2 es, Show (Chain es)) => DeviceFeatureChain es where-instance (KnownChain es, Extendss PhysicalDeviceFeatures2 es, Show (Chain es)) => DeviceFeatureChain es where+class (KnownChain es, Extendss PhysicalDeviceFeatures2 es, Show (Chain es)) => DeviceFeatureChain es+instance (KnownChain es, Extendss PhysicalDeviceFeatures2 es, Show (Chain es)) => DeviceFeatureChain es -class (KnownChain es, Extendss PhysicalDeviceProperties2 es) => DevicePropertyChain es where-instance (KnownChain es, Extendss PhysicalDeviceProperties2 es) => DevicePropertyChain es where+class (KnownChain es, Extendss PhysicalDeviceProperties2 es) => DevicePropertyChain es+instance (KnownChain es, Extendss PhysicalDeviceProperties2 es) => DevicePropertyChain es -type ChainCont c a = forall (es :: [Type]) . (c es) => Proxy es -> a+type ChainCont c a = forall (es :: [Type]). (c es) => Proxy es -> a  ---------------------------------------------------------------- -- Helpers for getting features and properties without using the extended@@ -596,26 +636,30 @@    . (MonadIO m, KnownChain fs, Extendss PhysicalDeviceFeatures2 fs)   => PhysicalDevice   -> m (Maybe (PhysicalDeviceFeatures2 fs))-getPhysicalDeviceFeaturesMaybe = getMaybe pVkGetPhysicalDeviceFeatures2-                                          (PhysicalDeviceFeatures2 ())-                                          getPhysicalDeviceFeatures-                                          getPhysicalDeviceFeatures2+getPhysicalDeviceFeaturesMaybe =+  getMaybe+    pVkGetPhysicalDeviceFeatures2+    (PhysicalDeviceFeatures2 ())+    getPhysicalDeviceFeatures+    getPhysicalDeviceFeatures2  getPhysicalDevicePropertiesMaybe   :: forall fs m    . (MonadIO m, KnownChain fs, Extendss PhysicalDeviceProperties2 fs)   => PhysicalDevice   -> m (Maybe (PhysicalDeviceProperties2 fs))-getPhysicalDevicePropertiesMaybe = getMaybe pVkGetPhysicalDeviceProperties2-                                            (PhysicalDeviceProperties2 ())-                                            getPhysicalDeviceProperties-                                            getPhysicalDeviceProperties2+getPhysicalDevicePropertiesMaybe =+  getMaybe+    pVkGetPhysicalDeviceProperties2+    (PhysicalDeviceProperties2 ())+    getPhysicalDeviceProperties+    getPhysicalDeviceProperties2  getMaybe   :: forall fs s1 s2 m    . (MonadIO m, KnownChain fs, Extendss s2 fs)-  => (  InstanceCmds-     -> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ())+  => ( InstanceCmds+       -> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ())      )   -> (s1 -> s2 '[])   -> (PhysicalDevice -> m s1)@@ -624,9 +668,9 @@   -> m (Maybe (s2 fs)) getMaybe funPtr wrapper2 get1 get2 phys =   let hasFunPtr = funPtr (PhysicalDevice.instanceCmds phys) /= nullFunPtr-  in  case knownChainNull @fs of-        Just Refl -> Just . wrapper2 <$> get1 phys-        Nothing   -> if hasFunPtr then Just <$> get2 phys else pure Nothing+  in case knownChainNull @fs of+       Just Refl -> Just . wrapper2 <$> get1 phys+       Nothing -> if hasFunPtr then Just <$> get2 phys else pure Nothing  ---------------------------------------------------------------- -- Utils@@ -634,10 +678,11 @@  showVersion :: Word32 -> String showVersion ver = intercalate "." [show ma, show mi, show pa]-  where MAKE_API_VERSION ma mi pa = ver+  where+    MAKE_API_VERSION ma mi pa = ver  data Has c a where-  Has ::c a => Has c a+  Has :: (c a) => Has c a  instance Semigroup (Has c a) where   Has <> _ = Has@@ -649,3 +694,52 @@   -> Product f g a   -> Product f g a catProducts (Pair a1 b1) (Pair a2 b2) = Pair (a1 <> a2) (b1 <> b2)++----------------------------------------------------------------+-- A minimal dependent map keyed by 'TypeRep'+--+-- This is just enough to replace the uses of @dependent-map@ and+-- @dependent-sum@ in 'makeDeviceCreateInfo':+-- group the per-feature-struct setters by their+-- (existentially quantified) struct type, recovering that type+-- later to extend the chain.+----------------------------------------------------------------++{- | A dependent pair: a 'TypeRep' tag together with a value whose type is+determined by the tag.+-}+data DSum f = forall a. (TypeRep a) :=> (f a)++infixr 1 :=>++{- | A map from a type (witnessed by its 'TypeRep') to a value whose type+depends on that key.+-}+newtype DMap f = DMap (TRMap.Map SomeTypeRep (DSum f))++{- | Build a 'DMap' from a list of dependent pairs, combining the values of+any entries that share a key.+-}+dmapFromListWith :: (forall a. f a -> f a -> f a) -> [DSum f] -> DMap f+dmapFromListWith combine =+  DMap+    . TRMap.fromListWith merge+    . map (\d@(tr :=> _) -> (SomeTypeRep tr, d))+  where+    -- Both entries are stored under the same 'SomeTypeRep', so their tags+    -- necessarily witness the same type; 'eqTypeRep' recovers that equality+    -- so the values can be combined. The 'Nothing' case is unreachable.+    merge (trNew :=> vNew) (trOld :=> vOld) = case eqTypeRep trNew trOld of+      Just HRefl -> trNew :=> combine vNew vOld+      Nothing -> trNew :=> vNew++-- | The contents of a 'DMap', as dependent pairs.+dmapToList :: DMap f -> [DSum f]+dmapToList (DMap m) = TRMap.elems m++-- | Look up the value stored under a given type.+dmapLookup :: forall a f. TypeRep a -> DMap f -> Maybe (f a)+dmapLookup tr (DMap m) = do+  (trStored :=> v) <- TRMap.lookup (SomeTypeRep tr) m+  HRefl <- eqTypeRep tr trStored+  pure v

@@ -14,7 +14,7 @@ import Data.Either (lefts) import Data.Foldable import Data.Functor ((<&>))-import Data.List ( intercalate, isPrefixOf, dropWhileEnd )+import Data.List (dropWhileEnd, intercalate, isPrefixOf) import Data.List.Extra (nubOrd) import Data.Maybe import Data.String@@ -33,76 +33,79 @@ import Vulkan.Version (pattern MAKE_API_VERSION) import Prelude hiding (GT) --- $setup--- >>> import           Vulkan.Core11.Promoted_From_VK_KHR_multiview--- >>> import           Vulkan.Core12--- >>> import           Vulkan.Extensions.VK_KHR_ray_tracing_pipeline--- >>> import           Vulkan.Zero+{- $setup+>>> import           Vulkan.Core11.Promoted_From_VK_KHR_multiview+>>> import           Vulkan.Core12+>>> import           Vulkan.Extensions.VK_KHR_ray_tracing_pipeline+>>> import           Vulkan.Zero+-} --- | Parse a requirement and produce an appropriate 'DeviceRequirement'------ 'DeviceVersionRequirement's are specified by in the form--- @<major>.<minor>[.<patch>]@------ 'DeviceFeatureRequirement's are specified in the form @<type name>.<member--- name>@ and produce a 'RequireDeviceFeature' which checks and sets this--- feature.------ 'DevicePropertyRequirement's are specified like feature requirements except--- with an additional description of the constraint. This may be any of------ - @myFunctionName@: To check with an in-scope function taking the property---   type and returning 'Bool'--- - @> 123@: To indicate a minimum bound on a integral property--- - @>= 123@: To indicate an inclusive minimum bound on a integral property--- - @& SOMETHING_BIT@: To indicate that the specified bit must be present in---   the bitmask value------ 'DeviceExtensionRequirement's are specified in the form @<extension name>--- <optional version>@. @<extension name>@ must start with @VK_@. The version--- will be compared against the 'specVersion' field of the--- 'ExtensionProperties' record.------ - Names may be qualified.--- - The separator between the type and member can be any of @.@ @::@ @:@ @->@---   or any amount of space------ >>> let r = [req|PhysicalDeviceRayTracingPipelineFeaturesKHR.rayTracingPipeline|]--- >>> featureName r--- "PhysicalDeviceRayTracingPipelineFeaturesKHR.rayTracingPipeline"------ >>> let r = [req|PhysicalDeviceVulkan11Features.multiview|]--- >>> featureName r--- "PhysicalDeviceVulkan11Features.multiview"------ >>> let r = [reqs|  PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore |]--- >>> featureName <$> r--- ["PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore"]------ >>> let r = [req|PhysicalDeviceMultiviewFeatures.doesn'tExist|]--- ...---     • Couldn't find member "doesn'tExist" in Vulkan.Core11.Promoted_From_VK_KHR_multiview.PhysicalDeviceMultiviewFeatures--- ...------ >>> let r = [req|Doesn'tExist.multiview|]--- ...---     • Couldn't find type name "Doesn'tExist"--- ...------ >>> let r = [req|Either.multiview|]--- ...---     • Data.Either.Either doesn't seem to be the type of a record constructor--- ...+{- | Parse a requirement and produce an appropriate 'DeviceRequirement'++'DeviceVersionRequirement's are specified by in the form+@<major>.<minor>[.<patch>]@++'DeviceFeatureRequirement's are specified in the form @<type name>.<member+name>@ and produce a 'RequireDeviceFeature' which checks and sets this+feature.++'DevicePropertyRequirement's are specified like feature requirements except+with an additional description of the constraint. This may be any of++- @myFunctionName@: To check with an in-scope function taking the property+  type and returning 'Bool'+- @> 123@: To indicate a minimum bound on a integral property+- @>= 123@: To indicate an inclusive minimum bound on a integral property+- @& SOMETHING_BIT@: To indicate that the specified bit must be present in+  the bitmask value++'DeviceExtensionRequirement's are specified in the form @<extension name>+<optional version>@. @<extension name>@ must start with @VK_@. The version+will be compared against the 'specVersion' field of the+'ExtensionProperties' record.++- Names may be qualified.+- The separator between the type and member can be any of @.@ @::@ @:@ @->@+  or any amount of space++>>> let r = [req|PhysicalDeviceRayTracingPipelineFeaturesKHR.rayTracingPipeline|]+>>> featureName r+"PhysicalDeviceRayTracingPipelineFeaturesKHR.rayTracingPipeline"++>>> let r = [req|PhysicalDeviceVulkan11Features.multiview|]+>>> featureName r+"PhysicalDeviceVulkan11Features.multiview"++>>> let r = [reqs|  PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore |]+>>> featureName <$> r+["PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore"]++>>> let r = [req|PhysicalDeviceMultiviewFeatures.doesn'tExist|]+...+    • Couldn't find member "doesn'tExist" in Vulkan.Core11.Promoted_From_VK_KHR_multiview.PhysicalDeviceMultiviewFeatures+...++>>> let r = [req|Doesn'tExist.multiview|]+...+    • Couldn't find type name "Doesn'tExist"+...++>>> let r = [req|Either.multiview|]+...+    • Data.Either.Either doesn't seem to be the type of a record constructor+...+-} req :: QuasiQuoter req = (badQQ "req"){quoteExp = reqExp} --- | Like 'reqs' except that this parses a list of newline separated--- requirements------ It ignores------ - Blank lines--- - Lines beginning with @--@ or @#@+{- | Like 'reqs' except that this parses a list of newline separated+requirements++It ignores++- Blank lines+- Lines beginning with @--@ or @#@+-} reqs :: QuasiQuoter reqs = (badQQ "req"){quoteExp = exps reqExp . filterComments} @@ -117,38 +120,48 @@ renderRequest :: String -> Request Name Name -> ExpQ renderRequest input = \case   Feature s m ->-    let check = explicitRecordGet s m (ConT ''Bool)-        enable = explicitRecordSet s m (ConT ''Bool) [|True|]-     in do-          [|-            let featureName = fromString $(lift input)-                checkFeature = $(check)-                enableFeature = $(enable)-             in RequireDeviceFeature featureName checkFeature enableFeature-            |]-  Property s m c ->-    let t = conT s-        getProp = [|\str -> $(varE m) (str :: $t)|]-        checker = case c of-          GTE v -> [|(>= $(litE (IntegerL v)))|]-          GT v -> [|(> $(litE (IntegerL v)))|]-          AndBit b -> [|(.&&. $(conE b))|]-          Fun f -> [|$(varE f)|]-        check = [|$checker . $getProp|]-     in [|-          let propertyName = fromString $(lift input)-              checkProperty = $(check)-           in RequireDeviceProperty propertyName checkProperty+    let+      check = explicitRecordGet s m (ConT ''Bool)+      enable = explicitRecordSet s m (ConT ''Bool) [|True|]+    in+      do+        [|+          let+            featureName = fromString $(lift input)+            checkFeature = $(check)+            enableFeature = $(enable)+          in+            RequireDeviceFeature featureName checkFeature enableFeature           |]+  Property s m c ->+    let+      t = conT s+      getProp = [|\str -> $(varE m) (str :: $t)|]+      checker = case c of+        GTE v -> [|(>= $(litE (IntegerL v)))|]+        GT v -> [|(> $(litE (IntegerL v)))|]+        AndBit b -> [|(.&&. $(conE b))|]+        Fun f -> [|$(varE f)|]+      check = [|$checker . $getProp|]+    in+      [|+        let+          propertyName = fromString $(lift input)+          checkProperty = $(check)+        in+          RequireDeviceProperty propertyName checkProperty+        |]   Extension s v ->     [|-      let deviceExtensionLayerName = Nothing-          deviceExtensionName = fromString $(lift s)-          deviceExtensionMinVersion = $(lift (fromMaybe minBound v))-       in RequireDeviceExtension-            deviceExtensionLayerName-            deviceExtensionName-            deviceExtensionMinVersion+      let+        deviceExtensionLayerName = Nothing+        deviceExtensionName = fromString $(lift s)+        deviceExtensionMinVersion = $(lift (fromMaybe minBound v))+      in+        RequireDeviceExtension+          deviceExtensionLayerName+          deviceExtensionName+          deviceExtensionMinVersion       |]   Version v -> [|RequireDeviceVersion $(lift v)|] @@ -165,15 +178,15 @@     pure $ Property sName mName c'   Extension s v -> pure $ Extension s v   Version v -> pure $ Version v- where-  getQualTyName n = do-    let q = intercalate "." n-    maybe (fail $ "Couldn't find type name " <> show q) pure-      =<< lookupTypeName q-  getQualValueName n = do-    let q = intercalate "." n-    maybe (fail $ "Couldn't find value name " <> show q) pure-      =<< lookupValueName q+  where+    getQualTyName n = do+      let q = intercalate "." n+      maybe (fail $ "Couldn't find type name " <> show q) pure+        =<< lookupTypeName q+    getQualValueName n = do+      let q = intercalate "." n+      maybe (fail $ "Couldn't find value name " <> show q) pure+        =<< lookupValueName q  data Request qual unqual   = Version Word32@@ -189,104 +202,107 @@   | Fun qual   deriving (Show, Functor, Foldable, Traversable) --- |--- >>> parse ""--- Nothing------ >>> parse "Foo->bar"--- Just (Feature ["Foo"] "bar")------ >>> parse "V.Foo.bar"--- Just (Feature ["V","Foo"] "bar")------ >>> parse "V.E.Foo bar"--- Just (Feature ["V","E","Foo"] "bar")------ >>> parse "1.2"--- Just (Version 4202496)------ >>> parse "1 2 1"--- Just (Version 4202497)------ >>> parse "Foo.bar >= 10"--- Just (Property ["Foo"] "bar" (GTE 10))------ >>> parse "V.Foo.bar & A.B.C_BIT"--- Just (Property ["V","Foo"] "bar" (AndBit ["A","B","C_BIT"]))------ >>> parse "V.Foo.bar even"--- Just (Property ["V","Foo"] "bar" (Fun ["even"]))------ >>> parse "V.Foo.bar Prelude.even"--- Just (Property ["V","Foo"] "bar" (Fun ["Prelude","even"]))+{- |+>>> parse ""+Nothing++>>> parse "Foo->bar"+Just (Feature ["Foo"] "bar")++>>> parse "V.Foo.bar"+Just (Feature ["V","Foo"] "bar")++>>> parse "V.E.Foo bar"+Just (Feature ["V","E","Foo"] "bar")++>>> parse "1.2"+Just (Version 4202496)++>>> parse "1 2 1"+Just (Version 4202497)++>>> parse "Foo.bar >= 10"+Just (Property ["Foo"] "bar" (GTE 10))++>>> parse "V.Foo.bar & A.B.C_BIT"+Just (Property ["V","Foo"] "bar" (AndBit ["A","B","C_BIT"]))++>>> parse "V.Foo.bar even"+Just (Property ["V","Foo"] "bar" (Fun ["even"]))++>>> parse "V.Foo.bar Prelude.even"+Just (Property ["V","Foo"] "bar" (Fun ["Prelude","even"]))+-} parse :: String -> Maybe (Request [String] String) parse =-  let varRemChars = munch (isAlphaNum <||> (== '\'') <||> (== '_'))-      var = (:) <$> satisfy (isLower <||> (== '_')) <*> varRemChars-      con = (:) <$> satisfy isUpper <*> varRemChars-      mod' = con-      qual :: ReadP String -> ReadP [String]-      qual x = (pure <$> x) <|> ((:) <$> (mod' <* char '.') <*> qual x)-      separator = asum (skipSpaces : (void . string <$> [".", "->", "::", ":"]))+  let+    varRemChars = munch (isAlphaNum <||> (== '\'') <||> (== '_'))+    var = (:) <$> satisfy (isLower <||> (== '_')) <*> varRemChars+    con = (:) <$> satisfy isUpper <*> varRemChars+    mod' = con+    qual :: ReadP String -> ReadP [String]+    qual x = (pure <$> x) <|> ((:) <$> (mod' <* char '.') <*> qual x)+    separator = asum (skipSpaces : (void . string <$> [".", "->", "::", ":"])) -      digits = munch1 isDigit-      integer = readS_to_P (reads @Integer)-      word = do-        Just w <- readMaybe <$> digits-        pure w+    digits = munch1 isDigit+    integer = readS_to_P (reads @Integer)+    word = do+      Just w <- readMaybe <$> digits+      pure w -      comp = do-        c <- (GT <$ string ">") <|> (GTE <$ string ">=")-        skipSpaces-        w <- integer-        pure $ c w-      andBit = do-        _ <- string "&"-        skipSpaces-        q <- qual con-        pure $ AndBit q-      fun = Fun <$> qual var-      constraint = comp <|> andBit <|> fun+    comp = do+      c <- (GT <$ string ">") <|> (GTE <$ string ">=")+      skipSpaces+      w <- integer+      pure $ c w+    andBit = do+      _ <- string "&"+      skipSpaces+      q <- qual con+      pure $ AndBit q+    fun = Fun <$> qual var+    constraint = comp <|> andBit <|> fun -      version = do-        ma <- word-        separator-        mi <- word-        pa <- fromMaybe 0 <$> (separator *> optional word)-        pure $ Version (MAKE_API_VERSION ma mi pa)+    version = do+      ma <- word+      separator+      mi <- word+      pa <- fromMaybe 0 <$> (separator *> optional word)+      pure $ Version (MAKE_API_VERSION ma mi pa) -      feature = do-        s <- qual con-        _ <- separator-        m <- var-        pure $ Feature s m+    feature = do+      s <- qual con+      _ <- separator+      m <- var+      pure $ Feature s m -      property = do-        s <- qual con-        _ <- separator-        m <- var-        skipSpaces-        c <- constraint-        pure $ Property s m c+    property = do+      s <- qual con+      _ <- separator+      m <- var+      skipSpaces+      c <- constraint+      pure $ Property s m c -      extension = do-        let prefix = "VK_"-        _ <- string prefix-        e <- (prefix <>) <$> munch (isAlphaNum <||> (== '_'))-        skipSpaces-        v <- optional word-        pure $ Extension e v+    extension = do+      let prefix = "VK_"+      _ <- string prefix+      e <- (prefix <>) <$> munch (isAlphaNum <||> (== '_'))+      skipSpaces+      v <- optional word+      pure $ Extension e v -      request = do-        skipSpaces-        asum-          [ p <* skipSpaces <* eof-          | p <- [version, feature, property, extension]-          ]-   in readP_to_S request >>> \case-        -- xs        -> pure $ Feature [] (show xs)-        [(r, "")] -> pure r-        _ -> Nothing+    request = do+      skipSpaces+      asum+        [ p <* skipSpaces <* eof+        | p <- [version, feature, property, extension]+        ]+  in+    readP_to_S request >>> \case+      -- xs        -> pure $ Feature [] (show xs)+      [(r, "")] -> pure r+      _ -> Nothing {-# ANN parse ("HLint: ignore Use <$>" :: String) #-}  ----------------------------------------------------------------@@ -297,7 +313,7 @@ filterComments :: String -> [String] filterComments =   let bad = (("--" `isPrefixOf`) <||> ("#" `isPrefixOf`) <||> null)-   in nubOrd . filter (not . bad) . fmap strip . lines+  in nubOrd . filter (not . bad) . fmap strip . lines  strip :: String -> String strip = dropWhile isSpace . dropWhileEnd isSpace@@ -305,7 +321,7 @@ exps :: (String -> ExpQ) -> [String] -> ExpQ exps f = listE . fmap f -(<||>) :: Applicative f => f Bool -> f Bool -> f Bool+(<||>) :: (Applicative f) => f Bool -> f Bool -> f Bool (<||>) = liftA2 (||)  ----------------------------------------------------------------@@ -354,31 +370,34 @@   -- ^ (Constructor, [Left var name, Right selected member type]) overRecord s (nameBase -> m) t = do   reify s >>= \case-    TyConI (DataD _ _ _ _ [c] _) | RecC con vs <- c ->-      let ns = vs <&> \case-            (nameBase -> n, _bang, t') | n == m    -> Left t'-                                       | otherwise -> Right n-      in  case lefts ns of-            [] -> fail $ "Couldn't find member " <> show m <> " in " <> show s-            [t']-              | t == t'-              -> pure (con, ns)-              | otherwise-              -> fail-                $  "Member "-                <> show m-                <> " of "-                <> show s-                <> " has type "-                <> show t'-                <> " but we expected "-                <> show t-            _ ->-              fail-                $  "Found multiple members called"-                <> show m-                <> " in "-                <> show s-                <> " ...what?"+    TyConI (DataD _ _ _ _ [c] _)+      | RecC con vs <- c ->+          let ns =+                vs <&> \case+                  (nameBase -> n, _bang, t')+                    | n == m -> Left t'+                    | otherwise -> Right n+          in case lefts ns of+               [] -> fail $ "Couldn't find member " <> show m <> " in " <> show s+               [t']+                 | t == t' ->+                     pure (con, ns)+                 | otherwise ->+                     fail $+                       "Member "+                         <> show m+                         <> " of "+                         <> show s+                         <> " has type "+                         <> show t'+                         <> " but we expected "+                         <> show t+               _ ->+                 fail $+                   "Found multiple members called"+                     <> show m+                     <> " in "+                     <> show s+                     <> " ...what?"     _ ->       fail $ show s <> " doesn't seem to be the type of a record constructor"

@@ -0,0 +1,55 @@+module Vulkan.Utils.Shader+  ( shaderStage+  , shaderModuleStage+  ) where++import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, allocate)+import Data.ByteString (ByteString)+import Vulkan.CStruct.Extends (SomeStruct (..))+import qualified Vulkan.Core10 as Vk+import Vulkan.Utils.Pipeline.Specialization (Specialization, allocateSpecialization)+import Vulkan.Zero (zero)++{- | Build a 'PipelineShaderStageCreateInfo' for a single SPIR-V module with+entry point @main@. The returned 'ReleaseKey' frees the module — release it+once the pipeline is built.++The @spec@ argument supplies specialization constants (see+'Vulkan.Utils.Pipeline.Specialization'); pass @()@ for none.+-}+shaderStage+  :: (MonadResource m, Specialization spec)+  => Vk.Device+  -> Vk.ShaderStageFlagBits+  -> spec+  -> ByteString+  -> m (ReleaseKey, SomeStruct Vk.PipelineShaderStageCreateInfo)+shaderStage dev stage spec code = do+  specializationInfo <- allocateSpecialization spec+  shaderModuleStage dev stage specializationInfo code++{- | Lower-level companion to 'shaderStage' taking an already-built+'Vk.SpecializationInfo' (or 'Nothing'). Useful when one specialization is shared+across several stages — build it once with+'Vulkan.Utils.Pipeline.Specialization.withSpecialization' and pass it to each+stage rather than re-packing per stage.+-}+shaderModuleStage+  :: (MonadResource m)+  => Vk.Device+  -> Vk.ShaderStageFlagBits+  -> Maybe Vk.SpecializationInfo+  -> ByteString+  -> m (ReleaseKey, SomeStruct Vk.PipelineShaderStageCreateInfo)+shaderModuleStage dev stage specializationInfo code = do+  (key, module') <- Vk.withShaderModule dev zero{Vk.code = code} Nothing allocate+  pure+    ( key+    , SomeStruct+        zero+          { Vk.stage+          , Vk.module'+          , Vk.name = "main"+          , Vk.specializationInfo+          }+    )

@@ -4,9 +4,9 @@   , processGlslangMessages   ) where -import qualified Data.ByteString.Lazy.Char8    as BSL-import           Data.List.Extra-import           System.FilePath+import qualified Data.ByteString.Lazy.Char8 as BSL+import Data.List.Extra+import System.FilePath  type GlslangError = String type GlslangWarning = String@@ -14,10 +14,12 @@ processGlslangMessages :: BSL.ByteString -> ([GlslangWarning], [GlslangError]) processGlslangMessages =   foldr grep ([], []) . filter (not . null) . lines . BSL.unpack- where-  grep line (ws, es) | "WARNING: " `isPrefixOf` line = (cut line : ws, es)-                     | "ERROR: " `isPrefixOf` line   = (ws, cut line : es)-                     | otherwise                     = (ws, es)+  where+    grep line (ws, es)+      | "WARNING: " `isPrefixOf` line = (cut line : ws, es)+      | "ERROR: " `isPrefixOf` line = (ws, cut line : es)+      | otherwise = (ws, es) -  cut line = takeFileName path <> msg-    where (path, msg) = break (== ':') . drop 1 $ dropWhile (/= ' ') line+    cut line = takeFileName path <> msg+      where+        (path, msg) = break (== ':') . drop 1 $ dropWhile (/= ' ') line

@@ -3,30 +3,30 @@   , compileShader   ) where -import           Control.Monad.IO.Class-import           Data.ByteString                ( ByteString )-import qualified Data.ByteString               as BS-import           Data.FileEmbed-import           Language.Haskell.TH-import           System.Exit-import           System.IO.Temp-import           System.Process.Typed-import           Vulkan.Utils.ShaderQQ.ShaderType-import qualified Vulkan.Utils.ShaderQQ.GLSL    as GLSL-import qualified Vulkan.Utils.ShaderQQ.HLSL    as HLSL-import           Vulkan.Utils.ShaderQQ.Backend.Glslang-import           Vulkan.Utils.ShaderQQ.Backend.Internal+import Control.Monad.IO.Class+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.FileEmbed+import Language.Haskell.TH+import System.Exit+import System.IO.Temp+import System.Process.Typed+import Vulkan.Utils.ShaderQQ.Backend.Glslang+import Vulkan.Utils.ShaderQQ.Backend.Internal+import qualified Vulkan.Utils.ShaderQQ.GLSL as GLSL+import qualified Vulkan.Utils.ShaderQQ.HLSL as HLSL+import Vulkan.Utils.ShaderQQ.ShaderType  -- * Utilities --- | Compile a GLSL/HLSL shader to spir-v using glslangValidator.------ Messages are converted to GHC warnings or errors depending on compilation success.+{- | Compile a GLSL/HLSL shader to spir-v using glslangValidator.++Messages are converted to GHC warnings or errors depending on compilation success.+-} compileShaderQ   :: Maybe String   -- ^ Argument to pass to `--target-env`   -> ShaderType-  -- ^ Argument to specify between glsl/hlsl shader   -> String   -- ^ stage   -> Maybe String@@ -36,20 +36,19 @@   -> Q Exp   -- ^ Spir-V bytecode compileShaderQ targetEnv shaderType stage entryPoint code = do-  loc                <- location+  loc <- location   (warnings, result) <- compileShader (Just loc) targetEnv shaderType stage entryPoint code   bs <- messageProcess "glslangValidator" reportWarning fail (warnings, result)   bsToExp bs  -- | Compile a GLSL/HLSL shader to spir-v using glslangValidator compileShader-  :: MonadIO m+  :: (MonadIO m)   => Maybe Loc   -- ^ Source location   -> Maybe String   -- ^ Argument to pass to `--target-env`   -> ShaderType-  -- ^ Argument to specify between glsl/hlsl shader   -> String   -- ^ stage   -> Maybe String@@ -60,27 +59,33 @@   -- ^ Spir-V bytecode with warnings or errors compileShader loc targetEnv shaderType stage entryPoint code =   liftIO $ withSystemTempDirectory "th-shader" $ \dir -> do-    let codeWithLineDirective = maybe code (case shaderType of-                                              GLSL -> GLSL.insertLineDirective code-                                              HLSL -> HLSL.insertLineDirective code-                                           ) loc-    let shader = dir <> "/shader." <> stage-        spirv  = dir <> "/shader.spv"+    let codeWithLineDirective =+          maybe+            code+            ( case shaderType of+                GLSL -> GLSL.insertLineDirective code+                HLSL -> HLSL.insertLineDirective code+            )+            loc+    let+      shader = dir <> "/shader." <> stage+      spirv = dir <> "/shader.spv"     writeFile shader codeWithLineDirective -    let targetArgs = case targetEnv of-          Nothing -> []-          Just t  -> ["--target-env", t]-        shaderTypeArgs = case shaderType of-          GLSL -> []-          HLSL -> ["-D"]-        -- https://github.com/KhronosGroup/glslang/issues/1045#issuecomment-328707953-        entryPointArgs = case entryPoint of-          Nothing -> []-          Just name -> case shaderType of-            GLSL -> ["-e", name, "--source-entry-point", "main"]-            HLSL -> ["-e", name]-        args = targetArgs ++ shaderTypeArgs ++ entryPointArgs ++ ["-S", stage, "-V", shader, "-o", spirv]+    let+      targetArgs = case targetEnv of+        Nothing -> []+        Just t -> ["--target-env", t]+      shaderTypeArgs = case shaderType of+        GLSL -> []+        HLSL -> ["-D"]+      -- https://github.com/KhronosGroup/glslang/issues/1045#issuecomment-328707953+      entryPointArgs = case entryPoint of+        Nothing -> []+        Just name -> case shaderType of+          GLSL -> ["-e", name, "--source-entry-point", "main"]+          HLSL -> ["-e", name]+      args = targetArgs ++ shaderTypeArgs ++ entryPointArgs ++ ["-S", stage, "-V", shader, "-o", spirv]     (rc, out, err) <- readProcess $ proc "glslangValidator" args     let (warnings, errors) = processGlslangMessages (out <> err)     case rc of

@@ -2,8 +2,8 @@   ( messageProcess   ) where -import           Data.ByteString                ( ByteString )-import           Data.List.Extra+import Data.ByteString (ByteString)+import Data.List.Extra  messageProcess   :: (Applicative m, Monad m)@@ -19,10 +19,10 @@   -- ^ Spir-V bytecode messageProcess tool warn err (warnings, result) = do   case warnings of-    []    -> pure ()+    [] -> pure ()     _some -> warn $ prepare warnings   case result of-    Left []     -> err $ tool ++ " failed with no errors"+    Left [] -> err $ tool ++ " failed with no errors"     Left errors -> do       _ <- err $ prepare errors       pure mempty

@@ -4,10 +4,10 @@   , processShadercMessages   ) where -import           Control.Monad                  ( void )-import qualified Data.ByteString.Lazy.Char8    as BSL-import           Data.Foldable                  ( asum )-import           Text.ParserCombinators.ReadP+import Control.Monad (void)+import qualified Data.ByteString.Lazy.Char8 as BSL+import Data.Foldable (asum)+import Text.ParserCombinators.ReadP  type ShadercError = String type ShadercWarning = String@@ -39,59 +39,61 @@ -- >>> parseMsg "foo: foo(1): error at column 3, HLSL parsing failed." -- ([],["foo:1: error at column 3, HLSL parsing failed."]) parseMsg :: String -> ([ShadercWarning], [ShadercError])-parseMsg = runParser $ foldl1-  (<++)-  [ do-    f    <- filename-    line <- between colon colon number-    skipSpaces-    t   <- msgType-    msg <- manyTill get eof-    pure $ formatMsg t f line msg-  , do-    f <- filename-    colon *> skipSpaces-    t    <- msgType-    _    <- string f-    line <- between (char ':') (char ':') number-    skipSpaces-    msg <- manyTill get eof-    pure $ formatMsg t f line msg-  , do-    f <- filename-    colon *> skipSpaces-    _    <- string f-    line <- between (char '(') (char ')') number-    colon *> skipSpaces-    let t x = ([], [x])-    msg <- manyTill get eof-    pure $ formatMsg t f line msg-  , do-    _ <- number-    skipSpaces-    _ <- string "errors generated"-    eof-    pure ([], [])-  , do-    -- Unknown format-    msg <- manyTill get eof-    eof-    pure ([], [msg])-  ]- where-  formatMsg t f line msg = t (f <> ":" <> show line <> ": " <> msg)-  filename = many1 get-  number   = readS_to_P (reads @Integer)-  colon    = void $ char ':'-  msgType =-    asum+parseMsg =+  runParser $+    foldl1+      (<++)+      [ do+          f <- filename+          line <- between colon colon number+          skipSpaces+          t <- msgType+          msg <- manyTill get eof+          pure $ formatMsg t f line msg+      , do+          f <- filename+          colon *> skipSpaces+          t <- msgType+          _ <- string f+          line <- between (char ':') (char ':') number+          skipSpaces+          msg <- manyTill get eof+          pure $ formatMsg t f line msg+      , do+          f <- filename+          colon *> skipSpaces+          _ <- string f+          line <- between (char '(') (char ')') number+          colon *> skipSpaces+          let t x = ([], [x])+          msg <- manyTill get eof+          pure $ formatMsg t f line msg+      , do+          _ <- number+          skipSpaces+          _ <- string "errors generated"+          eof+          pure ([], [])+      , do+          -- Unknown format+          msg <- manyTill get eof+          eof+          pure ([], [msg])+      ]+  where+    formatMsg t f line msg = t (f <> ":" <> show line <> ": " <> msg)+    filename = many1 get+    number = readS_to_P (reads @Integer)+    colon = void $ char ':'+    msgType =+      asum         [ (\x -> ([], [x])) <$ string "error"         , (\x -> ([x], [])) <$ string "warning"         ]-      <* colon-      <* skipSpaces+        <* colon+        <* skipSpaces -runParser :: Monoid p => ReadP p -> String -> p+runParser :: (Monoid p) => ReadP p -> String -> p runParser p s = case readP_to_S p s of   [(r, "")] -> r-  _         -> mempty+  _ -> mempty

@@ -3,30 +3,30 @@   , compileShader   ) where -import           Control.Monad.IO.Class-import           Data.ByteString                ( ByteString )-import qualified Data.ByteString               as BS-import           Data.FileEmbed-import           Language.Haskell.TH-import           System.Exit-import           System.IO.Temp-import           System.Process.Typed-import           Vulkan.Utils.ShaderQQ.ShaderType-import qualified Vulkan.Utils.ShaderQQ.GLSL    as GLSL-import qualified Vulkan.Utils.ShaderQQ.HLSL    as HLSL-import           Vulkan.Utils.ShaderQQ.Backend.Shaderc-import           Vulkan.Utils.ShaderQQ.Backend.Internal+import Control.Monad.IO.Class+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.FileEmbed+import Language.Haskell.TH+import System.Exit+import System.IO.Temp+import System.Process.Typed+import Vulkan.Utils.ShaderQQ.Backend.Internal+import Vulkan.Utils.ShaderQQ.Backend.Shaderc+import qualified Vulkan.Utils.ShaderQQ.GLSL as GLSL+import qualified Vulkan.Utils.ShaderQQ.HLSL as HLSL+import Vulkan.Utils.ShaderQQ.ShaderType  -- * Utilities --- | Compile a GLSL/HLSL shader to SPIR-V using glslc (from the shaderc project)------ Messages are converted to GHC warnings or errors depending on compilation success.+{- | Compile a GLSL/HLSL shader to SPIR-V using glslc (from the shaderc project)++Messages are converted to GHC warnings or errors depending on compilation success.+-} compileShaderQ   :: Maybe String   -- ^ Argument to pass to `--target-spv`   -> ShaderType-  -- ^ Argument to specify between glsl/hlsl shader   -> String   -- ^ stage   -> Maybe String@@ -36,20 +36,19 @@   -> Q Exp   -- ^ Spir-V bytecode compileShaderQ targetSpv shaderType stage entryPoint code = do-  loc                <- location+  loc <- location   (warnings, result) <- compileShader (Just loc) targetSpv shaderType stage entryPoint code   bs <- messageProcess "glslc" reportWarning fail (warnings, result)   bsToExp bs  -- | Compile a GLSL/HLSL shader to spir-v using glslc compileShader-  :: MonadIO m+  :: (MonadIO m)   => Maybe Loc   -- ^ Source location   -> Maybe String   -- ^ Argument to pass to `--target-spv`   -> ShaderType-  -- ^ Argument to specify between glsl/hlsl shader   -> String   -- ^ stage   -> Maybe String@@ -60,24 +59,30 @@   -- ^ Spir-V bytecode with warnings or errors compileShader loc targetSpv shaderType stage entryPoint code =   liftIO $ withSystemTempDirectory "th-shader" $ \dir -> do-    let codeWithLineDirective = maybe code (case shaderType of-                                              GLSL -> GLSL.insertLineDirective code-                                              HLSL -> HLSL.insertLineDirective code-                                           ) loc-    let shader = dir <> "/shader." <> stage-        spirv  = dir <> "/shader.spv"+    let codeWithLineDirective =+          maybe+            code+            ( case shaderType of+                GLSL -> GLSL.insertLineDirective code+                HLSL -> HLSL.insertLineDirective code+            )+            loc+    let+      shader = dir <> "/shader." <> stage+      spirv = dir <> "/shader.spv"     writeFile shader codeWithLineDirective -    let targetArgs = case targetSpv of-          Nothing -> []-          Just t  -> ["--target-spv=" <> t]-        -- https://github.com/google/shaderc/blob/01dd72d6079ebdc0f96859365ba7abb1b62758bf/glslc/src/main.cc#L64-        entryPointArgs = case entryPoint of-          Nothing -> []-          Just name -> case shaderType of-            GLSL -> []-            HLSL -> ["-fentry-point=" <> name] -        args = targetArgs ++ entryPointArgs ++ ["-fshader-stage=" <> stage, "-x", show shaderType, shader, "-o", spirv]+    let+      targetArgs = case targetSpv of+        Nothing -> []+        Just t -> ["--target-spv=" <> t]+      -- https://github.com/google/shaderc/blob/01dd72d6079ebdc0f96859365ba7abb1b62758bf/glslc/src/main.cc#L64+      entryPointArgs = case entryPoint of+        Nothing -> []+        Just name -> case shaderType of+          GLSL -> []+          HLSL -> ["-fentry-point=" <> name]+      args = targetArgs ++ entryPointArgs ++ ["-fshader-stage=" <> stage, "-x", show shaderType, shader, "-o", spirv]     (rc, out, err) <- readProcess $ proc "glslc" args     let (warnings, errors) = processShadercMessages (out <> err)     case rc of

@@ -3,57 +3,62 @@   , insertLineDirective   ) where -import           Language.Haskell.TH-import           Language.Haskell.TH.Quote-import           Vulkan.Utils.Internal                  ( badQQ )-import           Vulkan.Utils.ShaderQQ.Interpolate-import           Data.Char-import           Data.List.Extra+import Data.Char+import Data.List.Extra+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Vulkan.Utils.Internal (badQQ)+import Vulkan.Utils.ShaderQQ.Interpolate --- $setup--- >>> :set -XQuasiQuotes+{- $setup+>>> :set -XQuasiQuotes+-} --- | 'glsl' is a QuasiQuoter which produces GLSL source code with @#line@--- directives inserted so that error locations point to the correct location in--- the Haskell source file. It also permits basic string interpolation.------ - Interpolated variables are prefixed with @$@--- - They can optionally be surrounded with braces like @${foo}@--- - Interpolated variables are converted to strings with 'show'--- - To escape a @$@ use @\\$@------ An explicit example (@<interactive>@ is from doctest):------ >>> let version = 450 :: Int in [glsl|#version $version|]--- "#version 450\n#extension GL_GOOGLE_cpp_style_line_directive : enable\n#line ... \"<interactive>\"\n"------ Note that line number will be thrown off if any of the interpolated--- variables contain newlines.+{- | 'glsl' is a QuasiQuoter which produces GLSL source code with @#line@+directives inserted so that error locations point to the correct location in+the Haskell source file. It also permits basic string interpolation.++- Interpolated variables are prefixed with @$@+- They can optionally be surrounded with braces like @${foo}@+- Interpolated variables are converted to strings with 'show'+- To escape a @$@ use @\\$@++An explicit example (@<interactive>@ is from doctest):++>>> let version = 450 :: Int in [glsl|#version $version|]+"#version 450\n#extension GL_GOOGLE_cpp_style_line_directive : enable\n#line ... \"<interactive>\"\n"++Note that line number will be thrown off if any of the interpolated+variables contain newlines.+-} glsl :: QuasiQuoter-glsl = (badQQ "glsl")-  { quoteExp = \s -> do-                 loc <- location-                 -- Insert the directive here, `compileShaderQ` will insert-                 -- another one, but it's before this one, so who cares.-                 let codeWithLineDirective = insertLineDirective s loc-                 interpExp codeWithLineDirective-  }+glsl =+  (badQQ "glsl")+    { quoteExp = \s -> do+        loc <- location+        -- Insert the directive here, `compileShaderQ` will insert+        -- another one, but it's before this one, so who cares.+        let codeWithLineDirective = insertLineDirective s loc+        interpExp codeWithLineDirective+    }  -- If possible, insert a #line directive after the #version directive (as well -- as the extension which allows filenames in line directives. insertLineDirective :: String -> Loc -> String-insertLineDirective code Loc {..} =-  let isVersionDirective = ("#version" `isPrefixOf`) . dropWhile isSpace-      codeLines = lines code-      (beforeVersion, afterVersion) = break isVersionDirective codeLines-      lineDirective =-        [ "#extension GL_GOOGLE_cpp_style_line_directive : enable"-        , "#line "+insertLineDirective code Loc{..} =+  let+    isVersionDirective = ("#version" `isPrefixOf`) . dropWhile isSpace+    codeLines = lines code+    (beforeVersion, afterVersion) = break isVersionDirective codeLines+    lineDirective =+      [ "#extension GL_GOOGLE_cpp_style_line_directive : enable"+      , "#line "           <> show (fst loc_start + length beforeVersion + 1)           <> " \""           <> loc_filename           <> "\""-        ]-  in  case afterVersion of-        []     -> code-        v : xs -> unlines $ beforeVersion <> [v] <> lineDirective <> xs+      ]+  in+    case afterVersion of+      [] -> code+      v : xs -> unlines $ beforeVersion <> [v] <> lineDirective <> xs

@@ -18,159 +18,176 @@   , compileShader   ) where -import           Control.Monad.IO.Class-import           Data.ByteString                                 ( ByteString )-import           Language.Haskell.TH-import           Language.Haskell.TH.Quote-import           Vulkan.Utils.Internal                           ( badQQ )-import           Vulkan.Utils.ShaderQQ.ShaderType-import           Vulkan.Utils.ShaderQQ.Backend.Glslang           ( GlslangError, GlslangWarning )+import Control.Monad.IO.Class+import Data.ByteString (ByteString)+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Vulkan.Utils.Internal (badQQ)+import Vulkan.Utils.ShaderQQ.Backend.Glslang (GlslangError, GlslangWarning) import qualified Vulkan.Utils.ShaderQQ.Backend.Glslang.Internal as Glslang-import qualified Vulkan.Utils.ShaderQQ.GLSL                     as GLSL+import qualified Vulkan.Utils.ShaderQQ.GLSL as GLSL+import Vulkan.Utils.ShaderQQ.ShaderType --- $setup--- >>> :set -XQuasiQuotes+{- $setup+>>> :set -XQuasiQuotes+-} --- | 'glsl' is a QuasiQuoter which produces GLSL source code with @#line@--- directives inserted so that error locations point to the correct location in--- the Haskell source file. It also permits basic string interpolation.------ - Interpolated variables are prefixed with @$@--- - They can optionally be surrounded with braces like @${foo}@--- - Interpolated variables are converted to strings with 'show'--- - To escape a @$@ use @\\$@------ It is intended to be used in concert with 'compileShaderQ' like so------ @--- myConstant = 3.141 -- Note that this will have to be in a different module--- myFragmentShader = $(compileShaderQ Nothing "frag" Nothing [glsl|---   #version 450---   const float myConstant = ${myConstant};---   main (){---   }--- |])--- @------ An explicit example (@<interactive>@ is from doctest):------ >>> let version = 450 :: Int in [glsl|#version $version|]--- "#version 450\n#extension GL_GOOGLE_cpp_style_line_directive : enable\n#line ... \"<interactive>\"\n"------ Note that line number will be thrown off if any of the interpolated--- variables contain newlines.+{- | 'glsl' is a QuasiQuoter which produces GLSL source code with @#line@+directives inserted so that error locations point to the correct location in+the Haskell source file. It also permits basic string interpolation.++- Interpolated variables are prefixed with @$@+- They can optionally be surrounded with braces like @${foo}@+- Interpolated variables are converted to strings with 'show'+- To escape a @$@ use @\\$@++It is intended to be used in concert with 'compileShaderQ' like so++@+myConstant = 3.141 -- Note that this will have to be in a different module+myFragmentShader = $(compileShaderQ Nothing "frag" Nothing [glsl|+  #version 450+  const float myConstant = ${myConstant};+  main (){+  }+|])+@++An explicit example (@<interactive>@ is from doctest):++>>> let version = 450 :: Int in [glsl|#version $version|]+"#version 450\n#extension GL_GOOGLE_cpp_style_line_directive : enable\n#line ... \"<interactive>\"\n"++Note that line number will be thrown off if any of the interpolated+variables contain newlines.+-} glsl :: QuasiQuoter glsl = GLSL.glsl --- | QuasiQuoter for creating a compute shader.------ Equivalent to calling @$(compileShaderQ Nothing "comp" Nothing [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a compute shader.++Equivalent to calling @$(compileShaderQ Nothing "comp" Nothing [glsl|...|])@ without+interpolation support.+-} comp :: QuasiQuoter comp = shaderQQ "comp" --- | QuasiQuoter for creating a fragment shader.------ Equivalent to calling @$(compileShaderQ Nothing "frag" Nothing [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a fragment shader.++Equivalent to calling @$(compileShaderQ Nothing "frag" Nothing [glsl|...|])@ without+interpolation support.+-} frag :: QuasiQuoter frag = shaderQQ "frag" --- | QuasiQuoter for creating a geometry shader.------ Equivalent to calling @$(compileShaderQ Nothing "geom" Nothing [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a geometry shader.++Equivalent to calling @$(compileShaderQ Nothing "geom" Nothing [glsl|...|])@ without+interpolation support.+-} geom :: QuasiQuoter geom = shaderQQ "geom" --- | QuasiQuoter for creating a tessellation control shader.------ Equivalent to calling @$(compileShaderQ Nothing "tesc" Nothing [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a tessellation control shader.++Equivalent to calling @$(compileShaderQ Nothing "tesc" Nothing [glsl|...|])@ without+interpolation support.+-} tesc :: QuasiQuoter tesc = shaderQQ "tesc" --- | QuasiQuoter for creating a tessellation evaluation shader.------ Equivalent to calling @$(compileShaderQ Nothing "tese" Nothing [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a tessellation evaluation shader.++Equivalent to calling @$(compileShaderQ Nothing "tese" Nothing [glsl|...|])@ without+interpolation support.+-} tese :: QuasiQuoter tese = shaderQQ "tese" --- | QuasiQuoter for creating a vertex shader.------ Equivalent to calling @$(compileShaderQ Nothing "vert" Nothing [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a vertex shader.++Equivalent to calling @$(compileShaderQ Nothing "vert" Nothing [glsl|...|])@ without+interpolation support.+-} vert :: QuasiQuoter vert = shaderQQ "vert" --- | QuasiQuoter for creating a ray generation shader.------ Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rgen" Nothing [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a ray generation shader.++Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rgen" Nothing [glsl|...|])@ without+interpolation support.+-} rgen :: QuasiQuoter rgen = rayShaderQQ "rgen" --- | QuasiQuoter for creating an intersection shader.------ Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rint" Nothing [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating an intersection shader.++Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rint" Nothing [glsl|...|])@ without+interpolation support.+-} rint :: QuasiQuoter rint = rayShaderQQ "rint" --- | QuasiQuoter for creating an any-hit shader.------ Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rahit" Nothing [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating an any-hit shader.++Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rahit" Nothing [glsl|...|])@ without+interpolation support.+-} rahit :: QuasiQuoter rahit = rayShaderQQ "rahit" --- | QuasiQuoter for creating a closest hit shader.------ Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rchit" Nothing [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a closest hit shader.++Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rchit" Nothing [glsl|...|])@ without+interpolation support.+-} rchit :: QuasiQuoter rchit = rayShaderQQ "rchit" --- | QuasiQuoter for creating a miss shader.------ Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rmiss" Nothing [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a miss shader.++Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rmiss" Nothing [glsl|...|])@ without+interpolation support.+-} rmiss :: QuasiQuoter rmiss = rayShaderQQ "rmiss" --- | QuasiQuoter for creating a callable shader.------ Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rcall" Nothing [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a callable shader.++Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rcall" Nothing [glsl|...|])@ without+interpolation support.+-} rcall :: QuasiQuoter rcall = rayShaderQQ "rcall" --- | QuasiQuoter for creating a task shader.------ Equivalent to calling @$(compileShaderQ Nothing "task" Nothing [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a task shader.++Equivalent to calling @$(compileShaderQ Nothing "task" Nothing [glsl|...|])@ without+interpolation support.+-} task :: QuasiQuoter task = shaderQQ "task" --- | QuasiQuoter for creating a mesh shader.------ Equivalent to calling @$(compileShaderQ Nothing "mesh" Nothing [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a mesh shader.++Equivalent to calling @$(compileShaderQ Nothing "mesh" Nothing [glsl|...|])@ without+interpolation support.+-} mesh :: QuasiQuoter mesh = shaderQQ "mesh"  shaderQQ :: String -> QuasiQuoter-shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ Nothing stage Nothing }+shaderQQ stage = (badQQ stage){quoteExp = compileShaderQ Nothing stage Nothing}  rayShaderQQ :: String -> QuasiQuoter-rayShaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ (Just "spirv1.4") stage Nothing }+rayShaderQQ stage = (badQQ stage){quoteExp = compileShaderQ (Just "spirv1.4") stage Nothing}  -- * Utilities --- | Compile a GLSL shader to spir-v using glslangValidator.------ Messages are converted to GHC warnings or errors depending on compilation success.+{- | Compile a GLSL shader to spir-v using glslangValidator.++Messages are converted to GHC warnings or errors depending on compilation success.+-} compileShaderQ   :: Maybe String   -- ^ Argument to pass to `--target-env`@@ -186,7 +203,7 @@  -- | Compile a GLSL shader to spir-v using glslangValidator. compileShader-  :: MonadIO m+  :: (MonadIO m)   => Maybe Loc   -- ^ Source location   -> Maybe String

@@ -18,159 +18,176 @@   , compileShader   ) where -import           Control.Monad.IO.Class-import           Data.ByteString                                 ( ByteString )-import           Language.Haskell.TH-import           Language.Haskell.TH.Quote-import           Vulkan.Utils.Internal                           ( badQQ )-import           Vulkan.Utils.ShaderQQ.ShaderType-import           Vulkan.Utils.ShaderQQ.Backend.Shaderc           ( ShadercError, ShadercWarning )+import Control.Monad.IO.Class+import Data.ByteString (ByteString)+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Vulkan.Utils.Internal (badQQ)+import Vulkan.Utils.ShaderQQ.Backend.Shaderc (ShadercError, ShadercWarning) import qualified Vulkan.Utils.ShaderQQ.Backend.Shaderc.Internal as Shaderc-import qualified Vulkan.Utils.ShaderQQ.GLSL                     as GLSL+import qualified Vulkan.Utils.ShaderQQ.GLSL as GLSL+import Vulkan.Utils.ShaderQQ.ShaderType --- $setup--- >>> :set -XQuasiQuotes+{- $setup+>>> :set -XQuasiQuotes+-} --- | 'glsl' is a QuasiQuoter which produces GLSL source code with @#line@--- directives inserted so that error locations point to the correct location in--- the Haskell source file. It also permits basic string interpolation.------ - Interpolated variables are prefixed with @$@--- - They can optionally be surrounded with braces like @${foo}@--- - Interpolated variables are converted to strings with 'show'--- - To escape a @$@ use @\\$@------ It is intended to be used in concert with 'compileShaderQ' like so------ @--- myConstant = 3.141 -- Note that this will have to be in a different module--- myFragmentShader = $(compileShaderQ Nothing "frag" [glsl|---   #version 450---   const float myConstant = ${myConstant};---   main (){---   }--- |])--- @------ An explicit example (@<interactive>@ is from doctest):------ >>> let version = 450 :: Int in [glsl|#version $version|]--- "#version 450\n#extension GL_GOOGLE_cpp_style_line_directive : enable\n#line ... \"<interactive>\"\n"------ Note that line number will be thrown off if any of the interpolated--- variables contain newlines.+{- | 'glsl' is a QuasiQuoter which produces GLSL source code with @#line@+directives inserted so that error locations point to the correct location in+the Haskell source file. It also permits basic string interpolation.++- Interpolated variables are prefixed with @$@+- They can optionally be surrounded with braces like @${foo}@+- Interpolated variables are converted to strings with 'show'+- To escape a @$@ use @\\$@++It is intended to be used in concert with 'compileShaderQ' like so++@+myConstant = 3.141 -- Note that this will have to be in a different module+myFragmentShader = $(compileShaderQ Nothing "frag" [glsl|+  #version 450+  const float myConstant = ${myConstant};+  main (){+  }+|])+@++An explicit example (@<interactive>@ is from doctest):++>>> let version = 450 :: Int in [glsl|#version $version|]+"#version 450\n#extension GL_GOOGLE_cpp_style_line_directive : enable\n#line ... \"<interactive>\"\n"++Note that line number will be thrown off if any of the interpolated+variables contain newlines.+-} glsl :: QuasiQuoter glsl = GLSL.glsl --- | QuasiQuoter for creating a compute shader.------ Equivalent to calling @$(compileShaderQ Nothing "comp" [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a compute shader.++Equivalent to calling @$(compileShaderQ Nothing "comp" [glsl|...|])@ without+interpolation support.+-} comp :: QuasiQuoter comp = shaderQQ "comp" --- | QuasiQuoter for creating a fragment shader.------ Equivalent to calling @$(compileShaderQ Nothing "frag" [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a fragment shader.++Equivalent to calling @$(compileShaderQ Nothing "frag" [glsl|...|])@ without+interpolation support.+-} frag :: QuasiQuoter frag = shaderQQ "frag" --- | QuasiQuoter for creating a geometry shader.------ Equivalent to calling @$(compileShaderQ Nothing "geom" [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a geometry shader.++Equivalent to calling @$(compileShaderQ Nothing "geom" [glsl|...|])@ without+interpolation support.+-} geom :: QuasiQuoter geom = shaderQQ "geom" --- | QuasiQuoter for creating a tessellation control shader.------ Equivalent to calling @$(compileShaderQ Nothing "tesc" [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a tessellation control shader.++Equivalent to calling @$(compileShaderQ Nothing "tesc" [glsl|...|])@ without+interpolation support.+-} tesc :: QuasiQuoter tesc = shaderQQ "tesc" --- | QuasiQuoter for creating a tessellation evaluation shader.------ Equivalent to calling @$(compileShaderQ Nothing "tese" [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a tessellation evaluation shader.++Equivalent to calling @$(compileShaderQ Nothing "tese" [glsl|...|])@ without+interpolation support.+-} tese :: QuasiQuoter tese = shaderQQ "tese" --- | QuasiQuoter for creating a vertex shader.------ Equivalent to calling @$(compileShaderQ Nothing "vert" [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a vertex shader.++Equivalent to calling @$(compileShaderQ Nothing "vert" [glsl|...|])@ without+interpolation support.+-} vert :: QuasiQuoter vert = shaderQQ "vert" --- | QuasiQuoter for creating a ray generation shader.------ Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rgen" [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a ray generation shader.++Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rgen" [glsl|...|])@ without+interpolation support.+-} rgen :: QuasiQuoter rgen = rayShaderQQ "rgen" --- | QuasiQuoter for creating an intersection shader.------ Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rint" [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating an intersection shader.++Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rint" [glsl|...|])@ without+interpolation support.+-} rint :: QuasiQuoter rint = rayShaderQQ "rint" --- | QuasiQuoter for creating an any-hit shader.------ Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rahit" [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating an any-hit shader.++Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rahit" [glsl|...|])@ without+interpolation support.+-} rahit :: QuasiQuoter rahit = rayShaderQQ "rahit" --- | QuasiQuoter for creating a closest hit shader.------ Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rchit" [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a closest hit shader.++Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rchit" [glsl|...|])@ without+interpolation support.+-} rchit :: QuasiQuoter rchit = rayShaderQQ "rchit" --- | QuasiQuoter for creating a miss shader.------ Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rmiss" [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a miss shader.++Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rmiss" [glsl|...|])@ without+interpolation support.+-} rmiss :: QuasiQuoter rmiss = rayShaderQQ "rmiss" --- | QuasiQuoter for creating a callable shader.------ Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rcall" [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a callable shader.++Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rcall" [glsl|...|])@ without+interpolation support.+-} rcall :: QuasiQuoter rcall = rayShaderQQ "rcall" --- | QuasiQuoter for creating a task shader.------ Equivalent to calling @$(compileShaderQ Nothing "task" [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a task shader.++Equivalent to calling @$(compileShaderQ Nothing "task" [glsl|...|])@ without+interpolation support.+-} task :: QuasiQuoter task = shaderQQ "task" --- | QuasiQuoter for creating a mesh shader.------ Equivalent to calling @$(compileShaderQ Nothing "mesh" [glsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a mesh shader.++Equivalent to calling @$(compileShaderQ Nothing "mesh" [glsl|...|])@ without+interpolation support.+-} mesh :: QuasiQuoter mesh = shaderQQ "mesh"  shaderQQ :: String -> QuasiQuoter-shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ Nothing stage }+shaderQQ stage = (badQQ stage){quoteExp = compileShaderQ Nothing stage}  rayShaderQQ :: String -> QuasiQuoter-rayShaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ (Just "spv1.4") stage }+rayShaderQQ stage = (badQQ stage){quoteExp = compileShaderQ (Just "spv1.4") stage}  -- * Utilities --- | Compile a GLSL shader to spir-v using glslc.------ Messages are converted to GHC warnings or errors depending on compilation success.+{- | Compile a GLSL shader to spir-v using glslc.++Messages are converted to GHC warnings or errors depending on compilation success.+-} compileShaderQ   :: Maybe String   -- ^ Argument to pass to `--target-env`@@ -184,7 +201,7 @@  -- | Compile a GLSL shader to spir-v using glslc. compileShader-  :: MonadIO m+  :: (MonadIO m)   => Maybe Loc   -- ^ Source location   -> Maybe String

@@ -3,40 +3,42 @@   , insertLineDirective   ) where -import           Language.Haskell.TH-import           Language.Haskell.TH.Quote-import           Vulkan.Utils.Internal                  ( badQQ )-import           Vulkan.Utils.ShaderQQ.Interpolate+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Vulkan.Utils.Internal (badQQ)+import Vulkan.Utils.ShaderQQ.Interpolate --- | 'hlsl' is a QuasiQuoter which produces HLSL source code with a @#line@--- directive inserted so that error locations point to the correct location in--- the Haskell source file. It also permits basic string interpolation.------ - Interpolated variables are prefixed with @$@--- - They can optionally be surrounded with braces like @${foo}@--- - Interpolated variables are converted to strings with 'show'--- - To escape a @$@ use @\\$@------ An explicit example (@<interactive>@ is from doctest):------ >>> let foo = 450 :: Int in [hlsl|const float foo = $foo|]--- "#line ... \"<interactive>\"\nconst float foo = 450"------ Note that line number will be thrown off if any of the interpolated--- variables contain newlines.+{- | 'hlsl' is a QuasiQuoter which produces HLSL source code with a @#line@+directive inserted so that error locations point to the correct location in+the Haskell source file. It also permits basic string interpolation.++- Interpolated variables are prefixed with @$@+- They can optionally be surrounded with braces like @${foo}@+- Interpolated variables are converted to strings with 'show'+- To escape a @$@ use @\\$@++An explicit example (@<interactive>@ is from doctest):++>>> let foo = 450 :: Int in [hlsl|const float foo = $foo|]+"#line ... \"<interactive>\"\nconst float foo = 450"++Note that line number will be thrown off if any of the interpolated+variables contain newlines.+-} hlsl :: QuasiQuoter-hlsl = (badQQ "hlsl")-  { quoteExp = \s -> do-                 loc <- location-                 -- Insert the directive here, `compileShaderQ` will insert-                 -- another one, but it's before this one, so who cares.-                 let codeWithLineDirective = insertLineDirective s loc-                 interpExp codeWithLineDirective-  }+hlsl =+  (badQQ "hlsl")+    { quoteExp = \s -> do+        loc <- location+        -- Insert the directive here, `compileShaderQ` will insert+        -- another one, but it's before this one, so who cares.+        let codeWithLineDirective = insertLineDirective s loc+        interpExp codeWithLineDirective+    }  -- Insert a #line directive with the specified location at the top of the file insertLineDirective :: String -> Loc -> String-insertLineDirective code Loc {..} =+insertLineDirective code Loc{..} =   let lineDirective =         "#line " <> show (fst loc_start) <> " \"" <> loc_filename <> "\""-  in  lineDirective <> "\n" <> code+  in lineDirective <> "\n" <> code

@@ -18,156 +18,172 @@   , compileShader   ) where -import           Control.Monad.IO.Class-import           Data.ByteString                                 ( ByteString )-import           Language.Haskell.TH-import           Language.Haskell.TH.Quote-import           Vulkan.Utils.Internal                           ( badQQ )-import           Vulkan.Utils.ShaderQQ.ShaderType-import           Vulkan.Utils.ShaderQQ.Backend.Glslang           ( GlslangError, GlslangWarning )+import Control.Monad.IO.Class+import Data.ByteString (ByteString)+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Vulkan.Utils.Internal (badQQ)+import Vulkan.Utils.ShaderQQ.Backend.Glslang (GlslangError, GlslangWarning) import qualified Vulkan.Utils.ShaderQQ.Backend.Glslang.Internal as Glslang-import qualified Vulkan.Utils.ShaderQQ.HLSL                     as HLSL+import qualified Vulkan.Utils.ShaderQQ.HLSL as HLSL+import Vulkan.Utils.ShaderQQ.ShaderType --- | 'hlsl' is a QuasiQuoter which produces HLSL source code with a @#line@--- directive inserted so that error locations point to the correct location in--- the Haskell source file. It also permits basic string interpolation.------ - Interpolated variables are prefixed with @$@--- - They can optionally be surrounded with braces like @${foo}@--- - Interpolated variables are converted to strings with 'show'--- - To escape a @$@ use @\\$@------ It is intended to be used in concert with 'compileShaderQ' like so------ @--- myConstant = 3.141 -- Note that this will have to be in a different module--- myFragmentShader = $(compileShaderQ Nothing "frag" (Just "main") [hlsl|---   static const float myConstant = ${myConstant};---   float main (){---     return myConstant;---   }--- |])--- @------ An explicit example (@<interactive>@ is from doctest):------ >>> let foo = 450 :: Int in [hlsl|const float foo = $foo|]--- "#line ... \"<interactive>\"\nconst float foo = 450"------ Note that line number will be thrown off if any of the interpolated--- variables contain newlines.+{- | 'hlsl' is a QuasiQuoter which produces HLSL source code with a @#line@+directive inserted so that error locations point to the correct location in+the Haskell source file. It also permits basic string interpolation.++- Interpolated variables are prefixed with @$@+- They can optionally be surrounded with braces like @${foo}@+- Interpolated variables are converted to strings with 'show'+- To escape a @$@ use @\\$@++It is intended to be used in concert with 'compileShaderQ' like so++@+myConstant = 3.141 -- Note that this will have to be in a different module+myFragmentShader = $(compileShaderQ Nothing "frag" (Just "main") [hlsl|+  static const float myConstant = ${myConstant};+  float main (){+    return myConstant;+  }+|])+@++An explicit example (@<interactive>@ is from doctest):++>>> let foo = 450 :: Int in [hlsl|const float foo = $foo|]+"#line ... \"<interactive>\"\nconst float foo = 450"++Note that line number will be thrown off if any of the interpolated+variables contain newlines.+-} hlsl :: QuasiQuoter hlsl = HLSL.hlsl --- | QuasiQuoter for creating a compute shader.------ Equivalent to calling @$(compileShaderQ Nothing "comp" (Just "main") [hlsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a compute shader.++Equivalent to calling @$(compileShaderQ Nothing "comp" (Just "main") [hlsl|...|])@ without+interpolation support.+-} comp :: QuasiQuoter comp = shaderQQ "comp" --- | QuasiQuoter for creating a fragment shader.------ Equivalent to calling @$(compileShaderQ Nothing "frag" (Just "main") [hlsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a fragment shader.++Equivalent to calling @$(compileShaderQ Nothing "frag" (Just "main") [hlsl|...|])@ without+interpolation support.+-} frag :: QuasiQuoter frag = shaderQQ "frag" --- | QuasiQuoter for creating a geometry shader.------ Equivalent to calling @$(compileShaderQ Nothing "geom" (Just "main") [hlsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a geometry shader.++Equivalent to calling @$(compileShaderQ Nothing "geom" (Just "main") [hlsl|...|])@ without+interpolation support.+-} geom :: QuasiQuoter geom = shaderQQ "geom" --- | QuasiQuoter for creating a tessellation control shader.------ Equivalent to calling @$(compileShaderQ Nothing "tesc" (Just "main") [hlsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a tessellation control shader.++Equivalent to calling @$(compileShaderQ Nothing "tesc" (Just "main") [hlsl|...|])@ without+interpolation support.+-} tesc :: QuasiQuoter tesc = shaderQQ "tesc" --- | QuasiQuoter for creating a tessellation evaluation shader.------ Equivalent to calling @$(compileShaderQ Nothing "tese" (Just "main") [hlsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a tessellation evaluation shader.++Equivalent to calling @$(compileShaderQ Nothing "tese" (Just "main") [hlsl|...|])@ without+interpolation support.+-} tese :: QuasiQuoter tese = shaderQQ "tese" --- | QuasiQuoter for creating a vertex shader.------ Equivalent to calling @$(compileShaderQ Nothing "vert" (Just "main") [hlsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a vertex shader.++Equivalent to calling @$(compileShaderQ Nothing "vert" (Just "main") [hlsl|...|])@ without+interpolation support.+-} vert :: QuasiQuoter vert = shaderQQ "vert" --- | QuasiQuoter for creating a ray generation shader.------ Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rgen" (Just "main") [hlsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a ray generation shader.++Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rgen" (Just "main") [hlsl|...|])@ without+interpolation support.+-} rgen :: QuasiQuoter rgen = rayShaderQQ "rgen" --- | QuasiQuoter for creating an intersection shader.------ Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rint" (Just "main") [hlsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating an intersection shader.++Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rint" (Just "main") [hlsl|...|])@ without+interpolation support.+-} rint :: QuasiQuoter rint = rayShaderQQ "rint" --- | QuasiQuoter for creating an any-hit shader.------ Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rahit" (Just "main") [hlsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating an any-hit shader.++Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rahit" (Just "main") [hlsl|...|])@ without+interpolation support.+-} rahit :: QuasiQuoter rahit = rayShaderQQ "rahit" --- | QuasiQuoter for creating a closest hit shader.------ Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rchit" (Just "main") [hlsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a closest hit shader.++Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rchit" (Just "main") [hlsl|...|])@ without+interpolation support.+-} rchit :: QuasiQuoter rchit = rayShaderQQ "rchit" --- | QuasiQuoter for creating a miss shader.------ Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rmiss" (Just "main") [hlsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a miss shader.++Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rmiss" (Just "main") [hlsl|...|])@ without+interpolation support.+-} rmiss :: QuasiQuoter rmiss = rayShaderQQ "rmiss" --- | QuasiQuoter for creating a callable shader.------ Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rcall" (Just "main") [hlsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a callable shader.++Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rcall" (Just "main") [hlsl|...|])@ without+interpolation support.+-} rcall :: QuasiQuoter rcall = rayShaderQQ "rcall" --- | QuasiQuoter for creating a task shader.------ Equivalent to calling @$(compileShaderQ Nothing "task" (Just "main") [hlsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a task shader.++Equivalent to calling @$(compileShaderQ Nothing "task" (Just "main") [hlsl|...|])@ without+interpolation support.+-} task :: QuasiQuoter task = shaderQQ "task" --- | QuasiQuoter for creating a mesh shader.------ Equivalent to calling @$(compileShaderQ Nothing "mesh" (Just "main") [hlsl|...|])@ without--- interpolation support.+{- | QuasiQuoter for creating a mesh shader.++Equivalent to calling @$(compileShaderQ Nothing "mesh" (Just "main") [hlsl|...|])@ without+interpolation support.+-} mesh :: QuasiQuoter mesh = shaderQQ "mesh"  shaderQQ :: String -> QuasiQuoter-shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ Nothing stage (Just "main") }+shaderQQ stage = (badQQ stage){quoteExp = compileShaderQ Nothing stage (Just "main")}  rayShaderQQ :: String -> QuasiQuoter-rayShaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ (Just "spirv1.4") stage (Just "main") }+rayShaderQQ stage = (badQQ stage){quoteExp = compileShaderQ (Just "spirv1.4") stage (Just "main")}  -- * Utilities --- | Compile a HLSL shader to spir-v using glslangValidator.------ Messages are converted to GHC warnings or errors depending on compilation success.+{- | Compile a HLSL shader to spir-v using glslangValidator.++Messages are converted to GHC warnings or errors depending on compilation success.+-} compileShaderQ   :: Maybe String   -- ^ Argument to pass to `--target-env`@@ -183,7 +199,7 @@  -- | Compile a HLSL shader to spir-v using glslangValidator. compileShader-  :: MonadIO m+  :: (MonadIO m)   => Maybe Loc   -- ^ Source location   -> Maybe String