packages feed

vulkan-utils-spirv (empty) → 0.1.0.0

raw patch · 22 files changed

+4523/−0 lines, 22 filesdep +basedep +bytestringdep +containers

Dependencies added: base, bytestring, containers, geomancy, gl-block, ptrdiff, resourcet, spirv-enum, spirv-reflect-ffi, spirv-reflect-types, tasty, tasty-hunit, template-haskell, text, unliftio-core, vector, vulkan, vulkan-utils, vulkan-utils-spirv

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright IC Rainbow (c) 2026++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of IC Rainbow nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,73 @@+# vulkan-utils-spirv++Generate Haskell data types and Vulkan descriptor-set / pipeline-layout+`*CreateInfo` values from compiled SPIR-V, at compile time, via+[`spirv-reflect`](https://hackage.haskell.org/package/spirv-reflect-ffi)+reflection and [`gl-block`](https://hackage.haskell.org/package/gl-block)+std140/std430 layout.++## Types from a shader++A Template Haskell splice generates a record — with a std140/std430 `Storable`+derived via gl-block — for every uniform / storage / push-constant block the+shader declares:++```haskell+import Vulkan.Utils.SpirV.TH (reflectShaderTypes)++-- e.g. `Scene { view :: Mat4, lightDir :: Vec3, time :: Float }` (geomancy types),+-- ready to poke straight into a mapped buffer.+reflectShaderTypes "shaders/scene.vert.spv"+```++## Pipeline layout from reflection++`allocateReflectedLayout` merges the descriptor-set layouts and push-constant+ranges across a family of shaders — stage flags OR-ed, shared blocks+cross-checked — into one `PipelineLayout`. `allocateGraphicsPipeline` then builds+each pipeline against it, folding in the vertex stage's reflected vertex input:++```haskell+import Data.SpirV.Reflect.FFI (loadBytes)+import Vulkan.Utils.DynamicRendering qualified as Dynamic+import Vulkan.Utils.SpirV.Pipeline (allocateGraphicsPipeline, allocateReflectedLayout)+import Vulkan.Zero (zero)++vertModule <- loadBytes vertSpv+fragModule <- loadBytes fragSpv++-- one layout for the whole family+(_, layout) <- allocateReflectedLayout dev [vertModule, fragModule]++(_, pipeline) <-+  allocateGraphicsPipeline dev layout+    zero{Dynamic.colorFormats = [colorFormat], Dynamic.depthFormat = Just depthFormat}+    () -- specialization; () for none+    [(vertModule, vertSpv), (fragModule, fragSpv)]+```++## Compile-time stage composition++`reflectStageSig` emits a per-shader signature; `MatchInterface` /+`CompatibleResources` then check — at compile time — that the fragment inputs+match the vertex outputs and that any shared descriptor blocks agree. A mismatch+is a type error, not a validation-layer message at runtime:++```haskell+import Vulkan.Utils.SpirV.Stage (CompatibleResources, MatchInterface, reflectStageSig)++reflectStageSig "VertSig" "shaders/scene.vert.spv"+reflectStageSig "FragSig" "shaders/scene.frag.spv"++-- only type-checks if the two stages compose+pipelineComposes :: (MatchInterface VertSig FragSig, CompatibleResources VertSig FragSig) => Bool+pipelineComposes = True+```++## Examples++Four end-to-end, validation-clean programs under+[`examples/`](../examples): `compute-reflect`, `pathtrace-reflect` (buffer+device address / BVH), `mesh-reflect` (a vertex shader driving a z-prepass and a+shaded pass off one merged layout), and `texture-reflect` (colour-attachment-as-+texture with reflected vertex attributes).
+ package.yaml view
@@ -0,0 +1,79 @@+name: vulkan-utils-spirv+version: "0.1.0.0"+synopsis: Generate Haskell types and Vulkan descriptor/pipeline layouts from SPIR-V reflection+category: Graphics+maintainer: IC Rainbow <aenor.realm@gmail.com>+license: BSD-3-Clause+license-file: LICENSE+github: haskell-game/vulkan+extra-source-files:+- README.md+- package.yaml++library:+  source-dirs: src+  dependencies:+  - base >= 4.16 && <5+  - bytestring+  - containers+  - gl-block+  - ptrdiff+  - resourcet+  - spirv-enum+  - spirv-reflect-ffi+  - spirv-reflect-types+  - template-haskell+  - text+  - unliftio-core+  - vector+  - vulkan >= 3.27 && < 3.28+  - vulkan-utils++tests:+  spec:+    main: Spec.hs+    source-dirs: test+    dependencies:+    - base <5+    - bytestring+    - containers+    - geomancy+    - gl-block+    - spirv-reflect-ffi+    - spirv-reflect-types+    - tasty+    - tasty-hunit+    - template-haskell+    - text+    - vector+    - vulkan+    - vulkan-utils+    - vulkan-utils-spirv++ghc-options:+- -Wall++default-extensions:+- BlockArguments+- DataKinds+- DeriveAnyClass+- DeriveGeneric+- DerivingStrategies+- DerivingVia+- DuplicateRecordFields+- FlexibleContexts+- FlexibleInstances+- ImportQualifiedPost+- LambdaCase+- NamedFieldPuns+- OverloadedRecordDot+- OverloadedStrings+- PatternSynonyms+- RecordWildCards+- ScopedTypeVariables+- StrictData+- TemplateHaskell+- TupleSections+- TypeApplications+- TypeOperators+- ViewPatterns
+ src/Vulkan/Utils/SpirV/Array.hs view
@@ -0,0 +1,198 @@+-- These extensions are not in the package-wide default-extensions.+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-| A fixed-length array suitable as a std140\/std430 block /field/.++@'Array' n a@ is @n@ elements of @a@ laid out as an array member: each element+occupies a layout-dependent stride (std140 rounds the element stride up to a+multiple of 16; std430 packs to the element's own alignment). The element type's+'Block' instance does the per-element encoding, so anything that is a 'Block' (a+scalar, a vector, or a generated struct record) can be the element.++The backing 'VS.Vector' should hold exactly @n@ elements; 'write140' \/ 'write430'+write the first @n@ and ignore any extra (so a buffer is never overrun).+-}+module Vulkan.Utils.SpirV.Array+  ( Array (..)+  , unsafeFromList+  , toList++    -- * Runtime-sized arrays+    -- $runtime+  , std140Stride+  , std430Stride+  , pokeStd140+  , pokeStd430+  , peekStd140+  , peekStd430+  ) where++import Control.Monad.IO.Class (MonadIO (..))+import Data.Proxy (Proxy (..))+import Data.Vector.Storable qualified as VS+import Foreign.Ptr (Ptr, castPtr)+import Foreign.Ptr.Diff (Diff (..))+import Foreign.Storable (Storable (..))+import GHC.TypeNats (KnownNat, Nat, natVal)+import GHC.TypeNats qualified as TN+import Graphics.Gl.Block (Block (..), roundUp)++-- | @n@ elements of @a@, laid out as an array block member.+newtype Array (n :: Nat) a = Array (VS.Vector a)++deriving instance (Storable a, Eq a) => Eq (Array n a)+deriving instance (Storable a, Show a) => Show (Array n a)++-- | Build an 'Array' from a list (should be @n@ elements long).+{-# INLINE unsafeFromList #-}+unsafeFromList :: forall n a. (KnownNat n, Storable a) => [a] -> Array n a+unsafeFromList = Array . VS.fromListN (count (Proxy @n))++-- | The elements of an 'Array' as a list.+toList :: (Storable a) => Array n a -> [a]+toList (Array v) = VS.toList v++{- | A tight, host-side 'Storable' (n contiguous elements). This is unrelated to+the gl-block layout below — it only lets an 'Array' nest as the element of+another 'Array' (multi-dimensional arrays: @'Array' h ('Array' w a)@).+-}+instance (KnownNat n, Storable a) => Storable (Array n a) where+  sizeOf _ = count (Proxy @n) * sizeOf (undefined :: a)+  alignment _ = alignment (undefined :: a)+  peek ptr = Array <$> VS.generateM (count (Proxy @n)) (peekElemOff (castPtr ptr))+  poke ptr (Array v) = VS.imapM_ (pokeElemOff (castPtr ptr)) (VS.take (count (Proxy @n)) v)++instance (KnownNat n, Block a, Storable a) => Block (Array n a) where+  type PackedSize (Array n a) = n TN.* PackedSize a++  isStruct _ = True++  alignment140 _ = lcm 16 (alignment140 (Proxy @a))+  alignment430 _ = alignment430 (Proxy @a)++  sizeOf140 _ = count (Proxy @n) * std140Stride (Proxy @a)+  sizeOf430 _ = count (Proxy @n) * std430Stride (Proxy @a)+  sizeOfPacked _ = count (Proxy @n) * sizeOfPacked (Proxy @a)++  read140 = readArrayWith (count (Proxy @n)) (std140Stride (Proxy @a)) read140+  read430 = readArrayWith (count (Proxy @n)) (std430Stride (Proxy @a)) read430+  readPacked = readArrayWith (count (Proxy @n)) (sizeOfPacked (Proxy @a)) readPacked++  write140 = writeArrayWith (count (Proxy @n)) (std140Stride (Proxy @a)) write140+  write430 = writeArrayWith (count (Proxy @n)) (std430Stride (Proxy @a)) write430+  writePacked = writeArrayWith (count (Proxy @n)) (sizeOfPacked (Proxy @a)) writePacked+  {-# INLINE alignment140 #-}+  {-# INLINE alignment430 #-}+  {-# INLINE isStruct #-}+  {-# INLINE read140 #-}+  {-# INLINE read430 #-}+  {-# INLINE readPacked #-}+  {-# INLINE sizeOf140 #-}+  {-# INLINE sizeOf430 #-}+  {-# INLINE write140 #-}+  {-# INLINE write430 #-}+  {-# INLINE writePacked #-}++{-# INLINE count #-}+count :: (KnownNat n) => Proxy n -> Int+count = fromIntegral . natVal++{- | Per-element stride for an array member: std140 rounds the element size up to+a multiple of 16.+-}+std140Stride :: (Block a) => Proxy a -> Int+std140Stride p = roundUp (sizeOf140 p) (lcm 16 (alignment140 p))++{- | Per-element stride for an array member: std430 packs to the element's own+base alignment.+-}+std430Stride :: (Block a) => Proxy a -> Int+std430Stride p = roundUp (sizeOf430 p) (alignment430 p)++{- $runtime+A runtime-sized array (the trailing @T[]@ of a storage buffer) has no+compile-time length, so it is /not/ a fixed-size 'Block' and is represented+directly as a @'VS.Vector' a@. These helpers (de)serialize such a vector at the+layout's element stride, using the element's own 'Block' instance — so an element+whose array stride differs from its packed size (e.g. a @vec3@, or a struct+padded up to its alignment) is still placed correctly. The 'Ptr' should point at+the start of the array (for a buffer whose only contents are the array, that is+the mapped base pointer).+-}++-- | Write a runtime-length array of std140 elements starting at @ptr@.+{-# INLINE pokeStd140 #-}+pokeStd140 :: forall a x m. (Block a, Storable a, MonadIO m) => Ptr x -> VS.Vector a -> m ()+pokeStd140 = pokeArrayAt (std140Stride (Proxy @a)) write140++-- | Write a runtime-length array of std430 elements starting at @ptr@.+{-# INLINE pokeStd430 #-}+pokeStd430 :: forall a x m. (Block a, Storable a, MonadIO m) => Ptr x -> VS.Vector a -> m ()+pokeStd430 = pokeArrayAt (std430Stride (Proxy @a)) write430++-- | Read @n@ std140 elements starting at @ptr@.+{-# INLINE peekStd140 #-}+peekStd140 :: forall a x m. (Block a, Storable a, MonadIO m) => Int -> Ptr x -> m (VS.Vector a)+peekStd140 = peekArrayAt (std140Stride (Proxy @a)) read140++-- | Read @n@ std430 elements starting at @ptr@.+{-# INLINE peekStd430 #-}+peekStd430 :: forall a x m. (Block a, Storable a, MonadIO m) => Int -> Ptr x -> m (VS.Vector a)+peekStd430 = peekArrayAt (std430Stride (Proxy @a)) read430++{-# INLINE pokeArrayAt #-}+pokeArrayAt+  :: (Storable a, MonadIO m)+  => Int+  -> (Ptr x -> Diff x a -> a -> IO ())+  -> Ptr x+  -> VS.Vector a+  -> m ()+pokeArrayAt stride wr ptr v =+  liftIO $ VS.imapM_ (\i x -> wr ptr (Diff (i * stride)) x) v++{-# INLINE peekArrayAt #-}+peekArrayAt+  :: (Storable a, MonadIO m)+  => Int+  -> (Ptr x -> Diff x a -> IO a)+  -> Int+  -> Ptr x+  -> m (VS.Vector a)+peekArrayAt stride rd n ptr =+  liftIO $ VS.generateM n (\i -> rd ptr (Diff (i * stride)))++{-# INLINE readArrayWith #-}+readArrayWith+  :: (Storable a, MonadIO m)+  => Int+  -- ^ element count+  -> Int+  -- ^ element stride+  -> (Ptr x -> Diff x a -> IO a)+  -- ^ element reader+  -> Ptr x+  -> Diff x (Array n a)+  -> m (Array n a)+readArrayWith n stride rd ptr (Diff o) =+  liftIO $ Array <$> VS.generateM n (\i -> rd ptr (Diff (o + i * stride)))++{-# INLINE writeArrayWith #-}+writeArrayWith+  :: (Storable a, MonadIO m)+  => Int+  -- ^ element count+  -> Int+  -- ^ element stride+  -> (Ptr x -> Diff x a -> a -> IO ())+  -- ^ element writer+  -> Ptr x+  -> Diff x (Array n a)+  -> Array n a+  -> m ()+writeArrayWith n stride wr ptr (Diff o) (Array v) =+  liftIO $ VS.imapM_ (\i x -> wr ptr (Diff (o + i * stride)) x) (VS.take n v)
+ src/Vulkan/Utils/SpirV/Block.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE NoFieldSelectors #-}++{-| Generate a Haskell record type for a reflected uniform/storage/push-constant+block, deriving its layout from gl-block: @deriving anyclass 'Block'@ (via+"GHC.Generics") plus @deriving 'Storable' via ('Std140' \/ 'Std430')@.++Splice sites must therefore have @Graphics.Gl.Block (Std140(..), Std430(..))@ in+scope (the @via@ coercion needs the newtype constructor visible) and enable+@DataKinds@ and @TypeFamilies@ (each record also gets a+'Vulkan.Utils.SpirV.Signature.KnownLayout' instance carrying its type-level+layout signature).++== Guardrail+gl-block's @Generic@ 'Block' instance lays a struct out correctly only when its+field alignments are non-increasing. A lower-aligned field that precedes a+higher-aligned one (e.g. @float@ before @uvec2@) is over-padded and no longer+matches the shader's std140/std430 offsets. Until that is fixed in gl-block,+'structRecordDec' refuses (with a compile error) to generate such a record rather+than emit a silently-wrong layout.+-}+module Vulkan.Utils.SpirV.Block+  ( structTypeName+  , structRecordDec+  , collectStructs+  , allMembers16+  ) where++import Control.Monad (filterM)+import Data.Char (toLower)+import Data.List (intercalate, mapAccumL)+import Data.Maybe (fromMaybe)+import Data.Text qualified as Text+import Data.Vector qualified as V+import Foreign.Storable (Storable)+import GHC.Generics (Generic)+import Graphics.Gl.Block (Block, Std140, Std430)+import Language.Haskell.TH++import Data.SpirV.Reflect.TypeDescription (TypeDescription)+import Data.SpirV.Reflect.TypeDescription qualified++import Vulkan.Utils.SpirV.Array (Array)+import Vulkan.Utils.SpirV.DeviceAddress (DeviceAddress)+import Vulkan.Utils.SpirV.Layout (offsetMapOf)+import Vulkan.Utils.SpirV.Signature (knownLayoutInstance)+import Vulkan.Utils.SpirV.Types (LayoutMode (..), NumericType (..), TypeMap, arrayBaseAlign, arrayDims, classifyType, isBdaPointer, leafAlignment, structBaseAlign)++{- | A block's struct together with every nested and array-element struct+reachable from it, each tagged with the layout to generate it under. This lets+an SSBO array of structs (e.g. @Sphere spheres[]@) yield a record for the+element type even though the wrapping block — a runtime array — isn't itself+representable as a flat record (the caller skips it).+-}+collectStructs :: LayoutMode -> TypeDescription -> [(LayoutMode, TypeDescription)]+collectStructs layout root = snd (go [] root)+  where+    -- Thread a visited set of SPIR-V ids so a recursive @buffer_reference@ type+    -- (a shared DAG / cycle) is collected exactly once rather than unrolled+    -- forever — a self-referential @Node@ would otherwise loop here.+    go seen td+      | maybe False (`elem` seen) td.id = (seen, [])+      | otherwise =+          let+            seen' = maybe seen (: seen) td.id+            (seenN, kids) = mapAccumL go seen' (concatMap targets (V.toList td.members))+          in+            (seenN, (layout, td) : concat kids)++    -- The struct(s) reachable from a member: an array- or pointer-element struct+    -- (via @struct_type_description@), or a directly-nested struct. Leaf members+    -- (scalars/vectors/matrices, and device-address pointers) contribute none.+    targets m =+      case m.struct_type_description of+        Just s -> [s]+        Nothing+          | not (V.null m.members) -> [m]+          | otherwise -> []++{- | The Haskell type name to generate for an @OpTypeStruct@ 'TypeDescription':+its @type_name@, used verbatim (SPIR-V struct names are already capitalised+Haskell-friendly identifiers).+-}+structTypeName :: TypeDescription -> Maybe String+structTypeName td = case td.type_name of+  Just t | not (Text.null t) -> Just (Text.unpack t)+  _ -> Nothing++{- | A classified record field: its name, Haskell type, base alignment (bytes)+under the layout, and whether it is a leaf (scalar/vector/matrix) as opposed to+a nested struct.+-}+data Field = Field+  { name :: Name+  , type' :: Type+  , align :: Int+  , leaf :: Bool+  }++{- | Generate the record @data@ declaration for an @OpTypeStruct@, deriving its+'Block' / 'Storable' from gl-block. Returns 'Nothing' if it has no usable name+or a member cannot be represented as a field (e.g. an array — see the+arrays-in-records gap), in which case the caller should skip it. Fails the+splice (guardrail) if the field order would defeat gl-block's std140/std430+layout. Nested struct members become fields of the corresponding generated+record type.+-}+structRecordDec :: TypeMap -> LayoutMode -> TypeDescription -> Q (Maybe [Dec])+structRecordDec tymap layout td =+  case (structTypeName td, classifiedFields tymap layout (V.toList td.members)) of+    (Just nameStr, Just classified) ->+      case layoutViolation classified of+        Just msg ->+          fail $+            "vulkan-utils-spirv: refusing to generate record '"+              <> nameStr+              <> "': "+              <> msg+        Nothing -> do+          let+            tyName = mkName nameStr+            recFields =+              [ (f.name, Bang NoSourceUnpackedness NoSourceStrictness, f.type')+              | f <- classified+              ]+            wrapper = case layout of+              Std140Layout -> ''Std140+              Std430Layout -> ''Std430+          -- Derive @Show@/@Eq@ only when every field type supports them. Some+          -- mapped types (e.g. geomancy's @Mat4@) lack @Eq@, and a nested struct+          -- field's instances aren't yet visible mid-splice, so a record with a+          -- struct field derives neither.+          stockExtra <-+            if all (.leaf) classified+              then filterM (allFieldsAreInstances [f.type' | f <- classified]) [''Show, ''Eq]+              else pure []+          let+            dataDec =+              DataD+                []+                tyName+                []+                Nothing+                [RecC tyName recFields]+                [ DerivClause (Just StockStrategy) (ConT ''Generic : map ConT stockExtra)+                , DerivClause (Just AnyclassStrategy) [ConT ''Block]+                , DerivClause+                    (Just (ViaStrategy (ConT wrapper `AppT` ConT tyName)))+                    [ConT ''Storable]+                ]+            -- Tie a type-level layout signature to the record, computed from+            -- the same reflection (the value-level offset map is the oracle). Skipped+            -- if the offset map can't be computed (shouldn't happen for a record we+            -- already classified).+            sigDecs = either (const []) (knownLayoutInstance tyName) (offsetMapOf layout td)+          pure (Just (dataDec : sigDecs))+    _ -> pure Nothing++-- | True when every field type is an instance of the given class.+allFieldsAreInstances :: [Type] -> Name -> Q Bool+allFieldsAreInstances tys cls = and <$> traverse (\t -> isInstance cls [t]) tys++{- | Classify every member, failing (with 'Nothing') if any cannot be represented+as a record field (e.g. an array member).+-}+classifiedFields :: TypeMap -> LayoutMode -> [TypeDescription] -> Maybe [Field]+classifiedFields tymap layout = traverse $ \mem -> do+  fname <- memberFieldName mem+  (ty, align, isLeaf) <- fieldOf tymap layout mem+  pure Field{name = mkName fname, type' = ty, align, leaf = isLeaf}++{- | The Haskell type, base alignment and leaf-ness of a single member, or+'Nothing' if it can't be a field (a runtime\/multi-dimensional array, or an+unrecognised type). A fixed-size array becomes an @'Array' n@ field.+-}+fieldOf :: TypeMap -> LayoutMode -> TypeDescription -> Maybe (Type, Int, Bool)+fieldOf tymap layout mem =+  case arrayDims mem of+    [] -> elementOf tymap layout mem+    dims+      | all (> 0) dims -> do+          -- Fixed-size array (any dimensionality). Multi-dimensional arrays nest:+          -- @a[h][w]@ -> @Array h (Array w a)@ (outermost dimension first).+          (elemTy, elemAlign, _) <- elementOf tymap layout mem+          pure (foldr wrapArray elemTy dims, arrayBaseAlign layout elemAlign, False)+      | otherwise -> Nothing -- contains a runtime (0) dimension+  where+    wrapArray d ty = ConT ''Array `AppT` LitT (NumTyLit (fromIntegral d)) `AppT` ty++{- | The Haskell type, base alignment and leaf-ness of a member's element type+(i.e. ignoring any array dimensions).+-}+elementOf :: TypeMap -> LayoutMode -> TypeDescription -> Maybe (Type, Int, Bool)+elementOf tymap layout mem+  -- A buffer_reference pointer: an 8-byte device address, typed by its pointee+  -- record when that is a named struct (else @DeviceAddress ()@). The pointee+  -- struct is generated separately by 'collectStructs', not inlined here. The+  -- REF check precedes 'classifyType' (a pointer also carries the pointee's leaf+  -- flags, e.g. @REF INT@).+  | isBdaPointer mem =+      -- Reported as non-leaf so the record skips auto-deriving Show/Eq: the+      -- pointee (often the record being defined — a self-referential @Node@) is+      -- not in scope mid-splice, so probing @Show (DeviceAddress Node)@ would+      -- fail, exactly as for a nested-struct field.+      let+        pointee = mem.struct_type_description >>= structTypeName+        arg = maybe (TupleT 0) (ConT . mkName) pointee+      in+        Just (ConT ''DeviceAddress `AppT` arg, 8, False)+  | otherwise =+      case classifyType mem of+        Just numeric -> do+          let numeric' = numeric{array = []}+          ty <- tymap numeric'+          pure (ty, leafAlignment layout numeric'.scalar numeric'.shape, True)+        Nothing -> do+          -- A nested struct member: field of the corresponding generated record.+          let s = fromMaybe mem mem.struct_type_description+          nm <- structTypeName s+          align <- structAlignment layout s+          pure (ConT (mkName nm), align, False)++{- | Guardrail: gl-block's 'Generic' layout matches std140/std430 only when field+alignments are non-increasing. Report the first inversion, if any.+-}+layoutViolation :: [Field] -> Maybe String+layoutViolation classified = go [(nameBase f.name, f.align) | f <- classified]+  where+    go ((n1, a1) : rest@((n2, a2) : _))+      | a1 < a2 =+          Just $+            intercalate+              " "+              [ "field '" <> n1 <> "' (alignment " <> show a1 <> ")"+              , "precedes higher-aligned field '" <> n2 <> "' (alignment " <> show a2 <> ");"+              , "gl-block's Generic layout would not match std140/std430."+              , "Reorder the block's fields by non-increasing alignment"+              , "(temporary gl-block limitation)."+              ]+      | otherwise = go rest+    go _ = Nothing++{- | The base alignment (bytes) of a struct under the given layout: the largest+member alignment, rounded up to 16 for std140. 'Nothing' if any member's+alignment can't be determined.+-}+structAlignment :: LayoutMode -> TypeDescription -> Maybe Int+structAlignment layout td = do+  as <- traverse (memberBaseAlignment layout) (V.toList td.members)+  pure (structBaseAlign layout as)++-- | The base alignment of any member (leaf, nested struct, or fixed array).+memberBaseAlignment :: LayoutMode -> TypeDescription -> Maybe Int+memberBaseAlignment layout mem =+  case arrayDims mem of+    [] -> elementBaseAlignment layout mem+    dims+      | all (> 0) dims -> arrayBaseAlign layout <$> elementBaseAlignment layout mem+      | otherwise -> Nothing++-- | The base alignment of a member's element type (ignoring array dimensions).+elementBaseAlignment :: LayoutMode -> TypeDescription -> Maybe Int+elementBaseAlignment layout mem+  | isBdaPointer mem = Just 8 -- device address: 8-byte scalar+  | otherwise =+      case classifyType mem of+        Just numeric -> Just (leafAlignment layout numeric.scalar numeric.shape)+        Nothing -> structAlignment layout (fromMaybe mem mem.struct_type_description)++{- | True when every member of the struct has 16-byte base alignment. Such a+struct lays out identically under std140 and std430 (same offsets, same size),+so a single generated record can be shared across both layouts ("promotion").+Anything else used across layouts is rejected by the sharing guardrail.+-}+allMembers16 :: TypeDescription -> Bool+allMembers16 td = not (null ms) && all is16 ms+  where+    ms = V.toList td.members+    is16 m = memberBaseAlignment Std430Layout m == Just 16++uncapitalize :: String -> String+uncapitalize [] = []+uncapitalize (c : cs) = toLower c : cs++{- | The Haskell record-field name for a reflected member: its declared name,+uncapitalised (SPIR-V capitalises member names, Haskell fields are lower-case).+-}+memberFieldName :: TypeDescription -> Maybe String+memberFieldName = fmap (uncapitalize . Text.unpack) . (.struct_member_name)
+ src/Vulkan/Utils/SpirV/Buffer.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++{-| A block of memory tagged with a type-level layout signature.++A @'Buffer' sig@ is host memory whose byte layout is described by @sig@ (a+'SigOffsetMap' from "Vulkan.Utils.SpirV.Signature"). 'readBuffer' \/ 'writeBuffer'+move whole records in and out, but only for a record whose own layout 'Fits' the+buffer's signature — so a layout mismatch is a /compile/ error, and because+layout-equivalent records share a signature (and 'Fits' accepts a compatible one),+a value written as one record can be read back through any layout-compatible record+(a structural view).++@+buf <- 'newBuffer' (MyUbo …)         -- Buffer (Sig MyUbo)+view <- 'readBuffer' buf             -- any r with Fits (Sig r) (Sig MyUbo)+@++The signature is the soundness boundary: 'newBuffer' derives it from the record+it writes (sound by construction); 'unsafeAsBuffer' tags a foreign pointer you+already hold (e.g. VMA @mappedData@) with a signature /you/ assert it satisfies —+that assertion is exactly the reflected buffer's layout.+-}+module Vulkan.Utils.SpirV.Buffer+  ( Buffer+  , newBuffer+  , allocBuffer+  , allocArrayBuffer+  , readBuffer+  , writeBuffer+  , readBufferElem+  , writeBufferElem+  , bufferSize+  , withBufferPtr+  , unsafeAsBuffer+  , unsafeAsBufferPtr+  ) where++import Control.Monad.IO.Class (MonadIO (..))+import Data.Proxy (Proxy (..))+import Data.Word (Word8)+import Foreign.ForeignPtr (ForeignPtr, castForeignPtr, mallocForeignPtrBytes, newForeignPtr_, withForeignPtr)+import Foreign.Ptr (Ptr, castPtr, plusPtr)+import Foreign.Storable (Storable (..))++import Vulkan.Utils.SpirV.Layout qualified -- brings OffsetMap's fields into scope for HasField/ORD+import Vulkan.Utils.SpirV.Signature (Fits, FitsTail, KnownArrayTail, KnownLayout, KnownSigOffsetMap, Sig, SigOffsetMap, arrayTailBaseStride, sigOffsetMapVal)++-- | Host memory laid out as @sig@.+newtype Buffer (sig :: SigOffsetMap) = Buffer (ForeignPtr Word8)++-- | Allocate and initialize a buffer from a record, taking its layout signature.+newBuffer :: forall r io. (KnownLayout r, Storable r, MonadIO io) => r -> io (Buffer (Sig r))+newBuffer r = liftIO $ do+  fp <- mallocForeignPtrBytes (sizeOf r)+  withForeignPtr fp $ \p -> poke (castPtr p) r+  pure (Buffer fp)++{- | Allocate an uninitialized buffer sized for the (statically-sized) signature+@sig@; use with a type application, e.g. @allocBuffer \@(Sig MyUbo)@.+-}+allocBuffer :: forall sig io. (KnownSigOffsetMap sig, MonadIO io) => io (Buffer sig)+allocBuffer = liftIO $ case sigSize @sig of+  Just n -> Buffer <$> mallocForeignPtrBytes n+  Nothing ->+    ioError (userError "allocBuffer: runtime-sized layout has no static size")++-- | Read a record out of a buffer, if its layout fits the buffer's signature.+readBuffer :: forall r sig io. (Storable r, Fits (Sig r) sig, MonadIO io) => Buffer sig -> io r+readBuffer (Buffer fp) = liftIO (withForeignPtr fp (peek . castPtr))++-- | Write a record into a buffer, if its layout fits the buffer's signature.+writeBuffer :: forall r sig io. (Storable r, Fits (Sig r) sig, MonadIO io) => Buffer sig -> r -> io ()+writeBuffer (Buffer fp) r = liftIO (withForeignPtr fp (\p -> poke (castPtr p) r))++{- | Allocate a runtime-array buffer (an 'ArrayOf' signature) sized for @n@+elements: @base + n * stride@ bytes, both taken from the signature's tail.+-}+allocArrayBuffer :: forall sig io. (KnownArrayTail sig, MonadIO io) => Int -> io (Buffer sig)+allocArrayBuffer n = liftIO (Buffer <$> mallocForeignPtrBytes (base + n * stride))+  where+    (base, stride) = arrayTailBaseStride @sig++{- | Read the @i@-th element of a runtime-array buffer (an SSBO @T[]@), if the+record's layout fits the buffer's array tail. The element is at byte offset+@base + i * stride@ taken from the buffer's signature.+-}+readBufferElem :: forall r sig io. (Storable r, FitsTail (Sig r) sig, KnownArrayTail sig, MonadIO io) => Buffer sig -> Int -> io r+readBufferElem (Buffer fp) i =+  liftIO (withForeignPtr fp (\p -> peek (castPtr (p `plusPtr` elemOffset @sig i))))++{- | Write the @i@-th element of a runtime-array buffer, if the record's layout+fits the buffer's array tail.+-}+writeBufferElem :: forall r sig io. (Storable r, FitsTail (Sig r) sig, KnownArrayTail sig, MonadIO io) => Buffer sig -> Int -> r -> io ()+writeBufferElem (Buffer fp) i r =+  liftIO (withForeignPtr fp (\p -> poke (castPtr (p `plusPtr` elemOffset @sig i)) r))++{- | The byte offset of array element @i@ from the buffer signature's tail.++'KnownArrayTail' provides the @(base, stride)@ from the type level.+-}+elemOffset :: forall sig. (KnownArrayTail sig) => Int -> Int+elemOffset i = base + i * stride+  where+    (base, stride) = arrayTailBaseStride @sig++-- | The buffer's size in bytes, from its signature ('Nothing' if open-ended).+bufferSize :: forall sig. (KnownSigOffsetMap sig) => Buffer sig -> Maybe Int+bufferSize _ = sigSize @sig++-- | The static byte size of a signature, if it is not runtime-sized.+sigSize :: forall sig. (KnownSigOffsetMap sig) => Maybe Int+sigSize = (sigOffsetMapVal (Proxy @sig)).size++-- | Run an action on the raw buffer pointer (e.g. to upload to a GPU buffer).+withBufferPtr :: (MonadIO io) => Buffer sig -> (Ptr Word8 -> IO a) -> io a+withBufferPtr (Buffer fp) k = liftIO (withForeignPtr fp k)++{- | Tag a foreign pointer with a layout signature you assert it satisfies. The+safety obligation is the caller's: @sig@ must match the memory's real layout+(for a reflected GPU buffer, its reflected block layout).+-}+unsafeAsBuffer :: ForeignPtr a -> Buffer sig+unsafeAsBuffer = Buffer . castForeignPtr++{- | Tag a raw pointer (e.g. VMA @mappedData@) with an asserted layout signature.+The pointer's memory is owned elsewhere — no finalizer is attached, so the+caller must keep it alive for the buffer's lifetime. Same obligation as+'unsafeAsBuffer'.+-}+unsafeAsBufferPtr :: (MonadIO io) => Ptr a -> io (Buffer sig)+unsafeAsBufferPtr p = liftIO (Buffer . castForeignPtr <$> newForeignPtr_ p)
+ src/Vulkan/Utils/SpirV/Descriptors.hs view
@@ -0,0 +1,154 @@+{-| Build Vulkan descriptor-set-layout and push-constant values from a reflected+'Module' at runtime. The reflected SPIR-V enums share Vulkan's numeric values, so+'Vk.DescriptorType' / 'Vk.ShaderStageFlags' come straight from the reflected+integers.+-}+module Vulkan.Utils.SpirV.Descriptors+  ( descriptorSetLayoutInfos+  , singleDescriptorSetLayoutInfo+  , pushConstantRanges+  , pushConstantsSize+  , mergedDescriptorSetLayoutInfos+  , mergedPushConstantRanges+  , moduleStageFlags+  ) where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe)+import Data.Vector qualified as V+import Data.Word (Word32)+import Vulkan.Core10 qualified as Vk+import Vulkan.Zero (zero)++import Data.SpirV.Reflect.BlockVariable qualified+import Data.SpirV.Reflect.DescriptorBinding qualified as DescriptorBinding+import Data.SpirV.Reflect.DescriptorSet qualified+import Data.SpirV.Reflect.Enums.DescriptorType qualified as R+import Data.SpirV.Reflect.Module (Module)+import Data.SpirV.Reflect.Module qualified++import Vulkan.Utils.PipelineLayout (DescriptorBindingConflict (..), mergeDescriptorSetLayoutBindings, mergePushConstantRanges)+import Vulkan.Utils.SpirV.Layout (OffsetMap, mergeKeyed, renderMismatch)+import Vulkan.Utils.SpirV.Reflect.OffsetMaps (pushOffsetMaps, resourceOffsetMaps)++{- | One @(set number, layout create-info)@ per reflected descriptor set, with+all bindings tagged with this module's shader stage.+-}+descriptorSetLayoutInfos :: Module -> [(Word32, Vk.DescriptorSetLayoutCreateInfo '[])]+descriptorSetLayoutInfos m =+  [ ( ds.set+    , zero+        { Vk.bindings =+            V.fromList [bindingToVk stage b | b <- V.toList ds.bindings]+        }+    )+  | ds <- V.toList m.descriptor_sets+  ]+  where+    stage = moduleStageFlags m++bindingToVk :: Vk.ShaderStageFlags -> DescriptorBinding.DescriptorBinding -> Vk.DescriptorSetLayoutBinding+bindingToVk stage b =+  zero+    { Vk.binding = b.binding+    , Vk.descriptorType = Vk.DescriptorType (fromIntegral (descriptorTypeInt b))+    , Vk.descriptorCount = fromMaybe 1 b.count+    , Vk.stageFlags = stage+    }++{- | The create-info of a module's sole descriptor set — the common single-set+shader. 'Left' if the module declares no sets or more than one.+-}+singleDescriptorSetLayoutInfo :: Module -> Either String (Vk.DescriptorSetLayoutCreateInfo '[])+singleDescriptorSetLayoutInfo m =+  case descriptorSetLayoutInfos m of+    [(_, info)] -> Right info+    [] -> Left "shader declares no descriptor sets"+    sets -> Left ("shader declares " <> show (length sets) <> " descriptor sets, expected exactly one")++{- | One range per reflected push-constant block, tagged with this module's+shader stage.+-}+pushConstantRanges :: Module -> [Vk.PushConstantRange]+pushConstantRanges m =+  [ zero+      { Vk.stageFlags = stage+      , Vk.offset = pc.absolute_offset+      , Vk.size = pc.size+      }+  | pc <- V.toList m.push_constants+  ]+  where+    stage = moduleStageFlags m++{- | Total extent of a module's push-constant ranges — the size to pass to+@cmdPushConstants@.++This is the /reflected/ extent, which is smaller than a generated record's+'Foreign.Storable.sizeOf' whenever std430 trailing-pads the block; pushing the+padded size overruns the declared range.+-}+pushConstantsSize :: Module -> Word32+pushConstantsSize m = maximum (0 : [r.offset + r.size | r <- pushConstantRanges m])++{- | Descriptor set layouts for a /pipeline/ built from several stages: bindings+are collected across all modules and each binding's @stageFlags@ is the OR of the+stages that declare it — correct for a set shared between, say, vertex and+fragment (unlike the single-stage 'descriptorSetLayoutInfos').++On top of the generic Vulkan-binding merge ('mergeDescriptorSetLayoutBindings'),+stages sharing a @(set, binding)@ must also agree on its /block layout/ (their+reflected offset maps are unified, see "Vulkan.Utils.SpirV.Layout"). Either a+descriptor-type or a layout disagreement is a 'Left' naming the offending binding.+-}+mergedDescriptorSetLayoutInfos :: [Module] -> Either String [(Word32, Vk.DescriptorSetLayoutCreateInfo '[])]+mergedDescriptorSetLayoutInfos modules = do+  verifyKeyed descKey (concatMap resourceOffsetMaps modules)+  traverse mergeSet (Map.toAscList bindingsBySet)+  where+    descKey (s, b) = "descriptor set " <> show s <> " binding " <> show b++    -- set -> the bindings every stage contributes to it (each tagged with its stage).+    bindingsBySet :: Map Word32 [Vk.DescriptorSetLayoutBinding]+    bindingsBySet =+      Map.fromListWith+        (flip (++))+        [ (b.set, [bindingToVk (moduleStageFlags m) b])+        | m <- modules+        , b <- V.toList m.descriptor_bindings+        ]++    mergeSet (setNo, bs) = case mergeDescriptorSetLayoutBindings bs of+      Right merged -> Right (setNo, zero{Vk.bindings = V.fromList merged})+      Left c ->+        Left (descKey (setNo, c.binding) <> ": descriptor type disagreement between stages")++{- | Push-constant ranges for a multi-stage pipeline: ranges with the same offset+and size are merged with their stage flags OR-ed. Stages that share a range must+agree on its block layout (the offset maps are unified); a disagreement is a 'Left'.+-}+mergedPushConstantRanges :: [Module] -> Either String [Vk.PushConstantRange]+mergedPushConstantRanges modules = do+  verifyKeyed pushKey (concatMap pushOffsetMaps modules)+  pure (mergePushConstantRanges (concatMap pushConstantRanges modules))+  where+    pushKey (o, sz) = "push constant at offset " <> show o <> " size " <> show sz++-- | A module's shader stage as a Vulkan flag (SPIR-V shares Vulkan's values).+moduleStageFlags :: Module -> Vk.ShaderStageFlags+moduleStageFlags m = Vk.ShaderStageFlagBits (fromIntegral m.shader_stage)++-- Layout agreement across stages. -----------------------------------------------++{- | Entries sharing a key must unify; the first disagreement is reported with the+key rendered by @shw@.+-}+verifyKeyed :: (Ord k) => (k -> String) -> [(k, OffsetMap)] -> Either String ()+verifyKeyed shw entries = case mergeKeyed entries of+  Right _ -> Right ()+  Left (k, mm) -> Left (shw k <> ": " <> renderMismatch mm)++-- | The reflected descriptor type as its raw integer (Vulkan-compatible).+descriptorTypeInt :: DescriptorBinding.DescriptorBinding -> Int+descriptorTypeInt b = let R.DescriptorType n = b.descriptor_type in n
+ src/Vulkan/Utils/SpirV/DeviceAddress.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}++{-| A 64-bit buffer device address — a GPU pointer to a @buffer_reference@ /+@PhysicalStorageBuffer@ block.++A @buffer_reference@ member of a shader block is stored as an 8-byte address, not+the pointee inline, so reflection-driven codegen maps it to a 'DeviceAddress'+field. The phantom @a@ records the pointee's generated record type (e.g.+@DeviceAddress Node@), purely for documentation and type-safety at the call site;+the runtime representation is just the 'Word64' address.++The 'Graphics.Gl.Block.Block' instance lays it out as a single 8-byte scalar+(alignment 8) under both std140 and std430 — matching @VkDeviceAddress@ — so a+generated record carrying one gets the right offsets via @deriving Storable via+(Std430 …)@.+-}+module Vulkan.Utils.SpirV.DeviceAddress+  ( DeviceAddress (..)+  ) where++import Data.Word (Word64)+import Foreign.Ptr.Diff (peekDiffOff, pokeDiffOff)+import Foreign.Storable (Storable)+import Graphics.Gl.Block (Block (..))++-- | A device address pointing at a @buffer_reference@ block of type @a@.+newtype DeviceAddress a = DeviceAddress Word64+  deriving stock (Eq, Ord, Show)+  deriving newtype (Storable)++{- | One 8-byte scalar (alignment 8) under both layouts; mirrors the @Double@+scalar instance gl-block ships, since @a@ is phantom.+-}+instance Block (DeviceAddress a) where+  type PackedSize (DeviceAddress a) = 8+  alignment140 _ = 8+  sizeOf140 = sizeOfPacked+  alignment430 = alignment140+  sizeOf430 = sizeOf140+  isStruct _ = False+  read140 = peekDiffOff+  write140 = pokeDiffOff+  read430 = read140+  write430 = write140+  readPacked = read140+  writePacked = write140
+ src/Vulkan/Utils/SpirV/Layout.hs view
@@ -0,0 +1,423 @@+{-# LANGUAGE NoFieldSelectors #-}++{-| A self-contained, reversible description of a block's memory layout, plus a+value-level unifier over those layouts.++This is the IR the reflection-driven type machinery is built on. Two levels:++  * 'Layout' \/ 'Member' \/ 'FieldType' — the /structured/ form. It keeps every+    member's name, byte offset, and full semantic shape (scalar kind, vector \/+    matrix dimensions, array sizes, nested structs), so it carries enough+    information to drive code generation /and/ to be run backwards (e.g. towards+    authoring SPIR-V), not merely the flattened offsets.++  * 'OffsetMap' — the /normalized/ form: the flattened offset table of occupied+    scalar 'Slot's (each a byte offset + scalar type), plus an optional+    runtime-array tail. This is exactly the offset map the GPU sees, so it is the+    canonical form for /layout equivalence/: @mat4@, @vec4[4]@ and @float[16]@+    reduce to the same std430 offset map (and correctly diverge under std140,+    where the array strides round to 16). This is structural/layout equivalence —+    identical normalized bytes — not memory aliasing in the SPIR-V @Aliased@ \/ C+    pointer sense.++'unify' is the compatibility relation: not equality and not a prefix match, but+unification. Two layouts unify when their offset maps can be reconciled (a runtime+tail absorbs a concrete repeat, pinning its length); the result is the+most-defined offset map, which can be folded against further layouts ('foldUnify')+to accumulate a combined picture across pipelines. A failure is reported as a+'Mismatch' with a legible 'renderMismatch'.+-}+module Vulkan.Utils.SpirV.Layout+  ( -- * Layout mode+    layoutForDescriptor++    -- * Structured layout+  , Layout (..)+  , Member (..)+  , FieldType (..)+  , ArraySize (..)+  , layoutOf+  , fromFields+  , leafFieldType++    -- * Normalized offset map+  , Slot (..)+  , OffsetMap (..)+  , RuntimeTail (..)+  , normalize+  , offsetMapOf++    -- * Unification+  , Mismatch (..)+  , renderMismatch+  , unify+  , foldUnify+  , mergeKeyed+  ) where++import Data.List (foldl', sortOn)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Vector qualified as V+import Graphics.Gl.Block (roundUp)++import Data.SpirV.Reflect.Enums.DescriptorType qualified as R+import Data.SpirV.Reflect.TypeDescription (TypeDescription)+import Data.SpirV.Reflect.TypeDescription qualified++import Vulkan.Utils.SpirV.Types (LayoutMode (..), MemberShape (..), NumericType (..), ScalarType (..), arrayBaseAlign, arrayDims, classifyType, isBdaPointer, leafAlignment, scalarWidth, structBaseAlign)++{- | The gl-block layout a descriptor's block follows: uniform buffers use+std140, storage buffers std430. Other descriptor types carry no block layout+('Nothing').+-}+layoutForDescriptor :: R.DescriptorType -> Maybe LayoutMode+layoutForDescriptor = \case+  R.DESCRIPTOR_TYPE_UNIFORM_BUFFER -> Just Std140Layout+  R.DESCRIPTOR_TYPE_STORAGE_BUFFER -> Just Std430Layout+  _ -> Nothing++{- | A struct's layout under a given 'LayoutMode': its members at their resolved+byte offsets, total size and base alignment. 'size' is 'Nothing' when the struct+ends in a runtime-sized array (its size is not known statically).+-}+data Layout = Layout+  { name :: Maybe Text+  , mode :: LayoutMode+  , members :: [Member]+  , size :: Maybe Int+  , align :: Int+  }+  deriving (Eq, Show)++-- | A struct member: its name, byte offset within the struct, and structured type.+data Member = Member+  { name :: Text+  , offset :: Int+  , type' :: FieldType+  }+  deriving (Eq, Show)++{- | The structured type of a member. Multi-dimensional arrays nest+(@'ArrayOf' a ('ArrayOf' b t)@, outermost dimension first).+-}+data FieldType+  = Scalar ScalarType+  | -- | component count (2..4)+    Vector ScalarType Int+  | -- | columns, rows+    Matrix ScalarType Int Int+  | ArrayOf ArraySize FieldType+  | Struct Layout+  deriving (Eq, Show)++-- | An array dimension: a fixed length, or a runtime (unsized) trailing array.+data ArraySize = Sized Int | Runtime+  deriving (Eq, Show)++-- Layout arithmetic (std140/std430). --------------------------------------------++{- | @(base alignment, size)@ of a field type; size is 'Nothing' for a runtime+array (open).+-}+fieldExtent :: LayoutMode -> FieldType -> (Int, Maybe Int)+fieldExtent mode = \case+  Scalar s -> (leafAlignment mode s ShScalar, Just (scalarWidth s))+  Vector s n -> (leafAlignment mode s (ShVector n), Just (n * scalarWidth s))+  Matrix s c r ->+    let colStride = leafAlignment mode s (ShMatrix c r)+    in (colStride, Just (c * colStride))+  ArrayOf Runtime e ->+    let (ea, _) = fieldExtent mode e+    in (arrayBaseAlign mode ea, Nothing)+  ArrayOf (Sized n) e ->+    let+      (ea, es) = fieldExtent mode e+      align = arrayBaseAlign mode ea+      stride = roundUp (fromMaybe 0 es) align+    in+      (align, Just (n * stride))+  Struct l -> (l.align, l.size)++{- | The stride between elements of an array of @e@ under the layout. Defined only+when @e@ has a static size (i.e. is not itself a runtime array).+-}+arrayStride :: LayoutMode -> FieldType -> Int+arrayStride mode e =+  let (ea, es) = fieldExtent mode e+  in roundUp (fromMaybe 0 es) (arrayBaseAlign mode ea)++-- Building from reflection. -----------------------------------------------------++-- | Compute the layout of a reflected @OpTypeStruct@ under the given mode.+layoutOf :: LayoutMode -> TypeDescription -> Either String Layout+layoutOf mode td = do+  members <- traverse (memberOf mode) (V.toList td.members)+  pure (fromFields mode (structName td) members)++{- | Build a layout from named fields directly, computing each member's offset+and the struct's size and alignment (no reflection). Besides constructing+expected layouts, this is the direction an authoring front end would use.+-}+fromFields :: LayoutMode -> Maybe Text -> [(Text, FieldType)] -> Layout+fromFields mode name members =+  Layout+    { name+    , mode+    , members = [m | (m, _, _) <- placed]+    , size = if openEnded then Nothing else Just (roundUp end baseAlign)+    , align = baseAlign+    }+  where+    placed = place mode members+    baseAlign = structBaseAlign mode [a | (_, a, _) <- placed]+    openEnded = any (\(_, _, sz) -> sz == Nothing) placed+    end = case reverse placed of+      [] -> 0+      ((Member _ off _, _, msz) : _) -> maybe off (off +) msz++{- | Place members in declaration order, returning each at its offset together+with its alignment and (maybe-open) size.+-}+place :: LayoutMode -> [(Text, FieldType)] -> [(Member, Int, Maybe Int)]+place mode = go 0+  where+    go _ [] = []+    go cursor ((nm, ft) : rest) =+      let+        (align, msz) = fieldExtent mode ft+        off = roundUp cursor align+        cursor' = maybe off (off +) msz+      in+        (Member nm off ft, align, msz) : go cursor' rest++-- | The structured type of a single reflected member.+memberOf :: LayoutMode -> TypeDescription -> Either String (Text, FieldType)+memberOf mode mem = do+  nm <- maybe (Left "member without a name") Right mem.struct_member_name+  base <- baseFieldType mode mem+  let+    dims = arrayDims mem+    wrap d ft = ArrayOf (if d == 0 then Runtime else Sized (fromIntegral d)) ft+  pure (nm, foldr wrap base dims)++{- | The element type of a member, ignoring array dimensions: a leaf+(scalar\/vector\/matrix) or a nested struct.+-}+baseFieldType :: LayoutMode -> TypeDescription -> Either String FieldType+baseFieldType mode mem+  -- A buffer_reference pointer is an 8-byte device address, not the pointee+  -- inline; the REF check precedes 'classifyType' because the pointer also+  -- carries the pointee's leaf flags (e.g. @REF INT@).+  | isBdaPointer mem = Right (Scalar STAddress)+  | otherwise =+      case classifyType mem of+        Just numeric -> Right (leafFieldType numeric)+        Nothing -> Struct <$> layoutOf mode (fromMaybe mem mem.struct_type_description)++leafFieldType :: NumericType -> FieldType+leafFieldType NumericType{scalar, shape} = case shape of+  ShScalar -> Scalar scalar+  ShVector n -> Vector scalar n+  ShMatrix c r -> Matrix scalar c r++-- Normalization to the scalar offset map. ---------------------------------------------++-- | One occupied scalar component at a byte offset.+data Slot = Slot+  { offset :: Int+  , scalar :: ScalarType+  }+  deriving (Eq, Ord, Show)++{- | A runtime-sized array tail: a repeating element offset map starting at 'base'+with the given stride. The element 'Slot's are relative to the element start.+-}+data RuntimeTail = RuntimeTail+  { base :: Int+  , stride :: Int+  , element :: [Slot]+  }+  deriving (Eq, Show)++{- | A normalized layout: the concrete occupied scalar slots (sorted by offset),+the total size (if statically known), and an optional runtime-array tail.+-}+data OffsetMap = OffsetMap+  { slots :: [Slot]+  , size :: Maybe Int+  , tail :: Maybe RuntimeTail+  }+  deriving (Eq, Show)++-- | Flatten a structured 'Layout' to its offset map.+normalize :: Layout -> OffsetMap+normalize l =+  OffsetMap+    { slots = sortOn (.offset) (concatMap fst pieces)+    , size = l.size+    , tail = listToMaybe (mapMaybe snd pieces)+    }+  where+    mode = l.mode+    pieces = map (flattenMember mode) l.members++-- | Build the offset map straight from reflection.+offsetMapOf :: LayoutMode -> TypeDescription -> Either String OffsetMap+offsetMapOf mode = fmap normalize . layoutOf mode++flattenMember :: LayoutMode -> Member -> ([Slot], Maybe RuntimeTail)+flattenMember mode (Member _ off ft) = case ft of+  ArrayOf Runtime e ->+    ([], Just (RuntimeTail off (arrayStride mode e) (flattenAt mode 0 e)))+  _ -> (flattenAt mode off ft, Nothing)++-- | The scalar slots of a (statically-sized) field type at a base offset.+flattenAt :: LayoutMode -> Int -> FieldType -> [Slot]+flattenAt mode off = \case+  Scalar s -> [Slot off s]+  Vector s n -> let w = scalarWidth s in [Slot (off + i * w) s | i <- [0 .. n - 1]]+  Matrix s c r ->+    let+      w = scalarWidth s+      colStride = leafAlignment mode s (ShMatrix c r)+    in+      [Slot (off + col * colStride + row * w) s | col <- [0 .. c - 1], row <- [0 .. r - 1]]+  ArrayOf (Sized n) e ->+    let stride = arrayStride mode e+    in concat [flattenAt mode (off + i * stride) e | i <- [0 .. n - 1]]+  ArrayOf Runtime _ -> [] -- a runtime array can only be a struct's last member+  Struct l -> concatMap (\(Member _ mo mft) -> flattenAt mode (off + mo) mft) l.members++-- Unification. ------------------------------------------------------------------++-- | Why two offset maps fail to unify.+data Mismatch+  = -- | differing scalar at a byte offset+    SlotMismatch Int ScalarType ScalarType+  | -- | differing number of occupied slots+    CountMismatch Int Int+  | -- | differing total size+    SizeMismatch Int Int+  | -- | incompatible runtime-array tails+    TailMismatch String+  deriving (Eq, Show)++renderMismatch :: Mismatch -> String+renderMismatch = \case+  SlotMismatch off l r ->+    "scalar mismatch at byte offset "+      <> show off+      <> ": "+      <> showScalar l+      <> " vs "+      <> showScalar r+  CountMismatch l r ->+    "different number of components: " <> show l <> " vs " <> show r+  SizeMismatch l r ->+    "different total size: " <> show l <> " vs " <> show r <> " bytes"+  TailMismatch msg ->+    "incompatible runtime arrays: " <> msg+  where+    showScalar STFloat = "float"+    showScalar STDouble = "double"+    showScalar STInt = "int"+    showScalar STUInt = "uint"+    showScalar STInt64 = "int64"+    showScalar STUInt64 = "uint64"+    showScalar STBool = "bool"+    showScalar STAddress = "address"++{- | Unify two offset maps into their most-defined common offset map, or report the first+'Mismatch'. A runtime tail on one side absorbs a matching concrete repeat on+the other (pinning the array length); two closed offset maps must coincide exactly.+-}+unify :: OffsetMap -> OffsetMap -> Either Mismatch OffsetMap+unify a b = case (a.tail, b.tail) of+  (Nothing, Nothing) -> do+    matchSlots a.slots b.slots+    matchSize a.size b.size+    pure a+  (Just _, Nothing) -> absorb a b+  (Nothing, Just _) -> absorb b a+  (Just ta, Just tb) -> do+    matchSlots a.slots b.slots+    if ta == tb+      then pure a+      else Left (TailMismatch "tails differ in stride, element shape or base offset")++{- | Reconcile an open offset map (with a runtime tail) against a closed one, requiring+the closed offset map to be the open offset map's prefix followed by whole repeats of its+tail element. Returns the closed (pinned) offset map.+-}+absorb :: OffsetMap -> OffsetMap -> Either Mismatch OffsetMap+absorb open closed = do+  let+    pre = open.slots+    n = length pre+  matchSlots pre (take n closed.slots)+  let+    tl = fromMaybe (error "absorb: open offset map has no tail") open.tail+    rest = drop n closed.slots+  matchRepeats tl rest+  pure closed++-- | The remaining slots must be zero or more whole repeats of the tail element.+matchRepeats :: RuntimeTail -> [Slot] -> Either Mismatch ()+matchRepeats tl = go 0+  where+    el = tl.element+    m = length el+    go _ [] = Right ()+    go j rest+      | length chunk < m =+          Left (TailMismatch "trailing bytes are not a whole array element")+      | otherwise = do+          matchSlots (shift (tl.base + j * tl.stride) el) chunk+          go (j + 1) more+      where+        (chunk, more) = splitAt m rest+    shift base = map (\(Slot o s) -> Slot (o + base) s)++matchSlots :: [Slot] -> [Slot] -> Either Mismatch ()+matchSlots xs ys+  | length xs /= length ys = Left (CountMismatch (length xs) (length ys))+  | otherwise =+      case [ (x.offset, x.scalar, y.scalar)+           | (x, y) <- zip xs ys+           , x.scalar /= y.scalar || x.offset /= y.offset+           ] of+        ((off, l, r) : _) -> Left (SlotMismatch off l r)+        [] -> Right ()++matchSize :: Maybe Int -> Maybe Int -> Either Mismatch ()+matchSize (Just l) (Just r) | l /= r = Left (SizeMismatch l r)+matchSize _ _ = Right ()++{- | Fold a layout against further layouts, accumulating the combined offset map (the+running most-general unifier). Use to add pipelines into a shared layout.+-}+foldUnify :: OffsetMap -> [OffsetMap] -> Either Mismatch OffsetMap+foldUnify = foldl' (\acc g -> acc >>= (`unify` g)) . Right++{- | Merge layouts tagged by a key (e.g. a @(set, binding)@ or vertex @location@):+entries sharing a key must unify, disjoint keys union in. Reports the offending+key with its 'Mismatch'.+-}+mergeKeyed :: (Ord k) => [(k, OffsetMap)] -> Either (k, Mismatch) (Map k OffsetMap)+mergeKeyed = foldl' step (Right Map.empty)+  where+    step acc (k, g) = do+      m <- acc+      case Map.lookup k m of+        Nothing -> Right (Map.insert k g m)+        Just g' -> case unify g' g of+          Right u -> Right (Map.insert k u m)+          Left e -> Left (k, e)++-- | The struct's @type_name@, treating an empty name as absent.+structName :: TypeDescription -> Maybe Text+structName td = td.type_name >>= \t -> if Text.null t then Nothing else Just t
+ src/Vulkan/Utils/SpirV/Pipeline.hs view
@@ -0,0 +1,145 @@+{-| Build "Vulkan.Utils.Pipeline" bundles from reflected SPIR-V.++'allocateReflectedLayout' merges a /family/ of shaders into one verified+'Pipeline.Layout' — bindings and push ranges merged across every module, stage+flags OR-ed, shared block layouts cross-checked — shared by every pipeline built+against it. 'allocateGraphicsPipeline' then folds that layout and the vertex+stage's reflected vertex input into "Vulkan.Utils.DynamicRendering";+'allocateComputePipeline' is the single-stage compute sibling, and+'allocateCompute' collapses the whole family-of-one case into one call.++The bundles carry their set infos and push ranges, so descriptor sets and pushes+('Pipeline.allocateSet', 'Pipeline.push') track the shaders with nothing+hand-counted.+-}+module Vulkan.Utils.SpirV.Pipeline+  ( allocateReflectedLayout+  , allocateGraphicsPipeline+  , allocateComputePipeline+  , allocateCompute+  ) where++import Control.Monad (unless)+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Trans.Resource (MonadResource, allocate, release)+import Data.ByteString (ByteString)+import Data.List (find)+import Data.Vector qualified as V+import Vulkan.CStruct.Extends (SomeStruct (..))+import Vulkan.Core10 qualified as Vk+import Vulkan.Zero (zero)++import Data.SpirV.Reflect.Module (Module)++import Vulkan.Utils.DynamicRendering qualified as Dynamic+import Vulkan.Utils.Pipeline (Layout, Pipeline (..))+import Vulkan.Utils.Pipeline qualified as Pipeline+import Vulkan.Utils.Pipeline.Specialization (Specialization)+import Vulkan.Utils.Shader (shaderModuleStage)+import Vulkan.Utils.SpirV.Descriptors (mergedDescriptorSetLayoutInfos, mergedPushConstantRanges, moduleStageFlags)+import Vulkan.Utils.SpirV.Reflect (reflectBytes)+import Vulkan.Utils.SpirV.Specialization (withSpecializationInfo)+import Vulkan.Utils.SpirV.VertexInput (vertexInputState)++{- | Build the 'Pipeline.Layout' for a family of pipelines from their reflected+modules. Bindings and push-constant ranges are merged across every module —+stage flags OR-ed, shared block layouts cross-checked (see+'mergedDescriptorSetLayoutInfos' / 'mergedPushConstantRanges') — and a conflict+'fail's in @m@.++Pass every distinct shader the family uses, so the one layout stays compatible+with each pipeline built against it. The layout is owned by @m@'s+'Control.Monad.Trans.Resource.ResourceT' and must outlive the pipelines.+-}+allocateReflectedLayout+  :: (MonadResource m, MonadFail m)+  => Vk.Device+  -> [Module]+  -> m Layout+allocateReflectedLayout dev modules = do+  setInfos <- orFail (mergedDescriptorSetLayoutInfos modules)+  pushRanges <- orFail (mergedPushConstantRanges modules)+  sets <-+    traverse+      (\(setNo, info) -> (,) setNo <$> Pipeline.allocateSetLayout dev info)+      setInfos+  Pipeline.allocateLayout dev sets pushRanges+  where+    orFail = either fail pure++{- | Build one pipeline of a family against a shared 'Layout', folding in both+that layout and the vertex stage's reflected vertex input.++Each stage is its reflected 'Module' paired with the SPIR-V to compile; the stage+flag is taken from the module. This fills in the config's 'Dynamic.layout' and+'Dynamic.vertexInput' (from the vertex stage's reflection), overwriting any+values set on them; set the per-variant 'Dynamic.colorFormats' \/+'Dynamic.depthFormat' \/ 'Dynamic.dynamicStates' and vary @spec@ for+specialization. For custom vertex input, drive "Vulkan.Utils.DynamicRendering"+directly and bundle the 'Pipeline' by hand.+-}+allocateGraphicsPipeline+  :: (MonadResource m, MonadUnliftIO m, MonadFail m, Specialization spec)+  => Vk.Device+  -> Layout+  -> Dynamic.PipelineConfig+  -> spec+  -- ^ Specialization shared by every stage; @()@ for none.+  -> [(Module, ByteString)]+  -- ^ Each stage's reflected module and the SPIR-V to compile.+  -> m Pipeline+allocateGraphicsPipeline dev layout config spec stages = do+  (_, pipeline) <-+    Dynamic.allocatePipelineFromShaders+      dev+      config+        { Dynamic.layout = Just layout.pipelineLayout+        , Dynamic.vertexInput = maybe zero vertexInputState vertexModule+        }+      spec+      [(moduleStageFlags m, spv) | (m, spv) <- stages]+  pure Pipeline{pipeline, bindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS, layout}+  where+    vertexModule = fst <$> find (\(m, _) -> moduleStageFlags m == Vk.SHADER_STAGE_VERTEX_BIT) stages++{- | The compute sibling of 'allocateGraphicsPipeline': one compute stage built+against a shared 'Layout'.++Specialization constants are packed against the module's reflected+@constant_id@s (see "Vulkan.Utils.SpirV.Specialization"); pass @()@ for none.+-}+allocateComputePipeline+  :: (MonadResource m, MonadUnliftIO m, MonadFail m, Specialization spec)+  => Vk.Device+  -> Layout+  -> spec+  -> (Module, ByteString)+  -- ^ The compute stage's reflected module and the SPIR-V to compile.+  -> m Pipeline+allocateComputePipeline dev layout spec (m, spv) = do+  unless (moduleStageFlags m == Vk.SHADER_STAGE_COMPUTE_BIT) $+    fail "allocateComputePipeline: the module is not a compute shader"+  withSpecializationInfo m spec $ \specInfo -> do+    (stageKey, stage) <- shaderModuleStage dev Vk.SHADER_STAGE_COMPUTE_BIT specInfo spv+    let createInfo = zero{Vk.layout = layout.pipelineLayout, Vk.stage = stage} :: Vk.ComputePipelineCreateInfo '[]+    (_, (_, pipelines)) <- Vk.withComputePipelines dev zero (V.singleton (SomeStruct createInfo)) Nothing allocate+    release stageKey+    pure Pipeline{pipeline = V.head pipelines, bindPoint = Vk.PIPELINE_BIND_POINT_COMPUTE, layout}++{- | Reflect → layout → pipeline, in one call.++The family-of-one case: the shader's SPIR-V is reflected here and the layout is+its alone. For pipelines sharing a layout across shaders, compose+'allocateReflectedLayout' with 'allocateComputePipeline'.+-}+allocateCompute+  :: (MonadResource m, MonadUnliftIO m, MonadFail m, Specialization spec)+  => Vk.Device+  -> spec+  -> ByteString+  -- ^ The compute stage's SPIR-V.+  -> m Pipeline+allocateCompute dev spec code = do+  reflected <- reflectBytes code+  layout <- allocateReflectedLayout dev [reflected]+  allocateComputePipeline dev layout spec (reflected, code)
+ src/Vulkan/Utils/SpirV/Reflect.hs view
@@ -0,0 +1,32 @@+{-| Reflect compiled SPIR-V into a 'Module', both at runtime and inside+Template Haskell splices.+-}+module Vulkan.Utils.SpirV.Reflect+  ( Module+  , reflectFile+  , reflectBytes+  , reflectFileQ+  ) where++import Control.Monad.IO.Class (MonadIO (..))+import Data.ByteString (ByteString)+import Language.Haskell.TH.Syntax (Q, addDependentFile, runIO)++import Data.SpirV.Reflect.FFI (load, loadBytes)+import Data.SpirV.Reflect.Module (Module)++-- | Reflect a @.spv@ file into a 'Module'.+reflectFile :: (MonadIO m) => FilePath -> m Module+reflectFile = load++-- | Reflect SPIR-V bytecode into a 'Module'.+reflectBytes :: (MonadIO m) => ByteString -> m Module+reflectBytes = loadBytes++{- | Reflect a @.spv@ file at compile time, registering it as a dependency so+the splice is rerun when the file changes.+-}+reflectFileQ :: FilePath -> Q Module+reflectFileQ path = do+  addDependentFile path+  runIO $ reflectFile path
+ src/Vulkan/Utils/SpirV/Reflect/OffsetMaps.hs view
@@ -0,0 +1,57 @@+{-| Extract normalized 'OffsetMap's from a reflected 'Module''s resources.++Both the runtime descriptor/push-constant builders+("Vulkan.Utils.SpirV.Descriptors") and the compile-time stage-signature+machinery ("Vulkan.Utils.SpirV.Stage") need the same thing: the std140\/std430+'OffsetMap' of each buffer-typed descriptor binding and of each push-constant block.+That extraction — pick the layout mode from the descriptor type, pull the block+'TypeDescription', run 'offsetMapOf' — lives here once so the two callers can't drift.+-}+module Vulkan.Utils.SpirV.Reflect.OffsetMaps+  ( resourceOffsetMap+  , resourceOffsetMaps+  , pushOffsetMap+  , pushOffsetMaps+  ) where++import Data.Maybe (mapMaybe)+import Data.Vector qualified as V+import Data.Word (Word32)++import Data.SpirV.Reflect.BlockVariable (BlockVariable)+import Data.SpirV.Reflect.BlockVariable qualified+import Data.SpirV.Reflect.DescriptorBinding (DescriptorBinding)+import Data.SpirV.Reflect.DescriptorBinding qualified+import Data.SpirV.Reflect.Module (Module)+import Data.SpirV.Reflect.Module qualified++import Vulkan.Utils.SpirV.Layout (OffsetMap, layoutForDescriptor, offsetMapOf)+import Vulkan.Utils.SpirV.Types (LayoutMode (..))++{- | The @((set, binding), offset map)@ of a single buffer-typed descriptor+binding. 'Nothing' for non-buffer descriptors (samplers, images, …) and for blocks+whose offset map can't be computed.+-}+resourceOffsetMap :: DescriptorBinding -> Maybe ((Word32, Word32), OffsetMap)+resourceOffsetMap b = do+  mode <- layoutForDescriptor b.descriptor_type+  td <- b.type_description+  g <- eitherToMaybe (offsetMapOf mode td)+  pure ((b.set, b.binding), g)++-- | The reflected block offset map of each buffer-typed binding, keyed by @(set, binding)@.+resourceOffsetMaps :: Module -> [((Word32, Word32), OffsetMap)]+resourceOffsetMaps = mapMaybe resourceOffsetMap . V.toList . (.descriptor_bindings)++-- | The std430 offset map of a push-constant block, if it can be computed.+pushOffsetMap :: BlockVariable -> Maybe OffsetMap+pushOffsetMap pc = pc.type_description >>= eitherToMaybe . offsetMapOf Std430Layout++-- | The reflected offset map of each push-constant block, keyed by @(offset, size)@.+pushOffsetMaps :: Module -> [((Word32, Word32), OffsetMap)]+pushOffsetMaps = mapMaybe keyed . V.toList . (.push_constants)+  where+    keyed pc = (,) (pc.absolute_offset, pc.size) <$> pushOffsetMap pc++eitherToMaybe :: Either e a -> Maybe a+eitherToMaybe = either (const Nothing) Just
+ src/Vulkan/Utils/SpirV/Signature.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}++{-| Type-level layout signatures, tied to the records reflection generates.++Each generated block record carries a ground 'SigOffsetMap' — the promotion of its+normalized 'OffsetMap' ("Vulkan.Utils.SpirV.Layout"), computed value-level at splice+time (the value-level layout is the oracle; see 'knownLayoutInstance'). Because+the offset map is /normalized/ before promotion, layout-equivalent layouts —+@mat4@, @vec4[4]@, @float[16]@ under std430 — promote to the /same/ 'SigOffsetMap',+so the type-level matcher 'Fits' accepts them with no special cases.++'Fits' is intentionally thin: a use-site /matcher/ against an already-ground+signature, not a unifier (the heavy unification stays value-level in @Q@). The+ground offset map can be reflected back to a value with 'layoutSig' \/+'sigOffsetMapVal', which is how the type level is validated against the value-level+unifier.+-}+module Vulkan.Utils.SpirV.Signature+  ( -- * Type-level offset map+    SigOffsetMap (..)+  , SigSlot (..)+  , SigTail (..)++    -- * Records carrying a signature+  , KnownLayout (..)+  , layoutSig++    -- * Reflecting a signature back to a value+  , KnownSigOffsetMap (..)+  , KnownArrayTail (..)+  , KnownMaybeSig (..)+  , KnownKeyedSigs (..)++    -- * Matching+  , Fits+  , FitsTail+  , ArrayOf++    -- * Generation (Template Haskell)+  , knownLayoutInstance+  , promoteOffsetMap+  , promoteList+  , promoteMaybe+  , natT+  ) where++import Data.Kind (Constraint)+import Data.Proxy (Proxy (..))+import Data.Word (Word32)+import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal)+import Language.Haskell.TH++import Vulkan.Utils.SpirV.Layout (OffsetMap (..), RuntimeTail (..), Slot (..))+import Vulkan.Utils.SpirV.Types (ScalarType (..))++-- | One occupied scalar component at a byte offset (type-level mirror of 'Slot').+data SigSlot = SigSlot Nat ScalarType++{- | A runtime-array tail (mirror of 'RuntimeTail'): base offset, stride, and the+element's slots (relative to the element start).+-}+data SigTail = SigTail Nat Nat [SigSlot]++{- | A normalized layout at the type level (mirror of 'OffsetMap'): concrete slots, the+total size if statically known, and an optional runtime-array tail.+-}+data SigOffsetMap = SigOffsetMap [SigSlot] (Maybe Nat) (Maybe SigTail)++{- | A Haskell type with a ground, reflection-derived layout signature. Generated+records get an instance via 'knownLayoutInstance'.+-}+class (KnownSigOffsetMap (Sig a)) => KnownLayout a where+  type Sig a :: SigOffsetMap++-- | The value-level normal form of a record's signature (the oracle view).+layoutSig :: forall a. (KnownLayout a) => OffsetMap+layoutSig = sigOffsetMapVal (Proxy @(Sig a))++-- Reflection: type-level offset map -> value 'OffsetMap'. ----------------------------------++class KnownScalar (s :: ScalarType) where+  scalarVal :: Proxy s -> ScalarType++instance KnownScalar 'STFloat where scalarVal _ = STFloat+instance KnownScalar 'STDouble where scalarVal _ = STDouble+instance KnownScalar 'STInt where scalarVal _ = STInt+instance KnownScalar 'STUInt where scalarVal _ = STUInt+instance KnownScalar 'STInt64 where scalarVal _ = STInt64+instance KnownScalar 'STUInt64 where scalarVal _ = STUInt64+instance KnownScalar 'STBool where scalarVal _ = STBool+instance KnownScalar 'STAddress where scalarVal _ = STAddress++class KnownSlots (xs :: [SigSlot]) where+  slotsVal :: Proxy xs -> [Slot]++instance KnownSlots '[] where+  slotsVal _ = []++instance (KnownNat o, KnownScalar s, KnownSlots rest) => KnownSlots ('SigSlot o s ': rest) where+  slotsVal _ =+    Slot (fromIntegral (natVal (Proxy @o))) (scalarVal (Proxy @s)) : slotsVal (Proxy @rest)++class KnownMaybeNat (m :: Maybe Nat) where+  maybeNatVal :: Proxy m -> Maybe Int++instance KnownMaybeNat 'Nothing where+  maybeNatVal _ = Nothing++instance (KnownNat n) => KnownMaybeNat ('Just n) where+  maybeNatVal _ = Just (fromIntegral (natVal (Proxy @n)))++class KnownTail (t :: SigTail) where+  tailVal :: Proxy t -> RuntimeTail++instance (KnownNat b, KnownNat s, KnownSlots es) => KnownTail ('SigTail b s es) where+  tailVal _ =+    RuntimeTail+      (fromIntegral (natVal (Proxy @b)))+      (fromIntegral (natVal (Proxy @s)))+      (slotsVal (Proxy @es))++class KnownMaybeTail (m :: Maybe SigTail) where+  maybeTailVal :: Proxy m -> Maybe RuntimeTail++instance KnownMaybeTail 'Nothing where+  maybeTailVal _ = Nothing++instance (KnownTail t) => KnownMaybeTail ('Just t) where+  maybeTailVal _ = Just (tailVal (Proxy @t))++-- | Reflect a ground type-level offset map back to its value form.+class KnownSigOffsetMap (g :: SigOffsetMap) where+  sigOffsetMapVal :: Proxy g -> OffsetMap++instance (KnownSlots ss, KnownMaybeNat sz, KnownMaybeTail tl) => KnownSigOffsetMap ('SigOffsetMap ss sz tl) where+  sigOffsetMapVal _ =+    OffsetMap (slotsVal (Proxy @ss)) (maybeNatVal (Proxy @sz)) (maybeTailVal (Proxy @tl))++{- | The @(base offset, element stride)@ of a buffer signature's runtime-array+tail, recovered straight from the type level. Only a layout that /has/ a tail has+an instance, so reading it is total — and unlike reflecting the whole 'OffsetMap' and+inspecting its 'Maybe' tail ('sigOffsetMapVal'), it forces only the two 'Nat's it+needs, not the element's slot list. So an element loop pays @O(1)@ per element,+not @O(offset map)@.+-}+class KnownArrayTail (t :: SigOffsetMap) where+  arrayTailBaseStride :: (Int, Int)++instance (KnownNat base, KnownNat stride) => KnownArrayTail ('SigOffsetMap cs csz ('Just ('SigTail base stride es))) where+  arrayTailBaseStride =+    (fromIntegral (natVal (Proxy @base)), fromIntegral (natVal (Proxy @stride)))++-- | Reflect an optional ground offset map (e.g. a push-constant layout) back to a value.+class KnownMaybeSig (m :: Maybe SigOffsetMap) where+  maybeSigVal :: Proxy m -> Maybe OffsetMap++instance KnownMaybeSig 'Nothing where+  maybeSigVal _ = Nothing++instance (KnownSigOffsetMap g) => KnownMaybeSig ('Just g) where+  maybeSigVal _ = Just (sigOffsetMapVal (Proxy @g))++-- | Reflect a list of @((set, binding), offset map)@ entries back to values.+class KnownKeyedSigs (xs :: [((Nat, Nat), SigOffsetMap)]) where+  keyedSigsVal :: Proxy xs -> [((Word32, Word32), OffsetMap)]++instance KnownKeyedSigs '[] where+  keyedSigsVal _ = []++instance+  (KnownNat s, KnownNat b, KnownSigOffsetMap g, KnownKeyedSigs rest)+  => KnownKeyedSigs ('( '(s, b), g) ': rest)+  where+  keyedSigsVal _ =+    ((nat32 (Proxy @s), nat32 (Proxy @b)), sigOffsetMapVal (Proxy @g))+      : keyedSigsVal (Proxy @rest)++nat32 :: (KnownNat n) => Proxy n -> Word32+nat32 = fromIntegral . natVal++-- Matching. ---------------------------------------------------------------------++{- | The use-site matcher: @'Fits' r t@ holds when a value of layout @r@ may be+viewed at a slot of layout @t@. Since both are normalized before promotion,+layout-equivalent layouts share a signature and match by equality; a difference is+a legible compile error. (Runtime-tail absorption is handled value-level when a+buffer's signature is built; this matcher covers the ground case.)+-}+type family Fits (r :: SigOffsetMap) (t :: SigOffsetMap) :: Constraint where+  Fits g g = ()+  Fits r t =+    TypeError+      ( 'Text "Layout mismatch."+          ':$$: 'Text "  have: "+          ':<>: 'ShowType r+          ':$$: 'Text "  want: "+          ':<>: 'ShowType t+      )++{- | The signature of a tightly-packed runtime array @r[]@ — an SSBO whose content+is a runtime array of the element layout @r@. The element becomes the array+tail: its (statically known) size is the stride, the base offset is 0, and the+closed slots clear. Use to tag a mapped SSBO pointer, e.g.+@'Vulkan.Utils.SpirV.Buffer.unsafeAsBufferPtr' p :: io (Buffer ('ArrayOf' ('Sig' Vertex)))@.+(The element's std430 standalone size equals its array stride, so this is exact+for a tightly-packed @T[]@.)+-}+type family ArrayOf (r :: SigOffsetMap) :: SigOffsetMap where+  ArrayOf ('SigOffsetMap slots ('Just size) 'Nothing) =+    'SigOffsetMap '[] 'Nothing ('Just ('SigTail 0 size slots))+  ArrayOf r =+    TypeError+      ( 'Text "ArrayOf: the element layout must be statically sized and not itself open:"+          ':$$: 'Text "  "+          ':<>: 'ShowType r+      )++{- | @'FitsTail' r t@ holds when a record of layout @r@ is one element of the+runtime-array tail of buffer layout @t@: @r@ is closed with a known size equal+to the tail stride, and its slots are exactly the tail element's. Layout-equivalent+element records share a signature, so they match too; a mismatch (or a @t@+without a tail) is a legible compile error.+-}+type family FitsTail (r :: SigOffsetMap) (t :: SigOffsetMap) :: Constraint where+  FitsTail ('SigOffsetMap es ('Just sz) 'Nothing) ('SigOffsetMap _ _ ('Just ('SigTail _ sz es))) = ()+  FitsTail r t =+    TypeError+      ( 'Text "Element layout does not fit the buffer's array tail."+          ':$$: 'Text "  element: "+          ':<>: 'ShowType r+          ':$$: 'Text "  buffer:  "+          ':<>: 'ShowType t+      )++-- Generation. -------------------------------------------------------------------++{- | Emit @instance 'KnownLayout' <name> where type 'Sig' <name> = <promoted+offset map>@, promoting the value-level normal form to the type level.+-}+knownLayoutInstance :: Name -> OffsetMap -> [Dec]+knownLayoutInstance name om =+  [ InstanceD+      Nothing+      []+      (ConT ''KnownLayout `AppT` ConT name)+      [TySynInstD (TySynEqn Nothing (ConT ''Sig `AppT` ConT name) (promoteOffsetMap om))]+  ]++promoteOffsetMap :: OffsetMap -> Type+promoteOffsetMap (OffsetMap slots msize mtail) =+  PromotedT 'SigOffsetMap+    `AppT` promoteSlots slots+    `AppT` promoteMaybe natT msize+    `AppT` promoteMaybe promoteTail mtail++promoteTail :: RuntimeTail -> Type+promoteTail (RuntimeTail base stride es) =+  PromotedT 'SigTail `AppT` natT base `AppT` natT stride `AppT` promoteSlots es++promoteSlots :: [Slot] -> Type+promoteSlots = promoteList promoteSlot++promoteSlot :: Slot -> Type+promoteSlot (Slot off sc) =+  PromotedT 'SigSlot `AppT` natT off `AppT` PromotedT (scalarName sc)++-- | Promote a list, element-wise, to a promoted @'[..]@.+promoteList :: (a -> Type) -> [a] -> Type+promoteList f = foldr (\x acc -> PromotedConsT `AppT` f x `AppT` acc) PromotedNilT++-- | Promote a 'Maybe' to a promoted @'Nothing@ \/ @'Just@.+promoteMaybe :: (a -> Type) -> Maybe a -> Type+promoteMaybe _ Nothing = PromotedT 'Nothing+promoteMaybe f (Just x) = PromotedT 'Just `AppT` f x++-- | An integral value as a type-level 'Nat' literal.+natT :: (Integral a) => a -> Type+natT = LitT . NumTyLit . fromIntegral++scalarName :: ScalarType -> Name+scalarName = \case+  STFloat -> 'STFloat+  STDouble -> 'STDouble+  STInt -> 'STInt+  STUInt -> 'STUInt+  STInt64 -> 'STInt64+  STUInt64 -> 'STUInt64+  STBool -> 'STBool+  STAddress -> 'STAddress
+ src/Vulkan/Utils/SpirV/Specialization.hs view
@@ -0,0 +1,145 @@+{-| Build Vulkan specialization-constant values from a reflected 'Module'.++Reflection yields each constant's @constant_id@ and name but not its type or+width, and the value side (the 'Specialization' class) is a stack of 'Word32's —+so only 32-bit scalar constants (@int@\/@uint@\/@float@\/@bool@, the+@GL_KHR_vulkan_glsl@ baseline) are supported, one 4-byte slot each.+'specializationMapEntries' lays them out in ascending @constant_id@ order (the+ids need not be contiguous). Wider constants are out of scope (see+@spirv-cleanup.md@); a 64-bit value supplied as two 'Word32's trips 'packed'\'s+arity check rather than being silently truncated.++Supply the values via the 'Specialization' class from+"Vulkan.Utils.Pipeline.Specialization", in ascending @constant_id@ order. (That+module shares the 32-bit limit and additionally assumes @constantID = offset \/ 4@.)+-}+module Vulkan.Utils.SpirV.Specialization+  ( specializationConstants+  , specializationMapEntries+  , withSpecializationInfo+  , allocateSpecializationInfo+  ) where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)+import Control.Monad.Trans.Resource (MonadResource, allocate)+import Data.List (sortOn)+import Data.Text (Text)+import Data.Vector (Vector)+import Data.Vector qualified as V+import Data.Vector.Storable qualified as VS+import Data.Word (Word32)+import Foreign.Marshal.Alloc (free)+import Foreign.Marshal.Array (mallocArray, pokeArray)+import Foreign.Ptr (Ptr, castPtr)+import Vulkan.Core10 qualified as Vk+import Vulkan.Utils.Pipeline.Specialization (Specialization (..))++import Data.SpirV.Reflect.Module (Module)+import Data.SpirV.Reflect.Module qualified as Module+import Data.SpirV.Reflect.SpecializationConstant qualified as SC++-- | Reflected specialization constants as @(constant_id, name)@, ascending by id.+specializationConstants :: Module -> [(Word32, Maybe Text)]+specializationConstants m =+  sortOn fst [(scId c, scName c) | c <- V.toList (moduleSpecConstants m)]++{- | One tightly-packed 32-bit map entry per reflected spec constant, ascending+by @constant_id@ (offset @= index * 4@, size 4).+-}+specializationMapEntries :: Module -> Vector Vk.SpecializationMapEntry+specializationMapEntries m =+  V.fromList+    [ Vk.SpecializationMapEntry+        { Vk.constantID = cid+        , Vk.offset = fromIntegral (ix * 4)+        , Vk.size = 4+        }+    | (ix, (cid, _)) <- zip [0 :: Int ..] (specializationConstants m)+    ]++{- | Pack a 'Specialization' against the reflected map entries, yielding a+'Vk.SpecializationInfo' valid for the callback's duration (pipeline creation+copies the values out — build and create the pipeline inside the callback).+'Nothing' when the shader declares no spec constants.++The supplied values must be in ascending @constant_id@ order and number the+shader's declared constants; a mismatch is a programmer error and 'error's.+-}+withSpecializationInfo+  :: (Specialization spec, MonadUnliftIO m)+  => Module+  -> spec+  -> (Maybe Vk.SpecializationInfo -> m a)+  -> m a+withSpecializationInfo m spec action =+  case packed m spec of+    Nothing -> action Nothing+    Just (entries, ws) ->+      withRunInIO $ \run ->+        VS.unsafeWith (VS.fromList ws) $ \p ->+          run . action $ Just (specInfo entries (length ws) (castPtr p))++{- | As 'withSpecializationInfo', but the backing buffer lives until the+surrounding 'Control.Monad.Trans.Resource.ResourceT' scope ends rather than a+callback — so it survives a later pipeline creation. 'Nothing' when the shader+declares no spec constants.+-}+allocateSpecializationInfo+  :: (Specialization spec, MonadResource m)+  => Module+  -> spec+  -> m (Maybe Vk.SpecializationInfo)+allocateSpecializationInfo m spec =+  case packed m spec of+    Nothing -> pure Nothing+    Just (entries, 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 (specInfo entries n (castPtr ptr))++{- | Reflected map entries paired with the caller's packed values, or 'Nothing'+when there are no spec constants. 'error's on an arity mismatch.+-}+packed+  :: (Specialization spec)+  => Module+  -> spec+  -> Maybe (Vector Vk.SpecializationMapEntry, [Word32])+packed m spec+  | V.null entries = Nothing+  | length ws /= n =+      error $+        "Vulkan.Utils.SpirV.Specialization: shader declares "+          <> show n+          <> " specialization constant(s) but "+          <> show (length ws)+          <> " value(s) were supplied"+  | otherwise = Just (entries, ws)+  where+    entries = specializationMapEntries m+    n = V.length entries+    ws = specializationData spec++specInfo :: Vector Vk.SpecializationMapEntry -> Int -> Ptr () -> Vk.SpecializationInfo+specInfo entries n p =+  Vk.SpecializationInfo+    { Vk.mapEntries = entries+    , Vk.dataSize = fromIntegral (n * 4)+    , Vk.data' = p+    }++-- Field accessors via record patterns (the constructor disambiguates the+-- DuplicateRecordFields names).++moduleSpecConstants :: Module -> Vector SC.SpecializationConstant+moduleSpecConstants Module.Module{Module.spec_constants = cs} = cs++scId :: SC.SpecializationConstant -> Word32+scId SC.SpecializationConstant{SC.constant_id = i} = i++scName :: SC.SpecializationConstant -> Maybe Text+scName SC.SpecializationConstant{SC.name = n} = n
+ src/Vulkan/Utils/SpirV/Stage.hs view
@@ -0,0 +1,392 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoFieldSelectors #-}++{-| Per-shader /stage signatures/ and the type-level checks that compose them.++A 'ShaderSig' captures, at the type level, a shader stage's interface (its @in@+and @out@ variables, by location) and its resource layouts (descriptor blocks by+@(set, binding)@, and push constants) — each as a normalized 'SigOffsetMap'+("Vulkan.Utils.SpirV.Signature"). 'reflectStageSig' emits one from a compiled+@.spv@; the value-level 'StageInfo' it is promoted from is also returned by+'stageInfoOf' for use as the oracle and for building Vulkan create-infos.++The composition checks are thin type-level /matchers/ (the heavy work stayed+value-level): 'MatchInterface' requires every fragment input to have a+matching-typed vertex output at the same location.++'reflectPipelineLayoutSig' goes one step further: it promotes the /merged/+pipeline-layout signature (descriptor blocks by @(set, binding)@ + push) across a+family of shaders — the type-level counterpart of the runtime merge in+"Vulkan.Utils.SpirV.Descriptors".+-}+module Vulkan.Utils.SpirV.Stage+  ( -- * Stage signatures+    ShaderSig (..)+  , StageKind (..)++    -- * Value-level extraction (the oracle)+  , StageInfo (..)+  , stageInfoOf+  , matchInterface+  , Linked (..)+  , linkStages++    -- * Type-level checks+  , MatchInterface+  , CompatibleResources++    -- * Merged pipeline-layout signature+  , LayoutSig (..)+  , LayoutInfo (..)+  , mergeLayout+  , KnownLayoutSig (..)++    -- * Generation+  , reflectStageSig+  , reflectStageSigBytes+  , reflectPipelineLayoutSig+  , reflectPipelineLayoutSigBytes+  ) where++import Data.ByteString (ByteString)+import Data.Kind (Constraint)+import Data.List (foldl', sortOn)+import Data.Proxy (Proxy (..))+import Data.Vector qualified as V+import Data.Word (Word32)+import GHC.TypeLits (ErrorMessage (..), Nat, TypeError)+import Language.Haskell.TH++import Data.SpirV.Enum (BuiltIn (..))+import Data.SpirV.Reflect.InterfaceVariable qualified as InterfaceVariable+import Data.SpirV.Reflect.Module (Module)+import Data.SpirV.Reflect.Module qualified+import Data.SpirV.Reflect.TypeDescription (TypeDescription)++import Vulkan.Utils.SpirV.Layout (OffsetMap, fromFields, leafFieldType, normalize)+import Vulkan.Utils.SpirV.Reflect (reflectBytes, reflectFileQ)+import Vulkan.Utils.SpirV.Reflect.OffsetMaps (pushOffsetMap, resourceOffsetMaps)+import Vulkan.Utils.SpirV.Signature (KnownKeyedSigs (..), KnownMaybeSig (..), SigOffsetMap, natT, promoteList, promoteMaybe, promoteOffsetMap)+import Vulkan.Utils.SpirV.Types (LayoutMode (..), classifyType)++-- | Which pipeline stage a shader is.+data StageKind = VertexStage | FragmentStage | ComputeStage+  deriving (Eq, Show)++{- | A stage's type-level signature: stage, inputs and outputs (location ↦ layout),+resources (@(set, binding)@ ↦ block layout) and an optional push-constant layout.+-}+data ShaderSig+  = ShaderSig+      StageKind+      [(Nat, SigOffsetMap)]+      [(Nat, SigOffsetMap)]+      [((Nat, Nat), SigOffsetMap)]+      (Maybe SigOffsetMap)++-- Value-level extraction. -------------------------------------------------------++{- | The value-level form of a 'ShaderSig', reflected from a 'Module'. This is the+oracle the type level is promoted from, and the source for Vulkan create-infos.+-}+data StageInfo = StageInfo+  { stage :: StageKind+  , inputs :: [(Word32, OffsetMap)]+  , outputs :: [(Word32, OffsetMap)]+  , resources :: [((Word32, Word32), OffsetMap)]+  , push :: Maybe OffsetMap+  }+  deriving (Eq, Show)++-- | Reflect a module's stage signature.+stageInfoOf :: Module -> StageInfo+stageInfoOf m =+  StageInfo+    { stage = stageKindOf m.shader_stage+    , inputs = interfaceOffsetMaps m.input_variables+    , outputs = interfaceOffsetMaps m.output_variables+    , resources = sortOn fst (resourceOffsetMaps m)+    , push =+        case V.toList m.push_constants of+          (pc : _) -> pushOffsetMap pc+          [] -> Nothing+    }++-- | Interface variables as @(location, offset map)@, built-ins dropped, ascending.+interfaceOffsetMaps :: V.Vector InterfaceVariable.InterfaceVariable -> [(Word32, OffsetMap)]+interfaceOffsetMaps vs =+  sortOn+    fst+    -- a non-built-in reads as Nothing (ffi) or the @BuiltIn (-1)@ sentinel (yaml)+    [ (v.location, g)+    | v <- V.toList vs+    , v.built_in `elem` [Nothing, Just (BuiltIn (-1))]+    , Just td <- [v.type_description]+    , Just g <- [interfaceOffsetMap td]+    ]++-- | The offset map of a single interface variable (a scalar/vector at offset 0).+interfaceOffsetMap :: TypeDescription -> Maybe OffsetMap+interfaceOffsetMap td = do+  numeric <- classifyType td+  pure (normalize (fromFields Std430Layout Nothing [("v", leafFieldType numeric)]))++stageKindOf :: Int -> StageKind+stageKindOf n+  | n == 0x01 = VertexStage+  | n == 0x10 = FragmentStage+  | otherwise = ComputeStage++{- | The interface oracle: every input of the second stage must have an+equal-typed output in the first. (Use as @matchInterface vert frag@.)+-}+matchInterface :: StageInfo -> StageInfo -> Either String ()+matchInterface producer consumer =+  mapM_ check consumer.inputs+  where+    outs = producer.outputs+    check (loc, want) =+      case lookup loc outs of+        Just have+          | have == want -> Right ()+          | otherwise ->+              Left ("interface mismatch at location " <> show loc)+        Nothing ->+          Left ("input at location " <> show loc <> " has no matching output")++{- | A linked vertex+fragment pipeline's combined signature (value-level oracle):+the merged resources (shared @(set, binding)@s deduped) and push constants, the+vertex stage's inputs (vertex attributes) and the fragment stage's outputs+(colour attachments).+-}+data Linked = Linked+  { resources :: [((Word32, Word32), OffsetMap)]+  , push :: Maybe OffsetMap+  , inputs :: [(Word32, OffsetMap)]+  , outputs :: [(Word32, OffsetMap)]+  }+  deriving (Eq, Show)++{- | Link a vertex and a fragment stage: the interface must match, shared bindings+and push constants must agree, and the resources union. Mirrors the type-level+'MatchInterface' + 'CompatibleResources'.+-}+linkStages :: StageInfo -> StageInfo -> Either String Linked+linkStages vert frag = do+  matchInterface vert frag+  resources <- mergeAssoc showKey vert.resources frag.resources+  push <- mergePush vert.push frag.push+  pure+    Linked+      { resources = sortOn fst resources+      , push+      , inputs = vert.inputs+      , outputs = frag.outputs+      }+  where+    showKey (s, b) = "(set " <> show s <> ", binding " <> show b <> ")"++-- | Union two keyed offset-map lists; a shared key whose maps differ is an error.+mergeAssoc :: (Eq k) => (k -> String) -> [(k, OffsetMap)] -> [(k, OffsetMap)] -> Either String [(k, OffsetMap)]+mergeAssoc shw xs ys = foldr step (Right xs) ys+  where+    step (k, g) acc = do+      m <- acc+      case lookup k m of+        Nothing -> Right ((k, g) : m)+        Just g'+          | g' == g -> Right m+          | otherwise -> Left ("incompatible layouts at " <> shw k)++mergePush :: Maybe OffsetMap -> Maybe OffsetMap -> Either String (Maybe OffsetMap)+mergePush Nothing b = Right b+mergePush a Nothing = Right a+mergePush (Just a) (Just b)+  | a == b = Right (Just a)+  | otherwise = Left "incompatible push-constant layouts between stages"++-- Merged pipeline-layout signature. ---------------------------------------------++{- | A merged pipeline-layout signature at the type level: the descriptor blocks by+@(set, binding)@ and the push-constant block, unified across a family of shaders.+The type-level mirror of 'LayoutInfo'.+-}+data LayoutSig = LayoutSig [((Nat, Nat), SigOffsetMap)] (Maybe SigOffsetMap)++{- | The value-level merged layout 'reflectPipelineLayoutSig' promotes (its oracle):+each descriptor block's 'OffsetMap' by @(set, binding)@ ascending, and the+push-constant block.+-}+data LayoutInfo = LayoutInfo+  { resources :: [((Word32, Word32), OffsetMap)]+  , push :: Maybe OffsetMap+  }+  deriving (Eq, Show)++{- | Merge several stages into one pipeline-layout signature: descriptor blocks are+unioned (a shared @(set, binding)@ whose layouts disagree is a 'Left') and the+push-constant blocks unified. Unlike 'linkStages' there is no interface check — one+layout is shared across pipelines whose vertex\/fragment interfaces differ.+-}+mergeLayout :: [Module] -> Either String LayoutInfo+mergeLayout modules = do+  resources <- foldl' addResources (Right []) infos+  push <- foldl' addPush (Right Nothing) infos+  pure LayoutInfo{resources = sortOn fst resources, push}+  where+    infos = map stageInfoOf modules+    addResources acc info = acc >>= mergeAssoc showKey info.resources+    addPush acc info = acc >>= \p -> mergePush p info.push+    showKey (s, b) = "(set " <> show s <> ", binding " <> show b <> ")"++{- | Reflect a type-level 'LayoutSig' back to its value 'LayoutInfo' — the oracle+view, for validating the promotion and (later) driving bind-site checks.+-}+class KnownLayoutSig (sig :: LayoutSig) where+  layoutSigVal :: Proxy sig -> LayoutInfo++instance (KnownKeyedSigs rs, KnownMaybeSig p) => KnownLayoutSig ('LayoutSig rs p) where+  layoutSigVal _ = LayoutInfo{resources = keyedSigsVal (Proxy @rs), push = maybeSigVal (Proxy @p)}++-- Type-level checks. ------------------------------------------------------------++{- | Holds when every input of @f@ has a matching-typed output of @v@ at the same+location (extra outputs of @v@ are allowed). A mismatch is a compile error.+-}+type family MatchInterface (v :: ShaderSig) (f :: ShaderSig) :: Constraint where+  MatchInterface ('ShaderSig _ _ vouts _ _) ('ShaderSig _ fins _ _ _) = MatchAll fins vouts++type family MatchAll (ins :: [(Nat, SigOffsetMap)]) (outs :: [(Nat, SigOffsetMap)]) :: Constraint where+  MatchAll '[] _ = ()+  MatchAll ('(loc, g) ': rest) outs = (MatchOne loc g (Lookup loc outs), MatchAll rest outs)++type family MatchOne (loc :: Nat) (want :: SigOffsetMap) (have :: Maybe SigOffsetMap) :: Constraint where+  MatchOne _ g ('Just g) = ()+  MatchOne loc want ('Just have) =+    TypeError+      ( 'Text "Interface mismatch at location "+          ':<>: 'ShowType loc+          ':<>: 'Text ":"+          ':$$: 'Text "  vertex out: "+          ':<>: 'ShowType have+          ':$$: 'Text "  fragment in: "+          ':<>: 'ShowType want+      )+  MatchOne loc _ 'Nothing =+    TypeError+      ('Text "Fragment input at location " ':<>: 'ShowType loc ':<>: 'Text " has no matching vertex output.")++type family Lookup (k :: Nat) (xs :: [(Nat, SigOffsetMap)]) :: Maybe SigOffsetMap where+  Lookup _ '[] = 'Nothing+  Lookup k ('(k, v) ': _) = 'Just v+  Lookup k ('(_, _) ': rest) = Lookup k rest++{- | Holds when every descriptor block and push constant the two stages /share/+(same @(set, binding)@) has the same layout. Disjoint resources are fine; a+shared binding with differing layouts is a compile error.+-}+type family CompatibleResources (v :: ShaderSig) (f :: ShaderSig) :: Constraint where+  CompatibleResources ('ShaderSig _ _ _ vres vpush) ('ShaderSig _ _ _ fres fpush) =+    (CompatAll vres fres, CompatPush vpush fpush)++type family CompatAll (xs :: [((Nat, Nat), SigOffsetMap)]) (ys :: [((Nat, Nat), SigOffsetMap)]) :: Constraint where+  CompatAll '[] _ = ()+  CompatAll ('(k, g) ': rest) ys = (CompatOne k g (LookupR k ys), CompatAll rest ys)++type family CompatOne (k :: (Nat, Nat)) (g :: SigOffsetMap) (m :: Maybe SigOffsetMap) :: Constraint where+  CompatOne _ _ 'Nothing = ()+  CompatOne _ g ('Just g) = ()+  CompatOne k _ ('Just _) =+    TypeError+      ( 'Text "Resource layout mismatch at set/binding "+          ':<>: 'ShowType k+          ':<>: 'Text " between stages."+      )++type family CompatPush (a :: Maybe SigOffsetMap) (b :: Maybe SigOffsetMap) :: Constraint where+  CompatPush 'Nothing _ = ()+  CompatPush _ 'Nothing = ()+  CompatPush ('Just g) ('Just g) = ()+  CompatPush ('Just _) ('Just _) =+    TypeError ('Text "Push-constant layouts differ between stages.")++type family LookupR (k :: (Nat, Nat)) (xs :: [((Nat, Nat), SigOffsetMap)]) :: Maybe SigOffsetMap where+  LookupR _ '[] = 'Nothing+  LookupR k ('(k, v) ': _) = 'Just v+  LookupR k ('(_, _) ': rest) = LookupR k rest++-- Generation. -------------------------------------------------------------------++-- | Reflect a compiled @.spv@ and emit @type \<name\> = \<promoted ShaderSig\>@.+reflectStageSig :: String -> FilePath -> Q [Dec]+reflectStageSig name path = do+  m <- reflectFileQ path+  pure [TySynD (mkName name) [] (promoteStageInfo (stageInfoOf m))]++{- | As 'reflectStageSig', but from SPIR-V bytecode already in hand — e.g. a+quasiquoted shader imported from another module (the Template Haskell stage+restriction applies).+-}+reflectStageSigBytes :: String -> ByteString -> Q [Dec]+reflectStageSigBytes name bytes = do+  m <- runIO (reflectBytes bytes)+  pure [TySynD (mkName name) [] (promoteStageInfo (stageInfoOf m))]++promoteStageInfo :: StageInfo -> Type+promoteStageInfo si =+  PromotedT 'ShaderSig+    `AppT` promoteStage si.stage+    `AppT` promoteList (promoteLocated promoteOffsetMap) si.inputs+    `AppT` promoteList (promoteLocated promoteOffsetMap) si.outputs+    `AppT` promoteList (promoteKeyed promoteOffsetMap) si.resources+    `AppT` promoteMaybe promoteOffsetMap si.push++promoteStage :: StageKind -> Type+promoteStage = \case+  VertexStage -> PromotedT 'VertexStage+  FragmentStage -> PromotedT 'FragmentStage+  ComputeStage -> PromotedT 'ComputeStage++promoteLocated :: (a -> Type) -> (Word32, a) -> Type+promoteLocated f (loc, x) = pair (natT loc) (f x)++promoteKeyed :: (a -> Type) -> ((Word32, Word32), a) -> Type+promoteKeyed f ((s, b), x) = pair (pair (natT s) (natT b)) (f x)++pair :: Type -> Type -> Type+pair a b = PromotedTupleT 2 `AppT` a `AppT` b++{- | Reflect the @.spv@ of a pipeline's shaders and emit+@type \<name\> = \<promoted merged layout signature\>@ — the descriptor blocks by+@(set, binding)@ and push constants merged across the stages ('mergeLayout' is the+oracle). A layout disagreement between stages fails the splice. The type-level+counterpart of 'Vulkan.Utils.SpirV.Descriptors.mergedDescriptorSetLayoutInfos'.+-}+reflectPipelineLayoutSig :: String -> [FilePath] -> Q [Dec]+reflectPipelineLayoutSig name paths = do+  modules <- traverse reflectFileQ paths+  case mergeLayout modules of+    Left err -> fail ("reflectPipelineLayoutSig: " <> err)+    Right info -> pure [TySynD (mkName name) [] (promoteLayoutSig info)]++-- | As 'reflectPipelineLayoutSig', but from SPIR-V bytecode already in hand.+reflectPipelineLayoutSigBytes :: String -> [ByteString] -> Q [Dec]+reflectPipelineLayoutSigBytes name bytess = do+  modules <- runIO (traverse reflectBytes bytess)+  case mergeLayout modules of+    Left err -> fail ("reflectPipelineLayoutSigBytes: " <> err)+    Right info -> pure [TySynD (mkName name) [] (promoteLayoutSig info)]++promoteLayoutSig :: LayoutInfo -> Type+promoteLayoutSig info =+  PromotedT 'LayoutSig+    `AppT` promoteList (promoteKeyed promoteOffsetMap) info.resources+    `AppT` promoteMaybe promoteOffsetMap info.push
+ src/Vulkan/Utils/SpirV/TH.hs view
@@ -0,0 +1,140 @@+{-| Template Haskell entry points: reflect a compiled @.spv@ at build time and+splice Haskell record types for its uniform / storage / push-constant blocks.++Types are keyed by their SPIR-V struct name and generated at most once; a name+that already resolves in scope (e.g. generated from another shader that shares+an include) is referenced rather than redefined, so shared GLSL types map to a+single shared Haskell type.+-}+module Vulkan.Utils.SpirV.TH+  ( reflectShaderTypes+  , reflectShaderTypesWith+  , reflectShaderTypesBytes+  , reflectShaderTypesBytesWith+  , reflectModuleTypes+  , reflectModuleTypesWith+  ) where++import Data.ByteString (ByteString)+import Data.Map.Strict qualified as Map+import Data.Vector qualified as V+import Language.Haskell.TH++import Data.SpirV.Reflect.BlockVariable qualified+import Data.SpirV.Reflect.DescriptorBinding qualified+import Data.SpirV.Reflect.Enums.DescriptorType qualified as R+import Data.SpirV.Reflect.Module (Module)+import Data.SpirV.Reflect.Module qualified+import Data.SpirV.Reflect.TypeDescription (TypeDescription)++import Vulkan.Utils.SpirV.Block (allMembers16, collectStructs, structRecordDec, structTypeName)+import Vulkan.Utils.SpirV.Reflect (reflectBytes, reflectFileQ)+import Vulkan.Utils.SpirV.Types (LayoutMode (..), TypeMap, geomancyTypeMap)++{- | Reflect a @.spv@ file and generate record types for its blocks, using the+default 'geomancyTypeMap'.+-}+reflectShaderTypes :: FilePath -> Q [Dec]+reflectShaderTypes = reflectShaderTypesWith geomancyTypeMap++-- | As 'reflectShaderTypes', with a caller-supplied 'TypeMap'.+reflectShaderTypesWith :: TypeMap -> FilePath -> Q [Dec]+reflectShaderTypesWith tymap path = reflectFileQ path >>= reflectModuleTypesWith tymap++{- | As 'reflectShaderTypes', but reflecting SPIR-V bytecode already in hand+rather than reading a @.spv@ file — e.g. the 'ByteString' a @[comp|…|]@+quasiquoter produced in a shader module, referenced from the module that+assembles the pipeline:++@+reflectShaderTypesBytes Shaders.compSpirv+@++No file is involved. Because the bytes are an ordinary imported binding, GHC's+cross-module recompilation reruns the splice when they change, so (unlike the+file path) there is no 'Language.Haskell.TH.Syntax.addDependentFile' to forget.+The usual Template Haskell stage restriction applies: the bytes must come from a+different module than the splice.+-}+reflectShaderTypesBytes :: ByteString -> Q [Dec]+reflectShaderTypesBytes = reflectShaderTypesBytesWith geomancyTypeMap++-- | As 'reflectShaderTypesBytes', with a caller-supplied 'TypeMap'.+reflectShaderTypesBytesWith :: TypeMap -> ByteString -> Q [Dec]+reflectShaderTypesBytesWith tymap bytes = runIO (reflectBytes bytes) >>= reflectModuleTypesWith tymap++{- | Generate record types for every block a reflected 'Module' declares.++The shared core of 'reflectShaderTypes' and 'reflectShaderTypesBytes', exposed so+a caller who already holds a 'Module' can reach codegen without re-reflecting —+and can reflect once, then splice from the same 'Module' in more than one place.+-}+reflectModuleTypes :: Module -> Q [Dec]+reflectModuleTypes = reflectModuleTypesWith geomancyTypeMap++-- | As 'reflectModuleTypes', with a caller-supplied 'TypeMap'.+reflectModuleTypesWith :: TypeMap -> Module -> Q [Dec]+reflectModuleTypesWith tymap = genStructs tymap . moduleStructCandidates++{- | The @OpTypeStruct@ descriptions worth turning into records, each paired with+the layout its 'Storable' should follow. Each block is expanded through+'collectStructs' so nested and array-element structs (e.g. an SSBO's @Sphere[]@+element) are generated too.+-}+moduleStructCandidates :: Module -> [(LayoutMode, TypeDescription)]+moduleStructCandidates m =+  concatMap (uncurry collectStructs) $+    [ (layoutForDescriptor b.descriptor_type, td)+    | b <- V.toList m.descriptor_bindings+    , Just td <- [b.type_description]+    ]+      ++ [ (Std430Layout, td)+         | pc <- V.toList m.push_constants+         , Just td <- [pc.type_description]+         ]++layoutForDescriptor :: R.DescriptorType -> LayoutMode+layoutForDescriptor = \case+  R.DESCRIPTOR_TYPE_UNIFORM_BUFFER -> Std140Layout+  _ -> Std430Layout++genStructs :: TypeMap -> [(LayoutMode, TypeDescription)] -> Q [Dec]+genStructs tymap = go Map.empty+  where+    go _ [] = pure []+    go seen ((layout, td) : rest) =+      case structTypeName td of+        Nothing -> go seen rest+        Just nm ->+          case Map.lookup nm seen of+            -- Already requested in this splice.+            Just prev+              | prev == layout -> go seen rest -- same layout; reference it+              | allMembers16 td -> go seen rest -- std140 == std430; safe to share+              | otherwise -> fail (sharingError nm prev layout)+            Nothing -> do+              existing <- lookupTypeName nm+              case existing of+                Just _ -> go (Map.insert nm layout seen) rest -- defined elsewhere; reference it+                Nothing -> do+                  mdec <- structRecordDec tymap layout td+                  decs <- go (Map.insert nm layout seen) rest+                  pure $ maybe decs (++ decs) mdec++{- | A struct used under two layouts that aren't byte-compatible (see+'allMembers16') can't be represented by a single Haskell record.+-}+sharingError :: String -> LayoutMode -> LayoutMode -> String+sharingError nm a b =+  "vulkan-utils-spirv: struct '"+    <> nm+    <> "' is used under both "+    <> showLayout a+    <> " and "+    <> showLayout b+    <> " layouts but is not layout-compatible: not every member is 16-byte "+    <> "aligned. Make each member 16-byte aligned (e.g. use vec4/mat4) so the "+    <> "layouts coincide, or keep the struct to a single layout."+  where+    showLayout Std140Layout = "std140"+    showLayout Std430Layout = "std430"
+ src/Vulkan/Utils/SpirV/Types.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE NoFieldSelectors #-}++{-| Classify a reflected block member into a base scalar + shape, and map it to+a Haskell type that carries a 'Graphics.Gl.Block.Block' instance.++The mapping is pluggable ('TypeMap'). The default is 'geomancyTypeMap', onto+[geomancy](https://hackage.haskell.org/package/geomancy)'s @Vec*@ \/ @IVec*@ \/+@UVec*@ \/ @Mat4@ (which carry native std140/std430 'Block' instances).+'linearTypeMap' is a worked /example/ of the same recipe for a library whose+types are parametric (it is not usable for codegen yet — see its note).++A map names its types by /raw qualified name/ against the library's base module+(e.g. @Geomancy.Vec3@) rather than a compile-time @''@ quote, so this package+depends on no vector library. The names resolve at the /splice site/, so a module+that splices these records must @import Geomancy qualified@ — under the base+module's own name, not an @as@ alias — and have a 'Graphics.Gl.Block.Block'+instance in scope for each mapped type. A missing import surfaces as a plain+\"Not in scope: type constructor Geomancy.Vec3\".++Build a map for any other vector library the same way with 'mkTypeMap' ++'qualType' (+ 'scalarLeaf' for the base components): 'geomancyTypeMap' shows the+monomorphic case (the scalar is baked into the name), 'linearTypeMap' the+parametric case (the scalar is applied as a type argument).+-}+module Vulkan.Utils.SpirV.Types+  ( ScalarType (..)+  , MemberShape (..)+  , NumericType (..)+  , classifyType+  , isBdaPointer+  , arrayDims+  , LayoutMode (..)+  , scalarWidth+  , arrayBaseAlign+  , leafAlignment+  , structBaseAlign+  , TypeMap+  , mkTypeMap+  , scalarLeaf+  , qualType+  , geomancyTypeMap+  , linearTypeMap+  ) where++import Data.Bits ((.&.))+import Data.Int (Int32, Int64)+import Data.Vector.Storable qualified as VS+import Data.Word (Word32, Word64)+import Graphics.Gl.Block (roundUp)+import Language.Haskell.TH (Type (AppT, ConT), mkName)++import Data.SpirV.Reflect.Enums.TypeFlags qualified as TypeFlags+import Data.SpirV.Reflect.Traits qualified as Traits+import Data.SpirV.Reflect.TypeDescription (TypeDescription)+import Data.SpirV.Reflect.TypeDescription qualified as TypeDescription++{- | The base component type of a block member.++'STInt64' \/ 'STUInt64' are 64-bit integers (@int64_t@ \/ @uint64_t@, the+@GL_EXT_shader_explicit_arithmetic_types_int64@ scalars): 8-byte slots, like+'STDouble'. 'STAddress' is a 64-bit buffer device address (@buffer_reference@ /+@PhysicalStorageBuffer@ pointer): no GLSL scalar spelling, but one 8-byte slot+like any other scalar. Sub-32-bit scalars (@float16@ \/ @int16@) are out of scope.+-}+data ScalarType = STFloat | STDouble | STInt | STUInt | STInt64 | STUInt64 | STBool | STAddress+  deriving (Eq, Ord, Show)++-- | The shape of a block member.+data MemberShape+  = ShScalar+  | -- | component count (2..4)+    ShVector Int+  | -- | columns, rows+    ShMatrix Int Int+  deriving (Eq, Ord, Show)++{- | Which gl-block layout a block follows. Uniform buffers use std140; storage+buffers and push constants use std430.+-}+data LayoutMode = Std140Layout | Std430Layout+  deriving (Eq, Show)++-- | The byte width of a scalar component (64-bit scalars are 8, the rest 4).+scalarWidth :: ScalarType -> Int+scalarWidth STDouble = 8+scalarWidth STInt64 = 8+scalarWidth STUInt64 = 8+scalarWidth STAddress = 8+scalarWidth _ = 4++{- | The base alignment of an array or matrix column: std140 rounds the+element\/column alignment up to a multiple of 16, std430 keeps it.+-}+arrayBaseAlign :: LayoutMode -> Int -> Int+arrayBaseAlign Std140Layout a = roundUp a 16+arrayBaseAlign Std430Layout a = a++{- | The base alignment of a leaf member (scalar\/vector\/matrix) under the+layout. A matrix aligns as its column vector (rounded up to 16 under std140).+-}+leafAlignment :: LayoutMode -> ScalarType -> MemberShape -> Int+leafAlignment mode s = \case+  ShScalar -> w+  ShVector 2 -> 2 * w+  ShVector _ -> 4 * w+  ShMatrix _ r -> arrayBaseAlign mode (if r <= 2 then 2 * w else 4 * w)+  where+    w = scalarWidth s++{- | The base alignment of a struct: the largest member alignment (at least 1),+rounded up to 16 under std140.+-}+structBaseAlign :: LayoutMode -> [Int] -> Int+structBaseAlign mode alignments = case mode of+  Std140Layout -> roundUp base 16+  Std430Layout -> base+  where+    base = maximum (1 : alignments)++{- | A numeric (non-struct) leaf type: a base scalar component, a shape+(scalar\/vector\/matrix), and zero or more array dimensions (outermost first;+empty means not an array).+-}+data NumericType = NumericType+  { scalar :: ScalarType+  , shape :: MemberShape+  , array :: [Word32]+  }+  deriving (Eq, Ord, Show)++{- | Classify a reflected struct member (a 'TypeDescription') from its numeric+traits and type flags.+-}+classifyType :: TypeDescription -> Maybe NumericType+classifyType+  TypeDescription.TypeDescription+    { TypeDescription.type_flags = flags+    , TypeDescription.traits = mtraits+    } = do+    Traits.Numeric+      { Traits.scalar = Traits.Scalar{Traits.width = width, Traits.signed = signed}+      , Traits.vector = Traits.Vector{Traits.component_count = vecN}+      , Traits.matrix = Traits.Matrix{Traits.column_count = cols, Traits.row_count = rows}+      } <-+      numericOf mtraits+    let+      shape+        | cols > 0 = ShMatrix (fromIntegral cols) (fromIntegral rows)+        | vecN > 1 = ShVector (fromIntegral vecN)+        | otherwise = ShScalar+      wide = width >= 64+      baseScalar+        | has TypeFlags.TYPE_FLAG_FLOAT = Just $ if wide then STDouble else STFloat+        | has TypeFlags.TYPE_FLAG_INT = Just $ case (signed, wide) of+            (True, False) -> STInt+            (False, False) -> STUInt+            (True, True) -> STInt64+            (False, True) -> STUInt64+        | has TypeFlags.TYPE_FLAG_BOOL = Just STBool+        | otherwise = Nothing+    scalar <- baseScalar+    pure+      NumericType+        { scalar+        , shape+        , array = maybe [] dimsOf (arrayOf mtraits)+        }+    where+      has bit = (flags .&. bit) /= TypeFlags.TypeFlagBits 0++      numericOf t = do+        TypeDescription.Traits{TypeDescription.numeric = n} <- t+        Just n++      arrayOf t = do+        TypeDescription.Traits{TypeDescription.array = a} <- t+        Just a++{- | True when this type is a buffer device address: a @buffer_reference@ \/+@PhysicalStorageBuffer@ pointer (the @REF@ type flag). Such a member is stored as+an 8-byte address, not its pointee inline.+-}+isBdaPointer :: TypeDescription -> Bool+isBdaPointer td = (td.type_flags .&. TypeFlags.TYPE_FLAG_REF) /= TypeFlags.TypeFlagBits 0++{- | The array dimensions of a member (outermost first); @[]@ for a non-array,+@[0]@ for a runtime (unsized) array.+-}+arrayDims :: TypeDescription -> [Word32]+arrayDims td = maybe [] dimsOf (fmap (.array) td.traits)++dimsOf :: Traits.Array -> [Word32]+dimsOf a+  | a.dims_count == 0 = []+  | otherwise = VS.toList a.dims++{- | A pluggable mapping from a classified member to the Haskell type used for+the generated record field. The returned type must have a+'Graphics.Gl.Block.Block' instance. Returning 'Nothing' rejects the member+(the block record is then not generated).+-}+type TypeMap = NumericType -> Maybe Type++{- | Assemble a 'TypeMap' from a vector and a matrix spelling — the shared core+of 'geomancyTypeMap' / 'linearTypeMap'. Scalars always map to base types (via+'scalarLeaf'); only the vector/matrix cases differ between libraries.++This maps an /element/ type only: array dimensions are handled one layer up (in+"Vulkan.Utils.SpirV.Block", which wraps the result in 'Vulkan.Utils.SpirV.Array.Array'),+so a member that still carries array dims here is rejected.+-}+mkTypeMap+  :: (ScalarType -> Int -> Maybe Type)+  -- ^ vector: component scalar and count (2..4)+  -> (ScalarType -> Int -> Int -> Maybe Type)+  -- ^ matrix: component scalar, columns, rows+  -> TypeMap+mkTypeMap vector matrix NumericType{scalar, shape, array}+  | not (null array) = Nothing+  | otherwise = case shape of+      ShScalar -> scalarLeaf scalar+      ShVector n -> vector scalar n+      ShMatrix c r -> matrix scalar c r++{- | The Haskell type for a base scalar component, as a global @''@ quote: 'base'+is always in scope, so a field of this type needs no import at the splice site.+'STAddress' has no scalar spelling — a pointer member is mapped to+'Vulkan.Utils.SpirV.DeviceAddress.DeviceAddress' before it reaches a 'TypeMap'.+-}+scalarLeaf :: ScalarType -> Maybe Type+scalarLeaf = \case+  STFloat -> Just (ConT ''Float)+  STDouble -> Just (ConT ''Double)+  STInt -> Just (ConT ''Int32)+  STUInt -> Just (ConT ''Word32)+  STInt64 -> Just (ConT ''Int64)+  STUInt64 -> Just (ConT ''Word64)+  STBool -> Just (ConT ''Bool)+  STAddress -> Nothing++{- | A type referenced by /raw qualified name/ (@Module.Type@), resolved at the+splice site. This is how a default 'TypeMap' names a vector library's types+without this package depending on it: the splice site supplies the import.+-}+qualType :: String -> String -> Type+qualType modName typeName = ConT (mkName (modName <> "." <> typeName))++{- | The default mapping, onto [geomancy](https://hackage.haskell.org/package/geomancy)'s+vector/matrix types (which carry native std140/std430 'Block' instances). The+names resolve against geomancy's base module, so the splice site needs only a+single @import Geomancy qualified@.+-}+geomancyTypeMap :: TypeMap+geomancyTypeMap = mkTypeMap vector matrix+  where+    -- geomancy spells the scalar into the type name: Vec3 / IVec3 / UVec3.+    vector STFloat n = geomancy <$> sized "Vec" n+    vector STInt n = geomancy <$> sized "IVec" n+    vector STUInt n = geomancy <$> sized "UVec" n+    vector _ _ = Nothing+    matrix STFloat 4 4 = Just (geomancy "Mat4")+    matrix _ _ _ = Nothing+    geomancy = qualType "Geomancy"++{- | A worked /example/ of mapping a vector library whose types are /parametric/:+[linear](https://hackage.haskell.org/package/linear)'s @V2@ \/ @V3@ \/ @V4@ \/+@M44@ take the component scalar as a type argument, so the map applies it+(@V3 Float@, @M44 Float@) instead of spelling it into the name as 'geomancyTypeMap'+does. Names resolve against linear's base module (a single @import Linear qualified@).++Not usable for record generation yet: neither linear nor gl-block ships a+'Graphics.Gl.Block.Block' instance for @V3 Float@ etc., so a generated record+could not derive its 'Foreign.Storable.Storable'. It stands as the template for+the parametric case until linear gains those instances, at which point it becomes+a real alternative default.+-}+linearTypeMap :: TypeMap+linearTypeMap = mkTypeMap vector matrix+  where+    -- linear's vectors are parametric (V3 a): apply the component scalar.+    vector s n+      | s `elem` [STFloat, STInt, STUInt] = AppT . linear <$> sized "V" n <*> scalarLeaf s+      | otherwise = Nothing+    matrix STFloat 4 4 = AppT (linear "M44") <$> scalarLeaf STFloat+    matrix _ _ _ = Nothing+    linear = qualType "Linear"++-- | A library type whose name carries its component count, e.g. @Vec3@ \/ @V4@.+sized :: String -> Int -> Maybe String+sized prefix n+  | n >= 2 && n <= 4 = Just (prefix <> show n)+  | otherwise = Nothing
+ src/Vulkan/Utils/SpirV/VertexInput.hs view
@@ -0,0 +1,91 @@+{-| Build Vulkan vertex-input descriptions from a reflected vertex shader's input+variables. Built-in inputs (e.g. @gl_VertexIndex@) are skipped; the remaining+inputs are packed tightly into a single binding (binding 0), ordered by+@location@, with per-attribute formats taken directly from reflection (SPIR-V+@Format@ shares Vulkan's numeric values).+-}+module Vulkan.Utils.SpirV.VertexInput+  ( vertexInputState+  , vertexInputAttributes+  , vertexInputBinding+  ) where++import Data.List (sortOn)+import Data.Vector qualified as V+import Data.Word (Word32)+import Vulkan.Core10 qualified as Vk+import Vulkan.Zero (zero)++import Data.SpirV.Enum (BuiltIn (..))+import Data.SpirV.Reflect.Enums.Format qualified as R+import Data.SpirV.Reflect.InterfaceVariable qualified as InterfaceVariable+import Data.SpirV.Reflect.Module (Module)+import Data.SpirV.Reflect.Module qualified+import Data.SpirV.Reflect.Traits qualified as Traits++{- | The vertex-input state reflected from a vertex module: the single packed+binding plus its attributes ('vertexInputBinding' + 'vertexInputAttributes'). A+module with no vertex inputs — e.g. one pulling geometry from an SSBO via+@gl_VertexIndex@ — yields 'zero' (no bindings, no attributes).+-}+vertexInputState :: Module -> Vk.PipelineVertexInputStateCreateInfo '[]+vertexInputState m =+  case vertexInputAttributes m of+    [] -> zero+    attrs ->+      zero+        { Vk.vertexBindingDescriptions = V.fromList [vertexInputBinding m]+        , Vk.vertexAttributeDescriptions = V.fromList attrs+        }++-- | One attribute per non-built-in input variable, tightly packed into binding 0.+vertexInputAttributes :: Module -> [Vk.VertexInputAttributeDescription]+vertexInputAttributes m = go 0 (inputs m)+  where+    go _ [] = []+    go off ((loc, fmt, sz) : rest) =+      zero+        { Vk.location = loc+        , Vk.binding = 0+        , Vk.format = fmt+        , Vk.offset = off+        }+        : go (off + sz) rest++{- | The single binding (binding 0, per-vertex) covering all inputs, with stride+equal to their packed size.+-}+vertexInputBinding :: Module -> Vk.VertexInputBindingDescription+vertexInputBinding m =+  zero+    { Vk.binding = 0+    , Vk.stride = sum [sz | (_, _, sz) <- inputs m]+    , Vk.inputRate = Vk.VERTEX_INPUT_RATE_VERTEX+    }++-- | @(location, format, byte size)@ for each non-built-in input, ordered by location.+inputs :: Module -> [(Word32, Vk.Format, Word32)]+inputs m =+  sortOn+    (\(loc, _, _) -> loc)+    -- a non-built-in reads as Nothing (ffi) or the @BuiltIn (-1)@ sentinel (yaml)+    [ (v.location, ivFormat v, ivSize v)+    | v <- V.toList m.input_variables+    , v.built_in `elem` [Nothing, Just (BuiltIn (-1))]+    ]++-- Vulkan-side field extractions.++ivFormat :: InterfaceVariable.InterfaceVariable -> Vk.Format+ivFormat InterfaceVariable.InterfaceVariable{InterfaceVariable.format = R.Format n} =+  Vk.Format (fromIntegral n)++ivSize :: InterfaceVariable.InterfaceVariable -> Word32+ivSize InterfaceVariable.InterfaceVariable{InterfaceVariable.numeric = num} =+  components * (width `div` 8)+  where+    Traits.Numeric+      { Traits.scalar = Traits.Scalar{Traits.width = width}+      , Traits.vector = Traits.Vector{Traits.component_count = vecN}+      } = num+    components = max 1 vecN
+ test/Fixtures.hs view
@@ -0,0 +1,428 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++{-| The test fixture shaders, compiled to SPIR-V at build time by the+vulkan-utils GLSL quasiquoters.++The reflection splices in "Spec" and "LayoutSpec" consume these bytes; the+Template Haskell stage restriction is why they live in their own module.+-}+module Fixtures+  ( juliaComp+  , pushComp+  , ssboStructComp+  , nestedComp+  , arrayFieldComp+  , array2dComp+  , bdaComp+  , wideComp+  , specComp+  , meshVert+  , meshFrag+  , triVert+  ) where++import Data.ByteString (ByteString)+import Vulkan.Utils.ShaderQQ.GLSL.Glslang (comp, compileShaderQ, frag, glsl, vert)++{- | A Julia-set compute shader whose @Params@ UBO (set 0, binding 0, std140)+becomes the generated record, next to an @OutputBuffer@ runtime-array SSBO+(binding 1, not generated). Fields are ordered by non-increasing alignment+(vec2\/uvec2 = 8, float\/uint = 4).+-}+juliaComp :: ByteString+juliaComp =+  [comp|+    #version 450++    layout(local_size_x = 16, local_size_y = 16) in;++    layout(set = 0, binding = 0, std140) uniform Params {+      vec2  center;        // align 8 @0+      uvec2 resolution;    // align 8 @8+      float escapeRadius;  // align 4 @16+      uint  maxIterations; // align 4 @20+    } params;++    layout(set = 0, binding = 1, std430) buffer OutputBuffer {+      vec4 pixels[];+    };++    void main() {+      uvec2 gid = gl_GlobalInvocationID.xy;+      if (gid.x >= params.resolution.x || gid.y >= params.resolution.y) {+        return;+      }+      vec2 z = (vec2(gid) / vec2(params.resolution) * 2.0 - 1.0) * params.escapeRadius;+      uint i = 0u;+      for (; i < params.maxIterations; ++i) {+        z = vec2(z.x * z.x - z.y * z.y, 2.0 * z.x * z.y) + params.center;+        if (dot(z, z) > params.escapeRadius * params.escapeRadius) {+          break;+        }+      }+      pixels[gid.y * params.resolution.x + gid.x] =+        vec4(vec3(float(i) / float(params.maxIterations)), 1.0);+    }+  |]++{- | Push-constant reflection: the @Push@ block becomes a Haskell record with a+gl-block std430 Storable, and @pushConstantRanges@ derives the+VkPushConstantRange. Fields are ordered by non-increasing alignment (mat4 =+16, vec2 = 8, float\/int = 4) to satisfy the gl-block layout guardrail.+-}+pushComp :: ByteString+pushComp =+  [comp|+    #version 450++    layout(local_size_x = 64) in;++    layout(push_constant, std430) uniform Push {+      mat4  transform;+      vec2  offset;+      float scale;+      int   count;+    } push;++    layout(set = 0, binding = 0, std430) buffer Output {+      vec4 data[];+    };++    void main() {+      uint i = gl_GlobalInvocationID.x;+      if (i >= uint(push.count)) {+        return;+      }+      data[i] = push.transform * vec4(push.offset * push.scale, 0.0, 1.0);+    }+  |]++{- | SSBO arrays of structs: the @Particle@ element type is generated as a+std430 record even though the wrapping @Particles@ block is a runtime array+(not itself representable as a flat record). Fields are ordered by+non-increasing alignment (vec3 = 16, vec2 = 8, float\/uint = 4).+-}+ssboStructComp :: ByteString+ssboStructComp =+  [comp|+    #version 450++    layout(local_size_x = 64) in;++    struct Particle {+      vec3  position; // align 16 @0+      vec2  velocity; // align 8  @16+      float mass;     // align 4  @24+      uint  flags;    // align 4  @28+    };++    layout(set = 0, binding = 0, std430) buffer Particles {+      Particle items[];+    };++    void main() {+      uint i = gl_GlobalInvocationID.x;+      items[i].position += vec3(items[i].velocity, 0.0) * items[i].mass;+    }+  |]++{- | Nested structs as fields, plus cross-layout sharing. The @Material@ struct+is all-vec4 (every member 16-byte aligned), so std140 and std430 lay it out+identically: it is used both as a field of the std140 @Scene@ UBO and as the+element of the std430 @Mats@ SSBO, and a single generated record is shared+("promoted") across both.+-}+nestedComp :: ByteString+nestedComp =+  [comp|+    #version 450++    layout(local_size_x = 1) in;++    struct Material {+      vec4 albedo;+      vec4 emission;+    };++    layout(set = 0, binding = 0, std140) uniform Scene {+      Material sun;  // nested struct field @0 (size 32)+      vec4     tint; // @32+    } scene;++    layout(set = 0, binding = 1, std430) buffer Mats {+      Material mats[];+    };++    layout(set = 0, binding = 2, std430) writeonly buffer O {+      vec4 o[];+    };++    void main() {+      o[0] = scene.sun.albedo + scene.sun.emission + scene.tint + mats[0].emission;+    }+  |]++{- | Fixed-size array fields, mapped to @Array n a@. The same fields appear in a+std140 UBO and a std430 SSBO to show the stride difference: std140 rounds+every element up to 16 bytes, std430 packs tightly.+-}+arrayFieldComp :: ByteString+arrayFieldComp =+  [comp|+    #version 450++    layout(local_size_x = 1) in;++    layout(set = 0, binding = 0, std140) uniform Kernel140 {+      vec4  taps[4];    // stride 16 in both+      float weights[4]; // stride 16 in std140+    } k140;++    layout(set = 0, binding = 1, std430) buffer Kernel430 {+      vec4  taps[4];    // stride 16+      float weights[4]; // stride 4 in std430+    } k430;++    layout(set = 0, binding = 2, std430) writeonly buffer O {+      vec4 o[];+    };++    void main() {+      o[0] = k140.taps[0] * k140.weights[0] + k430.taps[0] * k430.weights[0];+    }+  |]++{- | A multi-dimensional array field: @float grid[3][4]@ maps to+@Array 3 (Array 4 Float)@. In std430 the inner stride is 4 (outer 16); in+std140 the inner stride is 16 (outer 64).+-}+array2dComp :: ByteString+array2dComp =+  [comp|+    #version 450++    layout(local_size_x = 1) in;++    layout(set = 0, binding = 0, std430) buffer Grid430 {+      vec4  head;        // @0+      float grid[3][4];  // @16, inner stride 4, outer stride 16+    } g430;++    layout(set = 0, binding = 1, std140) uniform Grid140 {+      vec4  head;        // @0+      float grid[3][4];  // @16, inner stride 16, outer stride 64+    } g140;++    layout(set = 0, binding = 2, std430) writeonly buffer O {+      vec4 o[];+    };++    void main() {+      o[0] = g430.head + g140.head + vec4(g430.grid[0][0] + g140.grid[0][0]);+    }+  |]++{- | A self-referential buffer_reference (BDA) type: a BVH-ish node whose+children are 64-bit device addresses back to @Node@. Reflection-driven codegen+maps the pointer members to @DeviceAddress Node@ (8-byte address), not an+inlined struct, and generates @Node@ once despite the cycle.++buffer_reference needs SPIR-V 1.3+, hence the vulkan1.2 target.+-}+bdaComp :: ByteString+bdaComp =+  $( compileShaderQ+       (Just "vulkan1.2")+       "comp"+       Nothing+       [glsl|+        #version 460+        #extension GL_EXT_buffer_reference : require++        layout(local_size_x = 64) in;++        layout(buffer_reference) buffer Node;            // fwd decl enables self-reference+        layout(buffer_reference, std430) buffer Node {+          vec4 boundsMin;+          vec4 boundsMax;+          Node left;                                     // BDA pointer -> cycle+          Node right;                                    // BDA pointer -> cycle+          uint primCount;+        };++        layout(push_constant, std430) uniform Bvh {+          Node root;                                     // entry address into the graph+        } bvh;++        layout(set = 0, binding = 0, std430) writeonly buffer Out {+          uint hits[];+        };++        void main() {+          Node n = bvh.root;+          uint count = 0u;+          for (int i = 0; i < 8; ++i) {+            count += n.primCount;+            n = n.left;+          }+          hits[gl_GlobalInvocationID.x] = count;+        }+      |]+   )++{- | 64-bit integer block members. A uint64_t\/int64_t occupies an 8-byte std430+slot (alignment 8), exactly like a double — the regression fixture for+scalar-width-faithful classification, so a 64-bit int is never laid out as a+4-byte int. Fields are ordered by non-increasing alignment (8, 8, 4) to keep+gl-block's Generic layout valid.++int64 needs the Int64 capability, hence the vulkan1.1 target.+-}+wideComp :: ByteString+wideComp =+  $( compileShaderQ+       (Just "vulkan1.1")+       "comp"+       Nothing+       [glsl|+        #version 460+        #extension GL_EXT_shader_explicit_arithmetic_types_int64 : require++        layout(local_size_x = 1) in;++        layout(push_constant, std430) uniform Wide {+          uint64_t hi;  // align 8 @0,  size 8+          int64_t  lo;  // align 8 @8,  size 8+          uint     tag; // align 4 @16, size 4+        } wide;++        layout(set = 0, binding = 0, std430) writeonly buffer Out {+          uint sink[];+        };++        void main() {+          sink[0] = uint(wide.hi) + uint(wide.lo) + wide.tag;+        }+      |]+   )++{- | Specialization-constant reflection. The ids are deliberately non-contiguous+(0 and 3) to show that map entries follow the shader's actual constant_ids+while values pack tightly (offsets 0, 4).+-}+specComp :: ByteString+specComp =+  [comp|+    #version 450++    layout(local_size_x = 64) in;++    layout(constant_id = 0) const uint  count = 1u;+    layout(constant_id = 3) const float scale = 1.0;++    layout(set = 0, binding = 0, std430) buffer Output {+      float xs[];+    };++    void main() {+      uint i = gl_GlobalInvocationID.x;+      if (i < count) {+        xs[i] = scale;+      }+    }+  |]++{- | Vertex stage for the type-verified pipeline-assembly tests. Shares the+@Scene@ UBO (set 0, binding 0) with 'meshFrag' (vertex uses viewProj; fragment+uses the light fields), carries a vertex-only @Model@ push constant, and feeds+the fragment stage @outNormal@ (loc 0) + @outUV@ (loc 1).+-}+meshVert :: ByteString+meshVert =+  [vert|+    #version 450++    layout(location = 0) in vec3 inPosition;+    layout(location = 1) in vec3 inNormal;+    layout(location = 2) in vec2 inUV;++    layout(set = 0, binding = 0, std140) uniform Scene {+      mat4 viewProj;+      vec4 lightDir;+      vec4 lightColor;+    } scene;++    layout(push_constant, std430) uniform Model {+      mat4 model;+    } model;++    layout(location = 0) out vec3 outNormal;+    layout(location = 1) out vec2 outUV;++    void main() {+      gl_Position = scene.viewProj * model.model * vec4(inPosition, 1.0);+      outNormal = mat3(model.model) * inNormal;+      outUV = inUV;+    }+  |]++{- | Fragment stage paired with 'meshVert'. Consumes the vertex outputs+(inNormal loc 0, inUV loc 1), shares the @Scene@ UBO (set 0, binding 0 — using+the light fields the vertex stage ignores), and reads a fragment-only+@Materials@ SSBO (set 0, binding 1).+-}+meshFrag :: ByteString+meshFrag =+  [frag|+    #version 450++    layout(location = 0) in vec3 inNormal;+    layout(location = 1) in vec2 inUV;++    layout(set = 0, binding = 0, std140) uniform Scene {+      mat4 viewProj;+      vec4 lightDir;+      vec4 lightColor;+    } scene;++    struct Material {+      vec4 albedo;+      vec4 params;+    };++    layout(set = 0, binding = 1, std430) buffer Materials {+      Material materials[];+    };++    layout(location = 0) out vec4 outColor;++    void main() {+      float ndl = max(dot(normalize(inNormal), normalize(scene.lightDir.xyz)), 0.0);+      vec4 albedo = materials[0].albedo * vec4(inUV, 1.0, 1.0);+      outColor = albedo * scene.lightColor * ndl;+    }+  |]++{- | Vertex-input reflection: three attributes (vec3 \/ vec2 \/ vec4 at+locations 0\/1\/2) that pack tightly to offsets 0\/12\/20 and a 36-byte binding+stride.+-}+triVert :: ByteString+triVert =+  [vert|+    #version 450++    layout(location = 0) in vec3 inPosition;+    layout(location = 1) in vec2 inUV;+    layout(location = 2) in vec4 inColor;++    layout(location = 0) out vec2 outUV;+    layout(location = 1) out vec4 outColor;++    void main() {+      gl_Position = vec4(inPosition, 1.0);+      outUV = inUV;+      outColor = inColor;+    }+  |]
+ test/LayoutSpec.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE OverloadedStrings #-}++{-| Tests for the structured 'Layout' IR, its normalization to a scalar 'OffsetMap',+and the value-level unifier.+-}+module LayoutSpec (tests) where++import Data.Either (isLeft)+import Data.List (isInfixOf)+import Data.Map.Strict qualified as Map+import Data.Text (unpack)+import Data.Vector qualified as V+import Test.Tasty+import Test.Tasty.HUnit++import Data.SpirV.Reflect.BlockVariable qualified+import Data.SpirV.Reflect.DescriptorBinding qualified+import Data.SpirV.Reflect.FFI (loadBytes)+import Data.SpirV.Reflect.Module (Module)+import Data.SpirV.Reflect.Module qualified+import Data.SpirV.Reflect.TypeDescription (TypeDescription)++import Vulkan.Utils.SpirV.Layout+import Vulkan.Utils.SpirV.Layout qualified as OffsetMap (OffsetMap (..))+import Vulkan.Utils.SpirV.Types (LayoutMode (..), ScalarType (..))++import Fixtures qualified++tests :: TestTree+tests =+  testGroup+    "layout IR + unification"+    [ structuredTests+    , normalizeTests+    , unifyTests+    , runtimeTests+    , mergeTests+    , reflectionTests+    ]++-- Convenience constructors. -----------------------------------------------------++-- | A single-member std430 layout.+field430 :: FieldType -> Layout+field430 ft = fromFields Std430Layout Nothing [("x", ft)]++-- | A single-member std140 layout.+field140 :: FieldType -> Layout+field140 ft = fromFields Std140Layout Nothing [("x", ft)]++structuredTests :: TestTree+structuredTests =+  testGroup+    "structured layout (fromFields)"+    [ testCase "std430 packs by member alignment" $ do+        -- mat4 (align 16) @0 size 64, vec2 (align 8) @64, float @72, int @76+        let l =+              fromFields+                Std430Layout+                (Just "Push")+                [ ("transform", Matrix STFloat 4 4)+                , ("offset", Vector STFloat 2)+                , ("scale", Scalar STFloat)+                , ("count", Scalar STInt)+                ]+        offsets l @?= [("transform", 0), ("offset", 64), ("scale", 72), ("count", 76)]+        l.size @?= Just 80+        l.align @?= 16+    , testCase "std140 rounds a scalar array's stride and the struct align to 16" $ do+        let l = field140 (ArrayOf (Sized 4) (Scalar STFloat))+        l.align @?= 16+        l.size @?= Just 64 -- stride 16 * 4+    , testCase "std430 packs a scalar array tightly" $ do+        let l = field430 (ArrayOf (Sized 4) (Scalar STFloat))+        l.align @?= 4+        l.size @?= Just 16+    , testCase "vec3 occupies 12 bytes but aligns to 16" $ do+        let l = fromFields Std430Layout Nothing [("a", Vector STFloat 3), ("b", Scalar STFloat)]+        offsets l @?= [("a", 0), ("b", 12)]+    ]++normalizeTests :: TestTree+normalizeTests =+  testGroup+    "normalize to scalar offset map"+    [ testCase "vec4 flattens to four floats" $+        (normalize (field430 (Vector STFloat 4))).slots+          @?= [Slot 0 STFloat, Slot 4 STFloat, Slot 8 STFloat, Slot 12 STFloat]+    , testCase "mat4 flattens column-major to a 16-float offset map" $+        map (.offset) (normalize (field430 (Matrix STFloat 4 4))).slots+          @?= [0, 4, 8, 12, 16, 20, 24, 28, 32, 36, 40, 44, 48, 52, 56, 60]+    , testCase "std140 float[4] strides by 16" $+        map (.offset) (normalize (field140 (ArrayOf (Sized 4) (Scalar STFloat)))).slots+          @?= [0, 16, 32, 48]+    ]++unifyTests :: TestTree+unifyTests =+  testGroup+    "unify (layout equivalence)"+    [ testCase "mat4 == vec4[4] == float[16] under std430" $ do+        let+          m = normalize (field430 (Matrix STFloat 4 4))+          v = normalize (field430 (ArrayOf (Sized 4) (Vector STFloat 4)))+          f = normalize (field430 (ArrayOf (Sized 16) (Scalar STFloat)))+        foldUnify m [v, f] @?= Right m+    , testCase "float[16] under std140 is NOT layout-equivalent to mat4" $ do+        let+          m = normalize (field430 (Matrix STFloat 4 4))+          f = normalize (field140 (ArrayOf (Sized 16) (Scalar STFloat)))+        case unify m f of+          Left (SlotMismatch off _ _) -> off @?= 4 -- first divergence: mat4 has a float here+          other -> assertFailure ("expected a SlotMismatch at 4, got " <> show other)+    , testCase "a scalar-kind mismatch is reported with its offset" $ do+        let+          a = normalize (field430 (Vector STFloat 2))+          b = normalize (field430 (Vector STInt 2))+        unify a b @?= Left (SlotMismatch 0 STFloat STInt)+    , testCase "differing total size fails even when slots agree" $ do+        -- Same scalar slots, different declared size (e.g. extra trailing padding).+        let+          a = normalize (field430 (Vector STFloat 4))+          big = a{OffsetMap.size = Just 32}+        unify a big @?= Left (SizeMismatch 16 32)+    , testCase "renderMismatch is legible" $+        assertBool "mentions offset and types" $+          "offset 4" `isInfixOf` renderMismatch (SlotMismatch 4 STFloat STInt)+            && "float" `isInfixOf` renderMismatch (SlotMismatch 4 STFloat STInt)+    ]++runtimeTests :: TestTree+runtimeTests =+  testGroup+    "runtime arrays (unification with a hole)"+    [ testCase "an open vec4[] offset map is open (no size, has a tail)" $ do+        let g = normalize (field430 (ArrayOf Runtime (Vector STFloat 4)))+        g.size @?= Nothing+        fmap (.stride) g.tail @?= Just 16+    , testCase "a runtime vec4[] unifies with a concrete vec4[3], pinning the length" $ do+        let+          open = normalize (field430 (ArrayOf Runtime (Vector STFloat 4)))+          closed = normalize (field430 (ArrayOf (Sized 3) (Vector STFloat 4)))+        unify open closed @?= Right closed+        unify closed open @?= Right closed -- symmetric+    , testCase "a runtime vec4[] rejects an offset map that is not whole elements" $ do+        let+          open = normalize (field430 (ArrayOf Runtime (Vector STFloat 4)))+          ragged = normalize (field430 (ArrayOf (Sized 5) (Scalar STFloat)))+        assertBool "should not unify" (isLeft (unify open ragged))+    ]++mergeTests :: TestTree+mergeTests =+  testGroup+    "mergeKeyed (row unification across pipelines)"+    [ testCase "disjoint keys union; shared keys must agree" $ do+        let+          camera = normalize (field140 (Vector STFloat 4))+          lights = normalize (field430 (ArrayOf (Sized 2) (Vector STFloat 4)))+          merged =+            mergeKeyed+              [ ((0, 0) :: (Int, Int), camera) -- vertex stage: set 0 binding 0+              , ((0, 1), lights) -- vertex stage: set 0 binding 1+              , ((0, 0), camera) -- fragment stage: same UBO, must agree+              ]+        fmap Map.keys merged @?= Right [(0, 0), (0, 1)]+    , testCase "a conflicting shared key reports the key and the mismatch" $ do+        let+          a = normalize (field430 (Vector STFloat 4))+          b = normalize (field430 (Vector STInt 4))+        case mergeKeyed [((0, 0) :: (Int, Int), a), ((0, 0), b)] of+          Left (k, SlotMismatch{}) -> k @?= (0, 0)+          other -> assertFailure ("expected a keyed SlotMismatch, got " <> show other)+    ]++reflectionTests :: TestTree+reflectionTests =+  testGroup+    "built from reflected SPIR-V"+    [ testCase "push.comp Push has std430 offsets 0/64/72/76, size 80" $ do+        m <- loadBytes Fixtures.pushComp+        td <- maybe (assertFailure "no push constant block") pure (pushBlock m)+        l <- either (assertFailure . ("layoutOf: " <>)) pure (layoutOf Std430Layout td)+        map snd (offsets l) @?= [0, 64, 72, 76]+        l.size @?= Just 80+    , testCase "push.comp Output (vec4 data[]) is an open offset map with stride 16" $ do+        m <- loadBytes Fixtures.pushComp+        td <- maybe (assertFailure "no SSBO binding") pure (firstBinding m)+        g <- either (assertFailure . ("offsetMapOf: " <>)) pure (offsetMapOf Std430Layout td)+        g.size @?= Nothing+        fmap (.stride) g.tail @?= Just 16+    , testCase "ssbo-struct Particle[] tail unifies with a concrete Particle[2]" $ do+        m <- loadBytes Fixtures.ssboStructComp+        td <- maybe (assertFailure "no SSBO binding") pure (firstBinding m)+        open <- either (assertFailure . ("offsetMapOf: " <>)) pure (offsetMapOf Std430Layout td)+        -- Particle = vec3 @0, vec2 @16, float @24, uint @28 (stride 32).+        let+          particle =+            Struct+              ( fromFields+                  Std430Layout+                  (Just "Particle")+                  [ ("position", Vector STFloat 3)+                  , ("velocity", Vector STFloat 2)+                  , ("mass", Scalar STFloat)+                  , ("flags", Scalar STUInt)+                  ]+              )+          closed = normalize (fromFields Std430Layout Nothing [("items", ArrayOf (Sized 2) particle)])+        open `unifies` closed+    ]++-- Helpers. ----------------------------------------------------------------------++offsets :: Layout -> [(String, Int)]+offsets l = [(unpack m.name, m.offset) | m <- l.members]++unifies :: OffsetMap -> OffsetMap -> Assertion+unifies a b = case unify a b of+  Right _ -> pure ()+  Left e -> assertFailure (renderMismatch e)++pushBlock :: Module -> Maybe TypeDescription+pushBlock m = case V.toList m.push_constants of+  (pc : _) -> pc.type_description+  [] -> Nothing++firstBinding :: Module -> Maybe TypeDescription+firstBinding m = case V.toList m.descriptor_bindings of+  (b : _) -> b.type_description+  [] -> Nothing
+ test/Spec.hs view
@@ -0,0 +1,697 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Main (main) where++import Data.Bits ((.|.))+import Data.Either (isLeft)+import Data.Int (Int32, Int64)+import Data.List (sortOn)+import Data.Maybe (isJust)+import Data.Proxy (Proxy (..))+import Data.Vector qualified as V+import Data.Vector.Storable qualified as VS+import Data.Word (Word32, Word64)+import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Marshal.Utils (fillBytes)+import Foreign.Ptr (castPtr)+import Foreign.Storable (Storable (..))+import GHC.Generics (Generic)+import Geomancy qualified+import Geomancy.Mat4 (identity)+import Geomancy.UVec2 (uvec2)+import Geomancy.Vec2 (Vec2, vec2)+import Geomancy.Vec3 (vec3)+import Geomancy.Vec4 (Vec4, vec4)+import Graphics.Gl.Block (Block, Std140 (..), Std430 (..))+import Language.Haskell.TH (Type (AppT, ConT), mkName)+import Test.Tasty+import Test.Tasty.HUnit++import Vulkan.Core10 qualified as Vk++import Data.SpirV.Reflect.FFI (loadBytes)+import Vulkan.Utils.SpirV.Array qualified as Array+import Vulkan.Utils.SpirV.Buffer (allocArrayBuffer, newBuffer, readBuffer, readBufferElem, writeBufferElem)+import Vulkan.Utils.SpirV.Descriptors (descriptorSetLayoutInfos, mergedDescriptorSetLayoutInfos, mergedPushConstantRanges, pushConstantRanges)+import Vulkan.Utils.SpirV.DeviceAddress (DeviceAddress (..))+import Vulkan.Utils.SpirV.Layout (ArraySize (..), FieldType (..), fromFields, normalize)+import Vulkan.Utils.SpirV.Layout qualified+import Vulkan.Utils.SpirV.Signature (ArrayOf, Fits, Sig, knownLayoutInstance, layoutSig)+import Vulkan.Utils.SpirV.Specialization (specializationConstants, specializationMapEntries)+import Vulkan.Utils.SpirV.Stage (CompatibleResources, KnownLayoutSig (..), MatchInterface, linkStages, matchInterface, mergeLayout, reflectPipelineLayoutSigBytes, reflectStageSigBytes, stageInfoOf)+import Vulkan.Utils.SpirV.Stage qualified+import Vulkan.Utils.SpirV.Stage qualified as StageInfo (StageInfo (..))+import Vulkan.Utils.SpirV.TH (reflectShaderTypesBytes)+import Vulkan.Utils.SpirV.Types (LayoutMode (..), MemberShape (..), NumericType (..), ScalarType (..), geomancyTypeMap, linearTypeMap)+import Vulkan.Utils.SpirV.VertexInput (vertexInputAttributes, vertexInputBinding, vertexInputState)++import Fixtures qualified+import LayoutSpec qualified++-- Generate the @Params@ record from the quasiquoted compute fixture.+reflectShaderTypesBytes Fixtures.juliaComp++-- Generate the @Push@ push-constant record (std430) from its fixture.+reflectShaderTypesBytes Fixtures.pushComp++-- Generate the @Particle@ element record of an SSBO array of structs. The+-- wrapping @Particles@ runtime-array block is (correctly) not generated.+reflectShaderTypesBytes Fixtures.ssboStructComp++-- Generate @Material@ (shared across a std140 UBO field and a std430 SSBO array,+-- safe because all members are 16-byte aligned) and @Scene@, which has the+-- nested @Material@ as a field.+reflectShaderTypesBytes Fixtures.nestedComp++-- Generate @Kernel140@ / @Kernel430@: records with fixed-size @Array n a@ fields+-- under std140 (element stride 16) and std430 (tight) layouts.+reflectShaderTypesBytes Fixtures.arrayFieldComp++-- Generate @Grid430@ / @Grid140@: a 2D array field @float grid[3][4]@ maps to+-- @Array 3 (Array 4 Float)@.+reflectShaderTypesBytes Fixtures.array2dComp++-- Generate @Node@ (a self-referential @buffer_reference@ struct) and @Bvh@ (a+-- push-constant block holding a @Node@ device address). The pointer members map+-- to @DeviceAddress Node@; @Node@ is generated once despite the cycle.+reflectShaderTypesBytes Fixtures.bdaComp++-- Generate @Wide@: a std430 push-constant block with 64-bit integer members+-- (@uint64_t hi@ / @int64_t lo@), which must occupy 8-byte slots like a double.+reflectShaderTypesBytes Fixtures.wideComp++-- A std430 element whose array stride (32) exceeds its packed size (20): vec4 @0+-- + float @16 -> size 20, rounded up to its 16-byte alignment for the stride.+data Pad = Pad Vec4 Float+  deriving stock (Generic, Eq, Show)+  deriving anyclass (Block)+  deriving (Storable) via (Std430 Pad)++-- Three types that are layout-equivalent under std430 (same scalar offset map): mat4, vec4[4] and+-- float[16]. Their layout signatures are produced from the value-level normal+-- form (the oracle), so they promote to the SAME 'Sig' and 'Fits' accepts them.+data EquivMat4+data EquivVec4x4+data EquivFloat16++pure+  ( knownLayoutInstance+      ''EquivMat4+      (normalize (fromFields Std430Layout Nothing [("m", Matrix STFloat 4 4)]))+  )+pure+  ( knownLayoutInstance+      ''EquivVec4x4+      (normalize (fromFields Std430Layout Nothing [("a", ArrayOf (Sized 4) (Vector STFloat 4))]))+  )+pure+  ( knownLayoutInstance+      ''EquivFloat16+      (normalize (fromFields Std430Layout Nothing [("a", ArrayOf (Sized 16) (Scalar STFloat))]))+  )++-- Compile-time witnesses: each body only type-checks if the 'Fits' constraint+-- holds (a mismatch is a compile error). Returned as 'Bool' so a test can run.+mat4FitsVec4x4 :: (Fits (Sig EquivMat4) (Sig EquivVec4x4)) => Bool+mat4FitsVec4x4 = True++vec4x4FitsFloat16 :: (Fits (Sig EquivVec4x4) (Sig EquivFloat16)) => Bool+vec4x4FitsFloat16 = True++pushFitsItself :: (Fits (Sig Push) (Sig Push)) => Bool+pushFitsItself = True++-- Two records that are layout-equivalent under std430: two vec4s vs four vec2s both flatten to+-- eight floats at offsets 0,4,..,28 (size 32). Real 'Storable' records, so a+-- value written as one can be read back through the other.+data PairA = PairA Vec4 Vec4+  deriving stock (Generic, Eq, Show)+  deriving anyclass (Block)+  deriving (Storable) via (Std430 PairA)++data PairB = PairB Vec2 Vec2 Vec2 Vec2+  deriving stock (Generic, Eq, Show)+  deriving anyclass (Block)+  deriving (Storable) via (Std430 PairB)++pure+  ( knownLayoutInstance+      ''PairA+      (normalize (fromFields Std430Layout Nothing [("a", Vector STFloat 4), ("b", Vector STFloat 4)]))+  )+pure+  ( knownLayoutInstance+      ''PairB+      ( normalize+          ( fromFields+              Std430Layout+              Nothing+              [("a", Vector STFloat 2), ("b", Vector STFloat 2), ("c", Vector STFloat 2), ("d", Vector STFloat 2)]+          )+      )+  )++-- Stage signatures for a matched vertex+fragment pair (shared Scene UBO, vertex+-- push constant, fragment SSBO). Phase 1 exercises only the interface.+reflectStageSigBytes "MeshVert" Fixtures.meshVert+reflectStageSigBytes "MeshFrag" Fixtures.meshFrag++-- The merged pipeline-layout signature of the same pair, promoted to the type level.+reflectPipelineLayoutSigBytes "MeshLayout" [Fixtures.meshVert, Fixtures.meshFrag]++-- Compile-time witness: only type-checks if the vertex→fragment interface matches.+meshInterfaceOk :: (MatchInterface MeshVert MeshFrag) => Bool+meshInterfaceOk = True++-- Compile-time witness: only type-checks if the shared resources are compatible+-- (the Scene UBO is declared identically in both stages).+meshResourcesOk :: (CompatibleResources MeshVert MeshFrag) => Bool+meshResourcesOk = True++main :: IO ()+main =+  defaultMain $+    testGroup+      "vulkan-utils-spirv"+      [ testGroup+          "block record (std140)"+          [ testCase "alignment is std140 vec4 (16)" $+              alignment params @?= 16+          , testCase "fields land at the shader's std140 offsets" $ do+              -- shader.comp: center@0, resolution@8, escapeRadius@16, maxIterations@20+              let n = sizeOf params+              (resX, esc, maxIt) <- allocaBytes n $ \ptr -> do+                fillBytes ptr 0 n+                poke (castPtr ptr) params+                (,,)+                  <$> (peekByteOff ptr 8 :: IO Word32)+                  <*> (peekByteOff ptr 16 :: IO Float)+                  <*> (peekByteOff ptr 20 :: IO Int32)+              resX @?= 512+              esc @?= 2.0+              maxIt @?= 1000+          , testCase "round-trips through Storable" $ do+              let n = sizeOf params+              rt <- allocaBytes n $ \ptr -> do+                fillBytes ptr 0 n+                poke (castPtr ptr) params+                peek (castPtr ptr)+              rt @?= params+          ]+      , testGroup+          "field type spelling (TypeMap)"+          -- geomancyTypeMap is also exercised end-to-end by the record fixtures.+          -- linearTypeMap is a worked example of the parametric case with no Block+          -- instances to splice against yet, so these pure checks pin its spelling.+          [ testCase "geomancy: scalar in name, single qualifier" $ do+              geomancyTypeMap (NumericType STFloat (ShVector 3) []) @?= Just (ConT (mkName "Geomancy.Vec3"))+              geomancyTypeMap (NumericType STUInt (ShVector 2) []) @?= Just (ConT (mkName "Geomancy.UVec2"))+              geomancyTypeMap (NumericType STFloat (ShMatrix 4 4) []) @?= Just (ConT (mkName "Geomancy.Mat4"))+          , testCase "linear: parametric, scalar applied" $ do+              linearTypeMap (NumericType STFloat (ShVector 3) []) @?= Just (AppT (ConT (mkName "Linear.V3")) (ConT ''Float))+              linearTypeMap (NumericType STUInt (ShVector 2) []) @?= Just (AppT (ConT (mkName "Linear.V2")) (ConT ''Word32))+              linearTypeMap (NumericType STFloat (ShMatrix 4 4) []) @?= Just (AppT (ConT (mkName "Linear.M44")) (ConT ''Float))+          , testCase "both reject array members and address scalars" $ do+              geomancyTypeMap (NumericType STFloat (ShVector 3) [4]) @?= Nothing+              linearTypeMap (NumericType STAddress ShScalar []) @?= Nothing+          ]+      , testGroup+          "push-constant block (std430)"+          [ testCase "alignment is mat4 (16)" $+              alignment pushc @?= 16+          , testCase "fields land at the shader's std430 offsets" $ do+              -- push.comp: transform@0, offset@64, scale@72, count@76+              let n = sizeOf pushc+              (sc, cnt) <- allocaBytes n $ \ptr -> do+                fillBytes ptr 0 n+                poke (castPtr ptr) pushc+                (,)+                  <$> (peekByteOff ptr 72 :: IO Float)+                  <*> (peekByteOff ptr 76 :: IO Int32)+              sc @?= 2.5+              cnt @?= 7+          , testCase "size covers the last member (80)" $+              sizeOf pushc @?= 80+          , testCase "round-trips through Storable" $ do+              -- @Push@ has a @Mat4@ field (no @Eq@), so compare the comparable+              -- fields after a Storable round-trip rather than the whole record.+              let n = sizeOf pushc+              rt <- allocaBytes n $ \ptr -> do+                fillBytes ptr 0 n+                poke (castPtr ptr) pushc+                peek (castPtr ptr) :: IO Push+              (rt.offset, rt.scale, rt.count) @?= (pushc.offset, pushc.scale, pushc.count)+          ]+      , testCase "push-constant range from reflection" $ do+          m <- loadBytes Fixtures.pushComp+          case pushConstantRanges m of+            [r] -> do+              r.offset @?= 0+              r.size @?= 80+              r.stageFlags @?= Vk.SHADER_STAGE_COMPUTE_BIT+            other -> assertFailure ("expected one range, got " <> show (length other))+      , testGroup+          "64-bit integer scalars (std430)"+          [ testCase "uint64_t/int64_t members land at 8-byte-aligned offsets" $ do+              -- wide.comp: hi@0, lo@8, tag@16. A 64-bit int is an 8-byte slot, so+              -- tag sits at 16 — under the old 32-bit assumption it would be at 8.+              let n = sizeOf wide+              (hi, lo, tag) <- allocaBytes n $ \ptr -> do+                fillBytes ptr 0 n+                poke (castPtr ptr) wide+                (,,)+                  <$> (peekByteOff ptr 0 :: IO Word64)+                  <*> (peekByteOff ptr 8 :: IO Int64)+                  <*> (peekByteOff ptr 16 :: IO Word32)+              (hi, lo, tag) @?= (0xDEADBEEFCAFEF00D, -42, 7)+          , testCase "record rounds up to its 8-byte alignment (24)" $+              -- gl-block pads the record to a multiple of its base alignment (8);+              -- the SPIR-V block extent below is the unpadded 20.+              sizeOf wide @?= 24+          , testCase "push-constant range from reflection ends at 20" $ do+              -- 16 + 4: tag (a uint) ends at 20, so each int64 before it took 8+              -- bytes — a 4-byte misclassification would put the end at 12.+              m <- loadBytes Fixtures.wideComp+              case pushConstantRanges m of+                [r] -> (r.offset, r.size) @?= (0, 20)+                other -> assertFailure ("expected one range, got " <> show (length other))+          , testCase "Wide's std430 Sig has 8-byte int slots at 0/8, uint at 16" $+              layoutSig @Wide+                @?= normalize+                  ( fromFields+                      Std430Layout+                      Nothing+                      [ ("hi", Scalar STUInt64)+                      , ("lo", Scalar STInt64)+                      , ("tag", Scalar STUInt)+                      ]+                  )+          ]+      , testGroup+          "buffer_reference (BDA)"+          [ testCase "Node's std430 Sig has DeviceAddress slots at 32/40, size 64" $+              -- boundsMin@0, boundsMax@16, left@32, right@40, primCount@48; size 64.+              layoutSig @Node+                @?= normalize+                  ( fromFields+                      Std430Layout+                      Nothing+                      [ ("boundsMin", Vector STFloat 4)+                      , ("boundsMax", Vector STFloat 4)+                      , ("left", Scalar STAddress)+                      , ("right", Scalar STAddress)+                      , ("primCount", Scalar STUInt)+                      ]+                  )+          , testCase "DeviceAddress fields land at std430 byte offsets 32 and 40" $ do+              let n = Node (vec4 0 0 0 0) (vec4 0 0 0 0) (DeviceAddress 0xCAFE) (DeviceAddress 0xBEEF) 0+              (a32, a40) <- allocaBytes (sizeOf (Std430 n)) $ \p -> do+                poke (castPtr p) (Std430 n)+                (,) <$> (peekByteOff p 32 :: IO Word64) <*> (peekByteOff p 40 :: IO Word64)+              (a32, a40) @?= (0xCAFE, 0xBEEF)+          , testCase "push-constant block is a single 8-byte device address" $ do+              m <- loadBytes Fixtures.bdaComp+              case pushConstantRanges m of+                [r] -> (r.offset, r.size) @?= (0, 8)+                other -> assertFailure ("expected one range, got " <> show (length other))+          ]+      , testGroup+          "SSBO array-of-struct element (std430)"+          [ testCase "element record alignment is vec3 (16)" $+              alignment particle @?= 16+          , testCase "fields land at the shader's std430 offsets" $ do+              -- ssbo-struct.comp: position@0, velocity@16, mass@24, flags@28+              let n = sizeOf particle+              (vx, m, fl) <- allocaBytes n $ \ptr -> do+                fillBytes ptr 0 n+                poke (castPtr ptr) particle+                (,,)+                  <$> (peekByteOff ptr 16 :: IO Float)+                  <*> (peekByteOff ptr 24 :: IO Float)+                  <*> (peekByteOff ptr 28 :: IO Word32)+              vx @?= 3.0+              m @?= 1.5+              fl @?= 7+          , testCase "element size is std430-padded (32)" $+              sizeOf particle @?= 32+          ]+      , testGroup+          "nested struct as a field (shared across layouts)"+          [ testCase "nested element record offsets (Material)" $ do+              let n = sizeOf mat+              (al, em) <- allocaBytes n $ \ptr -> do+                fillBytes ptr 0 n+                poke (castPtr ptr) mat+                (,) <$> (peekByteOff ptr 0 :: IO Float) <*> (peekByteOff ptr 16 :: IO Float)+              alignment mat @?= 16+              sizeOf mat @?= 32+              al @?= 1.0+              em @?= 2.0+          , testCase "parent embeds the nested struct at its std140 offsets" $ do+              -- nested.comp: sun@0 (albedo@0, emission@16), tint@32+              let n = sizeOf scene+              (al, em, ti) <- allocaBytes n $ \ptr -> do+                fillBytes ptr 0 n+                poke (castPtr ptr) scene+                (,,)+                  <$> (peekByteOff ptr 0 :: IO Float)+                  <*> (peekByteOff ptr 16 :: IO Float)+                  <*> (peekByteOff ptr 32 :: IO Float)+              alignment scene @?= 16+              sizeOf scene @?= 48+              al @?= 1.0+              em @?= 2.0+              ti @?= 3.0+          ]+      , testGroup+          "fixed-size array fields (Array n a)"+          [ testCase "std140 rounds element stride up to 16" $ do+              -- Kernel140: taps[4] vec4 @0 (stride 16), weights[4] float @64 (stride 16)+              let n = sizeOf k140+              (t0, t1, w0, w1, w3) <- allocaBytes n $ \ptr -> do+                fillBytes ptr 0 n+                poke (castPtr ptr) k140+                (,,,,)+                  <$> (peekByteOff ptr 0 :: IO Float)+                  <*> (peekByteOff ptr 16 :: IO Float)+                  <*> (peekByteOff ptr 64 :: IO Float)+                  <*> (peekByteOff ptr 80 :: IO Float) -- std140 stride 16+                  <*> (peekByteOff ptr 112 :: IO Float)+              alignment k140 @?= 16+              sizeOf k140 @?= 128+              (t0, t1) @?= (1, 2)+              (w0, w1, w3) @?= (10, 20, 40)+          , testCase "std430 packs the float array tightly (stride 4)" $ do+              -- Kernel430: taps[4] vec4 @0, weights[4] float @64 (stride 4)+              let n = sizeOf k430+              (w0, w1, w3) <- allocaBytes n $ \ptr -> do+                fillBytes ptr 0 n+                poke (castPtr ptr) k430+                (,,)+                  <$> (peekByteOff ptr 64 :: IO Float)+                  <*> (peekByteOff ptr 68 :: IO Float) -- std430 stride 4+                  <*> (peekByteOff ptr 76 :: IO Float)+              sizeOf k430 @?= 80+              (w0, w1, w3) @?= (10, 20, 40)+          ]+      , testGroup+          "multi-dimensional array field (Array h (Array w a))"+          [ testCase "std430 nested strides (inner 4, outer 16)" $ do+              -- Grid430: head@0, grid[3][4] @16; grid[i][j] @ 16 + i*16 + j*4+              let n = sizeOf g430+              (h, g00, g01, g10, g23) <- allocaBytes n $ \ptr -> do+                fillBytes ptr 0 n+                poke (castPtr ptr) g430+                (,,,,)+                  <$> (peekByteOff ptr 0 :: IO Float)+                  <*> (peekByteOff ptr 16 :: IO Float)+                  <*> (peekByteOff ptr 20 :: IO Float)+                  <*> (peekByteOff ptr 32 :: IO Float)+                  <*> (peekByteOff ptr 60 :: IO Float)+              sizeOf g430 @?= 64+              h @?= 9+              (g00, g01, g10, g23) @?= (1, 2, 5, 12)+          , testCase "std140 nested strides (inner 16, outer 64)" $ do+              -- Grid140: head@0, grid[3][4] @16; grid[i][j] @ 16 + i*64 + j*16+              let n = sizeOf g140+              (g00, g01, g10) <- allocaBytes n $ \ptr -> do+                fillBytes ptr 0 n+                poke (castPtr ptr) g140+                (,,)+                  <$> (peekByteOff ptr 16 :: IO Float)+                  <*> (peekByteOff ptr 32 :: IO Float) -- inner stride 16+                  <*> (peekByteOff ptr 80 :: IO Float) -- outer stride 64+              sizeOf g140 @?= 208+              (g00, g01, g10) @?= (1, 2, 5)+          ]+      , testGroup+          "runtime-sized array (Storable.Vector at the std430 stride)"+          [ testCase "elements placed at the array stride (32 > element size 20)" $ do+              let+                pads = VS.fromList [Pad (vec4 1 0 0 0) 2, Pad (vec4 9 0 0 0) 8]+                stride = Array.std430Stride (Proxy :: Proxy Pad)+                n = 2 * stride+              (a0, b0, a1, b1) <- allocaBytes n $ \ptr -> do+                fillBytes ptr 0 n+                Array.pokeStd430 ptr pads+                (,,,)+                  <$> (peekByteOff ptr 0 :: IO Float)+                  <*> (peekByteOff ptr 16 :: IO Float)+                  <*> (peekByteOff ptr 32 :: IO Float) -- second element at stride 32+                  <*> (peekByteOff ptr 48 :: IO Float)+              stride @?= 32+              (a0, b0, a1, b1) @?= (1, 2, 9, 8)+          , testCase "round-trips through pokeStd430/peekStd430" $ do+              let+                pads = VS.fromList [Pad (vec4 1 2 3 4) 5, Pad (vec4 6 7 8 9) 10]+                stride = Array.std430Stride (Proxy :: Proxy Pad)+              rt <- allocaBytes (2 * stride) $ \ptr -> do+                fillBytes ptr 0 (2 * stride)+                Array.pokeStd430 ptr pads+                Array.peekStd430 2 ptr+              VS.toList rt @?= VS.toList pads+          ]+      , testGroup+          "specialization constants from reflection"+          [ testCase "reflects ids and names (ascending, non-contiguous)" $ do+              m <- loadBytes Fixtures.specComp+              specializationConstants m+                @?= [(0, Just "count"), (3, Just "scale")]+          , testCase "map entries keep real ids but pack tightly" $ do+              m <- loadBytes Fixtures.specComp+              let es = toL (specializationMapEntries m)+              map (\e -> (e.constantID, e.offset, e.size)) es+                @?= [(0, 0, 4), (3, 4, 4)]+          ]+      , testCase "descriptor set layout from reflection" $ do+          m <- loadBytes Fixtures.juliaComp+          case descriptorSetLayoutInfos m of+            [(setNo, info)] -> do+              setNo @?= 0+              let bs = toL info.bindings+              map (.binding) bs @?= [0, 1]+              map (.descriptorType) bs+                @?= [Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER, Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER]+              all ((== Vk.SHADER_STAGE_COMPUTE_BIT) . (.stageFlags)) bs @? "all compute stage"+            other -> assertFailure ("expected one set, got " <> show (length other))+      , testGroup+          "vertex input from reflection"+          [ testCase "attributes: format + tightly-packed offset" $ do+              m <- loadBytes Fixtures.triVert+              let attrs = vertexInputAttributes m+              map (\a -> (a.location, a.format, a.offset)) attrs+                @?= [ (0, Vk.FORMAT_R32G32B32_SFLOAT, 0)+                    , (1, Vk.FORMAT_R32G32_SFLOAT, 12)+                    , (2, Vk.FORMAT_R32G32B32A32_SFLOAT, 20)+                    ]+          , testCase "binding stride is packed size" $ do+              m <- loadBytes Fixtures.triVert+              (vertexInputBinding m).stride @?= 36+          , testCase "vertexInputState packs the reflected binding + attributes" $ do+              m <- loadBytes Fixtures.triVert+              let vis = vertexInputState m+              map (.stride) (toL vis.vertexBindingDescriptions) @?= [36]+              map (.offset) (toL vis.vertexAttributeDescriptions) @?= [0, 12, 20]+          , testCase "vertexInputState is empty when a module declares no vertex inputs" $ do+              m <- loadBytes Fixtures.juliaComp+              let vis = vertexInputState m+              null (toL vis.vertexBindingDescriptions) @? "no bindings"+              null (toL vis.vertexAttributeDescriptions) @? "no attributes"+          ]+      , testGroup+          "type-level signatures"+          [ testCase "a record's Sig reflects back to its value-level offset map (the oracle)" $+              -- Push: mat4 @0, vec2 @64, float @72, int @76, size 80.+              layoutSig @Push+                @?= normalize+                  ( fromFields+                      Std430Layout+                      Nothing+                      [ ("transform", Matrix STFloat 4 4)+                      , ("offset", Vector STFloat 2)+                      , ("scale", Scalar STFloat)+                      , ("count", Scalar STInt)+                      ]+                  )+          , testCase "layout-equivalent layouts promote to the SAME Sig (mat4 == vec4[4] == float[16])" $ do+              layoutSig @EquivMat4 @?= layoutSig @EquivVec4x4+              layoutSig @EquivVec4x4 @?= layoutSig @EquivFloat16+          , testCase "Fits accepts layout-equivalent layouts at the type level" $ do+              -- These only type-check because the 'Fits' constraints are satisfied.+              mat4FitsVec4x4 @?= True+              vec4x4FitsFloat16 @?= True+              pushFitsItself @?= True+          ]+      , testGroup+          "buffer (structural views)"+          [ testCase "Storable size matches the layout signature size" $+              (layoutSig @PairA).size @?= Just (sizeOf (undefined :: PairA))+          , testCase "round-trips the same record" $ do+              let a = PairA (vec4 9 8 7 6) (vec4 5 4 3 2)+              buf <- newBuffer a+              a' <- readBuffer buf+              a' @?= a+          , testCase "write one layout, read a layout-compatible one back (typed view)" $ do+              buf <- newBuffer (PairA (vec4 1 2 3 4) (vec4 5 6 7 8))+              -- Fits (Sig PairB) (Sig PairA) holds because the layouts are equivalent.+              PairB x y z w <- readBuffer buf+              (x, y, z, w) @?= (vec2 1 2, vec2 3 4, vec2 5 6, vec2 7 8)+          ]+      , testGroup+          "buffer (runtime-array element access)"+          [ testCase "writes and reads back array elements by index" $ do+              -- ArrayOf (Sig PairA): a runtime PairA[] (stride 32, base 0).+              buf <- allocArrayBuffer @(ArrayOf (Sig PairA)) 2+              let+                p0 = PairA (vec4 1 2 3 4) (vec4 5 6 7 8)+                p1 = PairA (vec4 9 10 11 12) (vec4 13 14 15 16)+              writeBufferElem buf 0 p0+              writeBufferElem buf 1 p1+              e0 <- readBufferElem buf 0+              e1 <- readBufferElem buf 1+              (e0, e1) @?= (p0, p1)+          , testCase "reads an element back through a layout-compatible record (typed view)" $ do+              buf <- allocArrayBuffer @(ArrayOf (Sig PairA)) 2+              writeBufferElem buf 0 (PairA (vec4 1 2 3 4) (vec4 5 6 7 8))+              writeBufferElem buf 1 (PairA (vec4 10 20 30 40) (vec4 50 60 70 80))+              -- FitsTail (Sig PairB) (ArrayOf (Sig PairA)) holds: the element layout is equivalent.+              PairB x y z w <- readBufferElem buf 1+              (x, y, z, w) @?= (vec2 10 20, vec2 30 40, vec2 50 60, vec2 70 80)+          ]+      , testGroup+          "stage interface matching"+          [ testCase "vertex outputs reflect at locations 0 (vec3) and 1 (vec2)" $ do+              vm <- loadBytes Fixtures.meshVert+              let outs = (stageInfoOf vm).outputs+              map fst outs @?= [0, 1]+              map (length . (.slots) . snd) outs @?= [3, 2]+          , testCase "vertex outputs match fragment inputs (value oracle)" $ do+              vm <- loadBytes Fixtures.meshVert+              fm <- loadBytes Fixtures.meshFrag+              matchInterface (stageInfoOf vm) (stageInfoOf fm) @?= Right ()+          , testCase "a mismatched interface is rejected (value oracle)" $ do+              vm <- loadBytes Fixtures.meshVert+              fm <- loadBytes Fixtures.meshFrag+              -- frag outputs (vec4 @loc0) cannot satisfy the vertex's own inputs.+              assertBool "should not match" (isLeft (matchInterface (stageInfoOf fm) (stageInfoOf vm)))+          , testCase "MatchInterface holds at the type level" $+              meshInterfaceOk @?= True+          ]+      , testGroup+          "stage resource linking (shared UBO)"+          [ testCase "the Scene UBO reflects identically from both stages" $ do+              vm <- loadBytes Fixtures.meshVert+              fm <- loadBytes Fixtures.meshFrag+              lookup (0, 0) (stageInfoOf vm).resources+                @?= lookup (0, 0) (stageInfoOf fm).resources+          , testCase "linking unions resources, push and the external interface" $ do+              vm <- loadBytes Fixtures.meshVert+              fm <- loadBytes Fixtures.meshFrag+              case linkStages (stageInfoOf vm) (stageInfoOf fm) of+                Left e -> assertFailure e+                Right linked -> do+                  map fst linked.resources @?= [(0, 0), (0, 1)] -- Scene (shared) + Materials+                  isJust linked.push @?= True -- vertex Model push constant+                  map fst linked.inputs @?= [0, 1, 2] -- vertex attributes+                  map fst linked.outputs @?= [0] -- fragment colour output+          , testCase "a conflicting shared binding is rejected" $ do+              vm <- loadBytes Fixtures.meshVert+              fm <- loadBytes Fixtures.meshFrag+              let bad =+                    (stageInfoOf fm)+                      { StageInfo.resources = [((0, 0), normalize (fromFields Std140Layout Nothing [("x", Vector STFloat 2)]))]+                      }+              assertBool "should conflict" (isLeft (linkStages (stageInfoOf vm) bad))+          , testCase "CompatibleResources holds at the type level" $+              meshResourcesOk @?= True+          , testCase "the merged layout signature round-trips to the value-level merge" $ do+              vm <- loadBytes Fixtures.meshVert+              fm <- loadBytes Fixtures.meshFrag+              let info = layoutSigVal (Proxy @MeshLayout) -- reflected from the promoted type+              mergeLayout [vm, fm] @?= Right info -- equals the value-level merge+              map fst info.resources @?= [(0, 0), (0, 1)] -- Scene (shared) + Materials+              isJust info.push @?= True -- vertex Model push constant+          ]+      , testGroup+          "pipeline layout (depth-only vs depth+color from one vertex shader)"+          [ testCase "depth-only: the vertex stage alone" $ do+              vm <- loadBytes Fixtures.meshVert+              -- Only the vertex-visible resources: Scene UBO at (0,0), vertex stage.+              stageBindings [vm]+                @?= [(0, Vk.SHADER_STAGE_VERTEX_BIT)]+              fmap length (mergedPushConstantRanges [vm]) @?= Right 1 -- the Model push constant+          , testCase "depth+color: vertex+fragment, Scene gains the fragment stage" $ do+              vm <- loadBytes Fixtures.meshVert+              fm <- loadBytes Fixtures.meshFrag+              stageBindings [vm, fm]+                @?= [ (0, Vk.SHADER_STAGE_VERTEX_BIT .|. Vk.SHADER_STAGE_FRAGMENT_BIT) -- Scene, shared+                    , (1, Vk.SHADER_STAGE_FRAGMENT_BIT) -- Materials, frag-only+                    ]+          ]+      , LayoutSpec.tests+      ]+  where+    -- (binding, stageFlags) across all sets, for the merged pipeline layout.+    stageBindings modules =+      sortOn+        fst+        [ (b.binding, b.stageFlags)+        | (_set, info) <- either error id (mergedDescriptorSetLayoutInfos modules)+        , b <- V.toList info.bindings+        ]+    params =+      Params+        { center = vec2 (-0.8) 0.156+        , resolution = uvec2 512 512+        , escapeRadius = 2.0+        , maxIterations = 1000+        }+    pushc =+      Push+        { transform = identity+        , offset = vec2 1 2+        , scale = 2.5+        , count = 7+        }+    wide =+      Wide+        { hi = 0xDEADBEEFCAFEF00D+        , lo = -42+        , tag = 7+        }+    particle =+      Particle+        { position = vec3 (-1) 0 0+        , velocity = vec2 3 4+        , mass = 1.5+        , flags = 7+        }+    mat =+      Material+        { albedo = vec4 1 0 0 0+        , emission = vec4 2 0 0 0+        }+    scene =+      Scene+        { sun = mat+        , tint = vec4 3 0 0 0+        }+    taps = Array.unsafeFromList [vec4 1 0 0 0, vec4 2 0 0 0, vec4 3 0 0 0, vec4 4 0 0 0] :: Array.Array 4 Vec4+    weights = Array.unsafeFromList [10, 20, 30, 40] :: Array.Array 4 Float+    k140 = Kernel140{taps = taps, weights = weights}+    k430 = Kernel430{taps = taps, weights = weights}+    grid =+      Array.unsafeFromList (map Array.unsafeFromList [[1, 2, 3, 4], [5, 6, 7, 8], [9, 10, 11, 12]])+        :: Array.Array 3 (Array.Array 4 Float)+    g430 = Grid430{head = vec4 9 0 0 0, grid = grid}+    g140 = Grid140{head = vec4 9 0 0 0, grid = grid}+    toL = foldr (:) []
+ vulkan-utils-spirv.cabal view
@@ -0,0 +1,143 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.39.6.+--+-- see: https://github.com/sol/hpack++name:           vulkan-utils-spirv+version:        0.1.0.0+synopsis:       Generate Haskell types and Vulkan descriptor/pipeline layouts from SPIR-V reflection+category:       Graphics+homepage:       https://github.com/haskell-game/vulkan#readme+bug-reports:    https://github.com/haskell-game/vulkan/issues+maintainer:     IC Rainbow <aenor.realm@gmail.com>+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    package.yaml++source-repository head+  type: git+  location: https://github.com/haskell-game/vulkan++library+  exposed-modules:+      Vulkan.Utils.SpirV.Array+      Vulkan.Utils.SpirV.Block+      Vulkan.Utils.SpirV.Buffer+      Vulkan.Utils.SpirV.Descriptors+      Vulkan.Utils.SpirV.DeviceAddress+      Vulkan.Utils.SpirV.Layout+      Vulkan.Utils.SpirV.Pipeline+      Vulkan.Utils.SpirV.Reflect+      Vulkan.Utils.SpirV.Reflect.OffsetMaps+      Vulkan.Utils.SpirV.Signature+      Vulkan.Utils.SpirV.Specialization+      Vulkan.Utils.SpirV.Stage+      Vulkan.Utils.SpirV.TH+      Vulkan.Utils.SpirV.Types+      Vulkan.Utils.SpirV.VertexInput+  other-modules:+      Paths_vulkan_utils_spirv+  autogen-modules:+      Paths_vulkan_utils_spirv+  hs-source-dirs:+      src+  default-extensions:+      BlockArguments+      DataKinds+      DeriveAnyClass+      DeriveGeneric+      DerivingStrategies+      DerivingVia+      DuplicateRecordFields+      FlexibleContexts+      FlexibleInstances+      ImportQualifiedPost+      LambdaCase+      NamedFieldPuns+      OverloadedRecordDot+      OverloadedStrings+      PatternSynonyms+      RecordWildCards+      ScopedTypeVariables+      StrictData+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeOperators+      ViewPatterns+  ghc-options: -Wall+  build-depends:+      base >=4.16 && <5+    , bytestring+    , containers+    , gl-block+    , ptrdiff+    , resourcet+    , spirv-enum+    , spirv-reflect-ffi+    , spirv-reflect-types+    , template-haskell+    , text+    , unliftio-core+    , vector+    , vulkan ==3.27.*+    , vulkan-utils+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Fixtures+      LayoutSpec+      Paths_vulkan_utils_spirv+  autogen-modules:+      Paths_vulkan_utils_spirv+  hs-source-dirs:+      test+  default-extensions:+      BlockArguments+      DataKinds+      DeriveAnyClass+      DeriveGeneric+      DerivingStrategies+      DerivingVia+      DuplicateRecordFields+      FlexibleContexts+      FlexibleInstances+      ImportQualifiedPost+      LambdaCase+      NamedFieldPuns+      OverloadedRecordDot+      OverloadedStrings+      PatternSynonyms+      RecordWildCards+      ScopedTypeVariables+      StrictData+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeOperators+      ViewPatterns+  ghc-options: -Wall+  build-depends:+      base <5+    , bytestring+    , containers+    , geomancy+    , gl-block+    , spirv-reflect-ffi+    , spirv-reflect-types+    , tasty+    , tasty-hunit+    , template-haskell+    , text+    , vector+    , vulkan+    , vulkan-utils+    , vulkan-utils-spirv+  default-language: Haskell2010