packages feed

fir (empty) → 0.1.0.0

raw patch · 282 files changed

+43003/−0 lines, 282 filesdep +Cabaldep +atomic-file-opsdep +base

Dependencies added: Cabal, atomic-file-ops, base, binary, bytestring, containers, directory, distributive, filepath, finite-typelits, fir, generic-monoid, generics-sop, ghc-typelits-knownnat, ghc-typelits-natnormalise, half, lens, mtl, process, sop-core, split, template-haskell, text, text-short, transformers, tree-view, typelits-witnesses, variant, vector, vector-sized

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# `fir` – Changelog ++## 0.1.0.0 – 2026-11-06++First Hackage release, with the historical EDSL as it was circa 2022.
+ fir.cabal view
@@ -0,0 +1,481 @@+cabal-version:  3.0+name:           fir+version:        0.1.0.0+synopsis:       An EDSL that compiles to SPIR-V for graphics programming on the GPU in Haskell.+category:       Graphics+author:         Sam Derbyshire+maintainer:     sam.derbyshire@gmail.com+license:        BSD-3-Clause+homepage:       https://gitlab.com/sheaf/fir+bug-reports:    https://gitlab.com/sheaf/fir/-/issues+build-type:     Simple+tested-with:    GHC == 9.14.1+extra-doc-files:+    CHANGELOG.md+    img/FIR_logo.svg+extra-source-files:+    test/Tests/**/*.hs+    test/Tests/**/*.golden+description:++  <<img/FIR_logo.svg>>++  [__FIR__](https://gitlab.com/sheaf/fir) is an EDSL+  for writing GPU shader code in Haskell, compiled to __@SPIR-V@__.+  Requires GHC >= 8.10.++  With this library, shader programs can be written using @do@ notation.+  Such programs are then transformed into abstract syntax trees (ASTs),+  before being compiled to @SPIR-V@ assembly.++  In effect, this replaces @GLSL@ as a shader language.+  This means the Haskell type-system and type-checker are put to use+  in verifying programs at compile-time.+  Functional idioms, such as functor and applicative operations, are also supported.++  See the [fir-examples](https://gitlab.com/sheaf/fir/tree/0.1/fir-examples)+  project subdirectory for fleshed out examples,+  including using the @vulkan@ package for rendering.++  The exposed modules are:++  ["FIR"]+      Re-exports the main functionality of the library: writing and compiling programs.+++  ["FIR.Syntax.Labels"]+      Optional imperative-like syntax using /OverloadedLabels/.+++  ["Math.Linear"]+      Vectors, matrices, and operations on them, as used by this library.+++  ["Math.Quaternion"]+      Quaternions and their action by conjugation in 3 dimensions, useful for 3D cameras.++++  Important types used by this library:++  [@Code a@]++      Code for a pure value of type @a@, represented internally as an abstract syntax tree.+      See "FIR.AST".++      Overloaded functions are provided that automatically create and combine terms of this type.+      For instance, @3 + 5 :: Code Float@ gets desugared to @PrimOp FAdd ( Lit 3.0 ) ( Lit 5.0 )@.++  [@Program i j a@]++      A monadic expression, starting in state @i@ and ending in state @j@.+      This state is used to keep track of information at the type level,+      allowing for type errors to be thrown on invalid operations+      (e.g. writing to a read-only variable, image sampling outside a fragment shader, etc).++      A value of type @Program i j (Code a)@ can be thought of as stateful GPU code+      producing a value of type @a@.++      Internally represented using the codensity transformation of McBride-style indexed monads, see "Control.Monad.Indexed".++  [@Module defs@]++      Code for a program that can be compiled to a @SPIR-V@ module.++      @defs@ is a type-level list of shader inputs/ouputs (uniforms, varyings, etc),+      top-level functions, and entry points.++      See "FIR.Module" for the definition, and the [example shaders](https://gitlab.com/sheaf/fir/tree/0.1/fir-examples/readme.md#overview)+      for common usage patterns.+++  Values of all three of these types can be displayed graphically as trees using @showAST@/@drawAST@,+  which can be useful for debugging.++  See the [project readme](https://gitlab.com/sheaf/fir/tree/0.1/readme.md) for further information,+  as well as the ["getting started" guide](https://gitlab.com/sheaf/fir/tree/0.1/getting_started.md),+  which includes instructions concerning installation and usage of the library, and of useful tools+  such as the @SPIR-V@ tools provided by the [Vulkan SDK](https://www.lunarg.com/vulkan-sdk/).++source-repository head+  type:     git+  location: https://gitlab.com/sheaf/fir.git+  branch:   0.1++flag internals++  manual: True+  default: False+  description: This flag exposes all internal modules that by default are+               inaccessible. It's mostly only useful for library developers to+               use the internals of FIR rather than end users writing shader+               programs.++flag sop++  manual: True+  default: False+  description: This flag exposes a module with Syntactic instances for generics-sop.+++common common++  build-depends:+        base+          >= 4.14     && < 4.23+      , bytestring+          >= 0.10.9.0 && < 0.13+      , directory+          ^>= 1.3.3.0++common test++  build-depends:+        filepath+           >= 1.4.2.1 && < 1.6+      , process+          ^>= 1.6.3.0+      , text+           >= 1.2.3.1 && < 2.2++library++    import:+        common++    hs-source-dirs:+        src++    exposed-modules:+        FIR+      , FIR.Syntax.DebugPrintf+      , FIR.Syntax.Labels+      , Math.Linear+      , Math.Quaternion++    if flag(sop)+        exposed-modules:+            , FIR.Generics++    if flag(internals)+        exposed-modules:+          , CodeGen.Application+          , CodeGen.Applicative+          , CodeGen.Array+          , CodeGen.Atomics+          , CodeGen.Binary+          , CodeGen.CFG+          , CodeGen.CodeGen+          , CodeGen.Composite+          , CodeGen.Debug+          , CodeGen.Functions+          , CodeGen.IDs+          , CodeGen.Images+          , CodeGen.Instruction+          , CodeGen.Monad+          , CodeGen.Optics+          , CodeGen.Phi+          , CodeGen.Pointers+          , CodeGen.PrimOps+          , CodeGen.RayTracing+          , CodeGen.State+          , Control.Arrow.Strength+          , Control.Monad.Indexed+          , Control.Type.Optic+          , Data.Binary.Class.Put+          , Data.Constraint.All+          , Data.Containers.Traversals+          , Data.Finite.With+          , Data.Function.Variadic+          , Data.Product+          , Data.Type.Error+          , Data.Type.Known+          , Data.Type.LazyEquality+          , Data.Type.List+          , Data.Type.Map+          , Data.Type.Maybe+          , Data.Type.Nat+          , Data.Type.POrd+          , Data.Type.Snoc+          , Data.Type.String+          , Deriving.Base+          , FIR.AST+          , FIR.AST.ControlFlow+          , FIR.AST.Display+          , FIR.AST.Images+          , FIR.AST.Type+          , FIR.AST.Effs+          , FIR.AST.Exts+          , FIR.AST.Optics+          , FIR.AST.Prim+          , FIR.Binding+          , FIR.Builtin+          , FIR.Definition+          , FIR.Layout+          , FIR.Module+          , FIR.Pipeline+          , FIR.Prelude+          , FIR.Prim.Array+          , FIR.Prim.Image+          , FIR.Prim.RayTracing+          , FIR.Prim.Atomic+          , FIR.Prim.Struct+          , FIR.Prim.Types+          , FIR.Prim.Op+          , FIR.ProgramState+          , FIR.Syntax.AST+          , FIR.Syntax.Complex+          , FIR.Syntax.IfThenElse+          , FIR.Syntax.Images+          , FIR.Syntax.Optics+          , FIR.Syntax.Option+          , FIR.Syntax.Program+          , FIR.Syntax.RayTracing+          , FIR.Syntax.Swizzle+          , FIR.Syntax.Synonyms+          , FIR.Validation.Ambiguity+          , FIR.Validation.Arrayness+          , FIR.Validation.Bindings+          , FIR.Validation.Bounds+          , FIR.Validation.CFG+          , FIR.Validation.Definitions+          , FIR.Validation.ExecutionModes+          , FIR.Validation.Formats+          , FIR.Validation.Images+          , FIR.Validation.Interface+          , FIR.Validation.Layout+          , FIR.Validation.Pipeline+          , FIR.Validation.RayTracing+          , FIR.Temp+          , Instances.TH.Lift+          , Math.Algebra.Class+          , Math.Algebra.GradedSemigroup+          , Math.Logic.Bits+          , Math.Logic.Class+          , SPIRV.Builtin+          , SPIRV.Capability+          , SPIRV.Control+          , SPIRV.Decoration+          , SPIRV.ExecutionMode+          , SPIRV.Extension+          , SPIRV.Groups+          , SPIRV.Image+          , SPIRV.Layout+          , SPIRV.Operation+          , SPIRV.PrimOp+          , SPIRV.PrimTy+          , SPIRV.Requirements+          , SPIRV.ScalarTy+          , SPIRV.Stage+          , SPIRV.Storage+          , SPIRV.Synchronisation+          , SPIRV.Version+    else+        other-modules:+            CodeGen.Application+          , CodeGen.Applicative+          , CodeGen.Array+          , CodeGen.Atomics+          , CodeGen.Binary+          , CodeGen.CFG+          , CodeGen.CodeGen+          , CodeGen.Composite+          , CodeGen.Debug+          , CodeGen.Functions+          , CodeGen.IDs+          , CodeGen.Images+          , CodeGen.Instruction+          , CodeGen.Monad+          , CodeGen.Optics+          , CodeGen.Phi+          , CodeGen.Pointers+          , CodeGen.PrimOps+          , CodeGen.RayTracing+          , CodeGen.State+          , Control.Arrow.Strength+          , Control.Monad.Indexed+          , Control.Type.Optic+          , Data.Binary.Class.Put+          , Data.Constraint.All+          , Data.Containers.Traversals+          , Data.Finite.With+          , Data.Function.Variadic+          , Data.Product+          , Data.Type.Error+          , Data.Type.Known+          , Data.Type.LazyEquality+          , Data.Type.List+          , Data.Type.Map+          , Data.Type.Maybe+          , Data.Type.Nat+          , Data.Type.POrd+          , Data.Type.Snoc+          , Data.Type.String+          , Deriving.Base+          , FIR.AST+          , FIR.AST.ControlFlow+          , FIR.AST.Display+          , FIR.AST.Images+          , FIR.AST.Type+          , FIR.AST.Effs+          , FIR.AST.Exts+          , FIR.AST.Optics+          , FIR.AST.Prim+          , FIR.Binding+          , FIR.Builtin+          , FIR.Definition+          , FIR.Layout+          , FIR.Module+          , FIR.Pipeline+          , FIR.Prelude+          , FIR.Prim.Array+          , FIR.Prim.Image+          , FIR.Prim.RayTracing+          , FIR.Prim.Atomic+          , FIR.Prim.Struct+          , FIR.Prim.Types+          , FIR.Prim.Op+          , FIR.ProgramState+          , FIR.Syntax.AST+          , FIR.Syntax.Complex+          , FIR.Syntax.IfThenElse+          , FIR.Syntax.Images+          , FIR.Syntax.Optics+          , FIR.Syntax.Option+          , FIR.Syntax.Program+          , FIR.Syntax.RayTracing+          , FIR.Syntax.Swizzle+          , FIR.Syntax.Synonyms+          , FIR.Validation.Ambiguity+          , FIR.Validation.Arrayness+          , FIR.Validation.Bindings+          , FIR.Validation.Bounds+          , FIR.Validation.CFG+          , FIR.Validation.Definitions+          , FIR.Validation.ExecutionModes+          , FIR.Validation.Formats+          , FIR.Validation.Images+          , FIR.Validation.Interface+          , FIR.Validation.Layout+          , FIR.Validation.Pipeline+          , FIR.Validation.RayTracing+          , FIR.Temp+          , Instances.TH.Lift+          , Math.Algebra.Class+          , Math.Algebra.GradedSemigroup+          , Math.Logic.Bits+          , Math.Logic.Class+          , SPIRV.Builtin+          , SPIRV.Capability+          , SPIRV.Control+          , SPIRV.Decoration+          , SPIRV.ExecutionMode+          , SPIRV.Extension+          , SPIRV.Groups+          , SPIRV.Image+          , SPIRV.Layout+          , SPIRV.Operation+          , SPIRV.PrimOp+          , SPIRV.PrimTy+          , SPIRV.Requirements+          , SPIRV.ScalarTy+          , SPIRV.Stage+          , SPIRV.Storage+          , SPIRV.Synchronisation+          , SPIRV.Version+++    build-depends:+        atomic-file-ops+          ^>= 0.3.0.0+      , binary+          >= 0.8.7.0  && < 0.11+      , containers+          >= 0.6.2.1  && < 0.9+      , distributive+          ^>= 0.6+      , finite-typelits+          >= 0.1.4.2  && < 0.3+      , generic-monoid+          ^>= 0.1.0.0+      , ghc-typelits-knownnat+          ^>= 0.8.2+      , ghc-typelits-natnormalise+          ^>= 0.9.0+      , half+          ^>= 0.3+      , lens+          >= 4.18     && < 5.4+      , mtl+          >= 2.2.2    && < 2.4+      , split+          >= 0.2.3.3  && < 0.3+      , template-haskell+          >= 2.15     && < 2.25+      , text-short+          >= 0.1.4    && < 0.2+      , transformers+          >= 0.5.6.2  && < 0.7+      , tree-view+          ^>= 0.5+      , typelits-witnesses+          >= 0.2.3    && < 0.5+      , variant+          ^>= 1.0.1+      , vector+          >= 0.12.0.3 && < 0.14+      , vector-sized+          >= 1.4.0.0  && < 1.7++    if flag(sop)+        build-depends:+          , generics-sop+              >= 0.4 && < 0.5.2+          , sop-core+              >= 0.4 && < 0.5.1++    default-language:+        Haskell2010++    default-extensions:+        NoStarIsType++    ghc-options:+        -Wall+        -Wcompat+        -fno-warn-orphans+        -fno-warn-unticked-promoted-constructors+        -fno-warn-unused-do-bind+        -fwarn-missing-local-signatures+        -fwarn-incomplete-uni-patterns+        -fwarn-missing-deriving-strategies++    if impl(ghc >= 9.14)+      ghc-options:+        -Wno-pattern-namespace-specifier++test-suite fir-tests++    import: common, test++    type:+      detailed-0.9++    hs-source-dirs:+      test++    test-module:+      CabalTests++    other-modules:+        Test+      , Tests+      , Folders++    build-depends:+        fir+      , Cabal+          >= 3.0.0.0 && < 3.17++    default-language:+        Haskell2010
+ img/FIR_logo.svg view
@@ -0,0 +1,142 @@+<?xml version="1.0" encoding="UTF-8" standalone="no"?>+<!-- Created with Inkscape (http://www.inkscape.org/) -->++<svg+   xmlns:dc="http://purl.org/dc/elements/1.1/"+   xmlns:cc="http://creativecommons.org/ns#"+   xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"+   xmlns:svg="http://www.w3.org/2000/svg"+   xmlns="http://www.w3.org/2000/svg"+   xmlns:xlink="http://www.w3.org/1999/xlink"+   xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"+   xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"+   width="200"+   height="120"+   viewBox="0 0 52.916666 31.749999"+   version="1.1"+   id="svg2170"+   inkscape:version="0.92.4 (5da689c313, 2019-01-14)"+   sodipodi:docname="FIR_logo.svg">+  <defs+     id="defs2164">+    <linearGradient+       inkscape:collect="always"+       id="linearGradient2824">+      <stop+         style="stop-color:#bff4e6;stop-opacity:1"+         offset="0"+         id="stop2820" />+      <stop+         style="stop-color:#5799ea;stop-opacity:1"+         offset="0.2"+         id="stop2830" />+      <stop+         id="stop2832"+         offset="0.40000001"+         style="stop-color:#e574a1;stop-opacity:1" />+      <stop+         style="stop-color:#edb24a;stop-opacity:1"+         offset="0.667"+         id="stop2834" />+      <stop+         style="stop-color:#f7715c;stop-opacity:1"+         offset="1"+         id="stop2822" />+    </linearGradient>+    <linearGradient+       inkscape:collect="always"+       xlink:href="#linearGradient2824"+       id="linearGradient2826"+       x1="361.49585"+       y1="940.32275"+       x2="360.00391"+       y2="99.738281"+       gradientUnits="userSpaceOnUse"+       gradientTransform="matrix(0.79385928,0,0,0.79385928,-443.9031,-757.25189)" />+  </defs>+  <sodipodi:namedview+     id="base"+     pagecolor="#ffffff"+     bordercolor="#666666"+     borderopacity="1.0"+     inkscape:pageopacity="0.0"+     inkscape:pageshadow="2"+     inkscape:zoom="2"+     inkscape:cx="28.051368"+     inkscape:cy="1.1418467"+     inkscape:document-units="mm"+     inkscape:current-layer="g857"+     showgrid="false"+     inkscape:window-width="2560"+     inkscape:window-height="1377"+     inkscape:window-x="1912"+     inkscape:window-y="-8"+     inkscape:window-maximized="1"+     fit-margin-top="0"+     fit-margin-left="0"+     fit-margin-right="0"+     fit-margin-bottom="0"+     units="px"+     scale-x="1" />+  <metadata+     id="metadata2167">+    <rdf:RDF>+      <cc:Work+         rdf:about="">+        <dc:format>image/svg+xml</dc:format>+        <dc:type+           rdf:resource="http://purl.org/dc/dcmitype/StillImage" />+        <dc:title></dc:title>+      </cc:Work>+    </rdf:RDF>+  </metadata>+  <g+     inkscape:label="Layer 1"+     inkscape:groupmode="layer"+     id="layer1"+     transform="translate(479.11949,-239.1756)">+    <g+       id="g857"+       transform="matrix(0.04052823,0,0,0.04052823,-460.55139,271.49419)">+      <g+         id="g1442"+         transform="translate(39.170228,-78.340456)">+        <path+           style="opacity:1;fill:url(#linearGradient2826);fill-opacity:1;stroke:none;stroke-width:0.25851786;stroke-linecap:round;stroke-linejoin:bevel;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;paint-order:stroke fill markers"+           d="m -158.11046,-678.07373 -250.04105,144.36146 250.03175,144.35526 250.040872,-144.36147 z m 300.04161,230.9681 -250.03468,144.35834 V -14.030586 L 141.93115,-158.38737 Z m -600.08335,0.012 v 288.7074 l 250.03478,144.356784 V -302.73529 Z"+           id="path2095"+           inkscape:connector-curvature="0" />+        <path+           style="opacity:1;fill:#a41e22;fill-opacity:1;stroke:none;stroke-width:0.91290271;stroke-linecap:round;stroke-linejoin:bevel;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;paint-order:stroke fill markers"+           d="m -108.10353,-216.30344 v 151.639534 h 87.549352 z m -100.01389,0.001 -87.54785,151.637974 h 87.54785 z"+           id="path2148"+           inkscape:connector-curvature="0" />+        <path+           style="opacity:1;fill:#0a7f39;fill-opacity:1;stroke:none;stroke-width:1.07617247;stroke-linecap:round;stroke-linejoin:bevel;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;paint-order:stroke fill markers"+           d="m -158.11046,-678.07373 -125.0205,216.54219 125.0112,72.17453 125.025092,-72.18384 z m 175.022712,303.14883 -125.015782,72.17761 v 144.35992 h 250.03468 z m -350.050192,0.009 -125.01426,216.52979 h 250.03478 v -144.34906 z"+           id="path2134"+           inkscape:connector-curvature="0" />+        <g+           style="stroke:none;stroke-width:10;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"+           id="g17200-8"+           transform="matrix(1.2060705,0,0,1.2060705,-11147.316,15999.614)">+          <path+             inkscape:connector-curvature="0"+             style="fill:#a41e22;fill-opacity:1;stroke:none;stroke-width:10;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"+             d="m 9602.6916,-13572.662 v -44.115 h -150.4487 v 197.614 h 51.9024 v -75.786 h 83.5336 v -42.47 h -83.5336 v -35.243 z m 0,0"+             id="path17194-1" />+          <path+             inkscape:connector-curvature="0"+             style="fill:#a41e22;fill-opacity:1;stroke:none;stroke-width:10;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"+             d="m 9633.3152,-13419.163 h 51.9024 v -197.614 h -51.9024 z m 0,0"+             id="path17196-3" />+          <path+             inkscape:connector-curvature="0"+             style="fill:#a41e22;fill-opacity:1;stroke:none;stroke-width:10;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"+             d="m 9879.8645,-13474.116 c -1.9267,-18.585 -9.1521,-32.474 -29.4234,-38.295 23.041,-7.787 35.2439,-24.446 35.2439,-48.33 0,-31.35 -21.3551,-56.036 -63.8243,-56.036 h -104.0858 v 197.614 h 51.9024 v -72.736 h 31.6312 c 19.1473,0 26.9346,8.912 28.5804,26.654 l 4.4557,46.082 h 51.9024 z m -73.0166,-56.639 h -37.1706 v -45.239 h 39.9805 c 16.8994,0 24.6868,9.433 24.6868,22.198 0,13.046 -8.3092,23.041 -27.4967,23.041 z m 0,0"+             id="path17198-0" />+        </g>+      </g>+    </g>+  </g>+</svg>
+ src/CodeGen/Application.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DerivingStrategies  #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ViewPatterns        #-}++{-|+Module: CodeGen.Application++Functionality for keeping track of function arguments, such as patterns for the application of a function to several arguments.+-}++module CodeGen.Application+  ( UAST(..), UCode(..)+  , ASTs(.., SnocAST)+  , Codes, pattern ConsCode+  , Application(.., Nullary)+  , traverseASTs+  ) where++-- base+import Data.Kind+  ( Type )+import Data.Type.Equality+  ( (:~:)(Refl) )+import Unsafe.Coerce+  ( unsafeCoerce )++-- fir+import Data.Constraint.All+  ( All(allDict)+  , AllDict(ConsDict)+  )+import Data.Type.List+  ( Head, Tail, Snoc )+import FIR.AST+  ( AST, Code )+import FIR.AST.Type+  ( AugType, FunTys, Nullary, MapVal )++----------------------------------------------------------------------------+-- existential data types to emulate untyped AST++-- UAST = Untyped AST+data UAST where+  UAST :: AST a -> UAST+deriving stock instance Show UAST++data UCode where+  UCode :: Nullary a => AST a -> UCode+deriving stock instance Show UCode++----------------------------------------------------------------------------+-- typed list of ASTs++infixr 5 `ConsAST`+infixl 5 `SnocAST`++data ASTs (is :: [AugType]) :: Type where+  NilAST  :: ASTs '[]+  ConsAST :: AST i -> ASTs is -> ASTs (i ': is)++{-# COMPLETE SnocAST #-}+pattern SnocAST :: ASTs as -> AST a -> ASTs (as `Snoc` a)+pattern SnocAST as a <- ( unsnocAST -> (as, a) )+  where+    SnocAST NilAST           a = a `ConsAST` NilAST+    SnocAST (x `ConsAST` xs) a = unsafeCoerce ( x `ConsAST` (xs `SnocAST` a) )+      --                          ^^^^+      -- should be able to get rid of this @unsafeCoerce@++unsnocAST :: ASTs (as `Snoc` a) -> ( ASTs as, AST a )+unsnocAST NilAST               = error "impossible"+unsnocAST (b `ConsAST` NilAST) = unsafeCoerce ( NilAST, b )+unsnocAST (b `ConsAST` bs    ) =+  case unsnocAST ( unsafeCoerce bs ) of+    ( cs, c ) -> ( unsafeCoerce (b `ConsAST` cs), c )++type Codes as = ASTs (MapVal as)++data Application (ast :: AugType -> Type) (f :: AugType) (r :: AugType) where+  Applied :: FunTys f as r => ast f -> ASTs as -> Application ast f r++pattern Nullary :: FunTys f '[] r => ast f -> Application ast f r+pattern Nullary v = Applied v NilAST++traverseASTs+  :: forall c f as b+  .  ( Applicative f, All c as )+  => ( forall a. c a => AST a -> f b )+  -> ASTs as+  -> f [b]+traverseASTs f as = go allDict as+  where+    go :: AllDict c xs -> ASTs xs -> f [b]+    go _        NilAST           = pure []+    go ConsDict (x `ConsAST` xs) = (:) <$> f x <*> go allDict xs++----------------------------------------------------------------------------+-- Workaround for pattern matching not correctly propagating type family injectivity annotations+-- (See [GHC trac #16436](https://gitlab.haskell.org/ghc/ghc/issues/16436).)++infixr 5 `ConsCode`++pattern ConsCode :: () => ( as ~ ( Head as ': Tail as ) )+                 => Code (Head as) -> Codes (Tail as) -> Codes as+pattern ConsCode b bs <- ( getConsCode -> Just (GetConsCode b bs) )+  where+    ConsCode b bs = ConsAST b bs++data GetConsCode as where+  GetConsCode :: ( as ~ (Head as ': Tail as) ) => Code (Head as) -> Codes (Tail as) -> GetConsCode as++getConsCode :: forall as. Codes as -> Maybe (GetConsCode as)+getConsCode NilAST         = Nothing+getConsCode (ConsAST a as) = case unsafeCoerce Refl :: ( as :~: (Head as ': Tail as) ) of+  Refl -> Just (GetConsCode a as)
+ src/CodeGen/Applicative.hs view
@@ -0,0 +1,447 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE BlockArguments         #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE DerivingVia            #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE PatternSynonyms        #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE StandaloneDeriving     #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}+{-# LANGUAGE ViewPatterns           #-}++{-|+Module: CodeGen.Applicative++Code generation for (functor and) applicative operations:++  * vectors use vectorised instructions (whenever possible),+  * matrices use vectorised operations on their columns (whenever possible),+  * arrays use loops.++-}++module CodeGen.Applicative ( ) where++-- base+import Prelude+  hiding ( Num(..), Integral(..)+         , Fractional(..), Floating(..), RealFloat(..)+         )+import qualified Prelude+import Data.Foldable+  ( toList )+import Data.Kind+  ( Type )+import Data.Proxy+  ( Proxy(Proxy) )+import Data.Type.Equality+  ( (:~:)(Refl) )+import Data.Word+  ( Word32 )+import GHC.TypeNats+  ( Nat, KnownNat )+import Unsafe.Coerce+  ( unsafeCoerce )++-- lens+import Control.Lens+  ( assign )++-- mtl+import Control.Monad.Except+  ( throwError )++-- text-short+import qualified Data.Text.Short as ShortText+  ( pack )++-- variant+import Data.Variant.VariantF+  ( VariantF, ApplyAll, BottomUp(toBottomUp) )+import Data.Variant.EGADT+  ( EGADT(..), HVariantF(..) )++-- fir+import CodeGen.Application+  ( Application(Applied)+  , ASTs(NilAST, ConsAST)+  , pattern SnocAST+  , pattern Nullary+  )+import CodeGen.Array+  ( createArray )+import {-# SOURCE #-} CodeGen.CodeGen+  ( CodeGen(codeGenArgs), codeGen )+import CodeGen.Composite+  ( compositeConstruct )+import CodeGen.Instruction+  ( ID, Pointer(..) )+import CodeGen.Monad+  ( CGMonad )+import CodeGen.Pointers+  ( newVariable )+import CodeGen.State+  ( _localBinding, scoped )+import Control.Type.Optic+  ( AnIndex+  , ReifiedGetter(view)+  )+import Data.Constraint.All+  ( All(allDict), AllDict(NilDict, ConsDict) )+import Data.Type.Known+  ( knownValue )+import Data.Type.List+  ( Snoc )+import FIR.AST+  ( Code, AST+  , Syntactic(fromAST)+  , primOp+  , AppF(..), LitF(..)+  , ApplicativeF(..)+  , PrimOpF(..), MkVectorF(..)+  , UnsafeCoerceF(..)+  , pattern (:$), pattern Lam, pattern Pure, pattern MkID+  , pattern MkVector, pattern UnMat+  , pattern UnsafeCoerce, pattern Lit+  )+import FIR.AST.Type+  ( AugType(Val,(:-->)), UnderlyingType+  , FunArgs, FunRes, ApplyFun+  , ApplyFAug, MapApplyFAug+  )+import FIR.Prim.Array+  ( Array )+import FIR.Prim.Op+  ( PrimOp(..), SPrimOp(SMul)+  , Vectorise(Vectorise), VecPrimOpType(VecPrimOpType)+  , PrimTyVal+  )+import FIR.Prim.Types+  ( PrimTy, primTy+  , IntegralTy+  , PrimFunc(primFuncSing, distDict), DistDict(DistDict)+  , SPrimFunc(..)+  )+import FIR.Syntax.AST+  ( ) -- 'PrimFunc' instances, optic instances+import Math.Algebra.Class+  ( Semiring((*)), Integral )+import Math.Linear+  ( V, M, Semimodule((*^)) )+import qualified SPIRV.PrimTy  as SPIRV++----------------------------------------------------------------------------+-- Dispatch code-generation on AST constructors.++instance CodeGen AST => CodeGen (ApplicativeF AST) where++  codeGenArgs ( Applied ( ApF pxf (Pure _ f :: AST (Val (f a) :--> ApplyFAug f b )) (Pure _ a :: AST (Val (f a))) ) as )+    | ( _ :: AST t ) <- f+    , ( _ :: AST v ) <- a+    , Refl <- ( unsafeCoerce Refl :: t :~: ( Val a :--> b ) )+    , Refl <- ( unsafeCoerce Refl :: v :~: Val a )+    , ConsDict <- allDict @PrimTyVal @(Val a ': FunArgs b)+    = codeGenArgs ( Applied ( PureF pxf (f :$ a) ) as )+  codeGenArgs ( Applied ( ApF ( _ :: Proxy f) f a ) as ) =+    codeGenArgs ( Applied f (a `ConsAST` as) )++  codeGenArgs ( Applied (PureF ( _ :: Proxy f) (a :: AST a)) (as :: ASTs fas) )+    | Refl <- ( unsafeCoerce Refl :: ApplyFun a fas :~: Val (UnderlyingType (FunRes a)) )+    , Refl <- ( unsafeCoerce Refl :: fas :~: MapApplyFAug f (FunArgs a) )+    = idiom (makeIdiom @f @a @(FunArgs a) a as)+++makeIdiom+  :: forall f a as fas+  .  ( fas ~ MapApplyFAug f as, All PrimTyVal as )+  => AST a -> ASTs fas -> Idiom f as (ApplyFun a fas)+makeIdiom v NilAST+  | Refl <- ( unsafeCoerce Refl :: ApplyFun a fas :~: a )+  , Refl <- ( unsafeCoerce Refl :: as :~: '[] )+  = PureIdiom v+makeIdiom h as@(ConsAST _ _) = case snocDict ( allDict @PrimTyVal @as ) of+  sDict@SnocDict+    | ( _ :: SnocDict PrimTyVal (init_as `Snoc` last_as) ) <- sDict+    , ( _ :: Proxy init_fas ) <- Proxy @( MapApplyFAug f init_as )+    , Refl <- ( unsafeCoerce Refl :: fas :~: ( init_fas `Snoc` (ApplyFAug f last_as) ) )+    , ( bs `SnocAST` b ) <- as+    , ( nxt :: Idiom f init_as (ApplyFun a init_fas ) ) <- makeIdiom h bs+    , Refl <- ( unsafeCoerce Refl :: ApplyFun a init_fas :~: ( Val (UnderlyingType last_as) :--> ApplyFun a fas ) )+    -> ApIdiom nxt b++data Idiom (f :: Type -> Type) (as :: [AugType]) (b :: AugType) where+  PureIdiom :: forall f b. AST b -> Idiom f '[] b+  ApIdiom   :: PrimTy a => Idiom f as (Val a :--> b) -> AST (Val (f a)) -> Idiom f (as `Snoc` (Val a)) b+deriving stock instance Show (Idiom f as b)++data SnocDict c as where+  NilSnocDict :: SnocDict c '[]+  SnocDict    :: (All c as, c a) => SnocDict c (as `Snoc` a)++snocDict :: forall c as. AllDict c as -> SnocDict c as+snocDict NilDict = NilSnocDict+snocDict consDict@ConsDict = case consDict of+  ( _ :: AllDict c (b ': bs) ) -> case snocDict (allDict @c @bs) of+    NilSnocDict -> SnocDict+    sDict@SnocDict -> case sDict of+      ( _ :: SnocDict c (xs `Snoc` x ) )+        | Refl <- ( unsafeCoerce Refl :: as :~: ( (b ': xs) `Snoc` x) )+        -> SnocDict++----------------------------------------------------------------------------+-- Code-generation of an idiomatic expression.++idiom+  :: forall f bs r+  .  ( CodeGen AST, PrimFunc f, PrimTy r )+  => Idiom f bs (Val r) -> CGMonad ( ID, SPIRV.PrimTy )+idiom (PureIdiom b) = do+  elt@(eltID, eltTy) <- codeGen b+  case primFuncSing @f of+    sFuncVector@SFuncVector ->+      case sFuncVector of+        ( _ :: SPrimFunc (V n) ) ->+          let n :: Prelude.Num t => t+              n = Prelude.fromIntegral (knownValue @n)+          in compositeConstruct+               ( SPIRV.Vector n eltTy )+               ( replicate n eltID )+    sFuncMatrix@SFuncMatrix ->+      case sFuncMatrix of+        ( _ :: SPrimFunc (M m n) ) ->+          do+            constituentTy <-+              case eltTy of+                SPIRV.Scalar ty -> pure ty+                ty -> throwError +                        ( "codeGen: matrix contains non-scalars of type "+                         <> ShortText.pack (show ty)+                        )+            let colDim :: Word32+                colDim = knownValue @m+                rowDim :: Prelude.Num t => t+                rowDim = Prelude.fromIntegral (knownValue @n)+            col <- fst <$> idiom ( PureIdiom @(V m) (MkID elt :: Code r) )+            compositeConstruct+              ( SPIRV.Matrix colDim rowDim constituentTy )+              ( replicate rowDim col )+    sFuncArray@SFuncArray ->+      case sFuncArray of+          ( _ :: SPrimFunc (Array n) ) ->+            let n :: Prelude.Num t => t+                n = Prelude.fromIntegral (knownValue @n)+            in compositeConstruct+                 ( SPIRV.Array n eltTy )+                 ( replicate n eltID )+idiom apIdiom@(ApIdiom idi a) =+  case primFuncSing @f of+    sFuncVector@SFuncVector ->+      case sFuncVector of+        ( _ :: SPrimFunc (V n) ) ->+          case applyIdiomV @n apIdiom of+            -- attempt to directly vectorise operation if possible+            Just res -> codeGen res+            -- otherwise, revert to doing it component by component+            _ -> do +              ids <- toList <$> traverse codeGen (applyIdiom idi a)+              eltTy <- case ids of+                  ((_, ty) : _) -> pure ty+                  _             -> throwError "codeGen: empty vector"+              compositeConstruct+                ( SPIRV.Vector (knownValue @n) eltTy )+                ( map fst ids )+    sFuncMatrix@SFuncMatrix ->+      case sFuncMatrix of+        ( _ :: SPrimFunc (M m n) ) ->+          let idiom_cols :: V n (Idiom (V m) bs (Val r))+              idiom_cols = distributeMatrixIdiom apIdiom+          in do+               cols <- toList <$> traverse idiom idiom_cols+               eltTy <- case cols of+                 ((_, SPIRV.Vector _ (SPIRV.Scalar ty)) : _)+                     -> pure ty+                 _   -> throwError "codeGen: invalid matrix type, columns are not vectors of scalars"+               compositeConstruct+                 ( SPIRV.Matrix (knownValue @m) (knownValue @n) eltTy )+                 ( map fst cols )+    sFuncArray@SFuncArray ->+      case sFuncArray of+        ( _ :: SPrimFunc (Array n) ) ->+          let arrayFunction = applyIdiomArray @n @Word32 idi a+              arrayLg = knownValue @n+              eltTy = primTy @r+          in do+            Pointer resArrPtrID resArrPtrTy <- newVariable ( SPIRV.Array arrayLg eltTy )+            ( res, _ ) <- scoped do+              assign ( _localBinding "__tmp_array"      ) ( Just ( resArrPtrID, SPIRV.Pointer resArrPtrTy ) )+              assign ( _localBinding "__tmp_arrayIndex" ) Nothing+              codeGen ( createArray @n @"__tmp_array" @"__tmp_arrayIndex" @r arrayFunction )+            return res+++applyIdiom+  :: forall f as a b+  .  ( PrimFunc f, PrimTy a )+  => Idiom f as (Val a :--> b) -> AST (Val (f a)) -> f (AST b)+applyIdiom i a+  | DistDict <- distDict @f @(AST (Val a))+  = case i of+    PureIdiom f    ->   fromAST f                     <$> ( fromAST a :: f (AST (Val a)) )+    ApIdiom   f a' -> ( fromAST <$> applyIdiom f a' ) <*> ( fromAST a :: f (AST (Val a)) )++distributeMatrixIdiom+  :: forall m n as b.+     ( KnownNat m, KnownNat n )+  => Idiom (M m n) as b -> V n (Idiom (V m) as b)+distributeMatrixIdiom (PureIdiom f)+  = fmap PureIdiom . pure @(V n) $ f+distributeMatrixIdiom (ApIdiom f a)+  = ApIdiom <$> distributeMatrixIdiom f <*> fromAST ( UnMat :$ a )+++applyIdiomArray+  :: forall n ix as a b+  .  ( KnownNat n+     , Integral ix, IntegralTy ix+     , PrimTy a+     )+  => Idiom (Array n) as (Val a :--> b) -> Code (Array n a) -> ( Code ix -> AST b )+applyIdiomArray (PureIdiom f) arr i =+  fromAST f (view @(AnIndex (Code ix)) i arr)+applyIdiomArray (ApIdiom f arr') arr i =+  let f' :: Code a -> AST b+      f' = fromAST ( applyIdiomArray f arr' i )+  in f' (view @(AnIndex (Code ix)) i arr)++---------------------------------------------------------------------------------------+-- awful hacks to use native SPIR-V vectorised instructions if possible++newtype FakeScalar n a = FakeScalar a+  deriving stock Show++type family Vectorisation (n :: Nat) (a :: AugType) = (r :: AugType) | r -> a where+  Vectorisation n (Val a :--> b) = Val (FakeScalar n a) :--> Vectorisation n b+  Vectorisation n (Val b)        = Val b++applyIdiomV+  :: forall n as b+  .  ( KnownNat n, PrimTy b )+  => Idiom (V n) as (Val b) -> Maybe (Code (V n b))+applyIdiomV idi = sanitiseVectorisation @n ( unsafeVectorise idi )++unsafeVectorise :: forall n as b. Idiom (V n) as b -> AST (Vectorisation n b)+unsafeVectorise (PureIdiom b) = unsafeCoerce b+unsafeVectorise (ApIdiom f (v :: Code (V n a)))+  = fromAST+      ( unsafeVectorise f )+      ( ( UnsafeCoerce :$ v ) :: AST (Val (FakeScalar n a)) )++class KnownNat n => SanitiseVectorisation (n :: Nat) (ast :: AugType -> Type) where+  sanitiseVectorisationArgs :: PrimTy r => Application ast f (Val r) -> Maybe (Code (V n r))++sanitiseVectorisation+  :: forall n r ast+  .  ( SanitiseVectorisation n ast, PrimTy r )+  => ast (Val r) -> Maybe (Code (V n r))+sanitiseVectorisation r = sanitiseVectorisationArgs (Nullary r)++instance ( KnownNat n, BottomUp (SanitiseVectorisation n) vs ) => SanitiseVectorisation n (VariantF vs) where+  sanitiseVectorisationArgs (Applied f args) =+    toBottomUp @(SanitiseVectorisation n) ( \x -> sanitiseVectorisationArgs $ Applied x args ) f++deriving via VariantF ( ApplyAll (EGADT vs :: AugType -> Type) vs )+  instance ( KnownNat n, BottomUp (SanitiseVectorisation n) ( ApplyAll (EGADT vs) vs ) )+        => SanitiseVectorisation n (EGADT vs)++instance SanitiseVectorisation n AST => SanitiseVectorisation n (AppF AST) where+  sanitiseVectorisationArgs (Applied (AppF (Lam f) a) as) = sanitiseVectorisationArgs (Applied (f a) as)+  sanitiseVectorisationArgs (Applied (AppF f a) as) = sanitiseVectorisationArgs (Applied f (a `ConsAST` as))++instance {-# OVERLAPPABLE #-} KnownNat n => SanitiseVectorisation n ast where+  sanitiseVectorisationArgs = const Nothing++instance KnownNat n => SanitiseVectorisation n (MkVectorF AST) where+  sanitiseVectorisationArgs ( Applied (MkVectorF vec) NilAST )+    = Just ( unsafeCoerce $ MkVector vec )++instance KnownNat n => SanitiseVectorisation n (UnsafeCoerceF AST) where+  sanitiseVectorisationArgs ( Applied UnsafeCoerceF (vec `ConsAST` NilAST) )+    = Just ( unsafeCoerce vec )++instance KnownNat n => SanitiseVectorisation n (LitF AST) where+  sanitiseVectorisationArgs ( Applied (LitF a) NilAST )+    = Just ( Pure (Proxy @(V n)) (Lit ( unsafeCoerce a)) )++instance SanitiseVectorisation n AST => SanitiseVectorisation n (PrimOpF AST) where+  sanitiseVectorisationArgs ( Applied (PrimOpF ( _ :: Proxy a ) ( _ :: Proxy op )) as )+    -- special case for 'vector times scalar' optimisation+    |  Just smul@SMul <- opSing @_ @_ @op @a+    , ( _ :: SPrimOp a mul_op ) <- smul+    , ( v1 `ConsAST` v2 `ConsAST` NilAST ) <- as+    = case ( sanitiseVectorisation @n v1, sanitiseVectorisation @n v2 ) of+      ( Just (Pure _ (b1 :: AST vb1)), Just (Pure _ (b2 :: AST vb2)) )+        | Refl <- ( unsafeCoerce Refl :: vb1 :~: Val (UnderlyingType vb1) )+        , Refl <- ( unsafeCoerce Refl :: vb2 :~: Val (UnderlyingType vb2) )+        , ( _ :: Proxy b1 ) <- Proxy @(UnderlyingType vb1)+        , ( _ :: Proxy b2 ) <- Proxy @(UnderlyingType vb2)+        -> let b1b2 :: Code a+               b1b2 = unsafeCoerce b1 * unsafeCoerce b2+               b1b2' :: Code b1+               b1b2' = unsafeCoerce b1b2+           in Just $ Pure ( Proxy @(V n) ) b1b2'+      ( Just (Pure _ b1), Just sv2 )+        -> let b1' :: Code a+               b1' = unsafeCoerce b1+               sv2' :: Code (V n a)+               sv2' = unsafeCoerce sv2+           in Just $ b1' *^ sv2'+      ( Just sv1, Just (Pure _ b2) )+        -> let sv1' :: Code (V n a)+               sv1' = unsafeCoerce sv1+               b2' :: Code a+               b2' = unsafeCoerce b2+           in Just $ b2' *^ sv1'+      ( Just sv1, Just sv2 )+        -> let+              b1, b2 :: Code a+              b1 = unsafeCoerce sv1+              b2 = unsafeCoerce sv2+           in applyvPrimOp+                ( primOp @(V n a) @('Vectorise mul_op) )+                ( b1 `ConsAST` b2 `ConsAST` NilAST )+      _ -> Nothing+    | Just ( VecPrimOpType ( _ :: Proxy v_a) ) <- vectorisation @_ @_ @op @a @n+    , ( _ :: Proxy f  ) <- Proxy @(PrimOpAugType op a)+    , ( _ :: Proxy vf ) <- Proxy @(PrimOpAugType ('Vectorise op) v_a)+    , Refl <- ( unsafeCoerce Refl :: FunRes f :~: Val (UnderlyingType (FunRes f)) )+    , Refl <- ( unsafeCoerce Refl :: ApplyFAug (V n) f :~: vf )+    = applyvPrimOp @n @f @(UnderlyingType (FunRes f)) ( primOp @v_a @('Vectorise op) ) as+    | otherwise+    = Nothing++applyvPrimOp+  :: forall (n :: Nat) f r+  .  ( KnownNat n, FunRes f ~ Val r, All PrimTyVal (FunArgs f) )+  => AST (ApplyFAug (V n) f) -> ASTs (FunArgs f) -> Maybe (Code (V n r))+applyvPrimOp vPrimOp as = case allDict @PrimTyVal @(FunArgs f) of+  NilDict+    | Refl <- ( unsafeCoerce Refl :: f :~: Val (UnderlyingType f) )+    -> Just vPrimOp+  ConsDict -> case as of+    ( ( x :: AST (Val x) ) `ConsAST` xs )+      | Refl <- ( unsafeCoerce Refl :: f :~: ( Val x :--> SkipFirstArg f ) )+      , Just v <- sanitiseVectorisation @n x+      -> applyvPrimOp ( vPrimOp :$ v ) xs+    _ -> Nothing++type family SkipFirstArg (x :: AugType) :: AugType where+  SkipFirstArg (_ :--> b) = b
+ src/CodeGen/Array.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++{-|+Module: CodeGen.Array++This module defines the AST for a loop creating an array, to be processed by the code generator to define loops over arrays.++This is done here with the user-facing syntax of the library, instead of wiring in the definition.+-}++module CodeGen.Array+  ( createArray )+  where++-- base+import Data.Type.Equality+  ( (:~:)(Refl) )+import GHC.TypeLits+  ( KnownSymbol )+import GHC.TypeNats+  ( KnownNat )+import Unsafe.Coerce+  ( unsafeCoerce )++-- fir+import Control.Monad.Indexed+  ( pure, (>>), (>>=) )+import Control.Type.Optic+  ( Name, AnIndex, (:.:) )+import Data.Type.Known+  ( knownValue )+import Data.Type.Map+  ( (:->)((:->)) )+import Math.Algebra.Class+  ( AdditiveMonoid(fromInteger, (+)) )+import Math.Logic.Class+  ( Ord((<)) )+import FIR.AST+  ( AST, Code+  , Syntactic(toAST)+  , pattern Lit+  )+import FIR.AST.Type+  ( Eff )+import FIR.Binding+  ( Var, RW )+import FIR.Prelude+import FIR.Prim.Array+  ( Array )+import FIR.Prim.Types+  ( PrimTy, HasOpaqueType )+import FIR.ProgramState+  ( ProgramState(ProgramState) )+import FIR.Syntax.AST+  ( )+import FIR.Syntax.Program+  ( def, get, put, assign+  , locally, while+  )+import FIR.Validation.Bindings+  ( Has, CanGet, CanPut+  , ValidDef, AddBinding+  )++----------------------------------------------------------------------------++-- | Code for a loop creating a new array.+--+-- Assumes that the array has already been defined,+-- but allows it to be uninitialised.+--+-- Runs in an environment with no local state.+createArray :: forall n arrName ixName a i j ctx cfg funs eps g_iface rayQs bkend.+             ( KnownNat n+             , KnownSymbol ixName+             , KnownSymbol arrName+             , PrimTy a+             , i ~ 'ProgramState '[ arrName ':-> Var RW (Array n a) ] ctx cfg funs eps g_iface rayQs bkend+             , j ~ AddBinding ixName (Var RW Word32) i+             , Has ixName  j ~ Word32+             , Has arrName j ~ Array n a+             , CanGet ixName  j+             , CanPut ixName  j+             , CanGet arrName j+             , CanPut arrName j+             , ValidDef ixName i Word32+             )+          => ( Code Word32 -> Code a )+          -> AST ( Eff i i (Array n a) )+createArray arrayFunction+  | Refl <- ( unsafeCoerce Refl :: HasOpaqueType a :~: False ) -- bypass validity check+  = toAST $ locally @i @j do+      _ <- def @ixName @RW @Word32 @i 0+      while ( get @ixName < pure (Lit arrayLg) ) do+        i <- get @ixName+        assign @(Name arrName :.: AnIndex Word32)+          i (arrayFunction i)+        put @ixName (i+1)+      get @arrName+        where arrayLg :: Word32+              arrayLg = knownValue @n
+ src/CodeGen/Atomics.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE TupleSections       #-}++{-|+Module: CodeGen.Atomics++Code generation for atomic operations.+-}++module CodeGen.Atomics+  ( atomicInstruction )+  where++-- base+import Control.Monad+  ( unless )++-- mtl+import Control.Monad.Except+  ( throwError )++-- lens+import Control.Lens+  ( view )++-- text-short+import Data.Text.Short+  ( ShortText )+import qualified Data.Text.Short as ShortText+  ( pack )++-- fir+import CodeGen.Binary+  ( instruction )+import CodeGen.IDs+  ( laidOutTypeID, constID )+import CodeGen.Instruction+  ( Args, toArgs+  , ID(ID), Instruction(..)+  , Pointer(..)+  )+import CodeGen.Monad+  ( CGMonad+  , MonadFresh(fresh)+  )+import CodeGen.Pointers+  ( relayout )+import CodeGen.State+  ( _backend+  , requireCapability, requireExtension+  )+import FIR.Prim.Atomic+  ( SAtomicOp(..), atomicOp, SAtomicShape(..), atomicShape )+import qualified SPIRV.Capability      as SPIRV+import qualified SPIRV.Extension       as SPIRV.Extension+import qualified SPIRV.Layout          as SPIRV+import qualified SPIRV.Operation       as SPIRV.Op+import qualified SPIRV.PrimTy          as SPIRV+import qualified SPIRV.ScalarTy        as SPIRV+import qualified SPIRV.Stage           as SPIRV+import qualified SPIRV.Storage         as Storage+import qualified SPIRV.Synchronisation as SPIRV++----------------------------------------------------------------------------++-- | Perform an atomic operation on the scalar a pointer points to,+-- with the given operands.+atomicInstruction+  :: SAtomicOp op -> Pointer -> [ ID ] -> CGMonad (ID, SPIRV.PrimTy)+atomicInstruction sOp (Pointer ptrID (SPIRV.PointerTy storage lay ty)) operandIDs+  = do+      bk <- view _backend+      unless ( storage `elem` atomicStorageClasses bk ) $+        throwError+          (  "codeGen: atomic operations are unsupported on pointers of storage "+          <> "class " <> ShortText.pack ( show storage ) <> " for backend "+          <> ShortText.pack ( show bk ) <> ".\n\+             \Supported storage classes: "+          <> ShortText.pack ( show ( atomicStorageClasses bk ) ) <> "."+          )+      op <- case ty of+        SPIRV.Scalar sTy -> atomicOperation sOp sTy+        _ -> throwError+               (  "codeGen: " <> opName <> " is unsupported on values of type "+               <> ShortText.pack ( show ty ) <> "."+               )+      -- Device scope and relaxed memory semantics, as for GLSL atomics.+      scopeID         <- constID ( SPIRV.synchronisationScope SPIRV.Device )+      semanticsID     <- constID ( SPIRV.memorySemanticsBitmask relaxed )+      laidOutOperands <-+        traverse ( \ v -> relayout SPIRV.logical lay (v, ty) ) operandIDs+      let+        args :: Args+        args = case ( atomicShape sOp, laidOutOperands ) of+          -- A compare-exchange has separate memory semantics for success and+          -- failure, and takes the new value before the expected value.+          ( SCompares, [ expectedID, newID ] )+            -> toArgs+                 [ ptrID, scopeID, semanticsID, semanticsID, newID, expectedID ]+          _ -> toArgs ( ptrID : scopeID : semanticsID : laidOutOperands )+      case atomicShape sOp of+        SWrites -> do+          instruction+            Instruction+              { operation = op+              , resTy = Nothing+              , resID = Nothing+              , args+              }+          pure (ID 0, SPIRV.Unit) -- ID should never be used+        _ -> do+          tyID <- laidOutTypeID lay ty+          v <- fresh+          instruction+            Instruction+              { operation = op+              , resTy = Just tyID+              , resID = Just v+              , args+              }+          (, ty) <$> relayout lay SPIRV.logical (v, ty)+  where+    opName :: ShortText+    opName = ShortText.pack ( show ( atomicOp sOp ) )+    relaxed :: SPIRV.MemorySemantics+    relaxed = SPIRV.MemorySemantics ( SPIRV.Lock [] ) []++-- | The SPIR-V instruction for an atomic operation on scalars of the given+-- type, requiring the capabilities and extensions it needs.+atomicOperation :: SAtomicOp op -> SPIRV.ScalarTy -> CGMonad SPIRV.Op.Operation+atomicOperation sOp sTy = case sTy of+  SPIRV.Integer sgn w -> do+    case w of+      SPIRV.W32 -> pure ()+      SPIRV.W64 -> requireCapability SPIRV.Int64Atomics+      _         -> unsupported+    pure case sOp of+      SAtomicLoad            -> SPIRV.Op.AtomicLoad+      SAtomicStore           -> SPIRV.Op.AtomicStore+      SAtomicExchange        -> SPIRV.Op.AtomicExchange+      SAtomicCompareExchange -> SPIRV.Op.AtomicCompareExchange+      SAtomicIncrement       -> SPIRV.Op.AtomicIIncrement+      SAtomicDecrement       -> SPIRV.Op.AtomicIDecrement+      SAtomicAdd             -> SPIRV.Op.AtomicIAdd+      SAtomicSub             -> SPIRV.Op.AtomicISub+      SAtomicMin             -> case sgn of+        SPIRV.Signed   -> SPIRV.Op.AtomicSMin+        SPIRV.Unsigned -> SPIRV.Op.AtomicUMin+      SAtomicMax             -> case sgn of+        SPIRV.Signed   -> SPIRV.Op.AtomicSMax+        SPIRV.Unsigned -> SPIRV.Op.AtomicUMax+      SAtomicAnd             -> SPIRV.Op.AtomicAnd+      SAtomicOr              -> SPIRV.Op.AtomicOr+      SAtomicXor             -> SPIRV.Op.AtomicXor+  SPIRV.Floating w -> case sOp of+    SAtomicLoad     -> pure SPIRV.Op.AtomicLoad+    SAtomicStore    -> pure SPIRV.Op.AtomicStore+    SAtomicExchange -> pure SPIRV.Op.AtomicExchange+    SAtomicAdd      -> do+      case w of+        SPIRV.W16 -> do+          requireCapability SPIRV.AtomicFloat16AddEXT+          requireExtension  SPIRV.Extension.SPV_EXT_shader_atomic_float16_add+        SPIRV.W32 -> do+          requireCapability SPIRV.AtomicFloat32AddEXT+          requireExtension  SPIRV.Extension.SPV_EXT_shader_atomic_float_add+        SPIRV.W64 -> do+          requireCapability SPIRV.AtomicFloat64AddEXT+          requireExtension  SPIRV.Extension.SPV_EXT_shader_atomic_float_add+        SPIRV.W8 -> unsupported+      pure SPIRV.Op.AtomicFAddEXT+    SAtomicMin -> SPIRV.Op.AtomicFMinEXT <$ floatMinMax+    SAtomicMax -> SPIRV.Op.AtomicFMaxEXT <$ floatMinMax+    _ -> unsupported+    where+      floatMinMax :: CGMonad ()+      floatMinMax = do+        case w of+          SPIRV.W16 -> requireCapability SPIRV.AtomicFloat16MinMaxEXT+          SPIRV.W32 -> requireCapability SPIRV.AtomicFloat32MinMaxEXT+          SPIRV.W64 -> requireCapability SPIRV.AtomicFloat64MinMaxEXT+          SPIRV.W8  -> unsupported+        requireExtension SPIRV.Extension.SPV_EXT_shader_atomic_float_min_max+  where+    unsupported :: CGMonad a+    unsupported = throwError+      (  "codeGen: " <> ShortText.pack ( show ( atomicOp sOp ) )+      <> " is unsupported on values of type "+      <> ShortText.pack ( show sTy ) <> "."+      )++-- | Storage classes of the pointers atomic operations accept, as specified by+-- the SPIR-V execution environment of each backend.+atomicStorageClasses :: SPIRV.Backend -> [ Storage.StorageClass ]+atomicStorageClasses SPIRV.Vulkan+  = [ Storage.Uniform, Storage.Workgroup, Storage.Image, Storage.StorageBuffer ]+atomicStorageClasses SPIRV.OpenCL+  = [ Storage.Function, Storage.Workgroup+    , Storage.CrossWorkgroup, Storage.Generic+    ]
+ src/CodeGen/Binary.hs view
@@ -0,0 +1,465 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE PackageImports      #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++{-|+Module: CodeGen.Binary++Emitting SPIR-V binary data.+-}++module CodeGen.Binary+  ( putModule+  , instruction+  , structuralInstruction+  , deferredInstructions+  )+  where++-- base+import Control.Monad+  ( when )+import Data.List+  ( sortOn)+import Data.Foldable+  ( traverse_)+import Data.Maybe+  ( isJust )+import Data.Word+  ( Word32 )+import qualified Data.Bits as Bits++-- binary+import qualified Data.Binary as Binary+import qualified Data.Binary.Put as Binary++-- containers+import Data.Map.Strict+  ( Map )+import qualified Data.Map.Strict as Map+import Data.Set+  ( Set )++-- lens+import Control.Lens+  ( view )++-- mtl+import Control.Monad.Except+  ( ExceptT, throwError )++-- text-short+import Data.Text.Short+  ( ShortText )+import qualified Data.Text.Short as ShortText+  ( pack )++-- transformers+import Control.Monad.Trans.Class+  ( lift )++-- fir+import CodeGen.IDs+  ( extInstID )+import CodeGen.Instruction+  ( Args(..), toArgs+  , ID(..), TyID(..), pattern MkTyID+  , Variable, variableID, variableDeclaration+  , Instruction(..)+  )+import CodeGen.Monad+  ( CGMonad, note, liftPut )+import CodeGen.State+  ( CGContext(..), CGState(moduleState), ModuleState(..)+  , _emittingCode+  , currentBlockID, leaveBlock+  , currentFunctionContext+  )+import Data.Binary.Class.Put+  ( Put(put, wordCount) )+import Data.Containers.Traversals+  ( traverseWithKey_, traverseSet_ )+import FIR.ProgramState+  ( FunctionContext(TopLevel) )+import qualified SPIRV.Capability    as SPIRV+import qualified SPIRV.Decoration    as SPIRV+import qualified SPIRV.ExecutionMode as SPIRV+import qualified SPIRV.Extension     as SPIRV+  ( Extension, ExtInst, extInstName )+import qualified SPIRV.Operation     as SPIRV.Op+import qualified SPIRV.PrimTy        as SPIRV+import qualified SPIRV.Stage         as SPIRV+import qualified SPIRV.Version       as SPIRV++----------------------------------------------------------------------------+-- emitting a SPIR-V module+-- some instruction need to be floated to the top++putModule :: CGContext -> CGState -> ExceptT ShortText Binary.PutM ()+putModule+  CGContext { .. }+  cgState+  | emittingCode = do+    lift $ do putHeader spirvVersion ( idNumber currentID )+              putCapabilities         neededCapabilities+              putExtensions           neededExtensions+              putExtendedInstructions knownExtInsts+              putMemoryModel          backend+    let knownBindingIDs = map ( \ (name, (ident, _)) -> (name, ident) ) ( Map.toList knownBindings )+        usedGlobalIDs   = map ( fmap variableID ) ( Map.toList usedGlobals )+        builtinIDs      = map ( fmap variableID ) ( Map.elems builtinVariables )+    putEntryPoints    entryPoints interfaces+    putExecutionModes entryPoints userEntryPoints+    lift $ do+              putKnownStringLits      knownStringLits+              putBindingAnnotations   knownBindingIDs+              putBindingAnnotations   usedGlobalIDs+              putBindingAnnotations   builtinIDs+              putNames                names+              putDecorations          decorations+              putMemberDecorations    memberDecorations++              -- Type and constant declarations need to be interleaved.+              -- For instance, an array type needs to have+              -- its length (a constant) defined earlier.+              putTypesAndConstants    knownTypes knownConstants++              putUndefineds           knownUndefineds++              putGlobals+                (  Map.elems usedGlobals+                ++ map snd ( Map.elems builtinVariables )+                )+  | otherwise = pure ()+    where+      ModuleState { .. } = moduleState cgState++----------------------------------------------------------------------------+-- individual binary instructions++-- | Emit an instruction in the current block (if there is one).+--+-- A block termination instruction ends the current block.+instruction :: Instruction -> CGMonad ()+instruction inst = do+  mbBlock <- currentBlockID+  case mbBlock of+    Nothing -> do+      context <- currentFunctionContext+      case context of+        TopLevel ->+          throwError ( "codeGen: instruction outside of a function: " <> ShortText.pack ( show ( operation inst ) ) )+        _ -> pure ()+    Just _  -> do+      emitInstruction inst+      when ( SPIRV.Op.isBlockTerminator ( operation inst ) )+        leaveBlock++-- | Emit an instruction which doesn't belong to a block, such as a label or @OpFunction@.+structuralInstruction :: Instruction -> CGMonad ()+structuralInstruction = emitInstruction++-- | Emit instructions in the current block, without inspecting them during+-- code generation (for instructions that are only known after generating+-- subsequent code).+--+-- Doesn't support extended instructions.+deferredInstructions :: [ Instruction ] -> CGMonad ()+deferredInstructions insts = do+  emitting <- view _emittingCode+  mbBlock  <- currentBlockID+  when ( emitting && isJust mbBlock )+    ( liftPut ( traverse_ putInstruction insts ) )++emitInstruction :: Instruction -> CGMonad ()+emitInstruction inst = do+  emitting <- view _emittingCode+  when emitting+    case operation inst of+      SPIRV.Op.ExtCode ext _ -> do+        extID <- extInstID ext+        liftPut $ putExtendedInstruction extID inst+      _ -> liftPut $ putInstruction inst++putInstruction :: Instruction -> Binary.Put+putInstruction Instruction { operation = op, resTy = opResTy, resID = opResID, args = opArgs }+    = case op of++      SPIRV.Op.Code opCode ->+        let n :: Word32+            n = 1                          -- OpCode and word count (first byte)+              + maybe 0 (const 1) opResTy  -- result type (if present)+              + maybe 0 (const 1) opResID  -- ID (if present)+              + wordCount opArgs+        in do put @Word32 ( Bits.shift n 16 + fromIntegral opCode)+              traverse_ put opResTy+              traverse_ put opResID+              put opArgs++      _ -> error "putInstruction: unexpected extended instruction"++putExtendedInstruction :: ID -> Instruction -> Binary.Put+putExtendedInstruction extID Instruction { operation = op, resTy = opResTy, resID = opResID, args = opArgs }+  = case op of++      SPIRV.Op.ExtCode _ extOpCode ->+        putInstruction+          Instruction+            { operation = SPIRV.Op.ExtInst+            , resTy     = opResTy+            , resID     = opResID+            , args      = Arg extID+                        $ Arg extOpCode+                        opArgs+            }++      _ -> error "putExtendedInstruction: unexpected non-extended instruction"++putHeader :: SPIRV.Version -> Word32 -> Binary.Put+putHeader ver bound+  = do+      put SPIRV.magicNo+      put ver+      put libraryMagicNo+      put bound+      put ( 0 :: Word32 )+  where+    libraryMagicNo :: Word32+    libraryMagicNo = 0x21524946 -- FIR!++putCapabilities :: Set SPIRV.Capability -> Binary.Put+putCapabilities = traverseSet_ putCap+  where+    putCap :: SPIRV.Capability -> Binary.Put+    putCap cap +      = putInstruction+          Instruction+            { operation = SPIRV.Op.Capability+            , resTy     = Nothing+            , resID     = Nothing+            , args      = Arg cap+                          EndArgs+            }++putExtensions :: Set SPIRV.Extension -> Binary.Put+putExtensions = traverseSet_ putExt+  where+    putExt :: SPIRV.Extension -> Binary.Put+    putExt ext+      = putInstruction+          Instruction+            { operation = SPIRV.Op.Extension+            , resTy     = Nothing+            , resID     = Nothing+            , args      = Arg ext+                          EndArgs+            }++putExtendedInstructions :: Map SPIRV.ExtInst ID -> Binary.Put+putExtendedInstructions+  = traverseWithKey_ \ extInst extID ->+      putInstruction+        Instruction+          { operation = SPIRV.Op.ExtInstImport+          , resTy     = Nothing+          , resID     = Just extID+          , args      = Arg ( SPIRV.extInstName extInst ) EndArgs+          }+      +putMemoryModel :: SPIRV.Backend -> Binary.Put+putMemoryModel bk+  = putInstruction+      Instruction+        { operation = SPIRV.Op.MemoryModel+        , resTy     = Nothing+        , resID     = Nothing+        , args      = Arg addressingModel+                    $ Arg memoryModel+                    EndArgs+        }+    where+      addressingModel :: Word32+      addressingModel = case bk of+        SPIRV.Vulkan -> 0 -- logical addressing+        SPIRV.OpenCL -> 2 -- physical 64-bit addressing+      memoryModel :: Word32+      memoryModel = case bk of+        SPIRV.Vulkan -> 1 -- GLSL450 memory model+        SPIRV.OpenCL -> 2 -- OpenCL memory model++putEntryPoint :: SPIRV.ExecutionModel -> ShortText -> ID -> Map ShortText ID -> Binary.Put+putEntryPoint model modelName entryPointID interface+  = putInstruction+      Instruction+        { operation = SPIRV.Op.EntryPoint+        -- slight kludge to account for unusual parameters for OpEntryPoint+        -- instead of result type, resTy field holds the ExecutionModel value+        , resTy     = Just . MkTyID $ SPIRV.executionModelID model+        , resID     = Just entryPointID+        , args      = Arg modelName+                    $ toArgs interface -- 'Map ShortText ID' has the appropriate traversable instance+        }++putEntryPoints+  :: Map (ShortText, SPIRV.ExecutionModel) ID+  -> Map (ShortText, SPIRV.ExecutionModel) (Map ShortText ID)+  -> ExceptT ShortText Binary.PutM ()+putEntryPoints entryPointIDs+  = traverseWithKey_+      ( \(modelName, model) interface -> do+        entryPointID+          <- note+              (  "putEntryPoints: " <> ShortText.pack (show model)+              <> " entry point named \"" <> modelName+              <> "\" not bound to any ID."+              )+              ( Map.lookup (modelName, model) entryPointIDs )+        lift ( putEntryPoint model modelName entryPointID interface )+      )++putModelExecutionModes :: ID -> SPIRV.ExecutionModes -> Binary.Put+putModelExecutionModes modelID+  = traverse_+      ( \case+          SPIRV.MaxPatchVertices {} -> pure () -- custom execution mode that doesn't exist in SPIR-V+          mode -> putInstruction+            Instruction+              { operation = SPIRV.Op.ExecutionMode+              , resTy     = Nothing+              , resID     = Nothing+              , args      = Arg modelID+                          $ Arg mode EndArgs+              }+      )++putExecutionModes+  :: Map (ShortText, SPIRV.ExecutionModel) ID+  -> Map (ShortText, SPIRV.ExecutionModel) SPIRV.ExecutionModes+  -> ExceptT ShortText Binary.PutM ()+putExecutionModes entryPointIDs+  = traverseWithKey_+      ( \(modelName, model) executionModes -> do+        entryPointID+          <- note+              (  "putExecutionModes: " <> ShortText.pack (show model)+              <> " entry point named \"" <> modelName+              <> "\" not bound to any ID."+              )+              ( Map.lookup (modelName, model) entryPointIDs )+        lift ( putModelExecutionModes entryPointID executionModes )+      )++putKnownStringLits :: Map ShortText ID -> Binary.Put+putKnownStringLits+  = traverseWithKey_+      ( \ lit ident -> putInstruction+        Instruction+          { operation = SPIRV.Op.String+          , resTy     = Nothing+          , resID     = Just ident+          , args      = Arg lit EndArgs+          }+      )++putBindingAnnotations :: [ ( ShortText, ID ) ] -> Binary.Put+putBindingAnnotations+  = traverse_+      ( \ ( name, ident ) -> putInstruction+        Instruction+          { operation = SPIRV.Op.Name+          , resTy     = Nothing+          , resID     = Nothing+          , args      = Arg ident+                      $ Arg name EndArgs+          }+      )++putNames :: Set ( ID, Either ShortText (Word32, ShortText) ) -> Binary.Put+putNames = traverse_+  ( \case+      ( ident, Left name )+        -> putInstruction+              Instruction+                { operation = SPIRV.Op.Name+                , resTy     = Nothing+                , resID     = Nothing+                , args      = Arg ident+                            $ Arg name EndArgs+                }++      ( ident, Right (index,name) )+        -> putInstruction+             Instruction+               { operation = SPIRV.Op.MemberName+               , resTy     = Nothing+               , resID     = Nothing+               , args      = Arg ident+                           $ Arg index+                           $ Arg name EndArgs+               }+  )++putDecorations :: Map ID SPIRV.Decorations -> Binary.Put+putDecorations+  = traverseWithKey_+      ( \ decoratee ->+          traverse_+            ( \ dec ->+                putInstruction+                  Instruction+                    { operation = SPIRV.Op.Decorate+                    , resTy     = Nothing+                    , resID     = Nothing+                    , args      = Arg decoratee+                                $ Arg dec EndArgs+                    }+            )+      )++putMemberDecorations :: Map (TyID, Word32) SPIRV.Decorations -> Binary.Put+putMemberDecorations+  = traverseWithKey_+      ( \ (structTyID, index) ->+           traverse_+             ( \dec ->+                 putInstruction+                   Instruction+                     { operation = SPIRV.Op.MemberDecorate+                     , resTy     = Nothing+                     , resID     = Nothing+                     , args      = Arg structTyID+                                 $ Arg index+                                 $ Arg dec EndArgs+                     }+             )+      )++putTypesAndConstants+  :: Map types     Instruction+  -> Map constants Instruction+  -> Binary.Put+putTypesAndConstants ts cs+  = traverse_ putInstruction+      ( sortOn resID $ Map.elems ts ++ Map.elems cs )++putUndefineds :: Map SPIRV.PrimTy (ID, TyID) -> Binary.Put+putUndefineds = traverse_+  ( \ ( undefID, undefTyID ) ->+      putInstruction+        Instruction+          { operation = SPIRV.Op.Undef+          , resTy     = Just undefTyID+          , resID     = Just undefID+          , args      = EndArgs+          }+  )++putGlobals :: [ Variable ] -> Binary.Put+putGlobals = traverse_ ( putInstruction . variableDeclaration )
+ src/CodeGen/CFG.hs view
@@ -0,0 +1,691 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE NamedWildCards        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE RecursiveDo           #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -Wno-partial-type-signatures #-}++{-|+Module: CodeGen.CFG++Code generation for control flow operations: branching, selections, loops.++See also "CodeGen.Phi" for ϕ-functions necessary for such constructs when using SSA form.+-}++module CodeGen.CFG+  ( newBlock, locally, embed )+  where++-- base+import Prelude+  hiding ( break )+import Control.Arrow+  ( second )+import Control.Monad+  ( unless, when )+import Data.Foldable+  ( for_ )+import Data.Maybe+  ( fromMaybe, isJust )+import Data.Proxy+  ( Proxy )+import Data.Traversable+  ( for )+import Data.Word+  ( Word32 )++-- containers+import Data.Map+  ( Map )+import qualified Data.Map.Strict as Map+import Data.Set+  ( Set )+import qualified Data.Set as Set+  ( fromList, member, toList, isSubsetOf )++-- lens+import Control.Lens+  ( view, use, assign )++-- mtl+import Control.Monad.Except+  ( throwError )++-- text-short+import Data.Text.Short+  ( ShortText )+import qualified Data.Text.Short as ShortText+  ( pack, unpack )++-- fir+import CodeGen.Application+  ( ASTs(NilAST, ConsAST), UCode(UCode)+  , Application(Applied)+  )+import CodeGen.Binary+  ( instruction, structuralInstruction )+import {-# SOURCE #-} CodeGen.CodeGen+  ( CodeGen(codeGenArgs), codeGen )+import CodeGen.Debug+  ( whenAsserting )+import CodeGen.IDs+  ( typeID, constID )+import CodeGen.Instruction+  ( Args(Arg, EndArgs), toArgs+  , ID(ID), Instruction(..)+  , Pair(Pair)+  )+import CodeGen.Monad+  ( MonadFresh(fresh)+  , CGMonad+  )+import CodeGen.Phi+  ( phiInstruction, phiInstructions )+import CodeGen.State+  ( LexicalEnv(localBindings)+  , EarlyExit(..), LoopExit(..), LoopBlockIDs(..)+  , _localBindings, _localBinding, _writableBindings+  , _spirvVersion+  , scoped+  , withLoopFrame, inLoopBodyScope, innermostLoop, loopDepth, addLoopExit+  , currentBlockID, enterBlock+  )+import Data.Containers.Traversals+  ( traverseWithKey_ )+import Data.Type.Known+  ( knownValue )+import Data.Type.Map+  ( Keys )+import FIR.AST+  ( AST, Code+  , SelectionF(..), LoopF(..), StateF(..)+  , pattern (:$), pattern Return+  )+import FIR.AST.Type+  ( AugType(Val), Eff, Nullary )+import FIR.Prim.Types+  ( IntegralTy, primTy )+import FIR.ProgramState+  ( Bindings )+import qualified SPIRV.Control   as SPIRV+  ( SelectionControl, pattern NoSelectionControl+  , LoopControl, pattern NoLoopControl+  )+import qualified SPIRV.Operation as SPIRV.Op+import qualified SPIRV.PrimTy    as SPIRV+  ( PrimTy(..) )+import qualified SPIRV.Version as SPIRV+  ( Version(..) )++----------------------------------------------------------------------------+-- blocks and branching++-- | Start a new block with the given ID.+block :: ID -> CGMonad ()+block blockID = do+  structuralInstruction+    Instruction+      { operation = SPIRV.Op.Label+      , resTy = Nothing+      , resID = Just blockID+      , args  = EndArgs+      }+  enterBlock blockID++newBlock :: CGMonad ()+newBlock = fresh >>= block++-- | Whether the code currently being generated is reachable.+inReachableCode :: CGMonad Bool+inReachableCode = isJust <$> currentBlockID++branch :: ID -> CGMonad ()+branch branchID+  = instruction+      Instruction+       { operation = SPIRV.Op.Branch+       , resID = Nothing+       , resTy = Nothing+       , args  = Arg branchID EndArgs+       }++branchConditional :: ID -> ID -> ID -> CGMonad ()+branchConditional b t f+  = instruction+      Instruction+        { operation = SPIRV.Op.BranchConditional+        , resTy = Nothing+        , resID = Nothing+        , args  = Arg b+                $ Arg t+                $ Arg f EndArgs+        }++unreachable :: CGMonad ()+unreachable+  = instruction+      Instruction+        { operation = SPIRV.Op.Unreachable+        , resTy = Nothing+        , resID = Nothing+        , args  = EndArgs+        }++select :: ID -> (ID, SPIRV.PrimTy) -> (ID, SPIRV.PrimTy) -> CGMonad (ID, SPIRV.PrimTy)+select c (o1, ty1) (o2, ty2) = do+  ( whenAsserting . when (ty1 /= ty2) )+    ( throwError+      ( "select: objects of different types: \n\+        \object 1: " <> ShortText.pack (show ty1) <> "\n\+        \object 2: " <> ShortText.pack (show ty2) <> "."+      )+    )+  v <- fresh+  resTyID <- typeID ty1+  instruction+    Instruction+      { operation = SPIRV.Op.Select+      , resTy     = Just resTyID+      , resID     = Just v+      , args      = Arg c+                  $ Arg o1+                  $ Arg o2+                  EndArgs+      }+  pure (v, ty1)++selectionMerge :: ID -> Maybe SPIRV.SelectionControl -> CGMonad ()+selectionMerge mergeBlockID mbControl+  = instruction+      Instruction+        { operation = SPIRV.Op.SelectionMerge+        , resTy     = Nothing+        , resID     = Nothing+        , args      = Arg mergeBlockID+                    $ Arg mbControl+                    EndArgs+        }+loopMerge :: ID -> ID -> SPIRV.LoopControl Word32 -> CGMonad ()+loopMerge mergeBlockID loopBlockID loopControl+  = instruction+      Instruction+         { operation = SPIRV.Op.LoopMerge+         , resTy = Nothing+         , resID = Nothing+         , args  = Arg mergeBlockID+                 $ Arg loopBlockID+                 $ Arg loopControl+                 EndArgs+         }++multiWaySwitch :: IntegralTy s => ID -> ID -> [Pair s ID] -> CGMonad ()+multiWaySwitch scrut defBlock ids+  = instruction+      Instruction+        { operation = SPIRV.Op.Switch+        , resTy     = Nothing+        , resID     = Nothing+        , args      = Arg scrut+                    $ Arg defBlock+                    $ toArgs ids+        }++-- | The values of the bindings (satisfying the predicate) at the start of a block,+-- given the bindings at the end of each of its predecessors.+-- Emits ϕ-instructions as necessary.+mergeBindings+  :: ( ShortText -> Bool )+  -> [ ( ID, Map ShortText (ID, SPIRV.PrimTy) ) ]+  -> CGMonad ( Map ShortText (ID, SPIRV.PrimTy) )+mergeBindings isRelevant preds = case preds of+  [] -> pure Map.empty+  [ ( _, bds ) ] -> pure ( Map.filterWithKey ( \ name _ -> isRelevant name ) bds )+  _ -> do+    phis <- phiInstructions isRelevant ( map fst preds ) ( map snd preds )+    let+      common :: Map ShortText (ID, SPIRV.PrimTy)+      common = Map.filterWithKey ( \ name _ -> isRelevant name )+             $ foldr1 Map.intersection ( map snd preds )+    pure ( Map.mapWithKey ( \ name ( ident, ty ) -> ( Map.findWithDefault ident name phis, ty ) ) common )++-- | Update the values of the given bindings.+updateBindings :: Map ShortText (ID, SPIRV.PrimTy) -> CGMonad ()+updateBindings = traverseWithKey_ \ name bd -> assign ( _localBinding name ) ( Just bd )++----------------------------------------------------------------------------+-- code generation for selections (pure or branching)++instance CodeGen AST => CodeGen (SelectionF AST) where++  -- if statement+  codeGenArgs (Applied IfF (c `ConsAST` (t :: Code a) `ConsAST ` f `ConsAST` NilAST)) = do+    ver <- view _spirvVersion+    if canUseSelection (primTy @a) ver+    then selection c        t         f+    else ifM       c (UCode t) (UCode f)+      where+        canUseSelection :: SPIRV.PrimTy -> SPIRV.Version -> Bool+        canUseSelection (SPIRV.Scalar    _) _ = True+        canUseSelection (SPIRV.Pointer _) _ = True+        canUseSelection ty ver+          | ver < SPIRV.Version 1 4 = False+          | SPIRV.Matrix {} <- ty   = True+          | SPIRV.Vector {} <- ty   = True+          | SPIRV.Array  {} <- ty   = True+          | SPIRV.Struct {} <- ty   = True+          | otherwise               = False++  -- monadic if statement+  codeGenArgs (Applied IfMF (c `ConsAST` t `ConsAST ` f `ConsAST` NilAST)) = ifM c (UCode t) (UCode f)++  -- switch statement+  codeGenArgs (Applied (SwitchF scrut def cases) NilAST) =+    codeGen+      ( SwitchMF+       ( Return :$ scrut )+       ( Return :$ def   )+       ( map (second (Return :$)) cases )+      )++  -- monadic switch statement+  codeGenArgs (Applied (SwitchMF scrut def cases) NilAST) = switch scrut def (map (second UCode) cases)+++selection :: ( CodeGen AST, Nullary a ) => Code Bool -> AST a -> AST a -> CGMonad (ID, SPIRV.PrimTy)+selection cond x y = do+  (condID, condTy) <- codeGen cond+  ( whenAsserting . unless ( condTy == SPIRV.Boolean) )+    ( throwError+    $  "codeGen: ASSERT failed, 'select' expected boolean conditional, but got "+    <> ShortText.pack (show condTy)+    )+  o1 <- codeGen x+  o2 <- codeGen y+  select condID o1 o2++ifM :: ( CodeGen AST, Nullary b ) => AST b -> UCode -> UCode -> CGMonad (ID, SPIRV.PrimTy)+ifM cond bodyTrue bodyFalse+  = branchingSelection conditionalHeader [bodyTrue, bodyFalse]+      where+        conditionalHeader :: [ID] -> ID -> CGMonad ()+        conditionalHeader [trueBlockID, falseBlockID] mergeBlockID = do+          (condID, condTy) <- locally (codeGen cond)+          ( whenAsserting . unless ( condTy == SPIRV.Boolean ) )+            ( throwError+            $  "codeGen: ASSERT failed, 'if' expected boolean conditional, but got "+            <> ShortText.pack (show condTy)+            )+          selectionMerge mergeBlockID SPIRV.NoSelectionControl+          branchConditional condID trueBlockID falseBlockID+        conditionalHeader ids _ =+          throwError+            ( "codeGen: if statement with "+            <> ShortText.pack ( show ( length ids ))+            <> " branches"+            )++switch :: ( CodeGen AST, IntegralTy t, Nullary s, Nullary a)+       => AST s -> AST a -> [(t, UCode)] -> CGMonad (ID, SPIRV.PrimTy)+switch scrut def cases+  = branchingSelection switchHeader (UCode def : map snd cases)+      where+        switchHeader :: [ID] -> ID -> CGMonad ()+        switchHeader [] _ = whenAsserting (throwError "codeGen: ASSERT failed, 'switch' statement missing default case")+        switchHeader ( defaultBlockID : caseBlockIDs ) mergeBlockID = do+          (scrutID, _) <- locally (codeGen scrut)+          selectionMerge mergeBlockID SPIRV.NoSelectionControl+          multiWaySwitch scrutID defaultBlockID+            (zipWith ( \(t,_) i -> Pair (t,i) ) cases caseBlockIDs)++branchingSelection :: CodeGen AST => ( [ID] -> ID -> CGMonad () ) -> [ UCode ] -> CGMonad (ID, SPIRV.PrimTy)+branchingSelection mkHeader cases = do+  live           <- inReachableCode+  headerBlockID  <- fresh+  caseBlockIDs   <- traverse (\x -> (,x) <$> fresh) cases+  mergeBlockID   <- fresh+  bindingsBefore <- use _localBindings++  -- header block+  when live do+    branch headerBlockID+    block  headerBlockID+  mkHeader ( map fst caseBlockIDs ) mergeBlockID++  -- code generation for each of the cases+  results <-+    for caseBlockIDs \ (caseBlockID, UCode caseBody) -> do+      ( ( bodyRes, mbEndBlock ), env ) <- scoped do+        when live ( block caseBlockID )+        bodyRes    <- codeGen caseBody+        mbEndBlock <- currentBlockID+        branch mergeBlockID+        pure ( bodyRes, mbEndBlock )+      pure ( bodyRes, ( , localBindings env ) <$> mbEndBlock )++  ( firstRes, resType ) <- case results of+    [] -> throwError "codeGen: empty list of branches in conditional"+    ( ( firstRes@( _, ty ), _ ) : others )+      -> do ( whenAsserting . unless ( all ( ( == ty ) . snd . fst ) others ) )+              ( throwError "codeGen: ASSERT failed, branches of conditional return different types" )+            pure ( firstRes, ty )+  let+    -- the cases which branch to the merge block+    preds :: [ ( ID, ( (ID, SPIRV.PrimTy), Map ShortText (ID, SPIRV.PrimTy) ) ) ]+    preds = [ ( endBlock, ( bodyRes, bds ) ) | ( bodyRes, Just ( endBlock, bds ) ) <- results ]++  if not live+  then pure firstRes -- (unreachable code)+  else do+    -- merge block+    block mergeBlockID+    case preds of+      [] -> do+        -- No case reaches the merge block: the code that follows is unreachable.+        unreachable+        pure firstRes+      _  -> do+        -- emit the appropriate ϕ-instructions, and update the bindings+        updateBindings+          =<< mergeBindings ( `Map.member` bindingsBefore ) [ ( b, bds ) | ( b, ( _, bds ) ) <- preds ]+        -- return the result+        if resType == SPIRV.Unit+        then pure (ID 0, resType) -- ID should never be used+        else do+          res <- fresh+          phiInstruction+            ( res, resType )+            [ Pair ( resID, b ) | ( b, ( ( resID, _ ), _ ) ) <- preds ]+          pure (res, resType)++----------------------------------------------------------------------------+-- code generation for loops++instance CodeGen AST => CodeGen (LoopF AST) where+  codeGenArgs ( Applied WhileF ( c `ConsAST` body `ConsAST` NilAST ) ) = while ( Just c ) body+  codeGenArgs ( Applied LoopF              ( body `ConsAST` NilAST ) ) = while ( Nothing :: Maybe ( AST ( Val Bool ) ) ) body+  codeGenArgs ( Applied ( BreakF         ( _ :: Proxy n ) ) NilAST   ) = break ( knownValue @n )+  codeGenArgs ( Applied ( BreakContinueF ( _ :: Proxy n ) ) NilAST   ) = breakContinue ( knownValue @n )++-- | Code generation for a loop (with an optional condition in the loop header).+--+-- Every modifiable binding gets a ϕ-instruction in the loop header. Its operand for the+-- back edge is only known after generating code for the loop body, which refers to the+-- ϕ-instruction: we tie the knot lazily.+while :: ( CodeGen AST, Nullary c, Nullary b ) => Maybe ( AST c ) -> AST b -> CGMonad (ID, SPIRV.PrimTy)+while mbCond loopBody = do+  mbBefore <- currentBlockID+  case mbBefore of+    Nothing            -> unreachableLoop+    Just beforeBlockID -> reachableLoop beforeBlockID+  pure (ID 0, SPIRV.Unit) -- ID should never be used++  where++    -- (generates code only to obtain the results; nothing is emitted)+    unreachableLoop :: CGMonad ()+    unreachableLoop = do+      loopIDs <- LoopBlockIDs <$> fresh <*> fresh+      _ <- scoped $ withLoopFrame loopIDs do+        for_ mbCond ( locally . codeGen )+        inLoopBodyScope ( codeGen loopBody )+      pure ()++    reachableLoop :: ID -> CGMonad ()+    reachableLoop beforeBlockID = mdo+      headerBlockID   <- fresh+      loopBlockID     <- fresh+      mergeBlockID    <- fresh -- block where control flow merges back+      continueBlockID <- fresh -- block at the end of the loop body from which we can continue for further loops+      branch headerBlockID++      -- Header block.+      block headerBlockID+      bindingsBefore <- use _localBindings+      writable       <- use _writableBindings+      let+        -- Bindings that the loop might modify.+        loopCarried :: Map ShortText (ID, SPIRV.PrimTy)+        loopCarried = bindingsBefore `Map.restrictKeys` writable++        -- value of a binding at the end of the continue block (see below)+        continueEndID :: ShortText -> ID+        continueEndID name =+          maybe+            ( error $ "codeGen: binding " <> ShortText.unpack name <> " missing at the end of a loop" )+            fst+            ( Map.lookup name continueEnd )+      headerPhis <-+        Map.traverseWithKey+          ( \ name ( beforeID, ty ) -> do+            v <- fresh+            -- NB: the second operand must not be forced during code generation.+            phiInstruction ( v, ty )+              [ Pair ( beforeID          , beforeBlockID   )+              , Pair ( continueEndID name, continueBlockID )+              ]+            pure ( v, ty )+          )+          loopCarried+      updateBindings headerPhis++      loopMerge mergeBlockID continueBlockID SPIRV.NoLoopControl+      -- The loop frame collects the early exits from the condition and the body.+      ( ( headerEndBindings, mbHeaderEndBlockID, mbCondID, mbBodyEndBlock, bodyEndBindings ), loopExits ) <-+        withLoopFrame ( LoopBlockIDs { continueBlockID, mergeBlockID } ) do++          -- Condition.+          mbCondition <- case mbCond of+            Nothing -> do+              branch loopBlockID+              pure Nothing+            Just cond -> do+              -- The condition gets its own block, as it might contain control flow.+              condBlockID <- fresh+              branch condBlockID+              block condBlockID+              (condID, condTy) <- locally (codeGen cond)+              ( whenAsserting . when ( condTy /= SPIRV.Boolean ) )+                ( throwError+                $  "codeGen: ASSERT failed, while loop expected boolean conditional, but got "+                <> ShortText.pack (show condTy)+                )+              pure ( Just condID )+          condEndBindings <- use _localBindings+          mbCondEndBlock  <- currentBlockID+          for_ mbCondition \ condID -> branchConditional condID loopBlockID mergeBlockID++          -- Loop body.+          ( mbEndBlock, env ) <- inLoopBodyScope $ scoped do+            block loopBlockID+            _ <- codeGen loopBody+            mbEndBlock <- currentBlockID+            branch continueBlockID+            pure mbEndBlock+          pure ( condEndBindings, mbCondEndBlock, mbCondition, mbEndBlock, localBindings env )++      -- Continue block.+      block continueBlockID+      let+        continuePreds :: [ ( ID, Map ShortText (ID, SPIRV.PrimTy) ) ]+        continuePreds+          =  [ ( b, bodyEndBindings ) | Just b <- [ mbBodyEndBlock ] ]+          ++ [ ( b, bds ) | ( b, ( ContinueLoop, bds ) ) <- Map.toList loopExits ]+      for_ continuePreds \ ( _, bds ) ->+        unless ( Map.keysSet loopCarried `Set.isSubsetOf` Map.keysSet bds ) $+          throwError "codeGen: early exit from a scope in which bindings modified by the loop are not visible"+      continueEnd <- case continuePreds of+        -- unreachable continue block: use the ϕ-instructions themselves+        [] -> pure headerPhis+        _  -> mergeBindings ( `Map.member` loopCarried ) continuePreds+      branch headerBlockID++      -- Merge block (first block after the loop).+      block mergeBlockID+      let+        -- with the early exit that remains to be performed (if any)+        mergePreds :: [ ( ID, Maybe EarlyExit, Map ShortText (ID, SPIRV.PrimTy) ) ]+        mergePreds+          =  [ ( b, Nothing, headerEndBindings ) | isJust mbCondID, Just b <- [ mbHeaderEndBlockID ] ]+          ++ [ ( b, mbEarlyExit, bds ) | ( b, ( ExitLoop mbEarlyExit, bds ) ) <- Map.toList loopExits ]+      case mergePreds of+        -- Nothing exits the loop: the code that follows is unreachable.+        [] -> unreachable+        _  -> do+          updateBindings+            =<< mergeBindings ( `Map.member` bindingsBefore ) [ ( b, bds ) | ( b, _, bds ) <- mergePreds ]+          continueEarlyExits [ ( b, mbEarlyExit ) | ( b, mbEarlyExit, _ ) <- mergePreds ]++-- | Perform the remaining early exits from the merge block of a loop,+-- given the predecessors of the merge block and the early exit that remains for each.+--+-- Emits ϕ-instructions: must be called at the start of the merge block.+continueEarlyExits :: [ ( ID, Maybe EarlyExit ) ] -> CGMonad ()+continueEarlyExits preds = do+  let+    -- Selector value for each early exit to perform (0 for none).+    selectors :: Map EarlyExit Word32+    selectors = Map.fromList $ zip ( Set.toList . Set.fromList $ [ ee | ( _, Just ee ) <- preds ] ) [ 1 .. ]+  unless ( null selectors ) do+    selectorID <- fresh+    selectorValues <-+      traverse+        ( \ ( b, mbEarlyExit ) -> ( , b ) <$> constID ( maybe 0 ( selectors Map.! ) mbEarlyExit ) )+        preds+    phiInstruction ( selectorID, primTy @Word32 ) ( map Pair selectorValues )+    caseBlockIDs <- traverse ( const fresh ) selectors+    afterBlockID <- fresh+    selectionMerge afterBlockID SPIRV.NoSelectionControl+    multiWaySwitch selectorID afterBlockID+      ( Map.elems $ Map.intersectionWith ( \ i caseBlockID -> Pair ( i, caseBlockID ) ) selectors caseBlockIDs )+    traverseWithKey_ ( \ ee caseBlockID -> block caseBlockID *> earlyExit ee ) caseBlockIDs+    block afterBlockID++-- | Break out of the given number of loops.+break :: Word32 -> CGMonad (ID, SPIRV.PrimTy)+break 0 = pure (ID 0, SPIRV.Unit) -- ID should never be used+break nbLoopsToBreak = do+  depth <- loopDepth+  when ( depth < fromIntegral nbLoopsToBreak ) $+    throwError+      ( "codeGen: 'break' statement inside too few loops.\n\+        \breaking " <> ShortText.pack ( show nbLoopsToBreak ) <> " loops,\n\+        \but only inside " <> ShortText.pack ( show depth ) <> " loops."+      )+  earlyExit ( Break nbLoopsToBreak )+  pure (ID 0, SPIRV.Unit) -- ID should never be used++-- | Break out of the given number of loops, and then continue to the next iteration+-- of the enclosing loop.+breakContinue :: Word32 -> CGMonad (ID, SPIRV.PrimTy)+breakContinue nbLoopsToBreak = do+  depth <- loopDepth+  when ( depth <= fromIntegral nbLoopsToBreak ) $+    throwError+      ( "codeGen: 'breakContinue' statement inside too few loops.\n\+        \continuing from start of loop after breaking " <> ShortText.pack ( show nbLoopsToBreak ) <> " loops,\n\+        \but only inside " <> ShortText.pack ( show depth ) <> " loops."+      )+  earlyExit ( BreakContinue nbLoopsToBreak )+  pure (ID 0, SPIRV.Unit) -- ID should never be used++-- | Perform an early exit.+--+-- Structured control flow only allows branching to the continue or merge block of the+-- innermost loop: to exit several loops, we exit the innermost loop, and perform the+-- remaining early exit from its merge block. The same goes for an early exit from the+-- condition of a loop, which is lexically outside of the loop.+earlyExit :: EarlyExit -> CGMonad ()+earlyExit ee = do+  mbLoop <- innermostLoop+  case mbLoop of+    Nothing -> throwError "codeGen: early exit outside of a loop"+    Just ( LoopBlockIDs { continueBlockID, mergeBlockID }, inBody ) -> do+      let+        ( loopExit, destBlockID ) = case ee of+          _ | not inBody  -> ( ExitLoop ( Just ee )                         , mergeBlockID    )+          BreakContinue 0 -> ( ContinueLoop                                 , continueBlockID )+          BreakContinue n -> ( ExitLoop ( Just ( BreakContinue ( n - 1 ) ) ), mergeBlockID    )+          Break n+            | n <= 1      -> ( ExitLoop Nothing                             , mergeBlockID    )+            | otherwise   -> ( ExitLoop ( Just ( Break ( n - 1 ) ) )        , mergeBlockID    )+      mbBlock <- currentBlockID+      for_ mbBlock \ currentBlock -> do+        currentBindings <- use _localBindings+        addLoopExit currentBlock loopExit currentBindings+        branch destBlockID++----------------------------------------------------------------------------+-- code-generation for locally / embed++instance CodeGen AST => CodeGen (StateF AST) where+  codeGenArgs (Applied LocallyF (a `ConsAST` NilAST)) =+    locally (codeGen a)+  codeGenArgs (Applied EmbedF   ( ( a :: AST ( Eff i i a ) ) `ConsAST` NilAST)) =+    embed ( Set.fromList $ knownValue @(Keys (Bindings i)) ) (codeGen a)++locally :: CGMonad a -> CGMonad a+locally action = do+  bindingsBefore <- use _localBindings+  ( res, env ) <- scoped action+  let+    bindingsAfter :: Map ShortText (ID, SPIRV.PrimTy)+    bindingsAfter = localBindings env++  -- keep the updated values of local bindings,+  -- but only for bindings that were defined before the "locally" block+  assign _localBindings ( bindingsAfter `Map.intersection` bindingsBefore )++  whenAsserting do+    let+      weirdos :: Map ShortText ( (ID, SPIRV.PrimTy), (ID, SPIRV.PrimTy) )+      weirdos = Map.mapMaybe id+              $ Map.intersectionWith ( \ ( id1, ty1 ) ( id2, ty2 ) -> if ty1 == ty2 then Nothing else Just ( ( id1, ty1 ), ( id2, ty2 ) ) )+                bindingsBefore bindingsAfter+    unless ( null weirdos ) $+      throwError ( "'codeGen': ASSERT failed, error in code-generation for 'locally'\nweirdos = " <> ShortText.pack ( show weirdos ) )++  pure res++embed :: Set ShortText -> CGMonad a -> CGMonad a+embed innerStartNames action = do+  bindingsBefore <- use _localBindings+  ( res, env ) <- scoped do+    assign _localBindings ( Map.restrictKeys bindingsBefore innerStartNames )+    action+  let+    bindingsAfter :: Map ShortText (ID, SPIRV.PrimTy)+    bindingsAfter = localBindings env++    -- discard the updated values of local bindings that shadowed previous bindings+    newBindings :: Map ShortText (ID, SPIRV.PrimTy)+    newBindings =+      Map.mapWithKey+        ( \ name aft -> fromMaybe aft (shadows name innerStartNames bindingsBefore ) )+        (  bindingsAfter `Map.intersection` bindingsBefore+        <> Map.withoutKeys bindingsBefore innerStartNames+        )++  assign _localBindings newBindings+  pure res++shadows :: ShortText -> Set ShortText -> Map ShortText (ID, SPIRV.PrimTy) -> Maybe (ID, SPIRV.PrimTy)+shadows name innerStartNames prevs+  | not ( name `Set.member` innerStartNames )+  , Just prev <- Map.lookup name prevs+  = Just prev+  | otherwise+  = Nothing
+ src/CodeGen/CodeGen.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE BlockArguments       #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DerivingVia          #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE PatternSynonyms      #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE TupleSections        #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: CodeGen.CodeGen++Main code generation function: dispatches code generation on the constructors of the AST.+-}++module CodeGen.CodeGen+  ( CodeGen(codeGenArgs), codeGen, runCodeGen )+  where++-- base+import Prelude+  hiding ( Monad(..) )+import Data.Kind+  ( Type )+import Data.Proxy+  ( Proxy )+import Data.Type.Equality+  ( (:~:)(Refl) )+import qualified GHC.Stack+  ( callStack )+import Unsafe.Coerce+  ( unsafeCoerce )++-- bytestring+import Data.ByteString.Lazy+  ( ByteString )++-- mtl+import Control.Monad.Except+  ( throwError )++-- text-short+import Data.Text.Short+  ( ShortText )++-- variant+import Data.Variant.VariantF+  ( VariantF, ApplyAll, BottomUp(toBottomUp) )+import Data.Variant.EGADT+  ( EGADT(..), HVariantF(..) )++-- fir+import CodeGen.Application+  ( Application(Applied)+  , pattern Nullary+  , ASTs(NilAST, ConsAST)+  )+import CodeGen.Applicative+  ( ) -- CodeGen instances for Ap, Pure+import CodeGen.Binary+  ( putModule )+import CodeGen.CFG+  ( locally ) -- + CodeGen instances for If, IfM, Switch, SwitchM, While, Locally, Embed+import CodeGen.Composite+  ( ) -- CodeGen instances for MkVector, Mat, UnMat, Struct, Array, GradedMappend+import CodeGen.Debug+  ( whenDebugging, putSrcInfo ) -- CodeGen instance for DebugPrintF+import CodeGen.Functions+  ( ) -- CodeGen instances for FunDef, FunCall, DefEntryPoint+import CodeGen.IDs+  ( constID, undefID )+import CodeGen.Images+  ( )  -- CodeGen instances for image operands+import CodeGen.Instruction+  ( ID, Pointer(..) )+import CodeGen.Pointers+  ( newVariable, store )+import CodeGen.PrimOps+  ( ) -- CodeGen instance for PrimOp+import CodeGen.RayTracing+  ( ) -- Codegen instances for TraceRay, ExecuteCallable, RayQuery+import CodeGen.Monad+  ( CGMonad, runCGMonad+  , runExceptTPutM+  )+import CodeGen.Optics+  ( ) -- CodeGen for View, Set, Use, Assign+import CodeGen.State+  ( CGState, CGContext+  , initialState+  , currentFunctionContext+  , defineLocalBinding+  )+import Data.Type.Known+  ( knownValue )+import FIR.AST+  ( AST+  , pattern (:$), pattern Lam, pattern MkID+  , AppF(..), LamF(..), LitF(..), MkIDF(..), ValueF(..)+  , IxMonadF(..)+  , LetF(..), DefF(..), UnsafeCoerceF(..)+  , HListF(..)+  , UndefinedF(..)+  )+import FIR.AST.Type+  ( AugType(Val, (:-->)), FunArgs, Nullary )+import FIR.Binding+  ( Permission(Write) )+import FIR.Prim.Types+  ( primTy )+import FIR.ProgramState+  ( FunctionContext(TopLevel) )+import FIR.Syntax.AST+  ( )+import qualified SPIRV.PrimTy  as SPIRV++----------------------------------------------------------------------------+-- run the code generator with given context to create a SPIR-V module++runCodeGen :: Nullary a => CGContext -> AST a -> Either ShortText (ByteString, CGState)+runCodeGen context ast+  = case runCGMonad context (initialState context) (codeGen ast) of++      Right (_, cgState, body)+        -> case runExceptTPutM $ putModule context cgState of+              Right ((), decs) -> Right ( decs <> body, cgState )+              Left err         -> Left err++      Left err -> Left err++----------------------------------------------------------------------------+-- typeclass to dispatch code generation on AST constructors++class CodeGen (ast :: AugType -> Type) where+  codeGenArgs :: Nullary r => Application ast f r -> CGMonad (ID, SPIRV.PrimTy)++codeGen :: ( CodeGen ast, Nullary v ) => ast v -> CGMonad (ID, SPIRV.PrimTy)+codeGen v = codeGenArgs (Nullary v)++instance BottomUp CodeGen vs => CodeGen (VariantF vs) where+  codeGenArgs (Applied f args) =+    toBottomUp @CodeGen ( \x -> codeGenArgs $ Applied x args ) f++deriving via VariantF ( ApplyAll (EGADT vs :: AugType -> Type) vs )+  instance BottomUp CodeGen ( ApplyAll (EGADT vs) vs )+        => CodeGen (EGADT vs)++----------------------------------------------------------------------------+-- some instances++instance CodeGen AST => CodeGen (LamF AST) where+  codeGenArgs (Applied (LamF f) (a `ConsAST` as)) = do+    cg <- codeGen a+    codeGenArgs ( Applied ( f (MkID cg) ) as )++instance CodeGen (LitF AST) where+  codeGenArgs (Applied (LitF (a :: ty)) NilAST) = ( , primTy @ty ) <$> constID a++instance CodeGen AST => CodeGen (MkIDF AST) where+  codeGenArgs (Applied (MkIDF idTy) NilAST) = pure idTy++-- TODO: "Value" should not be a constructor of the AST+-- we should internally change the AST to add the Value constructor when doing evaluation+instance CodeGen (ValueF AST) where+  codeGenArgs _ = throwError "codeGen: unsupported embedded value"++instance CodeGen AST => CodeGen (AppF AST) where+  codeGenArgs (Applied (AppF (Lam f) a) as) = codeGenArgs (Applied (f a) as)+  codeGenArgs (Applied (AppF f a) as) = codeGenArgs (Applied f (a `ConsAST` as))++instance CodeGen AST => CodeGen (IxMonadF AST) where++  codeGenArgs (Applied ReturnF (a `ConsAST` NilAST)) = codeGen a++  codeGenArgs (Applied BindF (a `ConsAST` f `ConsAST` as))+    | ( _ :: AST ( Val a :--> q j ) ) <- f+    , Refl <- ( unsafeCoerce Refl :: FunArgs (q j) :~: '[] )+    = do+      cg <- codeGen a+      codeGenArgs ( Applied ( f :$ MkID cg ) as )++instance CodeGen AST => CodeGen (UnsafeCoerceF AST) where+  codeGenArgs ( Applied UnsafeCoerceF (a `ConsAST` NilAST) ) = codeGenArgs ( Nullary a )++instance CodeGen AST => CodeGen (UndefinedF AST) where+  codeGenArgs ( Applied undef@UndefinedF NilAST ) = case undef of+    ( _ :: UndefinedF AST ( Val a ) ) ->+      let undefTy = primTy @a+      in ( , undefTy ) <$> undefID undefTy++instance CodeGen AST => CodeGen (HListF AST) where+  codeGenArgs _ = throwError "codeGen: internal error, cannot generate code for HList operations"++instance CodeGen AST => CodeGen (LetF AST) where+  codeGenArgs (Applied LetF (a `ConsAST` NilAST)) = locally (codeGen a)++instance CodeGen AST => CodeGen (DefF AST) where+  codeGenArgs (Applied (DefF (_ :: Proxy name) (_ :: Proxy ps)) (a `ConsAST` NilAST)) = do+    let name     = knownValue @name+        writable = Write `elem` (knownValue @ps)+    whenDebugging ( putSrcInfo GHC.Stack.callStack )+    cgRes@(a_ID, a_ty) <- codeGen a++    -- check if we should make this into a pointer or not+    let+      makeMutable =+        case a_ty of+          SPIRV.Array        {} -> writable+          SPIRV.RuntimeArray {} -> writable -- should never happen, user cannot define runtime arrays+          SPIRV.Struct       {} -> writable+          _                     -> False++    if makeMutable+    then do+      ctx <- currentFunctionContext+      case ctx of+        TopLevel ->+          throwError ( "codeGen: cannot define mutable variable " <> name <> " at the top level" )+        _ -> pure ()+      ptr@( Pointer ptrID ptrTy ) <- newVariable a_ty+      store name ptr a_ID+      defineLocalBinding name (ptrID, SPIRV.Pointer ptrTy) False+    else+      defineLocalBinding name cgRes writable+    pure cgRes
+ src/CodeGen/CodeGen.hs-boot view
@@ -0,0 +1,31 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}++module CodeGen.CodeGen where++-- base+import Data.Kind+  ( Type )++-- fir+import CodeGen.Application+  ( Application )+import CodeGen.Instruction+  ( ID )+import CodeGen.Monad+  ( CGMonad )+import FIR.AST.Type+  ( AugType, Nullary )+import qualified SPIRV.PrimTy as SPIRV++----------------------------------------------------------------------------+-- export the 'CodeGen' type class and instance for the AST+-- this allows auxiliary code generation code to recursively call 'codeGen'++class CodeGen (ast :: AugType -> Type) where+  codeGenArgs :: Nullary r => Application ast f r -> CGMonad (ID, SPIRV.PrimTy)++codeGen :: ( CodeGen f, Nullary a ) => f a -> CGMonad (ID, SPIRV.PrimTy)
+ src/CodeGen/Composite.hs view
@@ -0,0 +1,412 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE TypeApplications    #-}++{-|+Module: CodeGen.Composite++Code generation for composite objects (vectors, matrices, arrays and structures): construction and extraction.+-}++module CodeGen.Composite+  ( compositeConstruct+  , compositeInsert, compositeExtract+  , accessedTy, accessedLaidOutTy+  , vectorShuffle, vectorSwizzle+  , productConstruct+  )+  where++-- base+import Data.Foldable+  ( toList )+import Data.Proxy+  ( Proxy )+import Data.Word+  ( Word32 )+import GHC.TypeNats+  ( natVal )++-- mtl+import Control.Monad.Except+  ( throwError )++-- split+import Data.List.Split+  ( chunksOf )++-- text-short+import Data.Text.Short+  ( ShortText )+import qualified Data.Text.Short as ShortText+  ( pack )++-- vector-sized+import qualified Data.Vector.Sized as Vector+  ( toList, knownLength' )++-- fir+import CodeGen.Application+  ( Application(Applied)+  , pattern Nullary+  , ASTs(NilAST, ConsAST)+  )+import CodeGen.Binary+  ( instruction )+import {-# SOURCE #-} CodeGen.CodeGen+  ( CodeGen(codeGenArgs), codeGen )+import CodeGen.Debug+  ( whenAsserting )+import CodeGen.IDs+  ( bindingID, typeID, undefID )+import CodeGen.Instruction+  ( Args(..), toArgs+  , ID, Instruction(..)+  )+import CodeGen.Monad+  ( CGMonad, MonadFresh(fresh), note )+import Data.Type.Known+  ( knownValue )+import FIR.AST+  ( AST+  , MkVectorF(..), GradedMappendF(..)+  , MatF(..)+  , StructF(..), ArrayF(..), ArrayLengthF(..)+  )+import FIR.AST.Type+  ( AugType(Val) )+import FIR.Prim.Array+  ( Array(MkArray) )+import FIR.Prim.Struct+  ( traverseStructASTs )+import FIR.Prim.Types+  ( primTy )+import Math.Linear+  ( V )+import qualified SPIRV.Layout    as SPIRV+import qualified SPIRV.Operation as SPIRV.Op+import qualified SPIRV.PrimTy    as SPIRV+import           SPIRV.PrimTy+  ( PrimTy(..) )+import qualified SPIRV.ScalarTy as SPIRV+  ( ScalarTy(..), Signedness(..), Width(..) )++----------------------------------------------------------------------------+-- Code generation for constructing composite objects.++instance CodeGen AST => CodeGen (MkVectorF AST) where+  codeGenArgs ( Applied (MkVectorF (vec :: V n (AST (Val a))) ) NilAST ) = do+    let n = knownValue @n+    compositeTy <- case primTy @a of+      SPIRV.Scalar s ->+        pure $ SPIRV.Vector n (SPIRV.Scalar s)+      SPIRV.Vector m (SPIRV.Scalar s) ->+        pure $ SPIRV.Matrix m n s+      x ->+        throwError+          ( "codeGen: unexpected vector constituent "+          <> ShortText.pack ( show x )+          )+    ( compositeConstruct compositeTy . map fst . toList )+      =<< traverse codeGen vec++instance CodeGen AST => CodeGen (MatF AST) where+  codeGenArgs ( Applied MatF   (a `ConsAST` NilAST) ) = codeGenArgs ( Nullary a )+  codeGenArgs ( Applied UnMatF (a `ConsAST` NilAST) ) = codeGenArgs ( Nullary a )++instance CodeGen AST => CodeGen (StructF AST) where+  codeGenArgs ( Applied structF@(StructF struct) NilAST ) = case structF of+    ( _ :: StructF AST (Val struct) ) ->+      compositeConstruct (primTy @struct)+        =<< traverseStructASTs @AST (fmap fst . codeGen) struct++instance CodeGen AST => CodeGen (ArrayF AST) where+  codeGenArgs ( Applied arrF@(ArrayF (MkArray vec)) NilAST ) = case arrF of+    ( _ :: ArrayF AST (Val (Array n a)) ) ->+      let+        n :: Word32+        n = Vector.knownLength' vec ( fromIntegral . natVal )+        arrTy :: SPIRV.PrimTy+        arrTy = SPIRV.Array n ( primTy @a )+      in+        compositeConstruct arrTy+          =<< traverse (fmap fst . codeGen) (Vector.toList vec)++instance CodeGen (ArrayLengthF AST) where+  codeGenArgs ( Applied (ArrayLengthF (_ :: Proxy structName) (_ :: Proxy pos)) NilAST ) = do+    let+      structName :: ShortText+      structName = knownValue @structName+      arrayPos :: Word32+      arrayPos = knownValue @pos+    (structBdID, _) <- bindingID structName+    let+      word32Ty :: SPIRV.PrimTy+      word32Ty = SPIRV.Scalar ( SPIRV.Integer SPIRV.Unsigned SPIRV.W32 )+    word32TyID <- typeID word32Ty+    v <- fresh+    instruction+      Instruction+        { operation = SPIRV.Op.ArrayLength+        , resTy = Just word32TyID+        , resID = Just v+        , args  = Arg structBdID+                $ Arg arrayPos+                $ EndArgs+        }+    pure ( v, word32Ty )++instance CodeGen AST => CodeGen (GradedMappendF AST) where+  codeGenArgs ( Applied GradedMappendF ( a `ConsAST` b `ConsAST` NilAST ) ) = do+    (a_ID, a_ty) <- codeGen a+    (b_ID, b_ty) <- codeGen b+    case (a_ty, b_ty) of+      ( SPIRV.Vector i (SPIRV.Scalar s), SPIRV.Vector j (SPIRV.Scalar t)) ->+        if s /= t+        then throwError "codeGen: graded semigroup operation on incompatible vectors"+        else compositeConstruct (SPIRV.Vector (i+j) (SPIRV.Scalar s)) [a_ID, b_ID]+      ( SPIRV.Matrix m n s, SPIRV.Matrix m' n' s' ) ->+        if m /= m' || s /= s'+        then throwError "codeGen: graded semigroup operation on incompatible matrices"+        else do+          cols1 <- traverse ( \i -> fst <$> compositeExtract (a_ID, a_ty) [i] ) [0..n -1]+          cols2 <- traverse ( \i -> fst <$> compositeExtract (b_ID, b_ty) [i] ) [0..n'-1]+          compositeConstruct (SPIRV.Matrix m (n+n') s) (cols1 ++ cols2)+      ( SPIRV.Struct as, SPIRV.Struct bs ) ->+        do+          let lg  = fromIntegral (length as)+              lg' = fromIntegral (length bs)+          elts1 <- traverse ( \i -> fst <$> compositeExtract (a_ID, a_ty) [i] ) [0..lg -1]+          elts2 <- traverse ( \i -> fst <$> compositeExtract (b_ID, b_ty) [i] ) [0..lg'-1]+          compositeConstruct+            ( SPIRV.Struct (as ++ bs) )+            ( elts1 ++ elts2 )+      ( SPIRV.Array lg eltTy, SPIRV.Array lg' eltTy' ) ->+        if eltTy /= eltTy'+        then throwError "codeGen: graded semigroup operation on incompatible arrays"+        else do+          -- should probably use a loop instead of this, but nevermind+          elts1 <- traverse ( \i -> fst <$> compositeExtract (a_ID, a_ty) [i] ) [0..lg -1]+          elts2 <- traverse ( \i -> fst <$> compositeExtract (b_ID, b_ty) [i] ) [0..lg'-1]+          compositeConstruct+            ( SPIRV.Array (lg + lg') eltTy )+            ( elts1 ++ elts2 )+      _ -> throwError "codeGen: unsupported graded semigroup operation"++----------------------------------------------------------------------------+-- SPIR-V instructions.++compositeConstruct :: SPIRV.PrimTy -> [ ID ] -> CGMonad (ID, SPIRV.PrimTy)+compositeConstruct compositeType constituents+  = do tyID <- typeID compositeType+       v <- fresh+       instruction+         Instruction+           { operation = SPIRV.Op.CompositeConstruct+           , resTy = Just tyID+           , resID = Just v+           , args  = toArgs constituents+           }+       pure (v, compositeType)++compositeExtract+  :: (ID, SPIRV.PrimTy)+  -> [ Word32 ]+  -> CGMonad (ID, SPIRV.PrimTy)+compositeExtract (compositeID, compositeTy) indices+  = do+      constituentTy <-+          note ( "'compositeExtract': could not compute accessee type.\n\+                 \base: " <> ShortText.pack (show compositeTy) <> "\n\+                 \indices: " <> ShortText.pack (show indices) <> "."+               )+          ( accessedTy ( fmap Just indices ) compositeTy )+      constituentTyID <- typeID constituentTy+      v <- fresh+      instruction+        Instruction+          { operation = SPIRV.Op.CompositeExtract+          , resTy     = Just constituentTyID+          , resID     = Just v+          , args      = Arg compositeID+                      $ toArgs indices+          }+      pure (v, constituentTy)++compositeInsert+  :: (ID, SPIRV.PrimTy)+  -> (ID, SPIRV.PrimTy)+  -> [ Word32 ]+  -> CGMonad (ID, SPIRV.PrimTy)+compositeInsert (inserteeID, inserteeTy) (compositeID, compositeTy) indices+  = do+      compositeTyID <- typeID compositeTy+      constituentTy <-+          note ( "'compositeInsert': could not compute constituent type.\n\+                 \base: " <> ShortText.pack (show compositeTy) <> "\n\+                 \indices: " <> ShortText.pack (show indices) <> "."+               )+          ( accessedTy ( fmap Just indices ) compositeTy )+      constituentTyID <- typeID constituentTy+      correctInserteeID <-+        if constituentTy == inserteeTy+        then pure inserteeID+        else do+          u <- fresh+          instruction+            Instruction+               { operation = SPIRV.Op.BitCast+               , resTy     = Just constituentTyID+               , resID     = Just u+               , args      = Arg inserteeID EndArgs+               }+          pure u+      v <- fresh+      instruction+        Instruction+          { operation = SPIRV.Op.CompositeInsert+          , resTy     = Just compositeTyID+          , resID     = Just v+          , args      = Arg correctInserteeID+                      $ Arg compositeID+                      $ toArgs indices+          }+      pure (v, compositeTy)+++-- | The type of the component at the given indices of a value of the given type.+accessedTy :: [ Maybe Word32 ] -> SPIRV.PrimTy -> Maybe SPIRV.PrimTy+accessedTy is ty = snd <$> accessedLaidOutTy is ( SPIRV.logical, ty )++-- | The type of the component at the given indices of a type with the given layout,+-- together with the layout of that component.+accessedLaidOutTy :: [ Maybe Word32 ] -> ( SPIRV.Layout, SPIRV.PrimTy ) -> Maybe ( SPIRV.Layout, SPIRV.PrimTy )+accessedLaidOutTy []       base             = Just base+accessedLaidOutTy (i : is) ( lay, baseTy ) = do+  compTy <- componentTy i baseTy+  accessedLaidOutTy is ( SPIRV.componentLayout baseTy lay, compTy )+    where+      componentTy :: Maybe Word32 -> SPIRV.PrimTy -> Maybe SPIRV.PrimTy+      componentTy _        (SPIRV.Vector         {eltTy}) = Just eltTy+      componentTy _        (SPIRV.Matrix {rows, entryTy}) = Just (SPIRV.Vector rows (SPIRV.Scalar entryTy))+      componentTy _        (SPIRV.Array          {eltTy}) = Just eltTy+      componentTy _        (SPIRV.RuntimeArray   {eltTy}) = Just eltTy+      componentTy (Just j) (SPIRV.Struct        {eltTys})+        | j' < length eltTys = Just ( snd $ eltTys !! j' )+          where j' = fromIntegral j+      componentTy _ _+        = Nothing++----------------------------------------------------------------------------+-- vector shuffle/swizzle++vectorShuffle :: ( (ID, SPIRV.PrimTy), [Word32] )+              -> ( (ID, SPIRV.PrimTy), [Word32] )+              -> CGMonad (ID, SPIRV.PrimTy)+vectorShuffle ((u_ID, SPIRV.Vector n s), is) ((v_ID, SPIRV.Vector _ t), js)+  | s /= t = throwError "vectorShuffle: incompatible vector components"+  | otherwise =+    do+      v <- fresh+      let indices = is ++ map (+n) js+          shuffleTy = SPIRV.Vector ( fromIntegral (length is + length js) ) s+      shuffleTyID <- typeID shuffleTy+      instruction+        Instruction+          { operation = SPIRV.Op.VectorShuffle+          , resTy     = Just shuffleTyID+          , resID     = Just v+          , args      = Arg u_ID+                      $ Arg v_ID+                      $ toArgs indices+          }+      pure (v, shuffleTy)+vectorShuffle _ _+  = throwError "vectorShuffle used on non-vectors"++vectorSwizzle :: (ID, SPIRV.PrimTy) -> [Word32] -> CGMonad (ID, SPIRV.PrimTy)+vectorSwizzle v@(_, vecTy) is = do+  whenAsserting $+    case vecTy of+      SPIRV.Vector {} -> pure ()+      _ -> throwError ( "vectorSwizzle: ASSERT failed, swizzle on non-vector: " <> ShortText.pack ( show v ) )+  case is of+    []  -> throwError "vectorSwizzle: empty swizzle"+    [i] -> compositeExtract v [i]+    _   -> do+      undef <- (,vecTy) <$> undefID vecTy+      vectorShuffle (v, is) (undef, [])+      -- using 'undefined' here prevents any code duplication that could result from+      -- 'vectorShuffle (v, is) (v, [])'+      -- (e.g. if 'v' is the result of an expensive computation, which could get inlined twice)++----------------------------------------------------------------------------+-- products++-- like 'compositeConstruct', except it checks that the types are correct+-- (for matrices, it constructs the composite in two steps when needed)+productConstruct :: SPIRV.PrimTy -> [ ( ID, SPIRV.PrimTy ) ] -> CGMonad (ID, SPIRV.PrimTy)+productConstruct p as = case p of+  SPIRV.Matrix {..}+    | all ( (== SPIRV.Scalar entryTy) . snd ) as+    && fromIntegral (length as) == rows * cols+    -> do+      columns <- traverse (compositeConstruct colTy . map fst) (chunksOf (fromIntegral rows) as)+      compositeConstruct p (map fst columns)+    | all ( (== colTy) . snd ) as+    && fromIntegral (length as) == cols+    -> compositeConstruct p (map fst as)+    | otherwise+    -> throwError $+    "'productConstruct': type mismatch for constructing matrix\n"+    <> "attempting to construct matrix with " <> ShortText.pack (show rows)+    <> " rows and " <> ShortText.pack (show cols) <> " columns of type "+    <> ShortText.pack (show entryTy) <> ",\n"+    <> "using components of types " <> ShortText.pack (show (map snd as))+      where+        colTy :: SPIRV.PrimTy+        colTy = SPIRV.Vector rows (SPIRV.Scalar entryTy)+  SPIRV.Vector {..}+    | all ( (== eltTy) . snd ) as+    && fromIntegral (length as) == size+    -> compositeConstruct p (map fst as)+    | otherwise+    -> throwError $+    "'productConstruct': type mismatch for constructing vector\n"+    <> "attempting to construct vector with " <> ShortText.pack (show size)+    <> " components of type " <> ShortText.pack (show eltTy) <> ",\n"+    <> "using components of types " <> ShortText.pack (show (map snd as))+  SPIRV.Array {..}+    | all ( (== eltTy) . snd ) as+    && fromIntegral (length as) == size+    -> compositeConstruct p (map fst as)+    | otherwise+    -> throwError $+    "'productConstruct': type mismatch for constructing array\n"+    <> "attempting to construct array of size " <> ShortText.pack (show size)+    <> " with elements of type " <> ShortText.pack (show eltTy) <> ",\n"+    <> "using components of types " <> ShortText.pack (show (map snd as))+  SPIRV.Struct {..}+    | and ( zipWith (\(_, ty1) (_,t2) -> ty1 == t2) eltTys as )+    && length as == length eltTys+    -> compositeConstruct p (map fst as)+    | otherwise+    -> throwError $+    "'productConstruct': type mismatch for constructing structure\n"+    <> "attempting to construct structure with elements of type "+    <> ShortText.pack (show (map snd eltTys)) <> ",\n"+    <> "using components of types " <> ShortText.pack (show (map snd as))+  otherTy+    -> throwError $+    "'productConstruct': unexpected non-product type "+    <> ShortText.pack ( show otherTy )
+ src/CodeGen/Debug.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE BlockArguments    #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications  #-}++{-|+Module: CodeGen.Debug++Functionality for including extra debugging information as comments in SPIR-V modules,+such as including the line numbers of the Haskell source code.+-}++module CodeGen.Debug+  ( whenDebugging, whenAsserting+  , putSrcInfo+  )+  where++-- base+import Control.Monad+  ( when )+import Data.Foldable+  ( for_ )+import Data.Word+  ( Word32 )+import qualified GHC.Stack+import qualified GHC.Stack.Types as GHC.Stack++-- lens+import Control.Lens+  ( view )++-- mtl+import Control.Monad.Reader+  ( MonadReader )++-- text-short+import Data.Text.Short+  ( ShortText )+import qualified Data.Text.Short as ShortText+  ( pack )++-- fir+import CodeGen.Application+  ( Application(Applied)+  , traverseASTs+  )+import CodeGen.Binary+  ( instruction )+import {-# SOURCE #-} CodeGen.CodeGen+  ( CodeGen(codeGenArgs), codeGen )+import CodeGen.IDs+  ( stringLitID, typeID )+import CodeGen.Instruction+  ( ID(..), Args(..), toArgs+  , Instruction(..)+  )+import CodeGen.Monad+  ( MonadFresh(fresh), CGMonad, note )+import CodeGen.State+  ( CGContext+  , _debugging+  , _asserting+  , requireExtension+  , currentBlockID+  )+import FIR.AST+  ( AST, DebugPrintfF(..) )+import FIR.AST.Type+  ( Nullary )+import qualified SPIRV.Extension as SPIRV+import qualified SPIRV.Operation as SPIRV.Op+import qualified SPIRV.PrimTy    as SPIRV++----------------------------------------------------------------------------+-- debug printf++instance CodeGen AST => CodeGen (DebugPrintfF AST) where+  codeGenArgs ( Applied ( DebugPrintfF formatString ) as ) = do+    vals <- traverseASTs @Nullary ( fmap fst . codeGen ) as+    debugPrintf formatString vals++debugPrintf :: ShortText -> [ ID ] -> CGMonad (ID, SPIRV.PrimTy)+debugPrintf formatString vals = do+  whenDebugging do+    requireExtension SPIRV.SPV_KHR_non_semantic_info+    unitTyID <- typeID SPIRV.Unit+    v <- fresh+    formatStringID <- stringLitID formatString+    instruction+      Instruction+        { operation = SPIRV.Op.DebugPrintf+        , resTy = Just unitTyID+        , resID = Just v+        , args  = Arg formatStringID+                $ toArgs vals+        }+  pure (ID 0, SPIRV.Unit) -- ID should not be used++----------------------------------------------------------------------------+-- debugging annotations++whenDebugging :: MonadReader CGContext m => m () -> m ()+whenDebugging action = (`when` action) =<< view _debugging++whenAsserting :: MonadReader CGContext m => m () -> m ()+whenAsserting action = (`when` action) =<< view _asserting++sourceInfo :: GHC.Stack.CallStack -> Maybe (ShortText, Word32, Word32)+sourceInfo GHC.Stack.EmptyCallStack = Nothing+sourceInfo (GHC.Stack.PushCallStack _ loc stack)+  = case sourceInfo stack of+      Nothing+        -> Just ( ShortText.pack $ GHC.Stack.srcLocFile      loc+                , fromIntegral   $ GHC.Stack.srcLocStartLine loc+                , fromIntegral   $ GHC.Stack.srcLocStartCol  loc+                )+      Just info+        -> Just info+sourceInfo (GHC.Stack.FreezeCallStack stack) = sourceInfo stack++putSrcInfo :: GHC.Stack.CallStack -> CGMonad ()+putSrcInfo callstack+  = do+      -- (no debug information outside of blocks)+      mbBlock <- currentBlockID+      for_ mbBlock \ _ -> do+        (fileName, lineNo, colNo)+          <- note "putSrcInfo: cannot find source location \+                  \needed for debug statement"+                  ( sourceInfo callstack )+        fileID <- stringLitID fileName+        instruction+          Instruction+            { operation = SPIRV.Op.Line+            , resTy = Nothing+            , resID = Nothing+            , args  = Arg fileID+                    $ Arg lineNo+                    $ Arg colNo EndArgs+            }
+ src/CodeGen/Functions.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE BlockArguments       #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE PatternSynonyms      #-}+{-# LANGUAGE RecursiveDo          #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TupleSections        #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: CodeGen.Functions++Code generation for function and entry-point definitions, and function calls.+-}++module CodeGen.Functions ( ) where++-- base+import Data.Foldable+  ( traverse_ )+import Data.Maybe+  ( fromMaybe )+import Data.Proxy+  ( Proxy )+import Data.Word+  ( Word32 )+import qualified GHC.Stack+  ( callStack )++-- containers+import qualified Data.Map.Strict as Map++-- lens+import Control.Lens+  ( view, use, assign )++-- text-short+import Data.Text.Short+  ( ShortText )++-- fir+import CodeGen.Application+  ( ASTs(NilAST, ConsAST)+  , Application(Applied)+  , traverseASTs+  )+import CodeGen.Binary+  ( instruction, structuralInstruction, deferredInstructions )+import {-# SOURCE #-} CodeGen.CodeGen+  ( CodeGen(codeGenArgs), codeGen )+import CodeGen.CFG+  ( newBlock )+import CodeGen.Debug+  ( whenDebugging, putSrcInfo )+import CodeGen.IDs+  ( typeID )+import CodeGen.Instruction+  ( Args(..), toArgs+  , ID, TyID+  , Instruction(..)+  , variableDeclaration+  )+import CodeGen.Monad+  ( CGMonad+  , MonadFresh(fresh)+  , note+  , createIDRec+  )+import CodeGen.State+  ( FunctionState(localVariables)+  , _knownBinding+  , defineLocalBinding+  , scoped+  , withFunctionState+  , _interface+  , _entryPoint+  , _userFunction+  , requireCapabilities+  )+import Data.Type.Known+  ( knownValue )+import FIR.AST+  ( AST+  , FunDefF(..), FunCallF(..), DefEntryPointF(..)+  )+import FIR.AST.Type+  ( Nullary )+import FIR.Binding+  ( Permission(Write), Permissions )+import FIR.Prim.Types+  ( primTy, knownVars )+import FIR.ProgramState+  ( FunctionContext(..)+  , VLFunctionContext+  , VLInterface+  )+import qualified SPIRV.Control      as SPIRV+  ( FunctionControl, pattern NoFunctionControl )+import qualified SPIRV.Operation    as SPIRV.Op+import qualified SPIRV.PrimTy       as SPIRV+  ( PrimTy(..) )+import qualified SPIRV.Requirements as SPIRV+  ( executionModelCapabilities )+import qualified SPIRV.Stage        as SPIRV+  ( ExecutionModel, ExecutionInfo+  , modelOf+  )++----------------------------------+-- code-generation for functions and entry points++instance CodeGen AST => CodeGen (FunDefF AST) where+  codeGenArgs (Applied (FunDefF (_ :: Proxy name) (_ :: Proxy as) (_ :: Proxy b)) (body `ConsAST` NilAST)) =+    let as     = knownVars  @as+        retTy  = primTy     @b+        name   = knownValue @name+    in do+      whenDebugging ( putSrcInfo GHC.Stack.callStack )+      control <- fromMaybe SPIRV.NoFunctionControl <$> view ( _userFunction name )+      funID   <- declareFunction name control as retTy (codeGen body)+      pure ( funID , SPIRV.Function (map (fst . snd) as) retTy )++instance CodeGen AST => CodeGen (FunCallF AST) where+  codeGenArgs (Applied (FunCallF (_ :: Proxy name) ( _ :: Proxy as ) ( _ :: Proxy b )) (_ `ConsAST` as)) = do+    let+      funName = knownValue @name+      retTy   = primTy @b+    retTyID <- typeID retTy+    mbFunc <-  use ( _knownBinding funName )+    func <- note+              (  "codeGen: function " <> funName+              <> "\" not bound to any ID."+              )+              mbFunc+    retID <-+      declareFunctionCall+        ( retTyID, retTy )+        func+        =<< traverseASTs @Nullary codeGen as+    pure ( retID, retTy )++instance CodeGen AST => CodeGen (DefEntryPointF AST) where+  codeGenArgs (Applied (DefEntryPointF (_ :: Proxy name) (_ :: Proxy stageInfo)) (body `ConsAST` NilAST))+    = let name      = knownValue @name+          stageInfo = knownValue @stageInfo+      in do+        whenDebugging ( putSrcInfo GHC.Stack.callStack )+        entryPointID <- declareEntryPoint name stageInfo Nothing (codeGen body) -- TODO+        pure ( entryPointID, SPIRV.Function [] SPIRV.Unit )++----------------------------------+-- dealing with function context++inFunctionContext :: ShortText -> [(ShortText, (SPIRV.PrimTy, Permissions))] -> CGMonad a -> CGMonad a+inFunctionContext functionName as+  = inContext ( InFunction functionName as ) as++inEntryPointContext+  :: ShortText+  -> SPIRV.ExecutionInfo Word32 model+  -> Maybe VLInterface+  -> CGMonad a+  -> CGMonad a+inEntryPointContext modelName modelInfo mbIface+  = inContext ( InEntryPoint modelName modelInfo mbIface ) []++inContext :: forall a. VLFunctionContext -> [(ShortText, (SPIRV.PrimTy, Permissions))] -> CGMonad a -> CGMonad a+inContext context as body = mdo+  -- Use 'mdo' (and laziness) to declare local variables used in the function+  -- body (discovered only after generating code for the function body).+  ( ( a, _ ), funState ) <-+    withFunctionState context $ scoped do+      traverse_ (uncurry declareArgument) as+      newBlock+      deferredInstructions+        ( map variableDeclaration ( Map.elems ( localVariables funState ) ) )+      body+  pure a++----------------------------------+-- declaring function instructions++declareFunctionCall :: (TyID, SPIRV.PrimTy)+                    ->   (ID, SPIRV.PrimTy)+                    -> [ (ID, SPIRV.PrimTy) ]+                    -> CGMonad ID+declareFunctionCall res func argIDs+  = do v <- fresh+       instruction+         Instruction+           { operation = SPIRV.Op.FunctionCall+           , resTy = Just (fst res)+           , resID = Just v+           , args  = Arg (fst func)+                   $ toArgs (map fst argIDs)+           }+       pure v++declareFunction :: ShortText+                -> SPIRV.FunctionControl+                -> [(ShortText, (SPIRV.PrimTy, Permissions))]+                -> SPIRV.PrimTy+                -> CGMonad (ID, SPIRV.PrimTy)+                -> CGMonad ID+declareFunction funName control as b body+  = createIDRec ( _knownBinding funName )+      ( do resTyID <- typeID b+           fnTyID  <- typeID funTy+           pure (resTyID, fnTyID)+      )+      ( \(resTyID,fnTyID) v -> do+        structuralInstruction+          Instruction+            { operation = SPIRV.Op.Function+            , resTy     = Just resTyID+            , resID     = Just v+            , args      = Arg control+                        $ Arg fnTyID EndArgs+            }+        (retValID, _) <- inFunctionContext funName as body+        case b of+          SPIRV.Unit+            -> instruction+                 Instruction+                   { operation = SPIRV.Op.Return+                   , resTy = Nothing+                   , resID = Nothing+                   , args  = EndArgs+                   }+          _ -> instruction+                 Instruction+                   { operation = SPIRV.Op.ReturnValue+                   , resTy = Nothing+                   , resID = Just retValID+                   , args  = EndArgs+                   }+        structuralInstruction+          Instruction+            { operation = SPIRV.Op.FunctionEnd+            , resTy     = Nothing+            , resID     = Nothing+            , args      = EndArgs+            }+        pure (v, funTy)+      )+  where+    funTy :: SPIRV.PrimTy+    funTy = SPIRV.Function ( map (fst . snd) as ) b+++declareArgument :: ShortText -> (SPIRV.PrimTy, Permissions) -> CGMonad ID+declareArgument argName (argTy, permissions)+  = do+      argTyID <- typeID argTy+      v <- fresh+      structuralInstruction+        Instruction+          { operation = SPIRV.Op.FunctionParameter+          , resTy = Just argTyID+          , resID = Just v+          , args = EndArgs+          }+      let+        writable = case argTy of+          SPIRV.Pointer {} -> False+          _                -> Write `elem` permissions+      defineLocalBinding argName (v, argTy) writable+      pure v++declareEntryPoint+  :: ShortText+  -> SPIRV.ExecutionInfo Word32 model+  -> Maybe VLInterface+  -> CGMonad r+  -> CGMonad ID+declareEntryPoint modelName modelInfo mbIface body+  = createIDRec ( _knownBinding modelName )+      ( do unitTyID <- typeID SPIRV.Unit+           fnTyID  <- typeID funTy+           pure (unitTyID, fnTyID)+      )+      ( \(unitTyID,fnTyID) v -> do+        -- declare entry point ID proper+        assign ( _entryPoint modelName model ) (Just v)+        -- initialise entry point with empty interface+        -- (loading/storing should add to the interface as needed)+        assign ( _interface modelName model ) (Just Map.empty)+        -- set the required capabilities+        requireCapabilities ( SPIRV.executionModelCapabilities model )++        structuralInstruction+          Instruction+            { operation = SPIRV.Op.Function+            , resTy     = Just unitTyID+            , resID     = Just v+            , args      = Arg SPIRV.NoFunctionControl+                        $ Arg fnTyID EndArgs+            }+        _ <- inEntryPointContext modelName modelInfo mbIface body+        instruction+          Instruction+            { operation = SPIRV.Op.Return+            , resTy = Nothing+            , resID = Nothing+            , args  = EndArgs+            }+        structuralInstruction+          Instruction+            { operation = SPIRV.Op.FunctionEnd+            , resTy     = Nothing+            , resID     = Nothing+            , args      = EndArgs+            }+        pure (v, funTy)+      )+  where+    model :: SPIRV.ExecutionModel+    model = SPIRV.modelOf modelInfo++    funTy :: SPIRV.PrimTy+    funTy = SPIRV.Function [] SPIRV.Unit
+ src/CodeGen/IDs.hs view
@@ -0,0 +1,561 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE TypeApplications    #-}++{-|+Module: CodeGen.IDs++This module defines operations to obtain instruction IDs from the code generator state, such as:+  +  * 'typeID', which obtains the ID of a type, recursively defining new IDs for types that have not yet been defined,+  * 'constID', which obtains the ID of a constant value.++Suppose for instance we need an ID for the type @M 4 3 Float@, a matrix with 4 rows and 3 columns.    +In SPIR-V, matrices are represented in column-major order, so the (informal) process to obtain an ID for this matrix is as follows:++  1. query whether this matrix type has already been defined. If so, use that ID: we're done. Otherwise:+  2. query whether the column type @V 4 Float@ has already been defined.+     If so, define a new ID with @OpTypeMatrix vec4FloatID 3@. Otherwise:+  3. query whether the entry type @Float@ has already been defined.+     If so, define a column vector ID @OpTypeVector floatID 4@ and then a matrix ID from that as in 2. Otherwise:+  4. define a new ID for entry type, then one for the column type, then one for the matrix type.++This process lends itself extremely well to a recursive traversal.++-}++module CodeGen.IDs+  ( extInstID+  , typeID, laidOutTypeID+  , constID+  , bindingID+  , undefID+  , builtinID+  , globalID+  , stringLitID+  )+  where++-- base+import Control.Monad+  ( when )+import Data.Coerce+  ( coerce )+import Data.Foldable+  ( traverse_, for_ )+import Data.Maybe+  ( fromJust )+import Data.Semigroup+  ( First(First) )+import Data.Word+  ( Word32 )++-- containers+import qualified Data.Set as Set++-- lens+import Control.Lens+  ( Lens', view, use, assign )++-- mtl+import Control.Monad.Except+  ( MonadError, throwError )+import Control.Monad.State+  ( MonadState )+import Control.Monad.Reader+  ( MonadReader )++-- text-short+import Data.Text.Short+  ( ShortText )++-- fir+import CodeGen.Instruction+  ( ID(ID), TyID(TyID, tyID)+  , Pointer(..), Variable(..)+  , Instruction(..)+  , Args(Arg, EndArgs), toArgs+  )+import CodeGen.Monad+  ( MonadFresh+  , createID, createIDRec+  , tryToUse, tryToUseWith+  , note+  )+import CodeGen.State+  ( CGState, CGContext+  , currentFunctionContext+  , _knownExtInst+  , _knownStringLit+  , _knownBinding+  , _localBinding+  , _knownType+  , _knownConstant+  , _knownUndefined+  , _builtin, _builtinVariable+  , _usedGlobal+  , _userGlobal+  , _backend+  , _interfaceBinding+  , _spirvVersion+  , requireCapabilities+  , addName, addMemberName+  , addDecoration, addDecorations+  , addMemberDecoration, addMemberDecorations+  )+import FIR.Builtin+  ( modelBuiltins, builtinCapabilities )+import FIR.Layout+  ( arrayStride, memberLayoutDecorations )+import FIR.Prim.RayTracing+  ( AccelerationStructure(..) )+import FIR.Prim.Struct+  ( traverseStruct )+import FIR.Prim.Types+  ( PrimTy(primTySing), primTy+  , SPrimTy(..)+  , aConstant+  )+import FIR.ProgramState+  ( FunctionContext(InEntryPoint), executionContext )+import Math.Linear+  ( M(unM) )+import qualified SPIRV.Builtin      as SPIRV+import qualified SPIRV.Decoration   as SPIRV+import qualified SPIRV.Extension    as SPIRV+  ( ExtInst )+import qualified SPIRV.Image        as SPIRV.Image+import qualified SPIRV.Layout       as SPIRV+import qualified SPIRV.Operation    as SPIRV.Op+import qualified SPIRV.PrimTy       as SPIRV+import qualified SPIRV.PrimTy       as SPIRV.PrimTy+import qualified SPIRV.Requirements as SPIRV+  ( primTyCapabilities )+import qualified SPIRV.ScalarTy     as SPIRV+import qualified SPIRV.Stage        as SPIRV+import qualified SPIRV.Storage      as Storage+import qualified SPIRV.Version      as SPIRV++----------------------------------------------------------------------------+-- instructions generated along the way that need to be floated to the top++-- get extended instruction set ID (or create one if none exist)+extInstID :: (MonadState CGState m, MonadFresh ID m)+          => SPIRV.ExtInst -> m ID+extInstID extInst = +  tryToUse ( _knownExtInst extInst )+    id+    pure++-- | Get the ID of a (logical) type.+typeID :: ( MonadReader CGContext m+          , MonadState  CGState   m+          , MonadFresh  ID        m+          , MonadError  ShortText m+          )+       => SPIRV.PrimTy -> m TyID+typeID = laidOutTypeID SPIRV.logical++-- | Get the ID of a type with the given layout+-- (the result ID of the corresponding type constructor instruction).+--+-- If the type has not yet been declared, this recursively declares it,+-- together with the types it depends on.+laidOutTypeID :: forall m.+                 ( MonadReader CGContext m+                 , MonadState  CGState   m+                 , MonadFresh  ID        m+                 , MonadError  ShortText m+                 )+              => SPIRV.Layout -> SPIRV.PrimTy -> m TyID+laidOutTypeID lay ty = TyID <$>+  tryToUseWith _knownPrimTy+    ( coerce . fromJust . resID ) -- type constructor instructions always have a result ID+    do requireCapabilities ( SPIRV.primTyCapabilities ty )+       bk <- view _backend+       case ty of++        SPIRV.Matrix m n a -> +          createIDRec _knownPrimTy+            ( tyID <$> typeID (SPIRV.Vector m (SPIRV.Scalar a)) ) -- column type+            ( \ colID +                  -> mkTyConInstruction ( Arg colID $ Arg n EndArgs )+            )++        SPIRV.Vector n a ->+          createIDRec _knownPrimTy+            ( tyID <$> typeID a ) -- element type+            ( \ eltID +                  -> mkTyConInstruction ( Arg eltID $ Arg n EndArgs )+            )++        SPIRV.Function as b ->+          createIDRec _knownPrimTy+            ( do asIDs <- traverse typeID as -- types of function arguments+                 bID   <- typeID b           -- return type of function+                 pure (asIDs, bID)+            )+            ( \ (asIDs, bID) +                  -> mkTyConInstruction ( Arg bID $ toArgs asIDs )+            )++        SPIRV.Array l a ->+          createIDRec _knownPrimTy+            ( do lgID  <- constID l                         -- array size is the result of a constant instruction+                 eltID <- laidOutTypeID componentLayout a   --     as opposed to being a literal number+                 pure (eltID, lgID)                         -- (I suppose this is to do with specialisation constants)+            )+            ( \(eltTyID, lgID) v -> do+                addArrayStride v a+                mkTyConInstruction ( Arg eltTyID $ Arg lgID EndArgs ) v+            )++        SPIRV.RuntimeArray a ->+          createIDRec _knownPrimTy+            ( laidOutTypeID componentLayout a )+            ( \eltTyID v -> do+              addArrayStride v a+              mkTyConInstruction ( Arg eltTyID EndArgs ) v+            )++        SPIRV.Unit                  -> createID _knownPrimTy ( mkTyConInstruction EndArgs )+        SPIRV.Boolean               -> createID _knownPrimTy ( mkTyConInstruction EndArgs )+        SPIRV.AccelerationStructure -> createID _knownPrimTy ( mkTyConInstruction EndArgs )+        SPIRV.RayQuery              -> createID _knownPrimTy ( mkTyConInstruction EndArgs )++        SPIRV.Scalar (SPIRV.Integer s w)+          | SPIRV.Signed <- s+          , SPIRV.OpenCL <- bk+          -> tyID <$> typeID ( SPIRV.Scalar (SPIRV.Integer SPIRV.Unsigned w) ) -- no "sign semantics" in OpenCL++        SPIRV.Scalar (SPIRV.Integer s w)+          -> createID _knownPrimTy+                ( mkTyConInstruction+                    ( Arg (SPIRV.width w) $ Arg (SPIRV.signedness s) EndArgs )+                )++        SPIRV.Scalar (SPIRV.Floating w)+          -> createID _knownPrimTy+                ( mkTyConInstruction ( Arg (SPIRV.width w) EndArgs ) )++        SPIRV.Struct as+          -> createIDRec _knownPrimTy+                ( traverse ( fmap tyID . laidOutTypeID componentLayout . snd ) as ) -- return IDs of struct member types+                ( \eltIDs structTyID ->+                  do+                    memberLayoutDecs <-+                      case SPIRV.layoutRules lay of+                        Just rules -> memberLayoutDecorations rules ( map snd as )+                        Nothing    -> pure ( map ( const Set.empty ) as )++                    -- add information: name of each struct field, and decorations+                    for_ ( zip3 [0..] as memberLayoutDecs )+                      ( \ (i, (mbFieldName, _), eltDecs) -> do+                        traverse_ ( addMemberName (TyID structTyID) i ) mbFieldName+                        addMemberDecorations (TyID structTyID) i eltDecs+                        -- the members of a block of built-in variables are decorated using their names+                        when ( SPIRV.blockKind lay == Just SPIRV.BuiltinBlock ) $+                          for_ ( SPIRV.readBuiltin =<< mbFieldName )+                            ( addMemberDecoration (TyID structTyID) i . SPIRV.Builtin )+                      )++                    -- decorate interface blocks+                    for_ ( SPIRV.blockKind lay ) \ kind -> do+                      addDecoration structTyID SPIRV.Block+                      when ( kind == SPIRV.BuiltinBlock ) $+                        addName structTyID "gl_PerVertex"++                    -- declare the type+                    mkTyConInstruction (toArgs eltIDs) structTyID+                )++        SPIRV.Pointer (SPIRV.PointerTy storage pointeeLayout a) ->+          createIDRec _knownPrimTy+            ( laidOutTypeID pointeeLayout a )+            ( \ tyID -> mkTyConInstruction ( Arg storage $ Arg tyID EndArgs ) )++        SPIRV.PrimTy.Image (SPIRV.Image.Image { .. })+          -> createIDRec _knownPrimTy+               ( typeID (SPIRV.Scalar texelComponent) )  -- get the type ID of the image 'component' type+               ( \componentID+                   -> mkTyConInstruction+                        ( Arg componentID+                        $ Arg dimensionality+                        $ Arg hasDepth+                        $ Arg arrayness+                        $ Arg multiSampling+                        $ Arg imageUsage+                        $ Arg imageFormat+                        EndArgs+                        )+               )++        SPIRV.Sampler -> createID _knownPrimTy ( mkTyConInstruction EndArgs )++        SPIRV.SampledImage imageTy+          -> createIDRec _knownPrimTy+               ( typeID (SPIRV.PrimTy.Image imageTy) )+               ( \ imgTyID -> mkTyConInstruction (Arg imgTyID EndArgs ) )++  where _knownPrimTy :: Lens' CGState (Maybe Instruction)+        _knownPrimTy = _knownType declarationLayout ty++        -- Layout only affects the declarations of arrays and structures.+        declarationLayout :: SPIRV.Layout+        declarationLayout = case ty of+          SPIRV.Array        {} -> lay+          SPIRV.RuntimeArray {} -> lay+          SPIRV.Struct       {} -> lay+          _                     -> SPIRV.logical++        componentLayout :: SPIRV.Layout+        componentLayout = SPIRV.componentLayout ty lay++        -- Arrays in explicitly laid out memory have a stride,+        -- except for arrays of interface blocks.+        addArrayStride :: ID -> SPIRV.PrimTy -> m ()+        addArrayStride v eltTy = case lay of+          SPIRV.Layout { SPIRV.layoutRules = Just rules, SPIRV.blockKind = Nothing }+            -> addDecoration v . SPIRV.ArrayStride =<< arrayStride rules eltTy+          _ -> pure ()++        mkTyConInstruction :: Args -> ID -> m Instruction+        mkTyConInstruction flds v+          = pure +              Instruction+                { operation = SPIRV.tyOp ty+                , resTy     = Nothing+                , resID     = Just v+                , args      = flds+                }++-- get the ID for a given constant, or create one if none exist+-- this is the crucial location where we make use of singletons to perform type-case+constID :: forall m a.+           ( MonadReader CGContext m+           , MonadState  CGState   m+           , MonadFresh  ID        m+           , MonadError  ShortText m+           , PrimTy a+           )+        => a -> m ID+constID a =+  tryToUseWith _knownAConstant+    ( fromJust . resID ) -- constant definition instructions always have a result ID+    do resTyID <- typeID (primTy @a) -- start off by getting an ID for the type!+       let mkConstantInstruction +             :: SPIRV.Op.Operation -> Args -> ID -> m Instruction+           mkConstantInstruction op flds v+             = pure +                 Instruction+                   { operation = op+                   , resTy     = Just resTyID+                   , resID     = Just v+                   , args      = flds+                   }+       case primTySing @a of++        SMatrix {} ->+          createIDRec _knownAConstant+            ( traverse constID . unM $ a ) -- get the ID for each column+            ( \ cols -> +                  mkConstantInstruction +                    SPIRV.Op.ConstantComposite +                    ( toArgs cols )+            )++        SVector {} ->+          createIDRec _knownAConstant+            ( traverse constID a ) -- get the result ID for each component+            ( \ eltIDs -> +                  mkConstantInstruction +                    SPIRV.Op.ConstantComposite+                    (toArgs eltIDs)+            )++        SScalar {}+          -> createID _knownAConstant+              ( mkConstantInstruction+                  SPIRV.Op.Constant+                  ( Arg a EndArgs )+              )++        SUnit+          -> pure (ID 0) -- should not be used +            {- create _knownAConstant+                ( mkConstantInstruction+                    SPIRV.Op.ConstantNull+                    EndArgs+                )+              -}+              {-+              throwError+                "constId: called on Unit type.\n\+                \Unit has a unique value, \+                \and as such does not need to be constructed."+              -}++        SBool -> +          createID _knownAConstant+            ( mkConstantInstruction+                ( if a+                  then SPIRV.Op.ConstantTrue+                  else SPIRV.Op.ConstantFalse+                )+                EndArgs+            )++        SRuntimeArray {} ->+            throwError+              "'constID': cannot construct run-time arrays.\n\+              \Runtime arrays are only available through entry-point interfaces."++        SAccelerationStructure {} ->+          createIDRec _knownAConstant+            ( constID ( case a of { AccelerationStructureFromWord64 handle -> handle } ) )+            ( \ handleID ->+              mkConstantInstruction+                SPIRV.Op.ConvertUToAccelerationStructure+                ( Arg handleID EndArgs )+            )++        SArray {} ->+          createIDRec _knownAConstant+            ( traverse constID a )+            ( \ eltIDs ->+                  mkConstantInstruction+                    SPIRV.Op.ConstantComposite+                    ( toArgs eltIDs )+            )+        +        SStruct {} ->+          createIDRec _knownAConstant+            ( traverseStruct constID a :: m [ID] )+            ( \ eltIDs ->+                  mkConstantInstruction+                    SPIRV.Op.ConstantComposite+                    ( toArgs eltIDs )+            )++  where _knownAConstant :: Lens' CGState (Maybe Instruction)+        _knownAConstant = _knownConstant ( aConstant a )+++-- left-biased semigroup operation+infixl 6 <<?>+(<<?>) :: forall x. Maybe x -> Maybe x -> Maybe x+(<<?>) = coerce ( (<>) @(Maybe (First x)) )++bindingID :: forall m.+             ( MonadState  CGState   m+             , MonadReader CGContext m+             , MonadError  ShortText m+             , MonadFresh  ID        m+             ) => ShortText -> m (ID, SPIRV.PrimTy)+bindingID varName+  = do  ctxt <- currentFunctionContext+        bk <- view _backend+        case ctxt of+          InEntryPoint modelName modelInfo _+            | Just ptrTy <- lookup varName (modelBuiltins modelInfo)+              ->+                do -- this is a built-in variable, use 'builtinID'+                  builtin <- builtinID modelName modelInfo varName ptrTy+                  -- requirement+                  let requirements = builtinCapabilities bk varName+                  requireCapabilities requirements+                  -- note that 'builtinID' sets the necessary decorations for the builtin+                  pure (builtin, SPIRV.Pointer ptrTy)+          _ ->+            do -- this is not a built-in variable, obtain the binding ID+              mbLoc   <- use ( _localBinding varName )+              mbKnown <- use ( _knownBinding varName )+              mbGlob  <-+                fmap ( \ ( Pointer v ptrTy ) -> ( v, SPIRV.Pointer ptrTy ) )+                  <$> globalID varName (executionContext ctxt)++              -- return the binding ID (throwing an error if none was found)+              note+                ( "codeGen: no binding with name " <> varName )+                ( mbLoc <<?> mbKnown <<?> mbGlob )++undefID :: ( MonadReader CGContext m+           , MonadState  CGState   m+           , MonadError  ShortText m+           , MonadFresh  ID        m+           )+        => SPIRV.PrimTy -> m ID+undefID ty =+  tryToUse ( _knownUndefined ty )+    fst+    ( \v -> do+      tyID <- typeID ty+      pure (v,tyID)+    )++-- | Get the ID for a built-in variable.+--+-- Automatically switches on this built-in in the interface of the relevant entry-point,+-- by using the '_builtin' lens.+builtinID :: ( MonadReader CGContext m+             , MonadState  CGState   m+             , MonadError  ShortText m+             , MonadFresh  ID        m+             )+          => ShortText -> SPIRV.ExecutionInfo Word32 model -> ShortText -> SPIRV.PointerTy -> m ID+builtinID modelName modelInfo builtinName ptrTy =+  tryToUse ( _builtin modelName modelInfo builtinName )+    id+    ( \ v -> do+      ptrTyID <- typeID ( SPIRV.Pointer ptrTy )+      assign ( _builtinVariable v ) ( Just ( builtinName, Variable ( Pointer v ptrTy ) ptrTyID ) )+      pure v+    )++-- | Get the ID for a user-defined global variable,+-- adding this global to the list of 'used' global variables if it isn't already there,+-- adding the required decorations, and (manually) adding this global variable+-- to the relevant stage interface if necessary.+globalID :: ( MonadState  CGState   m+            , MonadReader CGContext m+            , MonadError  ShortText m+            , MonadFresh  ID        m+            )+         => ShortText -> Maybe (ShortText, SPIRV.ExecutionModel) -> m ( Maybe Pointer )+globalID globalName mbModel+  = do ver <- view _spirvVersion+       mbGlobID <- view ( _userGlobal globalName )+       case mbGlobID of+         Nothing+           -> pure Nothing+         Just (ptrTy, decs)+           -> do+                ptr@( Pointer ident _ ) <-+                  tryToUse ( _usedGlobal globalName )+                    variablePointer+                    ( \ v -> do+                      addDecorations v decs+                      ptrTyID <- typeID ( SPIRV.Pointer ptrTy )+                      pure ( Variable ( Pointer v ptrTy ) ptrTyID )+                    )+                case (mbModel, ptrTy) of+                  ( Just (model, modelName), SPIRV.PointerTy storage _ _ )+                    |  ver >= SPIRV.Version 1 4+                    || storage == Storage.Input+                    || storage == Storage.Output+                      -> assign ( _interfaceBinding model modelName globalName ) ( Just ident )+                  _   -> pure ()+                pure ( Just ptr )++stringLitID :: (MonadState CGState m, MonadFresh ID m)+            => ShortText -> m ID+stringLitID literal =+  tryToUse ( _knownStringLit literal )+    id+    pure
+ src/CodeGen/Images.hs view
@@ -0,0 +1,566 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DerivingStrategies  #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE TypeApplications    #-}++{-|+Module: CodeGen.Images++Code generation for image sampling, reading and writing.+-}++module CodeGen.Images+  ( imageTexel, writeTexel )+  where++-- base+import Control.Arrow+  ( first, (&&&) )+import Data.Bits+  ( Bits((.|.), shiftR, testBit) )+import Data.List+  ( insertBy )+import Data.Ord+  ( comparing )+import Data.Proxy+  ( Proxy )+import Data.Word+  ( Word32 )++-- lens+import Control.Lens+  ( view )++-- mtl+import Control.Monad.Except+  ( throwError )++-- text-short+import Data.Text.Short+  ( ShortText )+import qualified Data.Text.Short as ShortText+  ( pack )++-- fir+import CodeGen.Application+  ( ASTs(..), Application(..) )+import CodeGen.Binary+  ( instruction )+import CodeGen.Composite+  ( vectorSwizzle )+import {-# SOURCE #-} CodeGen.CodeGen+  ( CodeGen(codeGenArgs), codeGen )+import CodeGen.IDs+  ( bindingID, constID, typeID )+import CodeGen.Instruction+  ( ID, TyID, Instruction(..), Pointer(..)+  , Args(Arg,EndArgs), toArgs+  )+import CodeGen.Monad+  ( CGMonad, MonadFresh(fresh) )+import CodeGen.Pointers+  ( load )+import CodeGen.State+  ( _backend, requireCapability, requireCapabilities )+import Data.Type.Known+  ( Known, knownValue )+import FIR.AST+  ( AST, Code+  , pattern NilOps, pattern Proj, pattern Dref, pattern Bias+  , pattern LOD, pattern MinLOD, pattern Grad+  , pattern ConstOffsetBy, pattern OffsetBy+  , pattern Gather, pattern SampleNo+  , ImgOpsF+  )+import FIR.AST.Images+  ( ImgQueryF(..) )+import FIR.Prim.Image+  ( ImageProperties, ImageAndCoordinate(..)+  , ImageCoordinateKind(..)+  , ImageOperands, OperandName+  , GatherInfo(..)+  , knownImage+  )+import FIR.Prim.Types+  ( primTy )+import SPIRV.Image+  ( DepthTesting(..), Projection(..) )+import qualified SPIRV.Capability   as SPIRV+  ( pattern ComputeKernel, pattern ImageQuery )+import qualified SPIRV.Image        as SPIRV+  hiding ( Image(Image) )+import qualified SPIRV.Image+  ( Image(Image) )+import qualified SPIRV.Operation    as SPIRV+  ( Operation )+import qualified SPIRV.Operation    as SPIRV.Op+import qualified SPIRV.PrimTy       as SPIRV+import qualified SPIRV.PrimTy+  ( PrimTy(Image, SampledImage) )+import qualified SPIRV.Requirements as SPIRV+  ( lodCapabilities+  , gatherCapabilities+  , unknownFormatReadCapabilities+  , unknownFormatWriteCapabilities+  )+import qualified SPIRV.Stage        as SPIRV+  ( Backend(OpenCL, Vulkan) )++--------------------------------------------------------------------------+-- image sample/read/write++imageTexel+  :: forall+        ( props :: ImageProperties )+        ( ops   :: [OperandName]   )+  .  ( CodeGen AST, Known ImageProperties props )+  => (ID, SPIRV.PrimTy)+  -> Code (ImageOperands props ops)+  -> ID+  -> (TyID, SPIRV.PrimTy)+  -> CGMonad (ID, SPIRV.PrimTy)+imageTexel (imgID, imgTy) ops coords (imgTexelTyID, imgTexelTy)+  = do+      ( bm, operandsArgs ) <- operandsToArgs ops+      let lod    = lodMethod    bm+          proj   = projection   bm+          dtest  = depthTesting bm+          gathering = gather    bm+          ImageAndCoordinate+            ( SPIRV.Image.Image+                { SPIRV.dimensionality = dim+                , SPIRV.imageFormat    = mbFmt+                }+            , coordCompKind+            ) = knownValue @props++      v <- fresh+      let+        -- Image reads, (non-depth-comparison) sampling and gathering return+        -- four components: narrow the result to the requested texel type.+        texelInstruction :: Bool -> SPIRV.Operation -> Args -> CGMonad (ID, SPIRV.PrimTy)+        texelInstruction fourComponents op texelArgs = case imgTexelTy of+          SPIRV.Scalar s+            | fourComponents+            -> narrow ( SPIRV.Vector 4 ( SPIRV.Scalar s ) ) [0]+          SPIRV.Vector n c+            | fourComponents, n < 4+            -> narrow ( SPIRV.Vector 4 c ) [ 0 .. n - 1 ]+          _ -> do+            instruction ( Instruction { operation = op, resTy = Just imgTexelTyID, resID = Just v, args = texelArgs } )+            pure ( v, imgTexelTy )+          where+            narrow vec4Ty components = do+              vec4TyID <- typeID vec4Ty+              instruction ( Instruction { operation = op, resTy = Just vec4TyID, resID = Just v, args = texelArgs } )+              vectorSwizzle ( v, vec4Ty ) components++      res <- case coordCompKind of+        -- must be using a sampler (accessing with floating-point coordinates)+        FloatingPointCoordinates+          -> do sampledImgID+                  <- case imgTy of+                        SPIRV.PrimTy.SampledImage _+                          -> pure imgID+                        SPIRV.PrimTy.Image _+                          -> throwError+                                ( "codeGen: cannot sample image with floating-point coordinates: \+                                  \no sampler provided."+                                )+                        _ -> throwError+                                ( "codeGen: image sampling operation provided non-image \+                                  \of type " <> ShortText.pack ( show imgTy )+                                )+                if gathering+                then texelInstruction True ( gatherOperation dtest )+                       ( Arg sampledImgID $ Arg coords $ operandsArgs )+                else texelInstruction ( dtest == NoDepthTest ) ( sampleOperation lod dtest proj )+                       ( Arg sampledImgID $ Arg coords $ operandsArgs )+        -- reading from image directly (using integral coordinates)+        IntegralCoordinates+          -> do plainImgID+                  <- case imgTy of+                        SPIRV.PrimTy.Image _+                          -> pure imgID+                        SPIRV.PrimTy.SampledImage plainImg+                          -> fst <$> removeSampler (imgID, plainImg)+                        _ -> throwError+                               ( "codeGen: image read operation provided non-image \+                                 \of type " <> ShortText.pack ( show imgTy )+                               )+                res <- texelInstruction True SPIRV.Op.ImageRead+                         ( Arg plainImgID $ Arg coords $ operandsArgs )+                requireCapabilities ( SPIRV.unknownFormatReadCapabilities dim mbFmt )+                pure res++      -- declare capabilities+      requireOperandCapabilities bm++      pure res+++writeTexel+  :: forall props ops+  .  ( CodeGen AST, Known ImageProperties props )+  => (ID, SPIRV.PrimTy)+  -> Code (ImageOperands props ops)+  -> ID+  -> ID+  -> CGMonad ()+writeTexel (imgID, imgTy) ops coords texel+  = do+      let SPIRV.Image.Image+            { SPIRV.imageFormat = mbFmt+            } = knownImage @props++      ( bm, operandsArgs ) <- operandsToArgs ops+      plainImgID+        <- case imgTy of+              SPIRV.PrimTy.Image _+                -> pure imgID+              SPIRV.PrimTy.SampledImage plainImg+                -> fst <$> removeSampler (imgID, plainImg)+              _ -> throwError+                     ( "codeGen: image write operation provided non-image \+                       \of type " <> ShortText.pack ( show imgTy )+                     )+      instruction+        Instruction+          { operation = SPIRV.Op.ImageWrite+          , resTy     = Nothing+          , resID     = Nothing+          , args      = Arg plainImgID+                      $ Arg coords+                      $ Arg texel+                      $ operandsArgs+          }++      -- declare capabilities+      requireOperandCapabilities bm+      requireCapabilities ( SPIRV.unknownFormatWriteCapabilities mbFmt )++      -- return the result ID+      pure ()++--------------------------------------------------------------------------+-- add/remove sampler++{-+addSampler :: (ID, SPIRV.Image.Image) -> ID -> CGMonad (ID, SPIRV.PrimTy)+addSampler (imgID, imgTy) samplerID+  = do+      let sampledImgTy = SPIRV.PrimTy.SampledImage imgTy+      sampledImgTyID <- typeID sampledImgTy+      v <- fresh+      instruction+        Instruction+          { operation = SPIRV.Op.SampledImage+          , resTy     = Just sampledImgTyID+          , resID     = Just v+          , args      = Arg imgID+                      $ Arg samplerID EndArgs+          }+      pure (v, sampledImgTy)+-}++removeSampler :: CodeGen AST => (ID, SPIRV.Image.Image) -> CGMonad (ID, SPIRV.PrimTy)+removeSampler (imgID, imgTy)+  = do+      let plainImgTy = SPIRV.PrimTy.Image imgTy+      plainImgTyID <- typeID plainImgTy+      v <- fresh+      instruction+        Instruction+          { operation = SPIRV.Op.Image+          , resTy     = Just plainImgTyID+          , resID     = Just v+          , args      = Arg imgID EndArgs+          }+      pure (v, plainImgTy)++--------------------------------------------------------------------------+-- sampling: find which sampling operation to use++data LODMethod+  = ImplicitLOD+  | ExplicitLOD+  deriving stock ( Show, Eq, Ord, Enum, Bounded )++lodMethod :: Word32 -> LODMethod+lodMethod bm+  | bm `testBit` 9 || bm `testBit` 10 = ExplicitLOD --'LOD' or 'Grad' operand provided+  | otherwise                         = ImplicitLOD++depthTesting :: Word32 -> DepthTesting+depthTesting bm+  | bm `testBit` 0 = DepthTest+  | otherwise      = NoDepthTest++projection :: Word32 -> Projection+projection bm+  | bm `testBit` 1 = Projective+  | otherwise      = Affine++gather :: Word32 -> Bool+gather = (`testBit` 13)++sampleOperation :: LODMethod -> DepthTesting -> Projection -> SPIRV.Operation+sampleOperation ImplicitLOD NoDepthTest Affine     = SPIRV.Op.ImageSampleImplicitLod+sampleOperation ExplicitLOD NoDepthTest Affine     = SPIRV.Op.ImageSampleExplicitLod+sampleOperation ImplicitLOD DepthTest   Affine     = SPIRV.Op.ImageSampleDrefImplicitLod+sampleOperation ExplicitLOD DepthTest   Affine     = SPIRV.Op.ImageSampleDrefExplicitLod+sampleOperation ImplicitLOD NoDepthTest Projective = SPIRV.Op.ImageSampleProjImplicitLod+sampleOperation ExplicitLOD NoDepthTest Projective = SPIRV.Op.ImageSampleProjExplicitLod+sampleOperation ImplicitLOD DepthTest   Projective = SPIRV.Op.ImageSampleProjDrefImplicitLod+sampleOperation ExplicitLOD DepthTest   Projective = SPIRV.Op.ImageSampleProjDrefExplicitLod++gatherOperation :: DepthTesting -> SPIRV.Operation+gatherOperation NoDepthTest = SPIRV.Op.ImageGather+gatherOperation DepthTest   = SPIRV.Op.ImageDrefGather++--------------------------------------------------------------------------+-- capabilities++-- | Declare the capabilities required by the image operands+-- given by the bitmask.+requireOperandCapabilities :: Word32 -> CGMonad ()+requireOperandCapabilities bm+  = do+      bk <- view _backend+      requireCapabilities ( SPIRV.lodCapabilities bk bm )+      requireCapabilities ( SPIRV.gatherCapabilities bm )++--------------------------------------------------------------------------+-- dealing with operands++instance CodeGen (ImgOpsF ast) where+  codeGenArgs _ = throwError "Unexpected image operand."++operands :: CodeGen AST => Code (ImageOperands props ops) -> CGMonad (Word32, [(ID, Word32)])+operands NilOps     = pure  ( 0x0000, [] )+operands (Proj ops) = first ( 0x0002 .|. ) <$> operands ops+operands (Dref dref ops)+  = do+      i <- fst <$> codeGen dref+      (bm, nxt) <- operands ops+      let opBit = 0x0001+      pure ( opBit .|. bm+           , insertBy (comparing snd) (i, opBit) nxt+           )+operands (Bias bias ops)+  = do+      i <- fst <$> codeGen bias+      (bm, nxt) <- operands ops+      let opBit = 0x0100+      pure ( opBit .|. bm+           , insertBy (comparing snd) (i, opBit) nxt+           )+operands (LOD lod ops)+  = do+      i <- fst <$> codeGen lod+      (bm, nxt) <- operands ops+      let opBit = 0x0200+      pure ( opBit .|. bm+           , insertBy (comparing snd) (i, opBit) nxt+           )+operands (Grad (gx,gy) ops)+  = do+      i1 <- fst <$> codeGen gx+      i2 <- fst <$> codeGen gy+      (bm, nxt) <- operands ops+      let opBit = 0x0400+      pure ( opBit .|. bm+           , stableSplice ([i1,i2], opBit) nxt )+operands (ConstOffsetBy off ops)+  = do+      i <- constID off+      (bm, nxt) <- operands ops+      let opBit = 0x0800+      pure ( opBit .|. bm+           , insertBy (comparing snd) (i, opBit) nxt+           )+operands (OffsetBy off ops)+  = do+      offID <- fst <$> codeGen off+      (bm, nxt) <- operands ops+      let opBit = 0x1000+      pure ( opBit .|. bm+           , insertBy (comparing snd) (offID, opBit) nxt+           )+operands (Gather (ComponentWithOffsets comp offs) ops)+  = do+      compID <- fst <$> codeGen comp+      offsID <- constID offs+      (bm, nxt) <- operands ops+      let opBit = 0x2000+      pure ( opBit .|. bm+           , insertBy (comparing snd) (compID, 0x0001) -- says "put me first", see 'opArgs'+           . insertBy (comparing snd) (offsID, opBit )+           $ nxt+           )+operands (Gather (DepthWithOffsets offs) ops)+  = do+      offsID <- constID offs+      (bm, nxt) <- operands ops+      let opBit = 0x2000+      pure ( opBit .|. bm+           , insertBy (comparing snd) (offsID, opBit) nxt+           )+operands (SampleNo no ops)+  = do+      i <- fst <$> codeGen no+      (bm, nxt) <- operands ops+      let opBit = 0x4000+      pure ( opBit .|. bm+           , insertBy (comparing snd) (i, opBit) nxt+           )+operands (MinLOD lod ops)+  = do+      i <- fst <$> codeGen lod+      (bm, nxt) <- operands ops+      let opBit = 0x8000+      pure ( opBit .|. bm+           , insertBy (comparing snd) (i, opBit) nxt+           )+operands ops+  = throwError +  $ "'operands': image operands not of the expected form\n"+  <> ShortText.pack (show ops)++opArgs :: Word32 -> [(ID, Word32)] -> Args+opArgs _  [] = EndArgs+opArgs bm ((putMeFirst, 0x0001) : ops)+  -- special case for an argument that needs to be put first+  -- must go before everything else (including bitmask)+  = Arg putMeFirst (opArgs bm ops) +opArgs bm ops+  = Arg+      ( shiftR bm 8 ) -- bitmask first, with bottom byte removed+      ( toArgs (map fst ops) ) -- then the IDs in order++operandsToArgs :: CodeGen AST => Code (ImageOperands props ops) -> CGMonad (Word32, Args)+operandsToArgs ops = (fst &&& uncurry opArgs) <$> operands ops++stableSplice :: Ord b => ( [a], b ) -> [ (a,b) ] -> [ (a,b) ]+stableSplice    ( as, bref ) []+  = map ( , bref ) as+stableSplice l1@( as, bref ) l2@( (a, b) : nxt )+  | b > bref  = map ( , bref ) as ++ l2+  | otherwise = ( a, b ) : stableSplice l1 nxt++--------------------------------------------------------------------------+-- image query operations++instance CodeGen AST => CodeGen (ImgQueryF AST) where+  codeGenArgs (Applied imgQueryOp as) = do+    bk <- view _backend+    case bk of+      SPIRV.OpenCL -> case imgQueryOp of+        QueryLODF {} -> pure ()+        _            -> requireCapability SPIRV.ComputeKernel+      SPIRV.Vulkan -> requireCapability SPIRV.ImageQuery+    let+      imgName :: ShortText+      resultType :: SPIRV.PrimTy+      ( imgName, resultType ) = imageQueryImageNameAndResultType imgQueryOp+    resTyID <- typeID resultType+    ( bdID, bindingTy ) <- bindingID imgName++    ( valID, valTy ) <- case bindingTy of+      SPIRV.Pointer ptrTy+        -> load imgName (Pointer bdID ptrTy)+      _ -> throwError+              ( "codeGen: internal error, image query operation on non-pointer named "+               <> imgName <> " of type " <> ShortText.pack ( show bindingTy )+               )+    +    -- LOD query operation needs a sampled image.+    -- Other operations use a plain image.+    imgID <- case valTy of+      SPIRV.SampledImage imgTy+        | QueryLODF {} <- imgQueryOp+        -> pure valID+        | otherwise+        -> fst <$> removeSampler ( valID, imgTy )+      SPIRV.Image {}+        | QueryLODF {} <- imgQueryOp+        -> throwError+              ( "codeGen: cannot query LOD of image named " <> imgName <> ":\n\+                \no sampler provided."+              )+        | otherwise+        -> pure valID+      nonImgTy+        -> throwError+              ( "codeGen: image query operation on non-image named " <> imgName <> " of type " <> ShortText.pack ( show nonImgTy ) )++    v <- fresh+    let+      emitInstruction :: CGMonad ()+      emitInstruction = case imgQueryOp of+        QuerySizeF {} | NilAST <- as -> +          instruction+            Instruction+              { operation = SPIRV.Op.ImageQuerySize+              , resTy     = Just resTyID+              , resID     = Just v+              , args      = Arg imgID EndArgs+              }+        QuerySizeLODF {} | (lod `ConsAST` NilAST) <- as -> do+          lodID <- fst <$> codeGen lod+          instruction+            Instruction+              { operation = SPIRV.Op.ImageQuerySizeLod+              , resTy     = Just resTyID+              , resID     = Just v+              , args      = Arg imgID +                          $ Arg lodID+                          $ EndArgs+              }+        QueryLODF {} | (coords `ConsAST` NilAST) <- as -> do+          coordsID <- fst <$> codeGen coords+          instruction+            Instruction+              { operation = SPIRV.Op.ImageQueryLod+              , resTy     = Just resTyID+              , resID     = Just v+              , args      = Arg imgID+                          $ Arg coordsID+                          $ EndArgs+              }+        QueryLevelsF {} | NilAST <- as ->+          instruction+            Instruction+              { operation = SPIRV.Op.ImageQueryLevels+              , resTy     = Just resTyID+              , resID     = Just v+              , args      = Arg imgID EndArgs+              }+        QuerySamplesF {} | NilAST <- as ->+          instruction+            Instruction+              { operation = SPIRV.Op.ImageQuerySamples+              , resTy     = Just resTyID+              , resID     = Just v+              , args      = Arg imgID EndArgs+              }+    emitInstruction+    pure ( v, resultType )++imageQueryImageNameAndResultType :: ImgQueryF ast a -> ( ShortText, SPIRV.PrimTy )+imageQueryImageNameAndResultType = \ case+  QuerySizeF    ( _ :: Proxy imgName ) ( _ :: Proxy resTy ) -> ( knownValue @imgName, primTy @resTy )+  QuerySizeLODF ( _ :: Proxy imgName ) ( _ :: Proxy resTy ) -> ( knownValue @imgName, primTy @resTy )+  QueryLODF     ( _ :: Proxy imgName ) ( _ :: Proxy resTy ) -> ( knownValue @imgName, primTy @resTy )+  QueryLevelsF  ( _ :: Proxy imgName ) ( _ :: Proxy resTy ) -> ( knownValue @imgName, primTy @resTy )+  QuerySamplesF ( _ :: Proxy imgName ) ( _ :: Proxy resTy ) -> ( knownValue @imgName, primTy @resTy )
+ src/CodeGen/Instruction.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE BlockArguments             #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}++{-|+Module: CodeGen.Instruction++This module defines an 'Instruction' data type which collects the information associated to a SPIR-V instruction:+  +  * which instruction it is (essentially: the instruction's OpCode),+  * the ID of the result returned by the instruction (if any),+  * the ID of the return type of the instruction (if any),+  * the arguments to the instruction (usually IDs, but can be other things such as string literals).+-}+++module CodeGen.Instruction+  ( Args(..), foldrArgs, arity, toArgs, Pair(..)+  , ID(..), TyID(MkTyID, TyID, tyID)+  , Instruction(..)+  , prependArg, setArgs+  , Pointer(..), Variable(..), variableID, variableDeclaration+  ) where++-- base+import Control.Category+  ( (>>>) )+import Data.Word+  ( Word32 )++-- fir+import Data.Binary.Class.Put+  ( Put(..) )+import qualified SPIRV.Operation as SPIRV+import qualified SPIRV.PrimTy    as SPIRV+  ( PointerTy(..) )++----------------------------------------------------------------------------+-- args++data Args where+  EndArgs :: Args+  Arg     :: ( Show a, Put a ) => a -> Args -> Args++deriving stock instance Show Args++-- mono-foldable business+foldrArgs :: (forall a. (Show a, Put a) => a -> b -> b) -> b -> Args -> b+foldrArgs _ b0 EndArgs    = b0+foldrArgs f b0 (Arg a as) = f a ( foldrArgs f b0 as )++instance Put Args where+  put = foldrArgs (put >>> (>>)) (pure ())+  wordCount = foldrArgs ( (+) . wordCount ) 0++arity :: Num a => Args -> a+arity = foldrArgs (const (+1)) 0++toArgs :: ( Show a, Put a, Foldable t ) => t a -> Args+toArgs = foldr Arg EndArgs++newtype Pair a b = Pair (a,b)+  deriving stock Show+instance ( Put a, Put b ) => Put (Pair a b) where+  put (Pair (a,b)) = put a *> put b+  wordCount (Pair (a,b)) = wordCount a + wordCount b++----------------------------------------------------------------------------+-- instructions++newtype ID = ID { idNumber :: Word32 }+  deriving newtype ( Eq, Ord, Enum, Put )++instance Show ID where+  show (ID n) = "%" ++ show n++newtype TyID = TyID { tyID :: ID }+  deriving newtype ( Eq, Ord, Enum, Put, Show )++pattern MkTyID :: Word32 -> TyID+pattern MkTyID i = TyID (ID i)++data Instruction+  = Instruction+    { operation :: SPIRV.Operation+    , resTy     :: Maybe TyID+    -- making 'resTy' and 'resID' of different types prevents accidentally mixing them up+    , resID     :: Maybe ID+    , args      :: Args+    }+  deriving stock Show++prependArg :: ( Show a, Put a ) => a -> Instruction -> Instruction+prependArg arg instr@Instruction { args = oldArgs }+  = instr { args = Arg arg oldArgs }++setArgs :: Args -> Instruction -> Instruction+setArgs as instr = instr { args = as }++----------------------------------------------------------------------------+-- pointers and variables++-- | A pointer, together with its type.+data Pointer+  = Pointer+    { pointerID :: ID+    , pointerTy :: SPIRV.PointerTy+    }+  deriving stock Show++-- | A variable: a pointer declared with an @OpVariable@ instruction,+-- together with the ID of its type.+data Variable+  = Variable+    { variablePointer :: Pointer+    , variableTyID    :: TyID+    }+  deriving stock Show++-- | The ID of a variable.+variableID :: Variable -> ID+variableID = pointerID . variablePointer++-- | The instruction declaring a variable.+variableDeclaration :: Variable -> Instruction+variableDeclaration ( Variable ( Pointer v ( SPIRV.PointerTy storage _ _ ) ) ptrTyID )+  = Instruction+      { operation = SPIRV.Variable+      , resTy     = Just ptrTyID+      , resID     = Just v+      , args      = Arg storage EndArgs+      }
+ src/CodeGen/Monad.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE StandaloneDeriving         #-}++{-|+Module: CodeGen.Monad++Defines the monad used by the code generator, including the monadic state required for code generation.+-}++module CodeGen.Monad+  ( MonadFresh(fresh), runFreshSuccT+  , CGMonad, putCG+  , liftPut+  , create, createID+  , createRec, createIDRec+  , tryToUse, tryToUseWith+  , runExceptTPutM, runCGMonad+  , note+  )+  where++-- base+import Control.Monad.Fix+  ( MonadFix )+import Control.Category+  ( (>>>) )++-- binary+import Data.Binary+  ( Binary )+import qualified Data.Binary as Binary+import qualified Data.Binary.Put as Binary++-- bytestring+import Data.ByteString.Builder+  ( Builder, toLazyByteString )+import Data.ByteString.Lazy+  ( ByteString )++-- lens+import Control.Lens+  ( Lens'+  , use, assign, (<<%=)+  )++-- mtl+import Control.Monad.Except+  ( MonadError , ExceptT, runExceptT, throwError )+import Control.Monad.Reader+  ( MonadReader, ReaderT, runReaderT )+import Control.Monad.State+  ( MonadState , StateT , runStateT )++-- text-short+import Data.Text.Short+  ( ShortText )++-- transformers+import Control.Monad.Trans.Class+  ( MonadTrans, lift )+import Control.Monad.Trans.Writer.Lazy+  ( Writer, runWriter, tell )++-- fir+import Control.Arrow.Strength+  ( leftStrength )+import CodeGen.Instruction+  ( ID )+import CodeGen.State+  ( CGState, CGContext+  , _currentID+  )++----------------------------------------------------------------------------+-- monad for code generation++type CGMonad +  = FreshSuccT CGState        -- supply of fresh variable IDs using CGState (see below)+      ( ReaderT CGContext     -- context for code generation+        ( StateT CGState      -- state (including for instance a map of which types have been defined)+          ( ExceptT ShortText -- for errors during code generation+              ( Writer Builder ) -- to write instructions in binary form+          )+        )+      )+-- NB: all the layers of this monad are lazy, so that we can tie knots using 'mfix'.+deriving newtype instance MonadReader CGContext CGMonad+deriving newtype instance MonadError  ShortText CGMonad+-- other instances automatically derived from the definition of FreshSuccT:+-- Functor, Applicative, Monad, MonadState CGState, MonadFresh ID++liftPut :: Binary.Put -> CGMonad ()+liftPut = lift . lift . lift . lift . tell . Binary.execPut  -- apologies++putCG :: Binary a => a -> CGMonad ()+putCG = liftPut . Binary.put++----------------------------------------------------------------------------+-- fresh name generation++class HasSupply v s where+  supply :: Lens' s v++instance HasSupply ID CGState where+  supply = _currentID++instance HasSupply ID ID where+  supply = id++class Monad m => MonadFresh v m where+  fresh :: m v++newtype FreshSuccT s m a = FreshSuccT { runFreshSuccT :: m a }++deriving newtype instance Functor       m => Functor       (FreshSuccT s m)+deriving newtype instance Applicative   m => Applicative   (FreshSuccT s m)+deriving newtype instance Monad         m => Monad         (FreshSuccT s m)+deriving newtype instance MonadState  s m => MonadState  s (FreshSuccT s m)+deriving newtype instance MonadFix      m => MonadFix      (FreshSuccT s m)++instance MonadTrans (FreshSuccT s) where+  lift = FreshSuccT++instance (MonadState s m, HasSupply v s, Enum v) => MonadFresh v (FreshSuccT s m) where+  fresh = supply <<%= succ -- <<%= means: "modify, and return the _old_ value"++create :: ( MonadFresh v m, MonadState s m )+       => Lens' s (Maybe a) -> (v -> m a) -> m (v, a)+create _key mk+  = do v <- fresh+       a <- mk v+       assign _key ( Just a )+       pure (v, a)++createID :: ( MonadFresh v m, MonadState s m )+         => Lens' s (Maybe a) -> (v -> m a) -> m v+createID _key mk = fst <$> create _key mk++createRec :: ( MonadFresh v m, MonadState s m )+          => Lens' s (Maybe a) -> m b -> (b -> v -> m a) -> m (v, a)+createRec _key before mk+  = do b <- before+       v <- fresh+       a <- mk b v+       assign _key ( Just a )+       pure (v, a)++createIDRec :: ( MonadFresh v m, MonadState s m )+          => Lens' s (Maybe a) -> m b -> (b -> v -> m a) -> m v+createIDRec _key before mk = fst <$> createRec _key before mk++-- | Try to use a given lens to obtain a value.+--+-- If using the lens returns Nothing, create the value instead, using 'create'.+tryToUse :: ( MonadFresh v m, MonadState s m )+         => Lens' s (Maybe a) -> (a -> b) -> (v -> m a) -> m b+tryToUse _key f mk = tryToUseWith _key f ( f . snd <$> create _key mk )++-- | Like 'tryToUse', but allowing for a custom creation procedure.+tryToUseWith :: ( MonadState s m )+             => Lens' s (Maybe a) -> (a -> b) -> m b -> m b+tryToUseWith _key f creation =+  use _key >>= maybe creation (pure . f)++----------------------------------------------------------------------------+-- running the code generation monad++runExceptTPutM :: ExceptT e Binary.PutM a -> Either e (a, ByteString)+runExceptTPutM = runExceptT >>> uncurry leftStrength . Binary.runPutM++runCGMonad :: CGContext -> CGState -> CGMonad r -> Either ShortText (r, CGState, ByteString)+runCGMonad context state+  =   runFreshSuccT  +  >>> ( `runReaderT` context )+  >>> ( `runStateT`  state   )+  >>> runExceptT+  >>> runWriter+  >>> \ ( res, b ) -> fmap ( \ ( r, s ) -> ( r, s, toLazyByteString b ) ) res++----------------------------------------------------------------------------+-- utility for exceptions++note :: forall m a e. MonadError e m => e -> Maybe a -> m a+note _ (Just a) = pure a+note e Nothing  = throwError e
+ src/CodeGen/Optics.hs view
@@ -0,0 +1,918 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE BlockArguments         #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE PatternSynonyms        #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE RecordWildCards        #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE ViewPatterns           #-}++{-|+Module: CodeGen.Optics++Code generation for operations involving the type-level optics used by this library,+such as @view@, @set@, @use@, @assign@.++-}++module CodeGen.Optics ( ) where++-- base+import Control.Arrow+  ( first )+import Control.Monad+  ( unless )+import Data.Foldable+  ( traverse_ )+import Data.Kind+  ( Type )+import Data.Proxy+  ( Proxy(Proxy) )+import Data.Type.Equality+  ( (:~:)(Refl) )+import Data.Typeable+  ( eqT )+import Data.Word+  ( Word32 )+import Unsafe.Coerce+  ( unsafeCoerce )++-- lens+import Control.Lens+  ( assign )++-- mtl+import Control.Monad.Except+  ( throwError )++-- text-short+import Data.Text.Short+  ( ShortText )+import qualified Data.Text.Short as ShortText+  ( pack )++-- fir+import CodeGen.Application+  ( ASTs(NilAST, ConsAST), pattern SnocAST+  , Codes, pattern ConsCode+  , Application(..)+  )+import {-# SOURCE #-} CodeGen.CodeGen+  ( CodeGen(codeGenArgs), codeGen )+import CodeGen.Composite+  ( compositeConstruct+  , compositeExtract+  , compositeInsert+  , vectorSwizzle+  , productConstruct+  )+import CodeGen.Debug+  ( whenAsserting )+import CodeGen.IDs+  ( constID, bindingID, typeID )+import CodeGen.Images+  ( imageTexel, writeTexel )+import CodeGen.Instruction+  ( ID(ID), Pointer(..) )+import CodeGen.Monad+  ( CGMonad )+import CodeGen.Pointers+  ( Safeness(Safe, Unsafe)+  , Indices(RTInds, CTInds)+  , temporaryVariable, accessChain+  , load, store+  , loadInstruction, storeInstruction+  )+import CodeGen.Atomics+  ( atomicInstruction )+import CodeGen.State+  ( PointerState(Fresh, Modified)+  , _localBinding+  , setTemporaryPointer+  )+import Control.Type.Optic+  ( Optic+  , ProductComponents(..) )+import Data.Constraint.All+  ( All(allDict)+  , AllDict(NilDict, ConsDict)+  )+import Data.Product+  ( HList(HNil, (:>))+  , MapHList+  , IsProduct(toHList)+  , AreProducts(productsDict)+  , AreProductsDict(ConsProducts)+  , Distribute+  , distributeZipConsLemma1+  )+import Data.Type.Known+  ( knownValue )+import Data.Type.List+  ( type (:++:), ZipCons+  , KnownLength(sLength)+  , SLength(SZero, SSucc)+  , SameLength(sSameLength)+  , SSameLength(SSameZero, SSameSucc)+  , Snoc+  )+import FIR.AST+  ( AST, Code+  , pattern (:$), pattern Lit+  , pattern MkID+  , pattern NilHList, pattern ConsHList+  , OpticF(..)+  )+import FIR.AST.Type+  ( AugType(Val), MapVal )+import FIR.Prim.Atomic+  ( SAtomicOp, atomicOp, SAtomicShape(..), atomicShape )+import FIR.Prim.Types+  ( PrimTy, primTy, primTys+  , SPrimTy(..), sPrimTy+  )+import FIR.Syntax.Optics+  ( SOptic(..), showSOptic+  , SProductComponents(..)+  )+import qualified SPIRV.PrimTy  as SPIRV++----------------------------------------------------------------------------+-- Code generation for optics.++data OpticArgs where+  OpticView   :: forall is s a (optic :: Optic is s a). SOptic optic -> Codes is -> Code s -> OpticArgs+  OpticSet    :: forall is s a (optic :: Optic is s a). SOptic optic -> Codes is -> Code a -> Code s -> OpticArgs+  OpticUse    :: forall is s a (optic :: Optic is s a). SOptic optic -> Codes is -> OpticArgs+  OpticAssign :: forall is s a (optic :: Optic is s a). SOptic optic -> Codes is -> Code a -> OpticArgs+  OpticAtomic :: forall is s a (optic :: Optic is s a) op+              .  SAtomicOp op -> SOptic optic -> Codes is -> [ Code a ]+              -> OpticArgs++opticArgs :: Application (OpticF AST) f r -> OpticArgs+opticArgs ( Applied ( ViewF _ ( sOptic :: SOptic ( optic :: Optic is s a) ) ) is_s ) =+  case unsafeCoerce is_s :: ( ASTs (MapVal is `Snoc` Val s) ) of+    ( is `SnocAST` s ) -> OpticView sOptic is s+opticArgs ( Applied ( SetF _ ( sOptic :: SOptic ( optic :: Optic is s a) ) ) is_a_s ) =+  case unsafeCoerce is_a_s :: ( ASTs ( MapVal is `Snoc` Val a `Snoc` Val s ) ) of+    ( is `SnocAST` a `SnocAST` s ) -> OpticSet sOptic is a s+opticArgs ( Applied ( UseF _ ( sOptic :: SOptic ( optic :: Optic is s a) ) ) is ) =+  case unsafeCoerce is :: ASTs ( MapVal is ) of+    js -> OpticUse sOptic js+opticArgs ( Applied ( AssignF _ ( sOptic :: SOptic ( optic :: Optic is s a) ) ) is_a ) =+  case unsafeCoerce is_a :: ( ASTs ( MapVal is `Snoc` Val a ) ) of+    ( is `SnocAST` a ) -> OpticAssign sOptic is a+opticArgs ( Applied ( AtomicF sOp _ ( sOptic :: SOptic ( optic :: Optic is s a) ) ) is_vs ) =+  case atomicShape sOp of+    SReads ->+      OpticAtomic sOp sOptic ( unsafeCoerce is_vs :: Codes is ) []+    SWrites ->+      case unsafeCoerce is_vs :: ( ASTs ( MapVal is `Snoc` Val a ) ) of+      ( is `SnocAST` v ) -> OpticAtomic sOp sOptic is [ v ]+    SModifies ->+      case unsafeCoerce is_vs :: ( ASTs ( MapVal is `Snoc` Val a ) ) of+      ( is `SnocAST` v ) -> OpticAtomic sOp sOptic is [ v ]+    SCompares ->+      case unsafeCoerce is_vs :: ( ASTs ( MapVal is `Snoc` Val a `Snoc` Val a ) ) of+        ( is `SnocAST` expected `SnocAST` new )+          -> OpticAtomic sOp sOptic is [ expected, new ]+++instance CodeGen AST => CodeGen (OpticF AST) where++  codeGenArgs opticApplication = case opticArgs opticApplication of {++  -- View.+  OpticView sOptic is s -> do+    base <- codeGen s+    extractUsingGetter base sOptic is++  ;+  -- Set.+  OpticSet sOptic is a s -> do+    setUsingSetter s a sOptic is++  ;+  -- Use.+  OpticUse sOptic is -> case sOptic of++    SBinding (_ :: Proxy name) ->+      do  let varName = knownValue @name+          bd@(bdID, bdTy) <- bindingID varName+          case bdTy of+            SPIRV.Pointer ptrTy+              -> load varName (Pointer bdID ptrTy)+            _ -> pure bd++    -- image+    SImageTexel ( _ :: Proxy name ) ( _ :: Proxy props ) texelTy+      -> case is of +          ( ops `ConsAST` coords `ConsAST` NilAST )+            -> do+                  let imgName = knownValue @name+                      imgTexelTy = sPrimTy texelTy+                  bd@(bdID, bdTy) <- bindingID imgName+                  resTyID <- typeID imgTexelTy+                  img <- case bdTy of+                            SPIRV.Pointer ptrTy+                              -> load imgName (Pointer bdID ptrTy)+                            _ -> pure bd+                  (cdID, _) <- codeGen coords+                  imageTexel img ops cdID (resTyID, imgTexelTy)++    SComposeO _ (SBinding (_ :: Proxy name )) getter ->+      do  let varName = knownValue @name+          bd@(bdID, bdTy) <- bindingID varName++          case bdTy of+            SPIRV.Pointer ptrTy+              -> loadThroughAccessChain (Pointer bdID ptrTy) getter is+            _ -> extractUsingGetter     bd                   getter is++    SComposeO+      (SSucc (SSucc _))+      (SImageTexel ( _ :: Proxy name ) ( _ :: Proxy props ) texelTy)+      getter+       -> case is of+            ( ops `ConsAST` coords `ConsAST` nextindices )+              ->+                do +                  -- copy-pasted from above+                  let imgName = knownValue @name+                      imgTexelTy = sPrimTy texelTy+                  bd@(bdID, bdTy) <- bindingID imgName+                  resTyID <- typeID imgTexelTy+                  img <- case bdTy of+                            SPIRV.Pointer ptrTy+                              -> load imgName (Pointer bdID ptrTy)+                            _ -> pure bd+                  (cdID, _) <- codeGen coords+                  -- end of copy-paste+                  texel <- imageTexel img ops cdID (resTyID, imgTexelTy)+                  extractUsingGetter texel getter nextindices++    _ -> throwError (   "codeGen: cannot 'use', unsupported optic:\n"+                     <> ShortText.pack (showSOptic sOptic) <> "\n"+                     <> "Optic does not start by accessing a binding (or image texel).\n"+                    )++  ;+  -- Assign.+  OpticAssign sOptic is a -> case sOptic of++   SBinding (_ :: Proxy name) ->+     do  let varName = knownValue @name+         a_IDTy@(a_ID, _) <- codeGen a+         (bdID, bdTy)     <- bindingID varName++         case bdTy of+           SPIRV.Pointer ptrTy+             -> store varName (Pointer bdID ptrTy) a_ID+           _ -> assign ( _localBinding varName ) (Just a_IDTy)++         pure (ID 0, SPIRV.Unit) -- ID should never be used++   -- image+   SImageTexel ( _ :: Proxy name ) ( _ :: Proxy props ) _+     -> case is of +         ( ops `ConsAST` coords `ConsAST` NilAST )+           -> do+                 let imgName = knownValue @name+                 bd@(bdID, bdTy) <- bindingID imgName+                 img <- case bdTy of+                           SPIRV.Pointer ptrTy+                             -> load imgName (Pointer bdID ptrTy)+                           _ -> pure bd+                 (cdID , _) <- codeGen coords+                 (texID, _) <- codeGen a+                 writeTexel img ops cdID texID+                 pure (ID 0, SPIRV.Unit) -- ID should never be used++   SComposeO _ (SBinding (_ :: Proxy name)) setter ->+     do  let varName = knownValue @name+         bd@(bdID, bdTy) <- bindingID varName++         case bdTy of+           SPIRV.Pointer ptrTy+             -> storeThroughAccessChain   (Pointer bdID ptrTy) a setter is+           _ -> insertUsingSetter varName bd                   a setter is++         pure (ID 0, SPIRV.Unit) -- ID should never be used++   SComposeO _ SImageTexel {} _+     -> throwError ( "codeGen: writing to individual components \+                     \of an image texel currently unsupported"+                   )++   _ -> throwError (   "codeGen: cannot 'assign', unsupported optic:\n"+                    <> ShortText.pack (showSOptic sOptic) <> "\n"+                    <> "Optic does not start by accessing a binding."+                   )++  ;+  -- Atomic operation.+  OpticAtomic sOp sOptic is operands -> do+    let opName = ShortText.pack ( show ( atomicOp sOp ) )+    ptr        <- opticPointer opName sOptic is+    operandIDs <- traverse ( fmap fst . codeGen ) operands+    atomicInstruction sOp ptr operandIDs++  }++----------------------------------------------------------------------------+-- Pointers denoted by optics.++-- | The pointer an optic focuses on: the optic must start with a binding of+-- pointer type, possibly followed by an access chain.+opticPointer+  :: forall is s a (optic :: Optic is s a)+  .  CodeGen AST+  => ShortText -- ^ Name of the operation (for error messages).+  -> SOptic optic+  -> Codes is+  -> CGMonad Pointer+opticPointer opName sOptic is = case sOptic of+  SBinding ( _ :: Proxy name ) ->+    bindingPointer ( knownValue @name )+  SComposeO _ ( SBinding ( _ :: Proxy name ) ) accessor -> do+    basePtr <- bindingPointer ( knownValue @name )+    pointerThroughAccessChain' opName basePtr =<< operationTree is accessor+  _ -> unsupported "Optic does not start by accessing a binding."+  where+    bindingPointer :: ShortText -> CGMonad Pointer+    bindingPointer varName = do+      (bdID, bdTy) <- bindingID varName+      case bdTy of+        SPIRV.Pointer ptrTy+          -> pure ( Pointer bdID ptrTy )+        _ -> unsupported+               ( "Binding \"" <> varName <> "\" is not of pointer type." )+    unsupported :: ShortText -> CGMonad x+    unsupported reason =+      throwError (   "codeGen: cannot '" <> opName <> "', unsupported optic:\n"+                  <> ShortText.pack (showSOptic sOptic) <> "\n"+                  <> reason+                 )++----------------------------------------------------------------------------+-- Perform code-generation by computing associated optical trees.++-- | Load through a pointer with the supplied getter.+loadThroughAccessChain+  :: forall is s a (optic :: Optic is s a)+  .  CodeGen AST+  => Pointer -> SOptic optic -> Codes is -> CGMonad (ID, SPIRV.PrimTy)+loadThroughAccessChain basePtr sOptic is+  = loadThroughAccessChain' basePtr =<< operationTree is sOptic++-- | Use a getter to @view@ a part of the provided object.+extractUsingGetter+  :: forall is s a (optic :: Optic is s a)+  .  CodeGen AST+  => (ID, SPIRV.PrimTy) -> SOptic optic -> Codes is -> CGMonad (ID, SPIRV.PrimTy)+extractUsingGetter base sOptic is+  = extractUsingGetter' base =<< operationTree is sOptic++-- | Store into a pointer with the supplied setter.+storeThroughAccessChain+  :: forall is s a (optic :: Optic is s a)+  .  CodeGen AST+  => Pointer -> Code a -> SOptic optic -> Codes is -> CGMonad ()+storeThroughAccessChain basePtr val sOptic is+  = storeThroughAccessChain' basePtr val =<< operationTree is sOptic++-- | Set a component of an object, with focus given by the supplied setter.+--+-- Returns the updated object.+setUsingSetter+  :: forall is s a (optic :: Optic is s a)+  .  CodeGen AST+  => Code s+  -> Code a+  -> SOptic optic+  -> Codes is+  -> CGMonad (ID, SPIRV.PrimTy)+setUsingSetter base val sOptic is = do+  baseID <- codeGen base+  tree   <- operationTree is sOptic+  setUsingSetter' baseID val tree++-- | Set a component of a binding, with focus given by the supplied setter.+--+-- Doesn't return anything: updates the state of the provided binding.+insertUsingSetter+  :: forall is s a (optic :: Optic is s a)+  .  CodeGen AST+  => ShortText -> (ID, SPIRV.PrimTy) -> Code a -> SOptic optic -> Codes is -> CGMonad ()+insertUsingSetter varName base val sOptic is = do+  tree   <- operationTree is sOptic+  insertUsingSetter' varName base val tree++----------------------------------------------------------------------------+-- Optical trees.++data OpticalNode where+  Access   :: Safeness -> Indices -> OpticalNode+  OfTypeOp :: SPrimTy s -> SPrimTy a -> OpticalNode+  Combine  :: (PrimTy p, All PrimTy as, IsProduct p as)+           => Proxy p -> Proxy as -> [ OpticalOperationTree ] -> OpticalNode++instance Show OpticalNode where+  show (Access safe is) = "Access " ++ show safe ++ " " ++ show is+  show (OfTypeOp s a) = "OfTypeOp @" ++ show s ++ " @" ++ show a+  show (Combine (_ :: Proxy p) ( _ :: Proxy as) trees)+    = "Combine @" ++ show (primTy @p) ++ " @" ++ show (primTys @as)+    ++ " " ++ show trees++type OpticalOperationTree = [ OpticalNode ]++operationTree+  :: forall k is (s :: k) a (optic :: Optic is s a)+  .  CodeGen AST+  => Codes is -> SOptic optic -> CGMonad OpticalOperationTree+operationTree _ (SOfType s a) = pure [OfTypeOp s a]+operationTree (i `ConsAST` _) SAnIndex {}+  = (:[]) . Access Unsafe . RTInds . (:[]) . fst <$> codeGen i+operationTree _ (SIndex s _ n)+  -- if accessing a runtime array, a compile-time index may be unsafe+  | SRuntimeArray <- s+  = pure [ Access Unsafe (CTInds [n]) ]+  -- otherwise, a compile-time index is guaranteed to be in-bounds+  | otherwise+  = pure [ Access Safe   (CTInds [n]) ]+operationTree is (SComposeO lg1 opt1 opt2)+  = do  let (is1, is2) = composedIndices lg1 is+        ops1 <- operationTree is1 opt1+        ops2 <- operationTree is2 opt2+        ops1 `continue` ops2+operationTree is+  ( SProd same (comps :: SProductComponents (os :: ProductComponents iss s as))+    :: SOptic (optic :: Optic is s a)+  ) = do+        comp_indices <- combinedIndices @iss @is @as sSameLength sLength is+        comp_trees   <- componentsTrees same comps comp_indices+        case comp_trees of+          []       -> return []+          [ tree ] -> return tree+          trees    -> return [ Combine ( Proxy @a ) ( Proxy @as ) trees ]+            -- N.B.: only combine optical subtrees when there is combining taking place.+            -- If there are fewer than 2 subtrees, we won't be creating a composite structure.+            -- See bug #88.+operationTree _ (SBinding {})+  = throwError "operationTree: trying to access a binding within a binding"+operationTree _ (SImageTexel {})+  = throwError "operationTree: unexpected image optic"++continue :: OpticalOperationTree -> OpticalOperationTree -> CGMonad OpticalOperationTree+continue ops1 []   = pure ops1+continue []   ops2 = pure ops2+-- try to combine successive accesses into a single access chain as much as possible+-- (this helps bypass Vulkan implementation bugs in tessellation evaluation shaders)+continue [Access safe1 (CTInds is1)] (Access safe2 (CTInds is2) : ops2)+  = pure $ Access (safe1 <> safe2) (CTInds (is1 ++ is2)) : ops2+continue [Access safe1 (RTInds is1)] (Access safe2 (RTInds is2) : ops2)+  = pure $ Access (safe1 <> safe2) (RTInds (is1 ++ is2)) : ops2+continue [Access safe1 (CTInds is1)] (Access safe2 (RTInds is2) : ops2)+  = do+      js1 <- traverse constID is1+      pure $ ( Access (safe1 <> safe2) (RTInds (js1 ++ is2)) : ops2 )+continue [Access safe1 (RTInds is1)] (Access safe2 (CTInds is2) : ops2)+  = do+      js2 <- traverse constID is2+      pure $ Access (safe1 <> safe2) (RTInds (is1 ++ js2)) : ops2+continue (op1 : ops1) ops2+  = do+      cont <- ops1 `continue` ops2+      pure $ op1 : cont++componentsTrees+  :: forall+      (k :: Type) (iss :: [[Type]]) (s :: k)+      (as :: [Type]) (os :: ProductComponents iss s as)+  .  CodeGen AST+  => SSameLength (Distribute iss as) as+  -> SProductComponents os+  -> Codes (MapHList (Distribute iss as))+  -> CGMonad [OpticalOperationTree]+componentsTrees _ SEndProd  _+  = pure []+componentsTrees sameSucc@(SSameSucc lg) (so `SProductO` sos) (is `ConsAST` iss) =+  case sameSucc of+    ( _ :: SSameLength (ds ': dss) (b ': bs) ) ->+      case so of+        ( _ :: SOptic ( o :: Optic es s b ) ) ->+          case sos of+           ( _ :: SProductComponents ( tail_os :: ProductComponents ess s bs ) ) ->+            case distributeZipConsLemma1 @b @bs @ds @dss @es @ess of+              (Refl, Refl) ->+                (:) <$> operationTree (astsFromHList is) so <*> componentsTrees lg sos iss++composedIndices :: SLength is -> Codes (is :++: js) -> (Codes is, Codes js)+composedIndices SZero           js               = ( NilAST, js )+composedIndices (SSucc tail_is) (k `ConsAST` ks)+  = first ( k `ConsAST` ) ( composedIndices tail_is ks )++combinedIndices+  :: forall (jss :: [[Type]]) (is :: [Type]) (as :: [Type])+  .  ( CodeGen AST, AreProducts is jss as )+  => SSameLength is jss+  -> SLength as+  -> Codes is+  -> CGMonad (Codes (MapHList (Distribute jss as)))+combinedIndices SSameZero SZero      NilAST+  = pure $ NilAST+combinedIndices SSameZero (SSucc lg) NilAST+  = (NilHList `ConsAST`) <$> combinedIndices SSameZero lg NilAST+combinedIndices sSame@(SSameSucc sm) lg (i `ConsAST` is) =+  case sSame of+    ( _ :: SSameLength (p ': ps) (es ': ess) ) ->+      case productsDict @is @jss @as of+        ConsProducts ->+          zipIndices @es @(Distribute ess as) allDict sSameLength+            <$> deconstruct allDict i+            <*> combinedIndices sm lg is++zipIndices+  :: AllDict PrimTy is+  -> SSameLength is jss+  -> Codes is+  -> Codes (MapHList jss)+  -> Codes (MapHList (ZipCons is jss))+zipIndices NilDict  SSameZero      NilAST           NilAST             = NilAST+zipIndices ConsDict (SSameSucc lg) (i `ConsAST` is) (js `ConsAST` jss) =+  (ConsHList :$ i :$ js) `ConsAST` zipIndices allDict lg is jss++deconstruct+  :: forall (p :: Type) (as :: [Type])+  .  ( CodeGen AST, IsProduct p as )+  => AllDict PrimTy as -> Code p -> CGMonad (Codes as)+deconstruct NilDict    _       = pure NilAST+deconstruct dict       (Lit x) = pure $ hListToASTs dict (toHList @p @as x)+deconstruct dict       p+  | Just hlist <- recogniseHList dict p+  = pure hlist+  -- TODO: more cases to avoid spurious "compositeConstruct ---> compositeExtract"+deconstruct ConsDict p = do+    composite <- codeGen p+    compositeExtractAll composite allDict 0+++recogniseHList :: AllDict PrimTy as -> Code p -> Maybe (Codes as)+recogniseHList NilDict           _   = Just NilAST+recogniseHList consDict@ConsDict ast+  = case consDict of+      ( _ :: AllDict PrimTy (b ': bs) ) ->+        case ast of+          ( ConsHList :$ (c :: Code c) :$ cs )+            | Just Refl <- eqT @b @c+            -> (c `ConsAST`) <$> recogniseHList allDict cs+          _ -> Nothing++astsFromHList :: Code (HList as) -> Codes as+astsFromHList NilHList+  = NilAST+astsFromHList (ConsHList :$ a :$ as)+  = a `ConsAST` astsFromHList as+astsFromHList _+  = error "'operationTree': indexing heterogenous list AST not of the expected form (TODO?)"++hListToASTs :: AllDict PrimTy as -> HList as -> Codes as+hListToASTs _        HNil      = NilAST+hListToASTs ConsDict (a :> as) = Lit a `ConsAST` hListToASTs allDict as++compositeExtractAll+  :: forall (as :: [Type])+  .  CodeGen AST+  => (ID, SPIRV.PrimTy)+  -> AllDict PrimTy as+  -> Word32+  -> CGMonad (Codes as)+compositeExtractAll _                    NilDict  _ = pure NilAST+-- special case for matrix entries:+-- product for matrices can use individual components (rather than just columns)+compositeExtractAll comp@(_,compTy) dict@ConsDict i+  | SPIRV.Matrix {..} <- compTy+  , SPIRV.Scalar entryTy == expectedTy+  = do+      extracted <- traverse (compositeExtract comp) $ [ [i,j] | j <- [0..pred rows] ]+      makeIDsAndContinue (succ i) dict extracted++        where+          expectedTy :: SPIRV.PrimTy+          expectedTy = case dict of+            ( _ :: AllDict PrimTy (b ': bs) )+              -> primTy @b++          makeIDsAndContinue+            :: Word32+            -> AllDict PrimTy ts+            -> [(ID, SPIRV.PrimTy)]+            -> CGMonad (Codes ts)+          makeIDsAndContinue _        NilDict  _   = pure NilAST+          makeIDsAndContinue nxt dict'          []  = compositeExtractAll comp dict' nxt+          makeIDsAndContinue nxt dict'@ConsDict+            ( extract@(_,extractedTy) : extracts ) =+              case dict' of+                ( _ :: AllDict PrimTy (c ': cs) )+                  -> do+                        whenAsserting . unless ( expectedTy == extractedTy ) $+                          throwError $+                            "'compositeExtractAll': ASSERT failed\n"+                            <> "expected type" <> ShortText.pack (show expectedTy)+                            <> ", but composite component " <> ShortText.pack (show i)+                            <> " has type " <> ShortText.pack (show extractedTy)++                        next <- makeIDsAndContinue nxt allDict extracts+                        pure $ MkID extract `ConsAST` next+-- usual case+compositeExtractAll comp ConsDict i =+  do+    extracted <- compositeExtract comp [i]+    next      <- compositeExtractAll comp allDict (succ i)+    pure $ MkID extracted `ConsAST` next++----------------------------------------------------------------------------+-- Generate code for a tree of optical operations.++-- check whether a vector swizzle operation can be used+swizzleIndices :: SPIRV.PrimTy -> [OpticalOperationTree] -> Maybe [Word32]+swizzleIndices (SPIRV.Vector _ _) = traverse simpleIndex+  where+    simpleIndex :: OpticalOperationTree -> Maybe Word32+    simpleIndex [Access Safe (CTInds [i])] = Just i+    simpleIndex _ = Nothing+swizzleIndices _ = const Nothing++loadThroughAccessChain'+  :: CodeGen AST+  => Pointer -> OpticalOperationTree -> CGMonad (ID, SPIRV.PrimTy)+loadThroughAccessChain' basePtr []+  = loadInstruction basePtr+loadThroughAccessChain' basePtr ( Access safe is : ops )+  = do+      newBasePtr <- accessChain basePtr safe is+      loadThroughAccessChain' newBasePtr ops+loadThroughAccessChain' basePtr@(Pointer _ (SPIRV.PointerTy _ _ eltTy)) ( Combine (_ :: Proxy p) _ trees : ops )+  -- special case: can we use a vector swizzle operation?+  | Just is <- swizzleIndices eltTy trees+  = do+      base <- loadThroughAccessChain' basePtr []+      vec <- vectorSwizzle base is+      extractUsingGetter' vec ops+  | otherwise+  = do+      subtrees <- traverse (loadThroughAccessChain' basePtr) trees+      combined <- productConstruct (primTy @p) subtrees+      extractUsingGetter' combined ops+loadThroughAccessChain' _ ( OfTypeOp _ _ : _ )+  = throwError "loadThroughAccessChain': unexpected 'OfType' optic used as a getter"++-- | Follow a pointer through a tree of optical operations, which must be an+-- access chain (no product or 'OfType' optics).+pointerThroughAccessChain'+  :: ShortText -- ^ Name of the operation (for error messages).+  -> Pointer -> OpticalOperationTree -> CGMonad Pointer+pointerThroughAccessChain' _ basePtr []+  = pure basePtr+pointerThroughAccessChain' opName basePtr ( Access safe is : ops )+  = do+      newBasePtr <- accessChain basePtr safe is+      pointerThroughAccessChain' opName newBasePtr ops+pointerThroughAccessChain' opName _ ( OfTypeOp {} : _ )+  = throwError ( "codeGen: cannot '" <> opName <> "' through an 'OfType' \+                 \optic, which does not denote a pointer." )+pointerThroughAccessChain' opName _ ( Combine {} : _ )+  = throwError ( "codeGen: cannot '" <> opName <> "' through a product \+                 \optic, which does not denote a pointer." )+++extractUsingGetter'+  :: CodeGen AST+  => (ID, SPIRV.PrimTy) -> OpticalOperationTree -> CGMonad (ID, SPIRV.PrimTy)+extractUsingGetter' base []+  = pure base+extractUsingGetter' base tree@( Access _ (CTInds is) : ops )+  = do+      whenAsserting+        case base of+          ( _, SPIRV.Scalar _ ) ->+            throwError+              ( "extractUsingGetter': ASSERT failed, trying to extract from a scalar type\n\+                \base = " <> ShortText.pack ( show base ) <> "\n\+                \tree = " <> ShortText.pack ( show tree )+              )+          _ -> pure ()+      newBase <- compositeExtract base is+      extractUsingGetter' newBase ops+extractUsingGetter' base@(baseID, _) ops@( Access _ (RTInds _) : _ )+  -- run-time indices: revert to loading through pointers+  = do+      (basePtr, basePtrState) <- temporaryVariable base+      unless+        ( basePtrState == Fresh )+        ( do storeInstruction basePtr baseID+             -- reset temporary pointer to "fresh" as we just loaded the baseID into it+             setTemporaryPointer baseID (basePtr, Fresh)+        )+      loadThroughAccessChain' basePtr ops+extractUsingGetter' base@(_, eltTy) ( Combine (_ :: Proxy p) _ trees : ops )+  -- special case: can we use a vector swizzle operation?+  | Just is <- swizzleIndices eltTy trees+  = do+      vec <- vectorSwizzle base is+      extractUsingGetter' vec ops+  | otherwise+  = do+      subtrees <- traverse (extractUsingGetter' base) trees+      combined <- productConstruct (primTy @p) subtrees+      extractUsingGetter' combined ops+extractUsingGetter' _ ( OfTypeOp _ _ : _ )+  = throwError "extractUsingGetter': unexpected 'OfType' optic used as a getter"+++storeThroughAccessChain'+  :: CodeGen AST+  => Pointer -> Code a -> OpticalOperationTree -> CGMonad ()+-- Base case: identity.+storeThroughAccessChain' basePtr val []+  = storeInstruction basePtr =<< fst <$> codeGen val+-- Access.+storeThroughAccessChain' basePtr val ( Access safe is : ops )+  = do+      newBasePtr <- accessChain basePtr safe is+      storeThroughAccessChain' newBasePtr val ops+-- OfType optic.+storeThroughAccessChain' basePtr val ( OfTypeOp _ a : ops )+  = storeAtTypeThroughAccessChain basePtr val ops (sPrimTy a) [ wholeObject basePtr ]+-- Product optic.+-- This is a bit more tricky and requires a second level of recursion.+--+--   * Base case.+storeThroughAccessChain' basePtr val ( Combine (_ :: Proxy p) (_ :: Proxy as) trees : [] )+  = successiveStores basePtr trees =<< deconstruct @p @as allDict (unsafeCoerce val)+--   * Access.+storeThroughAccessChain' _ _ ( Combine {} : Access {} : _ )+  = throwError "storeThroughAccessChain': currently unsupported composition ( product optic - indexing )"+--   * OfType optic.+--     If "OfType ty" pertains to the individual components, then we can+--     perform a 'storeAtTypeThroughAccessChain' on all the components in turn.+--     We must first catch the other cases: focus onto a part that arose from the creation of the product type.+storeThroughAccessChain' basePtr val ( Combine (px_p :: Proxy p) (px_as :: Proxy as) trees : OfTypeOp _ a : ops )+  -- Start off by catching situations where we focus on a part that arose from the product.+  --   * 'Combine' followed by 'OfType combinedTy': can ignore 'OfType combinedTy' (identity lens).+  | combinedTy == ofTypeTy+  = storeThroughAccessChain' basePtr val ( Combine px_p px_as trees : ops )+  --   * Finicky corner case: we are combining entries (not columns) to form a matrix, but followed by `OfType colTy`.+  | SPIRV.Matrix m _ eltTy <- combinedTy+  , ( SPIRV.Scalar eltTy' : _ ) <- compTys+  , eltTy'  == eltTy+  , ( SPIRV.Vector m' (SPIRV.Scalar eltTy'') ) <- ofTypeTy+  , eltTy'' == eltTy && m' == m+  = throwError "storeThroughAccessChain': currently unsupported corner case \+      \(matrix product of entries followed by 'OfType' optic focused on column type)"+  -- General case: call 'storeAtTypeThroughAccessChain' on all the components in turn.+  | otherwise+  = storeAtTypeThroughAccessChain basePtr val ops ofTypeTy ( zipWith Component trees compTys )+  where+    combinedTy, ofTypeTy :: SPIRV.PrimTy+    compTys :: [SPIRV.PrimTy]+    combinedTy = primTy @p+    ofTypeTy   = sPrimTy a+    compTys    = primTys @as+--  * Second product optic.+storeThroughAccessChain' _ _ ( Combine {} : Combine {} : _ )+  = throwError "storeThroughAccessChain': currently unsupported composition ( product optic - product optic )"+++-- | Store into all the subcomponents of the given type of the given components,+-- applying the given operations to each of these subcomponents.+storeAtTypeThroughAccessChain+  :: CodeGen AST+  => Pointer+  -> Code a+  -> OpticalOperationTree+  -> SPIRV.PrimTy+  -> [ Component ]+  -> CGMonad ()+storeAtTypeThroughAccessChain basePtr val ops a = traverse_ go+  where+    go :: Component -> CGMonad ()+    go comp+      | componentTy comp == a+      = storeInto basePtr comp val ops+      | [] <- ops+      , Just filled <- replicated ( componentTy comp )+      = do+          v <- filled+          storeInto basePtr comp ( MkID v ) []+      | otherwise+      = traverse_ go =<< subcomponents comp++    -- A vector or matrix whose entries (or columns) are all of the given type+    -- can be stored into all at once.+    replicated :: SPIRV.PrimTy -> Maybe ( CGMonad (ID, SPIRV.PrimTy) )+    replicated ty = case ty of+      SPIRV.Vector n elt+        | elt == a+        -> Just $ fill ty n =<< value+      SPIRV.Matrix m n elt+        | a == colTy+        -> Just $ fill ty n =<< value+        | a == SPIRV.Scalar elt+        -> Just $ fill ty n . fst =<< fill colTy m =<< value+          where+            colTy :: SPIRV.PrimTy+            colTy = SPIRV.Vector m (SPIRV.Scalar elt)+      _ -> Nothing++    value :: CGMonad ID+    value = fst <$> codeGen val++    fill :: SPIRV.PrimTy -> Word32 -> ID -> CGMonad (ID, SPIRV.PrimTy)+    fill ty n x = compositeConstruct ty ( replicate (fromIntegral n) x )++-- | A component of the object a pointer points to.+data Component+  = Component+  { componentAccess :: OpticalOperationTree -- ^ How to access the component.+  , componentTy     :: SPIRV.PrimTy+  }++-- | The object a pointer points to, as a whole.+wholeObject :: Pointer -> Component+wholeObject ptr = Component [] ( SPIRV.pointee ( pointerTy ptr ) )++-- | The immediate subcomponents of a component.+subcomponents :: Component -> CGMonad [ Component ]+subcomponents ( Component access ty ) = case ty of+  SPIRV.Vector n elt    -> indexed n elt+  SPIRV.Matrix m n elt  -> indexed n ( SPIRV.Vector m (SPIRV.Scalar elt) )+  -- TODO: should be a loop as opposed to being fully unrolled,+  -- but creating loops is unfortunately quite cumbersome+  SPIRV.Array l elt     -> indexed l elt+  SPIRV.Struct eltTys   -> sequence $ zipWith sub [0..] ( map snd eltTys )+  SPIRV.RuntimeArray {} -> throwError "codeGen: cannot store into all components of a run-time array"+  _                     -> pure []+  where+    sub :: Word32 -> SPIRV.PrimTy -> CGMonad Component+    sub i subTy = ( `Component` subTy ) <$> access `continue` [ Access Safe (CTInds [i]) ]+    indexed :: Word32 -> SPIRV.PrimTy -> CGMonad [ Component ]+    indexed n eltTy = sequence $ zipWith sub [0..] ( replicate (fromIntegral n) eltTy )++-- | Store a value into a component, applying the given operations to it.+storeInto :: CodeGen AST => Pointer -> Component -> Code b -> OpticalOperationTree -> CGMonad ()+storeInto basePtr comp v ops = storeThroughAccessChain' basePtr v =<< ( componentAccess comp `continue` ops )++successiveStores+  :: CodeGen AST+  => Pointer+  -> [OpticalOperationTree]+  -> Codes as+  -> CGMonad ()+successiveStores basePtr ( tree : trees ) (ConsCode a as) = do+  storeThroughAccessChain' basePtr a  tree+  successiveStores basePtr trees   as+successiveStores _       _                _+  = pure ()++setUsingSetter'+  :: CodeGen AST+  => (ID, SPIRV.PrimTy)+  -> Code a+  -> OpticalOperationTree+  -> CGMonad (ID, SPIRV.PrimTy)+setUsingSetter' _ val [] = codeGen val+setUsingSetter' base val [Access _ (CTInds is)]+  = do+      valID <- codeGen val+      compositeInsert valID base is+-- in more complex situations, revert to using load/store+setUsingSetter' base@(baseID, _) val ops+  = do+      (basePtr, basePtrState) <- temporaryVariable base+      unless+        ( basePtrState == Fresh )+        ( storeInstruction basePtr baseID )+      -- set the temporary pointer state to "modified"+      -- as we are about to store something into it+      setTemporaryPointer baseID (basePtr, Modified)+      storeThroughAccessChain' basePtr val ops+      loadInstruction basePtr++insertUsingSetter'+  :: CodeGen AST+  => ShortText+  -> (ID, SPIRV.PrimTy)+  -> Code a+  -> OpticalOperationTree+  -> CGMonad ()+insertUsingSetter' varName base val ops =+  assign ( _localBinding varName ) . Just =<< setUsingSetter' base val ops
+ src/CodeGen/Phi.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE ScopedTypeVariables #-}++{-|+Module: CodeGen.Phi++Code generation for ϕ-functions, which enables definition of variables in branches when using an SSA form.++See also "CodeGen.CFG" which does code generation for the control flow operation themselves.+-}++module CodeGen.Phi+  ( phiInstruction, phiInstructions )+  where++-- base+import Data.List+  ( foldl1' )+import Data.List.NonEmpty+  ( NonEmpty((:|)) )+import qualified Data.List.NonEmpty as NE+  ( head, singleton, toList )++-- containers+import Data.Map+  ( Map )+import qualified Data.Map.Strict       as Map+import qualified Data.Map.Merge.Strict as Map++-- text-short+import Data.Text.Short+  ( ShortText )+++-- fir+import CodeGen.Binary+  ( instruction )+import CodeGen.IDs+  ( typeID )+import CodeGen.Instruction+  ( ID, Pair(Pair), Instruction(..), toArgs )+import CodeGen.Monad+  ( CGMonad, MonadFresh(fresh) )+import qualified SPIRV.Operation as SPIRV.Op+import qualified SPIRV.PrimTy    as SPIRV++----------------------------------------------------------------------------+-- ϕ-instructions++conflicts :: forall k a. (Ord k, Eq a)+          => ( k -> Bool )+          -> [ Map k a ]+          -> Map k (NonEmpty a)+conflicts keyIsOK+  = Map.filterWithKey ( \k as -> keyIsOK k && any (/= NE.head as) as )+  . foldl1'+      ( Map.merge+          Map.dropMissing+          Map.dropMissing+          ( Map.zipWithMatched (const (<>)) )+      )+  . map (fmap NE.singleton)++-- use "Pair" for the correct "Put" instance for list of pairs+phiInstruction :: (ID, SPIRV.PrimTy) -> [ Pair ID ID ] -> CGMonad ()+phiInstruction (v, ty) bdAndBlockIDs+  = do+      tyID <- typeID ty+      instruction+        Instruction+          { operation = SPIRV.Op.Phi+          , resTy     = Just tyID+          , resID     = Just v+          , args      = toArgs bdAndBlockIDs+          }++phiInstructions :: ( ShortText -> Bool )+                -> [ ID ]+                -> [ Map ShortText (ID, SPIRV.PrimTy) ]+                -> CGMonad (Map ShortText ID)+phiInstructions isRelevant blocks bindings +  = Map.traverseWithKey+      ( \ _ idsAndTys@( (_,ty) :| _ ) -> do+        let bdAndBlockIDs :: [Pair ID ID]+            bdAndBlockIDs+              = zipWith+                  (\(x_ID, _) blk -> Pair (x_ID, blk))+                  (NE.toList idsAndTys)+                  blocks+        v <- fresh+        phiInstruction (v,ty) bdAndBlockIDs+        pure v+      )+      ( conflicts isRelevant bindings )
+ src/CodeGen/Pointers.hs view
@@ -0,0 +1,305 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DerivingStrategies  #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE TypeApplications    #-}++{-|+Module: CodeGen.Pointers++Code generation for load/store instruction using pointers.++Values always have logical types, whereas memory can impose a layout on the types it contains.+Loading and storing converts between the two.+-}++module CodeGen.Pointers+  ( Safeness(Safe, Unsafe)+  , Indices(RTInds, CTInds)+  , newVariable, temporaryVariable+  , accessChain+  , load, loadInstruction+  , store, storeInstruction+  , relayout+  ) where++-- base+import Data.Word+  ( Word32 )++-- containers+import qualified Data.Map.Strict as Map++-- mtl+import Control.Monad.Except+  ( throwError )++-- lens+import Control.Lens+  ( use, assign, view )++-- text-short+import Data.Text.Short+  ( ShortText )+import qualified Data.Text.Short as ShortText+  ( pack )++-- fir+import CodeGen.Binary+  ( instruction )+import CodeGen.Composite+  ( accessedLaidOutTy )+import CodeGen.IDs+  ( typeID, laidOutTypeID, constID )+import CodeGen.Instruction+  ( Args(..), toArgs+  , ID, TyID, Instruction(..)+  , Pointer(..), Variable(..)+  )+import CodeGen.Monad+  ( CGMonad+  , MonadFresh(fresh)+  , note+  )+import CodeGen.State+  ( PointerState(Fresh)+  , _interfaceBinding+  , _knownConstants+  , _spirvVersion+  , currentFunctionContext+  , addLocalVariable+  , lookupTemporaryPointer, setTemporaryPointer+  )+import FIR.Prim.Types+  ( SPrimTy(..), SScalarTy(..)+  , PrimTy(primTySing), ScalarTy(scalarTySing)+  , AConstant(AConstant)+  )+import FIR.ProgramState+  ( FunctionContext(TopLevel, InEntryPoint) )+import qualified SPIRV.Layout    as SPIRV+import qualified SPIRV.Operation as SPIRV.Op+import qualified SPIRV.PrimTy    as SPIRV+import qualified SPIRV.Stage     as SPIRV+import qualified SPIRV.Storage   as Storage+import qualified SPIRV.Version   as SPIRV++----------------------------------------------------------------------------+-- safeness of pointer access (whether indices known to be within bounds)++data Safeness+  = Unsafe+  | Safe+  deriving stock ( Eq, Show )++instance Semigroup Safeness where+  Safe <> x = x+  _    <> _ = Unsafe++data Indices+  = CTInds [Word32] -- compile-time indices+  | RTInds [ID]     -- run-time indices+  deriving stock Show++----------------------------------------------------------------------------+-- creating pointers++-- | Create a new local variable of the current function, holding values of the given type.+newVariable :: SPIRV.PrimTy -> CGMonad Pointer+newVariable ty+  = do+      v <- fresh+      ptrTyID <- typeID ( SPIRV.Pointer ptrTy )+      let ptr = Pointer v ptrTy+      addLocalVariable ( Variable ptr ptrTyID )+      pure ptr+  where+    ptrTy :: SPIRV.PointerTy+    ptrTy = SPIRV.PointerTy Storage.Function SPIRV.logical ty++-- | Obtain a local variable holding a copy of the given value, in the current block.+temporaryVariable :: (ID, SPIRV.PrimTy) -> CGMonad (Pointer, PointerState)+temporaryVariable (baseID, baseTy)+  = do+      mbTemp <- lookupTemporaryPointer baseID+      case mbTemp of+        Just temp -> pure temp+        Nothing   -> do+          ptr <- newVariable baseTy+          storeInstruction ptr baseID+          setTemporaryPointer baseID (ptr, Fresh)+          pure (ptr, Fresh)++indicesIDs :: Indices -> CGMonad [ID]+indicesIDs (CTInds ws) = traverse constID ws+indicesIDs (RTInds is) = pure is++-- create a pointer into a composite object with a list of successive indices+accessChain :: Pointer -> Safeness -> Indices -> CGMonad Pointer+accessChain (Pointer basePtrID (SPIRV.PointerTy storage baseLayout baseTy)) safe indices+  = do+      is <- indicesIDs indices+      (eltLayout, eltTy) <-+        note ( "'accessChain': could not compute accessee type.\n\+               \base: " <> ShortText.pack (show baseTy) <> "\n\+               \indices: " <> ShortText.pack (show indices) <> "."+             )+          =<< ( flip accessedLaidOutTy (baseLayout, baseTy) <$> reverseLookupIndices indices )+      let opAccessChain+            = case safe of+                  Safe -> SPIRV.Op.InBoundsAccessChain+                  _    -> SPIRV.Op.AccessChain+          accessPtrTy = SPIRV.PointerTy storage eltLayout eltTy+      accessPtrTyID <- typeID (SPIRV.Pointer accessPtrTy)+      v <- fresh+      instruction+        Instruction+          { operation = opAccessChain+          , resTy     = Just accessPtrTyID+          , resID     = Just v+          , args      = Arg basePtrID+                      $ toArgs is+          }+      pure (Pointer v accessPtrTy)++reverseLookupIndices :: Indices -> CGMonad [ Maybe Word32 ]+reverseLookupIndices (CTInds is) = pure (map Just is)+reverseLookupIndices (RTInds is) = traverse reverseConstantLookup is++reverseConstantLookup :: ID -> CGMonad (Maybe Word32)+reverseConstantLookup c = do+  lookups <- filter ( (== Just c) . resID . snd ) . Map.assocs <$> use _knownConstants+  case lookups of+    ( (AConstant (a :: ty), _) : _ )+      -> case primTySing @ty of+            SScalar ->+              case scalarTySing @ty of+                SWord8  -> pure . Just $ fromIntegral a+                SWord16 -> pure . Just $ fromIntegral a+                SWord32 -> pure . Just $ fromIntegral a+                SWord64 -> pure . Just $ fromIntegral a+                SInt8   -> pure . Just $ fromIntegral a+                SInt16  -> pure . Just $ fromIntegral a+                SInt32  -> pure . Just $ fromIntegral a+                SInt64  -> pure . Just $ fromIntegral a+                _       -> pure Nothing+            _ -> pure Nothing+    _ -> pure Nothing++----------------------------------------------------------------------------+-- load/store through pointers++-- | Load a value through the pointer of the variable with the given name.+load :: ShortText -> Pointer -> CGMonad (ID, SPIRV.PrimTy)+load loadeeName ptr@(Pointer loadeeID (SPIRV.PointerTy storage _ _))+  = do+      context <- currentFunctionContext+      case context of+        TopLevel -> throwError "codeGen: load operation not allowed at top level"+        InEntryPoint entryPointName stageInfo _+          | storage == Storage.Input+          -- add this variable to the interface of the entry point+          -> assign+                ( _interfaceBinding entryPointName (SPIRV.modelOf stageInfo) loadeeName )+                ( Just loadeeID )+        _ -> pure ()+      loadInstruction ptr++-- | Load a value through a pointer.+loadInstruction :: Pointer -> CGMonad (ID, SPIRV.PrimTy)+loadInstruction (Pointer loadeeID (SPIRV.PointerTy _ lay ty))+  = do  tyID <- laidOutTypeID lay ty+        v <- fresh+        instruction+          Instruction+            { operation = SPIRV.Op.Load+            , resTy = Just tyID+            , resID = Just v+            , args  = Arg loadeeID EndArgs+            }+        (, ty) <$> relayout lay SPIRV.logical (v, ty)++-- | Store a value through the pointer of the variable with the given name.+store :: ShortText -> Pointer -> ID -> CGMonad ()+store storeeName ptr@(Pointer ptrID (SPIRV.PointerTy storage _ _)) storeeID+  = do+      context <- currentFunctionContext+      case context of+        TopLevel -> throwError "codeGen: store operation not allowed at top level"+        InEntryPoint entryPointName stageInfo _+          | storage == Storage.Output+          -- add this variable to the interface of the entry point+          -> assign+                ( _interfaceBinding entryPointName (SPIRV.modelOf stageInfo) storeeName )+                ( Just ptrID )+        _ -> pure ()+      storeInstruction ptr storeeID++-- | Store a value through a pointer.+storeInstruction :: Pointer -> ID -> CGMonad ()+storeInstruction (Pointer ptrID (SPIRV.PointerTy _ lay ty)) storeeID+  = do+      laidOutStoreeID <- relayout SPIRV.logical lay (storeeID, ty)+      instruction+        Instruction+          { operation = SPIRV.Op.Store+          , resTy = Nothing+          , resID = Nothing+          , args = Arg ptrID+                 $ Arg laidOutStoreeID EndArgs+          }++----------------------------------------------------------------------------+-- converting between layouts++-- | Convert a value of the given type from one layout to another.+relayout :: SPIRV.Layout -> SPIRV.Layout -> (ID, SPIRV.PrimTy) -> CGMonad ID+relayout from to (v, ty) = do+  fromTyID <- laidOutTypeID from ty+  toTyID   <- laidOutTypeID to   ty+  if fromTyID == toTyID+  then pure v+  else do+    ver <- view _spirvVersion+    if ver >= SPIRV.Version 1 4+    then+      newValue SPIRV.Op.CopyLogical toTyID ( Arg v EndArgs )+    else do+      components <- case ty of+        SPIRV.Array size eltTy+          -> pure $ replicate ( fromIntegral size ) eltTy+        SPIRV.Struct eltTys+          -> pure $ map snd eltTys+        _ -> throwError+               ( "'relayout': cannot convert a value of type " <> ShortText.pack ( show ty )+               <> " from layout " <> ShortText.pack ( show from )+               <> " to layout " <> ShortText.pack ( show to ) <> "."+               )+      let+        fromComp, toComp :: SPIRV.Layout+        fromComp = SPIRV.componentLayout ty from+        toComp   = SPIRV.componentLayout ty to+      convertedComps <-+        traverse+          ( \ ( i, compTy ) -> do+              compTyID <- laidOutTypeID fromComp compTy+              comp <- newValue SPIRV.Op.CompositeExtract compTyID ( Arg v $ Arg i EndArgs )+              relayout fromComp toComp ( comp, compTy )+          )+          ( zip [ ( 0 :: Word32 ) .. ] components )+      newValue SPIRV.Op.CompositeConstruct toTyID ( toArgs convertedComps )++  where+    newValue :: SPIRV.Op.Operation -> TyID -> Args -> CGMonad ID+    newValue op resTyID operands = do+      u <- fresh+      instruction+        Instruction+          { operation = op+          , resTy     = Just resTyID+          , resID     = Just u+          , args      = operands+          }+      pure u
+ src/CodeGen/PrimOps.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++{-|+Module: CodeGen.PrimOps++Code generation for primitive operations (e.g. arithmetic operations).+-}++module CodeGen.PrimOps+  ( primOp, operationInstruction )+  where++-- base+import Control.Monad+  ( when )+import Data.Foldable+  ( for_ )+import Data.Proxy+  ( Proxy )++-- lens+import Control.Lens+  ( view )++-- mtl+import Control.Monad.Except+  ( throwError )++-- text-short+import qualified Data.Text.Short as ShortText+  ( pack )++-- fir+import CodeGen.Application+  ( Application(Applied)+  , traverseASTs+  )+import CodeGen.Binary+  ( instruction )+import {-# SOURCE #-} CodeGen.CodeGen+  ( CodeGen(codeGenArgs), codeGen )+import CodeGen.Debug+  ( whenAsserting )+import CodeGen.IDs+  ( typeID )+import CodeGen.Instruction+  ( toArgs+  , ID(ID)+  , Instruction(..)+  )+import CodeGen.Monad+  ( CGMonad, MonadFresh(fresh) )+import CodeGen.State+  ( _backend, _spirvVersion, requireCapabilities, requireExtensions )+import FIR.AST+  ( AST, PrimOpF(..) )+import FIR.AST.Type+  ( Nullary )+import FIR.Prim.Op+  ( PrimOp(opName) )+import qualified SPIRV.PrimOp       as SPIRV+import qualified SPIRV.PrimTy       as SPIRV+import qualified SPIRV.Requirements as SPIRV+import qualified SPIRV.Operation    as SPIRV+  ( Operation )+import qualified SPIRV.Version      as SPIRV++----------------------------------------------------------------------------+-- primops+++instance CodeGen AST => CodeGen (PrimOpF AST) where+  codeGenArgs ( Applied ( PrimOpF ( _ :: Proxy a ) ( _ :: Proxy op ) ) as ) =+    primOp ( opName @_ @_ @op @a ) =<< traverseASTs @Nullary codeGen as+++primOp :: SPIRV.PrimOp -> [ (ID, SPIRV.PrimTy) ] -> CGMonad (ID, SPIRV.PrimTy)+primOp prim as = do+  bk <- view _backend+  let+    op :: SPIRV.Operation+    retTy :: SPIRV.PrimTy+    (op, retTy) = SPIRV.opAndReturnType bk prim+    minVer :: SPIRV.Version+    minVer = SPIRV.primOpMinVersion bk prim+  requireCapabilities $ SPIRV.primOpCapabilities bk prim+  requireExtensions   $ SPIRV.primOpExtensions   bk prim+  ver <- view _spirvVersion+  whenAsserting . when ( ver < minVer ) . throwError $+    "primOp: operation " <> ShortText.pack ( show prim ) <> "\n\+    \requires SPIR-V version " <>  ShortText.pack ( show minVer ) <> ",\n\+    \but current version is  " <>  ShortText.pack ( show ver    ) <> "."+  whenAsserting . for_ ( SPIRV.primOpUnsupported bk prim ) $ \ reason ->+    throwError $+      "primOp: operation " <> ShortText.pack ( show prim ) <> " is not supported:\n"+      <> ShortText.pack reason <> "."+  operationInstruction op retTy ( map fst as )++operationInstruction :: SPIRV.Operation -> SPIRV.PrimTy -> [ ID ] -> CGMonad (ID, SPIRV.PrimTy)+operationInstruction op retTy as = case retTy of+  SPIRV.Unit -> do+    instruction+      Instruction+        { operation = op+        , resTy = Nothing+        , resID = Nothing+        , args = toArgs as+        }+    pure (ID 0, retTy) -- ID should not be used+  _ -> do+    resTyID <- typeID retTy+    v <- fresh+    instruction+      Instruction+        { operation = op+        , resTy = Just resTyID+        , resID = Just v+        , args = toArgs as+        }+    pure (v, retTy)
+ src/CodeGen/RayTracing.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++{-|+Module: CodeGen.Debug++Code generation for ray-tracing instructions.+-}++module CodeGen.RayTracing+  ( )+  where++-- base+import Data.Proxy+  ( Proxy )+import Data.Word+  ( Word32 )++-- lens+import Control.Lens+  ( use, assign )++-- mtl+import Control.Monad.Except+  ( throwError )++-- fir+import CodeGen.Application+  ( ASTs(..), Application(..)+  , traverseASTs+  )+import CodeGen.Binary+  ( instruction )+import {-# SOURCE #-} CodeGen.CodeGen+  ( CodeGen(codeGenArgs), codeGen )+import CodeGen.IDs+  ( constID, globalID )+import CodeGen.Instruction+  ( ID(ID), Instruction(..), Args(..), Pointer(pointerID) )+import CodeGen.Monad+  ( note )+import CodeGen.Pointers+  ( newVariable )+import CodeGen.PrimOps+  ( operationInstruction )+import CodeGen.State+  ( requireCapability, requireExtension+  , currentFunctionContext, _rayQuery+  )+import FIR.AST+  ( AST )+import FIR.AST.Exts+  ( RayF(..) )+import FIR.AST.Type+  ( Nullary )+import FIR.Prim.RayTracing+  ( RayQuery(..), IntersectionType(..) )+import FIR.Prim.Types+  ( primTy )+import FIR.ProgramState+  ( FunctionContext(InEntryPoint) )+import qualified SPIRV.Capability as SPIRV+import qualified SPIRV.Extension  as SPIRV+import qualified SPIRV.Operation  as SPIRV.Op+import qualified SPIRV.PrimTy     as SPIRV+import qualified SPIRV.Stage      as SPIRV++-------------------------------------------------------------------------------++instance CodeGen AST => CodeGen (RayF AST) where++  codeGenArgs ( Applied ( TraceRayF {..} ) NilAST ) = do+    ctxt <- currentFunctionContext+    case ctxt of+      InEntryPoint modelName modelInfo _-> do+        let+          model :: SPIRV.ExecutionModel+          model = SPIRV.modelOf modelInfo+        accelerationStructure <- fst <$> codeGen  traceRayFAccelerationStructure+        rayFlags              <- fst <$> codeGen  traceRayFRayFlags+        cullMask              <- fst <$> codeGen  traceRayFCullMask+        sbt_offset            <- fst <$> codeGen  traceRayFSBTOffset+        sbt_stride            <- fst <$> codeGen  traceRayFSBTStride+        missIndex             <- fst <$> codeGen  traceRayFMissIndex+        rayOrigin             <- fst <$> codeGen  traceRayFRayOrigin+        rayTMin               <- fst <$> codeGen  traceRayFRayTMin+        rayDirection          <- fst <$> codeGen  traceRayFRayDirection+        rayTMax               <- fst <$> codeGen  traceRayFRayTMax+        mbRayPayloadID   <- fmap pointerID <$> globalID traceRayFRayPayloadName ( Just ( modelName, model ) )+        rayPayloadID <-+          note+            ( "codeGen: could not find RayPayload ID with name " <> traceRayFRayPayloadName  )+            mbRayPayloadID+        instruction+          Instruction+            { operation = SPIRV.Op.TraceRay+            , resTy = Nothing+            , resID = Nothing+            , args  = Arg accelerationStructure+                    $ Arg rayFlags+                    $ Arg cullMask+                    $ Arg sbt_offset+                    $ Arg sbt_stride+                    $ Arg missIndex+                    $ Arg rayOrigin+                    $ Arg rayTMin+                    $ Arg rayDirection+                    $ Arg rayTMax+                    $ Arg rayPayloadID+                    $ EndArgs+            }+        pure (ID 0, SPIRV.Unit) -- ID should not be used+      _ -> throwError "codeGen: 'traceRay' outside of a ray shader"++  codeGenArgs ( Applied ( ExecuteCallableF {..} ) NilAST ) = do+    ctxt <- currentFunctionContext+    case ctxt of+      InEntryPoint modelName modelInfo _-> do+        let+          model :: SPIRV.ExecutionModel+          model = SPIRV.modelOf modelInfo+        sbtIndex              <- fst <$> codeGen  executeCallableFSBTIndex+        mbCallableDataID <- fmap pointerID <$> globalID executeCallableFDataName ( Just ( modelName, model ) )+        callableDataID <-+          note+            ( "codeGen: could not find CallableData ID with name " <> executeCallableFDataName )+            mbCallableDataID+        instruction+          Instruction+            { operation = SPIRV.Op.ExecuteCallable+            , resTy = Nothing+            , resID = Nothing+            , args  = Arg sbtIndex+                    $ Arg callableDataID+                    $ EndArgs+            }+        pure (ID 0, SPIRV.Unit) -- ID should not be used+      _ -> throwError "codeGen: 'executeCallable' outside of a ray shader"++  codeGenArgs ( Applied ( RayQueryInitializeF {..} ) NilAST ) = do+    let+      RayQuery rayQueryName = rayQueryFRayQueryName+    v <- pointerID <$> newVariable SPIRV.RayQuery+    assign ( _rayQuery rayQueryName ) ( Just v )++    requireCapability SPIRV.RayQueryKHR+    requireExtension  SPIRV.SPV_KHR_ray_query++    accelerationStructure <- fst <$> codeGen rayQueryFAccelerationStructure+    rayFlags              <- fst <$> codeGen rayQueryFRayFlags+    cullMask              <- fst <$> codeGen rayQueryFCullMask+    rayOrigin             <- fst <$> codeGen rayQueryFRayOrigin+    rayTMin               <- fst <$> codeGen rayQueryFRayTMin+    rayDirection          <- fst <$> codeGen rayQueryFRayDirection+    rayTMax               <- fst <$> codeGen rayQueryFRayTMax+    instruction+      Instruction+        { operation = SPIRV.Op.RayQueryInitialize+        , resTy = Nothing+        , resID = Nothing+        , args  = Arg v+                $ Arg accelerationStructure+                $ Arg rayFlags+                $ Arg cullMask+                $ Arg rayOrigin+                $ Arg rayTMin+                $ Arg rayDirection+                $ Arg rayTMax+                $ EndArgs+        }+    pure (ID 0, SPIRV.Unit) -- ID should not be used++  codeGenArgs ( Applied ( RayQueryPrimOpF ( _ :: Proxy a ) rayOpName ( RayQuery rayQueryName ) mbInterTy ) as ) = do+    requireCapability SPIRV.RayQueryKHR+    requireExtension  SPIRV.SPV_KHR_ray_query+    v <- note ( "'codeGen': no ray query variable named " <> rayQueryName )+            =<< use ( _rayQuery rayQueryName )++    argIDs <- traverseASTs @Nullary ( fmap fst . codeGen ) as+    case mbInterTy of+      Nothing ->+        operationInstruction rayOpName ( primTy @a ) ( v : argIDs )+      Just interTy -> do+        interTyLit <- constID ( case interTy of { Candidate -> (0 :: Word32); Committed -> (1 :: Word32) } )+        operationInstruction rayOpName ( primTy @a ) ( v : interTyLit : argIDs )
+ src/CodeGen/State.hs view
@@ -0,0 +1,840 @@+{-# LANGUAGE BlockArguments     #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE NamedFieldPuns     #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RankNTypes         #-}++{-|+Module: CodeGen.State++This module defines the structure of the state used by the code generation,+in two parts:++  - 'CGContext', consisting of reified type-level data provided at the start+  of code generation (with a 'Control.Monad.Reader.ReaderT' transformer),+  - 'CGState', consisting of state accumulated during code generation,+  recording which objects have been declared and their IDs.++This module manually provides lenses for these. Most of these could be derived+automatically, but a few of them are slightly trickier, requiring an affine traversal.++These custom lenses also allow terse state modifications.+For instance, usage of a built-in variable simultaneously obtains an ID for the variable,+adds itself to the relevant entry point interface, and sets the necessary decorations.++-}++module CodeGen.State+  ( -- * Code generation state+    CGState(moduleState), initialState+  , ModuleState(..)+  , FunctionState(functionContext, localVariables)+  , LexicalEnv(..)+  , LoopBlockIDs(..), EarlyExit(..), LoopExit(..)+  , BlockState+  , PointerState(..)++    -- * Code generation context+  , CGContext(..), emptyContext++    -- * Lenses+  , affineTraverse+    -- ** Module state+  , _currentID+  , _neededCapabilities, _neededCapability+  , _neededExtensions, _neededExtension+  , _knownExtInsts, _knownExtInst+  , _knownStringLits, _knownStringLit+  , _names+  , _usedGlobals, _usedGlobal+  , _builtinVariables, _builtinVariable+  , _entryPoints, _entryPoint+  , _interfaces, _interface, _interfaceBinding+  , _builtin+  , _decorations, _decorate+  , _memberDecorations, _memberDecorate+  , _knownTypes, _knownType+  , _knownConstants, _knownConstant+  , _knownUndefineds, _knownUndefined+  , _knownBindings, _knownBinding+    -- ** Lexical environment+  , _localBindings, _localBinding+  , _writableBindings+  , _rayQueries, _rayQuery+  , defineLocalBinding+  , scoped+    -- ** Function state+  , currentFunctionContext+  , withFunctionState+  , addLocalVariable+    -- ** Loops+  , withLoopFrame+  , inLoopBodyScope, innermostLoop, loopDepth+  , addLoopExit+    -- ** Block state+  , currentBlockID+  , enterBlock, leaveBlock+  , lookupTemporaryPointer, setTemporaryPointer+    -- ** Code generation context+  , _userGlobals, _userGlobal+  , _userFunctions, _userFunction+  , _userEntryPoints, _userEntryPoint+  , _userCapabilities, _userExtensions+  , _userImages, _userImage+  , _spirvVersion, _backend+  , _debugging, _asserting, _emittingCode++    -- * Helper state update functions+  , requireCapability, requireCapabilities+  , requireExtension, requireExtensions+  , addName, addMemberName+  , addDecoration, addDecorations+  , addMemberDecoration, addMemberDecorations+  )+  where++-- base+import Data.Maybe+  ( fromMaybe )+import Data.Word+  ( Word32 )++-- containers+import Data.Map+  ( Map )+import qualified Data.Map as Map+import Data.Set+  ( Set )+import qualified Data.Set as Set++-- lens+import Control.Lens+  ( Lens', lens+  , at+  , view, set+  , use, assign, modifying+  )++-- mtl+import Control.Monad.Except+  ( MonadError, throwError )+import Control.Monad.State+  ( MonadState, gets, modify' )++-- text-short+import Data.Text.Short+  ( ShortText )+import qualified Data.Text.Short as ShortText+  ( unpack )++-- fir+import CodeGen.Instruction+  ( ID(ID), TyID(tyID)+  , Pointer, Variable, variableID+  , Instruction+  )+import Data.Containers.Traversals+  ( traverseSet_ )+import FIR.Builtin+  ( modelBuiltins, builtinDecorations )+import FIR.Prim.Types+  ( AConstant )+import FIR.ProgramState+  ( FunctionContext(TopLevel), VLFunctionContext ) -- value-level function context+import qualified SPIRV.Capability    as SPIRV+import qualified SPIRV.Control       as SPIRV+import qualified SPIRV.Decoration    as SPIRV+import qualified SPIRV.ExecutionMode as SPIRV+import qualified SPIRV.Extension     as SPIRV+  ( ExtInst, Extension )+import qualified SPIRV.Image         as SPIRV+import qualified SPIRV.Layout        as SPIRV+  ( Layout )+import qualified SPIRV.PrimTy        as SPIRV+import qualified SPIRV.Stage         as SPIRV+import qualified SPIRV.Version       as SPIRV++----------------------------------------------------------------------------+-- * Code generation state and context++-- | Code generation state.+--+-- The state is split up according to the lifetime of the information it contains:+--+--  - 'ModuleState': information about the whole SPIR-V module (types, constants, ...),+--  - 'FunctionState': information about the function currently being generated,+--  - 'LexicalEnv': the bindings in scope (restored at the end of each lexical scope),+--  - 'LoopFrame's: the loops we are currently inside,+--  - 'BlockState': information about the current basic block.+--+-- Each of these is replaced wholesale when entering/leaving the corresponding scope,+-- using the functions 'withFunctionState', 'scoped', 'withLoopFrame', 'enterBlock'+-- and 'leaveBlock' (the constructors of 'FunctionState' and 'BlockState' are not exported).+-- Information that refers to IDs that are only valid in part of a function body+-- should be stored in the narrowest such scope, so that it can't be used where+-- it isn't valid.+--+-- NB: the code generation for loops and functions ties a knot through this state+-- (see 'CodeGen.CFG.while' and 'CodeGen.Functions.inContext'),+-- so the fields of these records must remain lazy.+data CGState+  = CGState+      { moduleState   :: ModuleState+      , functionState :: Maybe FunctionState -- ^ @Nothing@ at the top level.+      , lexicalEnv    :: LexicalEnv+      , loopStack     :: [ LoopFrame ]       -- ^ Innermost loop first.+      , blockState    :: BlockState+      }++-- | Information about the whole SPIR-V module being generated.+data ModuleState+  = ModuleState+      {+      -- | Current ID number (increases by 1 each time a new ID is needed).+        currentID           :: ID++      -- | Capability requirements that have been declared.+      , neededCapabilities  :: Set                                   SPIRV.Capability++      -- | Needed extensions.+      , neededExtensions    :: Set                                   SPIRV.Extension++      -- | IDs of all used extended instruction sets.+      , knownExtInsts       :: Map SPIRV.ExtInst                     ID++      -- | IDs of constant text literals.+      , knownStringLits     :: Map ShortText                         ID++      -- | IDs which have been annotated with a name / member name.+      , names               :: Set                                   (ID, Either ShortText (Word32, ShortText))++      -- | Entry point IDs.+      , entryPoints         :: Map (ShortText, SPIRV.ExecutionModel) ID++      -- | Entry point interfaces, keeping track of which global variables are used.+      , interfaces          :: Map (ShortText, SPIRV.ExecutionModel) (Map ShortText ID)++      -- | Decorations for given types.+      , decorations         :: Map ID                                SPIRV.Decorations++      -- | Decorations for members of a given struct type.+      , memberDecorations   :: Map (TyID, Word32)                    SPIRV.Decorations++      -- | Map of all declared types, together with their layout.+      --+      -- We keep the full 'Instruction' rather than just its 'TyID',+      -- as the types have to be declared at the top of the SPIR-V module,+      -- rather than inline with the rest of the code.+      , knownTypes          :: Map (SPIRV.Layout, SPIRV.PrimTy)      Instruction++      -- | Map of all declared constants.+      --+      -- Same comment than for 'knownTypes' regarding 'Instruction' vs 'ID'.+      , knownConstants      :: Map AConstant                         Instruction++      -- | Map of all types who have a corresponding "Undefined" instruction.+      , knownUndefineds     :: Map SPIRV.PrimTy                      (ID, TyID)++      -- | Which user-defined global variables have been used?+      , usedGlobals         :: Map ShortText                         Variable++      -- | Built-in variables that have been used (each entry point has its own), with their names.+      , builtinVariables    :: Map ID                                (ShortText, Variable)++      -- | Top-level bindings available, such as top-level functions.+      , knownBindings       :: Map ShortText                         (ID, SPIRV.PrimTy)+      }++-- | Information about the function currently being generated.+data FunctionState+  = FunctionState+      { -- | Whether we are in a function or an entry point.+        functionContext :: VLFunctionContext++        -- | Local variables of the function.+        --+        -- These are declared at the start of the function body.+      , localVariables  :: Map ID Variable+      }++-- | The bindings in scope.+data LexicalEnv+  = LexicalEnv+      { -- | Variables declared by the user in the program.+        localBindings    :: Map ShortText (ID, SPIRV.PrimTy)++        -- | Which of the local bindings can be modified.+        --+        -- This doesn't include bindings that are pointers (e.g. a mutable array).+      , writableBindings :: Set ShortText++        -- | IDs of locally declared ray query variables.+      , rayQueries       :: Map ShortText ID+      }++-- | Information about a loop we are currently inside of.+data LoopFrame+  = LoopFrame+      { loopBlockIDs :: LoopBlockIDs++        -- | Whether we are in the body of this loop (as opposed to its condition).+      , inLoopBody   :: Bool++        -- | The early exits which branch to the continue or merge block of this+        -- loop, keyed by the ID of the block in which the early exit occurred,+        -- together with the values of the bindings at that point.+      , loopExits    :: Map ID ( LoopExit, Map ShortText (ID, SPIRV.PrimTy) )+      }++-- | Information about the current basic block.+data BlockState+  = BlockState+      { -- | ID of the current block, or @Nothing@ if there is no current block.+        currentBlock      :: Maybe ID++        -- | Temporary pointers holding copies of values, keyed by the ID of the value.+      , temporaryPointers :: Map ID (Pointer, PointerState)+      }++data PointerState+  = Fresh+  | Modified+  deriving stock ( Eq, Show )++data LoopBlockIDs+  = LoopBlockIDs+    { continueBlockID :: !ID+    , mergeBlockID    :: !ID+    }+    deriving stock ( Show, Eq, Ord )++-- | An early exit from loops ('break' or 'breakContinue').+data EarlyExit+  -- | Break out of the given number of loops (at least 1).+  = Break Word32+  -- | Break out of the given number of loops, and then continue+  -- to the next iteration of the enclosing loop.+  | BreakContinue Word32+  deriving stock ( Show, Eq, Ord )++-- | How an early exit leaves the innermost loop.+--+-- In structured control flow, it is only possible to branch to the continue or merge block+-- of the innermost loop. Exiting several loops at once thus amounts to exiting the innermost+-- loop, and then performing the remaining early exit from its merge block.+data LoopExit+  -- | Continue to the next iteration of the loop.+  = ContinueLoop+  -- | Exit the loop, and then perform the given early exit from the enclosing loops (if any).+  | ExitLoop ( Maybe EarlyExit )+  deriving stock ( Show, Eq, Ord )++initialState :: CGContext -> CGState+initialState CGContext { userCapabilities, userExtensions }+  = CGState+      { moduleState   =+          ModuleState+            { currentID           = ID 1+            , neededCapabilities  = userCapabilities+            , neededExtensions    = userExtensions+            , knownExtInsts       = Map.empty+            , knownStringLits     = Map.empty+            , names               = Set.empty+            , entryPoints         = Map.empty+            , interfaces          = Map.empty+            , decorations         = Map.empty+            , memberDecorations   = Map.empty+            , knownTypes          = Map.empty+            , knownConstants      = Map.empty+            , knownUndefineds     = Map.empty+            , usedGlobals         = Map.empty+            , builtinVariables    = Map.empty+            , knownBindings       = Map.empty+            }+      , functionState = Nothing+      , lexicalEnv    =+          LexicalEnv+            { localBindings    = Map.empty+            , writableBindings = Set.empty+            , rayQueries       = Map.empty+            }+      , loopStack     = []+      , blockState    = noBlock+      }++-- | Block state when there is no current block.+noBlock :: BlockState+noBlock = BlockState { currentBlock = Nothing, temporaryPointers = Map.empty }++-- | Code generation context.+--+-- Consists of information provided at the start of code generation,+-- as provided by the user-provided type annotations of+-- top-level functions, entry points and input/output variables.+data CGContext+  = CGContext+     { -- | User defined inputs/outputs (not builtins).+       userGlobals+          :: Map ShortText (SPIRV.PointerTy, SPIRV.Decorations)++       -- | User defined functions (not entry points).+     , userFunctions+          :: Map ShortText SPIRV.FunctionControl++       -- | User defined entry points.+     , userEntryPoints+          :: Map (ShortText, SPIRV.ExecutionModel) SPIRV.ExecutionModes++       -- | Capabilities that are required (computed from user definitions).+     , userCapabilities+          :: Set                                   SPIRV.Capability++       -- | Extensions that are required (computed from user definitions).+     , userExtensions+          :: Set                                   SPIRV.Extension++       -- | User defined images.+     , userImages+          :: Map ShortText SPIRV.Image++       -- | SPIR-V version to use.+     , spirvVersion :: SPIRV.Version++       -- | SPIR-V backend to use (Vulkan or OpenCL).+     , backend :: SPIRV.Backend++       -- | Whether to add extra source information in the generated SPIR-V assembly.+     , debugging :: Bool++       -- | Whether to enable assertions.+     , asserting :: Bool++       -- | Whether to emit assembly code.+     , emittingCode :: Bool+     }+  deriving stock Show++emptyContext :: CGContext+emptyContext+  = CGContext+      { userGlobals      = Map.empty+      , userFunctions    = Map.empty+      , userEntryPoints  = Map.empty+      , userCapabilities = Set.empty+      , userExtensions   = Set.empty+      , userImages       = Map.empty+      , spirvVersion     = SPIRV.Version 1 5+      , backend          = SPIRV.Vulkan+      , debugging        = False+      , asserting        = False+      , emittingCode     = True+      }++----------------------------------------------------------------------------+-- * Lenses++-- | Affine traversal relative to 'Maybe'.+--+-- Useful function to deal with nested data structures+-- such as @Map a (Map b c)@+affineTraverse :: (Monoid a, Functor f) => (a -> f b) -> (Maybe a -> f (Maybe b))+affineTraverse f Nothing  = fmap Just (f mempty)+affineTraverse f (Just a) = fmap Just (f a)++----------------------------------------------------------------------------+-- ** Module state++-- Internal+_moduleState :: Lens' CGState ModuleState+_moduleState = lens moduleState ( \s v -> s { moduleState = v } )++_currentID :: Lens' CGState ID+_currentID = _moduleState . lens currentID ( \s v -> s { currentID = v } )++_neededCapabilities :: Lens' CGState (Set SPIRV.Capability)+_neededCapabilities = _moduleState . lens neededCapabilities ( \s v -> s { neededCapabilities = v } )++_neededCapability :: SPIRV.Capability -> Lens' CGState (Maybe ())+_neededCapability capability = _neededCapabilities . at capability++_neededExtensions :: Lens' CGState (Set SPIRV.Extension)+_neededExtensions = _moduleState . lens neededExtensions ( \s v -> s { neededExtensions = v } )++_neededExtension :: SPIRV.Extension -> Lens' CGState (Maybe ())+_neededExtension extension = _neededExtensions . at extension++_knownExtInsts :: Lens' CGState (Map SPIRV.ExtInst ID)+_knownExtInsts = _moduleState . lens knownExtInsts ( \s v -> s { knownExtInsts = v } )++_knownExtInst :: SPIRV.ExtInst -> Lens' CGState (Maybe ID)+_knownExtInst ext = _knownExtInsts . at ext++_knownStringLits :: Lens' CGState (Map ShortText ID)+_knownStringLits = _moduleState . lens knownStringLits ( \s v -> s { knownStringLits = v } )++_knownStringLit :: ShortText -> Lens' CGState (Maybe ID)+_knownStringLit lit = _knownStringLits . at lit++_names :: Lens' CGState ( Set (ID, Either ShortText (Word32, ShortText)) )+_names = _moduleState . lens names ( \s v -> s { names = v } )++_usedGlobals :: Lens' CGState (Map ShortText Variable)+_usedGlobals = _moduleState . lens usedGlobals ( \s v -> s { usedGlobals = v } )++_usedGlobal :: ShortText -> Lens' CGState (Maybe Variable)+_usedGlobal name = _usedGlobals . at name++_builtinVariables :: Lens' CGState (Map ID (ShortText, Variable))+_builtinVariables = _moduleState . lens builtinVariables ( \s v -> s { builtinVariables = v } )++_builtinVariable :: ID -> Lens' CGState (Maybe (ShortText, Variable))+_builtinVariable v = _builtinVariables . at v++_entryPoints :: Lens' CGState (Map (ShortText, SPIRV.ExecutionModel) ID)+_entryPoints = _moduleState . lens entryPoints ( \s v -> s { entryPoints = v } )++_entryPoint :: ShortText -> SPIRV.ExecutionModel -> Lens' CGState (Maybe ID)+_entryPoint name stage = _entryPoints . at (name, stage)++_interfaces :: Lens' CGState (Map (ShortText, SPIRV.ExecutionModel) (Map ShortText ID))+_interfaces = _moduleState . lens interfaces ( \s v -> s { interfaces = v } )++_interface :: ShortText -> SPIRV.ExecutionModel -> Lens' CGState (Maybe (Map ShortText ID))+_interface stageName stage = _interfaces . at (stageName, stage)++_interfaceBinding :: ShortText -> SPIRV.ExecutionModel -> ShortText -> Lens' CGState (Maybe ID)+_interfaceBinding stageName stage varName+  = _interface stageName stage+  . affineTraverse+  . at varName++-- | The ID of a built-in variable, for a given entry point.+--+-- Setting this adds the built-in variable to the interface of the entry point,+-- and sets the necessary decorations.+_builtin :: ShortText -> SPIRV.ExecutionInfo Word32 stage -> ShortText -> Lens' CGState (Maybe ID)+_builtin stageName executionInfo builtinName+  = lens+      ( view _interfaceBuiltin )+      ( \s mb_i -> case mb_i of+         Nothing -> s+         Just i  -> set _interfaceBuiltin ( Just i )+                  . set ( _decorate i ) ( Just decs )+                  $ s+      )+  where executionModel :: SPIRV.ExecutionModel+        executionModel = SPIRV.modelOf executionInfo++        _interfaceBuiltin :: Lens' CGState (Maybe ID)+        _interfaceBuiltin = _interfaceBinding stageName executionModel builtinName++        decs :: SPIRV.Decorations+        decs = builtinDecorations executionModel builtinName builtinTy++        builtinTy :: SPIRV.PointerTy+        builtinTy =+          fromMaybe+            ( error+              ( "_builtin: builtin with name " ++ ShortText.unpack builtinName ++ " cannot be found,\n\+                  \among builtins for " ++ show executionModel ++ " named " ++ ShortText.unpack stageName+              )+            )+            ( lookup builtinName $ modelBuiltins executionInfo )+++_decorations :: Lens' CGState (Map ID SPIRV.Decorations)+_decorations = _moduleState . lens decorations ( \s v -> s { decorations = v } )++_decorate :: ID -> Lens' CGState (Maybe SPIRV.Decorations)+_decorate bindingID = _decorations . at bindingID++_memberDecorations :: Lens' CGState ( Map (TyID, Word32) SPIRV.Decorations )+_memberDecorations = _moduleState . lens memberDecorations ( \s v -> s { memberDecorations = v } )++_memberDecorate :: TyID -> Word32 -> Lens' CGState ( Maybe SPIRV.Decorations )+_memberDecorate bindingTyID index+  = _memberDecorations+  . at (bindingTyID, index)++_knownTypes :: Lens' CGState (Map (SPIRV.Layout, SPIRV.PrimTy) Instruction)+_knownTypes = _moduleState . lens knownTypes ( \s v -> s { knownTypes = v } )++_knownType :: SPIRV.Layout -> SPIRV.PrimTy -> Lens' CGState (Maybe Instruction)+_knownType lay primTy = _knownTypes . at (lay, primTy)++_knownConstants :: Lens' CGState (Map AConstant Instruction)+_knownConstants = _moduleState . lens knownConstants ( \s v -> s { knownConstants = v } )++_knownConstant :: AConstant -> Lens' CGState (Maybe Instruction)+_knownConstant constant = _knownConstants . at constant++_knownUndefineds :: Lens' CGState (Map SPIRV.PrimTy (ID, TyID))+_knownUndefineds = _moduleState . lens knownUndefineds ( \s v -> s { knownUndefineds = v } )++_knownUndefined :: SPIRV.PrimTy -> Lens' CGState (Maybe (ID,TyID))+_knownUndefined primTy = _knownUndefineds . at primTy++_knownBindings :: Lens' CGState (Map ShortText (ID, SPIRV.PrimTy))+_knownBindings = _moduleState . lens knownBindings ( \s v -> s { knownBindings = v } )++_knownBinding :: ShortText -> Lens' CGState (Maybe (ID, SPIRV.PrimTy))+_knownBinding binding = _knownBindings . at binding++----------------------------------------------------------------------------+-- ** Lexical environment++-- Internal+_lexicalEnv :: Lens' CGState LexicalEnv+_lexicalEnv = lens lexicalEnv ( \s v -> s { lexicalEnv = v } )++_localBindings :: Lens' CGState (Map ShortText (ID, SPIRV.PrimTy))+_localBindings = _lexicalEnv . lens localBindings ( \s v -> s { localBindings = v } )++_localBinding :: ShortText -> Lens' CGState (Maybe (ID, SPIRV.PrimTy))+_localBinding binding = _localBindings . at binding++_writableBindings :: Lens' CGState (Set ShortText)+_writableBindings = _lexicalEnv . lens writableBindings ( \s v -> s { writableBindings = v } )++_rayQueries :: Lens' CGState (Map ShortText ID)+_rayQueries = _lexicalEnv . lens rayQueries ( \s v -> s { rayQueries = v } )++_rayQuery :: ShortText -> Lens' CGState (Maybe ID)+_rayQuery v = _rayQueries . at v++-- | Define a local binding, recording whether it can be modified.+defineLocalBinding :: MonadState CGState m => ShortText -> (ID, SPIRV.PrimTy) -> Bool -> m ()+defineLocalBinding name bd writable = do+  assign ( _localBinding name ) ( Just bd )+  modifying _writableBindings ( if writable then Set.insert name else Set.delete name )++-- | Run an action in a new lexical scope; the previous lexical environment is+-- restored afterwards.+--+-- Returns the lexical environment at the end of the scope+scoped :: MonadState CGState m => m a -> m ( a, LexicalEnv )+scoped action = do+  envBefore <- use _lexicalEnv+  a         <- action+  envAfter  <- use _lexicalEnv+  assign _lexicalEnv envBefore+  pure ( a, envAfter )++----------------------------------------------------------------------------+-- ** Function state++-- | The current function context.+currentFunctionContext :: MonadState CGState m => m VLFunctionContext+currentFunctionContext = gets ( maybe TopLevel functionContext . functionState )++-- | Run an action with a fresh function state, returning the function state+-- at the end.+withFunctionState :: MonadState CGState m => VLFunctionContext -> m a -> m ( a, FunctionState )+withFunctionState context action = do+  before <- gets functionState+  modify' \ s -> s { functionState = Just ( FunctionState { functionContext = context, localVariables = Map.empty } ) }+  a <- action+  after <- gets functionState+  modify' \ s -> s { functionState = before }+  pure ( a, fromMaybe ( error "withFunctionState: function state disappeared" ) after )++-- | Record a local variable of the current function.+addLocalVariable :: ( MonadState CGState m, MonadError ShortText m ) => Variable -> m ()+addLocalVariable var = do+  mbFunState <- gets functionState+  case mbFunState of+    Nothing ->+      throwError "codeGen: cannot declare a local variable outside of a function"+    Just funState ->+      modify' \ s -> s { functionState = Just funState { localVariables = Map.insert ( variableID var ) var ( localVariables funState ) } }++----------------------------------------------------------------------------+-- ** Loops++-- | Run an action (code generation for a loop) inside a new loop frame,+-- returning the early exits that branch to the continue or merge block of this loop.+withLoopFrame+  :: MonadState CGState m+  => LoopBlockIDs -> m a -> m ( a, Map ID ( LoopExit, Map ShortText (ID, SPIRV.PrimTy) ) )+withLoopFrame ids action = do+  modify' \ s -> s { loopStack = LoopFrame { loopBlockIDs = ids, inLoopBody = False, loopExits = Map.empty } : loopStack s }+  a <- action+  frames <- gets loopStack+  case frames of+    frame : outer -> do+      modify' \ s -> s { loopStack = outer }+      pure ( a, loopExits frame )+    [] -> error "withLoopFrame: loop frame disappeared"++-- | Run an action (code generation for the body of the innermost loop) in the body of the loop.+inLoopBodyScope :: MonadState CGState m => m a -> m a+inLoopBodyScope action = do+  setInLoopBody True+  a <- action+  setInLoopBody False+  pure a++setInLoopBody :: MonadState CGState m => Bool -> m ()+setInLoopBody b = modify' \ s -> case loopStack s of+  frame : outer -> s { loopStack = frame { inLoopBody = b } : outer }+  []            -> s++-- | The innermost loop, and whether we are in its body.+innermostLoop :: MonadState CGState m => m ( Maybe ( LoopBlockIDs, Bool ) )+innermostLoop = gets \ s -> case loopStack s of+  frame : _ -> Just ( loopBlockIDs frame, inLoopBody frame )+  []        -> Nothing++-- | Number of loops whose body we are in.+loopDepth :: MonadState CGState m => m Int+loopDepth = gets ( length . filter inLoopBody . loopStack )++-- | Record an early exit from the innermost loop.+addLoopExit+  :: ( MonadState CGState m, MonadError ShortText m )+  => ID -> LoopExit -> Map ShortText (ID, SPIRV.PrimTy) -> m ()+addLoopExit blockID loopExit bindings = do+  frames <- gets loopStack+  case frames of+    frame : outer ->+      modify' \ s -> s { loopStack = frame { loopExits = Map.insert blockID ( loopExit, bindings ) ( loopExits frame ) } : outer }+    [] -> throwError "codeGen: early exit outside of a loop"++----------------------------------------------------------------------------+-- ** Block state++-- | The ID of the current block, if any.+--+-- When there is no current block, the code being generated is unreachable.+currentBlockID :: MonadState CGState m => m ( Maybe ID )+currentBlockID = gets ( currentBlock . blockState )++-- | Start a new block, with an empty block state.+--+-- NB: this doesn't emit the label instruction (see 'CodeGen.CFG.block').+enterBlock :: MonadState CGState m => ID -> m ()+enterBlock blockID = modify' \ s -> s { blockState = noBlock { currentBlock = Just blockID } }++-- | End the current block (e.g. after a terminator instruction).+leaveBlock :: MonadState CGState m => m ()+leaveBlock = modify' \ s -> s { blockState = noBlock }++lookupTemporaryPointer :: MonadState CGState m => ID -> m ( Maybe (Pointer, PointerState) )+lookupTemporaryPointer v = gets ( Map.lookup v . temporaryPointers . blockState )++setTemporaryPointer :: MonadState CGState m => ID -> (Pointer, PointerState) -> m ()+setTemporaryPointer v ptr =+  modify' \ s -> s { blockState = ( blockState s ) { temporaryPointers = Map.insert v ptr ( temporaryPointers ( blockState s ) ) } }++----------------------------------------------------------------------------+-- ** Code generation context++_userGlobals+  :: Lens' CGContext+        ( Map ShortText+            ( SPIRV.PointerTy+            , SPIRV.Decorations+            )+        )+_userGlobals = lens userGlobals ( \c v -> c { userGlobals = v } )++_userGlobal+  :: ShortText+  -> Lens' CGContext+        ( Maybe+            ( SPIRV.PointerTy+            , SPIRV.Decorations+            )+        )+_userGlobal global = _userGlobals . at global++_userFunctions :: Lens' CGContext ( Map ShortText SPIRV.FunctionControl )+_userFunctions = lens userFunctions ( \c v -> c { userFunctions = v } )++_userFunction :: ShortText -> Lens' CGContext ( Maybe SPIRV.FunctionControl )+_userFunction function = _userFunctions . at function++_userEntryPoints :: Lens' CGContext ( Map (ShortText, SPIRV.ExecutionModel) SPIRV.ExecutionModes )+_userEntryPoints = lens userEntryPoints ( \c v -> c { userEntryPoints = v } )++_userEntryPoint :: ShortText -> SPIRV.ExecutionModel -> Lens' CGContext ( Maybe SPIRV.ExecutionModes )+_userEntryPoint name stage = _userEntryPoints . at (name, stage)++_userCapabilities :: Lens' CGContext (Set SPIRV.Capability)+_userCapabilities = lens userCapabilities ( \c v -> c { userCapabilities = v } )++_userExtensions :: Lens' CGContext (Set SPIRV.Extension)+_userExtensions = lens userExtensions ( \c v -> c { userExtensions = v } )++_userImages :: Lens' CGContext ( Map ShortText SPIRV.Image )+_userImages = lens userImages ( \c v -> c { userImages = v } )++_userImage :: ShortText -> Lens' CGContext ( Maybe SPIRV.Image )+_userImage image = _userImages . at image++_spirvVersion :: Lens' CGContext SPIRV.Version+_spirvVersion = lens spirvVersion ( \c v -> c { spirvVersion = v } )++_backend :: Lens' CGContext SPIRV.Backend+_backend = lens backend ( \c v -> c { backend = v } )++_debugging :: Lens' CGContext Bool+_debugging = lens debugging ( \c v -> c { debugging = v } )++_asserting :: Lens' CGContext Bool+_asserting = lens asserting ( \c v -> c { asserting = v } )++_emittingCode :: Lens' CGContext Bool+_emittingCode = lens emittingCode ( \c v -> c { emittingCode = v } )++-----------------------------------------------------------------------------+-- * Helper state update functions++requireCapability :: MonadState CGState m => SPIRV.Capability -> m ()+requireCapability cap = assign ( _neededCapability cap ) (Just ())++requireCapabilities :: MonadState CGState m => Set SPIRV.Capability -> m ()+requireCapabilities = traverseSet_ requireCapability++requireExtension :: MonadState CGState m => SPIRV.Extension -> m ()+requireExtension ext = assign ( _neededExtension ext ) (Just ())++requireExtensions :: MonadState CGState m => Set SPIRV.Extension -> m ()+requireExtensions = traverseSet_ requireExtension++addName :: MonadState CGState m+        => ID -> ShortText -> m ()+addName bdID name+  = modifying _names+      ( Set.insert (bdID, Left name) )++addMemberName :: MonadState CGState m +              => TyID -> Word32 -> ShortText -> m ()+addMemberName structTyID index name+  = modifying _names+      ( Set.insert (tyID structTyID, Right (index,name)) )++addDecoration :: MonadState CGState m+              => ID -> SPIRV.Decoration Word32 -> m ()+addDecoration bdID dec+  = modifying ( _decorate bdID )+      ( Just . maybe (Set.singleton dec) (Set.insert dec) )++addDecorations :: MonadState CGState m+               => ID -> SPIRV.Decorations -> m ()+addDecorations bdID decs+  = modifying ( _decorate bdID )+      ( Just . maybe decs (Set.union decs) )++addMemberDecoration :: MonadState CGState m+                    => TyID -> Word32 -> SPIRV.Decoration Word32 -> m ()+addMemberDecoration structTyID index dec+  = modifying ( _memberDecorate structTyID index )+      ( Just . maybe (Set.singleton dec) (Set.insert dec) )++addMemberDecorations :: MonadState CGState m+                     => TyID -> Word32 -> SPIRV.Decorations -> m ()+addMemberDecorations structTyID index decs+  = modifying ( _memberDecorate structTyID index )+      ( Just . maybe decs (Set.union decs) )
+ src/Control/Arrow/Strength.hs view
@@ -0,0 +1,35 @@+{-|+Module: Control.Arrow.Strength++Some useful functions relating arrows and functors via functor strength.+-}++module Control.Arrow.Strength where++-- base+import Control.Arrow+  ( Arrow(first,second,(&&&)), (>>^) )++---------------------------------------------------+-- Strengths.++rightStrength :: Functor f => d -> f c -> f (d,c)+rightStrength = fmap . (,)++leftStrength :: Functor f => f b -> d -> f (b,d)+leftStrength = flip (fmap . flip (,))++strong :: Functor f => f (a,b) -> (f a, f b)+strong = fmap fst &&& fmap snd++---------------------------------------------------+-- Functor f => Strong (Star f)+-- (Strong p, Strong q) => Strong (ProCompose p q)++firstF :: (Arrow a, Functor f)+       => a b (f c) -> a (b, d) (f (c, d))+firstF = (>>^ uncurry leftStrength) . first++secondF :: (Arrow a, Functor f)+        => a b (f c) -> a (d, b) (f (d, c))+secondF = (>>^ uncurry rightStrength) . second
+ src/Control/Monad/Indexed.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE InstanceSigs        #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++{-|+Module: Control.Monad.Indexed++Indexed functors and monads.++This module includes two versions, as described in Conor McBride's paper+/Kleisli Arrows of Outrageous Fortune/.++McBride-style indexed monads are usually written with an @ix@ /suffix/,+whereas AtKey-style indexed monads are usually written with an @ix@ /prefix/.++-}++module Control.Monad.Indexed+  ( -- * McBride-style indexed monads+    FunctorIx(fmapIx), MonadIx(returnIx, extendIx), MonadIxFail(fail)+    -- ** Identity indexed monad+  , Id(Id, runId)+    -- ** Codensity transformation+  , Codensity(Codensity, runCodensity)++    -- * Atkey-style indexed monads+    -- ** Representing Atkey indexed monads using the /At Key/ trick+  , (:=)(AtKey), atKey, withKey+    -- ** Atkey functor operations+  , ixFmap, (<<$>>), (<<$), ($>>), (<<&>>)+    -- ** Atkey applicative operations+  , IxApplicative((<<*>>))+  , (*>>), (<<*), ixLiftA2, ixLiftA3, ixLiftA4++    -- ** Foldable/traversable operations+  , IxF(..)+  , ixTraverse, ixFor+  , ixTraverse_, ixFor_++    -- * Rebindable syntax for @do@ notation+  , (>>=), (=<<), (>>), (<<), return, pure, ixPure,++  )+  where++-- base+import Data.Coerce+  ( coerce )+import Data.Foldable+  ( traverse_ )+import Data.Kind+  ( Type )+import Prelude+  hiding ( Functor(..), Applicative(..), Monad(..), (=<<) )+import qualified Prelude++------------------------------------------------+-- indexed monads (à la McBride)++class FunctorIx ( f :: (k -> Type) -> (k -> Type) ) where+  fmapIx :: ( forall ix.   p ix ->   q ix )+         -> ( forall ix. f p ix -> f q ix )++class FunctorIx m => MonadIx m where+  returnIx :: p ix -> m p ix+  -- | Demonic bind.+  extendIx :: ( forall ix.   p ix -> m q ix )+           -> ( forall ix. m p ix -> m q ix )++class MonadIx m => MonadIxFail m where+  fail :: String -> m (a := j) i++------------------------------------------------------------+-- identity indexed monad++newtype Id p i = Id { runId :: p i }++instance FunctorIx Id where+  fmapIx f (Id a) = Id (f a)++instance MonadIx Id where+  extendIx f (Id a) = f a+  returnIx = Id++------------------------------------------------------------+-- codensity transformation++-- | Demonic codensity transformation.+--+-- For any @(f :: Type -> Type)@,+-- @Codensity f@ is guaranteed to be an indexed monad.+-- +-- This is especially useful for manipulating ASTs.+newtype Codensity (f :: t -> Type) (p :: ix -> Type) (i :: ix) where+  Codensity+    :: { runCodensity+          :: forall (q :: ix -> t)+          .  ( ( forall (j :: ix). p j -> f (q j) ) -> f (q i) )+       }+    -> Codensity f p i+++instance FunctorIx (Codensity f) where+  fmapIx :: ( forall ix.             p ix ->             q ix )+         -> ( forall ix. Codensity f p ix -> Codensity f q ix )+  fmapIx f (Codensity m) = Codensity ( \k -> m ( k . f ) )++instance MonadIx (Codensity f) where+  returnIx :: p i -> Codensity f p i+  returnIx a = Codensity ( \k -> k a )++  extendIx :: ( forall ix.             p ix -> Codensity f q ix )+           -> ( forall ix. Codensity f p ix -> Codensity f q ix )+  extendIx f (Codensity ma) = Codensity ( \k -> ma ( \a -> runCodensity (f a) k ) )++------------------------------------------------+-- Atkey indexing++-- | The /At Key/ datatype allows us to express Atkey-style indexed monads+-- in terms of McBride-style indexed monads.+data (:=) :: Type -> i -> (i -> Type) where+  AtKey :: a -> (a := i) i++atKey :: (a := j) i -> a+atKey (AtKey a) = a+  +instance Show a => Show ( (a := i) j ) where+  show (AtKey a) = "AtKey " ++ show a++withKey :: (a -> b) -> (a := i) j -> (b := i) j+withKey f (AtKey a) = AtKey (f a)++------------------------------------------------------------+-- useful operators & functions for AtKey-style indexing++ixFmap :: forall m i j a b. FunctorIx m => (a -> b) -> m (a := j) i -> m (b := j) i+ixFmap f = fmapIx ( withKey f )++infixl 4 <<$>>+infixl 4 <<$+infixl 4 $>>+infixl 1 <<&>>++(<<$>>) :: FunctorIx f => (a -> b) -> f (a := j) i -> f (b := j) i+(<<$>>) = ixFmap+(<<$) :: FunctorIx f => a -> f (b := j) i -> f (a := j) i+(<<$) = ixFmap . const+($>>) :: FunctorIx f => f (a := j) i -> b -> f (b := j) i+($>>) = flip (<<$)+(<<&>>) :: FunctorIx f => f (a := j) i -> (a -> b) -> f (b := j) i+(<<&>>) = flip ixFmap++infixl 4 <<*>>+class FunctorIx f => IxApplicative f where+  (<<*>>) :: f ((a -> b) := j) i -> (f (a := k) j -> f (b := k) i)+  ixPure :: a -> f (a := i) i++instance (FunctorIx m, MonadIx m) => IxApplicative m where+  mf <<*>> ma = mf >>= (<<$>> ma)+  ixPure = returnIx . AtKey++infixl 4 *>>+infixl 4 <<*++(*>>) :: IxApplicative f => f (a := j) i -> f (b := k) j -> f (b := k) i+fa *>> fb = (id <<$ fa) <<*>> fb+(<<*) :: IxApplicative f => f (a := j) i -> f (b := k) j -> f (a := k) i+fa <<* fb = (const <<$>> fa) <<*>> fb++ixLiftA2 :: IxApplicative f+       => (a -> b -> c)+       -> f (a := j) i -> f (b := k) j -> f (c := k) i+ixLiftA2 f a b = f <<$>> a <<*>> b++ixLiftA3 :: IxApplicative f+         => (a -> b -> c -> d)+         -> f (a := j) i -> f (b := k) j -> f (c := l) k -> f (d := l) i+ixLiftA3 f a b c = f <<$>> a <<*>> b <<*>> c++ixLiftA4 :: IxApplicative f+         => (a -> b -> c -> d -> e)+         -> f (a := j) i -> f (b := k) j -> f (c := l) k -> f (d := m) l -> f (e := m) i+ixLiftA4 f a b c d = f <<$>> a <<*>> b <<*>> c <<*>> d++------------------------------------------------+-- foldable/traversable++-- newtype to put type variable last+newtype IxF f i j a = IxF { ixF :: f (a := j) i }++instance FunctorIx f => Prelude.Functor (IxF f i j) where+  fmap :: forall a b. (a -> b) -> (IxF f i j a -> IxF f i j b)+  fmap = coerce ( ixFmap @f @i @j @a @b)+instance IxApplicative f => Prelude.Applicative (IxF f i i) where+  pure :: forall a. a -> IxF f i i a+  pure = coerce ( ixPure @f @a @i )+  (<*>) :: forall a b. IxF f i i (a -> b) -> (IxF f i i a -> IxF f i i b)+  (<*>) = coerce ( (<<*>>) @f @a @b @i @i @i )++ixTraverse+  :: forall f t a b i.+     (Prelude.Traversable t, IxApplicative f)+  => (a -> f (b := i) i) -> t a -> f (t b := i) i+ixTraverse f = coerce ( traverse @t (IxF . f) )++ixFor+  :: forall f t a b i.+     (Prelude.Traversable t, IxApplicative f)+  => t a -> (a -> f (b := i) i) -> f (t b := i) i+ixFor = flip ixTraverse++ixTraverse_+  :: forall f t a b i.+     (Prelude.Foldable t, IxApplicative f)+  => (a -> f (b := i) i) -> t a -> f (() := i) i+ixTraverse_ f = coerce ( traverse_ @t (IxF . f) )++ixFor_+  :: (Prelude.Foldable t, IxApplicative f)+  => t a -> (a -> f (b := i) i) -> f (() := i) i+ixFor_ = flip ixTraverse_++------------------------------------------------+-- rebindable syntax++infixl 1 >>=+-- | Angelic bind.+(>>=) :: MonadIx m => m (a := j) i -> (a -> m q j) -> m q i+c >>= f = extendIx ( \ (AtKey a) -> f a ) c  ++infixl 1 >>+(>>) :: MonadIx m => m (a := j) i -> m q j -> m q i+ma >> mb = ma >>= const mb++infixr 1 <<+(<<) :: MonadIx m => m q j -> m (a := j) i -> m q i+(<<) = flip (>>)++infixr 1 =<<+(=<<) :: MonadIx m => (a -> m q j) -> m (a := j) i -> m q i+(=<<) = flip (>>=)++return, pure :: MonadIx m => a -> m (a := i) i+return = returnIx . AtKey+pure   = returnIx . AtKey
+ src/Control/Type/Optic.hs view
@@ -0,0 +1,971 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE InstanceSigs           #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: Control.Type.Optic++This module provides __type-level optics__, in the form of /getters/ and /setters/.++@Optic is s a@ describes the kind of an optic:++  * @is@ is a list of the types of the indices which have to be provided at run-time.+  When all accessor information is known at compile-time, this is the empty list @'[]@.+  * @s@ is the type of the container,+  * @a@ is the type of the component which is being focused on inside the container.++For instance, an optic which focuses on a single component of a vector of size 4 with a compile-time index+has kind @Optic '[] (V 4 a) a@.+++The basic optics provided, to focus into an object of type @s@ onto a subobject of type @a@, are:++  * @AnIndex ix :: Optic '[ix] s a@: focus via a run-time index of type @ix@,+  * @Index   i  :: Optic '[]   s a@: focus via the compile-time index @i :: Nat@,+  * @Name    k  :: Optic '[]   s a@: focus via the compile-time literal @k :: Symbol@.++The compile-time nature of 'Index' and 'Name' means that we can type-check their usage+to prevent focusing on a non-existent field (such as an out-of-bounds index).++These optics can be combined in the following ways:++  * @(:.:) :: Optic is s a -> Optic js a b -> Optic (is :++: js) s b@ composes two optics,+  allowing for focusing into nested structures.+  \[ s \to a \to b \]+  * @(:*:) :: (o1 :: Optic is s a) -> (o2 :: Optic js s b) -> Optic (Zip is js) s (Product o1 o2)@+  takes the product of two optics, to focus onto multiple components simultaneously.+  \[ \begin{array}{ccc}+  s & \to & a \\+  \downarrow & & \\+  b & &+  \end{array} \]+  * @OfType ty :: Optic '[] a ty@ focuses on all components of 'a' of type 'ty'.+  This allows setting multiple components of the same type to a given value.++Again, these are type-checked for validity. For instance, one cannot create a product setter+unless the two argument setters are disjoint.+(Note that this disallows product setters involving run-time indices,+as the required disjointness property can't be checked at compile-time.)+++Getters\/setters are optics which support accessing\/setting components.+Type-level optics which can be reified to provide value-level getters and setters are defined+through the 'ReifiedGetter' and 'ReifiedSetter' type classes, instances of which are provided+for types used in this library in the "FIR.Syntax.Optics" module, or in this module+as far as combinators are concerned (e.g. the getter instance for the composite of two getters).++The usage of these optics mimics the [Lens](http://hackage.haskell.org/package/lens/docs/Control-Lens.html)+library, but type-level arguments are provided with type applications. For instance:++@+> view @(Index 2) (V4 00 11 22 33)+22+@++Note that numeric indexing starts at 0.++@+> view @AnIndex 2 (V4 00 11 22 33)+22+@++Here the index is provided at the value-level instead of at the type-level.+Multiple indices can be provided in this manner:++  * as separate arguments for a composition,+  * as pairs for a product optic.++@+> view @(Index 1 :.: Index 0)+    $ M22+        0 1+        2 3+1+@++Here we first access the outer layer (the column with index 1, i.e. second of two columns),+then access the first component of that column. We always access the column first then the row,+following the column-major convention.+The type synonym 'Entry' can also be used: @Entry i j@ stands for @Index i :.: Index j@,+restricted to work specifically on matrices.++Note that, in a composition, the outermost optic is on the left, and the nesting increases+as one reads from left to right.++@+> struct :: Struct '[ "a" ':-> V 4 Float, "b" ':-> V 2 Float ]+> struct = V4 0 1 2 3 :& V2 4 5 :& End++> set @( (Name "a" :.: Index 2) :*: (Name "b" :.: Index 0) ) (V2 6 7) struct+{ "a" ':-> V4 0 1 6 3, "b" ':-> V2 7 5 }+@++Setting multiple values at once: focusing on the component at index 2 of the field @"a"@,+and the component at index 0 of the field @"b"@.++Because the last type accessed by each optic in the product is a vector type,+the type-system combines these two setters using vectors.+This explains why the value-level argument to @set@ is a 2-vector.++@+> mat :: M 3 3 Double+> mat = M33+          0 1 2+          3 4 5+          6 7 8++> set @( ( Entry 0 0 :*: Entry 0 2 :*: Entry 2 0 :*: Entry 2 2 ) :.: OfType Double ) 9 mat+M33+  9 1 9+  3 4 5+  9 7 9+@++'OfType' allows us to simultaneously set several entries (of the same type) to the same value.+__Warning:__ 'OfType' only creates a /setter/, not a /getter/.++Note that the 'FIR.Syntax.Optics.Diag' synonym exists for focusing on the diagonal of a matrix:++@+> view @Diag mat+V3 0 4 8+@++There is also the 'FIR.Syntax.Optics.Center' synonym for the center of a matrix,+which allows setting all diagonal entries of a square matrix to a single value:++@+> set @Center 9 mat+M33+  9 1 2+  3 9 5+  6 7 9+@++In fact 'FIR.Syntax.Optics.Center' can be simply defined as @Diag :.: OfType eltTy@.+-}++module Control.Type.Optic+  ( -- * Type-level optics+    Optic(..), ShowOptic+    -- $kind_coercion+  , AnIndex, Index, Name+    -- ** Getters and setters+  , Gettable, Getter, ReifiedGetter(view)+  , Settable, Setter, ReifiedSetter(set)+  , ReifiedLens(over)+    -- $kind_synonyms+  , Whole, Part, Indices+    -- ** Indexing information (used for overlap checking)+  , IndexInfo(..), IndexChain++    -- ** Containers+    -- $containers+  , Container(..)++    -- * Getter & setter instances+    -- $instances++    -- ** OfType optic+  , OfType+    -- $oftype_instances++    -- ** Composition of optics+  , (:.:)+    -- $composition_instances++    -- ** Product of optics+  , (:*:), Prod, EndProd+  , ProductComponents(..)+  , ComponentsGettable, ComponentsSettable+  , ArePairwiseDisjoint+    -- $product_instances++  ) where+++-- base+import Data.Kind+  ( Type, Constraint )+import Data.Proxy+  ( Proxy(Proxy) )+import Data.Type.Equality+  ( (:~:)(Refl) )+import GHC.TypeLits+  ( Symbol, AppendSymbol+  , TypeError, ErrorMessage(..)+  )+import GHC.TypeNats+  ( Nat )+import Unsafe.Coerce+  ( unsafeCoerce )++-- fir+import Data.Product+  ( HList(HNil, (:>))+  , IsProduct(fromHList, toHList)+  , AreProducts+  , MapHList+  )+import Data.Type.Error+  ( IsRight, And )+import Data.Type.List+  ( type (:++:), Postpend+  , Tail, MapTail+  , Replicate, Length+  , MapSingleton+  , ZipCons+  , SameLength(sSameLength)+  , SSameLength(SSameSucc, SSameZero)+  )+import Data.Type.Maybe+  ( IfNothingThen )+import Data.Type.String+  ( ShowNat )+import Data.Function.Variadic+  ( ListVariadic )+import FIR.Prim.Image+  ( Image )+import {-# SOURCE #-} FIR.Prim.Types+  ( PrimTy(FieldsOfType) )++----------------------------------------------------------------------++infixr 9 :.:+infixr 9 `ComposeO`+infixr 3 `ProductO`+infixr 3 :*:++-- | Optic data (kind).+data Optic (is :: [Type]) (s :: k) (a :: Type) where+  -- | Focus onto all the sub-parts which have a certain type.+  OfType_  :: Type -> Optic is s a+  -- | Optic with indexing information provided at run-time.+  RTOptic_ :: Optic is s a+  -- | Compile-time field (e.g. numeric index or symbolic field name).+  Field_   :: fld -> Optic is s a+  -- | Composition of optics.+  ComposeO :: Optic is s a -> Optic js a b -> Optic ks s b+  -- | Unbiased product of optics.+  Prod_ :: ProductComponents iss s as -> Optic js s p++-- | Wrapper to keep track of components of a product optic.+--+-- The first argument keeps track of runtime indices.+-- Its length keeps track of how many additional arguments need to be provided when using the optic.+-- For instance, @ iss ~ [ [X1,X2], [Y1,Y2], [Z1,Z2] ]@ means that we expect 3 additional indexing arguments,+-- with first argument consisting of indices of types @X1@ and X2@,+-- second argument consisting of indices of types @Y1@ and @Y2@,+-- and third argument consisting of indices of types @Z1@ and @Z2@.+--+-- @ view \@( optic :: Optic [ [x1,x2], [y1,y2], [z1,z2] ] S A) (x1,x2) (y1,y2) (z1,z2) s :: A @+data ProductComponents (iss :: [[Type]]) (s :: k) (as :: [Type]) where+  EndProd_ :: ProductComponents iss s as+  ProductO :: Optic is s a -> ProductComponents iss s as -> ProductComponents jss s (a ': as)++-- $kind_coercion+--+-- /__Warning__/: the data constructors of the 'Optic' data type are not type-correct.+-- This is to bypass difficulties with kind coercions:+-- at the time of writing, GHC does not full support kind coercions, in that+-- given the context @a ~ b@, GHC is unable to unify a type+-- of kind @a@ with a type of kind @b@.+-- (See [GHC trac #15710](https://gitlab.haskell.org/ghc/ghc/issues/15710).)+--+-- As a result, the constructors for the 'Optic' data type have overly general types.+-- Kind-correct type-level smart constructors are instead provided (and their use recommended):+--+--   * 'AnIndex', 'Index', 'Name', 'OfType' create specific optics,+--   * ':.:' composes two optics (left-most argument = outer-most optic),+--   * 'Prod', ':*:' and 'EndProd' allow the formation of (unbiased) product optics.+--+-- See also "FIR.Syntax.Images" for an overview of how to use optics with images.+++-- | Run-time index (kind-correct).+type AnIndex (ix :: Type  ) = RTOptic_ @'[ix]+-- | Compile-time index (kind-correct).+type Index   (i  :: Nat   ) = Field_ @Nat @'[] i+-- | Compile-time field name (kind-correct).+type Name    (k  :: Symbol) = Field_ @Symbol @'[] k+++-- | Optic for components of a particular type (kind-correct).+type OfType (ty :: Type) = (OfType_ ty :: Optic '[] s ty)+-- | Composition of optics (kind-correct).+type (:.:) (o1 :: Optic is s a) (o2 :: Optic js a b)+  = ( (o1 `ComposeO` o2) :: Optic (is :++: js) s b )+-- | Gather optics together in order to take an unbiased product over them (kind-correct).+type family (:*:) (o :: Optic is s a) (os :: ProductComponents iss s as) :: ProductComponents (ProductIndices is os) s (a ': as) where+  ( o :: Optic is s a ) :*: EndProd_+    = o `ProductO` ( EndProd_ :: ProductComponents (Replicate (Length is) '[]) s '[] )+  ( o :: Optic is s a ) :*: ( os :: ProductComponents iss s as )+    = ( o `ProductO` os :: ProductComponents (ProductIndices is os) s (a ': as) )+-- | Empty set of optic components.+type family EndProd :: ProductComponents '[] s '[] where+  EndProd = EndProd_+-- | Kind of indices resulting from a product.+type family ProductIndices (is :: [Type]) (os :: ProductComponents iss s as) :: [[Type]] where+  ProductIndices is EndProd_ = MapSingleton is+  ProductIndices is ( os :: ProductComponents iss s as ) = ZipCons is iss+-- | Unbiased product of a set of component optics (kind-correct).+type Prod (os :: ProductComponents iss s as)+  = ( Prod_ os :: Optic (MapHList iss) s p )+-- TODO: it would be nice to have "p" as a first argument for visible kind application+-- (this might require standalone kind signatures?)++type family ShowOptic (o :: Optic is s a) :: ErrorMessage where+  ShowOptic (OfType_ ty) = Text "OfType " :<>: ShowType ty+  -- special case for image optics+  ShowOptic+    ( ( Field_ (k :: Symbol) :: Optic '[] i (Image props) )+    `ComposeO`+      ( RTOptic_ :: Optic '[ _, _ ] (Image props) _ )+    )+      = Text "ImageTexel " :<>: ShowType k+  ShowOptic (RTOptic_ :: Optic '[ix] s a)+    = Text "AnIndex (" :<>: ShowType ix :<>: Text ")"+  ShowOptic (RTOptic_ :: Optic is s a)+    = Text "SomeIndices (" :<>: ShowType is :<>: Text ")"+  ShowOptic (Field_ (i :: Nat))+    = Text "Index " :<>: ShowType i+  ShowOptic (Field_ (k :: Symbol) :: Optic is (s :: Type) a)+    = Text "Name " :<>: ShowType k+  ShowOptic (Field_ (k :: Symbol) :: Optic is (s :: _) a)+    = Text "Binding " :<>: ShowType k+  ShowOptic (o1 `ComposeO` o2)+    = Text "( " :<>: ShowOptic o1 :<>: Text " :.: " :<>: ShowOptic o2 :<>: Text " )"+  ShowOptic (Prod_ comps)+    = Text "Prod ( " :<>: ShowComponents comps :<>: Text " )"++type family ShowComponents (comps :: ProductComponents iss s as) :: ErrorMessage where+  ShowComponents EndProd_ = Text "EndProd"+  ShowComponents (o `ProductO` comps)+    = ShowOptic o :<>: Text " :*: " :<>: ShowComponents comps++----------------------------------------------------------------------+-- Type classes and synonyms.++-- | Type-level getter.+class Gettable (optic :: Optic is (s :: k) a) | optic -> is k s a where++type  Getter (optic :: Optic is (s :: Type) a) = ListVariadic (is `Postpend` s) a++-- | Type-level getter which can be turned into a value-level getter.+class Gettable optic => ReifiedGetter optic where+  view :: Getter optic++-- | Type-level setter.+class Settable (optic :: Optic is (s :: k) a) | optic -> is k s a where++type  Setter (optic :: Optic is (s :: Type) a) = ListVariadic (is `Postpend` a `Postpend` s) s++-- | Type-level setter which can be turned into a value-level setter.+class Settable optic => ReifiedSetter optic where+  set :: Setter optic++type Over (optic :: Optic is (s :: Type) a) = ListVariadic (is `Postpend` (a -> a) `Postpend` s) s++-- | Type-level lens: can be used to modify the part under its focus.+class ( ReifiedSetter optic, ReifiedGetter optic ) => ReifiedLens optic where+  over :: Over optic++-- $kind_synonyms+--+-- Synonyms that allow kind variables to remain invisible.+--+-- See [explicit specificity (GHC proposal #26)](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0026-explicit-specificity.rst).++type Whole   (optic :: Optic is s a) = s+type Part    (optic :: Optic is s a) = a+type Indices (optic :: Optic is s a) = is++-------------------------------+-- $containers+--+-- Auxiliary internal type class describing types that provide the functionality necessary+-- to be able to create product optics.+--+-- This type class contains type-level methods for checking disjointness of optics,+-- in particular the ability to check that a numeric index+-- and a symbolic field name do not refer to the same component,+-- when applicable.++class Container (s :: Type) where++  -- | Compute a numeric indexing from a symbolic index.+  -- Can return a type-error if symbolic indexing is not supported.+  --+  -- Chiefly needed for overlap checking for 'FIR.Prim.Struct.Struct's.+  type FieldIndexFromName s (k :: Symbol) :: Nat+  -- | Default instance: don't allow symbolic indexing. Can be overriden.+  type FieldIndexFromName s k+    = TypeError+      (    Text "Attempt to index object of type " :<>: ShowType s+      :<>: Text " with symbolic index " :<>: ShowType k :<>: Text "."+      :$$: Text "This type does not support symbolic indexing."+      )++----------------------------------------------------------------------+-- $instances+--+-- This module defines getter and setter instances that are applicable in general situations:+--+--   * composition of optics,+--   * product of optics,+--+-- In other words, this module provides the general framework for /combining/ optics.+-- To manipulate specific types (e.g. the ability to access a component of a vector by its index),+-- corresponding specific instances are required.+--+-- The specific instances, as they pertain to datatypes used by this library,+-- are found in the "FIR.Syntax.Optics" module.+-- This includes instances for vectors, matrices and structs.+-- See also "FIR.Syntax.Images" for the peculiar 'FIR.Syntax.Images.ImageTexel' lens.++--------------------------+-- $lens_instances+--+-- Combine a getter and a setter into a lens.++class GetterAndSetter is s a where+  getAndSet+    :: ListVariadic (is `Postpend` s) a+    -> ListVariadic (is `Postpend` a `Postpend` s) s+    -> ListVariadic (is `Postpend` (a -> a) `Postpend` s) s++instance ( s ~ ListVariadic '[] s, a ~ ListVariadic '[] a ) => GetterAndSetter '[] s a where+ getAndSet view1 set1 f s = set1 ( f (view1 s) ) s++instance GetterAndSetter is s a => GetterAndSetter (i ': is) s a where+  getAndSet view1 set1 i+    = getAndSet @is @s @a (view1 i) (set1 i)++instance forall is s a (optic :: Optic is s a).+                ( ReifiedGetter optic, ReifiedSetter optic+                , GetterAndSetter is s a+                )+            => ReifiedLens optic where+  over = getAndSet @is @s @a (view @optic) (set @optic)++--------------------------+-- $oftype_instances+--+-- The 'OfType' optic constructor creates setters, not getters.+-- So we prevent setter instances.+--+-- Getter instances are defined individually for specific types,+-- see "FIR.Syntax.Optics".++instance+  ( TypeError ( Text "get: cannot use 'OfType' optic as a getter." ) )+  => Gettable (OfType_ ty :: Optic i s a) where+instance+  ( TypeError ( Text "get: cannot use 'OfType' optic as a getter." ) )+  => ReifiedGetter (OfType_ ty :: Optic i s a) where+  view = error "unreachable"++-- Default instance to use: "a" does not contain components of type "ty".+-- Should be overridden by specific instances that+-- provide evidence that "a" does in fact contain components of type "ty".+instance {-# OVERLAPPABLE #-}+         ( r ~ ty, empty ~ '[] )+      => Settable      (OfType_ ty :: Optic empty a r) where+instance {-# OVERLAPPABLE #-}+         ( r ~ ty, empty ~ '[], ListVariadic '[] a ~ a )+      => ReifiedSetter (OfType_ ty :: Optic empty a r) where+  set _ = id++--------------------------+-- $composition_instances+--+-- Included are the following instances for composed optics:+--+--   * the composite of two getters is a getter,+--   * the composite of a lens (outside) with a setter (inside) is a setter.+--+-- Note that compositions where the first optic accesses from a monadic state+-- is not included here.+-- This is to provide improved type inference, see "FIR.Syntax.Optics".++instance forall (s :: Type) is js ks a b (o1 :: Optic is s a) (o2 :: Optic js a b).+         ( Gettable o1+         , Gettable o2+         , ks ~ (is :++: js)+         ) => Gettable ((o1 `ComposeO` o2) :: Optic ks s b) where+instance forall (s :: Type) is js ks a b (o1 :: Optic is s a) (o2 :: Optic js a b).+         ( Settable o1+         , Settable o2+         , ks ~ (is :++: js)+         ) => Settable ((o1 `ComposeO` o2) :: Optic ks s b) where++instance forall (s :: Type) is js ks a b (o1 :: Optic is s a) (o2 :: Optic js a b).+         ( ReifiedGetter o1+         , ReifiedGetter o2+         , ComposeGetters is js s a b+         , ks ~ (is :++: js)+         )+      => ReifiedGetter ((o1 `ComposeO` o2) :: Optic ks s b) where+  view = composeGetters @is @js @s @a @b (view @o1) (view @o2)++class ComposeGetters is js s a b where+  composeGetters :: ListVariadic (is `Postpend` s) a+                 -> ListVariadic (js `Postpend` a) b+                 -> ListVariadic ((is :++: js) `Postpend` s) b+instance (a ~ ListVariadic '[] a) => ComposeGetters '[] '[] s a b where+  composeGetters view1 view2 = view2 . view1+instance ComposeGetters is js s a b => ComposeGetters (i ': is) js s a b where+  composeGetters view1 view2 i+    = composeGetters @is @js @s @a @b (view1 i) view2+instance ComposeGetters '[] js s a b => ComposeGetters '[] (j ': js) s a b where+  composeGetters view1 view2 j+    = composeGetters @'[] @js @s @a @b view1 (view2 j)++instance forall (s :: Type) is js ks a b (o1 :: Optic is s a) (o2 :: Optic js a b).+         ( ReifiedSetter o1+         , ReifiedSetter o2+         , ReifiedGetter o1+         , ComposeSetters is js s a b+         , ks ~ (is :++: js)+         )+      => ReifiedSetter ((o1 `ComposeO` o2) :: Optic ks s b) where+  set = composeSetters @is @js @s @a @b (view @o1) (set @o1) (set @o2)++class ComposeSetters is js s a b where+  composeSetters :: ListVariadic (is `Postpend` s) a+                 -> ListVariadic (is `Postpend` a `Postpend` s) s+                 -> ListVariadic (js `Postpend` b `Postpend` a) a+                 -> ListVariadic ((is :++: js) `Postpend` b `Postpend` s) s+instance (a ~ ListVariadic '[] a) => ComposeSetters '[] '[] s a b where+  composeSetters view1 set1 set2 b s+    = set1 (set2 b (view1 s)) s+instance ComposeSetters is js s a b => ComposeSetters (i ': is) js s a b where+  composeSetters view1 set1 set2 i+    = composeSetters @is @js @s @a @b (view1 i) (set1 i) set2+instance ComposeSetters '[] js s a b => ComposeSetters '[] (j ': js) s a b where+  composeSetters view1 set1 set2 j+    = composeSetters @'[] @js @s @a @b view1 set1 (set2 j)++--------------------------+-- $product_instances+--+-- Included are the following instances for product optics:+--+--   * the product of disjoint setters is a setter,+--   * the product of getters is a getter.++-------------+-- disjointness checking++data IndexInfo+  = ThisIndex Nat+  | AnyIndex -- any index (e.g. runtime index, or a situation such as "TypeOf a :: Optic '[] (Array n a) a")++type IndexChain = [IndexInfo]++data IndexChoice+  = OneIndex IndexInfo+  | Choice   [IndexChoices]++type IndexChoices = [IndexChoice]++type family Disjoint ( o1 :: Optic is s a ) ( o2 :: Optic js s b ) :: Either ErrorMessage () where+  Disjoint o1 o2+    = ErrorIfOverlap o1 o2+        ( FirstOverlap (IndexChoicesOf o1) (IndexChoicesOf o2) )++type ArePairwiseDisjoint (os :: ProductComponents iss s as)+  = ( IsRight (PairwiseDisjoint os) :: Constraint )++type family PairwiseDisjoint (os :: ProductComponents iss s as) :: Either ErrorMessage () where+  PairwiseDisjoint EndProd_          = Right '()+  PairwiseDisjoint (o `ProductO` os) =+    ( o `DisjointFrom` os ) `And` PairwiseDisjoint os++type family DisjointFrom (o :: Optic is s a) (os :: ProductComponents iss s as) :: Either ErrorMessage () where+  DisjointFrom o EndProd_           = Right '()+  DisjointFrom o (o' `ProductO` os) =+    Disjoint o o' `And` (o `DisjointFrom` os)++type family ErrorIfOverlap+              ( o1      :: Optic is s a )+              ( o2      :: Optic js s b )+              ( overlap :: Maybe [Nat]  )+            :: Either ErrorMessage ()+            where+  ErrorIfOverlap _  _ 'Nothing = Right '()+  ErrorIfOverlap (o1 :: Optic is s a) o2 ('Just nfo)+    = TypeError+        (    Text "Cannot create product setter at type:"+        :$$: Text "  " :<>: ShowType s+        :$$: Text "Overlap between optics"+        :$$: Text "  - " :<>: ShowOptic o1 :<>: Text ","+        :$$: Text "  - " :<>: ShowOptic o2+        :<>: IndexChainErrorMessage nfo+        )++type family IndexChainErrorMessage (chain :: [Nat]) :: ErrorMessage where+  IndexChainErrorMessage '[]+    = Text "."+  IndexChainErrorMessage '[i]+    = Text "," :$$: Text "at index " :<>: Text (ShowNat i) :<>: Text "."+  IndexChainErrorMessage is+    = Text "," :$$: Text "at index chain ( " :<>: Text (ShowIndexChain is) :<>: Text " )."++type family ShowIndexChain (chain :: [Nat]) :: Symbol where+  ShowIndexChain '[ ] = ""+  ShowIndexChain '[i] = ShowNat i+  ShowIndexChain (i ': j ': is)+    = ShowNat i `AppendSymbol` " -- " `AppendSymbol` ( ShowIndexChain (j ': is) )++type family FirstOverlap+              ( nfo1 :: IndexChoices )+              ( nfo2 :: IndexChoices )+            :: Maybe [Nat]+            where+  FirstOverlap '[] _  = Just '[]+  FirstOverlap _  '[] = Just '[]+  FirstOverlap ( OneIndex  i1 ': nfo1 ) ( OneIndex  i2 ': nfo2 )+    = FirstOverlapOneIndex i1 nfo1 i2 nfo2+  FirstOverlap ( Choice nfos1 ': nfo1 ) ( Choice nfos2 ': nfo2 )+    = FirstCrosswiseOverlap  nfos1 (Just nfo1)  nfos2 (Just nfo2)+  FirstOverlap ( Choice nfos1 ': nfo1 ) nfo2+    = FirstCrosswiseOverlap  nfos1 (Just nfo1) '[nfo2] Nothing+  FirstOverlap nfo1                     ( Choice nfos2 ': nfo2 )+    = FirstCrosswiseOverlap '[nfo1] Nothing     nfos2 (Just nfo2)++type family FirstOverlapOneIndex+              ( i1   :: IndexInfo    )+              ( nfo1 :: IndexChoices )+              ( i2   :: IndexInfo    )+              ( nfo2 :: IndexChoices )+            :: Maybe [Nat] where+  FirstOverlapOneIndex (ThisIndex i ) nfo1 (ThisIndex i ) nfo2+    = FmapConsMaybe i ( FirstOverlap nfo1 nfo2 )+  FirstOverlapOneIndex (ThisIndex i1) _    (ThisIndex i2) _+    = Nothing+  FirstOverlapOneIndex (ThisIndex i1) nfo1 AnyIndex       nfo2+    = FmapConsMaybe i1 ( FirstOverlap nfo1 nfo2 )+  FirstOverlapOneIndex  AnyIndex      nfo1 (ThisIndex i2) nfo2+    = FmapConsMaybe i2 ( FirstOverlap nfo1 nfo2 )+  FirstOverlapOneIndex  AnyIndex      nfo1 AnyIndex       nfo2+    = FmapConsMaybe 0  ( FirstOverlap nfo1 nfo2 )++type family FirstCrosswiseOverlap+              ( nfos1 :: [IndexChoices]     )+              ( nxt1  :: Maybe IndexChoices )+              ( nfos2 :: [IndexChoices]     )+              ( nxt2  :: Maybe IndexChoices )+           :: Maybe [Nat]+           where+  FirstCrosswiseOverlap '[]               _      _     _+    = Nothing+  FirstCrosswiseOverlap ( nfo1 ': nfos1 ) mbNxt1 nfos2 mbNxt2+    = ( FirstOverlapIn nfo1 mbNxt1 nfos2 mbNxt2 )+      `IfNothingThen`+      ( FirstCrosswiseOverlap nfos1 mbNxt1 nfos2 mbNxt2 )++type family FirstOverlapIn+              ( nfo1  :: IndexChoices       )+              ( nxt1  :: Maybe IndexChoices )+              ( nfos2 :: [IndexChoices]     )+              ( nxt2  :: Maybe IndexChoices )+           :: Maybe [Nat]+           where+  FirstOverlapIn _    _      '[]               _+    = Nothing+  FirstOverlapIn nfo1 mbNxt1 ( nfo2 ': nfos2 ) mbNxt2+    = ( FirstOverlap ( nfo1 `MaybeAppend` mbNxt1 ) ( nfo2 `MaybeAppend` mbNxt2 ) )+      `IfNothingThen`+      ( FirstOverlapIn nfo1 mbNxt1 nfos2 mbNxt2 )++type family FmapConsMaybe ( i :: k ) ( js :: Maybe [k] ) :: Maybe [k] where+  FmapConsMaybe _ Nothing   = Nothing+  FmapConsMaybe i (Just js) = Just (i ': js)++type family MaybeAppend ( xs :: [k] ) ( mb_ys :: Maybe [k] ) :: [k] where+  MaybeAppend xs Nothing   = xs+  MaybeAppend xs (Just ys) = xs :++: ys++type family IndexChoicesOf ( o :: Optic is s a ) :: IndexChoices where+  IndexChoicesOf ( Field_ ( i :: Nat    ) ) = '[ OneIndex (ThisIndex i) ]+  IndexChoicesOf ( Field_ ( k :: Symbol ) :: Optic is s a )+    = '[ OneIndex (ThisIndex ( FieldIndexFromName s k )) ]+  IndexChoicesOf ( Field_ ( i :: fld    ) )+    = TypeError+        (    Text "Cannot create product setter."+        :$$: Text "Index " :<>: ShowType i+        :<>: Text " has unsupported kind " :<>: ShowType fld :<>: Text "."+        )+  IndexChoicesOf RTOptic_ = '[ OneIndex AnyIndex ]+  IndexChoicesOf ( o1 `ComposeO` o2 )+    = IndexChoicesOf o1 :++: IndexChoicesOf o2+  IndexChoicesOf ( Prod_ comps )+    = '[ Choice ( ComponentIndexChoices comps ) ]+  IndexChoicesOf ( OfType_ ty :: Optic is s a )+    = '[ Choice ( MapMapOneIndex (FieldsOfType s ty) ) ]+++type family ComponentIndexChoices ( comps :: ProductComponents iss s as ) :: [IndexChoices] where+  ComponentIndexChoices EndProd_ = '[]+  ComponentIndexChoices (o `ProductO` os)+    = IndexChoicesOf o ': ComponentIndexChoices os++type family MapMapOneIndex ( flds :: [IndexChain] ) :: [IndexChoices] where+  MapMapOneIndex '[] = '[]+  MapMapOneIndex ( nfo ': nfos ) = MapOneIndex nfo ': MapMapOneIndex nfos++type family MapOneIndex ( flds :: IndexChain ) :: IndexChoices where+  MapOneIndex '[] = '[]+  MapOneIndex ( nfo ': nfos ) = OneIndex nfo ': MapOneIndex nfos++-------------+-- instances++class ComponentsGettable (os :: ProductComponents iss s as) where+instance ComponentsGettable EndProd_ where+instance ( ComponentsGettable os, Gettable o ) => ComponentsGettable (o `ProductO` os)+class ComponentsSettable (os :: ProductComponents iss s as) where+instance ComponentsSettable EndProd_ where+instance ( ComponentsSettable os, Settable o ) => ComponentsSettable (o `ProductO` os)++instance forall+            ( iss :: [[Type]] )+            ( js  :: [Type]   )+            ( k   :: Type     )+            ( s   :: k        )+            ( as  :: [Type]   )+            ( p   :: Type     )+            ( os  :: ProductComponents iss s as )+          .+          ( ComponentsGettable os+          , IsProduct p as+          , AreProducts js iss as+          )+       => Gettable (Prod_ os :: Optic js s p)+       where++instance forall+            ( iss :: [[Type]] )+            ( js  :: [Type]   )+            ( k   :: Type     )+            ( s   :: k        )+            ( as  :: [Type]   )+            ( p   :: Type     )+            ( os  :: ProductComponents iss s as )+          .+          ( ComponentsSettable os+          , IsProduct p as+          , AreProducts js iss as+          , ArePairwiseDisjoint os+          )+       => Settable (Prod_ os :: Optic js s p)+       where++instance forall+            ( iss :: [[Type]] )+            ( js  :: [Type]   )+            ( s   :: Type     )+            ( as  :: [Type]   )+            ( p   :: Type     )+            ( os  :: ProductComponents iss s as )+          .+          ( ComponentsGettable os+          , IsProduct p as+          , AreProducts js iss as+          , MultiplyGetters iss js s as p+          , GetViewers os+          )+       => ReifiedGetter (Prod_ os :: Optic js s p)+       where+  view = multiplyGetters @iss @js @s @as @p+           ( viewers @iss @s @as @os )++instance forall+            ( iss :: [[Type]] )+            ( js  :: [Type]   )+            ( s   :: Type     )+            ( as  :: [Type]   )+            ( p   :: Type     )+            ( os  :: ProductComponents iss s as )+          .+          ( ComponentsSettable os+          , IsProduct p as+          , AreProducts js iss as+          , ArePairwiseDisjoint os+          , MultiplySetters iss js s as p+          , GetSetters os+          )+       => ReifiedSetter (Prod_ os :: Optic js s p)+       where+  set = multiplySetters @iss @js @s @as @p+           ( setters @iss @s @as @os )++class GetViewers (os :: ProductComponents iss (s :: Type) as) where+  viewers :: Viewers iss s as++instance ( as ~ '[] ) => GetViewers ( EndProd_ :: ProductComponents iss s as ) where+  viewers = NilViewer+instance forall+          ( iss :: [[Type]]    )+          ( kss :: [[Type]]    )+          ( is :: [Type]       )+          ( s  :: Type         )+          ( as :: [Type]       )+          ( a  :: Type         )+          ( o  :: Optic is s a )+          ( os :: ProductComponents iss s as )+         .+         ( GetViewers os+         , ReifiedGetter o+         , SameLength is kss+         , kss ~ ZipCons is iss+         )+       => GetViewers (o `ProductO` os :: ProductComponents kss s (a ': as)) where+  viewers = ConsViewer @is @s @a (sSameLength @_ @_ @is @kss) Proxy Proxy Proxy+              (view @o) (viewers @iss @s @as @os)++class GetSetters (os :: ProductComponents iss (s :: Type) as) where+  setters :: Setters iss s as++instance ( as ~ '[] ) => GetSetters ( EndProd_ :: ProductComponents iss s as ) where+  setters = NilSetter+instance forall+          ( iss :: [[Type]]    )+          ( kss :: [[Type]]    )+          ( is :: [Type]       )+          ( s  :: Type         )+          ( as :: [Type]       )+          ( a  :: Type         )+          ( o  :: Optic is s a )+          ( os :: ProductComponents iss s as )+         .+         ( GetSetters os+         , ReifiedSetter o+         , SameLength is kss+         , kss ~ ZipCons is iss+         )+       => GetSetters (o `ProductO` os :: ProductComponents kss s (a ': as)) where+  setters = ConsSetter @is @s @a (sSameLength @_ @_ @is @kss) Proxy Proxy Proxy+              (set @o) (setters @iss @s @as @os)++class MultiplyGetters (iss :: [[Type]]) (js :: [Type]) (s :: Type) (as :: [Type]) (p :: Type) where+  multiplyGetters :: Viewers iss s as -> ListVariadic (js `Postpend` s) p++class MultiplySetters (iss :: [[Type]]) (js :: [Type]) (s :: Type) (as :: [Type]) (p :: Type) where+  multiplySetters :: Setters iss s as -> ListVariadic (js `Postpend` p `Postpend` s) s++instance ( IsProduct p as, p ~ ListVariadic '[] p )+       => MultiplyGetters iss '[] s as p where+  multiplyGetters :: Viewers iss s as -> s -> p+  multiplyGetters views s = fromHList @p @as ( applyGetters views s )++instance ( IsProduct j is, SameLength is as, MultiplyGetters iss js s as p )+      => MultiplyGetters (is ': iss) (j ': js) s as p where+  multiplyGetters :: Viewers (is ': iss) s as -> ( j -> ListVariadic (js `Postpend` s) p )+  multiplyGetters views j =+    multiplyGetters @iss @js @s @as @p+      ( passGetterIndex (sSameLength @_ @_ @is @as) ( toHList j ) views )++instance ( IsProduct p as, s ~ ListVariadic '[] s )+      => MultiplySetters iss '[] s as p where+  multiplySetters :: Setters iss s as -> p -> s -> s+  multiplySetters sets p s = applySetters sets ( toHList @p @as p ) s++instance ( IsProduct j is, SameLength is as, MultiplySetters iss js s as p )+      => MultiplySetters (is ': iss) (j ': js) s as p where+  multiplySetters :: Setters (is ': iss) s as -> ( j -> ListVariadic (js `Postpend` p `Postpend` s) s )+  multiplySetters sets j+    = multiplySetters @iss @js @s @as @p+        ( passSetterIndex (sSameLength @_ @_ @is @as) ( toHList j ) sets )+++applyGetters :: Viewers iss s bs -> s -> HList bs+applyGetters   NilViewer                                        _ = HNil+applyGetters ( ConsViewer _ _ _ (_ :: Proxy b) getter getters ) s =+  case getters of+    ( _ :: Viewers jss s cs )+      -> ( unsafeCoerce getter :: s -> b ) s+         :> applyGetters ( unsafeCoerce getters :: Viewers '[] s cs ) s++applySetters :: Setters iss s bs -> HList bs -> s -> s+applySetters   NilSetter                                     _         s  = s+applySetters ( ConsSetter _ _ _ (_ :: Proxy b) setter sets ) (b :> bs) s  =+  case sets of+    ( _ :: Setters jss s cs )+      -> applySetters ( unsafeCoerce sets :: Setters '[] s cs ) bs+       $ ( unsafeCoerce setter :: b -> s -> s ) b s++passGetterIndex+  :: forall (js :: [Type]) (jss :: [[Type]]) (s :: Type) (as :: [Type])+  . SSameLength js as -> HList js -> Viewers (js ': jss) s as -> Viewers jss s as+passGetterIndex SSameZero                                        _  _    = unsafeCoerce NilViewer+passGetterIndex (SSameSucc ( same1 :: SSameLength t_js t_as ) ) js views =+  case ( js, views ) of+    ( (k :: j) :> (ks :: HList t_js), ConsViewer same2 (_ :: Proxy is) (_ :: Proxy iss) _ getter getters ) ->+      case same2 of+        ( sameSucc@(SSameSucc (same3 :: SSameLength t_is jss) ) ) ->+          case sameSucc of+            ( _ :: SSameLength (i ': t_is) (js ': jss) )+              | Refl <- ( unsafeCoerce Refl :: ZipCons t_is (Tail iss) :~: jss )+              , Refl <- ( unsafeCoerce Refl :: ( t_js ': MapTail jss ) :~: iss )+              , Refl <- ( unsafeCoerce Refl :: i :~: j )+              , Proxy :: Proxy bss <- Proxy @(Tail iss)+              -> ConsViewer same3 (Proxy @t_is) (Proxy @bss) Proxy+                    ( getter k )+                    ( passGetterIndex @t_js @(MapTail jss) @s @t_as same1 ks getters )++passSetterIndex+  :: forall (js :: [Type]) (jss :: [[Type]]) (s :: Type) (as :: [Type])+  . SSameLength js as -> HList js -> Setters (js ': jss) s as -> Setters jss s as+passSetterIndex SSameZero                                        _  _   = unsafeCoerce NilViewer+passSetterIndex (SSameSucc ( same1 :: SSameLength t_js t_as ) ) js sets =+  case ( js, sets ) of+    ( (k :: j) :> (ks :: HList t_js), ConsSetter same2 (_ :: Proxy is) (_ :: Proxy iss) _ setter setts ) ->+      case same2 of+        ( sameSucc@(SSameSucc (same3 :: SSameLength t_is jss) ) ) ->+          case sameSucc of+            ( _ :: SSameLength (i ': t_is) (js ': jss) )+              | Refl <- ( unsafeCoerce Refl :: ZipCons t_is (Tail iss) :~: jss )+              , Refl <- ( unsafeCoerce Refl :: ( t_js ': MapTail jss ) :~: iss )+              , Refl <- ( unsafeCoerce Refl :: i :~: j )+              , Proxy :: Proxy bss <- Proxy @(Tail iss)+              -> ConsSetter same3 (Proxy @t_is) (Proxy @(Tail iss)) Proxy+                    ( setter k )+                    ( passSetterIndex @t_js @bss @s @t_as same1 ks setts )++data Viewers (iss :: [[Type]]) (s :: Type) (as :: [Type]) where+  NilViewer  :: Viewers iss s '[] -- iss should always be a list of empty lists+  ConsViewer :: forall (is :: [Type]) (s :: Type) (a :: Type) (iss :: [[Type]]) (as :: [Type])+             .  SSameLength is (ZipCons is iss)+             -> Proxy is+             -> Proxy iss+             -> Proxy a+             -> ListVariadic (is `Postpend` s) a+             -> Viewers iss s as+             -> Viewers (ZipCons is iss) s (a ': as)++data Setters (iss :: [[Type]]) (s :: Type) (as :: [Type]) where+  NilSetter  :: Setters iss s '[]  -- iss should always be a list of empty lists+  ConsSetter :: forall (is :: [Type]) (s :: Type) (a :: Type) (iss :: [[Type]]) (as :: [Type])+             .  SSameLength is (ZipCons is iss)+             -> Proxy is+             -> Proxy iss+             -> Proxy a+             -> ListVariadic (is `Postpend` a `Postpend` s) s+             -> Setters iss s as+             -> Setters (ZipCons is iss) s (a ': as)
+ src/Control/Type/Optic.hs-boot view
@@ -0,0 +1,51 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE RoleAnnotations        #-}+{-# LANGUAGE TypeOperators          #-}++module Control.Type.Optic+  ( Optic+  , Whole, Part, Indices+  , IndexInfo(..), IndexChain+  , Gettable, ReifiedGetter+  , Settable, ReifiedSetter+  ) where++-- base+import Data.Kind+  ( Type )+import GHC.TypeNats+  ( Nat )++-- fir+import Data.Function.Variadic+  ( ListVariadic )+import Data.Type.List+  ( Postpend )++------------------------------------------------------------++data Optic (is :: [Type]) (s :: k) (a :: Type)+type role Optic phantom phantom phantom++type Whole   (optic :: Optic is s a) = s+type Part    (optic :: Optic is s a) = a+type Indices (optic :: Optic is s a) = is++data IndexInfo+  = ThisIndex Nat+  | AnyIndex++type IndexChain = [IndexInfo]++class Gettable (optic :: Optic (is :: [Type]) (s :: k) a) | optic -> is k s a+type  Getter (optic :: Optic is (s :: Type) a) = ListVariadic (is `Postpend` s) a+class Gettable optic => ReifiedGetter optic where+  view :: Getter optic++class Settable (optic :: Optic is (s :: k) a) | optic -> is k s a+type  Setter (optic :: Optic is (s :: Type) a) = ListVariadic (is `Postpend` a `Postpend` s) s+class Settable optic => ReifiedSetter optic where+  set :: Setter optic
+ src/Data/Binary/Class/Put.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE TypeApplications #-}++{-|+Module: Data.Binary.Class.Put++One half of the 'Data.Binary.Binary' type class: putting.++This type class is used to provide arguments to @SPIR-V@+instructions; everything comes in multiples of 'Word32'.++The instances provided in this module are /little endian/,+in agreement with the default endianness for @SPIR-V@ assembly.++Note: this type class is __not__ concerned with memory layout on the GPU.+GPU memory layout is managed using @SPIR-V@ decorations, in conjunction with @Vulkan@.+This type class is instead used internally, to emit binary SPIR-V assembly.++-}++module Data.Binary.Class.Put+  (+    -- * Put type class+    Put(..)+    -- ** Instances+    -- $instances+  , PutWord32Enum(..)+  ) where++-- base+import Data.Coerce+  ( coerce )+import Data.Int+  ( Int8,Int16,Int32,Int64 )+import Data.Semigroup+  ( stimes )+import Data.Word+  ( Word8,Word16,Word32,Word64 )+import Foreign.C.Types+  ( CUShort(CUShort) )++-- binary+import qualified Data.Binary.Put as Binary+  ( PutM+  , putWord8, putWord16le+  , putWord32le, putWord64le+  , putInt32le, putInt64le+  , putFloatle, putDoublele+  , putShortByteString+  )++-- bytestring+import qualified Data.ByteString.Short as ShortByteString+  ( length )++-- half+import Numeric.Half+  ( Half(Half) )++-- text-short+import Data.Text.Short+  ( ShortText )+import qualified Data.Text.Short as ShortText+  ( toShortByteString )++----------------------------------------------------------------------------+-- Put type class++-- | One half of 'Data.Binary.Binary'.+class Put a where+  put       :: a -> Binary.PutM ()+  -- | Memory footprint, as a multiple of __32 bits__+  -- (/not/ the usual 8 bits as in 'Foreign.Storable.sizeOf').+  wordCount :: a -> Word32++---------------------------------------------------------------------------+-- $instances+--+-- Little-endian instances are provided for 'Put',+-- as these are best suited to @SPIR-V@.+--+-- Note that types smaller than 32 bits are immediately padded:+-- this type class is purely used for specifying arguments+-- to @SPIR-V@ instructions, and the smallest allowed size is 32 bits;+-- it is not possible to tightly pack arguments of smaller sizes.++instance Put Word8 where+  put = Binary.putWord32le . fromIntegral+  wordCount _ = 1++instance Put Word16 where+  put = Binary.putWord32le . fromIntegral+  wordCount _ = 1++instance Put Word32 where+  put = Binary.putWord32le+  wordCount _ = 1++instance Put Word64 where+  put = Binary.putWord64le+  wordCount _ = 2++instance Put Int8 where+  put = Binary.putInt32le . fromIntegral+  wordCount _ = 1++instance Put Int16 where+  put = Binary.putInt32le . fromIntegral+  wordCount _ = 1++instance Put Int32 where+  put = Binary.putInt32le+  wordCount _ = 1++instance Put Int64 where+  put = Binary.putInt64le+  wordCount _ = 2++instance Put Half where+  put h = do+    Binary.putWord16le (coerce h)+    Binary.putWord16le 0+  wordCount _ = 1++instance Put Float where+  put = Binary.putFloatle+  wordCount _ = 1++instance Put Double where+  put = Binary.putDoublele+  wordCount _ = 2++-- | @C@-style string+instance Put ShortText where+  put lit =+    let n = ShortByteString.length (ShortText.toShortByteString lit)+        pad = 4 - (n `mod` 4)+    in Binary.putShortByteString (ShortText.toShortByteString lit)+    <> (pad `stimes` Binary.putWord8 0)+  wordCount lit+    = let n = fromIntegral $ ShortByteString.length (ShortText.toShortByteString lit)+      in 1 + (n `div` 4)++----------------------------------------------------------------------------+-- | Newtype for 'Put' instance using 'Enum'.+--+-- Useful with deriving via:+-- @ data ... deriving Put via (PutWord32Enum ...) @.+newtype PutWord32Enum a = PutWord32Enum { runPutWord32Enum :: a }++instance Enum a => Put (PutWord32Enum a) where+  put = put @Word32 . fromIntegral . fromEnum . runPutWord32Enum+  wordCount _ = 1
+ src/Data/Constraint/All.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE TypeOperators         #-}++{-|+Module: Data.Constraint.All++This module provides the ability to take a conjunction of a list of constraints.++Includes a reflection mechanism to enable resolution of individual constraints.+-}++module Data.Constraint.All+  ( AllDict(NilDict, ConsDict)+  , All(allDict)+  )+  where++import Data.Kind+  ( Constraint )++------------------------------------------------------------++data AllDict (c :: k -> Constraint) (as :: [k]) where+  NilDict  :: AllDict c '[]+  ConsDict :: (c a, All c as) => AllDict c (a ': as)++class All c as where+  allDict :: AllDict c as++instance All c '[] where+  allDict = NilDict++instance ( c a, All c as ) => All c (a ': as) where+  allDict = ConsDict
+ src/Data/Containers/Traversals.hs view
@@ -0,0 +1,25 @@+{-|+Module: Data.Containers.Traversals++Defines some folds/traversals on 'Data.Map.Map' and 'Data.Set.Set' that are not provided by the containers library.+-}++module Data.Containers.Traversals where++-- containers+import Data.Map+  ( Map )+import qualified Data.Map.Strict as Map+  ( foldrWithKey )+import Data.Set+  ( Set )+import qualified Data.Set as Set+  ( foldr' )++----------------------------------------------------------------------------++traverseWithKey_ :: Applicative t => (k -> v -> t u) -> Map k v -> t ()+traverseWithKey_ f = Map.foldrWithKey (\k a b -> f k a *> b) (pure ())++traverseSet_ :: Applicative t => (a -> t u) -> Set a -> t ()+traverseSet_ f = Set.foldr' ( \a b -> f a *> b ) (pure ())
+ src/Data/Finite/With.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}++{-|+Module: Data.Finite.With++Allows a function expecting a type-level natural to be passed a 'Data.Finite.Finite'.+-}+++module Data.Finite.With+  ( withFinite )+  where++-- base+import Data.Proxy+  ( Proxy )+import Data.Type.Equality+  ( (:~:)(Refl) )+import GHC.TypeNats+  ( Nat, KnownNat+  , SomeNat(..), someNatVal+  , CmpNat+  )+import Unsafe.Coerce+  ( unsafeCoerce )++-- finite-typelits+import Data.Finite+  ( Finite, getFinite )++----------------------------------------------------------------------++-- | Pass a 'Finite' to a function expecting a type-level natural (passed via a 'Proxy').+withFinite+  :: forall (n :: Nat) r+  .  ( forall i. ( KnownNat i, CmpNat i n ~ 'LT ) => Proxy i -> r )+  -> Finite n+  -> r+withFinite f j = case someNatVal ( fromIntegral $ getFinite j ) of+  ( SomeNat ( px :: Proxy j ) ) ->+    case unsafeCoerce Refl :: CmpNat j n :~: 'LT of+      Refl -> f px
+ src/Data/Function/Variadic.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: Data.Function.Variadic++Type families for variadic functions.+-}++module Data.Function.Variadic where++-- base+import Data.Int+  ( Int8,Int16,Int32,Int64 )+import Data.Kind+  ( Type )+import Data.Word+  ( Word8,Word16,Word32,Word64 )+import GHC.TypeNats+  ( Nat, type (-), type (<=?) )++-- half+import Numeric.Half+  ( Half )++-- fir+import {-# SOURCE #-} Data.Product+  ( HList )+import {-# SOURCE #-} FIR.AST+  ( AST )+import FIR.AST.Type+  ( AugType(Val, (:-->)) )+import FIR.Prim.Array+  ( Array,RuntimeArray )+import FIR.Prim.RayTracing+  ( AccelerationStructure, RayQuery )+import {-# SOURCE #-} FIR.Prim.Struct+  ( Struct )+import Math.Linear+  ( V,M )++------------------------------------------------------------++type NatVariadic+      ( n :: Nat  )+      ( a :: Type )+      ( b :: Type )+  = ( NatVariadic' n a b (1 <=? n) :: AugType )++type family NatVariadic'+              ( n    :: Nat  )+              ( a    :: Type )+              ( b    :: Type )+              ( geq1 :: Bool )+            = ( r    :: AugType )+            | r -> b+            where+  NatVariadic' n _ b 'False = Val b+  NatVariadic' n a b 'True  = Val a :--> NatVariadic (n-1) a b++------------------------------------------------------------++type family AugListVariadic (as :: [AugType]) (b :: Type) = ( r :: AugType ) | r -> as b where+  AugListVariadic '[]       b = Val b+  AugListVariadic (a ': as) b = a :--> AugListVariadic as b++-- explicitly list all primitive types, to allow injectivity annotation+type family ListVariadic (as :: [Type]) (b :: Type) = (r :: Type) | r -> as b where  +  ListVariadic (a ': as) b = a -> ListVariadic as b+  ListVariadic '[] ()     = ()+  ListVariadic '[] Bool   = Bool+  ListVariadic '[] Word   = Word +  ListVariadic '[] Word8  = Word8+  ListVariadic '[] Word16 = Word16+  ListVariadic '[] Word32 = Word32+  ListVariadic '[] Word64 = Word64+  ListVariadic '[] Int    = Int +  ListVariadic '[] Int8   = Int8+  ListVariadic '[] Int16  = Int16+  ListVariadic '[] Int32  = Int32+  ListVariadic '[] Int64  = Int64+  ListVariadic '[] Half   = Half+  ListVariadic '[] Float  = Float+  ListVariadic '[] Double = Double+  ListVariadic '[] (V n a) = V n a+  ListVariadic '[] (M m n a) = M m n a+  ListVariadic '[] (Struct as) = Struct as+  ListVariadic '[] (Array n a) = Array n a+  ListVariadic '[] (RuntimeArray a) = RuntimeArray a+  ListVariadic '[] (AST a) = AST a+  ListVariadic '[] (a1,a2) = (a1,a2)+  ListVariadic '[] (a1,a2,a3) = (a1,a2,a3)+  ListVariadic '[] (a1,a2,a3,a4) = (a1,a2,a3,a4)+  ListVariadic '[] (a1,a2,a3,a4,a5) = (a1,a2,a3,a4,a5)+  ListVariadic '[] (a1,a2,a3,a4,a5,a6) = (a1,a2,a3,a4,a5,a6)+  ListVariadic '[] (a1,a2,a3,a4,a5,a6,a7) = (a1,a2,a3,a4,a5,a6,a7)+  ListVariadic '[] (a1,a2,a3,a4,a5,a6,a7,a8) = (a1,a2,a3,a4,a5,a6,a7,a8)+  ListVariadic '[] (HList as) = HList as+  ListVariadic '[] AccelerationStructure = AccelerationStructure+  ListVariadic '[] RayQuery = RayQuery
+ src/Data/Product.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: Data.Product++This module uses heterogeneous lists to define unbiased products needed by the type-level optics of this library.+-}+++module Data.Product where++-- base+import Data.Kind+  ( Type )+import Data.Type.Equality+  ( (:~:)(Refl) )+import Unsafe.Coerce+  ( unsafeCoerce )++-- fir+import Data.Constraint.All+  ( All )+import Data.Type.List+  ( KnownLength+  , ZipCons+  , SameLength+  )+import {-# SOURCE #-} FIR.Prim.Types+  ( PrimTy )++----------------------------------------------------------------------++infixr 3 :>++data HList (as :: [Type]) where+  HNil :: HList '[]+  (:>) :: a -> HList as -> HList (a ': as)++instance Show (HList '[]) where+  show _ = "HNil"+instance ( Show a, Show (HList as) ) => Show (HList (a ': as)) where+  show (a :> as) = show a ++ " :> " ++ show as++class KnownLength as => IsProduct (p :: Type) (as :: [Type]) {---  | p -> as  ---}+  where+  fromHList :: HList as -> p+  toHList   :: p -> HList as++instance KnownLength as => IsProduct (HList as) as where+  fromHList = id+  toHList   = id++-- TODO: refactor this using 'Data.Constraint.All'+data AreProductsDict js iss as where+  NilProducts  :: AreProductsDict '[] '[] as+  ConsProducts+    :: ( IsProduct j is+       , All PrimTy is+       , AreProducts js iss as+       , SameLength is (Distribute iss as)+       )+     => AreProductsDict (j ': js) (is ': iss) as++class SameLength js iss +   => AreProducts (js :: [Type]) (iss :: [[Type]]) (as :: [Type])  {---  | js -> iss  ---}+   where+  productsDict :: AreProductsDict js iss as+instance AreProducts '[] '[] as where+  productsDict = NilProducts+instance (IsProduct j is, AreProducts js iss as, SameLength is (Distribute iss as), All PrimTy is)+      => AreProducts (j ': js) (is ': iss) as where+  productsDict = ConsProducts++type family MapHList (iss :: [[Type]]) = (as :: [Type]) | as -> iss where+  MapHList '[]         = '[]+  MapHList (is ': iss) = HList is ': MapHList iss++type family Distribute (iss :: [[Type]]) (as :: [Type]) = (jss :: [[Type]]) where+  Distribute '[]         '[]       = '[]+  Distribute '[]         (a ': as) = '[] ': Distribute '[] as+  Distribute (is ': iss) as        = ZipCons is (Distribute iss as)++distributeZipConsLemma1+  :: forall (a :: Type) (as :: [Type]) (ds :: [Type]) (dss :: [[Type]]) (es :: [Type]) (ess :: [[Type]])+  .  ( SameLength es ess+     , (ds ': dss) ~ Distribute (ZipCons es ess) (a ': as)+     )+  => ( ds :~: es, dss :~: Distribute ess as )+distributeZipConsLemma1 = ( unsafeCoerce Refl, unsafeCoerce Refl )++distributeZipConsLemma2+  :: forall (as :: [Type]) (is :: [Type]) (iss :: [[Type]])+  .  ( SameLength is (Distribute iss as) )+  => ( ZipCons is (Distribute iss as) :~: Distribute (is ': iss) as )+distributeZipConsLemma2 = unsafeCoerce Refl++instance IsProduct a '[a] where+  toHList x = x :> HNil+  fromHList (x :> HNil) = x++instance IsProduct (a1,a2) '[a1,a2] where+  toHList (x1,x2) = (x1 :> x2 :> HNil)+  fromHList (x1 :> x2 :> HNil) = (x1,x2)++instance IsProduct (a1,a2,a3) '[a1,a2,a3] where+  toHList (x1,x2,x3) = (x1 :> x2 :> x3 :> HNil)+  fromHList (x1 :> x2 :> x3 :> HNil) = (x1,x2,x3)++instance IsProduct (a1,a2,a3,a4) '[a1,a2,a3,a4] where+  toHList (x1,x2,x3,x4) = (x1 :> x2 :> x3 :> x4 :> HNil)+  fromHList (x1 :> x2 :> x3 :> x4 :> HNil) = (x1,x2,x3,x4)++instance IsProduct (a1,a2,a3,a4,a5) '[a1,a2,a3,a4,a5] where+  toHList (x1,x2,x3,x4,x5) = (x1 :> x2 :> x3 :> x4 :> x5 :> HNil)+  fromHList (x1 :> x2 :> x3 :> x4 :> x5 :> HNil) = (x1,x2,x3,x4,x5)++instance IsProduct (a1,a2,a3,a4,a5,a6) '[a1,a2,a3,a4,a5,a6] where+  toHList (x1,x2,x3,x4,x5,x6) = (x1 :> x2 :> x3 :> x4 :> x5 :> x6 :> HNil)+  fromHList (x1 :> x2 :> x3 :> x4 :> x5 :> x6 :> HNil) = (x1,x2,x3,x4,x5,x6)+ +instance IsProduct (a1,a2,a3,a4,a5,a6,a7) '[a1,a2,a3,a4,a5,a6,a7] where+  toHList (x1,x2,x3,x4,x5,x6,x7) = (x1 :> x2 :> x3 :> x4 :> x5 :> x6 :> x7 :> HNil)+  fromHList (x1 :> x2 :> x3 :> x4 :> x5 :> x6 :> x7 :> HNil) = (x1,x2,x3,x4,x5,x6,x7)+ +instance IsProduct (a1,a2,a3,a4,a5,a6,a7,a8) '[a1,a2,a3,a4,a5,a6,a7,a8] where+  toHList (x1,x2,x3,x4,x5,x6,x7,x8) = (x1 :> x2 :> x3 :> x4 :> x5 :> x6 :> x7 :> x8 :> HNil)+  fromHList (x1 :> x2 :> x3 :> x4 :> x5 :> x6 :> x7 :> x8 :> HNil) = (x1,x2,x3,x4,x5,x6,x7,x8)
+ src/Data/Product.hs-boot view
@@ -0,0 +1,28 @@+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE TypeOperators          #-}++module Data.Product where++-- base+import Data.Kind+  ( Type )++-- fir+import Data.Type.List+  ( KnownLength )++----------------------------------------------------------------------++infixr 3 :>++data HList (as :: [Type]) where+  HNil :: HList '[]+  (:>) :: a -> HList as -> HList (a ': as)++class KnownLength as => IsProduct (p :: Type) (as :: [Type]) {---  | p -> as  ---}+  where+  fromHList :: HList as -> p+  toHList   :: p -> HList as
+ src/Data/Type/Error.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: Data.Type.Error++Helper functions to manage custom type-errors: throwing them, combining them, etc.+-}++module Data.Type.Error where++-- base+import Data.Kind+  ( Constraint )+import GHC.TypeLits+  ( TypeError, ErrorMessage((:$$:)) )++----------------------------------------------------------------------++type family Try ( x :: Either ErrorMessage a ) :: a where+  Try (Left  err) = TypeError err+  Try (Right a  ) = a++type family IsRight ( x :: Either ErrorMessage a ) :: Constraint where+  IsRight (Left err) = TypeError err+  IsRight _          = ()++type family IfLeft ( x :: Either e a ) ( y :: Either e a ) :: Either e a where+  IfLeft (Left _) y = y+  IfLeft x        _ = x++type family And ( x :: Either ErrorMessage r ) ( y :: Either ErrorMessage r ) :: Either ErrorMessage r where+  And (Right _) y        = y+  And (Left  x) (Left y) = Left (x :$$: y)+  And (Left  x) _        = Left x++type family All ( xs :: [ Either ErrorMessage r ] ) :: Either ErrorMessage r where+  All '[]       = Right '()+  All (x ': xs) = x `And` (All xs)++data family Dummy1 :: k+data family Dummy2 :: k++type family Assert (x :: k) (y :: l) :: l where+  Assert Dummy1 _ = Dummy2+  Assert _      y = y
+ src/Data/Type/Known.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: Data.Type.Known++This module provides a simple type class for reification (turning type-level data into value-level data).++This allows programs to perform type-level computations (e.g. to perform validation at compile time),+and at the end turn this type-level data back into value-level data to be used e.g. by the code generator.++This is a one way process: these are not singletons. See "FIR.Prim.Types" for the singletons this library uses internally.++Note that some instances are tailored to this library: type-level literals 'Symbol' are turned into 'ShortText',+and type-level natural numbers 'Nat' are turned into 'Word32'.+-}+++module Data.Type.Known where++-- base+import Data.Kind+  ( Type )+import Data.Proxy+  ( Proxy(Proxy) )+import Data.Word+  ( Word32 )+import GHC.TypeLits+  ( Symbol, KnownSymbol, symbolVal )+import GHC.TypeNats+  ( Nat, KnownNat, natVal )++-- text-short+import Data.Text.Short+  ( ShortText )+import qualified Data.Text.Short as ShortText++-- fir+import Data.Type.Map+  ( (:->)((:->)) )++--------------------------------------------------++class Demotable k where+  type Demote k = (d :: Type) | d -> k++class Demotable k => Known (k :: Type) (a :: k) where+  known :: Demote k++-- make the kind parameter invisible+type KindOf (a :: k) = k+knownValue :: forall a. Known (KindOf a) a => Demote (KindOf a)+knownValue = known @(KindOf a) @a++instance Demotable Symbol where+  type Demote Symbol = ShortText+instance KnownSymbol k => Known Symbol k where+  known = ShortText.pack (symbolVal @k Proxy)++instance Demotable Nat where+  type Demote Nat = Word32+instance KnownNat n => Known Nat n where+  known = fromIntegral (natVal @n Proxy)++instance Demotable Bool where+  type Demote Bool = Bool++instance Known Bool 'False where+  known = False+instance Known Bool 'True where+  known = True++instance Demotable k => Demotable (Maybe k) where+  type Demote (Maybe k) = Maybe (Demote k)+instance Demotable k => Known (Maybe k) 'Nothing where+  known = Nothing+instance Known k a => Known (Maybe k) ('Just a) where+  known = Just ( known @k @a )++instance Demotable () where+  type Demote () = ()++instance Known () '() where+  known = ()++instance (Demotable k, Demotable l) => Demotable (k,l) where+  type Demote (k,l) = (Demote k, Demote l)+instance (Known k a, Known l b) => Known (k,l) '(a,b) where+  known = ( known @k @a, known @l @b )++instance (Demotable k, Demotable l, Demotable m) => Demotable (k,l,m) where+  type Demote (k,l,m) = (Demote k, Demote l, Demote m)+instance (Known k a, Known l b, Known m c) => Known (k,l,m) '(a,b,c) where+  known = ( known @k @a, known @l @b, known @m @c )++instance Demotable k => Demotable [k] where+  type Demote [k] = [Demote k]+instance Demotable k => Known [k] '[] where+  known = []+instance ( Known k a, Known [k] as ) => Known [k] (a ': as) where+  known = known @k @a : known @[k] @as++instance ( Demotable k, Demotable v ) => Demotable (k :-> v) where+  type Demote (k :-> v) = Demote k :-> Demote v+instance ( Known k a, Known v b ) => Known (k :-> v) (a ':-> b) where+  known = known @k @a :-> known @v @b
+ src/Data/Type/LazyEquality.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DataKinds     #-}+{-# LANGUAGE PolyKinds     #-}+{-# LANGUAGE TypeFamilies  #-}+{-# LANGUAGE TypeOperators #-}++{-|+Module: Data.Type.LazyEquality++This module defines an alternative version of 'Data.Type.Equality.==',+for which @a == a@ always reduces to 'True'.+-}++module Data.Type.LazyEquality+  ( LazyEq )+  where++-------------------------------------------------------++infix 4 `LazyEq`++-- Alternative version of 'Data.Type.Equality.=='.+-- Ensures that @a == a@ reduces to True for any argument @a@.+--+-- See "Data.Type.Equality.==", which explains the trade-off.+type family (a :: k) `LazyEq` (b :: k) :: Bool where+  a `LazyEq` a = 'True+  _ `LazyEq` _ = 'False
+ src/Data/Type/List.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: Data.Type.List++Operations on type-level lists, such as concatenation and length.+-}++module Data.Type.List+  ( type (:++:)+  , Elem, AtIndex+  , Head, Tail, MapTail+  , Init, Last+  , Join+  , MapSingleton+  , Zip, ExactZip, ZipCons+  , Replicate+  , Length+  , SLength(SZero, SSucc)+  , KnownLength(sLength), sLengthVal+  , SameLength(sSameLength)+  , SSameLength(SSameZero,SSameSucc)+  , Postpend+    -- re-exports+  , Snoc, Reverse+  ) where++-- base +import GHC.TypeLits+  ( TypeError, ErrorMessage(..) )+import GHC.TypeNats+  ( Nat, type (+), type (-) )++-- fir+import Data.Type.Snoc -- for re-export+  ( Snoc, Reverse )++------------------------------------------------+-- functionality to deal with type-level lists++infixr 6 :++:++type family (:++:) (as :: [k]) (bs :: [k]) :: [k] where+  '[]       :++: bs = bs+  (a ': as) :++: bs = a ': ( as :++: bs )++infix 4 `Elem`++type family Elem (x :: k) (as :: [k]) :: Bool where+  Elem _ '[]       = 'False+  Elem x (x ': _ ) = 'True+  Elem x (_ ': as) = Elem x as++type family AtIndex (i :: Nat) (as :: [k]) :: Maybe k where+  AtIndex _ '[]       = Nothing+  AtIndex 0 (k ': _ ) = Just k+  AtIndex i (_ ': ks) = AtIndex (i-1) ks++type family Head (x :: [k]) :: k where+  Head (x ': _) = x++type family Tail (x :: [k]) :: [k] where+  Tail (_ ': xs) = xs++type family Last (x :: [k]) :: k where+  Last '[x] = x+  Last (x ': xs) = Last xs++type family Init (x :: [k]) :: [k] where+  Init '[x] = '[]+  Init (x ': xs) = x ': Init xs++type family MapTail (x :: [[k]]) :: [[k]] where+  MapTail '[] = '[]+  MapTail (xs ': xss) = Tail xs ': MapTail xss++type family Join (xss :: [[k]]) :: [k] where+  Join '[]         = '[]+  Join (xs ': xss) = xs :++: Join xss++type family MapSingleton (as :: [k]) :: [[k]] where+  MapSingleton '[] = '[]+  MapSingleton (a ': as) = (a ': '[]) ': MapSingleton as++type family Zip (is :: [k]) (js :: [k]) :: [k] where+  Zip '[] js = js+  Zip is '[] = is+  Zip (i ': is) (j ': js) = (i,j) ': Zip is js++type family ExactZip (msg :: ErrorMessage) (as :: [k]) (bs :: [k]) :: [k] where+  ExactZip _  '[]        '[]       = '[]+  ExactZip msg (a ': as) (b ': bs) = (a,b) ': ExactZip msg as bs+  ExactZip msg _ _ = TypeError msg++type family ZipCons (as :: [k]) (bss :: [[k]]) = (r :: [[k]]) | r -> as bss where+  ZipCons '[] '[] = '[]+  ZipCons (a ': as) (bs ': bss) = (a ': bs) ': ZipCons as bss++type family Replicate (n :: Nat) (a :: k) :: [k] where+  Replicate 0 _ = '[]+  Replicate n a = a ': Replicate (n-1) a++type family Length (as :: [k]) :: Nat where+  Length '[]       = 0+  Length (_ ': as) = 1 + Length as++data SLength (is :: [k]) where+  SZero :: SLength '[]+  SSucc :: SLength is -> SLength (i ': is)++class KnownLength (is :: [k]) where+  sLength :: SLength is++instance KnownLength '[] where+  sLength = SZero++instance KnownLength is => KnownLength (i ': is) where+  sLength = SSucc ( sLength @_ @is )++sLengthVal :: SLength is -> Int+sLengthVal SZero     = 0+sLengthVal (SSucc i) = 1 + sLengthVal i++data SSameLength (is :: [k]) (js :: [l]) where+  SSameZero :: SSameLength '[] '[]+  SSameSucc :: SSameLength is js -> SSameLength (i ': is) (j ': js)++class SameLength (is :: [k]) (js :: [l]) where+  sSameLength :: SSameLength is js+instance SameLength '[] '[] where+  sSameLength = SSameZero+instance SameLength is js => SameLength (i ': is) (j ': js) where+  sSameLength = SSameSucc ( sSameLength @_ @_ @is @js )++infixl 4 `Postpend`+-- Non-injective type family for post-pending.+--+-- Prefer using 'Data.Type.Snoc.Snoc' to retain injectivity.+--+-- (Note that this sometimes gives GHC trouble with constraint solving...)+type family Postpend (as :: [k]) (b :: k) :: [k] where+  Postpend '[]       b = '[ b ]+  Postpend (a ': as) b = a ': Postpend as b
+ src/Data/Type/Map.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE DerivingStrategies     #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: Data.Type.Map++Simple type-level maps (association lists).+-}++module Data.Type.Map where++-- base+import Data.Type.Bool+  ( If )+import GHC.TypeLits+  ( TypeError, ErrorMessage(..) )++-- fir+import Data.Type.POrd+  ( POrd(Compare, (:<)) )++------------------------------------------------+-- barebones type-level map functionality++infixr 4 :->+data (:->) k v = k :-> v+  deriving stock ( Eq, Show )++-- this synonym should only be used when we are working+-- with lists that are known to be ordered+-- (assumes keys are an instance of POrd)+type Map k v = [k :-> v]++type family Key (a :: (k :-> v)) :: k where+  Key (k ':-> _) = k++type family Value (a :: (k :-> v)) :: v where+  Value (_ ':-> v) = v++type family Keys (i :: [k :-> v]) :: [k] where+  Keys '[] = '[]+  Keys (kv ': kvs) = Key kv ': Keys kvs++type family Values (i :: [k :-> v]) :: [v] where+  Values '[] = '[]+  Values (kv ': kvs) = Value kv ': Values kvs++-- looks through the whole list always, in case the list is not sorted+type family Lookup (s :: k) (i :: [k :-> v]) :: Maybe v where+  Lookup _ '[]               = 'Nothing+  Lookup k ((k ':-> a) ': _) = 'Just a+  Lookup k (_          ': b) = Lookup k b++type family LookupKey (s :: k) (i :: [k :-> v]) :: Maybe k where+  LookupKey _ '[]               = 'Nothing+  LookupKey k ((k ':-> _) ': _) = 'Just k+  LookupKey k (_          ': b) = LookupKey k b++-- | Insert a key/value pair in an already-sorted map.+--+-- Throws an error if the key is already present.+type family Insert (s :: k) (t :: v) (i :: Map k v) :: Map k v where+  Insert k v '[]              = '[ k ':-> v ]+  Insert k v ((k ':-> a) ': _) =+    TypeError+      (     Text "Duplicate key: "+       :$$: ShowType '[ (k ':-> v), (k ':-> a) ]+      )+  Insert k v ((l ':-> a) ': b) =+    If ( k :< l )+      ( (k ':-> v) ': (l ':-> a) ': b )+      ( (l ':-> a) ': Insert k v b )++-- | Insert a key/value pair in an already-sorted map.+--+-- If a value already exists with that key, it gets overwritten with the new value.+type family InsertOverwriting (s :: k) (t :: v) (i :: Map k v) :: Map k v where+  InsertOverwriting k v '[]               = '[ k ':-> v ]+  InsertOverwriting k v ((k ':-> a) ': b) = (k ':-> v) ': b+  InsertOverwriting k v ((l ':-> a) ': b) =+    If ( k :< l )+      ( (k ':-> v) ': (l ':-> a) ': b )+      ( (l ':-> a) ': InsertOverwriting k v b )++type family InsertWithAppend ( key :: k ) ( val :: v ) ( map :: Map k [v] ) :: Map k [v] where+  InsertWithAppend key val '[] = '[ key ':-> '[ val ] ]+  InsertWithAppend key val ( ( k ':-> vals ) ': kvs ) =+    InsertWithAppendWithComparison key val k vals kvs ( Compare key k )++type family InsertWithAppendWithComparison ( key :: k ) ( val :: v ) ( key' :: k ) ( vals :: [v] ) ( rest :: Map k [v] ) ( comp :: Ordering ) :: Map k [v] where+  InsertWithAppendWithComparison key val key' vals rest LT =+    ( ( key ':-> '[val] ) ': ( key' ':-> vals ) ': rest )+  InsertWithAppendWithComparison key val key' vals rest EQ =+    ( ( key ':-> ( val ': vals ) ) ': rest )+  InsertWithAppendWithComparison key val key' vals rest GT =+    ( ( key' ':-> vals ) ': InsertWithAppend key val rest )+++type family Union (i :: Map k v) (j :: Map k v) :: Map k v where+  Union i '[]                = i+  Union i ( (k ':-> a) ': b) = Union (Insert k a i) b++type family UnionWithAppend (i :: Map k [v]) (j :: Map k [v]) :: Map k [v] where+  UnionWithAppend i '[] = i+  UnionWithAppend '[] i = i+  UnionWithAppend ((k1 ':-> '[]) ': kvs1) i = UnionWithAppend kvs1 i+  UnionWithAppend ((k1 ':-> val ': vals1) ': kvs1) ( ( k2 ':-> vals2 ) ': kvs2 ) =+    UnionWithAppend  ((k1 ':-> vals1) ': kvs1) (InsertWithAppendWithComparison k1 val k2 vals2 kvs2 (Compare k1 k2))++type family Delete (s :: k) (is :: Map k v) :: Map k v where+  Delete _ '[]                 = '[]+  Delete k ( (k ':-> _) ': is) = is -- assumes there are no duplicates+  Delete k ( i          ': is) = i ': Delete k is++type family Remove (i :: Map k v) (j :: Map k v) :: Map k v where+  Remove '[]                j = j+  Remove ( (k ':-> _) ': i) j = Remove i (Delete k j)++type family InsertionSort (i :: [k :-> v]) :: Map k v where+  InsertionSort '[]              = '[]+  InsertionSort ((k ':-> v) : l) = Insert k v (InsertionSort l)++type family ZipValue (i :: [k]) (x :: v) :: Map k v where+  ZipValue '[]       _ = '[]+  ZipValue (a ': as) x = ( (a ':-> x) ': ZipValue as x )++type family LookupAndLookup (key1 :: k1) (key2 :: k2) (map :: Map k1 (Map k2 v)) :: Maybe v where+  LookupAndLookup key1 key2 map = LookupAndLookupFrom key2 (Lookup key1 map)++type family LookupAndLookupFrom (key2 :: k2) (lk :: Maybe (Map k2 v)) :: Maybe b where+  LookupAndLookupFrom _    Nothing    = Nothing+  LookupAndLookupFrom key2 (Just map) = Lookup key2 map++type family InsertWithInsert (key1 :: k1) (key2 :: k2) (val :: v) (map :: Map k1 (Map k2 v)) :: Map k1 (Map k2 v) where+  InsertWithInsert key1 key2 val '[] = '[ key1 ':-> '[ key2 ':-> val ] ]+  InsertWithInsert key1 key2 val ((key1 ':-> map) ': rest) = ( key1 ':-> Insert key2 val map ) ': rest+  InsertWithInsert key1 key2 val ((key ':-> map) ': rest) =+    If (key1 :< key)+      ((key1 ':-> '[ key2 ':-> val ]) ': (key ':-> map) ': rest)+      ((key ':-> map) ': InsertWithInsert key1 key2 val rest)
+ src/Data/Type/Maybe.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DataKinds    #-}+{-# LANGUAGE PolyKinds    #-}+{-# LANGUAGE TypeFamilies #-}++{-|+Module: Data.Type.Maybe++Type families for manipulating 'Maybe'.+-}++module Data.Type.Maybe+  ( FromMaybe, FromJust, IsJust, IsNothing+  , IfNothingThen, SequenceMaybe+  )+  where++-- base+import GHC.TypeLits+  ( TypeError, ErrorMessage )++------------------------------------------------++type family FromMaybe (x :: Maybe k) (y :: k) :: k where+  FromMaybe (Just x) _ = x+  FromMaybe Nothing y  = y++type family FromJust (x :: Maybe k) (y :: ErrorMessage) :: k where+  FromJust (Just x) _  = x+  FromJust Nothing err = TypeError err++type family IsJust (x :: Maybe k) :: Bool where+  IsJust (Just _) = True+  IsJust Nothing  = False++type family IsNothing (x :: Maybe k) :: Bool where+  IsNothing Nothing   = True+  IsNothing (Just _ ) = False++type family IfNothingThen (x :: Maybe k) (y :: Maybe k) :: Maybe k where+  IfNothingThen (Just x) _ = Just x+  IfNothingThen Nothing  y = y++type family SequenceMaybe (m :: Maybe [a]) :: [a] where+  SequenceMaybe Nothing   = '[]+  SequenceMaybe (Just as) = as
+ src/Data/Type/Nat.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: Data.Type.Maybe++This module defines some arithmetic operations on type-level natural numbers.+-}++module Data.Type.Nat where++-- base+import GHC.TypeNats+  ( Nat, Div, Log2+  , type (+), type (-), type (*), type (^)+  )++--------------------------------------------------------------------------++-- | Round @n@ up to the nearest multiple of @r@.+type RoundUp n r+  = ( ( n + r - 1 ) `Div` r ) * r++type family NextPositivePowerOf2 (n :: Nat) :: Nat where+  NextPositivePowerOf2 0 = 1+  NextPositivePowerOf2 n = NextPowerOf2 n++type family NextPowerOf2 (n :: Nat) :: Nat where+  NextPowerOf2 0 = 0+  NextPowerOf2 1 = 1+  NextPowerOf2 n = 2 ^ ( Log2 (n-1) + 1 ) -- Log2 x is actually Floor ( Log2 x )++type family Succ ( n :: Nat ) = ( m :: Nat ) | m -> n where+  Succ  0 =  1+  Succ  1 =  2+  Succ  2 =  3+  Succ  3 =  4+  Succ  4 =  5+  Succ  5 =  6+  Succ  6 =  7+  Succ  7 =  8+  Succ  8 =  9+  Succ  9 = 10+  Succ 10 = 11+  Succ 11 = 12+  Succ 12 = 13+  Succ 13 = 14+  Succ 14 = 15+  Succ 15 = 16+  Succ 16 = 17+  Succ 17 = 18+  Succ 18 = 19+  Succ 19 = 20+  Succ 20 = 21+  Succ 21 = 22+  Succ 22 = 23+  Succ 23 = 24+  Succ 24 = 25+  Succ 25 = 26+  Succ 26 = 27+  Succ 27 = 28+  Succ 28 = 29+  Succ 29 = 30+  Succ 30 = 31+  Succ 31 = 32+  Succ 32 = 33+  Succ 33 = 34+  Succ 34 = 35+  Succ 35 = 36+  Succ 36 = 37+  Succ 37 = 38+  Succ 38 = 39+  Succ 39 = 40+  Succ 40 = 41+  Succ 41 = 42+  Succ 42 = 43+  Succ 43 = 44+  Succ 44 = 45+  Succ 45 = 46+  Succ 46 = 47+  Succ 47 = 48+  Succ 48 = 49+  Succ 49 = 50+  Succ 50 = 51+  Succ 51 = 52+  Succ 52 = 53+  Succ 53 = 54+  Succ 54 = 55+  Succ 55 = 56+  Succ 56 = 57+  Succ 57 = 58+  Succ 58 = 59+  Succ 59 = 60+  Succ 60 = 61+  Succ 61 = 62+  Succ 62 = 63+  Succ 63 = 64+  Succ 64 = 65
+ src/Data/Type/POrd.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: Data.Type.POrd++Promotion of the 'Ord' type class.+-}++module Data.Type.POrd where++-- base+import Data.Type.Bool+  ( If, Not )+import GHC.TypeLits+  ( Symbol, CmpSymbol )+import GHC.TypeNats+  ( Nat, CmpNat, type (+), type (-) )++-- fir+import Data.Type.LazyEquality+  ( LazyEq )++-------------------------------------------------------------------------------++infix 4 :<+infix 4 :>+infix 4 :<=+infix 4 :>=+infix 4 `Compare`++class POrd a where+  type Compare (x :: a) (y :: a) :: Ordering+  type (x :: a) :<  (y :: a) :: Bool+  type x :< y = Compare x y `LazyEq` LT+  type (x :: a) :>  (y :: a) :: Bool+  type x :> y = Compare x y `LazyEq` GT+  type (x :: a) :<= (y :: a) :: Bool+  type x :<= y = Not (Compare x y `LazyEq` GT)+  type (x :: a) :>= (y :: a) :: Bool+  type x :>= y = Not (Compare x y `LazyEq` LT)+  type Max (x :: a) (y :: a) :: a+  type Max x y = If (x :< y) y x+  type Min (x :: a) (y :: a) :: a+  type Min x y = If (x :> y) y x++instance POrd Symbol where+  type Compare x y = CmpSymbol x y++instance POrd Nat where+  type Compare x y = CmpNat x y+  type Max     x y = MaxNat x y++-- | The maximum of two natural numbers.+--+-- The equations for @0@ hold off reduction until both arguments+-- have been evaluated, which avoids duplicating unevaluated arguments.+type family MaxNat (x :: Nat) (y :: Nat) :: Nat where+  MaxNat 0 y = y+  MaxNat x 0 = x+  MaxNat x y = If (x :< y) y x++instance ( POrd a, POrd b ) => POrd (a,b) where+  type Compare p1 p2 = Lexicographic2 p1 p2++type family Lexicographic2 (p1 :: (a,b)) (p2 :: (a,b)) :: Ordering where+  Lexicographic2 '(x ,y1) '(x ,y2) = Compare y1 y2+  Lexicographic2 '(x1,_)  '(x2,_)  = Compare x1 x2++instance ( POrd a, POrd b, POrd c ) => POrd (a,b,c) where+  type Compare t1 t2 = Lexicographic3 t1 t2++type family Lexicographic3 (t1 :: (a,b,c)) (t2 :: (a,b,c)) :: Ordering where+  Lexicographic3 '(x ,y ,z1) '(x ,y ,z2) = Compare z1 z2+  Lexicographic3 '(x ,y1,_ ) '(x ,y2,_ ) = Compare y1 y2+  Lexicographic3 '(x1,_ ,_ ) '(x2,_ ,_ ) = Compare x1 x2+++class POrd a => PEnum a where+  type Succ (x :: a) :: a+  type Pred (x :: a) :: a+  type ToEnum (i :: Nat) :: a+  type FromEnum (x :: a) :: Nat+  type EnumFromTo (x :: a) (y :: a) :: [a]+  type EnumFromTo x y+    = EnumFromToDefault x y (x :> y)+  type EnumFromOfCount (x :: a) (i :: Nat) :: [a]+  type EnumFromOfCount x i+    = EnumFromOfCountDefault x i++type family EnumFromToDefault (x :: a) (y :: a) (x_gt_y :: Bool) :: [a] where+  EnumFromToDefault _ _ 'True  = '[]+  EnumFromToDefault x y 'False = x ': EnumFromTo (Succ x) y++type family EnumFromOfCountDefault (x :: a) (i :: Nat) :: [a] where+  EnumFromOfCountDefault _ 0 = '[]+  EnumFromOfCountDefault x i = x ': EnumFromOfCountDefault (Succ x) (Pred i)++instance PEnum Nat where+  type Succ x     = x + 1+  type Pred x     = x - 1+  type ToEnum x   = x+  type FromEnum x = x
+ src/Data/Type/Snoc.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: Data.Type.Snoc++Type-level snoc lists, providing injective type families 'Snoc' and 'Reverse'.++(c) Artem Chirkin+-}++module Data.Type.Snoc where+++type Snoc (ns :: [k]) (n :: k) = GetSnoc (DoSnoc ns n)+type Reverse (xs :: [k]) = Reversed (DoReverse xs)++data Snocing k = SSingle k | Snocing [k]++type family DoSnoc (xs :: [k]) (z::k) = (ys :: Snocing k) | ys -> xs z where+    DoSnoc '[]       x               = 'SSingle x+    DoSnoc (x ': xs :: [k]) (y :: k) = ('Snocing (x ': GetSnoc (DoSnoc xs y) :: [k]) :: Snocing k)++type family GetSnoc (xs :: Snocing k) = (ys :: [k]) | ys -> xs where+    GetSnoc ('SSingle x)              = '[x]+    GetSnoc ('Snocing (y ': x ': xs)) = y ': x ': xs++data Reversing k = REmpty | Reversing [k]++type family Reversed (ts :: Reversing k) = (rs :: [k]) | rs -> ts where+    Reversed 'REmpty                = '[]+    Reversed ('Reversing (x ': xs)) = x ': xs++type family DoReverse (as :: [k]) = (rs :: Reversing k) | rs -> as where+    DoReverse '[]       = 'REmpty+    DoReverse (a ': as) = 'Reversing (Reversed (DoReverse as) `Snoc` a)
+ src/Data/Type/String.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++{-|+Module: Data.Type.String++Type-level manipulation of symbols and lists of symbols.++Includes operations to convert between type-level natural numbers+and type-level symbols.++Credit to Csongor Kiss for the underlying techniques+(see https://kcsongor.github.io/symbol-parsing-haskell/).+-}++module Data.Type.String+  (+  -- * Type-level ToList+    CompareWith+  , LookupTree(..)+  , LookupChars, LookupPrefixedChars+  -- * Converting between 'Symbol' and 'Nat'+  -- ** Reading symbols as natural numbers+  , ReadNat, ReadPrefixedNat+  -- ** Showing natural numbers as symbols+  , ShowNat+  ) where++-- base+import GHC.TypeLits+  ( Symbol, CmpSymbol, AppendSymbol+  , TypeError, ErrorMessage(..)+  )+import GHC.TypeNats+  ( Nat+  , type (+), type (*)+  , Div, Mod+  )++-------------------------------------------------------------------------------------------+-- Type-level ToList++-- | Compare a prefixed symbol with a specified symbol.+--+-- Note that the comparison is done relative to the last argument. For instance:+--+--   * @ CompareWith "prefix" "1" "prefix7" = GT @+--   * @ CompareWith "prefix" "7" "prefix7" = EQ @+--   * @ CompareWith "prefix" "9" "prefix7" = LT @+type family CompareWith (prefix :: Symbol) (i :: Symbol) (k :: Symbol) :: Ordering where+  CompareWith prefix i k = k `CmpSymbol` (prefix `AppendSymbol` i)++-- | Character lookup tree.+--+-- Used at the type level as a data kind.+data LookupTree a+  = EnsureGTE a (LookupTree a)+  | EnsureLT  a (LookupTree a)+  | Node a a (LookupTree a) (LookupTree a)+  | Leaf a+  | Return+++-- | Obtain the leading list of characters that succeed lookup.+--+-- For instance, using the numeric digit tree 'DigitTree', one has:+--+-- @ LookupChars DigitTree "127foo89" = '[ "1", "2", "7" ] @+type family LookupChars (tree :: LookupTree Symbol) (k :: Symbol) :: [Symbol] where+  LookupChars tree k = LookupPrefixedChars tree "" k++-- | Same as 'LookupChars', but allows a prefix.+--+-- @ LookupPrefixedChars DigitTree "foo" "foo34bar7" = '[ "3", "4" ] @+type family LookupPrefixedChars+              ( tree   :: LookupTree Symbol )+              ( prefix :: Symbol            )+              ( k      :: Symbol            )+           :: [Symbol]+           where+  LookupPrefixedChars tree prefix k+    = LookupPrefixedCharsFrom tree tree prefix k++-- Recursively traverse the lookup tree.+type family LookupPrefixedCharsFrom+              ( tree   :: LookupTree Symbol )+              ( curr   :: LookupTree Symbol )+              ( prefix :: Symbol            )+              ( k      :: Symbol            )+           :: [Symbol]+           where+  LookupPrefixedCharsFrom tree (EnsureGTE min subtree) prefix k+    = LookupEnsureGTE (CompareWith prefix min k) tree subtree prefix k+  LookupPrefixedCharsFrom tree (EnsureLT max subtree) prefix k+    = LookupEnsureLT (CompareWith prefix max k) tree subtree prefix k+  LookupPrefixedCharsFrom tree (Node min max left right) prefix k+    = NodeLookup tree left right prefix k min max (CompareWith prefix min k) (CompareWith prefix max k)+  LookupPrefixedCharsFrom tree (Leaf l) prefix k+    = l ': LookupPrefixedChars tree (prefix `AppendSymbol` l) k+  LookupPrefixedCharsFrom tree Return _ k+    = '[ k ]++type family LookupEnsureGTE+              ( cmp     :: Ordering          )+              ( tree    :: LookupTree Symbol )+              ( subtree :: LookupTree Symbol )+              ( prefix  :: Symbol            )+              ( k       :: Symbol            )+            :: [Symbol] where+  LookupEnsureGTE 'LT _    _       _      _ = '[]+  LookupEnsureGTE _   tree subtree prefix k = LookupPrefixedCharsFrom tree subtree prefix k+++type family LookupEnsureLT+              ( cmp     :: Ordering          )+              ( tree    :: LookupTree Symbol )+              ( subtree :: LookupTree Symbol )+              ( prefix  :: Symbol            )+              ( k       :: Symbol            )+            :: [Symbol] where+  LookupEnsureLT 'LT tree subtree prefix k = LookupPrefixedCharsFrom tree subtree prefix k+  LookupEnsureLT _   _    _       _      _ = '[]++type family NodeLookup+              ( tree   :: LookupTree Symbol )+              ( left   :: LookupTree Symbol )+              ( right  :: LookupTree Symbol )+              ( prefix :: Symbol            )+              ( k      :: Symbol            )+              ( min    :: Symbol            )+              ( max    :: Symbol            )+              ( cmpMin :: Ordering          )+              ( cmpMax :: Ordering          )+           :: [Symbol]+           where+  NodeLookup tree left _     prefix k _   _   'LT  _  = LookupPrefixedCharsFrom tree left  prefix k+  NodeLookup tree _    right prefix k _   _   _   'GT = LookupPrefixedCharsFrom tree right prefix k+  NodeLookup tree _    _     prefix k _   max _   'EQ = max ': LookupPrefixedChars tree (prefix `AppendSymbol` max) k+  NodeLookup tree _    _     prefix k min _   _    _  = min ': LookupPrefixedChars tree (prefix `AppendSymbol` min) k+++-------------------------------------------------------------------------------------------+-- Converting between 'Symbol' and 'Nat'++-- Reading symbols as natural numbers++-- | Lookup tree for numeric digits.+type DigitTree+  = EnsureGTE "0"+    ( EnsureLT ":"+      ( Node "5" "6"+        ( Node "3" "4"+          ( Node "1" "2"+              ( Leaf "0" )+              ( Leaf "2" )+          )+          ( Leaf "4" )+        )+        ( Node "7" "8"+          ( Leaf "6" )+          ( Node "9" ":"+            ( Leaf "8" )+            Return -- inaccessible+          )+        )+      )+    )++-- | Reads a natural number from the leading digits of a literal.+--+--   * @ ReadNat "0123"  = 123 @+--   * @ ReadNat "34abc" = 34  @+--   * @ ReadNat "foo"   = 0   @+type family ReadNat (k :: Symbol) :: Nat where+  ReadNat k = ReadPrefixedNat "" k++-- | Same as 'ReadNat' but allows a prefix.+--+--   * @ ReadPrefixedNat "foo1" "foo1099" = 99 @.+type family ReadPrefixedNat (prefix :: Symbol) (k :: Symbol) :: Nat where+  ReadPrefixedNat prefix k+    = FromDecimalDigitsAcc+        0+        ( LookupPrefixedChars DigitTree prefix k )++-- | Read an individual digit.+type family ReadDigit (d :: Symbol) :: Nat where+  ReadDigit "0" = 0+  ReadDigit "1" = 1+  ReadDigit "2" = 2+  ReadDigit "3" = 3+  ReadDigit "4" = 4+  ReadDigit "5" = 5+  ReadDigit "6" = 6+  ReadDigit "7" = 7+  ReadDigit "8" = 8+  ReadDigit "9" = 9+  ReadDigit x+    = TypeError+        ( Text "Cannot read digit: " :<>: ShowType x :<>: Text " is not a digit." )++-- Returns a natural number from a base-10 representation.+type family FromDecimalDigitsAcc (acc :: Nat) (ds :: [Symbol]) :: Nat where+  FromDecimalDigitsAcc acc '[] = acc+  FromDecimalDigitsAcc acc (d ': ds)+    = FromDecimalDigitsAcc ( 10 * acc + ReadDigit d ) ds++-- | Turn a type-level natural number into a type-level symbol.+type family ShowNat (n :: Nat) :: Symbol where+  ShowNat 0 = "0"+  ShowNat 1 = "1"+  ShowNat 2 = "2"+  ShowNat 3 = "3"+  ShowNat 4 = "4"+  ShowNat 5 = "5"+  ShowNat 6 = "6"+  ShowNat 7 = "7"+  ShowNat 8 = "8"+  ShowNat 9 = "9"+  ShowNat n = ShowNat (n `Div` 10) `AppendSymbol` ShowNat (n `Mod` 10)
+ src/Deriving/Base.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE DerivingVia        #-}+{-# LANGUAGE StandaloneDeriving #-}++{-|+Module: Deriving.Base++This module defines the newtype 'Base', used with `deriving via` to name instances coming from the Haskell prelude.++For instance (pun intended):++> deriving via Base Float  instance Floating Float+> deriving via Base Double instance Floating Double++See "Math.Algebra.Class" for illustration.++-}++module Deriving.Base+  ( Base(Base, runBase) )+  where++import qualified Prelude++newtype Base a = Base { runBase :: a }++deriving via a instance Prelude.Eq a  => Prelude.Eq  (Base a)+deriving via a instance Prelude.Ord a => Prelude.Ord (Base a)++deriving via a instance Prelude.Show a => Prelude.Show (Base a)+deriving via a instance Prelude.Read a => Prelude.Read (Base a)++deriving via a instance Prelude.Enum a    => Prelude.Enum    (Base a)+deriving via a instance Prelude.Bounded a => Prelude.Bounded (Base a)
+ src/FIR.hs view
@@ -0,0 +1,489 @@+{-# OPTIONS_HADDOCK ignore-exports #-}++{-# LANGUAGE AllowAmbiguousTypes  #-}+{-# LANGUAGE BlockArguments       #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE DeriveLift           #-}+{-# LANGUAGE DerivingVia          #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE LambdaCase           #-}+{-# LANGUAGE NamedFieldPuns       #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE PatternSynonyms      #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: FIR+Description: @---@ __Main module, re-exports what's needed to write programs and compile to SPIR-V.__++This module re-exports the main functionality needed to use the library.++For an overview of the library, refer to the project [__readme__](https://gitlab.com/sheaf/fir/tree/master/readme.md).++To illustrate the syntax of this library, the example of a trivial fragment shader follows.++@+\{\-\# LANGUAGE BlockArguments   \#\-\} -- cleaner syntax for 'do' blocks (optional)+\{\-\# LANGUAGE DataKinds        \#\-\} -- for datatype promotion and type-level literals+\{\-\# LANGUAGE RebindableSyntax \#\-\} -- 'do' notation to create ASTs with indexed monads+\{\-\# LANGUAGE TypeApplications \#\-\} -- to specify type-level arguments+\{\-\# LANGUAGE TypeOperators    \#\-\} -- for type operators such as ':->, which stands for key/value assignment++import FIR+import Math.Linear -- for vectors++-- Specify the input/output of the shader, with memory locations (and other interface parameters).+-- This consists of a type-level list of top-level definitions.+type FragmentDefs+  =  '[ "in_pos"  ':-> Input      '[ Location 0                 ] (V 2 Float)   -- input  (varying) of type V 2 Float and memory location 0+      , "out_col" ':-> Output     '[ Location 0                 ] (V 4 Float)   -- output (varying) of type V 4 Float and memory location 0+      , "image"   ':-> Texture2D  '[ DescriptorSet 0, Binding 0 ] (RGBA8 UNorm) -- input sampled image (provided as binding 0 of descriptor set 0)+      , "main"    ':-> EntryPoint '[ OriginUpperLeft            ] Fragment      -- fragment shader stage (with the origin in the upper left corner)+      ]++fragment :: Module FragmentDefs ()+fragment =+  Module $ entryPoint \@"main" \@Fragment do+    pos <- get \@"in_pos"+    col <- use \@(ImageTexel "image") NilOps pos+    put \@"out_col" col+@++Note the lens-like operations:++  - @'FIR.Syntax.Program.get' \@"in_pos"@ – equivalent to+    @'FIR.Syntax.Program.use' \@(Name "in_pos")@ – obtains the shader input varying "in_pos".+    This operation is similar to @get@ in a state monad, except that an additional binding name+    is provided via a type application.+  - @'FIR.Syntax.Program.use' \@(ImageTexel "image") NilOps pos@ samples the provided image+    at coordinates @pos@. Additional image operands can be provided for this sampling operation,+    such as an explicit level of detail or whether to use projective coordinates+    (refer to the SPIR-V specification for further information concerning image operands).+  - @'FIR.Syntax.Program.put' \@"out_col" col@ – equivalent to+    @'FIR.Syntax.Program.assign' \@(Name "out_col") col@ –+    sets the output value of the shader.+++This fragment shader can then be compiled using:++> compileTo filePath flags fragment++where @filePath@ is the desired output filepath, and @flags@ is a list of 'CompilerFlag's.+++More meaningful examples can be found in the (@fir-examples@ subdirectory)(https://gitlab.com/sheaf/fir/tree/master/fir-examples)+of the project's repository.++-}++module FIR+  ( DrawableProgramAST(showAST, drawAST)+  , CompilableProgram(compile, compileTo)+  , CompilerFlag(..)+  , ModuleBinary(..), ModuleRequirements(..)+  , runCompilationsTH++  -- re-exports+  , module Control.Monad.Indexed+  , Control.Type.Optic.Optic+  , Control.Type.Optic.ShowOptic+  , (Control.Type.Optic.:*:), Control.Type.Optic.Prod, Control.Type.Optic.EndProd+  , (Control.Type.Optic.:.:)+  , Control.Type.Optic.OfType+  , Control.Type.Optic.AnIndex+  , Control.Type.Optic.Index+  , Control.Type.Optic.Name+  , Control.Type.Optic.ReifiedGetter(view)+  , Control.Type.Optic.ReifiedSetter(set)+  , Control.Type.Optic.ReifiedLens(over)+  , module Data.Product+  , module Data.Type.List+  , (Data.Type.Map.:->)((:->))+  , module Data.Type.POrd+  , AST, FIR.AST.Code, EGADT+  , module FIR.AST.Type+  , pattern (:$), pattern Lit, pattern Struct, pattern Array+  -- image operands+  , pattern NilOps, pattern Proj, pattern Dref, pattern Bias+  , pattern LOD, pattern MinLOD, pattern Grad+  , pattern ConstOffsetBy, pattern OffsetBy+  , pattern Gather, pattern SampleNo+  -- internal hlist+  , pattern NilHList, pattern ConsHList+  , FIR.AST.Syntactic(..)+  , FIR.AST.SyntacticVal, FIR.AST.InternalType+  , FIR.AST.HasUndefined(undefined)+  , FIR.Binding.BindingsMap+  , FIR.Binding.Var, FIR.Binding.Fun+  , FIR.Binding.R+  , FIR.Binding.W+  , FIR.Binding.RW+  , FIR.Definition.Definition+      ( Function+      , EntryPoint+      )+  , FIR.Layout.Layout(..)+  , FIR.Layout.Poke(..)+  , FIR.Layout.pokeArray+  , FIR.Layout.pokeArrayOff+  , FIR.Layout.MemberOffset+  , FIR.Layout.memberOffset+  , FIR.Layout.roundUp+  , FIR.Layout.nextAligned+  , module FIR.Module+  , module FIR.Pipeline+  , module FIR.Prim.Array+  , FIR.Prim.Image.ImageProperties(..)+  , FIR.Prim.Image.Image+  , FIR.Prim.Image.GatherInfo(..)+  , module FIR.Prim.RayTracing+  , module FIR.Prim.Struct+  , FIR.Prim.Types.PrimTy+  , FIR.Prim.Types.ScalarTy+  , FIR.Prim.Types.IntegralTy+  , FIR.Prim.Atomic.AtomicTy, FIR.Prim.Atomic.AtomicIntegralTy+  , FIR.Prim.Types.PrimTyMap+  , FIR.Prim.Types.HasOpaqueType+  , FIR.ProgramState.ProgramState(ProgramState)+  , FIR.ProgramState.FunctionContext(TopLevel)+  , module FIR.Syntax.AST+  , module FIR.Syntax.Complex+  , module FIR.Syntax.IfThenElse+  , module FIR.Syntax.Images+  , module FIR.Syntax.Optics+  , module FIR.Syntax.Option+  , module FIR.Syntax.Program+  , module FIR.Syntax.RayTracing+  , module FIR.Syntax.Swizzle+  , module FIR.Syntax.Synonyms+  , module FIR.Validation.Bindings+  , module FIR.Validation.CFG+  , module FIR.Validation.Images+  , module FIR.Validation.RayTracing+  , module Math.Algebra.Class+  , module Math.Algebra.GradedSemigroup+  , module Math.Logic.Bits+  , module Math.Logic.Class+  , module SPIRV.Capability+  , SPIRV.Control.Inlineability(..)+  , SPIRV.Control.SideEffects(..)+  , SPIRV.Control.FunctionControl+  , SPIRV.Control.SelectionControl(..)+  , SPIRV.Decoration.Decoration(..)+  , SPIRV.ExecutionMode.ExecutionMode(..)+  , SPIRV.ExecutionMode.InputVertices -- synonym of 'OutputVertices' for tessellation evaluation shaders+  , module SPIRV.Extension+  , SPIRV.Groups.GroupOperation(..)+  , SPIRV.Stage.Vertex+  , SPIRV.Stage.TessellationControl+  , SPIRV.Stage.TessellationEvaluation+  , SPIRV.Stage.Geometry+  , SPIRV.Stage.Fragment+  , SPIRV.Stage.Compute+  , SPIRV.Stage.Stage(..)+  , SPIRV.Stage.Shader(..)+  , SPIRV.Stage.RayShader(..)+  , SPIRV.Stage.MeshShader(..)+  , SPIRV.Stage.ExecutionModel(..)+  , SPIRV.Stage.RayGeneration+  , SPIRV.Stage.Intersection+  , SPIRV.Stage.AnyHit+  , SPIRV.Stage.ClosestHit+  , SPIRV.Stage.Miss+  , SPIRV.Stage.Callable+  , SPIRV.Storage.DataOrigin(..)+  , module SPIRV.Synchronisation+  , SPIRV.Version.Version(..)+  -- image properties+  , SPIRV.Image.Dimensionality(..)+  , SPIRV.Image.HasDepth(..)+  , SPIRV.Image.Arrayness(..)+  , SPIRV.Image.MultiSampling(..)+  , SPIRV.Image.ImageUsage(..)+  , SPIRV.Image.ImageFormat(ImageFormat)+  , SNorm, UNorm, F, I, UI+  , pattern SNorm, pattern UNorm+  , pattern F, pattern I, pattern UI+  , RGBA32, RGBA16, RGBA8+  , RG32, RG16, RG8+  , R32, R16, R8+  , R11G11B10+  , RGB10A2+  , pattern RGBA32, pattern RGBA16, pattern RGBA8+  , pattern RG32, pattern RG16, pattern RG8+  , pattern R32, pattern R16, pattern R8+  , pattern R11G11B10+  , pattern RGB10A2++  -- known+  , Data.Type.Known.Known(..)+  , Data.Type.Known.knownValue++  -- Re-export of prelude and related functions+  , module FIR.Prelude+  ) where++-- base+import Data.Functor+  ( ($>) )+import GHC.Generics+  ( Generic )++-- template-haskell+import qualified Language.Haskell.TH        as TH+import qualified Language.Haskell.TH.Syntax as TH++-- atomic-file-ops+import System.IO.AtomicFileOps+  ( atomicReplaceFile )++-- bytestring+import qualified Data.ByteString.Lazy as ByteString+  ( writeFile )+import Data.ByteString.Lazy+  ( ByteString )++-- containers+import Data.Set+  ( Set )++-- directory+import System.Directory+  ( doesFileExist )++-- generic-monoid+import Data.Monoid.Generic+  ( GenericSemigroup(..), GenericMonoid(..) )++-- tree-view+import Data.Tree.View+  ( showTree )++-- text-short+import Data.Text.Short+  ( ShortText )++-- variant+import Data.Variant.EGADT+  ( EGADT )++-- fir+import CodeGen.CodeGen+import CodeGen.State+import Control.Arrow.Strength+import Control.Monad.Indexed+import Control.Type.Optic+import Data.Product+import Data.Type.Known+import Data.Type.List+import Data.Type.Map+import Data.Type.POrd+import FIR.AST+import FIR.AST.Type+import FIR.Binding+import FIR.Definition+import FIR.Layout+import FIR.Module+import FIR.Pipeline+import FIR.Prelude+import FIR.Prim.Array+import FIR.Prim.Image+import FIR.Prim.RayTracing+  hiding ( pattern RayQuery )+import FIR.Prim.Atomic+import FIR.Prim.Types+import FIR.Prim.Struct+import FIR.ProgramState+import FIR.Syntax.AST+import FIR.Syntax.Complex+import FIR.Syntax.IfThenElse+import FIR.Syntax.Images+import FIR.Syntax.Optics+import FIR.Syntax.Option+import FIR.Syntax.Program+import FIR.Syntax.RayTracing+import FIR.Syntax.Swizzle+import FIR.Syntax.Synonyms+import FIR.Validation.Bindings+  ( Has, CanGet, CanPut+  , ValidFunDef, ValidEntryPoint+  , Embeddable+  )+import FIR.Validation.CFG+  ( InLoop )+import FIR.Validation.Images+  ( ValidImageRead, ValidImageWrite )+import FIR.Validation.RayTracing+  ( CanTraceRay, CanExecuteCallable )+import Instances.TH.Lift+  ( ) -- Lift instances for ByteString, ShortText, Set+import Math.Algebra.Class+import Math.Algebra.GradedSemigroup+import Math.Logic.Bits+import Math.Logic.Class+import SPIRV.Capability+import qualified SPIRV.Capability as SPIRV+import SPIRV.Control+import SPIRV.Decoration+import SPIRV.ExecutionMode+import SPIRV.Extension+import qualified SPIRV.Extension  as SPIRV+import SPIRV.Image hiding ( LODOperand(..), Operand(..) )+import SPIRV.Groups+import SPIRV.Stage+import SPIRV.Storage+import SPIRV.Version+import qualified SPIRV.Version    as SPIRV+import SPIRV.Synchronisation++------------------------------------------------++-- | Functionality for drawing a program AST as a tree.+--+-- Can be used on whole programs, or on snippets of code in the AST indexed monad.+class DrawableProgramAST prog where+  showAST :: prog -> String+  drawAST :: prog -> IO ()+  drawAST = putStrLn . showAST++instance DrawableProgramAST (AST a) where+  showAST = showTree . toTree+instance SyntacticVal a => DrawableProgramAST (Program i j a) where+  showAST = showTree . toTree . toAST+instance DrawableProgramAST (Module def) where+  showAST (Module prog) = showAST prog+instance DrawableProgramAST (ShaderModule name stage defs endState) where+  showAST (ShaderModule prog) = showAST prog++-- | Compiler flags.+data CompilerFlag+  = NoCode -- ^ Don't emit any SPIR-V code.+  | Debug  -- ^ Include additional debug instructions, such as source-code line-number annotations and @debugPrintf@ output.+  | Assert -- ^ Include additional assertions.+  | SPIRV SPIRV.Version -- ^ SPIR-V version number (default: 1.5 for Vulkan, 1.2 for OpenCL).+  deriving stock ( Prelude.Eq, Show )++updateContextFromFlags :: CGContext -> [ CompilerFlag ] -> CGContext+updateContextFromFlags = foldl updateContext+  where+    updateContext :: CGContext -> CompilerFlag -> CGContext+    updateContext ctxt NoCode      = ctxt { emittingCode = False }+    updateContext ctxt Debug       = ctxt { debugging    = True  }+    updateContext ctxt Assert      = ctxt { asserting    = True  }+    updateContext ctxt (SPIRV ver) = ctxt { spirvVersion = ver   }++-- | Information about requirements for a given SPIR-V module,+-- such as which SPIR-V capabilities and extensions are needed.+--+-- This information can be useful to compute Vulkan requirements.+data ModuleRequirements+  = ModuleRequirements+  { requiredCapabilities :: Set SPIRV.Capability+  , requiredExtensions   :: Set SPIRV.Extension+  }+  deriving stock ( Prelude.Eq, Show, Generic, TH.Lift )+  deriving Semigroup via GenericSemigroup ModuleRequirements+  deriving Monoid    via GenericMonoid    ModuleRequirements++-- | Newtype wrapper for the binary source of a SPIR-V module.+--+-- This newtype emphasises the fact that module binaries are monolithic,+-- e.g. one can't combine binaries using '(<>)'.+newtype ModuleBinary = ModuleBinary { moduleBinary :: ByteString }++-- | Functionality for compiling a program into a SPIR-V module.+class CompilableProgram prog where+  compile :: [CompilerFlag] -> prog -> IO ( Either ShortText ( Maybe ModuleBinary, ModuleRequirements ) )+  compileTo :: FilePath -> [CompilerFlag] -> prog -> IO ( Either ShortText ModuleRequirements )+  compileTo filePath flags prog =+    compile flags prog Prelude.>>= \case+      Left err+        -> Prelude.pure (Left err)+      Right (mbBin, reqs)+        | Just (ModuleBinary bytes) <- mbBin+        -> writeBytesAtomically bytes $> Right reqs+        | otherwise+        -> Prelude.pure ( Right reqs )+    where+      writeBytesAtomically :: ByteString -> IO ()+      writeBytesAtomically bytes = +       doesFileExist filePath Prelude.>>= \case+         False -> ByteString.writeFile      filePath bytes+         True  -> atomicReplaceFile Nothing filePath bytes++instance ( KnownDefinitions defs ) => CompilableProgram (Module defs) where+  compile flags (Module program)+    = case runCodeGen cgContext (toAST program) of+        Left  err -> Prelude.pure ( Left err )+        Right ( bytes, cgState )+          ->  let+                reqs :: ModuleRequirements+                reqs = ModuleRequirements+                  { requiredCapabilities = neededCapabilities ( moduleState cgState )+                  , requiredExtensions   = neededExtensions   ( moduleState cgState )+                  }+                mbBin :: Maybe ModuleBinary+                mbBin+                  | emittingCode cgContext+                  = Just (ModuleBinary bytes)+                  | otherwise+                  = Nothing+              in Prelude.pure ( Right (mbBin, reqs) )+      where cgContext :: CGContext+            cgContext =+              updateContextFromFlags+                ( initialCGContext @defs )+                flags++instance ( KnownDefinitions defs )+      => CompilableProgram (ShaderModule name stage defs endState)+      where+  compile flags (ShaderModule prog)+    = compile flags (Module @defs prog)++-- | Utility function to run IO actions at compile-time using Template Haskell.+-- Useful for compiling shaders at compile-time, before launching a graphics application.+--+-- __Usage example__: in a module which imports this module and shaders+-- @vertexShader@, @fragmentShader@ (bearing in mind the TH staging restriction), write:+--+-- > shaderCompilationResult :: Either ShortText ModuleRequirements+-- > shaderCompilationResult =+-- >   $( runCompilationsTH+-- >        [ ("Vertex shader"  , compileTo vertPath [] vertexShader  )+-- >        , ("Fragment shader", compileTo fragPath [] fragmentShader)+-- >        ]+-- >   )+--+-- At compile-time, this will compile the vertexShader @vertexShader@ at filepath @vertPath@,+-- and similarly for the fragment shader.+-- These can then be loaded into Vulkan shader modules for use in rendering.+runCompilationsTH+  :: forall f. Traversable f+  => f ( ShortText, IO (Either ShortText ModuleRequirements) )+  -> TH.Q TH.Exp+runCompilationsTH namedCompilations+  = TH.lift Prelude.=<< TH.runIO (combineCompilations namedCompilations)+    where+      combineCompilations+        :: f ( ShortText, IO (Either ShortText ModuleRequirements) )+        -> IO (Either ShortText ModuleRequirements)+      combineCompilations+        = fmap ( foldl' ( \ b (n,a) -> combineResult n b a ) (Right mempty) )+        . traverse ( uncurry rightStrength )++      combineResult+        :: ShortText+        -> Either ShortText ModuleRequirements+        -> Either ShortText ModuleRequirements+        -> Either ShortText ModuleRequirements+      combineResult _    (Right rs  ) (Right ss) = Right (rs <> ss)+      combineResult _    (Left  errs) (Right _ ) = Left  errs+      combineResult name (Right _   ) (Left err) = Left  (name <> ": " <> err)+      combineResult name (Left errs ) (Left err) = Left  (errs <> "\n" <> name <> ": " <> err)
+ src/FIR/AST.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE AllowAmbiguousTypes      #-}+{-# LANGUAGE DataKinds                #-}+{-# LANGUAGE DeriveAnyClass           #-}+{-# LANGUAGE DeriveGeneric            #-}+{-# LANGUAGE DerivingVia              #-}+{-# LANGUAGE FlexibleContexts         #-}+{-# LANGUAGE FlexibleInstances        #-}+{-# LANGUAGE GADTs                    #-}+{-# LANGUAGE InstanceSigs             #-}+{-# LANGUAGE MultiParamTypeClasses    #-}+{-# LANGUAGE PatternSynonyms          #-}+{-# LANGUAGE PolyKinds                #-}+{-# LANGUAGE ScopedTypeVariables      #-}+{-# LANGUAGE StandaloneDeriving       #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications         #-}+{-# LANGUAGE TypeFamilies             #-}+{-# LANGUAGE TypeOperators            #-}+{-# LANGUAGE UndecidableInstances     #-}++{-# OPTIONS_GHC -O0 #-}++{-|+Module: FIR.AST++Representation of programs using abstract syntax trees.++The user interface to the AST is through type class overloading,+see "FIR.Syntax.AST" and "FIR.Syntax.Program".++This is an extensible AST represented by an open sum type (variant type),+with a higher-order abstract syntax representation (HOAS),+as seen in the paper /Combining Deep and Shallow Embeddings of Domain-Specific Languages/+by Josef Svenningsson and Emil Axelsson.+-}++module FIR.AST+  ( -- * Main AST data type+    AST, Code+    -- * Syntactic type class+  , Syntactic(Internal, toAST, fromAST)+  , SyntacticVal, InternalType+    -- * Primitive operations+  , primOp+  , HasUndefined(undefined)+    -- * Displaying ASTs graphically+  , toTree++    -- * Re-exports+  , module FIR.AST.ControlFlow+  , module FIR.AST.Effs+  , module FIR.AST.Exts+  , module FIR.AST.Images+  , module FIR.AST.Optics+  , module FIR.AST.Prim++  )+  where++-- base+import Prelude+  hiding ( undefined )+import qualified Prelude+import Data.Typeable+import Data.Kind+  ( Type, Constraint )++-- tree-view+import Data.Tree.View+  ( showTree )++-- variant+import Data.Variant.EGADT+  ( EGADT )++-- fir+import FIR.AST.ControlFlow+import FIR.AST.Display+  ( toTree )+import FIR.AST.Effs+import FIR.AST.Exts+import FIR.AST.Images+import FIR.AST.Optics+import FIR.AST.Prim+import FIR.AST.Type++import FIR.Prim.Op+  ( PrimOp(PrimOpAugType) )+import {-# SOURCE #-} FIR.Prim.Types+  ( PrimTy )++------------------------------------------------------------+-- main AST data type: extensible GADT++type AllOpsF+  = '[ LamF, AppF, LitF, MkIDF, ValueF, UnsafeCoerceF+     , IxMonadF+     , PrimOpF, UndefinedF, GradedMappendF+     , ApplicativeF+     , MkVectorF, MatF, StructF, ArrayF, ArrayLengthF, HListF+     , SelectionF, LoopF+     , LetF, DefF, FunDefF, FunCallF, DefEntryPointF, StateF+     , DebugPrintfF, RayF+     , ImgOpsF, ImgQueryF+     , OpticF+     ]++type AST    = EGADT AllOpsF+type Code a = AST (Val a)++------------------------------------------------++-- | Syntactic type class (Axelsson, Svenningsson).+class Syntactic a where+  type Internal a :: AugType+  toAST :: a -> AST (Internal a)+  fromAST :: AST (Internal a) -> a++type family SyntacticVal a :: Constraint where+  SyntacticVal a = ( Syntactic a, Internal a ~ Val (InternalType a) )+type InternalType a = UnderlyingType (Internal a)++instance Syntactic (AST a) where+  type Internal (AST a) = a+  toAST   = id+  fromAST = id++instance (SyntacticVal a, Syntactic b) => Syntactic (a -> b) where+  type Internal (a -> b) = Internal a :--> Internal b+  toAST        f    = Lam @( Val (InternalType a) :--> Internal b )+                      ( toAST . f . fromAST )+  fromAST (Lam f) a = fromAST ( f  $ toAST a )+  fromAST      f  a = fromAST ( f :$ toAST a )++------------------------------------------------++-- | Utility function for defining primops.+primOp :: forall a op r+       .  ( PrimOp op a+          , Syntactic r+          , Internal r ~ PrimOpAugType op a+          )+       => r+primOp = fromAST $ PrimOp ( Proxy @a ) ( Proxy @op )++-- | Types at which we can define "undefined."+class HasUndefined (a :: Type) where+  undefined :: a++instance PrimTy a => HasUndefined (Code a) where+  undefined = Undefined++instance {-# OVERLAPPABLE #-} HasUndefined a where+  undefined = Prelude.undefined++------------------------------------------------+-- display AST for viewing++instance Show (AST ast) where+  show = showTree . toTree
+ src/FIR/AST.hs-boot view
@@ -0,0 +1,60 @@+{-# LANGUAGE DataKinds    #-}+{-# LANGUAGE PolyKinds    #-}+{-# LANGUAGE TypeFamilies #-}++module FIR.AST+  ( AST, Code+  , Syntactic(..)+  , InternalType+  )+  where++-- variant+import Data.Variant.EGADT+  ( EGADT )++-- fir+import FIR.AST.Type+  ( AugType(Val), UnderlyingType )+import {-# SOURCE #-} FIR.AST.ControlFlow+  ( SelectionF, LoopF )+import {-# SOURCE #-} FIR.AST.Effs+  ( LetF, DefF, FunDefF, FunCallF, DefEntryPointF, StateF )+import {-# SOURCE #-} FIR.AST.Exts+  ( DebugPrintfF, RayF )+import {-# SOURCE #-} FIR.AST.Images+  ( ImgOpsF, ImgQueryF )+import {-# SOURCE #-} FIR.AST.Optics+  ( OpticF )+import {-# SOURCE #-} FIR.AST.Prim+  ( LamF, AppF, LitF, MkIDF, ValueF, UnsafeCoerceF+  , IxMonadF+  , PrimOpF, UndefinedF, GradedMappendF+  , ApplicativeF+  , MkVectorF, MatF, StructF, ArrayF, ArrayLengthF, HListF+  )++------------------------------------------------------------++type AllOpsF+  = '[ LamF, AppF, LitF, MkIDF, ValueF, UnsafeCoerceF+     , IxMonadF+     , PrimOpF, UndefinedF, GradedMappendF+     , ApplicativeF+     , MkVectorF, MatF, StructF, ArrayF, ArrayLengthF, HListF+     , SelectionF, LoopF+     , LetF, DefF, FunDefF, FunCallF, DefEntryPointF, StateF+     , DebugPrintfF, RayF+     , ImgOpsF, ImgQueryF+     , OpticF+     ]++type AST    = EGADT AllOpsF+type Code a = AST (Val a)++class Syntactic a where+  type Internal a :: AugType+  toAST :: a -> AST (Internal a)+  fromAST :: AST (Internal a) -> a++type InternalType a = UnderlyingType (Internal a)
+ src/FIR/AST/ControlFlow.hs view
@@ -0,0 +1,157 @@+{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -Wno-missing-signatures #-}++{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}++{-|+Module: FIR.AST.ControlFlow++AST operations involving control flow (conditional branching, selections, loops).+-}++module FIR.AST.ControlFlow where++-- base+import Data.Kind+  ( Type )+import Data.Proxy+  ( Proxy(..) )+import qualified GHC.Stack+  ( HasCallStack )+import GHC.TypeNats+  ( KnownNat, natVal )++-- containers+import Data.Tree+ ( Tree(Node) )++-- variant+import Data.Variant.EGADT+  ( EGADT, type (:<!), pattern VF )++-- fir+import Control.Arrow.Strength+  ( secondF )+import FIR.AST.Display+  ( Display(toTreeArgs) )+import FIR.AST.Type+  ( AugType(Val, (:-->)), Eff )+import {-# SOURCE #-} FIR.Prim.Types+  ( PrimTy, IntegralTy )+import FIR.Validation.CFG+  ( InLoop )++------------------------------------------------------------++pattern If :: forall a fs+           .  ( GHC.Stack.HasCallStack, PrimTy a, SelectionF :<! fs )+           => EGADT fs ( Val Bool :--> Val a :--> Val a :--> Val a )+pattern If              = VF IfF+pattern IfM             = VF IfMF+pattern Switch  s d cs  = VF (SwitchF  s d cs)+pattern SwitchM s d cs  = VF (SwitchMF s d cs)++pattern While           = VF WhileF+pattern Loop            = VF LoopF+pattern Break         n = VF (BreakF n)+pattern BreakContinue n = VF (BreakContinueF n)++data SelectionF ( ast :: AugType -> Type ) ( t :: AugType ) where+  -- | If-then-else statement.+  IfF+    :: ( GHC.Stack.HasCallStack+       , PrimTy a+       )+    => SelectionF ast ( Val Bool :--> Val a :--> Val a :--> Val a )++  -- | Monadic if-then-else.+  IfMF+    :: GHC.Stack.HasCallStack+    => SelectionF ast ( Eff i i Bool :--> Eff i j a :--> Eff i k a :--> Eff i i a )++  -- | Switch statement.+  SwitchF+    :: ( GHC.Stack.HasCallStack+       , PrimTy a+       , IntegralTy s+       )+    => ast ( Val s ) -- ^ Scrutinee.+    -> ast ( Val a ) -- ^ Default case.+    -> [ ( s, ast (Val a) ) ] -- ^ Cases.+    -> SelectionF ast ( Val a )++  -- | Monadic switch statement.+  SwitchMF+    :: ( GHC.Stack.HasCallStack+       , PrimTy a+       , IntegralTy s+       )+    => ast ( Eff i i s ) -- ^ Scrutinee.+    -> ast ( Eff i i a ) -- ^ Default case.+    -> [ ( s, ast ( Eff i i a ) ) ] -- ^ Cases.+    -> SelectionF ast ( Eff i i a )+  -- ( SwitchM could be generalised by allowing different return types in the branches.)++data LoopF ( ast :: AugType -> Type ) ( t :: AugType ) where+  -- | While loop.+  WhileF+    :: GHC.Stack.HasCallStack+    => LoopF ast ( Eff i i Bool :--> Eff (InLoop i) j () :--> Eff i i () )++  -- | Loop.+  LoopF+    :: GHC.Stack.HasCallStack+    => LoopF ast ( Eff (InLoop i) j () :--> Eff i i () )++  -- | Break out of the given number of loops.+  BreakF+    :: ( KnownNat n, GHC.Stack.HasCallStack )+    => Proxy n+    -> LoopF ast ( Eff i i () )++  -- | Break out of the given number of loops, and continue from the resulting loop.+  BreakContinueF+    :: ( KnownNat n, GHC.Stack.HasCallStack )+    => Proxy n+    -> LoopF ast ( Eff i i () )++------------------------------------------------------------+-- displaying++instance Display ast => Display (SelectionF ast) where+  toTreeArgs as IfF  = pure ( Node "If" as )+  toTreeArgs as IfMF = pure ( Node "IfM" as )+  toTreeArgs as ( SwitchF s d cs ) = do+    scrut <- toTreeArgs [] s+    def   <- toTreeArgs [] d+    cases <- traverse ( secondF ( toTreeArgs [] ) ) cs+    let+      allCases+        =  map ( \(v,a) -> Node ("Case " ++ show v) [a] ) cases+        ++ [ Node "Default" [def] ]+    return (Node "Switch" (scrut : allCases ++ as))+  toTreeArgs as (SwitchMF s d cs) = do+    scrut <- toTreeArgs [] s+    def   <- toTreeArgs [] d+    cases <- traverse ( secondF ( toTreeArgs [] ) ) cs+    let+      allCases+        =  map ( \(v,a) -> Node ("Case " ++ show v) [a] ) cases+        ++ [ Node "Default" [def] ]+    return (Node "SwitchM" (scrut : allCases ++ as))++instance Display ast => Display (LoopF ast) where+  toTreeArgs as WhileF = pure ( Node "While" as )+  toTreeArgs as LoopF  = pure ( Node "Loop"  as )+  toTreeArgs as ( BreakF n ) = pure ( Node ( "Break @" ++ show ( natVal n ) ) as )+  toTreeArgs as ( BreakContinueF n ) =+    let+      nm = case natVal n of+        0 -> "Continue"+        i -> "BreakContinue @" ++ show i+    in pure ( Node nm as )
+ src/FIR/AST/ControlFlow.hs-boot view
@@ -0,0 +1,21 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RoleAnnotations     #-}++module FIR.AST.ControlFlow where++-- base+import Data.Kind+  ( Type )++-- fir+import FIR.AST.Type+  ( AugType )++------------------------------------------------------------++data SelectionF ( ast :: AugType -> Type ) ( t :: AugType )+data LoopF      ( ast :: AugType -> Type ) ( t :: AugType )++type role SelectionF representational nominal+type role LoopF      phantom          nominal
+ src/FIR/AST/Display.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DerivingVia          #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: FIR.AST.Display++Graphically displaying syntax trees for inspection.++Each constructor of the AST must provide a `Display` instance.+-}+++module FIR.AST.Display+  ( Display(toTreeArgs), toTree, named )+  where++-- base+import Data.Kind+  ( Type )++-- containers+import Data.Tree+ ( Tree(Node) )++-- mtl+import Control.Monad.State.Lazy+  ( evalState )++-- variant+import Data.Variant.EGADT+  ( EGADT(..), HVariantF(..) )+import Data.Variant.VariantF+  ( VariantF(VariantF), ApplyAll, BottomUp(toBottomUp) )++-- fir+import CodeGen.Instruction+  ( ID(ID) )+import CodeGen.Monad+  ( MonadFresh, runFreshSuccT )++-------------------------------------------------------------------------------------++class Display (f :: k -> Type) where+  toTreeArgs :: MonadFresh ID m => [Tree String] -> f a -> m (Tree String)++toTree :: Display f => f a -> Tree String+toTree = (`evalState` (ID 1)) . runFreshSuccT . toTreeArgs []++instance BottomUp Display fs => Display (VariantF fs) where+  toTreeArgs as = toBottomUp @Display ( toTreeArgs as )++deriving via VariantF ( ApplyAll (EGADT fs) fs )+  instance BottomUp Display ( ApplyAll (EGADT fs) fs )+        => Display ( EGADT fs )++named :: Monad m => ( f a -> String ) -> ( [Tree String] -> f a -> m (Tree String) )+named name as f = pure ( Node ( name f ) as )
+ src/FIR/AST/Effs.hs view
@@ -0,0 +1,218 @@+{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -Wno-missing-signatures #-}++{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++{-|+Module: FIR.AST.Effs++Effectful operations of the AST:+  * defining new variables/functions/entry-points,+  * management of indexed state.+-}++module FIR.AST.Effs where++-- base+import Data.Kind+  ( Type )+import Data.Proxy+  ( Proxy )+import qualified GHC.Stack+  ( HasCallStack )+import GHC.TypeLits+  ( Symbol, KnownSymbol, symbolVal )+import GHC.TypeNats+  ( Nat )++-- variant+import Data.Variant.EGADT+  ( pattern VF )++-- fir+import Data.Constraint.All+  ( All )+import Data.Type.Known+  ( Known, knownValue )+import FIR.AST.Display+  ( Display(toTreeArgs), named )+import FIR.AST.Type+  ( AugType(Val, (:-->)), Eff, FunArgs, Nullary )+import FIR.Binding+  ( BindingsMap+  , FunctionAugType, Var, Permissions+  )+import FIR.Prim.Types+  ( PrimTy, KnownVars )+import FIR.ProgramState+  ( ProgramState, TLInterface )+import FIR.Validation.Bindings+  ( ValidDef, ValidFunDef, FunctionTypes+  , AddBinding, AddFunBinding+  , FunctionDefinitionStartState, FunctionDefinitionEndState+  , ValidEntryPoint, SetInterface+  , GetExecutionInfo+  , EntryPointStartState, EntryPointEndState+  , Embeddable+  )+import qualified SPIRV.Stage  as SPIRV+  ( ExecutionModel, ExecutionInfo )++------------------------------------------------------------++pattern Let                     = VF LetF+pattern Def           k ps      = VF ( DefF           k ps )+pattern FunDef        name as b = VF ( FunDefF        name as b )+pattern FunCall       name as b = VF ( FunCallF       name as b )+pattern DefEntryPoint name info = VF ( DefEntryPointF name info )+pattern Locally                 = VF LocallyF+pattern Embed                   = VF EmbedF++-- | Let binding.+data LetF ( ast :: AugType -> Type ) ( t :: AugType ) where+  LetF :: GHC.Stack.HasCallStack => LetF ast ( Val a :--> Eff i i a )++-- | Defining a new constant/variable.+data DefF ( ast :: AugType -> Type ) ( t :: AugType ) where+  DefF+    :: forall+        ( k   :: Symbol           )+        ( ps  :: Permissions      )+        ( a   :: Type             )+        ( i   :: ProgramState     )+        ( ast :: AugType -> Type  )+    . ( GHC.Stack.HasCallStack+      , KnownSymbol k+      , Known Permissions ps+      , PrimTy a+      , ValidDef k i a+      )+    => Proxy k  -- ^ Variable name.+    -> Proxy ps -- ^ Permissions (read,write,...).+    -> DefF ast ( Val a :--> Eff i (AddBinding k (Var ps a) i) a )++-- | Defining a new function.+--+-- Meaning of type variables:+-- * name: function name,+-- * as: named function arguments (usually inferred),+-- * b: function return type (usually inferred),+-- * j_bds: bindings state at end of function definition (usually inferred),+-- * i: monadic state at function definition site (usually inferred).+data FunDefF ( ast :: AugType -> Type ) ( t :: AugType ) where+  FunDefF+    :: forall+         ( name  :: Symbol          )+         ( as    :: BindingsMap     )+         ( b     :: Type            )+         ( j_bds :: BindingsMap     )+         ( i     :: ProgramState    )+         ( ast   :: AugType -> Type )+    . ( GHC.Stack.HasCallStack+      , KnownSymbol name+      , KnownVars as+      , PrimTy b+      , ValidFunDef name as i j_bds+      , '(as,b) ~ FunctionTypes name i+      )+    => Proxy name -- ^ Funtion name.+    -> Proxy as   -- ^ Function argument types.+    -> Proxy b    -- ^ Function return type.+    -> FunDefF ast+        ( Eff +          ( FunctionDefinitionStartState name as       i )+          ( FunctionDefinitionEndState   name as j_bds i )+          b+        :--> Eff i ( AddFunBinding name as b i ) ( FunctionHandle name as b )+        )++data FunctionHandle (name :: Symbol) (as :: BindingsMap) (b :: Type)++data FunCallF ( ast :: AugType -> Type ) ( t :: AugType ) where+  FunCallF +    :: ( KnownSymbol name+       , KnownVars as+       , PrimTy b+       , All Nullary (FunArgs (FunctionAugType as b))+       )+    => Proxy name+    -> Proxy as+    -> Proxy b+    -> FunCallF ast ( Val (FunctionHandle name as b) :--> FunctionAugType as b )++-- | Defining a new entry point.+--+-- An entry point is like a function definition with no arguments and Unit return type.+-- Code within an entry point is given access to additional builtins.+--+-- Meaning of type variables:+-- * name: entry point name,+-- * stage: entry point stage,+-- * stageInfo: entry point stage info (usually inferred),+-- * j_bds: bindings state at end of entry point definition (usually inferred),+-- * j_iface: entry point interface (usually inferred),+-- * i: monadic state at entry point definition site (usually inferred).+data DefEntryPointF ( ast :: AugType -> Type ) ( t :: AugType ) where+  DefEntryPointF+    :: forall+        ( name      :: Symbol )+        ( stage     :: SPIRV.ExecutionModel          )+        ( stageInfo :: SPIRV.ExecutionInfo Nat stage )+        ( j_bds     :: BindingsMap  )+        ( j_iface   :: TLInterface  )+        ( i         :: ProgramState )+        ( ast       :: AugType -> Type )+    . ( GHC.Stack.HasCallStack+      , KnownSymbol name+      , Known SPIRV.ExecutionModel stage+      , Known (SPIRV.ExecutionInfo Nat stage) stageInfo+      , ValidEntryPoint name stageInfo i j_bds+      , stageInfo ~ GetExecutionInfo name stage i+      )+    => Proxy name      -- ^ Entry point name.+    -> Proxy stageInfo -- ^ Entry point stage info.+    -> DefEntryPointF ast+        (  Eff +          ( EntryPointStartState name stageInfo               i )+          ( EntryPointEndState   name stageInfo j_bds j_iface i )+          ()+        :--> ( Eff i ( SetInterface name stageInfo j_iface i ) () )+        )+++data StateF ( ast :: AugType -> Type ) ( t :: AugType ) where+  -- | Encapsulate local state.+  LocallyF :: StateF ast ( Eff i j a :--> Eff i i a )++  -- | Embed a computation into one with larger state.+  EmbedF :: Embeddable i j => StateF ast ( Eff i i a :--> Eff j j a )++------------------------------------------------------------+-- displaying++instance Display (LetF ast) where+  toTreeArgs = named \ LetF -> "Let"+instance Display (DefF ast) where+  toTreeArgs = named \(DefF k _) ->+    "Def @" ++ symbolVal k+instance Display (FunDefF ast) where+  toTreeArgs = named \(FunDefF k _ _) ->+    "FunDef @" ++ symbolVal k+instance Display (FunCallF ast) where+  toTreeArgs = named \(FunCallF k _ _) ->+    "FunCall @" ++ symbolVal k+instance Display (DefEntryPointF ast) where+  toTreeArgs = named \(DefEntryPointF _ (_ :: Proxy (stageInfo :: SPIRV.ExecutionInfo Nat stage) )) ->+    "Entry @(" ++ show (knownValue @stage) ++ ")"+instance Display (StateF ast) where+  toTreeArgs = named \ case+    LocallyF -> "Locally"+    EmbedF   -> "Embed"
+ src/FIR/AST/Effs.hs-boot view
@@ -0,0 +1,29 @@+{-# LANGUAGE DataKinds       #-}+{-# LANGUAGE PolyKinds       #-}+{-# LANGUAGE RoleAnnotations #-}++module FIR.AST.Effs where++-- base+import Data.Kind+  ( Type )++-- fir+import FIR.AST.Type+  ( AugType )++------------------------------------------------------------++data LetF           ( ast :: AugType -> Type ) ( t :: AugType )+data DefF           ( ast :: AugType -> Type ) ( t :: AugType )+data FunDefF        ( ast :: AugType -> Type ) ( t :: AugType )+data FunCallF       ( ast :: AugType -> Type ) ( t :: AugType )+data DefEntryPointF ( ast :: AugType -> Type ) ( t :: AugType )+data StateF         ( ast :: AugType -> Type ) ( t :: AugType )++type role LetF           phantom nominal+type role DefF           phantom nominal+type role FunDefF        phantom nominal+type role FunCallF       phantom nominal+type role DefEntryPointF phantom nominal+type role StateF         phantom nominal
+ src/FIR/AST/Exts.hs view
@@ -0,0 +1,261 @@+{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -Wno-missing-signatures #-}++{-# LANGUAGE BlockArguments         #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE PatternSynonyms        #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE RecordWildCards        #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: FIR.AST.Exts++Additional operations, such as ray tracing operations and Debug Printf.+-}++module FIR.AST.Exts where++-- base+import Data.Kind+  ( Type )+import Data.Proxy+  ( Proxy )+import Data.Word+  ( Word32 )++-- containers+import Data.Tree+ ( Tree(Node) )++-- text-short+import Data.Text.Short+  ( ShortText )+import qualified Data.Text.Short as ShortText+  ( unpack )++-- variant+import Data.Variant.EGADT+  ( pattern VF )++-- fir+import Data.Constraint.All+  ( All )+import FIR.AST.Display+  ( Display(toTreeArgs), named )+import FIR.AST.Type+  ( AugType(..), Eff+  , Nullary, FunArgs, FunRes+  )+import FIR.Prim.RayTracing+  ( AccelerationStructure+  , RayQuery(..), IntersectionType(..)+  )+import FIR.Prim.Types+  ( PrimTy )+import FIR.ProgramState+  ( ProgramState )+import Math.Linear+  ( V )+import qualified SPIRV.Operation as SPIRV+  ( Operation, showOperation )++------------------------------------------------------------++pattern DebugPrintf formatString = VF ( DebugPrintfF formatString )+pattern+  TraceRay+    { traceRayAccelerationStructure+    , traceRayRayFlags+    , traceRayCullMask+    , traceRaySBTOffset+    , traceRaySBTStride+    , traceRayMissIndex+    , traceRayRayOrigin+    , traceRayRayTMin+    , traceRayRayDirection+    , traceRayRayTMax+    , traceRayPayloadID+    } = VF+      ( TraceRayF+          traceRayAccelerationStructure+          traceRayRayFlags+          traceRayCullMask+          traceRaySBTOffset+          traceRaySBTStride+          traceRayMissIndex+          traceRayRayOrigin+          traceRayRayTMin+          traceRayRayDirection+          traceRayRayTMax+          traceRayPayloadID+      )+pattern ExecuteCallable sbtIndex dataID = VF ( ExecuteCallableF sbtIndex dataID )+pattern+  RayQueryInitialize+    { rayQueryRayQueryName+    , rayQueryAccelerationStructure+    , rayQueryRayFlags+    , rayQueryCullMask+    , rayQueryRayOrigin+    , rayQueryRayTMin+    , rayQueryRayDirection+    , rayQueryRayTMax+    } = VF+      ( RayQueryInitializeF+          rayQueryRayQueryName+          rayQueryAccelerationStructure+          rayQueryRayFlags+          rayQueryCullMask+          rayQueryRayOrigin+          rayQueryRayTMin+          rayQueryRayDirection+          rayQueryRayTMax+      )+pattern RayQueryPrimOp px rayQueryOp rayQueryName mbIntersectionType =+  VF ( RayQueryPrimOpF px rayQueryOp rayQueryName mbIntersectionType )+++-- | Printf debugging statement (SPIR-V non-semantic extension).+data DebugPrintfF ( ast :: AugType -> Type ) ( t :: AugType ) where+  DebugPrintfF+    :: All Nullary ( FunArgs ( PrintfAugType i as ) )+    => ShortText  -- ^ PrintF format string+    -> DebugPrintfF ast ( PrintfAugType i as )++type family PrintfAugType ( i :: ProgramState ) ( as :: [ Type ] ) = ( r :: AugType ) | r -> as i where+  PrintfAugType i '[]         = Eff i i ()+  PrintfAugType i ( a ': as ) = Val a :--> PrintfAugType i as+++data RayF ( ast :: AugType -> Type ) ( t :: AugType ) where+  -- | Trace a ray into the given acceleration structure.+  TraceRayF ::+    { traceRayFAccelerationStructure :: ast ( Val AccelerationStructure )+    , traceRayFRayFlags              :: ast ( Val Word32 )+    , traceRayFCullMask              :: ast ( Val Word32 )+    , traceRayFSBTOffset             :: ast ( Val Word32 )+    , traceRayFSBTStride             :: ast ( Val Word32 )+    , traceRayFMissIndex             :: ast ( Val Word32 )+    , traceRayFRayOrigin             :: ast ( Val ( V 3 Float ) )+    , traceRayFRayTMin               :: ast ( Val Float )+    , traceRayFRayDirection          :: ast ( Val ( V 3 Float ) )+    , traceRayFRayTMax               :: ast ( Val Float )+    , traceRayFRayPayloadName        :: ShortText+    } -> RayF ast ( Eff i i () )++  -- | Invoke a callable shader.+  ExecuteCallableF ::+    { executeCallableFSBTIndex :: ast ( Val Word32 )+    , executeCallableFDataName :: ShortText+    } -> RayF ast ( Eff i i () )++  -- | Initialise a ray query.+  RayQueryInitializeF ::+    { rayQueryFRayQueryName          :: RayQuery+    , rayQueryFAccelerationStructure :: ast ( Val AccelerationStructure )+    , rayQueryFRayFlags              :: ast ( Val Word32 )+    , rayQueryFCullMask              :: ast ( Val Word32 )+    , rayQueryFRayOrigin             :: ast ( Val ( V 3 Float ) )+    , rayQueryFRayTMin               :: ast ( Val Float )+    , rayQueryFRayDirection          :: ast ( Val ( V 3 Float ) )+    , rayQueryFRayTMax               :: ast ( Val Float )+    } -> RayF ast ( Eff i j () )++  -- | Ray query operations.+  RayQueryPrimOpF+    :: ( All Nullary ( FunArgs opTy )+       , FunRes opTy ~ Eff i i a+       , PrimTy a+       )+    => Proxy a+    -> SPIRV.Operation+    -> RayQuery+    -> Maybe IntersectionType+    -> RayF ast opTy++------------------------------------------------------------+-- displaying++instance Display ast => Display (DebugPrintfF ast) where+  toTreeArgs = named \(DebugPrintfF formatString) ->+    "DebugPrintf \"" <> ShortText.unpack formatString <> "\""++instance Display ast => Display (RayF ast) where++  toTreeArgs as (TraceRayF {..}) = do+    accelerationStructure <- toTreeArgs [] traceRayFAccelerationStructure+    rayFlags              <- toTreeArgs [] traceRayFRayFlags+    cullMask              <- toTreeArgs [] traceRayFCullMask+    sbtOffset             <- toTreeArgs [] traceRayFSBTOffset+    sbtStride             <- toTreeArgs [] traceRayFSBTStride+    missIndex             <- toTreeArgs [] traceRayFMissIndex+    rayOrigin             <- toTreeArgs [] traceRayFRayOrigin+    rayTMin               <- toTreeArgs [] traceRayFRayTMin+    rayDirection          <- toTreeArgs [] traceRayFRayDirection+    rayTMax               <- toTreeArgs [] traceRayFRayTMax+    let+      rayPayloadName = ShortText.unpack traceRayFRayPayloadName+    pure $+      Node "TraceRay"+        ( accelerationStructure+        : rayFlags+        : cullMask+        : sbtOffset+        : sbtStride+        : missIndex+        : rayOrigin+        : rayTMin+        : rayDirection+        : rayTMax+        : Node rayPayloadName []+        : as+        )++  toTreeArgs as (ExecuteCallableF {..}) = do+    sbtIndex <- toTreeArgs [] executeCallableFSBTIndex+    let+      callableDataName = ShortText.unpack executeCallableFDataName+    pure $+      Node "ExecuteCallable"+        ( sbtIndex+        : Node callableDataName []+        : as+        )++  toTreeArgs as (RayQueryInitializeF {..}) = do+    let+      RayQuery rayQueryName = rayQueryFRayQueryName+    accelerationStructure <- toTreeArgs [] rayQueryFAccelerationStructure+    rayFlags              <- toTreeArgs [] rayQueryFRayFlags+    cullMask              <- toTreeArgs [] rayQueryFCullMask+    rayOrigin             <- toTreeArgs [] rayQueryFRayOrigin+    rayTMin               <- toTreeArgs [] rayQueryFRayTMin+    rayDirection          <- toTreeArgs [] rayQueryFRayDirection+    rayTMax               <- toTreeArgs [] rayQueryFRayTMax+    pure $+      Node "RayQueryInitialize"+        ( Node ( ShortText.unpack rayQueryName ) []+        : accelerationStructure+        : rayFlags+        : cullMask+        : rayOrigin+        : rayTMin+        : rayDirection+        : rayTMax+        : as+        )++  toTreeArgs as (RayQueryPrimOpF _ rayQueryOp (RayQuery rayQueryName) mbInterType) =+    pure $+      Node ( SPIRV.showOperation rayQueryOp )+        ( Node ( ShortText.unpack rayQueryName ) []+        : ( case mbInterType of+             Nothing -> id+             Just Candidate -> ( Node "Candidate" [] : )+             Just Committed -> ( Node "Committed" [] : )+          ) as+        )
+ src/FIR/AST/Exts.hs-boot view
@@ -0,0 +1,22 @@+{-# LANGUAGE DataKinds       #-}+{-# LANGUAGE PolyKinds       #-}+{-# LANGUAGE RoleAnnotations #-}++module FIR.AST.Exts where++-- base+import Data.Kind+  ( Type )++-- fir+import FIR.AST.Type+  ( AugType )++------------------------------------------------------------++data DebugPrintfF ( ast :: AugType -> Type ) ( t :: AugType )+data RayF         ( ast :: AugType -> Type ) ( t :: AugType )+++type role DebugPrintfF phantom          nominal+type role RayF         representational nominal
+ src/FIR/AST/Images.hs view
@@ -0,0 +1,291 @@+{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -Wno-missing-signatures #-}++{-# LANGUAGE BlockArguments  #-}+{-# LANGUAGE DataKinds       #-}+{-# LANGUAGE GADTs           #-}+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds       #-}+{-# LANGUAGE TypeOperators   #-}++{-|+Module: FIR.AST.Images++Handling image operands and image query operations.+-}++module FIR.AST.Images where++-- base+import Data.Kind+  ( Type )+import Data.Proxy+  ( Proxy )+import Data.Word+  ( Word32 )+import GHC.TypeLits+  ( KnownSymbol, symbolVal )++-- containers+import Data.Tree+ ( Tree(Node) )++-- variant+import Data.Variant.EGADT+  ( pattern VF )++-- fir+import FIR.AST.Display+  ( Display(toTreeArgs), named )+import FIR.AST.Type+  ( AugType(..), Eff )+import {-# SOURCE #-} FIR.Prim.Image+  ( ImageOperands, OperandName(..)+  , GatherInfo(..), WhichGather+  )+import {-# SOURCE #-} FIR.Prim.Types+  ( PrimTy )+import FIR.Validation.Images+  ( BasicDim, NotCubeDim+  , CanAddProj, CanAddDref+  , UsesAffineCoords+  , NoDuplicate+  , NoMS, CanMultiSample+  , NoLODOps+  , ValidImageCoordinate, ValidImageGradCoordinate, ValidImageOffsetCoordinate+  )+import qualified SPIRV.Image as SPIRV++------------------------------------------------------------++infixl 5 `Dref`+infixl 5 `Bias`+infixl 5 `LOD`+infixl 5 `MinLOD`+infixl 5 `Grad`+infixl 5 `ConstOffsetBy`+infixl 5 `OffsetBy`+infixl 5 `Gather`+infixl 5 `SampleNo`++pattern NilOps                = VF NilOpsF+pattern Proj              ops = VF (ProjF              ops)+pattern Dref          ref ops = VF (DrefF          ref ops)+pattern Bias         bias ops = VF (BiasF         bias ops)+pattern LOD           lod ops = VF (LODF           lod ops)+pattern MinLOD        lod ops = VF (MinLODF        lod ops)+pattern Grad         grad ops = VF (GradF         grad ops)+pattern ConstOffsetBy off ops = VF (ConstOffsetByF off ops)+pattern OffsetBy      off ops = VF (OffsetByF      off ops)+pattern Gather       gath ops = VF (GatherF       gath ops)+pattern SampleNo      sno ops = VF (SampleNoF      sno ops)++pattern QuerySize    img res = VF ( QuerySizeF    img res )+pattern QuerySizeLOD img res = VF ( QuerySizeLODF img res )+pattern QueryLOD     img res = VF ( QueryLODF     img res )+pattern QueryLevels  img res = VF ( QueryLevelsF  img res )+pattern QuerySamples img res = VF ( QuerySamplesF img res )++data ImgOpsF ( ast :: AugType -> Type ) ( t :: AugType ) where++  -- | End of (snoc-)list of image operands.+  NilOpsF :: ImgOpsF ast ( Val ( ImageOperands props '[] ) )++  -- | Use projective coordinates.+  --+  -- Must be provided after all other operands,+  -- except possibly 'Dref'.+  ProjF+    :: CanAddProj ops+    => ast ( Val ( ImageOperands props ops ) )+    -> ImgOpsF ast ( Val ( ImageOperands props (ProjectiveCoords ': ops) ) )++  -- | Provide a depth-comparison reference value.+  --+  -- Must be provided after all other operands,+  -- except possibly 'Proj'.+  DrefF+    :: CanAddDref ops+    => ast ( Val Float ) -- ^ Reference value used to perform the depth comparison.+    -> ast ( Val ( ImageOperands props ops ) )+    -> ImgOpsF ast ( Val ( ImageOperands props (DepthComparison ': ops) ) )++  -- | Add a bias to the implicit level of detail.+  BiasF+    :: ( BasicDim "Bias" props+       , NoMS "Bias" props+       , NoDuplicate (BaseOperand ('SPIRV.LODOperand SPIRV.Bias)) ops+       , NoLODOps "Bias" '[SPIRV.LOD, SPIRV.Grad] ops+       , ValidImageCoordinate props ops imgCoord+       )+    => ast ( Val imgCoord ) -- ^ Bias.+    -> ast ( Val ( ImageOperands props ops ) )+    -> ImgOpsF ast ( Val ( ImageOperands props (BaseOperand ('SPIRV.LODOperand SPIRV.Bias) ': ops) ) )++  -- | Provide an explicit level of detail.+  LODF+    :: ( BasicDim "LOD" props+       , NoMS "LOD" props+       , NoDuplicate (BaseOperand ('SPIRV.LODOperand SPIRV.LOD)) ops+       , NoLODOps "LOD" '[SPIRV.Bias, SPIRV.Grad, SPIRV.MinLOD] ops+       , ValidImageCoordinate props ops imgCoord+       )+     => ast ( Val imgCoord ) -- ^ LOD.+     -> ast ( Val ( ImageOperands props ops ) )+     -> ImgOpsF ast ( Val ( ImageOperands props (BaseOperand ('SPIRV.LODOperand SPIRV.LOD ) ': ops) ) )++  -- | Specify the minimum level of detail to use+  -- when sampling the image.+  MinLODF+    :: ( BasicDim "MinLOD" props+       , NoMS "MinLOD" props+       , NoDuplicate (BaseOperand ('SPIRV.LODOperand SPIRV.MinLOD)) ops+       , NoLODOps "MinLOD" '[SPIRV.LOD, SPIRV.Bias] ops+       , ValidImageCoordinate props ops imgCoord+       )+    => ast ( Val imgCoord ) -- ^ Minimum LOD.+    -> ast ( Val ( ImageOperands props ops ) )+    -> ImgOpsF ast ( Val ( ImageOperands props (BaseOperand ('SPIRV.LODOperand SPIRV.MinLOD ) ': ops) ) )++  -- | Provide explicit derivatives.+  GradF+    :: ( PrimTy gradCoords+       , NoMS "Grad" props+       , NoDuplicate (BaseOperand ('SPIRV.LODOperand SPIRV.Grad)) ops+       , NoLODOps "Grad" '[ SPIRV.Bias, SPIRV.LOD ] ops+       , ValidImageGradCoordinate props ops gradCoords+       )+    => ( ast (Val gradCoords), ast (Val gradCoords) ) -- ^ Gradient: ( df\/dx, df\/dy ).+    -> ast ( Val ( ImageOperands props ops ) )+    -> ImgOpsF ast ( Val ( ImageOperands props (BaseOperand ('SPIRV.LODOperand SPIRV.Grad) ': ops) ) )++  -- | Add a constant offset to the coordinates.+  ConstOffsetByF+    :: ( PrimTy offCoords+       , NoDuplicate (BaseOperand SPIRV.ConstOffset) ops+       , NotCubeDim "ConstOffsetBy" props+       , ValidImageOffsetCoordinate props ops offCoords+       )+    => offCoords -- Offset (a Haskell constant).+    -> ast ( Val ( ImageOperands props ops ) )+    -> ImgOpsF ast ( Val ( ImageOperands props (BaseOperand SPIRV.ConstOffset ': ops) ) )++  -- | Add an offset to the coordinates.+  OffsetByF+    :: ( PrimTy offCoords+       , NoDuplicate (BaseOperand SPIRV.Offset) ops+       , NotCubeDim "OffsetBy" props+       , ValidImageOffsetCoordinate props ops offCoords+       )+    => ast ( Val offCoords ) -- Offset.+    -> ast ( Val ( ImageOperands props ops ) )+    -> ImgOpsF ast ( Val ( ImageOperands props (BaseOperand SPIRV.Offset ': ops) ) )++  -- | Specify an image gather operation: gather texel data from 4 specified texel coordinates.+  GatherF+    :: ( NotCubeDim "Gather" props+       , NoDuplicate (BaseOperand SPIRV.ConstOffsets) ops+       , NoLODOps "Gather" '[ SPIRV.LOD, SPIRV.Grad, SPIRV.Bias, SPIRV.MinLOD ] ops+       , UsesAffineCoords ops+       )+    => GatherInfo ( ast ( Val Word32 ) ) (WhichGather ops)+    -> ast ( Val ( ImageOperands props ops ) )+    -> ImgOpsF ast ( Val ( ImageOperands props (BaseOperand SPIRV.ConstOffsets ': ops) ) )++  -- | Specify which sample number to use in a multi-sampled image.+  SampleNoF+    :: ( CanMultiSample props+       , NoDuplicate (BaseOperand SPIRV.Sample) ops+       )+    => ast ( Val Word32 ) -- ^ Sample number.+    -> ast ( Val ( ImageOperands props ops ) )+    -> ImgOpsF ast ( Val ( ImageOperands props (BaseOperand SPIRV.Sample ': ops) ) )+++data ImgQueryF ( ast :: AugType -> Type ) ( t :: AugType ) where+  -- | Query the size of an image with implicit LOD.+  QuerySizeF+    :: ( KnownSymbol imgName, PrimTy res )+    => Proxy imgName+    -> Proxy res+    -> ImgQueryF ast ( Eff i i res )+  -- | Query the size of an image with explicit LOD.+  QuerySizeLODF+    :: ( KnownSymbol imgName, PrimTy res )+    => Proxy imgName+    -> Proxy res+    -> ImgQueryF ast ( Val Word32 :--> Eff i i res )+  -- | Query the LOD of an image at given coordinates.+  QueryLODF+    :: ( KnownSymbol imgName, PrimTy res )+    => Proxy imgName+    -> Proxy res+    -> ImgQueryF ast ( Val coords :--> Eff i i res )+  -- | Query the number of levels of detail supported by an image.+  QueryLevelsF+    :: ( KnownSymbol imgName, PrimTy res )+    => Proxy imgName+    -> Proxy res+    -> ImgQueryF ast ( Eff i i res )+  -- | Query the number of samples of a multi-sampled image.+  QuerySamplesF+    :: ( KnownSymbol imgName, PrimTy res )+    => Proxy imgName+    -> Proxy res+    -> ImgQueryF ast ( Eff i i res )++------------------------------------------------------------+-- displaying++instance Display ast => Display (ImgOpsF ast) where+  toTreeArgs as NilOpsF = pure $ Node "NilOps" as+  toTreeArgs as (ProjF ops) = do+    a <- toTreeArgs [] ops+    pure $ Node "Proj" (a:as)+  toTreeArgs as (DrefF ref ops) = do+    r <- toTreeArgs [] ref+    a <- toTreeArgs [] ops+    pure $ Node "Dref" (r:a:as)+  toTreeArgs as (BiasF bias ops) = do+    b <- toTreeArgs [] bias+    a <- toTreeArgs [] ops+    pure $ Node "Bias=" (b:a:as)+  toTreeArgs as (LODF lod ops) = do+    l <- toTreeArgs [] lod+    a <- toTreeArgs [] ops+    pure $ Node "LOD" (l:a:as)+  toTreeArgs as (MinLODF lod ops) = do+    l <- toTreeArgs [] lod+    a <- toTreeArgs [] ops+    pure $ Node "MinLOD" (l:a:as)+  toTreeArgs as (GradF (dfdx, dfdy) ops) = do+    x <- toTreeArgs [] dfdx+    y <- toTreeArgs [] dfdy+    a <- toTreeArgs [] ops+    pure $ Node "Grad" (x:y:a:as)+  toTreeArgs as (ConstOffsetByF vec ops) = do+    a <- toTreeArgs [] ops+    pure $ Node "ConstOffsetBy" (pure (show vec):a:as)+  toTreeArgs as (OffsetByF vec ops) = do+    v <- toTreeArgs [] vec+    a <- toTreeArgs [] ops+    pure $ Node "OffsetBy" (v:a:as)+  toTreeArgs as (GatherF (ComponentWithOffsets comp offs) ops) = do+    c <- toTreeArgs [] comp+    a <- toTreeArgs [] ops+    pure $ Node "GatherComponentWithOffsets" (c:pure (show offs):a:as)+  toTreeArgs as (GatherF (DepthWithOffsets offs) ops) = do+    a <- toTreeArgs [] ops+    pure $ Node "GatherDepthWithOffsets" (pure (show offs):a:as)+  toTreeArgs as (SampleNoF no ops) = do+    n <- toTreeArgs [] no+    a <- toTreeArgs [] ops+    pure $ Node "SampleNo" (n:a:as)++instance Display ast => Display (ImgQueryF ast) where+  toTreeArgs = named \case+    QuerySizeF    imgName _ -> "ImageQuerySize @"    ++ symbolVal imgName+    QuerySizeLODF imgName _ -> "ImageQuerySizeLod @" ++ symbolVal imgName+    QueryLODF     imgName _ -> "ImageQueryLod @"     ++ symbolVal imgName+    QueryLevelsF  imgName _ -> "ImageQueryLevels @"  ++ symbolVal imgName+    QuerySamplesF imgName _ -> "ImageQuerySamples @" ++ symbolVal imgName
+ src/FIR/AST/Images.hs-boot view
@@ -0,0 +1,21 @@+{-# LANGUAGE DataKinds       #-}+{-# LANGUAGE PolyKinds       #-}+{-# LANGUAGE RoleAnnotations #-}++module FIR.AST.Images where++-- base+import Data.Kind+  ( Type )++-- fir+import FIR.AST.Type+  ( AugType )++------------------------------------------------------------++data ImgOpsF   ( ast :: AugType -> Type ) ( t :: AugType )+data ImgQueryF ( ast :: AugType -> Type ) ( t :: AugType )++type role ImgOpsF   representational nominal+type role ImgQueryF phantom          nominal
+ src/FIR/AST/Optics.hs view
@@ -0,0 +1,170 @@+{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -Wno-missing-signatures #-}++{-# LANGUAGE BlockArguments         #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE LambdaCase             #-}+{-# LANGUAGE PatternSynonyms        #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: FIR.AST.Optics++AST operations involving optics (view, set, use, assign).+-}++module FIR.AST.Optics where++-- base+import Data.Kind+  ( Type )+import qualified GHC.Stack+  ( HasCallStack )++-- variant+import Data.Variant.EGADT+  ( pattern VF )++-- fir+import {-# SOURCE #-} Control.Type.Optic+  ( Optic+  , Gettable, ReifiedGetter+  , Settable, ReifiedSetter+  , Indices, Part+  )+import Data.Type.List+  ( SLength, Snoc )+import FIR.AST.Display+  ( Display(toTreeArgs), named )+import FIR.AST.Type+  ( AugType(Val, (:-->)), Eff )+import FIR.Prim.Atomic+  ( SAtomicOp, atomicOp+  , AtomicShape(..), AtomicOpShape, AtomicOpTy+  )+import FIR.ProgramState+  ( ProgramState )+import {-# SOURCE #-} FIR.Syntax.Optics+  ( KnownOptic, SOptic, showSOptic )++------------------------------------------------------------++pattern Use    lg optic = VF ( UseF    lg optic )+pattern Assign lg optic = VF ( AssignF lg optic )+pattern View   lg optic = VF ( ViewF   lg optic )+pattern Set    lg optic = VF ( SetF    lg optic )+pattern Atomic op lg optic = VF ( AtomicF op lg optic )+++data OpticF ( ast :: AugType -> Type ) ( t :: AugType ) where+  -- | /Use/ an optic, returning a monadic value read from the (indexed) state.+  --+  -- Like @use@ from the lens library.+  UseF+    :: forall optic ast+    .  ( GHC.Stack.HasCallStack+       , KnownOptic optic, Gettable optic+       )+    => SLength ( Indices optic ) -- ^ Singleton for the number of run-time indices.+    -> SOptic optic              -- ^ Singleton for the optic.+    -> OpticF ast ( AugUser optic )++  -- | /Assign/ a new value with an optic.+  --+  -- Like @assign@ from the lens library.+  AssignF+    :: forall optic ast+    .  ( GHC.Stack.HasCallStack+       , KnownOptic optic, Settable optic+       )+    => SLength ( Indices optic ) -- ^ Singleton for the number of run-time indices.+    -> SOptic optic              -- ^ Singleton for the optic.+    -> OpticF ast ( AugAssigner optic )++  -- | /View/: access a value using an optic.+  --+  -- Like @view@ from the lens library.+  ViewF+    :: forall optic ast+    .  ( GHC.Stack.HasCallStack+       , KnownOptic optic, ReifiedGetter optic+       )+    => SLength ( Indices optic ) -- ^ Singleton for the number of run-time indices.+    -> SOptic optic              -- ^ Singleton for the optic.+    -> OpticF ast ( AugViewer optic )++  -- | /Set/: set a value using an optic.+  --+  -- Like @set@ from the lens library.+  SetF+    :: forall optic ast+    .  ( GHC.Stack.HasCallStack+       , KnownOptic optic, ReifiedSetter optic+       )+    => SLength ( Indices optic ) -- ^ Singleton for the number of run-time indices.+    -> SOptic optic              -- ^ Singleton for the optic.+    -> OpticF ast ( AugSetter optic )++  -- | An atomic operation on the scalar an optic focuses on.+  AtomicF+    :: forall op optic ast+    .  ( GHC.Stack.HasCallStack+       , KnownOptic optic, Gettable optic, Settable optic+       , AtomicOpTy op ( Part optic )+       )+    => SAtomicOp op+    -> SLength ( Indices optic ) -- ^ Singleton for the number of run-time indices.+    -> SOptic optic              -- ^ Singleton for the optic.+    -> OpticF ast ( AugAtomic ( AtomicOpShape op ) optic )++------------------------------------------------------------+-- type synonyms for augmented types of optical operations++type AugUser     (g :: Optic as i b) = AugListVariadicIx i as b+type AugViewer   (g :: Optic is s a) = AugListVariadic   (is `Snoc` s) a+type AugAssigner (g :: Optic as i b) = AugListVariadicIx i (as `Snoc` b) ()+type AugSetter   (g :: Optic is s a) = AugListVariadic   (is `Snoc` a `Snoc` s) s+type AugExchanger (g :: Optic as i b)+  = AugListVariadicIx i (as `Snoc` b) b+type AugCompareExchanger (g :: Optic as i b)+  = AugListVariadicIx i (as `Snoc` b `Snoc` b) b++-- | The augmented type of an atomic operation of the given shape.+type family AugAtomic (sh :: AtomicShape) (g :: Optic as i b) :: AugType where+  AugAtomic 'Reads    g = AugUser g+  AugAtomic 'Writes   g = AugAssigner g+  AugAtomic 'Modifies g = AugExchanger g+  AugAtomic 'Compares g = AugCompareExchanger g++type family AugListVariadic+              ( as :: [Type] )+              ( b  :: Type   )+            = ( r :: AugType )+            | r -> as b where+  AugListVariadic '[]       b = Val b+  AugListVariadic (a ': as) b = Val a :--> AugListVariadic as b++type family AugListVariadicIx+              ( i  :: ProgramState )+              ( as :: [Type]  )+              ( b  :: Type    )+            = ( r  :: AugType )+            | r -> as i b  where+  AugListVariadicIx i '[]       b = Eff i i b+  AugListVariadicIx i (a ': as) b = Val a :--> AugListVariadicIx i as b++------------------------------------------------------------+-- displaying++instance Display (OpticF ast) where+  toTreeArgs = named \ case+    UseF    _ o ->    "Use @(" ++ showSOptic o ++ ")"+    AssignF _ o -> "Assign @(" ++ showSOptic o ++ ")"+    ViewF   _ o ->   "View @(" ++ showSOptic o ++ ")"+    SetF    _ o ->    "Set @(" ++ showSOptic o ++ ")"+    AtomicF op _ o -> show ( atomicOp op ) ++ " @(" ++ showSOptic o ++ ")"
+ src/FIR/AST/Optics.hs-boot view
@@ -0,0 +1,19 @@+{-# LANGUAGE DataKinds       #-}+{-# LANGUAGE PolyKinds       #-}+{-# LANGUAGE RoleAnnotations #-}++module FIR.AST.Optics where++-- base+import Data.Kind+  ( Type )++-- fir+import FIR.AST.Type+  ( AugType )++------------------------------------------------------------++data OpticF ( ast :: AugType -> Type ) ( t :: AugType )++type role OpticF phantom nominal
+ src/FIR/AST/Prim.hs view
@@ -0,0 +1,362 @@+{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -Wno-missing-signatures #-}++{-# LANGUAGE BlockArguments       #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE LambdaCase           #-}+{-# LANGUAGE PatternSynonyms      #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: FIR.AST.Prim++Primitive operations of the AST:+  * lambda abstraction,+  * function application,+  * constant literals;+  * primitive SPIR-V operations,+  * vector/array/matrix creation,+  * ...+-}++module FIR.AST.Prim where++-- base+import Data.Foldable+  ( toList )+import Data.Kind+  ( Type )+import GHC.TypeLits+  ( Symbol )+import Data.Proxy+  ( Proxy )+import Data.Word+  ( Word32 )+import GHC.TypeLits+  ( KnownSymbol, symbolVal )+import GHC.TypeNats+  ( KnownNat, natVal )+import Numeric.Natural+  ( Natural )+import Data.Type.Map++-- containers+import Data.Tree+ ( Tree(Node) )++-- text-short+import Data.Text.Short+  ( ShortText )++-- variant+import Data.Variant.EGADT+  ( EGADT, pattern VF, (:<!) )++-- vector-sized+import qualified Data.Vector.Sized as Vector+  ( knownLength', toList )++-- fir+import CodeGen.Instruction+  ( ID )+import CodeGen.Monad+  ( MonadFresh(fresh) )+import Data.Constraint.All+  ( All )+import {-# SOURCE #-} Data.Product+  ( HList )+import Data.Type.Known+  ( knownValue )+import FIR.AST.Display+  ( Display(toTreeArgs), named )+import FIR.AST.Type+  ( AugType(Val, (:-->)), Eff+  , FunArgs, FunRes+  , ApplyFAug+  )+import FIR.Prim.Array+  ( Array(MkArray) )+import FIR.Prim.Op+  ( PrimOp(PrimOpAugType, opName)+  , PrimTyVal+  )+import {-# SOURCE #-} FIR.Prim.Struct+  ( Struct, ASTStructFields, traverseStructASTs )+import {-# SOURCE #-} FIR.Prim.Types+  ( PrimTy, primTy+  , PrimTyMap, primTyMap+  , PrimFunc, primFuncName+  )+import Math.Algebra.GradedSemigroup+  ( GradedSemigroup(Grade, (:<!>:)) )+import Math.Linear+  ( V, M )+import qualified SPIRV.PrimOp as SPIRV+  ( op )+import qualified SPIRV.PrimTy as SPIRV+  ( PrimTy )+import qualified SPIRV.Stage  as SPIRV+  ( Backend(Vulkan) )++------------------------------------------------------------++infixl 9 :$+infixr 5 `ConsHList`++pattern Lam :: forall fun fs+            .  ( LamF :<! fs )+            => forall a b+            .  ( fun ~ ( Val a :--> b ) )+            => ( EGADT fs ( Val a ) -> EGADT fs b )+            -> EGADT fs fun+pattern Lam   f             = VF (LamF f )+pattern (:$)  f a           = VF (AppF   f a)+pattern Lit   l             = VF (LitF   l  )+pattern MkID  i             = VF (MkIDF  i  )+pattern Value v             = VF (ValueF v  )+pattern UnsafeCoerce        = VF UnsafeCoerceF+pattern Return              = VF ReturnF+pattern Bind                = VF BindF+pattern PrimOp a op         = VF (PrimOpF a op)++pattern Undefined :: forall a fs+                  .  ( PrimTy a, UndefinedF :<! fs )+                  => EGADT fs (Val a)+pattern Undefined           = VF UndefinedF+pattern GradedMappend       = VF GradedMappendF+pattern Pure px   a         = VF (PureF px   a)+pattern Ap   px f a         = VF (ApF   px f a)+pattern MkVector v          = VF (MkVectorF v)+pattern Mat                 = VF MatF+pattern UnMat               = VF UnMatF+pattern Struct st           = VF (StructF st)+pattern Array arr           = VF (ArrayF arr)+pattern ArrayLength px1 px2 = VF ( ArrayLengthF px1 px2 )+pattern NilHList            = VF NilHListF+pattern ConsHList           = VF ConsHListF+++-- | Lambda abstraction.+data LamF ( ast :: AugType -> Type ) ( t :: AugType ) where+  LamF :: ( ast (Val a) -> ast b ) -> LamF ast ( Val a :--> b )++-- | Function application.+data AppF ( ast :: AugType -> Type ) ( t :: AugType ) where+  AppF :: ast ( a :--> b ) -> ast a -> AppF ast b++-- | Haskell-level constants can be embedded into the AST.+data LitF ( ast :: AugType -> Type ) ( t :: AugType ) where+  LitF :: PrimTy a => a -> LitF ast (Val a)++-- | Create an object of the given type from its ID.+-- These are the internal @SPIR-V@ identifiers, in SSA form.+-- Used internally during code-generation (evaluation not possible).+data MkIDF ( ast :: AugType -> Type ) ( t :: AugType ) where+  MkIDF :: ( ID, SPIRV.PrimTy ) -> MkIDF ast (Val a)++-- | Embed a value into the AST.+--+-- Used internallly to implement evaluation (code-generation not possible).+data ValueF ( ast :: AugType -> Type ) ( t :: AugType ) where+  ValueF :: a -> ValueF ast (Val a)++-- | Coercions (unsafe).+data UnsafeCoerceF ( ast :: AugType -> Type ) ( t :: AugType ) where+  UnsafeCoerceF :: UnsafeCoerceF ast (Val a :--> Val b)+++data IxMonadF ( ast :: AugType -> Type ) ( t :: AugType ) where+  -- Indexed monadic operations (for the AST itself).+  -- | Indexed /return/+  ReturnF :: IxMonadF ast (Val a :--> Eff i i a)+  -- | Indexed /angelic bind/+  BindF :: IxMonadF ast ( Eff i j a :--> ( Val a :--> q j ) :--> q i )++-- | @SPIR-V@ primitive operations.+data PrimOpF ( ast :: AugType -> Type ) ( t :: AugType ) where+  PrimOpF :: PrimOp op a => Proxy a -> Proxy op -> PrimOpF ast (PrimOpAugType op a)++-- | Undefined (result of @SPIR-V@'s @OpUndef@).+data UndefinedF ( ast :: AugType -> Type ) ( t :: AugType ) where+  UndefinedF :: PrimTy a => UndefinedF ast (Val a)++-- | Graded mappend to concatenate objects (e.g. two vectors).+data GradedMappendF ( ast :: AugType -> Type ) ( t :: AugType ) where+  GradedMappendF+    :: ( GradedSemigroup g k, a ~ Grade k g i, b ~ Grade k g j )+    => GradedMappendF ast ( Val a :--> Val b :--> Val (Grade k g (i :<!>: j)) )++data ApplicativeF ( ast :: AugType -> Type ) ( t :: AugType ) where+  -- | pure/return for applicative functors within the AST.+  PureF+    :: forall f a v ast+    .  ( PrimFunc f+       , All PrimTyVal (FunArgs a)+       , FunRes a ~ Val v, PrimTy v+       )+    => Proxy f+    -> ast a+    -> ApplicativeF ast ( ApplyFAug f a )+  -- | ap/(<*>) for applicative functors within the AST.+  ApF+    :: forall f a b ast. ( PrimFunc f, PrimTy a )+    => Proxy f+    -> ast ( Val (f a) :--> ApplyFAug f b )+    -> ast ( Val (f a) )+    -> ApplicativeF ast ( ApplyFAug f b )++-- | Create a vector from its components.+data MkVectorF ( ast :: AugType -> Type ) ( t :: AugType ) where+  MkVectorF+    :: ( KnownNat n, PrimTy a )+    => V n (ast (Val a))+    -> MkVectorF ast (Val (V n a))++data MatF ( ast :: AugType -> Type ) ( t :: AugType ) where+  -- | Newtype wrapping for matrices.+  MatF+    :: forall m n a ast+    .  ( KnownNat m, KnownNat n )+    => MatF ast ( Val (V n (V m a)) :--> Val (M m n a) )++  -- | Newtype unwrapping for matrices.+  UnMatF+    :: forall m n a ast+    .  ( KnownNat n, KnownNat m )+    => MatF ast ( Val (M m n a) :--> Val (V n (V m a)) )++-- | Construct a structure from statically-known parts.+data StructF ( ast :: AugType -> Type ) ( t :: AugType ) where+  StructF+    :: ( PrimTyMap bs, ASTStructFields ast as bs, bs ~ StructFResultFromArgs as, as ~ StructFArgsFromResult bs ast)+    => Struct as+    -> StructF ast ( Val (Struct bs) )++type family StructFResultFromArgs (as :: [ Symbol :-> Type ]) :: [ Symbol :-> Type ] where+  StructFResultFromArgs '[] = '[]+  StructFResultFromArgs ((k ':-> ast (Val b)) : as) = ((k ':-> b) : StructFResultFromArgs as)++type family StructFArgsFromResult (bs :: [ Symbol :-> Type ]) (ast :: AugType -> Type) :: [ Symbol :-> Type ] where+  StructFArgsFromResult '[] ast = '[]+  StructFArgsFromResult ((k ':-> b) : bs) ast = ((k ':-> ast (Val b)) : StructFArgsFromResult bs ast)++-- | Construct an array from its components.+data ArrayF ( ast :: AugType -> Type ) ( t :: AugType ) where+  ArrayF+    :: PrimTy a+    => Array n ( ast (Val a) )+    -> ArrayF ast ( Val (Array n a) )++-- | Query length of a run-time array.+data ArrayLengthF ( ast :: AugType -> Type ) ( t :: AugType ) where+  ArrayLengthF+    :: ( KnownSymbol structName, KnownNat arrayPosition )+    => Proxy structName+    -> Proxy arrayPosition+    -> ArrayLengthF ast ( Eff i i Word32 )++-- | Internal HList data type.+--+-- Only used for providing multiple run-time indices to product optics.+-- See [FIR issue #13](https://gitlab.com/sheaf/fir/issues/13).+data HListF ( ast :: AugType -> Type ) ( t :: AugType ) where++  ConsHListF+    :: PrimTy a+    => HListF ast ( Val a :--> Val (HList as) :--> Val (HList (a ': as)) )++  NilHListF+    :: HListF ast ( Val ( HList '[] ) )++------------------------------------------------------------+-- displaying++instance ( ast ~ EGADT cs, MkIDF :<! cs, Display ast ) => Display (LamF ast) where+  toTreeArgs as (LamF f) = do+    v <- fresh+    let var = MkID (v, undefined)+    body <- toTreeArgs @_ @ast [] (f var)+    return case as of+      [] -> Node ("Lam " ++ show v) [body]+      _  -> Node  ":$"              (body : as)+instance Display ast => Display (AppF ast) where+  toTreeArgs as (f `AppF` a) = do+    at <- toTreeArgs [] a+    toTreeArgs (at:as) f+instance Display (LitF ast) where+  toTreeArgs = named \ (LitF (a :: ty)) ->+    "Lit @" ++ show (primTy @ty) ++ ") " ++ show a+instance Display (MkIDF ast) where+  toTreeArgs = named ( \ (MkIDF (v,_)) -> show v )+instance Display (ValueF ast) where+  toTreeArgs = error "internal error: unexpected 'Value' constructor, unsupported in pretty-printing"+instance Display (UnsafeCoerceF ast) where+  toTreeArgs = named (const "UnsafeCoerce")+instance Display (IxMonadF ast) where+  toTreeArgs = named \case+    ReturnF -> "Return"+    BindF   -> "Bind"+instance Display (PrimOpF ast) where+  toTreeArgs = named+    ( \( PrimOpF ( _ :: Proxy a ) ( _ :: Proxy op ) ) ->+    -- use the Vulkan backend as a default for printing operation names+        "PrimOp" ++ show ( SPIRV.op SPIRV.Vulkan ( opName @_ @_ @op @a ) )+    )+instance Display (UndefinedF ast) where+  toTreeArgs = named (const "Undefined")+instance Display (GradedMappendF ast) where+  toTreeArgs = named (const "(<!>)")+instance Display ast => Display (ApplicativeF ast) where+  toTreeArgs as (PureF ( _ :: Proxy f ) a) = do+    at <- toTreeArgs [] a+    pure $ Node ( "Pure @(" ++ primFuncName @f ++ ")" ) (at:as)+  toTreeArgs as (ApF ( _ :: Proxy f ) f a) = do+    ft <- toTreeArgs [] f+    at <- toTreeArgs [] a+    pure $ Node ( "(<*>) @(" ++ primFuncName @f ++ ")" ) (ft:at:as)+instance Display ast => Display (MkVectorF ast) where+  toTreeArgs as (MkVectorF (vec :: V n (ast (Val a)))) = do+    trees <- toList <$> traverse ( toTreeArgs @_ @ast []) vec+    pure $ Node ("Vec" ++ show ( knownValue @n ) ) ( trees ++ as )+instance Display (MatF ast) where+  toTreeArgs = named \case+    MatF   -> "Mat"+    UnMatF -> "UnMat"+instance Display ast => Display (StructF ast) where+  toTreeArgs as mkStruct@(StructF elts) = case mkStruct of+    ( _ :: StructF ast (Val (Struct bs)) ) -> do+      trees <- traverseStructASTs (toTreeArgs @_ @ast []) elts+      let+        fieldNames :: [ (Maybe ShortText, SPIRV.PrimTy) ]+        fieldNames = primTyMap @_ @bs+      pure $ Node ("Struct @" ++ show fieldNames) (trees ++ as)+instance Display ast => Display (ArrayF ast) where+  toTreeArgs as mkArray@(ArrayF (MkArray vec)) = case mkArray of+    ( _ :: ArrayF ast (Val (Array n a)) ) -> do+      let+        comps = Vector.toList vec+        lg = Vector.knownLength' vec ( \px -> show ( natVal px ) )+      trees <- traverse (toTreeArgs []) comps+      pure $+        Node+          ( "Array @" ++ lg ++ " @" ++ show (primTy @a) )+          ( trees ++ as )+instance Display (ArrayLengthF ast) where+  toTreeArgs as (ArrayLengthF px_name px_pos) =+    let+      structName :: String+      structName = symbolVal px_name+      structPos :: Natural+      structPos = natVal px_pos+    in+      pure $ Node ( "ArrayLength @" <> structName <> " @" <> show structPos ) as+instance Display (HListF ast) where+  toTreeArgs = named \case+    NilHListF  -> "NilHList"+    ConsHListF -> "ConsHList"
+ src/FIR/AST/Prim.hs-boot view
@@ -0,0 +1,51 @@+{-# LANGUAGE DataKinds       #-}+{-# LANGUAGE PolyKinds       #-}+{-# LANGUAGE RoleAnnotations #-}++module FIR.AST.Prim where++-- base+import Data.Kind+  ( Type )++-- fir+import FIR.AST.Type+  ( AugType )++------------------------------------------------------------++data LamF           ( ast :: AugType -> Type ) ( t :: AugType )+data AppF           ( ast :: AugType -> Type ) ( t :: AugType )+data LitF           ( ast :: AugType -> Type ) ( t :: AugType )+data MkIDF          ( ast :: AugType -> Type ) ( t :: AugType )+data ValueF         ( ast :: AugType -> Type ) ( t :: AugType )+data UnsafeCoerceF  ( ast :: AugType -> Type ) ( t :: AugType )+data IxMonadF       ( ast :: AugType -> Type ) ( t :: AugType )+data PrimOpF        ( ast :: AugType -> Type ) ( t :: AugType )+data UndefinedF     ( ast :: AugType -> Type ) ( t :: AugType )+data GradedMappendF ( ast :: AugType -> Type ) ( t :: AugType )+data ApplicativeF   ( ast :: AugType -> Type ) ( t :: AugType )+data MkVectorF      ( ast :: AugType -> Type ) ( t :: AugType )+data MatF           ( ast :: AugType -> Type ) ( t :: AugType )+data StructF        ( ast :: AugType -> Type ) ( t :: AugType )+data ArrayF         ( ast :: AugType -> Type ) ( t :: AugType )+data ArrayLengthF   ( ast :: AugType -> Type ) ( t :: AugType )+data HListF         ( ast :: AugType -> Type ) ( t :: AugType )++type role LamF           representational nominal+type role AppF           representational nominal+type role LitF           phantom          nominal+type role MkIDF          phantom          nominal+type role ValueF         phantom          nominal+type role UnsafeCoerceF  phantom          nominal+type role IxMonadF       phantom          nominal+type role PrimOpF        phantom          nominal+type role UndefinedF     phantom          nominal+type role GradedMappendF phantom          nominal+type role ApplicativeF   representational nominal+type role MkVectorF      representational nominal+type role MatF           phantom          nominal+type role StructF        nominal          nominal+type role ArrayF         nominal          nominal+type role ArrayLengthF   phantom          nominal+type role HListF         phantom          nominal
+ src/FIR/AST/Type.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: FIR.AST.Type++Augmented annotation type for the AST GADT.++Distinguishes between a partially applied constructor of the AST+and a fully applied constructor of the AST that returns a function.++Enforces a distinction between pure and stateful operations,+as necessary to be able to write an evaluator.+-}++module FIR.AST.Type+  ( AugType(..), Eff, UnderlyingType+  , FunArgs, FunRes, FunTys, MkFunType, ApplyFun+  , Nullary, MapVal+  , ApplyFAug, MapApplyFAug+  )+  where++-- base+import Data.Kind+  ( Type )++-- fir+import Control.Monad.Indexed+  ( (:=) )+import {-# SOURCE #-} FIR.ProgramState+  ( ProgramState )++------------------------------------------------------------++infixr 0 :-->+-- | Types of values the AST can hold: concrete values (pure or effectful), and functions.+data AugType+  = Val Type+  | MkEff Type ProgramState ProgramState -- last parameter must be starting indexed monadic state (McBride formalism)+  | AugType :--> AugType++type Eff i j a = MkEff a j i++-- | Return the underlying type of an augmented type.+type family UnderlyingType ( t :: AugType ) :: Type where+  UnderlyingType (Val ty) = ty+  UnderlyingType (Eff i j a) = (a := j) i+  UnderlyingType (s :--> t) = UnderlyingType s -> UnderlyingType t++class    ( as ~ FunArgs t, b ~ FunRes t, t ~ MkFunType as b, Nullary b )+      => FunTys (t :: AugType) (as :: [AugType]) (b :: AugType) | t -> as b, as b -> t+instance ( as ~ FunArgs t, b ~ FunRes t, t ~ MkFunType as b, Nullary b )+      => FunTys t as b++-- | Returns list of arguments of an augmented type.+type family FunArgs (t :: AugType) :: [AugType] where+  FunArgs (Val _) = '[]+  FunArgs (Eff _ _ _) = '[]+  FunArgs (a :--> b) = a ': FunArgs b++type family FunRes (t :: AugType) :: AugType where+  FunRes (a :--> b) = FunRes b+  FunRes b          = b+type family MkFunType (as :: [AugType]) (b :: AugType) :: AugType where+  MkFunType '[]       b = b+  MkFunType (a ': as) b = a :--> MkFunType as b++class    ( FunArgs a ~ '[], FunRes a ~ a ) => Nullary a+instance ( FunArgs a ~ '[], FunRes a ~ a ) => Nullary a++type family ApplyFun (a :: AugType) (as :: [AugType]) :: AugType where+  ApplyFun a '[] = a+  ApplyFun (a :--> b) (a ': as) = ApplyFun b as++-- | Augment a list of types of values.+type family MapVal (ts :: [Type]) = (as :: [AugType]) | as -> ts where+  MapVal '[]       = '[]+  MapVal (t ': ts) = Val t ': MapVal ts++------------------------------------------------+-- Dealing with applying/unapplying functors.++-- | Apply a functor to an augmented type.+type family ApplyFAug (f :: Type -> Type) (t :: AugType) = ( r :: AugType ) | r -> f t where+  ApplyFAug f (Val a    ) = Val (f a)+  ApplyFAug f (a :--> b ) = ApplyFAug f a :--> ApplyFAug f b+  ApplyFAug f (Eff i j a) = Eff i j (f a)++type family MapApplyFAug (f :: Type -> Type) (fas :: [AugType]) :: [AugType] where+  MapApplyFAug _ '[] = '[]+  MapApplyFAug f ( Val a ': as ) = Val (f a) ': MapApplyFAug f as
+ src/FIR/Binding.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++{-|+Module: FIR.Binding++Keeping track of variable and function bindings at the type-level.+-}++module FIR.Binding+  ( Permission(Read,Write), Permissions+  , R, W, RW+  , Binding(Variable, Function)+  , Var, Fun+  , BindingsMap+  , FunctionType, FunctionAugType, FunArgTypes+  , StoragePermissions+  )+  where++-- base+import Data.Kind+  ( Type )+import GHC.TypeLits+  ( Symbol )+import GHC.TypeNats+  ( Nat )++-- fir+import Data.Type.Known+  ( Demotable(Demote), Known(known) )+import Data.Type.List+  ( Elem )+import Data.Type.Map+  ( (:->)((:->)), Map )+import FIR.AST.Type+  ( AugType(Val,(:-->)), UnderlyingType )+import qualified SPIRV.Decoration as SPIRV+  ( Decoration(NonReadable, NonWritable) )+import qualified SPIRV.Storage    as SPIRV++------------------------------------------------------------------------------------------------+-- bindings: variables, functions, images++data Permission = Read | Write+  deriving stock (Eq, Show)++type Permissions = [Permission]++instance Demotable Permission where+  type Demote Permission = Permission+instance Known Permission 'Read where+  known = Read+instance Known Permission 'Write where+  known = Write++type R  = '[ 'Read  ]+type W  = '[ 'Write ]+type RW = '[ 'Read, 'Write ]++-- | A binding consists of either:+--   * a variable of given type and permissions (readable/writable), or+--   * a function, with (named) arguments of given types, and given return type.+data Binding where+  Variable   :: Permissions -> Type -> Binding+  Function   :: [Symbol :-> Binding] -> Type -> Binding++-- shorthands+type Var ps a = 'Variable ps a+type Fun as b = 'Function as b++type BindingsMap = Map Symbol Binding++type FunctionType as b = UnderlyingType (FunctionAugType as b)++type family FunArgTypes (as :: BindingsMap) :: [Type] where+  FunArgTypes '[] = '[]+  FunArgTypes ((_ ':-> a) ': as) = UnderlyingType (BindingAugType a) ': FunArgTypes as++type family FunctionAugType (as :: BindingsMap) (b :: Type) :: AugType where+  FunctionAugType '[]                b = Val b+  FunctionAugType ((_ ':-> a) ': as) b = BindingAugType a :--> FunctionAugType as b++-- auxiliary type family (non-exported),+-- used only in the above 'FunctionType' type family+type family BindingAugType (bd :: Binding) :: AugType where+  BindingAugType (Var  _ a) = Val a+  BindingAugType (Fun as b) = FunctionAugType as b++------------------------------------------------------------------------------------------------+-- relation to SPIRV storage classes++type family StoragePermissions (storage :: SPIRV.StorageClass) (decs :: [SPIRV.Decoration Nat]) :: Permissions where+  StoragePermissions SPIRV.UniformConstant  _    = R+  StoragePermissions SPIRV.Input            _    = R+  StoragePermissions SPIRV.Uniform          _    = R+  StoragePermissions SPIRV.Output           _    = W+  StoragePermissions SPIRV.Workgroup        decs = PermissionsFromDecorations decs+  StoragePermissions SPIRV.CrossWorkgroup   decs = PermissionsFromDecorations decs+  StoragePermissions SPIRV.Private          decs = PermissionsFromDecorations decs+  StoragePermissions SPIRV.Function         _    = RW -- default value, specific functions can specialise this+  StoragePermissions SPIRV.Generic          decs = PermissionsFromDecorations decs+  StoragePermissions SPIRV.PushConstant     _    = R+  StoragePermissions SPIRV.AtomicCounter    decs = PermissionsFromDecorations decs+  StoragePermissions SPIRV.Image            decs = PermissionsFromDecorations decs+  StoragePermissions SPIRV.StorageBuffer    decs = PermissionsFromDecorations decs+  StoragePermissions ('SPIRV.RayStorage SPIRV.HitAttribute ) decs = RW+  StoragePermissions ('SPIRV.RayStorage SPIRV.ShaderRecordBuffer ) _ = R+  StoragePermissions ('SPIRV.RayStorage _ ) decs = PermissionsFromDecorations decs+++{-+TODO:+Variables with storage class HitAttribute:++They can be written to only in Intersection execution model,+and read from only in AnyHit and ClosestHit execution models.+-}++type family PermissionsFromDecorations (decs :: [SPIRV.Decoration Nat]) :: Permissions where+  PermissionsFromDecorations decs =+    PermissionsFromDecorations'+      ( SPIRV.NonReadable `Elem` decs )+      ( SPIRV.NonWritable `Elem` decs )++type family PermissionsFromDecorations' (nonReadable :: Bool) (nonWritable :: Bool) :: Permissions where+  PermissionsFromDecorations' True  True  = '[]+  PermissionsFromDecorations' True  False = W+  PermissionsFromDecorations' False True  = R+  PermissionsFromDecorations' False False = RW
+ src/FIR/Builtin.hs view
@@ -0,0 +1,339 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE PatternSynonyms      #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: FIR.Builtin++This module describes the built-in variables that are provided+for each execution model in SPIR-V.++For instance, in a vertex shader, one can always write position information+into the built-in variable named @gl_Position@, of type @V 4 Float@.+-}++module FIR.Builtin where++-- base+import Control.Arrow+  ( second )+import Data.Proxy+  ( Proxy )+import Data.Word+  ( Word32 )+import GHC.TypeLits+  ( Symbol )+import GHC.TypeNats+  ( Nat, SomeNat(SomeNat), someNatVal )++-- containers+import Data.Set+  ( Set )+import qualified Data.Set as Set++-- text-short+import Data.Text.Short+  ( ShortText )+import qualified Data.Text.Short as ShortText+  ( drop )++-- fir+import Data.Type.List+  ( type (:++:) )+import Data.Type.Map+  ( (:->)((:->))+  , InsertionSort+  )+import FIR.Binding+  ( Binding, BindingsMap, Var, R, W )+import FIR.Layout+  ( variableLayout )+import FIR.Prim.Array+  ( Array )+import FIR.Prim.Struct+  ( Struct )+import FIR.Prim.Types+  ( KnownInterface(knownInterface) )+import Math.Linear+  ( V, M )+import qualified SPIRV.Builtin       as SPIRV+  ( Builtin(TessLevelInner, TessLevelOuter)+  , readBuiltin+  )+import qualified SPIRV.Decoration    as SPIRV+  ( Decoration(Builtin, Patch, Flat), Decorations )+import qualified SPIRV.Layout        as SPIRV+  ( BlockKind(BuiltinBlock) )+import qualified SPIRV.PrimTy        as SPIRV+  ( PrimTy, PointerTy(PointerTy), scalars )+import qualified SPIRV.ScalarTy      as SPIRV+  ( ScalarTy(..), Width(W64) )+import qualified SPIRV.Storage       as SPIRV+  ( StorageClass(..) )+import SPIRV.Stage+  ( TessellationMode(..)+  , GeometryInputMode(..)+  , ShaderInfo(..)+  , ExecutionInfo(..)+  , VertexInfo+  , TessellationControlInfo+  , TessellationEvaluationInfo+  , GeometryInfo+  , FragmentInfo+  , ComputeInfo+  , RayShader(..), RayShaderInfo(..)+  )++import qualified SPIRV.Stage as SPIRV+  ( Backend(..), ExecutionModel(..), Stage(..), Shader(..) )+import qualified SPIRV.Capability as SPIRV++--------------------------------------------------------------------------++type ModelBuiltins (info :: ExecutionInfo Nat stage)+  = ( InsertionSort ( ModelBuiltins' info ) :: BindingsMap )++type family ModelBuiltins' (info :: ExecutionInfo Nat stage) :: [ Symbol :-> Binding ] where+  ModelBuiltins' VertexInfo+    = '[ "gl_VertexIndex"    ':-> Var R Word32+       , "gl_InstanceIndex"  ':-> Var R Word32+       , "gl_Position"       ':-> Var W ( V 4 Float )+       , "gl_PointSize"      ':-> Var W Float+       ]+  ModelBuiltins' (TessellationControlInfo inputSize outputSize _)+    = '[ "gl_InvocationID"   ':-> Var R Word32+       , "gl_PatchVertices"  ':-> Var R Word32+       , "gl_PrimitiveID"    ':-> Var R Word32+       , "gl_in"+            ':-> Var R+                  ( Array inputSize+                    ( Struct '[ "gl_Position"  ':-> V 4 Float+                              , "gl_PointSize" ':-> Float+                              ]+                    )+                  )+       , "gl_out"+            ':-> Var W+                  ( Array outputSize+                    ( Struct '[ "gl_Position"  ':-> V 4 Float+                              , "gl_PointSize" ':-> Float+                              ]+                    )+                  )+       , "gl_TessLevelOuter" ':-> Var W ( Array 4 Float )+       , "gl_TessLevelInner" ':-> Var W ( Array 2 Float )+       ]+  ModelBuiltins' (TessellationEvaluationInfo inputSize _)+    = '[ "gl_TessCoord"      ':-> Var R ( V 3 Float )+       , "gl_PatchVertices"  ':-> Var R Word32+       , "gl_PrimitiveID"    ':-> Var R Word32+       , "gl_in"+           ':-> Var R+                  ( Array inputSize+                    ( Struct '[ "gl_Position"  ':-> V 4 Float+                              , "gl_PointSize" ':-> Float+                              ]+                    )+                  )+       , "gl_Position"       ':-> Var W ( V 4 Float )+       , "gl_PointSize"      ':-> Var W Float+       ]+  ModelBuiltins' (GeometryInfo inputSize _)+    = '[ "gl_PrimitiveID"    ':-> Var R Word32+       , "gl_InvocationID"   ':-> Var R Word32+       , "gl_in"+           ':-> Var R+                  ( Array inputSize+                    ( Struct '[ "gl_Position"  ':-> V 4 Float+                              , "gl_PointSize" ':-> Float+                              ]+                    )+                  )+       , "gl_Position"       ':-> Var W ( V 4 Float )+       , "gl_PointSize"      ':-> Var W Float+       , "gl_Layer"          ':-> Var W Word32+       , "gl_ViewportIndex"  ':-> Var W Word32+       ]+  ModelBuiltins' FragmentInfo+    = '[ "gl_Layer"          ':-> Var R Word32+       , "gl_ViewportIndex"  ':-> Var R Word32+       , "gl_FragCoord"      ':-> Var R ( V 4 Float )+       , "gl_PointCoord"     ':-> Var R ( V 2 Float )+       , "gl_FrontFacing"    ':-> Var R Bool+       , "gl_SampleID"       ':-> Var R Word32+       , "gl_SamplePosition" ':-> Var R ( V 2 Float )+       , "gl_FragDepth"      ':-> Var W Float+       ]+  ModelBuiltins' ( ComputeInfo _ )+    = '[ "gl_NumWorkgroups"        ':-> Var R ( V 3 Word32 )+       , "gl_WorkgroupSize"        ':-> Var R ( V 3 Word32 )+       , "gl_WorkgroupID"          ':-> Var R ( V 3 Word32 )+       , "gl_LocalInvocationID"    ':-> Var R ( V 3 Word32 )+       , "gl_GlobalInvocationID"   ':-> Var R ( V 3 Word32 )+       , "gl_LocalInvocationIndex" ':-> Var R Word32+       , "gl_SubgroupInvocationID" ':-> Var R Word32+       , "gl_SubgroupID"           ':-> Var R Word32+       , "gl_SubgroupSize"         ':-> Var R Word32+       ]+  ModelBuiltins' ( KernelInfo _ )+    = '[ "cl_WorkDim"              ':-> Var R Word32+       , "cl_GlobalSize"           ':-> Var R (V 3 Word32)+       , "cl_GlobalInvocationID"   ':-> Var R (V 3 Word32)+       , "cl_LocalInvocationID"    ':-> Var R (V 3 Word32)+       , "cl_NumWorkgroups"        ':-> Var R (V 3 Word32)+       , "cl_WorkgroupID"          ':-> Var R (V 3 Word32)+       , "cl_GlobalOffset"         ':-> Var R (V 3 Word32)+       , "cl_GlobalLinearID"       ':-> Var R Word32+       , "cl_SubgroupInvocationID" ':-> Var R Word32+       , "cl_SubgroupID"           ':-> Var R Word32+       , "cl_SubgroupSize"         ':-> Var R Word32+       , "cl_SubgroupMaxSize"      ':-> Var R Word32+       ]+  ModelBuiltins' ( 'RayShaderInfo ( _ :: RayShaderInfo rayShader ) )+    = RayShaderBuiltins rayShader++type family RayShaderBuiltins ( shader :: RayShader ) :: [ Symbol :-> Binding ] where+  RayShaderBuiltins RayGenerationShader+    = '[ "gl_LaunchID"   ':-> Var R (V 3 Word32)+       , "gl_LaunchSize" ':-> Var R (V 3 Word32)+       ]+  RayShaderBuiltins IntersectionShader+    = '[ "gl_LaunchID"            ':-> Var R (V 3 Word32)+       , "gl_LaunchSize"          ':-> Var R (V 3 Word32)+       , "gl_PrimitiveID"         ':-> Var R Word32+       , "gl_InstanceID"          ':-> Var R Word32+       , "gl_InstanceCustomIndex" ':-> Var R Word32+       , "gl_GeometryIndex"       ':-> Var R Word32+       , "gl_WorldRayOrigin"      ':-> Var R (V 3 Float)+       , "gl_WorldRayDirection"   ':-> Var R (V 3 Float)+       , "gl_ObjectRayOrigin"     ':-> Var R (V 3 Float)+       , "gl_ObjectRayDirection"  ':-> Var R (V 3 Float)+       , "gl_RayTMin"             ':-> Var R Float+       , "gl_RayTMax"             ':-> Var R Float+       , "gl_IncomingRayFlags"    ':-> Var R Word32+       , "gl_ObjectToWorld"       ':-> Var R (M 3 4 Float)+       , "gl_WorldToObject"       ':-> Var R (M 3 4 Float)+       ]+  RayShaderBuiltins AnyHitShader = RayShaderBuiltins IntersectionShader :++:+      '[ "gl_HitKind" ':-> Var R Word32 ]+  RayShaderBuiltins ClosestHitShader = RayShaderBuiltins AnyHitShader+  RayShaderBuiltins MissShader+    = '[ "gl_LaunchID"            ':-> Var R (V 3 Word32)+       , "gl_LaunchSize"          ':-> Var R (V 3 Word32)+       , "gl_WorldRayOrigin"      ':-> Var R (V 3 Float)+       , "gl_WorldRayDirection"   ':-> Var R (V 3 Float)+       , "gl_RayTMin"             ':-> Var R Float+       , "gl_RayTMax"             ':-> Var R Float+       , "gl_IncomingRayFlags"    ':-> Var R Word32+       ]+  RayShaderBuiltins CallableShader+    = '[ "gl_LaunchID"            ':-> Var R (V 3 Word32)+       , "gl_LaunchSize"          ':-> Var R (V 3 Word32)+       ]++shaderBuiltins :: ShaderInfo Word32 shader -> [ (ShortText, SPIRV.PointerTy) ]+shaderBuiltins VertexShaderInfo+  = builtinPointer ( knownInterface @(ModelBuiltins' VertexInfo) )+shaderBuiltins (TessellationControlShaderInfo inputSize outputSize _)+  = case ( someNatVal (fromIntegral inputSize), someNatVal (fromIntegral outputSize) ) of+      ( SomeNat ( _ :: Proxy inputSize ), SomeNat ( _ :: Proxy outputSize ) )+        -> builtinPointer ( knownInterface @(ModelBuiltins' (TessellationControlInfo inputSize outputSize 'Nothing)) )+shaderBuiltins (TessellationEvaluationShaderInfo inputSize _)+  = case someNatVal (fromIntegral inputSize) of+      SomeNat ( _ :: Proxy inputSize )+        -> builtinPointer ( knownInterface @(ModelBuiltins' (TessellationEvaluationInfo inputSize 'ModeTriangles)) ) -- dummy mode that is not used+shaderBuiltins (GeometryShaderInfo inputSize _)+  = case someNatVal (fromIntegral inputSize) of+      SomeNat ( _ :: Proxy inputSize )+        -> builtinPointer ( knownInterface @(ModelBuiltins' (GeometryInfo inputSize 'InputModeTriangles)) ) -- another dummy+shaderBuiltins FragmentShaderInfo+  = builtinPointer ( knownInterface @(ModelBuiltins' FragmentInfo) )+shaderBuiltins (ComputeShaderInfo _)+  = builtinPointer ( knownInterface @(ModelBuiltins' (ComputeInfo '(1,1,1))) ) -- yet another++rayShaderBuiltins :: RayShaderInfo shader -> [ (ShortText, SPIRV.PointerTy) ]+rayShaderBuiltins RayGenerationShaderInfo = builtinPointer ( knownInterface @(RayShaderBuiltins RayGenerationShader) )+rayShaderBuiltins IntersectionShaderInfo  = builtinPointer ( knownInterface @(RayShaderBuiltins IntersectionShader) )+rayShaderBuiltins AnyHitShaderInfo        = builtinPointer ( knownInterface @(RayShaderBuiltins AnyHitShader) )+rayShaderBuiltins ClosestHitShaderInfo    = builtinPointer ( knownInterface @(RayShaderBuiltins ClosestHitShader) )+rayShaderBuiltins MissShaderInfo          = builtinPointer ( knownInterface @(RayShaderBuiltins MissShader) )+rayShaderBuiltins CallableShaderInfo      = builtinPointer ( knownInterface @(RayShaderBuiltins CallableShader) )++modelBuiltins :: ExecutionInfo Word32 model -> [ (ShortText, SPIRV.PointerTy) ]+modelBuiltins (ShaderExecutionInfo shaderInfo) = shaderBuiltins shaderInfo+modelBuiltins (KernelInfo _)+  = builtinPointer ( knownInterface @(ModelBuiltins' (KernelInfo '(1,1,1))) ) -- dummy again+modelBuiltins (RayShaderInfo rayInfo) = rayShaderBuiltins rayInfo++builtinPointer+    :: [ (ShortText, (SPIRV.PrimTy, SPIRV.StorageClass)) ]+    -> [ (ShortText, SPIRV.PointerTy) ]+builtinPointer = map+  ( second $ \ (ty, storage)+      -> SPIRV.PointerTy storage (variableLayout SPIRV.BuiltinBlock storage ty) ty+  )++--------------------------------------------------------------------------+-- decoration of builtins+-- slight indirection to account for complexities with 'gl_in', 'gl_out'+-- (that is, inputs/outputs that are given as arrays of structs)++-- | Decorations of a built-in variable, used in an entry point with the given execution model.+builtinDecorations :: SPIRV.ExecutionModel -> ShortText -> SPIRV.PointerTy -> SPIRV.Decorations+builtinDecorations model builtin ( SPIRV.PointerTy storage _ ty )+  = builtinNameDecorations builtin <> flat+  where+    -- Integer and double-precision fragment shader inputs must be decorated with 'Flat'.+    flat :: SPIRV.Decorations+    flat+      | model == SPIRV.Stage ( SPIRV.ShaderStage SPIRV.FragmentShader )+      , storage == SPIRV.Input+      , any needsFlat ( SPIRV.scalars ty )+      = Set.singleton SPIRV.Flat+      | otherwise+      = Set.empty+    needsFlat :: SPIRV.ScalarTy -> Bool+    needsFlat ( SPIRV.Integer {} )        = True+    needsFlat ( SPIRV.Floating SPIRV.W64 ) = True+    needsFlat _                           = False++builtinNameDecorations :: ShortText -> SPIRV.Decorations+builtinNameDecorations "gl_TessLevelInner"+  = Set.fromAscList [ SPIRV.Builtin SPIRV.TessLevelInner, SPIRV.Patch ]+builtinNameDecorations "gl_TessLevelOuter"+  = Set.fromAscList [ SPIRV.Builtin SPIRV.TessLevelOuter, SPIRV.Patch ]+builtinNameDecorations perVertex+  | perVertex `elem` [ "gl_in", "gl_out" ]+  -- workaround: in this case the 'Builtin' decoration is applied when we create the relevant struct+  = Set.empty+builtinNameDecorations builtin+  = maybe+      Set.empty+      ( Set.singleton . SPIRV.Builtin )+      ( SPIRV.readBuiltin builtin )++builtinCapabilities :: SPIRV.Backend -> ShortText -> Set SPIRV.Capability+builtinCapabilities bk builtinName+  | builtinName `elem` [ "gl_ClipDistance", "gl_CullDistance" ]+  = Set.singleton SPIRV.ClipDistance+  | builtinName `elem` [ "gl_SampleID", "gl_SamplePosition" ]+  = Set.singleton SPIRV.SampleRateShading+  | isSubgroupBuiltin ( ShortText.drop 3 builtinName )+  = case bk of+    SPIRV.Vulkan -> Set.singleton SPIRV.GroupNonUniform+    SPIRV.OpenCL -> Set.singleton SPIRV.ComputeKernel+  | otherwise+  = Set.empty++isSubgroupBuiltin :: ShortText -> Bool+isSubgroupBuiltin "SubgroupInvocationID" = True+isSubgroupBuiltin "SubgroupID"           = True+isSubgroupBuiltin "SubgroupSize"         = True+isSubgroupBuiltin "SubgroupMaxSize"      = True+isSubgroupBuiltin _                      = False
+ src/FIR/Definition.hs view
@@ -0,0 +1,508 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DerivingVia           #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++{-|+Module: FIR.Definition++In this module, a definition refers to a type-level annotation the user+can/must provide to describe the interface of a SPIR-V module.++For example, a typical fragment shader for mapping a texture could+declare the following definitions:++> type FragmentDefs =+>   '[ "in_colour"   ':-> Input      '[ Location 0 ]                 (V 4 Float)+>    , "in_uv"       ':-> Input      '[ Location 1 ]                 (V 2 Float)+>    , "texture"     ':-> Texture2D  '[ Binding 0, DescriptorSet 0 ] (RGBA8 UNorm)+>    , "out_colour"  ':-> Output     '[ Location 0 ]                 (V 4 Float)+>    , "main"        ':-> EntryPoint '[ OriginUpperLeft ]            Fragment+>    ]+>+> fragment :: ShaderModule "main" FragmentShader FragmentDefs _endState+> fragment = ...++There are three types of definitions:++  * global variables that belong to the interface (inputs, outputs, uniform constants such as textures, etc),+  * functions that are going to be defined,+  * entry points that are going to be defined.++In the above example all definitions are of the first kind,+save for the last definition which declares an entry point.++The definitions allow the user to specify, within a SPIR-V module, detailed information about the interface.++For instance, in the above example, the inputs/outputs are annotated with location information,+whereas the texture (a uniform constant) is annotated with its binding and descriptor set.+See "FIR.Layout" for further details concerning such annotations.++On the other hand, the execution model (in this case the fragment shader) is given its execution modes+(in this case, specifying that the origin for the coordinate system used by fragments is+in the upper-left corner).++See also "FIR.Validation.Definitions", which provides type families+used to validate user-provided definitions.+-}++module FIR.Definition where++-- base+import Data.Kind+  ( Type )+import GHC.Generics+  ( Generic )+import GHC.TypeLits+  ( Symbol+  , TypeError, ErrorMessage(..)+  )+import GHC.TypeNats+  ( Nat )++-- containers+import Data.Map+  ( Map )+import qualified Data.Map.Strict as Map+  ( toList )+import Data.Set+  ( Set )+import qualified Data.Set as Set+  ( fromList )++-- lens+import Control.Lens+  ( Lens', lens, at+  , set, over+  )++-- generic-monoid+import Data.Monoid.Generic+  ( GenericSemigroup(..), GenericMonoid(..) )++-- text-short+import Data.Text.Short+  ( ShortText )++-- fir+import CodeGen.State+  ( CGContext(..), emptyContext )+import Data.Type.Known+  ( Demotable(Demote), Known(known), knownValue )+import Data.Type.Map+  ( (:->)((:->))+  , Insert, Union+  , InsertWithInsert+  )+import FIR.Binding+  ( Binding(Variable), StoragePermissions )+import qualified FIR.Binding as Binding+  ( Binding(Function) )+import FIR.Layout+  ( variableLayout )+import FIR.Prim.Image+  ( Image, knownImage, ImageProperties )+import FIR.Prim.Types+  ( PrimTy, primTy )+import FIR.ProgramState+  ( ProgramState(ProgramState), CFGState(..)+  , Definedness(Declared)+  , FunctionInfo(FunctionInfo)+  , EntryPointInfo(EntryPointInfo), TLInterfaceVariable+  )+import qualified FIR.ProgramState as ProgramState+  ( FunctionContext(TopLevel) )+import FIR.Validation.Bindings+  ( InsertEntryPointInfo, EntryPointsBackend )+import FIR.Validation.ExecutionModes+  ( ValidateExecutionModes )+import qualified SPIRV.Capability    as SPIRV+  ( Capability )+import qualified SPIRV.Control       as SPIRV+  ( FunctionControl )+import qualified SPIRV.Decoration    as SPIRV+  ( Decoration, Decorations )+import qualified SPIRV.ExecutionMode as SPIRV+  ( ExecutionMode, ExecutionModes )+import qualified SPIRV.Extension     as SPIRV+  ( Extension )+import qualified SPIRV.Image         as SPIRV+  ( Image(imageUsage), ImageUsage(Sampled) )+import qualified SPIRV.Layout        as SPIRV+  ( BlockKind(UserBlock) )+import qualified SPIRV.PrimTy        as SPIRV+  ( PrimTy(Image, SampledImage)+  , PointerTy(PointerTy)+  )+import qualified SPIRV.Requirements  as SPIRV+  ( globalCapabilities, globalExtensions+  , executionModelCapabilities, executionModelExtensions+  )+import qualified SPIRV.Stage         as SPIRV+  ( ExecutionModel, ExecutionInfo, Backend(..), backendOf )+import qualified SPIRV.Storage       as SPIRV+  ( StorageClass )+import qualified SPIRV.Version       as SPIRV+  ( Version(..) )++--------------------------------------------------------------------------+-- annotating top-level definitions with necessary information+-- for instance, annotating layout information++-- | Definitions are top-level type-level annotations which provide+-- the necessary information for a SPIR-V module.+data Definition where+  Global     :: SPIRV.StorageClass -> [ SPIRV.Decoration Nat ] -> Type -> Definition+  Function   :: SPIRV.FunctionControl -> [Symbol :-> Binding] -> Type -> Definition+  EntryPoint :: [ SPIRV.ExecutionMode Nat ] -> SPIRV.ExecutionModel -> Definition++data Annotate+  = AnnotateGlobal     ( SPIRV.PointerTy, SPIRV.Decorations )+  | AnnotateFunction   SPIRV.FunctionControl+  | AnnotateEntryPoint ( SPIRV.ExecutionModel, SPIRV.ExecutionModes )++data Annotations+  = Annotations+    { globalAnnotations      :: Map  ShortText                        ( SPIRV.PointerTy, SPIRV.Decorations )+    , functionAnnotations    :: Map  ShortText                        SPIRV.FunctionControl+    , executionAnnotations   :: Map (ShortText, SPIRV.ExecutionModel) SPIRV.ExecutionModes+    , annotationCapabilities :: Set                                   SPIRV.Capability+    , annotationExtensions   :: Set                                   SPIRV.Extension+    }+  deriving stock (Show, Eq, Generic)+  deriving Semigroup via GenericSemigroup Annotations+  deriving Monoid    via GenericMonoid    Annotations++_globalAnnotations :: Lens' Annotations (Map ShortText (SPIRV.PointerTy, SPIRV.Decorations))+_globalAnnotations = lens globalAnnotations ( \anns v -> anns { globalAnnotations = v } )++_globalAnnotation :: ShortText -> Lens' Annotations (Maybe (SPIRV.PointerTy, SPIRV.Decorations))+_globalAnnotation name = _globalAnnotations . at name++_functionAnnotations :: Lens' Annotations (Map ShortText SPIRV.FunctionControl)+_functionAnnotations = lens functionAnnotations ( \anns v -> anns { functionAnnotations = v } )++_functionAnnotation :: ShortText -> Lens' Annotations (Maybe SPIRV.FunctionControl)+_functionAnnotation name = _functionAnnotations . at name++_executionAnnotations :: Lens' Annotations (Map (ShortText, SPIRV.ExecutionModel) SPIRV.ExecutionModes)+_executionAnnotations = lens executionAnnotations ( \anns v -> anns { executionAnnotations = v } )++_executionAnnotation+  :: ShortText -> SPIRV.ExecutionModel+  -> Lens' Annotations (Maybe SPIRV.ExecutionModes)+_executionAnnotation name em = _executionAnnotations . at (name, em)++_annotationCapabilities :: Lens' Annotations (Set SPIRV.Capability)+_annotationCapabilities = lens annotationCapabilities ( \anns v -> anns { annotationCapabilities = v } )++_annotationExtensions :: Lens' Annotations (Set SPIRV.Extension)+_annotationExtensions = lens annotationExtensions ( \anns v -> anns { annotationExtensions = v } )++--------------------------------------------------------------------------+-- reification of type-level definitions/annotations++initialCGContext :: forall defs. KnownDefinitions defs => CGContext+initialCGContext =+  let Annotations {..} = annotations @defs+      bk = entryPointsBackend executionAnnotations+  in  emptyContext+        { userGlobals      = globalAnnotations+        , userFunctions    = functionAnnotations+        , userEntryPoints  = executionAnnotations+        , userCapabilities = annotationCapabilities+        , userExtensions   = annotationExtensions+        , backend          = bk+        , spirvVersion     = defaultSPIRVVersion bk+        }++-- | Default SPIR-V version for a backend.+defaultSPIRVVersion :: SPIRV.Backend -> SPIRV.Version+defaultSPIRVVersion SPIRV.Vulkan = SPIRV.Version 1 5+defaultSPIRVVersion SPIRV.OpenCL = SPIRV.Version 1 2++entryPointsBackend :: Map (ShortText, SPIRV.ExecutionModel) SPIRV.ExecutionModes -> SPIRV.Backend+entryPointsBackend eps = case Map.toList eps of+  [] -> error "internal error: empty list of entry points"+  ( ( (_, em), _ ) : _ ) -> SPIRV.backendOf em++instance Demotable Definition where+  type Demote Definition = Annotate++-- workaround for image types being opaque and not having a Haskell-level counterpart+instance {-# OVERLAPPING #-}+         ( Known ImageProperties        props+         , Known SPIRV.StorageClass     storage+         , Known [SPIRV.Decoration Nat] decs+         )+      => Known Definition ('Global storage decs (Image props))+      where+  known = AnnotateGlobal+    ( globalPointer ( knownValue @storage ) imgTy+    , Set.fromList    ( knownValue @decs    )+    )+        where imgTy :: SPIRV.PrimTy+              imgTy = case knownImage @props of+                        img -> case SPIRV.imageUsage img of+                                Just SPIRV.Sampled -> SPIRV.SampledImage img+                                _                  -> SPIRV.Image        img++instance ( PrimTy ty, Known SPIRV.StorageClass storage, Known [SPIRV.Decoration Nat] decs )+      => Known Definition ('Global storage decs ty)+      where+  known = AnnotateGlobal+    ( globalPointer ( knownValue @storage ) ( primTy @ty )+    , Set.fromList    ( knownValue @decs    )+    )++-- | The pointer type of a user-defined global variable.+globalPointer :: SPIRV.StorageClass -> SPIRV.PrimTy -> SPIRV.PointerTy+globalPointer storage ty = SPIRV.PointerTy storage ( variableLayout SPIRV.UserBlock storage ty ) ty++instance Known SPIRV.FunctionControl control+      => Known Definition ('Function control args res)+      where+  known = AnnotateFunction ( knownValue @control )++instance ( Known SPIRV.ExecutionModel stage, Known [SPIRV.ExecutionMode Nat] modes )+      => Known Definition ('EntryPoint modes stage)+      where+  known = AnnotateEntryPoint+            ( knownValue @stage+            , Set.fromList ( knownValue @modes )+            )++class KnownDefinitions (defs :: [ Symbol :-> Definition ]) where+  annotations :: Annotations++instance KnownDefinitions '[] where+  annotations = mempty++instance ( Known Symbol k, Known Definition def, KnownDefinitions defs)+      => KnownDefinitions ((k ':-> def) ': defs)+      where+  annotations+    = let anns = annotations @defs+          k    = knownValue @k+      in case knownValue @def of+           AnnotateGlobal     x@(SPIRV.PointerTy _ _ ty, _)+             -> set ( _globalAnnotation    k  ) (Just x)+              . over _annotationCapabilities    (SPIRV.globalCapabilities ty <>)+              . over _annotationExtensions      (SPIRV.globalExtensions   ty <>)+              $ anns+           AnnotateFunction   x+             -> set ( _functionAnnotation  k  ) (Just x) anns+           AnnotateEntryPoint (s, x)+             -> set ( _executionAnnotation k s) (Just x)+              . over _annotationCapabilities    (SPIRV.executionModelCapabilities s <>)+              . over _annotationExtensions      (SPIRV.executionModelExtensions   s <>)+              $ anns++--------------------------------------------------------------------------+-- computing type-level states from type-level definitions++type Definitions = [ Symbol :-> Definition ]+-- recall:+-- type TLInterfaceVariable = ( [SPIRV.Decoration Nat], Type )+type TriagedDefinitions =+  ( [ Symbol :-> FunctionInfo ]+  , [ Symbol :-> (SPIRV.ExecutionModel, [ SPIRV.ExecutionMode Nat ]) ]+  , [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ]+  )++-- | Computes the starting indexed monadic state, from user-supplied+-- list of top level 'Definition's.+--+-- Performs a limited amount of validation:+--+--  * Checks there are no duplicate declarations.+--  * Validates entry point execution modes.+--+-- Validation of global variables (and their layout) is done separately,+-- see "FIR.Module".+type StartState (defs :: Definitions)+  = ( StartStateFromTriage ( TrieDefinitions defs ) :: ProgramState )++-- | Helper computation of the starting indexed monadic state, from triaged definitions.+--+--   * The insertion sorts will throw an error if there are duplicates.+--   * The computation of entry point infos performs validation of entry points.+--   * Validation of bindings is done separately, see "FIR.Module".+type family StartStateFromTriage+              ( triaged :: TriagedDefinitions )+            :: ProgramState where+  StartStateFromTriage '( funs, eps, globals )+    = 'ProgramState+        ( InsertionSortGlobals globals ) -- checks for duplicate globals+        ProgramState.TopLevel+        ( 'CFGState 0 )+        funs+        ( EntryPointInfos globals eps )  -- validates entry points and checks for duplicates+        globals+        '[]                              -- no ray queries have been started+        ( EntryPointsBackend eps )++-- | Perform triage of user-supplied definitions,+-- so that different kinds of definition can be handled separately.+type family TrieDefinitions ( defs :: Definitions ) :: TriagedDefinitions where+  TrieDefinitions '[] = '( '[], '[], '[] )+  TrieDefinitions+    ( ( k ':-> Global storage decs ty ) ': defs )+    = TrieInsertGlobal k storage '(decs, ty) (TrieDefinitions defs)+  TrieDefinitions+    ( ( k ':-> Function fc as b ) ': defs )+    = TrieInsertFunctionInfo k ('FunctionInfo as b fc 'Declared) (TrieDefinitions defs)+  TrieDefinitions+    ( ( k ':-> EntryPoint modes em ) ': defs )+    = TrieAddEntryPoint k '(em, modes) (TrieDefinitions defs)+    -- in this case, insertion sorting (including duplicate checking)+    -- happens later (after computing entry point infos)++type family TrieInsertGlobal+              ( k :: Symbol )+              ( storage :: SPIRV.StorageClass  )+              ( global  :: TLInterfaceVariable )+              ( triaged :: TriagedDefinitions  )+            :: TriagedDefinitions+            where+  TrieInsertGlobal k storage glob '( funs, eps, globs )+    = '( funs, eps, InsertGlobal k storage glob globs )++type family InsertGlobal+              ( k :: Symbol )+              ( storage :: SPIRV.StorageClass )+              ( global  :: TLInterfaceVariable )+              ( globals :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] )+            :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ]+            where+  InsertGlobal k storage global '[] = '[ storage ':-> '[ k ':-> global ] ]+  InsertGlobal k storage global+    ( (storage ':-> globals ) ': others )+    = ( storage ':-> Insert k global globals ) ': others+  InsertGlobal k storage global ( others ': globals )+    = others ': InsertGlobal k storage global globals++type family TrieInsertFunctionInfo+              ( k :: Symbol )+              ( nfo :: FunctionInfo )+              ( triaged :: TriagedDefinitions )+            :: TriagedDefinitions+            where+  TrieInsertFunctionInfo k nfo '( funs, eps, globs )+    = '( Insert k nfo funs, eps, globs )++type family TrieAddEntryPoint+              ( k :: Symbol )+              ( ep :: ( SPIRV.ExecutionModel, [SPIRV.ExecutionMode Nat] ) )+              ( triaged :: TriagedDefinitions )+            :: TriagedDefinitions+            where+  TrieAddEntryPoint k ep '( funs, eps, globs )+    = '( funs, ( k ':-> ep) ': eps, globs )++type family EntryPointInfos+              ( globals :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] )+              ( entryPoints :: [ Symbol :-> (SPIRV.ExecutionModel, [ SPIRV.ExecutionMode Nat ]) ] )+            :: [ Symbol :-> EntryPointInfo ]+            where+  EntryPointInfos _       '[] = '[]+  EntryPointInfos globals ( ( k ':-> '( em, modes ) ) ': eps )+    = InsertMaybeEntryPointInfo k globals+        ( ValidateExecutionModes k em modes )+        ( EntryPointInfos globals eps )++type family DefinitionFunctions+              ( defs :: [ Symbol :-> Definition ] )+              :: [Symbol :-> FunctionInfo]+              where+  DefinitionFunctions '[] = '[]+  DefinitionFunctions ( (k ':-> Function fc as b) ': defs )+    = Insert k ('FunctionInfo as b fc Declared) (DefinitionFunctions defs)+  DefinitionFunctions ( _ ': defs ) -- not a function+    = DefinitionFunctions defs+++type family InsertMaybeEntryPointInfo+              ( k    :: Symbol                                )+              ( globals :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] )+              ( nfo  :: Maybe (SPIRV.ExecutionInfo Nat stage) )+              ( nfos :: [ Symbol :-> EntryPointInfo ]         )+              :: [ Symbol :-> EntryPointInfo ]+              where+  InsertMaybeEntryPointInfo _ _ 'Nothing _+  -- 'ValidateExecutionModes' never returns Nothing, it throws a type error instead+  -- this trick forces evaluation of 'ValidateExecutionModes'+  -- ( this fixes [issue #43](https://gitlab.com/sheaf/fir/issues/43) )+    = TypeError ( Text "Invalid entry point execution modes (unreachable)" )+  InsertMaybeEntryPointInfo k globals ('Just nfo) nfos+    = InsertEntryPointInfo k+        ( 'EntryPointInfo nfo globals 'Declared )+        nfos++-- | Grabs the variables in the given definition.+--+-- This is a workaround for the fact that shader interfaces are not kept track of+-- at the type level.+-- This is permissible as long as the interface for the entry-point consists precisely+-- of the 'Input'/'Output' variables provided in the top-level annotation.+-- See [FIR issue #51](https://gitlab.com/sheaf/fir/issues/51).+type family Variables+              ( defs :: [Symbol :-> Definition] )+            :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ]+            where+  Variables '[] = '[]+  Variables ( ( varName ':-> Global storage decs ty) ': defs )+    = InsertWithInsert storage varName '(decs,ty) ( Variables defs )+  Variables ( _ ': defs ) = Variables defs+++type family InsertionSortGlobals+               ( globals :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] )+            :: [ Symbol :-> Binding ]+            where+  InsertionSortGlobals '[] = '[]+  InsertionSortGlobals ( ( storage ':-> globals ) ': others )+    = Union ( InsertionSortGlobalsWith storage globals ) ( InsertionSortGlobals others )++type family InsertionSortGlobalsWith+              ( storage :: SPIRV.StorageClass )+              ( globals :: [ Symbol :-> TLInterfaceVariable ] )+            :: [ Symbol :-> Binding ]+            where+  InsertionSortGlobalsWith _ '[] = '[]+  InsertionSortGlobalsWith storage ( ( k ':-> '( decs, ty ) ) ': globals )+    = Insert k+        ( Variable (StoragePermissions storage decs) ty )+        ( InsertionSortGlobalsWith storage globals )+++type family StartBindings (defs :: [ Symbol :-> Definition ]) :: [ Symbol :-> Binding ] where+  StartBindings '[]+    = '[]+  StartBindings ((k ':-> Global storage decs ty) ': defs)+    = Insert k (Variable (StoragePermissions storage decs) ty) (StartBindings defs)+  ---- ^^^^^ TODO: we probably don't want to add all of these storage classes to the list of bindings?+  StartBindings ((k ':-> _) ': defs)+    = StartBindings defs++type family EndBindings (defs :: [ Symbol :-> Definition ]) :: [ Symbol :-> Binding ] where+  EndBindings '[]+    = '[]+  EndBindings ((k ':-> Global storage decs ty) ': defs)+    = Insert k (Variable (StoragePermissions storage decs) ty) (EndBindings defs)+  EndBindings ((k ':-> Function _ as b) ': defs)+    = Insert k (Binding.Function as b) (EndBindings defs)+  EndBindings (_ ': defs)+    = EndBindings defs
+ src/FIR/Generics.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE AllowAmbiguousTypes      #-}+{-# LANGUAGE DataKinds                #-}+{-# LANGUAGE DeriveAnyClass           #-}+{-# LANGUAGE DeriveGeneric            #-}+{-# LANGUAGE DerivingVia              #-}+{-# LANGUAGE FlexibleContexts         #-}+{-# LANGUAGE FlexibleInstances        #-}+{-# LANGUAGE GADTs                    #-}+{-# LANGUAGE InstanceSigs             #-}+{-# LANGUAGE MultiParamTypeClasses    #-}+{-# LANGUAGE PatternSynonyms          #-}+{-# LANGUAGE PolyKinds                #-}+{-# LANGUAGE ScopedTypeVariables      #-}+{-# LANGUAGE StandaloneDeriving       #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications         #-}+{-# LANGUAGE TypeFamilies             #-}+{-# LANGUAGE TypeOperators            #-}+{-# LANGUAGE UndecidableInstances     #-}+module FIR.Generics (FromGenericProduct(..)) where++-- base+import Prelude+  hiding ( undefined )+import Data.Typeable+import Data.Kind+  ( Type )+import GHC.TypeLits ( Symbol, KnownSymbol )++-- variant+import Data.Variant.EGADT+  ( pattern VF )++-- fir+import Data.Type.Map++import FIR.AST.Prim+import FIR.AST.Type++import FIR.Prim.Struct+import FIR.Prim.Types+  ( PrimTyMap )++import FIR.AST++-- generics-sop+import Generics.SOP (NP(..), I(..), K(..))+import qualified Generics.SOP as SOP++------------------------------------------------+-- Generic deriving for Syntactic++-- | Newtype to automatically derive Syntactic for instances generically for product types.+--+-- Example+--+-- @+-- data MinMax = MinMax Float Float+--   deriving (GHC.Generic, SOP.Generic)+--   deriving Syntactic via (FromGenericProduct MinMax ["min", "max"])+-- @+type FromGenericProduct :: Type -> [Symbol] -> Type+newtype FromGenericProduct t xs = FromGenericProduct t++instance forall (t :: Type) (ts :: [Type]) (xs :: [Symbol]) (zgs :: [Symbol :-> Type]) (zgs' :: [Symbol :-> Type]).+         ( SOP.IsProductType t ts++         , zgs  ~ ZipGenericSyntactic  xs ts+         , zgs' ~ ZipGenericSyntactic' xs ts++         , PrimTyMap zgs++         , ASTStructFields AST zgs' zgs+         , StructFResultFromArgs zgs' ~ zgs+         , StructFArgsFromResult zgs AST ~ zgs'++         , SOP.AllZip SyntacticRel xs ts+         , SOP.All Typeable ts+         , SOP.All KnownSymbol xs+         ) => Syntactic (FromGenericProduct t xs) where+  type Internal (FromGenericProduct t xs) = Val (Struct (ZipGenericSyntactic xs (SOP.ProductCode t)))++  toAST :: FromGenericProduct t xs -> AST (Val (Struct (ZipGenericSyntactic xs ts)))+  toAST (FromGenericProduct a)+    = Struct (npToStruct (mkNP @xs) (SOP.productTypeFrom a))+    where+      npToStruct :: forall ns ys+                  . (SOP.AllZip SyntacticRel ns ys)+                 => NP (K ()) ns+                 -> NP I ys+                 -> Struct (ZipGenericSyntactic' ns ys)+      npToStruct Nil   Nil = End+      npToStruct (_ SOP.:* xs) (SOP.I y SOP.:* ys) = toAST y :& npToStruct xs ys++  fromAST :: AST (Val (Struct (ZipGenericSyntactic xs ts))) -> FromGenericProduct t xs+  fromAST (VF (StructF struct)) = FromGenericProduct $+    SOP.productTypeTo @t (structToNp (mkNP @xs) struct)+    where+      structToNp :: forall (ns :: [Symbol]) ys+                  . ( SOP.AllZip SyntacticRel ns ys )+                 => NP (K ()) ns+                 -> Struct (ZipGenericSyntactic' ns ys)+                 -> NP I ys+      structToNp Nil End = Nil+      structToNp ((_ :: (K () (n :: Symbol))) :* xs) (y :& ys)+        = I (fromAST y) :* structToNp xs ys+  fromAST _ = error "impossible"++mkNP :: forall ns. SOP.SListI ns => NP (K ()) ns+mkNP = case SOP.sList @ns of+  SOP.SNil -> Nil+  SOP.SCons -> K () SOP.:* mkNP++type family ZipGenericSyntactic (xs :: [Symbol]) (ys :: [Type]) where+  ZipGenericSyntactic '[] '[] = '[]+  ZipGenericSyntactic (x : xs) (y : ys) = (x ':-> InternalType y) : ZipGenericSyntactic xs ys++type family ZipGenericSyntactic' (xs :: [Symbol]) (ys :: [Type]) where+  ZipGenericSyntactic' '[] '[] = '[]+  ZipGenericSyntactic' (x : xs) (y : ys) = (x ':-> AST (Val y)) : ZipGenericSyntactic' xs ys++class (Val y ~ Internal y, Syntactic y) => SyntacticRel x y+instance (Val y ~ Internal y, Syntactic y) => SyntacticRel x y+
+ src/FIR/Layout.hs view
@@ -0,0 +1,812 @@+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise -fconstraint-solver-iterations=8 #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}++{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} -- for some reason this needs to be bumped with GHC 9.14++{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++{-|+Module: FIR.Layout++This module is concerned with the memory layout of types for use with Vulkan.+There are three different situations one needs to account for:++  - uniform buffers must form a struct or array of structs,+  laid out according to the Extended alignment rules,+  - push constants and storage buffers must form a struct or array of structs,+  laid out according to the Base alignment rules,+  - vertex input data is specified with Location and Component information.++This module automatically performs layout of types according to the above rules.+See also "FIR.Validation.Layout", which performs validation of user-supplied layouts.++In the first two situations above, the shader that makes use of such structs+must provide explicit Offset and Stride decorations. These offsets+are computed by this module to avoid the user needing to manually specify them.++In the last situation, per-vertex/per-instance data is laid out in locations,+for use by the vertex shader. See "FIR.Validation.Layout".++For further reference, see:++  - SPIR-V specification, 2.16.2 "Validation Rules for Shader Capabilities", bullet point 3,+  - SPIR-V specification, 2.18.1 "Memory Layout",+  - Vulkan specification, 14.1.4 "Location Assignment", and 14.1.5 "Component Assignment",+  - Vulkan specification, 14.5.2 "Descriptor Set Interface", and 14.5.4 "Offset and Stride Assignment".++-}++module FIR.Layout+  ( Layout(..), Components+  , Poke(..), pokeArrayOff, pokeArray+  , MemberOffset, memberOffset+  , variableLayout+  , arrayStride, memberLayoutDecorations+  , roundUp, nextAligned+  )+  where++-- base+import Control.Monad+  ( foldM_ )+import Data.Int+  ( Int8, Int16, Int32, Int64 )+import Data.Kind+  ( Type )+import Data.Maybe+  ( isJust )+import Data.Proxy+  ( Proxy(..) )+import Data.Type.Equality+  ( (:~:)(Refl) )+import Data.Word+  ( Word8, Word16, Word32, Word64 )+import Foreign.Ptr+  ( Ptr, castPtr, plusPtr )+import qualified Foreign.Storable as Storable+  ( poke )+import GHC.TypeLits+  ( Symbol, SomeSymbol(..)+  , TypeError, ErrorMessage(..)+  , someSymbolVal+  )+import GHC.TypeNats+  ( Nat, KnownNat, SomeNat(..)+  , type (<=), type (<=?), type (+), type (*)+  , Div+  , someNatVal+  )+import Numeric.Natural+  ( Natural )+import Unsafe.Coerce+  ( unsafeCoerce )++-- containers+import qualified Data.Set as Set+  ( empty, fromList, insert )++-- half+import Numeric.Half+  ( Half, fromHalf )++-- mtl+import Control.Monad.Except+  ( MonadError, throwError )++-- text-short+import Data.Text.Short+  ( ShortText )+import qualified Data.Text.Short as ShortText+  ( pack )++-- fir+import Data.Constraint.All+  ( AllDict(ConsDict)+  , All(allDict)+  )+import Data.Type.Known+  ( Known, knownValue )+import Data.Type.Map+  ( (:->)((:->)), Value )+import Data.Type.Nat+  ( NextPositivePowerOf2, RoundUp )+import Data.Type.POrd+  ( POrd(Max) )+import FIR.Prim.Array+  ( Array(..) )+import FIR.Prim.RayTracing+  ( AccelerationStructure(..) )+import FIR.Prim.Struct+  ( Struct(..)+  , LocationSlot(LocationSlot)+  , FieldKind(..)+  , StructFieldKind(fieldKind)+  )+import FIR.Prim.Types+  ( ScalarTy, PrimTyMap(..), SPrimTyMap(..)+  , SPrimTy(..)+  , primTySing+  )+import qualified FIR.Prim.Types as Prim+  ( PrimTy )+import Math.Algebra.Class+  ( AdditiveGroup, Semiring )+import Math.Linear+  ( V, M(unM) )+import qualified SPIRV.Decoration as SPIRV+import qualified SPIRV.Layout     as SPIRV+import qualified SPIRV.PrimTy     as SPIRV+import           SPIRV.PrimTy+  ( PrimTy(..) ) -- field accessors for named field puns+import qualified SPIRV.ScalarTy   as SPIRV+import qualified SPIRV.Storage    as SPIRV+  ( StorageClass )+import qualified SPIRV.Storage    as Storage++--------------------------------------------------------------------------------------------++-- | Specification of alignment requirements.+data Layout+  = Base      -- ^ Layout used for storage buffers and push constants.+  | Extended  -- ^ Layout used for uniform buffers.+  | Locations -- ^ Layout used for vertex binding input data.+  deriving stock ( Eq, Show )++-- | Type-class for data that can be stored in memory,+-- following the specified alignment requirements.+class ( KnownNat (SizeOf    lay a)+      , KnownNat (Alignment lay a)+      ) => Poke a (lay :: Layout) where++  type SizeOf lay a :: Nat+  sizeOf :: Word32+  sizeOf = knownValue @(SizeOf lay a)++  type Alignment lay a :: Nat+  alignment :: Word32+  alignment = knownValue @(Alignment lay a)++  poke :: Ptr a -> a -> IO ()++type Components a = ( SizeOf Locations a `Div` 4 :: Nat )++type family SumRoundedUpSizes (lay :: Layout) (as :: [fld :-> Type]) (acc :: Nat) :: Nat where+  SumRoundedUpSizes _   '[]                    acc = acc+  SumRoundedUpSizes lay ( ( _ ':-> a ) ': as ) acc = SumRoundedUpSizes lay as ( ( acc `RoundUp` Alignment lay a ) + SizeOf lay a )++-- | The offset, in bytes, of a member of a structure, in a layout.+type family MemberOffset (lay :: Layout) (k :: Symbol) (struct :: Type) :: Nat where+  MemberOffset lay k ( Struct as ) = MemberOffsetFrom lay k as 0++type family MemberOffsetFrom (lay :: Layout) (k :: Symbol) (as :: [Symbol :-> Type]) (acc :: Nat) :: Nat where+  MemberOffsetFrom lay k ( ( k ':-> a ) ': _  ) acc =+    acc `RoundUp` Alignment lay a+  MemberOffsetFrom lay k ( ( _ ':-> a ) ': as ) acc =+    MemberOffsetFrom lay k as ( ( acc `RoundUp` Alignment lay a ) + SizeOf lay a )+  MemberOffsetFrom _   k '[]                    _   =+    TypeError ( Text "No structure member named " :<>: ShowType k :<>: Text "." )++-- | 'MemberOffset', as a value.+memberOffset+  :: forall lay k struct. KnownNat ( MemberOffset lay k struct ) => Word32+memberOffset = knownValue @( MemberOffset lay k struct )++type family MaximumAlignment (lay :: Layout) (as :: [fld :-> Type]) :: Nat where+  MaximumAlignment _   '[]                    = 1+  MaximumAlignment lay ( ( _ ':-> a ) ': as ) = Max ( Alignment lay a ) ( MaximumAlignment lay as )++roundUp :: Integral a => a -> a -> a+roundUp n r = (n + r) - ( 1 + ( (n + r - 1) `mod` r ) )++-- | Write elements to an array, whose start is given by a pointer.+pokeArray :: forall a lay. ( Poke a lay, Poke (Array 1 a) lay ) => Ptr a -> [a] -> IO ()+pokeArray ptr = pokeArrayOff @a @lay ptr 0++-- | Write elements to an array, starting from the given index offset.+pokeArrayOff :: forall a lay. ( Poke a lay, Poke (Array 1 a) lay ) => Ptr a -> Int -> [a] -> IO ()+pokeArrayOff ptr off vals0+  | off < 0   = pure ()+  | otherwise = go ( ptr `plusPtr` ( sz * off ) ) vals0+  where+    sz :: Int+    sz = fromIntegral $ nextAligned (sizeOf @a @lay) (alignment @(Array 1 a) @lay)+    go :: Ptr a -> [a] -> IO ()+    go _    []         = pure ()+    go ptr' (val:vals) = do+      poke @a @lay ptr' val+      go ( ptr' `plusPtr` sz ) vals++nextAligned :: Integral a => a -> a -> a+nextAligned size ali+  = case size `mod` ali of+         0 -> size+         x -> size + ali - x++instance Poke Word8 lay where+  type SizeOf    lay Word8 = 4+  type Alignment lay Word8 = 4+  poke ptr = Storable.poke (castPtr @_ @Word32 ptr) . fromIntegral++instance Poke Word16 lay where+  type SizeOf    lay Word16 = 4+  type Alignment lay Word16 = 4+  poke ptr = Storable.poke (castPtr @_ @Word32 ptr) . fromIntegral++instance Poke Word32 lay where+  type SizeOf    lay Word32 = 4+  type Alignment lay Word32 = 4+  poke = Storable.poke++instance Poke Word64 lay where+  type SizeOf    lay Word64 = 8+  type Alignment lay Word64 = 8+  poke = Storable.poke++instance Poke Int8 lay where+  type SizeOf    lay Int8 = 4+  type Alignment lay Int8 = 4+  poke ptr = Storable.poke (castPtr @_ @Int32 ptr) . fromIntegral++instance Poke Int16 lay where+  type SizeOf    lay Int16 = 4+  type Alignment lay Int16 = 4+  poke ptr = Storable.poke (castPtr @_ @Int32 ptr) . fromIntegral++instance Poke Int32 lay where+  type SizeOf    lay Int32 = 4+  type Alignment lay Int32 = 4+  poke = Storable.poke++instance Poke Int64 lay where+  type SizeOf    lay Int64 = 4+  type Alignment lay Int64 = 4+  poke = Storable.poke++instance Poke Half lay where+  type SizeOf    lay Half = 4+  type Alignment lay Half = 4+  poke ptr = Storable.poke (castPtr @_ @Float ptr) . fromHalf++instance Poke Float lay where+  type SizeOf    lay Float = 4+  type Alignment lay Float = 4+  poke = Storable.poke++instance Poke Double lay where+  type SizeOf    lay Double = 8+  type Alignment lay Double = 8+  poke = Storable.poke++instance TypeError ( Text "Cannot store Boolean types." ) => Poke Bool lay where+  type SizeOf    lay Bool = 4+  type Alignment lay Bool = 4+  poke = error "unreachable"++-- Acceleration structures are just represented as Word64 address+instance Poke AccelerationStructure lay where+  type SizeOf    lay AccelerationStructure = 8+  type Alignment lay AccelerationStructure = 8+  poke ptr ( AccelerationStructureFromWord64 word64 ) = poke @Word64 @lay ( castPtr ptr ) word64++instance ( Poke a lay+         , ScalarTy a+         , KnownNat n, 1 <= n+         , KnownNat (SizeOf lay (V n a))+         , KnownNat (Alignment lay (V n a))+         ) => Poke (V n a) lay where+  type SizeOf lay (V n a) = n * SizeOf lay a+  type Alignment lay (V n a)+    = SizeOf lay a * NextPositivePowerOf2 n+  poke ptr v+    = foldM_+        ( \accPtr elt -> poke @a @lay accPtr elt *> pure (accPtr `plusPtr` off) )+        ( castPtr ptr )+        v+    where+      off :: Int+      off = fromIntegral ( sizeOf @a @lay )++-- A matrix is laid out like an array of its columns.+-- As the size of a column is no larger than its alignment,+-- the stride between columns is the alignment of the matrix.++instance (Poke (V m a) Base, ScalarTy a, KnownNat n, KnownNat m, 1 <= n, 1 <= m)+       => Poke (M m n a) Base where+  type SizeOf Base (M m n a)+    = n * Alignment Base (M m n a)+  type Alignment Base (M m n a) = Alignment Base (V m a)+  poke ptr mat+    = foldM_+        ( \accPtr col -> poke @(V m a) @Base accPtr col *> pure (accPtr `plusPtr` colStride) )+        ( castPtr ptr )+        ( unM mat )+    where+      colStride = fromIntegral $ alignment @(M m n a) @Base++instance ( Poke (V m a) Extended, ScalarTy a, KnownNat n, KnownNat m, 1 <= n, 1 <= m+         , KnownNat (SizeOf    Extended (M m n a))+         , KnownNat (Alignment Extended (M m n a))+         )+       => Poke (M m n a) Extended where+  type SizeOf Extended (M m n a)+    = n * Alignment Extended (M m n a)+  type Alignment Extended (M m n a) = Alignment Extended (V m a) `RoundUp` 16+  poke ptr mat+    = foldM_+        ( \accPtr col -> poke @(V m a) @Extended accPtr col *> pure (accPtr `plusPtr` colStride) )+        ( castPtr ptr )+        ( unM mat )+    where+      colStride = fromIntegral $ alignment @(M m n a) @Extended++instance ( Poke (V m a) Locations+         , ScalarTy a+         , KnownNat n, KnownNat m, 1 <= n, 1 <= m+         , KnownNat (SizeOf Locations (M m n a))+         )+      => Poke (M m n a) Locations where+ type SizeOf Locations (M m n a)+   = n * ( SizeOf Locations (V m a) `RoundUp` 16 )+ type Alignment Locations (M m n a) = 16+ poke ptr mat+   = foldM_+       ( \accPtr col -> poke @(V m a) @Locations accPtr col *> pure (accPtr `plusPtr` colSize) )+       ( castPtr ptr )+       ( unM mat )+   where+    colSize :: Int+    colSize = fromIntegral ( sizeOf @(V m a) @Locations ) `roundUp` 16++instance ( Poke a Base, Prim.PrimTy a, KnownNat n, 1 <= n+         , KnownNat ( SizeOf Base ( Array n a ) )+         )+       => Poke (Array n a) Base where+  type SizeOf Base (Array n a) = n * ( SizeOf Base a `RoundUp` Alignment Base (Array n a) )+  type Alignment Base (Array n a) = Alignment Base a+  poke ptr (MkArray arr)+    = foldM_+        ( \accPtr elt -> poke @a @Base accPtr elt *> pure (accPtr `plusPtr` off) )+        ( castPtr ptr )+        arr+    where+      off :: Int+      off = fromIntegral $ nextAligned (sizeOf @a @Base) (alignment @(Array n a) @Base)++instance ( Poke a Extended+         , Prim.PrimTy a+         , KnownNat n, 1 <= n+         , KnownNat ( SizeOf    Extended ( Array n a ) )+         , KnownNat ( Alignment Extended ( Array n a ) )+         )+       => Poke (Array n a) Extended where+  type SizeOf Extended (Array n a)+    = n * ( SizeOf Extended a `RoundUp` Alignment Extended (Array n a) )+  type Alignment Extended (Array n a)+    = Alignment Extended a `RoundUp` 16+  poke ptr (MkArray arr)+    = foldM_+        ( \accPtr elt -> poke @a @Extended accPtr elt *> pure (accPtr `plusPtr` off) )+        ( castPtr ptr )+        arr+    where+      off :: Int+      off = fromIntegral $ nextAligned (sizeOf @a @Extended) (alignment @(Array n a) @Extended)++instance (Poke a Locations, Prim.PrimTy a, KnownNat n, 1 <= n)+       => Poke (Array n a) Locations where+  type SizeOf Locations (Array n a)+    = n * SizeOf Locations a+  type Alignment Locations (Array n a)+    = Alignment Locations a+  poke ptr (MkArray arr)+    = foldM_+        ( \accPtr elt -> poke @a @Locations accPtr elt *> pure (accPtr `plusPtr` off) )+        ( castPtr ptr )+        arr+    where+      off :: Int+      off = fromIntegral $ nextAligned (sizeOf @a @Locations) (alignment @(Array n a) @Locations `roundUp` 16)+++class    ( Poke (Value x) lay ) => Pokeable (lay :: Layout) (x :: fld :-> Type) where+instance ( Poke (Value x) lay ) => Pokeable (lay :: Layout) (x :: fld :-> Type) where++structPoke :: forall (fld :: Type) (lay :: Layout) (as :: [fld :-> Type]).+              ( PrimTyMap as, All (Pokeable lay) as )+           => Word32 -> Ptr (Struct as) -> Struct as -> IO ()+structPoke currOff ptr struct = case primTyMapSing @_ @as of+  SNil -> pure ()+  scons@SCons -> case scons of+    ( _ :: SPrimTyMap ((k ':-> b) ': bs) ) ->+      case (struct, allDict @(Pokeable lay) @as) of+        ( b :& bs, ConsDict ) -> do+          let+            off :: Word32+            off = nextAligned currOff ( alignment @b @lay )+          poke @b @lay ( castPtr ptr `plusPtr` ( fromIntegral off ) ) b+          structPoke @fld @lay @bs ( off + sizeOf @b @lay ) ( castPtr ptr ) bs++instance ( PrimTyMap as+         , All (Pokeable Base) as+         , KnownNat (SizeOf Base (Struct as))+         , KnownNat (Alignment Base (Struct as))+         ) => Poke (Struct as) Base where+  type SizeOf Base (Struct as)+    = SumRoundedUpSizes Base as 0 `RoundUp` Alignment Base (Struct as)+  type Alignment Base (Struct as)+    = MaximumAlignment Base as+  poke = structPoke @_ @Base @as 0++instance ( PrimTyMap as+         , All (Pokeable Extended) as+         , KnownNat (SizeOf Extended (Struct as))+         , KnownNat (Alignment Extended (Struct as))+         ) => Poke (Struct as) Extended where+  type SizeOf Extended (Struct as)+    = SumRoundedUpSizes Extended as 0 `RoundUp` Alignment Extended (Struct as)+  type Alignment Extended (Struct as)+    = MaximumAlignment Extended as `RoundUp` 16+  poke = structPoke @_ @Extended @as 0++instance+  ( TypeError+      (    Text "Structure contains insufficient layout information."+      :$$: Text ""+      :$$: Text "To use the 'Locations' layout, location/component information needs to be supplied, such as:"+      :$$: Text "    Struct '[ Slot 0 0 ':-> V 2 Float, Slot 0 2 ':-> V 2 Float ],"+      :$$: Text "where 'Slot l c' refers to the interface slot in location 'l' with component 'c',"+      :$$: Text "with 0 <= l < maxVertexInputAttributes (at least 16), 0 <= c < 4."+      )+  )+  => Poke (Struct (as :: [Symbol :-> Type])) Locations+  where+    type SizeOf Locations (Struct (as :: [Symbol :-> Type]))+      = 16+    type Alignment Locations (Struct (as :: [Symbol :-> Type]))+      = 16+    poke = error "unreachable"++-- TODO: refactor this using 'Data.Constraint.All'+data PokeSlotsDict (as :: [LocationSlot Nat :-> Type]) :: Type where+  NoSlotsPoke  :: PokeSlotsDict '[]+  PokeSlotDict :: ( Poke a Locations+                  , Known (LocationSlot Nat) slot+                  , PokeSlots as+                  , KnownNat (SizeOf    Locations (Struct as))+                  , KnownNat (Alignment Locations (Struct as))+                  )+               => PokeSlotsDict ( (slot ':-> a) ': as )++class PokeSlots (as :: [LocationSlot Nat :-> Type]) where+  pokeSlotsDict :: PokeSlotsDict as+instance PokeSlots '[] where+  pokeSlotsDict = NoSlotsPoke+instance ( Poke a Locations+         , Known (LocationSlot Nat) loc+         , PokeSlots as+         , KnownNat (SizeOf    Locations (Struct as))+         , KnownNat (Alignment Locations (Struct as))+         )+       => PokeSlots ( (loc ':-> a) ': as )+       where+  pokeSlotsDict = PokeSlotDict++instance forall (as :: [LocationSlot Nat :-> Type])+       . ( PrimTyMap as+         , PokeSlots as+         , KnownNat (SizeOf Locations (Struct as))+         , KnownNat (Alignment Locations (Struct as))+         ) => Poke (Struct as) Locations where+  type SizeOf Locations (Struct as)+    = SizeOfLocations as+  type Alignment Locations (Struct as)+    = 16+  poke ptr struct = case primTyMapSing @_ @as of+    SNil -> pure ()+    scons@SCons -> case scons of+      ( _ :: SPrimTyMap ((loc ':-> b) ': bs) ) ->+        case (struct, pokeSlotsDict @as) of+          ( b :& bs, PokeSlotDict ) ->+            let LocationSlot l c = knownValue @loc+                off = fromIntegral $ 16 * l + 4 * c+            in do+              -- if we are poking another struct with location information,+              -- we want to keep the pointer as is as opposed to adding an offset to it+              case primTySing @b of+                sStruct@SStruct+                  | ( _ :: SPrimTy (Struct (cs :: [fld :-> Type]) ) ) <- sStruct+                  , LocationField <- fieldKind @fld+                  -> poke @b @Locations (castPtr ptr              ) b+                _ -> poke @b @Locations (castPtr ptr `plusPtr` off) b+              poke @(Struct bs) @Locations (castPtr ptr) bs++type family SizeOfLocations (as :: [LocationSlot Nat :-> Type]) :: Nat where+  SizeOfLocations '[] = 0+  SizeOfLocations ( ( 'LocationSlot l _ ':-> _ ) ': as )+    = Max ( 16 * (l+1) ) ( SizeOfLocations as )++--------------------------------------------------------------------------------------------+-- Layout of SPIR-V types in memory.++-- | The layout rules imposed by a storage class, if any.+storageLayoutRules :: SPIRV.StorageClass -> Maybe SPIRV.LayoutRules+storageLayoutRules Storage.Uniform                                 = Just SPIRV.ExtendedAlignment+storageLayoutRules Storage.StorageBuffer                           = Just SPIRV.BaseAlignment+storageLayoutRules Storage.PushConstant                            = Just SPIRV.BaseAlignment+storageLayoutRules (Storage.RayStorage Storage.ShaderRecordBuffer) = Just SPIRV.BaseAlignment+storageLayoutRules _                                               = Nothing++-- | The layout of a global variable of the given type, in the given storage class.+--+-- In storage classes with explicit layout, as well as for inputs and outputs,+-- structures and arrays of structures are interface blocks.+variableLayout :: SPIRV.BlockKind -> SPIRV.StorageClass -> SPIRV.PrimTy -> SPIRV.Layout+variableLayout kind storageClass ty+  = SPIRV.Layout+      { SPIRV.layoutRules = rules+      , SPIRV.blockKind+          = if   isInterface && isBlockShaped ty+            then Just kind+            else Nothing+      }+  where+    rules :: Maybe SPIRV.LayoutRules+    rules = storageLayoutRules storageClass+    isInterface :: Bool+    isInterface = isJust rules || storageClass `elem` [ Storage.Input, Storage.Output ]+    isBlockShaped :: SPIRV.PrimTy -> Bool+    isBlockShaped ( SPIRV.Struct {} )                   = True+    isBlockShaped ( SPIRV.Array _ ( SPIRV.Struct {} ) ) = True+    isBlockShaped _                                     = False++-- | The stride of an array with the given element type.+arrayStride :: MonadError ShortText m => SPIRV.LayoutRules -> SPIRV.PrimTy -> m Word32+arrayStride rules eltTy = uncurry nextAligned <$> primTySizeAndAli rules ( SPIRV.Array 1 eltTy )++-- | The layout decorations of the members of a structure with the given member types.+memberLayoutDecorations+  :: forall m+  .  MonadError ShortText m+  => SPIRV.LayoutRules -> [ SPIRV.PrimTy ] -> m [ SPIRV.Decorations ]+memberLayoutDecorations rules = go 0+  where+    go :: Word32 -> [ SPIRV.PrimTy ] -> m [ SPIRV.Decorations ]+    go _      []           = pure []+    go offset ( ty : tys ) = do+      ( size, ali ) <- primTySizeAndAli rules ( sizedTy ty )+      matDecs       <- matrixDecorations ( innermostElement ty )+      let+        memberOffset :: Word32+        memberOffset = nextAligned offset ali+      ( Set.insert ( SPIRV.Offset memberOffset ) matDecs : ) <$> go ( memberOffset + size ) tys++    -- A run-time array has no size; it is laid out like an array with a single element.+    sizedTy :: SPIRV.PrimTy -> SPIRV.PrimTy+    sizedTy ( SPIRV.RuntimeArray { eltTy } ) = SPIRV.Array 1 eltTy+    sizedTy ty                               = ty++    innermostElement :: SPIRV.PrimTy -> SPIRV.PrimTy+    innermostElement ( SPIRV.Array        { eltTy } ) = innermostElement eltTy+    innermostElement ( SPIRV.RuntimeArray { eltTy } ) = innermostElement eltTy+    innermostElement ty                               = ty++    -- The layout of a matrix is specified on the structure member that contains it;+    -- a matrix is laid out like an array of its columns.+    matrixDecorations :: SPIRV.PrimTy -> m SPIRV.Decorations+    matrixDecorations ( SPIRV.Matrix { rows, entryTy } ) = do+      colStride <- arrayStride rules ( SPIRV.Vector rows ( SPIRV.Scalar entryTy ) )+      pure ( Set.fromList [ SPIRV.MatrixStride colStride, SPIRV.ColMajor ] )+    matrixDecorations _ = pure Set.empty++primTySizeAndAli :: MonadError ShortText m => SPIRV.LayoutRules -> SPIRV.PrimTy -> m ( Word32, Word32 )+primTySizeAndAli SPIRV.BaseAlignment ty+  | Just ( LayoutablePrimTy ( _ :: Proxy ty ) ) <- layoutable @Base ty+  = pure $ ( sizeOf @ty @Base, alignment @ty @Base )+primTySizeAndAli SPIRV.ExtendedAlignment ty+  | Just ( LayoutablePrimTy ( _ :: Proxy ty ) ) <- layoutable @Extended ty+  = pure $ ( sizeOf @ty @Extended, alignment @ty @Extended )+primTySizeAndAli rules ty = throwError+  ( "'primTySizeAndAli': cannot compute " <> ShortText.pack (show rules) <> " size & alignment for " <> ShortText.pack (show ty) )++--------------------------------------------------------------------------------------------+-- Some functions for promoting SPIR-V primitive types that can be laid-out.+-- This allows us to re-use the type families that compute layout information+-- at the value level.++data SLayout (lay :: Layout) where+  SBase      :: SLayout Base+  SExtended  :: SLayout Extended+  SLocations :: SLayout Locations++class KnownLayout (lay :: Layout) where+  layoutSing :: SLayout lay+instance KnownLayout Base where+  layoutSing = SBase+instance KnownLayout Extended where+  layoutSing = SExtended+instance KnownLayout Locations where+  layoutSing = SLocations++data LayoutablePrimTy ( lay :: Layout ) where+  LayoutablePrimTy :: ( Prim.PrimTy a, Poke a lay ) => Proxy a -> LayoutablePrimTy lay+data LayoutableScalarTy ( lay :: Layout ) where+  LayoutableScalarTy :: ( ScalarTy a, Poke a lay ) => Proxy a -> LayoutableScalarTy lay+data LayoutableMatScalarTy ( lay :: Layout ) where+  LayoutableMatScalarTy :: ( ScalarTy a, AdditiveGroup a, Semiring a, Poke a lay ) => Proxy a -> LayoutableMatScalarTy lay+data LayoutableMembers (lay :: Layout) where+  LayoutableMembers+    :: ( PrimTyMap as, All (Pokeable lay) as+       , KnownNat (SizeOf    lay (Struct as))+       , KnownNat (Alignment lay (Struct as))+       )+    => Proxy as -> LayoutableMembers lay++layoutable :: forall ( lay :: Layout ). KnownLayout lay => SPIRV.PrimTy -> Maybe ( LayoutablePrimTy lay )+layoutable ( SPIRV.Scalar s )+  | Just ( LayoutableScalarTy ( _ :: Proxy a ) ) <- layoutableScalar @lay s+  = Just ( LayoutablePrimTy ( Proxy :: Proxy a ) )+layoutable ( SPIRV.Vector n ( SPIRV.Scalar s ) )+  | Just ( LayoutableScalarTy ( _ :: Proxy a ) ) <- layoutableScalar @lay s+  , True <- 1 <= n+  , SomeNat ( _ :: Proxy n ) <- someNatVal ( fromIntegral n )+  , Refl <- ( unsafeCoerce Refl :: ( 1 <=? n ) :~: True )+  , let+      npp2 :: Natural+      npp2+        | n == 1    = 1+        | otherwise = 2 ^ ( floor ( logBase 2 ( realToFrac ( n - 1 ) :: Float ) ) + 1 :: Int )+  , SomeNat ( _ :: Proxy npp2 ) <- someNatVal npp2+  , Refl <- ( unsafeCoerce Refl :: NextPositivePowerOf2 n :~: npp2 )+  = Just $ LayoutablePrimTy ( Proxy :: Proxy ( V n a ) )+layoutable ( SPIRV.Matrix m n a )+  | Just ( LayoutableMatScalarTy ( _ :: Proxy a ) ) <- layoutableMatScalar @lay a+  , SomeNat ( _ :: Proxy m ) <- someNatVal ( fromIntegral m )+  , SomeNat ( _ :: Proxy n ) <- someNatVal ( fromIntegral n )+  , True <- 1 <= n+  , Refl <- ( unsafeCoerce Refl :: ( 1 <=? n ) :~: True )+  , True <- 1 <= m+  , Refl <- ( unsafeCoerce Refl :: ( 1 <=? m ) :~: True )+  , let+      npp2 :: Natural+      npp2+        | m == 1    = 1+        | otherwise = 2 ^ ( floor ( logBase 2 ( realToFrac ( m - 1 ) :: Float ) ) + 1 :: Int )+  , SomeNat ( _ :: Proxy npp2 ) <- someNatVal npp2+  , Refl <- ( unsafeCoerce Refl :: NextPositivePowerOf2 m :~: npp2 )+  = case layoutSing @lay of+      SBase     -> Just $ LayoutablePrimTy ( Proxy :: Proxy ( M m n a ) )+      SExtended+        | let+            colStride :: Word32+            colStride = alignment @(V m a) @Extended `roundUp` 16+        , SomeNat ( _ :: Proxy ali ) <- someNatVal ( fromIntegral colStride )+        , Refl <- ( unsafeCoerce Refl :: ali :~: Alignment Extended ( M m n a ) )+        , SomeNat ( _ :: Proxy sz ) <- someNatVal ( fromIntegral $ n * colStride )+        , Refl <- ( unsafeCoerce Refl :: sz :~: SizeOf Extended ( M m n a ) )+        -> Just $ LayoutablePrimTy ( Proxy :: Proxy ( M m n a ) )+      _ -> Nothing+layoutable ( SPIRV.Array { size, eltTy } )+  | Just ( LayoutablePrimTy ( _ :: Proxy a ) ) <- layoutable @lay eltTy+  , True <- 1 <= size+  , SomeNat ( _ :: Proxy lg ) <- someNatVal ( fromIntegral size )+  , Refl <- ( unsafeCoerce Refl :: ( 1 <=? lg ) :~: True )+  = case layoutSing @lay of+      SBase+        | SomeNat ( _ :: Proxy sz ) <- someNatVal ( fromIntegral $ size * ( nextAligned ( sizeOf @a @Base ) ( alignment @a @Base ) ) )+        , Refl <- ( unsafeCoerce Refl :: sz :~: SizeOf Base ( Array lg a ) )+        -> Just $ LayoutablePrimTy ( Proxy :: Proxy ( Array lg a ) )+      SExtended+        | SomeNat ( _ :: Proxy sz ) <- someNatVal ( fromIntegral $ size * ( nextAligned ( sizeOf @a @Extended ) ( alignment @a @Extended `roundUp` 16 ) ) )+        , Refl <- ( unsafeCoerce Refl :: sz :~: SizeOf Extended ( Array lg a ) )+        , SomeNat ( _ :: Proxy ali ) <- someNatVal ( fromIntegral $ alignment @a @Extended `roundUp` 16 )+        , Refl <- ( unsafeCoerce Refl :: ali :~: (Alignment Extended a `RoundUp` 16) )+        -> Just $ LayoutablePrimTy ( Proxy :: Proxy ( Array lg a ) )+      _ -> Nothing+layoutable ( SPIRV.Struct { eltTys } ) = layoutableStruct @lay eltTys+layoutable _ = Nothing++layoutableScalar :: forall ( lay :: Layout ). SPIRV.ScalarTy -> Maybe ( LayoutableScalarTy lay )+layoutableScalar ( SPIRV.Integer SPIRV.Unsigned SPIRV.W8  ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Word8  )+layoutableScalar ( SPIRV.Integer SPIRV.Unsigned SPIRV.W16 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Word16 )+layoutableScalar ( SPIRV.Integer SPIRV.Unsigned SPIRV.W32 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Word32 )+layoutableScalar ( SPIRV.Integer SPIRV.Unsigned SPIRV.W64 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Word64 )+layoutableScalar ( SPIRV.Integer SPIRV.Signed   SPIRV.W8  ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Int8   )+layoutableScalar ( SPIRV.Integer SPIRV.Signed   SPIRV.W16 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Int16  )+layoutableScalar ( SPIRV.Integer SPIRV.Signed   SPIRV.W32 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Int32  )+layoutableScalar ( SPIRV.Integer SPIRV.Signed   SPIRV.W64 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Int64  )+layoutableScalar ( SPIRV.Floating               SPIRV.W16 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Half   )+layoutableScalar ( SPIRV.Floating               SPIRV.W32 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Float  )+layoutableScalar ( SPIRV.Floating               SPIRV.W64 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Double )+layoutableScalar _ = Nothing++layoutableMatScalar :: forall ( lay :: Layout ). SPIRV.ScalarTy -> Maybe ( LayoutableMatScalarTy lay )+layoutableMatScalar ( SPIRV.Integer SPIRV.Signed   SPIRV.W8  ) = Just $ LayoutableMatScalarTy ( Proxy :: Proxy Int8   )+layoutableMatScalar ( SPIRV.Integer SPIRV.Signed   SPIRV.W16 ) = Just $ LayoutableMatScalarTy ( Proxy :: Proxy Int16  )+layoutableMatScalar ( SPIRV.Integer SPIRV.Signed   SPIRV.W32 ) = Just $ LayoutableMatScalarTy ( Proxy :: Proxy Int32  )+layoutableMatScalar ( SPIRV.Integer SPIRV.Signed   SPIRV.W64 ) = Just $ LayoutableMatScalarTy ( Proxy :: Proxy Int64  )+layoutableMatScalar ( SPIRV.Floating               SPIRV.W16 ) = Just $ LayoutableMatScalarTy ( Proxy :: Proxy Half   )+layoutableMatScalar ( SPIRV.Floating               SPIRV.W32 ) = Just $ LayoutableMatScalarTy ( Proxy :: Proxy Float  )+layoutableMatScalar ( SPIRV.Floating               SPIRV.W64 ) = Just $ LayoutableMatScalarTy ( Proxy :: Proxy Double )+layoutableMatScalar _ = Nothing++layoutableStruct+  :: forall ( lay :: Layout ) mbName+  .  KnownLayout lay+  => [ ( mbName, SPIRV.PrimTy ) ]+  -> Maybe ( LayoutablePrimTy lay )+layoutableStruct elts = makeLayoutableStruct =<< layoutableStructMembers 0 elts+  where+    layoutableStructMembers :: Int -> [ ( mbName, SPIRV.PrimTy ) ] -> Maybe [ ( SomeSymbol, LayoutablePrimTy lay ) ]+    layoutableStructMembers _ [] = Just []+    layoutableStructMembers i ( (_,ty) : tys )+      | Just layoutableTy  <- layoutable @lay ty+      , Just layoutableTys <- layoutableStructMembers (i+1) tys+      , nm <- someSymbolVal ( show i )+      = Just ( ( nm, layoutableTy ) : layoutableTys )+    layoutableStructMembers _ _ = Nothing++    makeLayoutableStruct :: [ ( SomeSymbol, LayoutablePrimTy lay ) ] -> Maybe ( LayoutablePrimTy lay )+    makeLayoutableStruct members+      | Just ( LayoutableMembers ( _ :: Proxy as ) ) <- makeLayoutableMembers members+      = case layoutSing @lay of+          SBase     -> Just ( LayoutablePrimTy ( Proxy :: Proxy ( Struct as ) ) )+          SExtended -> Just ( LayoutablePrimTy ( Proxy :: Proxy ( Struct as ) ) )+          _         -> Nothing+    makeLayoutableStruct _ = Nothing++    makeLayoutableMembers :: [ ( SomeSymbol, LayoutablePrimTy lay ) ] -> Maybe ( LayoutableMembers lay )+    makeLayoutableMembers [] = case layoutSing @lay of+      SBase     -> Just ( LayoutableMembers ( Proxy :: Proxy ('[] :: [ Symbol :-> Type ] ) ) )+      SExtended -> Just ( LayoutableMembers ( Proxy :: Proxy ('[] :: [ Symbol :-> Type ] ) ) )+      _         -> Nothing+    makeLayoutableMembers members@( ( SomeSymbol ( _ :: Proxy nm ), LayoutablePrimTy ( _ :: Proxy a ) ) : as )+      | Just ( LayoutableMembers ( _ :: Proxy ( as :: [ fld :-> Type ] ) ) ) <- makeLayoutableMembers as+      , NamedField <- fieldKind @fld+      , ( structSize, structAli ) <- structSizeAndAlignment @lay members+      , SomeNat ( _ :: Proxy structSize ) <- someNatVal ( fromIntegral structSize )+      , Refl <- ( unsafeCoerce Refl :: structSize :~: SizeOf lay ( Struct ( ( nm ':-> a ) ': as ) ) )+      , SomeNat ( _ :: Proxy structAli ) <- someNatVal ( fromIntegral structAli )+      , Refl <- ( unsafeCoerce Refl :: structAli :~: Alignment lay ( Struct ( ( nm ':-> a ) ': as ) ) )+      = case layoutSing @lay of+          SBase     -> Just ( LayoutableMembers ( Proxy :: Proxy ( ( nm ':-> a ) ': as ) ) )+          SExtended -> Just ( LayoutableMembers ( Proxy :: Proxy ( ( nm ':-> a ) ': as ) ) )+          _         -> Nothing+    makeLayoutableMembers _ = Nothing++-- | Size and alignment of a structure with the given members.+--+-- The size of a structure is rounded up to its alignment.+structSizeAndAlignment+  :: forall ( lay :: Layout )+  .  KnownLayout lay+  => [ ( SomeSymbol, LayoutablePrimTy lay ) ] -> ( Word32, Word32 )+structSizeAndAlignment members = ( nextAligned ( foldl' memberEnd 0 members ) structAli, structAli )+  where+    structAli :: Word32+    structAli = case layoutSing @lay of+      SExtended -> maxAli `roundUp` 16+      _         -> maxAli+    maxAli :: Word32+    maxAli = maximum ( 1 : map memberAlignment members )+    memberAlignment :: ( SomeSymbol, LayoutablePrimTy lay ) -> Word32+    memberAlignment ( _, LayoutablePrimTy ( _ :: Proxy b ) ) = alignment @b @lay+    memberEnd :: Word32 -> ( SomeSymbol, LayoutablePrimTy lay ) -> Word32+    memberEnd offset ( _, LayoutablePrimTy ( _ :: Proxy b ) ) = nextAligned offset ( alignment @b @lay ) + sizeOf @b @lay
+ src/FIR/Module.hs view
@@ -0,0 +1,117 @@+{-# OPTIONS_HADDOCK ignore-exports #-}++{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE InstanceSigs           #-}+{-# LANGUAGE PatternSynonyms        #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: FIR.Module++Utility wrapper types for programs.++A program essentially consists of a value of type @Codensity AST (AST a := j) i@,+but with additional type-level information pertaining to the program inputs/outputs,+similar to the interface for a shader module in @OpenGL@ or @Vulkan@.++See "FIR.ProgramState" which defines the type-level data that programs keep track of.+-}++module FIR.Module+  ( Program+  , Module(Module)+  , ShaderModule(ShaderModule)+  )+  where++-- base+import Data.Kind+  ( Type )+import GHC.TypeLits+  ( Symbol )++-- fir+import Control.Monad.Indexed+  ( (:=)(AtKey), Codensity(..) )+import Data.Type.Map+  ( (:->) )+import FIR.AST+  ( AST, Code+  , Syntactic(..), SyntacticVal, InternalType+  , pattern (:$), pattern Bind, pattern Return+  )+import FIR.AST.Type+  ( Eff )+import FIR.Definition+  ( Definition, KnownDefinitions+  , StartState+  )+import FIR.ProgramState+  ( ProgramState )+import FIR.Validation.Definitions+  ( ValidDefinitions )+import qualified SPIRV.Stage  as SPIRV+  ( Shader )++--------------------------------------------------------------------------+-- * Program type synonym+--+-- $wrappers+-- Wrapper for the main internal representation+-- @Codensity AST (a := j) i@++type Program (i :: ProgramState) (j :: ProgramState) (a :: Type)+  = Codensity AST (a := j) i++instance SyntacticVal a => Syntactic (Program i j a) where+  type Internal (Codensity AST (a := j) i) = Eff i j (InternalType a)++  toAST :: Codensity AST (a := j) i -> AST ( Eff i j (InternalType a) )+  toAST (Codensity k) = k ( \(AtKey a) -> Return :$ toAST a )++  fromAST :: AST ( Eff i j (InternalType a) ) -> Codensity AST (a := j) i+  fromAST a = Codensity ( \k -> Bind :$ toAST a :$ toAST (k . AtKey) )++--------------------------------------------------------------------------+-- * Module type++-- | A 'Module' wraps a value-level program with additional+-- 'Definition's which specify the interface of the module,+-- such as memory layout of input and output data.+--+-- Corresponds to the concept of a SPIR-V module.+data Module+      ( defs :: [ Symbol :-> Definition ] )+    :: Type where+  Module  :: forall defs endState+          .  ( KnownDefinitions defs, ValidDefinitions defs )+          => Program (StartState defs) endState (Code ())+          -> Module defs++--------------------------------------------------------------------------+-- * Shader stage type++-- | Value-level wrapper for a shader stage.+--+-- Takes a module (which may have multiple shaders defined),+-- and specifies (using name + stage) which shader+-- is being referred to (e.g. for use in a shader pipeline).+--+-- Keeps track of the final indexed monadic state of the shader,+-- which is used to perform type-level validation.+data ShaderModule+        ( name     :: Symbol                  )+        ( stage    :: SPIRV.Shader            )+        ( defs     :: [Symbol :-> Definition] )+        ( endState :: ProgramState            )+        where+  ShaderModule+    :: forall name stage defs endState+    .  ( KnownDefinitions defs, ValidDefinitions defs )+    => Program (StartState defs) endState (Code ())+    -> ShaderModule name stage defs endState
+ src/FIR/Pipeline.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveFoldable        #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE DeriveTraversable     #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++{-|+Module: FIR.Pipeline++This module encodes the Vulkan concept of graphics pipelines+as a sequence of shader programs.++See "FIR.Validation.Pipeline" for the validation of such pipelines.+-}++module FIR.Pipeline+  ( PipelineInfo(..)+  , PipelineStages(..), pipelineStages+  , ShaderPipeline(..), pipelineShaders+  , ShaderGroup(..)+  , PrimitiveConnectedness(..)+  , PrimitiveTopology(..)+  , BindingStrides+  , VertexLocationDescriptions+  , GetVertexInputInfo, GetTopologyInfo -- (re-exports)+  )+  where++-- base+import Data.Kind+  ( Type )+import Data.Word+  ( Word32 )+import GHC.TypeLits+  ( Symbol )+import GHC.TypeNats+  ( Nat, KnownNat )++-- fir+import Data.Type.Known+  ( Demotable(Demote), Known(known), knownValue )+import Data.Type.Map+  ( (:->) )+import FIR.Definition+  ( Variables )+import FIR.Module+  ( ShaderModule )+import FIR.ProgramState+  ( Definedness(Defined)+  , EntryPointInfo(EntryPointInfo)+  )+import FIR.Validation.Pipeline+  ( ValidPipelineInfo+  , GetExecutionInfo+  , GetVertexInputInfo+  , GetTopologyInfo+  )+import qualified SPIRV.Image as SPIRV+  ( ImageFormat )+import qualified SPIRV.Stage as SPIRV++--------------------------------------------------------------------------+-- * Primitive topologies++data PrimitiveConnectedness+  = List+  | Strip+  | Fan+  | AdjacencyList+  | AdjacencyStrip+  deriving stock ( Eq, Ord, Show, Enum, Bounded )++data PrimitiveTopology (n :: Type)+  = Points+  | Line          PrimitiveConnectedness+  | Triangle      PrimitiveConnectedness+  | PatchesOfSize n+  deriving stock ( Eq, Show )++instance Demotable PrimitiveConnectedness where+  type Demote PrimitiveConnectedness = PrimitiveConnectedness++instance Known PrimitiveConnectedness 'List where+  known = List+instance Known PrimitiveConnectedness 'Strip where+  known = Strip+instance Known PrimitiveConnectedness 'Fan where+  known = Fan+instance Known PrimitiveConnectedness 'AdjacencyList where+  known = AdjacencyList+instance Known PrimitiveConnectedness 'AdjacencyStrip where+  known = AdjacencyStrip++instance Demotable (PrimitiveTopology Nat) where+  type Demote (PrimitiveTopology Nat) = PrimitiveTopology Word32++instance Known (PrimitiveTopology Nat) 'Points where+  known = Points+instance Known PrimitiveConnectedness conn+      => Known (PrimitiveTopology Nat) ('Line conn) where+  known = Line ( knownValue @conn )+instance Known PrimitiveConnectedness conn+      => Known (PrimitiveTopology Nat) ('Triangle conn) where+  known = Triangle ( knownValue @conn )+instance KnownNat n => Known (PrimitiveTopology Nat) ('PatchesOfSize n) where+  known = PatchesOfSize ( knownValue @n )++-------------------------------------------------------+-- * Graphics pipelines++-- | For each location:+--   - a binding index,+--   - the offset (in bytes) within the buffer bound at that index,+--   - the image format of the location.+type VertexLocationDescriptions = [ Nat :-> ( Nat, Nat, SPIRV.ImageFormat Nat ) ]++-- | For each binding, the corresponding stride to use.+type BindingStrides = [ Nat :-> Nat ]++-- | Pipeline information data kind.+--+-- Records information about a pipeline which should be kept track of at the type level,+-- to be used for validation.+--+--   - Primitive topology used for the pipeline,+--   - layout information (vertex location descriptions, binding strides),+--   - type-level information associated to each shader in the pipeline,+--     such as the type of shader (vertex shader, geometry shader, ...)+--     and the input/output interfaces (for interface matching).+--+-- Represented as a snoc-list, beginning with vertex input information,+-- and then the sequence of shaders in order.+data PipelineInfo where+  VertexInputInfo+    :: PrimitiveTopology Nat+    -> VertexLocationDescriptions+    -> BindingStrides+    -> PipelineInfo+  Into+    :: PipelineInfo+    -> ( Symbol, EntryPointInfo )+    -> PipelineInfo++-- | Value-level sequence of pipeline stages.+--+-- Specified as a snoc-list:+--+-- > VertexInput @top @descs @strides :>-> (shader_1, filepath_1) :>-> ... (shader_n, filepath_n)+--+-- Keeps track of type-level information necessary for validation.+data PipelineStages (info :: PipelineInfo) (stageData :: Type) where+  VertexInput+    :: forall+          ( top       :: PrimitiveTopology Nat      )+          ( descs     :: VertexLocationDescriptions )+          ( strides   :: BindingStrides             )+          ( stageData :: Type                       )+    .  ( Known (PrimitiveTopology Nat)    top+       , Known VertexLocationDescriptions descs+       , Known BindingStrides             strides+       )+    => PipelineStages (VertexInputInfo top descs strides) stageData+  (:>->) :: ( Known SPIRV.Shader shader )+         => PipelineStages info stageData+         -> ( ShaderModule name shader defs endState, stageData )+         -> PipelineStages+              ( info `Into`+                '( name+                 , 'EntryPointInfo+                      ( GetExecutionInfo shader name endState )+                      ( Variables defs )+                      'Defined+                 )+              )+              stageData++deriving stock instance Functor     (PipelineStages info)+deriving stock instance Foldable    (PipelineStages info)+deriving stock instance Traversable (PipelineStages info)++-- | Smart wrapper for a shader pipeline,+-- performing type-level validation on a sequence of pipeline stages.+data ShaderPipeline (stageData :: Type) where+  ShaderPipeline+    :: forall+        ( info      :: PipelineInfo               )+        ( top       :: PrimitiveTopology Nat      )+        ( descs     :: VertexLocationDescriptions )+        ( strides   :: BindingStrides             )+        ( stageData :: Type                       )+    . ( ValidPipelineInfo info+      , '(top, descs, strides) ~ GetVertexInputInfo info+      , Known (PrimitiveTopology Nat)    top+      , Known VertexLocationDescriptions descs+      , Known BindingStrides             strides+      )+    => PipelineStages info stageData+    -> ShaderPipeline stageData++deriving stock instance Functor     ShaderPipeline+deriving stock instance Foldable    ShaderPipeline+deriving stock instance Traversable ShaderPipeline++pipelineStages :: PipelineStages info stageData -> [(SPIRV.Shader, stageData)]+pipelineStages = reverse . go []+  where+    go :: [(SPIRV.Shader, stageData)] -> PipelineStages info2 stageData -> [(SPIRV.Shader, stageData)]+    go shaders VertexInput = shaders+    go shaders ( info :>-> ( (_ :: ShaderModule name shader defs endState) , stageData) )+      = go ( (knownValue @shader, stageData) : shaders) info++pipelineShaders :: ShaderPipeline stageData -> [(SPIRV.Shader, stageData)]+pipelineShaders (ShaderPipeline stages) = pipelineStages stages++--------------------------------------------------------------------------+-- * Ray-tracing shader groups++-- | Utility datatype used to organise ray-tracing shaders into groups,+-- to facilitate creation of a Vulkan ray-tracing pipeline.+data ShaderGroup a+  = RaygenGroup   a+  | MissGroup     a+  | CallableGroup a+  | HitGroup+    { intersection :: Maybe a+    , closestHit   :: Maybe a+    , anyHit       :: Maybe a+    }+  deriving stock ( Show, Eq, Functor, Foldable, Traversable )
+ src/FIR/Pipeline.hs-boot view
@@ -0,0 +1,66 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++module FIR.Pipeline+  ( PipelineInfo(..)+  , PrimitiveConnectedness(..)+  , PrimitiveTopology(..)+  , VertexLocationDescriptions+  , BindingStrides+  )+  where++-- base+import Data.Kind+  ( Type )+import GHC.TypeLits+  ( Symbol )+import GHC.TypeNats+  ( Nat )++-- fir+import Data.Type.Map+  ( (:->) )+import FIR.ProgramState+  ( EntryPointInfo )+import qualified SPIRV.Image as SPIRV++--------------------------------------------------------------------------++data PrimitiveConnectedness+  = List+  | Strip+  | Fan+  | AdjacencyList+  | AdjacencyStrip++data PrimitiveTopology (n :: Type)+  = Points+  | Line          PrimitiveConnectedness+  | Triangle      PrimitiveConnectedness+  | PatchesOfSize n++type VertexLocationDescriptions = [ Nat :-> ( Nat, Nat, SPIRV.ImageFormat Nat ) ]++type BindingStrides = [ Nat :-> Nat ]++data PipelineInfo where+  VertexInputInfo+    :: PrimitiveTopology Nat+    -> VertexLocationDescriptions+    -> BindingStrides+    -> PipelineInfo+  Into+    :: PipelineInfo+    -> ( Symbol, EntryPointInfo )+    -> PipelineInfo
+ src/FIR/Prelude.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE CPP           #-}+{-# LANGUAGE TypeOperators #-}++-- | An internal module which re-exports some definitions needed+-- from the Prelude and related modules.+--+-- As a user of the EDSL, you should never need to import this module.+module FIR.Prelude+  ( module Prelude+  , module Data.Int+  , module Data.Word+  , module Numeric.Half+  , module Data.Complex+  , module Data.Coerce+  , module Data.String+  , module Data.Kind+  )+  where++import Prelude+  ( Bool(..), Maybe(..), Either(..)+  , Float, Double+  , Semigroup(..), Monoid(..)+  , IO+  , FilePath+#if __GLASGOW_HASKELL__ >= 903+  , type (~)+#endif+  , ($), (.)+  , otherwise, maybe, either+  , fst, snd+  , curry, uncurry+  , subtract+  , id, const+  , flip+  , until, asTypeOf+  , error, errorWithoutStackTrace+  , seq, ($!)+  )++-- NB: deliberately not re-exporting Int/Word.+import Data.Int+  ( Int8, Int16, Int32, Int64 )+import Data.Word+  ( Word8, Word16, Word32, Word64 )+import Numeric.Half+  ( Half )++import Data.Complex+  ( Complex(..) )++import Data.Coerce+  ( Coercible, coerce )++import Data.String+  ( IsString(..) )++import Data.Kind+  ( Type, Constraint )
+ src/FIR/Prim/Array.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE DeriveTraversable      #-}+{-# LANGUAGE DerivingVia            #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE InstanceSigs           #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE StandaloneDeriving     #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: FIR.Prim.Array++This module defines the array type used in this library,+which simply consists in a wrapper around a 'Data.Vector.Vector'.++There are two kinds of arrays:++  * arrays, affixed with a type-level natural number denoting their length,+  * runtime arrays, whose length is not statically known.++The user cannot create new runtime arrays within a SPIR-V module+(although this is not currently enforced by this library),+as they are only meant to be used as inputs within shader storage buffer objects,+as the last object within a 'FIR.Synonyms.StorageBuffer'.+-}++module FIR.Prim.Array+  ( Array(..)+  , RuntimeArray(..)+  )+  where++-- base+import Data.Coerce+  ( coerce )+import Data.Kind+  ( Type )+import GHC.TypeNats+  ( Nat, KnownNat, type (+) )++-- vector+import qualified Data.Vector as Unsized+  ( Vector )++-- vector-sized+import qualified Data.Vector.Sized as V+  ( Vector, (++) )++-- fir+import Math.Algebra.GradedSemigroup+  ( GradedSemigroup(..) )++------------------------------------------------------------+-- arrays++newtype Array :: Nat -> Type -> Type where+  MkArray :: V.Vector n a -> Array n a++deriving stock instance Eq   a => Eq   (Array n a)+deriving stock instance Ord  a => Ord  (Array n a)+deriving stock instance Show a => Show (Array n a)+deriving via (V.Vector n) instance Functor     (Array n)+deriving via (V.Vector n) instance Foldable    (Array n)+deriving stock            instance Traversable (Array n)+deriving via (V.Vector n) instance KnownNat n => Applicative (Array n)++instance GradedSemigroup (Array 0 a) Nat where+  type Grade Nat (Array 0 a) l = Array l a+  type l1 :<!>: l2 = l1 + l2+  (<!>) = coerce (V.++)++newtype RuntimeArray (a :: Type) = MkRuntimeArray (Unsized.Vector a)++deriving via Unsized.Vector a instance Eq   a => Eq   (RuntimeArray a)+deriving via Unsized.Vector a instance Ord  a => Ord  (RuntimeArray a)+deriving via Unsized.Vector a instance Show a => Show (RuntimeArray a)+deriving via Unsized.Vector   instance Functor     RuntimeArray+deriving via Unsized.Vector   instance Foldable    RuntimeArray+deriving stock                instance Traversable RuntimeArray
+ src/FIR/Prim/Atomic.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE ConstraintKinds          #-}+{-# LANGUAGE DataKinds                #-}+{-# LANGUAGE DerivingStrategies       #-}+{-# LANGUAGE GADTs                    #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeFamilies             #-}+{-# LANGUAGE UndecidableInstances     #-}++{-|+Module: FIR.Prim.Atomic++Atomic operations (loads, stores, exchanges, and arithmetic and bitwise+read-modify-write operations), and the scalar types that support them.+-}++module FIR.Prim.Atomic+  ( AtomicOp(..), SAtomicOp(..), atomicOp+  , AtomicShape(..), SAtomicShape(..), AtomicOpShape, atomicShape+  , AtomicTy, AtomicIntegralTy, AtomicOpTy+  )+  where++-- base+import Data.Int+  ( Int32, Int64 )+import Data.Kind+  ( Type, Constraint )+import Data.Word+  ( Word32, Word64 )++-- half+import Numeric.Half+  ( Half )++-- fir+import FIR.Prim.Types+  ( ScalarTy, IntegralTy )++------------------------------------------------------------++-- | Atomic operations on the scalar a pointer points to.+data AtomicOp+  = AtomicLoad            -- ^ Read the value.+  | AtomicStore           -- ^ Write a value.+  | AtomicExchange        -- ^ Write a value, returning the previous value.+  | AtomicCompareExchange -- ^ Write a value if the current value equals+                          --   an expected value.+  | AtomicIncrement       -- ^ Add one.+  | AtomicDecrement       -- ^ Subtract one.+  | AtomicAdd             -- ^ Add a value.+  | AtomicSub             -- ^ Subtract a value.+  | AtomicMin             -- ^ Take the minimum with a value.+  | AtomicMax             -- ^ Take the maximum with a value.+  | AtomicAnd             -- ^ Bitwise and with a value.+  | AtomicOr              -- ^ Bitwise or with a value.+  | AtomicXor             -- ^ Bitwise exclusive or with a value.+  deriving stock ( Eq, Show )++-- | Singleton for 'AtomicOp'.+data SAtomicOp ( op :: AtomicOp ) where+  SAtomicLoad            :: SAtomicOp 'AtomicLoad+  SAtomicStore           :: SAtomicOp 'AtomicStore+  SAtomicExchange        :: SAtomicOp 'AtomicExchange+  SAtomicCompareExchange :: SAtomicOp 'AtomicCompareExchange+  SAtomicIncrement       :: SAtomicOp 'AtomicIncrement+  SAtomicDecrement       :: SAtomicOp 'AtomicDecrement+  SAtomicAdd             :: SAtomicOp 'AtomicAdd+  SAtomicSub             :: SAtomicOp 'AtomicSub+  SAtomicMin             :: SAtomicOp 'AtomicMin+  SAtomicMax             :: SAtomicOp 'AtomicMax+  SAtomicAnd             :: SAtomicOp 'AtomicAnd+  SAtomicOr              :: SAtomicOp 'AtomicOr+  SAtomicXor             :: SAtomicOp 'AtomicXor++atomicOp :: SAtomicOp op -> AtomicOp+atomicOp SAtomicLoad            = AtomicLoad+atomicOp SAtomicStore           = AtomicStore+atomicOp SAtomicExchange        = AtomicExchange+atomicOp SAtomicCompareExchange = AtomicCompareExchange+atomicOp SAtomicIncrement       = AtomicIncrement+atomicOp SAtomicDecrement       = AtomicDecrement+atomicOp SAtomicAdd             = AtomicAdd+atomicOp SAtomicSub             = AtomicSub+atomicOp SAtomicMin             = AtomicMin+atomicOp SAtomicMax             = AtomicMax+atomicOp SAtomicAnd             = AtomicAnd+atomicOp SAtomicOr              = AtomicOr+atomicOp SAtomicXor             = AtomicXor++-- | The shape of an atomic operation: its operands besides the pointer,+-- and its result.+data AtomicShape+  = Reads    -- ^ No operand; returns the value.+  | Writes   -- ^ One operand; returns nothing.+  | Modifies -- ^ One operand; returns the previous value.+  | Compares -- ^ Two operands (the expected value, then the new value);+             --   returns the previous value.++-- | Singleton for 'AtomicShape'.+data SAtomicShape ( sh :: AtomicShape ) where+  SReads    :: SAtomicShape 'Reads+  SWrites   :: SAtomicShape 'Writes+  SModifies :: SAtomicShape 'Modifies+  SCompares :: SAtomicShape 'Compares++type AtomicOpShape :: AtomicOp -> AtomicShape+type family AtomicOpShape op where+  AtomicOpShape 'AtomicLoad            = 'Reads+  AtomicOpShape 'AtomicIncrement       = 'Reads+  AtomicOpShape 'AtomicDecrement       = 'Reads+  AtomicOpShape 'AtomicStore           = 'Writes+  AtomicOpShape 'AtomicCompareExchange = 'Compares+  AtomicOpShape _                      = 'Modifies++atomicShape :: SAtomicOp op -> SAtomicShape ( AtomicOpShape op )+atomicShape SAtomicLoad            = SReads+atomicShape SAtomicIncrement       = SReads+atomicShape SAtomicDecrement       = SReads+atomicShape SAtomicStore           = SWrites+atomicShape SAtomicCompareExchange = SCompares+atomicShape SAtomicExchange        = SModifies+atomicShape SAtomicAdd             = SModifies+atomicShape SAtomicSub             = SModifies+atomicShape SAtomicMin             = SModifies+atomicShape SAtomicMax             = SModifies+atomicShape SAtomicAnd             = SModifies+atomicShape SAtomicOr              = SModifies+atomicShape SAtomicXor             = SModifies++-- | Scalar types on which atomic operations are supported:+-- 32-bit and 64-bit integers, and floating-point numbers.+--+-- Under Vulkan, 64-bit integer atomics require the @shaderBufferInt64Atomics@+-- or @shaderSharedInt64Atomics@ features, and floating-point atomics require+-- features of @VK_EXT_shader_atomic_float@ (and of @VK_EXT_shader_atomic_float2@+-- for 16-bit floating-point numbers, and for minimum and maximum).+class ScalarTy ty => AtomicTy ty+instance AtomicTy Word32+instance AtomicTy Word64+instance AtomicTy Int32+instance AtomicTy Int64+instance AtomicTy Half+instance AtomicTy Float+instance AtomicTy Double++-- | Integral types on which atomic operations are supported:+-- 32-bit and 64-bit integers.+class ( AtomicTy ty, IntegralTy ty ) => AtomicIntegralTy ty+instance AtomicIntegralTy Word32+instance AtomicIntegralTy Word64+instance AtomicIntegralTy Int32+instance AtomicIntegralTy Int64++-- | Scalar types on which a given atomic operation is supported: bitwise+-- operations, subtraction, increment, decrement and compare-exchange are only+-- supported on integers.+type AtomicOpTy :: AtomicOp -> Type -> Constraint+type family AtomicOpTy op ty where+  AtomicOpTy 'AtomicCompareExchange ty = AtomicIntegralTy ty+  AtomicOpTy 'AtomicIncrement       ty = AtomicIntegralTy ty+  AtomicOpTy 'AtomicDecrement       ty = AtomicIntegralTy ty+  AtomicOpTy 'AtomicSub             ty = AtomicIntegralTy ty+  AtomicOpTy 'AtomicAnd             ty = AtomicIntegralTy ty+  AtomicOpTy 'AtomicOr              ty = AtomicIntegralTy ty+  AtomicOpTy 'AtomicXor             ty = AtomicIntegralTy ty+  AtomicOpTy _                      ty = AtomicTy ty
+ src/FIR/Prim/Image.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE DerivingStrategies     #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: FIR.Prim.Image++This module defines the 'Image' datatype,+which is a void datatype used to manipulate image handles.++This datatype is annotated at the type-level with various properties+describing the image, such as the format of the image (e.g. RGBA8, depth image, etc).+-}++module FIR.Prim.Image+  ( -- * Images+    -- ** Image properties+    ImageCoordinateKind(..)+  , ImageProperties(Properties)+  -- ** Opaque image data type+  , Image+  -- ** Type reflection of image properties+  -- $reflection+  , ImageAndCoordinate(..)+  , knownImage, knownImageCoordinateKind++  -- * Image operands+  , OperandName(..), ImageOperands+  -- ** Specific data type for gathering operations+  , Gather(..), GatherInfo(..)++  -- * Helper type families for checking validity of image operands+  , CanAddProj, CanAddDref, BasicDim, NotCubeDim+  , NoMS, NoDuplicate, CanMultiSample+  , NoLODOps, UsesAffineCoords+  , WhichGather+  )+  where++-- base+import Data.Int+  ( Int32 )+import Data.Kind+  ( Type )+import Data.Type.Bool+  ( If )+import GHC.TypeNats+  ( Nat )++-- fir+import Data.Type.Known+  ( Demotable(Demote), Known(known), knownValue )+import Data.Type.List+  ( Elem )+import FIR.Prim.Array+  ( Array )+import {-# SOURCE #-} FIR.Prim.Types+  ( ScalarTy, scalarTy )+import FIR.Validation.Images+  ( MatchesFormat, BasicDim, NotCubeDim+  , CanAddProj, CanAddDref+  , UsesAffineCoords+  , NoDuplicate+  , NoMS, CanMultiSample+  , NoLODOps+  )+import Math.Linear+  ( V )+import SPIRV.Image+  ( Arrayness(..)+  , Dimensionality(..)+  , HasDepth(..)+  , ImageUsage(..)+  , ImageFormat(..)+  , MultiSampling(..)+  , Operand+  )+import qualified SPIRV.Image    as SPIRV+  ( Image(..) )++--------------------------------------------------++-- | Properties of an image, used as a data kind+-- to describe the properties of an image at the type-level.+--+-- This allows type-checking that the image properties+-- comply with the @SPIR-V@ specification, as well+-- as check that operations done with the image are valid.+data ImageProperties where+  Properties+    :: ImageCoordinateKind     -- ^ The kind of coordinates this image allows (integral/floating point).+    -> Type                    -- ^ Texel component type.+    -> Dimensionality          -- ^ Dimensionality of the image (1D, 2D, 3D, cubemap, ...).+    -> Maybe HasDepth          -- ^ Whether the image is a depth image.+    -> Arrayness               -- ^ Whether the image has an extra array component.+    -> MultiSampling           -- ^ Whether the image is multisampled.+    -> ImageUsage              -- ^ Is the image sampled or a storage image?+    -> Maybe (ImageFormat Nat) -- ^ 'SPIRV.Image.ImageFormat' of the image.+    -> ImageProperties++-- | The kind of coordinates that an image format supports.+data ImageCoordinateKind+  = IntegralCoordinates      -- ^ Access image texels using integral coordinates.+  | FloatingPointCoordinates -- ^ Access image texels using floating point coordinates.++instance Demotable ImageCoordinateKind where+  type Demote ImageCoordinateKind = ImageCoordinateKind+instance Known ImageCoordinateKind IntegralCoordinates where+  known = IntegralCoordinates+instance Known ImageCoordinateKind FloatingPointCoordinates where+  known = FloatingPointCoordinates++-- | Abstract handle to an image.+data Image (props :: ImageProperties)++-- newtype to retain injectivity of 'Demote' type family+newtype ImageAndCoordinate+  = ImageAndCoordinate (SPIRV.Image, ImageCoordinateKind)++instance Demotable ImageProperties where+  type Demote ImageProperties = ImageAndCoordinate++instance ( Known ImageCoordinateKind       coordKind+         , ScalarTy                        texelComp+         , Known Dimensionality            dimensionality+         , Known (Maybe HasDepth)          hasDepth+         , Known Arrayness                 arrayness+         , Known MultiSampling             multiSampling+         , Known ImageUsage                imageUsage+         , Known (Maybe (ImageFormat Nat)) imageFormat+         , MatchesFormat imageFormat texelComp+         )+  => Known ImageProperties+      ( 'Properties+           coordKind texelComp+           dimensionality hasDepth+           arrayness multiSampling+           imageUsage imageFormat+      )+  where+  known+    = ImageAndCoordinate+        ( SPIRV.Image+            { SPIRV.texelComponent   = scalarTy   @texelComp+            , SPIRV.dimensionality   = knownValue @dimensionality+            , SPIRV.hasDepth         = knownValue @hasDepth+            , SPIRV.arrayness        = knownValue @arrayness+            , SPIRV.multiSampling    = knownValue @multiSampling+            , SPIRV.imageUsage = Just (knownValue @imageUsage)+            , SPIRV.imageFormat      = knownValue @imageFormat+            }+        , knownValue @coordKind+        )+++-- $reflection+--+-- As image properties are provided at the type level,+-- we use the 'Data.Type.Known.Known' mechanism to reflect+-- this type-level information to the value level.++-- | Provided image properties at the type-level,+-- return the kind of coordinates that the image uses.+knownImageCoordinateKind+  :: forall props. Known ImageProperties props+  => ImageCoordinateKind+knownImageCoordinateKind+  = case knownValue @props of+      ImageAndCoordinate (_, coordKind) -> coordKind++-- | Return the 'SPIRV.Image.Image' type with the given properties.+knownImage :: forall props. Known ImageProperties props => SPIRV.Image+knownImage+  = case knownValue @props of+      ImageAndCoordinate (img, _) -> img++--------------------------------------------------+-- Image operands++-- | Names of image operands.+--+-- These are used to keep track at the type level of the operands+-- which have been provided.+--+-- This is necessary so that we can type check their usage,+-- and know which types are being used in conjunction with the image.+--+-- For instance, if a depth-comparison is being performed,+-- the return of an image sampling operation is a scalar,+-- whereas otherwise it is a 4-vector.+data OperandName+  = DepthComparison  -- ^ Whether a depth-comparison is being performed.+  | ProjectiveCoords -- ^ Whether to use projective coordinates.+  | BaseOperand SPIRV.Image.Operand -- A @SPIR-V@ image "SPIRV.Image.Operand".+  deriving stock ( Show, Eq, Ord )++-- | == Image operands.+--+-- As there is no support for images in the evaluator, this datatype holds no information.+--+-- However, values of type @Code (ImageOperands props ops)@+-- can be constructed using the constructors of the AST,+-- and these contain information necessary for image sample/read/write operations.+--+-- === Overview+-- Image operands behave like a linked list of operands, with a /twist/:+--+--   - the type of an image operand in the list can depend+--     on which operands appear further down in the list.+--+-- Consider for instance the image operands:+--+--    @ Grad grad $ Proj $ NilOps @+--+-- These can loosely be thought of as a list of operands+--+--    @ Grad grad : Proj : [] @+--+-- This means we are specifying explicit derivatives,+-- and using projective coordinates.+--+-- However, the fact that we are using projective coordinates+-- means that the explicit derivatives require an extra+-- component (the projective coordinate).+--+-- In this way, the type of the head of the list+-- depends on the operands appearing in the tail.+data ImageOperands+       ( props :: ImageProperties )+       ( ops   :: [OperandName]   )+  = SomeImageOperands+    deriving stock ( Eq, Ord, Show, Bounded, Enum )++-----------------------------------------------------------+-- data type for gather image operand++data Gather+  = ComponentGather+  | DrefGather+  deriving stock ( Show, Eq, Ord, Bounded, Enum )++-- | Information hat needs to be provided to the 'Gather' image operand.+--+-- This consists of 4 offsets, together with the information+-- of which image component (0,1,2,3) to gather+-- in the case that a depth test is /not/ being performed.+--+-- Instantiated with val ~ AST Word32 (left as a parameter to avoid cylic module dependencies).+data GatherInfo val (gather :: Gather) where+  ComponentWithOffsets+    :: val -> Array 4 (V 2 Int32) -> GatherInfo val ComponentGather+  DepthWithOffsets+    ::        Array 4 (V 2 Int32) -> GatherInfo val DrefGather++-- Computes whether a component index needs to be provided to the+-- 'Gather' image operand.+type family WhichGather (ops :: [OperandName]) :: Gather where+  WhichGather ops+    = If+        ( DepthComparison `Elem` ops  )+        DrefGather+        ComponentGather
+ src/FIR/Prim/Image.hs-boot view
@@ -0,0 +1,86 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE RoleAnnotations      #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++module FIR.Prim.Image where++-- base+import Data.Int+  ( Int32 )+import Data.Kind+  ( Type )+import Data.Type.Bool+  ( If )+import GHC.TypeNats+  ( Nat )++-- fir+import Data.Type.List+  ( Elem )+import FIR.Prim.Array+  ( Array )+import Math.Linear+  ( V )+import SPIRV.Image+  ( Arrayness(..)+  , Dimensionality(..)+  , HasDepth(..)+  , ImageUsage(..)+  , ImageFormat(..)+  , MultiSampling(..)+  , Operand+  )++--------------------------------------------------++data ImageCoordinateKind+  = IntegralCoordinates+  | FloatingPointCoordinates ++data ImageProperties where+  Properties+    :: ImageCoordinateKind+    -> Type+    -> Dimensionality+    -> Maybe HasDepth+    -> Arrayness+    -> MultiSampling+    -> ImageUsage+    -> Maybe (ImageFormat Nat)+    -> ImageProperties++data Image (props :: ImageProperties)+type role Image phantom++data OperandName+  = DepthComparison+  | ProjectiveCoords+  | BaseOperand SPIRV.Image.Operand++data ImageOperands+        ( props :: ImageProperties )+        ( ops   :: [OperandName]   )+      :: Type+type role ImageOperands phantom phantom++data Gather+  = ComponentGather+  | DrefGather++data GatherInfo val (gather :: Gather) where+ ComponentWithOffsets+   :: val -> Array 4 (V 2 Int32) -> GatherInfo val ComponentGather+ DepthWithOffsets+   ::        Array 4 (V 2 Int32) -> GatherInfo val DrefGather++type role GatherInfo representational nominal++type family WhichGather (ops :: [OperandName]) :: Gather where+  WhichGather ops+    = If+        ( DepthComparison `Elem` ops  )+        DrefGather+        ComponentGather
+ src/FIR/Prim/Op.hs view
@@ -0,0 +1,796 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE InstanceSigs           #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: FIR.Prim.Op++Recall that the AST has a 'FIR.AST.PrimOp' constructor+of the following type:++>   PrimOp :: PrimOp op a+>          => Proxy a -> Proxy op -> AST (PrimOpType op a)++This module provides the wrapper type class 'PrimOp' which relates+the internal SPIR-V operation names (as defined in "SPIRV.PrimOp")+with their types within the context of the AST.++This module also specifies which operations can be vectorised.+-}++module FIR.Prim.Op where++-- base+import Prelude+  ( Show(..), Functor(..), fromIntegral )+import Control.Applicative+  ( liftA2 )+import Data.Proxy+  ( Proxy(Proxy) )+import GHC.TypeNats+  ( Nat, KnownNat, natVal )++-- fir+import Data.Constraint.All+  ( All )+import FIR.AST.Type+  ( AugType(Val, (:-->)), Eff, FunArgs, UnderlyingType, Nullary+  , ApplyFAug+  )+import FIR.Prelude+import FIR.Prim.RayTracing+  ( AccelerationStructure )+import FIR.Prim.Types+  ( PrimTy, ScalarTy+  , primTy, scalarTy+  )+import FIR.ProgramState+  ( ProgramState )+import Math.Linear+  ( V, M+  , Semimodule((^*)), Inner(dot, normalise), Cross(cross)+  , Matrix(..)+  )+import Math.Logic.Bits+  ( Bits(..), BitShift(..), BitCast(..) )+import Math.Logic.Class+  ( Boolean(..), Eq(..), Ord(..) )+import Math.Algebra.Class+  ( AdditiveMonoid(..), CancellativeAdditiveMonoid(..), AdditiveGroup(..)+  , Semiring(..), Signed(..)+  , Archimedean(..)+  , DivisionRing(..)+  , Floating(..), RealFloat(..)+  , Convert(..), Rounding(..)+  )+import qualified SPIRV.PrimOp as SPIRV+import qualified SPIRV.PrimTy as SPIRV+  ( PrimTy(..) )++-------------------------------------------------------------------------------+-- primitive operations++class All Nullary ( FunArgs (PrimOpAugType op a) ) => PrimOp (op :: opKind) (a :: k) | op -> k where+  type PrimOpAugType op a :: AugType+  op :: PrimOpType op a+  op = error+    ( "unsupported primitive operation " <> show ( opName @_ @_ @op @a ) )+  opName :: SPIRV.PrimOp+  opSing :: Maybe (SPrimOp a op)+  opSing = Nothing+  vectorisation :: KnownNat n => Maybe (VecPrimOpType n op a)+  vectorisation = Nothing++type PrimOpType op a = UnderlyingType ( PrimOpAugType op a )++-- some singletons for primitive operations+-- (only defining those that we use in code generation)+data SPrimOp (a :: k) (op :: opKind) :: Type where+  SMul :: (ScalarTy a, Semiring a) => SPrimOp a SPIRV.Mul+  +-- data type recording type-level information regarding vectorisation of primops+data VecPrimOpType (n :: Nat) op a where+  VecPrimOpType+    :: ( PrimOp ('Vectorise op) vec+       , All PrimTyVal (FunArgs (PrimOpAugType op a))+       , PrimOpAugType ('Vectorise op) vec ~ ApplyFAug (V n) (PrimOpAugType op a)+       )+    => Proxy vec -> VecPrimOpType n op a++newtype Vectorise a = Vectorise a++class    ( v ~ Val (UnderlyingType v), PrimTy (UnderlyingType v) ) => PrimTyVal v+instance ( v ~ Val (UnderlyingType v), PrimTy (UnderlyingType v) ) => PrimTyVal v++-------------------------------------------------------------------------------+-- instances++-- boolean operations+instance PrimOp SPIRV.BoolOr Bool where+  type PrimOpAugType SPIRV.BoolOr Bool = Val Bool :--> Val Bool :--> Val Bool+  op = (||)+  opName = SPIRV.BoolOp SPIRV.BoolOr+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BoolOr Bool)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n Bool))+instance PrimOp SPIRV.BoolAnd Bool where+  type PrimOpAugType SPIRV.BoolAnd Bool = Val Bool :--> Val Bool :--> Val Bool+  op = (&&)+  opName = SPIRV.BoolOp SPIRV.BoolAnd+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BoolAnd Bool)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n Bool))+instance PrimOp SPIRV.BoolNot Bool where+  type PrimOpAugType SPIRV.BoolNot Bool = Val Bool :--> Val Bool+  op = not+  opName = SPIRV.BoolOp SPIRV.BoolNot+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BoolNot Bool)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n Bool))++-- equality operations+instance (PrimTy a, Eq a, Logic a ~ Bool) => PrimOp SPIRV.Equal (a :: Type) where+  type PrimOpAugType SPIRV.Equal a = Val a :--> Val a :--> Val Bool+  op = (==)+  opName = SPIRV.EqOp SPIRV.Equal (primTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Equal a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (PrimTy a, Eq a, Logic a ~ Bool) => PrimOp SPIRV.NotEqual (a :: Type) where+  type PrimOpAugType SPIRV.NotEqual a = Val a :--> Val a :--> Val Bool+  op = (/=)+  opName = SPIRV.EqOp SPIRV.NotEqual (primTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.NotEqual a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))++-- comparison+instance (ScalarTy a, Ord a, Logic a ~ Bool) => PrimOp SPIRV.GT (a :: Type) where+  type PrimOpAugType SPIRV.GT a = Val a :--> Val a :--> Val Bool+  op = (>)+  opName = SPIRV.OrdOp SPIRV.GT (scalarTy @a)+instance (ScalarTy a, Ord a, Logic a ~ Bool) => PrimOp SPIRV.GTE (a :: Type) where+  type PrimOpAugType SPIRV.GTE a = Val a :--> Val a :--> Val Bool+  op = (>=)+  opName = SPIRV.OrdOp SPIRV.GTE (scalarTy @a)+instance (ScalarTy a, Ord a, Logic a ~ Bool) => PrimOp SPIRV.LT (a :: Type) where+  type PrimOpAugType SPIRV.LT a = Val a :--> Val a :--> Val Bool+  op = (<)+  opName = SPIRV.OrdOp SPIRV.LT (scalarTy @a)+instance (ScalarTy a, Ord a, Logic a ~ Bool) => PrimOp SPIRV.LTE (a :: Type) where+  type PrimOpAugType SPIRV.LTE a = Val a :--> Val a :--> Val Bool+  op = (<=)+  opName = SPIRV.OrdOp SPIRV.LTE (scalarTy @a)+instance (ScalarTy a, Ord a, Logic a ~ Bool) => PrimOp SPIRV.Min (a :: Type) where+  type PrimOpAugType SPIRV.Min a = Val a :--> Val a :--> Val a+  op = min+  opName = SPIRV.OrdOp SPIRV.Min (scalarTy @a)+instance (ScalarTy a, Ord a, Logic a ~ Bool) => PrimOp SPIRV.Max (a :: Type) where+  type PrimOpAugType SPIRV.Max a = Val a :--> Val a :--> Val a+  op = max+  opName = SPIRV.OrdOp SPIRV.Max (scalarTy @a)++-- bitwise operations+instance (ScalarTy a, Bits a) => PrimOp SPIRV.BitAnd (a :: Type) where+  type PrimOpAugType SPIRV.BitAnd a = Val a :--> Val a :--> Val a+  op = (.&.)+  opName = SPIRV.BitOp SPIRV.BitAnd (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BitAnd a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Bits a) => PrimOp SPIRV.BitOr (a :: Type) where+  type PrimOpAugType SPIRV.BitOr a = Val a :--> Val a :--> Val a+  op = (.|.)+  opName = SPIRV.BitOp SPIRV.BitOr (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BitOr a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Bits a) => PrimOp SPIRV.BitXor (a :: Type) where+  type PrimOpAugType SPIRV.BitXor a = Val a :--> Val a :--> Val a+  op = xor+  opName = SPIRV.BitOp SPIRV.BitXor (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BitXor a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Bits a) => PrimOp SPIRV.BitNot (a :: Type) where+  type PrimOpAugType SPIRV.BitNot a = Val a :--> Val a+  op = complement+  opName = SPIRV.BitOp SPIRV.BitNot (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BitNot a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Bits a) => PrimOp SPIRV.ReverseBits (a :: Type) where+  type PrimOpAugType SPIRV.ReverseBits a = Val a :--> Val a+  op = bitReverse+  opName = SPIRV.BitOp SPIRV.ReverseBits (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.ReverseBits a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance forall (b :: Type) (s :: Type). (ScalarTy b, PrimTy s, BitShift '(b,s))+        => PrimOp SPIRV.BitShiftRight '(b,s) where+  type PrimOpAugType SPIRV.BitShiftRight '(b,s) = Val b :--> Val s :--> Val b+  op = shiftR+  opName = SPIRV.BitOp SPIRV.BitShiftRight (scalarTy @b)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BitShiftRight '(b,s))+  vectorisation = Just $ VecPrimOpType (Proxy @'(V n b, V n s))+instance forall (b :: Type) (s :: Type). (ScalarTy b, PrimTy s, BitShift '(b,s))+      => PrimOp SPIRV.BitShiftLeft '(b,s) where+  type PrimOpAugType SPIRV.BitShiftLeft '(b,s) = Val b :--> Val s :--> Val b+  op = shiftL+  opName = SPIRV.BitOp SPIRV.BitShiftLeft (scalarTy @b)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BitShiftLeft '(b,s))+  vectorisation = Just $ VecPrimOpType (Proxy @'(V n b, V n s))++-- bitcast operation+instance (ScalarTy a, ScalarTy b, BitCast a b) => PrimOp SPIRV.CastOp '(a,b) where+  type PrimOpAugType SPIRV.CastOp '(a,b) = Val a :--> Val b+  op = bitcast+  opName = SPIRV.CastOp (primTy @b)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.CastOp '(a,b))+  vectorisation = Just $ VecPrimOpType (Proxy @'(V n a, V n b))++-- numeric operations+instance (ScalarTy a, AdditiveMonoid a) => PrimOp SPIRV.Add (a :: Type) where+  type PrimOpAugType SPIRV.Add a = Val a :--> Val a :--> Val a+  op = (+)+  opName = SPIRV.NumOp SPIRV.Add (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Add a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Semiring a) => PrimOp SPIRV.Mul (a :: Type) where+  type PrimOpAugType SPIRV.Mul a = Val a :--> Val a :--> Val a+  op = (*)+  opName = SPIRV.NumOp SPIRV.Mul (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Mul a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+  opSing = Just SMul+instance (ScalarTy a, CancellativeAdditiveMonoid a) => PrimOp SPIRV.Sub (a :: Type) where+  type PrimOpAugType SPIRV.Sub a = Val a :--> Val a :--> Val a+  op = (-)+  opName = SPIRV.NumOp SPIRV.Sub (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Sub a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, AdditiveGroup a) => PrimOp SPIRV.Neg (a :: Type) where+  type PrimOpAugType SPIRV.Neg a = Val a :--> Val a+  op = negate+  opName = SPIRV.NumOp SPIRV.Neg (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Neg a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Signed a) => PrimOp SPIRV.Abs (a :: Type) where+  type PrimOpAugType SPIRV.Abs a = Val a :--> Val a+  op = abs+  opName = SPIRV.NumOp SPIRV.Abs (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Abs a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Signed a) => PrimOp SPIRV.Sign (a :: Type) where+  type PrimOpAugType SPIRV.Sign a = Val a :--> Val a+  op = signum+  opName = SPIRV.NumOp SPIRV.Sign (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Sign a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, DivisionRing a) => PrimOp SPIRV.Div (a :: Type) where+  type PrimOpAugType SPIRV.Div a = Val a :--> Val a :--> Val a+  op = (/)+  opName = SPIRV.NumOp SPIRV.Div (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Div a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Archimedean a) => PrimOp SPIRV.Mod (a :: Type) where+  type PrimOpAugType SPIRV.Mod a = Val a :--> Val a :--> Val a+  op = mod+  opName = SPIRV.NumOp SPIRV.Mod (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Mod a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Archimedean a) => PrimOp SPIRV.Rem (a :: Type) where+  type PrimOpAugType SPIRV.Rem a = Val a :--> Val a :--> Val a+  op = rem+  opName = SPIRV.NumOp SPIRV.Rem (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Rem a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Archimedean a) => PrimOp SPIRV.Quot (a :: Type) where+  type PrimOpAugType SPIRV.Quot a = Val a :--> Val a :--> Val a+  op = div+  opName = SPIRV.NumOp SPIRV.Quot (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Quot a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+++-- floating operations+instance (ScalarTy a, Floating a) => PrimOp SPIRV.FSin (a :: Type) where+  type PrimOpAugType SPIRV.FSin a = Val a :--> Val a+  op = sin+  opName = SPIRV.FloatOp SPIRV.FSin (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FSin a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Floating a) => PrimOp SPIRV.FCos (a :: Type) where+  type PrimOpAugType SPIRV.FCos a = Val a :--> Val a+  op = cos+  opName = SPIRV.FloatOp SPIRV.FCos (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FCos a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Floating a) => PrimOp SPIRV.FTan (a :: Type) where+  type PrimOpAugType SPIRV.FTan a = Val a :--> Val a+  op = tan+  opName = SPIRV.FloatOp SPIRV.FTan (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FTan a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Floating a) => PrimOp SPIRV.FAsin (a :: Type) where+  type PrimOpAugType SPIRV.FAsin a = Val a :--> Val a+  op = asin+  opName = SPIRV.FloatOp SPIRV.FAsin (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FAsin a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Floating a) => PrimOp SPIRV.FAcos (a :: Type) where+  type PrimOpAugType SPIRV.FAcos a = Val a :--> Val a+  op = acos+  opName = SPIRV.FloatOp SPIRV.FAcos (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FAcos a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Floating a) => PrimOp SPIRV.FAtan (a :: Type) where+  type PrimOpAugType SPIRV.FAtan a = Val a :--> Val a+  op = atan+  opName = SPIRV.FloatOp SPIRV.FAtan (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FAtan a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Floating a) => PrimOp SPIRV.FSinh (a :: Type) where+  type PrimOpAugType SPIRV.FSinh a = Val a :--> Val a+  op = sinh+  opName = SPIRV.FloatOp SPIRV.FSinh (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FSinh a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Floating a) => PrimOp SPIRV.FCosh (a :: Type) where+  type PrimOpAugType SPIRV.FCosh a = Val a :--> Val a+  op = cosh+  opName = SPIRV.FloatOp SPIRV.FCosh (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FCosh a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Floating a) => PrimOp SPIRV.FTanh (a :: Type) where+  type PrimOpAugType SPIRV.FTanh a = Val a :--> Val a+  op = tanh+  opName = SPIRV.FloatOp SPIRV.FTanh (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FTanh a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Floating a) => PrimOp SPIRV.FAsinh (a :: Type) where+  type PrimOpAugType SPIRV.FAsinh a = Val a :--> Val a+  op = asinh+  opName = SPIRV.FloatOp SPIRV.FAsinh (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FAsinh a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Floating a) => PrimOp SPIRV.FAcosh (a :: Type) where+  type PrimOpAugType SPIRV.FAcosh a = Val a :--> Val a+  op = acosh+  opName = SPIRV.FloatOp SPIRV.FAcosh (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FAcosh a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Floating a) => PrimOp SPIRV.FAtanh (a :: Type) where+  type PrimOpAugType SPIRV.FAtanh a = Val a :--> Val a+  op = atanh+  opName = SPIRV.FloatOp SPIRV.FAtanh (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FAtanh a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, RealFloat a) => PrimOp SPIRV.FAtan2 (a :: Type) where+  type PrimOpAugType SPIRV.FAtan2 a = Val a :--> Val a :--> Val a+  op = atan2+  opName = SPIRV.FloatOp SPIRV.FAtan2 (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FAtan2 a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Floating a) => PrimOp SPIRV.FPow (a :: Type) where+  type PrimOpAugType SPIRV.FPow a = Val a :--> Val a :--> Val a+  op = (**)+  opName = SPIRV.FloatOp SPIRV.FPow (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FPow a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Floating a) => PrimOp SPIRV.FExp (a :: Type) where+  type PrimOpAugType SPIRV.FExp a = Val a :--> Val a+  op = exp+  opName = SPIRV.FloatOp SPIRV.FExp (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FExp a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Floating a) => PrimOp SPIRV.FLog (a :: Type) where+  type PrimOpAugType SPIRV.FLog a = Val a :--> Val a+  op = log+  opName = SPIRV.FloatOp SPIRV.FLog (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FLog a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Floating a) => PrimOp SPIRV.FSqrt (a :: Type) where+  type PrimOpAugType SPIRV.FSqrt a = Val a :--> Val a+  op = sqrt+  opName = SPIRV.FloatOp SPIRV.FSqrt (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FSqrt a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, Floating a) => PrimOp SPIRV.FInvSqrt (a :: Type) where+  type PrimOpAugType SPIRV.FInvSqrt a = Val a :--> Val a+  op = recip . sqrt+  opName = SPIRV.FloatOp SPIRV.FInvSqrt (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FInvSqrt a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, RealFloat a, Logic a ~ Bool) => PrimOp SPIRV.FIsNaN (a :: Type) where+  type PrimOpAugType SPIRV.FIsNaN a = Val a :--> Val Bool+  op = isNaN+  opName = SPIRV.FloatOp SPIRV.FIsNaN (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FIsNaN a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))+instance (ScalarTy a, RealFloat a, Logic a ~ Bool) => PrimOp SPIRV.FIsInf (a :: Type) where+  type PrimOpAugType SPIRV.FIsInf a = Val a :--> Val Bool+  op = isInfinite+  opName = SPIRV.FloatOp SPIRV.FIsInf (scalarTy @a)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FIsInf a)+  vectorisation = Just $ VecPrimOpType (Proxy @(V n a))++-- numeric conversions+instance ( ScalarTy a, ScalarTy b, Convert '(a,b) ) => PrimOp SPIRV.Convert '(a,b) where+  type PrimOpAugType SPIRV.Convert '(a,b) = Val a :--> Val b+  op = convert+  opName = SPIRV.ConvOp SPIRV.Convert (scalarTy @a) (scalarTy @b)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Convert '(a,b))+  vectorisation = Just $ VecPrimOpType (Proxy @'(V n a, V n b))+instance ( ScalarTy a, ScalarTy b, Rounding '(a,b) ) => PrimOp SPIRV.CTruncate '(a,b) where+  type PrimOpAugType SPIRV.CTruncate '(a,b) = Val a :--> Val b+  op = truncate+  opName = SPIRV.ConvOp SPIRV.CTruncate (scalarTy @a) (scalarTy @b)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.CTruncate '(a,b))+  vectorisation = Just $ VecPrimOpType (Proxy @'(V n a, V n b))+instance ( ScalarTy a, ScalarTy b, Rounding '(a,b) ) => PrimOp SPIRV.CRound '(a,b) where+  type PrimOpAugType SPIRV.CRound '(a,b) = Val a :--> Val b+  op = round+  opName = SPIRV.ConvOp SPIRV.CRound (scalarTy @a) (scalarTy @b)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.CRound '(a,b))+  vectorisation = Just $ VecPrimOpType (Proxy @'(V n a, V n b))+instance ( ScalarTy a, ScalarTy b, Rounding '(a,b) ) => PrimOp SPIRV.CFloor '(a,b) where+  type PrimOpAugType SPIRV.CFloor '(a,b) = Val a :--> Val b+  op = floor+  opName = SPIRV.ConvOp SPIRV.CFloor (scalarTy @a) (scalarTy @b)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.CFloor '(a,b))+  vectorisation = Just $ VecPrimOpType (Proxy @'(V n a, V n b))+instance ( ScalarTy a, ScalarTy b, Rounding '(a,b) ) => PrimOp SPIRV.CCeiling '(a,b) where+  type PrimOpAugType SPIRV.CCeiling '(a,b) = Val a :--> Val b+  op = ceiling+  opName = SPIRV.ConvOp SPIRV.CCeiling (scalarTy @a) (scalarTy @b)+  vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.CCeiling '(a,b))+  vectorisation = Just $ VecPrimOpType (Proxy @'(V n a, V n b))++-- geometry primitive instructions+instance PrimOp SPIRV.EmitGeometryVertex (i :: ProgramState) where+  type PrimOpAugType SPIRV.EmitGeometryVertex i = Eff i i ()+  opName = SPIRV.GeomOp SPIRV.EmitGeometryVertex+instance PrimOp SPIRV.EndGeometryPrimitive (i :: ProgramState) where+  type PrimOpAugType SPIRV.EndGeometryPrimitive i = Eff i i ()+  opName = SPIRV.GeomOp SPIRV.EndGeometryPrimitive++-- memory synchronisation instructions+instance PrimOp SPIRV.ControlSync (i :: ProgramState) where+  type PrimOpAugType SPIRV.ControlSync i = Val Word32 :--> Val Word32 :--> Val Word32 :--> Eff i i ()+  opName = SPIRV.SyncOp SPIRV.ControlSync+instance PrimOp SPIRV.MemorySync (i :: ProgramState) where+  type PrimOpAugType SPIRV.MemorySync i = Val Word32 :--> Val Word32 :--> Eff i i ()+  opName = SPIRV.SyncOp SPIRV.MemorySync++-- non uniform subgroup instructions+instance ( ScalarTy a, AdditiveMonoid a) => PrimOp SPIRV.GroupAdd '(i :: ProgramState, a) where+    type PrimOpAugType SPIRV.GroupAdd '(i,a) = Val Word32 :--> Val Word32 :--> Val a :--> Eff i i a+    opName = SPIRV.GroupOp $ SPIRV.GroupNumOp SPIRV.GroupAdd (scalarTy @a)+instance ( ScalarTy a, Semiring a) => PrimOp SPIRV.GroupMul '(i :: ProgramState, a)  where+    type PrimOpAugType SPIRV.GroupMul '(i,a) = Val Word32 :--> Val Word32 :--> Val a :--> Eff i i a+    opName = SPIRV.GroupOp $ SPIRV.GroupNumOp SPIRV.GroupMul (scalarTy @a)    +instance ( ScalarTy a, Ord a) => PrimOp SPIRV.GroupMin '(i :: ProgramState, a)  where+    type PrimOpAugType SPIRV.GroupMin '(i,a) = Val Word32 :--> Val Word32 :--> Val a :--> Eff i i a+    opName = SPIRV.GroupOp $ SPIRV.GroupNumOp SPIRV.GroupMin (scalarTy @a)+instance ( ScalarTy a, Ord a) => PrimOp SPIRV.GroupMax '(i :: ProgramState, a)  where+    type PrimOpAugType SPIRV.GroupMax '(i,a) = Val Word32 :--> Val Word32 :--> Val a :--> Eff i i a+    opName = SPIRV.GroupOp $ SPIRV.GroupNumOp SPIRV.GroupMax (scalarTy @a)+instance ( ScalarTy a ) => PrimOp SPIRV.GroupBitwiseAnd '(i :: ProgramState, a) where+    type PrimOpAugType SPIRV.GroupBitwiseAnd '(i,a) = Val Word32 :--> Val Word32 :--> Val a :--> Eff i i a+    opName = SPIRV.GroupOp $ SPIRV.GroupBitwiseOp SPIRV.GroupBitwiseAnd (scalarTy @a)+instance ( ScalarTy a ) => PrimOp SPIRV.GroupBitwiseOr '(i :: ProgramState, a) where+    type PrimOpAugType SPIRV.GroupBitwiseOr '(i,a) = Val Word32 :--> Val Word32 :--> Val a :--> Eff i i a+    opName = SPIRV.GroupOp $ SPIRV.GroupBitwiseOp SPIRV.GroupBitwiseOr (scalarTy @a)+instance ( ScalarTy a ) => PrimOp SPIRV.GroupBitwiseXor '(i :: ProgramState, a) where+    type PrimOpAugType SPIRV.GroupBitwiseXor '(i,a) = Val Word32 :--> Val Word32 :--> Val a :--> Eff i i a+    opName = SPIRV.GroupOp $ SPIRV.GroupBitwiseOp SPIRV.GroupBitwiseXor (scalarTy @a)+instance PrimOp SPIRV.GroupLogicalAnd (i :: ProgramState)  where+    type PrimOpAugType SPIRV.GroupLogicalAnd i = Val Word32 :--> Val Word32 :--> Val Bool :--> Eff i i Bool+    opName = SPIRV.GroupOp $ SPIRV.GroupLogicOp SPIRV.GroupLogicalAnd+instance PrimOp SPIRV.GroupLogicalOr (i :: ProgramState)  where+    type PrimOpAugType SPIRV.GroupLogicalOr i = Val Word32 :--> Val Word32 :--> Val Bool :--> Eff i i Bool+    opName = SPIRV.GroupOp $ SPIRV.GroupLogicOp SPIRV.GroupLogicalOr+instance PrimOp SPIRV.GroupLogicalXor (i :: ProgramState)  where+    type PrimOpAugType SPIRV.GroupLogicalXor i = Val Word32 :--> Val Word32 :--> Val Bool :--> Eff i i Bool+    opName = SPIRV.GroupOp $ SPIRV.GroupLogicOp SPIRV.GroupLogicalXor++-- ray tracing instructions+instance PrimOp SPIRV.RT_ReportIntersection (i :: ProgramState) where+  type PrimOpAugType SPIRV.RT_ReportIntersection i = Val Float :--> Val Word32 :--> Eff i i Bool+  opName = SPIRV.RayOp SPIRV.RT_ReportIntersection+instance PrimOp SPIRV.RT_IgnoreIntersection (i :: ProgramState) where+  type PrimOpAugType SPIRV.RT_IgnoreIntersection i = Eff i i ()+  opName = SPIRV.RayOp SPIRV.RT_IgnoreIntersection+instance PrimOp SPIRV.RT_TerminateRay (i :: ProgramState) where+  type PrimOpAugType SPIRV.RT_TerminateRay i = Eff i i ()+  opName = SPIRV.RayOp SPIRV.RT_TerminateRay+instance PrimOp SPIRV.RT_AccelerationStructureFromDeviceAddress '() where+  type PrimOpAugType SPIRV.RT_AccelerationStructureFromDeviceAddress _ = Val Word64 :--> Val AccelerationStructure+  opName = SPIRV.RayOp SPIRV.RT_AccelerationStructureFromDeviceAddress++-- vector operations+-- doing it by hand because I'm an idiot who doesn't know better++val :: forall n. KnownNat n => Word32+val = fromIntegral ( natVal (Proxy @n) )+++instance KnownNat n => PrimOp ('Vectorise SPIRV.BoolOr) (V n Bool) where+  type PrimOpAugType ('Vectorise SPIRV.BoolOr) (V n Bool) = Val (V n Bool) :--> Val (V n Bool) :--> Val (V n Bool)+  op = liftA2 (||)+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BoolOr @Bool)) (val @n) SPIRV.Boolean+instance KnownNat n => PrimOp ('Vectorise SPIRV.BoolAnd) (V n Bool) where+  type PrimOpAugType ('Vectorise SPIRV.BoolAnd) (V n Bool) = Val (V n Bool) :--> Val (V n Bool) :--> Val (V n Bool)+  op = liftA2 (&&)+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BoolAnd @Bool)) (val @n) SPIRV.Boolean+instance KnownNat n => PrimOp ('Vectorise SPIRV.BoolNot) (V n Bool) where+  type PrimOpAugType ('Vectorise SPIRV.BoolNot) (V n Bool) = Val (V n Bool) :--> Val (V n Bool)+  op = fmap not+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BoolNot @Bool)) (val @n) SPIRV.Boolean++instance ( KnownNat n, PrimTy a, Eq a, Logic a ~ Bool ) => PrimOp ('Vectorise SPIRV.Equal) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.Equal) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n Bool)+  op = liftA2 (==)+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Equal @a)) (val @n) SPIRV.Boolean+instance ( KnownNat n, PrimTy a, Eq a, Logic a ~ Bool ) => PrimOp ('Vectorise SPIRV.NotEqual) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.NotEqual) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n Bool)+  op = liftA2 (/=)+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.NotEqual @a)) (val @n) SPIRV.Boolean++instance (KnownNat n, ScalarTy a, AdditiveMonoid a) => PrimOp ('Vectorise SPIRV.GroupAdd) '(i :: ProgramState, V n a)  where+  type PrimOpAugType ('Vectorise SPIRV.GroupAdd) '(i,V n a) = Val Word32 :--> Val Word32 :--> Val (V n a) :--> Eff i i (V n a)+  opName = SPIRV.VecOp (SPIRV.Vectorise  (opName @_ @_ @SPIRV.GroupAdd @'(i, a))) (val @n) (primTy @a)+instance (KnownNat n, ScalarTy a, Semiring a) => PrimOp ('Vectorise SPIRV.GroupMul) '(i :: ProgramState, V n a)  where+  type PrimOpAugType ('Vectorise SPIRV.GroupMul) '(i,V n a) = Val Word32 :--> Val Word32 :--> Val (V n a) :--> Eff i i (V n a)+  opName = SPIRV.VecOp (SPIRV.Vectorise  (opName @_ @_ @SPIRV.GroupMul @'(i, a))) (val @n) (primTy @a)    +instance (KnownNat n, ScalarTy a, Ord a) => PrimOp ('Vectorise SPIRV.GroupMin) '(i :: ProgramState, V n a)  where+  type PrimOpAugType ('Vectorise SPIRV.GroupMin) '(i,V n a) = Val Word32 :--> Val Word32 :--> Val (V n a) :--> Eff i i (V n a)+  opName = SPIRV.VecOp (SPIRV.Vectorise  (opName @_ @_ @SPIRV.GroupMin @'(i, a))) (val @n) (primTy @a)+instance (KnownNat n, ScalarTy a, Ord a) => PrimOp ('Vectorise SPIRV.GroupMax) '(i :: ProgramState, V n a)  where+  type PrimOpAugType ('Vectorise SPIRV.GroupMax) '(i,V n a) = Val Word32 :--> Val Word32 :--> Val (V n a) :--> Eff i i (V n a)+  opName = SPIRV.VecOp (SPIRV.Vectorise  (opName @_ @_ @SPIRV.GroupMax @'(i, a))) (val @n) (primTy @a)+instance (KnownNat n, ScalarTy a, Bits a) => PrimOp ('Vectorise SPIRV.GroupBitwiseAnd) '(i :: ProgramState, V n a)  where+  type PrimOpAugType ('Vectorise SPIRV.GroupBitwiseAnd) '(i,V n a) = Val Word32 :--> Val Word32 :--> Val (V n a) :--> Eff i i (V n a)+  opName = SPIRV.VecOp (SPIRV.Vectorise  (opName @_ @_ @SPIRV.GroupBitwiseAnd @'(i, a))) (val @n) (primTy @a)+instance (KnownNat n, ScalarTy a, Bits a) => PrimOp ('Vectorise SPIRV.GroupBitwiseOr) '(i :: ProgramState, V n a)  where+  type PrimOpAugType ('Vectorise SPIRV.GroupBitwiseOr) '(i,V n a) = Val Word32 :--> Val Word32 :--> Val (V n a) :--> Eff i i (V n a)+  opName = SPIRV.VecOp (SPIRV.Vectorise  (opName @_ @_ @SPIRV.GroupBitwiseOr @'(i, a))) (val @n) (primTy @a)+instance (KnownNat n, ScalarTy a, Bits a) => PrimOp ('Vectorise SPIRV.GroupBitwiseXor) '(i :: ProgramState, V n a)  where+  type PrimOpAugType ('Vectorise SPIRV.GroupBitwiseXor) '(i,V n a) = Val Word32 :--> Val Word32 :--> Val (V n a) :--> Eff i i (V n a)+  opName = SPIRV.VecOp (SPIRV.Vectorise  (opName @_ @_ @SPIRV.GroupBitwiseXor @'(i, a))) (val @n) (primTy @a)+instance (KnownNat n) => PrimOp ('Vectorise SPIRV.GroupLogicalAnd) '(i :: ProgramState, n :: Nat)  where+  type PrimOpAugType ('Vectorise SPIRV.GroupLogicalAnd) '(i,n) = Val Word32 :--> Val Word32 :--> Val (V n Bool) :--> Eff i i (V n Bool)+  opName = SPIRV.VecOp (SPIRV.Vectorise  (opName @_ @_ @SPIRV.GroupLogicalAnd @i)) (val @n) SPIRV.Boolean+instance (KnownNat n) => PrimOp ('Vectorise SPIRV.GroupLogicalOr) '(i :: ProgramState, n :: Nat)  where+  type PrimOpAugType ('Vectorise SPIRV.GroupLogicalOr) '(i,n) = Val Word32 :--> Val Word32 :--> Val (V n Bool) :--> Eff i i (V n Bool)+  opName = SPIRV.VecOp (SPIRV.Vectorise  (opName @_ @_ @SPIRV.GroupLogicalOr @i)) (val @n) SPIRV.Boolean+instance (KnownNat n) => PrimOp ('Vectorise SPIRV.GroupLogicalXor) '(i :: ProgramState, n :: Nat)  where+  type PrimOpAugType ('Vectorise SPIRV.GroupLogicalXor) '(i,n) = Val Word32 :--> Val Word32 :--> Val (V n Bool) :--> Eff i i (V n Bool)+  opName = SPIRV.VecOp (SPIRV.Vectorise  (opName @_ @_ @SPIRV.GroupLogicalXor @i)) (val @n) SPIRV.Boolean++instance ( KnownNat n, ScalarTy a, Bits a ) => PrimOp ('Vectorise SPIRV.BitAnd) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.BitAnd) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a)+  op = liftA2 (.&.)+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BitAnd @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Bits a  ) => PrimOp ('Vectorise SPIRV.BitOr) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.BitOr) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a)+  op = liftA2 (.|.)+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BitOr @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Bits a  ) => PrimOp ('Vectorise SPIRV.BitXor) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.BitXor) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a)+  op = liftA2 xor+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BitXor @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Bits a ) => PrimOp ('Vectorise SPIRV.BitNot) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.BitNot) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap complement+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BitNot @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Bits a ) => PrimOp ('Vectorise SPIRV.ReverseBits) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.ReverseBits) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap bitReverse+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.ReverseBits @a)) (val @n) (primTy @a)++instance ( KnownNat n, ScalarTy a, ScalarTy b, BitCast a b ) => PrimOp ('Vectorise SPIRV.CastOp) '(V n a, V n b) where+  type PrimOpAugType ('Vectorise SPIRV.CastOp) '(V n a, V n b) = Val (V n a) :--> Val (V n b)+  op = fmap bitcast+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.CastOp @'(a,b))) (val @n) (primTy @b)++instance ( KnownNat n, ScalarTy b, PrimTy s, BitShift '(b,s) ) => PrimOp ('Vectorise SPIRV.BitShiftRight) '(V n b, V n s) where+  type PrimOpAugType ('Vectorise SPIRV.BitShiftRight) '(V n b, V n s) = Val (V n b) :--> Val (V n s) :--> Val (V n b)+  op = liftA2 shiftR+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BitShiftRight @'(b,s))) (val @n) (primTy @b)+instance ( KnownNat n, ScalarTy b, PrimTy s, BitShift '(b,s) ) => PrimOp ('Vectorise SPIRV.BitShiftLeft) '(V n b, V n s) where+  type PrimOpAugType ('Vectorise SPIRV.BitShiftLeft) '(V n b, V n s) = Val (V n b) :--> Val (V n s) :--> Val (V n b)+  op = liftA2 shiftL+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BitShiftLeft @'(b,s))) (val @n) (primTy @b)++instance ( KnownNat n, ScalarTy a, AdditiveMonoid a ) => PrimOp ('Vectorise SPIRV.Add) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.Add) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a)+  op = liftA2 (+)+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Add @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, CancellativeAdditiveMonoid a ) => PrimOp ('Vectorise SPIRV.Sub) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.Sub) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a)+  op = liftA2 (-)+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Sub @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, AdditiveGroup a ) => PrimOp ('Vectorise SPIRV.Neg) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.Neg) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap negate+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Neg @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Semiring a ) => PrimOp ('Vectorise SPIRV.Mul) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.Mul) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a)+  op = liftA2 (*)+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Mul @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Signed a ) => PrimOp ('Vectorise SPIRV.Abs) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.Abs) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap abs+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Abs @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Signed a ) => PrimOp ('Vectorise SPIRV.Sign) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.Sign) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap signum+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Sign @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, DivisionRing a ) => PrimOp ('Vectorise SPIRV.Div) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.Div) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a)+  op = liftA2 (/)+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Div @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Archimedean a ) => PrimOp ('Vectorise SPIRV.Mod) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.Mod) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a)+  op = liftA2 mod+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Mod @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Archimedean a ) => PrimOp ('Vectorise SPIRV.Rem) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.Rem) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a)+  op = liftA2 rem+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Rem @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Archimedean a ) => PrimOp ('Vectorise SPIRV.Quot) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.Quot) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a)+  op = liftA2 div+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Quot @a)) (val @n) (primTy @a)++instance ( KnownNat n, ScalarTy a, ScalarTy b, Convert '(a,b) ) => PrimOp ('Vectorise SPIRV.Convert) '(V n a, V n b) where+  type PrimOpAugType ('Vectorise SPIRV.Convert) '(V n a, V n b) = Val (V n a) :--> Val (V n b)+  op = fmap convert+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Convert @'(a,b))) (val @n) (primTy @b)+instance ( KnownNat n, ScalarTy a, ScalarTy b, Rounding '(a,b) ) => PrimOp ('Vectorise SPIRV.CTruncate) '(V n a, V n b) where+  type PrimOpAugType ('Vectorise SPIRV.CTruncate) '(V n a, V n b) = Val (V n a) :--> Val (V n b)+  op = fmap truncate+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.CTruncate @'(a,b))) (val @n) (primTy @b)+instance ( KnownNat n, ScalarTy a, ScalarTy b, Rounding '(a,b) ) => PrimOp ('Vectorise SPIRV.CRound) '(V n a, V n b) where+  type PrimOpAugType ('Vectorise SPIRV.CRound) '(V n a, V n b) = Val (V n a) :--> Val (V n b)+  op = fmap round+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.CRound @'(a,b))) (val @n) (primTy @b)+instance ( KnownNat n, ScalarTy a, ScalarTy b, Rounding '(a,b) ) => PrimOp ('Vectorise SPIRV.CFloor) '(V n a, V n b) where+  type PrimOpAugType ('Vectorise SPIRV.CFloor) '(V n a, V n b) = Val (V n a) :--> Val (V n b)+  op = fmap floor+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.CFloor @'(a,b))) (val @n) (primTy @b)+instance ( KnownNat n, ScalarTy a, ScalarTy b, Rounding '(a,b) ) => PrimOp ('Vectorise SPIRV.CCeiling) '(V n a, V n b) where+  type PrimOpAugType ('Vectorise SPIRV.CCeiling) '(V n a, V n b) = Val (V n a) :--> Val (V n b)+  op = fmap ceiling+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.CCeiling @'(a,b))) (val @n) (primTy @b)++instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FSin) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FSin) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap sin+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FSin @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FCos) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FCos) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap cos+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FCos @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FTan) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FTan) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap tan+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FTan @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FAsin) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FAsin) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap asin+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FAsin @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FAcos) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FAcos) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap acos+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FAcos @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FAtan) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FAtan) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap atan+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FAtan @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FSinh) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FSinh) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap sinh+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FSinh @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FCosh) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FCosh) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap cosh+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FCosh @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FTanh) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FTanh) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap tanh+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FTanh @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FAsinh) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FAsinh) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap asinh+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FAsinh @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FAcosh) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FAcosh) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap acosh+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FAcosh @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FAtanh) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FAtanh) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap atanh+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FAtanh @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, RealFloat a ) => PrimOp ('Vectorise SPIRV.FAtan2) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FAtan2) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a)+  op = liftA2 atan2+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FAtan2 @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FPow) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FPow) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a)+  op = liftA2 (**)+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FPow @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FExp) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FExp) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap exp+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FExp @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FLog) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FLog) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap log+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FLog @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FSqrt) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FSqrt) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap sqrt+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FSqrt @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FInvSqrt) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FInvSqrt) (V n a) = Val (V n a) :--> Val (V n a)+  op = fmap ( recip . sqrt )+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FInvSqrt @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, RealFloat a, Logic a ~ Bool) => PrimOp ('Vectorise SPIRV.FIsNaN) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FIsNaN) (V n a) = Val (V n a) :--> Val (V n Bool)+  op = fmap isNaN+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FIsNaN @a)) (val @n) (primTy @a)+instance ( KnownNat n, ScalarTy a, RealFloat a, Logic a ~ Bool) => PrimOp ('Vectorise SPIRV.FIsInf) (V n a) where+  type PrimOpAugType ('Vectorise SPIRV.FIsInf) (V n a) = Val (V n a) :--> Val (V n Bool)+  op = fmap isInfinite+  opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FIsInf @a)) (val @n) (primTy @a)++instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp SPIRV.DotV (V n a) where+  type PrimOpAugType SPIRV.DotV (V n a) = Val (V n a) :--> Val (V n a) :--> Val a+  op = dot+  opName = SPIRV.VecOp SPIRV.DotV (val @n) (primTy @a)+-- vector times scalar operation requires floating point type in SPIR-V+instance ( KnownNat n, ScalarTy a, Semiring a, Floating a ) => PrimOp SPIRV.VMulK (V n a) where +  type PrimOpAugType SPIRV.VMulK (V n a) = Val (V n a) :--> Val a :--> Val (V n a)+  op = (^*)+  opName = SPIRV.VecOp SPIRV.VMulK (val @n) (primTy @a)+instance ( n ~ 3, ScalarTy a, Floating a ) => PrimOp SPIRV.CrossV (V n a) where+  type PrimOpAugType SPIRV.CrossV (V n a) = Val (V 3 a) :--> Val (V 3 a) :--> Val (V 3 a)+  op = cross+  opName = SPIRV.VecOp SPIRV.CrossV 3 (primTy @a)+instance ( KnownNat n, ScalarTy a, Floating a) => PrimOp SPIRV.NormaliseV (V n a) where+  type PrimOpAugType SPIRV.NormaliseV (V n a) = Val (V n a) :--> Val (V n a)+  op = normalise+  opName = SPIRV.VecOp SPIRV.NormaliseV (val @n) (primTy @a)+++instance ( KnownNat i, KnownNat j, ScalarTy a, Floating a ) => PrimOp SPIRV.MMulK '(a,i,j) where+  type PrimOpAugType SPIRV.MMulK '(a,i,j) = Val (M i j a) :--> Val a :--> Val (M i j a)+  op = (!*)+  opName = SPIRV.MatOp SPIRV.MMulK (val @i) (val @j) (scalarTy @a)+instance ( KnownNat i, KnownNat j, ScalarTy a, Floating a ) => PrimOp SPIRV.MMulV '(a,i,j) where+  type PrimOpAugType SPIRV.MMulV '(a,i,j) = Val (M i j a) :--> Val (V j a) :--> Val (V i a)+  op = (!*^)+  opName = SPIRV.MatOp SPIRV.MMulV (val @i) (val @j) (scalarTy @a)+instance ( KnownNat i, KnownNat j, ScalarTy a, Floating a ) => PrimOp SPIRV.VMulM '(a,i,j) where+  type PrimOpAugType SPIRV.VMulM '(a,i,j) = Val (V i a) :--> Val (M i j a) :--> Val (V j a)+  op = (^*!)+  opName = SPIRV.MatOp SPIRV.VMulM (val @i) (val @j) (scalarTy @a)+instance ( KnownNat i, KnownNat j, KnownNat k, ScalarTy a, Floating a ) => PrimOp SPIRV.MMulM '(a,i,j,k) where+  type PrimOpAugType SPIRV.MMulM '(a,i,j,k) = Val (M i j a) :--> Val (M j k a) :--> Val (M i k a)+  op = (!*!)+  opName = SPIRV.MatOp SPIRV.MMulM (val @i) (val @k) (scalarTy @a)+instance ( KnownNat i, KnownNat j, ScalarTy a, Floating a ) => PrimOp SPIRV.Transp '(a,i,j) where+  type PrimOpAugType SPIRV.Transp '(a,i,j) = Val (M i j a) :--> Val (M j i a)+  op = transpose+  opName = SPIRV.MatOp SPIRV.Transp (val @j) (val @i) (scalarTy @a)+instance ( KnownNat i, ScalarTy a, Floating a ) => PrimOp SPIRV.Det '(a,i) where+  type PrimOpAugType SPIRV.Det '(a,i) = Val (M i i a) :--> Val a+  op = determinant+  opName = SPIRV.MatOp SPIRV.Det (val @i) (val @i) (scalarTy @a)+instance ( KnownNat i, ScalarTy a, Floating a ) => PrimOp SPIRV.Inv '(a,i) where+  type PrimOpAugType SPIRV.Inv '(a,i) = Val (M i i a) :--> Val (M i i a)+  op = inverse+  opName = SPIRV.MatOp SPIRV.Inv (val @i) (val @i) (scalarTy @a)
+ src/FIR/Prim/RayTracing.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE EmptyDataDeriving     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE TypeFamilies          #-}++{-|+Module: FIR.Prim.RayTracing++This module defines the opaque 'AccelerationStructure' and 'RayQuery' types,+to be used to refer to such objects in ray tracing operations.+-}++module FIR.Prim.RayTracing where++-- base+import Data.Word+  ( Word64 )++-- text-short+import Data.Text.Short+  ( ShortText )++-- fir+import Data.Type.Known+  ( Demotable(..), Known(..) )++------------------------------------------------------------++newtype AccelerationStructure = AccelerationStructureFromWord64 Word64+  deriving stock ( Show, Eq, Ord )+newtype RayQuery = RayQuery ShortText -- refer to the ray query by its name internally (not exported by the library)+  deriving stock ( Show, Eq, Ord )++data RayQueryState+  = RayQueryState+      ( Maybe RayQueryProceedState )+      ( Maybe RayQueryCommittedIntersection )+  deriving stock ( Show, Eq, Ord )++data RayQueryProceedState+  = Complete+  | Incomplete ( Maybe RayQueryCandidateIntersection )+  deriving stock ( Show, Eq, Ord )++data IntersectionType+  = Candidate+  | Committed+  deriving stock ( Show, Eq, Ord )++data RayQueryCandidateIntersection +  = TriangleCandidateIntersection+  | AABBCandidateIntersection+  deriving stock ( Show, Eq, Ord )+data RayQueryCommittedIntersection+  = NoIntersection+  | TriangleIntersection+  | GeneratedIntersection+  deriving stock ( Show, Eq, Ord )++instance Demotable IntersectionType where+  type Demote IntersectionType = IntersectionType++instance Known IntersectionType Candidate where+  known = Candidate+instance Known IntersectionType Committed where+  known = Committed
+ src/FIR/Prim/Struct.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE DerivingStrategies     #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE InstanceSigs           #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE StandaloneDeriving     #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: FIR.Prim.Struct++A __structure__ (or __struct__ for short) can be thought of as an ordered record.++Here, we simply represent a struct as a linked list, with the fields annotated at the type level.++To illustrate:++> struct :: Struct '[ "field1" ':-> Float, "field2" ':-> V 3 Float ]+> struct = 1.0 :& V3 0.0 1.0 0.0 :& End++This defines a struct with two fields:++  * first field named @"field1"@, of type @Float@,+  * second field named @"field2"@, of type @V 3 Float@.++Note that the field annotations need not be type-level literals.+For instance, when specifying memory layout of vertex input data,+one instead specifies location slots (see "FIR.Layout"):++> inputData :: Struct '[ Slot 0 0 ':-> Float, Slot 0 3 ':-> V 3 Float ]+++-}++module FIR.Prim.Struct+  ( Struct(End, (:&))+  , LocationSlot(..)+  , ShowLocationSlot+  , FieldKind(..)+  , StructFieldKind(fieldKind)+  , HasStructField(getStructField, setStructField)+  , headS, tailS+  , foldrStruct+  , traverseStruct+  , ASTStructFields(..)+  )+  where++-- base+import Data.Kind+  ( Type )+import Data.List+  ( intercalate )+import Data.Typeable+  ( Typeable )+import Data.Word+  ( Word32 )+import GHC.TypeLits+  ( Symbol, KnownSymbol, AppendSymbol )+import GHC.TypeNats+  ( Nat, KnownNat+  , type (+), type(-), type (*)+  , Mod, Div+  )++-- fir+import Data.Product+  ( HList(HNil,(:>)), IsProduct(..) )+import Data.Type.List+  ( type (:++:) )+import Data.Type.Map+  ( (:->)((:->)) )+import Data.Type.Known+  ( Demotable(Demote)+  , Known(known), knownValue+  )+import Data.Type.POrd+  ( POrd(Compare)+  , PEnum(Succ, Pred, FromEnum, ToEnum)+  )+import Data.Type.String+  ( ShowNat )+import FIR.AST.Type+  ( AugType(Val) )+import Math.Algebra.GradedSemigroup+  ( GradedSemigroup(..) )+import {-# SOURCE #-} FIR.Prim.Types+  ( PrimTy+  , PrimTyMap(primTyMapSing)+  , SPrimTyMap(SNil, SCons)+  )++------------------------------------------------------------+-- structs++infixr 4 :&+-- order *matters* for structs (memory layout!)+data Struct :: [fld :-> Type] -> Type where+  End  :: Struct '[]+  (:&) :: forall k a as. a -> Struct as -> Struct ((k ':-> a) ': as)++headS :: Struct ((k ':-> a) ': as) -> a+headS (a :& _) = a++tailS :: Struct ((k ':-> a) ': as) -> Struct as+tailS (_ :& as) = as++data LocationSlot n where+  LocationSlot :: n -> n -> LocationSlot n++deriving stock instance Show n => Show (LocationSlot n)++type family ShowLocationSlot ( slot :: LocationSlot Nat ) :: Symbol where+  ShowLocationSlot ('LocationSlot l c)+    = "Location " `AppendSymbol` ShowNat l `AppendSymbol` ", Component " `AppendSymbol` ShowNat c++data FieldKind (fld :: Type) where+  NamedField    :: FieldKind Symbol+  LocationField :: FieldKind (LocationSlot Nat)+  OtherField    :: FieldKind fld++class (Show (Demote fld), Typeable fld) => StructFieldKind fld where+  fieldKind :: FieldKind fld+instance StructFieldKind Symbol where+  fieldKind = NamedField+instance StructFieldKind (LocationSlot Nat) where+  fieldKind = LocationField+instance {-# OVERLAPPABLE #-} (Show (Demote fld), Typeable fld) => StructFieldKind fld where+  fieldKind = OtherField++class HasStructField k a as | k as -> a where+  getStructField :: Struct as -> a+  setStructField :: a -> Struct as -> Struct as+instance {-# OVERLAPPING #-}+         forall fld (k :: fld) (a :: Type) (as :: [ fld :-> Type ])+         .  HasStructField k a ((k ':-> a) ': as)+         where+  getStructField = headS+  setStructField b ( _ :& as ) = b :& as+instance forall fld (k :: fld) (a :: Type) (l :: fld) (x :: Type) (as :: [ fld :-> Type ])+         .  HasStructField k a as+         => HasStructField k a ((l ':-> x) ': as)+         where+  getStructField = getStructField @k @a @as . tailS+  setStructField b ( a :& as ) = a :& setStructField @k @a @as b as+instance {-# OVERLAPPING #-}+         forall fld (k :: fld) (a :: Type) (as :: [ fld :-> Type ])+         .  HasStructField (0 :: Nat) a ((k ':-> a) ': as)+         where+  getStructField = headS+  setStructField b ( _ :& as ) = b :& as+instance forall fld (l :: fld) (i :: Nat) (a :: Type) (x :: Type) (as :: [ fld :-> Type])+         .  HasStructField (i-1) a as+         => HasStructField i a ((l ':-> x) ': as)+         where+  getStructField = getStructField @(i-1) @a @as . tailS+  setStructField b ( a :& as ) = a :& setStructField @(i-1) @a @as b as++instance PrimTyMap as => Eq (Struct as) where+  s1 == s2 = case primTyMapSing @_ @as of+    SNil -> True+    SCons ->+      case (s1, s2) of+        (a :& as, b :& bs) ->+          a == b && as == bs++instance PrimTyMap as => Ord (Struct as) where+  compare s1 s2 = case primTyMapSing @_ @as of+    SNil -> EQ+    SCons ->+      case (s1, s2) of+        (a :& as, b :& bs) ->+          case compare a b of+            EQ -> compare as bs+            un -> un++display :: forall fld (as :: [fld :-> Type])+        .  ( StructFieldKind fld, PrimTyMap as )+        => Struct as -> [String]+display s = case primTyMapSing @_ @as of+  SNil -> []+  sCons@SCons ->+    case sCons of+      ( _ :: SPrimTyMap ((k ':-> a) ': xs) ) ->+        case s of+          (a :& as) ->+            ( show (knownValue @k) ++ " :-> " ++ show a )+            : display as++instance forall fld (as :: [fld :-> Type])+         .  ( StructFieldKind fld, PrimTyMap as )+         => Show (Struct as) where+  show s = "{ " ++ intercalate ", " (display s) ++ " }"++instance IsProduct (Struct '[]) '[] where+  fromHList _ = End+  toHList   _ = HNil++instance IsProduct (Struct as) tys => IsProduct (Struct ((fld ':-> ty) ': as)) (ty ': tys) where+  fromHList (a :> as) = a :& fromHList as+  toHList   (a :& as) = a :> toHList   as++instance GradedSemigroup (Struct :: [ fld :-> Type ] -> Type) [fld :-> Type] where+  type Grade [fld :-> Type] (Struct :: [ fld :-> Type ] -> Type) as = Struct as+  type as :<!>: bs = as :++: bs+  (<!>) :: Struct as -> Struct bs -> Struct (as :++: bs)+  End <!> t = t+  (a :& s) <!> t = a :& ( s <!> t )++foldrStruct+    :: forall as b. PrimTyMap as+    => ( forall a. PrimTy a => a -> b -> b )+    -> b -> Struct as -> b+foldrStruct f b s =+  case primTyMapSing @_ @as of+    SNil+      -> b+    SCons {}+      -> case s of+          (a :& as)+            -> f a (foldrStruct f b as)++traverseStruct+    :: ( Applicative f, PrimTyMap as )+    => ( forall a. PrimTy a => a -> f b )+    -> Struct as+    -> f [b]+traverseStruct f+   = foldrStruct ( \a bs -> liftA2 (:) (f a) bs )+       ( pure [] )++class Typeable bs =>+        ASTStructFields+          ( ast :: ( AugType -> Type ) )+          ( as :: [ Symbol :-> Type ] )+          ( bs :: [ Symbol :-> Type ] )+        | as -> bs, bs ast -> as where+  traverseStructASTs+    :: forall f b. Applicative f+    => ( forall a. ast (Val a) -> f b ) -> Struct as -> f [b]+instance ASTStructFields ast '[] '[] where+  traverseStructASTs _ _ = pure []+instance (KnownSymbol k2, k1 ~ k2, a ~ ast (Val b), Typeable b, ASTStructFields ast as bs)+   => ASTStructFields ast ( (k1 ':-> a) ': as) ( (k2 ':-> b) ': bs) where+  traverseStructASTs f (a :& as) = (:) <$> f a <*> traverseStructASTs f as++-----------------------------------------------------------+-- instances for 'LocationSlot'++instance Demotable (LocationSlot Nat) where+  type Demote (LocationSlot Nat) = LocationSlot Word32++instance (KnownNat l, KnownNat c) => Known (LocationSlot Nat) ('LocationSlot l c) where+  known = LocationSlot (knownValue @l) (knownValue @c)++instance POrd (LocationSlot Nat) where+  type Compare ('LocationSlot l1 c1) ('LocationSlot l2 c2)+    = Compare '(l1, c1) '(l2, c2) -- lexicographic ordering++type family SuccLocationSlot (slot :: LocationSlot Nat) :: LocationSlot Nat where+  SuccLocationSlot ('LocationSlot l 3) = 'LocationSlot (l+1) 0+  SuccLocationSlot ('LocationSlot l c) = 'LocationSlot l (c+1)++type family PredLocationSlot (slot :: LocationSlot Nat) :: LocationSlot Nat where+  PredLocationSlot ('LocationSlot 0 0) = 'LocationSlot 0 0+  PredLocationSlot ('LocationSlot l 0) = 'LocationSlot (l-1) 3+  PredLocationSlot ('LocationSlot l c) = 'LocationSlot l (c-1)++instance PEnum (LocationSlot Nat) where+  type Succ loc = SuccLocationSlot loc+  type Pred loc = PredLocationSlot loc+  type FromEnum ('LocationSlot l c)+    = 4 * l + c+  type ToEnum n+    = 'LocationSlot (n `Div` 4) (n `Mod` 4)
+ src/FIR/Prim/Struct.hs-boot view
@@ -0,0 +1,67 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE RoleAnnotations        #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++module FIR.Prim.Struct where++-- base+import Data.Kind+  ( Type )+import Data.Typeable+  ( Typeable )+import GHC.TypeLits+  ( Symbol )+import GHC.TypeNats+  ( Nat )++-- fir+import Data.Type.Known+  ( Demote )+import Data.Type.Map+  ( (:->) )+import FIR.AST.Type+  ( AugType(Val) )++------------------------------------------------------------+-- structs++data Struct :: [fld :-> Type] -> Type where+type role Struct nominal++data LocationSlot n where+  LocationSlot :: n -> n -> LocationSlot n++instance Show n => Show (LocationSlot n) where++data FieldKind (fld :: Type) where+  NamedField    :: FieldKind Symbol+  LocationField :: FieldKind (LocationSlot Nat)+  OtherField    :: FieldKind fld++class (Show (Demote fld), Typeable fld) => StructFieldKind fld where+  fieldKind :: FieldKind fld++instance StructFieldKind Symbol where+instance StructFieldKind (LocationSlot Nat) where+instance {-# OVERLAPPABLE #-} (Show (Demote fld), Typeable fld) => StructFieldKind fld where++class Typeable bs =>+        ASTStructFields+          ( ast :: ( AugType -> Type ) )+          ( as :: [ Symbol :-> Type ] )+          ( bs :: [ Symbol :-> Type ] )+        | as -> bs, bs ast -> as where+  traverseStructASTs+    :: forall f b. Applicative f+    => ( forall a. ast (Val a) -> f b ) -> Struct as -> f [b]
+ src/FIR/Prim/Types.hs view
@@ -0,0 +1,728 @@+{-# LANGUAGE AllowAmbiguousTypes      #-}+{-# LANGUAGE DataKinds                #-}+{-# LANGUAGE FlexibleContexts         #-}+{-# LANGUAGE FlexibleInstances        #-}+{-# LANGUAGE GADTs                    #-}+{-# LANGUAGE InstanceSigs             #-}+{-# LANGUAGE MultiParamTypeClasses    #-}+{-# LANGUAGE PolyKinds                #-}+--{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes               #-}+{-# LANGUAGE ScopedTypeVariables      #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications         #-}+{-# LANGUAGE TypeFamilies             #-}+{-# LANGUAGE TypeOperators            #-}+{-# LANGUAGE UndecidableInstances     #-}++{-|+Module: FIR.Prim.Types++This module defines the types used internally, including singletons machinery that is necessary for code generation.++See for instance 'CodeGen.IDs.constID' for a crucial application of these singletons.++For situations where we only need one-way reification, i.e. being able to turn type-level data into value-level data+without the need to be able to go back the other way, see "Data.Type.Known".++-}++module FIR.Prim.Types where++-- base+import Data.Int+  ( Int8, Int16, Int32, Int64 )+import Data.Kind+  ( Type )+import Data.List+  ( intercalate )+import Data.Proxy+  ( Proxy(Proxy) )+import Data.Type.Bool+  ( type (&&) )+import Data.Type.Equality+  ( (:~:)(Refl) )+import Data.Type.List+  ( type (:++:) )+import Data.Typeable+  ( Typeable, eqT )+import Data.Word+  ( Word8, Word16, Word32, Word64 )+import GHC.TypeLits+  ( Symbol, KnownSymbol+  , TypeError, ErrorMessage(Text, ShowType, (:$$:), (:<>:))+  )+import GHC.TypeNats+  ( Nat, KnownNat, natVal+  , type (+)+  )++-- half+import Numeric.Half+  ( Half )++-- text-short+import Data.Text.Short+  ( ShortText )++-- fir+import {-# SOURCE #-} Control.Type.Optic+  ( IndexChain, IndexInfo(ThisIndex, AnyIndex) )+import Data.Binary.Class.Put+  ( Put )+import Data.Constraint.All+  ( All(allDict), AllDict(NilDict, ConsDict) )+import Data.Function.Variadic+  ( ListVariadic )+import Data.Type.Known+  ( Known, knownValue )+import Data.Type.Map+  ( (:->)((:->)) )+import {-# SOURCE #-} FIR.AST+  ( Syntactic(Internal) )+import FIR.AST.Type+  ( AugType(Val) )+import FIR.Binding+  ( Binding, BindingsMap, Var+  , Permission(Read,Write), Permissions+  )+import FIR.Prim.Array+  ( Array, RuntimeArray )+import {-# SOURCE #-} FIR.Prim.Image+  ( Image )+import FIR.Prim.RayTracing+  ( AccelerationStructure, RayQuery )+import FIR.Prim.Struct+  ( Struct, FieldKind(NamedField), StructFieldKind(fieldKind) )+import Math.Algebra.Class+  ( Ring )+import Math.Linear+  ( V, M )+import qualified SPIRV.PrimTy     as SPIRV+import SPIRV.ScalarTy+  ( Signedness(Unsigned, Signed)+  , Width(W8,W16,W32,W64)+  )+import qualified SPIRV.ScalarTy   as SPIRV+import qualified SPIRV.Storage    as SPIRV+  ( StorageClass )+import qualified SPIRV.Storage    as Storage++------------------------------------------------------------+-- singletons for primitive types+-- this allows us to pattern match on the type when necessary++data SScalarTy :: Type -> Type where+  SWord8  :: SScalarTy Word8+  SWord16 :: SScalarTy Word16+  SWord32 :: SScalarTy Word32+  SWord64 :: SScalarTy Word64+  SInt8   :: SScalarTy Int8+  SInt16  :: SScalarTy Int16+  SInt32  :: SScalarTy Int32+  SInt64  :: SScalarTy Int64+  SHalf   :: SScalarTy Half+  SFloat  :: SScalarTy Float+  SDouble :: SScalarTy Double++showSScalarTy :: SScalarTy ty -> String+showSScalarTy SWord8  = "Word8"+showSScalarTy SWord16 = "Word16"+showSScalarTy SWord32 = "Word32"+showSScalarTy SWord64 = "Word64"+showSScalarTy SInt8   = "Int8"+showSScalarTy SInt16  = "Int16"+showSScalarTy SInt32  = "Int32"+showSScalarTy SInt64  = "Int64"+showSScalarTy SHalf   = "Half"+showSScalarTy SFloat  = "Float"+showSScalarTy SDouble = "Double"++type ScalarFromTy (ty :: Type)+  = ( ScalarFromSScalar ( ScalarTySing ty ) :: SPIRV.ScalarTy )++type ScalarFromSScalar :: SScalarTy ty -> SPIRV.ScalarTy+type family ScalarFromSScalar sTy where+  ScalarFromSScalar SWord8  = SPIRV.Integer Unsigned W8+  ScalarFromSScalar SWord16 = SPIRV.Integer Unsigned W16+  ScalarFromSScalar SWord32 = SPIRV.Integer Unsigned W32+  ScalarFromSScalar SWord64 = SPIRV.Integer Unsigned W64+  ScalarFromSScalar SInt8   = SPIRV.Integer Signed   W8+  ScalarFromSScalar SInt16  = SPIRV.Integer Signed   W16+  ScalarFromSScalar SInt32  = SPIRV.Integer Signed   W32+  ScalarFromSScalar SInt64  = SPIRV.Integer Signed   W64+  ScalarFromSScalar SHalf   = SPIRV.Floating         W16+  ScalarFromSScalar SFloat  = SPIRV.Floating         W32+  ScalarFromSScalar SDouble = SPIRV.Floating         W64++type family TypeFromScalar ( scalar :: SPIRV.ScalarTy ) :: Type where+  TypeFromScalar (SPIRV.Integer Unsigned W8 ) = Word8+  TypeFromScalar (SPIRV.Integer Unsigned W16) = Word16+  TypeFromScalar (SPIRV.Integer Unsigned W32) = Word32+  TypeFromScalar (SPIRV.Integer Unsigned W64) = Word64+  TypeFromScalar (SPIRV.Integer Signed   W8 ) = Int8+  TypeFromScalar (SPIRV.Integer Signed   W16) = Int16+  TypeFromScalar (SPIRV.Integer Signed   W32) = Int32+  TypeFromScalar (SPIRV.Integer Signed   W64) = Int64+  TypeFromScalar (SPIRV.Floating         W16) = Half+  TypeFromScalar (SPIRV.Floating         W32) = Float+  TypeFromScalar (SPIRV.Floating         W64) = Double++type family ScalarWidth (sTy :: SScalarTy ty) :: Nat where+  ScalarWidth sTy+   = SPIRV.WidthToNat+        ( SPIRV.ScalarWidth ( ScalarFromSScalar sTy ) )++-- singleton data type+data SPrimTy :: Type -> Type where+  SUnit   :: SPrimTy ()+  SBool   :: SPrimTy Bool+  SScalar :: ScalarTy a => SPrimTy a+  SVector :: (KnownNat n, PrimTy a)+          => SPrimTy (V n a)+  SMatrix :: (KnownNat m, KnownNat n, ScalarTy a, Ring a)+          => SPrimTy (M m n a)+  SArray  :: (KnownNat n, PrimTy a)+          => SPrimTy (Array n a)+  SRuntimeArray+          :: PrimTy a+          => SPrimTy (RuntimeArray a)+  SStruct :: forall (fld :: Type) (as :: [fld :-> Type])+          .  ( StructFieldKind fld, PrimTyMap as )+          => SPrimTy (Struct as)+  SAccelerationStructure+    :: SPrimTy AccelerationStructure++data SPrimTyMap :: [fld :-> Type] -> Type where+  SNil  :: SPrimTyMap '[]+  SCons :: (StructFieldKind fld, Known fld k, PrimTy a, PrimTyMap as)+        => SPrimTyMap ((k ':-> a) ': as)++type family HasOpaqueType (a :: Type) :: Bool where+  HasOpaqueType (Image _)                    = True+  HasOpaqueType AccelerationStructure        = True+  HasOpaqueType RayQuery                     = True+  HasOpaqueType (RuntimeArray _)             = True+  HasOpaqueType (Array _ a)                  = HasOpaqueType a+  HasOpaqueType (Struct ((_ ':-> a) ': as )) = HasOpaqueType a && HasOpaqueType (Struct as)+  HasOpaqueType _                            = False++instance Show (SPrimTy ty) where+  show :: SPrimTy ty -> String+  show SUnit = "()"+  show SBool = "Bool"+  show (SScalar :: SPrimTy a) = showSScalarTy (scalarTySing @a)+  show sVector@SVector+    = case sVector of+        ( _ :: SPrimTy (V n a) ) ->+          "V " ++ show (natVal (Proxy @n)) ++ " " ++ show (primTySing @a)+  show sMatrix@SMatrix+    = case sMatrix of+        ( _ :: SPrimTy (M m n a) ) ->+          "M " ++ show (natVal (Proxy @m)) ++ " "+          ++ show (natVal (Proxy @n))+          ++ " " ++ showSScalarTy (scalarTySing @a)+  show sArray@SArray+    = case sArray of+        ( _ :: SPrimTy (Array n a) ) ->+          "Array " ++ show (natVal (Proxy @n))+          ++ " " ++ show (primTySing @a)+  show sRuntimeArray@SRuntimeArray+    = case sRuntimeArray of+        ( _ :: SPrimTy (RuntimeArray a) ) ->+          "RuntimeArray " ++ show (primTySing @a)+  show sStruct@SStruct+    = case sStruct of+        ( _ :: SPrimTy (Struct as) ) ->+          "Struct '["+          ++ intercalate ", " ( showSPrimTyMap ( primTyMapSing @_ @as ) )+          ++ "]"+  show SAccelerationStructure = "AccelerationStructure"++showSPrimTyMap :: SPrimTyMap as -> [String]+showSPrimTyMap SNil = []+showSPrimTyMap sCons@SCons+  = case sCons of+      ( _ :: SPrimTyMap ((k ':-> a) ': as) ) ->+        ( show (knownValue @k) ++ " :-> " ++ show ( primTySing @a ) )+        : showSPrimTyMap ( primTyMapSing @_ @as )++-- singleton data kind, without unpromotable contexts+data SKPrimTy :: Type -> Type where+  SKUnit   :: SKPrimTy ()+  SKBool   :: SKPrimTy Bool+  SKScalar :: SScalarTy a -> SKPrimTy a+  SKVector :: SScalarTy a -> SKPrimTy (V n a)+  SKMatrix :: SScalarTy a -> SKPrimTy (M m n a)+  SKArray  :: SKPrimTy a -> SKPrimTy (Array n a)+  SKRuntimeArray+           :: SKPrimTy a -> SKPrimTy (RuntimeArray a)+  SKStruct :: SKPrimTyMap as -> SKPrimTy (Struct as)+  SKAccelerationStructure :: SKPrimTy AccelerationStructure++data SKPrimTyMap :: [fld :-> Type] -> Type where+  SKNil :: SKPrimTyMap '[]+  SKCons :: SKPrimTy a -> SKPrimTyMap as -> SKPrimTyMap ((k ':-> a) ': as)++type ScalarTySing :: forall (ty :: Type) -> SScalarTy ty+type family ScalarTySing (ty :: Type) :: SScalarTy ty where+  ScalarTySing Word8  = SWord8+  ScalarTySing Word16 = SWord16+  ScalarTySing Word32 = SWord32+  ScalarTySing Word64 = SWord64+  ScalarTySing Int8   = SInt8+  ScalarTySing Int16  = SInt16+  ScalarTySing Int32  = SInt32+  ScalarTySing Int64  = SInt64+  ScalarTySing Half   = SHalf+  ScalarTySing Float  = SFloat+  ScalarTySing Double = SDouble+  ScalarTySing a+    = TypeError+      ( Text "Type " :<>: ShowType a :<>: Text " is not a valid scalar type." )++type PrimTySing :: forall (ty :: Type) -> SKPrimTy ty+type family PrimTySing (ty :: Type) :: SKPrimTy ty where+  PrimTySing ()     = SKUnit+  PrimTySing Bool   = SKBool+  PrimTySing Word8  = SKScalar SWord8+  PrimTySing Word16 = SKScalar SWord16+  PrimTySing Word32 = SKScalar SWord32+  PrimTySing Word64 = SKScalar SWord64+  PrimTySing Int8   = SKScalar SInt8+  PrimTySing Int16  = SKScalar SInt16+  PrimTySing Int32  = SKScalar SInt32+  PrimTySing Int64  = SKScalar SInt64+  PrimTySing Half   = SKScalar SHalf+  PrimTySing Float  = SKScalar SFloat+  PrimTySing Double = SKScalar SDouble+  PrimTySing (V n a) = SKVector (ScalarTySing a)+  PrimTySing (M m n a) = SKMatrix (ScalarTySing a)+  PrimTySing (Array n a) = SKArray (PrimTySing a)+  PrimTySing (RuntimeArray a) = SKRuntimeArray (PrimTySing a)+  PrimTySing (Struct as) = SKStruct (MapPrimTySing as)+  PrimTySing AccelerationStructure = SKAccelerationStructure+  PrimTySing ty+    = TypeError+        ( Text "Type " :<>: ShowType ty :<>: Text " is not a valid primitive type." )++type MapPrimTySing :: forall fld. forall (as :: [fld :-> Type]) -> SKPrimTyMap as+type family MapPrimTySing as where+  MapPrimTySing '[] = SKNil+  MapPrimTySing ( ( k ':-> a) ': as)+    = SKCons (PrimTySing a) (MapPrimTySing as)++------------------------------------------------++class ( Show ty                    -- for convenience+      , Eq ty, Ord ty, Typeable ty -- to keep track of lists of constants+      , ty ~ ListVariadic '[] ty   -- ty is not a function type+      )+    => PrimTy ty where+  -- associated type used for computing overlap with "OfType" optic+  type FieldsOfType ty fldTy :: [ IndexChain ]+  primTySing :: SPrimTy ty++class ( PrimTy ty+      , Put ty                     -- for serialisation+      , HasOpaqueType ty ~ False+      ) => ScalarTy ty where+  scalarTySing :: SScalarTy ty++type family MonolithicFields (a :: Type) (ty :: Type) :: [ IndexChain ] where+  MonolithicFields a a = '[ '[] ]+  MonolithicFields _ _ = '[]++instance PrimTy ()   where+  type FieldsOfType () _ = '[]+  primTySing = SUnit+instance PrimTy Bool where+  type FieldsOfType Bool a = MonolithicFields Bool a+  primTySing = SBool+instance PrimTy AccelerationStructure where+  type FieldsOfType AccelerationStructure a = MonolithicFields AccelerationStructure a+  primTySing = SAccelerationStructure++instance ScalarTy Word8  where+  scalarTySing = SWord8+instance ScalarTy Word16 where+  scalarTySing = SWord16+instance ScalarTy Word32 where+  scalarTySing = SWord32+instance ScalarTy Word64 where+  scalarTySing = SWord64+instance ScalarTy Int8   where+  scalarTySing = SInt8+instance ScalarTy Int16  where+  scalarTySing = SInt16+instance ScalarTy Int32  where+  scalarTySing = SInt32+instance ScalarTy Int64  where+  scalarTySing = SInt64+instance ScalarTy Half   where+  scalarTySing = SHalf+instance ScalarTy Float  where+  scalarTySing = SFloat+instance ScalarTy Double where+  scalarTySing = SDouble++class (ScalarTy ty, Integral ty) => IntegralTy ty where+instance IntegralTy Word8  where+instance IntegralTy Word16 where+instance IntegralTy Word32 where+instance IntegralTy Word64 where+instance IntegralTy Int8   where+instance IntegralTy Int16  where+instance IntegralTy Int32  where+instance IntegralTy Int64  where++instance PrimTy Word8  where+  type FieldsOfType Word8  a = MonolithicFields Word8  a+  primTySing = SScalar+instance PrimTy Word16 where+  type FieldsOfType Word16 a = MonolithicFields Word16 a+  primTySing = SScalar+instance PrimTy Word32 where+  type FieldsOfType Word32 a = MonolithicFields Word32 a+  primTySing = SScalar+instance PrimTy Word64 where+  type FieldsOfType Word64 a = MonolithicFields Word64 a+  primTySing = SScalar+instance PrimTy Int8   where+  type FieldsOfType Int8   a = MonolithicFields Int8   a+  primTySing = SScalar+instance PrimTy Int16  where+  type FieldsOfType Int16  a = MonolithicFields Int16  a+  primTySing = SScalar+instance PrimTy Int32  where+  type FieldsOfType Int32  a = MonolithicFields Int32  a+  primTySing = SScalar+instance PrimTy Int64  where+  type FieldsOfType Int64  a = MonolithicFields Int64  a+  primTySing = SScalar+instance PrimTy Half   where+  type FieldsOfType Half   a = MonolithicFields Half   a+  primTySing = SScalar+instance PrimTy Float  where+  type FieldsOfType Float  a = MonolithicFields Float  a+  primTySing = SScalar+instance PrimTy Double where+  type FieldsOfType Double a = MonolithicFields Double a+  primTySing = SScalar+++instance ( TypeError+             ( Text "Use a specific width unsigned integer type \+                    \instead of 'Word' (recommended: 'Word32')."+              )+         , Put Word+         )+    => PrimTy Word where+  type FieldsOfType Word a = MonolithicFields Word a+  primTySing = error "unreachable" +instance ( TypeError+             ( Text "Use a specific width signed integer type \+                    \instead of 'Int' (recommended: 'Int32')."+              )+         , Put Int+         )+    => PrimTy Int where+  type FieldsOfType Int a = MonolithicFields Int a+  primTySing = error "unreachable"+instance ( TypeError+             ( Text "Use a specific width unsigned integer type \+                    \instead of 'Word' (recommended: 'Word32')."+              )+         , Put Word+         )+    => ScalarTy Word where+  scalarTySing = error "unreachable" +instance ( TypeError+             ( Text "Use a specific width signed integer type \+                    \instead of 'Int' (recommended: 'Int32')."+              )+         , Put Int+         )+    => ScalarTy Int where+  scalarTySing = error "unreachable"+++type family HomogeneousFields (c :: Type -> Type) (a :: Type) (b :: Type) :: [ IndexChain ] where+  HomogeneousFields c a (c a) = '[ '[] ]+  HomogeneousFields _ a b     = MapCons AnyIndex ( FieldsOfType a b )++type family MapCons (x :: k) (xss :: [[k]]) :: [[k]] where+  MapCons _ '[]         = '[]+  MapCons x (ys ': yss) = ( x ': ys ) ': MapCons x yss++instance ( PrimTy a+         , KnownNat n+         ) => PrimTy (V n a) where+  type FieldsOfType (V n a) ty = HomogeneousFields (V n) a ty+  primTySing = SVector++type family MatrixFields (m :: Nat) (a :: Type) (b :: Type) :: [ IndexChain ] where+  MatrixFields m a (V m a) = '[ '[ AnyIndex ] ]+  MatrixFields _ a a       = '[ '[ AnyIndex, AnyIndex ] ]+  MatrixFields _ _ _       = '[] -- no need to recurse as matrices can only contain scalars++instance ( PrimTy a, ScalarTy a+         , Ring a+         , KnownNat m--, 2 <= m, m <= 4+         , KnownNat n--, 2 <= n, n <= 4+         ) => PrimTy (M m n a) where+  type FieldsOfType (M m n a) ty = MatrixFields m a ty+  primTySing = SMatrix++instance (PrimTy a, KnownNat l) => PrimTy (Array l a) where+  type FieldsOfType (Array l a) ty = HomogeneousFields (Array l) a ty+  primTySing = SArray++instance PrimTy a => PrimTy (RuntimeArray a) where+  type FieldsOfType (RuntimeArray a) ty = HomogeneousFields RuntimeArray a ty+  primTySing = SRuntimeArray++class    (Typeable as, StructFieldKind fld) => PrimTyMap (as :: [fld :-> Type]) where+  primTyMapSing :: SPrimTyMap as++instance StructFieldKind fld => PrimTyMap ('[] :: [fld :-> Type]) where+  primTyMapSing = SNil++instance forall ( fld :: Type           )+                ( k   :: fld            )+                ( a   :: Type           )+                ( as  :: [fld :-> Type] )+      . ( StructFieldKind fld+        , Typeable k+        , Known fld k+        , PrimTy a+        , PrimTyMap as+        )+       => PrimTyMap ((k ':-> a) ': as) where+  primTyMapSing = SCons++instance PrimTyMap as => PrimTy (Struct (as :: [fld :-> Type])) where+  type FieldsOfType (Struct as) ty = StructFieldsStartingAt 0 as ty+  primTySing = SStruct++type family StructFieldsStartingAt+              ( i  :: Nat              )+              ( as :: [ fld :-> Type ] )+              ( ty :: Type             )+            :: [ IndexChain ]+            where+  StructFieldsStartingAt _ '[]                    _+    = '[]+  StructFieldsStartingAt i ( ( _ ':-> a ) ': as ) ty+    = ( MapCons ( ThisIndex i ) (FieldsOfType a ty) )+    :++:+    StructFieldsStartingAt (i+1) as ty++primTy :: forall ty. PrimTy ty => SPIRV.PrimTy+primTy = sPrimTy ( primTySing @ty )++primTys :: forall as. All PrimTy as => [SPIRV.PrimTy]+primTys = case allDict @PrimTy @as of+  NilDict -> []+  consDict@ConsDict ->+    case consDict of+      ( _ :: AllDict PrimTy (b ': bs) ) ->+        primTy @b : primTys @bs++primTyMap :: forall (fld :: Type) (flds :: [fld :-> Type])+          .  PrimTyMap flds+          => [ (Maybe ShortText, SPIRV.PrimTy) ]+primTyMap = sPrimTyMap ( primTyMapSing @fld @flds )++sPrimTy :: SPrimTy ty -> SPIRV.PrimTy+sPrimTy SUnit = SPIRV.Unit+sPrimTy SBool = SPIRV.Boolean+sPrimTy (SScalar :: SPrimTy a)+  = SPIRV.Scalar (scalarTy @a)+sPrimTy vec@SVector = case vec of+  ( _ :: SPrimTy (V n a) )+    -> SPIRV.Vector (knownValue @n) (primTy @a)+sPrimTy mat@SMatrix = case mat of+  ( _ :: SPrimTy (M m n a) )+    -> SPIRV.Matrix (knownValue @m) (knownValue @n) (scalarTy @a)+sPrimTy arr@SArray = case arr of+  ( _ :: SPrimTy (Array l a) )+    -> SPIRV.Array  (knownValue @l) (primTy @a)+sPrimTy rtArr@SRuntimeArray = case rtArr of+  ( _ :: SPrimTy (RuntimeArray a) )+    -> SPIRV.RuntimeArray (primTy @a)+sPrimTy struct@SStruct = case struct of+  ( _ :: SPrimTy (Struct as) )+    -> SPIRV.Struct (sPrimTyMap (primTyMapSing @_ @as))+sPrimTy SAccelerationStructure = SPIRV.AccelerationStructure++sPrimTyMap :: forall (fld :: Type) (flds :: [fld :-> Type])+           .  SPrimTyMap flds+           -> [ (Maybe ShortText, SPIRV.PrimTy) ]+sPrimTyMap SNil = []+sPrimTyMap cons@SCons = case cons of+  ( _ :: SPrimTyMap (( f ':-> a ) ': as) )+    ->  let+          mbFieldName :: Maybe ShortText+          mbFieldName =+            case fieldKind @fld of+              NamedField -> Just ( knownValue @f )+              _          -> Nothing+        in ( mbFieldName, primTy @a )+           : sPrimTyMap (primTyMapSing @_ @as)+++scalarTy :: forall ty. ScalarTy ty => SPIRV.ScalarTy+scalarTy = sScalarTy ( scalarTySing @ty )++sScalarTy :: SScalarTy ty -> SPIRV.ScalarTy+sScalarTy SWord8  = SPIRV.Integer Unsigned W8+sScalarTy SWord16 = SPIRV.Integer Unsigned W16+sScalarTy SWord32 = SPIRV.Integer Unsigned W32+sScalarTy SWord64 = SPIRV.Integer Unsigned W64+sScalarTy SInt8   = SPIRV.Integer Signed   W8+sScalarTy SInt16  = SPIRV.Integer Signed   W16+sScalarTy SInt32  = SPIRV.Integer Signed   W32+sScalarTy SInt64  = SPIRV.Integer Signed   W64+sScalarTy SHalf   = SPIRV.Floating         W16+sScalarTy SFloat  = SPIRV.Floating         W32+sScalarTy SDouble = SPIRV.Floating         W64++------------------------------------------------------------+-- statically known list of variables (for function definitions)++class KnownVar (bd :: (Symbol :-> Binding)) where+  knownVar :: ( ShortText, (SPIRV.PrimTy, Permissions) )++instance (KnownSymbol k, Known Permissions ps, PrimTy a)+       => KnownVar (k ':-> Var ps a) where+  knownVar =+    ( knownValue @k+    , ( primTy @a+      , knownValue @ps+      )+    )++class KnownVars (bds :: BindingsMap) where+  knownVars :: [ (ShortText, (SPIRV.PrimTy, Permissions)) ]+instance KnownVars '[] where+  knownVars = []+instance (KnownVar bd, KnownVars bds)+      => KnownVars (bd ': bds) where+  knownVars = knownVar @bd : knownVars @bds++------------------------------------------------------------+-- statically known interfaces (for entry points)++class KnownInterfaceBinding (bd :: (Symbol :-> Binding)) where+  knownInterfaceBinding :: ( ShortText, (SPIRV.PrimTy, SPIRV.StorageClass) )++instance (KnownSymbol k, PrimTy a)+       => KnownInterfaceBinding (k ':-> Var '[ 'Read ] a) where+  knownInterfaceBinding+    = ( knownValue @k+      , ( primTy @a+        , Storage.Input+        )+      )+instance (KnownSymbol k, PrimTy a)+       => KnownInterfaceBinding (k ':-> Var '[ 'Write ] a) where+  knownInterfaceBinding+    = ( knownValue @k+      , ( primTy @a+        , Storage.Output+        )+      )++instance+  TypeError+    (    Text "Interface binding " :<>: ShowType k :<>: Text " is both readable and writable."+    :$$: Text "Interface variables must be of either 'Input' or 'Output' type, not both." )+  => KnownInterfaceBinding (k ':-> Var '[ 'Read, 'Write ] a) where+  knownInterfaceBinding = error "unreachable"+instance+  TypeError+    (    Text "Interface binding " :<>: ShowType k :<>: Text " is both readable and writable."+    :$$: Text "Interface variables must be of either 'Input' or 'Output' type, not both." )+  => KnownInterfaceBinding (k ':-> Var '[ 'Write, 'Read ] a) where+  knownInterfaceBinding = error "unreachable"++class KnownInterface (bds :: BindingsMap) where+  knownInterface :: [ ( ShortText, (SPIRV.PrimTy, SPIRV.StorageClass) ) ]+instance KnownInterface '[] where+  knownInterface = []+instance (KnownInterfaceBinding bd, KnownInterface bds)+      => KnownInterface (bd ': bds) where+  knownInterface = knownInterfaceBinding @bd : knownInterface @bds++------------------------------------------------------------+-- functors++type SPrimFunc :: (Type -> Type) -> Type+data SPrimFunc f where+  SFuncVector  :: KnownNat n => SPrimFunc (V n)+  SFuncMatrix  :: (KnownNat m, KnownNat n) => SPrimFunc (M m n)+  SFuncArray   :: KnownNat n => SPrimFunc (Array n)++-- explicit dictionary passing workaround+-- would like to use a quantified constraint instead+-- (see (GHC issue #17226)[https://gitlab.haskell.org/ghc/ghc/issues/17226])+type DistDict :: (Type -> Type) -> Type -> Type+data DistDict f a where+  DistDict+    :: ( Syntactic a, Internal a ~ Val va+       , Syntactic (f a), Internal (f a) ~ Val (f va)+       )+    => DistDict f a++class ( Applicative f+    --, forall a. (Syntactic a, Internal a ~ Val va, PrimTy va) => Syntactic (f a)+      ) => PrimFunc f where+  primFuncSing :: SPrimFunc f+  distDict     :: ( Syntactic a, Internal a ~ Val va, PrimTy va )+               => DistDict f a++primFuncName :: forall f. PrimFunc f => String+primFuncName = case primFuncSing @f of++  sFuncVector@SFuncVector ->+    case sFuncVector of+      ( _ :: SPrimFunc (V n) ) ->+        "V " ++ show (natVal (Proxy @n))++  sFuncMatrix@SFuncMatrix ->+    case sFuncMatrix of+      ( _ :: SPrimFunc (M m n) ) ->+        "M " ++ show (natVal (Proxy @m))+             ++ " "+             ++ show (natVal (Proxy @n))+  sFuncArray@SFuncArray ->+    case sFuncArray of+      ( _ :: SPrimFunc (Array n) ) ->+        "Array " ++ show (natVal (Proxy @n))++------------------------------------------------------------+-- dependent pair++data AConstant :: Type where+  AConstant :: PrimTy ty => ty -> AConstant++aConstant :: PrimTy ty => ty -> AConstant+aConstant = AConstant++instance Show AConstant where+  show (AConstant (a :: ty))+    = "Constant " ++ show a ++ " of type " ++ show (primTy @ty)++instance Eq AConstant where+  (AConstant (a1 :: ty1)) == (AConstant (a2 :: ty2))+    = case eqT @ty1 @ty2 of+        Just Refl -> a1 == a2+        _         -> False++instance Ord AConstant where+  (AConstant (a1 :: ty1)) `compare` (AConstant (a2 :: ty2))+    = case eqT @ty1 @ty2 of+         Just Refl -> compare a1 a2+         _         -> compare (primTy @ty1)+                              (primTy @ty2)
+ src/FIR/Prim/Types.hs-boot view
@@ -0,0 +1,117 @@+{-# LANGUAGE AllowAmbiguousTypes      #-}+{-# LANGUAGE DataKinds                #-}+{-# LANGUAGE FlexibleInstances        #-}+{-# LANGUAGE GADTs                    #-}+{-# LANGUAGE PolyKinds                #-}+{-# LANGUAGE RoleAnnotations          #-}+{-# LANGUAGE ScopedTypeVariables      #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeFamilies             #-}+{-# LANGUAGE TypeOperators            #-}++module FIR.Prim.Types where++-- base+import Data.Kind+  ( Type )+import Data.Typeable+  ( Typeable )++-- text-short+import Data.Text.Short+  ( ShortText )++-- fir+import {-# SOURCE #-} Control.Type.Optic+  ( IndexChain )+import Data.Binary.Class.Put+  ( Put )+import Data.Function.Variadic+  ( ListVariadic )+import Data.Type.Known+  ( Known )+import Data.Type.Map+  ( (:->)((:->)) )+import {-# SOURCE #-} FIR.AST+import FIR.AST.Type+  ( AugType(Val) )+import {-# SOURCE #-} FIR.Prim.Struct+  ( StructFieldKind )+import qualified SPIRV.PrimTy   as SPIRV+import qualified SPIRV.ScalarTy as SPIRV++------------------------------------------------------------+-- singletons for primitive types++data SScalarTy :: Type -> Type where+type role SScalarTy nominal++data SPrimTy :: Type -> Type where+type role SPrimTy nominal++type family HasOpaqueType (a :: Type) :: Bool where ..++class ( Show ty+      , Eq ty, Ord ty, Typeable ty+      , ty ~ ListVariadic '[] ty+      )+    => PrimTy ty where+  type FieldsOfType ty fldTy :: [ IndexChain ]+  primTySing :: SPrimTy ty++class ( PrimTy ty+      , Put ty+      , HasOpaqueType ty ~ False+      )+    => ScalarTy ty where+  scalarTySing :: SScalarTy ty++class (ScalarTy ty, Integral ty) => IntegralTy ty++scalarTy :: forall ty. ScalarTy ty => SPIRV.ScalarTy+primTy   :: forall ty. PrimTy   ty => SPIRV.PrimTy++data SPrimTyMap :: [fld :-> Type] -> Type where+  SNil  :: SPrimTyMap '[]+  SCons :: (StructFieldKind fld, Known fld k, PrimTy a, PrimTyMap as)+        => SPrimTyMap ((k ':-> a) ': as)+type role SPrimTyMap nominal++class    (Typeable as, StructFieldKind fld) => PrimTyMap (as :: [fld :-> Type]) where+  primTyMapSing :: SPrimTyMap as++primTyMap :: forall (fld :: Type) (flds :: [fld :-> Type])+          .  PrimTyMap flds+          => [ (Maybe ShortText, SPIRV.PrimTy) ]++instance StructFieldKind fld => PrimTyMap ('[] :: [fld :-> Type]) where++instance forall ( fld :: Type           )+                ( k   :: fld            )+                ( a   :: Type           )+                ( as  :: [fld :-> Type] )+      . ( StructFieldKind fld+        , Typeable k+        , Known fld k+        , PrimTy a+        , PrimTyMap as+        )+       => PrimTyMap ((k ':-> a) ': as) where+++type SPrimFunc :: (Type -> Type) -> Type+data SPrimFunc :: (Type -> Type) -> Type where+type role SPrimFunc nominal++type DistDict :: (Type -> Type) -> Type -> Type+data DistDict f a where+type role DistDict nominal nominal++class ( Applicative f+    --, forall a. (Syntactic a, Internal a ~ Val va, PrimTy va) => Syntactic (f a)+      ) => PrimFunc f where+  primFuncSing :: SPrimFunc f+  distDict     :: ( Syntactic a, Internal a ~ Val va, PrimTy va )+               => DistDict f a++primFuncName :: forall f. PrimFunc f => String
+ src/FIR/ProgramState.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++{-|+Module: FIR.ProgramState++Defines the type-level data used for the state of the indexed monad used to construct programs:++> program :: Program (i :: ProgramState) (j :: ProgramState) (a :: Type)++See "FIR.Module.Program".++The program state consists of:++  * the bindings that are in scope (such as built-in variables or user-defined variables),+  * the function context (whether the current code is contained within a function/entry-point, or is at the top-level),+  * information associated to the functions and entry-points relevant to the program,+    such as whether they have been defined yet or only declared.+  * the data of which SPIR-V backend we are using: Vulkan or OpenCL.+-}++module FIR.ProgramState where++-- base+import Data.Kind+  ( Type )+import Data.Word+  ( Word32 )+import GHC.TypeLits+  ( Symbol, KnownSymbol+  , TypeError, ErrorMessage(..)+  )+import GHC.TypeNats+  ( Nat )++-- text-short+import Data.Text.Short+  ( ShortText )++-- fir+import Data.Type.Known+  ( Demotable(Demote)+  , Known(known), knownValue+  )+import Data.Type.Map+  ( Map, (:->) )+import FIR.Binding+  ( BindingsMap+  , Permissions+  )+import FIR.Prim.RayTracing+  ( RayQueryState )+import FIR.Prim.Types+  ( KnownVars(knownVars) )+import qualified SPIRV.Control    as SPIRV+import qualified SPIRV.Decoration as SPIRV+import qualified SPIRV.PrimTy     as SPIRV+  ( PrimTy )+import qualified SPIRV.Stage      as SPIRV+import qualified SPIRV.Storage    as SPIRV++-------------------------------------------------------------------+-- | Data (kind) used to keep track of function context at the type-level.+data FunctionContext lit nat bindings mbIface where+  TopLevel :: FunctionContext lit nat bindings iface+  InFunction :: lit -> bindings -> FunctionContext lit nat bindings mbIface+  InEntryPoint+    :: lit+    -> SPIRV.ExecutionInfo nat em+    -> mbIface+    -> FunctionContext lit nat bindings mbIface++deriving stock instance ( Show lit, Show bindings, Show nat, Show mbIface )+                     => Show ( FunctionContext lit nat bindings mbIface )+++type InterfaceVariable nat ty = ([SPIRV.Decoration nat], ty)+type TLInterfaceVariable = InterfaceVariable Nat    Type+type VLInterfaceVariable = InterfaceVariable Word32 SPIRV.PrimTy++type TLInterface+  = [ SPIRV.StorageClass :-> [ Symbol    :-> TLInterfaceVariable ] ]+type VLInterface+  = [ SPIRV.StorageClass :-> [ ShortText :-> VLInterfaceVariable ] ]++-- | A type-level function context.+type TLFunctionContext+  = FunctionContext+      Symbol+      Nat+      BindingsMap+      ( Maybe TLInterface )+-- | A value-level function context.+type VLFunctionContext+  = FunctionContext+      ShortText+      Word32+      [ ( ShortText, (SPIRV.PrimTy, Permissions) ) ]+      ( Maybe VLInterface )++instance Demotable TLFunctionContext where+  type Demote TLFunctionContext = VLFunctionContext++instance Known TLFunctionContext 'TopLevel where+  known = TopLevel+instance ( KnownVars args+         , KnownSymbol fnName+         )+       => Known TLFunctionContext ('InFunction fnName args) where+  known = InFunction+            ( knownValue @fnName )+            ( knownVars  @args   )+instance ( Known (SPIRV.ExecutionInfo Nat stage) stageInfo+         , KnownSymbol stageName+         )+      => Known TLFunctionContext+            ( 'InEntryPoint+                  stageName+                  ( stageInfo :: SPIRV.ExecutionInfo Nat stage )+                  ('Just iface)+            ) where+  known = InEntryPoint+            ( knownValue     @stageName )+            ( knownValue     @stageInfo )+            Nothing++data Definedness+  = Declared+  | Defined++-- | Keeps track of a function at the type level.+data FunctionInfo where+  FunctionInfo+    :: BindingsMap+    -> Type+    -> SPIRV.FunctionControl+    -> Definedness+    -> FunctionInfo++-- | Keeps track of an entry point at the type level:+--+--   - a type level 'SPIRV.ExecutionInfo' recording the stage as well as additional+--     stage information,+--   - the entry point interface (input/output variables which it uses),+--     (or Nothing if the interface has not yet been computed).+data EntryPointInfo where+  EntryPointInfo+    :: SPIRV.ExecutionInfo Nat stage+    -> TLInterface+    -> Definedness+    -> EntryPointInfo++newtype CFGState = CFGState { loopDepth :: Nat }++-- | State that is used in the user-facing indexed monad (at the type level).+-- Consists of:+--+--    - a type-level list of which bindings are in scope,+--    such as user-defined functions, user-defined variables+--    and built-in variables,+--    - a context – whether code in the current indexed monadic state+--    occurs inside a function or entry-point body –+--    - the current control-flow state,+--    - which functions are to be declared,+--    whether they have been declared yet,+--    and some further information (arguments, function control),+--    - which entry points are to be declared,+--    whether they have been declared yet, together with+--    some additional info pertaining to their respective execution modes,+--    and their interfaces (user defined inputs/outputs),+--    - the state of all current ray-query operations,+--    - which SPIR-V backend is being used (Vulkan or OpenCL).+data ProgramState+  = ProgramState+      { bindings    :: BindingsMap+      , context     :: TLFunctionContext+      , cfgState    :: CFGState+      , functions   :: Map Symbol FunctionInfo+      , entryPoints :: Map Symbol EntryPointInfo+      , interface   :: TLInterface+      , rayQueries  :: Map Symbol RayQueryState+      , backend     :: SPIRV.Backend+      }++type family Bindings ( s :: ProgramState ) :: BindingsMap where+  Bindings ('ProgramState bds _ _ _ _ _ _ _) = bds++type family CFGInfo ( s :: ProgramState ) :: CFGState where+  CFGInfo ('ProgramState _ _ cfg _ _ _ _ _) = cfg++type family FunctionInfos ( s :: ProgramState ) :: Map Symbol FunctionInfo where+  FunctionInfos ('ProgramState _ _ _ fs _ _ _ _) = fs++type family EntryPointInfos ( s :: ProgramState ) :: Map Symbol EntryPointInfo where+  EntryPointInfos ('ProgramState _ _ _ _ eps _ _ _) = eps++type family ExecutionContext ( s :: ProgramState ) :: Maybe SPIRV.ExecutionModel where+  ExecutionContext ('ProgramState _ ('InEntryPoint _ (info :: SPIRV.ExecutionInfo Nat stage) _) _ _ _ _ _ _)+    = Just stage+  ExecutionContext _+    = Nothing++type family RayQueries ( s :: ProgramState ) :: Map Symbol RayQueryState where+  RayQueries ('ProgramState _ _ _ _ _ _ rayQueries _) = rayQueries++executionContext :: VLFunctionContext -> Maybe (ShortText, SPIRV.ExecutionModel)+executionContext (InEntryPoint stageName stageInfo _) = Just (stageName, SPIRV.modelOf stageInfo)+executionContext _ = Nothing++type family ExecutionContext' ( s :: ProgramState ) :: SPIRV.ExecutionModel where+  ExecutionContext' ('ProgramState _ ('InEntryPoint _ (info :: SPIRV.ExecutionInfo Nat stage) _) _ _ _ _ _ _)+    = stage+  ExecutionContext' _+    = TypeError+        ( Text "Cannot access stage context: not within a stage." )++type family ExecutionInfoContext+                ( s :: ProgramState )+              :: Maybe (SPIRV.ExecutionInfo Nat (ExecutionContext' s))+                where+  ExecutionInfoContext ('ProgramState _ ('InEntryPoint _ info _) _ _ _ _ _ _)+    = Just info+  ExecutionInfoContext _ = 'Nothing
+ src/FIR/ProgramState.hs-boot view
@@ -0,0 +1,3 @@+module FIR.ProgramState where++data ProgramState
+ src/FIR/Syntax/AST.hs view
@@ -0,0 +1,1213 @@+{-# OPTIONS_HADDOCK ignore-exports #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}++{-# LANGUAGE AllowAmbiguousTypes        #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs               #-}+{-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE QuantifiedConstraints      #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE TypeFamilyDependencies     #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE UndecidableInstances       #-}++{-|+Module: FIR.Syntax.AST++This module, together with "FIR.Syntax.Program",+provides most of the user-facing syntax for constructing+and manipulating values in the EDSL.++This is done through type class overloading, here in the form of+orphan instances for types of the form @AST a@+(representing pure values in the EDSL).++-}++module FIR.Syntax.AST+  ( -- switch statement+    switch++    -- functor/applicative for AST values+  , ASTApplicative(..), fmapAST, (<$$>)++    -- + orphan instances+  )+  where++-- base+import Prelude hiding+  ( Eq(..), (&&), (||), not+  , Ord(..)+  , Num(..), Floating(..)+  , Integral(..), floor+  , Fractional(..), fromRational+  , Floating(..)+  , RealFloat(..)+  , Functor(..), (<$>)+  , Applicative(..)+  )+import qualified Prelude+import Data.Int+  ( Int8, Int16, Int32, Int64 )+import Data.Kind+  ( Type, Constraint )+import Data.Proxy+  ( Proxy(Proxy) )+import Data.Typeable+  ( Typeable )+import Data.Word+  ( Word8, Word16, Word32, Word64 )+import GHC.TypeLits+  ( Symbol, KnownSymbol+  , TypeError, ErrorMessage(..)+  )+import GHC.TypeNats+  ( Nat, KnownNat+  , type (+), CmpNat, sameNat+  )++-- half+import Numeric.Half+  ( Half )++-- vector-sized+import qualified Data.Vector.Sized as Vector+  ( Vector, generate )++-- fir+import Control.Type.Optic+  ( Optic(..), Index+  , Gettable, ReifiedGetter(view)+  , Settable, ReifiedSetter(set)+  , ProductComponents(ProductO, EndProd_)+  , ComponentsGettable+  , ComponentsSettable+  , ArePairwiseDisjoint+  , Container(FieldIndexFromName)+  )+import Data.Constraint.All+  ( All )+import Data.Finite.With+  ( withFinite )+import Data.Function.Variadic+  ( ListVariadic )+import Data.Product+  ( IsProduct+  , AreProducts+  , Distribute+  , MapHList+  )+import Data.Type.List+  ( KnownLength(sLength)+  , SameLength+  , type (:++:), Postpend, Snoc+  )+import Data.Type.Map+  ( (:->)((:->)), Key )+import FIR.AST+  ( AST, Code+  , Syntactic(Internal, toAST, fromAST)+  , InternalType+  , primOp+  , pattern (:$), pattern Lit+  , pattern Switch+  , pattern View, pattern Set+  , pattern Pure, pattern Ap+  , pattern MkVector, pattern Mat, pattern UnMat, pattern Array, pattern Struct+  , pattern GradedMappend+  )+import FIR.AST.Optics+  ( AugListVariadic )+import FIR.AST.Type+  ( AugType(Val, (:-->))+  , FunArgs, FunRes+  , ApplyFAug+  )+import FIR.Syntax.Optics+  ( KnownOptic(opticSing)+  , KnownComponents+  , (%:.:)+  , ValidAnIndexOptic+  )+import FIR.Prim.Array+  ( Array(MkArray), RuntimeArray )+import FIR.Prim.Op+  ( PrimTyVal, Vectorise(Vectorise) )+import FIR.Prim.Struct+  ( Struct((:&), End) )+import FIR.Prim.Types+  ( PrimTy+  , SScalarTy(..), ScalarTy, IntegralTy+  , ScalarFromTy, TypeFromScalar+  , SPrimFunc(..), PrimFunc(..), DistDict(DistDict)+  , scalarTySing+  )+import FIR.Validation.Bounds+  ( StructIndexFromName )+import Math.Algebra.Class+  ( AdditiveMonoid(..), CancellativeAdditiveMonoid(..), AdditiveGroup(..)+  , Semiring(..), Ring+  , DivisionRing(..)+  , Signed(..), Archimedean(..)+  , Floating(..), RealFloat(..)+  , Integral, Unsigned+  , Convert(..), Rounding(..)+  )+import Math.Algebra.GradedSemigroup+  ( GradedSemigroup(..) )+import Math.Linear+  ( Semimodule(..), LinearModule(..)+  , Inner(..), Cross(..)+  , Matrix(..), VectorOf+  , V, M(..)+  , buildV+  )+import Math.Logic.Bits+  ( Bits(..), BitShift(..), BitCast(..) )+import Math.Logic.Class+  ( Eq(..), Boolean(..), Ord(..) )+import qualified SPIRV.ScalarTy as SPIRV+import qualified SPIRV.PrimOp   as SPIRV++--------------------------------------------------------------------------------------+-- Instances for AST type++-- * Logical operations+--+-- $logical+-- Instances for:+--+-- 'Boolean',+--+-- 'Eq', 'Ord' (note: not the "Prelude" type classes).+--+-- Note that rebindable syntax for if-then-else is provided+-- by the module "FIR.Syntax.IfThenElse".++instance ( b ~ Bool ) => Boolean (Code b) where+  true  = Lit True+  false = Lit False+  (&&)  = primOp @Bool @SPIRV.BoolAnd+  (||)  = primOp @Bool @SPIRV.BoolOr+  not   = primOp @Bool @SPIRV.BoolNot++instance ( PrimTy a, Eq a, Logic a ~ Bool )+  => Eq (Code a) where+  type Logic (Code a) = Code Bool+  (==) = primOp @a @SPIRV.Equal+  (/=) = primOp @a @SPIRV.NotEqual++instance ( ScalarTy a, Ord a, Logic a ~ Bool ) +  => Ord (Code a) where+  (<=) = primOp @a @SPIRV.LTE+  (>=) = primOp @a @SPIRV.GTE+  (<)  = primOp @a @SPIRV.LT+  (>)  = primOp @a @SPIRV.GT+  min  = primOp @a @SPIRV.Min+  max  = primOp @a @SPIRV.Max++-- | Switch statement.+-- Takes a scrutinee, a list of cases and a default (fallthrough) case.+--+-- Returns a switch statement which decides on the branch to follow by inspecting the scrutinee.+--+-- See 'FIR.Syntax.Program.switchM' for a monadic version.+switch :: ( Syntactic scrut+          , Internal scrut ~ Val vscrut+          , IntegralTy vscrut+          , Syntactic val+          , Internal val ~ Val vval+          , PrimTy vval+          )+       => scrut -- ^ Scrutinee.+       -> [ vscrut :-> val ] -- ^ Cases.+       -> val  -- ^ Default (fallthrough) case.+       -> val+switch scrut cases val = fromAST $ Switch (toAST scrut) (toAST val) (map ( \ (x :-> y) -> (x, toAST y) ) cases)++-- * Bitwise operations+--+-- $bitwise+-- Instances for:+--+-- 'Bits', 'BitShift' (note: not 'Data.Bits.Bits'), 'BitCast'.++instance (ScalarTy a, Bits a) => Bits (Code a) where+  (.&.)      = primOp @a @SPIRV.BitAnd+  (.|.)      = primOp @a @SPIRV.BitOr+  xor        = primOp @a @SPIRV.BitXor+  complement = primOp @a @SPIRV.BitNot+  zeroBits   = Lit ( zeroBits @a )+  bitReverse = primOp @a @SPIRV.ReverseBits++instance (ScalarTy a, ScalarTy s, BitShift '(a,s))+  => BitShift '(Code a, Code s) where+  shiftL = primOp @'(a,s) @SPIRV.BitShiftLeft+  shiftR = primOp @'(a,s) @SPIRV.BitShiftRight++instance (ScalarTy a, ScalarTy b, BitCast a b)+  => BitCast (Code a) (Code b) where+  bitcast = primOp @'(a,b) @SPIRV.CastOp++-- * Numeric operations+-- +-- $numeric+-- Instances for:+--+-- 'AdditiveMonoid', 'AdditiveGroup', 'Signed',+--+-- 'Semiring', 'Ring', +--+-- 'DivisionRing', 'Archimedean' (Archimedean ordered group),+--+-- 'Floating', 'RealFloat' (note: not the "Prelude" type classes)+--+-- 'Integral', 'Unsigned'.++instance (ScalarTy a, AdditiveMonoid a) => AdditiveMonoid (Code a) where+  (+)    = primOp @a @SPIRV.Add+  zero   = Lit (zero :: a)+  fromInteger = Lit . fromInteger+instance (ScalarTy a, Semiring a) => Semiring (Code a) where+  (*)    = primOp @a @SPIRV.Mul+instance (ScalarTy a, CancellativeAdditiveMonoid a) => CancellativeAdditiveMonoid (Code a) where+  (-)    = primOp @a @SPIRV.Sub+instance (ScalarTy a, AdditiveGroup a) => AdditiveGroup (Code a) where+  negate = primOp @a @SPIRV.Neg+instance (ScalarTy a, Signed a) => Signed (Code a) where+  abs    = primOp @a @SPIRV.Abs+  signum = primOp @a @SPIRV.Sign+instance (ScalarTy a, DivisionRing a) => DivisionRing (Code a) where+  (/)    = primOp @a @SPIRV.Div+  fromRational = Lit . fromRational++instance Archimedean (Code Word8 ) where+  mod    = primOp @Word8  @SPIRV.Mod+  rem    = primOp @Word8  @SPIRV.Rem+  div    = primOp @Word8  @SPIRV.Quot+instance Archimedean (Code Word16) where+  mod    = primOp @Word16 @SPIRV.Mod+  rem    = primOp @Word16 @SPIRV.Rem+  div    = primOp @Word16 @SPIRV.Quot+instance Archimedean (Code Word32) where+  mod    = primOp @Word32 @SPIRV.Mod+  rem    = primOp @Word32 @SPIRV.Rem+  div    = primOp @Word32 @SPIRV.Quot+instance Archimedean (Code Word64) where+  mod    = primOp @Word64 @SPIRV.Mod+  rem    = primOp @Word64 @SPIRV.Rem+  div    = primOp @Word64 @SPIRV.Quot+instance Archimedean (Code Int8  ) where+  mod    = primOp @Int8   @SPIRV.Mod+  rem    = primOp @Int8   @SPIRV.Rem+  div    = primOp @Int8   @SPIRV.Quot+instance Archimedean (Code Int16 ) where+  mod    = primOp @Int16  @SPIRV.Mod+  rem    = primOp @Int16  @SPIRV.Rem+  div    = primOp @Int16  @SPIRV.Quot+instance Archimedean (Code Int32 ) where+  mod    = primOp @Int32  @SPIRV.Mod+  rem    = primOp @Int32  @SPIRV.Rem+  div    = primOp @Int32  @SPIRV.Quot+instance Archimedean (Code Int64 ) where+  mod    = primOp @Int64  @SPIRV.Mod+  rem    = primOp @Int64  @SPIRV.Rem+  div    = primOp @Int64  @SPIRV.Quot+instance Archimedean (Code Half  ) where+  mod    = primOp @Half   @SPIRV.Mod+  rem    = primOp @Half   @SPIRV.Rem+  div a b = floor (a / b)+instance Archimedean (Code Float ) where+  mod    = primOp @Float  @SPIRV.Mod+  rem    = primOp @Float  @SPIRV.Rem+  div a b = floor (a / b)+instance Archimedean (Code Double) where+  mod    = primOp @Double @SPIRV.Mod+  rem    = primOp @Double @SPIRV.Rem+  div a b = floor (a / b)++instance (ScalarTy a, Floating a) => Floating (Code a) where+  pi         = Lit pi+  exp        = primOp @a @SPIRV.FExp+  log        = primOp @a @SPIRV.FLog+  sqrt       = primOp @a @SPIRV.FSqrt+  invSqrt    = primOp @a @SPIRV.FInvSqrt+  sin        = primOp @a @SPIRV.FSin+  cos        = primOp @a @SPIRV.FCos+  tan        = primOp @a @SPIRV.FTan+  asin       = primOp @a @SPIRV.FAsin+  acos       = primOp @a @SPIRV.FAcos+  atan       = primOp @a @SPIRV.FAtan+  sinh       = primOp @a @SPIRV.FSinh+  cosh       = primOp @a @SPIRV.FCosh+  tanh       = primOp @a @SPIRV.FTanh+  asinh      = primOp @a @SPIRV.FAsinh+  acosh      = primOp @a @SPIRV.FAcosh+  atanh      = primOp @a @SPIRV.FAtanh+  (**)       = primOp @a @SPIRV.FPow++instance (ScalarTy a, RealFloat a, Eq a, Logic a ~ Bool) => RealFloat (Code a) where+  atan2      = primOp @a @SPIRV.FAtan2+  isNaN      = primOp @a @SPIRV.FIsNaN+  isInfinite = primOp @a @SPIRV.FIsInf++instance (ScalarTy a, Integral a) => Integral (Code a) where+instance (ScalarTy a, Unsigned a) => Unsigned (Code a) where++-- * Numeric conversions+--+-- $conversions+-- Instance for 'Convert', 'Rounding'.++-- Helpers to choose which conversion function to use.+--   * Can use identity function when @a ~ b@.+--   * For converting from different sign + different width integer types,+--   two operations are needed: resizing + bitcast.+--   The intermediate type is recorded.+data WhichConversion+  = UseIdentity+  | UseConversion+  | UseConversionThenBitcast Type++type family ChooseConversion (a :: Type) (b :: Type) :: WhichConversion where+  ChooseConversion a a = UseIdentity+  ChooseConversion a b =+    ChooseConversionFromScalars+      a ( ScalarFromTy a )+      b ( ScalarFromTy b )++type family ChooseConversionFromScalars+              ( a :: Type ) ( sa :: SPIRV.ScalarTy )+              ( b :: Type ) ( sb :: SPIRV.ScalarTy )+            :: WhichConversion+            where+  ChooseConversionFromScalars+    _ _+    _ ( SPIRV.Floating w )+      = UseConversion+  ChooseConversionFromScalars+    a ( SPIRV.Floating v )+    b _+      = TypeError+        (    Text "Cannot convert from type " :<>: ShowType a+        :$$: Text "to type " :<>: ShowType b+        )+  ChooseConversionFromScalars+    _ ( SPIRV.Integer s v )+    _ ( SPIRV.Integer s w )+      = UseConversion+  ChooseConversionFromScalars+    _ ( SPIRV.Integer r w )+    _ ( SPIRV.Integer s w )+      = UseConversion -- (strictly speaking this ends up being a bitcast)+  ChooseConversionFromScalars+    _ ( SPIRV.Integer r v )+    _ ( SPIRV.Integer s w )+      = UseConversionThenBitcast+          ( TypeFromScalar ( SPIRV.Integer r w ) )++class DispatchConversion a b (useIdentity :: WhichConversion) where+  conversion :: Code a -> Code b++instance ScalarTy a => DispatchConversion a a UseIdentity where+  conversion = id+instance (ScalarTy a, ScalarTy b, Convert '(a,b)) => DispatchConversion a b 'UseConversion where+  conversion = primOp @'(a,b) @SPIRV.Convert+instance ( ScalarTy a, ScalarTy b, ScalarTy x+         , Convert '(a,x), Convert '(x,b)+         )+       => DispatchConversion a b ('UseConversionThenBitcast x) where+  conversion+    = ( primOp @'(x,b) @SPIRV.Convert :: Code x -> Code b )+    . ( primOp @'(a,x) @SPIRV.Convert :: Code a -> Code x )++instance ( ScalarTy a, ScalarTy b, DispatchConversion a b (ChooseConversion a b) )+       => Convert '(Code a, Code b) where+  convert = conversion @a @b @(ChooseConversion a b)++instance {-# OVERLAPPING #-}+         ( ScalarTy a, Rounding '(a,a) )+      => Rounding '(Code a, Code a) where+  truncate = primOp @'(a,a) @SPIRV.CTruncate+  round    = primOp @'(a,a) @SPIRV.CRound+  floor    = primOp @'(a,a) @SPIRV.CFloor+  ceiling  = primOp @'(a,a) @SPIRV.CCeiling++instance ( ScalarTy a, ScalarTy b+         , Floating a, Integral b+         , Rounding '(a,a), Rounding '(a,b)+         )+       => Rounding '(Code a, Code b) where+  truncate = primOp @'(a,b) @SPIRV.CTruncate+  round    = primOp @'(a,b) @SPIRV.CTruncate @(Code a -> Code b)+           . primOp @'(a,a) @SPIRV.CRound+  floor    = primOp @'(a,b) @SPIRV.CTruncate @(Code a -> Code b)+           . primOp @'(a,a) @SPIRV.CFloor+  ceiling  = primOp @'(a,b) @SPIRV.CTruncate @(Code a -> Code b)+           . primOp @'(a,a) @SPIRV.CCeiling+++-----------------------------------------------+-- * Optics++class KnownOptic optic => KnownASTOptic astoptic optic | astoptic -> optic where++-- ** Simple instances++-- *** Name++instance ( empty ~ '[]+         , KnownSymbol k+         , r ~ Code a+         , KnownOptic (Field_ k :: Optic '[] s a)+         )+       => KnownASTOptic (Field_ k :: Optic empty1 (Code s) r) (Field_ k :: Optic '[] s a)+       where+instance ( KnownSymbol k+         , empty ~ '[]+         , Gettable (Field_ k :: Optic '[] s a)+         , r ~ Code a+         )+      => Gettable (Field_ k :: Optic empty (Code s) r)+      where+instance ( KnownSymbol k+         , empty ~ '[]+         , Gettable (Field_ k :: Optic '[] s a)+         , ReifiedGetter (Field_ k :: Optic '[] s a)+         , PrimTy a, PrimTy s+         , KnownOptic (Field_ k :: Optic '[] s a)+         , r ~ Code a+         )+      => ReifiedGetter (Field_ k :: Optic empty (Code s) r)+      where+  view = fromAST+       $ View+            sLength+            ( opticSing @(Field_ k :: Optic '[] s a) )+instance ( KnownSymbol k+         , empty ~ '[]+         , Settable (Field_ k :: Optic '[] s a)+         , r ~ Code a+         )+      => Settable (Field_ k :: Optic empty (Code s) r)+      where+instance ( KnownSymbol k+         , empty ~ '[]+         , Settable (Field_ k :: Optic '[] s a)+         , ReifiedSetter (Field_ k :: Optic '[] s a)+         , PrimTy s, PrimTy a+         , KnownOptic (Field_ k :: Optic '[] s a)+         , r ~ Code a+         )+      => ReifiedSetter (Field_ k :: Optic empty (Code s) r)+      where+  set = fromAST+       $ Set+            sLength+            ( opticSing @(Field_ k :: Optic '[] s a) )++-- *** Run-time index++instance ( Integral ty, IntegralTy ty+         , ix' ~ '[ Code ty ]+         , r ~ Code a+         , ValidAnIndexOptic '[ty] s a+         , PrimTy s, PrimTy a+         )+       => KnownASTOptic (RTOptic_ :: Optic ix' (Code s) r) (RTOptic_ :: Optic '[ty] s a)+       where+instance ( Integral ty+         , ix ~ '[Code ty]+         , Gettable (RTOptic_ :: Optic '[ty] s a)+         , r ~ Code a+         )+      => Gettable (RTOptic_ :: Optic ix (Code s) r)+      where+instance ( Integral ty, IntegralTy ty+         , ix ~ '[Code ty]+         , Gettable (RTOptic_ :: Optic '[ty] s a)+         , ReifiedGetter (RTOptic_ :: Optic '[ty] s a)+         , PrimTy a, PrimTy s+         , KnownOptic (RTOptic_ :: Optic '[ty] s a)+         , r ~ Code a+         )+      => ReifiedGetter (RTOptic_ :: Optic ix (Code s) r)+      where+  view = fromAST+       $ View+            sLength+            ( opticSing @(RTOptic_ :: Optic '[ty] s a) )+instance ( Integral ty+         , ix ~ '[Code ty]+         , Settable (RTOptic_ :: Optic '[ty] s a)+         , r ~ Code a+         )+      => Settable (RTOptic_ :: Optic ix (Code s) r)+      where+instance ( Integral ty, IntegralTy ty+         , ix ~ '[Code ty]+         , Settable (RTOptic_ :: Optic '[ty] s a)+         , ReifiedSetter (RTOptic_ :: Optic '[ty] s a)+         , PrimTy s, PrimTy a+         , KnownOptic (RTOptic_ :: Optic '[ty] s a)+         , r ~ Code a+         )+      => ReifiedSetter (RTOptic_ :: Optic ix (Code s) r)+      where+  set = fromAST+       $ Set+            sLength+            ( opticSing @(RTOptic_ :: Optic '[ty] s a) )++-- *** Compile-time index++instance ( empty ~ '[]+         , KnownNat i+         , r ~ Code a+         , KnownOptic (Field_ i :: Optic empty s a)+         )+       => KnownASTOptic (Field_ i :: Optic empty (Code s) r) (Field_ i :: Optic '[] s a)+       where+instance ( KnownNat i+         , empty ~ '[]+         , Gettable (Field_ i :: Optic '[] s a)+         , r ~ Code a+         )+      => Gettable (Field_ i :: Optic empty (Code s) r)+      where+instance ( KnownNat i+         , empty ~ '[]+         , Gettable (Field_ i :: Optic '[] s a)+         , ReifiedGetter (Field_ i :: Optic '[] s a)+         , PrimTy a, PrimTy s+         , KnownOptic (Field_ i :: Optic '[] s a)+         , r ~ Code a+         )+      => ReifiedGetter (Field_ i :: Optic empty (Code s) r)+      where+  view = fromAST+       $ View+            sLength+            ( opticSing @(Field_ i :: Optic '[] s a) )+instance ( KnownNat i+         , empty ~ '[]+         , Settable (Field_ i :: Optic '[] s a)+         , r ~ Code a+         )+      => Settable (Field_ i :: Optic empty (Code s) r)+      where+instance ( KnownNat i+         , empty ~ '[]+         , Settable (Field_ i :: Optic '[] s a)+         , ReifiedSetter (Field_ i :: Optic '[] s a)+         , PrimTy s, PrimTy a+         , KnownOptic (Field_ i :: Optic '[] s a)+         , r ~ Code a+         )+      => ReifiedSetter (Field_ i :: Optic empty (Code s) r)+      where+  set = fromAST+       $ Set+            sLength+            ( opticSing @(Field_ i :: Optic '[] s a) )+++-- ** Composite instances++-- *** Containers+--+-- $containers+-- Container instances, for product optics.++instance Container (Code (V n a)) where+  type FieldIndexFromName (Code (V n a)) k+    = TypeError (    Text "optic: attempt to index a vector component with name " :<>: ShowType k+                :$$: Text "Maybe you intended to use a swizzle?"+                )+instance KnownNat m => Container (Code (M m n a)) where+instance Container (Code (Struct (as :: [Symbol :-> Type]))) where+  type FieldIndexFromName (Code (Struct (as :: [Symbol :-> Type]))) k+    = Key (StructIndexFromName k as)+instance Container (Code (Array n a)) where+instance Container (Code (RuntimeArray a)) where++-- *** Optic focusing on parts with a given type+--+-- $oftype+-- Setter instances for 'OfType' optic.++instance ( empty ~ '[]+         , r ~ Code ty+         , KnownOptic (OfType_ ty :: Optic '[] s ty)+         )+       => KnownASTOptic+            (OfType_ (Code ty) :: Optic empty (Code s) r )+            (OfType_      ty  :: Optic '[]        s  ty)+       where+instance {-# OVERLAPPING #-}+         ( empty ~ '[]+         , r ~ Code ty+         , Settable (OfType_ ty :: Optic '[] s ty)+         )+      => Settable (OfType_ (Code ty) :: Optic empty (Code s) r)+      where+instance {-# OVERLAPPING #-}+         ( empty ~ '[]+         , r ~ Code ty+         , Settable   (OfType_ ty :: Optic '[] s ty)+         , KnownOptic (OfType_ ty :: Optic '[] s ty)+         , PrimTy s+         , PrimTy ty+         )+      => ReifiedSetter (OfType_ (Code ty) :: Optic empty (Code s) r)+      where+  set = fromAST+       $ Set+            sLength+            ( opticSing @(OfType_ ty :: Optic '[] s ty) )++-- *** Compound instance resolution++-- **** Composites++instance {-# OVERLAPPING #-}+         forall is js ks s x y+                (o1 :: Optic is (Code s) x) (o2 :: Optic js x y)+                is' js' ks' a b+                (o1' :: Optic is' s a) (o2' :: Optic js' a b)+                .+         ( KnownASTOptic o1 o1'+         , KnownASTOptic o2 o2'+         , ks  ~ ( is  :++: js  )+         , ks' ~ ( is' :++: js' )+         , KnownLength ks'+         , x ~ Code a+         , y ~ Code b+         )+         => KnownASTOptic+             ( (o1  `ComposeO` o2 ) :: Optic ks (Code s) y )+             ( (o1' `ComposeO` o2') :: Optic ks'     s  b )+         where+instance {-# OVERLAPPING #-}+         forall is js ks s x y+                (o1 :: Optic is (Code s) x) (o2 :: Optic js x y)+                is' js' ks' a b+                (o1' :: Optic is' s a) (o2' :: Optic js' a b)+                .+         ( Gettable o1+         , Gettable o2+         , ReifiedGetter ( ( o1' `ComposeO` o2' ) :: Optic ks' s b )+         , KnownASTOptic o1 o1'+         , KnownASTOptic o2 o2'+         , ks  ~ ( is  :++: js  )+         , ks' ~ ( is' :++: js' )+         , KnownLength ks'+         , x ~ Code a+         , y ~ Code b+         , Syntactic (ListVariadic (ks `Postpend` Code s) y)+         , Internal (ListVariadic (ks `Postpend` Code s) y)+            ~ AugListVariadic (ks' `Snoc` s) b+         )+         => ReifiedGetter ( (o1 `ComposeO` o2) :: Optic ks (Code s) y )+         where+  view = fromAST+       $ View sLength ( opticSing @o1' %:.: opticSing @o2' )+instance {-# OVERLAPPING #-}+         forall is js ks s x y+                (o1 :: Optic is (Code s) x) (o2 :: Optic js x y)+                is' js' ks' a b+                (o1' :: Optic is' s a) (o2' :: Optic js' a b)+                .+         ( Settable o1+         , Settable o2+         , ReifiedSetter ( ( o1' `ComposeO` o2' ) :: Optic ks' s b )+         , KnownASTOptic o1 o1'+         , KnownASTOptic o2 o2'+         , ks  ~ ( is  :++: js  )+         , ks' ~ ( is' :++: js' )+         , KnownLength ks'+         , x ~ Code a+         , y ~ Code b+         , Syntactic (ListVariadic (ks `Postpend` y `Postpend` Code s) (Code s))+         , Internal (ListVariadic (ks `Postpend` y `Postpend` Code s) (Code s))+            ~ AugListVariadic (ks' `Snoc` b `Snoc` s) s+         )+         => ReifiedSetter ( (o1 `ComposeO` o2) :: Optic ks (Code s) y )+         where+  set = fromAST+      $ Set sLength ( opticSing @o1' %:.: opticSing @o2' )++-- **** Products+type family MapAST (as :: [Type]) = (r :: [Type]) | r -> as where+  MapAST '[] = '[]+  MapAST (a ': as) = Code a ': MapAST as++type family MapMapAST (iss :: [[Type]]) = (r :: [[Type]]) | r -> iss where+  MapMapAST '[] = '[]+  MapMapAST (is ': iss) = MapAST is ': MapMapAST iss++instance forall+            ( s    ::   Type   )+            ( p    ::   Type   )+            ( p'   ::   Type   )+            ( iss  :: [[Type]] )+            ( iss' :: [[Type]] )+            ( js   ::  [Type]  )+            ( js'  ::  [Type]  )+            ( as   ::  [Type]  )+            ( as'  ::  [Type]  )+            ( os   :: ProductComponents iss       s  as  )+            ( os'  :: ProductComponents iss' (Code s) as' )+          . ( KnownASTOpticComponents os' os+            , KnownComponents os+            , KnownLength js+            , KnownOptic (Prod_ os :: Optic js s p)+            , SameLength (Distribute iss  as ) as+            , SameLength (Distribute iss' as') as'+            , IsProduct p as+            , p' ~ Code p+            , as' ~ MapAST as+            , AreProducts js iss as+            , js ~ MapHList iss+            , js' ~ MapAST js+            , PrimTy p+            )+          => KnownASTOptic+                ( Prod_ os' :: Optic js' (Code s) p' )+                ( Prod_ os  :: Optic js       s  p  )+          where+instance  {-# OVERLAPPING #-}+          forall+            ( s    ::   Type   )+            ( p    ::   Type   )+            ( p'   ::   Type   )+            ( iss  :: [[Type]] )+            ( iss' :: [[Type]] )+            ( js   ::  [Type]  )+            ( js'  ::  [Type]  )+            ( as   ::  [Type]  )+            ( as'  ::  [Type]  )+            ( os   :: ProductComponents iss       s  as  )+            ( os'  :: ProductComponents iss' (Code s) as' )+          . ( ComponentsGettable os+            , KnownASTOpticComponents os' os+            , KnownComponents os+            , KnownOptic (Prod_ os :: Optic js s p)+            , SameLength (Distribute iss  as ) as+            , SameLength (Distribute iss' as') as'+            , IsProduct p as+            , p' ~ Code p+            , as' ~ MapAST as+            , js' ~ MapAST js+            , AreProducts js iss as+            , js ~ MapHList iss+            , KnownLength js+            , PrimTy p+            , Syntactic (ListVariadic (js' `Postpend` Code s) p')+            , Internal (ListVariadic (js' `Postpend` Code s) p')+                ~ AugListVariadic (js `Snoc` s) p+            )+          => Gettable (Prod_ os' :: Optic js' (Code s) p') where+instance  {-# OVERLAPPING #-}+          forall+            ( s    ::   Type   )+            ( p    ::   Type   )+            ( p'   ::   Type   )+            ( iss  :: [[Type]] )+            ( iss' :: [[Type]] )+            ( js   ::  [Type]  )+            ( js'  ::  [Type]  )+            ( as   ::  [Type]  )+            ( as'  ::  [Type]  )+            ( os   :: ProductComponents iss       s  as  )+            ( os'  :: ProductComponents iss' (Code s) as' )+          . ( ComponentsGettable os+            , KnownASTOpticComponents os' os+            , KnownComponents os+            , KnownOptic (Prod_ os :: Optic js s p)+            , ReifiedGetter (Prod_ os :: Optic js s p)+            , SameLength (Distribute iss  as ) as+            , SameLength (Distribute iss' as') as'+            , IsProduct p as+            , p' ~ Code p+            , as' ~ MapAST as+            , js' ~ MapAST js+            , AreProducts js iss as+            , js ~ MapHList iss+            , KnownLength js+            , PrimTy p+            , Syntactic (ListVariadic (js' `Postpend` Code s) p')+            , Internal (ListVariadic (js' `Postpend` Code s) p')+                ~ AugListVariadic (js `Snoc` s) p+            )+          => ReifiedGetter (Prod_ os' :: Optic js' (Code s) p') where+  view = fromAST+       $ View sLength ( opticSing @(Prod_ os :: Optic js s p) )++instance  {-# OVERLAPPING #-}+          forall+            ( s    ::   Type   )+            ( p    ::   Type   )+            ( p'   ::   Type   )+            ( iss  :: [[Type]] )+            ( iss' :: [[Type]] )+            ( js   ::  [Type]  )+            ( js'  ::  [Type]  )+            ( as   ::  [Type]  )+            ( as'  ::  [Type]  )+            ( os   :: ProductComponents iss       s  as  )+            ( os'  :: ProductComponents iss' (Code s) as' )+          . ( ComponentsSettable os+            , ArePairwiseDisjoint os+            , KnownASTOpticComponents os' os+            , KnownComponents os+            , KnownOptic (Prod_ os :: Optic js s p)+            , SameLength (Distribute iss  as ) as+            , SameLength (Distribute iss' as') as'+            , IsProduct p as+            , p' ~ Code p+            , as' ~ MapAST as+            , js' ~ MapAST js+            , AreProducts js iss as+            , js ~ MapHList iss+            , KnownLength js+            , PrimTy p+            , Syntactic (ListVariadic (js' `Postpend` p' `Postpend` Code s) (Code s))+            , Internal (ListVariadic (js' `Postpend` p' `Postpend` Code s) (Code s))+              ~ AugListVariadic (js `Snoc` p `Snoc` s) s+            )+          => Settable (Prod_ os' :: Optic js' (Code s) p') where+instance  {-# OVERLAPPING #-}+          forall+            ( s    ::   Type   )+            ( p    ::   Type   )+            ( p'   ::   Type   )+            ( iss  :: [[Type]] )+            ( iss' :: [[Type]] )+            ( js   ::  [Type]  )+            ( js'  ::  [Type]  )+            ( as   ::  [Type]  )+            ( as'  ::  [Type]  )+            ( os   :: ProductComponents iss       s  as  )+            ( os'  :: ProductComponents iss' (Code s) as' )+          . ( ComponentsSettable os+            , ArePairwiseDisjoint os+            , KnownASTOpticComponents os' os+            , KnownComponents os+            , KnownOptic (Prod_ os :: Optic js s p)+            , ReifiedSetter (Prod_ os :: Optic js s p)+            , SameLength (Distribute iss  as ) as+            , SameLength (Distribute iss' as') as'+            , IsProduct p as+            , p' ~ Code p+            , as' ~ MapAST as+            , js' ~ MapAST js+            , AreProducts js iss as+            , js ~ MapHList iss+            , KnownLength js+            , PrimTy p+            , Syntactic (ListVariadic (js' `Postpend` p' `Postpend` Code s) (Code s))+            , Internal (ListVariadic (js' `Postpend` p' `Postpend` Code s) (Code s))+              ~ AugListVariadic (js `Snoc` p `Snoc` s) s+            )+          => ReifiedSetter (Prod_ os' :: Optic js' (Code s) p') where+  set = fromAST+      $ Set (sLength @_ @js) ( opticSing @(Prod_ os :: Optic js s p) )++class KnownASTOpticComponents ast_os os | ast_os -> os where+instance  ( iss ~ jss, as ~ '[], bs ~ '[] )+       => KnownASTOpticComponents+            ( EndProd_ :: ProductComponents iss (Code s) as )+            ( EndProd_ :: ProductComponents jss       s  bs )+          where+instance  ( KnownASTOptic o' o+          , KnownASTOpticComponents os' os+          , as' ~ MapAST as+          , iss' ~ MapMapAST iss+          )+        => KnownASTOpticComponents+             ( (o' `ProductO` os') :: ProductComponents iss' (Code s) ( a' ': as' ) )+             ( (o  `ProductO` os ) :: ProductComponents iss        s  ( a  ': as  ) )+        where++-----------------------------------------------+-- * Functor functionality++infixl 4 <$$>+infixl 4 <**>++class ( Typeable f, forall x. ASTApplicativeElt f x => PrimTy (f x) ) => ASTApplicative f where+  type ASTApplicativeElt f (x :: Type) :: Constraint+  pureAST+    :: ( FunRes a ~ Val va, PrimTy va+       , All PrimTyVal (FunArgs a)+       )+    => AST a -> AST (ApplyFAug f a)+  (<**>) :: ( Syntactic fb, Internal fb ~ ApplyFAug f b, PrimTy a )+         => ( AST ( Val (f a) :--> ApplyFAug f b ) ) -> Code (f a) -> fb++(<$$>), fmapAST+  :: forall f a b fb vb+  .  ( ASTApplicative f+     , PrimTy a+     , FunRes (Internal b) ~ Val vb+     , PrimTy vb+     , Syntactic b+     , Syntactic fb+     , Internal fb ~ ApplyFAug f (Internal b)+     , All PrimTyVal (FunArgs (Internal b))+     )+  => ( Code a -> b ) -> ( Code (f a) -> fb )+(<$$>) = fmapAST+fmapAST f fa = fromAST ( pureAST (toAST f) <**> fa )+++instance KnownNat n => ASTApplicative (V n) where+  type ASTApplicativeElt (V n) x = PrimTy x+  pureAST = Pure ( Proxy @(V n) )+  fab <**> fa = fromAST $ Ap ( Proxy @(V n) ) fab fa++instance (KnownNat m, KnownNat n) => ASTApplicative (M m n) where+  type ASTApplicativeElt (M m n) x = ( ScalarTy x, Ring x )+  pureAST = Pure ( Proxy @(M m n) )+  fab <**> fa = fromAST $ Ap ( Proxy @(M m n) ) fab fa++instance KnownNat n => ASTApplicative (Array n) where+  type ASTApplicativeElt (Array n) x = PrimTy x+  pureAST = Pure ( Proxy @(Array n) )+  fab <**> fa = fromAST $ Ap ( Proxy @(Array n) ) fab fa++{-+instance +  TypeError (     Text "The Code datatype does not have a Functor instance:"+             :$$: Text "    cannot map Haskell functions over internal types."+             :$$: Text "To map an internal function over an internal type, use 'fmapAST'/'<$$>'."+            ) => Prelude.Functor AST where+  fmap = error "unreachable"+-}++-----------------------------------------------+-- * Internal functors+--+-- $internalfunctors+-- Instances for vectors, matrices and arrays.++instance KnownNat n => PrimFunc (V n) where+  primFuncSing = SFuncVector @n+  distDict = DistDict+instance ( KnownNat m, KnownNat n ) => PrimFunc (M m n) where+  primFuncSing = SFuncMatrix @m @n+  distDict = DistDict+instance KnownNat n => PrimFunc (Array n) where+  primFuncSing = SFuncArray @n+  distDict = DistDict++-----------------------------------------------+-- * Syntactic instances+--+-- $syntactic+-- Instances for 'Syntactic'.++instance Syntactic () where+  type Internal () = Val ()+  toAST   = const ( Lit () )+  fromAST = const ()++instance ( Syntactic a, Syntactic b+         , Internal a ~ Val va, PrimTy va+         , Internal b ~ Val vb, PrimTy vb+         ) => Syntactic (a,b) where+  type Internal (a,b) =+    Val (Struct+      '[ "_0" ':-> InternalType a+       , "_1" ':-> InternalType b+       ] )+  toAST (a,b) = Struct ( toAST a :& toAST b :& End )+  fromAST struct =+    ( fromAST (view @(Index 0) struct)+    , fromAST (view @(Index 1) struct)+    )++instance ( Syntactic a, Syntactic b, Syntactic c+         , Internal a ~ Val va, PrimTy va+         , Internal b ~ Val vb, PrimTy vb+         , Internal c ~ Val vc, PrimTy vc+         ) => Syntactic (a,b,c) where+  type Internal (a,b,c) =+    Val ( Struct +      '[ "_0" ':-> InternalType a+       , "_1" ':-> InternalType b+       , "_2" ':-> InternalType c+       ] )+  toAST (a,b,c) = Struct ( toAST a :& toAST b :& toAST c :& End )+  fromAST struct =+    ( fromAST (view @(Index 0) struct)+    , fromAST (view @(Index 1) struct)+    , fromAST (view @(Index 2) struct)+    )++instance  ( KnownNat n+          , Syntactic a+          , Internal a ~ Val v+          , PrimTy v+          )+        => Syntactic (V n a)+        where+  type Internal (V n a) = Val (V n (InternalType a))++  toAST :: V n a -> Code (V n (InternalType a))+  toAST = MkVector . Prelude.fmap toAST ++  fromAST :: Code (V n (InternalType a)) -> V n a+  fromAST v = buildV @n builder+    where builder :: forall i. (KnownNat i, CmpNat i n ~ Prelude.LT)+                  => Proxy i -> a+          builder _ = fromAST ( View sLength (opticSing @(Index i)) :$ v )++instance ( KnownNat m, KnownNat n+         , Syntactic a, Internal a ~ Val v, PrimTy v+         )+       => Syntactic (M m n a) where+  type Internal (M m n a) = Val (M m n (InternalType a))+  toAST (M m) = Mat :$ toAST m+  fromAST = M . fromAST . ( UnMat :$ )++instance ( KnownNat n+         , Syntactic a, Internal a ~ Val v, PrimTy v+         )+       => Syntactic (Array n a) where+  type Internal (Array n a) = Val (Array n (InternalType a))+  toAST arr = Array $ Prelude.fmap toAST arr+  fromAST arr = MkArray vec+    where+      vec :: Vector.Vector n a+      vec = Vector.generate ( withFinite ( \ ( _ :: Proxy i ) -> fromAST $ view @(Index i) arr ) )++-----------------------------------------------+-- * Vectors and matrices++-- ** Vectors+--+-- $vectors+-- Instances for:+--+-- 'Semimodule', 'LinearModule', 'Inner', 'Cross'.+instance (ScalarTy a, Semiring a) => Semimodule Nat (Code (V 0 a)) where+  type Scalar   (Code (V 0 a))       = Code      a+  type OfDim    (Code (V 0 a)) Nat n = Code (V n a)+  type ValidDim (Code (V 0 a)) Nat n = KnownNat n++  (^+^) :: forall n. KnownNat n+        => Code (V n a) -> Code (V n a) -> Code (V n a)+  (^+^) = primOp @(V n a) @('Vectorise SPIRV.Add)++  (^*) :: forall n. KnownNat n+       => Code (V n a) -> Code a -> Code (V n a)+  (^*)  = case scalarTySing @a of+    SHalf   -> primOp @(V n a) @SPIRV.VMulK+    SFloat  -> primOp @(V n a) @SPIRV.VMulK+    SDouble -> primOp @(V n a) @SPIRV.VMulK+    -- No "vector times scalar" operation in SPIR-V+    -- for integral scalar types.+    _  -> ( \ vec a -> toAST $ Prelude.fmap ( * a ) ( fromAST vec :: V n ( Code a ) ) )++instance (ScalarTy a, Ring a) => LinearModule Nat (Code (V 0 a)) where+  (^-^) :: forall n. KnownNat n+        => Code (V n a) -> Code (V n a) -> Code (V n a)+  (^-^) = primOp @(V n a) @('Vectorise SPIRV.Sub)++  (-^) :: forall n. KnownNat n => Code (V n a) -> Code (V n a)+  (-^) = primOp @(V n a) @('Vectorise SPIRV.Neg)++instance (ScalarTy a, Floating a) => Inner Nat (Code (V 0 a)) where+  (^.^) :: forall n. KnownNat n+        => Code (V n a) -> Code (V n a) -> Code a+  (^.^) = primOp @(V n a) @SPIRV.DotV++  normalise :: forall n. KnownNat n => Code (V n a) -> Code (V n a)+  normalise = primOp @(V n a) @SPIRV.NormaliseV++instance (ScalarTy a, Floating a) => Cross Nat (Code (V 0 a)) where+  type CrossDim (Code (V 0 a)) Nat n = ( n ~ 3 )++  cross :: Code (V 3 a) -> Code (V 3 a) -> Code (V 3 a)+  cross = primOp @(V 3 a) @SPIRV.CrossV+++-- ** Matrices+--+-- $matrices+-- Instance for 'Matrix'.++type instance VectorOf (Code (M 0 0 a)) = Code (V 0 a)++instance (ScalarTy a, Floating a) => Matrix Nat (Code (M 0 0 a)) where+  type OfDims (Code (M 0 0 a)) Nat '(m,n) = Code (M m n a)++  diag :: forall (n :: Nat). KnownNat n => Code a -> Code (M n n a)+  diag a = toAST (M mat)+    where+      indicator :: (KnownNat i, KnownNat j) => Proxy i -> Proxy j -> Code a+      indicator px1 px2 = case sameNat px1 px2 of+        Just _ -> a+        _      -> zero+      mat :: V n (V n (Code a))+      mat = buildV @n ( \ px1 -> buildV @n ( \ px2 -> indicator px1 px2 ) )++  konst a = Mat :$ pureAST (pureAST a)++  transpose :: forall n m. (KnownNat n, KnownNat m)+            => Code (M n m a) -> Code (M m n a)+  transpose = primOp @'(a,n,m) @SPIRV.Transp++  inverse :: forall n. KnownNat n+          => Code (M n n a) -> Code (M n n a)+  inverse = primOp @'(a,n) @SPIRV.Inv+  +  determinant :: forall n. KnownNat n+              => Code (M n n a) -> Code a+  determinant = primOp @'(a,n) @SPIRV.Det++  -- no built-in matrix addition and subtraction, so we use the vector operations+  (!+!) :: forall i j. (KnownNat i, KnownNat j)+        => Code (M i j a) -> Code (M i j a) -> Code (M i j a)+  x !+! y = Mat :$ ( vecAdd <$$> (UnMat :$ x) <**> (UnMat :$ y) )+    where vecAdd :: Code (V i a) -> Code (V i a) -> Code (V i a)+          vecAdd = primOp @(V i a) @('Vectorise SPIRV.Add)+  (!-!) :: forall i j. (KnownNat i, KnownNat j)+        => Code (M i j a) -> Code (M i j a) -> Code (M i j a)+  x !-! y = Mat :$ ( vecSub <$$> (UnMat :$ x) <**> (UnMat :$ y) )+    where vecSub :: Code (V i a) -> Code (V i a) -> Code (V i a)+          vecSub = primOp @(V i a) @('Vectorise SPIRV.Sub)++  (!*!) :: forall i j k. (KnownNat i, KnownNat j, KnownNat k)+        => Code (M i j a) -> Code (M j k a) -> Code (M i k a)+  (!*!) = primOp @'(a,i,j,k) @SPIRV.MMulM++  (^*!) :: forall i j. (KnownNat i, KnownNat j)+        => Code (V i a) -> Code (M i j a) -> Code (V j a)+  (^*!) = primOp @'(a,i,j) @SPIRV.VMulM++  (!*^) :: forall i j. (KnownNat i, KnownNat j)+        => Code (M i j a) -> Code (V j a) -> Code (V i a)+  (!*^) = primOp @'(a,i,j) @SPIRV.MMulV++  (!*) :: forall i j. (KnownNat i, KnownNat j)+       => Code (M i j a) -> Code a -> Code (M i j a)+  (!*) = primOp @'(a,i,j) @SPIRV.MMulK++instance GradedSemigroup (Code (V 0 a)) Nat where+  type Grade Nat (Code (V 0 a)) n = Code (V n a)+  type n1 :<!>: n2 = n1 + n2+  (<!>) = fromAST GradedMappend
+ src/FIR/Syntax/Complex.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++{-|+Module: FIR.Syntax.Complex++Syntax for manipulating complex numbers.    ++@CodeComplex a@ is a newtype around @Code (V 2 a)@, but with a @ComplexFloat@ instance allowing for complex arithmetic.    ++Complex numbers can be constructed using using @:+:@, e.g. @0 :+: 1@ represents the imaginary unit @i@.++Note that @Floating@ operations such as trigonometric functions are not provided, as these are not supported by @SPIR-V@.+-}+++module FIR.Syntax.Complex+  ( CodeComplex(..), pattern (:+:), complexLog )+  where++-- fir+import Math.Algebra.Class+  ( AdditiveMonoid(..), CancellativeAdditiveMonoid(..), AdditiveGroup(..)+  , Semiring(..), DivisionRing(..)+  , Floating(..), RealFloat(..), ComplexFloat(..)+  )+import Math.Logic.Class+  ( Eq(Logic) )+import Math.Linear+  ( V, (^+^), (^-^), (-^), (*^) )+import FIR.AST+  ( Code, Syntactic(..), SyntacticVal, InternalType )+import FIR.AST.Type+  ( AugType(Val) )+import FIR.Prelude+import FIR.Prim.Types+  ( PrimTy, ScalarTy )+import FIR.Syntax.AST+  ( )+import FIR.Syntax.Synonyms+  ( pattern Vec2 )++----------------------------------------------------------------------------++-- | Newtype around @Code (V 2 a)@, but with typeclass instances+-- for complex arithmetic.+newtype CodeComplex a = CodeComplex { codeComplex :: Code ( V 2 a ) }++instance (ScalarTy a) => Syntactic (CodeComplex a) where+  type Internal (CodeComplex a) = Val ( V 2 a )+  toAST ( CodeComplex vec ) = vec+  fromAST vec = CodeComplex vec++instance (SyntacticVal a, ScalarTy (InternalType a)) => Syntactic (Complex a) where+  type Internal (Complex a) = Val ( V 2 (InternalType a) )+  toAST (x :+ y) = Vec2 ( toAST x ) ( toAST y )+  fromAST (Vec2 x y) = fromAST x :+ fromAST y++{-# COMPLETE (:+:) #-}+pattern (:+:) :: PrimTy a => Code a -> Code a -> CodeComplex a+pattern a :+: b = CodeComplex ( Vec2 a b )++instance ( Semiring a, ScalarTy a ) => AdditiveMonoid (CodeComplex a) where+  (+)           = coerce ( (^+^) :: Code ( V 2 a ) -> Code ( V 2 a ) -> Code ( V 2 a ) )+  zero          = zero :+: zero+  fromInteger a = fromInteger a :+: zero++instance ( Semiring a, CancellativeAdditiveMonoid a, ScalarTy a ) => Semiring (CodeComplex a) where+  ( a1 :+: b1 ) * ( a2 :+: b2 ) = ( a1 * a2 - b1 * b2 ) :+: ( a1 * b2 + b1 * a2 )++instance ( Semiring a, AdditiveGroup a, ScalarTy a ) => CancellativeAdditiveMonoid (CodeComplex a) where+  (-) = coerce ( (^-^) :: Code ( V 2 a ) -> Code ( V 2 a ) -> Code ( V 2 a ) )++instance ( Semiring a, AdditiveGroup a, ScalarTy a ) => AdditiveGroup (CodeComplex a) where+  negate = coerce ( (-^) :: Code ( V 2 a ) -> Code ( V 2 a ) )++instance ( RealFloat a, ScalarTy a, Logic a ~ Bool ) => DivisionRing (CodeComplex a) where+  z1 / ( z2@( a2 :+: b2 ) ) = scale ( recip $ sqMag_z2 ) ( z1 * conjugate z2 )+    where+      sqMag_z2 :: Code a+      sqMag_z2 = a2 * a2 + b2 * b2+  fromRational r = fromRational r :+: zero++instance ( b ~ Code a, ScalarTy a, RealFloat a, Logic a ~ Bool ) => ComplexFloat (CodeComplex a) b where+  conjugate ( a :+: b ) = a :+: negate b+  magnitude ( a :+: b ) = sqrt ( a * a + b * b )+  squaredMagnitude ( a :+: b ) = a * a + b * b+  phase     ( a :+: b ) = atan2 b a+  mkCartesian a b       = a :+: b+  mkPolar r theta       = scale r $ cis theta+  cis theta             = cos theta :+: sin theta+  scale r               = coerce ( ( r *^ ) :: Code ( V 2 a ) -> Code ( V 2 a ) )+  realPart  ( a :+: _ ) = a+  imagPart  ( _ :+: b ) = b++complexLog :: ( ScalarTy a, RealFloat a, Logic a ~ Bool ) => CodeComplex a -> CodeComplex a+complexLog z = log ( magnitude z ) :+: phase z
+ src/FIR/Syntax/DebugPrintf.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE DataKinds               #-}+{-# LANGUAGE DerivingStrategies      #-}+{-# LANGUAGE FlexibleContexts        #-}+{-# LANGUAGE FlexibleInstances       #-}+{-# LANGUAGE FunctionalDependencies  #-}+{-# LANGUAGE MagicHash               #-}+{-# LANGUAGE OverloadedStrings       #-}+{-# LANGUAGE PatternSynonyms         #-}+{-# LANGUAGE PolyKinds               #-}+{-# LANGUAGE ScopedTypeVariables     #-}+{-# LANGUAGE TypeFamilyDependencies  #-}+{-# LANGUAGE TypeOperators           #-}+{-# LANGUAGE UndecidableInstances    #-}+{-# LANGUAGE UndecidableSuperClasses #-}++{-|+Module: FIR.Syntax.DebugPrintf+Description: @---@ Printf-like formatting functionality (for shader debugging).+-}++module FIR.Syntax.DebugPrintf+  ( Format, Formatter+  , debugPrintf+  , (%)+  , int32, word32, word32Hex+  , float, scientific+  , vec+  )+  where++-- base+import Data.Int+  ( Int32 )+import Data.Kind+  ( Type )+import Data.Word+  ( Word32 )+import Data.String+  ( IsString(..) )+import GHC.Exts+  ( proxy#, Proxy# )+import GHC.TypeNats+  ( Nat, KnownNat+  , type (<=)+  , natVal'+  )++-- text-short+import Data.Text.Short+  ( ShortText )+import qualified Data.Text.Short as ShortText+  ( pack )++-- fir+import Data.Constraint.All+  ( All )+import Data.Type.List+  ( type (:++:) )+import FIR.AST+  ( Code, Syntactic(..)+  , PrintfAugType, pattern DebugPrintf+  )+import FIR.AST.Type+  ( FunArgs, Nullary )+import FIR.Module+  ( Program )+import FIR.ProgramState+  ( ProgramState )+import Math.Linear+  ( V )++----------------------------------------------------------------------------++-- | A printf format, taking parameters of the given types.+data Format ( as :: [ Type ] ) =+  UnsafeFormatFromFormatString { formatString :: !ShortText }+  deriving stock ( Eq, Show )++-- | Print to debug output using a printf-style formatter.+--+-- Need to pass the 'Debug' compiler flag (otherwise this instruction will be ignored).+--+-- /Usage/: say we want to print the following values:+--  +--   > x :: Code Float+--   > y :: Code Int32+--   > z :: Code (V 2 Float)+--+--  We can do this using the command:+--   > debugPrintf ( "x = " % float % " y = " % int32 % " z = " % vec @2 float ) x y z+--+-- '(%)' denotes composition of formatters.+--+-- /Note/: Enabling the OverloadedStrings extension is necessary.+--+-- To see this output, enable the following layers (off by default):+--+--   > VK_LAYER_PRINTF_ENABLE=1 VK_LAYER_PRINTF_TO_STDOUT=1 \+--   > VK_LAYER_PRINTF_ONLY_PRESET=1 VK_LAYER_PRINTF_BUFFER_SIZE=1048576 <my_exe>+debugPrintf+  :: forall+      ( as :: [Type ]      )+      ( i  :: ProgramState )+  .  ( Syntactic ( ProgPrintf i as )+     , Internal  ( ProgPrintf i as ) ~ PrintfAugType i as+     , All Nullary ( FunArgs ( PrintfAugType i as ) )+     )+  => Format as -> ProgPrintf i as+debugPrintf fmt = fromAST ( DebugPrintf ( formatString fmt ) )++type family ProgPrintf ( i :: ProgramState ) ( as :: [ Type ] ) = ( r :: Type ) | r -> i as where+  ProgPrintf i '[]         = Program i i ( Code () )+  ProgPrintf i ( a ': as ) = Code a -> ProgPrintf i as+++instance ( as ~ '[] ) => IsString ( Format as ) where+  fromString+    = UnsafeFormatFromFormatString +    . fromString+    . escapePercents++escapePercents :: [Char] -> [Char]+escapePercents [] = []+escapePercents ( '%' : as ) = '%' : '%' : escapePercents as+escapePercents (  c  : as ) =         c : escapePercents as++infixr 9 %+-- | Concatenate two formatters.+--+-- See 'debugPrintf' for example usage.+(%) :: Format as -> Format bs -> Format ( as :++: bs )+( UnsafeFormatFromFormatString a ) % ( UnsafeFormatFromFormatString b ) =+  UnsafeFormatFromFormatString ( a <> b )++-- | A class for types which can be formatted.+class Formattable ( a :: Type ) where+  data Formatter a :: Type+  formatterString :: Formatter a -> ShortText++instance Formattable Int32 where+  data Formatter Int32+    = FormatInt32+  formatterString _ = "i"++instance Formattable Word32 where+  data Formatter Word32+    = FormatWord32+    | FormatWord32Hex+  formatterString FormatWord32    = "u"+  formatterString FormatWord32Hex = "X"++instance Formattable Float where+  data Formatter Float+    = FormatFloatDigits+    | FormatFloatScientific+    | FormatFloatGeneric+  formatterString FormatFloatDigits     = "f"+  formatterString FormatFloatScientific = "e"+  formatterString FormatFloatGeneric    = "g"++instance ( KnownNat n, 2 <= n, n <= 4, Formattable a ) => Formattable ( V n a ) where+  data Formatter ( V n a )+    = FormatVec ( Formatter a )+  formatterString ( FormatVec fmt ) = "v" <> n <> formatterString fmt+    where+      n :: ShortText+      n = ShortText.pack . show $ natVal' ( proxy# :: Proxy# n )++mkFormatter :: Formattable a => Formatter a -> Format '[ a ]+mkFormatter fmt = UnsafeFormatFromFormatString ( "%" <> formatterString fmt )++class Int32Formatter r where+  int32 :: r+instance ( as ~ '[ Int32 ] ) => Int32Formatter ( Format as ) where+  int32 = mkFormatter FormatInt32+instance ( a ~ Int32 ) => Int32Formatter ( Formatter a ) where+  int32 = FormatInt32++class Word32Formatter r where+  word32    :: r+  word32Hex :: r+instance ( as ~ '[ Word32 ] ) => Word32Formatter ( Format as ) where+  word32    = mkFormatter FormatWord32+  word32Hex = mkFormatter FormatWord32Hex+instance ( a ~ Word32 ) => Word32Formatter ( Formatter a ) where+  word32    = FormatWord32+  word32Hex = FormatWord32Hex++class FloatFormatter r where+  float      :: r+  scientific :: r+instance ( as ~ '[ Float ] ) => FloatFormatter ( Format as ) where+  float      = mkFormatter FormatFloatDigits+  scientific = mkFormatter FormatFloatScientific+instance ( a ~ Float ) => FloatFormatter ( Formatter a ) where+  float      = FormatFloatDigits+  scientific = FormatFloatScientific++class ( KnownNat n, 2 <= n, n <= 4, Formattable a ) => VecFormatter (n :: Nat) a r | r -> n a where+  vec :: Formatter a -> r+instance ( KnownNat n, 2 <= n, n <= 4, Formattable a, as ~ '[ V n a ] )+      => VecFormatter n a ( Format as ) where+  vec fmt = mkFormatter ( FormatVec fmt )+instance ( KnownNat n, 2 <= n, n <= 4, Formattable a, v ~ V n a )+      => VecFormatter n a ( Formatter v ) where+  vec fmt = FormatVec fmt
+ src/FIR/Syntax/IfThenElse.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE LiberalTypeSynonyms   #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++{-|+Module: FIR.Syntax.IfThenElse++This module defines instances used to provide rebindable if-then-else statements.+-}++module FIR.Syntax.IfThenElse+  ( when, unless )+  where++-- base+import Data.Kind+  ( Type )++-- fir+import Control.Monad.Indexed+  ( (:=), ixPure )+import FIR.AST+  ( Code+  , Syntactic(toAST, fromAST)+  , SyntacticVal, InternalType+  , pattern (:$), pattern Lit+  , pattern If, pattern IfM+  , pattern Return+  )+import FIR.Module+  ( Program )+import FIR.Prim.Types+  ( PrimTy )+import FIR.Syntax.AST+  ( )+import FIR.Syntax.Program+  ( )+import Math.Logic.Class+  ( Choose(choose), Choosing )++--------------------------------------------------------------------------------------++when :: forall i. Code Bool -> Program i i (Code ()) -> Program i i (Code ())+when b action+  = choose b+      ( action )+      ( ixPure (Lit ()) :: Program i i (Code ()) )++unless :: forall i. Code Bool -> Program i i (Code ()) -> Program i i (Code ())+unless b action+  = choose b+      ( ixPure (Lit ()) :: Program i i (Code ()) )+      ( action )++--------------------------------------------------------------------------------------+-- | The 'Choose' instances provide syntax for rebindable 'ifThenElse'.+--+-- We uses a helper type class 'Chooser' in an attempt to improve type inference.+instance {-# OVERLAPPABLE #-}+         ( b ~ Bool+         , Syntactic z+         , Chooser x y z (WhichChoice (InternalType z))+         )+       => Choose (Code b) '(x, y, z) where+  choose = chosen @x @y @z @(WhichChoice (InternalType z))+instance ( b ~ Code Bool+         , j ~ i, k ~ i, l ~ i+         , SyntacticVal z+         , x ~ Program i j1 z+         , y ~ Program i j2 z+         )+       => Choose (Program k l b) '(x, y, Program i j z) where+  choose c t f = fromAST ( IfM :$ toAST c :$ toAST t :$ toAST f )+instance ( b ~ Bool+         , j ~ i+         , SyntacticVal z+         , x ~ Program i j1 z+         , y ~ Program i j2 z+         )+       => Choose (Code b) '(x, y, Program i j z) where+  choose c t f = fromAST ( IfM :$ ( Return :$ c ) :$ toAST t :$ toAST f )+instance {-# INCOHERENT #-}+         ( b ~ Program i i (Code Bool)+         , j ~ i+         , SyntacticVal z+         , x ~ Program i j1 z+         , y ~ Program i j2 z+         )+       => Choose b '(x, y, Program i j z) where+  choose c t f = fromAST ( IfM :$ toAST c :$ toAST t :$ toAST f )+++data Choice = PureChoice | ImpureChoice+class Chooser x y z (choice :: Choice) where+  chosen :: Choosing (Code Bool) '(x,y,z)+instance ( SyntacticVal z+         , PrimTy (InternalType z)+         , x ~ z, y ~ z+         )+       => Chooser x y z PureChoice where+  chosen = fromAST ( If @(InternalType z) )+instance ( x ~ Program i j1 x'+         , y ~ Program i j2 y'+         , z ~ Program i i  z'+         , SyntacticVal z'+         , PrimTy (InternalType z')+         , x' ~ z'+         , y' ~ z'+         )+      => Chooser x y z ImpureChoice where+  chosen c t f = fromAST ( IfM :$ ( Return :$ c ) :$ toAST t :$ toAST f )++type family WhichChoice (z :: Type) :: Choice where+  WhichChoice ( (_ := _) _ )+    = ImpureChoice+  WhichChoice _+    = PureChoice
+ src/FIR/Syntax/Images.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PatternSynonyms        #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: FIR.Syntax.Images ++This module allows for the operations 'FIR.Syntax.Program.use'+and 'FIR.Syntax.Program.assign' to work with images, by providing the 'ImageTexel' lens.++This allows accessing image data in a shader like so:++@ use \@(ImageTexel "imageName") imageOperands coords @++provided that @"imageName"@ binds an image in the monadic context.++@coords@ are the coordinates at which to access the image.+The specific type of these coordinates depends on:++  * whether we are sampling or reading directly,+  * the image dimensionality,+  * whether the image is arrayed,+  * the type of coordinates being used (affine or projective).++The return type of this operation depends on:++  * the image format (for instance a normalised integer image format+    will return floating-point types),+  * whether a depth-comparison is being performed: the return type+    will be a scalar in that case, and otherwise a vector with 4 components.+++These properties are specified either at the type level,+with a top-level type annotation declaring the image properties,+or by the 'FIR.Prim.Image.ImageOperands' @imageOperands@ (optional+unless a depth-comparison value is required, but can be used+e.g. to set an explicit level of detail).++++As images in @SPIR-V@ form an opaque type, the corresponding+'FIR.Prim.Image.Image' data type used by this library is+uninhabited, meaning it is impossible to construct or obtain+a value of this type. Instead, 'FIR.Prim.Image.Image'+is used only indirectly.+Attempting to directly obtain an 'FIR.Prim.Image.Image'+results in an error:++> img <- use @(Name "imgName")+>+>   • Variable named "imgName" refers to an image.+>     To access image data, use the 'ImageTexel' optic or the 'imageRead' function.+++-}++module FIR.Syntax.Images+  ( -- * Lens focusing on an image texel+    ImageTexel++  -- * Image query operations+  , imageSizeLOD, imageSize, imageLOD, imageLevels, imageSamples++  )+where++-- base+import Prelude+  hiding ( Floating, Integral )+import Data.Kind+  ( Type )+import Data.Proxy+  ( Proxy(..) )+import Data.Word+  ( Word32 )+import GHC.TypeLits+  ( Symbol, KnownSymbol )++-- fir+import Control.Type.Optic+  ( Optic(Field_, RTOptic_, ComposeO)+  , Gettable, Settable+  )+import Data.Type.Known+  ( Known )+import FIR.AST+  ( Code, Syntactic(fromAST)+  , pattern QuerySize, pattern QuerySizeLOD+  , pattern QueryLOD, pattern QueryLevels, pattern QuerySamples+  )+import FIR.Module+  ( Program )+import FIR.Prim.Image+  ( ImageProperties+  , Image+  , OperandName, ImageOperands+  )+import FIR.Prim.Types+  ( PrimTy )+import FIR.ProgramState+  ( ProgramState )+import FIR.Validation.Images+  ( LookupImageProperties+  , ValidImageRead, ValidImageWrite+  , ImageTexelType+  , ValidQueryImageSize, ValidQueryImageSizeLOD+  , ValidQueryImageLOD, ValidQueryImageLevels, ValidQueryImageSamples+  )++-----------------------------------------------------------------------++-- | Lens for focusing on texels of an image.+--+-- This is a /phantom/ composite @ Name k :.: Texel @,+-- where @Texel@ denotes a (hypothetical) run-time optic+-- which focuses on the texel at a given coordinate (with specified image operands).+--+-- As it is impossible to obtain actual values of type 'FIR.Prim.Image.Image',+-- it is only the composite optic @ImageTexel k@, understood atomically,+-- which allows focusing on image texels.+type family ImageTexel+              ( k :: Symbol )+            = ( optic+                :: Optic+                    '[ ImageOperands props ops, imgCds ]+                    ( i :: ProgramState )+                    ( ImageTexelType props ops )+              )+            | optic -> k+            where+  forall i props ops imgCds k.+    ImageTexel k+      = ( ( ( Field_ (k :: Symbol) :: Optic '[] i (Image props) )+            `ComposeO`+            ( RTOptic_+                :: Optic+                    '[ ImageOperands props ops, imgCds ]+                    ( Image props )+                    ( ImageTexelType props ops )+            )+          ) :: Optic+                '[ ImageOperands props ops, imgCds ]+                i+                (ImageTexelType props ops)+        )++----------------------------------------------------+-- instances for this particular 'ghost' composite+-- (leverages that normal runtime optics only ever have 1 run-time index, this has 2)++instance {-# OVERLAPPING #-} +         forall +           ( k        :: Symbol          )+           ( i        :: ProgramState    )+           ( props    :: ImageProperties )+           ( ops      :: [OperandName]   )+           ( empty    :: [Type]          )+           ( imgOps   :: Type            )+           ( imgCds   :: Type            )+           ( imgTexel :: Type            )+         .+         ( KnownSymbol k+         , LookupImageProperties k i ~ props+         , Known ImageProperties props+         , ValidImageRead props ops imgCds+         , empty ~ '[]+         , imgOps ~ ImageOperands props ops+         , imgTexel ~ ImageTexelType props ops+         )+      => Gettable ( ( ( Field_ k :: Optic empty i (Image props))+                    `ComposeO`+                      ( RTOptic_ :: Optic '[imgOps, imgCds] (Image props) imgTexel )+                    ) :: Optic '[imgOps, imgCds] i imgTexel+                  )+      where++instance {-# OVERLAPPING #-} +         forall +           ( k        :: Symbol          )+           ( i        :: ProgramState    )+           ( props    :: ImageProperties )+           ( ops      :: [OperandName]   )+           ( empty    :: [Type]          )+           ( imgOps   :: Type            )+           ( imgCds   :: Type            )+           ( imgTexel :: Type            )+         .+         ( KnownSymbol k+         , LookupImageProperties k i ~ props+         , Known ImageProperties props+         , ValidImageWrite props ops imgCds+         , empty ~ '[]+         , imgOps ~ ImageOperands props ops+         , imgTexel ~ ImageTexelType props ops+         )+      => Settable ( ( ( Field_ k :: Optic empty i (Image props))+                    `ComposeO`+                      ( RTOptic_ :: Optic '[imgOps, imgCds] (Image props) imgTexel )+                    ) :: Optic '[imgOps, imgCds] i imgTexel+                  )+      where++-----------------------------------------------------------------------+-- Image query operations.++-- | Query the size of the named image, at a given level-of-detail.+imageSizeLOD+  :: forall+      ( imgName :: Symbol )+      ( res     :: Type   )+      ( i       :: ProgramState )+  . ( KnownSymbol imgName+    , PrimTy res+    , ValidQueryImageSizeLOD imgName i res+    )+  => Code Word32 -- ^ Image level-of-detail to use for the query.+  -> Program i i ( Code res )+imageSizeLOD = fromAST ( QuerySizeLOD ( Proxy @imgName ) ( Proxy @res ) )++-- | Query the size of the named image.+imageSize+  :: forall+      ( imgName :: Symbol )+      ( res     :: Type   )+      ( i       :: ProgramState )+  . ( KnownSymbol imgName+    , PrimTy res+    , ValidQueryImageSize imgName i res+    )+  => Program i i ( Code res )+imageSize = fromAST ( QuerySize ( Proxy @imgName ) ( Proxy @res ) )++-- | Query the level of detail of the named image at the given coordinates.+imageLOD+  :: forall+      ( imgName :: Symbol )+      ( coords  :: Type   )+      ( res     :: Type   )+      ( i       :: ProgramState )+  . ( KnownSymbol imgName+    , PrimTy res+    , ValidQueryImageLOD imgName i coords res+    )+  => Code coords+  -> Program i i ( Code res )+imageLOD = fromAST ( QueryLOD ( Proxy @imgName ) ( Proxy @res ) )++-- | Query how many levels of detail the named image has.+imageLevels+  :: forall+      ( imgName :: Symbol )+      ( res     :: Type   )+      ( i       :: ProgramState )+  . ( KnownSymbol imgName+    , PrimTy res+    , ValidQueryImageLevels imgName i res+    )+  => Program i i ( Code res )+imageLevels = fromAST ( QueryLevels ( Proxy @imgName ) ( Proxy @res ) )++-- | Query how many samples the named multi-sampling image has.+imageSamples+  :: forall+      ( imgName :: Symbol )+      ( res     :: Type   )+      ( i       :: ProgramState )+  . ( KnownSymbol imgName+    , PrimTy res+    , ValidQueryImageSamples imgName i res+    )+  => Program i i ( Code res )+imageSamples = fromAST ( QuerySamples ( Proxy @imgName ) ( Proxy @res ) )
+ src/FIR/Syntax/Labels.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: FIR.Syntax.Labels+Description: @---@ __Optional__ /imperative-style/ syntax using overloaded labels.++Imperative-like syntax for variable assignment using overloaded labels. /Completely optional./++To use this functionality, import this module, activating /OverloadedLabels/ and /RebindableSyntax/.+You'll most likely want to use /TypeApplications/ too.++Usages of label syntax, such as @#foo@, will be desugared+using the 'fromLabel' method of the 'IsLabel' class in this module.++This allows for notation such as:++> do+>   #x #= (1 :: Float)  -- defines a new variable named 'x', initialised with value (1 :: Float)+> +>   #x .= 2             -- sets the value of variable 'x' to 2+> +>   #x %= (*3)          -- modifies the value of variable 'x' by multiplying it by 3+> +>   #y @Float #=! 7     -- defines a new constant named 'y', initialised with value (7 :: Float)+> +>   z <- #x + #y+>   -- 'z' then has value 6+7 = 13++In the first four examples, the overloaded labels are desugared into standalone labels,+which are then consumed by the infix operators @#=@, @.=@, @%=@ and @#=!@.++In the last example, the labels are desugared directly into values,+within the context of the indexed monad of the @do@ block.++The stateful nature of these labels is worth emphasising.+Consider for instance:++> do+>    #x @Float #= 0+>    x <- #x+>    #x .= 1+>    x' <- #x++When we write @x <- #x@, the /current/ value of @#x@ is obtained from the state.+In this example, this means that @x@ will continue to refer to the value @0@,+even after we set @#x@ to 1. When we retrieve the value of @#x@ after modifying it,+we then give @x'@ the (immutable) value of @1@.++This subtlety is especially important when working with @while@ loops,+as one wants to avoid having a constant conditional in the header.++Note that overloaded labels don't support visible type application in GHC 9.0 [due to a bug](https://gitlab.haskell.org/ghc/ghc/-/issues/19154).+For that version of GHC, you will need to write++> #label #= ( val :: type )++instead of++> #label @type #= val+-}++module FIR.Syntax.Labels+ ( -- * Overloaded labels+   IsLabel(fromLabel)+ , Label(..), LabelUsage(..)+   -- * Infix operators+ , (#=), (#=!), (.=), (%=)+ )+ where++-- base+import Data.Kind+  ( Type )+import qualified GHC.Stack+  ( HasCallStack )+import GHC.TypeLits+  ( Symbol, KnownSymbol )++-- fir+import Control.Type.Optic+  ( Optic, Name )+import FIR.AST+  ( Code )+import FIR.Binding+  ( Var, R, RW )+import FIR.Module+  ( Program )+import FIR.Syntax.Program+  ( def, use, assign, modifying )+import FIR.Prim.Types+  ( PrimTy )+import FIR.ProgramState+  ( ProgramState )+import FIR.Validation.Bindings+  ( ValidDef, AddBinding, Has, CanGet, CanPut )++--------------------------------------------------------------------------+-- overloaded labels++data Label (k :: Symbol) (a :: Type) = Label++data LabelUsage+  = Symbolic+  | Use Symbol ProgramState++class IsLabel k a (usage :: LabelUsage) v+    | v -> a, usage v -> k, v k -> usage+    where+  fromLabel :: GHC.Stack.HasCallStack => v++-- | Use a label symbolically.+--+-- That is, @#foo@ stands for a standalone label.+instance ( KnownSymbol k+         , PrimTy a+         , usage ~ Symbolic+         )+       => IsLabel k a usage (Label k a) where+  fromLabel = Label @k @a++-- | Use a label as a monadic value.+--+-- That is, @#foo@ stands for the value bound at @"foo"@+-- in the context of an indexed state monad.+instance ( KnownSymbol k+         , PrimTy a+         , a ~ Has k i+         , CanGet k i+         , r ~ Code a+         , j ~ i+         , usage ~ 'Use k i+         )+      => IsLabel k a usage (Program i j r) where+  fromLabel = use @(Name k :: Optic '[] i a)++--------------------------------------------------------------------------+-- infix operators++infixr 1 #=+infixr 1 #=!+infixr 1 .=++-- | Define a new variable using a label.+(#=) :: forall a k i.+        ( GHC.Stack.HasCallStack+        , KnownSymbol k+        , ValidDef k i a+        , PrimTy a+        )+     => Label k a+     -> Code a+     -> Program i (AddBinding k (Var RW a) i) (Code a)+_ #= a = def @k @RW a++-- | Define a new constant using a label.+(#=!) :: forall a k i.+        ( GHC.Stack.HasCallStack+        , KnownSymbol k+        , ValidDef k i a+        , PrimTy a+        )+     => Label k a+     -> Code a+     -> Program i (AddBinding k (Var R a) i) (Code a)+_ #=! a = def @k @R a++-- | Set the value of a variable with given label.+(.=) :: forall a k i.+        ( GHC.Stack.HasCallStack+        , KnownSymbol k+        , a ~ Has k i+        , CanPut k i+        , PrimTy a+        )+     => Label k a+     -> Code a+     -> Program i i (Code ())+_ .= a = assign @(Name k :: Optic '[] i a) a++-- | Modify a variable with given label using a function.+(%=) :: forall a k i.+        ( GHC.Stack.HasCallStack+        , KnownSymbol k+        , a ~ Has k i+        , CanGet k i+        , CanPut k i+        )+     => Label k a+     -> (Code a -> Code a)+     -> Program i i (Code ())+_ %= f = modifying @(Name k :: Optic '[] i a) f
+ src/FIR/Syntax/Optics.hs view
@@ -0,0 +1,1020 @@+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}++{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE InstanceSigs           #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE StandaloneDeriving     #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: FIR.Syntax.Optics++This module overloads 'Control.Type.Optic.view',+'Control.Type.Optic.set', and 'Control.Type.Optic.over'+to work with the AST,+in the way of getter/setter instances for types of the form @AST a@.++For instance:++> geometry = Module $ entrypoint @"main" @Geometry do+>   gl_in <- use @(Name "gl_in") -- geometry shader built-in input (structure array)+>   let pos0 = view @(Index 0 :.: Name "gl_Position") gl_in+>   ...++Singletons for optics are also provided, to assist in displaying+the names of optics, and internally for code generation.+-}++module FIR.Syntax.Optics where++-- base+import Data.Kind+  ( Type, Constraint )+import Data.Proxy+  ( Proxy(Proxy) )+import Data.Type.Equality+  ( (:~:)(Refl) )+import Data.Word+  ( Word32 )+import GHC.TypeLits+  ( Symbol, KnownSymbol, symbolVal+  , TypeError+  , ErrorMessage(Text, ShowType, (:<>:), (:$$:))+  )+import GHC.TypeNats+  ( Nat, KnownNat, natVal+  , CmpNat, type (<=), type (-)+  )++-- typelits-witnesses+import GHC.TypeLits.Compare+  ( (:<=?)(LE), (%<=?) )++-- vector+import qualified Data.Vector as Unsized.Vector+  ( (!), (//) )++-- vector-sized+import qualified Data.Vector.Sized as Vector+  ( index, (//) )++-- fir+import Control.Monad.Indexed+  ( (:=) )+import Control.Type.Optic+  ( Optic(..)+  , Indices+  , Gettable, ReifiedGetter(view)+  , Settable, ReifiedSetter(set )+  , Container(..)+  , (:.:), AnIndex, Name, OfType+  , ProductComponents(..)+  )+import Data.Constraint.All+  ( All )+import Data.Function.Variadic+  ( ListVariadic )+import Data.Product+  ( IsProduct, AreProducts+  , Distribute+  , MapHList+  )+import Data.Type.Known+  ( Known )+import Data.Type.LazyEquality+  ( LazyEq )+import Data.Type.List+  ( type (:++:), ZipCons+  , SLength, KnownLength(sLength)+  , SSameLength, SameLength(sSameLength)+  , Postpend+  )+import Data.Type.Map+  ( (:->)((:->))+  , Key+  )+import FIR.Prim.Array+  ( Array(..), RuntimeArray(..) )+import FIR.Prim.Image+  ( Image, ImageProperties+  , ImageOperands, OperandName+  )+import FIR.Prim.Struct+  ( Struct((:&))+  , HasStructField(getStructField, setStructField)+  )+import FIR.Prim.Types+  ( PrimTy(primTySing)+  , IntegralTy+  , ScalarTy(scalarTySing), SScalarTy+  , PrimTyMap+  , SPrimTy(SStruct)+  , HasOpaqueType+  )+import FIR.ProgramState+  ( ProgramState )+import qualified FIR.Validation.Bindings as Binding+  ( Has, CanGet, CanPut )+import FIR.Validation.Bounds+  ( VectorIndexInBounds+  , MatrixColumnIndexInBounds+  , ArrayIndexInBounds+  , StructFieldFromIndex, StructIndexFromName+  )+import FIR.Validation.Images+  ( LookupImageProperties, ImageTexelType )+import Math.Linear+  ( V((:.)), M(M)+  , (^!), at, replaceV+  )++----------------------------------------------------------------------+-- singletons++-- | Singletons associated to the type-level optics used by this library.+data SOptic (optic :: Optic i s a) :: Type where+  SOfType :: SPrimTy s -> SPrimTy a -> SOptic (OfType a :: Optic '[] s a)+  -- for indices, we additional specify the accessee, to distinguish+  -- the different methods SPIR-V supports for access:+  --  - vectors with VectorExtractDynamic / VectorInsertDynamic+  --  - arrays with OpAccessChain+  SAnIndex :: SPrimTy s -> SPrimTy a -> SScalarTy ix -> SOptic (AnIndex ix :: Optic '[ix] s a)+  SIndex   :: SPrimTy s -> SPrimTy a -> Word32 -> SOptic (o :: Optic '[] s a)+  -- we allow an overly-general return type for the above,+  -- as we convert 'Name' optics to 'Index' optics behind the scenes+  SBinding  :: KnownSymbol k+            => Proxy k+            -> SOptic (Name k :: Optic '[] (as :: ProgramState) b)+  SImageTexel :: ( KnownSymbol k+                 , Known ImageProperties props+                 )+              => Proxy k+              -> Proxy props+              -> SPrimTy (ImageTexelType props ops)+              -> SOptic ( (  ( Field_ (k :: Symbol) :: Optic '[] i (Image props) )+                             `ComposeO`+                             ( RTOptic_ :: Optic+                                            '[ ImageOperands props ops, imgCds ]+                                             (Image props)+                                             (ImageTexelType props ops)+                             )+                          ) :: Optic+                                '[ ImageOperands props ops, imgCds ]+                                i+                                (ImageTexelType props ops)+                        )+  SComposeO :: forall is js s a b (o1 :: Optic is s a) (o2 :: Optic js a b)+            .  SLength is -> SOptic o1 -> SOptic o2 -> SOptic (o1 :.: o2)+     --        ^^^^^^^^^^+     -- we need to know the length of the first list to generate code for composite optics+     -- see the function 'opticalTree' in the code generator++     -- similar remark applies to products+  SProd :: forall+              ( iss :: [[Type]] )+              ( k   :: Type     )+              ( s   :: k        )+              ( as  :: [Type]   )+              ( os  :: ProductComponents iss s as)+              ( js  :: [Type]   )+              ( p   :: Type     )+        .  ( IsProduct p as+           , AreProducts js iss as+           , PrimTy p -- need to know result for SPIR-V code generation+           , All PrimTy as+           )+        => SSameLength (Distribute iss as) as+        -> SProductComponents os+        -> SOptic (Prod_ os :: Optic js s p)++data SProductComponents (os :: ProductComponents iss s as) :: Type where+  SEndProd  :: SProductComponents EndProd_+  SProductO :: forall+                ( k   :: Type     )+                ( is  :: [Type]   )+                ( s   :: k        )+                ( a   :: Type     )+                ( iss :: [[Type]] )+                ( as  :: [Type]   )+                ( o   :: Optic is s a )+                ( os  :: ProductComponents iss s as )+            .  SameLength is iss+            => SOptic o+            -> SProductComponents os+            -> SProductComponents (ProductO o os :: ProductComponents (ZipCons is iss) s (a ': as))++infixr 9 %:.:++(%:.:) :: forall is js s a b (o1 :: Optic is s a) (o2 :: Optic js a b).+           KnownLength is+        => SOptic o1 -> SOptic o2 -> SOptic (o1 :.: o2)+o1 %:.: o2 = SComposeO (sLength @_ @is) o1 o2++showSOptic :: SOptic (o :: Optic is s a) -> String+showSOptic (SOfType _ sTy ) = "OfType " ++ show sTy+showSOptic (SAnIndex _ _ _) = "AnIndex"+showSOptic (SIndex   _ _ n) = "Index "   ++ show n+showSOptic (SBinding    k  ) = "Binding "    ++ show (symbolVal k)+showSOptic (SImageTexel k _ _) = "ImageTexel " ++ show (symbolVal k)+showSOptic (SComposeO _   o1 o2) = showSOptic o1 ++ " :.: " ++ showSOptic o2+showSOptic (SProd _ comps) = "Prod ( " ++ showSProductComponents comps ++ " )"++showSProductComponents :: SProductComponents os -> String+showSProductComponents SEndProd = "EndProd"+showSProductComponents (o `SProductO` os)+  = showSOptic o ++ " :*: " ++ showSProductComponents os+++class KnownLength (Indices optic) => KnownOptic optic where+  opticSing :: SOptic optic++instance ( empty ~ '[]+         , a ~ ty+         , Container s+         , PrimTy s+         , PrimTy a+         )+       => KnownOptic (OfType_ ty :: Optic empty s a) where+  opticSing = SOfType (primTySing @s) (primTySing @a)+instance ( KnownNat n+         , empty ~ '[]+         , PrimTy s+         , PrimTy a+         )+       => KnownOptic (Field_ (n :: Nat) :: Optic empty s a)+       where+  opticSing = SIndex (primTySing @s) (primTySing @a) (fromIntegral . natVal $ Proxy @n)+instance forall (as :: [Symbol :-> Type]) (k :: Symbol) (a :: Type)+                (empty :: [Type]) (i :: Nat)+         . ( KnownSymbol k+           , PrimTyMap as+           , PrimTy a+           , KnownNat i+           , (i ':-> a) ~ StructIndexFromName k as+           , empty ~ '[]+           )+        => KnownOptic (Field_ (k :: Symbol) :: Optic empty (Struct as) a)+        where+  opticSing = SIndex (SStruct @Symbol @as) (primTySing @a) (fromIntegral . natVal $ Proxy @i)+instance ( KnownSymbol k+         , empty ~ '[]+         , a ~ Binding.Has k bds+         )+      => KnownOptic (Field_ (k :: Symbol) :: Optic empty (bds :: ProgramState) a)+      where+  opticSing = SBinding (Proxy @k)+instance forall is js ks (s :: Type) a b (o1 :: Optic is s a) (o2 :: Optic js a b).+         ( KnownOptic o1+         , KnownOptic o2+         , ks ~ (is :++: js)+         , KnownLength is+         , KnownLength js+         , KnownLength ks -- deduced from the above two in concrete situations+         )+       => KnownOptic ((o1 `ComposeO` o2) :: Optic ks s b) where+  opticSing = (opticSing @o1) %:.: (opticSing @o2)+instance forall k is js ks (s :: ProgramState) a b+                (o1 :: Optic is s a) (o2 :: Optic js a b)+                .+         ( KnownSymbol k+         , o1 ~ ( Field_ k :: Optic is s a )+         , KnownOptic o2+         , KnownLength ks+         , is ~ '[]+         , ks ~ (is :++: js)+         , a ~ Binding.Has k s+         )+       => KnownOptic ( (o1 `ComposeO` o2) :: Optic ks s b ) where+  opticSing = SBinding (Proxy @k) %:.: (opticSing @o2)+instance forall iss s as js p (os :: ProductComponents iss s as)+       . ( KnownComponents os+         , SameLength (Distribute iss as) as+         , KnownLength js+         , IsProduct p as+         , AreProducts js iss as+         , js ~ MapHList iss+         , PrimTy p+         , All PrimTy as+         )+       => KnownOptic (Prod_ os :: Optic js s p) where+  opticSing = SProd sSameLength (componentsSing @os)++class KnownComponents os where+  componentsSing :: SProductComponents os+instance ( as ~ '[] ) => KnownComponents ( EndProd_ :: ProductComponents iss s as )  where+  componentsSing = SEndProd+instance  forall+            ( k   :: Type     )+            ( is  :: [Type]   )+            ( s   :: k        )+            ( a   :: Type     )+            ( iss :: [[Type]] )+            ( jss :: [[Type]] )+            ( as  :: [Type]   )+            ( o   :: Optic is s a )+            ( os  :: ProductComponents iss s as )+           . ( KnownOptic o+             , KnownComponents os+             , SameLength is iss+             , jss ~ ZipCons is iss+             )+           => KnownComponents (o `ProductO` os :: ProductComponents jss s (a ': as)) where+  componentsSing = opticSing @o `SProductO` componentsSing @os++--------------------------------------------------------------+-- some trickery to account for peculiarities of image optics++-- normal run-time index optic, not allowed to be used for images on its own+instance ( ValidAnIndexOptic is s a, is ~ '[ix], IntegralTy ix, PrimTy s, PrimTy a )+  => KnownOptic (RTOptic_ :: Optic is s a)+  where+  opticSing = SAnIndex (primTySing @s) (primTySing @a) (scalarTySing @ix)+++-- binding + image texel optic... the two parts must always occur together+instance {-# OVERLAPPING #-}+         forall+           ( k        :: Symbol          )+           ( i        :: ProgramState    )+           ( props    :: ImageProperties )+           ( ops      :: [OperandName]   )+           ( empty    :: [Type]          )+           ( imgOps   :: Type            )+           ( imgCds   :: Type            )+           ( imgTexel :: Type            )+         .+         ( KnownSymbol k+         , PrimTy imgCds+         , PrimTy imgTexel+         , LookupImageProperties k i ~ props+         , Known ImageProperties props+         , imgOps ~ ImageOperands props ops+         , imgTexel ~ ImageTexelType props ops+         , empty ~ '[]+         )+      => KnownOptic+            ( ( ( Field_ (k :: Symbol) :: Optic empty i (Image props) )+                `ComposeO`+                ( RTOptic_ :: Optic '[imgOps, imgCds] (Image props) imgTexel)+              ) :: Optic '[imgOps, imgCds] i imgTexel+            )+  where+  opticSing = SImageTexel (Proxy @k) (Proxy @props) (primTySing @imgTexel)++type family ValidAnIndexOptic (is :: [Type]) (s :: Type) (a :: Type) :: Constraint where+  ValidAnIndexOptic '[] _ _+    = TypeError ( Text "Run-time optic does not specify the type of its run-time indices." )+  ValidAnIndexOptic _ (Image _) _+    = TypeError (    Text "Forbidden standalone image texel optic."+                :$$: Text "Use the 'ImageTexel` optic, or an `imageRead`/`imageWrite` operation."+                )+  ValidAnIndexOptic '[ix] _ _ = ()+  ValidAnIndexOptic is _ _+    = TypeError (    Text "Run-time optic specifies more than one type of index:"+                :$$: Text "    " :<>: ShowType is+                )++----------------------------------------------------------------------+-- Instances for compositions involving indexed monadic state.+-- These are provided for improved type inference,+-- by requiring that the part focused onto by the outer optic+-- is as dictated by the state.++instance forall (k :: Symbol) (i :: ProgramState) empty js ks a b (o2 :: Optic js a b).+         ( KnownSymbol k+         , Gettable o2+         , empty ~ '[]+         , ks ~ js+         , a ~ Binding.Has k i -- this is the additional line that helps type inference+         , Binding.CanGet k i+         , NoOpaqueTypes "'get'/'use'" k b ( HasOpaqueType b )+         ) => Gettable ( ((Field_ (k :: Symbol) :: Optic empty i a) `ComposeO` o2) :: Optic ks i b )+         where+instance forall (k :: Symbol) (i :: ProgramState) empty js ks a b (o2 :: Optic js a b).+         ( KnownSymbol k+         , Settable o2+         , empty ~ '[]+         , ks ~ js+         , a ~ Binding.Has k i -- ditto+         , Binding.CanPut k i+         , NoOpaqueTypes "'put'/'assign'" k b ( HasOpaqueType b )+         ) => Settable ( ((Field_ (k :: Symbol) :: Optic empty i a) `ComposeO` o2) :: Optic ks i b )+         where++type family NoOpaqueTypes ( msg :: Symbol ) ( k :: Symbol ) ( b :: Type ) ( hasOpaque :: Bool ) :: Constraint where+  NoOpaqueTypes _   _ _ False = ( () :: Constraint )+  NoOpaqueTypes msg k b True  = TypeError+    (    Text msg :<>: Text ": cannot focus on type "+    :$$: Text "  " :<>: ShowType b+    :$$: Text "within binding named " :<>: ShowType k :<>: Text ", as it is (or contains) an opaque type."+    )++----------------------------------------------------------------------++type StatefulOptic (optic :: Optic is (s :: ProgramState) a) = ( () :: Constraint )+-- to distinguish from (optic :: Optic is (s :: Type) a)++type family ListVariadicIx+              ( as :: [Type] )+              ( i  :: ProgramState )+              ( b  :: Type  )+            = ( r  :: Type  )+            | r -> as i b  where+  ListVariadicIx '[]       i b = (b := i) i+  ListVariadicIx (a ': as) i b = a -> ListVariadicIx as i b++----------------------------------------------------------------------+-- getters++type User   (g :: Optic as i b) = ListVariadicIx as i b+type Viewer (g :: Optic is s a) = ListVariadic (is `Postpend` s) a++-- bindings+instance ( KnownSymbol k+         , r ~ Binding.Has k i+         , Binding.CanGet k i+         , empty ~ '[]+         )+      => Gettable (Field_ (k :: Symbol) :: Optic empty (i :: ProgramState) r) where+++instance+  TypeError (     Text "get: cannot get a binding using a numeric index."+             :$$: Text "Use the binding's name instead."+            )+  => Gettable (Field_ (n :: Nat) :: Optic empty (i :: [Symbol :-> v]) r)+  where++-- arrays+instance ( KnownNat n, KnownNat i+         , ArrayIndexInBounds n i+         , r ~ a+         , empty ~ '[]+         )+      => Gettable (Field_ (i :: Nat) :: Optic empty (Array n a) r) where+instance ( KnownNat n, KnownNat i+         , r ~ a+         , empty ~ '[]+         , PrimTy a+         , Gettable (Field_ (i :: Nat) :: Optic empty (Array n a) r)+         )+       => ReifiedGetter (Field_ (i :: Nat) :: Optic empty (Array n a) r) where+  view (MkArray arr) = arr `Vector.index` fromIntegral (natVal (Proxy @i))++instance ( KnownNat i+         , empty ~ '[]+         , r ~ a+         )+      => Gettable (Field_ (i :: Nat) :: Optic empty (RuntimeArray a) r) where+instance ( KnownNat n, KnownNat i+         , empty ~ '[]+         , r ~ a+         , PrimTy a+         )+       => ReifiedGetter (Field_ (i :: Nat) :: Optic empty (RuntimeArray a) r) where+  view (MkRuntimeArray arr) = arr Unsized.Vector.! fromIntegral (natVal (Proxy @i))+++instance ( IntegralTy ty+         , ix ~ '[ty]+         , r ~ a+         )+      => Gettable (RTOptic_ :: Optic ix (Array n a) r) where+instance ( KnownNat n+         , IntegralTy ty+         , ix ~ '[ty]+         , r ~ a+         , Gettable (RTOptic_ :: Optic ix (Array n a) r)+         , PrimTy a+         )+      => ReifiedGetter (RTOptic_ :: Optic ix (Array n a) r) where+  view i (MkArray arr) = arr `Vector.index` fromIntegral i++instance ( IntegralTy ty+         , ix ~ '[ty]+         , r ~ a+         )+      => Gettable (RTOptic_ :: Optic ix (RuntimeArray a) r) where+instance ( IntegralTy ty, ix ~ '[ty], r ~ a, PrimTy a )+      => ReifiedGetter (RTOptic_ :: Optic ix (RuntimeArray a) r) where+  view i (MkRuntimeArray arr) = arr Unsized.Vector.! fromIntegral i++instance+    TypeError (    Text "get: attempt to access array element \+                        \using symbolic identifier "+              :<>: ShowType k :<>: Text "."+              )+    => Gettable (Field_ (k :: Symbol) :: Optic empty (Array n a) r) where+++instance+    TypeError (    Text "get: attempt to access run-time array \+                        \element using symbolic identifier "+              :<>: ShowType k :<>: Text "."+              )+    => Gettable (Field_ (k :: Symbol) :: Optic empty (RuntimeArray a) r) where+++-- structs+instance ( KnownSymbol k+         , (n ':-> r) ~ StructIndexFromName k as+         , empty ~ '[]+         )+       => Gettable (Field_ (k :: Symbol) :: Optic empty (Struct as) r) where+instance ( KnownSymbol k+         , HasStructField k r as+         , (n ':-> r) ~ StructIndexFromName k as+         , empty ~ '[]+         , PrimTy r+         )+      => ReifiedGetter+            (Field_ (k :: Symbol) :: Optic empty (Struct as) r)+      where+  view = getStructField @k @r @as++instance ( KnownNat n+         , (k ':-> r) ~ StructFieldFromIndex n as+         , empty ~ '[]+         ) => Gettable (Field_ (n :: Nat) :: Optic empty (Struct as) r) where+instance ( KnownNat n+         , empty ~ '[]+         , PrimTy r+         , HasStructField n r as+         , (k ':-> r) ~ StructFieldFromIndex n as+         )+      => ReifiedGetter+           (Field_ (n :: Nat) :: Optic empty (Struct as) r)+       where+  view = getStructField @n @r @as++instance+    TypeError (    Text "get: attempt to access struct element \+                        \using run-time index."+              :$$: Text "Structs can only be accessed using \+                        \compile-time indices, or field names."+              )+    => Gettable (RTOptic_ :: Optic ix (Struct as) r) where+++-- vectors+instance ( KnownNat i+         , VectorIndexInBounds n i+         , empty ~ '[]+         )+      => Gettable (Field_ (i :: Nat) :: Optic empty (V n a) r) where+instance ( KnownNat n+         , KnownNat i+         , VectorIndexInBounds n i+         , empty ~ '[]+         , PrimTy a+         , CmpNat i n ~ 'LT+         , r ~ a+         )+      => ReifiedGetter+            (Field_ (i :: Nat) :: Optic empty (V n a) r)+      where+  view v = at @i v++instance ( IntegralTy ty+         , ix ~ '[ty]+         , r ~ a+         )+       => Gettable (RTOptic_ :: Optic ix (V n a) r) where+instance ( IntegralTy ty+         , r ~ a+         , ix ~ '[ty]+         , PrimTy a+         )+      => ReifiedGetter+            (RTOptic_ :: Optic ix (V n a) r)+      where+  view i v = v ^! fromIntegral i+++instance +    TypeError (    Text "get: attempt to access vector element \+                        \using symbolic identifier "+              :<>: ShowType k :<>: Text "."+              :$$: Text "For a vector swizzle, use 'Swizzle' (e.g. Swizzle '[\"x\",\"z\",\"y\"]),"+              :$$: Text "or a synonym such as XZY (limited to X/Y/Z/W)."+              )+    => Gettable (Field_ (k :: Symbol) :: Optic empty (V n a) r) where+++-- matrices+instance ( KnownNat n+         , KnownNat i+         , r ~ V m a+         , MatrixColumnIndexInBounds m n i+         , empty ~ '[]+         )+      => Gettable (Field_ (i :: Nat) :: Optic empty (M m n a) r) where+instance ( KnownNat m+         , KnownNat n+         , KnownNat i+         , MatrixColumnIndexInBounds m n i+         , r ~ V m a+         , CmpNat i n ~ 'LT+         , empty ~ '[]+         )+      => ReifiedGetter+            (Field_ (i :: Nat) :: Optic empty (M m n a) r)+      where+  view (M cols) = at @i cols++instance ( IntegralTy ty+         , ix ~ '[ty]+         , r ~ V m a+         )+        => Gettable (RTOptic_ :: Optic ix (M m n a) r) where+instance ( KnownNat m+         , KnownNat n+         , IntegralTy ty+         , r ~ V m a+         , ix ~ '[ty]+         )+      => ReifiedGetter+            (RTOptic_ :: Optic ix (M m n a) r)+      where+  view i (M cols) = cols ^! fromIntegral i+++instance+    TypeError (    Text "get: attempt to access matrix column \+                        \using symbolic identifier "+              :<>: ShowType k :<>: Text "."+              )+    => Gettable (Field_ (k :: Symbol) :: Optic empty (M m n a) r) where++----------------------------------------------------------------------+-- setters++type Assigner (g :: Optic as i b) = ListVariadicIx (as `Postpend` b) i ()+type Setter   (g :: Optic is s a) = ListVariadic   (is `Postpend` a `Postpend` s) s+++-- bindings+instance ( KnownSymbol k+         , r ~ Binding.Has k i+         , Binding.CanPut k i+         , empty ~ '[]+         )+      => Settable (Field_ (k :: Symbol) :: Optic empty (i :: ProgramState) r ) where++  ++instance+    TypeError (    Text "set: cannot set binding using a numeric index."+              :$$: Text "Use the binding's name instead."+              )+    => Settable (Field_ (n :: Nat) :: Optic empty (i :: [Symbol :-> v]) r) where++-- arrays+instance ( KnownNat n, KnownNat i+         , ArrayIndexInBounds n i+         , empty ~ '[]+         , r ~ a+         )+      => Settable (Field_ (i :: Nat) :: Optic empty (Array n a) r) where+instance ( KnownNat n, KnownNat i+         , r ~ a+         , empty ~ '[]+         , Settable (Field_ (i :: Nat) :: Optic empty (Array n a) r)+         )+      => ReifiedSetter+           (Field_ (i :: Nat) :: Optic empty (Array n a) r)+      where+  set a (MkArray arr) = MkArray ( arr Vector.// [( fromIntegral (natVal (Proxy @i)), a)] )++instance ( KnownNat i+         , empty ~ '[]+         , r ~ a+         )+      => Settable (Field_ (i :: Nat) :: Optic empty (RuntimeArray a) r) where+instance ( KnownNat i+         , empty ~ '[]+         , r ~ a+         , PrimTy a+         )+      => ReifiedSetter+           (Field_ (i :: Nat) :: Optic empty (RuntimeArray a) r)+      where+  set a (MkRuntimeArray arr)+    = MkRuntimeArray ( arr Unsized.Vector.// [( fromIntegral (natVal (Proxy @i)), a)] )++instance ( IntegralTy ty+         , ix ~ '[ty]+         , r ~ a+         )+      => Settable (RTOptic_ :: Optic ix (Array n a) r) where+instance ( KnownNat n+         , IntegralTy ty+         , r ~ a+         , ix ~ '[ty]+         , Settable (RTOptic_ :: Optic ix (Array n a) r)+         )+      => ReifiedSetter+           (RTOptic_ :: Optic ix (Array n a) r)+      where+  set i a (MkArray arr) = MkArray ( arr Vector.// [(fromIntegral i, a)] )++instance ( IntegralTy ty+         , ix ~ '[ty]+         , r ~ a+         )+      => Settable (RTOptic_ :: Optic ix (RuntimeArray a) r) where+instance ( IntegralTy ty+         , ix ~ '[ty]+         , r ~ a+         , PrimTy a+         )+      => ReifiedSetter+           (RTOptic_ :: Optic ix (RuntimeArray a) r)+      where+  set i a (MkRuntimeArray arr)+    = MkRuntimeArray ( arr Unsized.Vector.// [(fromIntegral i, a)] )+  +instance +    TypeError (    Text "set: attempt to update array element \+                        \using symbolic identifier "+              :<>: ShowType k :<>: Text "."+              )+    => Settable (Field_ (k :: Symbol) :: Optic empty (Array n a) r) where++instance+    TypeError (    Text "set: attempt to update run-time array \+                        \element using symbolic identifier "+              :<>: ShowType k :<>: Text "."+              )+    => Settable (Field_ (k :: Symbol) :: Optic empty (RuntimeArray a) r) where++-- structs+instance ( KnownSymbol k+         , (n ':-> r) ~ StructIndexFromName k as+         , empty ~ '[]+         )+  => Settable (Field_ (k :: Symbol) :: Optic empty (Struct as) r) where+instance ( KnownSymbol k+         , HasStructField k r as+         , (n ':-> r) ~ StructIndexFromName k as+         , empty ~ '[]+         )+      => ReifiedSetter+            (Field_ (k :: Symbol) :: Optic empty (Struct as) r)+      where+  set = setStructField @k @r @as++instance ( KnownNat n+         , (k ':-> r) ~ StructFieldFromIndex n as+         , empty ~ '[]+         ) => Settable (Field_ (n :: Nat) :: Optic empty (Struct as) r) where+instance ( KnownNat n+         , HasStructField n r as+         , (k ':-> r) ~ StructFieldFromIndex n as+         , empty ~ '[]+         )+      => ReifiedSetter+          (Field_ (n :: Nat) :: Optic empty (Struct as) r)+      where+  set = setStructField @n @r @as++instance+    TypeError (    Text "set: attempt to set struct element \+                        \using run-time index."+              :$$: Text "Structs can only be modified using \+                        \compile-time indices or field names."+              )+    => Settable (RTOptic_ :: Optic ix (Struct as) r) where++-- vectors+instance ( KnownNat i+         , VectorIndexInBounds n i+         , empty ~ '[]+         )+      => Settable (Field_ (i :: Nat) :: Optic empty (V n a) r) where+instance ( KnownNat n, KnownNat i, 1 <= n+         , CmpNat i n ~ 'LT+         , r ~ a+         , empty ~ '[]+         , VectorIndexInBounds n i+         )+      => ReifiedSetter+          (Field_ (i :: Nat) :: Optic empty (V n a) r)+      where+  set = replaceV ( fromIntegral ( natVal ( Proxy @i ) ) )++instance ( IntegralTy ty+         , ix ~ '[ty]+         , r ~ a+         , KnownNat n, 1 <= n+         )+    => Settable (RTOptic_ :: Optic ix (V n a) r) where+instance ( IntegralTy ty+         , ix ~ '[ty]+         , r ~ a+         , KnownNat n, 1 <= n+         )+    => ReifiedSetter (RTOptic_ :: Optic ix (V n a) r) where+  set 0 b (_ :. as) = b :. as+  set i b (a :. as) = case Proxy @1 %<=? Proxy @(n-1) of+    LE Refl -> a :. set @(RTOptic_ :: Optic ix (V (n-1) a) r) (i-1) b as+    _       -> a :. as++instance+    TypeError (    Text "set: attempt to update vector element \+                        \using symbolic identifier "+              :<>: ShowType k :<>: Text "."+              :$$: Text "For a vector swizzle, use 'Swizzle' (e.g. Swizzle '[\"x\",\"z\",\"y\"]),"+              :$$: Text "or a synonym such as XZY (limited to X/Y/Z/W)."+              )+    => Settable (Field_ (k :: Symbol) :: Optic empty (V n a) r) where++-- matrices+instance ( KnownNat i+         , empty ~ '[]+         , MatrixColumnIndexInBounds m n i+         )+      => Settable (Field_ (i :: Nat) :: Optic empty (M m n a) r) where+instance ( KnownNat m, KnownNat n, KnownNat i, 1 <= n+         , empty ~ '[]+         , r ~ V m a+         , MatrixColumnIndexInBounds m n i+         )+      => ReifiedSetter+           (Field_ (i :: Nat) :: Optic empty (M m n a) r)+       where+  set c (M m) = M $ replaceV ( fromIntegral ( natVal ( Proxy @i ) ) ) c m++instance ( IntegralTy ty+         , ix ~ '[ty]+         , r ~ V m a+         )+       => Settable (RTOptic_ :: Optic ix (M m n a) r) where+instance ( IntegralTy ty+         , ix ~ '[ty]+         , r ~ V m a+         , KnownNat m, KnownNat n, 1 <= n+         )+       => ReifiedSetter (RTOptic_ :: Optic ix (M m n a) r)+       where+  set i c (M m)+    = ( M+      . set @(RTOptic_ :: Optic ix (V n (V m a)) (V m a)) i c+      ) m++instance+    TypeError (    Text "set: attempt to update matrix column \+                        \using symbolic identifier "+              :<>: ShowType k :<>: Text "."+              )+    => Settable (Field_ (k :: Symbol) :: Optic empty (M m n a) r) where+++----------------------------------------------------------------------+-- type class instances for containers++instance Container (Array n a) where+instance Container (RuntimeArray a) where+instance KnownNat n => Container (M m n a) where+instance Container (V n a) where+  type FieldIndexFromName (V n a) k+    = TypeError (    Text "optic: attempt to index a vector component with name " :<>: ShowType k+                :$$: Text "Maybe you intended to use a swizzle?"+                )+instance Container (Struct (as :: [Symbol :-> Type])) where+  type FieldIndexFromName (Struct (as :: [Symbol :-> Type])) k+    = Key (StructIndexFromName k as)++----------------------------------------------------------------------+-- type class instances for "OfType" optic++-- vectors+class SetVector n a b (a_eq_b :: Bool) where+  setVector :: b -> V n a -> V n a+instance (a ~ b, KnownNat n) => SetVector n a b 'True where+  setVector a _ = pure a+instance SetVector n a b 'False where+  setVector _ = id++instance ( empty ~ '[]+         , KnownNat n+         , SetVector n a b (a `LazyEq` b)+         )+      => Settable (OfType_ ty :: Optic empty (V n a) b)+      where+instance ( empty ~ '[]+         , b ~ a+         , KnownNat n+         , SetVector n a b (a `LazyEq` b)+         )+      => ReifiedSetter (OfType_ ty :: Optic empty (V n a) b)+      where+  set = setVector @n @a @b @(a `LazyEq` b)++-- matrices+data MatrixComponent+  = Column+  | Entry++type family WhichMatrixComponent+              (m :: Nat) (a :: Type) (b :: Type)+            :: Maybe MatrixComponent+            where+  WhichMatrixComponent _ a a       = Just Entry+  WhichMatrixComponent m a (V m a) = Just Column+  WhichMatrixComponent _ _ _       = Nothing++class SetMatrix m n a b (w :: Maybe MatrixComponent) where+  setMatrix :: b -> M m n a -> M m n a+instance ( b ~ a+         , KnownNat m+         , KnownNat n+         )+      => SetMatrix m n a b (Just Entry) where+  setMatrix a _ = pure a+instance ( b ~ V m a+         , KnownNat m+         , KnownNat n+         )+      => SetMatrix m n a b (Just Column) where+  setMatrix col _ = M ( pure col :: V n (V m a) )+instance SetMatrix m n a b Nothing where+  setMatrix _ = id++instance ( empty ~ '[]+         , KnownNat m+         , KnownNat n+         , b ~ ty+         , SetMatrix m n a b (WhichMatrixComponent m a b)+         )+      => Settable (OfType_ ty :: Optic empty (M m n a) b)+      where+instance ( empty ~ '[]+         , KnownNat m+         , KnownNat n+         , b ~ ty+         , SetMatrix m n a b (WhichMatrixComponent m a b)+         )+      => ReifiedSetter (OfType_ ty :: Optic empty (M m n a) b)+      where+  set = setMatrix @m @n @a @b @(WhichMatrixComponent m a b)++-- arrays+instance ( empty ~ '[]+         , KnownNat n+         , b ~ ty+         , Settable (OfType ty :: Optic '[] a ty)+         )+      => Settable (OfType_ ty :: Optic empty (Array n a) b)+      where+instance ( empty ~ '[]+         , KnownNat n+         , b ~ ty+         , ReifiedSetter (OfType ty :: Optic '[] a ty)+         , ListVariadic '[] a ~ a+         )+      => ReifiedSetter (OfType_ ty :: Optic empty (Array n a) b)+      where+  set a = fmap ( set @(OfType ty :: Optic '[] a ty) a )++instance ( TypeError ( Text "Cannot use 'OfType' optic on a runtime array." ) )+      => Settable (OfType_ ty :: Optic empty (RuntimeArray a) r)+      where+instance ( TypeError ( Text "Cannot use 'OfType' optic on a runtime array." ) )+      => ReifiedSetter (OfType_ ty :: Optic empty (RuntimeArray a) r)+      where+  set = error "unreachable"++-- structs+instance ( empty ~ '[] ) => Settable      (OfType_ ty :: Optic empty (Struct '[]) b) where+instance ( empty ~ '[] ) => ReifiedSetter (OfType_ ty :: Optic empty (Struct '[]) b) where+  set _ = id+instance ( empty ~ '[]+         , Settable (OfType ty :: Optic '[] a           ty)+         , Settable (OfType ty :: Optic '[] (Struct as) ty)+         , b ~ ty+         )+      => Settable ( OfType_ ty :: Optic empty (Struct ( (fld ':-> a) ': as ) ) b ) where+instance ( empty ~ '[]+         , ReifiedSetter (OfType ty :: Optic '[] a           ty)+         , ReifiedSetter (OfType ty :: Optic '[] (Struct as) ty)+         , b ~ ty+         , ListVariadic '[] a ~ a+         )+      => ReifiedSetter ( OfType_ ty :: Optic empty (Struct ( (fld ':-> a) ': as ) ) b ) where+  set x ( a :& as )+    =  set @(OfType ty :: Optic '[] a           b) x a+    :& set @(OfType ty :: Optic '[] (Struct as) b) x as
+ src/FIR/Syntax/Optics.hs-boot view
@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}++{-# LANGUAGE DataKinds       #-}+{-# LANGUAGE PolyKinds       #-}+{-# LANGUAGE RoleAnnotations #-}++module FIR.Syntax.Optics where++-- base+import Data.Kind+  ( Type )++-- fir+import {-# SOURCE #-} Control.Type.Optic+  ( Optic+  , Indices+  )+import Data.Type.List+  ( KnownLength )++----------------------------------------------------------------------++data SOptic (optic :: Optic i s a) :: Type+type role SOptic nominal++class KnownLength (Indices optic) => KnownOptic optic where+  opticSing :: SOptic optic++showSOptic :: SOptic (o :: Optic is s a) -> String
+ src/FIR/Syntax/Option.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DeriveFunctor        #-}+{-# LANGUAGE DerivingStrategies   #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE PatternSynonyms      #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: FIR.Syntax.Option++Custom 'Option' type (like 'Maybe') and associated functionality.+-}++module FIR.Syntax.Option+  ( Option(..)+  , some, none+  , option, fromOption+  )+  where++-- base+import Prelude hiding ((&&))+import Control.Monad+  ( ap )++-- fir+import Control.Type.Optic+  ( Name, ReifiedGetter(view) )+import Data.Type.Map+  ( (:->)((:->)) )+import FIR.AST+  ( Code+  , Syntactic(..)+  , SyntacticVal, InternalType+  , pattern Lit, pattern Undefined, pattern Struct+  )+import FIR.AST.Type+  ( AugType(Val) )+import FIR.Prim.Struct+  ( Struct(..) )+import FIR.Prim.Types+  ( PrimTy )+import FIR.Syntax.AST+  ( )+import FIR.Syntax.IfThenElse+  ( )+import FIR.Syntax.Program+  ( )+import Math.Logic.Class+  ( Choose(..), Boolean((&&)) )++--------------------------------------------------------------------------------------++-- | 'Option' type like in Axelsson–Svenningsson.+data Option a = Option { isSome :: Code Bool, fromSome :: a }+  deriving stock Functor+instance Applicative Option where+  pure = some+  (<*>) = ap+instance Monad Option where+  return = pure+  Option { isSome = c, fromSome = a } >>= f+    | Option { isSome = d, fromSome = b } <- f a+    = Option { isSome = c && d, fromSome = b }++instance ( SyntacticVal a, PrimTy (InternalType a) ) => Syntactic (Option a) where+  type Internal (Option a) =+    Val (Struct '[ "isSome" ':-> Bool, "fromSome" ':-> InternalType a ])+  toAST (Option { isSome = c, fromSome = a })+    = choose c+        ( Struct ( Lit True  :& toAST a   :& End ) )+        ( Struct ( Lit False :& Undefined :& End ) )+  fromAST struct+    = Option+      { isSome   =          view @(Name "isSome"  ) struct+      , fromSome = fromAST (view @(Name "fromSome") struct)+      }+some :: a -> Option a+some a = Option { isSome = Lit True, fromSome = a }+none :: forall a. ( SyntacticVal a, PrimTy (InternalType a) ) => Option a+none = Option { isSome = Lit False, fromSome = fromAST $ Undefined @(InternalType a) }+option+  :: ( SyntacticVal a+     , PrimTy (InternalType a)+     , Choose (Code Bool) '(b,b,b)+     )+  => b -> (a -> b) -> Option a -> b+option b f a_opt =+  choose ( isSome a_opt ) ( f ( fromSome a_opt ) ) b++fromOption :: ( SyntacticVal a, PrimTy (InternalType a), Choose (Code Bool) '(a,a,a) )+           => a -> Option a -> a+fromOption a = option a id
+ src/FIR/Syntax/Program.hs view
@@ -0,0 +1,1455 @@+{-# LANGUAGE AllowAmbiguousTypes     #-}+{-# LANGUAGE DataKinds               #-}+{-# LANGUAGE FlexibleContexts        #-}+{-# LANGUAGE FlexibleInstances       #-}+{-# LANGUAGE InstanceSigs            #-}+{-# LANGUAGE MultiParamTypeClasses   #-}+{-# LANGUAGE PatternSynonyms         #-}+{-# LANGUAGE PolyKinds               #-}+{-# LANGUAGE RebindableSyntax        #-}+{-# LANGUAGE ScopedTypeVariables     #-}+{-# LANGUAGE TypeApplications        #-}+{-# LANGUAGE TypeFamilyDependencies  #-}+{-# LANGUAGE TypeOperators           #-}+{-# LANGUAGE UndecidableInstances    #-}+{-# LANGUAGE UndecidableSuperClasses #-}++{-|+Module: FIR.Syntax.Program++This module, together with "FIR.Syntax.AST",+provides most of the user-facing syntax for constructing+and manipulating values in the EDSL.++This is done through type class overloading, here in the form of+orphan instances for types of the form @Program (i :: ProgramState) (j :: ProgramState) (a :: Type)@,+representing stateful values in the EDSL.    +See also "FIR.ProgramState".++Recall that 'Program' is a wrapper for the internal representation+using the indexed codensity transformation, see "FIR.Module".++See also the validation modules:++  * "FIR.Validation.Bindings" for stateful operations such as 'get'/'put',+  and definitions (of variables, functions, entrypoints).+  * "FIR.Validation.Images" for image read/write operations such as+  'imageRead'/'imageWrite'.++-}++module FIR.Syntax.Program+  ( -- * Monadic control operations+    while, loop, break, breakContinue, continue+  , switchM, locally, embed, purely++    -- * Stateful operations (with indexed monadic state)+    -- ** Defining new objects+    -- *** Constants / variables+  , let', def, def'+    -- *** Functions+  , fundef+    -- *** Entry points+  , entryPoint, shader++    -- ** Optics+    -- *** General functions: use, assign, modifying+  , use, assign, modifying+    -- *** Special cases for manipulating variables+  , get, put, modify+    -- *** Special cases for manipulating images+  , imageRead, imageWrite+    -- *** Atomic operations+    -- $atomics+  , atomicLoad, atomicStore+  , atomicExchange, atomicCompareExchange+  , atomicIncrement, atomicDecrement+  , atomicAdd, atomicSub, atomicMin, atomicMax+  , atomicAnd, atomicOr, atomicXor+  , ProgExchanger, ProgCompareExchanger++  -- * Querying the length of a run-time array+  , ArrayLength, arrayLength++  -- * Geometry shader primitive instructions+  , emitVertex, endPrimitive++  -- * Memory synchronisation primitive operations+  , controlBarrier, memoryBarrier++  -- * Group operations+  , HasGroupAdd(..)+  , HasGroupMul(..)+  , HasGroupMinMax(..)+  , HasGroupBitwise(..)+  , HasGroupLogic(..)++    -- * Instances++    -- ** Undefined type class+    -- $undef++    -- ** Logical operations+    -- $logical++    -- ** Numeric operations+    -- $numeric++    -- ** Numeric conversions+    -- $conversions++    -- ** Vectors+    -- $vectors++    -- ** Matrices+    -- $matrices++    -- + orphan instances+  )+  where++-- base+import Prelude hiding+  ( Eq(..), (&&), (||), not+  , Ord(..)+  , Num(..), Floating(..), RealFrac(..)+  , Integral(..)+  , Fractional(..), fromRational+  , Floating(..), RealFloat(..)+  , Functor(..), Monad(..)+  , Applicative(..)+  , break, undefined+  )+import qualified Prelude+import Data.Kind+  ( Type )+import Data.Maybe+  ( fromMaybe )+import Data.Proxy+  ( Proxy(Proxy) )+import Data.Word+  ( Word32 )+import qualified GHC.Stack+  ( HasCallStack )+import GHC.TypeLits+  ( Symbol, KnownSymbol+  , TypeError, ErrorMessage(..)+  )+import GHC.TypeNats+  ( Nat, KnownNat )++-- fir+import CodeGen.Instruction+  ( ID(..) )+import Control.Monad.Indexed+  ( (:=)(AtKey), Codensity(Codensity)+  , MonadIxFail(fail)+  , ixFmap, ixPure, ixLiftA2+  )+import qualified Control.Monad.Indexed as Indexed+import Control.Type.Optic+  ( Optic(..), Name, Gettable, Settable+  , Part, Whole, Indices+  )+import Data.Constraint.All+  ( All )+import Data.Type.Known+  ( Known, knownValue  )+import Data.Type.List+  ( KnownLength(sLength), Postpend )+import Data.Type.Map+  ( (:->)((:->)), Map )+import FIR.AST+  ( AST, Code+  , Syntactic(Internal,toAST,fromAST)+  , SyntacticVal, InternalType+  , primOp+  , pattern MkID+  , HasUndefined(undefined)+  , AugUser, AugAssigner, AugExchanger, AugCompareExchanger+  , FunctionHandle+  , pattern Lam, pattern (:$), pattern Lit+  , pattern Locally, pattern Embed+  , pattern While, pattern Loop, pattern Break, pattern BreakContinue+  , pattern SwitchM+  , pattern Bind+  , pattern Let, pattern Def, pattern FunDef, pattern FunCall, pattern DefEntryPoint+  , pattern ArrayLength+  , pattern Use, pattern Assign, pattern Atomic+  , pattern NilOps+  )+import FIR.AST.Type+  ( AugType(Val), Eff, FunArgs, Nullary )+import FIR.Binding+  ( BindingsMap, Var, Permissions+  , FunctionAugType+  )+import FIR.Definition+  ( Definition, KnownDefinitions+  , StartState+  , StartBindings, EndBindings+  )+import FIR.Module+  ( Program+  , ShaderModule(ShaderModule)+  )+import FIR.Prim.Array+  ( RuntimeArray )+import FIR.Prim.Image+  ( ImageProperties, ImageOperands+  )+import FIR.Prim.RayTracing+  ( RayQueryState )+import FIR.Prim.Struct+  ( Struct )+import FIR.Prim.Op+  ( Vectorise(Vectorise) )+import FIR.Prim.Atomic+  ( SAtomicOp(..), AtomicTy, AtomicIntegralTy )+import FIR.Prim.Types+  ( PrimTy, ScalarTy, IntegralTy+  , KnownVars+  , primTy+  )+import FIR.ProgramState+  ( CFGState(..)+  , FunctionInfo+  , FunctionContext(..)+  , ProgramState(ProgramState)+  , TLInterface+  , ExecutionContext+  , EntryPointInfo+  )+import FIR.Syntax.AST+  ( )+import FIR.Syntax.Images+  ( ImageTexel )+import FIR.Syntax.Optics+  ( KnownOptic, opticSing+  , StatefulOptic+  )+import FIR.Validation.Bindings+  ( ValidDef, AddBinding, Has+  , ValidFunDef, AddFunBinding, FunctionTypes+  , FunctionDefinitionStartState, FunctionDefinitionEndState+  , ValidEntryPoint+  , EntryPointStartState, EntryPointEndState+  , SetInterface, GetExecutionInfo+  , Embeddable+  )+import FIR.Validation.Bounds+  ( StructIndexFromName )+import FIR.Validation.CFG+  ( InLoop+  , ValidBreak, ValidContinue+  )+import FIR.Validation.Definitions+  ( ValidDefinitions )+import FIR.Validation.Images+  ( LookupImageProperties, ImageTexelType+  , ValidImageRead, ValidImageWrite+  )+import Math.Algebra.Class+  ( AdditiveMonoid(..), CancellativeAdditiveMonoid(..), AdditiveGroup(..)+  , Semiring(..), Ring+  , DivisionRing(..)+  , Signed(..), Archimedean(..)+  , Floating(..), RealFloat(..)+  , Convert(..), Rounding(..)+  )+import Math.Linear+  ( Semimodule(..), LinearModule(..)+  , Inner(..), Cross(..)+  , Matrix(..), VectorOf+  , V, M+  )+import Math.Logic.Bits+  ( Bits(..), BitShift(..), BitCast(..) )+import Math.Logic.Class+  ( Eq(..), Boolean(..), Ord(..) )+import qualified SPIRV.Groups          as SPIRV+  ( GroupOperation(..), groupOperationToWord32 )+import qualified SPIRV.PrimOp          as SPIRV+  ( GeomPrimOp(..), SyncPrimOp(..)+  , GroupNumOp(..), GroupBitwiseOp(..), GroupLogicOp(..)+  )+import qualified SPIRV.Stage           as SPIRV+import qualified SPIRV.Synchronisation as SPIRV+  ( SynchronisationScope, MemorySemantics+  , synchronisationScope, memorySemanticsBitmask+  )+--------------------------------------------------------------------------+-- * Monadic control operations++-- | Encapsulate local state, turning a program which changes state+-- into one that preserves state.+locally :: forall i j r. (SyntacticVal r) => Program i j r -> Program i i r+locally p = fromAST ( Locally :$ toAST p )++-- | Embed a program with a /smaller/ state into one with a /larger/ state.+embed :: forall i j r. (Embeddable i j, SyntacticVal r)+      => Program i i r -> Program j j r+embed p = fromAST ( Embed :$ toAST p )++-- | Take a stateless program and embed it into another program.+purely+  :: ( SyntacticVal r+     , i ~ 'ProgramState '[] 'TopLevel ('CFGState 0) '[] '[] '[] '[] bkend+     , Embeddable i k+     )+  => Program i j r -> Program k k r+purely = embed . locally++-- | While loop: loop over the body as long as the condition is true.+--+-- The condition is checked before the first time around the loop.+while :: GHC.Stack.HasCallStack+      => Program i i (Code Bool)        -- ^ Condition.+      -> Program (InLoop i) j (Code ()) -- ^ Loop body.+      -> Program i i (Code ())+while c p = fromAST ( While :$ toAST c :$ toAST p )++-- | Unconditional loop. Break out of the loop using 'break'.+loop :: GHC.Stack.HasCallStack+     => Program (InLoop i) j (Code ())+     -> Program i i (Code ())+loop p = fromAST ( Loop :$ toAST p )++-- | Break out of the given number of loops (specified with a type application).+--+-- Usage: @break \@n@ breaks out of the @n@ innermost loops at the current stage.+break :: forall ( n :: Nat ) ( i :: ProgramState )+      .  ( GHC.Stack.HasCallStack+         , KnownNat n, ValidBreak n i+         )+      => Program i i (Code ())+break = fromAST ( Break ( Proxy @n ) )++-- | Break out the given number of loops (possibly @0@),+-- and then continue from the start of the remaining innermost loop,+-- checking the loop header condition if there is one.+--+-- Usage: @breakContinue \@i@.+breakContinue+  :: forall ( n :: Nat ) ( i :: ProgramState )+  .  ( GHC.Stack.HasCallStack+     , KnownNat n, ValidContinue n i+     )+  => Program i i (Code ())+breakContinue = fromAST ( BreakContinue ( Proxy @n ) )++-- | Go back to the start of the current loop,+-- checking the loop header condition if there is one.+continue :: ( GHC.Stack.HasCallStack, ValidContinue 0 i ) => Program i i (Code ())+continue = breakContinue @0++-- | Monadic switch statement.+-- Takes a scrutinee, a list of cases and a default (fallthrough) case.+--+-- Returns a switch statement which decides on the branch to follow by inspecting the scrutinee.+--+-- See 'FIR.Syntax.AST.switch' for a non-monadic version.+switchM :: ( Syntactic scrut, Internal scrut ~ Val vscrut+           , IntegralTy vscrut+           , Syntactic val, Internal val ~ Val vval+           , PrimTy vval+           )+        => Program i i scrut -- ^ Scrutinee.+        -> [ InternalType scrut :-> Program i i val ] -- ^ Cases.+        -> Program i i val   -- ^ Default (fallthrough) case.+        -> Program i i val+switchM scrut cases val = fromAST $ SwitchM (toAST scrut) (toAST val) (map ( \ (x :-> y) -> (x, toAST y) ) cases)++--------------------------------------------------------------------------+-- Undefined++-- $undef+-- Instance for the 'Undefined' type class.++-- Enforcing "i ~ j" allows the user to use 'undefined' in indexed-monadic code+-- without wreaking havoc on type inference by causing the computation to result+-- in an arbitrary state.+-- This does mean that the user cannot use 'undefined' to stand-in for an+-- arbitrary state-changing computation.+instance ( PrimTy a, j ~ i ) => HasUndefined (Program i j (Code a)) where+  undefined = ixPure undefined++instance {-# OVERLAPPABLE #-} ( j ~ i ) => HasUndefined (Program i j a) where+  undefined = Prelude.undefined++--------------------------------------------------------------------------+-- Stateful operations (with indexed monadic state)++-- Defining functions and variables.++-- | let binding.+let' :: forall ( a :: Type ) ( i :: ProgramState )+     . ( GHC.Stack.HasCallStack, SyntacticVal a, PrimTy (InternalType a) )+     => a+     -> Program i i a+let' = fromAST Let++-- | Define a new variable.+--+-- Type-level arguments:+--+-- *@k@: name to use for definition,+-- *@ps@: 'FIR.Binding.Permission's (readable, writable, ...),+-- *@a@: type of definition,+-- *@i@: state at start of definition (usually inferred).+def :: forall+         ( k  :: Symbol       )+         ( ps :: Permissions  )+         ( a  :: Type         )+         ( i  :: ProgramState )+    .  ( GHC.Stack.HasCallStack+       , KnownSymbol k+       , Known Permissions ps+       , PrimTy a+       , ValidDef k i a+       )+    => Code a -- ^ Initial value.+    -> Program i (AddBinding k (Var ps a) i) (Code a)+def = fromAST ( Def (Proxy @k) (Proxy @ps) )++-- | Define a new variable, using `Syntactic` for desugaring.+--+-- Type-level arguments:+--+-- *@k@: name to use for definition,+-- *@ps@: 'FIR.Binding.Permission's (readable, writable, ...),+-- *@a@: type of definition,+-- *@i@: state at start of definition (usually inferred).+def' :: forall+         ( k  :: Symbol       )+         ( ps :: Permissions  )+         ( a  :: Type         )+         ( i  :: ProgramState )+    .  ( GHC.Stack.HasCallStack+       , KnownSymbol k+       , Known Permissions ps+       , SyntacticVal a, PrimTy (InternalType a)+       , ValidDef k i (InternalType a)+       )+    => a -- ^ Initial value.+    -> Program i (AddBinding k (Var ps (InternalType a)) i) a+def' = fromAST ( Def (Proxy @k) (Proxy @ps) )++-- | Define a new function.+--+-- Type-level arguments:+--+-- * @name@: function name,+-- * @as@: list of argument types,+-- * @b@: return type,+-- * @j_bds@: bindings state at end of function body (usually inferred),+-- * @i@: monadic state at start of function body (usually inferred),+-- * @r@: function type itself, result of 'fundef' (usually inferred).+fundef :: forall+            ( name  :: Symbol       )+            ( as    :: BindingsMap  )+            ( b     :: Type         )+            ( j_bds :: BindingsMap  )+            ( i     :: ProgramState )+            ( r     :: Type         )+        .  ( GHC.Stack.HasCallStack+           , Syntactic r+           , Internal r ~ FunctionAugType as b, All Nullary (FunArgs (FunctionAugType as b))+           , KnownSymbol name+           , KnownVars as+           , PrimTy b+           , ValidFunDef name as i j_bds+           , '(as, b) ~ FunctionTypes name i+           )+        => Program+              ( FunctionDefinitionStartState name as i )+              ( FunctionDefinitionEndState name as j_bds i )+              ( Code b ) -- ^ Function body code.+        -> Program i (AddFunBinding name as b i) r+fundef f = ixFmap ( \g -> fromAST ( FunCall (Proxy @name) ( Proxy @as ) ( Proxy @b ) :$ g ) ) cod+  where+    fun :: AST (Eff i (AddFunBinding name as b i) (FunctionHandle name as b))+    fun = FunDef (Proxy @name) (Proxy @as) (Proxy @b) :$ toAST f+    cod :: Program i (AddFunBinding name as b i) (AST (Val (FunctionHandle name as b)))+    cod = Codensity ( \k -> Bind :$ fun :$ Lam (k . AtKey) )++-- | Define a new entry point.+--+-- The appropriate built-in variables are made available in the entry point body.+--+-- Type-level arguments:+--+-- *@name@: name of entry point,+-- *@stage@: entry point 'SPIRV.Stage.ExecutionModel',+-- *@stageInfo@: entry point 'SPIRV.Stage.ExecutionInfo' (usually inferred),+-- *@j_bds@: bindings state at end of entry point body (usually inferred),+-- *@j_iface@: interface of entry point (usually inferred),+-- *@i@: state at start of entry point body (usually inferred).+entryPoint :: forall+               ( name      :: Symbol )+               ( stage     :: SPIRV.ExecutionModel          )+               ( stageInfo :: SPIRV.ExecutionInfo Nat stage )+               ( j_bds     :: BindingsMap  )+               ( j_iface   :: TLInterface  )+               ( i         :: ProgramState )+           .+             ( GHC.Stack.HasCallStack+             , KnownSymbol name+             , Known SPIRV.ExecutionModel stage+             , Known (SPIRV.ExecutionInfo Nat stage) stageInfo+             , ValidEntryPoint name stageInfo i j_bds+             , stageInfo ~ GetExecutionInfo name stage i+             )+           => Program+                ( EntryPointStartState name stageInfo               i )+                ( EntryPointEndState   name stageInfo j_bds j_iface i )+                ( Code () )+           -> Program+                i+                ( SetInterface name stageInfo j_iface i )+                ( Code () )+entryPoint ep = fromAST ( DefEntryPoint (Proxy @name) (Proxy @stageInfo) :$ toAST ep )++-- | Define a new shader stage.+--+-- This function provides a convenience wrapper around 'entryPoint',+-- suitable for creating a program containing a single shader and+-- no top-level functions.+--+-- Type-level arguments:+--+-- *@name@: name of entry point,+-- *@shader@: which shader stage to use,+-- *@defs@: top-level inputs/outputs of shader stage.+--+-- Other type-level arguments should be inferred.+shader :: forall+            ( name      :: Symbol                        )+            ( shader    :: SPIRV.Shader                  )+            ( defs      :: [Symbol :-> Definition]       )+            ( stage     :: SPIRV.ExecutionModel          )+            ( stageInfo :: SPIRV.ExecutionInfo Nat stage )+            ( j_bds     :: BindingsMap                   )+            ( j_iface   :: TLInterface                   )+            ( cfg       :: CFGState                      )+            ( funs      :: [Symbol :-> FunctionInfo   ]  )+            ( eps       :: [Symbol :-> EntryPointInfo ]  )+            ( g_iface   :: TLInterface                   )+            ( rayQs     :: Map Symbol RayQueryState      )+            ( bkend     :: SPIRV.Backend                 )+            ( i         :: ProgramState                  )+       . ( GHC.Stack.HasCallStack+         , KnownDefinitions defs+         , ValidDefinitions defs+         , GetExecutionInfo name stage i ~ stageInfo+         , funs ~ '[ ]+         , i ~ 'ProgramState (StartBindings defs) 'TopLevel cfg funs eps g_iface rayQs bkend+         , i ~ StartState defs+         , KnownSymbol name+         , stage ~ 'SPIRV.Stage ('SPIRV.ShaderStage shader)+         , Known SPIRV.Shader shader+         , Known (SPIRV.ExecutionInfo Nat stage) stageInfo+         , EndBindings defs ~ StartBindings defs+         , ValidEntryPoint name stageInfo ('ProgramState (EndBindings defs) 'TopLevel cfg funs eps g_iface rayQs bkend) j_bds+         )+       => Program+            ( EntryPointStartState name stageInfo               i )+            ( EntryPointEndState   name stageInfo j_bds j_iface i )+            ( Code () )+       -> ShaderModule name shader defs (SetInterface name stageInfo j_iface i)+shader+  = ShaderModule+  . entryPoint @name @stage++-- Optics.++-- | /Use/ an optic, returning a monadic value read from the (indexed) state.+--+-- Like @use@ from the lens library, except the optic needs to be passed with a type application.+use :: forall optic.+             ( GHC.Stack.HasCallStack+             , KnownOptic optic, StatefulOptic optic+             , Gettable optic+             , Syntactic (ProgUser optic)+             , Internal (ProgUser optic) ~ AugUser optic+             )+           => ProgUser optic+use = fromAST ( Use sLength ( opticSing @optic ) )++-- | Assign a new value with an optic.+--+-- Like @assign@ from the lens library, except the optic needs to be passed with a type application.+assign :: forall optic.+             ( GHC.Stack.HasCallStack+             , KnownOptic optic, StatefulOptic optic+             , Settable optic+             , Syntactic (ProgAssigner optic)+             , Internal (ProgAssigner optic) ~ AugAssigner optic+             )+           => ProgAssigner optic+assign = fromAST ( Assign sLength ( opticSing @optic ) )++-- *** Get, put, modify.++-- | Get the value of a variable.+-- Like @get@ for state monads, except a binding name needs to be specified with a type application.+--+-- Synonym for @use \@(Name k)@.+get :: forall (k :: Symbol) (a :: Type) (i :: ProgramState).+       ( KnownSymbol k+       , Gettable (Name k :: Optic '[] i a)+       , a ~ Has k i+       , PrimTy a+       )+    => Program i i (Code a)+get = use @(Name k :: Optic '[] i a)++-- | Set the value of a variable.+-- Like @put@ for state monads, except a binding name needs to be specified with a type application.+--+-- Synonym for @assign \@(Name k)@.+put :: forall (k :: Symbol) (a :: Type) (i :: ProgramState).+       ( KnownSymbol k+       , Settable (Name k :: Optic '[] i a)+       , a ~ Has k i+       , PrimTy a+       )+    => Code a -> Program i i (Code ())+put = assign @(Name k :: Optic '[] i a)++-- | Modify the value of a variable.+-- | Like @modify@ for state monads, except a binding name needs to be specified with a type application.+--+-- Synonym for @modifying \@(Name k)@.+modify :: forall (k :: Symbol) (a :: Type) (i :: ProgramState).+          ( KnownSymbol k+          , Gettable (Name k :: Optic '[] i a)+          , Settable (Name k :: Optic '[] i a)+          , a ~ Has k i+          , PrimTy a+          )+       => (Code a -> Code a) -> Program i i (Code ())+modify = modifying @(Name k :: Optic '[] i a)++--------------------------------------------------------------------------+-- Image operations (synonyms for 'use'/'assign').++-- | Read from an image (with or without a sampler).+--+-- Synonym for @use \@(ImageTexel \"imgName\")@,+-- but with no additional image operands provided.+--+-- Type-level arguments:+--+-- * @imgName@: image name,+-- * @props@: image properties (usually inferred),+-- * @i@: monadic state (usually inferred).+imageRead :: forall+              ( imgName  :: Symbol          )+              ( props    :: ImageProperties )+              ( imgCds   :: Type            )+              ( imgTexel :: Type            )+              ( i        :: ProgramState    )+            .+            ( KnownSymbol imgName+            , PrimTy imgCds+            , PrimTy imgTexel+            , imgTexel ~ ImageTexelType props '[]+            , Gettable+                ( ImageTexel imgName+                  :: Optic+                      '[ ImageOperands props '[], imgCds ]+                       i+                       ( ImageTexelType props '[] ) -- can't use "imgTexel", GHC trac #15710+                )+            , props ~ LookupImageProperties imgName i+            , Known ImageProperties props+            , ValidImageRead props '[] imgCds+            )+          => Code imgCds+          -> Program i i (Code (ImageTexelType props '[]))+imageRead = use+          @( ImageTexel imgName+              :: Optic+                   '[ ImageOperands props '[], imgCds ]+                    i+                    imgTexel+           )+          NilOps++-- | Write directly to an image (without a sampler).+--+-- Synonym for @assign \@(ImageTexel \"imgName\")@,+-- but with no additional image operands provided.+--+-- Type-level arguments:+--+-- * @imgName@: image name,+-- * @props@: image properties (usually inferred),+-- * @i@: monadic state (usually inferred).+imageWrite :: forall+                ( imgName  :: Symbol          )+                ( props    :: ImageProperties )+                ( imgCds   :: Type            )+                ( imgTexel :: Type            )+                ( i        :: ProgramState    )+             .+             ( KnownSymbol imgName+             , PrimTy imgCds+             , PrimTy imgTexel+             , imgTexel ~ ImageTexelType props '[]+             , Gettable+                ( ImageTexel imgName+                  :: Optic+                      '[ ImageOperands props '[], imgCds ]+                       i+                       ( ImageTexelType props '[] ) -- can't use "imgTexel", GHC trac #15710+                )+             , props ~ LookupImageProperties imgName i+             , Known ImageProperties props+             , ValidImageWrite props '[] imgCds+             )+           => Code imgCds+           -> Code imgTexel+           -> Program i i ( Code () )+imageWrite = assign+           @( ImageTexel imgName+                :: Optic+                    '[ ImageOperands props '[], imgCds ]+                     i+                     imgTexel+            )+           NilOps++-- *** Atomic operations.++-- $atomics+-- Atomic operations on storage buffers and workgroup variables, through an+-- optic passed with a type application. The optic must focus on a scalar, e.g.+-- a member or an array element of the buffer. The run-time indices of the+-- optic come first, then the operands of the operation:+--+-- > previous <- atomicAdd @( Name "buf" :.: Name "arr" :.: AnIndex Word32 ) i v+--+-- Except for 'atomicStore', an atomic operation returns the previous value.+-- All operations are atomic at 'SPIRV.Synchronisation.Device' scope with+-- relaxed memory semantics (no ordering constraints on other memory accesses).++-- | Atomically read the value.+atomicLoad :: forall optic.+             ( GHC.Stack.HasCallStack+             , KnownOptic optic, StatefulOptic optic+             , Gettable optic, Settable optic+             , AtomicTy (Part optic)+             , Syntactic (ProgUser optic)+             , Internal (ProgUser optic) ~ AugUser optic+             )+           => ProgUser optic+atomicLoad = fromAST ( Atomic SAtomicLoad sLength ( opticSing @optic ) )++-- | Atomically write a value.+atomicStore :: forall optic.+             ( GHC.Stack.HasCallStack+             , KnownOptic optic, StatefulOptic optic+             , Gettable optic, Settable optic+             , AtomicTy (Part optic)+             , Syntactic (ProgAssigner optic)+             , Internal (ProgAssigner optic) ~ AugAssigner optic+             )+           => ProgAssigner optic+atomicStore = fromAST ( Atomic SAtomicStore sLength ( opticSing @optic ) )++-- | Atomically write a value, returning the previous value.+atomicExchange :: forall optic.+             ( GHC.Stack.HasCallStack+             , KnownOptic optic, StatefulOptic optic+             , Gettable optic, Settable optic+             , AtomicTy (Part optic)+             , Syntactic (ProgExchanger optic)+             , Internal (ProgExchanger optic) ~ AugExchanger optic+             )+           => ProgExchanger optic+atomicExchange = fromAST ( Atomic SAtomicExchange sLength ( opticSing @optic ) )++-- | Atomically write a new value if the current value equals an expected+-- value, returning the previous value. Takes the expected value, then the+-- new value.+atomicCompareExchange :: forall optic.+             ( GHC.Stack.HasCallStack+             , KnownOptic optic, StatefulOptic optic+             , Gettable optic, Settable optic+             , AtomicIntegralTy (Part optic)+             , Syntactic (ProgCompareExchanger optic)+             , Internal (ProgCompareExchanger optic) ~ AugCompareExchanger optic+             )+           => ProgCompareExchanger optic+atomicCompareExchange =+  fromAST ( Atomic SAtomicCompareExchange sLength ( opticSing @optic ) )++-- | Atomically add one, returning the previous value.+atomicIncrement :: forall optic.+             ( GHC.Stack.HasCallStack+             , KnownOptic optic, StatefulOptic optic+             , Gettable optic, Settable optic+             , AtomicIntegralTy (Part optic)+             , Syntactic (ProgUser optic)+             , Internal (ProgUser optic) ~ AugUser optic+             )+           => ProgUser optic+atomicIncrement =+  fromAST ( Atomic SAtomicIncrement sLength ( opticSing @optic ) )++-- | Atomically subtract one, returning the previous value.+atomicDecrement :: forall optic.+             ( GHC.Stack.HasCallStack+             , KnownOptic optic, StatefulOptic optic+             , Gettable optic, Settable optic+             , AtomicIntegralTy (Part optic)+             , Syntactic (ProgUser optic)+             , Internal (ProgUser optic) ~ AugUser optic+             )+           => ProgUser optic+atomicDecrement =+  fromAST ( Atomic SAtomicDecrement sLength ( opticSing @optic ) )++-- | Atomically add a value, returning the previous value.+atomicAdd :: forall optic.+             ( GHC.Stack.HasCallStack+             , KnownOptic optic, StatefulOptic optic+             , Gettable optic, Settable optic+             , AtomicTy (Part optic)+             , Syntactic (ProgExchanger optic)+             , Internal (ProgExchanger optic) ~ AugExchanger optic+             )+           => ProgExchanger optic+atomicAdd = fromAST ( Atomic SAtomicAdd sLength ( opticSing @optic ) )++-- | Atomically subtract a value, returning the previous value.+atomicSub :: forall optic.+             ( GHC.Stack.HasCallStack+             , KnownOptic optic, StatefulOptic optic+             , Gettable optic, Settable optic+             , AtomicIntegralTy (Part optic)+             , Syntactic (ProgExchanger optic)+             , Internal (ProgExchanger optic) ~ AugExchanger optic+             )+           => ProgExchanger optic+atomicSub = fromAST ( Atomic SAtomicSub sLength ( opticSing @optic ) )++-- | Atomically replace the value by the minimum of it and a given value,+-- returning the previous value.+atomicMin :: forall optic.+             ( GHC.Stack.HasCallStack+             , KnownOptic optic, StatefulOptic optic+             , Gettable optic, Settable optic+             , AtomicTy (Part optic)+             , Syntactic (ProgExchanger optic)+             , Internal (ProgExchanger optic) ~ AugExchanger optic+             )+           => ProgExchanger optic+atomicMin = fromAST ( Atomic SAtomicMin sLength ( opticSing @optic ) )++-- | Atomically replace the value by the maximum of it and a given value,+-- returning the previous value.+atomicMax :: forall optic.+             ( GHC.Stack.HasCallStack+             , KnownOptic optic, StatefulOptic optic+             , Gettable optic, Settable optic+             , AtomicTy (Part optic)+             , Syntactic (ProgExchanger optic)+             , Internal (ProgExchanger optic) ~ AugExchanger optic+             )+           => ProgExchanger optic+atomicMax = fromAST ( Atomic SAtomicMax sLength ( opticSing @optic ) )++-- | Atomically replace the value by its bitwise and with a given value,+-- returning the previous value.+atomicAnd :: forall optic.+             ( GHC.Stack.HasCallStack+             , KnownOptic optic, StatefulOptic optic+             , Gettable optic, Settable optic+             , AtomicIntegralTy (Part optic)+             , Syntactic (ProgExchanger optic)+             , Internal (ProgExchanger optic) ~ AugExchanger optic+             )+           => ProgExchanger optic+atomicAnd = fromAST ( Atomic SAtomicAnd sLength ( opticSing @optic ) )++-- | Atomically replace the value by its bitwise or with a given value,+-- returning the previous value.+atomicOr :: forall optic.+             ( GHC.Stack.HasCallStack+             , KnownOptic optic, StatefulOptic optic+             , Gettable optic, Settable optic+             , AtomicIntegralTy (Part optic)+             , Syntactic (ProgExchanger optic)+             , Internal (ProgExchanger optic) ~ AugExchanger optic+             )+           => ProgExchanger optic+atomicOr = fromAST ( Atomic SAtomicOr sLength ( opticSing @optic ) )++-- | Atomically replace the value by its bitwise exclusive or with a given+-- value, returning the previous value.+atomicXor :: forall optic.+             ( GHC.Stack.HasCallStack+             , KnownOptic optic, StatefulOptic optic+             , Gettable optic, Settable optic+             , AtomicIntegralTy (Part optic)+             , Syntactic (ProgExchanger optic)+             , Internal (ProgExchanger optic) ~ AugExchanger optic+             )+           => ProgExchanger optic+atomicXor = fromAST ( Atomic SAtomicXor sLength ( opticSing @optic ) )++--------------------------------------------------------------------------++-- | Query the length of a run-time array.+--+-- Usage:+--+-- > arrayLength @( Name "structName" :.: Name "arrayName" )+--+-- This returns the size of the run-time array, bound within the structure named @"structureName"@+-- with member field name @"arrayName"@.+--+-- Note that run-time arrays can only appear as the last structure member.+arrayLength+  :: forall optic i+  .  ( i ~ Whole optic )+  => ArrayLength (Whole optic) optic+  => Program i i (Code Word32)+arrayLength = arrayLength' @_ @_ @i @optic++class ArrayLength (i :: ProgramState) (optic :: Optic is i r) where+  arrayLength' :: Program i i ( Code Word32 )++instance+  ( empty1 ~ '[], empty2 ~ '[], r ~ RuntimeArray a+  , KnownSymbol structName, KnownNat memberIndex+  , struct ~ Has structName i+  , struct ~ Struct as+  )+  => ArrayLength i+        (          ( Field_ ( structName  :: Symbol ) :: Optic empty1 i struct )+        `ComposeO` ( Field_ ( memberIndex :: Nat    ) :: Optic empty2 struct r )+        )+  where+  arrayLength' = fromAST $ ArrayLength ( Proxy :: Proxy structName ) ( Proxy :: Proxy memberIndex )++instance+  ( empty1 ~ '[], empty2 ~ '[], r ~ RuntimeArray a+  , KnownSymbol structName, KnownNat memberIndex+  , struct ~ Has structName i+  , ( memberIndex ':-> r ) ~ StructIndexFromName memberName as+  , struct ~ Struct as+  )+  => ArrayLength i+        (          ( Field_ ( structName :: Symbol ) :: Optic empty1 i struct )+        `ComposeO` ( Field_ ( memberName :: Symbol ) :: Optic empty2 struct r )+        )+  where+  arrayLength' = fromAST $ ArrayLength ( Proxy :: Proxy structName ) ( Proxy :: Proxy memberIndex )++--------------------------------------------------------------------------+-- subgroup operations++-- Unsightly hack to convert a group operation to a `SPIR-V` word value.+groupOperationToWord32 :: SPIRV.GroupOperation -> Code Word32+groupOperationToWord32 op = MkID ( ID (SPIRV.groupOperationToWord32 op), primTy @Word32 )++class (Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp)+      => HasGroupAdd scope groupOp a ( i :: ProgramState ) where+  groupAdd :: Code a -> Program i i ( Code a )++class (Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp)+      => HasGroupMul scope groupOp a ( i :: ProgramState ) where+  groupMul :: Code a -> Program i i ( Code a )  ++class (Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp)+      => HasGroupMinMax scope groupOp a ( i :: ProgramState ) where+  groupMin :: Code a -> Program i i ( Code a )+  groupMax :: Code a -> Program i i ( Code a )++class (Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp)+      => HasGroupBitwise scope groupOp a ( i :: ProgramState ) where  +  groupBitwiseAnd :: Code a -> Program i i ( Code a )+  groupBitwiseOr  :: Code a -> Program i i ( Code a )+  groupBitwiseXor :: Code a -> Program i i ( Code a )++class (Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp)+      => HasGroupLogic scope groupOp a ( i :: ProgramState ) where  +  groupLogicalAnd :: Code a -> Program i i ( Code a )+  groupLogicalOr  :: Code a -> Program i i ( Code a )+  groupLogicalXor :: Code a -> Program i i ( Code a )++instance ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp+         , ScalarTy a, AdditiveMonoid a+         )+      => HasGroupAdd scope groupOp a i where+  groupAdd = primOp @'(i, a) @SPIRV.GroupAdd+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)++instance ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp+         , ScalarTy a, Semiring a+         )+      => HasGroupMul scope groupOp a i where+  groupMul = primOp @'(i, a) @SPIRV.GroupMul+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)++instance ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp+         , ScalarTy a, Ord a+         )+      => HasGroupMinMax scope groupOp a i where+  groupMin = primOp @'(i, a) @SPIRV.GroupMin+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)+  groupMax = primOp @'(i, a) @SPIRV.GroupMax+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)+  +instance ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp+         , ScalarTy a, Bits a+         )+      => HasGroupBitwise scope groupOp a i where+  groupBitwiseAnd = primOp @'(i,a) @SPIRV.GroupBitwiseAnd+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)+  groupBitwiseOr  = primOp @'(i,a) @SPIRV.GroupBitwiseOr+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)+  groupBitwiseXor = primOp @'(i,a) @SPIRV.GroupBitwiseXor+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)++instance ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp+         , b ~ Bool+         )+      => HasGroupLogic scope groupOp b i where+  groupLogicalAnd = primOp @i @SPIRV.GroupLogicalAnd+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)+  groupLogicalOr  = primOp @i @SPIRV.GroupLogicalOr+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)+  groupLogicalXor = primOp @i @SPIRV.GroupLogicalXor+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)++instance {-# OVERLAPPING #-}+      ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp+      , ScalarTy a, AdditiveMonoid a+      , KnownNat n+      )+    => HasGroupAdd scope groupOp ( V n a ) i where+  groupAdd = primOp @'(i, V n a) @('Vectorise SPIRV.GroupAdd)+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)+  +instance {-# OVERLAPPING #-}+      ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp+      , ScalarTy a, Semiring a+      , KnownNat n+      )+    => HasGroupMul scope groupOp ( V n a ) i where+  groupMul = primOp @'(i, V n a) @('Vectorise SPIRV.GroupMul)+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)++instance {-# OVERLAPPING #-}+      ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp+      , ScalarTy a, Ord a+      , KnownNat n+      )+    => HasGroupMinMax scope groupOp ( V n a ) i where+  groupMin = primOp @'(i, V n a) @('Vectorise SPIRV.GroupMin)+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)+  groupMax = primOp @'(i, V n a) @('Vectorise SPIRV.GroupMax)+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)+  +instance {-# OVERLAPPING #-}+      ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp+      , ScalarTy a, Bits a+      , KnownNat n+      )+    => HasGroupBitwise scope groupOp ( V n a ) i where+  groupBitwiseAnd = primOp @'(i, V n a) @('Vectorise SPIRV.GroupBitwiseAnd)+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)+  groupBitwiseOr  = primOp @'(i, V n a) @('Vectorise SPIRV.GroupBitwiseOr)+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)+  groupBitwiseXor = primOp @'(i, V n a) @('Vectorise SPIRV.GroupBitwiseXor)+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)++instance {-# OVERLAPPING #-}+      ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp+      , KnownNat n, b ~ Bool+      )+    => HasGroupLogic scope groupOp (V n b) i where+  groupLogicalAnd = primOp @'(i,n) @('Vectorise SPIRV.GroupLogicalAnd)+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)+  groupLogicalOr  = primOp @'(i,n) @('Vectorise SPIRV.GroupLogicalOr)+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)+  groupLogicalXor = primOp @'(i,n) @('Vectorise SPIRV.GroupLogicalXor)+    (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32)+    (groupOperationToWord32 $ knownValue @groupOp)++--------------------------------------------------------------------------+-- geometry shader primitive instructions++-- | Geometry shader: write the current output values at the current vertex index.+emitVertex :: forall (i :: ProgramState)+           . ( ExecutionContext i ~ Just SPIRV.Geometry )+           => Program i i ( Code () )+emitVertex = primOp @i @SPIRV.EmitGeometryVertex++-- | Geometry shader: end the current primitive and pass to the next one.+endPrimitive :: forall (i :: ProgramState)+             .  ( ExecutionContext i ~ Just SPIRV.Geometry )+             => Program i i ( Code () )+endPrimitive = primOp @i @SPIRV.EndGeometryPrimitive++--------------------------------------------------------------------------+-- memory synchronisation primitive instructions++-- | Control barrier: wait for other invocations to reach the current point of execution.+--+-- Can also act as a memory barrier if a memory synchronisation scope is specified.+controlBarrier :: forall (i :: ProgramState)+               .  SPIRV.SynchronisationScope+               -> Maybe ( SPIRV.SynchronisationScope, SPIRV.MemorySemantics )+               -> Program i i ( Code () )+controlBarrier controlScope memScope+  = primOp @i @SPIRV.ControlSync+      ( Lit $ controlScopeWord32 :: Code Word32 )+      ( Lit $ fromMaybe controlScopeWord32 $ SPIRV.synchronisationScope   . fst <$> memScope :: Code Word32 )+      --                ^^^^^^^^^^^^^^^^^^+      -- can get validation errors if this is set to 0 (which is "CrossDevice" scope)+      -- even though this field is supposed to be ignored if the memory semantics argument is 0+      ( Lit $ fromMaybe 0                  $ SPIRV.memorySemanticsBitmask . snd <$> memScope :: Code Word32 )+    where+      controlScopeWord32 :: Word32+      controlScopeWord32 = SPIRV.synchronisationScope controlScope++-- | Memory barrier: ensure ordering on memory accesses.+memoryBarrier :: forall (i :: ProgramState)+               .  SPIRV.SynchronisationScope+               -> SPIRV.MemorySemantics+               -> Program i i ( Code () )+memoryBarrier memScope memSem+  = primOp @i @SPIRV.MemorySync+      ( Lit $ SPIRV.synchronisationScope   memScope :: Code Word32 )+      ( Lit $ SPIRV.memorySemanticsBitmask memSem   :: Code Word32 )++--------------------------------------------------------------------------+-- type synonyms for use/assign++type family ProgListVariadic+              ( is :: [Type] )+              ( s  :: ProgramState )+              ( a  :: Type  )+            = ( r  :: Type  )+            | r -> is s a where+  ProgListVariadic '[]         s a = Program s s (Code a)+  ProgListVariadic ( i ': is ) s a = Code i -> ProgListVariadic is s a+++-- recall (defined in FIR.Syntax.Optics):+-- type User     (g :: Optic is s a) = ListVariadicIx is                s a+-- type Assigner (g :: Optic is s a) = ListVariadicIx (is `Postpend` s) s ()++type ProgUser     (optic :: Optic is s a) = ProgListVariadic  is               s a+type ProgAssigner (optic :: Optic is s a) = ProgListVariadic (is `Postpend` a) s ()+type ProgExchanger (optic :: Optic is s a)+  = ProgListVariadic (is `Postpend` a) s a+type ProgCompareExchanger (optic :: Optic is s a)+  = ProgListVariadic (is `Postpend` a `Postpend` a) s a++--------------------------------------------------------------------------+-- modifying++type family ProgVariadicModifier+              ( is :: [Type] )+              ( s  :: ProgramState )+              ( a  :: Type )+            = ( r  :: Type )+            | r -> is s a+            where+  ProgVariadicModifier '[]       s a = (Code a -> Code a) -> Program s s (Code ())+  ProgVariadicModifier (i ': is) s a = Code i -> ProgVariadicModifier is s a++type ProgModifier (optic :: Optic is s a) = ProgVariadicModifier is s a++-- | Modify a value with an optic.+--+-- Like @modifying@ from the lens library, except the optic needs to be passed with a type application.+modifying+    :: forall optic.+       ( GHC.Stack.HasCallStack+       , KnownOptic optic+       , StatefulOptic optic+       , Settable optic+       , Gettable optic+       , Syntactic (ProgUser optic)+       , Internal (ProgUser optic) ~ AugUser optic+       , Syntactic (ProgAssigner optic)+       , Internal (ProgAssigner optic) ~ AugAssigner optic+       , Modifier (Indices optic) (Whole optic) (Part optic)+       )+    => ProgModifier optic+modifying+  = modifier @(Indices optic) @(Whole optic) @(Part optic)+      ( use    @optic )+      ( assign @optic )++class Modifier is s a where+  modifier :: ProgListVariadic      is               s a+           -> ProgListVariadic     (is `Postpend` a) s ()+           -> ProgVariadicModifier  is               s a++instance Modifier '[] s a where+  modifier used assigned f+    = ixFmap f used Indexed.>>= assigned++instance Modifier is s a => Modifier (i ': is) s a where+  modifier used assigned i+    = modifier @is @s @a (used i) (assigned i)++--------------------------------------------------------------------------+-- Instances for codensity representation++-- Logical operations++-- $logical+-- Instances for:+--+-- 'Boolean',+--+-- 'Eq', 'Ord' (note: not the "Prelude" type classes).+instance Boolean b => Boolean (Program i i b) where+  true  = ixPure   true+  false = ixPure   false+  (&&)  = ixLiftA2 (&&)+  (||)  = ixLiftA2 (||)+  not   = ixFmap   not++instance ( PrimTy a, Eq a, Logic a ~ Bool+         , i ~ j+         , r ~ Code a+         )+  => Eq (Program i j r) where+  type Logic (Program i j r) = Program i i (Code Bool)+  (==) = ixLiftA2 (==)+  (/=) = ixLiftA2 (/=)++instance ( ScalarTy a, Ord a, Logic a ~ Bool+         , i ~ j+         , r ~ Code a+         )+  => Ord (Program i j r) where+  (<=) = ixLiftA2 (<=)+  (>=) = ixLiftA2 (>=)+  (<)  = ixLiftA2 (<)+  (>)  = ixLiftA2 (>)+  min  = ixLiftA2 min+  max  = ixLiftA2 max++-- * Bitwise operations+--+-- $bitwise+-- Instances for:+--+-- 'Bits', 'BitShift' (note: not 'Data.Bits.Bits').++instance ( ScalarTy a+         , r ~ Code a+         , j ~ i+         , Bits a+         ) => Bits (Program i j r) where+  (.&.) = ixLiftA2 (.&.)+  (.|.) = ixLiftA2 (.|.)+  xor   = ixLiftA2 xor+  complement = ixFmap complement+  zeroBits   = ixPure zeroBits+  bitReverse = ixFmap bitReverse++instance ( ScalarTy a, ScalarTy s+         , BitShift '(a,s)+         , x ~ Code a+         , t ~ Code s+         , j ~ i, i' ~ i, j' ~ i+         )+  => BitShift '(Program i j x, Program i' j' t) where+  shiftL = ixLiftA2 shiftL+  shiftR = ixLiftA2 shiftR++instance ( ScalarTy a, ScalarTy s+         , BitShift '(a,s)+         , x ~ Code a+         , i ~ j+         )+  => BitShift '(Program i j x, Code s) where+  shiftL a s = shiftL @'(Program i j x, Program i i (Code s)) a (ixPure s)+  shiftR a s = shiftR @'(Program i j x, Program i i (Code s)) a (ixPure s)++instance (ScalarTy a, ScalarTy b, BitCast a b, i1 ~ j1, i2 ~ j2, i1 ~ i2, x ~ Code a, y ~ Code b)+  => BitCast (Program i1 j1 x) (Program i2 j2 y) where+  bitcast = ixFmap bitcast++-- Numeric operations++-- $numeric+-- Instances for:+--+-- 'AdditiveMonoid', 'AdditiveGroup', 'Signed',+--+-- 'Semiring', 'Ring',+--+-- 'DivisionRing', 'Archimedean' (Archimedean ordered group),+--+-- 'Floating', 'RealFloat' (note: not the "Prelude" type classes).+instance (ScalarTy a, AdditiveMonoid a, j ~ i) => AdditiveMonoid (Program i j (Code a)) where+  (+)    = ixLiftA2 (+)+  zero   = ixPure zero+  fromInteger = ixPure . fromInteger+instance (ScalarTy a, Semiring a, j ~ i) => Semiring (Program i j (Code a)) where+  (*)    = ixLiftA2 (*)+instance (ScalarTy a, CancellativeAdditiveMonoid a, j ~ i) => CancellativeAdditiveMonoid (Program i j (Code a)) where+  (-)    = ixLiftA2 (-)+instance (ScalarTy a, AdditiveGroup a, j ~ i) => AdditiveGroup (Program i j (Code a)) where+  negate = ixFmap negate+instance (ScalarTy a, Signed a, j ~ i) => Signed (Program i j (Code a)) where+  abs    = ixFmap abs+  signum = ixFmap signum+instance (ScalarTy a, DivisionRing a, j ~ i) => DivisionRing (Program i j (Code a)) where+  (/)    = ixLiftA2 (/)+  fromRational = ixPure . fromRational+instance ( ScalarTy a+         , Archimedean a+         , Archimedean (Code a)+         , Logic a ~ Bool+         , j ~ i+         ) => Archimedean (Program i j (Code a)) where+  mod    = ixLiftA2 mod+  rem    = ixLiftA2 rem+  div    = ixLiftA2 div++instance (ScalarTy a, Floating a, j ~ i) => Floating (Program i j (Code a)) where+  pi      = ixPure pi+  exp     = ixFmap exp+  log     = ixFmap log+  sqrt    = ixFmap sqrt+  invSqrt = ixFmap invSqrt+  sin     = ixFmap sin+  cos     = ixFmap cos+  tan     = ixFmap tan+  asin    = ixFmap asin+  acos    = ixFmap acos+  atan    = ixFmap atan+  sinh    = ixFmap sinh+  cosh    = ixFmap cosh+  tanh    = ixFmap tanh+  asinh   = ixFmap asinh+  acosh   = ixFmap acosh+  atanh   = ixFmap atanh+  (**)    = ixLiftA2 (**)++instance (ScalarTy a, RealFloat a, Eq a, Logic a ~ Bool, j ~ i) => RealFloat (Program i j (Code a)) where+  atan2      = ixLiftA2 atan2+  isNaN      = ixFmap   isNaN+  isInfinite = ixFmap   isInfinite++-- Numeric conversions++-- $conversions+-- Instance for 'Convert', 'Rounding'.+instance ( ScalarTy a, ScalarTy b+         , Convert '(Code a, Code b)+         , j ~ i, k ~ i, l ~ i+         )+         => Convert '( Program i j (Code a)+                     , Program k l (Code b)+                     ) where+  convert = ixFmap ( convert @'(Code a, Code b) )++instance ( ScalarTy a, ScalarTy b, Rounding '(Code a, Code b)+         , j ~ i, k ~ i, l ~ i+         )+         => Rounding '( Program i j (Code a)+                      , Program k l (Code b)+                      ) where+  truncate = ixFmap truncate+  round    = ixFmap round+  floor    = ixFmap floor+  ceiling  = ixFmap ceiling++-- Vectors++-- $vectors+-- Instances for:+--+-- 'Semimodule', 'LinearModule', 'Inner', 'Cross'.+instance (ScalarTy a, Semiring a, j ~ i) => Semimodule Nat (Program i j (Code (V 0 a))) where+  type Scalar   (Program i j (Code (V 0 a)))       = Program i j (Code a)+  type OfDim    (Program i j (Code (V 0 a))) Nat n = Program i j (Code (V n a))+  type ValidDim (Program i j (Code (V 0 a))) Nat n = KnownNat n++  (^+^) = ixLiftA2 (^+^)+  (^*)  = ixLiftA2 (^*)++instance (ScalarTy a, Ring a, j ~ i) => LinearModule Nat (Program i j (Code (V 0 a))) where+  (^-^) = ixLiftA2 (^-^)++instance (ScalarTy a, Floating a, j ~ i) => Inner Nat (Program i j (Code (V 0 a))) where+  (^.^) = ixLiftA2 (^.^)+  normalise = ixFmap normalise++instance (ScalarTy a, Floating a, j ~ i) => Cross Nat (Program i j (Code (V 0 a))) where+  type CrossDim (Program i j (Code (V 0 a))) Nat n = ( n ~ 3 )+  cross = ixLiftA2 cross++-- Matrices++-- $matrices+-- Instance for 'Matrix'.++type instance VectorOf (Program i j (Code (M 0 0 a))) = Program i j (Code (V 0 a))++instance (ScalarTy a, Floating a, j ~ i) => Matrix Nat (Program i j (Code (M 0 0 a))) where+  type OfDims (Program i j (Code (M 0 0 a))) Nat '(m,n) = Program i j (Code (M m n a))++  diag  = ixFmap diag+  konst = ixFmap konst++  transpose   = ixFmap transpose+  inverse     = ixFmap inverse+  determinant = ixFmap determinant++  (!+!) = ixLiftA2 (!+!)+  (!-!) = ixLiftA2 (!-!)+  (!*!) = ixLiftA2 (!*!)+  (^*!) = ixLiftA2 (^*!)+  (!*^) = ixLiftA2 (!*^)+  (!*)  = ixLiftA2 (!*)+++instance TypeError (     Text "Failable pattern detected in 'do' block, but only unfailable patterns are supported."+                    :$$: Text ""+                    :$$: Text "As inference of pattern failability is sometimes patchy,"+                    :$$: Text "consider using an irrefutable pattern instead, such as:"+                    :$$: Text ""+                    :$$: Text "    ~(Vec4 x y z w) <- get @\"position\""+                    :$$: Text ""+                    :$$: Text "instead of"+                    :$$: Text ""+                    :$$: Text "    Vec4 x y z w <- get @\"position\""+                    :$$: Text ""+                    ) => MonadIxFail (Codensity AST) where+  fail = error "'fail': irrefutable pattern failed to match."
+ src/FIR/Syntax/RayTracing.hs view
@@ -0,0 +1,472 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TypeOperators       #-}++{-|+Module: FIR.Syntax.RayTracing++Ray-tracing and ray-query operations, such as 'traceRay', 'reportIntersection', 'executeCallable'...+-}++module FIR.Syntax.RayTracing where++-- base+import Data.Kind+  ( Type )+import Data.Proxy+  ( Proxy(..) )+import Data.Word+  ( Word32, Word64 )+import GHC.TypeLits+  ( Symbol )+import Unsafe.Coerce+  ( unsafeCoerce )++-- fir+import Data.Type.Known+  ( Known, knownValue )+import Data.Type.Map+  ( Lookup )+import FIR.AST+import FIR.AST.Type+  ( AugType(..), Eff )+import FIR.Module+  ( Program )+import FIR.Prim.RayTracing+  ( AccelerationStructure+  , RayQuery(..), RayQueryProceedState(..)+  , RayQueryCandidateIntersection(..), RayQueryCommittedIntersection(..)+  , IntersectionType(..)+  )+import FIR.Prim.Types+  ( PrimTy )+import FIR.ProgramState+  ( ProgramState, ExecutionContext, RayQueries )+import FIR.Syntax.Program+  ( ) -- Syntactic instance for 'Program'+import FIR.Validation.RayTracing+  ( CanTraceRay, CanExecuteCallable+  , NewRayQuery, RayQueryProceed, RayQueryCandidateState, RayQueryCommittedState+  , Terminate, CanGenerateIntersection, CanConfirmIntersection+  , HasRayQuery, CanGetIntersectionT, HasSomeIntersection, HasSomeTriangleIntersection+  )+import Math.Linear+  ( V, M )+import qualified SPIRV.Operation as SPIRV.Op+import qualified SPIRV.PrimOp    as SPIRV+  ( RayPrimOp(..) )+import qualified SPIRV.Stage     as SPIRV+  ( AnyHit, Intersection )++--------------------------------------------------------------------------+-- ray tracing instructions++data RayInfo+  = RayInfo+  { rayFlags     :: Code Word32+  , rayOrigin    :: Code ( V 3 Float )+  , rayDirection :: Code ( V 3 Float )+  , rayTMin      :: Code Float+  , rayTMax      :: Code Float+  , cullMask     :: Code Word32 -- ^ Only the least significant 8 bits are used.+  }++data RayShaderInfo+  = RayShaderInfo+  { bindingTableOffset :: Code Word32 -- ^ Only the least significant 4 bits are used.+  , bindingTableStride :: Code Word32 -- ^ Only the least significant 4 bits are used.+  , missShaderIndex    :: Code Word32 -- ^ Only the least significant 16 bits are used.+  }++traceRay+  :: forall+      ( rayPayloadName :: Symbol       )+      ( i              :: ProgramState )+  . ( Known Symbol rayPayloadName+    , CanTraceRay  rayPayloadName i+    )+  => Code AccelerationStructure+  -> RayInfo+  -> RayShaderInfo+  -> Program i i ( Code () )+traceRay accelerationStructure ( RayInfo { .. } ) ( RayShaderInfo { .. } ) = fromAST $+  TraceRay+    { traceRayAccelerationStructure = accelerationStructure+    , traceRayRayFlags              = rayFlags+    , traceRayCullMask              = cullMask+    , traceRaySBTOffset             = bindingTableOffset+    , traceRaySBTStride             = bindingTableStride+    , traceRayMissIndex             = missShaderIndex+    , traceRayRayOrigin             = rayOrigin+    , traceRayRayTMin               = rayTMin+    , traceRayRayDirection          = rayDirection+    , traceRayRayTMax               = rayTMax+    , traceRayPayloadID             = knownValue @rayPayloadName+    }++reportIntersection +  :: forall (i :: ProgramState)+  .  ( ExecutionContext i ~ Just SPIRV.Intersection )+  => Code Float  -- ^ HitT+  -> Code Word32 -- ^ Hit kind.+  -> Program i i ( Code Bool )+reportIntersection = primOp @i @SPIRV.RT_ReportIntersection++ignoreIntersection+  :: forall (i :: ProgramState)+  .  ( ExecutionContext i ~ Just SPIRV.AnyHit )+  => Program i i ( Code () )+ignoreIntersection = primOp @i @SPIRV.RT_IgnoreIntersection++terminateRay+  :: forall (i :: ProgramState)+  .  ( ExecutionContext i ~ Just SPIRV.AnyHit )+  => Program i i ( Code () )+terminateRay = primOp @i @SPIRV.RT_TerminateRay++executeCallable+  :: forall+        ( callableDataName :: Symbol       )+        ( i                :: ProgramState )+  . ( Known Symbol callableDataName+    , CanExecuteCallable callableDataName i+    )+  => Code Word32 -- ^ Index into the shader binding table.+  -> Program i i ( Code () )+executeCallable bindingTableOffset = fromAST $+  ExecuteCallable bindingTableOffset ( knownValue @callableDataName )++accelerationStructureFromDeviceAddress :: Code Word64 -> Code AccelerationStructure+accelerationStructureFromDeviceAddress+  = primOp @'() @'SPIRV.RT_AccelerationStructureFromDeviceAddress++--------------------------------------------------------------------------+-- ray query instructions++initialize+  :: forall+       ( rayQuery :: Symbol       )+       ( i        :: ProgramState )+  .  ( Known Symbol rayQuery )+  => Code AccelerationStructure+  -> RayInfo+  -> Program i ( NewRayQuery rayQuery i ) ( Code () )+initialize accelStructure ( RayInfo {..} ) = fromAST $+  RayQueryInitialize+    { rayQueryRayQueryName          = RayQuery (knownValue @rayQuery)+    , rayQueryAccelerationStructure = accelStructure+    , rayQueryRayFlags              = rayFlags+    , rayQueryCullMask              = cullMask+    , rayQueryRayOrigin             = rayOrigin+    , rayQueryRayTMin               = rayTMin+    , rayQueryRayDirection          = rayDirection+    , rayQueryRayTMax               = rayTMax+    }++ifProceeding+  :: forall+      ( rayQuery :: Symbol       )+      ( a        :: Type         )+      ( i        :: ProgramState )+      ( j1       :: ProgramState )+      ( j2       :: ProgramState )+  .  ( Known Symbol rayQuery, PrimTy a )+  => Program ( RayQueryProceed rayQuery ( Incomplete Nothing ) i ) j1 ( Code a )+  -> Program ( RayQueryProceed rayQuery     Complete           i ) j2 ( Code a )+  -> Program i i ( Code a )+ifProceeding proceed don't =+  fromAST+    ( IfM :$ ( RayQueryPrimOp (Proxy @Bool) SPIRV.Op.RayQueryProceed ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Eff i i Bool ) )+          :$ ( unsafeCoerce $ toAST proceed )+          :$ ( unsafeCoerce $ toAST don't   )+    )++withCandidateIntersectionType+  :: forall+      ( rayQuery :: Symbol       )+      ( a        :: Type         )+      ( i        :: ProgramState )+      ( j1       :: ProgramState )+      ( j2       :: ProgramState )+  .  ( Known Symbol rayQuery, PrimTy a )+  => Program ( RayQueryCandidateState rayQuery TriangleCandidateIntersection i ) j1 ( Code a )+  -> Program ( RayQueryCandidateState rayQuery     AABBCandidateIntersection i ) j2 ( Code a )+  -> Program i i ( Code a )+withCandidateIntersectionType withTriangle withAABB =+  fromAST+    ( SwitchM+        ( RayQueryPrimOp (Proxy @Word32) SPIRV.Op.RayQueryGetIntersectionType ( RayQuery $ knownValue @rayQuery ) ( Just Candidate ) :: AST ( Eff i i Word32 ) )+        ( unsafeCoerce $ toAST withTriangle )+        [ ( 1, unsafeCoerce $ toAST withAABB ) ]+    )++withCommittedIntersectionType+  :: forall+      ( rayQuery :: Symbol       )+      ( a        :: Type         )+      ( i        :: ProgramState )+      ( j1       :: ProgramState )+      ( j2       :: ProgramState )+      ( j3       :: ProgramState )+  .  ( Known Symbol rayQuery, PrimTy a )+  => Program ( RayQueryCommittedState rayQuery NoIntersection        i ) j1 ( Code a )+  -> Program ( RayQueryCommittedState rayQuery TriangleIntersection  i ) j2 ( Code a )+  -> Program ( RayQueryCommittedState rayQuery GeneratedIntersection i ) j3 ( Code a )+  -> Program i i ( Code a )+withCommittedIntersectionType noInter tri gen =+  fromAST+    ( SwitchM+        ( RayQueryPrimOp (Proxy @Word32) SPIRV.Op.RayQueryGetIntersectionType ( RayQuery $ knownValue @rayQuery ) ( Just Committed ) :: AST ( Eff i i Word32 ) )+        ( unsafeCoerce $ toAST noInter )+        [ ( 1, unsafeCoerce $ toAST tri )+        , ( 2, unsafeCoerce $ toAST gen )+        ]+    )++terminate+  :: forall+       ( rayQuery :: Symbol       )+       ( i        :: ProgramState )+  .  ( Known Symbol rayQuery )+  => Program i ( Terminate rayQuery i ) ( Code () )+terminate = fromAST . ( unsafeCoerce :: AST ( Eff i i () ) -> AST ( Eff i ( Terminate rayQuery i ) () ) ) $+  ( RayQueryPrimOp (Proxy @()) SPIRV.Op.RayQueryTerminate ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Eff i i () ) )++generateIntersection+  :: forall+       ( rayQuery :: Symbol       )+       ( i        :: ProgramState )+  .  ( Known Symbol rayQuery+     , CanGenerateIntersection rayQuery ( Lookup rayQuery ( RayQueries i ) )+     )+  => Code Float -> Program i i ( Code () )+generateIntersection = fromAST+  ( RayQueryPrimOp (Proxy @()) SPIRV.Op.RayQueryGenerateIntersection ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Val Float :--> Eff i i () ) )++confirmIntersection+  :: forall+       ( rayQuery :: Symbol       )+       ( i        :: ProgramState )+  .  ( Known Symbol rayQuery+     , CanConfirmIntersection rayQuery ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code () )+confirmIntersection = fromAST+  ( RayQueryPrimOp (Proxy @()) SPIRV.Op.RayQueryConfirmIntersection ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Eff i i () ) )++getRayTMin+  :: forall+       ( rayQuery :: Symbol       )+       ( i        :: ProgramState )+  .  ( Known Symbol rayQuery+     , HasRayQuery "getRayTMin" rayQuery ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code Float )+getRayTMin = fromAST+  ( RayQueryPrimOp (Proxy @Float) SPIRV.Op.RayQueryGetRayTMin ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Eff i i Float ) )++getRayFlags+  :: forall+       ( rayQuery :: Symbol       )+       ( i        :: ProgramState )+  .  ( Known Symbol rayQuery+     , HasRayQuery "getRayFlags" rayQuery ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code Word32 )+getRayFlags = fromAST+  ( RayQueryPrimOp (Proxy @Word32) SPIRV.Op.RayQueryGetRayFlags ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Eff i i Word32 ) )++getWorldRayDirection+  :: forall+       ( rayQuery :: Symbol       )+       ( i        :: ProgramState )+  .  ( Known Symbol rayQuery+     , HasRayQuery "getWorldRayDirection" rayQuery ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code ( V 3 Float ) )+getWorldRayDirection = fromAST+  ( RayQueryPrimOp (Proxy @(V 3 Float)) SPIRV.Op.RayQueryGetWorldRayDirection ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Eff i i ( V 3 Float ) ) )++getWorldRayOrigin+  :: forall+       ( rayQuery :: Symbol       )+       ( i        :: ProgramState )+  .  ( Known Symbol rayQuery+     , HasRayQuery "getWorldRayOrigin" rayQuery ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code ( V 3 Float ) )+getWorldRayOrigin = fromAST+  ( RayQueryPrimOp (Proxy @(V 3 Float)) SPIRV.Op.RayQueryGetWorldRayOrigin ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Eff i i ( V 3 Float ) ) )++getIntersectionCandidateAABBOpaque+  :: forall+       ( rayQuery :: Symbol       )+       ( i        :: ProgramState )+  .  ( Known Symbol rayQuery+     , HasRayQuery "getIntersectionCandidateAABBOpaque" rayQuery ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code Bool )+getIntersectionCandidateAABBOpaque = fromAST+  ( RayQueryPrimOp (Proxy @Bool) SPIRV.Op.RayQueryGetIntersectionCandidateAABBOpaque ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Eff i i Bool ) )++getIntersectionT+  :: forall+       ( rayQuery :: Symbol           )+       ( interTy  :: IntersectionType )+       ( i        :: ProgramState     )+  .  ( Known Symbol rayQuery+     , Known IntersectionType interTy+     , CanGetIntersectionT rayQuery interTy ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code Float )+getIntersectionT = fromAST+  ( RayQueryPrimOp (Proxy @Float) SPIRV.Op.RayQueryGetIntersectionT ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i Float ) )++getIntersectionInstanceCustomIndex+  :: forall+       ( rayQuery :: Symbol           )+       ( interTy  :: IntersectionType )+       ( i        :: ProgramState     )+  .  ( Known Symbol rayQuery+     , Known IntersectionType interTy+     , HasSomeIntersection "getIntersectionInstanceCustomIndex" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code Word32 )+getIntersectionInstanceCustomIndex = fromAST+  ( RayQueryPrimOp (Proxy @Word32) SPIRV.Op.RayQueryGetIntersectionInstanceCustomIndex ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i Word32 ) )++getIntersectionInstanceId+  :: forall+       ( rayQuery :: Symbol           )+       ( interTy  :: IntersectionType )+       ( i        :: ProgramState     )+  .  ( Known Symbol rayQuery+     , Known IntersectionType interTy+     , HasSomeIntersection "getIntersectionInstanceId" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code Word32 )+getIntersectionInstanceId = fromAST+  ( RayQueryPrimOp (Proxy @Word32) SPIRV.Op.RayQueryGetIntersectionInstanceId ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i Word32 ) )++getIntersectionInstanceShaderBindingTableRecordOffset+  :: forall+       ( rayQuery :: Symbol           )+       ( interTy  :: IntersectionType )+       ( i        :: ProgramState     )+  .  ( Known Symbol rayQuery+     , Known IntersectionType interTy+     , HasSomeIntersection "getIntersectionInstanceShaderBindingTableRecordOffset" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code Word32 )+getIntersectionInstanceShaderBindingTableRecordOffset = fromAST+  ( RayQueryPrimOp (Proxy @Word32) SPIRV.Op.RayQueryGetIntersectionInstanceShaderBindingTableRecordOffset ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i Word32 ) )++getIntersectionGeometryIndex+  :: forall+       ( rayQuery :: Symbol           )+       ( interTy  :: IntersectionType )+       ( i        :: ProgramState     )+  .  ( Known Symbol rayQuery+     , Known IntersectionType interTy+     , HasSomeIntersection "getIntersectionGeometryIndex" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code Word32 )+getIntersectionGeometryIndex = fromAST+  ( RayQueryPrimOp (Proxy @Word32) SPIRV.Op.RayQueryGetIntersectionGeometryIndex ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i Word32 ) )++getIntersectionPrimitiveIndex+  :: forall+       ( rayQuery :: Symbol           )+       ( interTy  :: IntersectionType )+       ( i        :: ProgramState     )+  .  ( Known Symbol rayQuery+     , Known IntersectionType interTy+     , HasSomeIntersection "getIntersectionPrimitiveIndex" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code Word32 )+getIntersectionPrimitiveIndex = fromAST+  ( RayQueryPrimOp (Proxy @Word32) SPIRV.Op.RayQueryGetIntersectionPrimitiveIndex ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i Word32 ) )++getIntersectionObjectRayDirection+  :: forall+       ( rayQuery :: Symbol           )+       ( interTy  :: IntersectionType )+       ( i        :: ProgramState     )+  .  ( Known Symbol rayQuery+     , Known IntersectionType interTy+     , HasSomeIntersection "getIntersectionObjectRayDirection" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code ( V 3 Float ) )+getIntersectionObjectRayDirection = fromAST+  ( RayQueryPrimOp (Proxy @(V 3 Float)) SPIRV.Op.RayQueryGetIntersectionObjectRayDirection ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i ( V 3 Float ) ) )++getIntersectionObjectRayOrigin+  :: forall+       ( rayQuery :: Symbol           )+       ( interTy  :: IntersectionType )+       ( i        :: ProgramState     )+  .  ( Known Symbol rayQuery+     , Known IntersectionType interTy+     , HasSomeIntersection "getIntersectionObjectRayOrigin" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code ( V 3 Float ) )+getIntersectionObjectRayOrigin = fromAST+  ( RayQueryPrimOp (Proxy @(V 3 Float)) SPIRV.Op.RayQueryGetIntersectionObjectRayOrigin ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i ( V 3 Float ) ) )++getIntersectionObjectToWorld+  :: forall+       ( rayQuery :: Symbol           )+       ( interTy  :: IntersectionType )+       ( i        :: ProgramState     )+  .  ( Known Symbol rayQuery+     , Known IntersectionType interTy+     , HasSomeIntersection "getIntersectionObjectToWorld" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code ( M 3 4 Float ) )+getIntersectionObjectToWorld = fromAST+  ( RayQueryPrimOp (Proxy @( M 3 4 Float)) SPIRV.Op.RayQueryGetIntersectionObjectToWorld( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i ( M 3 4 Float ) ) )++getIntersectionWorldToObject+  :: forall+       ( rayQuery :: Symbol           )+       ( interTy  :: IntersectionType )+       ( i        :: ProgramState     )+  .  ( Known Symbol rayQuery+     , Known IntersectionType interTy+     , HasSomeIntersection "getIntersectionWorldToObject" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code ( M 3 4 Float ) )+getIntersectionWorldToObject = fromAST+  ( RayQueryPrimOp (Proxy @( M 3 4 Float)) SPIRV.Op.RayQueryGetIntersectionWorldToObject ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i ( M 3 4 Float ) ) )++getIntersectionBarycentrics+  :: forall+       ( rayQuery :: Symbol           )+       ( interTy  :: IntersectionType )+       ( i        :: ProgramState     )+  .  ( Known Symbol rayQuery+     , Known IntersectionType interTy+     , HasSomeTriangleIntersection "getIntersectionBarycentrics" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code ( V 2 Float ) )+getIntersectionBarycentrics = fromAST+  ( RayQueryPrimOp (Proxy @(V 2 Float)) SPIRV.Op.RayQueryGetIntersectionBarycentrics ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i ( V 2 Float ) ) )++getIntersectionFrontFace+  :: forall+       ( rayQuery :: Symbol           )+       ( interTy  :: IntersectionType )+       ( i        :: ProgramState     )+  .  ( Known Symbol rayQuery+     , Known IntersectionType interTy+     , HasSomeTriangleIntersection "getIntersectionFrontFace" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) )+     )+  => Program i i ( Code Bool )+getIntersectionFrontFace = fromAST+  ( RayQueryPrimOp (Proxy @Bool) SPIRV.Op.RayQueryGetIntersectionFrontFace ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i Bool ) )
+ src/FIR/Syntax/Swizzle.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PatternSynonyms        #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeAbstractions #-}++{-|+Module: FIR.Syntax.Swizzle++A swizzle is a way of remapping components of a vector, e.g.:++> > view @(Swizzle "xyxz") (V3 1.0 2.0 3.0)+> V4 1.0 2.0 1.0 3.0++This is a convenience layer around the general type-level optics machinery+defined in "Control.Type.Optic", and more specifically a wrapper+around product optics, as @Swizzle "xyxz"@ desugars to the product optic++> Prod ( Index 0 :*: Index 1 :*: Index 0 :*: Index 2 :*: EndProd )++The purpose of this module is simply to implement this desugaring.+-}++module FIR.Syntax.Swizzle+  ( Swizzle )+  where++-- base+import Data.Kind+  ( Type )+import Data.Type.Bool+  ( If )+import Data.Type.Equality+  ( type (==) )+import GHC.TypeLits+  ( Symbol+  , TypeError, ErrorMessage(..)+  )++-- fir+import Control.Type.Optic+  ( Optic(..), Index+  , ProductComponents(ProductO)+  , EndProd+  )+import Data.Type.List+  ( Length )+import Data.Type.String+  ( LookupTree+      ( EnsureGTE, EnsureLT, Node, Leaf, Return )+  , LookupChars+  )+import FIR.AST+  ( Code )+import Math.Linear+  ( V )++--------------------------------------------------------------------------------------------------++-- swizzle sets: xyzw rgba stpq+-- ASCII order: AB...G...PQRST...WXYZ...ab...g...pqrst...wxyz++type SwizzleTree+  = EnsureGTE "A"+    ( EnsureLT "{"+      ( Node "[" "`"+        ( Node "G" "H"+           ( Node "B" "C"+             ( Leaf "A" )+             ( Node "D" "E"+               ( Leaf "C" )+               Return+             )+           )+           ( Node "U" "V"+             ( Node "P" "Q"+                Return+                ( Node "R" "S"+                  ( Leaf "Q" )+                  ( Node "T" "U"+                    ( Leaf "S" )+                    Return+                  )+                )+             )+             ( Node "W" "X"+                Return+                ( Node "Y" "Z"+                  ( Leaf "X" )+                  ( Leaf "Z" )+                )+             )+           )+        )+        ( Node "g" "h"+           ( Node "b" "c"+             ( Leaf "a" )+             ( Node "d" "e"+               ( Leaf "c" )+               Return+             )+           )+           ( Node "u" "v"+             ( Node "p" "q"+                Return+                ( Node "r" "s"+                  ( Leaf "q" )+                  ( Node "t" "u"+                    ( Leaf "s" )+                    Return+                  )+                )+             )+             ( Node "w" "x"+                Return+                ( Node "y" "z"+                  ( Leaf "x" )+                  ( Leaf "z" )+                )+             )+           )+        )+      )+    )++type Swizzle :: forall vec. forall (string :: Symbol) -> Optic '[] vec (SwizzleRes vec (LookupChars SwizzleTree string))+type Swizzle @vec string+  = Prod_ ( SwizzleFromString (LookupChars SwizzleTree string) )++--------------------------------------------------------------------------------------------------+++type family SwizzleRes (vec :: Type) (ks :: [Symbol]) :: Type where+  SwizzleRes _   '[ ] = TypeError ( Text "Empty swizzle." )+  SwizzleRes vec '[k] = SwizzleComponent vec+  SwizzleRes        (V _ a) ks =       V (Length ks) a+  SwizzleRes (Code (V _ a)) ks = Code (V (Length ks) a)+  SwizzleRes ty _ =+    TypeError+        ( Text "Cannot use swizzle on non-vector of type " :<>: ShowType ty :<>: Text "." )++type family SwizzleComponent (vec :: Type) :: Type where+  SwizzleComponent       (V _ a)  =      a+  SwizzleComponent (Code (V _ a)) = Code a+  SwizzleComponent ty =+    TypeError+        ( Text "Cannot use swizzle on non-vector of type " :<>: ShowType ty :<>: Text "." )++type family SwizzleComponents (vec :: Type) (ks :: [Symbol]) :: [Type] where+  SwizzleComponents _   '[]  = '[]+  SwizzleComponents vec '[k] = '[ SwizzleComponent vec ]+  SwizzleComponents vec (k1 ': k2 ': ks) =+    SwizzleComponent vec ': SwizzleComponents vec (k2 ': ks)++type family SwizzleFromChar (k :: Symbol) :: Optic '[] vec (SwizzleComponent vec) where+  SwizzleFromChar "x" = Index 0+  SwizzleFromChar "X" = Index 0+  SwizzleFromChar "y" = Index 1+  SwizzleFromChar "Y" = Index 1+  SwizzleFromChar "z" = Index 2+  SwizzleFromChar "Z" = Index 2+  SwizzleFromChar "w" = Index 3+  SwizzleFromChar "W" = Index 3+  SwizzleFromChar "r" = Index 0+  SwizzleFromChar "R" = Index 0+  SwizzleFromChar "g" = Index 1+  SwizzleFromChar "G" = Index 1+  SwizzleFromChar "b" = Index 2+  SwizzleFromChar "B" = Index 2+  SwizzleFromChar "a" = Index 3+  SwizzleFromChar "A" = Index 3+  SwizzleFromChar "s" = Index 0+  SwizzleFromChar "S" = Index 0+  SwizzleFromChar "t" = Index 1+  SwizzleFromChar "T" = Index 1+  SwizzleFromChar "p" = Index 2+  SwizzleFromChar "P" = Index 2+  SwizzleFromChar "q" = Index 3+  SwizzleFromChar "Q" = Index 3+  SwizzleFromChar  k  =+    TypeError+      (     Text "Unsupported swizzle character " :<>: ShowType k :<>: Text "."+       :$$: Text "Supported swizzle sets are: \"xyzw\", \"rgba\", \"stpq\"."+      )++type SwizzleFromString :: forall vec. forall (swizzle :: [Symbol]) -> ProductComponents '[] vec (SwizzleComponents vec swizzle)+type family SwizzleFromString @vec swizzle where+  SwizzleFromString '[ ] = EndProd+  SwizzleFromString '[k] = SwizzleFromChar k `ProductO` EndProd+  SwizzleFromString (k1 ': k2 ': ks) =+    If ( SwizzleSet k1 == SwizzleSet k2 )+      ( SwizzleFromChar k1 `ProductO` SwizzleFromString (k2 ': ks) )+      ( TypeError+        (    Text "Cannot mix and match different swizzle sets."+        :$$: Text "Swizzle set of " :<>: ShowType k1 :<>: Text " is "+        :<>: ShowType (SwizzleSet k1) :<>: Text "."+        :$$: Text "Swizzle set of " :<>: ShowType k2 :<>: Text " is "+        :<>: ShowType (SwizzleSet k2) :<>: Text "."+        )+      )++type family SwizzleSet ( swizzle :: Symbol ) :: Symbol where+  SwizzleSet "x" = "xyzw"+  SwizzleSet "X" = "xyzw"+  SwizzleSet "y" = "xyzw"+  SwizzleSet "Y" = "xyzw"+  SwizzleSet "z" = "xyzw"+  SwizzleSet "Z" = "xyzw"+  SwizzleSet "w" = "xyzw"+  SwizzleSet "W" = "xyzw"+  SwizzleSet "r" = "rgba"+  SwizzleSet "R" = "rgba"+  SwizzleSet "g" = "rgba"+  SwizzleSet "G" = "rgba"+  SwizzleSet "b" = "rgba"+  SwizzleSet "B" = "rgba"+  SwizzleSet "a" = "rgba"+  SwizzleSet "A" = "rgba"+  SwizzleSet "s" = "stpq"+  SwizzleSet "S" = "stpq"+  SwizzleSet "t" = "stpq"+  SwizzleSet "T" = "stpq"+  SwizzleSet "p" = "stpq"+  SwizzleSet "P" = "stpq"+  SwizzleSet "q" = "stpq"+  SwizzleSet "Q" = "stpq"+  SwizzleSet k+    = TypeError+        (     Text "Unsupported swizzle character detected in " :<>: ShowType k :<>: Text "."+         :$$: Text "Supported swizzle sets are: \"xyzw\", \"rgba\", \"stpq\"."+        )
+ src/FIR/Syntax/Synonyms.hs view
@@ -0,0 +1,805 @@+{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -Wno-missing-signatures #-}++{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PatternSynonyms        #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}+{-# LANGUAGE ViewPatterns           #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeAbstractions #-}++{-|+Module: FIR.Syntax.Synonyms++This module provides various convenience synonyms+to mitigate verbosity in user-written programs.++-}++module FIR.Syntax.Synonyms+  (+  -- * Synonyms for floating point types of a given width+    Float16, Float32, Float64++  -- * Synonyms for entry point globals with a given storage class+  , UniformConstant, Input, Output+  , Uniform, PushConstant+  , StorageBuffer, Private+  , Workgroup, CrossWorkgroup+  , AtomicCounter+  , RayPayload, RayPayloadIn+  , CallableData, CallableDataIn+  , HitAttribute, ShaderRecordBuffer++  -- * Synonyms for function with given function control information+  , Function, Function'++  -- * Synonyms for images+  -- ** Sampled images+  , Texture1D, Texture2D, Texture3D, Texture+  -- ** Storage images+  , Image1D, Image2D, Image3D, StorageImage+  , UnknownFormatImage1D, UnknownFormatImage2D, UnknownFormatImage3D+  -- ** Image operand shorthands+  , pattern DepthTestOffsets+  , pattern GatherComponentWithOffsets+  -- ** Helper type family for choosing image texel type+  , FormatDefault++  -- * Synonyms involved in pipeline creation+  , Slot+  , pattern StructInput++  -- * Synonyms for optics+  , Field+  , Col, Cols+  , Row, Rows+  , Entry, Elts+  , Diag, Center++  -- * Pattern synonyms for vectors/matrices+  -- ** Patterns for vectors+  , pattern Vec2, pattern Vec3, pattern Vec4++  -- ** Patterns for matrices+  , pattern Mat22, pattern Mat23, pattern Mat24+  , pattern Mat32, pattern Mat33, pattern Mat34+  , pattern Mat42, pattern Mat43, pattern Mat44++  -- * Ray tracing flags+  , pattern RayFlagsNone, pattern RayFlagsOpaque, pattern RayFlagsNoOpaque+  , pattern RayFlagsTerminateOnFirstHit, pattern RayFlagsSkipClosestHitShader+  , pattern RayFlagsCullBackFacingTriangles, pattern RayFlagsCullFrontFacingTriangles+  , pattern RayFlagsCullOpaque, pattern RayFlagsCullNoOpaque++  -- * Ray tracing hit kinds+  , pattern HitKindFrontFacingTriangle, pattern HitKindBackFacingTriangle++  )+  where++-- base+import Prelude+  hiding ( Floating, Integral )+import Data.Int+  ( Int8, Int16, Int32 )+import Data.Kind+  ( Type )+import Data.Word+  ( Word8, Word16, Word32 )+import GHC.TypeLits+  ( Symbol )+import GHC.TypeNats+  ( Nat, KnownNat+  , type (*)+  )++-- half+import Numeric.Half+  ( Half )++-- fir+import Control.Type.Optic+  ( Optic(..), Index+  , (:.:), (:*:)+  , OfType+  , EndProd+  )+import Data.Type.Known+  ( Known )+import Data.Type.Map+  ( (:->)((:->)), InsertionSort, Value )+import FIR.AST+  ( Code+  , Syntactic(fromAST)+  , pattern (:$)+  , pattern MkVector, pattern Mat, pattern UnMat+  , pattern Gather+  )+import FIR.Definition+  ( Definition(Global) )+import qualified FIR.Definition as Def+import FIR.Syntax.AST+  ( )+import FIR.Syntax.Optics+  ( )+import FIR.Layout+  ( Layout(Locations)+  , Poke(SizeOf)+  )+import FIR.Pipeline+  ( PrimitiveTopology+  , BindingStrides+  , VertexLocationDescriptions+  , PipelineInfo(VertexInputInfo)+  , PipelineStages(VertexInput)+  )+import FIR.Prim.Array+  ( Array )+import FIR.Prim.Image+  ( ImageProperties(Properties)+  , ImageCoordinateKind(..)+  , Image, GatherInfo(..)+  )+import FIR.Prim.Struct+  ( Struct+  , LocationSlot(LocationSlot)+  )+import FIR.Prim.Types+  ( PrimTy, ScalarTy )+import FIR.Validation.Bounds+  ( StructIndexFromName )+import FIR.Validation.Formats+  ( ComputeFormats )+import Math.Linear+  ( V, M+  , pattern V2, pattern V3, pattern V4+  )+import SPIRV.ScalarTy+  ( Signedness(..) )+import SPIRV.Image+  ( Dimensionality(..)+  , HasDepth(..)+  , Arrayness(..)+  , MultiSampling(..)+  , Normalisation(..)+  , ImageUsage(..)+  , ImageFormat(..)+  )+import SPIRV.Control+  ( NoFunctionControl )+import qualified SPIRV.Image   as Image+import qualified SPIRV.Image   as SPIRV+  ( ImageFormat )+import qualified SPIRV.Storage as Storage++--------------------------------------------------------------------------++type Float16 = Half+type Float32 = Float+type Float64 = Double++-- synonyms for (decorated) globals+type UniformConstant    decs ty = Global Storage.UniformConstant    decs ty+type Input              decs ty = Global Storage.Input              decs ty+type Output             decs ty = Global Storage.Output             decs ty+type Uniform            decs ty = Global Storage.Uniform            decs ty+type PushConstant       decs ty = Global Storage.PushConstant       decs ty+type StorageBuffer      decs ty = Global Storage.StorageBuffer      decs ty+type Private            decs ty = Global Storage.Private            decs ty+type Workgroup          decs ty = Global Storage.Workgroup          decs ty+type CrossWorkgroup     decs ty = Global Storage.CrossWorkgroup     decs ty+type AtomicCounter      decs ty = Global Storage.AtomicCounter      decs ty+type RayPayload         decs ty = Global ( 'Storage.RayStorage ( Storage.RayPayload   Storage.Lifetime ) ) decs ty+type RayPayloadIn       decs ty = Global ( 'Storage.RayStorage ( Storage.RayPayload   Storage.Incoming ) ) decs ty+type CallableData       decs ty = Global ( 'Storage.RayStorage ( Storage.CallableData Storage.Lifetime ) ) decs ty+type CallableDataIn     decs ty = Global ( 'Storage.RayStorage ( Storage.CallableData Storage.Incoming ) ) decs ty+type HitAttribute       decs ty = Global ( 'Storage.RayStorage Storage.HitAttribute                      ) decs ty+type ShaderRecordBuffer decs ty = Global ( 'Storage.RayStorage Storage.ShaderRecordBuffer                ) decs ty++-- synonym for function with no function control information+type Function     as b = Def.Function NoFunctionControl as b+type Function' fc as b = Def.Function fc as b++-- synonyms for images+type Texture1D decs fmt+  = Global Storage.UniformConstant+      decs+      ( Image+         (Properties FloatingPointCoordinates (FormatDefault fmt) OneD   (Just NotDepthImage) NonArrayed SingleSampled Sampled (Just fmt))+      )+type Texture2D decs fmt+  = Global Storage.UniformConstant+      decs+      ( Image+         (Properties FloatingPointCoordinates (FormatDefault fmt) TwoD   (Just NotDepthImage) NonArrayed SingleSampled Sampled (Just fmt))+      )+type Texture3D decs fmt+  = Global Storage.UniformConstant+      decs+      ( Image+         (Properties FloatingPointCoordinates (FormatDefault fmt) ThreeD (Just NotDepthImage) NonArrayed SingleSampled Sampled (Just fmt))+      )++type Image1D decs fmt+  = Global Storage.UniformConstant+      decs+      ( Image+         (Properties IntegralCoordinates (FormatDefault fmt) OneD   (Just NotDepthImage) NonArrayed SingleSampled Storage (Just fmt))+      )+type Image2D decs fmt+  = Global Storage.UniformConstant+      decs+      ( Image+         (Properties IntegralCoordinates (FormatDefault fmt) TwoD   (Just NotDepthImage) NonArrayed SingleSampled Storage (Just fmt))+      )+type Image3D decs fmt+  = Global Storage.UniformConstant+      decs+      ( Image+         (Properties IntegralCoordinates (FormatDefault fmt) ThreeD (Just NotDepthImage) NonArrayed SingleSampled Storage (Just fmt))+      )++type UnknownFormatImage1D decs texel+  = Global Storage.UniformConstant+      decs+      ( Image+         (Properties IntegralCoordinates texel OneD   (Just NotDepthImage) NonArrayed SingleSampled Storage Nothing)+      )+type UnknownFormatImage2D decs texel+  = Global Storage.UniformConstant+      decs+      ( Image+         (Properties IntegralCoordinates texel TwoD   (Just NotDepthImage) NonArrayed SingleSampled Storage Nothing)+      )+type UnknownFormatImage3D decs texel+  = Global Storage.UniformConstant+      decs+      ( Image+         (Properties IntegralCoordinates texel ThreeD (Just NotDepthImage) NonArrayed SingleSampled Storage Nothing)+      )++type Texture decs props+  = Global+      Storage.UniformConstant+      decs+      ( Image props )+type StorageImage decs props+  = Global+      Storage.UniformConstant+      decs+      ( Image props )++-- shorthand pattern synonyms for image operands+pattern DepthTestOffsets offs ops = Gather (DepthWithOffsets offs) ops+pattern GatherComponentWithOffsets component offs ops+  = Gather (ComponentWithOffsets component offs) ops++-----------------------------------------------------+-- helper type family for choosing image texel type++type family FormatDefault ( fmt :: ImageFormat Nat ) :: Type where+  FormatDefault ('ImageFormat Image.Floating (16 ': _)) = Half+  FormatDefault ('ImageFormat Image.Floating (_  ': _)) = Float+  FormatDefault ('ImageFormat (Image.Integer Normalised _) _ ) = Float+  FormatDefault ('ImageFormat (Image.Integer Unnormalised Signed  ) ( 8  ': _ )) = Int8+  FormatDefault ('ImageFormat (Image.Integer Unnormalised Signed  ) ( 16 ': _ )) = Int16+  FormatDefault ('ImageFormat (Image.Integer Unnormalised Signed  ) ( _  ': _ )) = Int32+  FormatDefault ('ImageFormat (Image.Integer Unnormalised Unsigned) ( 8  ': _ )) = Word8+  FormatDefault ('ImageFormat (Image.Integer Unnormalised Unsigned) ( 16 ': _ )) = Word16+  FormatDefault ('ImageFormat (Image.Integer Unnormalised Unsigned) ( _  ': _ )) = Word32++-----------------------------------------------------+-- pipeline synonyms++-- | Synonym for interface location slots.+type Slot (l :: Nat) (c :: Nat) = 'LocationSlot l c++-- | Utility pattern synonym for specifying a simple kind of vertex input:+-- use a single array of structs to keep track of vertex data.+pattern StructInput+  :: forall+        ( as        :: [LocationSlot Nat :-> Type] )+        ( top       :: PrimitiveTopology Nat       )+        ( descs     :: VertexLocationDescriptions  )+        ( stride    :: Nat                         )+        ( strides   :: BindingStrides              )+        ( stageData :: Type                        )+  .  ( descs   ~ StructLocationDescriptions 0 as+     , stride  ~ SizeOf Locations (Struct as)+     , strides ~ '[ 0 ':-> stride ]+     , Known (PrimitiveTopology Nat) top+     , Known VertexLocationDescriptions descs+     , KnownNat stride+     , Known BindingStrides strides+     )+  => ()+  => PipelineStages (VertexInputInfo top descs strides) stageData+pattern StructInput = VertexInput+++-- internal helper type synonyms / type families used for the above pattern synonym++type StructLocationDescriptions ( bdNo :: Nat ) ( as :: [LocationSlot Nat :-> Type] )+  = ( AnnotateLocationsWithBindingAndOffset+        bdNo+        ( LocationDescriptionsOfStruct as )+    :: VertexLocationDescriptions+    )++type family AnnotateLocationsWithBindingAndOffset+              ( bdNo :: Nat )+              ( locationFormats :: [ Nat :-> SPIRV.ImageFormat Nat ] )+           :: [ Nat :-> ( Nat, Nat, SPIRV.ImageFormat Nat ) ]+           where+  AnnotateLocationsWithBindingAndOffset _ '[] = '[]+  AnnotateLocationsWithBindingAndOffset bdNo+    ( ( loc ':-> fmt ) ': locs )+      = ( loc ':-> '( bdNo, 16 * loc, fmt ) )+      ': AnnotateLocationsWithBindingAndOffset bdNo locs++type LocationDescriptionsOfStruct+      ( as :: [ LocationSlot Nat :-> Type ] )+    = ( ComputeFormats (InsertionSort as) :: [ Nat :-> SPIRV.ImageFormat Nat ] )++----------------------------------------------------------------------+-- synonyms for optics++type family FieldRes ( k :: Symbol ) ( struct :: Type ) :: Type where+  FieldRes k (Struct as)  = Value (StructIndexFromName k as)+  FieldRes k (Code (Struct as)) = Code (Value (StructIndexFromName k as))++type Field :: forall struct. forall (k :: Symbol) -> Optic '[] struct (FieldRes k struct)+type family Field @struct k where+  Field @(Struct as)        k = Field_ k+  Field @(Code (Struct as)) k = Field_ k++-- internal synonyms to help inference in subsequent definitions+type Col_ :: forall (m :: Nat) (n :: Nat) a. Nat -> Optic '[] (M m n a) (V m a)+type Col_  i = Index i++type Col__ :: forall (m :: Nat) (n :: Nat) a. Nat -> Optic '[] (Code (M m n a)) (Code (V m a))+type Col__ i = Index i++type Ix_ :: forall (n :: Nat) a. Nat -> Optic '[] (V n a) a+type Ix_   i = Index i++type Ix__ :: forall (n :: Nat) a. Nat -> Optic '[] (Code (V n a)) (Code a)+type Ix__  i = Index i++type family EltRes (t :: Type) :: Type where+  EltRes (V m a) = a+  EltRes (M m n a) = a+  EltRes (Array n a) = a+  EltRes (Code (V m a)) = Code a+  EltRes (Code (M m n a)) = Code a+  EltRes (Code (Array n a)) = Code a++type Elts :: forall t. Optic '[] t (EltRes t)+type family Elts @t where+  Elts @t = OfType (EltRes t)++type family ColRes (mat :: Type) :: Type where+  ColRes (Code (M m n a)) = Code (V m a)+  ColRes (M m n a) = V m a++type Col :: forall mat. Nat -> Optic '[] mat (ColRes mat)+type family Col i = optic | optic -> i where+  Col @(Code (M m n a)) i = Col__ i+  Col @(M m n a)        i = Col_  i++type Cols :: forall mat. Optic '[] mat (ColRes mat)+type family Cols @mat where+  Cols @mat = OfType (ColRes mat)++type family RowRes (mat :: Type) :: Type where+  RowRes (M m n a) = V n a+  RowRes (Code (M m n a)) = Code (V n a)++type Row :: forall mat. Nat -> Optic '[] mat (RowRes mat)+type family Row i where+  Row @(Code (M m 2 a)) i+    = Prod_+        (   (Col__ 0 :.: Ix__ i)+        :*: (Col__ 1 :.: Ix__ i)+        :*: EndProd+        )+  Row @(Code (M m 3 a)) i+    = Prod_+        (   (Col__ 0 :.: Ix__ i)+        :*: (Col__ 1 :.: Ix__ i)+        :*: (Col__ 2 :.: Ix__ i)+        :*: EndProd+        )+  Row @(Code (M m 4 a)) i+    = Prod_+        (   (Col__ 0 :.: Ix__ i)+        :*: (Col__ 1 :.: Ix__ i)+        :*: (Col__ 2 :.: Ix__ i)+        :*: (Col__ 3 :.: Ix__ i)+        :*: EndProd+        )+  Row @(M m 2 a) i+    = Prod_+        (   (Col_ 0 :.: Ix_ i)+        :*: (Col_ 1 :.: Ix_ i)+        :*: EndProd+        )+  Row @(M m 3 a) i+    = Prod_+        (   (Col_ 0 :.: Ix_ i)+        :*: (Col_ 1 :.: Ix_ i)+        :*: (Col_ 2 :.: Ix_ i)+        :*: EndProd+        )+  Row @(M m 4 a) i+    = Prod_+        (   (Col_ 0 :.: Ix_ i)+        :*: (Col_ 1 :.: Ix_ i)+        :*: (Col_ 2 :.: Ix_ i)+        :*: (Col_ 3 :.: Ix_ i)+        :*: EndProd+        )++type Rows :: forall mat. Optic '[] mat (RowRes mat)+type family Rows @mat where+  Rows @(M 2 n a)+    = ( Prod_ ( Row 0 :*: Row 1 :*: EndProd )+          :: Optic '[] (M 2 n a) (Struct '[ "row0" ':-> V n a, "row1" ':-> V n a]) )+    :.: OfType (V n a)+  Rows @(M 3 n a)+    = ( Prod_ ( Row 0 :*: Row 1 :*: Row 2 :*: EndProd )+          :: Optic '[] (M 3 n a) (Struct '[ "row0" ':-> V n a, "row1" ':-> V n a, "row2" ':-> V n a]) )+    :.: OfType (V n a)+  Rows @(M 4 n a)+    = ( Prod_ ( Row 0 :*: Row 1 :*: Row 2 :*: Row 3 :*: EndProd )+          :: Optic '[] (M 4 n a) (Struct '[ "row0" ':-> V n a, "row1" ':-> V n a, "row2" ':-> V n a, "row3" ':-> V n a ]) )+    :.: OfType (V n a)+  Rows @(Code (M 2 n a))+    = ( Prod_ ( Row 0 :*: Row 1 :*: EndProd )+          :: Optic '[] (Code (M 2 n a)) (Struct '[ "row0" ':-> Code (V n a), "row1" ':-> Code (V n a)]) )+    :.: OfType (Code (V n a))+  Rows @(Code (M 3 n a))+    = ( Prod_ ( Row 0 :*: Row 1 :*: Row 2 :*: EndProd )+          :: Optic '[] (Code (M 3 n a)) (Struct '[ "row0" ':-> Code (V n a), "row1" ':-> Code (V n a), "row2" ':-> Code (V n a)]) )+    :.: OfType (Code (V n a))+  Rows @(Code (M 4 n a))+    = ( Prod_ ( Row 0 :*: Row 1 :*: Row 2 :*: Row 3 :*: EndProd )+          :: Optic '[] (Code (M 4 n a)) (Struct '[ "row0" ':-> Code (V n a), "row1" ':-> Code (V n a), "row2" ':-> Code (V n a), "row3" ':-> Code (V n a)]) )+    :.: OfType (Code (V n a))++type family EntryRes (mat :: Type) :: Type where+  EntryRes (M m n a) = a+  EntryRes (Code (M m n a)) = Code a++type Entry :: forall mat. Nat -> Nat -> Optic '[] mat (EntryRes mat)+type family Entry i j where+  Entry @(M m n a)        i j = Col_  j :.: Ix_  i+  Entry @(Code (M m n a)) i j = Col__ j :.: Ix__ i++type family DiagRes (mat :: Type) :: Type where+  DiagRes (M n n a) = V n a+  DiagRes (Code (M n n a)) = Code (V n a)++type Diag :: forall mat. Optic '[] mat (DiagRes mat)+type family Diag @mat where+  Diag @(M 2 2 a)+    = Prod_+        (   (Col_ 0 :.: Ix_ 0)+        :*: (Col_ 1 :.: Ix_ 1)+        :*: EndProd+        )+  Diag @(M 3 3 a)+    = Prod_+        (   (Col_ 0 :.: Ix_ 0)+        :*: (Col_ 1 :.: Ix_ 1)+        :*: (Col_ 2 :.: Ix_ 2)+        :*: EndProd+        )+  Diag @(M 4 4 a)+    = Prod_+        (   (Col_ 0 :.: Ix_ 0)+        :*: (Col_ 1 :.: Ix_ 1)+        :*: (Col_ 2 :.: Ix_ 2)+        :*: (Col_ 3 :.: Ix_ 3)+        :*: EndProd+        )+  Diag @(Code (M 2 2 a))+    = Prod_+        (   (Col__ 0 :.: Ix__ 0)+        :*: (Col__ 1 :.: Ix__ 1)+        :*: EndProd+        )+  Diag @(Code (M 3 3 a))+    = Prod_+        (   (Col__ 0 :.: Ix__ 0)+        :*: (Col__ 1 :.: Ix__ 1)+        :*: (Col__ 2 :.: Ix__ 2)+        :*: EndProd+        )+  Diag @(Code (M 4 4 a))+    = Prod_+        (   (Col__ 0 :.: Ix__ 0)+        :*: (Col__ 1 :.: Ix__ 1)+        :*: (Col__ 2 :.: Ix__ 2)+        :*: (Col__ 3 :.: Ix__ 3)+        :*: EndProd+        )++type Center :: forall mat. Optic '[] mat (EntryRes mat)+type family Center @mat where+  Center @mat = Diag @mat :.: OfType (EntryRes mat)++----------------------------------------------------------------------+-- pattern synonyms for vectors/matrices++-- these patterns could be generalised to have types such as:+-- Vec2 :: forall a. (Syntactic a, PrimTy (Internal a))+--      => a -> a -> Code ( V 2 (Internal a) )+-- but this leads to poor type-inference++{-# COMPLETE Vec2 #-}+pattern Vec2 :: forall a. PrimTy a => Code a -> Code a -> Code ( V 2 a )+pattern Vec2 x y <- (fromAST -> V2 x y)+  where Vec2 x y = MkVector ( V2 x y )++{-# COMPLETE Vec3 #-}+pattern Vec3 :: forall a. PrimTy a => Code a -> Code a -> Code a -> Code ( V 3 a )+pattern Vec3 x y z <- (fromAST -> V3 x y z)+  where Vec3 x y z = MkVector ( V3 x y z )++{-# COMPLETE Vec4 #-}+pattern Vec4 :: forall a. PrimTy a => Code a -> Code a -> Code a -> Code a -> Code ( V 4 a )+pattern Vec4 x y z w <- (fromAST -> V4 x y z w)+  where Vec4 x y z w = MkVector ( V4 x y z w )++{-# COMPLETE Mat22 #-}+pattern Mat22+  :: ScalarTy a+  => Code a -> Code a+  -> Code a -> Code a+  -> Code ( M 2 2 a )+pattern Mat22 a11 a12+              a21 a22+  <- ( fromAST . ( UnMat :$ )+       -> V2 ( V2 a11 a21 )+             ( V2 a12 a22 )+     )+  where Mat22+            a11 a12+            a21 a22+          = Mat :$ Vec2+            ( Vec2 a11 a21 )+            ( Vec2 a12 a22 )++{-# COMPLETE Mat23 #-}+pattern Mat23+  :: ScalarTy a+  => Code a -> Code a -> Code a+  -> Code a -> Code a -> Code a+  -> Code ( M 2 3 a )+pattern Mat23 a11 a12 a13+              a21 a22 a23+   <- ( fromAST . ( UnMat :$ )+        -> V3 ( V2 a11 a21 )+              ( V2 a12 a22 )+              ( V2 a13 a23 )+      )+  where Mat23+            a11 a12 a13+            a21 a22 a23+          = Mat :$ Vec3+              ( Vec2 a11 a21 )+              ( Vec2 a12 a22 )+              ( Vec2 a13 a23 )++{-# COMPLETE Mat24 #-}+pattern Mat24+  :: ScalarTy a+  => Code a -> Code a -> Code a -> Code a+  -> Code a -> Code a -> Code a -> Code a+  -> Code ( M 2 4 a )+pattern Mat24 a11 a12 a13 a14+              a21 a22 a23 a24+   <- ( fromAST . ( UnMat :$ )+        -> V4 ( V2 a11 a21 )+              ( V2 a12 a22 )+              ( V2 a13 a23 )+              ( V2 a14 a24 )+      )+  where Mat24+            a11 a12 a13 a14+            a21 a22 a23 a24+          = Mat :$ Vec4+              ( Vec2 a11 a21 )+              ( Vec2 a12 a22 )+              ( Vec2 a13 a23 )+              ( Vec2 a14 a24 )++{-# COMPLETE Mat32 #-}+pattern Mat32+  :: ScalarTy a+  => Code a -> Code a+  -> Code a -> Code a+  -> Code a -> Code a+  -> Code ( M 3 2 a )+pattern Mat32 a11 a12+              a21 a22+              a31 a32+   <- ( fromAST . ( UnMat :$ )+        -> V2 ( V3 a11 a21 a31 )+              ( V3 a12 a22 a32 )+      )+  where Mat32+            a11 a12+            a21 a22+            a31 a32+          = Mat :$ Vec2+              ( Vec3 a11 a21 a31 )+              ( Vec3 a12 a22 a32 )++{-# COMPLETE Mat33 #-}+pattern Mat33+  :: ScalarTy a+  => Code a -> Code a -> Code a+  -> Code a -> Code a -> Code a+  -> Code a -> Code a -> Code a+  -> Code ( M 3 3 a )+pattern Mat33 a11 a12 a13+              a21 a22 a23+              a31 a32 a33+   <- ( fromAST . ( UnMat :$ )+        -> V3 ( V3 a11 a21 a31 )+              ( V3 a12 a22 a32 )+              ( V3 a13 a23 a33 )+      )+  where Mat33+            a11 a12 a13+            a21 a22 a23+            a31 a32 a33+          = Mat :$ Vec3+              ( Vec3 a11 a21 a31 )+              ( Vec3 a12 a22 a32 )+              ( Vec3 a13 a23 a33 )++{-# COMPLETE Mat34 #-}+pattern Mat34+  :: ScalarTy a+  => Code a -> Code a -> Code a -> Code a+  -> Code a -> Code a -> Code a -> Code a+  -> Code a -> Code a -> Code a -> Code a+  -> Code ( M 3 4 a )+pattern Mat34 a11 a12 a13 a14+              a21 a22 a23 a24+              a31 a32 a33 a34+   <- ( fromAST . ( UnMat :$ )+        -> V4 ( V3 a11 a21 a31 )+              ( V3 a12 a22 a32 )+              ( V3 a13 a23 a33 )+              ( V3 a14 a24 a34 )+      )+  where Mat34+            a11 a12 a13 a14+            a21 a22 a23 a24+            a31 a32 a33 a34+          = Mat :$ Vec4+              ( Vec3 a11 a21 a31 )+              ( Vec3 a12 a22 a32 )+              ( Vec3 a13 a23 a33 )+              ( Vec3 a14 a24 a34 )++{-# COMPLETE Mat42 #-}+pattern Mat42+  :: ScalarTy a+  => Code a -> Code a+  -> Code a -> Code a+  -> Code a -> Code a+  -> Code a -> Code a+  -> Code ( M 4 2 a )+pattern Mat42 a11 a12+              a21 a22+              a31 a32+              a41 a42+   <- ( fromAST . ( UnMat :$ )+        -> V2 ( V4 a11 a21 a31 a41 )+              ( V4 a12 a22 a32 a42 )+      )+  where Mat42+            a11 a12+            a21 a22+            a31 a32+            a41 a42+          = Mat :$ Vec2+              ( Vec4 a11 a21 a31 a41 )+              ( Vec4 a12 a22 a32 a42 )++{-# COMPLETE Mat43 #-}+pattern Mat43+  :: ScalarTy a+  => Code a -> Code a -> Code a+  -> Code a -> Code a -> Code a+  -> Code a -> Code a -> Code a+  -> Code a -> Code a -> Code a+  -> Code ( M 4 3 a )+pattern Mat43 a11 a12 a13+              a21 a22 a23+              a31 a32 a33+              a41 a42 a43+   <- ( fromAST . ( UnMat :$ )+        -> V3 ( V4 a11 a21 a31 a41 )+              ( V4 a12 a22 a32 a42 )+              ( V4 a13 a23 a33 a43 )+      )+  where Mat43+            a11 a12 a13+            a21 a22 a23+            a31 a32 a33+            a41 a42 a43+          = Mat :$ Vec3+              ( Vec4 a11 a21 a31 a41 )+              ( Vec4 a12 a22 a32 a42 )+              ( Vec4 a13 a23 a33 a43 )++{-# COMPLETE Mat44 #-}+pattern Mat44+  :: ScalarTy a+  => Code a -> Code a -> Code a -> Code a+  -> Code a -> Code a -> Code a -> Code a+  -> Code a -> Code a -> Code a -> Code a+  -> Code a -> Code a -> Code a -> Code a+  -> Code ( M 4 4 a )+pattern Mat44 a11 a12 a13 a14+              a21 a22 a23 a24+              a31 a32 a33 a34+              a41 a42 a43 a44+   <- ( fromAST . ( UnMat :$ )+        -> V4 ( V4 a11 a21 a31 a41 )+              ( V4 a12 a22 a32 a42 )+              ( V4 a13 a23 a33 a43 )+              ( V4 a14 a24 a34 a44 )+      )+  where Mat44+            a11 a12 a13 a14+            a21 a22 a23 a24+            a31 a32 a33 a34+            a41 a42 a43 a44+          = Mat :$ Vec4+              ( Vec4 a11 a21 a31 a41 )+              ( Vec4 a12 a22 a32 a42 )+              ( Vec4 a13 a23 a33 a43 )+              ( Vec4 a14 a24 a34 a44 )++-- Ray flags.+pattern RayFlagsNone :: Word32+pattern RayFlagsNone = 0+pattern RayFlagsOpaque :: Word32+pattern RayFlagsOpaque = 1+pattern RayFlagsNoOpaque :: Word32+pattern RayFlagsNoOpaque = 2+pattern RayFlagsTerminateOnFirstHit :: Word32+pattern RayFlagsTerminateOnFirstHit = 4+pattern RayFlagsSkipClosestHitShader :: Word32+pattern RayFlagsSkipClosestHitShader = 8+pattern RayFlagsCullBackFacingTriangles :: Word32+pattern RayFlagsCullBackFacingTriangles = 16+pattern RayFlagsCullFrontFacingTriangles :: Word32+pattern RayFlagsCullFrontFacingTriangles = 32+pattern RayFlagsCullOpaque :: Word32+pattern RayFlagsCullOpaque = 64+pattern RayFlagsCullNoOpaque :: Word32+pattern RayFlagsCullNoOpaque = 128++pattern HitKindFrontFacingTriangle :: Word32+pattern HitKindFrontFacingTriangle = 0xfe+pattern HitKindBackFacingTriangle :: Word32+pattern HitKindBackFacingTriangle = 0xff
+ src/FIR/Temp.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++{-|+Module: FIR.Temp++Functionality for creating new (temporary) variable names at the type level. Currently unused.+-}++module FIR.Temp+  ( -- * Creating fresh temporary variable names+    NewTemp+  ) where++-- base+import Data.Type.Bool+  ( If )+import GHC.TypeLits+  ( Symbol, CmpSymbol, AppendSymbol )+import GHC.TypeNats+  ( type (+) )++-- fir+import Data.Type.Map+  ( (:->)((:->)) )+import Data.Type.String+  ( ShowNat, ReadPrefixedNat )++-------------------------------------------------------------------------------------------+-- Creating fresh temporary variable names++type TempPrefix = ( "__tmp" :: Symbol )++-- | Create a new temporary variable name.+type family NewTemp (i :: [Symbol :-> t]) :: Symbol where+  NewTemp i = NextTemp (LastTemp i)++type family NextTemp ( mbk :: Maybe Symbol ) :: Symbol where+  NextTemp Nothing = TempPrefix `AppendSymbol` "0001"+  NextTemp (Just k)+    = TempPrefix `AppendSymbol` ( ShowNat (ReadPrefixedNat TempPrefix k + 1) )++--type family ReadTempNat ( k :: Symbol ) :: Nat where+--  ReadTempNat k = ReadPrefixedNat TempPrefix k++type family LastTemp (i :: [Symbol :-> t]) :: Maybe Symbol where+  LastTemp '[] = Nothing+  LastTemp ( (k ':-> _) ': ks )+    = If ( InTempRange k )+        ( Just (LastInRange k ks) )+        ( LastTemp ks )++type family LastInRange (k :: Symbol) (i :: [Symbol :-> t]) :: Symbol where+  LastInRange k '[] = k+  LastInRange k ( (l ':-> _) ': ls)+    = If ( InTempRange l )+        ( LastInRange l ls )+        k++type family InTempRange (k :: Symbol) :: Bool where+  InTempRange k+    = InBetween+        ( CmpSymbol k (TempPrefix `AppendSymbol` "0") )+        ( CmpSymbol k (TempPrefix `AppendSymbol` ":") )++type family InBetween (min :: Ordering) (max :: Ordering) :: Bool where+  InBetween GT LT = True+  InBetween _  _  = False
+ src/FIR/Validation/Ambiguity.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: FIR.Validation.Ambiguity++Contains some type errors that catch ambiguous type variables.++This module is currently unused, as these ambiguity checks+seem to hinder more than they help, by preventing polymorphic+metaprogramming (unless the user passes additional constraints around).++-}++module FIR.Validation.Ambiguity where++-- base+import Prelude+  hiding ( Integral, Floating )+import Data.Kind+  ( Constraint )+import GHC.TypeLits+  ( Symbol+  , TypeError, ErrorMessage(..)+  )++-- fir+import Control.Type.Optic+  ( Optic )+import Data.Type.Map+  ( (:->)((:->)) )+import FIR.Binding+  ( BindingsMap, Var )+import qualified SPIRV.Stage    as SPIRV+  ( ExecutionModel )++-------------------------------------------------+-- * Checking for ambiguous type variables.++data family Dummy :: k++type family Assert ( err :: Constraint ) (ambig :: k) (x :: l) :: l where+  Assert _ Dummy _ = Dummy+  Assert _  _    l = l++-- | Check that monadic state is not ambiguous.+type DefiniteState i = AssertDefiniteState i ( () :: Constraint )++type family AssertDefiniteState ( i :: BindingsMap ) (x :: l) :: l where+  AssertDefiniteState i x =+    AssertProvidedBindings+      ( TypeError+          (    Text "Ambiguous state in indexed monad."+          :$$: Text "Potential causes:"+          :$$: Text "  - lack of a type signature indicating the starting monadic state,"+          :$$: Text "  - an earlier overly general value (such as 'undefined') resulting in an ambiguous state."+          :$$: Text " "+          :$$: Text "If you are not expecting a specific state"+          :$$: Text "    ( for instance if you are writing a function which is polymorphic over monadic state )"+          :$$: Text "add the constraint 'DefiniteState " :<>: ShowType i :<>: Text "' "+          :<>: Text "to defer this error message to the use-site."+         )+      )+      i+      x++type family AssertProvidedBindings ( err :: Constraint ) ( i :: BindingsMap ) (x :: l) :: l where+  AssertProvidedBindings _   ( ("dummy" ':-> Var '[] Dummy) ': nxt) x = Dummy+  AssertProvidedBindings err ( _                            ': nxt) x = AssertProvidedBindings err nxt x+  AssertProvidedBindings _ _ x = x++-- | Check that a type-level symbol is not ambiguous.+type ProvidedSymbol k = AssertProvidedSymbol k ( () :: Constraint )+type family AssertProvidedSymbol ( k :: Symbol ) (x :: l) :: l where+  AssertProvidedSymbol k x =+    Assert+      ( TypeError+          (      Text "Ambiguous type-level symbol."+            :$$: Text "Suggestion: provide a specific name using a type application."+            :$$: Text " "+            :$$: Text "If you intend for " :<>: ShowType k :<>: Text " to remain un-instantiated,"+            :$$: Text "add the constraint 'ProvidedSymbol " :<>: ShowType k :<>: Text "' "+            :<>: Text "to defer this error message to the use-site."+          )+       )+      k+      x++-- | Check that a shader stage is not ambiguous.+type family ProvidedStage ( s :: SPIRV.ExecutionModel ) :: Constraint where+  ProvidedStage s =+    Assert+      ( TypeError+          (      Text "Ambiguous entry point stage."+            :$$: Text "Suggestion: specify the stage using a type application."+            :$$: Text " "+            :$$: Text "If you intend for " :<>: ShowType s :<>: Text " to remain un-instantiated,"+            :$$: Text "add the constraint 'ProvidedStage " :<>: ShowType s :<>: Text "' "+            :<>: Text "to defer this error message to the use-site."+          )+       )+      s+      ( () :: Constraint )++-- | Check that an optic is not ambiguous.+type family ProvidedOptic ( optic :: Optic is s a ) :: Constraint where+  ProvidedOptic (optic :: Optic is s a) =+    Assert+      ( TypeError+          (     Text "Ambiguous type-level optic."+           :$$: Text "Suggestion: provide a specific optic using a type application."+           :$$: Text "Expecting an optic:"+           :$$: Text "  - with run-time indices of types: " :<>: ShowType is+           :$$: Text "  - focusing within an object of type " :<>: ShowType s+           :$$: Text "  - onto an object of type " :<>: ShowType a+           :$$: Text " "+           :$$: Text "If " :<>: ShowType optic :<>: Text " is not intended to be a specific optic,"+           :$$: Text "for instance if you are writing an optic-polymorphic function,"+           :$$: Text "add the constraint 'ProvidedOptic " :<>: ShowType optic :<>: Text "' "+           :<>: Text "to defer this error message to the use-site."+          )+       )+      optic+      ( () :: Constraint )
+ src/FIR/Validation/Arrayness.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: FIR.Validation.Arrayness++Validation of implicit arrayness.++Non-patch inputs to tessellation and geometry shaders,+and non-patch outputs of tessellation control shaders,+have an added layer of arrayness.++This module checks for the presence of these layers of arrayness,+and provides type families to peel off such implicit arrayness layers.+-}++module FIR.Validation.Arrayness where++-- base+import Data.Kind+  ( Type )+import Data.Type.Bool+  ( If )+import GHC.TypeLits+  ( Symbol+  , TypeError, ErrorMessage(..)+  )+import GHC.TypeNats+  ( Nat )++-- fir+import Data.Type.List+  ( Elem )+import Data.Type.String+  ( ShowNat )+import FIR.Prim.Array+  ( Array )+import qualified SPIRV.Decoration as SPIRV+  ( Decoration(..) )+import qualified SPIRV.Stage      as SPIRV+  ( ExecutionModel+  , ExecutionInfo(..), ShaderInfo(..) +  , NamedExecutionModel+  )+import qualified SPIRV.Storage    as SPIRV+  ( StorageClass(Input, Output) )++-------------------------------------------------------------++data IsPatchVariable+  = IsPatch+  | NotPatch++data ImplicitArrayness+  = NoImplicitArrayness IsPatchVariable+  | ImplicitArrayness   Nat++type family UnderlyingType+              ( varName :: Symbol                     )+              ( inOut   :: SPIRV.StorageClass         )+              ( decs    :: [ SPIRV.Decoration Nat ]   )+              ( emName  :: Symbol                     )+              ( ty      :: Type                       )+              ( xnfo    :: SPIRV.ExecutionInfo Nat em )+            :: Type+            where+  UnderlyingType varName inOut decs emName ty ( xnfo :: SPIRV.ExecutionInfo Nat em )+    = RemoveArrayness varName inOut emName em ty+        ( Arrayness inOut decs xnfo )++type family Arrayness+              ( inOut :: SPIRV.StorageClass         )+              ( decs  :: [ SPIRV.Decoration Nat ]   )+              ( xnfo  :: SPIRV.ExecutionInfo Nat em )+          :: ImplicitArrayness+          where+  Arrayness SPIRV.Input  decs+    ( SPIRV.ShaderExecutionInfo ( SPIRV.TessellationControlShaderInfo i _ _ ) )+      = If ( SPIRV.Patch `Elem` decs )+           ( 'NoImplicitArrayness IsPatch )+           ( 'ImplicitArrayness i )+  Arrayness SPIRV.Input  decs+    ( SPIRV.ShaderExecutionInfo ( SPIRV.TessellationEvaluationShaderInfo i _ ) )+      = If ( SPIRV.Patch `Elem` decs )+           ( 'NoImplicitArrayness IsPatch )+           ( 'ImplicitArrayness i )+  Arrayness SPIRV.Input  decs+    ( SPIRV.ShaderExecutionInfo ( SPIRV.GeometryShaderInfo i _ ) )+      = 'ImplicitArrayness i+  Arrayness SPIRV.Output decs+    ( SPIRV.ShaderExecutionInfo ( SPIRV.TessellationControlShaderInfo _ j _ ) )+      = If ( SPIRV.Patch `Elem` decs )+           ( 'NoImplicitArrayness IsPatch )+           ( 'ImplicitArrayness j )+  Arrayness _ _ _ = 'NoImplicitArrayness NotPatch+++type family RemoveArrayness+              ( varName   :: Symbol )+              ( inOut     :: SPIRV.StorageClass )+              ( emName     :: Symbol )+              ( em        :: SPIRV.ExecutionModel )+              ( ty        :: Type  )+              ( arrayness :: ImplicitArrayness )+          :: Type+          where+  RemoveArrayness _       _     _      _  ty           (NoImplicitArrayness _) = ty+  -- if an implicit level of arrayness is detected,+  -- remove it (ignoring the specific array length, as Vulkan does)+  RemoveArrayness _       _     _      _  (Array _ a) ('ImplicitArrayness _) = a+  RemoveArrayness varName inOut emName em ty          ('ImplicitArrayness i)+    = TypeError+        (    ShowType inOut :<>: Text " per-vertex variable " :<>: ShowType varName+        :<>: Text " of " :<>: Text (SPIRV.NamedExecutionModel emName em)+        :<>: Text " should be an array,"+        :$$: Text "but its type is " :<>: ShowType ty :<>: Text "."+        )++type family ArraynessNote+              ( em1        :: SPIRV.ExecutionModel )+              ( name1      :: Symbol               )+              ( arrayness1 :: ImplicitArrayness    )+              ( em2        :: SPIRV.ExecutionModel )+              ( name2      :: Symbol               )+              ( arrayness2 :: ImplicitArrayness    )+            :: ErrorMessage+            where+  ArraynessNote+    em1 name1 ('ImplicitArrayness  i1)+    _   _     ('NoImplicitArrayness _)+      =    Text ""+      :$$: Text "Note that per-vertex outputs of "+      :<>: Text ( SPIRV.NamedExecutionModel name1 em1 )+      :<>: Text " must be arrays of size " :<>: Text (ShowNat i1) :<>: Text "."+  ArraynessNote+    _   _     ('NoImplicitArrayness _)+    em2 name2 ('ImplicitArrayness  i2)+      =    Text ""+      :$$: Text "Note that per-vertex inputs of "+      :<>: Text ( SPIRV.NamedExecutionModel name2 em2 )+      :<>: Text " must be arrays of size " :<>: Text (ShowNat i2) :<>: Text "."+  ArraynessNote+    em1 name1 ('ImplicitArrayness i1)+    em2 name2 ('ImplicitArrayness i2)+      =    Text ""+      :$$: Text "Note that:"+      :$$: Text "  - per-vertex outputs of "+      :<>: Text ( SPIRV.NamedExecutionModel name1 em1 )+      :<>: Text " must be arrays of size " :<>: Text (ShowNat i1) :<>: Text ","+      :$$: Text "  - per-vertex inputs of "+      :<>: Text ( SPIRV.NamedExecutionModel name2 em2 )+      :<>: Text " must be arrays of size " :<>: Text (ShowNat i2) :<>: Text "."+  ArraynessNote+    _ _ ('NoImplicitArrayness _)+    _ _ ('NoImplicitArrayness _)+      = Text ""
+ src/FIR/Validation/Bindings.hs view
@@ -0,0 +1,709 @@+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: FIR.Validation.Bindings++Validation module providing checks for stateful operations+such as 'FIR.Syntax.Program.get' and 'FIR.Syntax.Program.put',+using type families with custom type errors.++These are used, for instance, to prevent any name from being bound twice,+or accessing a binding that does not exist.++-}++module FIR.Validation.Bindings where++-- base+import Prelude+  hiding ( Integral, Floating )+import Data.Kind+  ( Type, Constraint )+import Data.Type.Bool+  ( If, type (||), type (&&) )+import Data.Type.Equality+  ( type (==) )+import GHC.TypeLits+  ( Symbol+  , TypeError+  , ErrorMessage(..)+  )+import GHC.TypeNats+  ( Nat )++-- fir+import Data.Type.Known+  ( Known )+import Data.Type.List+  ( Elem )+import Data.Type.Map+  ( Map, (:->)((:->))+  , Insert, Remove+  , Lookup, Union+  , Keys+  )+import Data.Type.POrd+  ( POrd(Compare) )+import FIR.Binding+  ( Binding, BindingsMap, FunctionType+  , Permission(Read,Write)+  , Var, Fun+  )+import FIR.Builtin+  ( ModelBuiltins )+import FIR.Prim.Types+  ( HasOpaqueType )+import FIR.ProgramState+  ( FunctionContext(..)+  , ProgramState(ProgramState)+  , Definedness(..), FunctionInfo(..)+  , EntryPointInfo(..), TLInterface+  , Bindings+  )+import FIR.Validation.Interface+  ( ValidInterface )+import qualified SPIRV.Stage as SPIRV+  ( ExecutionModel, NamedExecutionModel+  , ExecutionInfo+  , Backend, OtherBackend, BackendOf+  )++-------------------------------------------------+-- * Lookup whether a binding exists in the monadic state.++-- | Compute the type of a variable bound by a given name.+--+-- Throws a type error if no variable by that name exists.+type family Has (k :: Symbol) (i :: ProgramState) :: Type where+  Has k ('ProgramState bds _ _ _ _ _ _ _) = HasBinding k (Lookup k bds)++type family HasBinding (k :: Symbol) (mbd :: Maybe Binding) :: Type where+  HasBinding k 'Nothing+   = TypeError+      (  Text "No binding named " :<>: ShowType k :<>: Text " is in scope." )+  HasBinding k ('Just (Var _ a))+    = a+  HasBinding _ ('Just (Fun as b)) = FunctionType as b++-------------------------------------------------+-- * Constraints for 'FIR.Syntax.Program.get' and 'FIR.Syntax.Program.use'++-- | Check whether we can 'get' a binding.+type family CanGet (k :: Symbol) (i :: ProgramState) :: Constraint where+  CanGet k ('ProgramState bds _ _ _ _ _ _ _) = GetBinding k (Lookup k bds)++type family GetBinding (k :: Symbol) (mbd :: Maybe Binding) :: Constraint where+  GetBinding k 'Nothing+   = TypeError+      (  Text "'get'/'use': no binding named " :<>: ShowType k :<>: Text " is in scope." )+  GetBinding k ('Just (Var perms _))+    = If +        ( Elem 'Read perms )+        ( () :: Constraint )+        ( TypeError+          ( Text "'get'/'use': variable named " :<>: ShowType k :<>: Text " is not readable." )+        )+  GetBinding _ ('Just (Fun as b)) = ()++-------------------------------------------------+-- * Constraints for 'FIR.Syntax.Program.put' and 'FIR.Syntax.Program.assign'++-- | Check whether we can write to a binding.+type family CanPut (k :: Symbol) (i :: ProgramState) :: Constraint where+  CanPut k ('ProgramState bds _ _ _ _ _ _ _) = PutBinding k (Lookup k bds)++type family PutBinding (k :: Symbol) (lookup :: Maybe Binding) :: Constraint where+  PutBinding k 'Nothing = TypeError+    (      Text "'put'/'assign': no binding named " :<>: ShowType k :<>: Text " is in scope."+      :$$: Text "To bind a new variable, use 'def'."+    )+  PutBinding k ('Just (Fun as b)) = TypeError+    (      Text "'put'/'assign': function bound at name "+      :<>: ShowType k :<>: Text ": "+      :<>: ShowType (Fun as b) :<>: Text "."+      :$$: Text "Use 'fundef' to define a function."+    )+  PutBinding k ('Just (Var perms _))+    = If+        ( Elem 'Write perms )+        ( () :: Constraint )+        ( TypeError +          ( Text "'put'/'assign': variable " :<>: ShowType k :<>: Text " is not writable." )+        )++-------------------------------------------------+-- * Constraints for 'FIR.Syntax.Program.def'++-- | Add a new binding to the indexed state.+type family AddBinding+              ( k  :: Symbol  )+              ( bd :: Binding )+              ( s  :: ProgramState )+              :: ProgramState where+  AddBinding k bd ('ProgramState bds ctx cfg funs eps iface rayQueries bkend)+    = 'ProgramState (Insert k bd bds) ctx cfg funs eps iface rayQueries bkend++-- | Check that it is valid to define a new variable with given name.+--+-- Throws a type error if a binding by this name already exists.+type family ValidDef (k :: Symbol) (i :: ProgramState) (a :: Type) :: Constraint where+  ValidDef k ('ProgramState bds _ _ _ _ _ _ _) a = +    ( NotAlreadyDefined k (Lookup k bds)+    , NotOpaqueType (HasOpaqueType a) k a+    )++type family NotAlreadyDefined (k :: Symbol) (lookup :: Maybe Binding) :: Constraint where+  NotAlreadyDefined _ 'Nothing  = ()+  NotAlreadyDefined k ('Just _) = TypeError+    ( Text "'def': a binding by the name " :<>: ShowType k :<>: Text " already exists." )++type family NotOpaqueType (hasOpaque :: Bool) (k :: Symbol) (a :: Type) :: Constraint where+  NotOpaqueType True k a =+    TypeError+      (    Text "'def': cannot define new binding named " :<>: ShowType k :<>: Text ":"+      :$$: ShowType a :<>: Text " is an opaque type (or it contains an opaque type)."+      )+  NotOpaqueType False _ _ = ()++-------------------------------------------------+-- * Constraints for 'FIR.Syntax.Program.fundef'++-- | Indexed monadic state at start of function body.+--+-- Adds the required function variables to the map of in-scope bindings.+type family FunctionDefinitionStartState+              ( k  :: Symbol       )+              ( as :: BindingsMap  )+              ( s  :: ProgramState )+            = ( j  :: ProgramState )+            | j -> k as+            where+  FunctionDefinitionStartState k as ('ProgramState i ctx cfg funs eps iface rayQueries bkend)+    = 'ProgramState (Union i as) ('InFunction k as) cfg funs eps iface rayQueries bkend++type family FunctionDefinitionEndState+              ( k   :: Symbol       )+              ( as  :: BindingsMap  )+              ( bds :: BindingsMap  )+              ( i   :: ProgramState )+            = ( j   :: ProgramState )+            | j -> k as bds+            where+  FunctionDefinitionEndState k as bds ('ProgramState _ _ cfg funs eps iface rayQueries bkend)+    = 'ProgramState+        bds+        ( 'InFunction k as)+        cfg+        funs+        eps+        iface+        rayQueries+        bkend++type family GetFunctionInfo+              ( k :: Symbol       )+              ( i :: ProgramState )+            :: FunctionInfo+            where+  GetFunctionInfo k ('ProgramState _ _ _ funs _ _ _ _)+    = GetFunctionInfoFromLookup k (Lookup k funs)++type family FunctionTypes+              ( k :: Symbol       )+              ( i :: ProgramState )+           :: ( BindingsMap, Type )+           where+  FunctionTypes k i = FunctionTypesFromInfo (GetFunctionInfo k i)++type family FunctionTypesFromInfo+              ( info :: FunctionInfo )+            :: ( BindingsMap, Type )+            where+  FunctionTypesFromInfo ('FunctionInfo as b _ _) = '( as, b )++type family GetFunctionInfoFromLookup+              ( k :: Symbol )+              ( mbFun :: Maybe FunctionInfo )+            :: FunctionInfo+            where+  GetFunctionInfoFromLookup _ (Just info) = info+  GetFunctionInfoFromLookup k 'Nothing+    = TypeError+    (    Text "'fundef': function named " :<>: ShowType k+    :<>: Text " has not been declared (no function info)."+    )++-- | Adds a function binding to the indexed monadic state.+type family AddFunBinding (k :: Symbol) (as :: BindingsMap) (b :: Type) (s :: ProgramState) :: ProgramState where+  AddFunBinding k as b ('ProgramState bds ctx cfg funs eps iface rayQueries bkend)+  -- 'ValidFunDef' should have already checked that name 'k' is not already in use+    = 'ProgramState (Insert k (Fun as b) bds) ctx cfg (SetFunctionDefined k funs) eps iface rayQueries bkend++type family SetFunctionDefined+              ( k    :: Symbol                  )+              ( funs :: Map Symbol FunctionInfo )+            :: Map Symbol FunctionInfo+            where+  SetFunctionDefined k '[]+    = TypeError+    (    Text "'fundef': function named " :<>: ShowType k+    :<>: Text " has not been declared."+    )+  SetFunctionDefined k ( ( k ':-> 'FunctionInfo as b fc Declared ) ': funs )+    = ( k ':-> 'FunctionInfo as b fc Defined ) ': funs+  SetFunctionDefined k ( ( k ':-> 'FunctionInfo _  _ _  Defined  ) ': _    )+    = TypeError+    (    Text "'fundef': function named " :<>: ShowType k+    :<>: Text " has already been defined."+    )+  SetFunctionDefined k ( fun ': funs )+    = fun ': SetFunctionDefined k funs++-- | Set the monadic context: within a function body.+type family SetFunctionContext+              ( k  :: Symbol       )+              ( as :: BindingsMap  )+              ( s  :: ProgramState )+              :: ProgramState where+  SetFunctionContext k as ('ProgramState bds TopLevel cfg funs eps iface rayQueries bkend)+    = 'ProgramState bds ('InFunction k as) cfg funs eps iface rayQueries bkend+  SetFunctionContext k _ ('ProgramState _ ('InFunction l _) _ _ _ _ _ _)+    = TypeError+        (    Text "'fundef': unexpected nested function definition."+        :$$: Text "Function " :<>: ShowType k+        :<>: Text " declared inside the body of function " :<>: ShowType l :<>: Text "."+        )+  SetFunctionContext k _+    ( 'ProgramState _ ('InEntryPoint stageName ( _ :: SPIRV.ExecutionInfo Nat em) _) _ _ _ _ _ _ )+    = TypeError+        (    Text "'fundef': unexpected function definition inside entry point."+        :$$: Text "Function " :<>: ShowType k+        :<>: Text " declared inside " :<>: Text (SPIRV.NamedExecutionModel stageName em)+        :<>: Text "."+        )++-- | Check that a function definition is valid.+--+-- Throws a type error if:+-- +--   * function is not declared at the top level,+--   * function name is already in use,+--   * one of the function's arguments is itself a function,+--   * another function is defined inside the function,+type family ValidFunDef +      ( k  :: Symbol       )  -- name of function to be defined+      ( as :: BindingsMap  )  -- function arguments+      ( s  :: ProgramState )  -- indexed state at the point the function is definition+      ( l  :: BindingsMap  )  -- total bindings at the end of the function definition+    :: Constraint+    where+  ValidFunDef k _ ('ProgramState _ ('InFunction l _) _ _ _ _ _ _ ) _+    = TypeError+        (    Text "'fundef': unexpected nested function definition."+        :$$: Text "Function " :<>: ShowType k+        :<>: Text " declared inside the body of function " :<>: ShowType l :<>: Text "."+        )+  ValidFunDef k _+    ( 'ProgramState _ ('InEntryPoint stageName ( _ :: SPIRV.ExecutionInfo Nat em) _) _ _ _ _ _ _)+    _+      = TypeError+          (    Text "'fundef': unexpected function definition inside entry point."+          :$$: Text "Function " :<>: ShowType k+          :<>: Text " declared inside " :<>: Text (SPIRV.NamedExecutionModel stageName em)+          :<>: Text "."+          )+  ValidFunDef k as ('ProgramState i 'TopLevel _ _ _ _ _ _) l+    = ( NoFunctionNameConflict k ( Lookup k i ) -- check that function name is not already in use+      , ValidArguments k as (Remove i (Remove as l)) )+        --     │                      └━━━━━━┬━━━━━┘+        --     │                             │+        --     │                             │+        --     │    local variables ├━━━━━━━━┘+        --     │+        --     └━━┤ check that none of the function arguments or local variables are themselves functions or images+++type ValidArguments (k :: Symbol) (as :: BindingsMap) (l :: BindingsMap)+  = ( ValidArguments' k as l as l :: Constraint )++type family ValidArguments'+              ( k      :: Symbol      )+              ( as     :: BindingsMap )+              ( l      :: BindingsMap )+              ( as_rec :: BindingsMap )+              ( l_rec  :: BindingsMap )+              :: Constraint where+  ValidArguments' _ _ _ '[]                           '[] = ()+  ValidArguments' k as _ ((v ':-> Fun _ _) ': _     ) _   = TypeError+    (     Text "'fundef': forbidden higher order argument " :<>: ShowType v :<>: Text ","+     :$$: Text "in function definition for " :<>: ShowType k :<>: Text ","+     :$$: Text "when trying to abstract over:"+     :$$: ShowType as+     :$$: Text "Function definitions can only abstract over variables, not over functions."+    )+  ValidArguments' k as l (_ ': as_rec) l_rec = ValidArguments' k as l as_rec l_rec+  ValidArguments' k _  l _ ((v ':-> Fun _ _) ': _    ) = TypeError+    (     Text "'fundef': unexpected nested function definition inside function " :<>: ShowType k :<>: Text ":"+     :$$: Text "local name " :<>: ShowType v :<>: Text " binds a function."+     :$$: Text "Local bindings for " :<>: ShowType k :<>: Text " are:"+     :$$: ShowType l+    )+  ValidArguments' k as l as_rec (_ ': l_rec) = ValidArguments' k as l as_rec l_rec++type family NoFunctionNameConflict+      ( k     :: Symbol        )+      ( mb_bd :: Maybe Binding ) -- conflict with in-scope variables?+      :: Constraint where+  NoFunctionNameConflict k ('Just _) = TypeError+    (     Text "'fundef': cannot define a new function with name " :<>: ShowType k :<>: Text "."+     :$$: Text "that name is already in scope."+    )+  NoFunctionNameConflict _ 'Nothing = ()++-------------------------------------------------+-- * Constraints for 'FIR.Syntax.Program.entryPoint'++-- | Check that an entry point definition is valid.+--+-- Throws a type error if:+--+--   * a function is defined within the entry point,+--   * the name of a builtin for this entry point is already in use.+type family ValidEntryPoint+              ( k        :: Symbol                    )+              ( nfo      :: SPIRV.ExecutionInfo Nat s )+              ( i        :: ProgramState              )+              ( l        :: BindingsMap               )+            :: Constraint where+  ValidEntryPoint k (nfo :: SPIRV.ExecutionInfo Nat s) ('ProgramState i _ _ _ eps _ _ bkend) l+    = ( ValidInterface k ( LookupEntryPointInfo k s eps )+      , NoEntryPointNameConflict k (Lookup k i)+      , ValidLocalBehaviour s (Remove i l)+      , BuiltinsDoNotAppearBefore s (ModelBuiltins nfo) i+      )++type family EntryPointsBackend+              ( eps :: [ Symbol :-> ( SPIRV.ExecutionModel, modes ) ] )+            :: SPIRV.Backend+            where+  EntryPointsBackend '[]+    = TypeError+    (    Text "SPIR-V module must specify at least one entry point."+    :$$: Text "Entry points are specified as part of a type signature containing module definitions."+    :$$: Text "For instance, a fragment shader can be specified as follows:"+    :$$: Text " \"main\" ':-> EntryPoint '[ OriginUpperLeft ] Fragment "+    )+  EntryPointsBackend ( ( k ':-> '( s, _ ) ) ': eps )+    = CompatibleWithBackend k s (SPIRV.BackendOf s) eps++type family CompatibleWithBackend+              ( k     :: Symbol               )+              ( s     :: SPIRV.ExecutionModel )+              ( bkend :: SPIRV.Backend        )+              ( eps   :: [ Symbol :-> ( SPIRV.ExecutionModel, modes ) ] )+            :: SPIRV.Backend+            where+  CompatibleWithBackend _ _ bk '[] = bk+  CompatibleWithBackend k s bk ( ( k' ':-> '( s', _ ) ) ': eps )+    = If ( SPIRV.BackendOf s' == bk )+        ( CompatibleWithBackend k s bk eps )+        ( TypeError+          (    Text "Incompatible backends."+          :$$: Text ( SPIRV.NamedExecutionModel k s )+          :<>: Text " uses " :<>: ShowType bk :<>: Text ","+          :$$: Text "while " :<>: Text ( SPIRV.NamedExecutionModel k' s' )+          :<>: Text " uses " :<>: ShowType ( SPIRV.OtherBackend bk ) :<>: Text "."+          )+        )+++-- | Indexed monadic state at start of entry point body.+type family EntryPointStartState+              ( k   :: Symbol                    )+              ( nfo :: SPIRV.ExecutionInfo Nat s )+              ( i   :: ProgramState              )+            = ( j   :: ProgramState              )+            | j -> k nfo+            where+  EntryPointStartState k nfo ('ProgramState bds _ cfg funs eps g_iface _ bkend)+    = 'ProgramState+        ( Union bds (ModelBuiltins nfo) ) -- bindings at the beginning+        ( 'InEntryPoint                   -- context: now within an entry point+             k+             nfo+             ( 'Just '[] )                -- initial empty interface+        )+        cfg+        funs+        eps+        g_iface+        '[]                               -- no ray queries to start off with+        bkend++-- | Indexed monadic state at end of entry point body.+type family EntryPointEndState+              ( k     :: Symbol                    )+              ( nfo   :: SPIRV.ExecutionInfo Nat s )+              ( bds   :: BindingsMap               )+              ( iface :: TLInterface               )+              ( i     :: ProgramState              )+            = ( j     :: ProgramState              )+            | j -> k nfo bds iface+            where+  EntryPointEndState k nfo bds iface ('ProgramState _ _ cfg funs eps g_iface rayQueries bkend)+    = 'ProgramState+        bds+        ( InEntryPoint k nfo ('Just iface) )+        cfg+        funs+        eps+        g_iface+        rayQueries+        bkend++type family GetExecutionInfo+              ( k  :: Symbol               )+              ( em :: SPIRV.ExecutionModel )+              ( i  :: ProgramState         )+            :: SPIRV.ExecutionInfo Nat em+            where+  GetExecutionInfo k em ('ProgramState _ _ _ _ eps _ _ _)+    = GetExecutionInfoOf k em eps++type family GetExecutionInfoOf+              ( k  :: Symbol                        )+              ( em :: SPIRV.ExecutionModel          )+              ( i  :: [ Symbol :-> EntryPointInfo ] )+            :: SPIRV.ExecutionInfo Nat em+            where+  GetExecutionInfoOf k em '[]+    = TypeError+      (    Text "'GetExecutionInfo': cannot find "+      :<>: Text (SPIRV.NamedExecutionModel k em)+      :<>: Text "."+      )+  GetExecutionInfoOf k em+    ( ( k ':-> 'EntryPointInfo (nfo :: SPIRV.ExecutionInfo Nat em) _ _ ) ': _ )+      = nfo+  GetExecutionInfoOf k em (_ ': eps)+    = GetExecutionInfoOf k em eps+++type family SetInterface+              ( k     :: Symbol                    )+              ( nfo   :: SPIRV.ExecutionInfo Nat s )+              ( iface :: TLInterface               )+              ( i     :: ProgramState              )+            :: ProgramState+            where+  SetInterface k (nfo :: SPIRV.ExecutionInfo Nat s) iface ('ProgramState i fc cfg funs eps globalIface rayQueries bkend)+    = 'ProgramState i fc cfg funs (SetInterfaceOf k s iface eps) globalIface rayQueries bkend++type family SetInterfaceOf+              ( k     :: Symbol                      )+              ( em    :: SPIRV.ExecutionModel        )+              ( iface :: TLInterface                 )+              ( eps   :: [ Symbol :-> EntryPointInfo ] )+            :: [ Symbol :-> EntryPointInfo ]+            where+  SetInterfaceOf k em  _ '[]+    = TypeError+      (    Text "'SetInterface': cannot find "+      :<>: Text (SPIRV.NamedExecutionModel k em)+      :<>: Text "."+      )+  SetInterfaceOf k em iface+    ( ( k ':-> 'EntryPointInfo (nfo :: SPIRV.ExecutionInfo Nat em) _ Declared ) ': eps )+      = ( k ':-> 'EntryPointInfo nfo iface Defined ) ': eps+  SetInterfaceOf k em iface+    ( (k ':-> 'EntryPointInfo (nfo :: SPIRV.ExecutionInfo Nat em) _ Defined ) ': _ )+      = TypeError+      (    Text "'entryPoint': entry point "+      :<>: Text (SPIRV.NamedExecutionModel k em)+      :<>: Text " has already been defined."+      )+  SetInterfaceOf k em iface (ep ': eps)+    = ep ': SetInterfaceOf k em iface eps++type family InsertEntryPointInfo+              ( k     :: Symbol                        )+              ( nfo   :: EntryPointInfo                )+              ( eps   :: [ Symbol :-> EntryPointInfo ] )+              :: [ Symbol :-> EntryPointInfo ]+              where+  InsertEntryPointInfo k nfo '[]+    = '[ k ':-> nfo ]+  InsertEntryPointInfo k+    ( 'EntryPointInfo (nfo  :: SPIRV.ExecutionInfo Nat s1) iface  def)+    ( ( l ':-> 'EntryPointInfo (nfo2 :: SPIRV.ExecutionInfo Nat s2) iface2 def2 ) ': eps )+    = InsertEntryPointInfoWithComparison+          ( k  `Compare` l  )+          ( s1 `Compare` s2 )+          k ( 'EntryPointInfo nfo  iface  def  )+          l ( 'EntryPointInfo nfo2 iface2 def2 )+          eps++type family InsertEntryPointInfoWithComparison+              ( cmpName  :: Ordering       )+              ( cmpStage :: Ordering       )+              ( name1    :: Symbol         )+              ( nfo1     :: EntryPointInfo )+              ( name2    :: Symbol         )+              ( nfo2     :: EntryPointInfo )+              ( nfos     :: [ Symbol :-> EntryPointInfo ] )+            :: [ Symbol :-> EntryPointInfo ]+            where+  -- NB: duplicate declarations are reported by 'FIR.Validation.Definitions.ValidDefinitions'.+  InsertEntryPointInfoWithComparison EQ EQ+      _ _+      name2 nfo2+      nfos+    = ( name2 ':-> nfo2 ) ': nfos+  InsertEntryPointInfoWithComparison cmpName cmpStage name1 nfo1 name2 nfo2 nfos+    = If ( cmpName == LT || ( cmpName == EQ && cmpStage == LT ) )+        ( ( name1 ':-> nfo1 ) ': ( name2 ':-> nfo2 ) ': nfos )+        ( ( name2 ':-> nfo2 ) ': InsertEntryPointInfo name1 nfo1 nfos )+      +type family LookupEntryPointInfo+              ( name :: Symbol )+              ( em   :: SPIRV.ExecutionModel )+              ( eps  :: [ Symbol :-> EntryPointInfo ] )+            :: EntryPointInfo+            where+  LookupEntryPointInfo name em+    ( ( name ':-> 'EntryPointInfo ( nfo :: SPIRV.ExecutionInfo Nat em ) iface defi ) ': _ )+    = 'EntryPointInfo nfo iface defi+  LookupEntryPointInfo name em ( _ ': eps ) = LookupEntryPointInfo name em eps+  LookupEntryPointInfo name em '[]+    = TypeError+    (   Text "'entryPoint': cannot define "+    :<>: Text (SPIRV.NamedExecutionModel name em) :<>: Text "."+    :$$: Text "No such entry point has been declared in the top-level definitions of the program."+    )++type family NoEntryPointNameConflict+               ( k     :: Symbol        )+               ( mb_bd :: Maybe Binding )+               :: Constraint where+  NoEntryPointNameConflict k ('Just _) = TypeError+    (     Text "'entryPoint': cannot define a new entry point with name " :<>: ShowType k :<>: Text "."+     :$$: Text "That name is already in scope."+    )+  NoEntryPointNameConflict _ 'Nothing = ()++type ValidLocalBehaviour (s :: SPIRV.ExecutionModel) (l :: BindingsMap)+  = ( ValidLocalBehaviour' s l l :: Constraint )++type family ValidLocalBehaviour'+              ( s     :: SPIRV.ExecutionModel )+              ( l     :: BindingsMap          )+              ( l_rec :: BindingsMap          )+              :: Constraint where+  ValidLocalBehaviour' _ _ '[]                         = ()+  ValidLocalBehaviour' s l ((_ ':-> Var _ _) ': l_rec) = ValidLocalBehaviour' s l l_rec+  ValidLocalBehaviour' s l ((v ':-> Fun _ _) ': _    ) = TypeError+    (     Text "'entryPoint': unexpected nested function definition inside " :<>: ShowType s :<>: Text " entry point:"+     :$$: Text "local name " :<>: ShowType v :<>: Text "binds a function."+     :$$: Text "Local bindings for " :<>: ShowType s :<>: Text " entry point are:"+     :$$: ShowType l+    )++type family BuiltinsDoNotAppearBefore+              ( s        :: SPIRV.ExecutionModel )+              ( builtins :: BindingsMap          )+              ( i        :: BindingsMap          )+              :: Constraint where+  BuiltinsDoNotAppearBefore _ '[]                _  = ()+  BuiltinsDoNotAppearBefore s ((b ':-> _) ': bs) i +    = BuiltinDoesNotAppearBefore s b bs i (Lookup b i)++type family BuiltinDoesNotAppearBefore+              ( s   :: SPIRV.ExecutionModel )+              ( b   :: Symbol               )+              ( bs  :: BindingsMap          )+              ( i   :: BindingsMap          )+              ( lkp :: Maybe Binding        )+              :: Constraint where+  BuiltinDoesNotAppearBefore s _ bs i 'Nothing  = BuiltinsDoNotAppearBefore s bs i+  BuiltinDoesNotAppearBefore s b _  i ('Just _)+    = TypeError (     Text "'entryPoint': conflict with built-in variable for " :<>: ShowType s :<>: Text " stage."+                 :$$: Text "Variable with name " :<>: ShowType b :<>: Text " is a built-in, yet is already bound."+                 :$$: Text "Variables in scope at site of entry point definition are:"+                 :$$: ShowType i+                )++-------------------------------------------------+-- * Constraints for 'FIR.Syntax.Program.embed'.++class      Known [Symbol] (Keys (Bindings i))                 => Embeddable (i :: ProgramState) (j :: ProgramState) where+instance ( Known [Symbol] (Keys (Bindings i)), CanEmbed i j ) => Embeddable i j where++type family CanEmbed (i :: ProgramState) (j :: ProgramState) :: Constraint where+  CanEmbed ('ProgramState '[] 'TopLevel _ '[] _ _ _ _) _ = ()+  CanEmbed ('ProgramState i_bds i_ctx _ i_funs _ _ _ _) ('ProgramState j_bds i_ctx _ j_funs _ _ _ _)+    = ( SubsetBindings  i_bds  j_bds+      , SubsetFunctions i_funs j_funs+      )+  CanEmbed ('ProgramState _ i_ctx _ _ _ _ _ _) ('ProgramState _ j_ctx _ _ _ _ _ _)+    = TypeError+      (      Text "'embed': cannot embed computation with function context "+        :<>: ShowType i_ctx+        :<>: Text " into computation with function context "+        :<>: ShowType j_ctx+        :<>: Text "."+      )++type family SubsetBindings (is :: BindingsMap) (js :: BindingsMap) :: Constraint where+  SubsetBindings '[]       _ = ()+  SubsetBindings (i ': is) js+    = If (i `Elem` js)+        ( SubsetBindings is js )+        ( TypeError+           (     Text "'embed': cannot embed computation."+            :$$: Text "Binding " :<>: ShowType i+            :<>: Text " is missing in larger context "+            :<>: ShowType js+            :<>: Text "."+           )+        )++type family SubsetFunctions+              ( fs :: Map Symbol FunctionInfo )+              ( gs :: Map Symbol FunctionInfo )+            :: Constraint where+  SubsetFunctions '[] _ = ()+  SubsetFunctions ( (k ':-> f) ': fs) gs+    = SubsetFunctionsRec k f (Lookup k gs) fs gs++type family SubsetFunctionsRec+              ( k  :: Symbol                  )+              ( f  :: FunctionInfo            )+              ( g  :: Maybe FunctionInfo      )+              ( fs :: Map Symbol FunctionInfo )+              ( gs :: Map Symbol FunctionInfo )+            :: Constraint where+  SubsetFunctionsRec k _ Nothing _ _+    = TypeError+    (    Text "'embed': cannot embed computation."+    :$$: Text "Function named " :<>: ShowType k+    :<>: Text " is missing in larger context."+    )+  SubsetFunctionsRec _ f (Just f) fs gs+    = SubsetFunctions fs gs+  SubsetFunctionsRec k f (Just f') _ _+    = TypeError+    (    Text "'embed': cannot embed computation."+    :$$: Text "Mismatch between functions of name " :<>: ShowType k+    :<>: Text "."+    :$$: Text "  - Smaller context function info: " :<>: ShowType f :<>: Text ","+    :$$: Text "  - Larger context function info: " :<>: ShowType f' :<>: Text "."+    )
+ src/FIR/Validation/Bounds.hs view
@@ -0,0 +1,113 @@++{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: FIR.Validation.Bounds++Custom error messages for out-of bounds indexing operations.++-}++module FIR.Validation.Bounds+  ( VectorIndexInBounds, MatrixColumnIndexInBounds+  , ArrayIndexInBounds+  , StructFieldFromIndex, StructIndexFromName+  )+  where++-- base+import Data.Kind+  ( Constraint )+import GHC.TypeLits+  ( TypeError+  , ErrorMessage(..)+  )+import GHC.TypeNats+  ( Nat, CmpNat, type (+) )++-- fir+import Data.Type.List+  ( AtIndex, Length )+import Data.Type.Map+  ( (:->)((:->)) )+import Data.Type.Maybe+  ( FromJust )++---------------------------------------------------------------------------------------------++type family ErrorIfNotLT (n :: Nat) (i :: Nat) (msg :: ErrorMessage) :: Constraint where+  ErrorIfNotLT n i msg = ErrorIfNotLT_Helper msg (CmpNat i n)++type family ErrorIfNotLT_Helper (msg :: ErrorMessage) (cmp :: Ordering) :: Constraint where+  ErrorIfNotLT_Helper _  LT = ( () :: Constraint )+  ErrorIfNotLT_Helper msg _ = TypeError msg++type family VectorIndexInBounds (n :: Nat) (i :: Nat) :: Constraint where+  VectorIndexInBounds n i+    = ErrorIfNotLT n i+        (    Text "Vector index "+        :<>: ShowType i+        :<>: Text " is out of bounds."+        :$$: Text "Vector dimension is "+        :<>: ShowType n :<>: Text "."+        :$$: Text "Note: indexing starts from 0."+        )++type family MatrixColumnIndexInBounds (m :: Nat) (n :: Nat) (i :: Nat) :: Constraint where+  MatrixColumnIndexInBounds m n i+    = ErrorIfNotLT n i+        (    Text "Matrix column index "+        :<>: ShowType i+        :<>: Text " is out of bounds."+        :$$: Text "This matrix has "+        :<>: ShowType m :<>: Text " rows, "+        :<>: ShowType n :<>: Text " columns."+        :$$: Text "Note: indexing starts from 0."+        )++type family ArrayIndexInBounds (n :: Nat) (i :: Nat) :: Constraint where+  ArrayIndexInBounds n i+    = ErrorIfNotLT n i+        (    Text "Array index "+        :<>: ShowType i+        :<>: Text " is out of bounds."+        :$$: Text "Array size is "+        :<>: ShowType n :<>: Text "."+        :$$: Text "Note: indexing starts from 0."+        )++type family StructFieldFromIndex (i :: Nat) (as :: [fld :-> ty]) :: ( fld :-> ty ) where+  StructFieldFromIndex i as =+    FromJust (AtIndex i as)+      (    Text "Index "+      :<>: ShowType i+      :<>: Text " out of bounds when accessing structure with fields"+      :$$: ShowType as+      :$$: Text "Structure has only " :<>: ShowType (Length as)+      :<>: Text " fields."+      :$$: Text "Note: indexing starts from 0."+      )++type family StructIndexFromName (k :: fld) (as :: [fld :-> ty]) :: ( Nat :-> ty ) where+  StructIndexFromName k as = StructIndexFromNameRec k as 0 as++type family StructIndexFromNameRec+                  (k :: fld) (as :: [fld :-> ty])+                  (i :: Nat) (as_rec :: [fld :-> ty])+                :: ( Nat :-> ty )+                  where+  StructIndexFromNameRec k _  i ((k ':-> a)': _) = (i ':-> a)+  StructIndexFromNameRec k as i ( _ ': as_rec) = StructIndexFromNameRec k as (i+1) as_rec+  StructIndexFromNameRec k as _ '[]+    = ( TypeError+          (    Text "Structure has no field with name "+          :<>: ShowType k :<>: Text "."+          :$$: Text "This structure has the following fields:"+          :$$: ShowType as+          )+      )
+ src/FIR/Validation/CFG.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: FIR.Validation.CFG++Validation module providing checks for control-flow based operations.++-}++module FIR.Validation.CFG+  ( InLoop+  , ValidBreak, ValidContinue+  )+  where++-- base+import Data.Kind+  ( Constraint )+import GHC.TypeLits+  ( TypeError+  , ErrorMessage(..)+  )+import GHC.TypeNats+  ( Nat, CmpNat )++-- fir+import Data.Type.Nat+  ( Succ )+import FIR.ProgramState+  ( ProgramState(ProgramState), CFGState(..) )++-------------------------------------------------++-- | The program state within the body of a loop (see 'FIR.Syntax.Program.while'+-- and 'FIR.Syntax.Program.loop'): the loop nesting level is one higher.+--+-- A combinator which runs a user-supplied computation within a loop, e.g. once for+-- each element of a collection, takes a computation of type @Program (InLoop i) (InLoop i) a@.+type family InLoop ( i :: ProgramState ) = ( i' :: ProgramState ) | i' -> i where+  InLoop ( 'ProgramState bds ctx cfg funs eps iface rayQueries bk ) =+    'ProgramState bds ctx ( CFGStateAddLoop cfg ) funs eps iface rayQueries bk++type family CFGStateAddLoop ( cfg :: CFGState ) = ( cfg' :: CFGState ) | cfg' -> cfg where+  CFGStateAddLoop ( 'CFGState currLoopLevel ) = 'CFGState ( Succ currLoopLevel )+++-- | Check whether a break statement is valid.+type family ValidBreak ( n :: Nat ) ( i :: ProgramState ) :: Constraint where+  ValidBreak 0 _ = ()+  ValidBreak n ( 'ProgramState _ _ ('CFGState currLoopDepth) _ _ _ _ _ ) =+    EnsureValidBreakNb n currLoopDepth ( n `CmpNat` currLoopDepth )++type family EnsureValidBreakNb ( n :: Nat ) ( currLoopDepth :: Nat ) ( cmp :: Ordering ) :: Constraint where+  EnsureValidBreakNb n currLoopDepth GT =+    TypeError+      (    Text "Cannot break out of " :<>: ShowType n :<>: Text " loops."+      :$$: Text "Current loop nesting level is only " :<>: ShowType currLoopDepth :<>: Text "."+      )+  EnsureValidBreakNb _ _ _ = ()++-- | Check whether a continue statement is valid.+type family ValidContinue ( n :: Nat ) ( i :: ProgramState ) :: Constraint where+  ValidContinue n ( 'ProgramState _ _ ('CFGState currLoopDepth) _ _ _ _ _ ) =+    EnsureValidBreakContinue n currLoopDepth ( n `CmpNat` currLoopDepth )++type family EnsureValidBreakContinue ( n :: Nat ) ( currLoopDepth :: Nat ) ( cmp :: Ordering ) :: Constraint where+  EnsureValidBreakContinue _ _             LT = ()+  EnsureValidBreakContinue 0 currLoopDepth _ =+    TypeError+      ( Text "Unexpected 'continue' statement: not inside a loop" )+  EnsureValidBreakContinue n currLoopDepth _ =+    TypeError+      (    Text "'breakContinue': cannot continue after breaking out of " :<>: ShowType n :<>: Text " loops."+      :$$: Text "Current loop nesting level is only " :<>: ShowType currLoopDepth :<>: Text "."+      )
+ src/FIR/Validation/Definitions.hs view
@@ -0,0 +1,412 @@+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: FIR.Validation.Definitions++Validate individual top-level "FIR.Definition.Definition"s.++For instance, this checks that uniform buffer objects are+decorated with the required binding and descriptor set indices.++Does __not__ perform validation of entry point interfaces,+i.e. input/output variables. See "FIR.Validation.Interface".+This is because it is not possible to validate layout using only the definitions,+as the layout validity of an entry point interface depends on+the specific entry-point it is used by.+For instance, an arrayed input means something different in+a tessellation evaluation shader than in a vertex shader,+because of implicit arrayness levels. See "FIR.Validation.Arrayness".++-}++module FIR.Validation.Definitions+  ( ValidDefinitions )+  where++-- base+import Data.Kind+  ( Type, Constraint )+import GHC.TypeLits+  ( Symbol+  , TypeError, ErrorMessage(..)+  )+import GHC.TypeNats+  ( Nat )++-- fir+import Data.Type.Maybe+  ( FromMaybe )+import Data.Type.Map+  ( (:->)((:->)), Map+  , InsertWithAppend, UnionWithAppend+  )+import FIR.Definition+  ( Definition(..)+  , TriagedDefinitions+  , TrieDefinitions+  )+import FIR.Prim.Array+  ( Array, RuntimeArray )+import FIR.Prim.Image+  ( Image )+import FIR.Prim.RayTracing+  ( AccelerationStructure )+import FIR.Prim.Struct+  ( Struct )+import FIR.Prim.Types+  ( HasOpaqueType )+import FIR.ProgramState+  ( TLInterfaceVariable )+import FIR.Validation.Images+  ( ImageUsageFromProperties )+import qualified SPIRV.Decoration as SPIRV+  ( Decoration(..) )+import qualified SPIRV.Image      as SPIRV+  ( ImageUsage )+import qualified SPIRV.ExecutionMode as SPIRV+  ( ExecutionMode )+import qualified SPIRV.Stage      as SPIRV+  ( ExecutionModel, NamedExecutionModel )+import qualified SPIRV.Image+  ( ImageUsage(..) )+import qualified SPIRV.Storage    as SPIRV+  ( StorageClass )+import qualified SPIRV.Storage    as Storage+  ( StorageClass(..), RayStorage(ShaderRecordBuffer) )++------------------------------------------------------------------------++-- | Validate user-supplied top-level 'FIR.Definition.Definition's.+--+-- Note that this only validates global variables and their layout,+-- as other kinds of validation are performed elsewhere.+-- See for instance 'FIR.Definition.StartState'.+type ValidDefinitions ( defs :: [ Symbol :-> Definition ] )+  = ( ValidTriagedDefinitions ( TrieDefinitions defs ) :: Constraint)++-- | Validate that descriptor set and bindings don't overlap+type family NonOverlappingDescriptors ( globs :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] )+              :: Constraint+              where+  NonOverlappingDescriptors list = EnsureNoDuplicates (BuildDescriptorList list)++type family BuildDescriptorList  ( globs :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] ) :: Map (Nat, Nat) [Symbol]+  where+    BuildDescriptorList '[] = '[]+    BuildDescriptorList  ( (storage ':-> vars) ': globs ) = UnionWithAppend (GetDescriptor vars)  (BuildDescriptorList globs)++type family AppendMaybeDescriptor ( mbDescNo :: Maybe Nat ) ( mbBdNo :: Maybe Nat ) ( name :: Symbol ) ( bds :: Map (Nat,Nat) [Symbol] ) :: Map (Nat,Nat) [Symbol] where+  AppendMaybeDescriptor ( Just descNo ) mbBdNo name bds = InsertWithAppend '( descNo, FromMaybe mbBdNo 0 ) name bds+  -- Ignore bindings which don't have a "DescriptorSet" decoration.+  AppendMaybeDescriptor _ _ _ bds = bds++type family GetDescriptor  ( globs :: [ Symbol :-> TLInterfaceVariable ] ) :: Map (Nat, Nat) [Symbol]+  where+    GetDescriptor '[] = '[]+    GetDescriptor  ( (k ':-> '( decs, ty )) ': globs ) =+      AppendMaybeDescriptor ( ExtractDescriptorSet decs ) ( ExtractBinding decs ) k ( GetDescriptor globs )++type family ExtractDescriptorSet  ( decs :: [ SPIRV.Decoration Nat ] ) :: Maybe Nat+  where+    ExtractDescriptorSet '[] = 'Nothing+    ExtractDescriptorSet  (SPIRV.DescriptorSet n ': globs) = 'Just n+    ExtractDescriptorSet  (_ ': globs) = ExtractDescriptorSet globs++type family ExtractBinding  ( decs :: [ SPIRV.Decoration Nat ] ) :: Maybe Nat+  where+    ExtractBinding '[] = 'Nothing+    ExtractBinding  (SPIRV.Binding n ': globs) = 'Just n+    ExtractBinding  (_ ': globs) = ExtractBinding globs    ++type family EnsureNoDuplicates (as :: Map (Nat,Nat) [Symbol]) :: Constraint where+  EnsureNoDuplicates '[] = ()+  EnsureNoDuplicates ( ( '( descNo, bdNo ) ':-> names ) ': bds ) = ( NoDuplicates descNo bdNo names, EnsureNoDuplicates bds )++type family NoDuplicates ( descNo :: Nat ) ( bdNo :: Nat ) ( names :: [Symbol] ) :: Constraint where+  NoDuplicates _ _ '[] = ()+  NoDuplicates _ _ '[_] = ()+  NoDuplicates descNo bdNo names = TypeError+    (    Text "More than one descriptor with DescriptorSet " :<>: ShowType descNo+    :<>: Text " and Binding " :<>: ShowType bdNo :<>: Text ":"+    :$$: ShowType names+    )+++type family ValidTriagedDefinitions ( defs :: TriagedDefinitions ) :: Constraint where+  ValidTriagedDefinitions '( _, eps, globs )+    = ( ValidGlobals globs, NonOverlappingDescriptors globs, NoDuplicateEntryPoints eps )+  --   * not validating functions: no validation necessary+  --   * execution modes are validated as part of the computation of entry point info++type family NoDuplicateEntryPoints+              ( eps :: [ Symbol :-> ( SPIRV.ExecutionModel, [ SPIRV.ExecutionMode Nat ] ) ] )+              :: Constraint+              where+  NoDuplicateEntryPoints '[] = ()+  NoDuplicateEntryPoints ( ( k ':-> '( em, _ ) ) ': eps )+    = ( EntryPointNotDeclaredIn k em eps, NoDuplicateEntryPoints eps )++type family EntryPointNotDeclaredIn+              ( k :: Symbol ) ( em :: SPIRV.ExecutionModel )+              ( eps :: [ Symbol :-> ( SPIRV.ExecutionModel, [ SPIRV.ExecutionMode Nat ] ) ] )+              :: Constraint+              where+  EntryPointNotDeclaredIn _ _ '[] = ()+  EntryPointNotDeclaredIn k em ( ( k ':-> '( em, _ ) ) ': _ )+    = TypeError+        (    Text "Duplicate entry point declaration: "+        :<>: Text ( SPIRV.NamedExecutionModel k em ) :<>: Text "."+        )+  EntryPointNotDeclaredIn k em ( _ ': eps ) = EntryPointNotDeclaredIn k em eps++type family ValidGlobals+              ( globs :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] )+              :: Constraint+              where+  ValidGlobals '[] = ()+  ValidGlobals ( ( Storage.Input ':-> _ ) ': globs )+  -- no validity checking for input variables (see "FIR.Validation.Interface")+    = ValidGlobals globs+  ValidGlobals ( ( Storage.Output ':-> _ ) ': globs )+  -- no validity checking for output variables (see "FIR.Validation.Interface")+    = ValidGlobals globs+  ValidGlobals ( ( storage ':-> vars ) ': globs )+    = ( MapValidGlobal storage vars+      , ValidGlobals   globs+      )+++type family MapValidGlobal+              ( storage :: SPIRV.StorageClass )+              ( globals :: [ Symbol :-> TLInterfaceVariable ] )+            :: Constraint+            where+  MapValidGlobal _ '[] = ()+  MapValidGlobal storage ( ( k ':-> '( decs, ty ) ) ': globals )+    = ( ValidGlobal  k storage decs ty+      , MapValidGlobal storage globals+      )++type family ValidGlobal+              ( name    :: Symbol                   )+              ( storage :: SPIRV.StorageClass       )+              ( decs    :: [ SPIRV.Decoration Nat ] )+              ( ty      :: Type                     )+              :: Constraint+              where+  ValidGlobal name Storage.UniformConstant decs (Image props)+    = ( ValidUniformDecorations+        ( Text "Image named " :<>: ShowType name )+        decs+        (Image props)+      , ValidImageDecorations name (ImageUsageFromProperties props) decs+      )+  ValidGlobal name Storage.UniformConstant decs AccelerationStructure+    = ValidUniformDecorations+        ( Text "Acceleration structure named " :<>: ShowType name )+        decs+        AccelerationStructure+  ValidGlobal name Storage.UniformConstant _ otherTy+    = TypeError+        (    Text "Uniform constant global named " :<>: ShowType name+        :<>: Text " points to unexpected type "+        :<>: ShowType otherTy :<>: Text "."+        )+  ValidGlobal name Storage.Image decs (Image props)+    = ( ValidUniformDecorations+        ( Text "Storage image named " :<>: ShowType name )+        decs+        (Image props)+      , ValidImageDecorations name (ImageUsageFromProperties props) decs+      )+  ValidGlobal name Storage.Image  _ nonImageTy+    = TypeError+        (    Text "Image global named " :<>: ShowType name+        :<>: Text " expected to point to an image, but points to "+        :<>: ShowType nonImageTy :<>: Text " instead."+        )+  ValidGlobal name Storage.Uniform decs (Struct as)+    = ( ValidUniformDecorations+          ( Text "Uniform buffer named " :<>: ShowType name )+          decs+          (Struct as)+      , NoOpaqueTypes name ( Text "buffer" ) as+      )+  ValidGlobal name Storage.Uniform decs (Array n (Struct as))+    = ( ValidUniformDecorations+          ( Text "Uniform buffer named " :<>: ShowType name )+          decs+          (Array n (Struct as))+      , NoOpaqueTypes name ( Text "buffer" ) as+      )+  ValidGlobal name Storage.Uniform _ ty+    = TypeError+        (    Text "Uniform buffer named " :<>: ShowType name+        :<>: Text " should be backed by a struct or a fixed-size array containing a struct;"+        :$$: Text "found type " :<>: ShowType ty :<>: Text " instead."+        )+  ValidGlobal name Storage.StorageBuffer decs (Struct as)+      = ( ValidUniformDecorations+            ( Text "Uniform storage buffer named " :<>: ShowType name )+            decs+            (Struct as)+        , NoOpaqueTypesExceptRuntimeArrayLast name as+        )+  ValidGlobal name Storage.StorageBuffer decs (Array n (Struct as))+      = ( ValidUniformDecorations+            ( Text "Uniform storage buffer named " :<>: ShowType name )+            decs+            (Array n (Struct as))+        , NoOpaqueTypes name ( Text "storage buffer" ) as+        )+  ValidGlobal name Storage.StorageBuffer decs (RuntimeArray a)+    = TypeError+        (    Text "Uniform storage buffer named " :<>: ShowType name+        :<>: Text " should be backed by a struct or a fixed-size array containing a struct;"+        :$$: Text "found type " :<>: ShowType (RuntimeArray a) :<>: Text " instead."+        :$$: Text "To use a dynamically sized array in a storage buffer, define a structure"+        :<>: Text " whose last member is a RuntimeArray."+        )+  ValidGlobal name Storage.StorageBuffer _ ty+    = TypeError+        (    Text "Uniform storage buffer named " :<>: ShowType name+        :<>: Text " should be backed by a struct or fixed-size array containing a struct;"+        :$$: Text "found type " :<>: ShowType ty :<>: Text " instead."+        )+  ValidGlobal name Storage.PushConstant _ (Struct as)+    = NoOpaqueTypes name ( Text "push constant" ) as+  ValidGlobal name Storage.PushConstant _ ty+    = TypeError+        (    Text "Push constant named " :<>: ShowType name+        :<>: Text " should be backed by a struct;"+        :$$: Text "found type " :<>: ShowType ty :<>: Text " instead."+        )+  ValidGlobal name ( 'Storage.RayStorage Storage.ShaderRecordBuffer ) _ (Struct as)+    = NoOpaqueTypesExceptRuntimeArrayLast name as+  ValidGlobal name ( 'Storage.RayStorage Storage.ShaderRecordBuffer ) _ ty+    = TypeError+        (    Text "Shader record buffer named " :<>: ShowType name+        :<>: Text " should be backed by a struct;"+        :$$: Text "found type " :<>: ShowType ty :<>: Text " instead."+        )+  -- TODO: more validation for ray-tracing storage classes+  ValidGlobal _ _ _ _ = ()++type family ValidUniformDecorations+              ( name :: ErrorMessage             )+              ( decs :: [ SPIRV.Decoration Nat ] )+              ( ty   :: Type                     )+            :: Constraint+            where+  ValidUniformDecorations name decs _+    = ( HasBinding name decs, HasDescriptorSet name decs )++type family HasBinding+              ( name :: ErrorMessage             )+              ( decs :: [ SPIRV.Decoration Nat ] )+            :: Constraint+            where+  HasBinding _    ( SPIRV.Binding _ ': _ ) = ()+  HasBinding name ( _ ': decs ) = HasBinding name decs+  HasBinding name '[]+    = TypeError+        ( name :<>: Text " is missing a 'Binding' decoration." )++type family HasDescriptorSet+              ( name :: ErrorMessage             )+              ( decs :: [ SPIRV.Decoration Nat ] )+            :: Constraint+            where+  HasDescriptorSet _    ( SPIRV.DescriptorSet _ ': _ ) = ()+  HasDescriptorSet name ( _ ': decs ) = HasDescriptorSet name decs+  HasDescriptorSet name '[]+    = TypeError+        ( name :<>: Text " is missing a 'DescriptorSet' decoration." )++type family HasLocation+              ( name :: Symbol                   )+              ( decs :: [ SPIRV.Decoration Nat ] )+              :: Constraint+              where+  HasLocation _    ( SPIRV.Location _ ': _ ) = ()+  HasLocation name ( _ ': decs ) = HasLocation name decs+  HasLocation name '[]+    = TypeError+        ( ShowType name :<>: Text " is missing a 'Location' decoration." )++-- TODO: I'm not sure what the valid decorations are here...+type family ValidImageDecorations+              ( name    :: Symbol                  )+              ( imageTy :: SPIRV.ImageUsage        )+              ( decs    :: [ SPIRV.Decoration Nat] )+            :: Constraint+            where+  ValidImageDecorations _    _ '[]          = ()+  ValidImageDecorations name ty ( SPIRV.DescriptorSet _ ': decs )+    = ValidImageDecorations name ty decs+  ValidImageDecorations name ty ( SPIRV.Binding _ ': decs )+    = ValidImageDecorations name ty decs+  ValidImageDecorations name ty ( SPIRV.NonReadable ': decs )+    = ValidImageDecorations name ty decs+  ValidImageDecorations name SPIRV.Image.Storage ( SPIRV.NonWritable ': decs )+    = ValidImageDecorations name SPIRV.Image.Storage decs+  ValidImageDecorations name _ ( dec ': _ )+    = TypeError+        (    Text "Unexpected decoration " :<>: ShowType dec+        :<>: Text " applied to image named " :<>: ShowType name+        :<>: Text "."+        )++type family NoOpaqueTypes+              ( name    :: Symbol              )+              ( loc     :: ErrorMessage        )+              ( as      :: [ Symbol :-> Type ] )+            :: Constraint+            where+  NoOpaqueTypes _    _     '[] = ()+  NoOpaqueTypes name loc ((k ':-> a) ': as) =+    ( ErrorIfOpaque (HasOpaqueType a) name loc k a+    , NoOpaqueTypes name loc as+    )++type family ErrorIfOpaque (hasOpaque :: Bool) (name :: Symbol) (loc :: ErrorMessage) (k :: Symbol) (a :: Type) :: Constraint where+  ErrorIfOpaque True name loc k a =+    TypeError+      (    Text "Structure member " :<>: ShowType k :<>: Text " cannot appear"+      :<>: Text " in " :<>: loc :<>: Text " named " :<>: ShowType name :<>: Text "."+      :$$: Text "Its type " :<>: ShowType a +      :$$: Text "is opaque (or it contains an opaque type)."+      )+  ErrorIfOpaque _ _ _ _ _ = ()++type family NoOpaqueTypesExceptRuntimeArrayLast ( name :: Symbol ) ( as :: [ Symbol :-> Type ] ) :: Constraint where+  NoOpaqueTypesExceptRuntimeArrayLast _   '[] = ()+  NoOpaqueTypesExceptRuntimeArrayLast name ( ( k ':-> RuntimeArray a ) ': '[] ) =+    ErrorIfOpaqueRuntimeArray (HasOpaqueType a) name k a+  NoOpaqueTypesExceptRuntimeArrayLast name ( ( k ':-> RuntimeArray a ) ': _ ) =+    TypeError+      (    Text "Unexpected runtime array named " :<>: ShowType k+      :<>: Text " within storage buffer named " :<>: Text name :<>: Text "."+      :$$: Text "Runtime arrays must appear last in the structure."+      )+  NoOpaqueTypesExceptRuntimeArrayLast name ( ( k ':-> a ) ': as ) =+    ( NoOpaqueTypes name ( Text "storage buffer" ) '[ k ':-> a ]+    , NoOpaqueTypesExceptRuntimeArrayLast name as+    )++type family ErrorIfOpaqueRuntimeArray (hasOpaque :: Bool) (name :: Symbol) (k :: Symbol) (a :: Type) :: Constraint where+  ErrorIfOpaqueRuntimeArray True name k a =+    TypeError+      (    Text "Structure member " :<>: ShowType k :<>: Text " cannot appear"+      :<>: Text " in storage buffer named " :<>: ShowType name :<>: Text "."+      :$$: Text "It is a runtime array whose element type"+      :$$: ShowType a+      :$$: Text "is opaque, or contains an opaque type."+      )+  ErrorIfOpaqueRuntimeArray _ _ _ _ = ()
+ src/FIR/Validation/ExecutionModes.hs view
@@ -0,0 +1,416 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: FIR.Validation.Definitions++Validate user-provided execution modes.++For instance, this checks that compute shaders+are decorated with local group sizes,+or that a geometry shader specifies its output+primitive type.++-}++module FIR.Validation.ExecutionModes where++-- base+import Data.Type.Bool+  ( If, type (&&) )+import GHC.TypeLits+  ( Symbol+  , TypeError, ErrorMessage(..)+  )+import GHC.TypeNats+  ( Nat )++-- fir+import Data.Type.Error+  ( Assert )+import Data.Type.List+  ( Elem )+import Data.Type.Maybe+  ( IsJust, FromMaybe )+import SPIRV.ExecutionMode+import SPIRV.Stage++--------------------------------------------------+-- validation of execution modes (at the type level)++type family ValidModelsFor (mode :: ExecutionMode Nat) :: [ ExecutionModel ] where+  ValidModelsFor (Invocations _)         = '[ Geometry ]+  ValidModelsFor SpacingEqual            = '[ TessellationControl, TessellationEvaluation ]+  ValidModelsFor SpacingFractionalEven   = '[ TessellationControl, TessellationEvaluation ]+  ValidModelsFor SpacingFractionalOdd    = '[ TessellationControl, TessellationEvaluation ]+  ValidModelsFor VertexOrderCw           = '[ TessellationControl, TessellationEvaluation ]+  ValidModelsFor VertexOrderCcw          = '[ TessellationControl, TessellationEvaluation ]+  ValidModelsFor PixelCenterInteger      = '[ Fragment ]+  ValidModelsFor OriginUpperLeft         = '[ Fragment ]+  ValidModelsFor OriginLowerLeft         = '[ Fragment ]+  ValidModelsFor EarlyFragmentTests      = '[ Fragment ]+  ValidModelsFor PointMode               = '[ TessellationControl, TessellationEvaluation ]+  ValidModelsFor DepthReplacing          = '[ Fragment ]+  ValidModelsFor DepthGreater            = '[ Fragment ]+  ValidModelsFor DepthLess               = '[ Fragment ]+  ValidModelsFor DepthUnchanged          = '[ Fragment ]+  ValidModelsFor (LocalSize _ _ _)       = '[ Compute, Kernel ]+  ValidModelsFor (LocalSizeHint _ _ _)   = '[ Kernel ]+  ValidModelsFor InputPoints             = '[ Geometry ]+  ValidModelsFor InputLines              = '[ Geometry ]+  ValidModelsFor InputLinesAdjacency     = '[ Geometry ]+  ValidModelsFor Triangles               = '[ Geometry, TessellationControl, TessellationEvaluation ]+  ValidModelsFor InputTrianglesAdjacency = '[ Geometry ]+  ValidModelsFor Quads                   = '[ TessellationControl, TessellationEvaluation ]+  ValidModelsFor Isolines                = '[ TessellationControl, TessellationEvaluation ]+  ValidModelsFor (OutputVertices _)      = '[ Geometry, TessellationControl, TessellationEvaluation ]+  ValidModelsFor OutputPoints            = '[ Geometry ]+  ValidModelsFor OutputLineStrip         = '[ Geometry ]+  ValidModelsFor OutputTriangleStrip     = '[ Geometry ]+  ValidModelsFor (VecTypeHint _)         = '[ Kernel ]+  ValidModelsFor ContractionOff          = '[ Kernel ]+  ValidModelsFor (MaxPatchVertices _)    = '[ TessellationControl ]+  ValidModelsFor _+    -- for the moment, anything else is considered valid (no validity checks)+    = '[ Vertex, TessellationControl, TessellationEvaluation, Geometry, Fragment, Compute, Kernel ]+++type family ValidateExecutionModes+                ( k     :: Symbol              )+                ( em    :: ExecutionModel      )+                ( modes :: [ExecutionMode Nat] )+              :: Maybe (ExecutionInfo Nat em)+              where+  ValidateExecutionModes k Fragment modes+    = If (  HasValidOrigin k ( BackendOf Fragment ) modes+         && HasAtMostOneOf k Fragment '[ DepthGreater, DepthLess, DepthUnchanged ] modes+         && PertainTo k Fragment modes+         )+        ( Just FragmentInfo )+        Nothing+  ValidateExecutionModes k Vertex modes+    = If ( PertainTo k Vertex modes )+         ( Just VertexInfo )+         Nothing+  ValidateExecutionModes k TessellationControl modes+    = If (  HasOneOf       k TessellationControl '[ SpacingEqual, SpacingFractionalEven, SpacingFractionalOdd ] modes+         && HasAtMostOneOf k TessellationControl '[ VertexOrderCw, VertexOrderCcw ] modes+         && PertainTo      k TessellationControl modes+         )+        ( Just+            ( TessellationControlInfo+              ( TessellationControlMaxPatchVertices k modes )+              ( TessellationControlOutputSize       k modes )+              ( TessellationControlMbMode           k modes )+            )+        )+        Nothing+  ValidateExecutionModes k TessellationEvaluation modes+    = If (  HasAtMostOneOf k TessellationEvaluation '[ SpacingEqual, SpacingFractionalEven, SpacingFractionalOdd ] modes+         && HasAtMostOneOf k TessellationEvaluation '[ VertexOrderCw, VertexOrderCcw ] modes+         && PertainTo      k TessellationEvaluation modes+         )+        ( Just+          ( TessellationEvaluationInfo+              32 -- default value+              ( TessellationEvaluationMode k modes )+          )+        )+        Nothing+  ValidateExecutionModes k Geometry modes+    = If (  HasOneOf k Geometry '[ OutputPoints, OutputLineStrip, OutputTriangleStrip ] modes+         && HasInvocations k modes+         )+        ( Just+          ( GeometryInputInfo k modes )+        )+        Nothing+  ValidateExecutionModes k Compute modes+    = If ( PertainTo k Compute modes )+        ( Just (ComputeInfo (LocalSizes k Compute modes) ) )+        Nothing+  ValidateExecutionModes k Kernel modes+    = If ( PertainTo k Kernel modes )+        ( Just (KernelInfo (LocalSizes k Kernel modes) ) )+        Nothing+  ValidateExecutionModes k ( 'Stage ( 'RayStage rayShader ) ) modes+    = If ( PertainTo k ( 'Stage ( 'RayStage rayShader ) ) modes )+      ( Just ( 'RayShaderInfo ( MkRayShaderInfo rayShader ) ) )+      Nothing+  ValidateExecutionModes k em _+    = TypeError ( Text "Unsupported " :<>: Text (NamedExecutionModel k em) )++type family PertainTo (k :: Symbol) (em :: ExecutionModel) (modes :: [ExecutionMode Nat]) :: Bool where+  PertainTo _ _ '[] = True+  PertainTo k s (mode ': modes)+    = Pertains k s mode (s `Elem` ValidModelsFor mode) && PertainTo k s modes++type family Pertains (k :: Symbol) (em :: ExecutionModel) (mode :: m) (ok :: Bool) :: Bool where+  Pertains _ _ _ True = True+  Pertains k em mode False+    = TypeError+        (    Text (NamedExecutionModel k em) :<>: Text " does not support execution mode "+        :<>: ShowType mode :<>: Text "."+        )++-- | A fragment shader must specify its origin.+--+-- Vulkan only allows 'OriginUpperLeft'.+type family HasValidOrigin (k :: Symbol) (backend :: Backend) (modes :: [ExecutionMode Nat]) :: Bool where+  HasValidOrigin k Vulkan modes+    = If ( OriginLowerLeft `Elem` modes )+        ( TypeError+            (    Text (NamedExecutionModel k Fragment) :<>: Text " uses execution mode OriginLowerLeft, which Vulkan does not allow."+            :$$: Text "Use OriginUpperLeft instead."+            )+        )+        ( HasOneOf k Fragment '[ OriginUpperLeft ] modes )+  HasValidOrigin k _ modes+    = HasOneOf k Fragment '[ OriginLowerLeft, OriginUpperLeft ] modes++type family HasOneOf (k :: Symbol) (em :: ExecutionModel) (oneOf :: [ m ]) (modes :: [ m ]) :: Bool where+  HasOneOf k em oneOf modes+    = If ( IsJust ( LookupOneOf k em oneOf modes ) )+        True+        ( TypeError+            ( Text (NamedExecutionModel k em) :<>: Text " needs to be given one of the following execution modes:"+             :$$: ShowType oneOf+            )+        )++type family HasAtMostOneOf (k :: Symbol) (em :: ExecutionModel) (oneOf :: [ m ]) (modes :: [ m ]) :: Bool where+  HasAtMostOneOf k em oneOf modes+    = If ( IsJust ( LookupOneOf k em oneOf modes ) ) -- computes LookupOneOf which will error if there are conflicts+        True+        True++type family LookupOneOf (k :: Symbol) (em :: ExecutionModel) (oneOf :: [ m ]) (modes :: [ m ]) :: Maybe m where+  LookupOneOf k em oneOf '[] = Nothing+  LookupOneOf k em oneOf (mode ': modes)+    = If ( mode `Elem` oneOf )+        ( Just (NoConflictWithLookupOneOf k em mode ( LookupOneOf k em oneOf modes ) ) )+        ( LookupOneOf k em oneOf modes )++type family NoConflictWithLookupOneOf (k :: Symbol) (em :: ExecutionModel) (already :: m) (another :: Maybe m) :: m where+  NoConflictWithLookupOneOf _ _  already Nothing = already+  NoConflictWithLookupOneOf k em already (Just another)+    = TypeError+        (    Text (NamedExecutionModel k em) :<>: Text " has conflicting execution modes: "+        :<>: ShowType already :<>: Text " and " :<>: ShowType another :<>: Text "."+        )+++type family GeometryInputInfo+              ( k :: Symbol )+              ( modes :: [ ExecutionMode Nat ] )+              :: (ExecutionInfo Nat Geometry)  where+  GeometryInputInfo k '[]+    = TypeError+      (    Text (NamedExecutionModel k Geometry) :<>: Text " is under-specified: missing input information."+      :$$: Text "Must specify exactly one of 'Triangles', 'InputTrianglesAdjacency',\+                \ 'InputPoints', 'InputLines', 'InputLinesAdjacency'."+      )+  GeometryInputInfo k ( InputPoints ': modes )+    = Assert ( NoSizes k Geometry InputPoints modes )+        ( GeometryInfo 1 InputModePoints )+  GeometryInputInfo k ( InputLines ': modes )+    = Assert ( NoSizes k Geometry InputLines modes )+        ( GeometryInfo 2 InputModeLines )+  GeometryInputInfo k ( InputLinesAdjacency ': modes )+    = Assert ( NoSizes k Geometry InputLinesAdjacency modes )+        ( GeometryInfo 4 InputModeLinesAdjacency )+  GeometryInputInfo k ( Triangles ': modes )+    = Assert ( NoSizes k Geometry Triangles modes )+        ( GeometryInfo 3 InputModeTriangles )+  GeometryInputInfo k ( InputTrianglesAdjacency ': modes )+    = Assert ( NoSizes k Geometry Triangles modes )+        ( GeometryInfo 6 InputModeTrianglesAdjacency )+  GeometryInputInfo k ( _ ': modes )+    = GeometryInputInfo k modes++type family TessellationControlMbMode+              ( k     :: Symbol                )+              ( modes :: [ ExecutionMode Nat ] )+            :: Maybe TessellationMode+            where+  TessellationControlMbMode k modes+    = FmapReadTessellationMode+        ( LookupOneOf k TessellationControl+            '[ Triangles, Quads, Isolines, PointMode ]+            modes+        )++type family FmapReadTessellationMode+               ( m :: Maybe (ExecutionMode Nat) )+            :: Maybe TessellationMode+            where+  FmapReadTessellationMode 'Nothing = 'Nothing+  FmapReadTessellationMode ('Just mode) = 'Just (ReadTessellationMode mode)++type family ReadTessellationMode (m :: ExecutionMode Nat) :: TessellationMode where+  ReadTessellationMode Triangles = ModeTriangles+  ReadTessellationMode Quads = ModeQuads+  ReadTessellationMode Isolines = ModeIsolines+  ReadTessellationMode PointMode = ModePoints+  ReadTessellationMode nonMode+    = TypeError+      (    Text "Expected tessellation mode, but got " :<>: ShowType nonMode+      :<>: Text " instead."+      )+++type family TessellationEvaluationMode+              ( k     :: Symbol                )+              ( modes :: [ ExecutionMode Nat ] )+            :: TessellationMode+            where+  TessellationEvaluationMode k modes+    = ReadTessellationMode+        ( FromMaybe+          ( LookupOneOf k TessellationEvaluation+            '[ Triangles, Quads, Isolines, PointMode ]+            modes+          )+          ( TypeError+            (    Text (NamedExecutionModel k TessellationEvaluation)+            :<>: Text " does not specify its tessellation mode."+            :$$: Text "One of 'Triangles', 'Quads', 'Isolines' or 'PointMode' must be provided."+            )+          )+        )++type family TessellationControlOutputSize+              ( k     :: Symbol                )+              ( modes :: [ ExecutionMode Nat ] )+            :: Nat+            where+  TessellationControlOutputSize k '[]+    = TypeError+      (   Text (NamedExecutionModel k TessellationControl) :<>: Text " is under-specified: missing number of output points."+      :$$: Text "The 'OutputVertices' execution mode must be provided."+      )+  TessellationControlOutputSize k ( OutputVertices verts ': modes )+    = Assert ( NoOutputVertices k TessellationControl verts modes )+        verts+  TessellationControlOutputSize k (_ ': modes )+    = TessellationControlOutputSize k modes++type family TessellationControlMaxPatchVertices ( k :: Symbol ) ( modes :: [ ExecutionMode Nat ] ) :: Nat where+  TessellationControlMaxPatchVertices k '[] = 32 -- default as used by SPIR-V+  TessellationControlMaxPatchVertices k ( MaxPatchVertices verts ': _ )+    = verts+  TessellationControlMaxPatchVertices k (_ ': modes)+    = TessellationControlMaxPatchVertices k modes++type family NoSizes+              ( k         :: Symbol                )+              ( em        :: ExecutionModel        )+              ( givenSize :: ExecutionMode Nat     )+              ( modes     :: [ ExecutionMode Nat ] )+              :: Bool+              where+  NoSizes _ _  _     '[]+    = 'True+  NoSizes k em given (InputPoints ': _ )+    = TypeError+        (   Text (NamedExecutionModel k em) :<>: Text " has conflicting inputs."+        :$$:  Text "Provided both " :<>: ShowType given :<>: Text " and " :<>: ShowType (InputPoints :: ExecutionMode Nat ) :<>: Text "."+        )+  NoSizes k em given (InputLines ': _ )+    = TypeError+        (   Text (NamedExecutionModel k em) :<>: Text " has conflicting inputs."+        :$$:  Text "Provided both " :<>: ShowType given :<>: Text " and " :<>: ShowType (InputLines :: ExecutionMode Nat ) :<>: Text "."+        )+  NoSizes k em given (InputLinesAdjacency ': _ )+    = TypeError+        (   Text (NamedExecutionModel k em) :<>: Text " has conflicting inputs."+        :$$:  Text "Provided both " :<>: ShowType given :<>: Text " and " :<>: ShowType ( InputLinesAdjacency :: ExecutionMode Nat ) :<>: Text "."+        )+  NoSizes k em given (Triangles ': _ )+    = TypeError+        (   Text (NamedExecutionModel k em) :<>: Text " has conflicting inputs."+        :$$:  Text "Provided both " :<>: ShowType given :<>: Text " and " :<>: ShowType ( Triangles :: ExecutionMode Nat ) :<>: Text "."+        )+  NoSizes k em given (InputTrianglesAdjacency ': _ )+    = TypeError+        (   Text (NamedExecutionModel k em) :<>: Text " has conflicting inputs."+        :$$:  Text "Provided both " :<>: ShowType given :<>: Text " and " :<>: ShowType ( InputTrianglesAdjacency :: ExecutionMode Nat ) :<>: Text "."+        )+  NoSizes k em given (Quads ': _ )+    = TypeError+        (   Text (NamedExecutionModel k em) :<>: Text " has conflicting inputs."+        :$$:  Text "Provided both " :<>: ShowType given :<>: Text " and " :<>: ShowType ( Quads :: ExecutionMode Nat ) :<>: Text "."+        )+  NoSizes k em given (Isolines ': _ )+    = TypeError+        (   Text (NamedExecutionModel k em) :<>: Text " has conflicting inputs."+        :$$:  Text "Provided both " :<>: ShowType given :<>: Text " and " :<>: ShowType ( Isolines :: ExecutionMode Nat ) :<>: Text "."+        )+  NoSizes k em given ( _ ': modes )+    = NoSizes k em given modes++type family NoOutputVertices+              ( k          :: Symbol                )+              ( em         :: ExecutionModel        )+              ( givenVerts :: Nat                   )+              ( modes      :: [ ExecutionMode Nat ] )+            :: Bool+            where+  NoOutputVertices _ _  _        '[] = True+  NoOutputVertices k em givenVerts ( OutputVertices verts ': _ )+    = TypeError+        (   Text (NamedExecutionModel k em) :<>: Text "has conflicting numbers of output vertices."+        :$$:  Text "Provided both " :<>: ShowType givenVerts :<>: Text " and " :<>: ShowType verts :<>: Text "."+        )+  NoOutputVertices k em given ( _ ': modes )+    = NoOutputVertices k em given modes++type family LocalSizes+              ( k     :: Symbol                )+              ( em    :: ExecutionModel        )+              ( modes :: [ ExecutionMode Nat ] )+            :: (Nat, Nat, Nat)+            where+  LocalSizes k em '[]+    = TypeError+    ( Text (NamedExecutionModel k em) :<>: Text " is missing 'LocalSize' information." )+  LocalSizes k em ( LocalSize x y z ': modes )+    = Assert ( NoLocalSizes k em '(x,y,z) modes )+        ( '(x,y,z) )+  LocalSizes k em ( _ ': modes ) = LocalSizes k em modes++type family NoLocalSizes+              ( k     :: Symbol                )+              ( em    :: ExecutionModel        )+              ( xyz   :: (Nat,Nat,Nat)         )+              ( modes :: [ ExecutionMode Nat ] )+            :: Bool+            where+  NoLocalSizes _ _ _ '[] = 'True+  NoLocalSizes k em xyz (LocalSize x' y' z' ': _)+    = TypeError+    ( Text (NamedExecutionModel k em) :<>: Text " has conflicting local size information."+    :$$: Text "Provided both " :<>: ShowType xyz+    :<>: Text " and " :<>: ShowType '(x',y',z') :<>: Text "."+    )+  NoLocalSizes k em xyz ( _ ': modes )+    = NoLocalSizes k em xyz modes++type family HasInvocations+              ( k     :: Symbol                )+              ( modes :: [ ExecutionMode Nat ] )+           :: Bool+           where+  HasInvocations k '[]+    = TypeError+    (    Text (NamedExecutionModel k Geometry) :<>: Text " is missing the number of invocations."+    :$$: Text "Expecting an 'Invocations i' execution mode, with 0 < i <= maxGeometryShaderInvocations."+    )+  HasInvocations k ( Invocations 0 ': _ )+    = TypeError+    ( Text (NamedExecutionModel k Geometry) :<>: Text ": number of invocations cannot be 0." )+  HasInvocations k ( Invocations _ ': _ ) = True+  HasInvocations k ( _ ': modes ) = HasInvocations k modes
+ src/FIR/Validation/Formats.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: FIR.Validation.Formats++Computes the image formats underlying a given layout.++-}++module FIR.Validation.Formats+  ( ComputeFormats )+  where++-- base+import Data.Kind+  ( Type )+import Data.Type.Bool+  ( If, type (&&), type (||) )+import Data.Type.Equality+  ( type (==) )+import GHC.TypeNats+  ( Nat+  , type (+), type (-), Div+  )++-- fir+import Data.Type.List+  ( Length, Replicate, type (:++:) )+import Data.Type.Map+  ( Map, (:->)((:->)) )+import Data.Type.POrd+  ( POrd(..) )+import FIR.Prim.Array+  ( Array )+import FIR.Prim.Struct+  ( LocationSlot(LocationSlot) )+import FIR.Prim.Types+  ( SKPrimTy(..), SKPrimTyMap(..)+  , PrimTySing+  , ScalarFromSScalar+  )+import Math.Linear+  ( V, M )+import qualified SPIRV.Image+import qualified SPIRV.Image    as SPIRV+  ( ImageFormat(ImageFormat) )+import qualified SPIRV.ScalarTy as SPIRV++--------------------------------------------------------------------------+-- computing image formats for vertex input backed by a structure type++type family ComputeFormats+              ( slots :: Map (LocationSlot Nat) Type )+            :: Map Nat ( SPIRV.ImageFormat Nat )+            where+  ComputeFormats '[] = '[]+  ComputeFormats ( (loc ':-> ty) ': slots )+    = InsertFormatsCombining+        ( ComputeSlotFormats loc (PrimTySing ty) )+        ( ComputeFormats slots )++--------------------------------------------------------------------------+-- computing image formats for a given type++type family ComputeSlotFormats+              ( loc  :: LocationSlot Nat )+              ( skTy :: SKPrimTy ty      )+            :: [ Nat :-> SPIRV.ImageFormat Nat ]+            where+  -- scalars+  ComputeSlotFormats ('LocationSlot l c) ( SKScalar s :: SKPrimTy ty )+    = '[ l ':-> ScalarFormat ('LocationSlot l c) 1 ( ScalarFromSScalar s ) ]+  -- vectors+  ComputeSlotFormats ('LocationSlot l c) ( SKVector s :: SKPrimTy (V m ty) )+    = '[ l ':-> ScalarFormat ('LocationSlot l c) m ( ScalarFromSScalar s ) ]+  -- matrices+  ComputeSlotFormats ('LocationSlot l c) ( SKMatrix s :: SKPrimTy (M m n ty) )+    = MatrixSlotFormats l m+        ( ComponentOf ( ScalarFromSScalar s ) )+        ( SPIRV.WidthToNat (SPIRV.ScalarWidth ( ScalarFromSScalar s ) ) )+  -- arrays+  ComputeSlotFormats ('LocationSlot l c) ( SKArray elt :: SKPrimTy (Array 0 ty) )+    = '[ ]+  ComputeSlotFormats ('LocationSlot l c) ( SKArray elt :: SKPrimTy (Array 1 ty) )+    = ComputeSlotFormats ('LocationSlot l c) ( elt :: SKPrimTy ty )+  ComputeSlotFormats ('LocationSlot l c) ( SKArray elt :: SKPrimTy (Array n ty) )+    = CompoundSlotFormats+        ( 'LocationSlot l c )+        ( ComputeSlotFormats ('LocationSlot l c) elt )+        ( SKArray elt :: SKPrimTy (Array (n-1) ty) )+  -- structs+  ComputeSlotFormats ('LocationSlot l c) ( SKStruct SKNil ) = '[]+  ComputeSlotFormats ('LocationSlot l c) ( SKStruct (elt `SKCons` elts) )+    = CompoundSlotFormats+        ( 'LocationSlot l c )+        ( ComputeSlotFormats ('LocationSlot l c) elt )+        ( SKStruct elts )+  -- unsupported types: unit, bool, runtime array+  ComputeSlotFormats _  SKUnit             = '[]+  ComputeSlotFormats _  SKBool             = '[]+  ComputeSlotFormats _ (SKRuntimeArray _ ) = '[]++type family ScalarFormat+              ( loc      :: LocationSlot Nat )+              ( elems    :: Nat              )+              ( scalarTy :: SPIRV.ScalarTy   )+            :: SPIRV.ImageFormat Nat+            where+  ScalarFormat loc elems scalarTy+    = FormatForComponentsOfWidth+        loc elems+        ( ComponentOf scalarTy )+        ( SPIRV.WidthToNat (SPIRV.ScalarWidth scalarTy ) )++type family MatrixSlotFormats+              ( loc   :: Nat                   )+              ( n     :: Nat                   )+              ( comp  :: SPIRV.Image.Component )+              ( width :: Nat                   )+           :: [ Nat :-> SPIRV.ImageFormat Nat ]+           where+  MatrixSlotFormats _ 0 _    _ = '[]+  MatrixSlotFormats l 1 comp w = '[ l ':-> 'SPIRV.ImageFormat comp ( Replicate 4 w ) ]+  MatrixSlotFormats l n comp w+    = ( l ':-> 'SPIRV.ImageFormat comp ( Replicate 4 w ) )+    ': MatrixSlotFormats ( l + ( w `Div` 32 ) ) ( n-1 ) comp w++type family CompoundSlotFormats+              ( loc  :: LocationSlot Nat                  )+              ( fmts :: [ Nat :-> SPIRV.ImageFormat Nat ] )+              ( skTy :: SKPrimTy ty                       )+           :: [ Nat :-> SPIRV.ImageFormat Nat ]+           where+  CompoundSlotFormats ('LocationSlot l c) fmts skTy+    = fmts+    :++:+    ComputeSlotFormats ('LocationSlot (NextAvailableLocation l fmts) c) skTy++type family NextAvailableLocation+              ( loc  :: Nat                               )+              ( fmts :: [ Nat :-> SPIRV.ImageFormat Nat ] )+            :: Nat+            where+  NextAvailableLocation l '[]+    = l+  NextAvailableLocation _ ( (l ':-> _) ': ls )+    = NextAvailableLocation (l + 1) ls++type family FormatForComponentsOfWidth+              ( loc          :: LocationSlot Nat      )+              ( elems        :: Nat                   )+              ( component    :: SPIRV.Image.Component )+              ( width        :: Nat                   )+            :: ( SPIRV.ImageFormat Nat ) where+  FormatForComponentsOfWidth ('LocationSlot _ c) elems comp w+    = 'SPIRV.ImageFormat comp ( Replicate ( elems + ( c `Div` ( Max w 32 `Div` 32 ) ) ) w )++type family ComponentOf (scalar :: SPIRV.ScalarTy) :: SPIRV.Image.Component where+  ComponentOf (SPIRV.Integer SPIRV.Unsigned _) = SPIRV.Image.UI+  ComponentOf (SPIRV.Integer SPIRV.Signed   _) = SPIRV.Image.I+  ComponentOf (SPIRV.Floating _              ) = SPIRV.Image.F++--------------------------------------------------------------------------+-- combining formats++type family InsertFormatsCombining+             ( fmts :: [ Nat :-> SPIRV.ImageFormat Nat ] )+             ( nxt  :: Map Nat ( SPIRV.ImageFormat Nat ) )+          :: Map Nat ( SPIRV.ImageFormat Nat )+          where+  InsertFormatsCombining '[] nxt = nxt+  InsertFormatsCombining ( fmt ': fmts ) nxt+    = InsertFormatCombining fmt ( InsertFormatsCombining fmts nxt )++type family InsertFormatCombining+              ( fmt  :: ( Nat :-> SPIRV.ImageFormat Nat ) )+              ( fmts :: Map Nat ( SPIRV.ImageFormat Nat ) )+            :: Map Nat ( SPIRV.ImageFormat Nat )+            where+  InsertFormatCombining fmt '[]+    = '[ fmt ]+  InsertFormatCombining ( i  ':-> fmt1 ) ( ( i  ':-> fmt2 ) ': fmts )+    = ( i ':-> LargestFormat fmt1 fmt2 ) ': fmts+  InsertFormatCombining ( i1 ':-> fmt1 ) ( ( i2 ':-> fmt2 ) ': fmts )+    = MaybeInsertCombination i1 fmt1 i2 fmt2+        (Combination i1 fmt2 i2 fmt2)+        fmts++type family MaybeInsertCombination+                ( i1   :: Nat                                 )+                ( fmt1 :: SPIRV.ImageFormat Nat               )+                ( i2   :: Nat                                 )+                ( fmt2 :: SPIRV.ImageFormat Nat               )+                ( comb :: Maybe ( Nat, SPIRV.ImageFormat Nat) )+                ( fmts :: Map Nat ( SPIRV.ImageFormat Nat )   )+              :: Map Nat ( SPIRV.ImageFormat Nat )+              where+  MaybeInsertCombination _  _    _  _    ( Just '(i, fmt) ) fmts+    = ( ( i ':-> fmt ) ': fmts )+  MaybeInsertCombination i1 fmt1 i2 fmt2 'Nothing           fmts+    = If ( i1 :< i2 )+        ( ( i1 ':-> fmt1 ) ': ( i2 ':-> fmt2 ) ': fmts )+        ( ( i2 ':-> fmt2 ) ': InsertFormatCombining ( i1 ':-> fmt1 ) fmts )++type family Combination+              ( i1   :: Nat                   )+              ( fmt1 :: SPIRV.ImageFormat Nat )+              ( j2   :: Nat                   )+              ( fmt2 :: SPIRV.ImageFormat Nat )+            :: Maybe ( Nat, SPIRV.ImageFormat Nat )+            where+  Combination i fmt1 i fmt2+    = Just '( i, LargestFormat fmt1 fmt2 )+  Combination i1 ( 'SPIRV.ImageFormat comp widths1 ) i2 ( 'SPIRV.ImageFormat _ widths2 )+    = CrossLocationCombine comp i1 widths1 (Length widths2) i2 widths2 (Length widths2)++type family CrossLocationCombine+              ( comp    :: SPIRV.Image.Component )+              ( i1      ::  Nat                  )+              ( widths1 :: [Nat]                 )+              ( lg1     ::  Nat                  )+              ( i2      ::  Nat                  )+              ( widths2 :: [Nat]                 )+              ( lg2     ::  Nat                  )+            :: Maybe ( Nat, SPIRV.ImageFormat Nat )+            where+  CrossLocationCombine comp i1 widths1 lg1 i2 widths2 lg2+    = If (  ( i2 == i1 + 1 && ComponentsUsed widths1 :> 4 && Length widths2 :<= 2 )+         || ( i1 == i2 + 1 && ComponentsUsed widths2 :> 4 && Length widths1 :<= 2 )+         )+        ( Just+           '( Min i1 i2+            , 'SPIRV.ImageFormat comp+                ( Replicate+                  ( Max lg1 ( Max lg2 ( Min lg1 lg2 + 1 ) ) ) -- sorry+                  64+                )+            )+        )+        Nothing++type family ComponentsUsed ( widths :: [Nat] ) :: Nat where+  ComponentsUsed '[] = 0+  ComponentsUsed (w ': ws) = ( w `Div` 32 ) + ComponentsUsed ws++type family LargestFormat+              ( fmt1 :: SPIRV.ImageFormat Nat )+              ( fmt2 :: SPIRV.ImageFormat Nat )+           :: SPIRV.ImageFormat Nat+           where+  LargestFormat ( 'SPIRV.ImageFormat comp1 widths1 ) ( 'SPIRV.ImageFormat comp2 widths2 )+    = If ( Length widths2 :> Length widths1 )+        ( 'SPIRV.ImageFormat comp2 widths2 )+        ( 'SPIRV.ImageFormat comp1 widths1 )+  -- simply picking the largest of the two formats+  --+  -- trying to not throw any errors even when results don't make sense,+  -- as layout validation should prevent anything silly from happening+  -- (and we don't want to duplicate error messages)
+ src/FIR/Validation/Images.hs view
@@ -0,0 +1,656 @@+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: FIR.Validation.Images++Validation module for stateful operations involving images,+such as 'FIR.Syntax.Program.imageRead', 'FIR.Syntax.Program.imageWrite',+using type families with custom type errors.++This checks, for instance, that one doesn't access a non-sampled storage image+using floating-point texel coordinates.++-}++module FIR.Validation.Images+  ( LookupImageProperties+  , ImageUsageFromProperties+  , ValidImageRead, ValidImageWrite+  , ValidImageCoordinate, ValidImageGradCoordinate, ValidImageOffsetCoordinate +  , ImageTexelType+  , MatchesFormat, BasicDim, NotCubeDim+  , CanAddProj, CanAddDref+  , UsesAffineCoords+  , NoDuplicate+  , NoMS, CanMultiSample+  , NoLODOps, SupportsDepthTest+  , ValidQueryImageSize, ValidQueryImageSizeLOD+  , ValidQueryImageLOD, ValidQueryImageLevels, ValidQueryImageSamples+  )+  where++-- base+import Data.Kind+  ( Type, Constraint )+import Data.Type.Bool+  ( If, type (&&), Not )+import Data.Type.Equality+  ( type (==) )+import GHC.TypeLits+  ( Symbol+  , TypeError, ErrorMessage(..)+  )+import GHC.TypeNats+  ( Nat )++-- fir+import Data.Type.List+  ( Elem )+import Data.Type.Map+  ( Lookup )+import FIR.Binding+  ( Binding, BindingsMap, Var )+import {-# SOURCE #-} FIR.Prim.Image+  ( ImageProperties(Properties), Image+  , OperandName(DepthComparison, ProjectiveCoords, BaseOperand)+  , ImageCoordinateKind(..)+  )+import FIR.Prim.Types+  ( ScalarFromTy )+import FIR.ProgramState+  ( ProgramState(ProgramState) )+import Math.Linear+  ( V )+import SPIRV.Image+  ( ImageUsage(Sampled, Storage)+  , ImageFormat(ImageFormat), I, UI+  , ImageFormatDimension+  , RequiredFormatUsage+  , Arrayness(..)+  , Dimensionality(..)+  , Normalisation(..)+  , HasDepth(..)+  , MultiSampling(..)+  , Operand(..)+  , Projection(..)+  )+import qualified SPIRV.Image    as Image+  ( Component(Integer, Floating)+  , Operand(..)+  )+import qualified SPIRV.Image    as LOD+  ( LODOperand )+import qualified SPIRV.ScalarTy as SPIRV+  ( ScalarTy(Integer, Floating) )++-------------------------------------------------+-- * Constraints for images.++-- | Retrieve the properties of an image.+--+-- Throws a type error if there is no image with given name.+type family LookupImageProperties (k :: Symbol) (i :: ProgramState) :: ImageProperties where+  LookupImageProperties k ('ProgramState i _ _ _ _ _ _ _)+    = ImagePropertiesFromLookup k i (Lookup k i)++type family ImagePropertiesFromLookup+              ( k      :: Symbol        )+              ( i      :: BindingsMap   )+              ( lookup :: Maybe Binding )+            :: ImageProperties+              where+  ImagePropertiesFromLookup _ _ (Just (Var _ (Image props))) = props+  ImagePropertiesFromLookup k i  Nothing+    = TypeError (     Text "Expected an image, \+                           \but nothing is bound by name " :<>: ShowType k+                )+  ImagePropertiesFromLookup k i (Just nonImage)+    = TypeError (     Text "Unexpected type " :<>: ShowType nonImage+                 :<>: Text " bound by name " :<>: ShowType k+                 :$$: Text "Expected an image."+                 )++type family ImageUsageFromProperties ( props :: ImageProperties ) :: ImageUsage where+  ImageUsageFromProperties ( Properties _ _ _ _ _ _ usage _ ) = usage++-- | Check that we can read from an image.+--+-- Depending on the coordinate type, this is either a sampling operation+-- or a direct image read operation.+--+-- Throws a type error if the operation is incompatible with the given+-- image properties. For instance, if the image is a depth image,+-- a depth-comparison reference value must be provided.+--+-- Refer to the @SPIR-V@ specification for what operations are allowed.+type family ValidImageRead+              ( props     :: ImageProperties )+              ( ops       :: [OperandName]   )+              ( coordType :: Type            )+            :: Constraint where+  ValidImageRead+    ( Properties coordKind res dim depth arr ms usage fmt )+    ops+    coordType+      = ( AllowedIndexing coordKind ms usage+        , CheckDepthTest (DepthComparison `Elem` ops) coordKind depth+        , CheckLODOperands coordKind ops+        , CompatibleFormat (ScalarFromTy res) usage fmt+        , ValidCoordinateType "image coordinates (for reading)" (ImageCoordinatesDim dim arr ops) coordKind coordType+        )++type family ValidImageCoordinate+              ( props     :: ImageProperties )+              ( ops       :: [ OperandName ] )+              ( coordType :: Type            )+              where+  ValidImageCoordinate ( Properties coordKind _ _ _ _ _ _ _ ) _ coordType+    = ValidCoordinateType "image coordinates" 1 coordKind coordType++type family ValidImageGradCoordinate+              ( props     :: ImageProperties )+              ( ops       :: [ OperandName ] )+              ( coordType :: Type            )+              where+  ValidImageGradCoordinate ( Properties coordKind _ dim _ _ _ _ _ ) ops coordType+    = ValidCoordinateType "gradient coordinates" (GradCoordinatesDim dim ops) coordKind coordType++type family ValidImageOffsetCoordinate+              ( props     :: ImageProperties )+              ( ops       :: [ OperandName ] )+              ( coordType :: Type            )+              where+  ValidImageOffsetCoordinate ( Properties coordKind _ dim _ _ _ _ _ ) ops coordType+    = ValidCoordinateType "offset coordinates" (OffsetCoordinatesDim dim ops) coordKind coordType++type family ValidCoordinateType+              ( coordsName :: Symbol )+              ( coordDim   :: Nat )+              ( coordKind  :: ImageCoordinateKind )+              ( coordType  :: Type )+            :: Constraint where+  ValidCoordinateType _ 1 coordKind a         = CoordinateConstraint coordKind a+  ValidCoordinateType _ n coordKind ( V n a ) = CoordinateConstraint coordKind a+  ValidCoordinateType coordsName n coordKind ( V j a ) =+    TypeError +      (    Text "Use of " :<>: Text coordsName :<>: Text " of the wrong dimension."+      :$$: Text "Expected dimension: " :<>: ShowType n+      :$$: Text "  Actual dimension: " :<>: ShowType j+      )+  ValidCoordinateType coordsName n IntegralCoordinates nonVec =+    TypeError +      (    Text "Cannot use type " :<>: ShowType nonVec :<>: Text " as " :<>: Text coordsName :<>: Text "."+      :$$: Text "Expected a vector of integral types of dimension " :<>: ShowType n :<>: Text "."+      )+  ValidCoordinateType coordsName n FloatingPointCoordinates nonVec =+    TypeError +      (    Text "Cannot use type " :<>: ShowType nonVec :<>: Text " as " :<>: Text coordsName :<>: Text "."+      :$$: Text "Expected a vector of floating-point types of dimension " :<>: ShowType n :<>: Text "."+      )+++type family CoordinateConstraint ( coordKind :: ImageCoordinateKind ) :: ( Type -> Constraint ) where+  CoordinateConstraint IntegralCoordinates      = Integral+  CoordinateConstraint FloatingPointCoordinates = Floating++-- | Check that we can write to an image.+--+-- Throws a type error if:+--+--   * the image is not a storage image,+--   * the image is a depth image,+--   * the coordinate type is not an integral type, or is of the wrong dimension,+--   * an operand is incompatible with the given image properties,+--   * an operand doesn't make sense for write operations.+--+-- Refer to the @SPIR-V@ specification for what operations are allowed.+type family ValidImageWrite+              ( props     :: ImageProperties )+              ( ops       :: [OperandName]   )+              ( coordType :: Type            )+           :: Constraint where+  ValidImageWrite+    ( Properties _ _ _ _ _ _ Sampled _ )+    ops+    _+      = TypeError ( Text "Cannot write to a sampled image; must be a storage image." )+  ValidImageWrite+    ( Properties _ _ _ (Just DepthImage) _ _ _ _ )+    ops+    _+      = TypeError ( Text "Cannot write to a depth image." )+  ValidImageWrite+    ( Properties coordKind res dim _ arr _ usage fmt )+    ops+    coordType+      = ( IntegralIndexing coordKind+        , CompatibleFormat (ScalarFromTy res) usage fmt+        , AllowedWriteOps ops+        , ValidCoordinateType "image coordinates (for writing)" (ImageCoordinatesDim dim arr ops) coordKind coordType+        )++type family IntegralIndexing (inty :: ImageCoordinateKind) :: Constraint where+  IntegralIndexing FloatingPointCoordinates+    = TypeError ( Text "Cannot write to an image using floating-point coordinates." )+  IntegralIndexing _ = ()++-- Check whether floating-point coordinates are allowed.+type family AllowedIndexing+              ( inty  :: ImageCoordinateKind )+              ( ms    :: MultiSampling      )+              ( usage :: ImageUsage         )+            :: Constraint where+  AllowedIndexing FloatingPointCoordinates _ Storage+    = TypeError+        ( Text "Cannot use floating-point coordinates with a storage image." )+  AllowedIndexing FloatingPointCoordinates MultiSampled _+    = TypeError+        ( Text "Cannot use floating-point coordinates with multi-sampling." )+  AllowedIndexing _ _ _ = ()++-- Check that depth-testing is appropriately performed.+type family CheckDepthTest+              ( depthTesting :: Bool        )+              ( inty  :: ImageCoordinateKind )+              ( depth :: Maybe HasDepth     )+            :: Constraint where+  CheckDepthTest False _ (Just DepthImage)+    = TypeError+        ( Text "Must use a depth comparison with this depth image." )+  CheckDepthTest True _ (Just NotDepthImage)+    = TypeError+        ( Text "Cannot perform depth comparison: not a depth image." )+  CheckDepthTest True IntegralCoordinates _+    = TypeError+        ( Text "Cannot perform depth comparison using integral coordinates." )+  CheckDepthTest _ _ _ = ()++-- If using integral coordinates, LOD instructions cannot be provided.+type family CheckLODOperands+                ( inty :: ImageCoordinateKind )+                ( ops  :: [OperandName]      )+              :: Constraint where+  CheckLODOperands FloatingPointCoordinates _ = ()+  CheckLODOperands _ ( BaseOperand ('LODOperand lod) ': _ )+    = TypeError +        ( ShowType lod :<>: Text " operand not allowed: using integral coordinates." )+  CheckLODOperands inty ( op ': ops ) = CheckLODOperands inty ops+  CheckLODOperands _ '[] = ()++type family CompatibleFormat+                ( inty  :: SPIRV.ScalarTy          )+                ( usage :: ImageUsage              )+                ( fmt   :: Maybe (ImageFormat Nat) )+              :: Constraint+              where+  CompatibleFormat (SPIRV.Integer _ _) _ (Just ('ImageFormat (Image.Integer Normalised _) _))+    = TypeError+       (    Text "Expected a floating-point type, but provided an integer type."+       :$$: Text "Image uses a normalised integer format, resulting in floating-point texel data."+       )+  CompatibleFormat (SPIRV.Integer _ _) _ (Just ('ImageFormat Image.Floating _))+    = TypeError+       (    Text "Expected a floating-point type, but provided an integer type."+       :$$: Text "Image uses a floating-point format."+       )+  CompatibleFormat (SPIRV.Floating _) _ (Just ('ImageFormat (Image.Integer Unnormalised _) _))+    = TypeError+       (    Text "Expected an integral type, but provided a floating-point type."+       :$$: Text "Image uses unnormalised integers, resulting in integral texel data."+       )+  CompatibleFormat _ Storage _+    = ()+  CompatibleFormat _ Sampled (Just fmt)+    = If+        ( RequiredFormatUsage fmt == Just Storage )+        ( TypeError+           (     Text "Image format " :<>: ShowType fmt+            :<>: Text " can only be used with storage images."+            )+        )+        ( () :: Constraint )++-- Only 'Sample' and 'Offset'/'ConstOffset' image operands allowed.+type family AllowedWriteOps (ops :: [OperandName]) :: Constraint where+  AllowedWriteOps '[] = ()+  AllowedWriteOps (BaseOperand Image.Sample      ': ops) = AllowedWriteOps ops+  AllowedWriteOps (BaseOperand Image.ConstOffset ': ops) = AllowedWriteOps ops+  AllowedWriteOps (BaseOperand Image.Offset      ': ops) = AllowedWriteOps ops+  AllowedWriteOps (op                            ': _  )+    = TypeError (     Text "Image operand " :<>: ShowType op+                 :<>: Text " cannot be used in conjunction \+                           \with an image write operation."+                )++++----------------------------------------------------------+-- Computing relevant image coordinate type.++-- | Dimension of the coordinates used by an image.+--+-- For instance, a simple 2D texture requires a dimension 2 vector,+-- simple 3D textures and cube maps requires a dimension 3 vector, etc.+type family ImageCoordinatesDim+              ( dim   :: Dimensionality )+              ( arr   :: Arrayness      )+              ( ops   :: [OperandName]  )+            :: Nat where+  ImageCoordinatesDim dim arr ops =+    If ( ProjectiveCoords `Elem` ops )+      ( ComputeCoordsDim dim arr Projective )+      ( ComputeCoordsDim dim arr Affine )++-- | Texel type of an image.+--+-- This is what is returned from an image sampling operation,+-- or needs to be provided for an image write operation.+type family ImageTexelType+              ( props :: ImageProperties )+              ( ops   :: [OperandName]   )+            :: Type+            where+  ImageTexelType ( Properties _ r _ _ _ _ _ fmt ) ops+    = If+        (    DepthComparison `Elem` ops+          && Not ( (BaseOperand ConstOffsets) `Elem` ops)+        )+        r+        ( MkTexelType fmt r )++type family MkTexelType ( fmt :: Maybe ( ImageFormat Nat ) ) ( texel :: Type ) :: Type where+  MkTexelType Nothing      texel = V 4 texel -- most flexible default type for unknown image format+  MkTexelType ( Just fmt ) texel = MkTexelType' ( ImageFormatDimension fmt ) texel++type family MkTexelType' ( dim :: Nat ) ( texel :: Type ) :: Type where+  MkTexelType' 1 texel = texel+  MkTexelType' n texel = V n texel++type family ComputeCoordsDim+              ( dim  :: Dimensionality )+              ( arr  :: Arrayness      )+              ( proj :: Projection     )+              :: Nat+              where+  ComputeCoordsDim OneD        NonArrayed Affine     = 1+  ComputeCoordsDim TwoD        NonArrayed Affine     = 2+  ComputeCoordsDim ThreeD      NonArrayed Affine     = 3+  ComputeCoordsDim Cube        NonArrayed Affine     = 3+  ComputeCoordsDim Rect        NonArrayed Affine     = 2+  ComputeCoordsDim Buffer      NonArrayed Affine     = 1+  ComputeCoordsDim SubpassData NonArrayed Affine     = 2+  ComputeCoordsDim OneD        NonArrayed Projective = 2+  ComputeCoordsDim TwoD        NonArrayed Projective = 3+  ComputeCoordsDim ThreeD      NonArrayed Projective = 4+  ComputeCoordsDim Cube        NonArrayed Projective = 4+  ComputeCoordsDim Rect        NonArrayed Projective = 3+  ComputeCoordsDim Buffer      NonArrayed Projective = 2+  ComputeCoordsDim SubpassData NonArrayed Projective = 3+  ComputeCoordsDim OneD        Arrayed    Affine     = 2+  ComputeCoordsDim TwoD        Arrayed    Affine     = 3+  ComputeCoordsDim Cube        Arrayed    Affine     = 3 -- weird stuff going on here+  ComputeCoordsDim dim         Arrayed    Affine+    = TypeError ( Text "Unsupported arrayed image format \+                       \with dimensionality "+                  :<>: ShowType dim+                )+  ComputeCoordsDim dim         Arrayed    Projective+    = TypeError ( Text "Cannot use projective coordinates with an arrayed image." )++-- which coordinates to use to provide explicit derivatives+type family GradCoordinatesDim+              ( props :: Dimensionality  )+              ( ops   :: [OperandName]   )+            :: Nat where+  GradCoordinatesDim dim ops =+    If ( ProjectiveCoords `Elem` ops )+      ( ComputeCoordsDim dim NonArrayed Projective )+      ( ComputeCoordsDim dim NonArrayed Affine     )++-- which coordinates to use to provide an offset+type family OffsetCoordinatesDim+              ( props :: Dimensionality  )+              ( ops   :: [OperandName]   )+            :: Nat where+  OffsetCoordinatesDim dim ops =+    If ( ProjectiveCoords `Elem` ops )+      ( ComputeCoordsDim dim NonArrayed Projective )+      ( ComputeCoordsDim dim NonArrayed Affine     )+++-----------------------------------------------------------+-- Validation of image operands.++-- this type family could be slightly more specific+-- and enforce that e.g. reading from an 'Unsigned Integer' image format+-- necessarily returns unsigned integers+-- the 'No instance ...' error message can also be a bit confusing+type family MatchesFormat+              ( fmt :: Maybe (ImageFormat Nat) )+              ( a   :: Type                    )+            :: Constraint where+  MatchesFormat (Just ('ImageFormat I  _)) a = Integral a +  MatchesFormat (Just ('ImageFormat UI _)) a = Integral a+  MatchesFormat (Just ('ImageFormat _  _)) a = Floating a+  MatchesFormat _                          _ = ()++type family BasicDim (opName :: Symbol) (props :: ImageProperties) :: Constraint where+  BasicDim _      ( Properties _ _ OneD   _ _ _ _ _ ) = ()+  BasicDim _      ( Properties _ _ TwoD   _ _ _ _ _ ) = ()+  BasicDim _      ( Properties _ _ ThreeD _ _ _ _ _ ) = ()+  BasicDim _      ( Properties _ _ Cube   _ _ _ _ _ ) = ()+  BasicDim opName ( Properties _ _ dim    _ _ _ _ _ )+    = TypeError+        (     Text opName :<>: Text " operand: unexpected image dimensionality "+         :<>: ShowType dim :<>: Text "."+         :$$: Text "Image dimensionality must be 'OneD', 'TwoD', 'ThreeD' or 'Cube'. "+        )++type family NotCubeDim (opName :: Symbol) (props :: ImageProperties) :: Constraint where+  NotCubeDim opName ( Properties _ _ Cube _ _ _ _ _ )+    = TypeError+        (    Text opName :<>: Text " operand: unexpected 'Cube' image dimensionality."+        :$$: Text "Image dimensionality must not be 'Cube'."+        )+  NotCubeDim _ _ = ()++type family CanAddProj (ops :: [OperandName]) :: Constraint where+  CanAddProj '[] = ()+  CanAddProj ( ProjectiveCoords ': _ )+    = TypeError ( Text "'Proj' operand already supplied." )+  CanAddProj ( DepthComparison ': ops ) = CanAddProj ops+  CanAddProj ( op ': _ )+    = TypeError ( Text "'Proj' operand must be provided after " :<>: ShowType op )++type family CanAddDref (ops :: [OperandName]) :: Constraint where+  CanAddDref '[] = ()+  CanAddDref ( DepthComparison ': _ )+    = TypeError ( Text "'Dref' operand already supplied." )+  CanAddDref ( ProjectiveCoords ': ops ) = CanAddDref ops+  CanAddDref ( op ': _ )+    = TypeError ( Text "'Dref' operand must be provided after " :<>: ShowType op )++type family UsesAffineCoords (ops :: [OperandName]) :: Constraint where+  UsesAffineCoords '[] = ()+  UsesAffineCoords ( ProjectiveCoords ': _ )+    = TypeError ( Text "'Gather': unexpected 'Proj' operand; cannot use projective coordinates." )+  UsesAffineCoords ( _ ': ops ) = UsesAffineCoords ops++type NoDuplicate op ops = NoDuplicateFromElem op (op `Elem` ops)++type family NoDuplicateFromElem op dup :: Constraint where+  NoDuplicateFromElem _ False   = ()+  NoDuplicateFromElem op True+    = TypeError ( Text "Duplicate image operand " :<>: ShowType op :<>: Text "." )++type family NoMS (opName :: Symbol) (props :: ImageProperties) :: Constraint where+  NoMS _      (Properties _ _ _ _ _ SingleSampled _ _) = ()+  NoMS opName _+    = TypeError+        ( Text opName :<>: Text " operand: image cannot be multisampled." )++type family CanMultiSample (ms :: ImageProperties) :: Constraint where+  CanMultiSample (Properties _ _ _ _ _ SingleSampled _ _)+    = TypeError ( Text "Cannot multi-sample this single-sampled image." )+  CanMultiSample _ = ()++type family NoLODOps+              ( name :: Symbol           )+              ( excl :: [LOD.LODOperand] )+              ( ops  :: [OperandName]    )+            :: Constraint+            where+  NoLODOps _ _ '[] = ()+  NoLODOps name excl (BaseOperand ('LODOperand op) ': ops)+    = If+        (op `Elem` excl)+        ( TypeError +            (     Text "Cannot provide " :<>: ShowType name :<>: Text " operand:"+             :$$: ShowType op :<>: Text " operand already provided."+            )+        )+        ( NoLODOps name excl ops )+  NoLODOps name excl ( _ ': ops ) = NoLODOps name excl ops++type family SupportsDepthTest ( props :: ImageProperties ) :: Constraint where+  SupportsDepthTest (Properties _ _ _ (Just NotDepthImage) _ _ _ _)+    = TypeError ( Text "Cannot do a depth comparison: image is not a depth image." )+  SupportsDepthTest _ = ()++-----------------------------------------------------------+-- Validation of image query operations.++type ValidQueryImageSizeLOD ( imgName :: Symbol ) ( i :: ProgramState ) ( res :: Type )+  = ValidQueryImageSizeLODFromProps imgName ( LookupImageProperties imgName i ) res++type ValidQueryImageSize ( imgName :: Symbol ) ( i :: ProgramState ) ( res :: Type )+  = ValidQueryImageSizeFromProps imgName ( LookupImageProperties imgName i ) res++type ValidQueryImageLOD ( imgName :: Symbol ) ( i :: ProgramState ) ( coords :: Type ) ( res :: Type )+  = ValidQueryImageLODFromProps imgName ( LookupImageProperties imgName i ) coords res++type ValidQueryImageLevels ( imgName :: Symbol ) ( i :: ProgramState ) ( res :: Type )+  = ValidQueryImageLevelsFromProps imgName ( LookupImageProperties imgName i ) res++type ValidQueryImageSamples ( imgName :: Symbol ) ( i :: ProgramState ) ( res :: Type )+  = ValidQueryImageSamplesFromProps imgName ( LookupImageProperties imgName i ) res+++-- ImageQuerySizeLod++type family ValidQueryImageSizeLODFromProps ( imgName :: Symbol ) ( imgProps :: ImageProperties ) ( res :: Type ) :: Constraint where+  ValidQueryImageSizeLODFromProps imgName ( Properties _ _ _ _ _ MultiSampled _ _ ) res =+    TypeError+      ( Text "Cannot query size (with explicit LOD) of multi-sampled image " :<>: ShowType imgName )+  ValidQueryImageSizeLODFromProps imgName ( Properties _ _ dim _ arr _ _ _ ) res =+    ( ValidCoordinateType "image coordinates (for querying)" (ImageCoordinatesDim dim arr '[]) IntegralCoordinates res+    , ValidImageSizeLODQueryDim imgName dim+    )++type family ValidImageSizeLODQueryDim ( imgName :: Symbol ) ( dim :: Dimensionality ) :: Constraint where+  ValidImageSizeLODQueryDim _       OneD   = ()+  ValidImageSizeLODQueryDim _       TwoD   = ()+  ValidImageSizeLODQueryDim _       ThreeD = ()+  ValidImageSizeLODQueryDim _       Cube   = ()+  ValidImageSizeLODQueryDim imgName dim    =+    TypeError+      (    Text "Cannot query the size (with explicit LOD) of image " :<>: ShowType imgName :<>: Text "."+      :$$: Text "Unsupported dimensionality " :<>: ShowType dim :<>: Text "."+      )++-- ImageQuerySize++type family ValidQueryImageSizeFromProps ( imgName :: Symbol ) ( imgProps :: ImageProperties ) ( res :: Type ) :: Constraint where+  ValidQueryImageSizeFromProps imgName ( Properties _ _ dim _ arr ms usage _ ) res =+    ( ValidCoordinateType "image coordinates (for querying)" (ImageCoordinatesDim dim arr '[]) IntegralCoordinates res+    , ValidImageSizeQueryDim imgName dim ms usage+    )++type family ValidImageSizeQueryDim ( imgName :: Symbol ) ( dim :: Dimensionality ) ( ms :: MultiSampling ) ( usage :: ImageUsage ) :: Constraint where+  ValidImageSizeQueryDim _ Rect   _ _ = ()+  ValidImageSizeQueryDim _ Buffer _ _ = ()+  ValidImageSizeQueryDim imgName SubpassData _ _ =+    TypeError+      (    Text "Cannot query the size (without LOD) of image " :<>: ShowType imgName :<>: Text "."+      :$$: Text "Unsupported dimensionality " :<>: ShowType SubpassData :<>: Text "."+      )+  ValidImageSizeQueryDim imgName dim SingleSampled Sampled =+    TypeError+      (    Text "Cannot query the size (without LOD) of image " :<>: ShowType imgName :<>: Text "."+      :$$: Text "Unsupported combination:"+      :$$: Text "  - dimensionality " :<>: ShowType dim :<>: Text ","+      :$$: Text "  - no multisampling,"+      :$$: Text "  - image used with a sampler."+      )+  ValidImageSizeQueryDim _ _ _ _ = ()+++-- ImageQueryLod++type family ValidQueryImageLODFromProps ( imgName :: Symbol ) ( imgProps :: ImageProperties ) ( coords :: Type ) ( res :: Type ) :: Constraint where+  ValidQueryImageLODFromProps imgName ( Properties coordKind _ dim _ arr _ _ _ ) coords res =+    ( QueryLODIsV2Floating imgName res+    , ValidCoordinateType "image coordinates (for querying LOD)" (ImageCoordinatesDim dim arr '[]) coordKind res -- TODO: enforce floating point coordinates outside of ComputeKernel?+    , ValidImageLODQueryDim imgName dim+    )++type family QueryLODIsV2Floating ( imgName :: Symbol ) ( res :: Type ) :: Constraint where+  QueryLODIsV2Floating _ ( V 2 a ) = Floating a+  QueryLODIsV2Floating imgName t   =+    TypeError+      (    Text "Unexpected result type " :<>: ShowType t+      :$$: Text "when querying LOD for image named " :<>: ShowType imgName :<>: Text "."+      :$$: Text "Result type should be a 2-component floating-point type vector."+      )++type family ValidImageLODQueryDim ( imgName :: Symbol ) ( dim :: Dimensionality ) :: Constraint where+  ValidImageLODQueryDim _       OneD   = ()+  ValidImageLODQueryDim _       TwoD   = ()+  ValidImageLODQueryDim _       ThreeD = ()+  ValidImageLODQueryDim _       Cube   = ()+  ValidImageLODQueryDim imgName dim    =+    TypeError+      (    Text "Cannot query the LOD of image " :<>: ShowType imgName :<>: Text "."+      :$$: Text "Unsupported dimensionality " :<>: ShowType dim :<>: Text "."+      )++-- ImageQueryLevels++type family ValidQueryImageLevelsFromProps ( imgName :: Symbol ) ( imgProps :: ImageProperties ) ( res :: Type ) :: Constraint where+  ValidQueryImageLevelsFromProps imgName ( Properties _ _ dim _ _ _ _ _ ) res =+    ( Integral res+    , ValidImageLevelsQueryDim imgName dim+    )++type family ValidImageLevelsQueryDim ( imgName :: Symbol ) ( dim :: Dimensionality ) :: Constraint where+  ValidImageLevelsQueryDim _       OneD   = ()+  ValidImageLevelsQueryDim _       TwoD   = ()+  ValidImageLevelsQueryDim _       ThreeD = ()+  ValidImageLevelsQueryDim _       Cube   = ()+  ValidImageLevelsQueryDim imgName dim    =+    TypeError+      (    Text "Cannot query the number of accessible mipmap levels of image named " :<>: ShowType imgName :<>: Text "."+      :$$: Text "Unsupported dimensionality " :<>: ShowType dim :<>: Text "."+      )++-- ImageQuerySamples++type family ValidQueryImageSamplesFromProps ( imgName :: Symbol ) ( imgProps :: ImageProperties ) ( res :: Type ) :: Constraint where+  ValidQueryImageSamplesFromProps _       ( Properties _ _ TwoD _ _ MultiSampled _ _ ) res = Integral res+  ValidQueryImageSamplesFromProps imgName ( Properties _ _ dim  _ _ MultiSampled _ _ ) _   =+    TypeError+      (    Text "Cannot query the number of samples of image named " :<>: ShowType imgName :<>: Text "."+      :$$: Text "This image has unsupported dimensionality " :<>: ShowType dim :<>: Text "."+      :$$: Text "Expected a TwoD dimensionality."+      )+  ValidQueryImageSamplesFromProps imgName ( Properties _ _ _ _ _ _ _ _ ) _ =+    TypeError+      (    Text "Cannot query the number of samples of image named " :<>: ShowType imgName :<>: Text "."+      :$$: Text "This image is not multi-sampled."+      )
+ src/FIR/Validation/Interface.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: FIR.Validation.Interface++Validates the layout of individual entry point input/output interfaces.++For instance:++  * inputs/outputs in entry point interfaces must not overlap,+  * types within a location must use a consistent base type,+    e.g. a 'Float' and a 'Word32' cannot share a location.++-}++module FIR.Validation.Interface+  ( ValidInterface )+  where++-- base+import Data.Kind+  ( Type, Constraint )+import GHC.TypeLits+  ( Symbol+  , TypeError, ErrorMessage(..)+  )+import GHC.TypeNats+  ( Nat )++-- fir+import Data.Type.Map+  ( (:->)((:->)), Lookup )+import Data.Type.Maybe+  ( SequenceMaybe )+import FIR.Prim.Struct+  ( LocationSlot(LocationSlot) )+import FIR.ProgramState+  ( TLInterfaceVariable+  , EntryPointInfo(EntryPointInfo)+  )+import FIR.Validation.Arrayness+  ( IsPatchVariable(..), ImplicitArrayness(..)+  , Arrayness, RemoveArrayness+  )+import FIR.Validation.Layout+  ( ValidLayout )+import qualified SPIRV.Decoration as SPIRV+  ( Decoration(..) )+import qualified SPIRV.Stage      as SPIRV+  ( ExecutionModel(..), ExecutionInfo(..) )+import qualified SPIRV.Storage    as SPIRV+  ( StorageClass(Input,Output) )++------------------------------------------------------------------------++type family ValidInterface ( epName :: Symbol ) ( nfo :: EntryPointInfo ) :: Constraint where+  ValidInterface epName ( 'EntryPointInfo xNfo globals _ )+    = ( ValidLayout ( LocationSlotsFromDecorations epName xNfo SPIRV.Input  ( SequenceMaybe ( Lookup SPIRV.Input  globals ) ) )+      , ValidLayout ( LocationSlotsFromDecorations epName xNfo SPIRV.Output ( SequenceMaybe ( Lookup SPIRV.Output globals ) ) )+      )++type family LocationSlotsFromDecorations+              ( emName  :: Symbol                     )+              ( xNfo    :: SPIRV.ExecutionInfo Nat em )+              ( inOut   :: SPIRV.StorageClass         )+              ( globals :: [ Symbol :-> TLInterfaceVariable ] )+            :: [ LocationSlot Nat :-> Type ]+            where+  LocationSlotsFromDecorations _      _    _     '[] = '[]+  LocationSlotsFromDecorations+    emName ( xNfo :: SPIRV.ExecutionInfo Nat em )+    inOut  ( ( varName ':-> '(decs, ty) ) ': globals )+    = AddLocationSlotIfNecessary varName ty decs emName em inOut+        ( Arrayness inOut decs xNfo )+        ( LocationSlotsFromDecorations emName xNfo inOut globals )++type family AddLocationSlotIfNecessary+              ( varName   :: Symbol                        )+              ( ty        :: Type                          )+              ( decs      :: [ SPIRV.Decoration Nat ]      )+              ( emName    :: Symbol                        )+              ( em        :: SPIRV.ExecutionModel          )+              ( inOut     :: SPIRV.StorageClass            )+              ( arrayness :: ImplicitArrayness             )+              ( slots     :: [ LocationSlot Nat :-> Type ] )+            :: [ LocationSlot Nat :-> Type ] +            where+  AddLocationSlotIfNecessary _ _ _ _ _ _ ('NoImplicitArrayness 'IsPatch) slots+  -- ignore patch variables+    = slots+  -- otherwise, add the located type (after removing the implicit arrayness)+  AddLocationSlotIfNecessary varName ty decs emName em inOut arrayness slots+    = AddLocationSlot varName+        ( RemoveArrayness varName inOut emName em ty arrayness )+        ( LocationDecorations decs )+        slots++type family AddLocationSlot+              ( k       :: Symbol )+              ( ty      :: Type   )+              ( locInfo :: ( [Nat], [Nat] ) )+              ( slots   :: [ LocationSlot Nat :-> Type ] )+           :: [ LocationSlot Nat :-> Type ]+           where+  AddLocationSlot k ty locInfo slots+    = ( LocationSlotFromDecorations k locInfo ':-> ty ) ': slots++type family LocationSlotFromDecorations+              (  k      :: Symbol )+              ( locInfo :: ( [Nat], [Nat] ) )+          :: LocationSlot Nat+          where+  LocationSlotFromDecorations _ '( '[l] , '[c]  )+    = 'LocationSlot l c+  LocationSlotFromDecorations _ '( '[l] , '[]   )+    = 'LocationSlot l 0+  LocationSlotFromDecorations k '( '[l] ,  cs   )+    = TypeError+    (    Text "Global named " :<>: ShowType k+    :<>: Text " has more than one 'Component' decoration:"+    :$$: ShowType cs+    )+  LocationSlotFromDecorations k '( '[]  ,  _    )+    = TypeError+    (    Text "Global named " :<>: ShowType k+    :<>: Text " is missing a 'Location' decoration."+    )+  LocationSlotFromDecorations k '(  ls ,  _     )+    = TypeError+    (    Text "Global named " :<>: ShowType k+    :<>: Text " has more than one 'Location' decoration:"+    :$$: ShowType ls+    )++type family LocationDecorations+                ( decs :: [SPIRV.Decoration Nat] )+             :: ( [Nat], [Nat] )+             where+  LocationDecorations '[] = '( '[], '[] )+  LocationDecorations ( SPIRV.Location l ': decs )+    = CombineLocations '( Just l, 'Nothing ) ( LocationDecorations decs )+  LocationDecorations ( SPIRV.Component c ': decs )+    = CombineLocations '( 'Nothing, 'Just c ) ( LocationDecorations decs )+  LocationDecorations ( _ ': decs ) = LocationDecorations decs++type family CombineLocations+              ( lc  :: ( Maybe Nat, Maybe Nat ) )+              ( lcs :: ( [Nat], [Nat] ) )+            :: ( [Nat], [Nat] ) +            where+  CombineLocations '(Just l, Just c) '(ls, cs) = '( l ': ls, c ': cs )+  CombineLocations '(Just l, _     ) '(ls, cs) = '( l ': ls, cs )+  CombineLocations '(_     , Just c) '(ls, cs) = '( ls, c ': cs )+  CombineLocations _                 lcs       = lcs
+ src/FIR/Validation/Layout.hs view
@@ -0,0 +1,514 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: FIR.Validation.Layout++Validation module for GPU memory layout, e.g. shader location/component assignments.++To specify the layout of vertex input data, the user specifies the type of inhabitants+in the available memory locations. Each location holds four components,+with each component of size 32 bits (4 bytes), i.e. the size of a 'Float'.+The type-system checks the compliance of any user-supplied layout with the SPIR-V and Vulkan specifications,+in particular checking that the assignment of slots is non-overlapping.++For instance, suppose we want to lay out objects of the following types:++  [@A@] @Array 3 (V 2 Float)@++  [@B@] @Array 2 Float@++  [@C@] @Float@++  [@D@] @V 3 Double@++  [@E@] @Array 2 Double@++  [@F@] @M 2 3 Float@++We can lay out this data by specifying which location slots each type uses.+Consider for instance the following specification:++>  Struct+>    '[ Slot 0 0 ':-> Array 3 (V 2 Float)+>     , Slot 0 2 ':-> Array 2 Float+>     , Slot 1 3 ':-> Float+>     , Slot 3 0 ':-> V 3 Double+>     , Slot 4 2 ':-> Array 2 Double+>     , Slot 6 0 ':-> M 2 3 Float+>     ]++We can visualise this layout as follows,+each row representing a location (each consisting of 4 components):++\[+\begin{matrix}+  & 0                & 1                & 2                     & 3                     \\+0 & \color{brown}{A} & \color{brown}{A} & \color{RoyalBlue}{B}  & \circ                 \\+1 & \color{brown}{A} & \color{brown}{A} & \color{RoyalBlue}{B}  & \color{purple}{C}     \\+2 & \color{brown}{A} & \color{brown}{A} & \circ                 & \circ                 \\+3 & \color{Plum}{D}  & \color{Plum}{D}  & \color{Plum}{D}       & \color{Plum}{D}       \\+4 & \color{Plum}{D}  & \color{Plum}{D}  & \color{orange}{E}     & \color{orange}{E}     \\+5 & \circ            & \circ            & \color{orange}{E}     & \color{orange}{E}     \\+6 & \color{green}{F} & \color{green}{F} & \color{green}{\times} & \color{green}{\times} \\+7 & \color{green}{F} & \color{green}{F} & \color{green}{\times} & \color{green}{\times} \\+8 & \color{green}{F} & \color{green}{F} & \color{green}{\times} & \color{green}{\times}+\end{matrix}+\]++Here \( \circ \) denotes unused components that are still available for other data,+whereas \( \times \) denotes unused components that /cannot/ be filled with other data.++Note in particular that matrices use as many locations as they have columns, consuming each location in its entirety.++The specification guarantees that locations 0 to 15 will be available. The availability of further locations+will depend on the GPU and its implementation of Vulkan.++For further reference, see:++  - SPIR-V specification, 2.16.2 "Validation Rules for Shader Capabilities", bullet point 3,+  - SPIR-V specification, 2.18.1 "Memory Layout",+  - Vulkan specification, 14.1.4 "Location Assignment", and 14.1.5 "Component Assignment",+  - Vulkan specification, 14.5.2 "Descriptor Set Interface", and 14.5.4 "Offset and Stride Assignment".++See also "FIR.Layout" for further information concerning memory layout.++-}++module FIR.Validation.Layout where++-- base+import Data.Kind+  ( Type, Constraint )+import Data.Type.Bool+  ( If, type (&&), type (||) )+import Data.Type.Equality+  ( type (==) )+import GHC.TypeLits+  ( TypeError, ErrorMessage(..) )+import GHC.TypeNats+  ( Nat+  , type (+), type (-)+  , type (*), Div, Mod+  )++-- fir+import Data.Type.Error+  ( IsRight )+import Data.Type.List+  ( Elem )+import Data.Type.Map+  ( (:->)((:->)) )+import Data.Type.Maybe+  ( IfNothingThen )+import Data.Type.POrd+  ( POrd(..)+  , PEnum(EnumFromOfCount)+  )+import Data.Type.String+  ( ShowNat )+import FIR.Layout+  ( Components )+import FIR.Prim.Array+  ( Array(..) )+import FIR.Prim.Struct+  ( LocationSlot(LocationSlot)+  , ShowLocationSlot+  )+import FIR.Prim.Types+  ( SScalarTy, ScalarWidth+  , ScalarFromSScalar+  , SKPrimTy(..), PrimTySing+  )+import Math.Linear+  ( V, M )+import qualified SPIRV.ScalarTy as SPIRV+  ( ScalarTy(Integer, Floating) )++-----------------------------------------------------------------------------------------------------+-- Layout validation.++-- | Validate the layout of a collection of located types.+type family ValidLayout (as :: [LocationSlot Nat :-> Type]) :: Constraint where+  ValidLayout '[] = ()+  ValidLayout ( ( loc ':-> ty ) ': slots )+    = ( IsRight ( ValidateSlot loc ( PrimTySing ty ) ) -- validate individual slot+      , CheckOverlaps ( loc ':-> ty ) slots -- pairwise overlap checks+      , ValidLayout slots+      )++-----------------------------------------------------------------------------------------------------+-- Individual validation of slots.++-- | Validate an individual location slot.+type family ValidateSlot+               ( loc  :: LocationSlot Nat )+               ( sing :: SKPrimTy ty      )+             :: Either ErrorMessage ()+             where+  ValidateSlot _ SKUnit+    = Left+        ( Text "Unit type not supported here." )+  ValidateSlot _ SKBool+    = Left+        ( Text "Booleans not supported here. Suggestion: use 'Word32' instead." )+  ValidateSlot ('LocationSlot l c) (SKScalar s :: SKPrimTy ty)+    = If ( c :<= 3 && ( c `Mod` 2 == 0 || ScalarWidth s :<= 32 ) )+        ( Right '() )+        ( Left+            (    Text "Cannot position scalar of type " :<>: ShowType ty+            :$$: Text " at " :<>: Text (ShowLocationSlot ('LocationSlot l c)) :<>: Text "."+            )+        )+  ValidateSlot ('LocationSlot l c) (SKVector s :: SKPrimTy (V n a))+    = If ( n :> 4 || n :< 2 )+        ( Left+          (    Text "Unexpected vector dimensions "+          :<>: ShowType (V n a)+          :$$: Text " at " :<>: Text (ShowLocationSlot ('LocationSlot l c)) :<>: Text "."+          )+        )+        ( If ( c == 0 || ( c `Mod` 2 == 0 && c :<= 3 && n :<= 2 && ScalarWidth s :<= 32 ) )+          ( Right '() )+          ( Left+              (    Text "Cannot position vector of type "+              :<>: ShowType (V n a)+              :$$: Text " at " :<>: Text (ShowLocationSlot ('LocationSlot l c)) :<>: Text "."+              )+          )+        )+  ValidateSlot ('LocationSlot l 0) (SKMatrix s :: SKPrimTy (M m n a))+    = If ( n :<= 4 && m :<= 4 && n :> 1 && m :> 1 )+        ( Right '() )+        ( Left+            (    Text "Unexpected matrix dimensions "+            :<>: ShowType (M m n a)+            :$$: Text " at " :<>: Text (ShowLocationSlot ('LocationSlot l 0)) :<>: Text "."+            )+        )+  ValidateSlot ('LocationSlot l c) (SKMatrix s :: SKPrimTy (M m n a))+    = Left+        (    Text "Cannot position matrix at location " :<>: ShowType l+        :<>: Text " with non-zero component " :<>: ShowType c :<>: Text "."+        )+  ValidateSlot loc (SKArray _ :: SKPrimTy (Array 0 a))+    = Left ( Text "Unexpected size 0 array at " :<>: Text (ShowLocationSlot loc) :<>: Text "." )+  ValidateSlot loc (SKArray elt :: SKPrimTy (Array l a))+    = ValidateArraySlot loc (Array l a) (ValidateSlot loc elt)+  ValidateSlot loc (SKRuntimeArray _)+    = Left ( Text "Unexpected runtime array at " :<>: Text (ShowLocationSlot loc) :<>: Text "." )+  ValidateSlot loc (SKStruct _)+    = Left+        (    Text "Unexpected struct at " :<>: Text (ShowLocationSlot loc) :<>: Text "."+        :$$: Text "Structs not (yet?) supported in inputs/outputs."+        )++type family ValidateArraySlot+              ( loc :: LocationSlot Nat )+              ( arr :: Type             )+              ( ok  :: Either ErrorMessage () )+            :: Either ErrorMessage ()+            where+  ValidateArraySlot loc arr (Left err)+    = Left+        (    Text "Attempting to position " :<>: ShowType arr+        :<>: Text " at " :<>: Text (ShowLocationSlot loc)+        :<>: Text " has caused the following error:"+        :$$: err+        )+  ValidateArraySlot _ _ _ = Right '()++-----------------------------------------------------------------------------------------------------+-- Check overlap within a collection of located types.++-- | Data (kind) recording problematic overlap between located types.+data Overlap+  = OverlappingSlot (LocationSlot Nat) -- ^ Location + component overlap.+  | OverlappingLocation Nat Type Type  -- ^ Location overlap with incompatible underlying scalar types.++type family CheckOverlaps+              ( slot  :: ( LocationSlot Nat :-> Type ) )+              ( slots :: [ LocationSlot Nat :-> Type ] )+            :: Constraint+            where+  CheckOverlaps _ '[] = ()+  CheckOverlaps slot ( s ': ss ) = ( CheckOverlap slot s, CheckOverlaps slot ss )++type family CheckOverlap+              ( slot1 :: ( LocationSlot Nat :-> Type ) )+              ( slot2 :: ( LocationSlot Nat :-> Type ) )+            :: Constraint+            where+  CheckOverlap ( loc1 ':-> ty1 ) ( loc2 ':-> ty2 )+    = ValidateOverlap+        loc1 ty1+        loc2 ty2+        ( ComputeFirstOverlap+            loc1 ( PrimTySing ty1 )+            loc2 ( PrimTySing ty2 )+        )++type family ValidateOverlap+              ( loc1    :: LocationSlot Nat )+              ( ty1     :: Type             )+              ( loc2    :: LocationSlot Nat )+              ( ty2     :: Type             )+              ( overlap :: Maybe Overlap    )+          :: Constraint+          where+  ValidateOverlap+    _ _+    _ _+    'Nothing+      = ()+  ValidateOverlap+    slot1 ty1+    slot2 ty2+    ( Just (OverlappingSlot overlapSlot) )+      = TypeError+        (    Text "Overlap at " :<>: Text (ShowLocationSlot overlapSlot) :<>: Text ":"+        :$$: Text "  - " :<>: ShowType ty1 :<>: Text " with "+        :<>: Text (ShowLocationSlot slot1) :<>: Text ","+        :$$: Text "  - " :<>: ShowType ty2 :<>: Text " with "+        :<>: Text (ShowLocationSlot slot2) :<>: Text "."+        )+  ValidateOverlap+    slot1 ty1+    slot2 ty2+    ( Just (OverlappingLocation loc scalar1 scalar2 ) )+      = TypeError+          (    Text "Incompatible scalars within Location " :<>: Text (ShowNat loc) :<>: Text ":"+          :$$: Text "  - " :<>: ShowType ty1 :<>: Text " with " :<>: Text (ShowLocationSlot slot1)+          :<>: Text " requires " :<>: ShowType scalar1 :<>: Text ","+          :$$: Text "  - " :<>: ShowType ty2 :<>: Text " with " :<>: Text (ShowLocationSlot slot2)+          :<>: Text " requires " :<>: ShowType scalar2 :<>: Text "."+          )++-- | Compute the first problematic overlap between any two pairs of located types.+--+-- This computation is done explicitly, to avoid building up any large+-- intermediate structures.+--+-- Only needs to cover pairs of the following types:+--+--  * scalars,+--  * vectors,+--  * matrices,+--  * arrays of any of the above (but not arrays of arrays).+--+-- Other types are not (currently) allowed in inputs/outputs.+type family ComputeFirstOverlap+              ( loc1  :: LocationSlot Nat )+              ( skty1 :: SKPrimTy ty1     )+              ( loc2  :: LocationSlot Nat )+              ( skty2 :: SKPrimTy ty2     )+            :: Maybe Overlap+            where+  -- scalar - scalar+  ComputeFirstOverlap+    ( 'LocationSlot l c1 ) ( SKScalar s1 :: SKPrimTy ty1 )+    ( 'LocationSlot l c2 ) ( SKScalar s2 :: SKPrimTy ty2 )+      = FirstOverlapFromEnum l+          ( 'LocationSlot l c1 ) ty1 s1+          ( 'LocationSlot l c2 ) ty2 s2+    -- (scalars are always contained within a single location)+  ComputeFirstOverlap+    ( 'LocationSlot l1 _ ) ( SKScalar _ )+    ( 'LocationSlot l2 _ ) ( SKScalar _ )+      = Nothing+  -- scalar - vector+  ComputeFirstOverlap+    ( 'LocationSlot l1 c1 ) ( SKScalar s1 :: SKPrimTy ty1        )+    ( 'LocationSlot l2 c2 ) ( SKVector s2 :: SKPrimTy (V m2 ty2) )+      = If ( l1 :< l2 || l1 :>= ( l2 + VectorLocations m2 s2 ) )+          Nothing -- no overlap possible+          ( FirstOverlapFromEnum l1+              ( 'LocationSlot l1 c1 ) ty1        s1+              ( 'LocationSlot l2 c2 ) (V m2 ty2) s2+          )+  -- vector - scalar: reduce to scalar - vector+  ComputeFirstOverlap+    ( 'LocationSlot l1 c1 ) ( SKVector s1 :: SKPrimTy (V m1 ty1) )+    ( 'LocationSlot l2 c2 ) ( SKScalar s2 :: SKPrimTy       ty2  )+      = FmapSwapOverlap+          ( ComputeFirstOverlap+            ( 'LocationSlot l2 c2 ) ( SKScalar s2 :: SKPrimTy       ty2  )+            ( 'LocationSlot l1 c1 ) ( SKVector s1 :: SKPrimTy (V m1 ty1) )+          )+  -- vector - vector+  ComputeFirstOverlap+    ( 'LocationSlot l1 c1 ) ( SKVector s1 :: SKPrimTy (V m1 ty1) )+    ( 'LocationSlot l2 c2 ) ( SKVector s2 :: SKPrimTy (V m2 ty2) )+      = If (  l1 :>= ( l2 + VectorLocations m2 s2 )+           || l2 :>= ( l1 + VectorLocations m1 s1 )+           )+          Nothing -- no overlap possible+          ( -- in this case, a unique location is used by both vectors: Max l1 l2+            FirstOverlapFromEnum (Max l1 l2)+              ( 'LocationSlot l1 c1 ) (V m1 ty1) s1+              ( 'LocationSlot l2 c2 ) (V m2 ty2) s2+          )+  -- scalar - matrix+  --   only need to check location overlap;+  --   no need to worry about components, as matrices consume locations entirely+  ComputeFirstOverlap+    ( 'LocationSlot l1 c1 ) ( SKScalar s1 :: SKPrimTy          ty1  )+    ( 'LocationSlot l2 _  ) ( SKMatrix s2 :: SKPrimTy (M m2 n2 ty2) )+      = If ( l1 :< l2 || l1 :>= ( l2 + MatrixLocations n2 s2 ) )+          Nothing+          ( Just ( 'OverlappingSlot ( 'LocationSlot l1 c1 ) ) )+  -- matrix - scalar: reduce to scalar - matrix+  ComputeFirstOverlap+    loc1 ( SKMatrix s1 :: SKPrimTy (M m1 n1 ty1) )+    loc2 ( SKScalar s2 :: SKPrimTy          ty2  )+      = FmapSwapOverlap+        ( ComputeFirstOverlap+            loc2 ( SKScalar s2 :: SKPrimTy          ty2  )+            loc1 ( SKMatrix s1 :: SKPrimTy (M m1 n1 ty1) )+        )+  -- vector - matrix+  --    essentially the same as scalar - matrix,+  --    except that the vector might take up two locations+  ComputeFirstOverlap+    ( 'LocationSlot l1 c1 ) ( SKVector s1 :: SKPrimTy (V m1    ty1) )+    ( 'LocationSlot l2 _  ) ( SKMatrix s2 :: SKPrimTy (M m2 n2 ty2) )+      = If (  ( l2 :>= ( l1 + VectorLocations m1 s1 ) )+           || ( l1 :>= ( l2 + MatrixLocations n2 s2 ) )+           )+          Nothing+          ( If ( l1 :< l2 )+              ( Just ( 'OverlappingSlot ( 'LocationSlot (l1 + 1) 0  ) ) )+              ( Just ( 'OverlappingSlot ( 'LocationSlot l1       c1 ) ) )+          )+  -- matrix - vector: reduce to vector - matrix+  ComputeFirstOverlap+    loc1 ( SKMatrix s1 :: SKPrimTy (M m1 n1 ty1) )+    loc2 ( SKVector s2 :: SKPrimTy (V m2    ty2) )+      = FmapSwapOverlap+        ( ComputeFirstOverlap+            loc2 ( SKVector s2 :: SKPrimTy (V m2    ty2) )+            loc1 ( SKMatrix s1 :: SKPrimTy (M m1 n1 ty1) )+        )+  -- matrix - matrix+  ComputeFirstOverlap+    ( 'LocationSlot l1 _ ) ( SKMatrix s1 :: SKPrimTy (M m1 n1 ty1) )+    ( 'LocationSlot l2 _ ) ( SKMatrix s2 :: SKPrimTy (M m2 n2 ty2) )+      = If (  ( l2 :>= ( l1 + MatrixLocations n1 s1 ) )+           || ( l1 :>= ( l2 + MatrixLocations n2 s2 ) )+           )+          Nothing+          ( Just ( OverlappingSlot ( 'LocationSlot ( Max l1 l2 ) 0 ) ) )+  -- arrays+  ComputeFirstOverlap+    _ ( SKArray _ :: SKPrimTy (Array 0 ty1) )+    _ _+      = Nothing+  ComputeFirstOverlap+    loc1 ( SKArray elt :: SKPrimTy (Array 1 ty1) )+    loc2 sing2+      = ComputeFirstOverlap loc1 elt loc2 sing2+  ComputeFirstOverlap+    ( 'LocationSlot l1 c1 ) ( SKArray elt1 :: SKPrimTy (Array n1 ty1) )+    ( 'LocationSlot l2 c2 ) ( sing2        :: SKPrimTy           ty2  )+      = If ( ( l1 + n1 * ( Components ty1 `Div` 4 ) ) :< l2 )+          Nothing+          ( ( ComputeFirstOverlap+                ( 'LocationSlot l1 c1 ) elt1+                ( 'LocationSlot l2 c2 ) sing2+            )+            `IfNothingThen`+            ( ComputeFirstOverlap+                ( 'LocationSlot+                    ( l1 + 1 + ( Components ty1 `Div` 4 ) )+                    c1+                )+                ( SKArray elt1 :: SKPrimTy ( Array (n1-1) ty1) )+                ( 'LocationSlot l2 c2 ) sing2+            )+          )+  ComputeFirstOverlap+    loc1 sing1+    loc2 ( SKArray elt2 :: SKPrimTy (Array n2 ty2) )+      = FmapSwapOverlap+        ( ComputeFirstOverlap+            loc2 ( SKArray elt2 :: SKPrimTy (Array n2 ty2) )+            loc1 sing1+        )++-- | Helper function to accomodate for switching arguments.+type family FmapSwapOverlap ( overlap :: Maybe Overlap ) :: Maybe Overlap where+  FmapSwapOverlap Nothing = Nothing+  FmapSwapOverlap (Just (OverlappingSlot slot)) = Just (OverlappingSlot slot)+  FmapSwapOverlap (Just (OverlappingLocation i ty1 ty2))+    = Just (OverlappingLocation i ty2 ty1)++type family VectorLocations (m :: Nat) (s :: SScalarTy ty) :: Nat where+  VectorLocations m s = If ( ScalarWidth s :<= 32 || m :<= 2 ) 1 2++type family MatrixLocations (n :: Nat) (s :: SScalarTy ty) :: Nat where+  MatrixLocations n s = n * VectorLocations 4 s++type family FirstOverlapFromEnum+              ( loc  :: Nat              ) -- location used for 'OverlappingLocation'+              ( loc1 :: LocationSlot Nat )+              ( ty1  :: Type             )+              ( s1   :: SScalarTy scal1  )+              ( loc2 :: LocationSlot Nat )+              ( ty2  :: Type             )+              ( s2   :: SScalarTy scal2  )+           :: Maybe Overlap+           where+  FirstOverlapFromEnum loc+    loc1 ty1 (s1 :: SScalarTy scal1)+    loc2 ty2 (s2 :: SScalarTy scal2)+    = ( FirstOverlappingSlot+        ( EnumConsecutiveSlots loc1 ty1 )+        ( EnumConsecutiveSlots loc2 ty2 )+      )+      `IfNothingThen`+      ( If ( CompatibleSScalars s1 s2 )+          Nothing+          ( Just ('OverlappingLocation loc scal1 scal2 ) )+      )++type family FirstOverlappingSlot+              ( slots1 :: [ LocationSlot Nat ] ) -- ordered+              ( slots2 :: [ LocationSlot Nat ] ) -- ordered+           :: Maybe Overlap+           where+  FirstOverlappingSlot '[]               _      = Nothing+  FirstOverlappingSlot (slot1 ': slots1) slots2+    = If ( slot1 `Elem` slots2 )+        ( Just (OverlappingSlot slot1) )+        ( FirstOverlappingSlot slots1 slots2 )++type CompatibleSScalars+              ( s1 :: SScalarTy ty1 )+              ( s2 :: SScalarTy ty2 )+  = ( CompatibleScalars ( ScalarFromSScalar s1 ) ( ScalarFromSScalar s2 ) :: Bool )++type family CompatibleScalars+              ( s1 :: SPIRV.ScalarTy )+              ( s2 :: SPIRV.ScalarTy )+            :: Bool+            where+  CompatibleScalars ( SPIRV.Integer _ w ) ( SPIRV.Integer _ w ) = True+  CompatibleScalars ( SPIRV.Floating  w ) ( SPIRV.Floating  w ) = True+  CompatibleScalars _                     _                     = False++-- | Simple enumeration of consecutive slots,+-- as many as the size of the type.+--+-- Should not be used for compound types,+-- where the locations used are not necessarily consecutive.+type family EnumConsecutiveSlots+              ( startLoc :: LocationSlot Nat )+              ( ty       :: Type )+            :: [ LocationSlot Nat ]+              where+  EnumConsecutiveSlots loc ty+    = EnumFromOfCount loc (Components ty)
+ src/FIR/Validation/Pipeline.hs view
@@ -0,0 +1,746 @@+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: FIR.Validation.Pipeline++Validation of graphics pipelines at compile-time.++This module validates graphics pipelines and computes information+necessary for the creation of a graphics pipeline in @Vulkan@.+-}++module FIR.Validation.Pipeline where++-- base+import Data.Kind+  ( Type, Constraint )+import Data.Type.Bool+  ( type (&&) )+import GHC.TypeLits+  ( Symbol+  , TypeError, ErrorMessage(..)+  )+import GHC.TypeNats+  ( Nat )++-- fir+import Data.Type.Error+  ( Assert )+import Data.Type.Map+  ( (:->)((:->)), Lookup )+import Data.Type.Maybe+  ( SequenceMaybe )+import Data.Type.String+  ( ShowNat )+import {-# SOURCE #-} FIR.Pipeline+  ( PrimitiveConnectedness(..), PrimitiveTopology(..)+  , PipelineInfo(VertexInputInfo, Into)+  , VertexLocationDescriptions, BindingStrides+  )+import FIR.ProgramState+  ( ProgramState(ProgramState)+  , TLInterface, TLInterfaceVariable+  , EntryPointInfo(EntryPointInfo)+  )+import FIR.Validation.Arrayness+  ( UnderlyingType )+import qualified SPIRV.Decoration as SPIRV+  ( Decoration(..) )+import qualified SPIRV.Stage      as SPIRV+import SPIRV.Stage+  ( NamedShader )+import qualified SPIRV.Storage    as SPIRV+  ( StorageClass(Input, Output) )++-----------------------------------------------------------------------------------------++-- | Check that a pipeline is valid:+--+--  - the first shader is a vertex shader,+--  - the last shader is a fragment shader,+--  - the ordering of the shaders is allowed,+--  - the interfaces between consecutive shaders match,+--  - the supplied primitive topology is valid.+type ValidPipelineInfo ( info :: PipelineInfo )+  = ( ValidPipelineInfoWithTopology info (GetTopologyInfo info) :: Constraint )++type ValidPipelineInfoWithTopology+        ( info :: PipelineInfo )+        ( top  :: PrimitiveTopology Nat )+  = ( (   StartsWithVertex   info+        , EndsWithFragment   info+        , MatchingInterfaces top info+        , ValidTopology      top+        ) :: Constraint )++type family GetVertexInputInfo ( info :: PipelineInfo )+             :: ( PrimitiveTopology Nat, VertexLocationDescriptions, BindingStrides )+             where+  GetVertexInputInfo+    ( VertexInputInfo top descs strides ) = '( top, descs, strides )+  GetVertexInputInfo+    ( pipe `Into` _ ) = GetVertexInputInfo pipe++type family GetTopologyInfo ( info :: PipelineInfo ) :: PrimitiveTopology Nat where+  GetTopologyInfo info = Proj31 (GetVertexInputInfo info)++type family Proj31 ( p :: (a,b,c) ) :: a where+  Proj31 '(a,_,_) = a++-- | Check that a pipeline starts with a vertex shader.+type family StartsWithVertex ( info :: PipelineInfo ) :: Constraint where+  StartsWithVertex+    ( VertexInputInfo _ _ _ `Into` '( _, 'EntryPointInfo (_ :: SPIRV.ExecutionInfo Nat SPIRV.Vertex) _ _ ) )+      = ()+  StartsWithVertex ( info `Into` _ )+    = StartsWithVertex info+  StartsWithVertex _+    = TypeError+        ( Text "Pipeline does not begin with a vertex shader." )++-- | Check that a pipeline ends with a fragment shader.+type family EndsWithFragment ( info :: PipelineInfo ) :: Constraint where+  EndsWithFragment+    ( _ `Into` '( _, 'EntryPointInfo (_ :: SPIRV.ExecutionInfo Nat SPIRV.Fragment) _ _ ) )+      = ()+  EndsWithFragment _+    = TypeError+        ( Text "Pipeline does not end with a fragment shader." )++-- | Check that the supplied primitive topology is valid.+type family ValidTopology (top :: PrimitiveTopology n) :: Constraint where+  ValidTopology (Line Fan)+    = TypeError ( Text "Invalid topology: fan of lines." )+  ValidTopology _+    = ()++-----------------------------------------------------------------------------------------+-- Validation of shader sequence / matching of interfaces.++-- | Check that consecutive shaders in the pipeline match up correctly:+--+--  - the sequence makes sense (e.g. can't have a tessellation shader following a geometry shader),+--  - the sequence is compatible with the supplied primitive topology,+--  - the interfaces match.+type family MatchingInterfaces+              ( top  :: PrimitiveTopology Nat )+              ( info :: PipelineInfo          )+            :: Constraint where+  MatchingInterfaces _ (VertexInputInfo _ _ _ ) = ()+  MatchingInterfaces _ (VertexInputInfo _ _ _ `Into` _) = ()+  MatchingInterfaces top+    (      pipelineStages+    `Into` pipelineStage1+    `Into` pipelineStage2+    )+      = ( ValidPipelineInterface top pipelineStage1 pipelineStage2+        , MatchingInterfaces top ( pipelineStages `Into` pipelineStage1 )+        )++---------------------------+-- Sequencing of shaders.++-- | Check that a given pair of shaders sequences correctly.+type family ValidPipelineInterface+              ( top    :: PrimitiveTopology Nat )+              ( stage1 :: (Symbol, EntryPointInfo) )+              ( stage2 :: (Symbol, EntryPointInfo) )+            :: Constraint+            where+  ValidPipelineInterface top+    '( name1,+        'EntryPointInfo+          ( 'SPIRV.ShaderExecutionInfo info1+              :: SPIRV.ExecutionInfo Nat ('SPIRV.Stage ('SPIRV.ShaderStage shader1))+          )+          ifaceVars1+          _+    )+    '( name2,+        'EntryPointInfo+          ( 'SPIRV.ShaderExecutionInfo info2+              :: SPIRV.ExecutionInfo Nat ('SPIRV.Stage ('SPIRV.ShaderStage shader2))+          )+          ifaceVars2+          _+    )+      = ( MatchingInterface+          name1 info1 ( SequenceMaybe ( Lookup SPIRV.Output ifaceVars1 ) )+          name2 info2 ( SequenceMaybe ( Lookup SPIRV.Input  ifaceVars2 ) )+        , ValidSequence top+            name1 shader1 info1+            name2 shader2 info2+        )++-- | Checks that the sequencing of shaders is valid.+--+-- Checks that:+--+--   - the sequence of stages is an allowed stage sequence,+--     e.g. a Geometry shader must be followed by a Fragment shader,+--+--   - the stages fit the given primitive topology,+--     e.g. no tessellation shaders if primitive topology is not 'Patches',+--+--   - subsequent stages are in the correct mode,+--     e.g. the Tessellation Evaluation shader outputs geometry+--     in the appropriate mode for the Geometry shader that follows.+type family ValidSequence+              ( top     :: PrimitiveTopology Nat        )+              ( name1   :: Symbol                       )+              ( shader1 :: SPIRV.Shader                 )+              ( info1   :: SPIRV.ShaderInfo Nat shader1 )+              ( name2   :: Symbol                       )+              ( shader2 :: SPIRV.Shader                 )+              ( info2   :: SPIRV.ShaderInfo Nat shader2 )+            :: Constraint where+  ValidSequence ('PatchesOfSize n)+    _ SPIRV.VertexShader               _+    _ SPIRV.TessellationControlShader  _+      = ()+  ValidSequence top+    _ SPIRV.VertexShader               _+    _ SPIRV.TessellationControlShader  _+      = TypeError+        (    Text "Primitive topology is " :<>: ShowType top :<>: Text ","+        :$$: Text "which cannot be used in the presence of tessellation shaders."+        )+  ValidSequence ('PatchesOfSize n)+    _ SPIRV.VertexShader   _+    _ SPIRV.GeometryShader _+      = TypeError+        (    Text "Primitive topology is 'Patches' – "+        :<>: Text "which requires the use of tessellation – "+        :$$: Text "but the supplied shader pipeline does not contain\+                  \ any tessellation shaders."+        )+  ValidSequence top+    _     SPIRV.VertexShader   _+    name2 SPIRV.GeometryShader geomInfo+      = CompatibleGeometryTopology top 'Nothing name2 geomInfo+  ValidSequence ('PatchesOfSize n)+    _ SPIRV.VertexShader   _+    _ SPIRV.FragmentShader _+      = TypeError+        (    Text "Primitive topology is 'Patches' – "+        :<>: Text "which requires the use of tessellation – "+        :$$: Text "but the supplied shader pipeline does not contain\+                  \ any tessellation shaders."+        )+  ValidSequence _+    _ SPIRV.VertexShader   _+    _ SPIRV.FragmentShader _+      = ()+  ValidSequence _+    name1 SPIRV.TessellationControlShader    info1+    name2 SPIRV.TessellationEvaluationShader info2+      = CompatibleTessellationStages name1 info1 name2 info2+  ValidSequence top+    name1 SPIRV.TessellationEvaluationShader info1+    name2 SPIRV.GeometryShader               info2+      = CompatibleGeometryTopology top (Just '(name1, info1)) name2 info2+  ValidSequence _+    _ SPIRV.TessellationEvaluationShader _+    _ SPIRV.FragmentShader               _+      = ()+  ValidSequence _+    _ SPIRV.GeometryShader _+    _ SPIRV.FragmentShader _+      = ()+  ValidSequence _ name1 shader1 _ name2 shader2 _+    = TypeError+        ( Text "Invalid pipeline:"+         :$$: Text (NamedShader name2 shader2) :<>: Text " cannot follow "+         :<>: Text (NamedShader name1 shader1) :<>: Text "."+        )++type family CompatibleGeometryTopology+              ( top :: PrimitiveTopology Nat )+              ( mbTess :: Maybe+                  ( Symbol, SPIRV.ShaderInfo Nat SPIRV.TessellationEvaluationShader )+              )+              ( geomName :: Symbol )+              ( geom :: SPIRV.ShaderInfo Nat SPIRV.GeometryShader )+            :: Constraint+            where+  CompatibleGeometryTopology+    ( 'PatchesOfSize n )+    ( 'Just '( teseName, SPIRV.TessellationEvaluationShaderInfo _ teseMode ) )+    geomName+    ( SPIRV.GeometryShaderInfo _ geomMode )+      = ( CompatibleTessellationGeometryModes teseName teseMode geomName geomMode )+  CompatibleGeometryTopology+    top+    'Nothing+    geomName+    ( SPIRV.GeometryShaderInfo _ geomMode )+      = ( CompatibleBasicGeometryTopology top geomName geomMode )+++-- | Check that the Geometry shader is getting the correct primitive topology,+-- in a pipeline without any tessellation.+type family CompatibleBasicGeometryTopology+                ( top      :: PrimitiveTopology Nat   )+                ( geomName :: Symbol                  )+                ( geomMode :: SPIRV.GeometryInputMode )+              :: Constraint+              where+  CompatibleBasicGeometryTopology+    Points+    _+    SPIRV.InputModePoints+      = ()+  CompatibleBasicGeometryTopology+    (Line List)+    _+    SPIRV.InputModeLines+      = ()+  CompatibleBasicGeometryTopology+    (Line AdjacencyStrip)+    _+    SPIRV.InputModeLinesAdjacency+      = ()+  CompatibleBasicGeometryTopology+    (Triangle List)+    _+    SPIRV.InputModeTriangles+      = ()+  CompatibleBasicGeometryTopology+    (Triangle Strip)+    _+    SPIRV.InputModeTriangles+      = ()+  CompatibleBasicGeometryTopology+    (Triangle Fan)+    _+    SPIRV.InputModeTriangles+      = ()+  CompatibleBasicGeometryTopology+    (Triangle AdjacencyList)+    _+    SPIRV.InputModeTrianglesAdjacency+      = ()+  CompatibleBasicGeometryTopology+    (Triangle AdjacencyStrip)+    _+    SPIRV.InputModeTrianglesAdjacency+      = ()+  CompatibleBasicGeometryTopology+    top+    geomName+    geomMode+      = TypeError+      (    Text (NamedShader geomName SPIRV.GeometryShader)+      :<>: Text " input mode " :<>: Text (SPIRV.ShowGeometryInputMode geomMode)+      :$$: Text "is incompatible with the primitive topology "+      :<>: ShowType top :<>: Text "."+      )++-- | Check that the Geometry shader is getting the correct primitive topology,+-- in a pipeline which does contain tessellation.+type family CompatibleTessellationGeometryModes+              ( teseName :: Symbol                  )+              ( teseMode :: SPIRV.TessellationMode  )+              ( geomName :: Symbol                  )+              ( geomMode :: SPIRV.GeometryInputMode )+            :: Constraint+            where+  CompatibleTessellationGeometryModes+    _ SPIRV.ModePoints+    _ SPIRV.InputModePoints+      = ()+  CompatibleTessellationGeometryModes+    _ SPIRV.ModeIsolines+    _ SPIRV.InputModeLines+      = ()+  CompatibleTessellationGeometryModes+    _ SPIRV.ModeTriangles+    _ SPIRV.InputModeTriangles+      = ()+  CompatibleTessellationGeometryModes+    _ SPIRV.ModeQuads+    _ SPIRV.InputModeTriangles+      = ()+  CompatibleTessellationGeometryModes+    teseName teseMode+    geomName geomMode+      = TypeError+        (    Text (NamedShader geomName SPIRV.GeometryShader)+        :<>: Text " input mode " :<>: Text (SPIRV.ShowGeometryInputMode geomMode)+        :$$: Text "is incompatible with the preceding "+        :<>: Text (NamedShader teseName SPIRV.TessellationEvaluationShader)+        :<>: Text " output mode "+        :<>: Text (SPIRV.ShowTessellationMode teseMode) :<>: Text "."+        )++-- | Check that the two tessellation stages are using the same tessellation mode.+type family CompatibleTessellationStages+              ( tescName :: Symbol )+              ( tesc :: SPIRV.ShaderInfo Nat SPIRV.TessellationControlShader    )+              ( teseName :: Symbol )+              ( tese :: SPIRV.ShaderInfo Nat SPIRV.TessellationEvaluationShader )+            :: Constraint+            where+  CompatibleTessellationStages+    _ ( SPIRV.TessellationControlShaderInfo  _ _ 'Nothing )+    _ ( SPIRV.TessellationEvaluationShaderInfo _ _        )+      = ()+  CompatibleTessellationStages+    _ ( SPIRV.TessellationControlShaderInfo  _ _ ('Just mode) )+    _ ( SPIRV.TessellationEvaluationShaderInfo _ mode         )+      = ()+  CompatibleTessellationStages+    tescName ( SPIRV.TessellationControlShaderInfo  _ _ ('Just tescMode) )+    teseName ( SPIRV.TessellationEvaluationShaderInfo _ teseMode         )+      = TypeError+        (    Text "Conflicting tessellation modes:"+        :$$: Text "  - " :<>: Text (NamedShader tescName SPIRV.TessellationControlShader)+        :<>: Text" specifies "+        :<>: Text (SPIRV.ShowTessellationMode tescMode) :<>: Text ","+        :$$: Text "  - " :<>: Text (NamedShader teseName SPIRV.TessellationEvaluationShader)+        :<>: Text" specifies "+        :<>: Text (SPIRV.ShowTessellationMode teseMode) :<>: Text "."+        )+++type family GetExecutionInfo+              ( shader :: SPIRV.Shader )+              ( name   :: Symbol       )+              ( state  :: ProgramState )+          :: SPIRV.ExecutionInfo Nat ('SPIRV.Stage ('SPIRV.ShaderStage shader))+          where+  GetExecutionInfo shader name ('ProgramState _ _ _ _ eps _ _ _)+    = GetExecutionInfoOf shader name eps++type family GetExecutionInfoOf+             ( shader :: SPIRV.Shader )+             ( name   :: Symbol       )+             ( eps    :: [ Symbol :-> EntryPointInfo ] )+          :: SPIRV.ExecutionInfo Nat ('SPIRV.Stage ('SPIRV.ShaderStage shader))+          where+  GetExecutionInfoOf shader name '[]+    = TypeError+        (      Text "Module does not define a "+          :<>: Text (NamedShader name shader)+          :<>: Text "."+        )+  GetExecutionInfoOf shader name+    ( ( name ':->+        ( 'EntryPointInfo+           ( nfo :: SPIRV.ExecutionInfo Nat ('SPIRV.Stage ('SPIRV.ShaderStage shader)) )+           _+           _+        )+      )+    ': _+    )+      = nfo+  GetExecutionInfoOf shader name ( _ ': eps )+    = GetExecutionInfoOf shader name eps++type family GetInterface+              ( shader :: SPIRV.Shader )+              ( name   :: Symbol       )+              ( state  :: ProgramState )+          :: TLInterface+          where+  GetInterface shader name ('ProgramState _ _ _ _ eps _ _ _)+    = GetInterfaceOf shader name eps++type family GetInterfaceOf+              ( shader :: SPIRV.Shader )+              ( name   :: Symbol       )+              ( eps    :: [ Symbol :-> EntryPointInfo ] )+          :: TLInterface+          where+  GetInterfaceOf shader name '[]+    = TypeError+        (      Text "Module does not define a "+          :<>: Text (NamedShader name shader)+          :<>: Text "."+        )+  GetInterfaceOf shader name+    ( ( name ':->+        ( 'EntryPointInfo+           _+           iface+           _+        )+      )+    ': _+    )+      = iface+  GetInterfaceOf shader name ( _ ': eps )+    = GetInterfaceOf shader name eps++---------------------------+-- Interface matching.++type family MatchingInterface+              ( stageName1 :: Symbol                           )+              ( stageInfo1 :: SPIRV.ShaderInfo Nat stage1      )+              ( outputs    :: [Symbol :-> TLInterfaceVariable] )+              ( stageName2 :: Symbol                           )+              ( stageInfo2 :: SPIRV.ShaderInfo Nat stage2      )+              ( inputs     :: [Symbol :-> TLInterfaceVariable] )+            :: Constraint+            where+  MatchingInterface+    _ _ '[]+    _ _ '[]+      = ()+  MatchingInterface+    stageName1 ( stageInfo1 :: SPIRV.ShaderInfo Nat stage1 ) '[]+    stageName2 ( stageInfo2 :: SPIRV.ShaderInfo Nat stage2 ) ( ( inputName ':-> '(_, ty2) ) ': _ )+      = TypeError+          (      Text "Input " :<>: ShowType inputName+            :<>: Text " of type " :<>: ShowType ty2+            :<>: Text " of " :<>: Text ( NamedShader stageName1 stage2 ) :<>: Text ","+            :$$: Text "does not match any output of "+            :<>: Text (NamedShader stageName2 stage1) :<>: Text "."+          )+  MatchingInterface+    stageName1 stageInfo1 ( ( outputName ':-> output ) ': outputs )+    stageName2 stageInfo2 inputs+      = MatchingInterface+          stageName1 stageInfo1 outputs+          stageName2 stageInfo2+            ( RemoveMatch+                stageName1 stageInfo1 outputName output+                stageName2 stageInfo2            inputs+            )++type family RemoveMatch+              ( stageName1 :: Symbol                            )+              ( stageInfo1 :: SPIRV.ShaderInfo Nat stage1       )+              ( outputName :: Symbol                            )+              ( output     :: TLInterfaceVariable               )+              ( stageName2 :: Symbol                            )+              ( stageInfo2 :: SPIRV.ShaderInfo Nat stage2       )+              ( inputs     :: [ Symbol :-> TLInterfaceVariable] )+            :: [ Symbol :-> TLInterfaceVariable]+            where+  RemoveMatch+    stageName1 ( stageInfo1 :: SPIRV.ShaderInfo Nat stage1 ) outputName '(_, ty1)+    stageName2 ( stageInfo2 :: SPIRV.ShaderInfo Nat stage2 )            '[]+      = TypeError+          (      Text "Output " :<>: ShowType outputName+            :<>: Text " of type " :<>: ShowType ty1+            :<>: Text " of " :<>: Text ( NamedShader stageName1 stage1 ) :<>: Text ","+            :$$: Text "does not match any input of "+            :<>: Text (NamedShader stageName2 stage2) :<>: Text "."+          )+  RemoveMatch+    stageName1 stageInfo1 outputName '(decs1, ty1)+    stageName2 stageInfo2            ( ( inputName ':-> '(decs2, ty2) ) ': inputs )+    = RemoveThisMatchOrContinue+        ( SameLocation+            (Location decs1) (Component decs1)+            (Location decs2) (Component decs2)+        )+        stageName1 stageInfo1 outputName '(decs1, ty1)+        stageName2 stageInfo2 inputName  '(decs2, ty2)+        inputs++type family RemoveThisMatchOrContinue+              ( mbLocation :: Maybe (Nat, Nat)                  )+              ( stageName1 :: Symbol                            )+              ( stageInfo1 :: SPIRV.ShaderInfo Nat shader1      )+              ( outputName :: Symbol                            )+              ( output     :: TLInterfaceVariable               )+              ( stageName2 :: Symbol                            )+              ( stageInfo2 :: SPIRV.ShaderInfo Nat shader2      )+              ( inputName  :: Symbol                            )+              ( input      :: TLInterfaceVariable               )+              ( inputs     :: [ Symbol :-> TLInterfaceVariable] )+          :: [ Symbol :-> TLInterfaceVariable ]+          where+  RemoveThisMatchOrContinue (Just loc)+    stageName1 stageInfo1 outputName output+    stageName2 stageInfo2 inputName  input  inputs+      = Assert+          ( Matches loc+              stageName1 stageInfo1 outputName output+              stageName2 stageInfo2 inputName  input+          )+          inputs+  RemoveThisMatchOrContinue Nothing+    stageName1 stageInfo1 outputName output+    stageName2 stageInfo2 inputName  input  inputs+      = ( inputName ':-> input ) ':+          RemoveMatch+            stageName1 stageInfo1 outputName output+            stageName2 stageInfo2            inputs++type family Matches+              ( location   :: (Nat,Nat)                    )+              ( stageName1 :: Symbol                       )+              ( stage1     :: SPIRV.ShaderInfo Nat shader1 )+              ( outputName :: Symbol                       )+              ( output     :: TLInterfaceVariable          )+              ( stageName2 :: Symbol                       )+              ( stage2     :: SPIRV.ShaderInfo Nat shader2 )+              ( inputName  :: Symbol                       )+              ( input      :: TLInterfaceVariable          )+            :: Bool+            where+  Matches loc+    stageName1 ( stageInfo1 :: SPIRV.ShaderInfo Nat stage1 )+    outputName '(decs1, ty1)+    stageName2 ( stageInfo2 :: SPIRV.ShaderInfo Nat stage2 )+    inputName  '(decs2, ty2)+      =   MatchingUnderlyingTypes loc+            stageName1 stage1+            outputName+            ( UnderlyingType outputName SPIRV.Output decs1 stageName1 ty1+                ( SPIRV.ShaderExecutionInfo stageInfo1 )+            )+            stageName2 stage2+            inputName+            ( UnderlyingType inputName  SPIRV.Input  decs2 stageName2 ty2+                ( SPIRV.ShaderExecutionInfo stageInfo2 )+            )+      &&  MatchingDecorations loc+            stageName1 stage1 outputName decs1+            stageName2 stage2 inputName  decs2++type family SameLocation+              ( loc1  :: Maybe Nat )+              ( comp1 :: Nat       )+              ( loc2  :: Maybe Nat )+              ( comp2 :: Nat       )+            :: Maybe (Nat, Nat)+            where+  SameLocation (Just loc) comp (Just loc) comp+    = Just '(loc, comp)+  SameLocation _ _ _ _+    = Nothing++type family Location (decs :: [SPIRV.Decoration Nat]) :: Maybe Nat where+  Location ('SPIRV.Location i ': _)+    = Just i+  Location (_ ': decs)+    = Location decs+  Location '[]+    = Nothing++type family Component (decs :: [SPIRV.Decoration Nat]) :: Nat where+  Component ('SPIRV.Component i ': _) = i+  Component (_ ': decs) = Component decs+  Component '[] = 0++type family MatchingUnderlyingTypes+              ( loc        :: (Nat, Nat)   )+              ( stageName1 :: Symbol       )+              ( stage1     :: SPIRV.Shader )+              ( varName1   :: Symbol       )+              ( u_type1    :: Type         )+              ( stageName2 :: Symbol       )+              ( stage2     :: SPIRV.Shader )+              ( varName2   :: Symbol       )+              ( u_type2    :: Type         )+            :: Bool+            where+  MatchingUnderlyingTypes _+    _ _ _ u_ty1+    _ _ _ u_ty1+      = 'True+  MatchingUnderlyingTypes loc+    stageName1 stage1 varName1 u_ty1+    stageName2 stage2 varName2 u_ty2+    = TypeError+        (    MismatchLocation loc+        :$$: Text "Output named " :<>: ShowType varName1+        :<>: Text " of " :<>: Text (NamedShader stageName1 stage1)+        :<>: Text " has underlying type " :<>: ShowType u_ty1 :<>: Text ","+        :$$: Text "whereas input named " :<>: ShowType varName2+        :<>: Text " of " :<>: Text (NamedShader stageName2 stage2)+        :<>: Text " has underlying type " :<>: ShowType u_ty2 :<>: Text "."+        )++type family MismatchLocation ( loc :: (Nat,Nat) ) :: ErrorMessage where+  MismatchLocation '(loc, 0)+    =    Text "Interface mismatch at location " :<>: Text (ShowNat loc)+    :<>: Text "."+  MismatchLocation '(loc, comp)+    =    Text "Interface mismatch at location " :<>: Text (ShowNat loc)+    :<>: Text ", component " :<>: Text (ShowNat loc) :<>: Text "."++type family MatchingDecorations+              ( loc        :: (Nat, Nat)             )+              ( stageName1 :: Symbol                 )+              ( stage1     :: SPIRV.Shader           )+              ( inputName  :: Symbol                 )+              ( decs1      :: [SPIRV.Decoration Nat] )+              ( stageName2 :: Symbol                 )+              ( stage2     :: SPIRV.Shader           )+              ( outputName :: Symbol                 )+              ( decs2      :: [SPIRV.Decoration Nat] )+            :: Bool+            where+  MatchingDecorations _+    _ _ _ '[]+    _ _ _ '[]+      = 'True+  MatchingDecorations loc+    stageName1 stage1 outputName '[]+    stageName2 stage2 inputName  (dec2 ': _)+      = TypeError+          ( MismatchLocation loc+           :$$: Text "Input named " :<>: ShowType inputName+           :<>: Text " to " :<>: Text (NamedShader stageName2 stage2)+           :<>: Text " is decorated with " :<>: ShowType dec2 :<>: Text ","+           :$$: Text "but matching output " :<>: ShowType outputName+           :<>: Text " to " :<>: Text (NamedShader stageName1 stage1)+           :<>: Text " is missing such a decoration."+          )+  MatchingDecorations loc+    stageName1 stage1 outputName ( dec1 ': decs1 )+    stageName2 stage2 inputName  decs2+      = MatchingDecorations loc+          stageName1 stage1 outputName decs1+          stageName2 stage2 inputName+            ( FindAndRemoveDecoration loc+                stageName1 stage1 outputName dec1+                stageName2 stage2 inputName  decs2+            )++type family FindAndRemoveDecoration+              ( loc        :: (Nat, Nat)             )+              ( stageName1 :: Symbol                 )+              ( stage1     :: SPIRV.Shader           )+              ( outputName :: Symbol                 )+              ( dec1       :: SPIRV.Decoration Nat   )+              ( stageName2 :: Symbol                 )+              ( stage2     :: SPIRV.Shader           )+              ( inputName  :: Symbol                 )+              ( decs2      :: [SPIRV.Decoration Nat] )+            :: [SPIRV.Decoration Nat]+            where+  FindAndRemoveDecoration _+    _ _ _ dec1+    _ _ _ (dec1 ': decs2)+      = decs2+  FindAndRemoveDecoration loc+    stageName1 stage1 outputName  dec1+    stageName2 stage2 inputName   (dec2 ': decs2)+      = dec2 ': FindAndRemoveDecoration loc+                  stageName1 stage1 outputName dec1+                  stageName2 stage2 inputName  decs2+  FindAndRemoveDecoration loc+    stageName1 stage1 outputName dec1+    stageName2 stage2 inputName  '[]+      = TypeError+          ( MismatchLocation loc+           :$$: Text "Output named " :<>: ShowType outputName+           :<>: Text " to " :<>: Text (NamedShader stageName1 stage1)+           :<>: Text " is decorated with " :<>: ShowType dec1 :<>: Text ","+           :$$: Text "but matching input " :<>: ShowType inputName+           :<>: Text " to " :<>: Text (NamedShader stageName2 stage2)+           :<>: Text " is missing such a decoration."+          )
+ src/FIR/Validation/RayTracing.hs view
@@ -0,0 +1,459 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module: FIR.Validation.RayTracing++Validation of ray-tracing and ray-query operations.+-}+++module FIR.Validation.RayTracing+  ( -- * Ray tracing validation+    CanTraceRay, CanExecuteCallable+    -- * Ray query validation+    -- ** Modifying ray query state+  , NewRayQuery, RayQueryProceed, RayQueryCandidateState, RayQueryCommittedState, Terminate+    -- ** Validating ray query state+  , CanGenerateIntersection, CanConfirmIntersection+  , HasRayQuery, CanGetIntersectionT, HasSomeIntersection, HasSomeTriangleIntersection+  )+  where++-- base+import Data.Kind+  ( Type, Constraint )+import Data.Type.Bool+  ( If )+import GHC.TypeLits+  ( Symbol+  , TypeError, ErrorMessage(..)+  )+import GHC.TypeNats+  ( Nat )++-- fir+import Data.Type.Error+  ( Try )+import Data.Type.Map+  ( (:->)((:->)), Insert, LookupAndLookup )+import Data.Type.Maybe+  ( IfNothingThen )+import FIR.Prim.RayTracing+  ( RayQueryState(..), RayQueryProceedState(..)+  , IntersectionType(..), RayQueryCandidateIntersection(..), RayQueryCommittedIntersection(..)+  )+import FIR.ProgramState+  ( ProgramState(..), FunctionContext(..)+  , TLInterfaceVariable+  )+import qualified SPIRV.Stage      as SPIRV+import qualified SPIRV.Storage    as SPIRV++--------------------------------------------------------------------------+-- Ray tracing validation.++-- | Check that a 'traceRay' instruction is valid:+--+--   - the execution model is a ray generation, closest hit or miss shader,+--   - @payload@ indeed refers to a variable with ray payload storage class.+type family CanTraceRay+             ( payload :: Symbol       )+             ( i       :: ProgramState )+          :: Constraint+          where+  CanTraceRay payload+    ( 'ProgramState+       _+       ('InEntryPoint _+         ( info :: SPIRV.ExecutionInfo Nat ( 'SPIRV.Stage ( 'SPIRV.RayStage shader ) ) )+         _+       )+       _ _ _ iface _ _+    ) = If ( StageIsCompatibleWithRayPayload shader )+          ( HasRayPayloadBinding payload+              ( IfNothingThen+                 ( LookupAndLookup ('SPIRV.RayStorage (SPIRV.RayPayload SPIRV.Incoming)) payload iface )+                 ( LookupAndLookup ('SPIRV.RayStorage (SPIRV.RayPayload SPIRV.Lifetime)) payload iface )+              )+          )+          ( TypeError+            (    Text "'traceRay' instruction not allowed in ray-tracing shader "+            :<>: Text ( SPIRV.StageName ( 'SPIRV.RayStage shader ) )+            :<>: Text "."+            )+          )+  CanTraceRay _ _ = TypeError+    ( Text "Cannot call 'traceRay' here: not within a ray-tracing shader." )++type family StageIsCompatibleWithRayPayload ( shader :: SPIRV.RayShader ) :: Bool where+  StageIsCompatibleWithRayPayload SPIRV.RayGenerationShader = 'True+  StageIsCompatibleWithRayPayload SPIRV.ClosestHitShader    = 'True+  StageIsCompatibleWithRayPayload SPIRV.MissShader          = 'True+  StageIsCompatibleWithRayPayload _                         = 'False+++type family HasRayPayloadBinding+              ( callable :: Symbol                    )+              ( mbVar    :: Maybe TLInterfaceVariable )+            :: Constraint+            where+  HasRayPayloadBinding payload 'Nothing =+    TypeError+      (    Text "Cannot use payload named " :<>: ShowType payload :<>: Text " in this call to 'traceRay'."+      :$$: Text "No interface variable with 'RayPayload' storage class could be found with this name."+      )+  HasRayPayloadBinding payload ( 'Just '( decs, ty ) ) =+    Try+      ( ValidPayloadType payload ty )++{-+type family PayloadLocation ( payload :: Symbol ) ( decs :: [ SPIRV.Decoration Nat ] ) :: Either ErrorMessage Constraint where+  PayloadLocation payload '[] = Left+    ( Text "Ray payload interface variable named " :<>: ShowType payload+    :$$: Text "is missing a 'Location' decoration."+    )+  PayloadLocation _ ( SPIRV.Location _ ': _ ) = Right ( () :: Constraint )+  PayloadLocation payload ( _ ': decs ) = PayloadLocation payload decs+-}++type family ValidPayloadType ( payload :: Symbol ) ( ty :: Type ) :: Either ErrorMessage Constraint where+  ValidPayloadType _ _ = Right ( () :: Constraint ) -- TODO+++-- | Check that an 'executeCallable' instruction is valid:+--+--  - the execution model is a ray generation, closest hit, miss shader or callable shader,+--  - @callableData@ indeed refers to a variable with callable data storage class.+type family CanExecuteCallable+              ( callableData :: Symbol       )+              ( i            :: ProgramState )+           :: Constraint+            where+  CanExecuteCallable callable +    ( 'ProgramState+       _+       ('InEntryPoint _+         ( info :: SPIRV.ExecutionInfo Nat ( 'SPIRV.Stage ( 'SPIRV.RayStage shader ) ) )+         _+       )+       _ _ _ iface _ _+    ) = If ( StageIsCompatibleWithCallableData shader )+          ( HasCallableDataBinding callable+              ( IfNothingThen+                 ( LookupAndLookup ('SPIRV.RayStorage (SPIRV.CallableData SPIRV.Incoming)) callable iface )+                 ( LookupAndLookup ('SPIRV.RayStorage (SPIRV.CallableData SPIRV.Lifetime)) callable iface )+              )+          )+          ( TypeError+            (    Text "'executeCallable' instruction not allowed in ray-tracing shader "+            :<>: Text ( SPIRV.StageName ( 'SPIRV.RayStage shader ) )+            :<>: Text "."+            )+          )+  CanExecuteCallable _ _ = TypeError+    ( Text "Cannot call 'executeCallable' here: not within a ray-tracing shader." )++type family StageIsCompatibleWithCallableData ( shader :: SPIRV.RayShader ) :: Bool where+  StageIsCompatibleWithCallableData SPIRV.RayGenerationShader = 'True+  StageIsCompatibleWithCallableData SPIRV.ClosestHitShader    = 'True+  StageIsCompatibleWithCallableData SPIRV.MissShader          = 'True+  StageIsCompatibleWithCallableData SPIRV.CallableShader      = 'True+  StageIsCompatibleWithCallableData _                         = 'False++type family HasCallableDataBinding+              ( callable :: Symbol )+              ( bd :: Maybe TLInterfaceVariable )+            :: Constraint+            where+  HasCallableDataBinding callable  'Nothing =+    TypeError+      (    Text "Cannot use callable data named " :<>: ShowType callable :<>: Text " in this call to 'executeCallable'."+      :$$: Text "No interface variable with 'CallableData' storage class could be found with this name."+      )+  HasCallableDataBinding callable  ( 'Just '( decs, ty ) ) =+    Try+      ( ValidCallableDataType callable ty )++{-+type family CallableDataLocation ( payload :: Symbol ) ( decs :: [ SPIRV.Decoration Nat ] ) :: Either ErrorMessage Constraint where+  CallableDataLocation callable '[] = Left+    ( Text "Callable data interface variable named " :<>: ShowType callable+    :$$: Text "is missing a 'Location' decoration."+    )+  CallableDataLocation _ ( SPIRV.Location _ ': _ ) = Right ( () :: Constraint )+  CallableDataLocation callable ( _ ': decs ) = CallableDataLocation callable decs+-}++type family ValidCallableDataType ( callable :: Symbol ) ( ty :: Type ) :: Either ErrorMessage Constraint where+  ValidCallableDataType _ _ = Right ( () :: Constraint ) -- TODO+++--------------------------------------------------------------------------+-- Ray query validation.++-- | Start a new ray query.+type family NewRayQuery ( rayQuery :: Symbol ) ( i :: ProgramState ) :: ProgramState where+  NewRayQuery rayQuery ( 'ProgramState bds ctx cfg fns eps iface rayQueries bk ) =+    'ProgramState bds ctx cfg fns eps iface ( Insert rayQuery ( 'RayQueryState 'Nothing 'Nothing ) rayQueries ) bk++-- | Validation for ray query 'ifProceeding' function:+--+--   - check that the ray query referred to has been initialized,+--   - check that the ray query has not already completed+--   - sets the ray query proceed state going forwards.+type family RayQueryProceed+              ( rayQuery :: Symbol               )+              ( st       :: RayQueryProceedState )+              ( i        :: ProgramState         )+           :: ProgramState where+  RayQueryProceed rayQuery st ( 'ProgramState bds ctx cfg fns eps iface rayQueries bk ) =+    'ProgramState bds ctx cfg fns eps iface ( SetProceedState rayQuery st rayQueries) bk++type family SetProceedState+              ( rayQuery   :: Symbol                       )+              ( st         :: RayQueryProceedState         )+              ( rayQueries :: [ Symbol :-> RayQueryState ] )+           :: [ Symbol :-> RayQueryState ]+           where+  SetProceedState rayQuery _ '[] =+    TypeError+      ( Text "'ifProceeding': no ray query found with name " :<>: ShowType rayQuery :<>: Text "." )+  SetProceedState rayQuery st ( ( rayQuery ':-> 'RayQueryState ( 'Just Complete ) _ ) ': _ ) =+    TypeError+      (    Text "'ifProceeding': cannot proceed with ray query named "  :<>: ShowType rayQuery :<>: Text ","+      :$$: Text "as this ray query has already completed."+      )+  SetProceedState rayQuery st ( ( rayQuery ':-> 'RayQueryState _ commState ) ': rayQueries ) =+    ( rayQuery ':-> 'RayQueryState ( 'Just st ) commState ) ': rayQueries+  SetProceedState rayQuery st ( otherRayQuery ': rayQueries )+    = otherRayQuery ': SetProceedState rayQuery st rayQueries++-- | Validation for ray query 'withCandidateIntersection' function:+--+--   - check that the ray query referred to has been initialized,+--   - check that the ray query has not already completed,+--   - sets the candidate intersection type going forwards.+type family RayQueryCandidateState+              ( rayQuery :: Symbol                        )+              ( st       :: RayQueryCandidateIntersection )+              ( i        :: ProgramState                  )+           :: ProgramState where+  RayQueryCandidateState rayQuery st ( 'ProgramState bds ctx cfg fns eps iface rayQueries bk ) =+    'ProgramState bds ctx cfg fns eps iface ( SetCandidateState rayQuery st rayQueries) bk++type family SetCandidateState+              ( rayQuery   :: Symbol                        )+              ( st         :: RayQueryCandidateIntersection )+              ( rayQueries :: [ Symbol :-> RayQueryState ]  )+           :: [ Symbol :-> RayQueryState ]+           where+  SetCandidateState rayQuery _ '[] =+    TypeError+      ( Text "'withCandidateIntersection': no ray query found with name " :<>: ShowType rayQuery :<>: Text "." )+  SetCandidateState rayQuery st ( ( rayQuery ':-> 'RayQueryState 'Nothing _ ) ': _ ) =+    TypeError+      (    Text "'withCandidateIntersection': cannot get candidate intersection type for ray query named "  :<>: ShowType rayQuery :<>: Text ","+      :$$: Text "as it has not been decided whether to proceed with this ray query."+      :$$: Text "Possible fix: use 'ifProceeding' to determine whether ray query proceeds."+      )+  SetCandidateState rayQuery st ( ( rayQuery ':-> 'RayQueryState ( 'Just Complete ) _ ) ': _ ) =+    TypeError+      (    Text "'withCandidateIntersection': cannot get candidate intersection type for ray query named "  :<>: ShowType rayQuery :<>: Text ","+      :$$: Text "as this ray query has already completed."+      )+  SetCandidateState rayQuery st ( ( rayQuery ':-> 'RayQueryState _ commState ) ': rayQueries ) =+    ( rayQuery ':-> 'RayQueryState ( 'Just ( Incomplete ( 'Just st ) ) ) commState ) ': rayQueries+  SetCandidateState rayQuery st ( otherRayQuery ': rayQueries )+    = otherRayQuery ': SetCandidateState rayQuery st rayQueries++-- | Validation for ray query 'withCommittedIntersection' function:+--+--   - check that the ray query referred to has been initialized,+--   - sets the committed intersection type going forwards.+type family RayQueryCommittedState+              ( rayQuery :: Symbol                        )+              ( st       :: RayQueryCommittedIntersection )+              ( i        :: ProgramState                  )+           :: ProgramState where+  RayQueryCommittedState rayQuery st ( 'ProgramState bds ctx cfg fns eps iface rayQueries bk ) =+    'ProgramState bds ctx cfg fns eps iface ( SetCommittedState rayQuery st rayQueries) bk++type family SetCommittedState+              ( rayQuery   :: Symbol                        )+              ( st         :: RayQueryCommittedIntersection )+              ( rayQueries :: [ Symbol :-> RayQueryState ]  )+           :: [ Symbol :-> RayQueryState ]+           where+  SetCommittedState rayQuery _ '[] =+    TypeError+      ( Text "'withCommittedIntersection': no ray query found with name " :<>: ShowType rayQuery :<>: Text "." )+  SetCommittedState rayQuery st ( ( rayQuery ':-> 'RayQueryState procState _ ) ': rayQueries ) =+    ( rayQuery ':-> 'RayQueryState procState ( 'Just st ) ) ': rayQueries+  SetCommittedState rayQuery st ( otherRayQuery ': rayQueries )+    = otherRayQuery ': SetCommittedState rayQuery st rayQueries++-- | Validation for ray query 'terminate' instruction.+--+--   - check that the ray query referred to has already been initialized,+--   - set it to completed state.+type family Terminate+              ( rayQuery :: Symbol       )+              ( i        :: ProgramState )+           :: ProgramState where+  Terminate rayQuery ( 'ProgramState bds ctx cfg fns eps iface rayQueries bk ) =+    'ProgramState bds ctx cfg fns eps iface ( TerminateRayQuery rayQuery rayQueries) bk++type family TerminateRayQuery+              ( rayQuery   :: Symbol                       )+              ( rayQueries :: [ Symbol :-> RayQueryState ] )+           :: [ Symbol :-> RayQueryState ]+           where+  TerminateRayQuery rayQuery '[] =+    TypeError+      ( Text "'terminate': no ray query found with name " :<>: ShowType rayQuery :<>: Text "." )+  TerminateRayQuery rayQuery ( ( rayQuery ':-> 'RayQueryState ( 'Just Complete ) _ ) ': _ ) =+    TypeError+      (    Text "'terminate': cannot terminate ray query named "  :<>: ShowType rayQuery :<>: Text ","+      :$$: Text "as it has already completed."+      )+  TerminateRayQuery rayQuery ( ( rayQuery ':-> 'RayQueryState _ comm ) ': rayQueries ) =+    ( rayQuery ':-> 'RayQueryState ( 'Just 'Complete ) comm ) ': rayQueries+  TerminateRayQuery rayQuery ( otherRayQuery ': rayQueries )+    = otherRayQuery ': TerminateRayQuery rayQuery rayQueries+++-- | Validation for ray query "generateIntersection":+--+--   - check that the ray query referred to has already been initialized,+--   - check that we have a candidate AABB intersection.+type family CanGenerateIntersection ( rayQuery :: Symbol ) ( lk :: Maybe RayQueryState ) :: Constraint where+  CanGenerateIntersection rayQuery 'Nothing = TypeError+    ( Text "'generateIntersection': no ray query found with name " :<>: ShowType rayQuery :<>: Text "." )+  CanGenerateIntersection _ ( Just ( 'RayQueryState ( 'Just ( 'Incomplete ( 'Just AABBCandidateIntersection ) ) ) _ ) ) = ( () :: Constraint )+  CanGenerateIntersection rayQuery _ = TypeError+    (    Text "'generateIntersection' cannot be called here on ray query named " :<>: ShowType rayQuery :<>: Text ","+    :$$: Text "as the candidate intersection type is not known to be an AABB."+    :$$: Text "Possible fix: use 'withCandidateIntersection' to determine candidate intersection type."+    )++-- | Validation for ray query "confirmIntersection":+--+--   - check that the ray query referred to has already been initialized,+--   - check that we have a candidate triangle intersection.+type family CanConfirmIntersection ( rayQuery :: Symbol ) ( lk :: Maybe RayQueryState ) :: Constraint where+  CanConfirmIntersection rayQuery 'Nothing = TypeError+    ( Text "'confirmIntersection': no ray query found with name " :<>: ShowType rayQuery :<>: Text "." )+  CanConfirmIntersection _ ( Just ( 'RayQueryState ( 'Just ( 'Incomplete ( 'Just TriangleCandidateIntersection ) ) ) _ ) ) = ( () :: Constraint )+  CanConfirmIntersection rayQuery _ = TypeError+    (    Text "'confirmIntersection' cannot be called here on ray query named " :<>: ShowType rayQuery :<>: Text ","+    :$$: Text "as the candidate intersection type is not known to be a triangle."+    :$$: Text "Possible fix: use 'withCandidateIntersection' to determine candidate intersection type."+    )++-- | Check that a given ray query name has been initialised.+type family HasRayQuery ( callerName :: Symbol ) ( rayQuery :: Symbol ) ( lk :: Maybe RayQueryState ) :: Constraint where+  HasRayQuery callerName rayQuery 'Nothing = TypeError+    ( ShowType callerName :<>: Text ": no ray query found with name " :<>: ShowType rayQuery :<>: Text "." )+  HasRayQuery _ _ _ = ( () :: Constraint )++-- | Validation for ray query 'getIntersectionT':+--+--   - check that the ray query referred to has already been initialized,+--   - for a candidate intersection, check that we have a candidate triangle intersection,+--   - for a committed intersection, check that we have some committed intersection.+type family CanGetIntersectionT ( rayQuery :: Symbol ) ( interTy :: IntersectionType ) ( lk :: Maybe RayQueryState ) :: Constraint where+  CanGetIntersectionT rayQuery _ Nothing = TypeError+    ( Text "'getIntersectionT': no ray query found with name " :<>: ShowType rayQuery :<>: Text "." )+  CanGetIntersectionT rayQuery Candidate ( Just ( 'RayQueryState ( 'Just ( 'Incomplete _ ) ) _ ) ) = ( () :: Constraint )+  CanGetIntersectionT rayQuery Candidate _ = TypeError+    (    Text "'getIntersectionT' cannot be called here with a 'Candidate' intersection type"+    :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text ","+    :$$: Text "as it has not been decided whether to proceed with this ray query."+    :$$: Text "Possible fix: use 'ifProceeding' to determine whether ray query proceeds."+    )+  CanGetIntersectionT rayQuery Committed ( Just ( 'RayQueryState _ Nothing ) ) = TypeError+    (    Text "'getIntersectionT' cannot be called here with a 'Committed' intersection type"+    :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text ","+    :$$: Text "as the committed intersection type has not been determined."+    :$$: Text "Possible fix: use 'withCommittedIntersection' to determine committed intersection type."+    )+  CanGetIntersectionT rayQuery Committed ( Just ( 'RayQueryState _ ( Just NoIntersection ) ) ) = TypeError+    (    Text "'getIntersectionT' cannot be called here with a 'Committed' intersection type"+    :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text ","+    :$$: Text "as there is no currently 'Committed' intersection type."+    )+  CanGetIntersectionT rayQuery Committed _ = ( () :: Constraint )++-- | Check that an intersection has occurred in the ray query state.+type family HasSomeIntersection+              ( callerName :: Symbol              )+              ( rayQuery   :: Symbol              )+              ( interTy    :: IntersectionType    )+              ( lk         :: Maybe RayQueryState )+           :: Constraint where+  HasSomeIntersection callerName rayQuery _  'Nothing = TypeError+    ( ShowType callerName :<>: Text ": no ray query found with name " :<>: ShowType rayQuery :<>: Text "." )+  HasSomeIntersection callerName rayQuery Candidate ( 'Just ( 'RayQueryState ( 'Just ( 'Incomplete _ ) ) _ ) ) = ( () :: Constraint )+  HasSomeIntersection callerName rayQuery Candidate _ = TypeError+    (    ShowType callerName :<>: Text " cannot be called here with a 'Candidate' intersection type"+    :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text ","+    :$$: Text "as it has not been decided whether to proceed with this ray query."+    :$$: Text "Possible fix: use 'ifProceeding' to determine whether ray query proceeds."+    )+  HasSomeIntersection callerName rayQuery Committed ( Just ( 'RayQueryState _ Nothing ) ) = TypeError+    (    ShowType callerName :<>: Text " cannot be called here with a 'Committed' intersection type"+    :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text ","+    :$$: Text "as the committed intersection type has not been determined."+    :$$: Text "Possible fix: use 'withCommittedIntersection' to determine committed intersection type."+    )+  HasSomeIntersection callerName rayQuery Committed ( Just ( 'RayQueryState _ ( Just NoIntersection ) ) ) = TypeError+    (    ShowType callerName :<>: Text " cannot be called here with a 'Committed' intersection type"+    :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text ","+    :$$: Text "as there is no currently 'Committed' intersection type."+    )+  HasSomeIntersection _ _ Committed _ = ( () :: Constraint )++-- | Check that a triangle intersection has occurred in the ray query state.+type family HasSomeTriangleIntersection+              ( callerName :: Symbol              )+              ( rayQuery   :: Symbol              )+              ( interTy    :: IntersectionType    )+              ( lk         :: Maybe RayQueryState )+           :: Constraint where+  HasSomeTriangleIntersection callerName rayQuery _  'Nothing = TypeError+    ( ShowType callerName :<>: Text ": no ray query found with name " :<>: ShowType rayQuery :<>: Text "." )+  HasSomeTriangleIntersection callerName rayQuery Candidate ( 'Just ( 'RayQueryState 'Nothing _ ) ) = TypeError+    (    ShowType callerName :<>: Text " cannot be called here with a 'Candidate' intersection type"+    :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text ","+    :$$: Text "as it has not been decided whether to proceed with this ray query."+    :$$: Text "Possible fix: use 'ifProceeding' to determine whether ray query proceeds."+    )+  HasSomeTriangleIntersection callerName rayQuery Candidate ( 'Just ( 'RayQueryState ( 'Just ( 'Incomplete 'Nothing ) ) _ ) ) = TypeError+    (    ShowType callerName :<>: Text " cannot be called here with a 'Candidate' intersection type"+    :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text ","+    :$$: Text "as the candidate intersection type has not been determined."+    :$$: Text "Possible fix: use 'withCandidateIntersection' to determine candidate intersection type."+    )+  HasSomeTriangleIntersection callerName rayQuery Candidate ( 'Just ( 'RayQueryState ( 'Just ( 'Incomplete ( 'Just TriangleCandidateIntersection ) ) ) _ ) ) =+    ( () :: Constraint )+  HasSomeTriangleIntersection callerName rayQuery Candidate _ = TypeError+    (    ShowType callerName :<>: Text " cannot be called here with a 'Candidate' intersection type"+    :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text ","+    :$$: Text "as the candidate intersection type is not 'Triangle'."+    )+  HasSomeTriangleIntersection callerName rayQuery Committed ( Just ( 'RayQueryState _ Nothing ) ) = TypeError+    (    ShowType callerName :<>: Text " cannot be called here with a 'Committed' intersection type"+    :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text ","+    :$$: Text "as the committed intersection type has not been determined."+    :$$: Text "Possible fix: use 'withCommittedIntersection' to determine committed intersection type."+    )+  HasSomeTriangleIntersection _ _ Committed ( Just ( 'RayQueryState _ ( Just TriangleIntersection ) ) ) = ( () :: Constraint )+  HasSomeTriangleIntersection callerName rayQuery Committed ( Just ( 'RayQueryState _ ( Just NoIntersection ) ) ) = TypeError+    (    ShowType callerName :<>: Text " cannot be called here with a 'Committed' intersection type"+    :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text ","+    :$$: Text "as the committed intersection type is not 'Triangle'."+    )
+ src/Instances/TH/Lift.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE CPP             #-} +{-# LANGUAGE TemplateHaskell #-} ++{-|+Module: Instances.TH.Lift++Some Template Haskell 'Lift' instances required by this library.+-}++module Instances.TH.Lift where++#if !MIN_VERSION_containers(0,6,6)++-- template-haskell+import Language.Haskell.TH.Syntax+  ( Lift(..) )++-- containers+import Data.Set+  ( Set )+import qualified Data.Set as Set+  ( fromList, toList )+++instance (Ord a, Lift a) => Lift (Set a) where+  lift      t = [|  Set.fromList  $(lift      $ Set.toList t)  |]+#if MIN_VERSION_template_haskell(2,16,0)+  liftTyped t = [|| Set.fromList $$(liftTyped $ Set.toList t) ||]+#endif++#endif
+ src/Math/Algebra/Class.hs view
@@ -0,0 +1,695 @@+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE DerivingVia            #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE StandaloneDeriving     #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: Math.Algebra.Class++Alternative numeric hierarchy, tailored for this library.++The main problem with the standard numeric hierarchy consists+of class methods with monomorphic return types.++For instance, the method++> toInteger :: Integral a => a -> Integer++is not amenable to overloading when working with ASTs, as+given e.g. @AST Int@ there is no way of recovering an @Integer@.++Contrast this with a method such as++> fromInteger :: Num a => Integer -> a++There is no problem instantiating this method at a type such as @AST Int@,+as it is indeed possible to turn a Haskell-level @Integer@ into an AST for an @Int@.++-}++module Math.Algebra.Class where++-- base+import Prelude+  ( Integer, Rational+  , Word, Int+  )+import qualified Prelude+import qualified Data.Fixed as Fixed+import Foreign.C.Types+import qualified GHC.Float as Float++-- half+import qualified Numeric.Half as Half++-- fir+import Deriving.Base+  ( Base(..) ) -- newtype for deriving via base instances+import Math.Logic.Class+  ( Eq(Logic,(==)), Ord+  , ifThenElse+  )+import FIR.Prelude++----------------------------------------------------------------------------++infixl 6 ++infixl 6 -+infixl 7 *+infixl 7 /+infixr 8 **++class AdditiveMonoid a where+  -- | Addition.+  (+)  :: a -> a -> a+  -- | Identity for addition.+  zero :: a+  fromInteger :: Integer -> a+  -- technically should be a method of "Ring"+  -- but there is no rebindable syntax for "fromNatural"++instance Prelude.Num a => AdditiveMonoid (Base a) where+  (+)  = coerce ( (Prelude.+) :: a -> a -> a )+  zero = coerce ( 0 :: a )+  fromInteger = (coerce :: a -> Base a) . Prelude.fromInteger++deriving via Base Word8  instance AdditiveMonoid Word8+deriving via Base Word16 instance AdditiveMonoid Word16+deriving via Base Word32 instance AdditiveMonoid Word32+deriving via Base Word64 instance AdditiveMonoid Word64+deriving via Base Word   instance AdditiveMonoid Word+deriving via Base Int8   instance AdditiveMonoid Int8+deriving via Base Int16  instance AdditiveMonoid Int16+deriving via Base Int32  instance AdditiveMonoid Int32+deriving via Base Int64  instance AdditiveMonoid Int64+deriving via Base Int    instance AdditiveMonoid Int+deriving via Base Half   instance AdditiveMonoid Half+deriving via Base Float  instance AdditiveMonoid Float+deriving via Base Double instance AdditiveMonoid Double++deriving via Base CChar   instance AdditiveMonoid CChar+deriving via Base CSChar  instance AdditiveMonoid CSChar+deriving via Base CUChar  instance AdditiveMonoid CUChar+deriving via Base CShort  instance AdditiveMonoid CShort+deriving via Base CUShort instance AdditiveMonoid CUShort+deriving via Base CInt    instance AdditiveMonoid CInt+deriving via Base CUInt   instance AdditiveMonoid CUInt+deriving via Base CLong   instance AdditiveMonoid CLong+deriving via Base CULong  instance AdditiveMonoid CULong+deriving via Base CLLong  instance AdditiveMonoid CLLong+deriving via Base CULLong instance AdditiveMonoid CULLong+deriving via Base CFloat  instance AdditiveMonoid CFloat+deriving via Base CDouble instance AdditiveMonoid CDouble++deriving via Base (Complex a) instance Prelude.RealFloat a => AdditiveMonoid (Complex a)++class AdditiveMonoid a => Semiring a where+  -- | Multiplication.+  (*) :: a -> a -> a++instance Prelude.Num a => Semiring (Base a) where+  (*) = coerce ( (Prelude.*) :: a -> a -> a )++deriving via Base Word8  instance Semiring Word8+deriving via Base Word16 instance Semiring Word16+deriving via Base Word32 instance Semiring Word32+deriving via Base Word64 instance Semiring Word64+deriving via Base Word   instance Semiring Word+deriving via Base Int8   instance Semiring Int8+deriving via Base Int16  instance Semiring Int16+deriving via Base Int32  instance Semiring Int32+deriving via Base Int64  instance Semiring Int64+deriving via Base Int    instance Semiring Int+deriving via Base Half   instance Semiring Half+deriving via Base Float  instance Semiring Float+deriving via Base Double instance Semiring Double++deriving via Base CChar   instance Semiring CChar+deriving via Base CSChar  instance Semiring CSChar+deriving via Base CUChar  instance Semiring CUChar+deriving via Base CShort  instance Semiring CShort+deriving via Base CUShort instance Semiring CUShort+deriving via Base CInt    instance Semiring CInt+deriving via Base CUInt   instance Semiring CUInt+deriving via Base CLong   instance Semiring CLong+deriving via Base CULong  instance Semiring CULong+deriving via Base CLLong  instance Semiring CLLong+deriving via Base CULLong instance Semiring CULLong+deriving via Base CFloat  instance Semiring CFloat+deriving via Base CDouble instance Semiring CDouble++deriving via Base (Complex a) instance Prelude.RealFloat a => Semiring (Complex a)++-- | Cancellative monoid under addition.+class AdditiveMonoid a => CancellativeAdditiveMonoid a where+  -- | Left-inverse to addition:+  --+  -- > ( \ x -> x - y ) . ( \ x -> x + y ) = id+  --+  -- Might be partially undefined or underflow,+  -- as ( \ x -> x + y ) need not be surjective for any fixed y.+  (-) :: a -> a -> a++instance Prelude.Num a => CancellativeAdditiveMonoid (Base a) where+  (-) = coerce ( (Prelude.-) :: a -> a -> a )++deriving via Base Word8  instance CancellativeAdditiveMonoid Word8+deriving via Base Word16 instance CancellativeAdditiveMonoid Word16+deriving via Base Word32 instance CancellativeAdditiveMonoid Word32+deriving via Base Word64 instance CancellativeAdditiveMonoid Word64+deriving via Base Word   instance CancellativeAdditiveMonoid Word+deriving via Base Int8   instance CancellativeAdditiveMonoid Int8+deriving via Base Int16  instance CancellativeAdditiveMonoid Int16+deriving via Base Int32  instance CancellativeAdditiveMonoid Int32+deriving via Base Int64  instance CancellativeAdditiveMonoid Int64+deriving via Base Int    instance CancellativeAdditiveMonoid Int+deriving via Base Half   instance CancellativeAdditiveMonoid Half+deriving via Base Float  instance CancellativeAdditiveMonoid Float+deriving via Base Double instance CancellativeAdditiveMonoid Double++deriving via Base CChar   instance CancellativeAdditiveMonoid CChar+deriving via Base CSChar  instance CancellativeAdditiveMonoid CSChar+deriving via Base CUChar  instance CancellativeAdditiveMonoid CUChar+deriving via Base CShort  instance CancellativeAdditiveMonoid CShort+deriving via Base CUShort instance CancellativeAdditiveMonoid CUShort+deriving via Base CInt    instance CancellativeAdditiveMonoid CInt+deriving via Base CUInt   instance CancellativeAdditiveMonoid CUInt+deriving via Base CLong   instance CancellativeAdditiveMonoid CLong+deriving via Base CULong  instance CancellativeAdditiveMonoid CULong+deriving via Base CLLong  instance CancellativeAdditiveMonoid CLLong+deriving via Base CULLong instance CancellativeAdditiveMonoid CULLong+deriving via Base CFloat  instance CancellativeAdditiveMonoid CFloat+deriving via Base CDouble instance CancellativeAdditiveMonoid CDouble++deriving via Base (Complex a) instance Prelude.RealFloat a => CancellativeAdditiveMonoid (Complex a)++-- | Additive group.+class CancellativeAdditiveMonoid a => AdditiveGroup a where+  -- | Negation.+  negate :: a -> a++instance Prelude.Num a => AdditiveGroup (Base a) where+  negate = coerce ( Prelude.negate :: a -> a )++deriving via Base Int8   instance AdditiveGroup Int8+deriving via Base Int16  instance AdditiveGroup Int16+deriving via Base Int32  instance AdditiveGroup Int32+deriving via Base Int64  instance AdditiveGroup Int64+deriving via Base Int    instance AdditiveGroup Int+deriving via Base Half   instance AdditiveGroup Half+deriving via Base Float  instance AdditiveGroup Float+deriving via Base Double instance AdditiveGroup Double++deriving via Base CChar   instance AdditiveGroup CChar+deriving via Base CSChar  instance AdditiveGroup CSChar+deriving via Base CShort  instance AdditiveGroup CShort+deriving via Base CInt    instance AdditiveGroup CInt+deriving via Base CLong   instance AdditiveGroup CLong+deriving via Base CLLong  instance AdditiveGroup CLLong+deriving via Base CFloat  instance AdditiveGroup CFloat+deriving via Base CDouble instance AdditiveGroup CDouble++deriving via Base (Complex a) instance Prelude.RealFloat a => AdditiveGroup (Complex a)++class AdditiveGroup a => Signed a where+  -- | Absolute value.+  abs    :: a -> a+  -- | Sign. +  --+  -- > signum  5 =  1+  -- > signum -7 = -1+  -- > signum  0 =  0+  signum :: a -> a++instance Prelude.Num a => Signed (Base a) where+  abs    = coerce ( Prelude.abs    :: a -> a )+  signum = coerce ( Prelude.signum :: a -> a )++deriving via Base Int8   instance Signed Int8+deriving via Base Int16  instance Signed Int16+deriving via Base Int32  instance Signed Int32+deriving via Base Int64  instance Signed Int64+deriving via Base Int    instance Signed Int+deriving via Base Half   instance Signed Half+deriving via Base Float  instance Signed Float+deriving via Base Double instance Signed Double++deriving via Base CChar   instance Signed CChar+deriving via Base CSChar  instance Signed CSChar+deriving via Base CShort  instance Signed CShort+deriving via Base CInt    instance Signed CInt+deriving via Base CLong   instance Signed CLong+deriving via Base CLLong  instance Signed CLLong+deriving via Base CFloat  instance Signed CFloat+deriving via Base CDouble instance Signed CDouble++class    (Semiring a, AdditiveGroup a) => Ring a where+instance (Semiring a, AdditiveGroup a) => Ring a where++class Ring a => DivisionRing a where+  {-# MINIMAL ( (/) | recip ), fromRational #-}+  -- | Division.+  (/)   :: a -> a -> a+  -- | Reciprocal.+  recip :: a -> a+  fromRational :: Rational -> a++  recip a = fromInteger 1 / a+  a / b = a * recip b++instance Prelude.Fractional a => DivisionRing (Base a) where+  (/)   = coerce ( (Prelude./) :: a -> a -> a )+  recip = coerce ( Prelude.recip :: a -> a ) +  fromRational = ( coerce :: a -> Base a ) . Prelude.fromRational++deriving via Base Half   instance DivisionRing Half+deriving via Base Float  instance DivisionRing Float+deriving via Base Double instance DivisionRing Double++deriving via Base CFloat  instance DivisionRing CFloat+deriving via Base CDouble instance DivisionRing CDouble++deriving via Base (Complex a) instance Prelude.RealFloat a => DivisionRing (Complex a)++-- totally ordered archimedean monoids+class (Ord a, AdditiveMonoid a) => Archimedean a where+  mod    :: a -> a -> a+  rem    :: a -> a -> a+  div    :: a -> a -> a+  divMod :: a -> a -> (a,a)+  divMod a b = ( div a b, mod a b )++instance ( Ord a, CancellativeAdditiveMonoid a, Prelude.Integral a ) => Archimedean (Base a) where+  mod    = coerce ( Prelude.mod    :: a -> a -> a     )+  rem    = coerce ( Prelude.rem    :: a -> a -> a     )+  div    = coerce ( Prelude.div    :: a -> a -> a     )+  divMod = coerce ( Prelude.divMod :: a -> a -> (a,a) )++deriving via Base Word8  instance Archimedean Word8+deriving via Base Word16 instance Archimedean Word16+deriving via Base Word32 instance Archimedean Word32+deriving via Base Word64 instance Archimedean Word64+deriving via Base Word   instance Archimedean Word+deriving via Base Int8   instance Archimedean Int8+deriving via Base Int16  instance Archimedean Int16+deriving via Base Int32  instance Archimedean Int32+deriving via Base Int64  instance Archimedean Int64+deriving via Base Int    instance Archimedean Int++deriving via Base CChar   instance Archimedean CChar+deriving via Base CSChar  instance Archimedean CSChar+deriving via Base CUChar  instance Archimedean CUChar+deriving via Base CShort  instance Archimedean CShort+deriving via Base CUShort instance Archimedean CUShort+deriving via Base CInt    instance Archimedean CInt+deriving via Base CUInt   instance Archimedean CUInt+deriving via Base CLong   instance Archimedean CLong+deriving via Base CULong  instance Archimedean CULong+deriving via Base CLLong  instance Archimedean CLLong+deriving via Base CULLong instance Archimedean CULLong++newtype Fixed a = Fixed { runFixed :: a }+deriving via a instance Eq                         a+                     => Eq                         (Fixed a)+deriving via a instance Ord                        a+                     => Ord                        (Fixed a)+deriving via a instance AdditiveMonoid             a+                     => AdditiveMonoid             (Fixed a)+deriving via a instance CancellativeAdditiveMonoid a+                     => CancellativeAdditiveMonoid (Fixed a)+deriving via a instance AdditiveGroup              a+                     => AdditiveGroup              (Fixed a)+deriving via a instance Semiring                   a+                     => Semiring                   (Fixed a)+deriving via a instance Signed                     a+                     => Signed                     (Fixed a)++instance ( Eq a, Logic a ~ Bool+         , Ord a+         , Ring a, Signed a+         , Prelude.Real a+         ) => Archimedean (Fixed a) where+  mod = coerce ( Fixed.mod' :: a -> a -> a )+  rem a m = ifThenElse (signum a == signum m)+              ( mod a m )+              ( negate ( mod a m ) )+  div (Fixed a) (Fixed b)+    = Fixed $ fromInteger ( Fixed.div' a b )+  divMod (Fixed a) (Fixed b)+    = case Fixed.divMod' a b of+        (q,r) -> ( Fixed (fromInteger q), Fixed r )++deriving via Fixed Half   instance Archimedean Half+deriving via Fixed Float  instance Archimedean Float+deriving via Fixed Double instance Archimedean Double++deriving via Fixed CFloat  instance Archimedean CFloat+deriving via Fixed CDouble instance Archimedean CDouble+++class DivisionRing a => Floating a where+  pi                  :: a+  exp, log            :: a -> a+  sqrt, invSqrt       :: a -> a+  sin, cos, tan       :: a -> a+  asin, acos, atan    :: a -> a+  sinh, cosh, tanh    :: a -> a+  asinh, acosh, atanh :: a -> a+  (**)                :: a -> a -> a+  -- no logBase++instance Prelude.Floating a => Floating (Base a) where+  pi      = coerce ( Prelude.pi :: a)+  exp     = coerce ( Prelude.exp   :: a -> a )+  log     = coerce ( Prelude.log   :: a -> a )+  sqrt    = coerce ( Prelude.sqrt  :: a -> a )+  sin     = coerce ( Prelude.sin   :: a -> a )+  cos     = coerce ( Prelude.cos   :: a -> a )+  tan     = coerce ( Prelude.tan   :: a -> a )+  asin    = coerce ( Prelude.asin  :: a -> a )+  acos    = coerce ( Prelude.acos  :: a -> a )+  atan    = coerce ( Prelude.atan  :: a -> a )+  sinh    = coerce ( Prelude.sinh  :: a -> a )+  cosh    = coerce ( Prelude.cosh  :: a -> a )+  tanh    = coerce ( Prelude.tanh  :: a -> a )+  asinh   = coerce ( Prelude.asinh :: a -> a )+  acosh   = coerce ( Prelude.acosh :: a -> a )+  atanh   = coerce ( Prelude.atanh :: a -> a )+  (**)    = coerce ( (Prelude.**) :: a -> a -> a )+  invSqrt = recip . sqrt++deriving via Base Half   instance Floating Half+deriving via Base Float  instance Floating Float+deriving via Base Double instance Floating Double++deriving via Base CFloat  instance Floating CFloat+deriving via Base CDouble instance Floating CDouble++deriving via Base (Complex a) instance Prelude.RealFloat a => Floating (Complex a)++class ( Floating a, Eq a ) => RealFloat a where+  atan2      :: a -> a -> a+  isNaN      :: a -> Logic a+  isInfinite :: a -> Logic a++instance ( Prelude.RealFloat a, Prelude.Eq a ) => RealFloat (Base a) where+  atan2      = coerce ( Prelude.atan2      :: a -> a -> a )+  isNaN      = coerce ( Prelude.isNaN      :: a -> Bool )+  isInfinite = coerce ( Prelude.isInfinite :: a -> Bool )++deriving via Base Half   instance RealFloat Half+deriving via Base Float  instance RealFloat Float+deriving via Base Double instance RealFloat Double++deriving via Base CFloat  instance RealFloat CFloat+deriving via Base CDouble instance RealFloat CDouble+++class ComplexFloat c a | c -> a where+  conjugate        :: c -> c+  magnitude        :: c -> a+  -- | Squared magnitude, without the square root.+  squaredMagnitude :: c -> a+  phase            :: c -> a+  mkCartesian      :: a -> a -> c+  mkPolar          :: a -> a -> c+  cis              :: a -> c+  scale            :: a -> c -> c+  realPart         :: c -> a+  imagPart         :: c -> a++instance (RealFloat a, b ~ a) => ComplexFloat (Complex a) b where+  conjugate ( a :+ b ) = a :+ negate b+  magnitude        ( a :+ b ) = sqrt ( a * a + b * b )+  squaredMagnitude ( a :+ b ) = a * a + b * b+  phase     ( a :+ b ) = atan2 b a+  mkCartesian          = (:+)+  mkPolar r theta      = scale r $ cis theta+  cis theta            = cos theta :+ sin theta+  scale r              = Prelude.fmap ( r * )+  realPart  ( a :+ _ ) = a+  imagPart  ( _ :+ b ) = b++-- constraint for integer types,+-- no methods+class Semiring a => Integral a where+instance Integral Word8   where+instance Integral Word16  where+instance Integral Word32  where+instance Integral Word64  where+instance Integral Word    where+instance Integral Int8    where+instance Integral Int16   where+instance Integral Int32   where+instance Integral Int64   where+instance Integral Int     where+instance Integral CChar   where+instance Integral CSChar  where+instance Integral CUChar  where+instance Integral CShort  where+instance Integral CUShort where+instance Integral CInt    where+instance Integral CUInt   where+instance Integral CLong   where+instance Integral CULong  where+instance Integral CLLong  where+instance Integral CULLong where++-- constraint for unsigned integer types,+-- no methods+class Integral a => Unsigned a where+instance Unsigned Word8   where+instance Unsigned Word16  where+instance Unsigned Word32  where+instance Unsigned Word64  where+instance Unsigned Word    where+instance Unsigned CUChar  where+instance Unsigned CUShort where+instance Unsigned CUInt   where+instance Unsigned CULong  where+instance Unsigned CULLong where+++type family Arr (domCod :: (Type,Type)) = (arr :: Type) | arr -> domCod where+  Arr '(dom, cod) = dom -> cod++class Convert (c :: (Type,Type)) where+  convert :: Arr c++instance Convert '(a,a) where+  convert = id++-- fromIntegral conversions+instance (Prelude.Integral a, Prelude.Num b) => Convert '(Base a, b) where+  convert (Base a) = Prelude.fromIntegral a++-- to unsigned integers+deriving via '(Base Word16, Word8 ) instance Convert '(Word16, Word8 )+deriving via '(Base Word32, Word8 ) instance Convert '(Word32, Word8 )+deriving via '(Base Word64, Word8 ) instance Convert '(Word64, Word8 )+deriving via '(Base Word  , Word8 ) instance Convert '(Word  , Word8 )+deriving via '(Base Int8  , Word8 ) instance Convert '(Int8  , Word8 )+deriving via '(Base Int16 , Word8 ) instance Convert '(Int16 , Word8 )+deriving via '(Base Int32 , Word8 ) instance Convert '(Int32 , Word8 )+deriving via '(Base Int64 , Word8 ) instance Convert '(Int64 , Word8 )+deriving via '(Base Int   , Word8 ) instance Convert '(Int   , Word8 )+deriving via '(Base Word8 , Word16) instance Convert '(Word8 , Word16)+deriving via '(Base Word32, Word16) instance Convert '(Word32, Word16)+deriving via '(Base Word64, Word16) instance Convert '(Word64, Word16)+deriving via '(Base Word  , Word16) instance Convert '(Word  , Word16)+deriving via '(Base Int8  , Word16) instance Convert '(Int8  , Word16)+deriving via '(Base Int16 , Word16) instance Convert '(Int16 , Word16)+deriving via '(Base Int32 , Word16) instance Convert '(Int32 , Word16)+deriving via '(Base Int64 , Word16) instance Convert '(Int64 , Word16)+deriving via '(Base Int   , Word16) instance Convert '(Int   , Word16)+deriving via '(Base Word8 , Word32) instance Convert '(Word8 , Word32)+deriving via '(Base Word16, Word32) instance Convert '(Word16, Word32)+deriving via '(Base Word64, Word32) instance Convert '(Word64, Word32)+deriving via '(Base Word  , Word32) instance Convert '(Word  , Word32)+deriving via '(Base Int8  , Word32) instance Convert '(Int8  , Word32)+deriving via '(Base Int16 , Word32) instance Convert '(Int16 , Word32)+deriving via '(Base Int32 , Word32) instance Convert '(Int32 , Word32)+deriving via '(Base Int64 , Word32) instance Convert '(Int64 , Word32)+deriving via '(Base Int   , Word32) instance Convert '(Int   , Word32)+deriving via '(Base Word8 , Word64) instance Convert '(Word8 , Word64)+deriving via '(Base Word16, Word64) instance Convert '(Word16, Word64)+deriving via '(Base Word32, Word64) instance Convert '(Word32, Word64)+deriving via '(Base Word  , Word64) instance Convert '(Word  , Word64)+deriving via '(Base Int8  , Word64) instance Convert '(Int8  , Word64)+deriving via '(Base Int16 , Word64) instance Convert '(Int16 , Word64)+deriving via '(Base Int32 , Word64) instance Convert '(Int32 , Word64)+deriving via '(Base Int64 , Word64) instance Convert '(Int64 , Word64)+deriving via '(Base Int   , Word64) instance Convert '(Int   , Word64)+deriving via '(Base Word8 , Word  ) instance Convert '(Word8 , Word  )+deriving via '(Base Word16, Word  ) instance Convert '(Word16, Word  )+deriving via '(Base Word32, Word  ) instance Convert '(Word32, Word  )+deriving via '(Base Word64, Word  ) instance Convert '(Word64, Word  )+deriving via '(Base Int8  , Word  ) instance Convert '(Int8  , Word  )+deriving via '(Base Int16 , Word  ) instance Convert '(Int16 , Word  )+deriving via '(Base Int32 , Word  ) instance Convert '(Int32 , Word  )+deriving via '(Base Int64 , Word  ) instance Convert '(Int64 , Word  )+deriving via '(Base Int   , Word  ) instance Convert '(Int   , Word  )+-- to signed integers+deriving via '(Base Word8 , Int8  ) instance Convert '(Word8 , Int8  )+deriving via '(Base Word16, Int8  ) instance Convert '(Word16, Int8  )+deriving via '(Base Word32, Int8  ) instance Convert '(Word32, Int8  )+deriving via '(Base Word64, Int8  ) instance Convert '(Word64, Int8  )+deriving via '(Base Word  , Int8  ) instance Convert '(Word  , Int8  )+deriving via '(Base Int16 , Int8  ) instance Convert '(Int16 , Int8  )+deriving via '(Base Int32 , Int8  ) instance Convert '(Int32 , Int8  )+deriving via '(Base Int64 , Int8  ) instance Convert '(Int64 , Int8  )+deriving via '(Base Int   , Int8  ) instance Convert '(Int   , Int8  )+deriving via '(Base Word8 , Int16 ) instance Convert '(Word8 , Int16 )+deriving via '(Base Word16, Int16 ) instance Convert '(Word16, Int16 )+deriving via '(Base Word32, Int16 ) instance Convert '(Word32, Int16 )+deriving via '(Base Word64, Int16 ) instance Convert '(Word64, Int16 )+deriving via '(Base Word  , Int16 ) instance Convert '(Word  , Int16 )+deriving via '(Base Int8  , Int16 ) instance Convert '(Int8  , Int16 )+deriving via '(Base Int32 , Int16 ) instance Convert '(Int32 , Int16 )+deriving via '(Base Int64 , Int16 ) instance Convert '(Int64 , Int16 )+deriving via '(Base Int   , Int16 ) instance Convert '(Int   , Int16 )+deriving via '(Base Word8 , Int32 ) instance Convert '(Word8 , Int32 )+deriving via '(Base Word16, Int32 ) instance Convert '(Word16, Int32 )+deriving via '(Base Word32, Int32 ) instance Convert '(Word32, Int32 )+deriving via '(Base Word64, Int32 ) instance Convert '(Word64, Int32 )+deriving via '(Base Word  , Int32 ) instance Convert '(Word  , Int32 )+deriving via '(Base Int8  , Int32 ) instance Convert '(Int8  , Int32 )+deriving via '(Base Int16 , Int32 ) instance Convert '(Int16 , Int32 )+deriving via '(Base Int64 , Int32 ) instance Convert '(Int64 , Int32 )+deriving via '(Base Int   , Int32 ) instance Convert '(Int   , Int32 )+deriving via '(Base Word8 , Int64 ) instance Convert '(Word8 , Int64 )+deriving via '(Base Word16, Int64 ) instance Convert '(Word16, Int64 )+deriving via '(Base Word32, Int64 ) instance Convert '(Word32, Int64 )+deriving via '(Base Word64, Int64 ) instance Convert '(Word64, Int64 )+deriving via '(Base Word  , Int64 ) instance Convert '(Word  , Int64 )+deriving via '(Base Int8  , Int64 ) instance Convert '(Int8  , Int64 )+deriving via '(Base Int16 , Int64 ) instance Convert '(Int16 , Int64 )+deriving via '(Base Int32 , Int64 ) instance Convert '(Int32 , Int64 )+deriving via '(Base Int   , Int64 ) instance Convert '(Int   , Int64 )+deriving via '(Base Word8 , Int   ) instance Convert '(Word8 , Int   )+deriving via '(Base Word16, Int   ) instance Convert '(Word16, Int   )+deriving via '(Base Word32, Int   ) instance Convert '(Word32, Int   )+deriving via '(Base Word64, Int   ) instance Convert '(Word64, Int   )+deriving via '(Base Word  , Int   ) instance Convert '(Word  , Int   )+deriving via '(Base Int8  , Int   ) instance Convert '(Int8  , Int   )+deriving via '(Base Int16 , Int   ) instance Convert '(Int16 , Int   )+deriving via '(Base Int32 , Int   ) instance Convert '(Int32 , Int   )+deriving via '(Base Int64 , Int   ) instance Convert '(Int64 , Int   )+-- to floating point+deriving via '(Base Word8 , Half  ) instance Convert '(Word8 , Half  )+deriving via '(Base Word16, Half  ) instance Convert '(Word16, Half  )+deriving via '(Base Word32, Half  ) instance Convert '(Word32, Half  )+deriving via '(Base Word64, Half  ) instance Convert '(Word64, Half  )+deriving via '(Base Word  , Half  ) instance Convert '(Word  , Half  )+deriving via '(Base Int8  , Half  ) instance Convert '(Int8  , Half  )+deriving via '(Base Int16 , Half  ) instance Convert '(Int16 , Half  )+deriving via '(Base Int32 , Half  ) instance Convert '(Int32 , Half  )+deriving via '(Base Int64 , Half  ) instance Convert '(Int64 , Half  )+deriving via '(Base Word8 , Float ) instance Convert '(Word8 , Float )+deriving via '(Base Word16, Float ) instance Convert '(Word16, Float )+deriving via '(Base Word32, Float ) instance Convert '(Word32, Float )+deriving via '(Base Word64, Float ) instance Convert '(Word64, Float )+deriving via '(Base Word  , Float ) instance Convert '(Word  , Float )+deriving via '(Base Int8  , Float ) instance Convert '(Int8  , Float )+deriving via '(Base Int16 , Float ) instance Convert '(Int16 , Float )+deriving via '(Base Int32 , Float ) instance Convert '(Int32 , Float )+deriving via '(Base Int64 , Float ) instance Convert '(Int64 , Float )+deriving via '(Base Word8 , Double) instance Convert '(Word8 , Double)+deriving via '(Base Word16, Double) instance Convert '(Word16, Double)+deriving via '(Base Word32, Double) instance Convert '(Word32, Double)+deriving via '(Base Word64, Double) instance Convert '(Word64, Double)+deriving via '(Base Word  , Double) instance Convert '(Word  , Double)+deriving via '(Base Int8  , Double) instance Convert '(Int8  , Double)+deriving via '(Base Int16 , Double) instance Convert '(Int16 , Double)+deriving via '(Base Int32 , Double) instance Convert '(Int32 , Double)+deriving via '(Base Int64 , Double) instance Convert '(Int64 , Double)++-- floating conversions+instance Convert '(Half  , Float ) where+  convert = Half.fromHalf+instance Convert '(Half  , Double) where+  convert = Float.float2Double . Half.fromHalf+instance Convert '(Float , Double) where+  convert = Float.float2Double+instance Convert '(Float , Half  ) where+  convert = Half.toHalf+instance Convert '(Double, Half  ) where+  convert = Half.toHalf . Float.double2Float+instance Convert '(Double, Float ) where+  convert = Float.double2Float++fromIntegral :: (Convert '(a,b), Integral a) => a -> b+fromIntegral = convert++realToFrac :: (Convert '(a,b), Floating a, DivisionRing b) => a -> b+realToFrac = convert++-- truncation/rounding/etc+class Rounding (c :: (Type,Type)) where+  -- | Truncate (towards 0).+  truncate :: Arr c+  round    :: Arr c+  floor    :: Arr c+  ceiling  :: Arr c++instance (Prelude.RealFrac a, Prelude.Integral b) => Rounding '(a, Base b) where+  truncate = Base . Prelude.truncate+  round    = Base . Prelude.round+  floor    = Base . Prelude.floor+  ceiling  = Base . Prelude.ceiling++instance (Prelude.RealFrac a, Prelude.Num b) => Rounding '(Base a, b) where+  truncate = Prelude.fromIntegral . Prelude.truncate @_ @Int64 . runBase+  round    = Prelude.fromIntegral . Prelude.round    @_ @Int64 . runBase+  floor    = Prelude.fromIntegral . Prelude.floor    @_ @Int64 . runBase+  ceiling  = Prelude.fromIntegral . Prelude.ceiling  @_ @Int64 . runBase++-- to unsigned integers+deriving via '(Half  , Base Word8 ) instance Rounding '(Half  , Word8 )+deriving via '(Half  , Base Word16) instance Rounding '(Half  , Word16)+deriving via '(Half  , Base Word32) instance Rounding '(Half  , Word32)+deriving via '(Half  , Base Word64) instance Rounding '(Half  , Word64)+deriving via '(Half  , Base Word  ) instance Rounding '(Half  , Word  )+deriving via '(Float , Base Word8 ) instance Rounding '(Float , Word8 )+deriving via '(Float , Base Word16) instance Rounding '(Float , Word16)+deriving via '(Float , Base Word32) instance Rounding '(Float , Word32)+deriving via '(Float , Base Word64) instance Rounding '(Float , Word64)+deriving via '(Float , Base Word  ) instance Rounding '(Float , Word  )+deriving via '(Double, Base Word8 ) instance Rounding '(Double, Word8 )+deriving via '(Double, Base Word16) instance Rounding '(Double, Word16)+deriving via '(Double, Base Word32) instance Rounding '(Double, Word32)+deriving via '(Double, Base Word64) instance Rounding '(Double, Word64)+deriving via '(Double, Base Word  ) instance Rounding '(Double, Word  )+-- to signed integers+deriving via '(Half  , Base Int8  ) instance Rounding '(Half  , Int8  )+deriving via '(Half  , Base Int16 ) instance Rounding '(Half  , Int16 )+deriving via '(Half  , Base Int32 ) instance Rounding '(Half  , Int32 )+deriving via '(Half  , Base Int64 ) instance Rounding '(Half  , Int64 )+deriving via '(Half  , Base Int   ) instance Rounding '(Half  , Int   )+deriving via '(Float , Base Int8  ) instance Rounding '(Float , Int8  )+deriving via '(Float , Base Int16 ) instance Rounding '(Float , Int16 )+deriving via '(Float , Base Int32 ) instance Rounding '(Float , Int32 )+deriving via '(Float , Base Int64 ) instance Rounding '(Float , Int64 )+deriving via '(Float , Base Int   ) instance Rounding '(Float , Int   )+deriving via '(Double, Base Int8  ) instance Rounding '(Double, Int8  )+deriving via '(Double, Base Int16 ) instance Rounding '(Double, Int16 )+deriving via '(Double, Base Int32 ) instance Rounding '(Double, Int32 )+deriving via '(Double, Base Int64 ) instance Rounding '(Double, Int64 )+deriving via '(Double, Base Int   ) instance Rounding '(Double, Int   )+-- to floating point+deriving via '(Base Half  , Half  ) instance Rounding '(Half  , Half  )+deriving via '(Base Half  , Float ) instance Rounding '(Half  , Float )+deriving via '(Base Half  , Double) instance Rounding '(Half  , Double)+deriving via '(Base Float , Half  ) instance Rounding '(Float , Half  )+deriving via '(Base Float , Float ) instance Rounding '(Float , Float )+deriving via '(Base Float , Double) instance Rounding '(Float , Double)+deriving via '(Base Double, Half  ) instance Rounding '(Double, Half  )+deriving via '(Base Double, Float ) instance Rounding '(Double, Float )+deriving via '(Base Double, Double) instance Rounding '(Double, Double)
+ src/Math/Algebra/GradedSemigroup.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}++{-|+Module: Math.Algebra.GradedSemigroup++A /graded/ object is one which splits up into parts of different indices.++For instance, the ring of polynomials \( R[x_1, \ldots, x_n] \) is graded+by degree, in that \( R \) can be decomposed:++\[ R = \bigoplus_{d \in \mathbb{N}} R_d, \]++where \( R_d \) consists of homogeneous polynomials of degree \( d \).++What's important is how the ring structure of \( R[x_1, \ldots, x_n] \) interacts with the grading.+We have:++\[ (+) \ \colon R_{d\phantom{_1}} \times R_{d\phantom{_2}} \to R_{d\phantom{_1+d_2}} \]++\[ (\times) \ \colon R_{d_1} \times R_{d_2} \to R_{d_1 + d_2}. \]++In this module, we are interested in the /second/ of these two behaviours.+Note then that two operations are in play:++  * the monoid \( \mathbb{N} \) of degrees under addition,+  * the graded multiplication \[ (\times) \ \colon R_{d_1} \times R_{d_2} \to R_{d_1 + d_2}. \]++One can alternatively think of a graded semigroup as a semigroup in a (monoidal) category of graded objects.++A motivating example is that of length-indexed vectors. In that case, we have:++  * type-level addition of natural numbers \( (+) \ \colon \mathbb{N} \times \mathbb{N} \to \mathbb{N}, \)+  * value-level concatenation of vectors \( \textrm{V}\ n\ a \times \textrm{V}\ m\ a \to \textrm{V}\ (n+m)\ a. \)++Another important example is that of structs (i.e. ordered records). In this case we have:++  * a type-level monoid operation on lists of fields,+      @(:++:) :: [ Symbol :-> Type ] -> [ Symbol :-> Type ] -> [ Symbol :-> Type ]@,+  * a value-level concatenation of structs, of type @Struct as -> Struct bs -> Struct (as :++: bs)@.++In this module, we follow the above two examples and insist that the operation on indices is at the type-level,+whereas the graded multiplication sits at the value-level.+-}++module Math.Algebra.GradedSemigroup where++-- base+import Data.Kind+  ( Type )+++infixl 6 <!>+infixl 6 :<!>:++-- * Graded semigroups++-- $graded+-- A __graded semigroup__ consists of:+--+--   * Types \( G_i \) for \( i : I \), where \( I \) is the index type (also called the degree type),+--   * a semigroup structure \( (+) \ \colon I \times I \to I \) on the index type \( I \),+--   * an associative operation \( (\cdot) \ \colon G_i \times G_j \to G_{i + j} \).++-- | Semigroup with graded structure.+class GradedSemigroup g k | g -> k where+  -- | For extra flexibility, instead of specifying a type-level function \( G \colon I \to \textrm{Type} \)+  -- to define the grading (which is often too restrictive), we use an associated /injective/ type family.+  type Grade k g (i :: k) = (r :: Type) | r -> k g i+  -- | Type-level semigroup operation on indices.+  type (i :: k) :<!>: (j :: k) :: k+  -- | Value-level graded semigroup operation.+  (<!>) :: Grade k g i -> Grade k g j -> Grade k g (i :<!>: j)
+ src/Math/Linear.hs view
@@ -0,0 +1,835 @@+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}++{-# LANGUAGE AllowAmbiguousTypes        #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE DerivingVia                #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE RebindableSyntax           #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE StandaloneKindSignatures   #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE TypeFamilyDependencies     #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE UndecidableInstances       #-}++{-|+Module: Math.Linear+Description: @---@ Vectors & matrices, as used by this library. __Import required to use vectors & matrices.__++Vectors and matrices, indexed by dimension.++Vectors are represented as linked lists, whereas matrices are represented as a vector of their columns,+following the conventions from Vulkan/OpenGL.+-}++module Math.Linear+  (+  -- * Vector and matrix types+  V(..), M(..)++  -- * Typeclasses+  -- ** Vectors+  , Semimodule(..), LinearModule(..), Inner(..), Cross(..)+  -- ** Matrices+  , VectorOf, Matrix(..)++  -- * General vector operations+  , angle, norm, squaredNorm+  , quadrance, distance+  , along+  , reflect, reflect'+  , proj, projC+  , isOrthogonal, gramSchmidt+  , rotateAroundAxis++  -- * Operations involving the vector data type+  , headV, tailV, headTailV+  , (^!), at, replaceV+  , sum+  , buildV+  , dfoldrV+  , unfold+  , pattern V0, pattern V1, pattern V2, pattern V3, pattern V4++  -- * Operations involving vectors of vectors+  , blockSum++  -- * Operations involving the matrix newtype+  , perspective, lookAt+  )+where++-- base+import Prelude hiding+  ( Eq(..), (&&), (||)+  , Ord(..)+  , Num(..), sum+  , Fractional(..), Floating(..)+  , Ordering(..)+  )+import qualified Prelude+import Control.Arrow+  ( second )+import Data.Foldable+  ( traverse_ )+import Data.Functor.Compose+  ( Compose(..) )+import Data.Kind+  ( Type, Constraint )+import Data.Type.Equality+  ( (:~:)(Refl) )+import Data.Proxy+  ( Proxy(Proxy) )+import Foreign.Ptr+  ( Ptr, castPtr )+import Foreign.Storable+  ( Storable(alignment, sizeOf, peek, poke, peekElemOff, pokeElemOff) )+import GHC.Base+  ( Int#, Int(I#), (+#) )+import GHC.TypeNats+  ( Nat, KnownNat, natVal+  , type (+), type (-), type (*)+  , CmpNat, type (<=), type (<=?)+  , sameNat+  )+import Numeric.Natural+  ( Natural )+import Unsafe.Coerce+  ( unsafeCoerce )++-- binary+import Data.Binary+  ( Binary(put,get) )++-- distributive+import Data.Distributive+  ( Distributive(..) )++-- typelits-witnesses+import GHC.TypeLits.Compare+  ( (:<=?)(LE,NLE), (%<=?) )++-- fir+import Control.Arrow.Strength+  ( strong )+import {-# SOURCE #-} Data.Product+  ( IsProduct(..)+  , HList(HNil, (:>))+  )+import Data.Type.List+  ( Replicate+  , Length, KnownLength+  )+import Math.Algebra.Class+  ( AdditiveMonoid(..), CancellativeAdditiveMonoid(..), AdditiveGroup(..)+  , Semiring(..), Ring+  , DivisionRing(..), Floating(..)+  )+import Math.Algebra.GradedSemigroup+  ( GradedSemigroup(..) )+import Math.Logic.Class+  ( Boolean(..), Eq(Logic,(==))+  , (#.)+  , Ord(..)+  )++-------------------------------------------------------------------------------++infixr 3 :.++-- | Vector data type.+--+-- @V m a@ denotes a vector of @m@ inhabitants of @a@.+-- Represented as a linked list.+data V :: Nat -> Type -> Type where+  VNil :: V 0 a+  (:.) :: (1 <= m, m ~ (1+n), n ~ (m-1))+       => a -> V n a -> V m a++deriving stock instance Functor     (V n)+deriving stock instance Foldable    (V n)+deriving stock instance Traversable (V n)++instance (KnownNat n, Show a) => Show (V n a) where+  show :: V n a -> String+  show v = "V" ++ n ++ foldMap ( \a -> " " ++ show a ) v+    where n :: String+          n = show (natVal (Proxy @n))++deriving stock instance Prelude.Eq  a => Prelude.Eq  (V n a)+deriving stock instance Prelude.Ord a => Prelude.Ord (V n a)++instance (KnownNat n, Binary a) => Binary (V n a) where+  put = traverse_ put+  get = case Proxy @1 %<=? Proxy @n of+            LE Refl   -> liftA2 (:.)+                           get+                           $ get @(V (n-1) a)+            NLE nle _ ->+              case lt1_is_Zero @n nle of+                   Refl -> pure VNil++instance KnownNat n => Distributive (V n) where+  distribute :: Functor f => f (V n a) -> V n (f a)+  distribute+    = case Proxy @1 %<=? Proxy @n of+        LE Refl   -> uncurry (:.) +                   . second distribute+                   . strong+                   . fmap headTailV+        NLE nle _ ->+          case lt1_is_Zero @n nle of+               Refl -> const VNil++instance KnownNat n => Applicative (V n) where+  pure                    = unfold id+  _         <*>  VNil     = VNil+  (f :. fs) <*> (a :. as) = f a :. fs <*> as+#if !MIN_VERSION_base(4,16,0)+  _         <*> _         = error "unreachable"+#endif++instance (KnownNat n, Eq a) => Eq (V n a) where+  type Logic (V n a) = Logic a+  (==) = (foldr (&&) true .) . liftA2 (==)++instance (KnownNat n, Ord a) => Ord (V n a) where+  VNil <= VNil = true+  (a :. as) <= (b :. bs) = a < b || (a <= b && as <= bs)+#if !MIN_VERSION_base(4,16,0)+  _ <= _ = error "unreachable"+#endif++  VNil < VNil = false+  (a :. as) <  (b :. bs) = a < b || (a <= b && as <  bs)+#if !MIN_VERSION_base(4,16,0)+  _ < _ = error "unreachable"+#endif++  min = liftA2 min+  max = liftA2 max++instance (KnownNat n, Semigroup a) => Semigroup (V n a) where+  (<>) = liftA2 (<>)++instance (KnownNat n, Monoid a) => Monoid (V n a) where+  mempty = pure mempty++headV :: (KnownNat n, 1 <= n) => V n a -> a+headV (a :. _) = a++tailV :: (KnownNat n, 1 <= n) => V n a -> V (n-1) a+tailV (_ :. as) = as++headTailV :: (KnownNat n, 1 <= n) => V n a -> (a, V (n-1) a)+headTailV (a :. as) = ( a, as )++splitAtV+  :: forall (s :: Nat) (n :: Nat) (a :: Type)+  .  ( KnownNat s, KnownNat n, s <= n )+  => V n a+  -> ( V s a, V (n-s) a )+splitAtV v = case Proxy @1 %<=? Proxy @s of+  LE Refl -> case lte_transitive @1 @s @n of+    Refl -> case headTailV v of+      ( h, t ) -> case splitAtV @(s-1) t of+        ( hs, d ) -> ( h :. hs, d )+  NLE nle _ -> case lt1_is_Zero @s nle of+    Refl -> ( VNil, v )++instance (KnownNat n, Storable a) => Storable (V n a) where+  sizeOf :: V n a -> Int+  sizeOf _ = n * sizeOf (undefined :: a)+    where n = fromIntegral $ natVal (Proxy @n)++  alignment _ = alignment (undefined :: a)++  poke ptr u = go u 0#+    where go :: KnownNat m => V m a -> Int# -> IO()+          go VNil     _  = pure ()+          go (a :. v) n# = do+              pokeElemOff (castPtr ptr) (I# n#) a+              go v (n# +# 1#)++  peek :: Ptr (V n a) -> IO (V n a)+  peek ptr = traverse (peekElemOff (castPtr ptr)) ixVec+      where ixVec :: V n Int+            ixVec = unfold pred (fromIntegral $ natVal (Proxy @n))++infixl 9 ^!++-- | Unsafe indexing.+(^!) :: V n a -> Int -> a+(^!) (a :. _)  0 = a+(^!) VNil      _ = error "empty vector"+(^!) (_ :. as) n = as ^! (n-1)++-- | Safe indexing.+--+-- Use with /TypeApplications/,+-- e.g. to access index @3@ of vector @v@: @at \@3 v@.+at :: forall i n a. (KnownNat i, KnownNat n, CmpNat i n ~ Prelude.LT)+   => V n a -> a+at v = v ^! fromIntegral (dim @i)++replaceV :: Int -> a -> V n a -> V n a+replaceV _ _ VNil      = VNil+replaceV 0 b (_ :. as) = (b :. as)+replaceV i b (a :. as) = a :. replaceV (i-1) b as++-----------------------------------------------------------+-- todo: temporary workaround++newtype Sum a = Sum { getSum :: a }+instance AdditiveMonoid a => Semigroup (Sum a) where+  (Sum a) <> (Sum b) = Sum (a + b)+instance AdditiveMonoid a => Monoid (Sum a) where+  mempty = Sum zero++sum :: (AdditiveMonoid a, Foldable t) => t a -> a+sum = getSum #. foldMap Sum++-----------------------------------------------------------+-- some basic facts about inequalities, bypassing the type-checker+-- a proper solution would be to use a type-checking plugin for this++lt1_is_Zero :: KnownNat n => (1 <=? n) :~: 'False -> (n :~: 0)+lt1_is_Zero _ = unsafeCoerce Refl++lemma1 :: forall j n. ( KnownNat j, KnownNat n, j <= n, 1 <= (n-j) )+       => ( CmpNat j n :~: Prelude.LT )+lemma1 = unsafeCoerce Refl++lemma2 :: forall j n. ( KnownNat j, KnownNat n, j <= n, 1 <= (n-j) )+       => ( (j+1) <=? n ) :~: 'True+lemma2 = unsafeCoerce Refl++lte_transitive+  :: forall i j k+  .  ( KnownNat i, KnownNat j, KnownNat k, i <= j, j <= k )+  => ( i <=? k ) :~: 'True+lte_transitive = unsafeCoerce Refl++-----------------------------------------------------------++-- | Build a vector using a generating function.+buildV :: forall n a. KnownNat n+      => ( forall i. (KnownNat i, CmpNat i n ~ Prelude.LT) => Proxy i -> a)+      -> V n a+buildV f = go @0+  where+    go :: forall j. (KnownNat j, j <= n) => V (n-j) a+    go = case Proxy @1 %<=? Proxy @(n-j) of+      NLE nle _ ->+        case lt1_is_Zero @(n-j) nle of+          Refl -> VNil+      LE Refl -> case ( lemma1 @j @n, lemma2 @j @n ) of+        (Refl, Refl) -> f ( Proxy @j ) :. go @(j+1)++-- | Dependent fold of a vector.+-- Folds a vector with a function whose type depends on the index.+dfoldrV :: forall n a b. KnownNat n+        => (forall k. (KnownNat k, k+1 <= n) => a -> b k -> b (k+1)) -- ^ Function used to fold.+        -> b 0   -- ^ Starting value.+        -> V n a -- ^ Vector to fold.+        -> b n+dfoldrV f d = go+  where go :: (KnownNat m, m <= n) => V m a -> b m+        go VNil    = d+        go (a:.as) = f a (go as)++-- | Unfold: create a vector of specified length,+-- by repeatedly applying a function to a starting value.+unfold :: forall n a. KnownNat n+       => (a -> a) -- ^ Function to iterate.+       -> a        -- ^ Starting value.+       -> V n a+unfold f a+  = case Proxy @1 %<=? Proxy @n of+      LE Refl   -> let b = f a in b :. (unfold f b :: V (n-1) a)+      NLE nle _ ->+       case lt1_is_Zero @n nle of+            Refl -> VNil+++{-# COMPLETE V0 #-}+pattern V0 :: V 0 a+pattern V0 = VNil++{-# COMPLETE V1 #-}+pattern V1 :: a -> V 1 a+pattern V1 x = x :. VNil++{-# COMPLETE V2 #-}+pattern V2 :: a -> a -> V 2 a+pattern V2 x y = x :. y :. VNil++{-# COMPLETE V3 #-}+pattern V3 :: a -> a -> a -> V 3 a+pattern V3 x y z = x :. y :. z :. VNil++{-# COMPLETE V4 #-}+pattern V4 :: a -> a -> a -> a -> V 4 a+pattern V4 x y z w = x :. y :. z :. w :. VNil++------------------------------------------------------------------+-- products for vectors++instance (KnownLength rs, Replicated n a rs)+      => IsProduct (V n a) rs where+  fromHList = fromHListVec replication+  toHList   = toHListVec   replication++data Replication n a rs where+  NilReplication  :: Replication 0 a '[]+  ConsReplication :: Replication n a rs -> Replication (1+n) a (a ': rs)++class ( rs ~ Replicate n a, KnownLength rs, n ~ Length rs )+    => Replicated n a rs | rs -> n where+  replication :: Replication n a rs+instance Replicated 0 a '[] where+  replication = NilReplication+instance (m ~ (1+n), rs ~ Replicate (m-1) a, (a ': rs) ~ Replicate m a, n ~ Length rs, Replicated n a rs)+       => Replicated m a (a ': rs) where+  replication = ConsReplication ( replication @n @a @rs )++fromHListVec :: Replication n a rs -> HList rs -> V n a+fromHListVec NilReplication          _        = VNil+fromHListVec (ConsReplication repl) (x :> xs) = x :. fromHListVec repl xs++toHListVec :: Replication n a rs -> V n a -> HList rs+toHListVec NilReplication         _         = HNil+toHListVec (ConsReplication repl) (x :. xs) = x :> toHListVec repl xs+toHListVec (ConsReplication {}) _ = error "impossible" -- why??++instance GradedSemigroup (V 0 a) Nat where+  type Grade Nat (V 0 a) i = V i a+  type i :<!>: j = i + j+  (<!>) :: V i a -> V j a -> V (i+j) a+  (<!>) VNil     v = v+  (<!>) (a:.as)  v = a :. (as <!> v)++------------------------------------------------------------------++dim :: forall n. KnownNat n => Natural+dim = natVal ( Proxy @n )++------------------------------------------------------------------+-- type classes for vector operations++infixl 6 ^+^, ^-^+infixl 7 ^.^, `dot`, ^×^, `cross`+infix 8 ^/, /^+infix  8 ^*, *^+++-- | A semimodule is to a semiring as a module is to a ring.+--+-- That is, a semimodule M over a semiring R consists of+--+--    * a commutative monoid M,+--    * an action of R on M.+--+-- The associated type family 'OfDim' is used to allow class methods+-- which involve elements in different dimensions.+-- This is crucial for the class methods for matrices (see the 'Matrix' type class)+class Semiring (Scalar v) => Semimodule d v | v -> d where+  type Scalar v :: Type+  type OfDim v d (n :: d) = (r :: Type) | r -> v d n+  type ValidDim v d (n :: d) :: Constraint+  {-# MINIMAL (^+^), ( (*^) | (^*) ) #-}+  (^+^) :: ValidDim v d n => OfDim v d n -> OfDim v d n -> OfDim v d n+  (*^)  :: ValidDim v d n => Scalar v    -> OfDim v d n -> OfDim v d n+  (^*)  :: ValidDim v d n => OfDim v d n -> Scalar v    -> OfDim v d n+  (*^) = flip (^*)+  (^*) = flip (*^)+  (^/) :: ( ValidDim v d n, DivisionRing (Scalar v) )+       => OfDim v d n -> Scalar v -> OfDim v d n+  v ^/ a = v ^* recip a+  (/^) :: ( ValidDim v d n, DivisionRing (Scalar v) )+       => Scalar v -> OfDim v d n -> OfDim v d n+  (/^) = flip (^/)++-- | A module M over a ring R consists of:+--+--     * an abelian group M,+--     * an action of R on M.+--+-- That is, we simply add additive inverses to the previous definition.+class (Ring (Scalar v), Semimodule d v) => LinearModule d v | v -> d where+  {-# MINIMAL (^-^) | (-^) #-}+  (^-^) :: ValidDim v d n => OfDim v d n -> OfDim v d n -> OfDim v d n+  (^-^) x y = x ^+^ ((-^) y)+  (-^) :: ValidDim v d n => OfDim v d n -> OfDim v d n+  (-^) x = (-1) *^ x++-- | Semimodule with an inner product.+--+-- This usually consists of a non-degenerate symmetric bilinear form on the underlying semimodule.+--+-- Other axioms might be more relevant depending on the underlying ring.+-- For instance, one instead insists on sesquilinearity over the field of complex numbers.+class Semimodule d v => Inner d v where+  {-# MINIMAL ( (^.^) | dot ), normalise #-}+  (^.^), dot :: ValidDim v d n => OfDim v d n -> OfDim v d n -> Scalar v+  dot = (^.^)+  (^.^) = dot+  normalise :: ValidDim v d n => OfDim v d n -> OfDim v d n++-- | Module with a cross product.+--+-- This usually consists of a non-degenerate skew-symmetric bilinear multiplication satisfying the Jacobi identity.+-- Over the real numbers, this implies the dimension is 3.+class LinearModule d v => Cross d v where+  type CrossDim v d (n :: d) :: Constraint+  {-# MINIMAL (^×^) | cross #-}+  (^×^), cross :: (ValidDim v d n, CrossDim v d n) => OfDim v d n -> OfDim v d n -> OfDim v d n+  (^×^) = cross+  cross = (^×^)++------------------------------------------------------------------+-- instances for plain vectors++instance Semiring a => Semimodule Nat (V 0 a) where+  type Scalar (V 0 a) = a+  type OfDim (V 0 a) Nat n = V n a+  type ValidDim (V 0 a) Nat n = KnownNat n+  (^+^) = liftA2 (+)+  v ^* k = fmap (*k) v++instance Ring a => LinearModule Nat (V 0 a) where+  (^-^) = liftA2 (-)  ++instance (Semiring a, Floating a) => Inner Nat (V 0 a) where+  (^.^) = (sum .) . liftA2 (*)+  normalise v = invSqrt (dot v v) *^ v++instance Ring a => Cross Nat (V 0 a) where+  type CrossDim (V 0 a) Nat n = ( n ~ 3 )+  cross (V3 x y z) (V3 x' y' z') = V3 a b c+    where a = y * z' - z * y'+          b = z * x' - x * z'+          c = x * y' - y * x'++------------------------------------------------------------------+-- derived operations++-- | Angle between two vectors, computed using the inner product structure.+angle :: (Floating (Scalar v), ValidDim v d n, Inner d v)+      => OfDim v d n -> OfDim v d n -> Scalar v+angle x y = acos $ dot (normalise x) (normalise y)++-- | Norm of a vector, computed using the inner product.+norm :: (Floating (Scalar v), ValidDim v d n, Inner d v)+     => OfDim v d n -> Scalar v+norm v = sqrt $ squaredNorm v++-- | Squared norm of a vector, computed using the inner product.+squaredNorm :: (ValidDim v d n, Inner d v)+            => OfDim v d n -> Scalar v+squaredNorm v = dot v v++-- | Quadrance between two points.+quadrance :: (ValidDim v d n, LinearModule d v, Inner d v)+       => OfDim v d n -> OfDim v d n -> Scalar v+quadrance x y = squaredNorm (x ^-^ y)++-- | Distance between two points.+distance :: (Floating (Scalar v), ValidDim v d n, LinearModule d v, Inner d v)+         => OfDim v d n -> OfDim v d n -> Scalar v+distance x y = norm (x ^-^ y)++-- | Linear interpolation between two points.+along :: (ValidDim v d n, LinearModule d v)+      => Scalar v    -- ^ Interpolation coefficient. 0 = start, 1 = end.+      -> OfDim v d n -- ^ Start.+      -> OfDim v d n -- ^ End.+      -> OfDim v d n+along t x y = (1-t) *^ x ^+^ t *^ y++-- | Reflects a vector along a hyperplane, specified by a normal vector.+-- /Computes the normalisation of the normal vector in the process./+reflect :: (Floating (Scalar v), ValidDim v d n, LinearModule d v, Inner d v)+        => OfDim v d n -- ^ Vector to be reflected.+        -> OfDim v d n -- ^ A normal vector of the reflecting hyperplane.+        -> OfDim v d n+reflect v n = reflect' v (normalise n)++-- | Same as 'reflect': reflects a vector along a hyperplane, specified by a normal vector.+-- However, /__this function assumes the given normal vector is already normalised__/.+reflect' :: (ValidDim v d n, LinearModule d v, Inner d v)+         => OfDim v d n -- ^ Vector to be reflected.+         -> OfDim v d n -- ^ /__Normalised__/ normal vector of the reflecting hyperplane.+         -> OfDim v d n+reflect' v n = v ^-^ (2 * dot v n) *^ n++-- | Projects the first argument onto the second.+proj :: (DivisionRing (Scalar v), ValidDim v d n, Inner d v)+     => OfDim v d n -> OfDim v d n -> OfDim v d n+proj x y = projC x y *^ y++-- | Projection constant: how far along the projection of the first vector lands along the second vector.+projC :: forall v d (n :: d). (DivisionRing (Scalar v), ValidDim v d n, Inner d v)+      => OfDim v d n -> OfDim v d n -> Scalar v+projC x y = dot x y / dot y y++-- | Orthogonality test.+--+-- /__Uses a precise equality test, so use at your own risk with floating point numbers.__/+isOrthogonal :: (ValidDim v d n, LinearModule d v, Inner d v, Eq (Scalar v))+             => OfDim v d n -> OfDim v d n -> Logic (Scalar v)+isOrthogonal v w = dot v w == 0++-- | Gram-Schmidt algorithm.+gramSchmidt :: (Floating (Scalar v), ValidDim v d n, LinearModule d v, Inner d v)+            => [OfDim v d n] -> [OfDim v d n]+gramSchmidt []     = []+gramSchmidt (x:xs) = x' : gramSchmidt (map (\v -> v ^-^ proj v x') xs)+  where x' = normalise x++-- | Rotate a vector around an axis (in dimension 3), with Rodrigues' formula.+rotateAroundAxis :: (Cross d v, Inner d v, Floating (Scalar v), ValidDim v d n, CrossDim v d n)+                 => OfDim v d n -- ^ Axis of rotation (a unit vector).+                 -> Scalar v    -- ^ Angle of rotation, according to the right hand rule.+                 -> OfDim v d n -- ^ Vector to be rotated.+                 -> OfDim v d n+rotateAroundAxis n theta v =+  cos theta *^ v ^+^ sin theta *^ (n ^×^ v) ^+^ ((1 - cos theta) * (n ^.^ v)) *^ n++------------------------------------------------------------------+-- specific implementation of matrices using nested vectors++identityMat :: forall n a. (KnownNat n, Semiring a) => V n (V n a)+identityMat = buildV @n ( \ px1 -> buildV @n ( \ px2 -> indicator px1 px2 ) )+  where+    indicator :: (KnownNat i, KnownNat j) => Proxy i -> Proxy j -> a+    indicator px1 px2 = case sameNat px1 px2 of+      Just _ -> 1+      _      -> 0++blockSum :: forall m1 m2 n1 n2 a. (KnownNat m1, KnownNat m2, KnownNat n1, KnownNat n2, Semiring a) +         => V m1 (V n1 a)-> V m2 (V n2 a) -> V (m1+m2) (V (n1+n2) a)+blockSum mat1 mat2 = fmap (<!> pure zero) mat1 <!> fmap (pure zero <!>) mat2++joinV :: V m (V n a) -> V (m * n) a+joinV VNil          = VNil+joinV (col :. cols) = col <!> joinV cols++------------------------------------------------------------------+-- matrix newtype++-- | Matrix newtype.+--+-- @M m n a@ denotes a matrix with @m@ rows and @n@ columns.+--+-- This is represented as a vector of columns: column-major representation.+-- This choice is made for compatibility with SPIR-V, Vulkan, and OpenGL,+-- as all those frameworks represent matrices in column-major order.+newtype M m n a = M { unM :: V n (V m a) }++deriving newtype instance Prelude.Eq a => Prelude.Eq (M m n a)+deriving newtype instance (KnownNat m, KnownNat n, Prelude.Ord a) => Prelude.Ord (M m n a)+deriving newtype instance (KnownNat m, KnownNat n, Eq   a) => Eq   (M m n a)+deriving newtype instance (KnownNat m, KnownNat n, Ord  a) => Ord  (M m n a)+deriving newtype instance (KnownNat m, KnownNat n, Show a) => Show (M m n a)+deriving via ( V n `Compose` V m )+                 instance (KnownNat m, KnownNat n) => Functor     (M m n)+deriving via ( V n `Compose` V m )+                 instance (KnownNat m, KnownNat n) => Applicative (M m n)+deriving stock   instance (KnownNat m, KnownNat n) => Foldable    (M m n)+deriving stock   instance (KnownNat m, KnownNat n) => Traversable (M m n)+deriving newtype instance (KnownNat m, KnownNat n, Binary a) => Binary (M m n a)+deriving newtype instance (KnownNat n, KnownNat m, Storable a) => Storable (M m n a)+++------------------------------------------------------------------+-- products for matrices+++instance {-# OVERLAPPING #-} IsProduct (M 0 0 a) '[] where+  fromHList _ = M VNil+  toHList   _ = HNil+instance {-# OVERLAPPABLE #-} IsProduct (M m 0 a) '[] where+  fromHList _ = M VNil+  toHList   _ = HNil+instance {-# OVERLAPPABLE #-} KnownNat n => IsProduct (M 0 n a) '[] where+  fromHList _ = M ( pure VNil )+  toHList   _ = HNil+instance ( KnownNat m+         , KnownNat n, 1 <= n+         , Replicated (n-1) (V m a) rs+         , KnownLength rs+         , (Length rs + 1) ~ n+         )+      => IsProduct (M m n a) (V m a ': rs)+      where+  fromHList (col :> cols) = M $ col :. (fromHListVec (replication @(n-1) @(V m a)) cols )+  toHList (M (col :. cols)) = col :> toHListVec (replication @(n-1) @(V m a)) cols++instance ( KnownNat n, 1 <= n+         , KnownNat m, 1 <= m+         , Replicated (m*n-1) a rs+         , Length rs ~ (n*m-1), (1 + Length rs) ~ (n*m)+         , 1 <= (n*m)+         , Replicate (n*m) a ~ (a ': rs) -- type checker unfortunately can't deduce this+         )+      => IsProduct (M m n a) (a ': rs)+      where+  toHList   = toHList . joinV . unM+  fromHList = M . splitCols . fromHList++splitCols+  :: forall (n :: Nat) (m :: Nat) (a :: Type)+  .  ( KnownNat n, KnownNat m )+  => V (m*n) a -> V n (V m a)+splitCols v = case Proxy @1 %<=? Proxy @n of+  NLE nle Refl ->+    case lt1_is_Zero @n nle of+      Refl -> VNil+  LE Refl ->+    case splitAtV @m v of+      ( col, next ) ->+        col :. splitCols @(n-1) next++instance KnownNat m => GradedSemigroup (M m 0 a) Nat where+  type Grade Nat (M m 0 a) i = M m i a+  type i :<!>: j = i + j+  (<!>) :: M m i a -> M m j a -> M m (i+j) a+  (M cs) <!> (M ds) = M ( cs <!> ds )++------------------------------------------------------------------+-- type classes for matrix operations++infixl 6 !+!, !-!+infixl 7 !*!+infix  8 !*^, ^*!+infix  9 *!, !*++type family VectorOf m :: Type++-- | Typeclass for matrix operations.+--+-- The 'OfDims' associated type family allows the type class methods to involve various dimension indices.+class LinearModule d (VectorOf m) => Matrix d m | m -> d where+  type OfDims m d (ij :: (d, d)) = r | r -> m ij+  identity    :: ValidDim (VectorOf m) d i => OfDims m d '(i,i)+  diag        :: ValidDim (VectorOf m) d i => Scalar (VectorOf m) -> OfDims m d '(i,i)+  inverse     :: ValidDim (VectorOf m) d i => OfDims m d '(i,i) -> OfDims m d '(i,i)+  determinant :: ValidDim (VectorOf m) d i => OfDims m d '(i,i) -> Scalar (VectorOf m)+  transpose   :: ( ValidDim (VectorOf m) d i+                 , ValidDim (VectorOf m) d j+                 )+              => OfDims m d '(i,j) -> OfDims m d '(j,i)++  (!+!)       :: ( ValidDim (VectorOf m) d i+                 , ValidDim (VectorOf m) d j+                 )+              => OfDims m d '(i,j) -> OfDims m d '(i,j) -> OfDims m d '(i,j)+  (!-!)       :: ( ValidDim (VectorOf m) d i+                 , ValidDim (VectorOf m) d j+                 )+              => OfDims m d '(i,j) -> OfDims m d '(i,j) -> OfDims m d '(i,j)+  konst       :: ( ValidDim (VectorOf m) d i+                 , ValidDim (VectorOf m) d j+                 )+              => Scalar (VectorOf m) -> OfDims m d '(i,j)+  (*!)        :: ( ValidDim (VectorOf m) d i+                 , ValidDim (VectorOf m) d j+                 )+              => Scalar (VectorOf m) -> OfDims m d '(i,j) -> OfDims m d '(i,j)+  (!*)        :: ( ValidDim (VectorOf m) d i+                 , ValidDim (VectorOf m) d j+                 )+              => OfDims m d '(i,j) -> Scalar (VectorOf m) -> OfDims m d '(i,j)+  (!*^)       :: ( ValidDim (VectorOf m) d i+                 , ValidDim (VectorOf m) d j+                 )+              => OfDims m d '(i,j) -> OfDim (VectorOf m) d j -> OfDim (VectorOf m) d i+  (^*!)       :: ( ValidDim (VectorOf m) d i+                 , ValidDim (VectorOf m) d j+                 )+              => OfDim (VectorOf m) d i -> OfDims m d '(i,j) -> OfDim (VectorOf m) d j+  (!*!)       :: ( ValidDim (VectorOf m) d i+                 , ValidDim (VectorOf m) d j+                 , ValidDim (VectorOf m) d k+                 )+              => OfDims m d '(i,j) -> OfDims m d '(j,k) -> OfDims m d '(i,k)+  identity = diag 1+  (*!) = flip (!*) -- SPIR-V defines MatrixTimesScalar++type instance VectorOf (M 0 0 a) = V 0 a++instance Ring a => Matrix Nat (M 0 0 a) where+  type OfDims (M 0 0 a) Nat '(i,j) = M i j a+  identity = M identityMat+  diag a = a *! identity+  transpose (M m) = M ( distribute m )+  (M m1) !+! (M m2) = M $ liftA2 ( liftA2 (+) ) m1 m2+  (M m1) !-! (M m2) = M $ liftA2 ( liftA2 (-) ) m1 m2+  konst = M . pure . pure+  (M m) !* a = M $ liftA2 ( liftA2 (*) ) ka m+    where M ka = konst a+  v ^*! (M m) = fmap (\col -> sum $ liftA2 (*) v col) m+  m !*^ v = v ^*! transpose m+  (M m) !*! (M n) = M $ fmap (\col -> fmap (sum . liftA2 (*) col) mt) n+    where mt = distribute m+  determinant = error "determinant: not implemented"+  inverse     = error "inverse matrix: not implemented"++------------------------------------------------------------------+-- utility 4x4 matrices for camera viewpoints in 3D++-- | Affine 3D transformation matrix for a perspective view.+-- (Adapted from Edward Kmett's __Linear__ library for the Vulkan coordinate system.)+perspective+  :: Floating a+  => a -- ^ FOV.+  -> a -- ^ Aspect ratio.+  -> a -- ^ Near plane.+  -> a -- ^ Far plane.+  -> M 4 4 a+perspective fovy aspect near far+  = M $ V4 (V4 x 0 0 0)+           (V4 0 y 0 0)+           (V4 0 0 z 1)+           (V4 0 0 w 0)+  where tanHalfFovy = tan $ fovy / 2+        x = 1 / (aspect * tanHalfFovy)+        y = 1 / tanHalfFovy+        z = far / (far - near)+        w = far * near / (near - far)++-- | Affine 3D transformation matrix for looking at focus point from a given view point.+-- (Adapted from Edward Kmett's __Linear__ library for the Vulkan coordinate system.)+lookAt+  :: forall a. Floating a+  => V 3 a -- ^ Focus point.+  -> V 3 a -- ^ View point.+  -> V 3 a -- ^ Up vector.+  -> M 4 4 a+lookAt focus viewPoint up+  = M $ (<!>)+        ( distribute ( V4 xa ya za (pure 0) ) )+        ( V1 (V4 (-xd) (-yd) (-zd) 1) )+  where za = normalise (focus ^-^ viewPoint)+        xa = normalise (za `cross` up)+        ya = za `cross` xa+        xd = xa ^.^ focus+        yd = ya ^.^ focus+        zd = za ^.^ focus
+ src/Math/Logic/Bits.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE DerivingVia            #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE StandaloneDeriving     #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: Math.Logic.Bits++Alternative "Data.Bits" type class tailored for this library.++Justification: some of the methods of "Data.Bits" are unsuited for this library.+Consider for instance the class method++> shiftL :: a -> Int -> a++This function bakes in the type `Int`.+For this library, this would mean that only shifts+by Haskell-level constants are possible.+Instead, we want something which can instantiate to, e.g.:++> shiftL :: AST Word64 -> AST Word8 -> AST Word64++See also "Math.Algebra.Class" for further explanations+regarding the limitations of the standard type classes.++-}++module Math.Logic.Bits+  ( Bits(..)+  , BitShift(..)+  , BitCast(..)+  , zipBits2+  )+  where++-- base+import Prelude+  ( Int, Word )+import qualified Prelude+import qualified Data.Bits as Base+import Foreign.C.Types+import GHC.Float+  ( castWord32ToFloat , castFloatToWord32+  , castWord64ToDouble, castDoubleToWord64+  )++-- half+import Numeric.Half+  ( Half(..) )++-- fir+import Deriving.Base+  ( Base(..) ) -- newtype for deriving via base instances+import FIR.Prelude+import Math.Algebra.Class+  ( Integral )++----------------------------------------------------------------------++infixl 7 .&.+infixl 5 .|.+infixl 6 `xor`++class Bits a where+  (.&.) :: a -> a -> a+  (.|.) :: a -> a -> a+  xor   :: a -> a -> a+  complement :: a -> a+  zeroBits :: a+  -- | Reverse the order of the bits.+  bitReverse :: a -> a++instance Base.FiniteBits a => Bits (Base a) where+  (.&.) = coerce ( (Base..&.) :: a -> a -> a)+  (.|.) = coerce ( (Base..|.) :: a -> a -> a)+  xor   = coerce ( Base.xor :: a -> a -> a)+  complement = coerce (Base.complement :: a -> a)+  zeroBits   = coerce (Base.zeroBits :: a)+  bitReverse = coerce ( reverseBits :: a -> a )+    where+      reverseBits :: a -> a+      reverseBits x =+        Prelude.foldr+          ( \ i acc -> if Base.testBit x i then Base.setBit acc ( n Prelude.- 1 Prelude.- i ) else acc )+          Base.zeroBits+          [ 0 .. n Prelude.- 1 ]+        where+          n = Base.finiteBitSize x++deriving via Base Bool   instance Bits Bool+deriving via Base Word8  instance Bits Word8+deriving via Base Word16 instance Bits Word16+deriving via Base Word32 instance Bits Word32+deriving via Base Word64 instance Bits Word64+deriving via Base Word   instance Bits Word+deriving via Base Int8   instance Bits Int8+deriving via Base Int16  instance Bits Int16+deriving via Base Int32  instance Bits Int32+deriving via Base Int64  instance Bits Int64+deriving via Base Int    instance Bits Int++deriving via Base CChar   instance Bits CChar+deriving via Base CSChar  instance Bits CSChar+deriving via Base CUChar  instance Bits CUChar+deriving via Base CShort  instance Bits CShort+deriving via Base CUShort instance Bits CUShort+deriving via Base CInt    instance Bits CInt+deriving via Base CUInt   instance Bits CUInt+deriving via Base CLong   instance Bits CLong+deriving via Base CULong  instance Bits CULong+deriving via Base CLLong  instance Bits CLLong+deriving via Base CULLong instance Bits CULLong++type family BitsType (bs :: (Type,Type)) :: Type where+  BitsType '(b,_) = b+type family ShiftType (bs :: (Type,Type)) :: Type where+  ShiftType '(_,b) = b++-- | Bit-shift operations.+class (bs ~ '(BitsType bs, ShiftType bs)) => BitShift (bs :: (Type,Type)) where+  -- | Shift the first argument left by the specified number of bits.+  --+  -- Ignores the sign of the shift argument (second argument).+  --+  -- This is a logical shift: least-significant bits are set to 0.+  shiftL :: BitsType bs -> ShiftType bs -> BitsType bs+  -- | Shift the first argument right by the specified number of bits.+  --+  -- Ignores the sign of the shift argument (second argument).+  --+  -- For signed types this is an arithmetic shift (most-significant bits+  -- are filled with the sign of the first argument), and for unsigned+  -- types a logical shift (most-significant bits are set to 0),+  -- as with 'Data.Bits.shiftR'.+  shiftR :: BitsType bs -> ShiftType bs -> BitsType bs++instance (Base.Bits a, Prelude.Integral i)+  => BitShift '(Base a,i) where+  shiftL (Base a) i = Base $ Base.shiftL a (Prelude.fromIntegral i)+  shiftR (Base a) i = Base $ Base.shiftR a (Prelude.fromIntegral i)++deriving via '(Base Word8 ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Word8 ,s)+deriving via '(Base Word16,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Word16,s)+deriving via '(Base Word32,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Word32,s)+deriving via '(Base Word64,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Word64,s)+deriving via '(Base Word  ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Word  ,s)+deriving via '(Base Int8  ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Int8  ,s)+deriving via '(Base Int16 ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Int16 ,s)+deriving via '(Base Int32 ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Int32 ,s)+deriving via '(Base Int64 ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Int64 ,s)+deriving via '(Base Int   ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Int   ,s)++deriving via '(Base CChar  ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CChar  ,s)+deriving via '(Base CSChar ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CSChar ,s)+deriving via '(Base CUChar ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CUChar ,s)+deriving via '(Base CShort ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CShort ,s)+deriving via '(Base CUShort,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CUShort,s)+deriving via '(Base CInt   ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CInt   ,s)+deriving via '(Base CUInt  ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CUInt  ,s)+deriving via '(Base CLong  ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CLong  ,s)+deriving via '(Base CULong ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CULong ,s)+deriving via '(Base CLLong ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CLLong ,s)+deriving via '(Base CULLong,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CULLong,s)++-- | Reinterpret the bits of a value as a value of another type of the same width,+-- e.g. a 'Float' as the 'Word32' with the same bit pattern, or a signed integer as the+-- unsigned integer with the same two's complement representation.+class BitCast a b where+  bitcast :: a -> b++instance BitCast Word8  Int8   where+  bitcast = Prelude.fromIntegral+instance BitCast Word16 Int16  where+  bitcast = Prelude.fromIntegral+instance BitCast Word32 Int32  where+  bitcast = Prelude.fromIntegral+instance BitCast Word64 Int64  where+  bitcast = Prelude.fromIntegral+instance BitCast Int8   Word8  where+  bitcast = Prelude.fromIntegral+instance BitCast Int16  Word16 where+  bitcast = Prelude.fromIntegral+instance BitCast Int32  Word32 where+  bitcast = Prelude.fromIntegral+instance BitCast Int64  Word64 where+  bitcast = Prelude.fromIntegral++instance BitCast Word16 Half where+  bitcast = coerce+instance BitCast Word32 Float where+  bitcast = castWord32ToFloat+instance BitCast Word64 Double where+  bitcast = castWord64ToDouble+instance BitCast Half   Word16 where+  bitcast = coerce+instance BitCast Float  Word32 where+  bitcast = castFloatToWord32+instance BitCast Double Word64 where+  bitcast = castDoubleToWord64+instance BitCast Int16 Half where+  bitcast = coerce . ( Prelude.fromIntegral :: Int16 -> Word16 )+instance BitCast Int32 Float where+  bitcast = castWord32ToFloat . ( Prelude.fromIntegral :: Int32 -> Word32 )+instance BitCast Int64 Double where+  bitcast = castWord64ToDouble . ( Prelude.fromIntegral :: Int64 -> Word64 )+instance BitCast Half   Int16 where+  bitcast = ( Prelude.fromIntegral :: Word16 -> Int16 ) . coerce+instance BitCast Float  Int32 where+  bitcast = ( Prelude.fromIntegral :: Word32 -> Int32 ) . castFloatToWord32+instance BitCast Double Int64 where+  bitcast = ( Prelude.fromIntegral :: Word64 -> Int64 ) . castDoubleToWord64++zipBits2 :: Bits a+         => (Bool -> Bool -> Bool)+         -> (a    -> a    -> a   )+zipBits2 f+  = case ( f False False, f False True, f True False, f True True ) of+      ( False, False, False, False ) -> \ _ _ -> zeroBits+      ( False, False, False, True  ) ->          (.&.)+      ( False, False, True , False ) -> \ x y -> x .&. complement y+      ( False, False, True , True  ) -> \ x _ -> x+      ( False, True , False, False ) -> \ x y -> complement x .&. y+      ( False, True , False, True  ) -> \ _ y -> y+      ( False, True , True , False ) ->          xor+      ( False, True , True , True  ) ->          (.|.)+      ( True , False, False, False ) -> \ x y -> complement ( x .|. y )+      ( True , False, False, True  ) -> \ x y -> complement ( x `xor` y )+      ( True , False, True , False ) -> \ _ y -> complement y+      ( True , False, True , True  ) -> \ x y -> x .|. complement y+      ( True , True , False, False ) -> \ x _ -> complement x+      ( True , True , False, True  ) -> \ x y -> complement x .|. y+      ( True , True , True , False ) -> \ x y -> complement ( x .&. y )+      ( True , True , True , True  ) -> \ _ _ -> complement zeroBits
+ src/Math/Logic/Class.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE DerivingVia            #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE StandaloneDeriving     #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-|+Module: Math.Logic.Class++This module overloads logical functionalities so that they can be used to manipulate ASTs:++  * overloaded boolen operations such as @&&@, @||@, @xor@...+  * overloaded if-then-else for use with @RebindableSyntax@,+  * alternative @Eq@ and @Ord@ type classes which allow overloading with ASTs.+-}++module Math.Logic.Class where++-- base+import Prelude+  ( Int, Word, Foldable(..) )+import qualified Prelude+import Foreign.C.Types+import qualified GHC.Stack+  ( HasCallStack )++-- fir+import Deriving.Base+  ( Base(..) ) -- newtype for deriving via base instances+import FIR.Prelude++----------------------------------------------------------------------++infixr 3 &&+infixr 2 ||++class Boolean b where+  true  :: b+  false :: b+  (&&)  :: b -> b -> b+  (||)  :: b -> b -> b+  not   :: b -> b++instance Boolean Bool where+  true  = True+  false = False+  (&&)  = (Prelude.&&)+  (||)  = (Prelude.||)+  not   = Prelude.not++infix 4 ==+infix 4 /=++type family Choosing b (t :: (Type,Type,Type)) = r | r -> b t where+  Choosing b '(x,y,z) = b -> x -> y -> z++class Boolean b => Choose b (t :: (Type,Type,Type)) where+  choose :: Choosing b t++ifThenElse :: (GHC.Stack.HasCallStack, Choose b (t :: (Type,Type,Type)))+           => Choosing b t+ifThenElse = choose++instance (x ~ y, x ~ z) => Choose Bool '(x,y,z) where+  choose True  x _ = x+  choose False _ y = y++class Boolean (Logic a) => Eq a where+  type Logic a+  (==) :: a -> a -> Logic a+  (/=) :: a -> a -> Logic a+  a /= b = not (a == b)++instance Prelude.Eq a => Eq (Base a) where+  type Logic (Base a) = Bool+  (==) = coerce ( (Prelude.==) :: a -> a -> Bool )+  (/=) = coerce ( (Prelude./=) :: a -> a -> Bool )++deriving via Base ()     instance Eq ()+deriving via Base Bool   instance Eq Bool+deriving via Base Word8  instance Eq Word8+deriving via Base Word16 instance Eq Word16+deriving via Base Word32 instance Eq Word32+deriving via Base Word64 instance Eq Word64+deriving via Base Word   instance Eq Word+deriving via Base Int8   instance Eq Int8+deriving via Base Int16  instance Eq Int16+deriving via Base Int32  instance Eq Int32+deriving via Base Int64  instance Eq Int64+deriving via Base Int    instance Eq Int+deriving via Base Half   instance Eq Half+deriving via Base Float  instance Eq Float+deriving via Base Double instance Eq Double++deriving via Base CChar   instance Eq CChar+deriving via Base CSChar  instance Eq CSChar+deriving via Base CUChar  instance Eq CUChar+deriving via Base CShort  instance Eq CShort+deriving via Base CUShort instance Eq CUShort+deriving via Base CInt    instance Eq CInt+deriving via Base CUInt   instance Eq CUInt+deriving via Base CLong   instance Eq CLong+deriving via Base CULong  instance Eq CULong+deriving via Base CLLong  instance Eq CLLong+deriving via Base CULLong instance Eq CULLong+deriving via Base CFloat  instance Eq CFloat+deriving via Base CDouble instance Eq CDouble+++newtype All b = All { getAll :: b }+newtype Any b = Any { getAny :: b }++instance Boolean b => Semigroup (All b) where+  (<>) = coerce ( (&&) @b )+instance Boolean b => Monoid (All b) where+  mempty = coerce ( true @b )++instance Boolean b => Semigroup (Any b) where+  (<>) = coerce ( (||) @b )+instance Boolean b => Monoid (Any b) where+  mempty = coerce (false @b)++-- from Data.Functor.Utils+{-# INLINE (#.) #-}+(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)+(#.) _f = coerce++and :: (Foldable t, Boolean b) => t b -> b+and = getAll #. foldMap All++or :: (Foldable t, Boolean b) => t b -> b+or = getAny #. foldMap Any++any :: (Foldable t, Boolean b) => (a -> b) -> t a -> b+any p = getAny #. foldMap (Any #. p)++all :: (Foldable t, Boolean b) => (a -> b) -> t a -> b+all p = getAll #. foldMap (All #. p)++infix 4 <=+infix 4 <+infix 4 >=+infix 4 >++class Eq a => Ord a where+  --type Ordering a+  --compare :: a -> a -> Ordering a+  (<=)    :: a -> a -> Logic a+  (>=)    :: a -> a -> Logic a+  (<)     :: a -> a -> Logic a+  (>)     :: a -> a -> Logic a+  max     :: a -> a -> a+  min     :: a -> a -> a++  (>=) = flip (<=)+  (>)  = flip (<)+++instance Prelude.Ord a => Ord (Base a) where+  (<=)    = coerce ( (Prelude.<=)    :: a -> a -> Bool )+  (>=)    = coerce ( (Prelude.>=)    :: a -> a -> Bool )+  (<)     = coerce ( (Prelude.<)     :: a -> a -> Bool )+  (>)     = coerce ( (Prelude.>)     :: a -> a -> Bool )+  max     = coerce ( Prelude.max     :: a -> a -> a )+  min     = coerce ( Prelude.min     :: a -> a -> a )++deriving via Base ()     instance Ord ()+deriving via Base Bool   instance Ord Bool+deriving via Base Word8  instance Ord Word8+deriving via Base Word16 instance Ord Word16+deriving via Base Word32 instance Ord Word32+deriving via Base Word64 instance Ord Word64+deriving via Base Word   instance Ord Word+deriving via Base Int8   instance Ord Int8+deriving via Base Int16  instance Ord Int16+deriving via Base Int32  instance Ord Int32+deriving via Base Int64  instance Ord Int64+deriving via Base Int    instance Ord Int+deriving via Base Half   instance Ord Half+deriving via Base Float  instance Ord Float+deriving via Base Double instance Ord Double++deriving via Base CChar   instance Ord CChar+deriving via Base CSChar  instance Ord CSChar+deriving via Base CUChar  instance Ord CUChar+deriving via Base CShort  instance Ord CShort+deriving via Base CUShort instance Ord CUShort+deriving via Base CInt    instance Ord CInt+deriving via Base CUInt   instance Ord CUInt+deriving via Base CLong   instance Ord CLong+deriving via Base CULong  instance Ord CULong+deriving via Base CLLong  instance Ord CLLong+deriving via Base CULLong instance Ord CULLong+deriving via Base CFloat  instance Ord CFloat+deriving via Base CDouble instance Ord CDouble
+ src/Math/Quaternion.hs view
@@ -0,0 +1,137 @@+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}++{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE RebindableSyntax           #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE UndecidableInstances       #-}++{-|+Module: Math.Quaternion++Bare-bones implementation of quaternions,+together with a few simple operations+such as the conjugation action of quaternions on 3-d vectors.++-}++module Math.Quaternion where++-- base+import Prelude+  ( Eq(..), Show(..), Functor(..), Applicative(..)+  , Foldable(..), Traversable(..) )+import Control.Applicative+  ( liftA2 )++-- fir+import FIR.Prelude+import Math.Algebra.Class+  ( AdditiveMonoid(..), CancellativeAdditiveMonoid(..), AdditiveGroup(..)+  , Semiring(..), Ring, DivisionRing(..)+  , Signed(..), Floating(..)+  )+import Math.Linear+  ( V(..), M(M)+  , pattern V3+  , pattern V4+  , Semimodule(..), LinearModule(..), Inner(..), Cross(..)+  , norm, normalise+  )++----------------------------------------------------------------------------++newtype Quaternion a = Quaternion { quaternion :: V 4 a }+ deriving stock   ( Eq, Show, Foldable, Traversable )+ deriving newtype ( Functor, Applicative )++instance Semiring a => Semimodule () (Quaternion a) where+  type Scalar (Quaternion a) = a+  type OfDim (Quaternion a) () '() = Quaternion a+  type ValidDim (Quaternion a) () unit = ( unit ~ '() )+  (^+^) = coerce ( (^+^) :: V 4 a -> V 4 a -> V 4 a )+  (*^)  = coerce ( (*^) :: a -> V 4 a -> V 4 a )++instance Ring a => LinearModule () (Quaternion a) where+  (^-^) = coerce ( (^-^) :: V 4 a -> V 4 a -> V 4 a )+  (-^)  = coerce ( ( -^) :: V 4 a -> V 4 a )++instance (Semiring a, Floating a) => Inner () (Quaternion a) where+  dot = coerce ( dot :: V 4 a -> V 4 a -> a )+  normalise = coerce ( normalise :: V 4 a -> V 4 a )++instance AdditiveMonoid a => AdditiveMonoid (Quaternion a) where+  (+) = liftA2 (+)+  zero = Quaternion (pure zero)+  fromInteger = Quaternion . ( :. pure zero ) . fromInteger++instance Ring a => Semiring (Quaternion a) where+  Quaternion { quaternion = V4 xr xi xj xk } * Quaternion { quaternion = V4 yr yi yj yk }+    = Quaternion $+        V4 (xr*yr - xi*yi - xj*yj - xk*yk)+           (xr*yi + xi*yr + xj*yk - xk*yj)+           (xr*yj + xj*yr + xk*yi - xi*yk)+           (xr*yk + xk*yr + xi*yj - xj*yi)++instance CancellativeAdditiveMonoid a => CancellativeAdditiveMonoid (Quaternion a) where+  (-) = liftA2 (-)++instance AdditiveGroup a => AdditiveGroup (Quaternion a) where+  negate = fmap negate++instance Floating a => Signed (Quaternion a) where+  abs    q = norm q *^ Quaternion (V4 1 0 0 0)+  signum q = recip (norm q) *^ q++instance ( DivisionRing a, Floating a ) => DivisionRing (Quaternion a) where+  recip a = recip (norm a) *^ conjugate a+  fromRational = Quaternion . ( :. pure zero ) . fromRational++conjugate :: Ring a => Quaternion a -> Quaternion a+conjugate (Quaternion (a :. v)) = Quaternion (a :. (-^) @_ @_ @3 v)++-- 'rotate' expects the quaternion to be of unit norm+rotate :: Ring a => Quaternion a -> V 3 a -> V 3 a+rotate q v = ijk where+  Quaternion (_ :. ijk) = q * Quaternion (0 :. v) * conjugate q++axisAngle :: ( Semiring a, Floating a ) => V 3 a -> a -> Quaternion a+axisAngle axis theta = Quaternion ( cos half :. sin half *^ normalise axis )+  where half = 0.5 * theta++-- | The shortest rotation from one vector to another.+rotationFromTo :: ( Floating a, Eq a ) => V 3 a -> V 3 a -> Quaternion a+rotationFromTo u v+  | w == 0+  = error "rotationFromTo: opposite directions"+  | otherwise+  = normalise ( Quaternion ( w :. cross u' v' ) )+  where+    u' = normalise u+    v' = normalise v+    w = 1 + dot u' v'++fromQuaternion :: Ring a => Quaternion a -> M 3 3 a+fromQuaternion (Quaternion (V4 w x y z))+ = M $ V3 (V3 (1-2*(y2+z2)) (2*(xy+zw)) (2*(xz-yw)))+          (V3 (2*(xy-zw)) (1-2*(x2+z2)) (2*(yz+xw)))+          (V3 (2*(xz+yw)) (2*(yz-xw)) (1-2*(x2+y2)))+  where x2 = x*x+        y2 = y*y+        z2 = z*z+        xy = x*y+        xz = x*z+        xw = x*w+        yz = y*z+        yw = y*w+        zw = z*w
+ src/SPIRV/Builtin.hs view
@@ -0,0 +1,350 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}++{-|+Module: SPIRV.Builtin++Enumeration of SPIR-V built-in variables. Used both at the type-level and value-level.++See the SPIR-V specification, section 3.21 __BuiltIn__.++Refer to "FIR.BuiltIn" for usage in this library.++-}++module SPIRV.Builtin+  ( Builtin(..)+  , readBuiltin+  )+  where++-- base+import Data.Word+  ( Word32 )++-- text-short+import Data.Text.Short+  ( ShortText )++-- fir+import Data.Binary.Class.Put+  ( Put(..) )+import Data.Type.Known+  ( Demotable(Demote), Known(known) )++--------------------------------------------------++data Builtin+  = Position+  | PointSize+  --+  | ClipDistance+  | CullDistance+  | VertexId+  | InstanceId+  | PrimitiveId+  | InvocationId+  | Layer+  | ViewportIndex+  | TessLevelOuter+  | TessLevelInner+  | TessCoord+  | PatchVertices+  | FragCoord+  | PointCoord+  | FrontFacing+  | SampleId+  | SamplePosition+  | SampleMask+  --+  | FragDepth+  | HelperInvocation+  | NumWorkgroups+  | WorkgroupSize+  | WorkgroupId+  | LocalInvocationId+  | GlobalInvocationId+  | LocalInvocationIndex+  | WorkDim+  | GlobalSize+  | EnqueuedWorkgroupSize+  | GlobalOffset+  | GlobalLinearId+  --+  | SubgroupSize+  | SubgroupMaxSize+  | NumSubgroups+  | NumEnqueuedSubgroups+  | SubgroupId+  | SubgroupLocalInvocationId+  | VertexIndex+  | InstanceIndex+  --+  | LaunchID+  | LaunchSize+  | WorldRayOrigin+  | WorldRayDirection+  | ObjectRayOrigin+  | ObjectRayDirection+  | RayTMin+  | RayTMax+  | InstanceCustomIndex+  | ObjectToWorld+  | WorldToObject+--  | HitT -- this only exists in the NV ray tracing extension, before it became an alias of RayTMax+  | HitKind+  | IncomingRayFlags+  | RayGeometryIndex+  deriving stock ( Show, Eq, Ord )++readBuiltin :: ShortText -> Maybe Builtin+readBuiltin "gl_Position"                  = Just Position+readBuiltin "gl_PointSize"                 = Just PointSize+readBuiltin "gl_ClipDistance"              = Just ClipDistance+readBuiltin "gl_CullDistance"              = Just CullDistance+readBuiltin "gl_VertexID"                  = Just VertexId+readBuiltin "gl_InstanceID"                = Just InstanceId+readBuiltin "gl_PrimitiveID"               = Just PrimitiveId+readBuiltin "gl_InvocationID"              = Just InvocationId+readBuiltin "gl_Layer"                     = Just Layer+readBuiltin "gl_ViewportIndex"             = Just ViewportIndex+readBuiltin "gl_TessLevelOuter"            = Just TessLevelOuter+readBuiltin "gl_TessLevelInner"            = Just TessLevelInner+readBuiltin "gl_TessCoord"                 = Just TessCoord+readBuiltin "gl_PatchVertices"             = Just PatchVertices+readBuiltin "gl_FragCoord"                 = Just FragCoord+readBuiltin "gl_PointCoord"                = Just PointCoord+readBuiltin "gl_FrontFacing"               = Just FrontFacing+readBuiltin "gl_SampleID"                  = Just SampleId+readBuiltin "gl_SamplePosition"            = Just SamplePosition+readBuiltin "gl_SampleMask"                = Just SampleMask+readBuiltin "gl_FragDepth"                 = Just FragDepth+readBuiltin "gl_HelperInvocation"          = Just HelperInvocation+readBuiltin "gl_NumWorkgroups"             = Just NumWorkgroups+readBuiltin "gl_WorkgroupSize"             = Just WorkgroupSize+readBuiltin "gl_WorkgroupID"               = Just WorkgroupId+readBuiltin "gl_LocalInvocationID"         = Just LocalInvocationId+readBuiltin "gl_GlobalInvocationID"        = Just GlobalInvocationId+readBuiltin "gl_LocalInvocationIndex"      = Just LocalInvocationIndex+readBuiltin "gl_WorkDim"                   = Just WorkDim+readBuiltin "gl_GlobalSize"                = Just GlobalSize+readBuiltin "gl_EnqueuedWorkgroupSize"     = Just EnqueuedWorkgroupSize+readBuiltin "gl_GlobalOffset"              = Just GlobalOffset+readBuiltin "gl_GlobalLinearID"            = Just GlobalLinearId+readBuiltin "gl_SubgroupSize"              = Just SubgroupSize+readBuiltin "gl_SubgroupMaxSize"           = Just SubgroupMaxSize+readBuiltin "gl_NumSubgroups"              = Just NumSubgroups+readBuiltin "gl_NumEnqueuedSubgroups"      = Just NumEnqueuedSubgroups+readBuiltin "gl_SubgroupID"                = Just SubgroupId+readBuiltin "gl_SubgroupInvocationID"      = Just SubgroupLocalInvocationId+readBuiltin "gl_VertexIndex"               = Just VertexIndex+readBuiltin "gl_InstanceIndex"             = Just InstanceIndex+readBuiltin "cl_WorkDim"                   = Just WorkDim+readBuiltin "cl_GlobalSize"                = Just GlobalSize+readBuiltin "cl_GlobalInvocationID"        = Just GlobalInvocationId+readBuiltin "cl_LocalInvocationID"         = Just LocalInvocationId+readBuiltin "cl_NumWorkgroups"             = Just NumWorkgroups+readBuiltin "cl_WorkgroupID"               = Just WorkgroupId+readBuiltin "cl_GlobalOffset"              = Just GlobalOffset+readBuiltin "cl_GlobalLinearID"            = Just GlobalLinearId+readBuiltin "gl_LaunchID"                  = Just LaunchID+readBuiltin "gl_LaunchSize"                = Just LaunchSize+readBuiltin "gl_WorldRayOrigin"            = Just WorldRayOrigin+readBuiltin "gl_WorldRayDirection"         = Just WorldRayDirection+readBuiltin "gl_ObjectRayOrigin"           = Just ObjectRayOrigin+readBuiltin "gl_ObjectRayDirection"        = Just ObjectRayDirection+readBuiltin "gl_RayTMin"                   = Just RayTMin+readBuiltin "gl_RayTMax"                   = Just RayTMax+readBuiltin "gl_InstanceCustomIndex"       = Just InstanceCustomIndex+readBuiltin "gl_ObjectToWorld"             = Just ObjectToWorld+readBuiltin "gl_WorldToObject"             = Just WorldToObject+readBuiltin "gl_HitT"                      = Just RayTMax -- NOT "HitT" which only exists in the NV extension+readBuiltin "gl_HitKind"                   = Just HitKind+readBuiltin "gl_IncomingRayFlags"          = Just IncomingRayFlags+readBuiltin "gl_RayGeometryIndex"          = Just RayGeometryIndex+readBuiltin _ = Nothing++instance Put Builtin where+  wordCount _ = 1++  put Position                  = put @Word32  0+  put PointSize                 = put @Word32  1+  --+  put ClipDistance              = put @Word32  3+  put CullDistance              = put @Word32  4+  put VertexId                  = put @Word32  5+  put InstanceId                = put @Word32  6+  put PrimitiveId               = put @Word32  7+  put InvocationId              = put @Word32  8+  put Layer                     = put @Word32  9+  put ViewportIndex             = put @Word32 10+  put TessLevelOuter            = put @Word32 11+  put TessLevelInner            = put @Word32 12+  put TessCoord                 = put @Word32 13+  put PatchVertices             = put @Word32 14+  put FragCoord                 = put @Word32 15+  put PointCoord                = put @Word32 16+  put FrontFacing               = put @Word32 17+  put SampleId                  = put @Word32 18+  put SamplePosition            = put @Word32 19+  put SampleMask                = put @Word32 20+  --+  put FragDepth                 = put @Word32 22+  put HelperInvocation          = put @Word32 23+  put NumWorkgroups             = put @Word32 24+  put WorkgroupSize             = put @Word32 25+  put WorkgroupId               = put @Word32 26+  put LocalInvocationId         = put @Word32 27+  put GlobalInvocationId        = put @Word32 28+  put LocalInvocationIndex      = put @Word32 29+  put WorkDim                   = put @Word32 30+  put GlobalSize                = put @Word32 31+  put EnqueuedWorkgroupSize     = put @Word32 32+  put GlobalOffset              = put @Word32 33+  put GlobalLinearId            = put @Word32 34+  --+  put SubgroupSize              = put @Word32 36+  put SubgroupMaxSize           = put @Word32 37+  put NumSubgroups              = put @Word32 38+  put NumEnqueuedSubgroups      = put @Word32 39+  put SubgroupId                = put @Word32 40+  put SubgroupLocalInvocationId = put @Word32 41+  put VertexIndex               = put @Word32 42+  put InstanceIndex             = put @Word32 43+--+  put LaunchID            = put @Word32 5319+  put LaunchSize          = put @Word32 5320+  put WorldRayOrigin      = put @Word32 5321+  put WorldRayDirection   = put @Word32 5322+  put ObjectRayOrigin     = put @Word32 5323+  put ObjectRayDirection  = put @Word32 5324+  put RayTMin             = put @Word32 5325+  put RayTMax             = put @Word32 5326+  put InstanceCustomIndex = put @Word32 5327+  put ObjectToWorld       = put @Word32 5330+  put WorldToObject       = put @Word32 5331+--put HitT                = put @Word32 5332+  put HitKind             = put @Word32 5333+  put IncomingRayFlags    = put @Word32 5351+  put RayGeometryIndex    = put @Word32 5352++instance Demotable Builtin where+  type Demote Builtin = Builtin+instance Known Builtin Position where+  known = Position+instance Known Builtin PointSize where+  known = PointSize+instance Known Builtin ClipDistance where+  known = ClipDistance+instance Known Builtin CullDistance where+  known = CullDistance+instance Known Builtin VertexId where+  known = VertexId+instance Known Builtin InstanceId where+  known = InstanceId+instance Known Builtin PrimitiveId where+  known = PrimitiveId+instance Known Builtin InvocationId where+  known = InvocationId+instance Known Builtin Layer where+  known = Layer+instance Known Builtin ViewportIndex where+  known = ViewportIndex+instance Known Builtin TessLevelOuter where+  known = TessLevelOuter+instance Known Builtin TessLevelInner where+  known = TessLevelInner+instance Known Builtin TessCoord where+  known = TessCoord+instance Known Builtin PatchVertices where+  known = PatchVertices+instance Known Builtin FragCoord where+  known = FragCoord+instance Known Builtin PointCoord where+  known = PointCoord+instance Known Builtin FrontFacing where+  known = FrontFacing+instance Known Builtin SampleId where+  known = SampleId+instance Known Builtin SamplePosition where+  known = SamplePosition+instance Known Builtin SampleMask where+  known = SampleMask+instance Known Builtin FragDepth where+  known = FragDepth+instance Known Builtin HelperInvocation where+  known = HelperInvocation+instance Known Builtin NumWorkgroups where+  known = NumWorkgroups+instance Known Builtin WorkgroupSize where+  known = WorkgroupSize+instance Known Builtin WorkgroupId where+  known = WorkgroupId+instance Known Builtin LocalInvocationId where+  known = LocalInvocationId+instance Known Builtin GlobalInvocationId where+  known = GlobalInvocationId+instance Known Builtin LocalInvocationIndex where+  known = LocalInvocationIndex+instance Known Builtin WorkDim where+  known = WorkDim+instance Known Builtin GlobalSize where+  known = GlobalSize+instance Known Builtin EnqueuedWorkgroupSize where+  known = EnqueuedWorkgroupSize+instance Known Builtin GlobalOffset where+  known = GlobalOffset+instance Known Builtin GlobalLinearId where+  known = GlobalLinearId+instance Known Builtin SubgroupSize where+  known = SubgroupSize+instance Known Builtin SubgroupMaxSize where+  known = SubgroupMaxSize+instance Known Builtin NumSubgroups where+  known = NumSubgroups+instance Known Builtin NumEnqueuedSubgroups where+  known = NumEnqueuedSubgroups+instance Known Builtin SubgroupId where+  known = SubgroupId+instance Known Builtin SubgroupLocalInvocationId where+  known = SubgroupLocalInvocationId+instance Known Builtin VertexIndex where+  known = VertexIndex+instance Known Builtin InstanceIndex where+  known = InstanceIndex+instance Known Builtin LaunchID where+  known = LaunchID+instance Known Builtin LaunchSize where+  known = LaunchSize+instance Known Builtin WorldRayOrigin where+  known = WorldRayOrigin+instance Known Builtin WorldRayDirection where+  known = WorldRayDirection+instance Known Builtin ObjectRayOrigin where+  known = ObjectRayOrigin+instance Known Builtin ObjectRayDirection where+  known = ObjectRayDirection+instance Known Builtin RayTMin where+  known = RayTMin+instance Known Builtin RayTMax where+  known = RayTMax+instance Known Builtin InstanceCustomIndex where+  known = InstanceCustomIndex+instance Known Builtin ObjectToWorld where+  known = ObjectToWorld+instance Known Builtin WorldToObject where+  known = WorldToObject+--instance Known Builtin HitT where+--  known = HitT+instance Known Builtin HitKind where+  known = HitKind+instance Known Builtin IncomingRayFlags where+  known = IncomingRayFlags+instance Known Builtin RayGeometryIndex where+  known = RayGeometryIndex
+ src/SPIRV/Capability.hs view
@@ -0,0 +1,350 @@+{-# LANGUAGE DeriveLift                 #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE PatternSynonyms            #-}++{-|+Module: SPIRV.Capability++Enumeration of SPIR-V capabilities. These are used at the value-level only.++A capability must be declared whenever an operation is used which requires it.+See the SPIR-V specification, section 3.31 __Capability__.++-}++module SPIRV.Capability where++-- base+import Data.String+  ( IsString(..) )+import Data.Word+  ( Word32 )++-- template-haskell+import Language.Haskell.TH.Syntax+  ( Lift )++-- fir+import Data.Binary.Class.Put+  ( Put )++--------------------------------------------------++newtype Capability = Capability Word32+  deriving newtype ( Eq, Ord, Put )+  deriving stock   Lift++instance Show Capability where+  show capability = "Capability " ++ showCapability capability+++pattern Matrix :: Capability+pattern Matrix = Capability 0++pattern Shader :: Capability+pattern Shader = Capability 1++pattern Geometry :: Capability+pattern Geometry = Capability 2++pattern Tessellation :: Capability+pattern Tessellation = Capability 3++pattern Addresses :: Capability+pattern Addresses = Capability 4++pattern Linkage :: Capability+pattern Linkage = Capability 5++pattern ComputeKernel :: Capability+pattern ComputeKernel = Capability 6++pattern Vector16 :: Capability+pattern Vector16 = Capability 7++pattern Float16Buffer :: Capability+pattern Float16Buffer = Capability 8++pattern Float16 :: Capability+pattern Float16 = Capability 9++pattern Float64 :: Capability+pattern Float64 = Capability 10++pattern Int64 :: Capability+pattern Int64 = Capability 11++pattern Int64Atomics :: Capability+pattern Int64Atomics = Capability 12++pattern ImageBasic :: Capability+pattern ImageBasic = Capability 13++pattern ImageReadWrite :: Capability+pattern ImageReadWrite = Capability 14++pattern ImageMipmap :: Capability+pattern ImageMipmap = Capability 15++-- no 16++pattern Pipes :: Capability+pattern Pipes = Capability 17++pattern Groups :: Capability+pattern Groups = Capability 18++pattern DeviceEnqueue :: Capability+pattern DeviceEnqueue = Capability 19++pattern LiteralSampler :: Capability+pattern LiteralSampler = Capability 20++pattern AtomicStorage :: Capability+pattern AtomicStorage = Capability 21++pattern Int16 :: Capability+pattern Int16 = Capability 22++pattern TessellationPointSize :: Capability+pattern TessellationPointSize = Capability 23++pattern GeometryPointSize :: Capability+pattern GeometryPointSize = Capability 24++pattern ImageGatherExtended :: Capability+pattern ImageGatherExtended = Capability 25++-- no 26++pattern StorageImageMultisample :: Capability+pattern StorageImageMultisample = Capability 27++pattern UniformBufferArrayDynamicIndexing :: Capability+pattern UniformBufferArrayDynamicIndexing = Capability 28++pattern SampledImageArrayDynamicIndexing :: Capability+pattern SampledImageArrayDynamicIndexing = Capability 29++pattern StorageBufferArrayDynamicIndexing :: Capability+pattern StorageBufferArrayDynamicIndexing = Capability 30++pattern StorageImageArrayDynamicIndexing :: Capability+pattern StorageImageArrayDynamicIndexing = Capability 31++pattern ClipDistance :: Capability+pattern ClipDistance = Capability 32++pattern CullDistance :: Capability+pattern CullDistance = Capability 33++pattern ImageCubeArray :: Capability+pattern ImageCubeArray = Capability 34++pattern SampleRateShading :: Capability+pattern SampleRateShading = Capability 35++pattern ImageRect :: Capability+pattern ImageRect = Capability 36++pattern SampledRect :: Capability+pattern SampledRect = Capability 37++pattern GenericPointer :: Capability+pattern GenericPointer = Capability 38++pattern Int8 :: Capability+pattern Int8 = Capability 39++pattern InputAttachment :: Capability+pattern InputAttachment = Capability 40++pattern SparseResidency :: Capability+pattern SparseResidency = Capability 41++pattern MinLod :: Capability+pattern MinLod = Capability 42++pattern Sampled1D :: Capability+pattern Sampled1D = Capability 43++pattern Image1D :: Capability+pattern Image1D = Capability 44++pattern SampledCubeArray :: Capability+pattern SampledCubeArray = Capability 45++pattern SampledBuffer :: Capability+pattern SampledBuffer = Capability 46++pattern ImageBuffer :: Capability+pattern ImageBuffer = Capability 47++pattern ImageMSArray :: Capability+pattern ImageMSArray = Capability 48++pattern StorageImageExtendedFormats :: Capability+pattern StorageImageExtendedFormats = Capability 49++pattern ImageQuery :: Capability+pattern ImageQuery = Capability 50++pattern DerivativeControl :: Capability+pattern DerivativeControl = Capability 51++pattern InterpolationFunction :: Capability+pattern InterpolationFunction = Capability 52++pattern TransformFeedback :: Capability+pattern TransformFeedback = Capability 53++pattern GeometryStreams :: Capability+pattern GeometryStreams = Capability 54++pattern StorageImageReadWithoutFormat :: Capability+pattern StorageImageReadWithoutFormat = Capability 55++pattern StorageImageWriteWithoutFormat :: Capability+pattern StorageImageWriteWithoutFormat = Capability 56++pattern MultiViewport :: Capability+pattern MultiViewport = Capability 57++-- no 61+pattern GroupNonUniform :: Capability+pattern GroupNonUniform = Capability 61++pattern GroupNonUniformVote :: Capability+pattern GroupNonUniformVote = Capability 62++pattern GroupNonUniformArithmetic :: Capability+pattern GroupNonUniformArithmetic = Capability 63++pattern GroupNonUniformBallot :: Capability+pattern GroupNonUniformBallot = Capability 64++pattern GroupNonUniformShuffle :: Capability+pattern GroupNonUniformShuffle = Capability 65++pattern GroupNonUniformShuffleRelative :: Capability+pattern GroupNonUniformShuffleRelative = Capability 66++pattern GroupNonUniformClustered :: Capability+pattern GroupNonUniformClustered = Capability 67++pattern GroupNonUniformQuad :: Capability+pattern GroupNonUniformQuad = Capability 68++-- extensions+pattern RayQueryKHR :: Capability+pattern RayQueryKHR = Capability 4472++pattern RayTraversalPrimitiveCullingKHR :: Capability+pattern RayTraversalPrimitiveCullingKHR = Capability 4478++pattern RayTracingKHR :: Capability+pattern RayTracingKHR = Capability 4479++pattern MeshShadingNV :: Capability+pattern MeshShadingNV = Capability 5266++pattern BitInstructions :: Capability+pattern BitInstructions = Capability 6025++pattern AtomicFloat32MinMaxEXT :: Capability+pattern AtomicFloat32MinMaxEXT = Capability 5612++pattern AtomicFloat64MinMaxEXT :: Capability+pattern AtomicFloat64MinMaxEXT = Capability 5613++pattern AtomicFloat16MinMaxEXT :: Capability+pattern AtomicFloat16MinMaxEXT = Capability 5616++pattern AtomicFloat32AddEXT :: Capability+pattern AtomicFloat32AddEXT = Capability 6033++pattern AtomicFloat64AddEXT :: Capability+pattern AtomicFloat64AddEXT = Capability 6034++pattern AtomicFloat16AddEXT :: Capability+pattern AtomicFloat16AddEXT = Capability 6095++showCapability :: IsString string => Capability -> string+showCapability Matrix = "Matrix"+showCapability Shader = "Shader"+showCapability Geometry = "Geometry"+showCapability Tessellation = "Tessellation"+showCapability Addresses = "Addresses"+showCapability Linkage = "Linkage"+showCapability ComputeKernel = "ComputeKernel"+showCapability Vector16 = "Vector16"+showCapability Float16Buffer = "Float16Buffer"+showCapability Float16 = "Float16"+showCapability Float64 = "Float64"+showCapability Int64 = "Int64"+showCapability Int64Atomics = "Int64Atomics"+showCapability ImageBasic = "ImageBasic"+showCapability ImageReadWrite = "ImageReadWrite"+showCapability ImageMipmap = "ImageMipmap"+showCapability Pipes = "Pipes"+showCapability Groups = "Groups"+showCapability DeviceEnqueue = "DeviceEnqueue"+showCapability LiteralSampler = "LiteralSampler"+showCapability AtomicStorage = "AtomicStorage"+showCapability Int16 = "Int16"+showCapability TessellationPointSize = "TessellationPointSize"+showCapability GeometryPointSize = "GeometryPointSize"+showCapability ImageGatherExtended = "ImageGatherExtended"+showCapability StorageImageMultisample = "StorageImageMultisample"+showCapability UniformBufferArrayDynamicIndexing = "UniformBufferArrayDynamicIndexing"+showCapability SampledImageArrayDynamicIndexing = "SampledImageArrayDynamicIndexing"+showCapability StorageBufferArrayDynamicIndexing = "StorageBufferArrayDynamicIndexing"+showCapability StorageImageArrayDynamicIndexing = "StorageImageArrayDynamicIndexing"+showCapability ClipDistance = "ClipDistance"+showCapability CullDistance = "CullDistance"+showCapability ImageCubeArray = "ImageCubeArray"+showCapability SampleRateShading = "SampleRateShading"+showCapability ImageRect = "ImageRect"+showCapability SampledRect = "SampledRect"+showCapability GenericPointer = "GenericPointer"+showCapability Int8 = "Int8"+showCapability InputAttachment = "InputAttachment"+showCapability SparseResidency = "SparseResidency"+showCapability MinLod = "MinLod"+showCapability Sampled1D = "Sampled1D"+showCapability Image1D = "Image1D"+showCapability SampledCubeArray = "SampledCubeArray"+showCapability SampledBuffer = "SampledBuffer"+showCapability ImageBuffer = "ImageBuffer"+showCapability ImageMSArray = "ImageMSArray"+showCapability StorageImageExtendedFormats = "StorageImageExtendedFormats"+showCapability ImageQuery = "ImageQuery"+showCapability DerivativeControl = "DerivativeControl"+showCapability InterpolationFunction = "InterpolationFunction"+showCapability TransformFeedback = "TransformFeedback"+showCapability GeometryStreams = "GeometryStreams"+showCapability StorageImageReadWithoutFormat = "StorageImageReadWithoutFormat"+showCapability StorageImageWriteWithoutFormat = "StorageImageWriteWithoutFormat"+showCapability MultiViewport = "MultiViewport"+showCapability GroupNonUniform = "GroupNonUniform"+showCapability GroupNonUniformVote = "GroupNonUniformVote"+showCapability GroupNonUniformArithmetic = "GroupNonUniformArithmetic"+showCapability GroupNonUniformBallot = "GroupNonUniformBallot"+showCapability GroupNonUniformShuffle = "GroupNonUniformShuffle"+showCapability GroupNonUniformShuffleRelative = "GroupNonUniformShuffleRelative"+showCapability GroupNonUniformClustered = "GroupNonUniformClustered"+showCapability GroupNonUniformQuad = "GroupNonUniformQuad"+showCapability RayQueryKHR = "RayQueryKHR"+showCapability RayTraversalPrimitiveCullingKHR = "RayTraversalPrimitiveCullingKHR"+showCapability RayTracingKHR = "RayTracingKHR"+showCapability MeshShadingNV = "MeshShadingNV"+showCapability BitInstructions = "BitInstructions"+showCapability AtomicFloat32MinMaxEXT = "AtomicFloat32MinMaxEXT"+showCapability AtomicFloat64MinMaxEXT = "AtomicFloat64MinMaxEXT"+showCapability AtomicFloat16MinMaxEXT = "AtomicFloat16MinMaxEXT"+showCapability AtomicFloat32AddEXT = "AtomicFloat32AddEXT"+showCapability AtomicFloat64AddEXT = "AtomicFloat64AddEXT"+showCapability AtomicFloat16AddEXT = "AtomicFloat16AddEXT"+showCapability (Capability i) = fromString ( show i )
+ src/SPIRV/Control.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}++{-|+Module: SPIRV.Control++This module enumerates SPIR-V control parameters:++  * selection control parameters (SPIR-V specification §3.22 __Selection Control__),+  * loop control parameters (SPIR-V specification §3.23 __Loop Control__),+  * function control parameters (SPIR-V specification §3.24 __Function Control__).++These are used both at the type-level and value-level.++-}++module SPIRV.Control+  ( Inlineability(..)+  , SideEffects(..)+  , FunctionControl+  , type NoFunctionControl, pattern NoFunctionControl+  , SelectionControl(..), pattern NoSelectionControl+  , LoopUnrolling(..)+  , LoopDependency(..)+  , LoopControl+  , type NoLoopControl, pattern NoLoopControl+  )+  where++-- base+import Data.Word+  ( Word32 )+import GHC.TypeLits+  ( Nat, KnownNat )++-- binary+import qualified Data.Binary.Put as Binary++-- fir+import Data.Binary.Class.Put+  ( Put(..) )+import Data.Type.Known+  ( Demotable(Demote), Known(known), knownValue )++------------------------------------------------------------------------------------------------+-- function control++data Inlineability = Inline | DontInline+  deriving stock ( Eq, Show )+data SideEffects = OnlyReads | NoSideEffects+  deriving stock ( Eq, Show )++type FunctionControl = ( Maybe Inlineability, Maybe SideEffects )++type NoFunctionControl = ( '( 'Nothing, 'Nothing ) :: FunctionControl )++pattern NoFunctionControl :: FunctionControl+pattern NoFunctionControl = ( Nothing, Nothing )++instance Put FunctionControl where+  wordCount _ = 1+  put ( i, s ) = put w+    where w :: Word32+          w = wi + ws+          wi = case i of+                  Nothing         -> 0+                  Just Inline     -> 1+                  Just DontInline -> 2+          ws = case s of+                  Nothing            -> 0+                  Just OnlyReads     -> 4+                  Just NoSideEffects -> 8++instance Demotable Inlineability where+  type Demote Inlineability = Inlineability+instance Known Inlineability 'Inline where+  known = Inline+instance Known Inlineability 'DontInline where+  known = DontInline++instance Demotable SideEffects where+  type Demote SideEffects = SideEffects+instance Known SideEffects 'OnlyReads where+  known = OnlyReads+instance Known SideEffects 'NoSideEffects where+  known = NoSideEffects+++------------------------------------------------------------------------------------------------+-- selection control++data SelectionControl+  = Flatten+  | DontFlatten+  deriving stock ( Eq, Show )++pattern NoSelectionControl :: Maybe SelectionControl+pattern NoSelectionControl = Nothing++instance Put SelectionControl where+  wordCount _ = 1+  put Flatten     = put @Word32 1+  put DontFlatten = put @Word32 2++instance Put (Maybe SelectionControl) where+  wordCount _ = 1+  put Nothing            = put @Word32 0+  put (Just Flatten    ) = put @Word32 1+  put (Just DontFlatten) = put @Word32 2++instance Demotable SelectionControl where+  type Demote SelectionControl = SelectionControl+instance Known SelectionControl Flatten where+  known = Flatten+instance Known SelectionControl DontFlatten where+  known = DontFlatten++------------------------------------------------------------------------------------------------+-- loop control++data LoopUnrolling+  = Unroll+  | DontUnroll+  deriving stock ( Eq, Show )++data LoopDependency n+  = DependencyInfinite+  | DependencyLength n+  deriving stock ( Eq, Show )++type LoopControl n = ( Maybe LoopUnrolling, Maybe (LoopDependency n) )+type NoLoopControl = ( '( Nothing, Nothing ) :: LoopControl Nat )+pattern NoLoopControl :: LoopControl Word32+pattern NoLoopControl = ( Nothing, Nothing )++instance Demotable LoopUnrolling where+  type Demote LoopUnrolling = LoopUnrolling+instance Known LoopUnrolling Unroll where+  known = Unroll+instance Known LoopUnrolling DontUnroll where+  known = DontUnroll++instance Demotable (LoopDependency Nat) where+  type Demote (LoopDependency Nat) = LoopDependency Word32+instance Known (LoopDependency Nat) DependencyInfinite where+  known = DependencyInfinite+instance KnownNat l => Known (LoopDependency Nat) (DependencyLength l) where+  known = DependencyLength ( knownValue @l )+++instance Put (LoopControl Word32) where+  wordCount (_, Just (DependencyLength _)) = 2+  wordCount _                              = 1+  put ( u, d ) = put w *> mbPutDependencyLength+    where w :: Word32+          w = wu + wd+          wu = case u of+                  Nothing         -> 0+                  Just Unroll     -> 1+                  Just DontUnroll -> 2+          wd = case d of+                  Nothing                   -> 0+                  Just DependencyInfinite   -> 4+                  Just (DependencyLength _) -> 8+          mbPutDependencyLength :: Binary.PutM ()+          mbPutDependencyLength = case d of+            Just (DependencyLength l) -> put l+            _                         -> pure ()
+ src/SPIRV/Decoration.hs view
@@ -0,0 +1,245 @@++{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}++{-|+Module: SPIRV.Decoration++This module enumerates SPIR-V decorations. Used both at the type-level and term-level.++See SPIR-V specification §3.20 __Decoration__.++In this library, decorations are usually provided as part of a top-level definition specifying an interface+for a SPIR-V module. See "FIR.Definition".++-}++module SPIRV.Decoration+  ( Decoration(..)+  , Decorations+  )+  where++-- base+import Data.Word+  ( Word32 )+import GHC.TypeLits+  ( Nat )++-- containers+import Data.Set+  ( Set )++-- fir+import Data.Binary.Class.Put+  ( Put(..) )+import Data.Type.Known+  ( Demotable(Demote), Known(known), knownValue )+import qualified SPIRV.Builtin as Builtin++--------------------------------------------------++data Decoration a+  = RelaxedPrecision+  | SpecId a+  | Block+  --   | BufferBlock -- deprecated+  | RowMajor+  | ColMajor+  | ArrayStride  a+  | MatrixStride a+  | GLSLShared+  | GLSLPacked+  | CPacked+  | Builtin Builtin.Builtin+  -- no 12+  | NoPerspective+  | Flat+  | Patch+  | Centroid+  | Sample+  | Invariant+  | Restrict+  | Aliased+  | Volatile+  | Constant+  | Coherent+  | NonWritable+  | NonReadable+  | DynamicallyUniform -- simply called 'Uniform' in the SPIR-V spec+  -- no 27+  | SaturatedConversion+  | Stream        a+  | Location      a+  | Component     a+  | Index         a+  | Binding       a+  | DescriptorSet a+  | Offset        a+  | XfbBuffer     a+  | XfbStride     a+  -- | FuncParamAttr Attribute+  -- | FPRoundingMode RoundingMode+  -- | FPFastMathMode FastMathMode+  -- | LinkageAttributes Word32 LinkageType+  | NoContraction+  | InputAttachmentIndex a+  | Alignment a+  deriving stock ( Show, Eq, Ord )++type Decorations = Set (Decoration Word32)++instance Put (Decoration Word32) where+  put RelaxedPrecision         = put @Word32  0+  put (SpecId i)               = put @Word32  1 *> put i+  put Block                    = put @Word32  2+  --put BufferBlock              = put @Word32  3+  put RowMajor                 = put @Word32  4+  put ColMajor                 = put @Word32  5+  put (ArrayStride  i)         = put @Word32  6 *> put i+  put (MatrixStride i)         = put @Word32  7 *> put i+  put GLSLShared               = put @Word32  8+  put GLSLPacked               = put @Word32  9+  put CPacked                  = put @Word32 10+  put (Builtin builtin)        = put @Word32 11 *> put builtin+  --+  put NoPerspective            = put @Word32 13+  put Flat                     = put @Word32 14+  put Patch                    = put @Word32 15+  put Centroid                 = put @Word32 16+  put Sample                   = put @Word32 17+  put Invariant                = put @Word32 18+  put Restrict                 = put @Word32 19+  put Aliased                  = put @Word32 20+  put Volatile                 = put @Word32 21+  put Constant                 = put @Word32 22+  put Coherent                 = put @Word32 23+  put NonWritable              = put @Word32 24+  put NonReadable              = put @Word32 25+  put DynamicallyUniform       = put @Word32 26+  --+  put SaturatedConversion      = put @Word32 28+  put (Stream               i) = put @Word32 29 *> put i+  put (Location             i) = put @Word32 30 *> put i+  put (Component            i) = put @Word32 31 *> put i+  put (Index                i) = put @Word32 32 *> put i+  put (Binding              i) = put @Word32 33 *> put i+  put (DescriptorSet        i) = put @Word32 34 *> put i+  put (Offset               i) = put @Word32 35 *> put i+  put (XfbBuffer            i) = put @Word32 36 *> put i+  put (XfbStride            i) = put @Word32 37 *> put i+  --+  --+  --+  --+  put NoContraction            = put @Word32 42+  put (InputAttachmentIndex i) = put @Word32 43 *> put i+  put (Alignment            i) = put @Word32 44 *> put i++  wordCount (SpecId               _) = 2+  wordCount (ArrayStride          _) = 2+  wordCount (MatrixStride         _) = 2+  wordCount (Builtin              _) = 2+  wordCount (Stream               _) = 2+  wordCount (Location             _) = 2+  wordCount (Component            _) = 2+  wordCount (Index                _) = 2+  wordCount (Binding              _) = 2+  wordCount (DescriptorSet        _) = 2+  wordCount (Offset               _) = 2+  wordCount (XfbBuffer            _) = 2+  wordCount (XfbStride            _) = 2+  wordCount (InputAttachmentIndex _) = 2+  wordCount (Alignment            _) = 2+  wordCount _ = 1++instance Demotable (Decoration Nat) where+  type Demote (Decoration Nat) = Decoration Word32++instance Known (Decoration Nat) RelaxedPrecision where+  known = RelaxedPrecision+instance Known Nat i => Known (Decoration Nat) (SpecId i) where+  known = SpecId ( knownValue @i )+instance Known (Decoration Nat) Block where+  known = Block+--instance Known (Decoration Nat) BufferBlock where+--  known = BufferBlock+instance Known (Decoration Nat) RowMajor where+  known = RowMajor+instance Known (Decoration Nat) ColMajor where+  known = ColMajor+instance Known Nat i => Known (Decoration Nat) (ArrayStride i) where+  known = ArrayStride ( knownValue @i )+instance Known Nat i => Known (Decoration Nat) (MatrixStride i) where+  known = MatrixStride ( knownValue @i )+instance Known (Decoration Nat) GLSLShared where+  known = GLSLShared+instance Known (Decoration Nat) GLSLPacked where+  known = GLSLPacked+instance Known (Decoration Nat) CPacked where+  known = CPacked+instance Known Builtin.Builtin builtin => Known (Decoration Nat) (Builtin builtin) where+  known = Builtin ( knownValue @builtin )+instance Known (Decoration Nat) NoPerspective where+  known = NoPerspective+instance Known (Decoration Nat) Flat where+  known = Flat+instance Known (Decoration Nat) Patch where+  known = Patch+instance Known (Decoration Nat) Centroid where+  known = Centroid+instance Known (Decoration Nat) Sample where+  known = Sample+instance Known (Decoration Nat) Invariant where+  known = Invariant+instance Known (Decoration Nat) Restrict where+  known = Restrict+instance Known (Decoration Nat) Aliased where+  known = Aliased+instance Known (Decoration Nat) Volatile where+  known = Volatile+instance Known (Decoration Nat) Constant where+  known = Constant+instance Known (Decoration Nat) Coherent where+  known = Coherent+instance Known (Decoration Nat) NonWritable where+  known = NonWritable+instance Known (Decoration Nat) NonReadable where+  known = NonReadable+instance Known (Decoration Nat) DynamicallyUniform where+  known = DynamicallyUniform+instance Known (Decoration Nat) SaturatedConversion where+  known = SaturatedConversion+instance Known Nat i => Known (Decoration Nat) (Stream i) where+  known = Stream ( knownValue @i )+instance Known Nat i => Known (Decoration Nat) (Location i) where+  known = Location ( knownValue @i )+instance Known Nat i => Known (Decoration Nat) (Component i) where+  known = Component ( knownValue @i )+instance Known Nat i => Known (Decoration Nat) (Index i) where+  known = Index ( knownValue @i )+instance Known Nat i => Known (Decoration Nat) (Binding i) where+  known = Binding ( knownValue @i )+instance Known Nat i => Known (Decoration Nat) (DescriptorSet i) where+  known = DescriptorSet ( knownValue @i )+instance Known Nat i => Known (Decoration Nat) (Offset i) where+  known = Offset ( knownValue @i )+instance Known Nat i => Known (Decoration Nat) (XfbBuffer i) where+  known = XfbBuffer ( knownValue @i )+instance Known Nat i => Known (Decoration Nat) (XfbStride i) where+  known = XfbStride ( knownValue @i )+instance Known (Decoration Nat) NoContraction where+  known = NoContraction+instance Known Nat i => Known (Decoration Nat) (InputAttachmentIndex i) where+  known = InputAttachmentIndex ( knownValue @i )+instance Known Nat i => Known (Decoration Nat) (Alignment i) where+  known = Alignment ( knownValue @i )
+ src/SPIRV/ExecutionMode.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DerivingVia           #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}++{-|+Module: SPIRV.ExecutionMode++This module enumerates SPIR-V execution modes. These are used both at the type-level and value-level.++These annotate execution models / shader stages (see "SPIRV.Stage") with further information,+such as the geometry type to use in a tessellation shader (points, triangles, quads, isolines),+or the workgroup size in a compute shader.++See the SPIR-V specification §3.6 __Execution Modes__.++-}++module SPIRV.ExecutionMode where++-- base+import Data.Word+  ( Word32 )+import GHC.TypeNats+  ( Nat )++-- containers+import Data.Set+  ( Set )++-- fir+import Data.Binary.Class.Put+  ( Put(..) )+import Data.Type.Known+  ( Demotable(Demote), Known(known), knownValue )++--------------------------------------------------+-- execution modes++data ExecutionMode a+  = Invocations a+  | SpacingEqual+  | SpacingFractionalEven+  | SpacingFractionalOdd+  | VertexOrderCw+  | VertexOrderCcw+  | PixelCenterInteger+  | OriginUpperLeft+  | OriginLowerLeft+  | EarlyFragmentTests+  | PointMode+  | Xfb+  | DepthReplacing+  | DepthGreater+  | DepthLess+  | DepthUnchanged+  | LocalSize a a a+  | LocalSizeHint a a a+  | InputPoints+  | InputLines+  | InputLinesAdjacency+  | Triangles+  | InputTrianglesAdjacency+  | Quads+  | Isolines+  | OutputVertices a+  | OutputPoints+  | OutputLineStrip+  | OutputTriangleStrip+  | VecTypeHint a+  | ContractionOff+  -- custom information that does not align with the SPIR-V spec+  | MaxPatchVertices a+  deriving stock ( Show, Eq, Ord )++type InputVertices i = OutputVertices i+  -- synonym for providing number of input vertices for a tessellation evaluation shader++type ExecutionModes = Set (ExecutionMode Word32)++instance Put (ExecutionMode Word32) where+  put (Invocations i)         = put @Word32 0 *> put i+  put SpacingEqual            = put @Word32 1+  put SpacingFractionalEven   = put @Word32 2+  put SpacingFractionalOdd    = put @Word32 3+  put VertexOrderCw           = put @Word32 4+  put VertexOrderCcw          = put @Word32 5+  put PixelCenterInteger      = put @Word32 6+  put OriginUpperLeft         = put @Word32 7+  put OriginLowerLeft         = put @Word32 8+  put EarlyFragmentTests      = put @Word32 9+  put PointMode               = put @Word32 10+  put Xfb                     = put @Word32 11+  put DepthReplacing          = put @Word32 12+  put DepthGreater            = put @Word32 14+  put DepthLess               = put @Word32 15+  put DepthUnchanged          = put @Word32 16+  put (LocalSize     x y z)   = put @Word32 17 *> put x *> put y *> put z+  put (LocalSizeHint x y z)   = put @Word32 18 *> put x *> put y *> put z+  put InputPoints             = put @Word32 19+  put InputLines              = put @Word32 20+  put InputLinesAdjacency     = put @Word32 21+  put Triangles               = put @Word32 22+  put InputTrianglesAdjacency = put @Word32 23+  put Quads                   = put @Word32 24+  put Isolines                = put @Word32 25+  put (OutputVertices i)      = put @Word32 26 *> put i+  put OutputPoints            = put @Word32 27+  put OutputLineStrip         = put @Word32 28+  put OutputTriangleStrip     = put @Word32 29+  put (VecTypeHint i)         = put @Word32 30 *> put i+  put ContractionOff          = put @Word32 31+  put (MaxPatchVertices _)+    = error "Cannot put custom 'MaxPatchVertices' execution mode."++  wordCount Invocations      {} = 2+  wordCount LocalSize        {} = 4+  wordCount LocalSizeHint    {} = 4+  wordCount OutputVertices   {} = 2+  wordCount VecTypeHint      {} = 2+  wordCount MaxPatchVertices {} = error "Cannot compute size of custom 'MaxPatchVertices' execution mode."+  wordCount _                   = 1++instance Demotable (ExecutionMode Nat) where+  type Demote (ExecutionMode Nat) = ExecutionMode Word32++instance Known Nat i => Known (ExecutionMode Nat) (Invocations i) where+  known = Invocations ( knownValue @i )+instance Known (ExecutionMode Nat) SpacingEqual where+  known = SpacingEqual+instance Known (ExecutionMode Nat) SpacingFractionalEven where+  known = SpacingFractionalEven+instance Known (ExecutionMode Nat) SpacingFractionalOdd where+  known = SpacingFractionalOdd+instance Known (ExecutionMode Nat) VertexOrderCw where+  known = VertexOrderCw+instance Known (ExecutionMode Nat) VertexOrderCcw where+  known = VertexOrderCcw+instance Known (ExecutionMode Nat) PixelCenterInteger where+  known = PixelCenterInteger+instance Known (ExecutionMode Nat) OriginUpperLeft where+  known = OriginUpperLeft+instance Known (ExecutionMode Nat) OriginLowerLeft where+  known = OriginLowerLeft+instance Known (ExecutionMode Nat) EarlyFragmentTests where+  known = EarlyFragmentTests+instance Known (ExecutionMode Nat) PointMode where+  known = PointMode+instance Known (ExecutionMode Nat) Xfb where+  known = Xfb+instance Known (ExecutionMode Nat) DepthReplacing where+  known = DepthReplacing+instance Known (ExecutionMode Nat) DepthGreater where+  known = DepthGreater+instance Known (ExecutionMode Nat) DepthLess where+  known = DepthLess+instance Known (ExecutionMode Nat) DepthUnchanged where+  known = DepthUnchanged+instance (Known Nat x, Known Nat y, Known Nat z)+        => Known (ExecutionMode Nat) (LocalSize x y z) where+  known = LocalSize+                    ( knownValue @x )+                    ( knownValue @y )+                    ( knownValue @z )+instance (Known Nat x, Known Nat y, Known Nat z)+        => Known (ExecutionMode Nat) (LocalSizeHint x y z) where+  known = LocalSizeHint+                    ( knownValue @x )+                    ( knownValue @y )+                    ( knownValue @z )+instance Known (ExecutionMode Nat) InputPoints where+  known = InputPoints+instance Known (ExecutionMode Nat) InputLines where+  known = InputLines+instance Known (ExecutionMode Nat) InputLinesAdjacency where+  known = InputLinesAdjacency+instance Known (ExecutionMode Nat) Triangles where+  known = Triangles+instance Known (ExecutionMode Nat) InputTrianglesAdjacency where+  known = InputTrianglesAdjacency+instance Known (ExecutionMode Nat) Quads where+  known = Quads+instance Known (ExecutionMode Nat) Isolines where+  known = Isolines+instance Known Nat i => Known (ExecutionMode Nat) (OutputVertices i) where+  known = OutputVertices ( knownValue @i )+instance Known (ExecutionMode Nat) OutputPoints where+  known = OutputPoints+instance Known (ExecutionMode Nat) OutputLineStrip where+  known = OutputLineStrip+instance Known (ExecutionMode Nat) OutputTriangleStrip where+  known = OutputTriangleStrip+instance Known Nat i => Known (ExecutionMode Nat) (VecTypeHint i) where+  known = VecTypeHint ( knownValue @i )+instance Known (ExecutionMode Nat) ContractionOff where+  known = ContractionOff+instance Known Nat i => Known (ExecutionMode Nat) (MaxPatchVertices i) where+  known = MaxPatchVertices ( knownValue @i )
+ src/SPIRV/Extension.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE DeriveLift                 #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE PatternSynonyms            #-}++{-|+Module: SPIRV.Extension++This module enumerates SPIR-V extensions as well as extended instruction sets.+These are used only at the value level.++See SPIR-V specification §2.10 __Extended Instruction Sets__,+as well as the SPIR-V registry for a complete list of SPIR-V extensions.++-}++module SPIRV.Extension where++-- template-haskell+import Language.Haskell.TH.Syntax+  ( Lift )++-- text-short+import Data.Text.Short+  ( ShortText )++-- fir+import Instances.TH.Lift+  ( ) -- Lift instance for ShortText+import Data.Binary.Class.Put+  ( Put )++--------------------------------------------------+-- extended instruction sets++data ExtInst+  = OpenCL+  | GLSL+  | DebugPrintf+  deriving stock ( Show, Eq, Ord, Enum, Bounded )++extInstName :: ExtInst -> ShortText+extInstName OpenCL      = "OpenCL.std"+extInstName GLSL        = "GLSL.std.450"+extInstName DebugPrintf = "NonSemantic.DebugPrintf"++--------------------------------------------------+-- extensions++newtype Extension = Extension ShortText+  deriving newtype ( Eq, Ord, Put )+  deriving stock   ( Show, Lift )++pattern SPV_AMD_shader_explicit_vertex_parameter :: Extension+pattern SPV_AMD_shader_explicit_vertex_parameter = Extension "SPV_AMD_shader_explicit_vertex_parameter"+pattern SPV_AMD_shader_trinary_minmax :: Extension+pattern SPV_AMD_shader_trinary_minmax = Extension "SPV_AMD_shader_trinary_minmax"+pattern SPV_AMD_gcn_shader :: Extension+pattern SPV_AMD_gcn_shader = Extension "SPV_AMD_gcn_shader"+pattern SPV_KHR_shader_ballot :: Extension+pattern SPV_KHR_shader_ballot = Extension "SPV_KHR_shader_ballot"+pattern SPV_AMD_shader_ballot :: Extension+pattern SPV_AMD_shader_ballot = Extension "SPV_AMD_shader_ballot"+pattern SPV_AMD_gpu_shader_half_float :: Extension+pattern SPV_AMD_gpu_shader_half_float = Extension "SPV_AMD_gpu_shader_half_float"+pattern SPV_KHR_shader_draw_parameters :: Extension+pattern SPV_KHR_shader_draw_parameters = Extension "SPV_KHR_shader_draw_parameters"+pattern SPV_KHR_subgroup_vote :: Extension+pattern SPV_KHR_subgroup_vote = Extension "SPV_KHR_subgroup_vote"+pattern SPV_KHR_16bit_storage :: Extension+pattern SPV_KHR_16bit_storage = Extension "SPV_KHR_16bit_storage"+pattern SPV_KHR_device_group :: Extension+pattern SPV_KHR_device_group = Extension "SPV_KHR_device_group"+pattern SPV_KHR_multiview :: Extension+pattern SPV_KHR_multiview = Extension "SPV_KHR_multiview"+pattern SPV_NVX_multiview_per_view_attributes :: Extension+pattern SPV_NVX_multiview_per_view_attributes = Extension "SPV_NVX_multiview_per_view_attributes"+pattern SPV_NV_viewport_array2 :: Extension+pattern SPV_NV_viewport_array2 = Extension "SPV_NV_viewport_array2"+pattern SPV_NV_stereo_view_rendering :: Extension+pattern SPV_NV_stereo_view_rendering = Extension "SPV_NV_stereo_view_rendering"+pattern SPV_NV_sample_mask_override_coverage :: Extension+pattern SPV_NV_sample_mask_override_coverage = Extension "SPV_NV_sample_mask_override_coverage"+pattern SPV_NV_geometry_shader_passthrough :: Extension+pattern SPV_NV_geometry_shader_passthrough = Extension "SPV_NV_geometry_shader_passthrough"+pattern SPV_AMD_texture_gather_bias_lod :: Extension+pattern SPV_AMD_texture_gather_bias_lod = Extension "SPV_AMD_texture_gather_bias_lod"+pattern SPV_KHR_storage_buffer_storage_class :: Extension+pattern SPV_KHR_storage_buffer_storage_class = Extension "SPV_KHR_storage_buffer_storage_class"+pattern SPV_KHR_variable_pointers :: Extension+pattern SPV_KHR_variable_pointers = Extension "SPV_KHR_variable_pointers"+pattern SPV_AMD_gpu_shader_int16 :: Extension+pattern SPV_AMD_gpu_shader_int16 = Extension "SPV_AMD_gpu_shader_int16"+pattern SPV_KHR_post_depth_coverage :: Extension+pattern SPV_KHR_post_depth_coverage = Extension "SPV_KHR_post_depth_coverage"+pattern SPV_KHR_shader_atomic_counter_ops :: Extension+pattern SPV_KHR_shader_atomic_counter_ops = Extension "SPV_KHR_shader_atomic_counter_ops"+pattern SPV_EXT_shader_stencil_export :: Extension+pattern SPV_EXT_shader_stencil_export = Extension "SPV_EXT_shader_stencil_export"+pattern SPV_EXT_shader_viewport_index_layer :: Extension+pattern SPV_EXT_shader_viewport_index_layer = Extension "SPV_EXT_shader_viewport_index_layer"+pattern SPV_AMD_shader_image_load_store_lod :: Extension+pattern SPV_AMD_shader_image_load_store_lod = Extension "SPV_AMD_shader_image_load_store_lod"+pattern SPV_AMD_shader_fragment_mask :: Extension+pattern SPV_AMD_shader_fragment_mask = Extension "SPV_AMD_shader_fragment_mask"+pattern SPV_EXT_fragment_fully_covered :: Extension+pattern SPV_EXT_fragment_fully_covered = Extension "SPV_EXT_fragment_fully_covered"+pattern SPV_AMD_gpu_shader_half_float_fetch :: Extension+pattern SPV_AMD_gpu_shader_half_float_fetch = Extension "SPV_AMD_gpu_shader_half_float_fetch"+pattern SPV_GOOGLE_decorate_string :: Extension+pattern SPV_GOOGLE_decorate_string = Extension "SPV_GOOGLE_decorate_string"+pattern SPV_GOOGLE_hlsl_functionality1 :: Extension+pattern SPV_GOOGLE_hlsl_functionality1 = Extension "SPV_GOOGLE_hlsl_functionality1"+pattern SPV_NV_shader_subgroup_partitioned :: Extension+pattern SPV_NV_shader_subgroup_partitioned = Extension "SPV_NV_shader_subgroup_partitioned"+pattern SPV_EXT_descriptor_indexing :: Extension+pattern SPV_EXT_descriptor_indexing = Extension "SPV_EXT_descriptor_indexing"+pattern SPV_KHR_8bit_storage :: Extension+pattern SPV_KHR_8bit_storage = Extension "SPV_KHR_8bit_storage"+pattern SPV_KHR_vulkan_memory_model :: Extension+pattern SPV_KHR_vulkan_memory_model = Extension "SPV_KHR_vulkan_memory_model"+pattern SPV_NV_ray_tracing :: Extension+pattern SPV_NV_ray_tracing = Extension "SPV_NV_ray_tracing"+pattern SPV_NV_compute_shader_derivatives :: Extension+pattern SPV_NV_compute_shader_derivatives = Extension "SPV_NV_compute_shader_derivatives"+pattern SPV_NV_fragment_shader_barycentric :: Extension+pattern SPV_NV_fragment_shader_barycentric = Extension "SPV_NV_fragment_shader_barycentric"+pattern SPV_NV_mesh_shader :: Extension+pattern SPV_NV_mesh_shader = Extension "SPV_NV_mesh_shader"+pattern SPV_NV_shader_image_footprint :: Extension+pattern SPV_NV_shader_image_footprint = Extension "SPV_NV_shader_image_footprint"+pattern SPV_NV_shading_rate :: Extension+pattern SPV_NV_shading_rate = Extension "SPV_NV_shading_rate"+pattern SPV_INTEL_subgroups :: Extension+pattern SPV_INTEL_subgroups = Extension "SPV_INTEL_subgroups"+pattern SPV_INTEL_media_block_io :: Extension+pattern SPV_INTEL_media_block_io = Extension "SPV_INTEL_media_block_io"+pattern SPV_INTEL_device_side_avc_motion_estimation :: Extension+pattern SPV_INTEL_device_side_avc_motion_estimation = Extension "SPV_INTEL_device_side_avc_motion_estimation"+pattern SPV_EXT_fragment_invocation_density :: Extension+pattern SPV_EXT_fragment_invocation_density = Extension "SPV_EXT_fragment_invocation_density"+pattern SPV_KHR_no_integer_wrap_decoration :: Extension+pattern SPV_KHR_no_integer_wrap_decoration = Extension "SPV_KHR_no_integer_wrap_decoration"+pattern SPV_KHR_float_controls :: Extension+pattern SPV_KHR_float_controls = Extension "SPV_KHR_float_controls"+pattern SPV_EXT_physical_storage_buffer :: Extension+pattern SPV_EXT_physical_storage_buffer = Extension "SPV_EXT_physical_storage_buffer"+pattern SPV_INTEL_fpga_memory_attributes :: Extension+pattern SPV_INTEL_fpga_memory_attributes = Extension "SPV_INTEL_fpga_memory_attributes"+pattern SPV_NV_cooperative_matrix :: Extension+pattern SPV_NV_cooperative_matrix = Extension "SPV_NV_cooperative_matrix"+pattern SPV_INTEL_shader_integer_functions2 :: Extension+pattern SPV_INTEL_shader_integer_functions2 = Extension "SPV_INTEL_shader_integer_functions2"+pattern SPV_INTEL_fpga_loop_controls :: Extension+pattern SPV_INTEL_fpga_loop_controls = Extension "SPV_INTEL_fpga_loop_controls"+pattern SPV_EXT_fragment_shader_interlock :: Extension+pattern SPV_EXT_fragment_shader_interlock = Extension "SPV_EXT_fragment_shader_interlock"+pattern SPV_NV_shader_sm_builtins :: Extension+pattern SPV_NV_shader_sm_builtins = Extension "SPV_NV_shader_sm_builtins"+pattern SPV_KHR_shader_clock :: Extension+pattern SPV_KHR_shader_clock = Extension "SPV_KHR_shader_clock"+pattern SPV_INTEL_unstructured_loop_controls :: Extension+pattern SPV_INTEL_unstructured_loop_controls = Extension "SPV_INTEL_unstructured_loop_controls"+pattern SPV_EXT_demote_to_helper_invocation :: Extension+pattern SPV_EXT_demote_to_helper_invocation = Extension "SPV_EXT_demote_to_helper_invocation"+pattern SPV_INTEL_fpga_reg :: Extension+pattern SPV_INTEL_fpga_reg = Extension "SPV_INTEL_fpga_reg"+pattern SPV_INTEL_blocking_pipes :: Extension+pattern SPV_INTEL_blocking_pipes = Extension "SPV_INTEL_blocking_pipes"+pattern SPV_KHR_physical_storage_buffer :: Extension+pattern SPV_KHR_physical_storage_buffer = Extension "SPV_KHR_physical_storage_buffer"+pattern SPV_KHR_non_semantic_info :: Extension+pattern SPV_KHR_non_semantic_info = Extension "SPV_KHR_non_semantic_info"+pattern SPV_KHR_ray_tracing :: Extension+pattern SPV_KHR_ray_tracing = Extension "SPV_KHR_ray_tracing"+pattern SPV_KHR_ray_query :: Extension+pattern SPV_KHR_ray_query = Extension "SPV_KHR_ray_query"+pattern SPV_KHR_bit_instructions :: Extension+pattern SPV_KHR_bit_instructions = Extension "SPV_KHR_bit_instructions"+pattern SPV_EXT_shader_atomic_float_add :: Extension+pattern SPV_EXT_shader_atomic_float_add = Extension "SPV_EXT_shader_atomic_float_add"+pattern SPV_EXT_shader_atomic_float16_add :: Extension+pattern SPV_EXT_shader_atomic_float16_add = Extension "SPV_EXT_shader_atomic_float16_add"+pattern SPV_EXT_shader_atomic_float_min_max :: Extension+pattern SPV_EXT_shader_atomic_float_min_max = Extension "SPV_EXT_shader_atomic_float_min_max"
+ src/SPIRV/Groups.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DerivingVia           #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-|+Module: SPIRV.Groups++This module defines @SPIR-V@ group operations.+-}++module SPIRV.Groups+  ( GroupOperation(..)+  , groupOperationToWord32+  ) where++-- base+import Data.Word+  ( Word32 )++-- fir+import Data.Binary.Class.Put+  ( Put(..), PutWord32Enum(..) )+import Data.Type.Known+  ( Demotable(Demote), Known(known) )  ++-------------------------------------------------------------------------------++data GroupOperation+  = Reduce+  | InclusiveScan+  | ExclusiveScan+  | ClusteredReduce+  deriving stock ( Show, Eq, Ord, Enum )+  deriving Put via ( PutWord32Enum GroupOperation )++groupOperationToWord32 :: GroupOperation -> Word32+groupOperationToWord32 = fromIntegral . fromEnum++instance Demotable GroupOperation where+  type Demote GroupOperation = GroupOperation++instance Known GroupOperation 'Reduce where+  known = Reduce+instance Known GroupOperation 'InclusiveScan where+  known = InclusiveScan+instance Known GroupOperation 'ExclusiveScan where+  known = ExclusiveScan+instance Known GroupOperation 'ClusteredReduce where+  known = ClusteredReduce
+ src/SPIRV/Image.hs view
@@ -0,0 +1,437 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DerivingVia           #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{-|+Module: SPIRV.Image++SPIR-V image properties, image formats, and image operand names.++See "FIR.Prim.Image" for their use within this library.++-}++module SPIRV.Image where++-- base+import Prelude hiding+  ( Integral, Floating )+import Data.Word+  ( Word32 )+import GHC.TypeLits+  ( TypeError, ErrorMessage(..) )+import GHC.TypeNats+  ( Nat )++-- fir+import Data.Binary.Class.Put+  ( Put(..), PutWord32Enum(..) )+import Data.Type.Known+  ( Demotable(Demote), Known(known), knownValue )+import Data.Type.List+  ( Length )+import SPIRV.ScalarTy+  ( ScalarTy, Signedness(..) )++--------------------------------------------------++data Image+  = Image+      { texelComponent :: ScalarTy -- called the 'Sampled type' in SPIR-V+      , dimensionality :: Dimensionality+      , hasDepth       :: Maybe HasDepth+      , arrayness      :: Arrayness+      , multiSampling  :: MultiSampling+      , imageUsage     :: Maybe ImageUsage+      , imageFormat    :: Maybe (ImageFormat Word32)+      }+  deriving stock ( Eq, Show, Ord )++data Dimensionality+  = OneD+  | TwoD+  | ThreeD+  | Cube+  | Rect+  | Buffer+  | SubpassData+  deriving stock ( Eq, Show, Ord, Enum, Bounded )+  deriving Put via ( PutWord32Enum Dimensionality )++instance Demotable Dimensionality where+  type Demote Dimensionality = Dimensionality+instance Known Dimensionality 'OneD where+  known = OneD+instance Known Dimensionality 'TwoD where+  known = TwoD+instance Known Dimensionality 'ThreeD where+  known = ThreeD+instance Known Dimensionality 'Cube where+  known = Cube+instance Known Dimensionality 'Rect where+  known = Rect+instance Known Dimensionality 'Buffer where+  known = Buffer+instance Known Dimensionality 'SubpassData where+  known = SubpassData++data HasDepth+  = NotDepthImage+  | DepthImage+  deriving stock ( Eq, Show, Ord, Enum, Bounded )+  deriving Put via (PutWord32Enum HasDepth)++instance Demotable HasDepth where+  type Demote HasDepth = HasDepth+instance Known HasDepth NotDepthImage where+  known = NotDepthImage+instance Known HasDepth DepthImage where+  known = DepthImage++instance Put (Maybe HasDepth) where+  put (Just d) = put         d+  put Nothing  = put @Word32 2+  wordCount _ = 1++data Arrayness+  = NonArrayed+  | Arrayed+  deriving stock ( Eq, Show, Ord, Enum, Bounded )+  deriving Put via (PutWord32Enum Arrayness)++instance Demotable Arrayness where+  type Demote Arrayness = Arrayness+instance Known Arrayness 'NonArrayed where+  known = NonArrayed+instance Known Arrayness 'Arrayed where+  known = Arrayed++data MultiSampling+  = SingleSampled+  | MultiSampled+  deriving stock ( Eq, Show, Ord, Enum, Bounded )+  deriving Put via (PutWord32Enum MultiSampling)++instance Demotable MultiSampling where+  type Demote MultiSampling = MultiSampling+instance Known MultiSampling 'SingleSampled where+  known = SingleSampled+instance Known MultiSampling 'MultiSampled where+  known = MultiSampled++data ImageUsage+  = Sampled+  | Storage+  deriving stock ( Eq, Show, Ord, Enum, Bounded )++instance Put (Maybe ImageUsage) where+  put Nothing        = put @Word32 0+  put (Just Sampled) = put @Word32 1+  put (Just Storage) = put @Word32 2+  wordCount _ = 1++instance Demotable ImageUsage where+  type Demote ImageUsage = ImageUsage+instance Known ImageUsage 'Sampled where+  known = Sampled+instance Known ImageUsage 'Storage where+  known = Storage++data Normalisation+  = Unnormalised+  | Normalised+  deriving stock ( Eq, Show, Ord, Enum, Bounded )+  deriving Put via (PutWord32Enum Normalisation)++instance Demotable Normalisation where+  type Demote Normalisation = Normalisation+instance Known Normalisation Unnormalised where+  known = Unnormalised+instance Known Normalisation Normalised where+  known = Normalised++data Component+  = Integer Normalisation Signedness+  | Floating+  deriving stock ( Eq, Show, Ord )++instance Demotable Component where+  type Demote Component = Component+instance ( Known Normalisation norm+         , Known Signedness    sign+         ) +      => Known Component ('Integer norm sign)+      where+  known = Integer (knownValue @norm) (knownValue @sign)+instance Known Component 'Floating where+  known = Floating++pattern SNorm :: Component+pattern SNorm = Integer Normalised Signed+type SNorm = ( 'Integer 'Normalised 'Signed :: Component )++pattern UNorm :: Component+pattern UNorm = Integer Normalised Unsigned+type UNorm = ( 'Integer 'Normalised 'Unsigned :: Component )++pattern F :: Component+pattern F = Floating+type F = ( 'Floating :: Component )++pattern I :: Component+pattern I = Integer Unnormalised Signed+type I = ( 'Integer 'Unnormalised 'Signed :: Component )++pattern UI :: Component+pattern UI = Integer Unnormalised Unsigned+type UI = ( 'Integer 'Unnormalised 'Unsigned :: Component )++data ImageFormat a+  = ImageFormat Component [a]+  deriving stock ( Eq, Show, Ord )++type family ImageFormatDimension ( fmt :: ImageFormat Nat ) :: Nat where+  ImageFormatDimension ( 'ImageFormat _ comps ) = Length comps++pattern RGBA32 :: Component -> ImageFormat Word32+pattern RGBA32 component = ImageFormat component [32,32,32,32]+type family RGBA32 (component :: Component) :: ImageFormat Nat where+  RGBA32 SNorm = TypeError ( Text "RGBA32 format cannot use normalised integers." )+  RGBA32 UNorm = TypeError ( Text "RGBA32 format cannot use normalised integers." )+  RGBA32 comp  = 'ImageFormat comp '[32,32,32,32] ++pattern RGBA16 :: Component -> ImageFormat Word32+pattern RGBA16 component = ImageFormat component [16,16,16,16]+type RGBA16 (component :: Component) = ( 'ImageFormat component '[16,16,16,16] :: ImageFormat Nat )++pattern RGBA8 :: Component -> ImageFormat Word32+pattern RGBA8 component = ImageFormat component [8,8,8,8]+type family RGBA8 (component :: Component) :: ImageFormat Nat where+  RGBA8 F    = TypeError ( Text "RGBA8 format cannot use floating-point numbers." )+  RGBA8 comp = 'ImageFormat comp '[8,8,8,8]++pattern RG32 :: Component -> ImageFormat Word32+pattern RG32 component = ImageFormat component [32,32]+type family RG32 (component :: Component) :: ImageFormat Nat where+  RG32 SNorm = TypeError ( Text "RG32 format cannot use normalised integers." )+  RG32 UNorm = TypeError ( Text "RG32 format cannot use normalised integers." )+  RG32 comp  = 'ImageFormat comp '[32,32] ++pattern RG16 :: Component -> ImageFormat Word32+pattern RG16 component = ImageFormat component [16,16]+type RG16 (component :: Component) = ( 'ImageFormat component '[16,16] :: ImageFormat Nat )++pattern RG8 :: Component -> ImageFormat Word32+pattern RG8 component = ImageFormat component [8,8]+type family RG8 (component :: Component) :: ImageFormat Nat where+  RG8 F    = TypeError ( Text "RG8 format cannot use floating-point numbers." )+  RG8 comp = 'ImageFormat comp '[8,8]++pattern R32 :: Component -> ImageFormat Word32+pattern R32 component = ImageFormat component [32]+type family R32 (component :: Component) :: ImageFormat Nat where+  R32 SNorm = TypeError ( Text "R32 format cannot use normalised integers." )+  R32 UNorm = TypeError ( Text "R32 format cannot use normalised integers." )+  R32 comp  = 'ImageFormat comp '[32] ++pattern R16 :: Component -> ImageFormat Word32+pattern R16 component = ImageFormat component [16]+type R16 (component :: Component) = ( 'ImageFormat component '[16] :: ImageFormat Nat )++pattern R8 :: Component -> ImageFormat Word32+pattern R8 component = ImageFormat component [8]+type family R8 (component :: Component) :: ImageFormat Nat where+  R8 F    = TypeError ( Text "R8 format cannot use floating-point numbers." )+  R8 comp = 'ImageFormat comp '[8]++pattern R11G11B10 :: Component -> ImageFormat Word32+pattern R11G11B10 component = ImageFormat component [11,11,10]+type family R11G11B10 (component :: Component) :: ImageFormat Nat where+  R11G11B10 F    = 'ImageFormat F '[11,11,10]+  R11G11B10 comp = TypeError ( Text "R11G11B10 format must use floating-point numbers." )++pattern RGB10A2 :: Component -> ImageFormat Word32+pattern RGB10A2 component = ImageFormat component [10,10,10,2]+type family RGB10A2 (component :: Component) :: ImageFormat Nat where+  RGB10A2 UI    = 'ImageFormat UI    '[10,10,10,2]+  RGB10A2 UNorm = 'ImageFormat UNorm '[10,10,10,2]+  RGB10A2 comp  = TypeError ( Text "RGB10A2 format must use unsigned integers." )++instance Demotable (ImageFormat Nat) where+  type Demote (ImageFormat Nat) = ImageFormat Word32+instance ( Known Component comp+         , Known [Nat] sizes+         )+       => Known (ImageFormat Nat) ('ImageFormat comp sizes)+     where+  known = ImageFormat (knownValue @comp) (knownValue @sizes)+++type family RequiredFormatUsage ( fmt :: ImageFormat Nat ) :: Maybe ImageUsage where+  RequiredFormatUsage ('ImageFormat _                       '[8,8,8,8]) = Nothing+  RequiredFormatUsage ('ImageFormat ('Integer Normalised _) '[_,_,_,_]) = Just Storage+  RequiredFormatUsage ('ImageFormat _                       '[i,_,_,i]) = Nothing+  RequiredFormatUsage ('ImageFormat _                       '[32]     ) = Nothing+  RequiredFormatUsage ('ImageFormat _                       '[_ ]     ) = Just Storage+  RequiredFormatUsage _                                                 = Just Storage++requiredFormatUsage :: ImageFormat Word32 -> Maybe ImageUsage+requiredFormatUsage (ImageFormat _                      [8,8,8,8]) = Nothing+requiredFormatUsage (ImageFormat (Integer Normalised _) [_,_,_,_]) = Just Storage+requiredFormatUsage (ImageFormat _                      [i,_,_,l])+                                                      | i == l     = Nothing+requiredFormatUsage (ImageFormat _                      [32]     ) = Nothing+requiredFormatUsage (ImageFormat _                      [_ ]     ) = Just Storage+requiredFormatUsage _                                              = Just Storage+++fromFormat :: ImageFormat Word32 -> Maybe Word32+fromFormat ( RGBA32    F     ) = Just  1+fromFormat ( RGBA16    F     ) = Just  2+fromFormat ( R32       F     ) = Just  3+fromFormat ( RGBA8     UNorm ) = Just  4+fromFormat ( RGBA8     SNorm ) = Just  5+fromFormat ( RG32      F     ) = Just  6+fromFormat ( RG16      F     ) = Just  7+fromFormat ( R11G11B10 F     ) = Just  8+fromFormat ( R16       F     ) = Just  9+fromFormat ( RGBA16    UNorm ) = Just 10+fromFormat ( RGB10A2   UNorm ) = Just 11+fromFormat ( RG16      UNorm ) = Just 12+fromFormat ( RG8       UNorm ) = Just 13+fromFormat ( R16       UNorm ) = Just 14+fromFormat ( R8        UNorm ) = Just 15+fromFormat ( RGBA16    SNorm ) = Just 16+fromFormat ( RG16      SNorm ) = Just 17+fromFormat ( RG8       SNorm ) = Just 18+fromFormat ( R16       SNorm ) = Just 19+fromFormat ( R8        SNorm ) = Just 20+fromFormat ( RGBA32    I     ) = Just 21+fromFormat ( RGBA16    I     ) = Just 22+fromFormat ( RGBA8     I     ) = Just 23+fromFormat ( R32       I     ) = Just 24+fromFormat ( RG32      I     ) = Just 25+fromFormat ( RG16      I     ) = Just 26+fromFormat ( RG8       I     ) = Just 27+fromFormat ( R16       I     ) = Just 28+fromFormat ( R8        I     ) = Just 29+fromFormat ( RGBA32    UI    ) = Just 30+fromFormat ( RGBA16    UI    ) = Just 31+fromFormat ( RGBA8     UI    ) = Just 32+fromFormat ( R32       UI    ) = Just 33+fromFormat ( RGB10A2   UI    ) = Just 34+fromFormat ( RG32      UI    ) = Just 35+fromFormat ( RG16      UI    ) = Just 36+fromFormat ( RG8       UI    ) = Just 37+fromFormat ( R16       UI    ) = Just 38+fromFormat ( R8        UI    ) = Just 39+fromFormat _                   = Nothing++instance Put (ImageFormat Word32) where+  put format = case fromFormat format of+    Just i  -> put         i+    Nothing -> put @Word32 0+  wordCount _ = 1++instance Put (Maybe (ImageFormat Word32)) where+  put (Just format) = put         format+  put Nothing       = put @Word32 0+  wordCount _ = 1++data SamplerAddressing+  = ClampToEdge+  | Clamp+  | Repeat+  | RepeatMirrored+  deriving stock ( Show, Eq, Ord, Enum, Bounded )++instance Put SamplerAddressing where+  put = put @Word32 . fromIntegral . succ . fromEnum+  wordCount _ = 1++instance Put (Maybe SamplerAddressing) where+  put (Just addr) = put         addr+  put Nothing     = put @Word32 0+  wordCount _ = 1++data FilterMode+  = Nearest+  | Linear+  deriving stock ( Show, Eq, Ord, Enum, Bounded )+  deriving Put via (PutWord32Enum FilterMode)++instance Demotable SamplerAddressing where+  type Demote SamplerAddressing = SamplerAddressing+instance Known SamplerAddressing ClampToEdge where+  known = ClampToEdge+instance Known SamplerAddressing Clamp where+  known = Clamp+instance Known SamplerAddressing Repeat where+  known = Repeat+instance Known SamplerAddressing RepeatMirrored   where+  known = RepeatMirrored++instance Demotable FilterMode where+  type Demote FilterMode = FilterMode+instance Known FilterMode Nearest where+  known = Nearest+instance Known FilterMode Linear where+  known = Linear++data DepthTesting+  = NoDepthTest+  | DepthTest+  deriving stock ( Show, Eq, Ord, Enum, Bounded )++instance Demotable DepthTesting where+  type Demote DepthTesting = DepthTesting+instance Known DepthTesting NoDepthTest where+  known = NoDepthTest+instance Known DepthTesting DepthTest where+  known = DepthTest++data Projection+  = Affine+  | Projective+  deriving stock ( Show, Eq, Ord, Enum, Bounded )++instance Demotable Projection where+  type Demote Projection = Projection+instance Known Projection Affine where+  known = Affine+instance Known Projection Projective where+  known = Projective++data LODOperand+  = Bias+  | LOD+  | Grad+  | MinLOD+  deriving stock ( Show, Eq, Ord )++data Operand+  = LODOperand LODOperand+  | ConstOffset+  | Offset+  | ConstOffsets+  | Sample+  deriving stock ( Show, Eq, Ord )++operandBit :: Operand -> Word32+operandBit (LODOperand Bias )   = 0x01+operandBit (LODOperand LOD  )   = 0x02+operandBit (LODOperand Grad )   = 0x04+operandBit ConstOffset          = 0x08+operandBit Offset               = 0x10+operandBit ConstOffsets         = 0x20+operandBit Sample               = 0x40+operandBit (LODOperand MinLOD ) = 0x80
+ src/SPIRV/Layout.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DerivingStrategies #-}++{-|+Module: SPIRV.Layout++This module describes how types are laid out in memory.++Values have logical types, which carry no layout information.+Memory can impose a layout on the types it contains: for instance,+a structure in a storage buffer must specify the offsets of its members.+In SPIR-V, the same logical type with different layouts gives different types,+which are declared with different decorations.++-}++module SPIRV.Layout+  ( LayoutRules(..)+  , BlockKind(..)+  , Layout(..), logical+  ) where++--------------------------------------------------++-- | Rules for explicitly laying out types in memory.+data LayoutRules+  = BaseAlignment     -- ^ Used for storage buffers, push constants and shader record buffers.+  | ExtendedAlignment -- ^ Used for uniform buffers.+  deriving stock ( Show, Eq, Ord )++-- | The kind of an interface block.+data BlockKind+  = UserBlock    -- ^ A block declared by the user.+  | BuiltinBlock -- ^ A block of built-in variables, such as @gl_PerVertex@.+  deriving stock ( Show, Eq, Ord )++-- | How a type is laid out in memory.+data Layout+  = Layout+  { layoutRules :: Maybe LayoutRules+    -- ^ Rules for explicit offsets and strides, if any.+  , blockKind   :: Maybe BlockKind+    -- ^ Whether the type is an interface block (or an array of interface blocks).+  }+  deriving stock ( Show, Eq, Ord )++-- | The layout of values: no explicit offsets or strides, and not an interface block.+logical :: Layout+logical = Layout { layoutRules = Nothing, blockKind = Nothing }
+ src/SPIRV/Operation.hs view
@@ -0,0 +1,1265 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE PatternSynonyms    #-}++{-|+Module: SPIRV.Operation++Raw SPIR-V OpCodes. Used only at the value-level.++See "SPIRV.PrimOp" which categorises operations.++-}++module SPIRV.Operation where++-- base+import Data.Word+  ( Word16, Word32 )++-- fir+import SPIRV.Extension+  ( ExtInst(GLSL, OpenCL) )+import qualified SPIRV.Extension+  ( ExtInst(DebugPrintf) )++--------------------------------------------------+-- operation data type++data Operation+  = Code Word16+  | ExtCode ExtInst Word32+  deriving stock Eq++instance Show Operation where+  show op@(Code _) = showOperation op+  show op@(ExtCode ext _) = "Ext(" ++ show ext ++") " ++ showOperation op++--------------------------------------------------+-- operations++pattern Nop   :: Operation+pattern Nop   = Code 0+pattern Undef :: Operation+pattern Undef = Code 1+-- (optional) annotations+pattern SourceContinued :: Operation+pattern SourceContinued = Code 2+pattern Source          :: Operation+pattern Source          = Code 3+pattern SourceExtension :: Operation+pattern SourceExtension = Code 4+pattern Name            :: Operation+pattern Name            = Code 5+pattern MemberName      :: Operation+pattern MemberName      = Code 6+pattern String          :: Operation+pattern String          = Code 7+pattern Line            :: Operation+pattern Line            = Code 8+-- no 9+-- extensions+pattern Extension     :: Operation+pattern Extension     = Code 10+pattern ExtInstImport :: Operation+pattern ExtInstImport = Code 11+pattern ExtInst      :: Operation+pattern ExtInst      = Code 12+-- no 13+pattern MemoryModel   :: Operation+pattern MemoryModel   = Code 14+pattern EntryPoint    :: Operation+pattern EntryPoint    = Code 15+pattern ExecutionMode :: Operation+pattern ExecutionMode = Code 16+pattern Capability    :: Operation+pattern Capability    = Code 17+-- no 18+-- type constructors+pattern TypeVoid           :: Operation+pattern TypeVoid           = Code 19+pattern TypeBool           :: Operation+pattern TypeBool           = Code 20+pattern TypeInt            :: Operation+pattern TypeInt            = Code 21+pattern TypeFloat          :: Operation+pattern TypeFloat          = Code 22+pattern TypeVector         :: Operation+pattern TypeVector         = Code 23+pattern TypeMatrix         :: Operation+pattern TypeMatrix         = Code 24+pattern TypeImage          :: Operation+pattern TypeImage          = Code 25+pattern TypeSampler        :: Operation+pattern TypeSampler        = Code 26+pattern TypeSampledImage   :: Operation+pattern TypeSampledImage   = Code 27+pattern TypeArray          :: Operation+pattern TypeArray          = Code 28+pattern TypeRuntimeArray   :: Operation+pattern TypeRuntimeArray   = Code 29+pattern TypeStruct         :: Operation+pattern TypeStruct         = Code 30+pattern TypeOpaque         :: Operation+pattern TypeOpaque         = Code 31+pattern TypePointer        :: Operation+pattern TypePointer        = Code 32+pattern TypeFunction       :: Operation+pattern TypeFunction       = Code 33+pattern TypeEvent          :: Operation+pattern TypeEvent          = Code 34+pattern TypeDeviceEvent    :: Operation+pattern TypeDeviceEvent    = Code 35+pattern TypeReserveId      :: Operation+pattern TypeReserveId      = Code 36+pattern TypeQueue          :: Operation+pattern TypeQueue          = Code 37+pattern TypePipe           :: Operation+pattern TypePipe           = Code 38+pattern TypeForwardPointer :: Operation+pattern TypeForwardPointer = Code 39+-- no 40+-- constants+pattern ConstantTrue      :: Operation+pattern ConstantTrue      = Code 41+pattern ConstantFalse     :: Operation+pattern ConstantFalse     = Code 42+pattern Constant          :: Operation+pattern Constant          = Code 43+pattern ConstantComposite :: Operation+pattern ConstantComposite = Code 44+pattern ConstantSampler   :: Operation+pattern ConstantSampler   = Code 45+pattern ConstantNull      :: Operation+pattern ConstantNull      = Code 46+-- no 47+-- specialisation constants+pattern SpecConstantTrue      :: Operation+pattern SpecConstantTrue      = Code 48+pattern SpecConstantFalse     :: Operation+pattern SpecConstantFalse     = Code 49+pattern SpecConstant          :: Operation+pattern SpecConstant          = Code 50+pattern SpecConstantComposite :: Operation+pattern SpecConstantComposite = Code 51+pattern SpecConstantOp        :: Operation+pattern SpecConstantOp        = Code 52+-- no 53+-- functions+pattern Function          :: Operation+pattern Function          = Code 54+pattern FunctionParameter :: Operation+pattern FunctionParameter = Code 55+pattern FunctionEnd       :: Operation+pattern FunctionEnd       = Code 56+pattern FunctionCall      :: Operation+pattern FunctionCall      = Code 57+-- no 58+-- variables & pointers+pattern Variable               :: Operation+pattern Variable               = Code 59+pattern ImageTexelPointer      :: Operation+pattern ImageTexelPointer      = Code 60+pattern Load                   :: Operation+pattern Load                   = Code 61+pattern Store                  :: Operation+pattern Store                  = Code 62+pattern CopyMemory             :: Operation+pattern CopyMemory             = Code 63+pattern CopyMemorySized        :: Operation+pattern CopyMemorySized        = Code 54+pattern AccessChain            :: Operation+pattern AccessChain            = Code 65+pattern InBoundsAccessChain    :: Operation+pattern InBoundsAccessChain    = Code 66+pattern PtrAccessChain         :: Operation+pattern PtrAccessChain         = Code 67+pattern ArrayLength            :: Operation+pattern ArrayLength            = Code 68+pattern GenericPtrMemSemantics :: Operation+pattern GenericPtrMemSemantics = Code 69+pattern InBoundsPtrAccessChain :: Operation+pattern InBoundsPtrAccessChain = Code 70+-- decorations+pattern Decorate            :: Operation+pattern Decorate            = Code 71+pattern MemberDecorate      :: Operation+pattern MemberDecorate      = Code 72+pattern DecorationGroup     :: Operation+pattern DecorationGroup     = Code 73+pattern GroupDecorate       :: Operation+pattern GroupDecorate       = Code 74+pattern GroupMemberDecorate :: Operation+pattern GroupMemberDecorate = Code 75+-- no 76+-- vector indexing+pattern VectorExtractDynamic :: Operation+pattern VectorExtractDynamic = Code 77+pattern VectorInsertDynamic  :: Operation+pattern VectorInsertDynamic  = Code 78+pattern VectorShuffle        :: Operation+pattern VectorShuffle        = Code 79+-- structs+pattern CompositeConstruct :: Operation+pattern CompositeConstruct = Code 80+pattern CompositeExtract   :: Operation+pattern CompositeExtract   = Code 81+pattern CompositeInsert    :: Operation+pattern CompositeInsert    = Code 82+pattern CopyObject         :: Operation+pattern CopyObject         = Code 83+pattern CopyLogical        :: Operation+pattern CopyLogical        = Code 400+-- operation 84 (Transpose) defined later (141.5)+-- no 85+-- image instructions+pattern SampledImage :: Operation+pattern SampledImage = Code 86+pattern ImageSampleImplicitLod :: Operation+pattern ImageSampleImplicitLod = Code 87+pattern ImageSampleExplicitLod :: Operation+pattern ImageSampleExplicitLod = Code 88+pattern ImageSampleDrefImplicitLod :: Operation+pattern ImageSampleDrefImplicitLod = Code 89+pattern ImageSampleDrefExplicitLod :: Operation+pattern ImageSampleDrefExplicitLod = Code 90+pattern ImageSampleProjImplicitLod :: Operation+pattern ImageSampleProjImplicitLod = Code 91+pattern ImageSampleProjExplicitLod :: Operation+pattern ImageSampleProjExplicitLod = Code 92+pattern ImageSampleProjDrefImplicitLod :: Operation+pattern ImageSampleProjDrefImplicitLod = Code 93+pattern ImageSampleProjDrefExplicitLod :: Operation+pattern ImageSampleProjDrefExplicitLod = Code 94+pattern ImageFetch :: Operation+pattern ImageFetch = Code 95+pattern ImageGather :: Operation+pattern ImageGather = Code 96+pattern ImageDrefGather :: Operation+pattern ImageDrefGather = Code 97+pattern ImageRead :: Operation+pattern ImageRead = Code 98+pattern ImageWrite :: Operation+pattern ImageWrite = Code 99+pattern Image :: Operation+pattern Image = Code 100+-- image queries+pattern ImageQueryFormat  :: Operation+pattern ImageQueryFormat  = Code 101+pattern ImageQueryOrder   :: Operation+pattern ImageQueryOrder   = Code 102+pattern ImageQuerySizeLod :: Operation+pattern ImageQuerySizeLod = Code 103+pattern ImageQuerySize    :: Operation+pattern ImageQuerySize    = Code 104+pattern ImageQueryLod     :: Operation+pattern ImageQueryLod     = Code 105+pattern ImageQueryLevels  :: Operation+pattern ImageQueryLevels  = Code 106+pattern ImageQuerySamples :: Operation+pattern ImageQuerySamples = Code 107+-- sparse image instructions+-- no 108+-- conversion instructions+pattern ConvertFToU    :: Operation+pattern ConvertFToU    = Code 109+pattern ConvertFToS    :: Operation+pattern ConvertFToS    = Code 110+pattern ConvertSToF    :: Operation+pattern ConvertSToF    = Code 111+pattern ConvertUToF    :: Operation+pattern ConvertUToF    = Code 112+pattern UConvert       :: Operation+pattern UConvert       = Code 113+pattern SConvert       :: Operation+pattern SConvert       = Code 114+pattern FConvert       :: Operation+pattern FConvert       = Code 115+pattern SatConvertSToU :: Operation+pattern SatConvertSToU = Code 118+pattern SatConvertUToS :: Operation+pattern SatConvertUToS = Code 119+-- pointer casting+-- bit cast+pattern BitCast :: Operation+pattern BitCast = Code 124+-- no 125+-- numeric instructions+pattern SNegate :: Operation+pattern SNegate = Code 126+pattern FNegate :: Operation+pattern FNegate = Code 127+pattern IAdd    :: Operation+pattern IAdd    = Code 128+pattern FAdd    :: Operation+pattern FAdd    = Code 129+pattern ISub    :: Operation+pattern ISub    = Code 130+pattern FSub    :: Operation+pattern FSub    = Code 131+pattern IMul    :: Operation+pattern IMul    = Code 132+pattern FMul    :: Operation+pattern FMul    = Code 133+pattern UDiv    :: Operation+pattern UDiv    = Code 134+pattern SDiv    :: Operation+pattern SDiv    = Code 135+pattern FDiv    :: Operation+pattern FDiv    = Code 136+pattern UMod    :: Operation+pattern UMod    = Code 137+pattern SRem    :: Operation+pattern SRem    = Code 138+pattern SMod    :: Operation+pattern SMod    = Code 139+pattern FRem    :: Operation+pattern FRem    = Code 140+pattern FMod    :: Operation+pattern FMod    = Code 141+-- vector and matrix instructions+pattern Transpose         :: Operation+pattern Transpose         = Code 84+pattern VectorTimesScalar :: Operation+pattern VectorTimesScalar = Code 142+pattern MatrixTimesScalar :: Operation+pattern MatrixTimesScalar = Code 143+pattern VectorTimesMatrix :: Operation+pattern VectorTimesMatrix = Code 144+pattern MatrixTimesVector :: Operation+pattern MatrixTimesVector = Code 145+pattern MatrixTimesMatrix :: Operation+pattern MatrixTimesMatrix = Code 146+pattern OuterProduct      :: Operation+pattern OuterProduct      = Code 147+pattern Dot               :: Operation+pattern Dot               = Code 148+-- IEEE floating point logical instructions+pattern IsNan :: Operation+pattern IsNan = Code 156+pattern IsInf :: Operation+pattern IsInf = Code 157+-- boolean instructions+pattern LogicalEqual    :: Operation+pattern LogicalEqual    = Code 164+pattern LogicalNotEqual :: Operation+pattern LogicalNotEqual = Code 165+pattern LogicalOr       :: Operation+pattern LogicalOr       = Code 166+pattern LogicalAnd      :: Operation+pattern LogicalAnd      = Code 167+pattern LogicalNot      :: Operation+pattern LogicalNot      = Code 168+pattern Select          :: Operation+pattern Select          = Code 169+-- integer comparisons+pattern IEqual            :: Operation+pattern IEqual            = Code 170+pattern INotEqual         :: Operation+pattern INotEqual         = Code 171+pattern UGreaterThan      :: Operation+pattern UGreaterThan      = Code 172+pattern SGreaterThan      :: Operation+pattern SGreaterThan      = Code 173+pattern UGreaterThanEqual :: Operation+pattern UGreaterThanEqual = Code 174+pattern SGreaterThanEqual :: Operation+pattern SGreaterThanEqual = Code 175+pattern ULessThan         :: Operation+pattern ULessThan         = Code 176 +pattern SLessThan         :: Operation+pattern SLessThan         = Code 177+pattern ULessThanEqual    :: Operation+pattern ULessThanEqual    = Code 178+pattern SLessThanEqual    :: Operation+pattern SLessThanEqual    = Code 179+-- floating point comparisons+pattern FOrdEqual              :: Operation+pattern FOrdEqual              = Code 180+pattern FUnordEqual            :: Operation+pattern FUnordEqual            = Code 181+pattern FOrdNotEqual           :: Operation+pattern FOrdNotEqual           = Code 182+pattern FUnordNotEqual         :: Operation+pattern FUnordNotEqual         = Code 183+pattern FOrdLessThan           :: Operation+pattern FOrdLessThan           = Code 184+pattern FUnordLessThan         :: Operation+pattern FUnordLessThan         = Code 185+pattern FOrdGreaterThan        :: Operation+pattern FOrdGreaterThan        = Code 186+pattern FUnordGreaterThan      :: Operation+pattern FUnordGreaterThan      = Code 187+pattern FOrdLessThanEqual      :: Operation+pattern FOrdLessThanEqual      = Code 188+pattern FUnordLessThanEqual    :: Operation+pattern FUnordLessThanEqual    = Code 189+pattern FOrdGreaterThanEqual   :: Operation+pattern FOrdGreaterThanEqual   = Code 190+pattern FUnordGreaterThanEqual :: Operation+pattern FUnordGreaterThanEqual = Code 191+-- bitwise operations+pattern ShiftRightLogical    :: Operation+pattern ShiftRightLogical    = Code 194+pattern ShiftRightArithmetic :: Operation+pattern ShiftRightArithmetic = Code 195+pattern ShiftLeftLogical     :: Operation+pattern ShiftLeftLogical     = Code 196+pattern BitwiseOr            :: Operation+pattern BitwiseOr            = Code 197+pattern BitwiseXor           :: Operation+pattern BitwiseXor           = Code 198+pattern BitwiseAnd           :: Operation+pattern BitwiseAnd           = Code 199+pattern Not                  :: Operation+pattern Not                  = Code 200+pattern BitReverse           :: Operation+pattern BitReverse           = Code 204+-- geometry primitives+pattern EmitVertex :: Operation+pattern EmitVertex = Code 218+pattern EndPrimitive :: Operation+pattern EndPrimitive = Code 219+pattern EmitStreamVertex :: Operation+pattern EmitStreamVertex = Code 220+pattern EndStreamPrimitive :: Operation+pattern EndStreamPrimitive = Code 221+-- memory synchronisation+pattern ControlBarrier :: Operation+pattern ControlBarrier = Code 224+pattern MemoryBarrier :: Operation+pattern MemoryBarrier = Code 225+-- atomic instructions+pattern AtomicLoad :: Operation+pattern AtomicLoad = Code 227+pattern AtomicStore :: Operation+pattern AtomicStore = Code 228+pattern AtomicExchange :: Operation+pattern AtomicExchange = Code 229+pattern AtomicCompareExchange :: Operation+pattern AtomicCompareExchange = Code 230+pattern AtomicIIncrement :: Operation+pattern AtomicIIncrement = Code 232+pattern AtomicIDecrement :: Operation+pattern AtomicIDecrement = Code 233+pattern AtomicIAdd :: Operation+pattern AtomicIAdd = Code 234+pattern AtomicISub :: Operation+pattern AtomicISub = Code 235+pattern AtomicSMin :: Operation+pattern AtomicSMin = Code 236+pattern AtomicUMin :: Operation+pattern AtomicUMin = Code 237+pattern AtomicSMax :: Operation+pattern AtomicSMax = Code 238+pattern AtomicUMax :: Operation+pattern AtomicUMax = Code 239+pattern AtomicAnd :: Operation+pattern AtomicAnd = Code 240+pattern AtomicOr :: Operation+pattern AtomicOr = Code 241+pattern AtomicXor :: Operation+pattern AtomicXor = Code 242+pattern AtomicFMinEXT :: Operation+pattern AtomicFMinEXT = Code 5614+pattern AtomicFMaxEXT :: Operation+pattern AtomicFMaxEXT = Code 5615+pattern AtomicFAddEXT :: Operation+pattern AtomicFAddEXT = Code 6035+-- group and subgroup operations+pattern GroupAsyncCopy :: Operation+pattern GroupAsyncCopy = Code 259+pattern GroupWaitEvents :: Operation+pattern GroupWaitEvents = Code 260+pattern GroupAll :: Operation+pattern GroupAll = Code 261+pattern GroupAny :: Operation+pattern GroupAny = Code 262+pattern GroupBroadcast :: Operation+pattern GroupBroadcast = Code 263+pattern GroupIAdd :: Operation+pattern GroupIAdd = Code 264+pattern GroupFAdd :: Operation+pattern GroupFAdd = Code 265+pattern GroupFMin :: Operation+pattern GroupFMin = Code 266+pattern GroupUMin :: Operation+pattern GroupUMin = Code 267+pattern GroupSMin :: Operation+pattern GroupSMin = Code 268+pattern GroupFMax :: Operation+pattern GroupFMax = Code 269+pattern GroupUMax :: Operation+pattern GroupUMax = Code 270+pattern GroupSMax :: Operation+pattern GroupSMax = Code 271++-- control flow+pattern Phi               :: Operation+pattern Phi               = Code 245+pattern LoopMerge         :: Operation+pattern LoopMerge         = Code 246+pattern SelectionMerge    :: Operation+pattern SelectionMerge    = Code 247+pattern Label             :: Operation+pattern Label             = Code 248+pattern Branch            :: Operation+pattern Branch            = Code 249+pattern BranchConditional :: Operation+pattern BranchConditional = Code 250+pattern Switch            :: Operation+pattern Switch            = Code 251+pattern Kill              :: Operation+pattern Kill              = Code 252+pattern Return            :: Operation+pattern Return            = Code 253+pattern ReturnValue       :: Operation+pattern ReturnValue       = Code 254+pattern Unreachable       :: Operation+pattern Unreachable       = Code 255++-- non uniform group instructions+pattern GroupNonUniformElect :: Operation+pattern GroupNonUniformElect = Code 333+pattern GroupNonUniformAll   :: Operation+pattern GroupNonUniformAll   = Code 334+pattern GroupNonUniformAny   :: Operation+pattern GroupNonUniformAny   = Code 335+pattern GroupNonUniformAllEqual :: Operation+pattern GroupNonUniformAllEqual = Code 336+pattern GroupNonUniformBroadcast :: Operation+pattern GroupNonUniformBroadcast = Code 337+pattern GroupNonUniformBroadcastFirst :: Operation+pattern GroupNonUniformBroadcastFirst = Code 338+pattern GroupNonUniformBallot :: Operation+pattern GroupNonUniformBallot = Code 339+pattern GroupNonUniformInverseBallot :: Operation+pattern GroupNonUniformInverseBallot = Code 340+pattern GroupNonUniformBallotBitExtract :: Operation+pattern GroupNonUniformBallotBitExtract = Code 341+pattern GroupNonUniformBallotBitCount :: Operation+pattern GroupNonUniformBallotBitCount = Code 342+pattern GroupNonUniformBallotFindLSB :: Operation+pattern GroupNonUniformBallotFindLSB = Code 343+pattern GroupNonUniformBallotFindMSB :: Operation+pattern GroupNonUniformBallotFindMSB = Code 344+pattern GroupNonUniformShuffle :: Operation+pattern GroupNonUniformShuffle = Code 345+pattern GroupNonUniformShuffleXor :: Operation+pattern GroupNonUniformShuffleXor = Code 346+pattern GroupNonUniformShuffleUp :: Operation+pattern GroupNonUniformShuffleUp = Code 347+pattern GroupNonUniformShuffleDown :: Operation+pattern GroupNonUniformShuffleDown = Code 348+pattern GroupNonUniformIAdd :: Operation+pattern GroupNonUniformIAdd = Code 349+pattern GroupNonUniformFAdd :: Operation+pattern GroupNonUniformFAdd = Code 350+pattern GroupNonUniformIMul :: Operation+pattern GroupNonUniformIMul = Code 351+pattern GroupNonUniformFMul :: Operation+pattern GroupNonUniformFMul = Code 352+pattern GroupNonUniformSMin :: Operation+pattern GroupNonUniformSMin = Code 353+pattern GroupNonUniformUMin :: Operation+pattern GroupNonUniformUMin = Code 354+pattern GroupNonUniformFMin :: Operation+pattern GroupNonUniformFMin = Code 355+pattern GroupNonUniformSMax :: Operation+pattern GroupNonUniformSMax = Code 356+pattern GroupNonUniformUMax :: Operation+pattern GroupNonUniformUMax = Code 357+pattern GroupNonUniformFMax :: Operation+pattern GroupNonUniformFMax = Code 358+pattern GroupNonUniformBitwiseAnd :: Operation+pattern GroupNonUniformBitwiseAnd = Code 359+pattern GroupNonUniformBitwiseOr :: Operation+pattern GroupNonUniformBitwiseOr = Code 360+pattern GroupNonUniformBitwiseXor :: Operation+pattern GroupNonUniformBitwiseXor = Code 361+pattern GroupNonUniformLogicalAnd :: Operation+pattern GroupNonUniformLogicalAnd = Code 362+pattern GroupNonUniformLogicalOr :: Operation+pattern GroupNonUniformLogicalOr = Code 363+pattern GroupNonUniformLogicalXor :: Operation+pattern GroupNonUniformLogicalXor = Code 364+pattern GroupNonUniformQuadBroadcast :: Operation+pattern GroupNonUniformQuadBroadcast = Code 365+pattern GroupNonUniformQuadSwap :: Operation+pattern GroupNonUniformQuadSwap = Code 366+++-- ray tracing instructions+pattern TraceRay                        :: Operation+pattern TraceRay                        = Code 4445+pattern ExecuteCallable                 :: Operation+pattern ExecuteCallable                 = Code 4446+pattern ConvertUToAccelerationStructure :: Operation+pattern ConvertUToAccelerationStructure = Code 4447+pattern IgnoreIntersection              :: Operation+pattern IgnoreIntersection              = Code 4448+pattern TerminateRay                    :: Operation+pattern TerminateRay                    = Code 4449+pattern ReportIntersection              :: Operation+pattern ReportIntersection              = Code 5334+pattern TypeAccelerationStructure       :: Operation+pattern TypeAccelerationStructure       = Code 5341+-- ray query instructions+pattern TypeRayQuery                                                  :: Operation+pattern TypeRayQuery                                                  = Code 4472+pattern RayQueryInitialize                                            :: Operation+pattern RayQueryInitialize                                            = Code 4473+pattern RayQueryTerminate                                             :: Operation+pattern RayQueryTerminate                                             = Code 4474+pattern RayQueryGenerateIntersection                                  :: Operation+pattern RayQueryGenerateIntersection                                  = Code 4475+pattern RayQueryConfirmIntersection                                   :: Operation+pattern RayQueryConfirmIntersection                                   = Code 4476+pattern RayQueryProceed                                               :: Operation+pattern RayQueryProceed                                               = Code 4477+pattern RayQueryGetIntersectionType                                   :: Operation+pattern RayQueryGetIntersectionType                                   = Code 4479+pattern RayQueryGetRayTMin                                            :: Operation+pattern RayQueryGetRayTMin                                            = Code 6016+pattern RayQueryGetRayFlags                                           :: Operation+pattern RayQueryGetRayFlags                                           = Code 6017+pattern RayQueryGetIntersectionT                                      :: Operation+pattern RayQueryGetIntersectionT                                      = Code 6018+pattern RayQueryGetIntersectionInstanceCustomIndex                    :: Operation+pattern RayQueryGetIntersectionInstanceCustomIndex                    = Code 6019+pattern RayQueryGetIntersectionInstanceId                             :: Operation+pattern RayQueryGetIntersectionInstanceId                             = Code 6020+pattern RayQueryGetIntersectionInstanceShaderBindingTableRecordOffset :: Operation+pattern RayQueryGetIntersectionInstanceShaderBindingTableRecordOffset = Code 6021+pattern RayQueryGetIntersectionGeometryIndex                          :: Operation+pattern RayQueryGetIntersectionGeometryIndex                          = Code 6022+pattern RayQueryGetIntersectionPrimitiveIndex                         :: Operation+pattern RayQueryGetIntersectionPrimitiveIndex                         = Code 6023+pattern RayQueryGetIntersectionBarycentrics                           :: Operation+pattern RayQueryGetIntersectionBarycentrics                           = Code 6024+pattern RayQueryGetIntersectionFrontFace                              :: Operation+pattern RayQueryGetIntersectionFrontFace                              = Code 6025+pattern RayQueryGetIntersectionCandidateAABBOpaque                    :: Operation+pattern RayQueryGetIntersectionCandidateAABBOpaque                    = Code 6026+pattern RayQueryGetIntersectionObjectRayDirection                     :: Operation+pattern RayQueryGetIntersectionObjectRayDirection                     = Code 6027+pattern RayQueryGetIntersectionObjectRayOrigin                        :: Operation+pattern RayQueryGetIntersectionObjectRayOrigin                        = Code 6028+pattern RayQueryGetWorldRayDirection                                  :: Operation+pattern RayQueryGetWorldRayDirection                                  = Code 6029+pattern RayQueryGetWorldRayOrigin                                     :: Operation+pattern RayQueryGetWorldRayOrigin                                     = Code 6030+pattern RayQueryGetIntersectionObjectToWorld                          :: Operation+pattern RayQueryGetIntersectionObjectToWorld                          = Code 6031+pattern RayQueryGetIntersectionWorldToObject                          :: Operation+pattern RayQueryGetIntersectionWorldToObject                          = Code 6032+-- GLSL extended instructions+pattern GLSL_Round         :: Operation+pattern GLSL_Round         = ExtCode GLSL 1+pattern GLSL_RoundEven     :: Operation+pattern GLSL_RoundEven     = ExtCode GLSL 2+pattern GLSL_Trunc         :: Operation+pattern GLSL_Trunc         = ExtCode GLSL 3+pattern GLSL_FAbs          :: Operation+pattern GLSL_FAbs          = ExtCode GLSL 4+pattern GLSL_SAbs          :: Operation+pattern GLSL_SAbs          = ExtCode GLSL 5+pattern GLSL_FSign         :: Operation+pattern GLSL_FSign         = ExtCode GLSL 6+pattern GLSL_SSign         :: Operation+pattern GLSL_SSign         = ExtCode GLSL 7+pattern GLSL_Floor         :: Operation+pattern GLSL_Floor         = ExtCode GLSL 8+pattern GLSL_Ceil          :: Operation+pattern GLSL_Ceil          = ExtCode GLSL 9+pattern GLSL_Fract         :: Operation+pattern GLSL_Fract         = ExtCode GLSL 10+pattern GLSL_Sin           :: Operation+pattern GLSL_Sin           = ExtCode GLSL 13+pattern GLSL_Cos           :: Operation+pattern GLSL_Cos           = ExtCode GLSL 14+pattern GLSL_Tan           :: Operation+pattern GLSL_Tan           = ExtCode GLSL 15+pattern GLSL_Asin          :: Operation+pattern GLSL_Asin          = ExtCode GLSL 16+pattern GLSL_Acos          :: Operation+pattern GLSL_Acos          = ExtCode GLSL 17+pattern GLSL_Atan          :: Operation+pattern GLSL_Atan          = ExtCode GLSL 18+pattern GLSL_Sinh          :: Operation+pattern GLSL_Sinh          = ExtCode GLSL 19+pattern GLSL_Cosh          :: Operation+pattern GLSL_Cosh          = ExtCode GLSL 20+pattern GLSL_Tanh          :: Operation+pattern GLSL_Tanh          = ExtCode GLSL 21+pattern GLSL_Asinh         :: Operation+pattern GLSL_Asinh         = ExtCode GLSL 22+pattern GLSL_Acosh         :: Operation+pattern GLSL_Acosh         = ExtCode GLSL 23+pattern GLSL_Atanh         :: Operation+pattern GLSL_Atanh         = ExtCode GLSL 24+pattern GLSL_Atan2         :: Operation+pattern GLSL_Atan2         = ExtCode GLSL 25+pattern GLSL_Pow           :: Operation+pattern GLSL_Pow           = ExtCode GLSL 26+pattern GLSL_Exp           :: Operation+pattern GLSL_Exp           = ExtCode GLSL 27+pattern GLSL_Log           :: Operation+pattern GLSL_Log           = ExtCode GLSL 28+pattern GLSL_Sqrt          :: Operation+pattern GLSL_Sqrt          = ExtCode GLSL 31+pattern GLSL_InvSqrt       :: Operation+pattern GLSL_InvSqrt       = ExtCode GLSL 32+pattern GLSL_Determinant   :: Operation+pattern GLSL_Determinant   = ExtCode GLSL 33+pattern GLSL_MatrixInverse :: Operation+pattern GLSL_MatrixInverse = ExtCode GLSL 34+pattern GLSL_FMin          :: Operation+pattern GLSL_FMin          = ExtCode GLSL 37+pattern GLSL_UMin          :: Operation+pattern GLSL_UMin          = ExtCode GLSL 38+pattern GLSL_SMin          :: Operation+pattern GLSL_SMin          = ExtCode GLSL 39+pattern GLSL_FMax          :: Operation+pattern GLSL_FMax          = ExtCode GLSL 40+pattern GLSL_UMax          :: Operation+pattern GLSL_UMax          = ExtCode GLSL 41+pattern GLSL_SMax          :: Operation+pattern GLSL_SMax          = ExtCode GLSL 42+pattern GLSL_Cross         :: Operation+pattern GLSL_Cross         = ExtCode GLSL 68+pattern GLSL_Normalize     :: Operation+pattern GLSL_Normalize     = ExtCode GLSL 69+-- OpenCL extended instructions+  -- floating point instructions+pattern OpenCL_Acos :: Operation+pattern OpenCL_Acos = ExtCode OpenCL 0+pattern OpenCL_Acosh :: Operation+pattern OpenCL_Acosh = ExtCode OpenCL 1+pattern OpenCL_Asin :: Operation+pattern OpenCL_Asin = ExtCode OpenCL 3+pattern OpenCL_Asinh :: Operation+pattern OpenCL_Asinh = ExtCode OpenCL 4+pattern OpenCL_Atan :: Operation+pattern OpenCL_Atan = ExtCode OpenCL 6+pattern OpenCL_Atan2 :: Operation+pattern OpenCL_Atan2 = ExtCode OpenCL 7+pattern OpenCL_Atanh :: Operation+pattern OpenCL_Atanh = ExtCode OpenCL 8+pattern OpenCL_Cbrt :: Operation+pattern OpenCL_Cbrt = ExtCode OpenCL 11+pattern OpenCL_Ceil :: Operation+pattern OpenCL_Ceil = ExtCode OpenCL 12+pattern OpenCL_Cos :: Operation+pattern OpenCL_Cos = ExtCode OpenCL 14+pattern OpenCL_Cosh :: Operation+pattern OpenCL_Cosh = ExtCode OpenCL 15+pattern OpenCL_Erfc :: Operation+pattern OpenCL_Erfc = ExtCode OpenCL 17+pattern OpenCL_Erf :: Operation+pattern OpenCL_Erf = ExtCode OpenCL 18+pattern OpenCL_Exp :: Operation+pattern OpenCL_Exp = ExtCode OpenCL 19+pattern OpenCL_Exp2 :: Operation+pattern OpenCL_Exp2 = ExtCode OpenCL 20+pattern OpenCL_Exp10 :: Operation+pattern OpenCL_Exp10 = ExtCode OpenCL 21+pattern OpenCL_Expm1 :: Operation+pattern OpenCL_Expm1 = ExtCode OpenCL 22+pattern OpenCL_FAbs :: Operation+pattern OpenCL_FAbs = ExtCode OpenCL 23+pattern OpenCL_FDim :: Operation+pattern OpenCL_FDim = ExtCode OpenCL 24+pattern OpenCL_Floor :: Operation+pattern OpenCL_Floor = ExtCode OpenCL 25+pattern OpenCL_FMAdd :: Operation+pattern OpenCL_FMAdd = ExtCode OpenCL 26+pattern OpenCL_FMax :: Operation+pattern OpenCL_FMax = ExtCode OpenCL 27+pattern OpenCL_FMin :: Operation+pattern OpenCL_FMin = ExtCode OpenCL 28+pattern OpenCL_FMod :: Operation+pattern OpenCL_FMod = ExtCode OpenCL 29+pattern OpenCL_Fract :: Operation+pattern OpenCL_Fract = ExtCode OpenCL 30+pattern OpenCL_FRExp :: Operation+pattern OpenCL_FRExp = ExtCode OpenCL 31+pattern OpenCL_Hypot :: Operation+pattern OpenCL_Hypot = ExtCode OpenCL 32+pattern OpenCL_LogGamma :: Operation+pattern OpenCL_LogGamma = ExtCode OpenCL 35+pattern OpenCL_Log :: Operation+pattern OpenCL_Log = ExtCode OpenCL 37+pattern OpenCL_Log2 :: Operation+pattern OpenCL_Log2 = ExtCode OpenCL 38+pattern OpenCL_Log10 :: Operation+pattern OpenCL_Log10 = ExtCode OpenCL 39+pattern OpenCL_Log1P :: Operation+pattern OpenCL_Log1P = ExtCode OpenCL 40+pattern OpenCL_LogB :: Operation+pattern OpenCL_LogB = ExtCode OpenCL 41+pattern OpenCL_MAdd :: Operation+pattern OpenCL_MAdd = ExtCode OpenCL 42+pattern OpenCL_MaxMag :: Operation+pattern OpenCL_MaxMag = ExtCode OpenCL 43+pattern OpenCL_MinMag :: Operation+pattern OpenCL_MinMag = ExtCode OpenCL 44+pattern OpenCL_ModF :: Operation+pattern OpenCL_ModF = ExtCode OpenCL 45+pattern OpenCL_NaN :: Operation+pattern OpenCL_NaN = ExtCode OpenCL 46+pattern OpenCL_NextAfter :: Operation+pattern OpenCL_NextAfter = ExtCode OpenCL 47+pattern OpenCL_Pow :: Operation+pattern OpenCL_Pow = ExtCode OpenCL 48+pattern OpenCL_FRem :: Operation+pattern OpenCL_FRem = ExtCode OpenCL 51+pattern OpenCL_FRemQuot :: Operation+pattern OpenCL_FRemQuot = ExtCode OpenCL 52+pattern OpenCL_RoundEven :: Operation+pattern OpenCL_RoundEven = ExtCode OpenCL 53+pattern OpenCL_Round :: Operation+pattern OpenCL_Round = ExtCode OpenCL 55+pattern OpenCL_InvSqrt :: Operation+pattern OpenCL_InvSqrt = ExtCode OpenCL 56+pattern OpenCL_Sin :: Operation+pattern OpenCL_Sin = ExtCode OpenCL 57+pattern OpenCL_SinCos :: Operation+pattern OpenCL_SinCos = ExtCode OpenCL 58+pattern OpenCL_Sinh :: Operation+pattern OpenCL_Sinh = ExtCode OpenCL 59+pattern OpenCL_Sqrt :: Operation+pattern OpenCL_Sqrt = ExtCode OpenCL 61+pattern OpenCL_Tan :: Operation+pattern OpenCL_Tan = ExtCode OpenCL 62+pattern OpenCL_Tanh :: Operation+pattern OpenCL_Tanh = ExtCode OpenCL 63+pattern OpenCL_Gamma :: Operation+pattern OpenCL_Gamma = ExtCode OpenCL 65+pattern OpenCL_Trunc :: Operation+pattern OpenCL_Trunc = ExtCode OpenCL 66+pattern OpenCL_FSign :: Operation+pattern OpenCL_FSign = ExtCode OpenCL 103+  -- integral instructions+pattern OpenCL_SAbs :: Operation+pattern OpenCL_SAbs = ExtCode OpenCL 141+pattern OpenCL_SAbsDiff :: Operation+pattern OpenCL_SAbsDiff = ExtCode OpenCL 142+pattern OpenCL_SMax :: Operation+pattern OpenCL_SMax = ExtCode OpenCL 156+pattern OpenCL_UMax :: Operation+pattern OpenCL_UMax = ExtCode OpenCL 157+pattern OpenCL_SMin :: Operation+pattern OpenCL_SMin = ExtCode OpenCL 158+pattern OpenCL_UMin :: Operation+pattern OpenCL_UMin = ExtCode OpenCL 159+pattern OpenCL_UAbs :: Operation+pattern OpenCL_UAbs = ExtCode OpenCL 201+pattern OpenCL_UAbsDiff :: Operation+pattern OpenCL_UAbsDiff = ExtCode OpenCL 202+  -- vectors and matrices+pattern OpenCL_Cross :: Operation+pattern OpenCL_Cross = ExtCode OpenCL 104+pattern OpenCL_Normalize :: Operation+pattern OpenCL_Normalize = ExtCode OpenCL 107+-- Non-semantic DebugPrintf instruction+pattern DebugPrintf :: Operation+pattern DebugPrintf = ExtCode SPIRV.Extension.DebugPrintf 1++-- | Whether an operation is a block termination instruction.+isBlockTerminator :: Operation -> Bool+isBlockTerminator op = op `elem`+  [ Branch, BranchConditional, Switch+  , Return, ReturnValue+  , Kill, Unreachable+  , IgnoreIntersection, TerminateRay+  ]++showOperation :: Operation -> String+showOperation Nop = "Nop"+showOperation Undef = "Undef"+showOperation SourceContinued = "SourceContinued"+showOperation Source = "Source"+showOperation SourceExtension = "SourceExtension"+showOperation Name = "Name"+showOperation MemberName = "MemberName"+showOperation String = "String"+showOperation Line = "Line"+showOperation ExtInst = "ExtInst"+showOperation ExtInstImport = "ExtInstImport"+showOperation MemoryModel = "MemoryModel"+showOperation EntryPoint = "EntryPoint"+showOperation ExecutionMode = "ExecutionMode"+showOperation Capability = "Capability"+showOperation TypeVoid = "TypeVoid"+showOperation TypeBool = "TypeBool"+showOperation TypeInt = "TypeInt"+showOperation TypeFloat = "TypeFloat"+showOperation TypeVector = "TypeVector"+showOperation TypeMatrix = "TypeMatrix"+showOperation TypeImage = "TypeImage"+showOperation TypeSampler = "TypeSampler"+showOperation TypeSampledImage = "TypeSampledImage"+showOperation TypeArray = "TypeArray"+showOperation TypeRuntimeArray = "TypeRuntimeArray"+showOperation TypeStruct = "TypeStruct"+showOperation TypeOpaque = "TypeOpaque"+showOperation TypePointer = "TypePointer"+showOperation TypeFunction = "TypeFunction"+showOperation TypeEvent = "TypeEvent"+showOperation TypeDeviceEvent = "TypeDeviceEvent"+showOperation TypeReserveId = "TypeReserveId"+showOperation TypeQueue = "TypeQueue"+showOperation TypePipe = "TypePipe"+showOperation TypeForwardPointer = "TypeForwardPointer"+showOperation ConstantTrue = "ConstantTrue"+showOperation ConstantFalse = "ConstantFalse"+showOperation Constant = "Constant"+showOperation ConstantComposite = "ConstantComposite"+showOperation ConstantSampler = "ConstantSampler"+showOperation ConstantNull = "ConstantNull"+showOperation SpecConstantTrue = "SpecConstantTrue"+showOperation SpecConstantFalse = "SpecConstantFalse"+showOperation SpecConstant = "SpecConstant"+showOperation SpecConstantComposite = "SpecConstantComposite"+showOperation SpecConstantOp = "SpecConstantOp"+showOperation Function = "Function"+showOperation FunctionParameter = "FunctionParameter"+showOperation FunctionEnd = "FunctionEnd"+showOperation FunctionCall = "FunctionCall"+showOperation Variable = "Variable"+showOperation ImageTexelPointer = "ImageTexelPointer"+showOperation Load = "Load"+showOperation Store = "Store"+showOperation CopyMemory = "CopyMemory"+showOperation CopyMemorySized = "CopyMemorySized"+showOperation AccessChain = "AccessChain"+showOperation InBoundsAccessChain = "InBoundsAccessChain"+showOperation PtrAccessChain = "PtrAccessChain"+showOperation ArrayLength = "ArrayLength"+showOperation GenericPtrMemSemantics = "GenericPtrMemSemantics"+showOperation InBoundsPtrAccessChain = "InBoundsPtrAccessChain"+showOperation Decorate = "Decorate"+showOperation MemberDecorate = "MemberDecorate"+showOperation DecorationGroup = "DecorationGroup"+showOperation GroupDecorate = "GroupDecorate"+showOperation GroupMemberDecorate = "GroupMemberDecorate"+showOperation VectorExtractDynamic = "VectorExtractDynamic"+showOperation VectorInsertDynamic = "VectorInsertDynamic"+showOperation VectorShuffle = "VectorShuffle"+showOperation CompositeConstruct = "CompositeConstruct"+showOperation CompositeExtract = "CompositeExtract"+showOperation CompositeInsert = "CompositeInsert"+showOperation CopyObject = "CopyObject"+showOperation CopyLogical = "CopyLogical"+showOperation SampledImage = "SampledImage"+showOperation ImageSampleImplicitLod = "ImageSampleImplicitLod"+showOperation ImageSampleExplicitLod = "ImageSampleExplicitLod"+showOperation ImageSampleDrefImplicitLod = "ImageSampleDrefImplicitLod"+showOperation ImageSampleDrefExplicitLod = "ImageSampleDrefExplicitLod"+showOperation ImageSampleProjImplicitLod = "ImageSampleProjImplicitLod"+showOperation ImageSampleProjExplicitLod = "ImageSampleProjExplicitLod"+showOperation ImageSampleProjDrefImplicitLod = "ImageSampleProjDrefImplicitLod"+showOperation ImageSampleProjDrefExplicitLod = "ImageSampleProjDrefExplicitLod"+showOperation ImageFetch = "ImageFetch"+showOperation ImageGather = "ImageGather"+showOperation ImageDrefGather = "ImageDrefGather"+showOperation ImageRead = "ImageRead"+showOperation ImageWrite = "ImageWrite"+showOperation Image = "Image"+showOperation ImageQueryFormat  = "ImageQueryFormat"+showOperation ImageQueryOrder   = "ImageQueryOrder"+showOperation ImageQuerySizeLod = "ImageQuerySizeLod"+showOperation ImageQuerySize    = "ImageQuerySize"+showOperation ImageQueryLod     = "ImageQueryLod"+showOperation ImageQueryLevels  = "ImageQueryLevels"+showOperation ImageQuerySamples = "ImageQuerySamples"+showOperation ConvertFToU = "ConvertFToU"+showOperation ConvertFToS = "ConvertFToS"+showOperation ConvertSToF = "ConvertSToF"+showOperation ConvertUToF = "ConvertUToF"+showOperation UConvert = "UConvert"+showOperation SConvert = "SConvert"+showOperation FConvert = "FConvert"+showOperation SatConvertSToU = "SatConvertSToU"+showOperation SatConvertUToS = "SatConvertUToS"+showOperation BitCast = "BitCast"+showOperation SNegate = "SNegate"+showOperation FNegate = "FNegate"+showOperation IAdd = "IAdd"+showOperation FAdd = "FAdd"+showOperation ISub = "ISub"+showOperation FSub = "FSub"+showOperation IMul = "IMul"+showOperation FMul = "FMul"+showOperation UDiv = "UDiv"+showOperation SDiv = "SDiv"+showOperation FDiv = "FDiv"+showOperation UMod = "UMod"+showOperation SRem = "SRem"+showOperation SMod = "SMod"+showOperation FRem = "FRem"+showOperation FMod = "FMod"+showOperation Transpose = "Transpose"+showOperation VectorTimesScalar = "VectorTimesScalar"+showOperation MatrixTimesScalar = "MatrixTimesScalar"+showOperation VectorTimesMatrix = "VectorTimesMatrix"+showOperation MatrixTimesVector = "MatrixTimesVector"+showOperation MatrixTimesMatrix = "MatrixTimesMatrix"+showOperation OuterProduct = "OuterProduct"+showOperation Dot = "Dot"+showOperation LogicalEqual = "LogicalEqual"+showOperation LogicalNotEqual = "LogicalNotEqual"+showOperation LogicalOr = "LogicalOr"+showOperation LogicalAnd = "LogicalAnd"+showOperation LogicalNot = "LogicalNot"+showOperation IEqual = "IEqual"+showOperation INotEqual = "INotEqual"+showOperation UGreaterThan = "UGreaterThan"+showOperation SGreaterThan = "SGreaterThan"+showOperation UGreaterThanEqual = "UGreaterThanEqual"+showOperation SGreaterThanEqual = "SGreaterThanEqual"+showOperation ULessThan = "ULessThan"+showOperation SLessThan = "SLessThan"+showOperation ULessThanEqual = "ULessThanEqual"+showOperation SLessThanEqual = "SLessThanEqual"+showOperation FOrdEqual = "FOrdEqual"+showOperation FUnordEqual = "FUnordEqual"+showOperation FOrdNotEqual = "FOrdNotEqual"+showOperation FUnordNotEqual = "FUnordNotEqual"+showOperation FOrdLessThan = "FOrdLessThan"+showOperation FUnordLessThan = "FUnordLessThan"+showOperation FOrdGreaterThan = "FOrdGreaterThan"+showOperation FUnordGreaterThan = "FUnordGreaterThan"+showOperation FOrdLessThanEqual = "FOrdLessThanEqual"+showOperation FUnordLessThanEqual = "FUnordLessThanEqual"+showOperation FOrdGreaterThanEqual = "FOrdGreaterThanEqual"+showOperation FUnordGreaterThanEqual = "FUnordGreaterThanEqual"+showOperation ShiftRightLogical    = "ShiftRightLogical"+showOperation ShiftRightArithmetic = "ShiftRightArithmetic"+showOperation ShiftLeftLogical     = "ShiftLeftLogical"+showOperation BitwiseOr            = "BitwiseOr"+showOperation BitwiseXor           = "BitwiseXor"+showOperation BitwiseAnd           = "BitwiseAnd"+showOperation Not                  = "Not"+showOperation BitReverse           = "BitReverse"+showOperation EmitVertex         = "EmitVertex"+showOperation EndPrimitive       = "EndPrimitive"+showOperation EmitStreamVertex   = "EmitStreamVertex"+showOperation EndStreamPrimitive = "EndStreamPrimitive"+showOperation AtomicLoad            = "AtomicLoad"+showOperation AtomicStore           = "AtomicStore"+showOperation AtomicExchange        = "AtomicExchange"+showOperation AtomicCompareExchange = "AtomicCompareExchange"+showOperation AtomicIIncrement      = "AtomicIIncrement"+showOperation AtomicIDecrement      = "AtomicIDecrement"+showOperation AtomicIAdd            = "AtomicIAdd"+showOperation AtomicISub            = "AtomicISub"+showOperation AtomicSMin            = "AtomicSMin"+showOperation AtomicUMin            = "AtomicUMin"+showOperation AtomicSMax            = "AtomicSMax"+showOperation AtomicUMax            = "AtomicUMax"+showOperation AtomicAnd             = "AtomicAnd"+showOperation AtomicOr              = "AtomicOr"+showOperation AtomicXor             = "AtomicXor"+showOperation AtomicFMinEXT         = "AtomicFMinEXT"+showOperation AtomicFMaxEXT         = "AtomicFMaxEXT"+showOperation AtomicFAddEXT         = "AtomicFAddEXT"+showOperation GroupAsyncCopy = "GroupAsyncCopy"+showOperation GroupWaitEvents = "GroupWaitEvents"+showOperation GroupAll = "GroupAll"+showOperation GroupAny = "GroupAny"+showOperation GroupBroadcast = "GroupBroadcast"+showOperation GroupIAdd = "GroupIAdd"+showOperation GroupFAdd = "GroupFAdd"+showOperation GroupFMin = "GroupFMin"+showOperation GroupUMin = "GroupUMin"+showOperation GroupSMin = "GroupSMin"+showOperation GroupFMax = "GroupFMax"+showOperation GroupUMax = "GroupUMax"+showOperation GroupSMax = "GroupSMax"+showOperation Phi = "Phi"+showOperation LoopMerge = "LoopMerge"+showOperation SelectionMerge = "SelectionMerge"+showOperation Label = "Label"+showOperation Branch = "Branch"+showOperation BranchConditional = "BranchConditional"+showOperation Switch = "Switch"+showOperation Kill = "Kill"+showOperation Return = "Return"+showOperation ReturnValue = "ReturnValue"+showOperation Unreachable = "Unreachable"+-- non uniform group instructions+showOperation GroupNonUniformElect = "GroupNonUniformElect"+showOperation GroupNonUniformAll = "GroupNonUniformAll"+showOperation GroupNonUniformAny = "GroupNonUniformAny"+showOperation GroupNonUniformAllEqual = "GroupNonUniformAllEqual"+showOperation GroupNonUniformBroadcast = "GroupNonUniformBroadcast"+showOperation GroupNonUniformBroadcastFirst = "GroupNonUniformBroadcastFirst"+showOperation GroupNonUniformBallot = "GroupNonUniformBallot"+showOperation GroupNonUniformInverseBallot = "GroupNonUniformInverseBallot"+showOperation GroupNonUniformBallotBitExtract = "GroupNonUniformBallotBitExtract"+showOperation GroupNonUniformBallotBitCount = "GroupNonUniformBallotBitCount"+showOperation GroupNonUniformBallotFindLSB = "GroupNonUniformBallotFindLSB"+showOperation GroupNonUniformBallotFindMSB = "GroupNonUniformBallotFindMSB"+showOperation GroupNonUniformShuffle = "GroupNonUniformShuffle"+showOperation GroupNonUniformShuffleXor = "GroupNonUniformShuffleXor"+showOperation GroupNonUniformShuffleUp = "GroupNonUniformShuffleUp"+showOperation GroupNonUniformShuffleDown = "GroupNonUniformShuffleDown"+showOperation GroupNonUniformIAdd = "GroupNonUniformIAdd"+showOperation GroupNonUniformFAdd = "GroupNonUniformFAdd"+showOperation GroupNonUniformIMul = "GroupNonUniformIMul"+showOperation GroupNonUniformFMul = "GroupNonUniformFMul"+showOperation GroupNonUniformSMin = "GroupNonUniformSMin"+showOperation GroupNonUniformUMin = "GroupNonUniformUMin"+showOperation GroupNonUniformFMin = "GroupNonUniformFMin"+showOperation GroupNonUniformSMax = "GroupNonUniformSMax"+showOperation GroupNonUniformUMax = "GroupNonUniformUMax"+showOperation GroupNonUniformFMax = "GroupNonUniformFMax"+showOperation GroupNonUniformBitwiseAnd = "GroupNonUniformBitwiseAnd"+showOperation GroupNonUniformBitwiseOr = "GroupNonUniformBitwiseOr"+showOperation GroupNonUniformBitwiseXor = "GroupNonUniformBitwiseXor"+showOperation GroupNonUniformLogicalAnd = "GroupNonUniformLogicalAnd"+showOperation GroupNonUniformLogicalOr = "GroupNonUniformLogicalOr"+showOperation GroupNonUniformLogicalXor = "GroupNonUniformLogicalXor"+showOperation GroupNonUniformQuadBroadcast = "GroupNonUniformQuadBroadcast"+showOperation GroupNonUniformQuadSwap = "GroupNonUniformQuadSwap"+-- ray tracing instructions+showOperation TraceRay                        = "TraceRay"+showOperation ExecuteCallable                 = "ExecuteCallable"+showOperation ConvertUToAccelerationStructure = "ConvertUToAccelerationStructure"+showOperation IgnoreIntersection              = "IgnoreIntersection"+showOperation TerminateRay                    = "TerminateRay"+showOperation ReportIntersection              = "ReportIntersection"+showOperation TypeAccelerationStructure       = "TypeAccelerationStructure"+-- ray query instructions+showOperation TypeRayQuery                                                  = "TypeRayQuery"+showOperation RayQueryInitialize                                            = "RayQueryInitialize"+showOperation RayQueryTerminate                                             = "RayQueryTerminate"+showOperation RayQueryGenerateIntersection                                  = "RayQueryGenerateIntersection"+showOperation RayQueryConfirmIntersection                                   = "RayQueryConfirmIntersection"+showOperation RayQueryProceed                                               = "RayQueryProceed"+showOperation RayQueryGetIntersectionType                                   = "RayQueryGetIntersectionType"+showOperation RayQueryGetRayTMin                                            = "RayQueryGetRayTMin"+showOperation RayQueryGetRayFlags                                           = "RayQueryGetRayFlags"+showOperation RayQueryGetIntersectionT                                      = "RayQueryGetIntersectionT"+showOperation RayQueryGetIntersectionInstanceCustomIndex                    = "RayQueryGetIntersectionInstanceCustomIndex"+showOperation RayQueryGetIntersectionInstanceId                             = "RayQueryGetIntersectionInstanceId"+showOperation RayQueryGetIntersectionInstanceShaderBindingTableRecordOffset = "RayQueryGetIntersectionInstanceShaderBindingTableRecordOffset"+showOperation RayQueryGetIntersectionGeometryIndex                          = "RayQueryGetIntersectionGeometryIndex"+showOperation RayQueryGetIntersectionPrimitiveIndex                         = "RayQueryGetIntersectionPrimitiveIndex"+showOperation RayQueryGetIntersectionBarycentrics                           = "RayQueryGetIntersectionBarycentrics"+showOperation RayQueryGetIntersectionFrontFace                              = "RayQueryGetIntersectionFrontFace"+showOperation RayQueryGetIntersectionCandidateAABBOpaque                    = "RayQueryGetIntersectionCandidateAABBOpaque"+showOperation RayQueryGetIntersectionObjectRayDirection                     = "RayQueryGetIntersectionObjectRayDirection"+showOperation RayQueryGetIntersectionObjectRayOrigin                        = "RayQueryGetIntersectionObjectRayOrigin"+showOperation RayQueryGetWorldRayDirection                                  = "RayQueryGetWorldRayDirection"+showOperation RayQueryGetWorldRayOrigin                                     = "RayQueryGetWorldRayOrigin"+showOperation RayQueryGetIntersectionObjectToWorld                          = "RayQueryGetIntersectionObjectToWorld"+showOperation RayQueryGetIntersectionWorldToObject                          = "RayQueryGetIntersectionWorldToObject"+-- GLSL instructions+showOperation GLSL_Round = "Round"+showOperation GLSL_RoundEven = "RoundEven"+showOperation GLSL_Trunc = "Trunc"+showOperation GLSL_FAbs = "FAbs"+showOperation GLSL_SAbs = "SAbs"+showOperation GLSL_FSign = "FSign"+showOperation GLSL_SSign = "SSign"+showOperation GLSL_Floor = "Floor"+showOperation GLSL_Ceil = "Ceil"+showOperation GLSL_Fract = "Fract"+showOperation GLSL_Sin = "Sin"+showOperation GLSL_Cos = "Cos"+showOperation GLSL_Tan = "Tan"+showOperation GLSL_Asin = "Asin"+showOperation GLSL_Acos = "Acos"+showOperation GLSL_Atan = "Atan"+showOperation GLSL_Sinh = "Sinh"+showOperation GLSL_Cosh = "Cosh"+showOperation GLSL_Tanh = "Tanh"+showOperation GLSL_Asinh = "Asinh"+showOperation GLSL_Acosh = "Acosh"+showOperation GLSL_Atanh = "Atanh"+showOperation GLSL_Atan2 = "Atan2"+showOperation GLSL_Pow = "Pow"+showOperation GLSL_Exp = "Exp"+showOperation GLSL_Log = "Log"+showOperation GLSL_Sqrt = "Sqrt"+showOperation GLSL_InvSqrt = "InvSqrt"+showOperation GLSL_Determinant = "Determinant"+showOperation GLSL_MatrixInverse = "MatrixInverse"+showOperation GLSL_FMin = "FMin"+showOperation GLSL_UMin = "UMin"+showOperation GLSL_SMin = "SMin"+showOperation GLSL_FMax = "FMax"+showOperation GLSL_UMax = "UMax"+showOperation GLSL_SMax = "SMax"+showOperation GLSL_Cross = "Cross"+showOperation GLSL_Normalize = "Normalize"+-- OpenCL instructions+showOperation OpenCL_Acos      = "Acos"+showOperation OpenCL_Acosh     = "Acosh"+showOperation OpenCL_Asin      = "Asin"+showOperation OpenCL_Asinh     = "Asinh"+showOperation OpenCL_Atan      = "Atan"+showOperation OpenCL_Atan2     = "Atan2"+showOperation OpenCL_Atanh     = "Atanh"+showOperation OpenCL_Cbrt      = "Cbrt"+showOperation OpenCL_Ceil      = "Ceil"+showOperation OpenCL_Cos       = "Cos"+showOperation OpenCL_Cosh      = "Cosh"+showOperation OpenCL_Erfc      = "Erfc"+showOperation OpenCL_Erf       = "Erf"+showOperation OpenCL_Exp       = "Exp"+showOperation OpenCL_Exp2      = "Exp2"+showOperation OpenCL_Exp10     = "Exp10"+showOperation OpenCL_Expm1     = "Expm1"+showOperation OpenCL_FAbs      = "FAbs"+showOperation OpenCL_FDim      = "FDim"+showOperation OpenCL_Floor     = "Floor"+showOperation OpenCL_FMAdd     = "FMAdd"+showOperation OpenCL_FMax      = "FMax"+showOperation OpenCL_FMin      = "FMin"+showOperation OpenCL_FMod      = "FMod"+showOperation OpenCL_Fract     = "Fract"+showOperation OpenCL_FRExp     = "FRExp"+showOperation OpenCL_Hypot     = "Hypot"+showOperation OpenCL_LogGamma  = "LogGamma"+showOperation OpenCL_Log       = "Log"+showOperation OpenCL_Log2      = "Log2"+showOperation OpenCL_Log10     = "Log10"+showOperation OpenCL_Log1P     = "Log1P"+showOperation OpenCL_LogB      = "LogB"+showOperation OpenCL_MAdd      = "MAdd"+showOperation OpenCL_MaxMag    = "MaxMag"+showOperation OpenCL_MinMag    = "MinMag"+showOperation OpenCL_ModF      = "ModF"+showOperation OpenCL_NaN       = "NaN"+showOperation OpenCL_NextAfter = "NextAfter"+showOperation OpenCL_Pow       = "Pow"+showOperation OpenCL_FRem      = "FRem"+showOperation OpenCL_FRemQuot  = "FRemQuot"+showOperation OpenCL_RoundEven = "RoundEven"+showOperation OpenCL_Round     = "Round"+showOperation OpenCL_InvSqrt   = "InvSqrt"+showOperation OpenCL_Sin       = "Sin"+showOperation OpenCL_SinCos    = "SinCos"+showOperation OpenCL_Sinh      = "Sinh"+showOperation OpenCL_Sqrt      = "Sqrt"+showOperation OpenCL_Tan       = "Tan"+showOperation OpenCL_Tanh      = "Tanh"+showOperation OpenCL_Gamma     = "Gamma"+showOperation OpenCL_Trunc     = "Trunc"+showOperation OpenCL_FSign     = "FSign"+showOperation OpenCL_SAbs      = "SAbs"+showOperation OpenCL_SAbsDiff  = "SAbsDiff"+showOperation OpenCL_SMax      = "SMax"+showOperation OpenCL_UMax      = "UMax"+showOperation OpenCL_SMin      = "SMin"+showOperation OpenCL_UMin      = "UMin"+showOperation OpenCL_UAbs      = "UAbs"+showOperation OpenCL_UAbsDiff  = "UAbsDiff"+showOperation OpenCL_Cross     = "Cross"+showOperation OpenCL_Normalize = "Normalize"+showOperation DebugPrintf      = "DebugPrintf"+showOperation (Code i) = show i+showOperation (ExtCode _ i) = show i
+ src/SPIRV/PrimOp.hs view
@@ -0,0 +1,480 @@+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-|+Module: SPIRV.PrimOp++This module categorises the raw primitive OpCodes from "SPIRV.Operation".++This allows easier use of operations by generalising over certain aspects,+such as unifying the various arithmetic and logical operations.+For instance, instead of having to distinguish:++  * @UMin@, unsigned integer minimum,+  * @SMin@, signed integer minimum, and+  * @FMin@, floating point minimum,++one can simply refer to the @Min@ operation defined in this module,+and the functions within this module will dispatch the correct primitive+operation depending on the types involved.++Refer also to the module "FIR.Prim.Op", which ties these into the rest of the library.+-}++module SPIRV.PrimOp+  ( PrimOp(..)+  , BoolPrimOp(..), EqPrimOp(..), OrdPrimOp(..)+  , BitPrimOp(..)+  , NumPrimOp(..), FloatPrimOp(..)+  , VecPrimOp(..), MatPrimOp(..)+  , ConvPrimOp(..)+  , GeomPrimOp(..)+  , SyncPrimOp(..)+  , GroupPrimOp(..), GroupNumOp(..), GroupBitwiseOp(..), GroupLogicOp(..)+  , RayPrimOp(..)+  , opAndReturnType, op+  ) where++-- base+import Prelude+  hiding ( Ordering(..) )+import Control.Arrow+  ( second )+import Data.Word+  ( Word32 )++-- fir+import SPIRV.Operation+import SPIRV.PrimTy+  ( PrimTy(..) )+import SPIRV.ScalarTy+  ( ScalarTy(..), Signedness(..) )+import SPIRV.Stage+  ( Backend(Vulkan, OpenCL) )++-------------------------------------------------------------------------------+-- names of primitive operations++data PrimOp where+  BoolOp  :: BoolPrimOp                                  -> PrimOp+  EqOp    :: EqPrimOp                        -> PrimTy   -> PrimOp+  OrdOp   :: OrdPrimOp                       -> ScalarTy -> PrimOp+  BitOp   :: BitPrimOp                       -> ScalarTy -> PrimOp+  NumOp   :: NumPrimOp                       -> ScalarTy -> PrimOp+  FloatOp :: FloatPrimOp                     -> ScalarTy -> PrimOp+  VecOp   :: VecPrimOp   -> Word32           -> PrimTy   -> PrimOp+  MatOp   :: MatPrimOp   -> Word32 -> Word32 -> ScalarTy -> PrimOp+  ConvOp  :: ConvPrimOp  -> ScalarTy         -> ScalarTy -> PrimOp+  CastOp  ::                                    PrimTy   -> PrimOp+  GeomOp  :: GeomPrimOp                                  -> PrimOp+  SyncOp  :: SyncPrimOp                                  -> PrimOp+  GroupOp :: GroupPrimOp                                 -> PrimOp+  RayOp   :: RayPrimOp                                   -> PrimOp+  deriving stock Show++data BoolPrimOp+  = BoolOr+  | BoolAnd+  | BoolNot+  deriving stock Show++data EqPrimOp+  = Equal+  | NotEqual+  deriving stock Show++data OrdPrimOp+  = GT+  | GTE+  | LT+  | LTE+  | Min+  | Max+  deriving stock Show++data BitPrimOp+  = BitAnd+  | BitOr+  | BitXor+  | BitNot+  | ReverseBits+  -- | Right shift: logical for unsigned integers, arithmetic for signed integers+  -- (as 'Data.Bits.shiftR').+  | BitShiftRight+  | BitShiftLeft+  deriving stock Show++data NumPrimOp+  -- additive monoid+  = Add+  -- semiring+  | Mul+  -- additive group+  | Sub+  | Neg+  -- signed+  | Abs+  | Sign+  -- division ring+  | Div+  -- archimedean ordered group+  | Mod+  | Rem+  | Quot+  deriving stock Show++data FloatPrimOp+  = FSin+  | FCos+  | FTan+  | FAsin+  | FAcos+  | FAtan+  | FSinh+  | FCosh+  | FTanh+  | FAsinh+  | FAcosh+  | FAtanh+  | FAtan2+  | FPow+  | FExp+  | FLog+  | FSqrt+  | FInvSqrt+  | FIsNaN+  | FIsInf+  deriving stock Show++data VecPrimOp+  = Vectorise PrimOp+  | DotV+  | VMulK+  | CrossV+  | NormaliseV+  deriving stock Show++data MatPrimOp+  = MMulK+  | MMulV+  | VMulM+  | MMulM+  | Transp+  | Det+  | Inv+  | Out+  deriving stock Show++data ConvPrimOp+  = Convert+  | CTruncate+  | CRound+  | CCeiling+  | CFloor+  deriving stock Show++data GeomPrimOp+  = EmitGeometryVertex+  | EndGeometryPrimitive+  deriving stock Show++data SyncPrimOp+  = ControlSync+  | MemorySync+  deriving stock Show++data GroupPrimOp+  = GroupNumOp     GroupNumOp     ScalarTy+  | GroupBitwiseOp GroupBitwiseOp ScalarTy+  | GroupLogicOp   GroupLogicOp+  deriving stock Show++data GroupNumOp+  = GroupAdd+  | GroupMin+  | GroupMax+  | GroupMul+  deriving stock Show++data GroupBitwiseOp+  = GroupBitwiseAnd+  | GroupBitwiseOr+  | GroupBitwiseXor+  deriving stock Show++data GroupLogicOp+  = GroupLogicalAnd+  | GroupLogicalOr+  | GroupLogicalXor+  deriving stock Show++data RayPrimOp+  = RT_ReportIntersection+  | RT_IgnoreIntersection+  | RT_TerminateRay+  | RT_AccelerationStructureFromDeviceAddress+  deriving stock Show++backendOp :: Backend -> Operation -> Operation -> Operation+backendOp Vulkan o _ = o+backendOp OpenCL _ o = o++opAndReturnType :: Backend -> PrimOp -> (Operation, PrimTy)+opAndReturnType _ (BoolOp boolOp)+  = ( booleanOp  boolOp+    , Boolean+    )+opAndReturnType _ (EqOp eqOp s)+  = ( equalityOp eqOp s+    , Boolean+    )+opAndReturnType bk (OrdOp ordOp s)+  = orderOp bk ordOp s+opAndReturnType _ (BitOp bitOp s)+  = bitwiseOp bitOp s+opAndReturnType _ (CastOp s)+  = castOp s+opAndReturnType bk (NumOp numOp s)+  = second Scalar (numericOp bk numOp s)+opAndReturnType bk (FloatOp flOp s)+  = floatingOp bk flOp s+opAndReturnType bk (VecOp vecOp n ty)+  = vectorOp bk vecOp n ty+opAndReturnType bk (MatOp matOp n m s)+  = matrixOp bk matOp n m s+opAndReturnType bk (ConvOp cOp s1 s2)+  = second Scalar (convOp bk cOp s1 s2)+opAndReturnType _ (GeomOp gOp)+  = geomOp gOp+opAndReturnType _ (SyncOp sOp)+  = syncOp sOp+opAndReturnType bk (GroupOp gOp)+  = groupOp bk gOp+opAndReturnType _ (RayOp rOp)+  = rayOp rOp++op :: Backend -> PrimOp -> Operation+op bkend = fst . opAndReturnType bkend++booleanOp :: BoolPrimOp -> Operation+booleanOp BoolOr  = LogicalOr+booleanOp BoolAnd = LogicalAnd+booleanOp BoolNot = LogicalNot++equalityOp :: EqPrimOp -> PrimTy -> Operation+equalityOp Equal    (Scalar (Floating  _)) = FOrdEqual -- not reflexive!+equalityOp Equal    (Scalar (Integer _ _)) = IEqual+equalityOp Equal    Boolean                = LogicalEqual+equalityOp NotEqual (Scalar (Floating  _)) = FOrdNotEqual+equalityOp NotEqual (Scalar (Integer _ _)) = INotEqual+equalityOp NotEqual Boolean                = LogicalNotEqual+equalityOp primOp ty = error $ "internal error: unsupported type " ++ show ty ++ " with equality operation " ++ show primOp++orderOp :: Backend -> OrdPrimOp -> ScalarTy -> (Operation, PrimTy)+orderOp _  GT  (Integer Unsigned _) = ( UGreaterThan        , Boolean )+orderOp _  GT  (Integer Signed   _) = ( SGreaterThan        , Boolean )+orderOp _  GT  (Floating         _) = ( FOrdGreaterThan     , Boolean )+orderOp _  GTE (Integer Unsigned _) = ( UGreaterThanEqual   , Boolean )+orderOp _  GTE (Integer Signed   _) = ( SGreaterThanEqual   , Boolean )+orderOp _  GTE (Floating         _) = ( FOrdGreaterThanEqual, Boolean )+orderOp _  LT  (Integer Unsigned _) = ( ULessThan           , Boolean )+orderOp _  LT  (Integer Signed   _) = ( SLessThan           , Boolean )+orderOp _  LT  (Floating         _) = ( FOrdLessThan        , Boolean )+orderOp _  LTE (Integer Unsigned _) = ( ULessThanEqual      , Boolean )+orderOp _  LTE (Integer Signed   _) = ( SLessThanEqual      , Boolean )+orderOp _  LTE (Floating         _) = ( FOrdLessThanEqual   , Boolean )+orderOp bk Min (Integer Unsigned w) = ( backendOp bk GLSL_UMin OpenCL_UMin , Scalar (Integer Unsigned w) )+orderOp bk Min (Integer Signed   w) = ( backendOp bk GLSL_SMin OpenCL_SMin , Scalar (Integer Signed   w) )+orderOp bk Min (Floating         w) = ( backendOp bk GLSL_FMin OpenCL_FMin , Scalar (Floating         w) )+orderOp bk Max (Integer Unsigned w) = ( backendOp bk GLSL_UMax OpenCL_UMax , Scalar (Integer Unsigned w) )+orderOp bk Max (Integer Signed   w) = ( backendOp bk GLSL_SMax OpenCL_SMax , Scalar (Integer Signed   w) )+orderOp bk Max (Floating         w) = ( backendOp bk GLSL_FMax OpenCL_FMax , Scalar (Floating         w) )++bitwiseOp :: BitPrimOp -> ScalarTy -> (Operation, PrimTy)+bitwiseOp BitAnd s = (BitwiseAnd, Scalar s)+bitwiseOp BitOr  s = (BitwiseOr , Scalar s)+bitwiseOp BitXor s = (BitwiseXor, Scalar s)+bitwiseOp BitNot s = (Not       , Scalar s)+bitwiseOp ReverseBits s = (BitReverse, Scalar s)+bitwiseOp BitShiftRight s@(Integer Unsigned _) = (ShiftRightLogical   , Scalar s)+bitwiseOp BitShiftRight s@(Integer Signed   _) = (ShiftRightArithmetic, Scalar s)+bitwiseOp BitShiftRight s@(Floating         _) = error ( "bitwiseOp: cannot shift a value of type " ++ show s )+bitwiseOp BitShiftLeft  s = (ShiftLeftLogical, Scalar s)++castOp :: PrimTy -> (Operation, PrimTy)+castOp s = (BitCast, s)++numericOp :: Backend -> NumPrimOp -> ScalarTy -> (Operation, ScalarTy)+-- additive monoid+numericOp _  Add  (Floating         w) = ( FAdd   , Floating         w )+numericOp _  Add  (Integer s        w) = ( IAdd   , Integer s        w )+-- semiring+numericOp _  Mul  (Floating         w) = ( FMul   , Floating         w )+numericOp _  Mul  (Integer s        w) = ( IMul   , Integer s        w )+-- additive group+numericOp _  Sub  (Floating         w) = ( FSub   , Floating         w )+numericOp _  Sub  (Integer s        w) = ( ISub   , Integer s        w )+numericOp _  Neg  (Floating         w) = ( FNegate, Floating         w )+numericOp _  Neg  (Integer Signed   w) = ( SNegate, Integer Signed   w )+numericOp _  Neg  (Integer Unsigned _) = error "internal error: 'negate' called on unsigned type"+-- signed+numericOp bk Abs  (Floating         w) = ( backendOp bk GLSL_FAbs OpenCL_FAbs  , Floating         w )+numericOp bk Abs  (Integer Signed   w) = ( backendOp bk GLSL_SAbs OpenCL_SAbs  , Integer Signed   w )+numericOp _  Abs  (Integer Unsigned _) = error "internal error: 'abs' called on unsigned type"+numericOp bk Sign (Floating         w) = ( backendOp bk GLSL_FSign OpenCL_FSign, Floating         w )+numericOp bk Sign (Integer Signed   w) +  | OpenCL <- bk = error "TODO: OpenCL backend does not support 'signum' operation on integer types"+  | otherwise =  ( GLSL_SSign  , Integer Signed   w )+numericOp _  Sign (Integer Unsigned _) = error "internal error: 'signum' called on unsigned type"+-- division ring+numericOp _  Div  (Floating         w) = ( FDiv   , Floating         w )+numericOp _  Div  (Integer  _       _) = error "internal error: Div used with integral type"+-- archimedean ordered group+numericOp _  Mod  (Floating         w) = ( FMod   , Floating         w )+numericOp _  Mod  (Integer Signed   w) = ( SMod   , Integer Signed   w )+numericOp _  Mod  (Integer Unsigned w) = ( UMod   , Integer Unsigned w )+numericOp _  Rem  (Floating         w) = ( FRem   , Floating         w )+numericOp _  Rem  (Integer Signed   w) = ( SRem   , Integer Signed   w )+numericOp _  Rem  (Integer Unsigned w) = ( UMod   , Integer Unsigned w ) -- URem pointless for unsigned type+numericOp _  Quot (Integer Signed   w) = ( SDiv   , Integer Signed   w )+numericOp _  Quot (Integer Unsigned w) = ( UDiv   , Integer Unsigned w )+numericOp _  Quot (Floating         _) = error "internal error: Quot used with floating-point type"++floatingOp :: Backend -> FloatPrimOp -> ScalarTy -> (Operation, PrimTy)+floatingOp bk FSin     s = ( backendOp bk GLSL_Sin     OpenCL_Sin     , Scalar s )+floatingOp bk FCos     s = ( backendOp bk GLSL_Cos     OpenCL_Cos     , Scalar s )+floatingOp bk FTan     s = ( backendOp bk GLSL_Tan     OpenCL_Tan     , Scalar s )+floatingOp bk FAsin    s = ( backendOp bk GLSL_Asin    OpenCL_Asin    , Scalar s )+floatingOp bk FAcos    s = ( backendOp bk GLSL_Acos    OpenCL_Acos    , Scalar s )+floatingOp bk FAtan    s = ( backendOp bk GLSL_Atan    OpenCL_Atan    , Scalar s )+floatingOp bk FSinh    s = ( backendOp bk GLSL_Sinh    OpenCL_Sinh    , Scalar s )+floatingOp bk FCosh    s = ( backendOp bk GLSL_Cosh    OpenCL_Cosh    , Scalar s )+floatingOp bk FTanh    s = ( backendOp bk GLSL_Tanh    OpenCL_Tanh    , Scalar s )+floatingOp bk FAsinh   s = ( backendOp bk GLSL_Asinh   OpenCL_Asinh   , Scalar s )+floatingOp bk FAcosh   s = ( backendOp bk GLSL_Acosh   OpenCL_Acosh   , Scalar s )+floatingOp bk FAtanh   s = ( backendOp bk GLSL_Atanh   OpenCL_Atanh   , Scalar s )+floatingOp bk FAtan2   s = ( backendOp bk GLSL_Atan2   OpenCL_Atan2   , Scalar s )+floatingOp bk FPow     s = ( backendOp bk GLSL_Pow     OpenCL_Pow     , Scalar s )+floatingOp bk FExp     s = ( backendOp bk GLSL_Exp     OpenCL_Exp     , Scalar s )+floatingOp bk FLog     s = ( backendOp bk GLSL_Log     OpenCL_Log     , Scalar s )+floatingOp bk FSqrt    s = ( backendOp bk GLSL_Sqrt    OpenCL_Sqrt    , Scalar s )+floatingOp bk FInvSqrt s = ( backendOp bk GLSL_InvSqrt OpenCL_InvSqrt , Scalar s )+floatingOp _  FIsNaN   _ = ( IsNan, Boolean )+floatingOp _  FIsInf   _ = ( IsInf, Boolean )++vectorOp :: Backend -> VecPrimOp -> Word32 -> PrimTy -> (Operation, PrimTy)+vectorOp bk (Vectorise prim) n ty = ( op bk prim, Vector n ty )+vectorOp _  DotV       _ (Scalar (Floating w)) = ( Dot, Scalar (Floating w) )+vectorOp _  DotV       _ _                     = error "internal error: dot product: vector elements must be of floating-point type."+vectorOp _  VMulK      n (Scalar (Floating w)) = ( VectorTimesScalar, Vector n (Scalar (Floating w)) )+vectorOp _  VMulK      _ _                     = error "internal error: scalar multiplication: vector elements must be of floating-point type."+vectorOp bk CrossV     n (Scalar (Floating w)) = ( backendOp bk GLSL_Cross OpenCL_Cross, Vector n (Scalar (Floating w)) )+vectorOp _  CrossV     _ _                     = error "internal error: cross product: vector elements must be of floating-point type."+vectorOp bk NormaliseV n (Scalar (Floating w)) = ( backendOp bk GLSL_Normalize OpenCL_Normalize, Vector n (Scalar (Floating w)) )+vectorOp _  NormaliseV _ _                     = error "internal error: normalise: vector elements must be of floating-point type."++matrixOp :: Backend -> MatPrimOp -> Word32 -> Word32 -> ScalarTy -> (Operation, PrimTy)+matrixOp _  MMulK  n m s = ( MatrixTimesScalar, Matrix n m s )+matrixOp _  MMulV  n _ s = ( MatrixTimesVector, Vector n   (Scalar s) )+matrixOp _  VMulM  n _ s = ( VectorTimesMatrix, Vector n   (Scalar s) )+matrixOp _  MMulM  n m s = ( MatrixTimesMatrix, Matrix n m s )+matrixOp _  Transp n m s = ( Transpose        , Matrix n m s )+matrixOp bk Det    _ _ s+  | Vulkan <- bk = ( GLSL_Determinant      , Scalar     s )+  | otherwise    = error "todo: determinant not implemented in OpenCL backend"+matrixOp bk Inv    n m s+  | Vulkan <- bk = ( GLSL_MatrixInverse    , Matrix n m s )+  | otherwise    = error "todo: matrix inverse not implemented in OpenCL backend"+matrixOp _  Out    n m s = ( OuterProduct     , Matrix n m s )++convOp :: Backend -> ConvPrimOp -> ScalarTy -> ScalarTy -> (Operation, ScalarTy)+convOp _  Convert (Integer Signed   _) (Floating         w) = ( ConvertSToF, Floating         w )+convOp _  Convert (Integer Unsigned _) (Floating         w) = ( ConvertUToF, Floating         w )+convOp _  Convert (Floating         _) (Integer Signed   w) = ( ConvertFToS, Integer Signed   w )+convOp _  Convert (Floating         _) (Integer Unsigned w) = ( ConvertFToU, Integer Unsigned w )+convOp bk Convert (Integer Unsigned v) (Integer Signed   w)+  | OpenCL <- bk = ( SatConvertUToS, Integer Signed w )+  | v == w = ( BitCast, Integer Signed   w )+  | otherwise = error "internal error: unsupported conversion between integer types of different width and sign"+convOp bk Convert (Integer Signed   v) (Integer Unsigned w)+  | OpenCL <- bk = ( SatConvertSToU, Integer Unsigned w )+  | v == w = ( BitCast    , Integer Unsigned w )+  | otherwise = error "internal error: unsupported conversion between integer types of different width and sign"+convOp _  Convert (Floating         v) (Floating         w)+  | v /= w = ( FConvert, Floating         w)+convOp _  Convert (Integer Signed   v) (Integer Signed   w)+  | v /= w = ( SConvert, Integer Signed   w)+convOp _  Convert (Integer Unsigned v) (Integer Unsigned w)+  | v /= w = ( UConvert, Integer Unsigned w)+convOp _  CTruncate (Floating _) (Integer Signed   w) = ( ConvertFToS, Integer Signed   w )+convOp _  CTruncate (Floating _) (Integer Unsigned w) = ( ConvertFToU, Integer Unsigned w )+convOp bk CTruncate (Floating v) (Floating w)+  | v == w    = ( backendOp bk GLSL_Trunc OpenCL_Trunc, Floating w )+  | otherwise = error "internal error: unsupported truncation between floating point types of different widths"+convOp bk CRound    (Floating v) (Floating w)+  | v == w    = ( backendOp bk GLSL_Round OpenCL_Round, Floating w )+  | otherwise = error "internal error: unsupported rounding between floating point types of different widths"+convOp bk CFloor    (Floating v) (Floating w)+  | v == w    = ( backendOp bk GLSL_Floor OpenCL_Floor, Floating w )+  | otherwise = error "internal error: unsupported floor operation between floating point types of different widths"+convOp bk CCeiling (Floating v) (Floating w)+  | v == w    = ( backendOp bk GLSL_Ceil OpenCL_Ceil, Floating w )+  | otherwise = error "internal error: unsupported ceiling operation between floating point types of different widths"+convOp _  cOp a b+  = error $ "internal error: unsupported operation " ++ show cOp ++ " from type " ++ show a ++ " to type " ++ show b++geomOp :: GeomPrimOp -> (Operation, PrimTy)+geomOp EmitGeometryVertex   = ( EmitVertex  , Unit )+geomOp EndGeometryPrimitive = ( EndPrimitive, Unit )++syncOp :: SyncPrimOp -> (Operation, PrimTy)+syncOp ControlSync = ( ControlBarrier, Unit )+syncOp MemorySync  = ( MemoryBarrier , Unit )++groupOp :: Backend -> GroupPrimOp -> (Operation, PrimTy)+groupOp bk (GroupNumOp gpOp s) = second Scalar $ groupNumOp bk gpOp s+groupOp OpenCL gpOp = error $ "internal error: OpenCL backend does not support group operation " ++ show gpOp+groupOp _ (GroupBitwiseOp gpOp s) = (groupBitwiseOp gpOp, Scalar s)+groupOp _ (GroupLogicOp   gpOp)   = (groupLogicOp gpOp, Boolean)++groupNumOp :: Backend -> GroupNumOp -> ScalarTy -> (Operation, ScalarTy)+groupNumOp OpenCL GroupAdd (Floating         w) = ( GroupFAdd, Floating         w )+groupNumOp OpenCL GroupAdd (Integer s        w) = ( GroupIAdd, Integer s        w )+groupNumOp OpenCL GroupMax (Floating         w) = ( GroupFMax, Floating         w )+groupNumOp OpenCL GroupMax (Integer Signed   w) = ( GroupSMax, Integer Signed   w )+groupNumOp OpenCL GroupMax (Integer Unsigned w) = ( GroupUMax, Integer Unsigned w )+groupNumOp OpenCL GroupMin (Floating         w) = ( GroupFMin, Floating         w )+groupNumOp OpenCL GroupMin (Integer Signed   w) = ( GroupSMin, Integer Signed   w )+groupNumOp OpenCL GroupMin (Integer Unsigned w) = ( GroupUMin, Integer Unsigned w )+groupNumOp Vulkan GroupAdd (Floating         w) = ( GroupNonUniformFAdd, Floating         w )+groupNumOp Vulkan GroupAdd (Integer s        w) = ( GroupNonUniformIAdd, Integer s        w )+groupNumOp Vulkan GroupMul (Floating         w) = ( GroupNonUniformFMul, Floating         w )+groupNumOp Vulkan GroupMul (Integer s        w) = ( GroupNonUniformIMul, Integer s        w )+groupNumOp Vulkan GroupMax (Floating         w) = ( GroupNonUniformFMax, Floating         w )+groupNumOp Vulkan GroupMax (Integer Signed   w) = ( GroupNonUniformSMax, Integer Signed   w )+groupNumOp Vulkan GroupMax (Integer Unsigned w) = ( GroupNonUniformUMax, Integer Unsigned w )+groupNumOp Vulkan GroupMin (Floating         w) = ( GroupNonUniformFMin, Floating         w )+groupNumOp Vulkan GroupMin (Integer Signed   w) = ( GroupNonUniformSMin, Integer Signed   w )+groupNumOp Vulkan GroupMin (Integer Unsigned w) = ( GroupNonUniformUMin, Integer Unsigned w )+groupNumOp OpenCL GroupMul _ =+  error "internal error: OpenCL backend does not support GroupMul operation"++groupBitwiseOp :: GroupBitwiseOp -> Operation+groupBitwiseOp GroupBitwiseAnd = GroupNonUniformBitwiseAnd+groupBitwiseOp GroupBitwiseOr  = GroupNonUniformBitwiseOr+groupBitwiseOp GroupBitwiseXor = GroupNonUniformBitwiseXor++groupLogicOp :: GroupLogicOp -> Operation+groupLogicOp GroupLogicalAnd = GroupNonUniformLogicalAnd+groupLogicOp GroupLogicalOr  = GroupNonUniformLogicalOr+groupLogicOp GroupLogicalXor = GroupNonUniformLogicalXor++rayOp :: RayPrimOp -> (Operation, PrimTy)+rayOp RT_ReportIntersection                     = ( ReportIntersection, Boolean )+rayOp RT_IgnoreIntersection                     = ( IgnoreIntersection, Unit )+rayOp RT_TerminateRay                           = ( TerminateRay, Unit )+rayOp RT_AccelerationStructureFromDeviceAddress = ( ConvertUToAccelerationStructure, AccelerationStructure )
+ src/SPIRV/PrimTy.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE NamedFieldPuns     #-}++{-|+Module: SPIRV.PrimTy++This module enumerates the types that exist within the SPIR-V type system.++These are logical types: they don't include any memory layout information.+The layout of a type in memory is specified separately, by a 'Layout'.++See the SPIR-V specification, §3.22.6 __Type-Declaration instructions__.+-}++module SPIRV.PrimTy+  ( PrimTy(..)+  , PointerTy(..)+  , componentLayout+  , tyOp+  , scalars+  ) where++-- base+import Data.Word+  ( Word32 )+import Prelude+  hiding (Integer, Floating)++-- text-short+import Data.Text.Short+  ( ShortText )++-- fir+import SPIRV.Image+  ( Image(texelComponent) )+import SPIRV.Layout+  ( Layout(blockKind) )+import SPIRV.Operation+  hiding ( Function, Image, SampledImage )+import SPIRV.ScalarTy+  ( ScalarTy(Integer, Floating) )+import SPIRV.Storage+  ( StorageClass )++--------------------------------------------------+-- SPIR-V types++data PrimTy where+  Unit    :: PrimTy -- known as Void in the SPIR-V specification+  Boolean :: PrimTy+  Scalar  :: ScalarTy -> PrimTy+  Vector  ::+    { size  :: Word32+    , eltTy :: PrimTy+    } -> PrimTy+  Matrix ::+    { rows    :: Word32+    , cols    :: Word32+    , entryTy :: ScalarTy+    } -> PrimTy+  Array ::+    { size  :: Word32+    , eltTy :: PrimTy+    } -> PrimTy+  RuntimeArray ::+    { eltTy :: PrimTy+    } -> PrimTy+  Struct ::+    { eltTys :: [ ( Maybe ShortText, PrimTy ) ]+    -- ^ the (optional) field names are only used to annotate the source code+    } -> PrimTy+  Pointer  :: PointerTy -> PrimTy+  Function ::+    { argumentTypes :: [PrimTy]+    , resultType    :: PrimTy+    } -> PrimTy+  Image        :: Image -> PrimTy+  Sampler      ::          PrimTy -- opaque+  SampledImage :: Image -> PrimTy+  AccelerationStructure :: PrimTy -- opaque+  RayQuery              :: PrimTy -- opaque+  deriving stock ( Show, Eq, Ord )++-- | A pointer type, to a type laid out in memory in the given way.+data PointerTy+  = PointerTy+  { pointerStorage :: StorageClass+  , pointerLayout  :: Layout+  , pointee        :: PrimTy+  }+  deriving stock ( Show, Eq, Ord )++-- | The layout of the components of a composite type with the given layout.+--+-- The elements of an array of interface blocks are interface blocks,+-- but the members of an interface block are not.+componentLayout :: PrimTy -> Layout -> Layout+componentLayout Array        {} lay = lay+componentLayout RuntimeArray {} lay = lay+componentLayout _               lay = lay { blockKind = Nothing }++tyOp :: PrimTy -> Operation+tyOp Unit                    = TypeVoid+tyOp Boolean                 = TypeBool+tyOp (Scalar Integer   {})   = TypeInt+tyOp (Scalar Floating  {})   = TypeFloat+tyOp (Vector _ (Vector _ _)) = TypeMatrix+  -- SPIR-V doesn't have vectors of vectors, so declare them as matrices instead.+  -- This is a bit of a workaround for issue #95.+tyOp Vector             {}   = TypeVector+tyOp Matrix             {}   = TypeMatrix+tyOp Array              {}   = TypeArray+tyOp RuntimeArray       {}   = TypeRuntimeArray+tyOp Struct             {}   = TypeStruct+tyOp Function           {}   = TypeFunction+tyOp Pointer            {}   = TypePointer+tyOp Image              {}   = TypeImage+tyOp Sampler                 = TypeSampler+tyOp SampledImage       {}   = TypeSampledImage+tyOp AccelerationStructure   = TypeAccelerationStructure+tyOp RayQuery                = TypeRayQuery++scalars :: PrimTy -> [ ScalarTy ]+scalars Unit                     = [ ]+scalars Boolean                  = [ ]+scalars (Scalar s)               = [ s ]+scalars (Vector _ a)             = scalars a+scalars (Matrix _ _ a)           = [ a ]+scalars (Array { eltTy })        = scalars eltTy+scalars (RuntimeArray { eltTy }) = scalars eltTy+scalars (Struct { eltTys })      = scalars . snd =<< eltTys+scalars (Pointer ptrTy)          = scalars ( pointee ptrTy )+scalars (Function as b)          = scalars b ++ ( scalars =<< as )+scalars (Image img)              = [ texelComponent img ]+scalars Sampler                  = [ ]+scalars (SampledImage img)       = [ texelComponent img ]+scalars AccelerationStructure    = []+scalars RayQuery                 = []
+ src/SPIRV/Requirements.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE ViewPatterns    #-}++{-|+Module: SPIRV.Requrements++Functions computing capability/extension requirements+for various circumstances.++-}++module SPIRV.Requirements where++-- base+import Data.Bits+  ( Bits(testBit) )+import Data.Word+  ( Word32 )++-- containers+import Data.Set+  ( Set )+import qualified Data.Set as Set+  ( insert, unions )++-- fir+import SPIRV.Capability+import SPIRV.Extension+import qualified SPIRV.Image    as Image+import           SPIRV.Operation+  hiding ( Capability )+import           SPIRV.PrimOp+  ( PrimOp(..), VecPrimOp(..), GroupPrimOp(..), BitPrimOp(ReverseBits)+  , op+  )+import           SPIRV.PrimTy+  ( PrimTy, scalars )+import qualified SPIRV.PrimTy   as PrimTy+import           SPIRV.ScalarTy+  ( ScalarTy, Width(..) )+import qualified SPIRV.ScalarTy as ScalarTy+import           SPIRV.Stage+  ( ExecutionModel(Stage), Stage(..), Shader, Backend(..) )+import qualified SPIRV.Stage    as Stage+  ( ExecutionModel(..), Shader(..) )+import           SPIRV.Version+  ( Version(..) )++--------------------------------------------------------------------------+-- primitive operations++primOpCapabilities :: Backend -> PrimOp -> Set Capability+primOpCapabilities bk ( op bk -> SatConvertSToU ) = [ ComputeKernel ]+primOpCapabilities bk ( op bk -> SatConvertUToS ) = [ ComputeKernel ]+primOpCapabilities _  ( MatOp {}                ) = [ Matrix ]+primOpCapabilities _  ( RayOp {}                ) = [ RayTracingKHR ]+primOpCapabilities bk ( BitOp ReverseBits _     ) =+  case bk of+    SPIRV.Stage.Vulkan -> [ ] -- (requires the Shader capability)+    SPIRV.Stage.OpenCL -> [ BitInstructions ]+primOpCapabilities bk ( GroupOp gpOp            ) = groupOpCapabilities bk gpOp+primOpCapabilities bk ( VecOp ( Vectorise primop ) _ _ ) = primOpCapabilities bk primop+primOpCapabilities _  _                           = [ ]++groupOpCapabilities :: Backend -> GroupPrimOp -> Set Capability+groupOpCapabilities bk _ =+  case bk of+    SPIRV.Stage.OpenCL -> [ Groups ]+    SPIRV.Stage.Vulkan -> [ GroupNonUniformArithmetic ]++primOpExtensions :: Backend -> PrimOp -> Set Extension+primOpExtensions SPIRV.Stage.OpenCL ( BitOp ReverseBits _ ) = [ SPV_KHR_bit_instructions ]+primOpExtensions bk ( VecOp ( Vectorise primop ) _ _ ) = primOpExtensions bk primop+primOpExtensions _  _                                  = [ ]++-- | Why the backend doesn't support a primitive operation (regardless of capabilities,+-- extensions and SPIR-V version), if it doesn't.+primOpUnsupported :: Backend -> PrimOp -> Maybe String+primOpUnsupported SPIRV.Stage.Vulkan ( BitOp ReverseBits s )+  | ScalarTy.scalarWidth s /= W32+  = Just "Vulkan only supports OpBitReverse on 32-bit integers"+primOpUnsupported bk ( VecOp ( Vectorise primop ) _ _ ) = primOpUnsupported bk primop+primOpUnsupported _  _                                  = Nothing++primOpMinVersion :: Backend -> PrimOp -> Version+primOpMinVersion SPIRV.Stage.Vulkan ( GroupOp {} ) = Version 1 3+primOpMinVersion _                  _              = Version 1 0++--------------------------------------------------------------------------+-- types++scalarCapabilities :: ScalarTy -> Set Capability+scalarCapabilities (ScalarTy.Integer _ W8 ) = [ Int8  ]+scalarCapabilities (ScalarTy.Integer _ W16) = [ Int16 ]+scalarCapabilities (ScalarTy.Integer _ W64) = [ Int64 ]+scalarCapabilities (ScalarTy.Integer _ _  ) = [ ]+scalarCapabilities (ScalarTy.Floating  W16) = [ Float16 ]+scalarCapabilities (ScalarTy.Floating  W64) = [ Float64 ]+scalarCapabilities (ScalarTy.Floating  _  ) = [ ]++primTyCapabilities :: PrimTy -> Set Capability+primTyCapabilities ( PrimTy.Matrix _ _ ty )+  = Set.insert Matrix    $ scalarCapabilities ty+primTyCapabilities ( PrimTy.Vector n   ty )+  | n > 4     = Set.insert Vector16 $ primTyCapabilities ty+  | otherwise =                       primTyCapabilities ty+primTyCapabilities ( PrimTy.Image img )+  = imageCapabilities img <> scalarCapabilities ( Image.texelComponent img )+primTyCapabilities ( PrimTy.SampledImage img )+  = imageCapabilities img <> scalarCapabilities ( Image.texelComponent img )+primTyCapabilities ty+  = Set.unions ( map scalarCapabilities ( PrimTy.scalars ty) )++-- types when present in an interface+globalCapabilities :: PrimTy -> Set Capability+globalCapabilities = primTyCapabilities++globalScalarExtensions :: ScalarTy -> Set Extension+globalScalarExtensions (ScalarTy.Integer _ W8 ) = [ SPV_KHR_8bit_storage  ]+globalScalarExtensions (ScalarTy.Integer _ W16) = [ SPV_KHR_16bit_storage ]+globalScalarExtensions (ScalarTy.Integer _ _  ) = [ ]+globalScalarExtensions (ScalarTy.Floating  W16) = [ SPV_KHR_16bit_storage ]+globalScalarExtensions (ScalarTy.Floating  _  ) = [ ]++globalExtensions :: PrimTy -> Set Extension+globalExtensions ty = Set.unions ( map globalScalarExtensions ( scalars ty ) )++--------------------------------------------------------------------------+-- stages / execution models++shaderCapabilities :: Shader -> Set Capability+shaderCapabilities Stage.VertexShader                 = [ Shader       ]+shaderCapabilities Stage.TessellationControlShader    = [ Tessellation ] --- |+shaderCapabilities Stage.TessellationEvaluationShader = [ Tessellation ] --- |-- shader capability implied+shaderCapabilities Stage.GeometryShader               = [ Geometry     ] --- |+shaderCapabilities Stage.FragmentShader               = [ Shader       ]+shaderCapabilities Stage.ComputeShader                = [ Shader       ]++stageCapabilities :: Stage -> Set Capability+stageCapabilities (ShaderStage s) = shaderCapabilities s+stageCapabilities (MeshStage   _) = [ MeshShadingNV ]+stageCapabilities (RayStage    _) = [ RayTracingKHR ]++executionModelCapabilities :: ExecutionModel -> Set Capability+executionModelCapabilities (Stage s)    = stageCapabilities s+executionModelCapabilities Stage.Kernel = [ ComputeKernel, Addresses ]++stageExtensions :: Stage -> Set Extension+stageExtensions (ShaderStage _) = [ ]+stageExtensions (MeshStage   _) = [ SPV_NV_mesh_shader ]+stageExtensions (RayStage    _) = [ SPV_KHR_ray_tracing ]++executionModelExtensions :: ExecutionModel -> Set Extension+executionModelExtensions (Stage s)    = stageExtensions s+executionModelExtensions Stage.Kernel = [ ]++--------------------------------------------------------------------------+-- images, image formats, image properties++formatCapabilities :: Image.ImageFormat Word32 -> Set Capability+formatCapabilities format+  = case Image.requiredFormatUsage format of+      Just Image.Storage   -> [ Shader, StorageImageExtendedFormats ]+      _                    -> [ Shader ]++-- | Capabilities required to read from an image of the given dimensionality+-- and format using @OpImageRead@.+unknownFormatReadCapabilities :: Image.Dimensionality -> Maybe (Image.ImageFormat Word32) -> Set Capability+unknownFormatReadCapabilities Image.SubpassData _       = [ ]+unknownFormatReadCapabilities _                 Nothing = [ StorageImageReadWithoutFormat ]+unknownFormatReadCapabilities _                 _       = [ ]++-- | Capabilities required to write to an image of the given format+-- using @OpImageWrite@.+unknownFormatWriteCapabilities :: Maybe (Image.ImageFormat Word32) -> Set Capability+unknownFormatWriteCapabilities Nothing = [ StorageImageWriteWithoutFormat ]+unknownFormatWriteCapabilities _       = [ ]++-- | Capabilities required to declare an image type.+imageCapabilities :: Image.Image -> Set Capability+imageCapabilities img+  =  foldMap formatCapabilities ( Image.imageFormat img )+  <> dimCapabilities ( Image.imageUsage img ) ( Image.dimensionality img ) ( Image.arrayness img )+  <> msCapabilities  ( Image.imageUsage img ) ( Image.arrayness img ) ( Image.multiSampling img )++dimCapabilities :: Maybe Image.ImageUsage -> Image.Dimensionality -> Image.Arrayness -> Set Capability+dimCapabilities _                    Image.SubpassData _             = [ Shader, InputAttachment ]+dimCapabilities (Just Image.Storage) Image.Rect        _             = [ Shader, SampledRect, ImageRect ]+dimCapabilities _                    Image.Rect        _             = [ Shader, SampledRect ]+dimCapabilities (Just Image.Storage) Image.OneD        _             = [ Sampled1D, Image1D ]+dimCapabilities _                    Image.OneD        _             = [ Sampled1D ]+dimCapabilities (Just Image.Storage) Image.Cube        Image.Arrayed = [ SampledCubeArray, ImageCubeArray ]+dimCapabilities _                    Image.Cube        Image.Arrayed = [ SampledCubeArray ]+dimCapabilities (Just Image.Storage) Image.Buffer      _             = [ SampledBuffer, ImageBuffer ]+dimCapabilities _                    Image.Buffer      _             = [ SampledBuffer ]+dimCapabilities _                    _                 _             = [ ]++msCapabilities :: Maybe Image.ImageUsage -> Image.Arrayness -> Image.MultiSampling -> Set Capability+msCapabilities (Just Image.Storage) Image.Arrayed    Image.MultiSampled = [ StorageImageMultisample, ImageMSArray ]+msCapabilities (Just Image.Storage) Image.NonArrayed Image.MultiSampled = [ StorageImageMultisample ]+msCapabilities _                    _                _                  = [ ]++-- lod capability from image operand bitmask+-- (note that the bitmask is shifted up one byte from what SPIR-V uses)+lodCapabilities :: Backend -> Word32 -> Set Capability+lodCapabilities bk bm+  -- uses the LOD operand+  | bm `testBit` 9+  && bk == SPIRV.Stage.OpenCL+  = [ ImageBasic, ImageMipmap ]+  -- uses the MinLOD opeand+  | bm `testBit` 15+  = [ MinLod ]+  | otherwise+  = [ ]++-- whether the ImageGatherExtended capability is required+gatherCapabilities :: Word32 -> Set Capability+gatherCapabilities bm+  |  bm `testBit` 12 -- Offset operand+  || bm `testBit` 13 -- ConstOffsets operand+  = [ ImageGatherExtended ]+  | otherwise+  = [ ]
+ src/SPIRV/ScalarTy.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE TypeFamilies          #-}++{-|+Module: SPIRV.ScalarTy++This module enumerates the scalar types that exist within the SPIR-V type system:++  * unsigned integers,+  * signed integers, and+  * floating point numbers.++-}++module SPIRV.ScalarTy+  ( Width(..), width, WidthToNat+  , Signedness(..), signedness+  , ScalarTy(..), scalarWidth, ScalarWidth+  ) where++-- base+import Data.Word+  ( Word32 )+import GHC.TypeNats+  ( Nat )+import Prelude+  hiding ( Integer, Floating )++-- fir+import Data.Type.Known+  ( Demotable(Demote), Known(known) )++--------------------------------------------------+-- SPIR-V scalar types++data Width+  = W8+  | W16+  | W32+  | W64+  deriving stock ( Show, Eq, Ord, Enum, Bounded )++width :: Width -> Word32+width W8  = 8+width W16 = 16+width W32 = 32+width W64 = 64++type family WidthToNat (width :: Width) :: Nat where+  WidthToNat W8  = 8+  WidthToNat W16 = 16+  WidthToNat W32 = 32+  WidthToNat W64 = 64++data Signedness+  = Unsigned+  | Signed+  deriving stock ( Show, Eq, Ord, Enum, Bounded )++instance Demotable Signedness where+  type Demote Signedness = Signedness+instance Known Signedness Unsigned where+  known = Unsigned+instance Known Signedness Signed where+  known = Signed++signedness :: Signedness -> Word32+signedness Unsigned = 0+signedness Signed   = 1++data ScalarTy where+  Integer  :: Signedness -> Width -> ScalarTy+  Floating ::               Width -> ScalarTy+  deriving stock ( Show, Eq, Ord )++scalarWidth :: ScalarTy -> Width+scalarWidth (Integer _ w) = w+scalarWidth (Floating  w) = w++type family ScalarWidth (sTy :: ScalarTy) :: Width where+  ScalarWidth (Integer _ w) = w+  ScalarWidth (Floating  w) = w
+ src/SPIRV/Stage.hs view
@@ -0,0 +1,510 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DerivingVia           #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++{-|+Module: SPIRV.Stage++This module enumerates the SPIR-V execution models / shader stages.++These are used both at the type-level and at the value-level.++See the SPIR-V specification, §3.3 __Execution Model__.+++This module also keeps track of certain execution modes that need to be known+at the type-level to perform certain type-level checks for custom error messages,+e.g. which kind of tessellation is happening (triangles, quads, isolines).+This information is eventually computed using user "SPIRV.Decoration.Decoration"s,+but it proved useful to separate these decorations out.++-}++module SPIRV.Stage where++-- base+import Data.Kind+  ( Type )+import Data.Word+  ( Word32 )+import GHC.TypeLits+  ( Symbol, AppendSymbol )+import GHC.TypeNats+  ( Nat, KnownNat, CmpNat )++-- fir+import Data.Binary.Class.Put+  ( Put(..), PutWord32Enum(..) )+import Data.Type.Known+  ( Demotable(Demote), Known(known), knownValue )+import Data.Type.POrd+  ( POrd(Compare) )++-------------------------------------------------------+-- execution models / stages++data ExecutionModel+  = Stage Stage+  | Kernel -- OpenCL compute kernel+  deriving stock ( Show, Eq, Ord )++data Stage+  = ShaderStage Shader+  | MeshStage   MeshShader+  | RayStage    RayShader+  deriving stock ( Show, Eq, Ord )++data Shader+  = VertexShader+  | TessellationControlShader+  | TessellationEvaluationShader+  | GeometryShader+  | FragmentShader+  | ComputeShader -- GLCompute in SPIR-V+  deriving stock ( Show, Eq, Ord, Enum, Bounded )+  deriving Put via (PutWord32Enum Shader)++data MeshShader+  = TaskShader+  | MeshShader+  deriving stock ( Show, Eq, Ord, Enum, Bounded )++instance Put MeshShader where+  put = put @Word32 . (+5267) . fromIntegral . fromEnum+  wordCount _ = 1++data RayShader+  = RayGenerationShader+  | IntersectionShader+  | AnyHitShader+  | ClosestHitShader+  | MissShader+  | CallableShader+  deriving stock ( Show, Eq, Ord, Enum, Bounded )++instance Put RayShader where+  put = put @Word32 . (+5313) . fromIntegral . fromEnum+  wordCount _ = 1++instance Put Stage where+  put (ShaderStage s) = put s+  put (MeshStage   s) = put s+  put (RayStage    s) = put s+  wordCount _ = 1++instance Put ExecutionModel where+  put (Stage s) = put s+  put Kernel = put @Word32 6+  wordCount _ = 1++stageID :: Stage -> Word32+stageID (ShaderStage s) = fromIntegral ( fromEnum s )+stageID (MeshStage   s) = fromIntegral ( fromEnum s + 5267 )+stageID (RayStage    s) = fromIntegral ( fromEnum s + 5313 )++executionModelID :: ExecutionModel -> Word32+executionModelID (Stage s) = stageID s+executionModelID Kernel    = 6+++type Vertex                 = 'Stage ('ShaderStage 'VertexShader)+type TessellationControl    = 'Stage ('ShaderStage 'TessellationControlShader)+type TessellationEvaluation = 'Stage ('ShaderStage 'TessellationEvaluationShader)+type Geometry               = 'Stage ('ShaderStage 'GeometryShader)+type Fragment               = 'Stage ('ShaderStage 'FragmentShader)+type Compute                = 'Stage ('ShaderStage 'ComputeShader)++type Task = 'Stage ('MeshStage 'TaskShader)+type Mesh = 'Stage ('MeshStage 'MeshShader)++type RayGeneration = 'Stage ('RayStage 'RayGenerationShader)+type Intersection  = 'Stage ('RayStage 'IntersectionShader)+type AnyHit        = 'Stage ('RayStage 'AnyHitShader)+type ClosestHit    = 'Stage ('RayStage 'ClosestHitShader)+type Miss          = 'Stage ('RayStage 'MissShader)+type Callable      = 'Stage ('RayStage 'CallableShader)+++instance Demotable Shader where+  type Demote Shader = Shader++instance Known Shader VertexShader where+  known = VertexShader+instance Known Shader TessellationControlShader where+  known = TessellationControlShader+instance Known Shader TessellationEvaluationShader where+  known = TessellationEvaluationShader+instance Known Shader GeometryShader where+  known = GeometryShader+instance Known Shader FragmentShader where+  known = FragmentShader+instance Known Shader ComputeShader where+  known = ComputeShader++instance Demotable MeshShader where+  type Demote MeshShader = MeshShader++instance Known MeshShader 'TaskShader where+  known = TaskShader+instance Known MeshShader 'MeshShader where+  known = MeshShader++instance Demotable RayShader where+  type Demote RayShader = RayShader++instance Known RayShader RayGenerationShader where+  known = RayGenerationShader+instance Known RayShader IntersectionShader where+  known = IntersectionShader+instance Known RayShader AnyHitShader where+  known = AnyHitShader+instance Known RayShader ClosestHitShader where+  known = ClosestHitShader+instance Known RayShader MissShader where+  known = MissShader+instance Known RayShader CallableShader where+  known = CallableShader++instance Demotable Stage where+  type Demote Stage = Stage++instance Known Shader shader => Known Stage (ShaderStage shader) where+  known = ShaderStage ( knownValue @shader )+instance Known MeshShader meshShader => Known Stage (MeshStage meshShader) where+  known = MeshStage ( knownValue @meshShader )+instance Known RayShader rayShader => Known Stage (RayStage rayShader) where+  known = RayStage ( knownValue @rayShader )++instance Demotable ExecutionModel where+  type Demote ExecutionModel = ExecutionModel++instance Known Stage stage => Known ExecutionModel ('Stage stage) where+  known = Stage ( knownValue @stage )+instance Known ExecutionModel Kernel where+  known = Kernel+++type family FromEnumShader (s :: Shader) :: Nat where+  FromEnumShader VertexShader                 = 0+  FromEnumShader TessellationControlShader    = 1+  FromEnumShader TessellationEvaluationShader = 2+  FromEnumShader GeometryShader               = 3+  FromEnumShader FragmentShader               = 4+  FromEnumShader ComputeShader                = 5++type family FromEnumMeshShader (s :: MeshShader) :: Nat where+  FromEnumMeshShader 'TaskShader = 5267+  FromEnumMeshShader 'MeshShader = 5268++type family FromEnumRayShader (s :: RayShader) :: Nat where+  FromEnumRayShader RayGenerationShader = 5313+  FromEnumRayShader IntersectionShader  = 5314+  FromEnumRayShader AnyHitShader        = 5315+  FromEnumRayShader ClosestHitShader    = 5316+  FromEnumRayShader MissShader          = 5317+  FromEnumRayShader CallableShader      = 5318++type family FromEnumStage (s :: Stage) :: Nat where+  FromEnumStage (ShaderStage s) = FromEnumShader     s+  FromEnumStage (MeshStage   s) = FromEnumMeshShader s+  FromEnumStage (RayStage    s) = FromEnumRayShader  s++type family FromEnumExecutionModel (em :: ExecutionModel) :: Nat where+  FromEnumExecutionModel ('Stage s) = FromEnumStage s+  FromEnumExecutionModel Kernel     = 6++instance POrd ExecutionModel where+  type Compare s1 s2 = FromEnumExecutionModel s1 `CmpNat` FromEnumExecutionModel s2++type family ShaderName (s :: Shader) :: Symbol where+  ShaderName VertexShader                 = "Vertex shader"+  ShaderName TessellationControlShader    = "Tessellation Control shader"+  ShaderName TessellationEvaluationShader = "Tessellation Evaluation shader"+  ShaderName GeometryShader = "Geometry shader"+  ShaderName FragmentShader = "Fragment shader"+  ShaderName ComputeShader  = "Compute shader"++type family StageName (s :: Stage) :: Symbol where+  StageName (ShaderStage s)                = ShaderName s+  StageName (MeshStage 'TaskShader)        = "Task shader"+  StageName (MeshStage 'MeshShader)        = "Mesh shader"+  StageName (RayStage RayGenerationShader) = "Ray Generation shader"+  StageName (RayStage IntersectionShader)  = "Ray Intersection shader"+  StageName (RayStage AnyHitShader)        = "Any Hit ray shader"+  StageName (RayStage ClosestHitShader)    = "Closest Hit ray shader"+  StageName (RayStage MissShader)          = "Ray Miss shader"+  StageName (RayStage CallableShader)      = "Ray Callable shader"++type family ExecutionModelName (em :: ExecutionModel) :: Symbol where+  ExecutionModelName ('Stage s) = StageName s+  ExecutionModelName Kernel     = "Compute kernel"++type family NamedShader (k :: Symbol) (s :: Shader) :: Symbol where+  NamedShader k s = ShaderName s `AppendSymbol` " named \"" `AppendSymbol` k `AppendSymbol` "\""++type family NamedStage (k :: Symbol) (s :: Stage) :: Symbol where+  NamedStage k s = StageName s `AppendSymbol` " named \"" `AppendSymbol` k `AppendSymbol` "\""++type family NamedExecutionModel (k :: Symbol) (em :: ExecutionModel) :: Symbol where+  NamedExecutionModel k em = ExecutionModelName em `AppendSymbol` " named \"" `AppendSymbol` k `AppendSymbol` "\""++--------------------------------------------------------------------------+-- execution backends: whether Vulkan or OpenCL++data Backend = Vulkan | OpenCL+  deriving stock ( Eq, Show )++type family OtherBackend ( bk :: Backend ) :: Backend where+  OtherBackend Vulkan = OpenCL+  OtherBackend OpenCL = Vulkan++instance Demotable Backend where+  type Demote Backend = Backend+instance Known Backend Vulkan where+  known = Vulkan+instance Known Backend OpenCL where+  known = OpenCL++type family BackendOf ( model :: ExecutionModel ) :: Backend where+  BackendOf ( 'Stage _ ) = Vulkan+  BackendOf Kernel       = OpenCL++backendOf :: ExecutionModel -> Backend+backendOf ( Stage _ ) = Vulkan+backendOf Kernel      = OpenCL++--------------------------------------------------------------------------+-- additional execution model information that needs to be known at the type-level++data TessellationMode+  = ModeTriangles+  | ModeQuads+  | ModeIsolines+  | ModePoints+  deriving stock (Show, Eq, Ord, Enum, Bounded)++type family ShowTessellationMode (mode :: TessellationMode) :: Symbol where+  ShowTessellationMode ModeTriangles = "Triangles"+  ShowTessellationMode ModeQuads     = "Quads"+  ShowTessellationMode ModeIsolines  = "Isolines"+  ShowTessellationMode ModePoints    = "Points"++data GeometryInputMode+  = InputModePoints+  | InputModeLines+  | InputModeLinesAdjacency+  | InputModeTriangles+  | InputModeTrianglesAdjacency+  deriving stock (Show, Eq, Ord, Enum, Bounded)++type family ShowGeometryInputMode (mode :: GeometryInputMode) :: Symbol where+  ShowGeometryInputMode InputModePoints+    = "InputPoints"+  ShowGeometryInputMode InputModeLines+    = "InputLines"+  ShowGeometryInputMode InputModeLinesAdjacency+    = "InputLinesAdjacency"+  ShowGeometryInputMode InputModeTriangles+    = "(Input)Triangles"+  ShowGeometryInputMode InputModeTrianglesAdjacency+    = "InputTrianglesAdjacency"++instance Demotable TessellationMode where+  type Demote TessellationMode = TessellationMode++instance Demotable GeometryInputMode where+  type Demote GeometryInputMode = GeometryInputMode++instance Known TessellationMode 'ModeTriangles where+  known = ModeTriangles+instance Known TessellationMode 'ModeQuads     where+  known = ModeQuads+instance Known TessellationMode 'ModeIsolines  where+  known = ModeIsolines+instance Known TessellationMode 'ModePoints    where+  known = ModePoints++instance Known GeometryInputMode 'InputModePoints             where+  known = InputModePoints+instance Known GeometryInputMode 'InputModeLines              where+  known = InputModeLines+instance Known GeometryInputMode 'InputModeLinesAdjacency     where+  known = InputModeLinesAdjacency+instance Known GeometryInputMode 'InputModeTriangles          where+  known = InputModeTriangles+instance Known GeometryInputMode 'InputModeTrianglesAdjacency where+  known = InputModeTrianglesAdjacency++data ShaderInfo (n :: Type) (s :: Shader) where+  VertexShaderInfo+    :: ShaderInfo n VertexShader+  TessellationControlShaderInfo+    :: n -- input size+    -> n -- output size+    -> Maybe TessellationMode+    -> ShaderInfo n TessellationControlShader+  TessellationEvaluationShaderInfo+    :: n -- input size+    -> TessellationMode+    -> ShaderInfo n TessellationEvaluationShader+  GeometryShaderInfo+    :: n -- input size+    -> GeometryInputMode+    -> ShaderInfo n GeometryShader+  FragmentShaderInfo+    :: ShaderInfo n FragmentShader+  ComputeShaderInfo+    :: (n,n,n) -- shader local size+    -> ShaderInfo n ComputeShader++deriving stock instance Show n => Show (ShaderInfo n s)+deriving stock instance Eq   n => Eq   (ShaderInfo n s)+deriving stock instance Ord  n => Ord  (ShaderInfo n s)++data RayShaderInfo (s :: RayShader) where+  RayGenerationShaderInfo :: RayShaderInfo RayGenerationShader+  IntersectionShaderInfo  :: RayShaderInfo IntersectionShader+  AnyHitShaderInfo        :: RayShaderInfo AnyHitShader+  ClosestHitShaderInfo    :: RayShaderInfo ClosestHitShader+  MissShaderInfo          :: RayShaderInfo MissShader+  CallableShaderInfo      :: RayShaderInfo CallableShader++type family MkRayShaderInfo ( s :: RayShader ) :: RayShaderInfo s where+  MkRayShaderInfo RayGenerationShader = RayGenerationShaderInfo+  MkRayShaderInfo IntersectionShader  = IntersectionShaderInfo+  MkRayShaderInfo AnyHitShader        = AnyHitShaderInfo+  MkRayShaderInfo ClosestHitShader    = ClosestHitShaderInfo+  MkRayShaderInfo MissShader          = MissShaderInfo+  MkRayShaderInfo CallableShader      = CallableShaderInfo++deriving stock instance Show (RayShaderInfo s)+deriving stock instance Eq   (RayShaderInfo s)+deriving stock instance Ord  (RayShaderInfo s)++data ExecutionInfo (n :: Type) (em :: ExecutionModel) where+  ShaderExecutionInfo :: ShaderInfo n s -> ExecutionInfo n ('Stage ('ShaderStage s))+  KernelInfo+    :: (n,n,n) -- kernel local size+    -> ExecutionInfo n Kernel+  -- ray shaders don't need extra info (at least at the moment)+  RayShaderInfo :: RayShaderInfo s -> ExecutionInfo n ('Stage ('RayStage s))++type VertexInfo = 'ShaderExecutionInfo 'VertexShaderInfo+type TessellationControlInfo i j m = 'ShaderExecutionInfo ( 'TessellationControlShaderInfo i j m)+type TessellationEvaluationInfo i m = 'ShaderExecutionInfo ( 'TessellationEvaluationShaderInfo i m)+type GeometryInfo i m = 'ShaderExecutionInfo ('GeometryShaderInfo i m)+type FragmentInfo = 'ShaderExecutionInfo 'FragmentShaderInfo+type ComputeInfo ijk = 'ShaderExecutionInfo ('ComputeShaderInfo ijk)++deriving stock instance Show n => Show (ExecutionInfo n s)+deriving stock instance Eq   n => Eq   (ExecutionInfo n s)+deriving stock instance Ord  n => Ord  (ExecutionInfo n s)++modelOf :: ExecutionInfo n em -> ExecutionModel+modelOf (ShaderExecutionInfo VertexShaderInfo)+  = Stage (ShaderStage VertexShader)+modelOf (ShaderExecutionInfo (TessellationControlShaderInfo {}))+  = Stage (ShaderStage TessellationControlShader)+modelOf (ShaderExecutionInfo (TessellationEvaluationShaderInfo {}))+  = Stage (ShaderStage TessellationEvaluationShader)+modelOf (ShaderExecutionInfo (GeometryShaderInfo {}))+  = Stage (ShaderStage GeometryShader)+modelOf (ShaderExecutionInfo FragmentShaderInfo)+  = Stage (ShaderStage FragmentShader)+modelOf (ShaderExecutionInfo (ComputeShaderInfo {}))+  = Stage (ShaderStage ComputeShader)+modelOf (KernelInfo {})+  = Kernel+modelOf (RayShaderInfo RayGenerationShaderInfo)+  = Stage (RayStage RayGenerationShader)+modelOf (RayShaderInfo IntersectionShaderInfo )+  = Stage (RayStage IntersectionShader)+modelOf (RayShaderInfo AnyHitShaderInfo)+  = Stage (RayStage AnyHitShader)+modelOf (RayShaderInfo ClosestHitShaderInfo)+  = Stage (RayStage ClosestHitShader)+modelOf (RayShaderInfo MissShaderInfo)+  = Stage (RayStage MissShader)+modelOf (RayShaderInfo CallableShaderInfo)+  = Stage (RayStage CallableShader)+++instance Demotable (ShaderInfo Nat s) where+  type Demote (ShaderInfo Nat s) = ShaderInfo Word32 s++instance Known (ShaderInfo Nat VertexShader) VertexShaderInfo where+  known = VertexShaderInfo+instance ( KnownNat inputSize+         , KnownNat outputSize+         , Known (Maybe TessellationMode) mbMode+         )+      => Known+            (ShaderInfo Nat TessellationControlShader)+            (TessellationControlShaderInfo inputSize outputSize mbMode) where+  known = TessellationControlShaderInfo+              ( knownValue @inputSize  )+              ( knownValue @outputSize )+              ( knownValue @mbMode     )+instance (KnownNat inputSize, Known TessellationMode mode)+      => Known+            (ShaderInfo Nat TessellationEvaluationShader)+            (TessellationEvaluationShaderInfo inputSize mode) where+  known = TessellationEvaluationShaderInfo+              ( knownValue @inputSize )+              ( knownValue @mode      )+instance (KnownNat inputSize, Known GeometryInputMode mode)+      => Known (ShaderInfo Nat GeometryShader)+            (GeometryShaderInfo inputSize mode) where+  known = GeometryShaderInfo+             ( knownValue @inputSize )+             ( knownValue @mode      )+instance Known (ShaderInfo Nat FragmentShader) FragmentShaderInfo where+  known = FragmentShaderInfo+instance ( Known (Nat,Nat,Nat) ijk )+      => Known (ShaderInfo Nat ComputeShader) (ComputeShaderInfo ijk) where+  known = ComputeShaderInfo ( knownValue @ijk )+++instance Demotable (RayShaderInfo s) where+  type Demote (RayShaderInfo s) = RayShaderInfo s++instance Known ( RayShaderInfo RayGenerationShader ) RayGenerationShaderInfo where+  known = RayGenerationShaderInfo+instance Known ( RayShaderInfo IntersectionShader ) IntersectionShaderInfo where+  known = IntersectionShaderInfo+instance Known ( RayShaderInfo AnyHitShader ) AnyHitShaderInfo where+  known = AnyHitShaderInfo+instance Known ( RayShaderInfo ClosestHitShader ) ClosestHitShaderInfo where+  known = ClosestHitShaderInfo+instance Known ( RayShaderInfo MissShader ) MissShaderInfo where+  known = MissShaderInfo+instance Known ( RayShaderInfo CallableShader ) CallableShaderInfo where+  known = CallableShaderInfo++instance Demotable (ExecutionInfo Nat s) where+  type Demote (ExecutionInfo Nat s) = ExecutionInfo Word32 s++instance Known (ShaderInfo Nat s) info+      => Known (ExecutionInfo Nat ('Stage ('ShaderStage s)))+           (ShaderExecutionInfo info)+      where+  known = ShaderExecutionInfo ( knownValue @info )+instance ( Known (Nat,Nat,Nat) ijk )+      => Known (ExecutionInfo Nat 'Kernel) (KernelInfo ijk) where+  known = KernelInfo ( knownValue @ijk)+instance Known (RayShaderInfo s) info+      => Known (ExecutionInfo Nat ('Stage ('RayStage s)))+           ('RayShaderInfo info)+      where+  known = RayShaderInfo ( knownValue @info )
+ src/SPIRV/Storage.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DerivingVia           #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{-|+Module: SPIRV.Storage++This module enumerates SPIR-V storage classes.++These are used both at the type-level and at the value-level.++See the SPIR-V specification, §3.7 __Storage Class__.++-}++module SPIRV.Storage where++-- base+import Data.Word+  ( Word32 )+import GHC.TypeNats+  ( Nat )++-- fir+import Data.Binary.Class.Put+  ( Put(..) )+import Data.Type.Known+  ( Demotable(Demote), Known(known), knownValue )+import Data.Type.POrd+  ( POrd(..) )++--------------------------------------------------++data StorageClass+  = UniformConstant+  | Input+  | Uniform+  | Output+  | Workgroup+  | CrossWorkgroup+  | Private+  | Function+  | Generic+  | PushConstant+  | AtomicCounter+  | Image+  | StorageBuffer+  | RayStorage RayStorage+  deriving stock (Show, Eq, Ord)++instance Put StorageClass where+  put UniformConstant = put @Word32 0+  put Input           = put @Word32 1+  put Uniform         = put @Word32 2+  put Output          = put @Word32 3+  put Workgroup       = put @Word32 4+  put CrossWorkgroup  = put @Word32 5+  put Private         = put @Word32 6+  put Function        = put @Word32 7+  put Generic         = put @Word32 8+  put PushConstant    = put @Word32 9+  put AtomicCounter   = put @Word32 10+  put Image           = put @Word32 11+  put StorageBuffer   = put @Word32 12+  put (RayStorage s)  = put s+  wordCount _         = 1++data DataOrigin+  = Lifetime+  | Incoming+  deriving stock (Show, Eq, Ord)++data RayStorage+  = CallableData DataOrigin+  | RayPayload   DataOrigin+  | HitAttribute+  | ShaderRecordBuffer+  deriving stock (Show, Eq, Ord)++instance Put RayStorage where+  put (CallableData Lifetime) = put @Word32 5328+  put (CallableData Incoming) = put @Word32 5329+  put (RayPayload   Lifetime) = put @Word32 5338+  put (RayPayload   Incoming) = put @Word32 5342+  put HitAttribute            = put @Word32 5339+  put ShaderRecordBuffer      = put @Word32 5343+  wordCount _                 = 1++instance Demotable StorageClass where+  type Demote StorageClass = StorageClass++instance Known StorageClass UniformConstant where+  known = UniformConstant+instance Known StorageClass Input where+  known = Input+instance Known StorageClass Uniform where+  known = Uniform+instance Known StorageClass Output where+  known = Output+instance Known StorageClass Workgroup where+  known = Workgroup+instance Known StorageClass CrossWorkgroup where+  known = CrossWorkgroup+instance Known StorageClass Private where+  known = Private+instance Known StorageClass Function where+  known = Function+instance Known StorageClass Generic where+  known = Generic+instance Known StorageClass PushConstant where+  known = PushConstant+instance Known StorageClass AtomicCounter where+  known = AtomicCounter+instance Known StorageClass Image where+  known = Image+instance Known StorageClass StorageBuffer where+  known = StorageBuffer+instance Known RayStorage s => Known StorageClass ('RayStorage s) where+  known = RayStorage (knownValue @s)++instance Demotable DataOrigin where+  type Demote DataOrigin = DataOrigin++instance Known DataOrigin Lifetime where+  known = Lifetime+instance Known DataOrigin Incoming where+  known = Incoming++instance Demotable RayStorage where+  type Demote RayStorage = RayStorage++instance Known DataOrigin origin => Known RayStorage (CallableData origin) where+  known = CallableData (knownValue @origin)+instance Known DataOrigin origin => Known RayStorage (RayPayload origin) where+  known = RayPayload (knownValue @origin)+instance Known RayStorage HitAttribute where+  known = HitAttribute+instance Known RayStorage ShaderRecordBuffer where+  known = ShaderRecordBuffer++++instance POrd StorageClass where+  type Compare x y = Compare (StorageClassToNat x) (StorageClassToNat y)++type family StorageClassToNat (s :: StorageClass) :: Nat where+  StorageClassToNat UniformConstant = 0+  StorageClassToNat Input           = 1+  StorageClassToNat Uniform         = 2+  StorageClassToNat Output          = 3+  StorageClassToNat Workgroup       = 4+  StorageClassToNat CrossWorkgroup  = 5+  StorageClassToNat Private         = 6+  StorageClassToNat Function        = 7+  StorageClassToNat Generic         = 8+  StorageClassToNat PushConstant    = 9+  StorageClassToNat AtomicCounter   = 10+  StorageClassToNat Image           = 11+  StorageClassToNat StorageBuffer   = 12+  StorageClassToNat ('RayStorage r) = RayStorageClassToNat r++type family RayStorageClassToNat (r :: RayStorage) :: Nat where+  RayStorageClassToNat (CallableData Lifetime) = 5328+  RayStorageClassToNat (CallableData Incoming) = 5329+  RayStorageClassToNat (RayPayload   Lifetime) = 5338+  RayStorageClassToNat (RayPayload   Incoming) = 5342+  RayStorageClassToNat HitAttribute            = 5339+  RayStorageClassToNat ShaderRecordBuffer      = 5343
+ src/SPIRV/Synchronisation.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE DerivingVia           #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-|+Module: SPIRV.Synchronisation++Defines synchronisation scopes and related memory lock semantics.++See the SPIR-V specification:+  +  * §3.25 __Memory Semantics__,+  * §3.27 __Scope__ (synchronisation scopes).++-}++module SPIRV.Synchronisation+  ( SynchronisationScope(..)+  , MemorySemantics(..)+  , OrderingSemantics(..)+  , LockSemantics(..)+  , MemoryType(..)+  , synchronisationScope+  , memorySemanticsBitmask+  ) where++-- base+import Data.Bits+  ( Bits ( (.|.), bit ) )+import Data.Word+  ( Word32 )++-- fir+import Data.Binary.Class.Put+  ( Put(..), PutWord32Enum(..) )+import Data.Type.Known+  ( Demotable(Demote), Known(known) )++--------------------------------------------------++data SynchronisationScope+  = CrossDevice+  | Device+  | Workgroup+  | Subgroup+  | Invocation+  | QueueFamily+  | ShaderCall+  deriving stock ( Eq, Ord, Show, Enum, Bounded )+  deriving Put via ( PutWord32Enum SynchronisationScope )++synchronisationScope :: SynchronisationScope -> Word32+synchronisationScope = fromIntegral . fromEnum++instance Demotable SynchronisationScope where+  type Demote SynchronisationScope = SynchronisationScope++instance Known SynchronisationScope 'CrossDevice where+  known = CrossDevice++instance Known SynchronisationScope 'Device where+  known = Device++instance Known SynchronisationScope 'Workgroup where+  known = Workgroup+  +instance Known SynchronisationScope 'Subgroup where+  known = Subgroup+  +instance Known SynchronisationScope 'Invocation where+  known = Invocation++instance Known SynchronisationScope 'QueueFamily where+  known = QueueFamily++instance Known SynchronisationScope 'ShaderCall where+  known = ShaderCall++data MemorySemantics+  = MemorySemantics+    { orderingSemantics :: OrderingSemantics+    , memoryTypes       :: [ MemoryType ]+    }+  deriving stock ( Eq, Show )++data OrderingSemantics+  = Lock [ LockSemantics ]+  | SequentiallyConsistent+  deriving stock ( Eq, Show )++ordBitmask :: OrderingSemantics -> Word32+ordBitmask = \case+  SequentiallyConsistent -> 16+  Lock locks -> case ( Acquire `elem` locks, Release `elem` locks ) of+    ( True , True  ) -> 8+    ( True , False ) -> 2+    ( False, True  ) -> 4+    ( False, False ) -> 0++memorySemanticsBitmask :: MemorySemantics -> Word32+memorySemanticsBitmask ( MemorySemantics ord mems ) = ordBitmask ord .|. memBitmask mems++data LockSemantics+  = Acquire+  | Release+  deriving stock ( Eq, Show )++instance Put MemorySemantics where+  wordCount _ = 1+  put memSem  = put ( memorySemanticsBitmask memSem )++instance Put (Maybe MemorySemantics) where+  wordCount _ = 1+  put Nothing    = put @Word32 0+  put (Just sem) = put sem++data MemoryType+  = UniformMemory+  | SubgroupMemory+  | WorkgroupMemory+  | CrossWorkgroupMemory+  | AtomicCounterMemory+  | ImageMemory+  | OutputMemory+  deriving stock ( Eq, Ord, Show, Enum, Bounded )++memBitmask :: [MemoryType] -> Word32+memBitmask = foldl (.|.) 0 . map memBit++memBit :: MemoryType -> Word32+memBit = bit . ( + 6 ) . fromEnum
+ src/SPIRV/Version.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DerivingStrategies #-}++{-|+Module: SPIRV.Version++Handles SPIR-V version numbers.++-}++module SPIRV.Version+  ( Version(..), magicNo )+  where++-- base+import Data.Bits+  ( Bits(shiftL) )+import Data.Word+  ( Word8, Word32 )++-- fir+import Data.Binary.Class.Put+  ( Put(..) )++----------------------------------------------------------------------------++data Version = Version { major :: Word8, minor :: Word8 }+  deriving stock ( Eq, Ord )++instance Show Version where+  show (Version majorVer minorVer)+    = show majorVer ++ "." ++ show minorVer++instance Put Version where+  put (Version majorVer minorVer) = put ver+    where+      ver :: Word32+      ver = (fromIntegral majorVer) `shiftL` 16+          + (fromIntegral minorVer) `shiftL` 8+  wordCount _ = 1++magicNo :: Word32+magicNo = 0x07230203
+ test/CabalTests.hs view
@@ -0,0 +1,62 @@+module CabalTests ( tests ) where++-- cabal+import qualified Distribution.TestSuite as Cabal++-- filepath+import System.FilePath+  ( (</>) )++-- fir-tests+import Folders+  ( Folder(Folder) )+import Test+  ( Test, TestOutput(..), TestFailure(..)+  , runTest+  )+import Tests+  ( allTests )++--------------------------------------------------+-- package up tests for cabal++tests :: IO [ Cabal.Test ]+tests = pure ( map groupFolderTests allTests )++groupFolderTests :: Folder (String, Test) -> Cabal.Test+groupFolderTests ( Folder folderName folderTests )+  = Cabal.Group folderName True+  $ map ( \( testName, testType ) ->+          mkCabalTest folderName testName testType+        )+        folderTests++mkCabalTest :: String -> String -> Test -> Cabal.Test+mkCabalTest folderName testName testType+  = Cabal.Test+  $ Cabal.TestInstance+  { Cabal.run  = Cabal.Finished . cabalResult <$> runTest testType testPath+  , Cabal.name = testPath+  , Cabal.tags = [ folderName, show testType ]+  , Cabal.options   = []+  , Cabal.setOption = \ _ _ -> Left "Test does not have any options."+  }++    where+      testPath :: FilePath+      testPath = folderName </> testName++cabalResult :: TestOutput -> Cabal.Result+cabalResult Success = Cabal.Pass+cabalResult NewTest+  = Cabal.Error "New test: created 'golden' file from test run."+cabalResult (Failure CGOutputParseError)+  = Cabal.Error "Could not parse result of code-generation. Maybe something crashed?"+cabalResult (Failure OtherError)+  = Cabal.Error "Encountered a problem loading test in ghci. Maybe something crashed?"+cabalResult (Failure FIRNotBuiltOrUnusableError)+  = Cabal.Error+      "Could not load 'fir' library.\n\+      \Possible cause: library not built, or wrong version."+cabalResult (Failure failure)+  = Cabal.Fail (show failure)
+ test/Folders.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE BlockArguments     #-}+{-# LANGUAGE DeriveFoldable     #-}+{-# LANGUAGE DeriveFunctor      #-}+{-# LANGUAGE DeriveTraversable  #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections      #-}++module Folders where++-- base+import Control.Monad+  ( forM )++-- filepath+import System.FilePath+  ( (</>) )++-- fir-tests+import Test+  ( Test, TestOutput(..)+  , runTest+  )++data Folder a = Folder String [a]+  deriving stock (Functor, Foldable, Traversable)++------------------------------------------------------------------------------------------+-- running tests on folders++runTestsP :: (String -> String -> Test -> Bool)+          -> [ Folder (String, Test) ]+          -> IO [ Folder (String, Test, TestOutput) ]+runTestsP f+  = runTests+  . map ( \ (Folder g tests) -> Folder g (filter ( \(p,t) -> f g p t ) tests) )++runTests :: [ Folder (String, Test) ]+         -> IO [ Folder (String, Test, TestOutput) ]+runTests+  = traverse+     ( \ (Folder folderName folderTests) ->+          Folder folderName <$>+            forM folderTests \ (testName, testType) ->+              (testName, testType, )+                <$> runTest testType ( folderName </> testName )+     )++runTestsFromFolder+  :: String+  -> [ Folder (String, Test) ]+  -> IO [ Folder (String, Test, TestOutput) ]+runTestsFromFolder folderName = runTestsP ( \ x _ _ -> x == folderName )+++------------------------------------------------------------------------------------------+-- displaying test result folders++deriving stock instance Show (Folder (String, Test))++instance Show (Folder (String, Test, TestOutput)) where+  show ( Folder folderName testResults )+    =  padRToLength 15 folderName+    <> "( " <> showPaddedL 2 passes <> " / " <> showPaddedL 2 total <> " )"+    <> foldMap showTestResult testResults+    <> "\n"+      where+        total, passes :: Int+        total  = length testResults+        passes = length . filter ( \(_,_,res) -> res == Success ) $ testResults+        showTestResult :: (String, Test, TestOutput) -> String+        showTestResult (testName, testType, testResult)+          =  "\n    " <> padRToLength 30 testName+          <> padRToLength 9 (show testType) <> ": " <> show testResult++instance {-# OVERLAPPING #-} Show [Folder (String, Test, TestOutput)] where+  show = unlines . map show+++-- utility padding functions++padRToLength :: Int -> String  -> String+padRToLength n s+  | lg >= n   = s+  | otherwise = s <> replicate (n - lg) ' '+  where lg = length s++padLToLength :: Int -> String  -> String+padLToLength n s+  | lg >= n   = s+  | otherwise = replicate (n - lg) ' ' <> s+  where lg = length s++showPaddedR :: Show a => Int -> a  -> String+showPaddedR n = padRToLength n . show++showPaddedL :: Show a => Int -> a  -> String+showPaddedL n = padLToLength n . show
+ test/Test.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings  #-}++module Test where++-- base+import Control.Concurrent+  ( forkIO, newEmptyMVar, putMVar, takeMVar )+import Control.Monad+  ( when )+import Data.Maybe+  ( fromMaybe )+import System.IO+  ( hClose )++-- bytestring+import Data.ByteString+  ( ByteString )+import qualified Data.ByteString as ByteString+  ( readFile, writeFile+  , hGetContents, hPut+  , null, take+  )+import qualified Data.ByteString.Char8 as ByteString+  ( lines, unlines, stripSuffix )++-- directory+import System.Directory+  ( doesFileExist, renameFile, removeFile )++-- filepath+import System.FilePath+  ( (</>), (<.>), splitDirectories )+import qualified System.FilePath.Posix as Posix+  ( joinPath )++-- process+import System.Process+  ( proc, createProcess+  , CreateProcess+      ( std_in, std_out, std_err )+  , StdStream+      ( CreatePipe )+  , waitForProcess+  )++-- text+import Data.Text+  ( Text )+import qualified Data.Text    as Text+  ( pack, lines+  , take, drop, dropWhile, dropWhileEnd+  , dropAround, breakOn, isPrefixOf+  , null, replace+  )+import qualified Data.Text.Encoding as Text+  ( encodeUtf8, decodeUtf8With )+import qualified Data.Text.Encoding.Error as Text+  ( lenientDecode )++-- fir+import FIR+  ( CompilerFlag(..) )++--------------------------------------------------++data Test+  = Typecheck+  | CodeGen+  | Validate+  deriving stock ( Eq, Show )++data TestFailure+  = MissingSource+  | WrongTypecheckOutput+  | ExpectedTypecheck+  | UnexpectedTypecheck+  | CodeGenFail  Text+  | ValidateFail Text+  | CGOutputParseError+  | FIRNotBuiltOrUnusableError+  | OtherError+  deriving stock ( Eq, Show )++data TestOutput+  = Failure TestFailure+  | Success+  | NewTest+  deriving stock ( Eq, Show )++runTest :: Test -> FilePath -> IO TestOutput+runTest Typecheck = typeCheck+runTest CodeGen   = codeGen+runTest Validate  = validate++--------------------------------------------------+-- truly disgusting testing setup++validator :: FilePath+validator = "spirv-val"++codeGen, validate :: FilePath -> IO TestOutput+codeGen  testName = compileTest [Debug, Assert, NoCode] testName+validate testName = compileTest [Debug, Assert]         testName++-- | Run an executable with the given arguments, feeding it the given input+-- on stdin, and return what it wrote to stdout and stderr.+readProcessOutput :: FilePath -> [String] -> ByteString -> IO (ByteString, ByteString)+readProcessOutput exe args input = do+  (Just inHandle, Just outHandle, Just errHandle, processHandle)+    <- createProcess+         ( proc exe args )+           { std_in  = CreatePipe+           , std_out = CreatePipe+           , std_err = CreatePipe+           }+  outVar <- newEmptyMVar+  errVar <- newEmptyMVar+  _ <- forkIO $ ByteString.hGetContents outHandle >>= putMVar outVar+  _ <- forkIO $ ByteString.hGetContents errHandle >>= putMVar errVar+  ByteString.hPut inHandle input+  hClose inHandle+  out <- takeMVar outVar+  err <- takeMVar errVar+  _ <- waitForProcess processHandle+  pure (out, err)++-- | Run GHC in the package environment of the cabal project, which provides+-- the in-place build of 'fir'.+--+-- A package environment file in the project directory is not reliable:+-- every cabal invocation with @write-ghc-environment-files@ rewrites it,+-- including those of the Haskell Language Server with its own build directory.+readGhcOutput :: [String] -> ByteString -> IO (ByteString, ByteString)+readGhcOutput args = readProcessOutput "cabal" ( [ "exec", "--verbose=0", "--", "ghc" ] ++ args )++decodeOutput :: ByteString -> Text+decodeOutput = Text.decodeUtf8With Text.lenientDecode++compileTest :: [CompilerFlag] -> FilePath -> IO TestOutput+compileTest flags testName = do+  srcExists <- doesFileExist src+  case srcExists of+    False -> pure ( Failure MissingSource )+    True  ->+      do+        (out, err) <-+          readGhcOutput+            [ "--interactive"+            , src+            , "-w"+            , "-package", "fir"+            , "-threaded"+            ]+            ( Text.encodeUtf8 ( compile <> "\n:q\n" ) )++        let res = parseCGOutput ( decodeOutput out )+        res' <- case res of+          Failure ExpectedTypecheck+            -> do ByteString.writeFile test err+                  pure res+          Failure (CodeGenFail _)+            -> do ByteString.writeFile test out+                  pure res+          Failure _+            -> do let errLines = dropWhile ignoreLineText . linesText $ decodeOutput err+                  case errLines of+                    ( l1 : _ )+                      | Text.take 43 l1 == "<command line>: cannot satisfy -package fir"+                      -> pure (Failure FIRNotBuiltOrUnusableError)+                    _ -> do ByteString.writeFile test err+                            pure res+          Success+            -> do failExists <- doesFileExist test+                  when ( NoCode `elem` flags && failExists ) ( removeFile test )+                  pure res+          NewTest+            -> pure res+        if res' /= Success || NoCode `elem` flags+        then pure res'+        else+          do  (_, valErr) <- readProcessOutput validator [ spv ] ""+              if ByteString.null valErr+              then do removeFile spv+                      failExists <- doesFileExist test+                      when failExists ( removeFile test )+                      pure Success+              else do ByteString.writeFile test valErr+                      renameFile spv (spv <.> "fail")+                      pure ( Failure ( ValidateFail ( decodeOutput valErr ) ) )++  where dir  = "test" </> "Tests"+        src  = dir </> testName <.> "hs"+        test = dir </> testName <.> "fail"+        spv  = dir </> testName <.> "spv"+        compile =  "compileTo "+                <> Text.pack (show spv)+                <> " "+                <> Text.pack (show flags)+                <> " program"++typeCheck :: FilePath -> IO TestOutput+typeCheck testName = do+  srcExists <- doesFileExist src+  case srcExists of+    False -> pure ( Failure MissingSource )+    True  ->+      do+        (_, testContents) <-+          readGhcOutput+            [ src+            , "-w"+            , "-fno-code"+            , "-package", "fir"+            , "-threaded"+            ]+            ""+        let mbTcOutput = normalisePath <$> parseTcOutput testContents++        case mbTcOutput of+          Nothing -> pure ( Failure FIRNotBuiltOrUnusableError )+          Just tcOutput -> do++            goldenExists <- doesFileExist gold++            if goldenExists+            then do+              golden <- ByteString.readFile gold+              if normaliseDiagnostics golden == normaliseDiagnostics tcOutput+              then pure Success+              else do+                ByteString.writeFile test tcOutput+                if golden == cleanTc+                then pure ( Failure ExpectedTypecheck)+                else+                  if tcOutput == cleanTc+                  then pure ( Failure UnexpectedTypecheck )+                  else pure ( Failure WrongTypecheckOutput )++            else do ByteString.writeFile gold tcOutput+                    pure NewTest++    where dir  = "test" </> "Tests"+          src  = dir </> testName <.> "hs"+          gold = dir </> testName <.> "golden"+          test = dir </> testName <.> "fail"+          -- GHC refers to the source file using the path separators of the platform:+          -- use forward slashes, so that the expected output is the same on all platforms.+          normalisePath :: ByteString -> ByteString+          normalisePath+            = Text.encodeUtf8+            . Text.replace ( Text.pack src ) ( Text.pack ( Posix.joinPath ( splitDirectories src ) ) )+            . decodeOutput++-- | Normalise diagnostics, for comparison with expected diagnostics, which might+-- have been produced on a different platform:+--+--  - use LF line endings (the golden files can be checked out with CRLF line endings),+--  - GHC replaces some Unicode characters in its diagnostics with ASCII substitutes+--    when the locale doesn't support Unicode (e.g. with most Windows code pages):+--    make these substitutions.+normaliseDiagnostics :: ByteString -> Text+normaliseDiagnostics+  = Text.replace "\r\n" "\n"+  . Text.replace "\x2018" "`"+  . Text.replace "\x2019" "'"+  . Text.replace "\x2022" "*"+  . decodeOutput++cleanTc :: ByteString+cleanTc = "No type-checking errors."++ignoreLineBS :: ByteString -> Bool+ignoreLineBS string+  |    ByteString.null string+    || ByteString.take 4  string == "GHCi"+    || ByteString.take 26 string == "Loaded package environment"+  = True+  | otherwise+  = False++ignoreLineText :: Text -> Bool+ignoreLineText string+  |    Text.null string+    || Text.take 4  string == "GHCi"+    || Text.take 26 string == "Loaded package environment"+    || Text.take 30 string == "Using default language edition"+  = True+  | otherwise+  = False++-- Split GHC output into lines, accepting both LF and CRLF line endings+-- (GHC uses CRLF on Windows).++linesBS :: ByteString -> [ ByteString ]+linesBS = map ( \ l -> fromMaybe l ( ByteString.stripSuffix "\r" l ) ) . ByteString.lines++linesText :: Text -> [ Text ]+linesText = map ( Text.dropWhileEnd ( == '\r' ) ) . Text.lines++parseTcOutput :: ByteString -> Maybe ByteString+parseTcOutput contents = go ( dropWhile ignoreLineBS ( linesBS contents ) )+  where+    go :: [ByteString] -> Maybe ByteString+    go [] = Just cleanTc+    go ls@(l:_)+      | ByteString.take 43 l == "<command line>: cannot satisfy -package fir"+      = Nothing+      | otherwise+      = Just $ ByteString.unlines ls++parseCGOutput :: Text -> TestOutput+parseCGOutput contents+  = let ls = dropWhile ignoreLineText (linesText contents)+    in case ls of+          l1 : l2 : l3 : _+            | Text.take 8 l1 == "[1 of 1]"+            -> case l2 of+                  "Ok, one module loaded."+                     -> let l3' = Text.drop 2+                                . Text.dropWhile ( /= '>' )+                                $ l3+                        in case Text.breakOn " " l3' of+                              ( "Left", rest )+                                -> Failure ( CodeGenFail+                                               ( Text.dropAround (== '\"' )+                                               . Text.drop 1+                                               $ rest+                                               )+                                           )+                              ( "Right", _)+                                -> Success+                              _ -> Failure CGOutputParseError+                  _ | "Failed," `Text.isPrefixOf` l2+                     -> Failure ExpectedTypecheck+                    | otherwise+                     -> Failure OtherError+          _ -> Failure OtherError
+ test/Tests.hs view
@@ -0,0 +1,187 @@+module Tests where++-- fir-tests+import Folders+  ( Folder(Folder)+  , runTests, runTestsP, runTestsFromFolder+  )+import Test+  ( Test(..), TestOutput )++--------------------------------------------------++runAllTestsP :: (String -> String -> Test -> Bool)+             -> IO [ Folder (String, Test, TestOutput) ]+runAllTestsP f = runTestsP f allTests++runAllTests :: IO [ Folder (String, Test, TestOutput) ]+runAllTests = runTests allTests++runAllTestsFromFolder :: String -> IO [ Folder (String, Test, TestOutput) ]+runAllTestsFromFolder = flip runTestsFromFolder allTests++--------------------------------------------------++allTests :: [ Folder (String, Test) ]+allTests+  = [ Folder "Array"+          [ ( "Applicative"       , Validate  )+          , ( "ApplicativeConvert", Validate  )+          , ( "Runtime"           , Typecheck )+          ]+    , Folder "Atomics"+          [ ( "Operations"  , Validate  )+          , ( "FloatBitwise", Typecheck )+          ]+    , Folder "Bits"+          [ ( "BitCast"   , Validate )+          , ( "Bits"      , Validate )+          , ( "ZipBits"   , Validate )+          , ( "BitReverse", Validate )+          ]+    , Folder "Builtins"+          [ ( "SampleId"     , Validate )+          , ( "SharedBuiltin", Validate )+          ]+    , Folder "Components"+          [ ( "FloatInt"  , Typecheck )+          , ( "FloatWidth", Typecheck )+          , ( "IntWidth"  , Typecheck )+          , ( "Sign"      , Validate  )+          ]+    , Folder "Definitions"+          [ ( "Descriptors"    , Typecheck )+          , ( "OriginLowerLeft", Typecheck )+          , ( "PushConstant"   , Typecheck )+          , ( "UniformRuntimeArray", Typecheck )+          ]+    , Folder "Control"+          [ ( "BreakContinueNested", Validate )+          , ( "BreakInCondition"   , Validate )+          , ( "BreakNested"        , Validate )+          , ( "DeadCode"           , Validate )+          , ( "Def"                , Validate )+          , ( "Loop1"              , Validate )+          , ( "Loop2"              , Validate )+          , ( "Loop3"              , Validate )+          , ( "LoopCondition"      , Validate )+          , ( "LoopsNested"        , Validate )+          , ( "RayQueryVariable"   , Validate )+          , ( "Selection"          , Validate )+          , ( "Switch"             , Validate )+          , ( "TemporaryBranches"  , Validate )+          , ( "TemporaryFunctions" , Validate )+          , ( "TemporaryLoop"      , Validate )+          , ( "TemporarySetter"    , Validate )+          ]+    , Folder "Debug"+          [ ( "Printf", Validate )+          ]+    , Folder "Geometry"+          [ ( "Geometry"   , Validate  )+          , ( "NotGeometry", Typecheck )+          ]+    , Folder "Groups"+          [ ( "GroupAdd", Validate )+          ]+    , Folder "Images"+          [ ( "Gather"   , Validate )+          , ( "ReadWrite", Validate )+          , ( "Sample"   , Validate )+          ]+    , Folder "Inference"+          [ ( "Ising1", Typecheck )+          , ( "Ising2", Typecheck )+          ]+    , Folder "Interface"+          [ ( "ComponentMismatch", Typecheck )+          , ( "ExtraOutput"      , Typecheck )+          , ( "InvalidComponent" , Typecheck )+          , ( "MissingInput"     , Typecheck )+          ]+    , Folder "Layout"+          [ ( "Copy"            , Validate )+          , ( "DescriptorArray" , Validate )+          , ( "FunctionArgument", Validate )+          , ( "LocalVariables"  , Validate )+          , ( "Matrices"        , Validate )+          , ( "NestedUniform"   , Validate )+          , ( "Offsets"         , Validate )+          , ( "PerVertexBlocks" , Validate )+          , ( "Products"        , Validate )+          , ( "PushConstant"    , Validate )+          , ( "RuntimeArray"    , Validate )+          , ( "Selection"       , Validate )+          , ( "StructPadding"   , Validate )+          ]+    , Folder "Matrix"+          [ ( "Applicative", Validate )+          ]+    , Folder "Module"+          [ ( "DiffStageDiffName", Validate  )+          , ( "DiffStageSameName", Validate  )+          , ( "SameStageDiffName", Validate  )+          , ( "SameStageSameName", Typecheck )+          ]+    , Folder "OpenCL"+          [ ( "Kernel", Validate )+          ]+    , Folder "Optics"+          [ ( "ASTIndices"    , Validate  )+          , ( "ASTProducts"   , Validate  )+          , ( "MVP1"          , Validate  )+          , ( "MVP2"          , Validate  )+          , ( "NestedOfType"  , Validate  )+          , ( "NoMatrixIndex" , Typecheck )+          , ( "NoStructField" , Typecheck )+          , ( "NoStructIndex" , Typecheck )+          , ( "NoVectorIndex" , Typecheck )+          , ( "Overlapping"   , Typecheck )+          , ( "ProductIndices", Typecheck )+          , ( "PureProducts"  , Typecheck )+          , ( "UnarySwizzle"  , Validate  )+          , ( "Various"       , Validate  )+          ]+    , Folder "PrimOps"+          [ ( "Rounding", Validate)+          ]+    , Folder "ProgramState"+          [ ( "Shadowing", Validate)+          ]+    , Folder "Small"+          [ ( "HalfArithmetic" , Validate )+          , ( "HalfInputOutput", Validate )+          , ( "IntArithmetic"  , Validate )+          , ( "IntInputOutput" , Validate )+          ]+    , Folder "Tessellation"+          [ ( "Control"   , Validate )+          , ( "Evaluation", Validate )+          ]+    , Folder "Unicode"+          [ ( "Syntax", Validate )+          ]+    , Folder "Vector"+          [ ( "Applicative" , Validate  )+          , ( "Functor"     , Validate  )+          , ( "Swizzle"     , Validate  )+          , ( "MixedSwizzle", Typecheck )+          ]+    , Folder "VertexInput"+          [ ( "CompatibleTypes"       , Typecheck )+          , ( "ComponentOutOfRange"   , Typecheck )+          , ( "DoubleComponents"      , Typecheck )+          , ( "EquivalentComponents"  , Typecheck )+          -- TODO: check that the vertex attributes are compatible with the+          -- vertex shader inputs, and provide every component they consume.+          --, ( "IncompatibleTypes"     , Typecheck )+          --, ( "IncompatibleWidths"    , Typecheck )+          --, ( "MissingComponents"     , Typecheck )+          , ( "InvalidDoubleComponent", Typecheck )+          , ( "InvalidVectorComponent", Typecheck )+          -- TODO: check that the vertex attributes of a 'StructInput'+          -- do not overlap.+          --, ( "Overlap"               , Typecheck )+          , ( "V3Double_Double"       , Typecheck )+          ]+    ]
+ test/Tests/Array/Applicative.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Array.Applicative where++-- fir+import FIR++------------------------------------------------+-- program++type Defs = '[ "arr"  ':-> Input      '[ Location 0 ] (Array 17 Float)+             , "out"  ':-> Output     '[ Location 0 ] Float+             , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment+             ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Fragment do++    arr <- get @"arr"++    let f :: Code Float -> Code Float -> Code Float+        f x y = x - abs y+        arr' :: Code (Array 17 Float)+        arr' = f <$$> arr <**> arr+        out = view @(Index 0) arr' + view @(Index 6) arr++    put @"out" out
+ test/Tests/Array/ApplicativeConvert.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Array.ApplicativeConvert where++-- base+import Data.Maybe+  ( fromJust )++-- vector-sized+import qualified Data.Vector.Sized as Vector++-- fir+import FIR++------------------------------------------------+-- program++-- Mapping a function over an array, with an element type for the result+-- that differs from that of the input array.++table :: Array 4 Word32+table = MkArray ( fromJust $ Vector.fromList [ 1, 2, 3, 4 ] )++type Defs =+  '[ "ubo"  ':-> Uniform '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "i" ':-> Word32 ] )+   , "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ]+                   ( Struct '[ "res" ':-> Float ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Compute do++    i <- use @( Name "ubo" :.: Name "i" )++    let+      arr :: Code ( Array 4 Word32 )+      arr = Lit table+      toFloat :: Code Word32 -> Code Float+      toFloat = fromIntegral+      arr' :: Code ( Array 4 Float )+      arr' = toFloat <$$> arr++    assign @( Name "out" :.: Name "res" )+      ( view @( Index 0 ) arr' + toFloat ( view @( AnIndex ( Code Word32 ) ) i arr ) )
+ test/Tests/Array/Runtime.golden view
@@ -0,0 +1,22 @@+test/Tests/Array/Runtime.hs:33:15: error: [GHC-64725]+    • 'get'/'use': cannot focus on type +        RuntimeArray Float+      within binding named "storage", as it is (or contains) an opaque type.+    • In a stmt of a 'do' block:+        buffer <- use @(Name "storage" :.: Name "buffer")+      In the third argument of ‘entryPoint’, namely+        ‘do buffer <- use @(Name "storage" :.: Name "buffer")+            let res :: Code Float+                res = view @(AnIndex (Code Word32)) 1728 buffer+            put @"out" res’+      In a stmt of a 'do' block:+        entryPoint+          @"main" @Fragment+          do buffer <- use @(Name "storage" :.: Name "buffer")+             let res :: Code Float+                 res = view @(AnIndex (Code Word32)) 1728 buffer+             put @"out" res+   |+33 |     buffer <- use @( Name "storage" :.: Name "buffer" )+   |               ^^^+
+ test/Tests/Array/Runtime.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Array.Runtime where++-- fir+import FIR++------------------------------------------------+-- program++type Defs = '[ "storage" ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ]+                                ( Struct '[ "buffer" ':-> RuntimeArray Float ] )+             , "out"  ':-> Output     '[ Location 0 ] Float+             , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment+             ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Fragment do++    -- Not allowed to retrieve a runtime array in this manner.+    buffer <- use @( Name "storage" :.: Name "buffer" )++    let+      res :: Code Float+      res = view @( AnIndex ( Code Word32 ) ) 1728 buffer+    +    put @"out" res
+ test/Tests/Atomics/FloatBitwise.golden view
@@ -0,0 +1,22 @@+test/Tests/Atomics/FloatBitwise.hs:26:8: error: [GHC-39999]+    • No instance for ‘AtomicIntegralTy Float’+        arising from a use of ‘atomicAnd’+    • In a stmt of a 'do' block:+        _ <- atomicAnd+               @(Name "floats" :.: Name "arr" :.: AnIndex Word32) x 1+      In the third argument of ‘entryPoint’, namely+        ‘do ~(Vec3 x _ _) <- get @"gl_GlobalInvocationID"+            _ <- atomicAnd+                   @(Name "floats" :.: Name "arr" :.: AnIndex Word32) x 1+            pure (Lit ())’+      In the second argument of ‘($)’, namely+        ‘entryPoint+           @"main" @Compute+           do ~(Vec3 x _ _) <- get @"gl_GlobalInvocationID"+              _ <- atomicAnd+                     @(Name "floats" :.: Name "arr" :.: AnIndex Word32) x 1+              pure (Lit ())’+   |+26 |   _ <- atomicAnd @( Name "floats" :.: Name "arr" :.: AnIndex Word32 ) x 1+   |        ^^^^^^^^^+
+ test/Tests/Atomics/FloatBitwise.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Atomics.FloatBitwise where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- bitwise atomic operations are only supported on integers++type Defs =+  '[ "floats" ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ]+                    ( Struct '[ "arr" ':-> RuntimeArray Float ] )+   , "main"   ':-> EntryPoint '[ LocalSize 8 8 1 ] Compute+   ]++program :: Module Defs+program = Module $ entryPoint @"main" @Compute do+  ~( Vec3 x _ _ ) <- get @"gl_GlobalInvocationID"+  _ <- atomicAnd @( Name "floats" :.: Name "arr" :.: AnIndex Word32 ) x 1+  pure ( Lit () )
+ test/Tests/Atomics/Operations.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Atomics.Operations where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs =+  '[ "floats" ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ]+                    ( Struct '[ "arr" ':-> RuntimeArray Float ] )+   , "words"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ]+                    ( Struct '[ "count" ':-> Word32, "arr" ':-> RuntimeArray Word32 ] )+   , "ints"   ':-> StorageBuffer '[ DescriptorSet 0, Binding 2 ]+                    ( Struct '[ "arr" ':-> RuntimeArray Int64 ] )+   , "shared" ':-> Workgroup '[] ( Array 4 Int32 )+   , "main"   ':-> EntryPoint '[ LocalSize 8 8 1 ] Compute+   ]++program :: Module Defs+program = Module $ entryPoint @"main" @Compute do++  ~( Vec3 x y _ ) <- get @"gl_GlobalInvocationID"+  i <- let' ( x + 64 * y )++  -- Floating-point operations on elements of a storage buffer.+  previous <- atomicAdd      @( Name "floats" :.: Name "arr" :.: AnIndex Word32 ) i 0.5+  _        <- atomicMin      @( Name "floats" :.: Name "arr" :.: AnIndex Word32 ) i previous+  _        <- atomicMax      @( Name "floats" :.: Name "arr" :.: AnIndex Word32 ) i 1+  _        <- atomicExchange @( Name "floats" :.: Name "arr" :.: AnIndex Word32 ) i 2+  f        <- atomicLoad     @( Name "floats" :.: Name "arr" :.: AnIndex Word32 ) i+  atomicStore @( Name "floats" :.: Name "arr" :.: AnIndex Word32 ) i ( f + 1 )++  -- Unsigned integer operations on a storage buffer member and on elements+  -- of its array.+  slot <- atomicAdd       @( Name "words" :.: Name "count" ) 1+  _    <- atomicIncrement @( Name "words" :.: Name "count" )+  _    <- atomicDecrement @( Name "words" :.: Name "count" )+  _    <- atomicSub       @( Name "words" :.: Name "count" ) 1+  _    <- atomicMin @( Name "words" :.: Name "arr" :.: AnIndex Word32 ) slot x+  _    <- atomicMax @( Name "words" :.: Name "arr" :.: AnIndex Word32 ) slot y+  _    <- atomicAnd @( Name "words" :.: Name "arr" :.: AnIndex Word32 ) slot 0xff+  _    <- atomicOr  @( Name "words" :.: Name "arr" :.: AnIndex Word32 ) slot 0x100+  _    <- atomicXor @( Name "words" :.: Name "arr" :.: AnIndex Word32 ) slot i+  old  <- atomicCompareExchange @( Name "words" :.: Name "arr" :.: AnIndex Word32 ) slot 0 x++  -- 64-bit signed integer operations.+  _ <- atomicAdd @( Name "ints" :.: Name "arr" :.: AnIndex Word32 ) i 1+  _ <- atomicMin @( Name "ints" :.: Name "arr" :.: AnIndex Word32 ) i (-1)++  -- Signed integer operations on a workgroup variable.+  _ <- atomicAdd @( Name "shared" :.: AnIndex Word32 ) 0 ( if previous > 1 then 1 else -1 )+  _ <- atomicMax @( Name "shared" :.: AnIndex Word32 ) 1 ( bitcast old )++  pure ( Lit () )
+ test/Tests/Bits/BitCast.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Bits.BitCast where++-- fir+import FIR++------------------------------------------------+-- program++type Defs = '[ "x"    ':-> Input  '[Location 0] Word32+             , "y"    ':-> Input  '[Location 1] Int32+             , "out"  ':-> Output '[Location 0] Word32+             , "main" ':-> EntryPoint '[] Vertex+             ]++program :: Module Defs+program = Module $ entryPoint @"main" @Vertex do+  x <- get @"x"+  y <- get @"y"+  -- Reinterpret between signed and unsigned integers, and floating-point numbers.+  let+    signed :: Code Int32+    signed = bitcast x+    float :: Code Float+    float = bitcast y+  put @"out" ( bitcast ( signed `shiftR` ( 1 :: Code Word32 ) ) + bitcast float )
+ test/Tests/Bits/BitReverse.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE NamedWildCards   #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Bits.BitReverse where++-- fir+import FIR++------------------------------------------------+-- program++type Defs = '[ "x"    ':-> Input  '[Location 0] Word32+             , "out"  ':-> Output '[Location 0] Word32+             , "main" ':-> EntryPoint '[] Vertex+             ]++program :: Module Defs+program = Module $ entryPoint @"main" @Vertex do++    x <- get @"x"++    put @"out" $ bitReverse x `xor` bitReverse ( Lit 0x80000001 )
+ test/Tests/Bits/Bits.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE NamedWildCards   #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Bits.Bits where++-- fir+import FIR++------------------------------------------------+-- program++type Defs = '[ "x"    ':-> Input  '[Location 0] Word32+             , "y"    ':-> Input  '[Location 1] Word32+             , "z"    ':-> Input  '[Location 2] Word32+             , "w"    ':-> Input  '[Location 3] Word32+             , "out"  ':-> Output '[Location 0] Word32+             , "main" ':-> EntryPoint '[] Vertex+             ]++program :: Module Defs+program = Module $ entryPoint @"main" @Vertex do++    a <- get @"x" .&. get @"y"+    +    b <- def @"b" @R =<< (get @"z" .|. get @"w")++    put @"out" $ (a `shiftL` (3 :: Code Word32)) `xor` (a `shiftR` b) `xor` (complement b)
+ test/Tests/Bits/ZipBits.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE NamedWildCards   #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies     #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Bits.ZipBits where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- some random boolean operations++f :: Bool -> Bool -> Bool+f a b = a && not b++g :: Bool -> Bool -> Bool -- g a b = not ( a || b )+g a b = not a && ( not (f a b) `xor` b )++h :: Bool -> Bool -> Bool -- h a b = a+h a b = a || ( g a (f (g b a) (not a)) && a )++k :: Bool -> Bool -> Bool -- k a b = not ( a && b )+k a b = h ( g a (g b (not a && b)) ) (h (b `xor` a) b) || f (not b) (a && b || h b b)++------------------------------------------------+-- program++type Defs = '[ "a"    ':-> Input  '[Location 0] Word32+             , "b"    ':-> Input  '[Location 1] Word32+             , "out"  ':-> Output '[Location 0] (V 4 Word32)+             , "main" ':-> EntryPoint '[] Vertex+             ]++program :: Module Defs+program = Module $ entryPoint @"main" @Vertex do++    a <- get @"a"+    b <- get @"b"++    put @"out" $ Vec4 +                  ( zipBits2 f a b ) -- a .&. complement b+                  ( zipBits2 g a b ) -- complement ( a .|. b )+                  ( zipBits2 h a b ) -- a+                  ( zipBits2 k a b ) -- complement ( a .&. b )
+ test/Tests/Builtins/SampleId.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Builtin.SampleId where++-- fir+import FIR++------------------------------------------------+-- program++type Defs = '[ "out"  ':-> Output     '[ Location 0 ] Float+             , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment+             ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Fragment do++    sampleNo <- get @"gl_SampleID"++    put @"out" (fromIntegral sampleNo)
+ test/Tests/Builtins/SharedBuiltin.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Builtins.SharedBuiltin where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++-- Two entry points of the same module using the same built-in variable.++type Defs =+  '[ "out"   ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ]+                    ( Struct '[ "res" ':-> RuntimeArray Word32 ] )+   , "main1" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   , "main2" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do++  entryPoint @"main1" @Compute do+    ~( Vec3 x _ _ ) <- get @"gl_GlobalInvocationID"+    assign @( Name "out" :.: Name "res" :.: AnIndex Word32 ) x x++  entryPoint @"main2" @Compute do+    ~( Vec3 x _ _ ) <- get @"gl_GlobalInvocationID"+    assign @( Name "out" :.: Name "res" :.: AnIndex Word32 ) x ( x + 1 )
+ test/Tests/Components/FloatInt.golden view
@@ -0,0 +1,29 @@+test/Tests/Components/FloatInt.hs:31:12: error: [GHC-64725]+    • Incompatible scalars within Location 0:+        - V 2 Float with Location 0, Component 0 requires Float,+        - V 2 Int32 with Location 0, Component 2 requires Int32.+    • In the second argument of ‘($)’, namely+        ‘entryPoint+           @"main" @Vertex+           do ~(Vec2 x y) <- get @"in_col1"+              ~(Vec2 z w) <- get @"in_col2"+              put @"out_col" (Vec4 x y (convert z) (convert w))’+      In the expression:+        Module+          $ entryPoint+              @"main" @Vertex+              do ~(Vec2 x y) <- get @"in_col1"+                 ~(Vec2 z w) <- get @"in_col2"+                 put @"out_col" (Vec4 x y (convert z) (convert w))+      In an equation for ‘program’:+          program+            = Module+                $ entryPoint+                    @"main" @Vertex+                    do ~(Vec2 x y) <- get @"in_col1"+                       ~(Vec2 z w) <- get @"in_col2"+                       put @"out_col" (Vec4 x y (convert z) (convert w))+   |+31 |   Module $ entryPoint @"main" @Vertex do+   |            ^^^^^^^^^^+
+ test/Tests/Components/FloatInt.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Components.FloatInt where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs+  =  '[ "in_col1" ':-> Input  '[ Location 0              ] (V 2 Float) -- component mismatch+      , "in_col2" ':-> Input  '[ Location 0, Component 2 ] (V 2 Int32) -- floating-point vs integer+      , "out_col" ':-> Output '[ Location 0              ] (V 4 Float)+      , "main"    ':-> EntryPoint '[ ] Vertex+      ]++program :: Module Defs+program =+  Module $ entryPoint @"main" @Vertex do+    ~(Vec2 x y) <- get @"in_col1"+    ~(Vec2 z w) <- get @"in_col2"+    put @"out_col" ( Vec4 x y (convert z) (convert w) )
+ test/Tests/Components/FloatWidth.golden view
@@ -0,0 +1,29 @@+test/Tests/Components/FloatWidth.hs:31:12: error: [GHC-64725]+    • Incompatible scalars within Location 0:+        - V 2 Float with Location 0, Component 0 requires Float,+        - Double with Location 0, Component 2 requires Double.+    • In the second argument of ‘($)’, namely+        ‘entryPoint+           @"main" @Vertex+           do ~(Vec2 x y) <- get @"in_col1"+              z <- get @"in_col2"+              put @"out_col" (Vec4 x y (convert z) 1)’+      In the expression:+        Module+          $ entryPoint+              @"main" @Vertex+              do ~(Vec2 x y) <- get @"in_col1"+                 z <- get @"in_col2"+                 put @"out_col" (Vec4 x y (convert z) 1)+      In an equation for ‘program’:+          program+            = Module+                $ entryPoint+                    @"main" @Vertex+                    do ~(Vec2 x y) <- get @"in_col1"+                       z <- get @"in_col2"+                       put @"out_col" (Vec4 x y (convert z) 1)+   |+31 |   Module $ entryPoint @"main" @Vertex do+   |            ^^^^^^^^^^+
+ test/Tests/Components/FloatWidth.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Components.FloatWidth where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs+  =  '[ "in_col1" ':-> Input  '[ Location 0              ] (V 2 Float) -- component mismatch+      , "in_col2" ':-> Input  '[ Location 0, Component 2 ] Double      -- floating-point types of different widths+      , "out_col" ':-> Output '[ Location 0              ] (V 4 Float)+      , "main"    ':-> EntryPoint '[ ] Vertex+      ]++program :: Module Defs+program =+  Module $ entryPoint @"main" @Vertex do+    ~(Vec2 x y) <- get @"in_col1"+    z <- get @"in_col2"+    put @"out_col" ( Vec4 x y (convert z) 1 )
+ test/Tests/Components/IntWidth.golden view
@@ -0,0 +1,29 @@+test/Tests/Components/IntWidth.hs:31:12: error: [GHC-64725]+    • Incompatible scalars within Location 0:+        - V 2 Word32 with Location 0, Component 0 requires Word32,+        - Word64 with Location 0, Component 2 requires Word64.+    • In the second argument of ‘($)’, namely+        ‘entryPoint+           @"main" @Vertex+           do ~(Vec2 x y) <- get @"in_col1"+              z <- get @"in_col2"+              put @"out_col" (Vec4 x y (convert z) 1)’+      In the expression:+        Module+          $ entryPoint+              @"main" @Vertex+              do ~(Vec2 x y) <- get @"in_col1"+                 z <- get @"in_col2"+                 put @"out_col" (Vec4 x y (convert z) 1)+      In an equation for ‘program’:+          program+            = Module+                $ entryPoint+                    @"main" @Vertex+                    do ~(Vec2 x y) <- get @"in_col1"+                       z <- get @"in_col2"+                       put @"out_col" (Vec4 x y (convert z) 1)+   |+31 |   Module $ entryPoint @"main" @Vertex do+   |            ^^^^^^^^^^+
+ test/Tests/Components/IntWidth.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Components.IntWidth where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs+  =  '[ "in_col1" ':-> Input  '[ Location 0              ] (V 2 Word32) -- component mismatch+      , "in_col2" ':-> Input  '[ Location 0, Component 2 ] Word64       -- integer types of different widths+      , "out_col" ':-> Output '[ Location 0              ] (V 4 Word32)+      , "main"    ':-> EntryPoint '[ ] Vertex+      ]++program :: Module Defs+program =+  Module $ entryPoint @"main" @Vertex do+    ~(Vec2 x y) <- get @"in_col1"+    z <- get @"in_col2"+    put @"out_col" ( Vec4 x y (convert z) 1 )
+ test/Tests/Components/Sign.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Components.Sign where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs+  =  '[ "in_col1" ':-> Input  '[ Location 0              ] (V 2 Int32 ) -- valid component assignment+      , "in_col2" ':-> Input  '[ Location 0, Component 2 ] (V 2 Word32) -- (signedness is not important)+      , "out_col" ':-> Output '[ Location 0              ] (V 4 Int32 )+      , "main"    ':-> EntryPoint '[ ] Vertex+      ]++program :: Module Defs+program =+  Module $ entryPoint @"main" @Vertex do+    ~(Vec2 x y) <- get @"in_col1"+    ~(Vec2 z w) <- get @"in_col2"+    put @"out_col" ( Vec4 x y (convert z) (convert w) )
+ test/Tests/Control/BreakContinueNested.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Control.BreakContinueNested where++-- fir+import FIR++------------------------------------------------+-- program++-- Early exits out of several loops at once, from the innermost of three nested loops:+--   - 'break @3' exits all three loops,+--   - 'breakContinue @2' continues the outermost loop,+--   - 'breakContinue @1' continues the middle loop.+--+-- In structured control flow, these must exit the innermost loop first,+-- and continue the early exit from its merge block.++type Defs =+  '[ "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "res" ':-> Float ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Compute do++    _ <- def @"x" @RW @Float  0+    _ <- def @"i" @RW @Word32 0+    while ( ( < 10 ) <<$>> get @"i" ) do+      modify @"i" ( + 1 )+      loop do+        modify @"x" ( * 2 )+        loop do+          modify @"x" ( + 1 )+          x <- get @"x"+          if x > 100+          then do+            put @"x" ( -1 )+            break @3+          else+            if x > 50+            then breakContinue @2+            else+              if x > 20+              then breakContinue @1+              else continue++    x <- get @"x"+    i <- get @"i"+    assign @( Name "out" :.: Name "res" ) ( x + fromIntegral i )
+ test/Tests/Control/BreakInCondition.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Control.BreakInCondition where++-- fir+import FIR++------------------------------------------------+-- program++-- Early exits from the condition of a loop, which refer to the enclosing loops.++type Defs =+  '[ "ubo"  ':-> Uniform '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "n" ':-> Word32 ] )+   , "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ]+                   ( Struct '[ "res" ':-> Float ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Compute do++    n <- use @( Name "ubo" :.: Name "n" )+    _ <- def @"x" @RW @Word32 0+    _ <- def @"y" @RW @Word32 0++    -- 'break' and 'continue' in the condition of an inner loop.+    loop do+      modify @"x" ( + 1 )+      while+        ( do+            x <- get @"x"+            when ( x > 100 ) ( break @1 )+            when ( x > 50  ) continue+            pure ( x < n )+        ) do+        modify @"x" ( + 2 )++    -- A loop in the condition of a loop, breaking out of both the inner loop+    -- and the loop enclosing the outer loop's condition.+    loop do+      modify @"y" ( + 1 )+      while+        ( do+            loop do+              y <- get @"y"+              when ( y > 100 ) ( break @2 )+              when ( y > 10  ) ( break @1 )+              put @"y" ( y * 2 )+            y <- get @"y"+            pure ( y < n )+        ) do+        modify @"y" ( + 3 )++    x <- get @"x"+    y <- get @"y"+    assign @( Name "out" :.: Name "res" ) ( fromIntegral ( x + y ) )
+ test/Tests/Control/BreakNested.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Control.BreakNested where++-- fir+import FIR++------------------------------------------------+-- program++-- Breaking out of two loops at once: the break is a predecessor of the merge block+-- of the outer loop, and must contribute to its ϕ-instructions (here, for "x").++type Defs =+  '[ "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "res" ':-> Float ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Compute do++    _ <- def @"x" @RW @Float 0+    loop do+      modify @"x" ( + 1 )+      loop do+        x <- get @"x"+        if x > 10+        then do+          put @"x" 100+          break @2+        else+          if x > 5+          then break @1+          else put @"x" ( x + 2 )++    x <- get @"x"+    assign @( Name "out" :.: Name "res" ) x
+ test/Tests/Control/DeadCode.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Control.DeadCode where++-- fir+import FIR++------------------------------------------------+-- program++-- Code following a 'break' is unreachable. It must not be emitted into the block+-- that the 'break' terminated, and control flow constructs within it must still be+-- emitted consistently (e.g. a selection whose merge block is missing is invalid).++type Defs =+  '[ "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "res" ':-> Float ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Compute do++    _ <- def @"x" @RW @Float 0++    -- Conditional in dead code after a break.+    loop do+      x <- get @"x"+      if x > 3+      then do+        break @1+        if x > 4+        then put @"x" 1+        else put @"x" 2+      else put @"x" ( x + 1 )++    -- Loop body ending with a break.+    while ( ( < 10 ) <<$>> get @"x" ) do+      modify @"x" ( * 2 )+      break @1++    x <- get @"x"+    assign @( Name "out" :.: Name "res" ) x
+ test/Tests/Control/Def.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE NamedWildCards   #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Control.Def where++-- fir+import FIR+import FIR.Syntax.Labels+import Math.Linear++------------------------------------------------+-- program++type Defs = '[ "position" ':-> Output     '[Location 0] (V 4 Float)+             , "main"     ':-> EntryPoint '[] Vertex+             ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Vertex do++    let (#<) = (<) @(Program _i _i _) -- disambiguate to help type inference++    #t @Float #= 0+    #s @Float #= 1+    #r @Float #= 1++    while ( #t #< abs ( #s - #t ) ) do+      t <- #t+      s <- #s++      #r .= t + s++    r <- #r+   +    if r < 1+    then #r .= 1+    else #r .= r - 1++    #u @Float #= 0 -- variable definition not in top block after function declaration++    #position .= Vec4 r r r 1
+ test/Tests/Control/Loop1.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE NamedWildCards   #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Control.Loop1 where++-- fir+import FIR+import FIR.Syntax.Labels++------------------------------------------------+-- program++type Defs = '[ "main" ':-> EntryPoint '[] Vertex ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Vertex do++    let (#<) = (<) @(Program _i _i _) -- disambiguate to help type inference++    #t @Float #= 0+    #s @Float #= 1+    #r @Float #= 1++    while ( #t #< abs ( #s - #t ) ) do+      t <- #t+      s <- #s+      #t %= (+1)+      #s .= (s+2*t)+      #r .= t + s+      while ( #r #< ( #t * ( #s + #t ) ) ) do+        #r %= (+1)++    r <- #r+    s <- #s+    t <- #t++    #gl_Position .= Vec4 r s t 1
+ test/Tests/Control/Loop2.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE NamedWildCards   #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Control.Loop2 where++-- fir+import FIR+import FIR.Syntax.Labels+import Math.Linear++------------------------------------------------+-- program++type Defs = '[ "main" ':-> EntryPoint '[] Vertex ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Vertex do++    #p #= ( 99 :: Code Float )+    #q #= ( Vec4 3 4 5 6 :: Code ( V 4 Float ) )++    loop do+      p <- #p+      q <- #q+      if p * norm q > 1555+      then break @1+      else do+        #p .= p + 17+        #q .= 3 *^ q+    +    q <- #q++    #gl_Position .= q
+ test/Tests/Control/Loop3.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE NamedWildCards   #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE PartialTypeSignatures    #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}+++module Tests.Control.Loop3 where++-- fir+import FIR+import FIR.Syntax.Labels++------------------------------------------------+-- program++type Defs = '[ "main" ':-> EntryPoint '[] Vertex ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Vertex do++    #i #= (1 :: Code Int32)+    #v #= (1728 :: Code Float)++    loop do+      i <- #i++      when (i > 32) do+        #v .= 123+        break @1++      when (i * 2 > 16) do+        #v .= 456+        break @1++      #i %= (+1)++    v <- #v++    #gl_Position .= Vec4 v v v 1
+ test/Tests/Control/LoopCondition.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Control.LoopCondition where++-- fir+import FIR++------------------------------------------------+-- program++-- A loop condition containing control flow, which modifies a binding.++type Defs =+  '[ "ubo"  ':-> Uniform '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "n" ':-> Word32 ] )+   , "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ]+                   ( Struct '[ "res" ':-> Float ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Compute do++    n <- use @( Name "ubo" :.: Name "n" )+    _ <- def @"x" @RW @Word32 0+    _ <- def @"y" @RW @Float  0+    while+      ( do+          x <- get @"x"+          if x > 3+          then do+            modify @"y" ( + 1 )+            pure ( x < n )+          else pure ( x < 2 * n )+      ) do+      modify @"x" ( + 1 )++    y <- get @"y"+    assign @( Name "out" :.: Name "res" ) y
+ test/Tests/Control/LoopsNested.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Control.LoopsNested where++-- fir+import FIR++------------------------------------------------+-- program++-- Nested loops in a function, with bindings that are:+--   - modified in the inner loop ("acc", "m"),+--   - modified in the outer loop only ("j"),+--   - never modified ("k"),+--   - only modified just before breaking out of the outer loop ("b").++type Defs =+  '[ "ubo"  ':-> Uniform '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "n" ':-> Word32 ] )+   , "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ]+                   ( Struct '[ "res" ':-> Float ] )+   , "f"    ':-> Function '[ "u" ':-> Var R Word32 ] Float+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do++  ( f :: Code Word32 -> Code Float ) <- fundef @"f" do+    _ <- def @"acc" @RW @Float  0+    _ <- def @"j"   @RW @Word32 0+    _ <- def @"m"   @RW @Word32 0+    _ <- def @"k"   @RW @Float  3+    _ <- def @"b"   @RW @Float  0+    u <- get @"u"+    while ( ( < u ) <<$>> get @"j" ) do+      j <- get @"j"+      put @"m" 0+      while ( ( < j ) <<$>> get @"m" ) do+        m <- get @"m"+        k <- get @"k"+        modify @"acc" ( + ( fromIntegral m * k ) )+        put @"m" ( m + 1 )+      acc <- get @"acc"+      if acc > 100+      then do+        put @"b" acc+        break @1+      else put @"j" ( j + 1 )+    acc <- get @"acc"+    b   <- get @"b"+    k   <- get @"k"+    pure ( acc + b + k )++  entryPoint @"main" @Compute do+    n <- use @( Name "ubo" :.: Name "n" )+    assign @( Name "out" :.: Name "res" ) ( f n )
+ test/Tests/Control/RayQueryVariable.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Control.RayQueryVariable where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++-- Initialising a ray query declares a variable holding the ray query object,+-- which must be declared in a valid location (module scope for a Private variable,+-- first block of the function for a Function variable).++type Defs =+  '[ "accel" ':-> UniformConstant '[ DescriptorSet 0, Binding 0 ] AccelerationStructure+   , "main"  ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Compute do+    accel <- get @"accel"+    locally do+      initialize @"query" accel+        ( RayInfo+          { rayFlags     = 0+          , rayOrigin    = Vec3 0 0 0+          , rayDirection = Vec3 0 0 1+          , rayTMin      = 0+          , rayTMax      = 100+          , cullMask     = 0xff+          }+        )+      terminate @"query"
+ test/Tests/Control/Selection.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE NamedWildCards   #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Control.Selection where++-- fir+import FIR++------------------------------------------------+-- program++type Defs = '[ "x"    ':-> Input      '[Location 0] Float+             , "y"    ':-> Input      '[Location 1] Float+             , "out"  ':-> Output     '[Location 0] Float+             , "main" ':-> EntryPoint '[OriginUpperLeft] Fragment+             ]++program :: Module Defs+program = Module $ entryPoint @"main" @Fragment do++  -- test "selection" instruction+  x  <- get @"x"+  x' <- def @"x'" @R @Float ( if x < 0 then 0 else 3*x )++  -- test monadic "if-then-else" instruction+  y  <- get @"y"+  _  <- def @"y'" @RW @Float y+  if y < 0+  then do+    put @"y'" (y+7)+  else do+    put @"y'" 4+  y' <- get @"y'"+  ++  put @"out" (x'+y')
+ test/Tests/Control/Switch.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE NamedWildCards   #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Control.Switch where++-- fir+import FIR++------------------------------------------------+-- program++type Defs = '[ "a"    ':-> Input      '[Location 0, Flat] Word32+             , "b"    ':-> Input      '[Location 1, Flat] Int32+             , "t"    ':-> Input      '[Location 2] Float+             , "out"  ':-> Output     '[Location 0] Float+             , "main" ':-> EntryPoint '[OriginUpperLeft] Fragment+             ]++program :: Module Defs+program = Module $ entryPoint @"main" @Fragment do++  -- test "switch" instruction+  a <- get @"a"+  t <- get @"t"+  x <- def @"x" @R @Float $+          switch a+            [ 7 :-> t + 1+            , 2 :-> 2+            , 1 :-> 3 - t+            ]+            ( t - 9 ) -- default++  -- test monadic "switchM" instruction+  y <- switchM (get @"b")+          [ 2 :-> pure 11+          , 1 :-> get @"t"+          ]+          ( abs $ get @"t" )++  put @"out" (x + y)
+ test/Tests/Control/TemporaryBranches.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Control.TemporaryBranches where++-- base+import Data.Maybe+  ( fromJust )++-- vector-sized+import qualified Data.Vector.Sized as Vector++-- fir+import FIR++------------------------------------------------+-- program++-- Indexing into an array value with a run-time index requires copying the array+-- into a local variable. The copy made in one branch must not be reused+-- in the other branch, nor after the branches merge, as the store that+-- initialises the local variable does not dominate those uses.++table :: Array 4 Float+table = MkArray ( fromJust $ Vector.fromList [ 1, 2, 3, 4 ] )++type Defs =+  '[ "ubo"  ':-> Uniform '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "i" ':-> Word32 ] )+   , "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ]+                   ( Struct '[ "res" ':-> Float ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Compute do++    let+      arr :: Code ( Array 4 Float )+      arr = Lit table+    i <- use @( Name "ubo" :.: Name "i" )++    r <-+      if i > 2+      then pure ( view @( AnIndex ( Code Word32 ) ) i arr )+      else pure ( view @( AnIndex ( Code Word32 ) ) ( i - 1 ) arr )++    assign @( Name "out" :.: Name "res" ) ( r + view @( AnIndex ( Code Word32 ) ) ( i + 1 ) arr )
+ test/Tests/Control/TemporaryFunctions.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Control.TemporaryFunctions where++-- base+import Data.Maybe+  ( fromJust )++-- vector-sized+import qualified Data.Vector.Sized as Vector++-- fir+import FIR++------------------------------------------------+-- program++-- Indexing a constant array with a run-time index requires a local variable+-- holding the array. Each function must use its own local variable.++table :: Array 4 Float+table = MkArray ( fromJust $ Vector.fromList [ 1, 2, 3, 4 ] )++type Defs =+  '[ "ubo"  ':-> Uniform '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "i" ':-> Word32 ] )+   , "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ]+                   ( Struct '[ "res" ':-> Float ] )+   , "f"    ':-> Function '[ "u" ':-> Var R Word32 ] Float+   , "g"    ':-> Function '[ "v" ':-> Var R Word32 ] Float+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do++  ( f :: Code Word32 -> Code Float ) <- fundef @"f" do+    u <- get @"u"+    pure ( view @( AnIndex ( Code Word32 ) ) u ( Lit table :: Code ( Array 4 Float ) ) )++  ( g :: Code Word32 -> Code Float ) <- fundef @"g" do+    v <- get @"v"+    pure ( view @( AnIndex ( Code Word32 ) ) ( v + 1 ) ( Lit table :: Code ( Array 4 Float ) ) )++  entryPoint @"main" @Compute do+    i <- use @( Name "ubo" :.: Name "i" )+    assign @( Name "out" :.: Name "res" ) ( f i + g i )
+ test/Tests/Control/TemporaryLoop.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Control.TemporaryLoop where++-- base+import Data.Maybe+  ( fromJust )++-- vector-sized+import qualified Data.Vector.Sized as Vector++-- fir+import FIR++------------------------------------------------+-- program++-- A local copy of an array made inside a loop body (in order to index it+-- with a run-time index) must not be reused after the loop:+-- the loop body might not run at all.++table :: Array 4 Float+table = MkArray ( fromJust $ Vector.fromList [ 1, 2, 3, 4 ] )++type Defs =+  '[ "ubo"  ':-> Uniform '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "n" ':-> Word32 ] )+   , "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ]+                   ( Struct '[ "res" ':-> Float ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Compute do++    let+      arr :: Code ( Array 4 Float )+      arr = Lit table+    n <- use @( Name "ubo" :.: Name "n" )++    _ <- def @"i"   @RW @Word32 0+    _ <- def @"acc" @RW @Float  0+    while ( ( < n ) <<$>> get @"i" ) do+      i <- get @"i"+      modify @"acc" ( + view @( AnIndex ( Code Word32 ) ) i arr )+      put @"i" ( i + 1 )++    acc <- get @"acc"+    assign @( Name "out" :.: Name "res" ) ( acc + view @( AnIndex ( Code Word32 ) ) n arr )
+ test/Tests/Control/TemporarySetter.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Control.TemporarySetter where++-- base+import Data.Maybe+  ( fromJust )++-- vector-sized+import qualified Data.Vector.Sized as Vector++-- fir+import FIR++------------------------------------------------+-- program++-- Setting an element of an array value at a run-time index goes through a local copy+-- of the array. Indexing the original array afterwards must not read the modified copy.++table :: Array 4 Float+table = MkArray ( fromJust $ Vector.fromList [ 1, 2, 3, 4 ] )++type Defs =+  '[ "ubo"  ':-> Uniform '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "i" ':-> Word32 ] )+   , "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ]+                   ( Struct '[ "res" ':-> Float ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Compute do++    let+      arr :: Code ( Array 4 Float )+      arr = Lit table+    i <- use @( Name "ubo" :.: Name "i" )++    new <- let' $ view @( AnIndex ( Code Word32 ) ) i ( set @( AnIndex ( Code Word32 ) ) i 7 arr )+    old <- let' $ view @( AnIndex ( Code Word32 ) ) i arr++    assign @( Name "out" :.: Name "res" ) ( new + old )
+ test/Tests/Debug/Printf.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE BlockArguments    #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE NamedWildCards    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds         #-}+{-# LANGUAGE RebindableSyntax  #-}+{-# LANGUAGE TypeApplications  #-}+{-# LANGUAGE TypeOperators     #-}++module Tests.Debug.Printf where++-- fir+import FIR+import FIR.Syntax.DebugPrintf+import Math.Linear++------------------------------------------------+-- program++type Defs = '[ "position" ':-> Input  '[Location 0] (V 4 Float)+             , "colour"   ':-> Input  '[Location 1, Flat] (V 4 Word32)+             , "out"      ':-> Output '[Location 0] (V 4 Word32)+             , "main"     ':-> EntryPoint '[OriginUpperLeft] Fragment+             ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Fragment do++    pos <- get @"position"+    col <- get @"colour"++    debugPrintf ( "position = " % vec @4 float % " colour = " % vec @4 word32Hex ) pos col++    put @"out" col
+ test/Tests/Definitions/Descriptors.golden view
@@ -0,0 +1,21 @@+test/Tests/Definitions/Descriptors.hs:28:11: error: [GHC-64725]+    • More than one descriptor with DescriptorSet 1 and Binding 2:+      ["desc3", "desc2", "desc1"]+    • In the expression:+        Module+          do entryPoint+               @"main" @Vertex+               do xy <- use @(Name "desc1" :.: Name "v")+                  abcd <- imageRead @"desc2" xy+                  ....+      In an equation for ‘program’:+          program+            = Module+                do entryPoint+                     @"main" @Vertex+                     do xy <- use @(Name "desc1" :.: Name "v")+                        ....+   |+28 | program = Module do+   |           ^^^^^^+
+ test/Tests/Definitions/Descriptors.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE NamedWildCards   #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Definitions.Descriptors where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs = '[ "desc1" ':-> Uniform    '[ DescriptorSet 1, Binding 2 ]+                              ( Struct '[ "v" ':-> V 2 Word32 ] )+             , "desc2" ':-> Image2D    '[ DescriptorSet 1, Binding 2 ] ( RGBA8 UNorm )+             , "desc3" ':-> StorageBuffer '[ DescriptorSet 1, Binding 2 ]+                              ( Struct '[ "rt" ':-> RuntimeArray ( V 4 Float ) ] )+             , "main"  ':-> EntryPoint '[] Vertex+             ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Vertex do++    xy <- use @( Name "desc1" :.: Name "v" )+    abcd <- imageRead @"desc2" xy+    assign @( Name "desc3" :.: Name "rt" :.: AnIndex Word32 ) 17 abcd
+ test/Tests/Definitions/OriginLowerLeft.golden view
@@ -0,0 +1,80 @@+test/Tests/Definitions/OriginLowerLeft.hs:24:3: error: [GHC-64725]+    • Fragment shader named "main" uses execution mode OriginLowerLeft, which Vulkan does not allow.+      Use OriginUpperLeft instead.+    • In a stmt of a 'do' block:+        entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)+      In the first argument of ‘Module’, namely+        ‘do entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)’+      In the expression:+        Module+          do entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)+   |+24 |   entryPoint @"main" @Fragment do+   |   ^^^^^^^^^^++test/Tests/Definitions/OriginLowerLeft.hs:24:3: error: [GHC-64725]+    • Fragment shader named "main" uses execution mode OriginLowerLeft, which Vulkan does not allow.+      Use OriginUpperLeft instead.+    • In a stmt of a 'do' block:+        entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)+      In the first argument of ‘Module’, namely+        ‘do entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)’+      In the expression:+        Module+          do entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)+   |+24 |   entryPoint @"main" @Fragment do+   |   ^^^^^^^^^^++test/Tests/Definitions/OriginLowerLeft.hs:24:3: error: [GHC-64725]+    • Fragment shader named "main" uses execution mode OriginLowerLeft, which Vulkan does not allow.+      Use OriginUpperLeft instead.+    • In a stmt of a 'do' block:+        entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)+      In the first argument of ‘Module’, namely+        ‘do entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)’+      In the expression:+        Module+          do entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)+   |+24 |   entryPoint @"main" @Fragment do+   |   ^^^^^^^^^^++test/Tests/Definitions/OriginLowerLeft.hs:24:3: error: [GHC-64725]+    • Fragment shader named "main" uses execution mode OriginLowerLeft, which Vulkan does not allow.+      Use OriginUpperLeft instead.+    • In a stmt of a 'do' block:+        entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)+      In the first argument of ‘Module’, namely+        ‘do entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)’+      In the expression:+        Module+          do entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)+   |+24 |   entryPoint @"main" @Fragment do+   |   ^^^^^^^^^^++test/Tests/Definitions/OriginLowerLeft.hs:25:5: error: [GHC-64725]+    • Fragment shader named "main" uses execution mode OriginLowerLeft, which Vulkan does not allow.+      Use OriginUpperLeft instead.+    • In a stmt of a 'do' block: put @"out_col" (Vec4 0 0 0 1)+      In the third argument of ‘entryPoint’, namely+        ‘do put @"out_col" (Vec4 0 0 0 1)’+      In a stmt of a 'do' block:+        entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)+   |+25 |     put @"out_col" ( Vec4 0 0 0 1 )+   |     ^^^++test/Tests/Definitions/OriginLowerLeft.hs:25:5: error: [GHC-64725]+    • Fragment shader named "main" uses execution mode OriginLowerLeft, which Vulkan does not allow.+      Use OriginUpperLeft instead.+    • In a stmt of a 'do' block: put @"out_col" (Vec4 0 0 0 1)+      In the third argument of ‘entryPoint’, namely+        ‘do put @"out_col" (Vec4 0 0 0 1)’+      In a stmt of a 'do' block:+        entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)+   |+25 |     put @"out_col" ( Vec4 0 0 0 1 )+   |     ^^^+
+ test/Tests/Definitions/OriginLowerLeft.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Definitions.OriginLowerLeft where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- Vulkan does not allow fragment shaders with a lower-left origin++type Defs =+  '[ "out_col" ':-> Output     '[ Location 0 ] ( V 4 Float )+   , "main"    ':-> EntryPoint '[ OriginLowerLeft ] Fragment+   ]++program :: Module Defs+program = Module do+  entryPoint @"main" @Fragment do+    put @"out_col" ( Vec4 0 0 0 1 )
+ test/Tests/Definitions/PushConstant.golden view
@@ -0,0 +1,16 @@+test/Tests/Definitions/PushConstant.hs:23:11: error: [GHC-64725]+    • Push constant named "pc" should be backed by a struct;+      found type Float instead.+    • In the expression:+        Module+          do entryPoint+               @"main" @Compute do assign @(Name "out" :.: Name "f") =<< get @"pc"+      In an equation for ‘program’:+          program+            = Module+                do entryPoint+                     @"main" @Compute do assign @(Name "out" :.: Name "f") =<< get @"pc"+   |+23 | program = Module do+   |           ^^^^^^+
+ test/Tests/Definitions/PushConstant.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Definitions.PushConstant where++-- fir+import FIR++------------------------------------------------+-- push constants must be structures++type Defs =+  '[ "pc"   ':-> PushConstant '[] Float+   , "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ] ( Struct '[ "f" ':-> Float ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do+  entryPoint @"main" @Compute do+    assign @( Name "out" :.: Name "f" ) =<< get @"pc"
+ test/Tests/Definitions/UniformRuntimeArray.golden view
@@ -0,0 +1,21 @@+test/Tests/Definitions/UniformRuntimeArray.hs:24:11: error: [GHC-64725]+    • Structure member "rt" cannot appear in buffer named "ubo".+      Its type RuntimeArray Float+      is opaque (or it contains an opaque type).+    • In the expression:+        Module+          do entryPoint+               @"main" @Compute+               do assign @(Name "out" :.: Name "f")+                    =<< use @(Name "ubo" :.: Name "x")+      In an equation for ‘program’:+          program+            = Module+                do entryPoint+                     @"main" @Compute+                     do assign @(Name "out" :.: Name "f")+                          =<< use @(Name "ubo" :.: Name "x")+   |+24 | program = Module do+   |           ^^^^^^+
+ test/Tests/Definitions/UniformRuntimeArray.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Definitions.UniformRuntimeArray where++-- fir+import FIR++------------------------------------------------+-- uniform buffers can't contain runtime arrays++type Defs =+  '[ "ubo"  ':-> Uniform '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "x" ':-> Float, "rt" ':-> RuntimeArray Float ] )+   , "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] ( Struct '[ "f" ':-> Float ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do+  entryPoint @"main" @Compute do+    assign @( Name "out" :.: Name "f" ) =<< use @( Name "ubo" :.: Name "x" )
+ test/Tests/Geometry/Geometry.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Geometry.Geometry where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type GeometryDefs =+  '[ "in_color"  ':-> Input  '[ Location 0 ] ( Array 3 (V 4 Float ) )+   , "out_color" ':-> Output '[ Location 0 ] ( V 4 Float )+   , "normal"    ':-> Output '[ Location 1 ] ( V 3 Float )+   , "main"      ':-> EntryPoint+                         '[ Triangles+                          , OutputTriangleStrip+                          , OutputVertices 3+                          , Invocations 1+                          ]+                          Geometry+   ]++program :: Module GeometryDefs+program = Module $ entryPoint @"main" @Geometry do+  v0 <- use @(Name "gl_in" :.: Index 0 :.: Name "gl_Position")+  v1 <- use @(Name "gl_in" :.: Index 1 :.: Name "gl_Position")+  v2 <- use @(Name "gl_in" :.: Index 2 :.: Name "gl_Position")+  let+    Vec4 u1x u1y u1z _ = v1 ^-^ v0+    Vec4 u2x u2y u2z _ = v2 ^-^ v0+    normal = normalise ( Vec3 u1x u1y u1z `cross` Vec3 u2x u2y u2z )+  color <- get @"in_color"++  put @"normal" normal+  put @"gl_Position" v0+  put @"out_color" ( view @(Index 0) color )+  emitVertex++  put @"normal" normal+  put @"gl_Position" v1+  put @"out_color" ( view @(Index 1) color )+  emitVertex++  put @"normal" normal+  put @"gl_Position" v2+  put @"out_color" ( view @(Index 2) color )+  emitVertex+  endPrimitive++  pure ( Lit () )
+ test/Tests/Geometry/NotGeometry.golden view
@@ -0,0 +1,18 @@+test/Tests/Geometry/NotGeometry.hs:34:5: error: [GHC-18872]+    • Couldn't match type ‘FragmentShader’ with ‘GeometryShader’+        arising from a use of ‘emitVertex’+    • In a stmt of a 'do' block: emitVertex+      In the third argument of ‘entryPoint’, namely+        ‘do col <- get @"in_colour"+            put @"out_colour" col+            emitVertex’+      In a stmt of a 'do' block:+        entryPoint+          @"main" @Fragment+          do col <- get @"in_colour"+             put @"out_colour" col+             emitVertex+   |+34 |     emitVertex    -- not allowed: not in a geometry shader+   |     ^^^^^^^^^^+
+ test/Tests/Geometry/NotGeometry.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Geometry.NotGeometry where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type FragmentDefs =+  '[ "in_position" ':-> Input  '[ Location 0 ] (V 4 Float)+   , "in_colour"   ':-> Input  '[ Location 1 ] (V 4 Float)+   , "out_colour"  ':-> Output '[ Location 0 ] (V 4 Float)+   , "main"        ':-> EntryPoint '[ OriginUpperLeft ] Fragment+   ]++program :: Module FragmentDefs+program = Module do+  entryPoint @"main" @Fragment do+    col <- get @"in_colour"+    put @"out_colour" col+    emitVertex    -- not allowed: not in a geometry shader
+ test/Tests/Groups/GroupAdd.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Groups.GroupAdd where++-- fir+import FIR+import Math.Linear+++------------------------------------------------+-- program++type Defs =+  '[    "img"  ':-> Image2D '[ DescriptorSet 0, Binding 1 ]+                    ( RGBA8 UNorm )+        , "main" ':-> EntryPoint '[ LocalSize 16 8 1 ]+                    Compute+   ]++program :: Module Defs+program = Module $ entryPoint @"main" @Compute do+    +  ~(Vec3 i_x i_y _) <- get @"gl_GlobalInvocationID"+  gl_SubgroupInvocationID <- get @"gl_SubgroupInvocationID"++  someSubgroupOutput <- groupAdd @Subgroup @Reduce (Vec2 i_x i_y)++  imageWrite @"img"+      someSubgroupOutput+      (Vec4 0 0 0 0)+
+ test/Tests/Images/Gather.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Images.Gather where++-- base+import Data.Maybe+  ( fromJust )++-- fir+import FIR+import Math.Linear++-- vector-sized+import qualified Data.Vector.Sized as Vector++------------------------------------------------+-- program++type Defs+  =  '[ "image"   ':-> Texture2D  '[ Binding 0, DescriptorSet 0 ] (RGBA8 UNorm)+      , "in_pos"  ':-> Input      '[ Location 0 ] (V 2 Float)+      , "out_col" ':-> Output     '[ Location 0 ] (V 4 Float)+      , "main"    ':-> EntryPoint '[ OriginUpperLeft ] Fragment+      ]++program :: Module Defs+program =+  Module $ entryPoint @"main" @Fragment do+    pos   <- get @"in_pos"+    let offsetArray :: Array 4 (V 2 Int32)+        offsetArray = MkArray (fromJust $ Vector.fromList [V2 0 0, V2 0 1, V2 1 0, V2 1 1])+    col <- use @(ImageTexel "image") (Gather (ComponentWithOffsets 0 offsetArray) NilOps) pos+    put @"out_col" col
+ test/Tests/Images/ReadWrite.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Images.ReadWrite where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs+  =  '[ "image1"  ':-> Image2D '[ Binding 0, DescriptorSet 0 ] (RG32 UI)+      , "image2"  ':-> Image2D '[ Binding 0, DescriptorSet 1 ] (R32 F)+      , "out_col" ':-> Output     '[ Location 0 ] (V 4 Float)+      , "main"    ':-> EntryPoint '[ OriginUpperLeft ] Fragment+      ]++program :: Module Defs+program = Module $ entryPoint @"main" @Fragment do+  ( index2D :: Code ( V 2 Word32 ) ) <-+    let' =<< imageRead @"image1" ( Vec2 ( 0 :: Code Word32 ) ( 1 :: Code Word32 ) )+  ( float :: Code Float ) <-+    let' =<< imageRead @"image2" index2D+  imageWrite @"image2" index2D ( 2 * float )+  put @"out_col" ( Vec4 float float float float )
+ test/Tests/Images/Sample.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Images.Sample where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs+  =  '[ "image"   ':-> Texture2D  '[ Binding 0, DescriptorSet 0 ] (RGBA8 UNorm)+      , "in_pos"  ':-> Input      '[ Location 0 ] (V 2 Float)+      , "out_col" ':-> Output     '[ Location 0 ] (V 4 Float)+      , "main"    ':-> EntryPoint '[ OriginUpperLeft ] Fragment+      ]++program :: Module Defs+program =+  Module $ entryPoint @"main" @Fragment do+    pos <- get @"in_pos"+    col <- use @(ImageTexel "image") (MinLOD ( 0.5 :: Code Float ) NilOps) pos+    put @"out_col" col
+ test/Tests/Inference/Ising1.golden view
@@ -0,0 +1,1 @@+No type-checking errors.
+ test/Tests/Inference/Ising1.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE NamedWildCards         #-}+{-# LANGUAGE PartialTypeSignatures  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE RebindableSyntax       #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators          #-}++module Tests.Inference.Ising1 where++-- fir+import FIR++------------------------------------------------++data Parity = Even | Odd+data SParity ( parity :: Parity ) where+  SEven :: SParity Even+  SOdd  :: SParity Odd++type family Bd ( parity :: Parity ) = r | r -> parity where+  Bd Even = 2+  Bd Odd  = 3++type Defs ( parity :: Parity ) =+  '[ "out"  ':-> Image2D    '[ DescriptorSet 0, Binding 37 ] ( R32 F )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++shader :: _ => SParity parity -> Module ( Defs parity )+shader sParity = Module $ entryPoint @"main" @Compute $ do+  val <- foo+  pure ( Lit () )++foo :: Program _s _t ( Code Float )+foo = def @"x" @R @Float 3
+ test/Tests/Inference/Ising2.golden view
@@ -0,0 +1,1 @@+No type-checking errors.
+ test/Tests/Inference/Ising2.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE NamedWildCards         #-}+{-# LANGUAGE PartialTypeSignatures  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE RebindableSyntax       #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeOperators          #-}++module Tests.Inference.Ising2 where++-- fir+import FIR++------------------------------------------------+-- Work sizes.++data Parity = Even | Odd+data SParity ( parity :: Parity ) where+  SEven :: SParity Even+  SOdd  :: SParity Odd++type Defs ( parity :: Parity ) =+  '[ "even" ':-> Input '[ Location 0 ] Float+   , "odd"  ':-> Input '[ Location 1 ] Float+   , "main" ':-> EntryPoint '[] Vertex+   ]++shader :: _ => SParity parity -> Module ( Defs parity )+shader sParity = Module $ entryPoint @"main" @Vertex $ do+  val <- readInputFromParity sParity+  pure ( Lit () )++readInputFromParity :: _ => SParity parity -> Program _s _s ( Code Float )+readInputFromParity sParity = readInput+  where+    readInput+      :: _ => Program _s _s ( Code Float )+    readInput = case sParity of+      SEven -> get @"even"+      SOdd  -> get @"odd"
+ test/Tests/Interface/ComponentMismatch.golden view
@@ -0,0 +1,22 @@+test/Tests/Interface/ComponentMismatch.hs:56:5: error: [GHC-64725]+    • Interface mismatch at location 0.+      Output named "out" of Vertex shader named "main" has underlying type V 4+                                                                             Float,+      whereas input named "in1" of Fragment shader named "main" has underlying type V 3+                                                                                      Float.+    • In the first argument of ‘($)’, namely ‘ShaderPipeline’+      In the expression:+        ShaderPipeline+          $ StructInput @VertexInput @(Triangle List)+              :>-> (vertex, "vertex.spv")+              :>-> (fragment, "fragment.spv")+      In an equation for ‘shaderPipeline’:+          shaderPipeline+            = ShaderPipeline+                $ StructInput @VertexInput @(Triangle List)+                    :>-> (vertex, "vertex.spv")+                    :>-> (fragment, "fragment.spv")+   |+56 |   = ShaderPipeline +   |     ^^^^^^^^^^^^^^+
+ test/Tests/Interface/ComponentMismatch.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.Interface.ComponentMismatch where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- pipeline input++type VertexInput+  = '[ Slot 0 0 ':-> V 4 Float+     ]++------------------------------------------------+-- vertex shader++type VertexDefs =+  '[ "in"   ':-> Input      '[ Location 0 ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0 ] ( V 4 Float )+   , "main" ':-> EntryPoint '[            ] Vertex+   ]++vertex :: ShaderModule "main" VertexShader VertexDefs _+vertex = shader do+  put @"out" =<< get @"in"++------------------------------------------------+-- fragment shader++type FragmentDefs =+  '[ "in1"  ':-> Input      '[ Location 0              ] ( V 3 Float )+   , "in2"  ':-> Input      '[ Location 0, Component 3 ] Float+   , "out"  ':-> Output     '[ Location 0              ] ( V 4 Float )+   , "main" ':-> EntryPoint '[ OriginUpperLeft         ] Fragment+   ]++fragment :: ShaderModule "main" FragmentShader FragmentDefs _+fragment = shader do+    ~(Vec3 x y z) <- get @"in1"+    w <- get @"in2"+    put @"out" ( Vec4 x y z w )++------------------------------------------------+-- pipeline++shaderPipeline :: ShaderPipeline FilePath+shaderPipeline+  = ShaderPipeline +  $    StructInput @VertexInput @(Triangle List)+  :>-> (vertex  ,   "vertex.spv")+  :>-> (fragment, "fragment.spv")
+ test/Tests/Interface/ExtraOutput.golden view
@@ -0,0 +1,19 @@+test/Tests/Interface/ExtraOutput.hs:56:5: error: [GHC-64725]+    • Output "out2" of type V 4 Float of Vertex shader named "main",+      does not match any input of Fragment shader named "main".+    • In the first argument of ‘($)’, namely ‘ShaderPipeline’+      In the expression:+        ShaderPipeline+          $ StructInput @VertexInput @(Triangle List)+              :>-> (vertex, "vertex.spv")+              :>-> (fragment, "fragment.spv")+      In an equation for ‘shaderPipeline’:+          shaderPipeline+            = ShaderPipeline+                $ StructInput @VertexInput @(Triangle List)+                    :>-> (vertex, "vertex.spv")+                    :>-> (fragment, "fragment.spv")+   |+56 |   = ShaderPipeline+   |     ^^^^^^^^^^^^^^+
+ test/Tests/Interface/ExtraOutput.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.Interface.ExtraOutput where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- pipeline input++type VertexInput+  = '[ Slot 0 0 ':-> V 4 Float+     ]++------------------------------------------------+-- vertex shader++type VertexDefs =+  '[ "in"   ':-> Input      '[ Location 0 ] ( V 4 Float )+   , "out1" ':-> Output     '[ Location 0 ] ( V 4 Float )+   , "out2" ':-> Output     '[ Location 1 ] ( V 4 Float )+   , "main" ':-> EntryPoint '[            ] Vertex+   ]++vertex :: ShaderModule "main" VertexShader VertexDefs _+vertex = shader do+  vec <- get @"in"+  put @"out1" vec+  put @"out2" vec++------------------------------------------------+-- fragment shader++type FragmentDefs =+  '[ "in"   ':-> Input      '[ Location 0      ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0      ] ( V 4 Float )+   , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment+   ]++fragment :: ShaderModule "main" FragmentShader FragmentDefs _+fragment = shader do+    put @"out" =<< get @"in"++------------------------------------------------+-- pipeline++shaderPipeline :: ShaderPipeline FilePath+shaderPipeline+  = ShaderPipeline+  $    StructInput @VertexInput @(Triangle List)+  :>-> (vertex  ,   "vertex.spv")+  :>-> (fragment, "fragment.spv")
+ test/Tests/Interface/InvalidComponent.golden view
@@ -0,0 +1,34 @@+test/Tests/Interface/InvalidComponent.hs:35:10: error: [GHC-64725]+    • Cannot position scalar of type Double+       at Location 1, Component 1.+    • In the expression:+        shader+          do put @"out1" =<< get @"in1"+             put @"out2" =<< get @"in2"+      In an equation for ‘vertex’:+          vertex+            = shader+                do put @"out1" =<< get @"in1"+                   put @"out2" =<< get @"in2"+   |+35 | vertex = shader do+   |          ^^^^^^++test/Tests/Interface/InvalidComponent.hs:50:12: error: [GHC-64725]+    • Cannot position scalar of type Double+       at Location 1, Component 1.+    • In the expression:+        shader+          do ~(Vec4 x y z _) <- get @"in1"+             w <- get @"in2"+             put @"out" (Vec4 x y z (convert w))+      In an equation for ‘fragment’:+          fragment+            = shader+                do ~(Vec4 x y z _) <- get @"in1"+                   w <- get @"in2"+                   put @"out" (Vec4 x y z (convert w))+   |+50 | fragment = shader do+   |            ^^^^^^+
+ test/Tests/Interface/InvalidComponent.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.Interface.InvalidComponent where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- pipeline input++type VertexInput+  = '[ Slot 0 0 ':-> V 4 Float+     , Slot 1 0 ':-> Double+     ]++------------------------------------------------+-- vertex shader++type VertexDefs =+  '[ "in1"  ':-> Input      '[ Location 0              ] ( V 4 Float )+   , "in2"  ':-> Input      '[ Location 1              ] Double+   , "out1" ':-> Output     '[ Location 0              ] ( V 4 Float )+   , "out2" ':-> Output     '[ Location 1, Component 1 ] Double+   , "main" ':-> EntryPoint '[                         ] Vertex+   ]++vertex :: ShaderModule "main" VertexShader VertexDefs _+vertex = shader do+  put @"out1" =<< get @"in1"+  put @"out2" =<< get @"in2"++------------------------------------------------+-- fragment shader++type FragmentDefs =+  '[ "in1"  ':-> Input      '[ Location 0              ] ( V 4 Float )+   , "in2"  ':-> Input      '[ Location 1, Component 1 ] Double+   , "out"  ':-> Output     '[ Location 0              ] ( V 4 Float )+   , "main" ':-> EntryPoint '[ OriginUpperLeft         ] Fragment+   ]++fragment :: ShaderModule "main" FragmentShader FragmentDefs _+fragment = shader do+    ~(Vec4 x y z _) <- get @"in1"+    w <- get @"in2"+    put @"out" ( Vec4 x y z ( convert w ) )++------------------------------------------------+-- pipeline++shaderPipeline :: ShaderPipeline FilePath+shaderPipeline+  = ShaderPipeline+  $    StructInput @VertexInput @(Triangle List)+  :>-> (vertex  ,   "vertex.spv")+  :>-> (fragment, "fragment.spv")
+ test/Tests/Interface/MissingInput.golden view
@@ -0,0 +1,19 @@+test/Tests/Interface/MissingInput.hs:54:5: error: [GHC-64725]+    • Input "in2" of type V 4 Float of Fragment shader named "main",+      does not match any output of Vertex shader named "main".+    • In the first argument of ‘($)’, namely ‘ShaderPipeline’+      In the expression:+        ShaderPipeline+          $ StructInput @VertexInput @(Triangle List)+              :>-> (vertex, "vertex.spv")+              :>-> (fragment, "fragment.spv")+      In an equation for ‘shaderPipeline’:+          shaderPipeline+            = ShaderPipeline+                $ StructInput @VertexInput @(Triangle List)+                    :>-> (vertex, "vertex.spv")+                    :>-> (fragment, "fragment.spv")+   |+54 |   = ShaderPipeline+   |     ^^^^^^^^^^^^^^+
+ test/Tests/Interface/MissingInput.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.Interface.MissingInput where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- pipeline input++type VertexInput+  = '[ Slot 0 0 ':-> V 4 Float+     ]++------------------------------------------------+-- vertex shader++type VertexDefs =+  '[ "in"   ':-> Input      '[ Location 0 ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0 ] ( V 4 Float )+   , "main" ':-> EntryPoint '[            ] Vertex+   ]++vertex :: ShaderModule "main" VertexShader VertexDefs _+vertex = shader do+  put @"out" =<< get @"in"++------------------------------------------------+-- fragment shader++type FragmentDefs =+  '[ "in1"  ':-> Input      '[ Location 0      ] ( V 4 Float )+   , "in2"  ':-> Input      '[ Location 1      ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0      ] ( V 4 Float )+   , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment+   ]++fragment :: ShaderModule "main" FragmentShader FragmentDefs _+fragment = shader do+    put @"out" =<< get @"in1"++------------------------------------------------+-- pipeline++shaderPipeline :: ShaderPipeline FilePath+shaderPipeline+  = ShaderPipeline+  $    StructInput @VertexInput @(Triangle List)+  :>-> (vertex  ,   "vertex.spv")+  :>-> (fragment, "fragment.spv")
+ test/Tests/Layout/Copy.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Layout.Copy where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- copying a structure from a uniform buffer to a storage buffer,+-- which use different layouts++type S =+  Struct+    '[ "a" ':-> Array 3 Float+     , "b" ':-> V 3 Float+     , "c" ':-> Array 2 ( Struct '[ "x" ':-> Float, "y" ':-> V 2 Float ] )+     , "m" ':-> M 4 4 Float+     ]++type Defs =+  '[ "ubo"  ':-> Uniform '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "s" ':-> S ] )+   , "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ]+                   ( Struct '[ "s" ':-> S, "t" ':-> S ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do+  entryPoint @"main" @Compute do+    assign @( Name "out" :.: Name "s" ) =<< use @( Name "ubo" :.: Name "s" )+    assign @( Name "out" :.: Name "t" ) =<< use @( Name "out" :.: Name "s" )
+ test/Tests/Layout/DescriptorArray.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Layout.DescriptorArray where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- arrays of uniform buffers++type S = Struct '[ "m" ':-> M 4 4 Float, "v" ':-> V 3 Float, "xs" ':-> Array 3 Float ]++type Defs =+  '[ "ubos" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] ( Array 4 S )+   , "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ]+                   ( Struct '[ "f" ':-> Float, "s" ':-> S ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do+  entryPoint @"main" @Compute do+    i     <- use @( Name "gl_LocalInvocationIndex" )+    x     <- use @( Name "ubos" :.: AnIndex Word32 :.: Name "xs" :.: Index 1 ) i+    s     <- use @( Name "ubos" :.: Index 2 )+    whole <- get @"ubos"+    assign @( Name "out" :.: Name "f" ) ( x + view @( Index 3 :.: Name "xs" :.: Index 0 ) whole )+    assign @( Name "out" :.: Name "s" ) s
+ test/Tests/Layout/FunctionArgument.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Layout.FunctionArgument where++-- fir+import FIR++------------------------------------------------+-- passing a value loaded from a buffer to a function++type S = Struct '[ "a" ':-> Float, "b" ':-> Array 2 Float ]++type Defs =+  '[ "ubo"  ':-> Uniform '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "s" ':-> S ] )+   , "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ]+                   ( Struct '[ "res" ':-> Float ] )+   , "f"    ':-> Function '[ "s" ':-> Var R S ] Float+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do++  ( f :: Code S -> Code Float ) <- fundef @"f" do+    s <- get @"s"+    pure ( view @( Name "a" ) s + view @( Name "b" :.: Index 1 ) s )++  entryPoint @"main" @Compute do+    s <- use @( Name "ubo" :.: Name "s" )+    assign @( Name "out" :.: Name "res" ) ( f s )
+ test/Tests/Layout/LocalVariables.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Layout.LocalVariables where++-- fir+import FIR++------------------------------------------------+-- local variables holding values loaded from a buffer++type S = Struct '[ "i" ':-> Word32, "arr" ':-> Array 4 Float ]++type Defs =+  '[ "ubo"  ':-> Uniform '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "s" ':-> S ] )+   , "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ]+                   ( Struct '[ "res" ':-> Float, "s" ':-> S ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do+  entryPoint @"main" @Compute do+    s <- use @( Name "ubo" :.: Name "s" )+    let i = view @( Name "i" ) s+    -- run-time indexing into a loaded value+    assign @( Name "out" :.: Name "res" )+      ( view @( Name "arr" :.: AnIndex ( Code Word32 ) ) i s )+    -- mutable local copy of a loaded value+    _ <- def @"t" @RW s+    assign @( Name "t" :.: Name "arr" :.: AnIndex Word32 ) i 7+    assign @( Name "out" :.: Name "s" ) =<< get @"t"
+ test/Tests/Layout/Matrices.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Layout.Matrices where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- matrices whose columns are smaller than their alignment++type S =+  Struct+    '[ "m2"  ':-> M 2 2 Float+     , "m3"  ':-> M 3 3 Float+     , "m23" ':-> M 2 3 Float+     , "ms"  ':-> Array 2 ( M 3 3 Float )+     , "f"   ':-> Float+     ]++type Defs =+  '[ "ubo"  ':-> Uniform '[ DescriptorSet 0, Binding 0 ] ( Struct '[ "s" ':-> S ] )+   , "ssbo" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] ( Struct '[ "s" ':-> S ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do+  entryPoint @"main" @Compute do+    assign @( Name "ssbo" :.: Name "s" ) =<< use @( Name "ubo" :.: Name "s" )
+ test/Tests/Layout/NestedUniform.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Layout.Nested where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- layout of nested uniform buffer++type Nested =+  Struct+    '[ "a" ':-> V 4 Float+     , "b" ':-> Word32+     , "c" ':-> Struct+         '[ "c1" ':-> V 4 Float+          , "c2" ':-> V 4 Double+          ]+     , "d" ':-> V 2 Int32+     ]++type Defs =+  '[ "uniform" ':-> Uniform    '[ DescriptorSet 0, Binding 0 ] Nested+   , "out"     ':-> Output     '[ Location 0      ] ( V 4 Float )+   , "vert"    ':-> EntryPoint '[ ] Vertex+   ]++program :: Module Defs+program = Module do+  entryPoint @"vert" @Vertex do+    put @"out" =<< use @( Name "uniform" :.: Name "c" :.: Name "c1" )
+ test/Tests/Layout/Offsets.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Layout.Offsets where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- offsets of structures nested in arrays, and arrays of matrices++type Defs =+  '[ "ssbo" ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ]+                   ( Struct+                      '[ "a"  ':-> Float+                       , "xs" ':-> Array 2 ( Struct '[ "x" ':-> Float ] )+                       , "ms" ':-> Array 2 ( M 4 4 Float )+                       ]+                   )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do+  entryPoint @"main" @Compute do+    x <- use @( Name "ssbo" :.: Name "xs" :.: Index 1 :.: Name "x" )+    m <- use @( Name "ssbo" :.: Name "ms" :.: Index 0 )+    assign @( Name "ssbo" :.: Name "a" ) x+    assign @( Name "ssbo" :.: Name "ms" :.: Index 1 ) m
+ test/Tests/Layout/PerVertexBlocks.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Layout.PerVertexBlocks where++-- fir+import FIR++------------------------------------------------+-- loading and storing whole per-vertex built-in blocks++type Defs =+  '[ "main" ':-> EntryPoint '[ SpacingEqual, VertexOrderCw, OutputVertices 3 ] TessellationControl ]++program :: Module Defs+program = Module do+  entryPoint @"main" @TessellationControl do+    i     <- get @"gl_InvocationID"+    v     <- use @( Name "gl_in" :.: AnIndex Word32 ) i+    allIn <- get @"gl_in"+    assign @( Name "gl_out" :.: AnIndex Word32 ) i v+    assign @( Name "gl_out" :.: AnIndex Word32 :.: Name "gl_PointSize" ) i+      ( view @( Index 1 :.: Name "gl_PointSize" ) allIn )+    assign @( Name "gl_TessLevelOuter" :.: Index 0 ) 16
+ test/Tests/Layout/Products.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Layout.Products where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- product optics over members of buffers with different layouts++type AB = Struct '[ "a" ':-> Array 2 Float, "b" ':-> Array 3 ( V 2 Float ) ]++type Defs =+  '[ "ubo"  ':-> Uniform '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "a" ':-> Array 2 Float, "b" ':-> Array 3 ( V 2 Float ), "v" ':-> V 4 Float ] )+   , "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ]+                   ( Struct '[ "a" ':-> Array 2 Float, "b" ':-> Array 3 ( V 2 Float ), "f" ':-> Float ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do+  entryPoint @"main" @Compute do+    ab <- use @( Name "ubo" :.: Prod @_ @_ @_ @AB ( Name "a" :*: Name "b" :*: EndProd ) )+    assign @( Name "out" :.: Prod @_ @_ @_ @AB ( Name "a" :*: Name "b" :*: EndProd ) ) ab
+ test/Tests/Layout/PushConstant.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Layout.PushConstant where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- copying push constants to a storage buffer++type A = Array 2 ( Struct '[ "a" ':-> Float, "b" ':-> V 3 Float ] )++type Defs =+  '[ "pc"   ':-> PushConstant '[]+                   ( Struct '[ "m" ':-> M 4 4 Float, "arr" ':-> A ] )+   , "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ]+                   ( Struct '[ "arr" ':-> A, "m" ':-> M 4 4 Float ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do+  entryPoint @"main" @Compute do+    assign @( Name "out" :.: Name "arr" ) =<< use @( Name "pc" :.: Name "arr" )+    assign @( Name "out" :.: Name "m"   ) =<< use @( Name "pc" :.: Name "m"   )
+ test/Tests/Layout/RuntimeArray.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Layout.RuntimeArray where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- structures containing matrices, in a run-time array++type E = Struct '[ "p" ':-> V 3 Float, "m" ':-> M 4 3 Float, "a" ':-> Array 2 ( M 2 2 Float ) ]++type Defs =+  '[ "ssbo" ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "n" ':-> Word32, "arr" ':-> RuntimeArray E ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do+  entryPoint @"main" @Compute do+    i <- use @( Name "gl_LocalInvocationIndex" )+    e <- use @( Name "ssbo" :.: Name "arr" :.: AnIndex Word32 ) i+    let e' = set @( Name "p" ) ( Vec3 1 2 3 ) e+    assign @( Name "ssbo" :.: Name "arr" :.: AnIndex Word32 ) ( i + 1 ) ( if i > 3 then e else e' )
+ test/Tests/Layout/Selection.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Layout.Selection where++-- vector-sized+import qualified Data.Vector.Sized as Vector++-- fir+import FIR++------------------------------------------------+-- selecting between a value loaded from a buffer+-- and a value constructed in the shader++type S = Struct '[ "a" ':-> Float, "b" ':-> Array 2 Float ]++type Defs =+  '[ "ubo"  ':-> Uniform '[ DescriptorSet 0, Binding 0 ]+                   ( Struct '[ "s" ':-> S, "x" ':-> Float ] )+   , "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ]+                   ( Struct '[ "s" ':-> S ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do+  entryPoint @"main" @Compute do+    loaded <- use @( Name "ubo" :.: Name "s" )+    x      <- use @( Name "ubo" :.: Name "x" )+    let built = Struct ( x :& Lit ( MkArray ( Vector.replicate 3 ) ) :& End ) :: Code S+    assign @( Name "out" :.: Name "s" ) ( if x > 0 then loaded else built )
+ test/Tests/Layout/StructPadding.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Layout.StructPadding where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- members following a nested structure are placed after its padding++type T = Struct '[ "v" ':-> V 3 Float ]++type S =+  Struct+    '[ "s" ':-> T+     , "f" ':-> Float+     , "d" ':-> Struct '[ "x" ':-> V 4 Double, "y" ':-> Float ]+     , "g" ':-> Float+     ]++type Defs =+  '[ "ubo"  ':-> Uniform '[ DescriptorSet 0, Binding 0 ] ( Struct '[ "s" ':-> S ] )+   , "ssbo" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] ( Struct '[ "s" ':-> S ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do+  entryPoint @"main" @Compute do+    assign @( Name "ssbo" :.: Name "s" ) =<< use @( Name "ubo" :.: Name "s" )
+ test/Tests/Matrix/Applicative.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Matrix.Applicative where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs = '[ "mvp1"    ':-> Input      '[Location 1] (M 3 3 Float)+             , "mvp2"    ':-> Input      '[Location 5] (M 3 3 Float)+             , "in_pos"  ':-> Input      '[Location 0] (V 3 Float)+             , "out_pos" ':-> Output     '[Location 0] (V 3 Float)+             , "main"    ':-> EntryPoint '[] Vertex+             ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Vertex do++    mvp1   <- get @"mvp1"+    mvp2   <- get @"mvp2"+    in_pos <- get @"in_pos"++    let adjustment :: Code Float -> Code Float -> Code Float+        adjustment x y = 0.5 * abs (x - y)+        adjusted_mvp :: Code (M 3 3 Float)+        adjusted_mvp = adjustment <$$> mvp1 <**> mvp2+    ++    put @"out_pos" (adjusted_mvp !*^ in_pos)
+ test/Tests/Module/DiffStageDiffName.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.Module.DiffStageDiffName where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- combined vertex and fragment shaders++type Defs =+  '[ "in"   ':-> Input      '[ Location 0      ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0      ] ( V 4 Float )+   , "vert" ':-> EntryPoint '[                 ] Vertex+   , "frag" ':-> EntryPoint '[ OriginUpperLeft ] Fragment+   ]++program :: Module Defs+program = Module do+  entryPoint @"vert" @Vertex   do+    put @"out" =<< get @"in"+  entryPoint @"frag" @Fragment do+    put @"out" =<< get @"in"
+ test/Tests/Module/DiffStageSameName.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.Module.DiffStageSameName where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- combined vertex and fragment shaders++type Defs =+  '[ "in"   ':-> Input      '[ Location 0      ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0      ] ( V 4 Float )+   , "main" ':-> EntryPoint '[                 ] Vertex+   , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment+   ]++program :: Module Defs+program = Module do+  entryPoint @"main" @Vertex   do+    put @"out" =<< get @"in"+  entryPoint @"main" @Fragment do+    put @"out" =<< get @"in"
+ test/Tests/Module/SameStageDiffName.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.Module.SameStageDiffName where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- combined vertex shaders (with different names)++type Defs =+  '[ "in"    ':-> Input      '[ Location 0 ] ( V 4 Float )+   , "out"   ':-> Output     '[ Location 0 ] ( V 4 Float )+   , "vert1" ':-> EntryPoint '[            ] Vertex+   , "vert2" ':-> EntryPoint '[            ] Vertex+   ]++program :: Module Defs+program = Module do+  entryPoint @"vert1" @Vertex do+    put @"out" =<< get @"in"+  entryPoint @"vert2" @Vertex do+    put @"out" =<< get @"in"
+ test/Tests/Module/SameStageSameName.golden view
@@ -0,0 +1,16 @@+test/Tests/Module/SameStageSameName.hs:27:3: error: [GHC-64725]+    • 'entryPoint': duplicate entry point declaration.+      There already exists a Vertex shader named "main".+    • In a stmt of a 'do' block:+        entryPoint @"main" @Vertex do put @"out" =<< get @"in"+      In the first argument of ‘Module’, namely+        ‘do entryPoint @"main" @Vertex do put @"out" =<< get @"in"+            entryPoint @"main" @Vertex do put @"out" =<< get @"in"’+      In the expression:+        Module+          do entryPoint @"main" @Vertex do put @"out" =<< get @"in"+             entryPoint @"main" @Vertex do put @"out" =<< get @"in"+   |+27 |   entryPoint @"main" @Vertex do+   |   ^^^^^^^^^^+
+ test/Tests/Module/SameStageSameName.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.Module.SameStageSameName where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- duplicate entrypoints (not allowed)++type Defs =+  '[ "in"   ':-> Input      '[ Location 0 ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0 ] ( V 4 Float )+   , "main" ':-> EntryPoint '[            ] Vertex+   , "main" ':-> EntryPoint '[            ] Vertex+   ]++program :: Module Defs+program = Module do+  entryPoint @"main" @Vertex do+    put @"out" =<< get @"in"+  entryPoint @"main" @Vertex do+    put @"out" =<< get @"in"
+ test/Tests/OpenCL/Kernel.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE NoStarIsType        #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.OpenCL.Kernel where++-- base+import GHC.TypeNats+  ( Nat, type (*), type (-) )++-- fir+import FIR++------------------------------------------------+-- program++type N = ( 128 :: Nat )+n :: Code Int32+n = Lit $ fromIntegral ( knownValue @N )++type Defs = '[ "arr"  ':-> CrossWorkgroup '[] ( Array (N * N) Float )+             , "main" ':-> EntryPoint '[ LocalSize (2 * N - 1) 1 1 ] Kernel+             ]++program :: Module Defs+program = Module $ entryPoint @"main" @Kernel do+  +  -- 0 ≤ diag < 2 * n - 1+  ( diag :: Code Int32 )+    <- convert <<$>> get @"cl_GlobalLinearID"++  _ <- def @"entry" @RW @Int32 0+  let+    diagSize :: Code Int32+    diagSize = n - abs ( n - diag - 1 )+  while ( get @"entry" < pure diagSize ) do+    entry <- get @"entry"++    let+      row, col :: Code Int32+      row = min ( n - 1 )   diag           - entry+      col = max   0       ( diag - n + 1 ) + entry++    _ <- def @"left" @RW @Float 1+    when ( col > 0 ) do+      put @"left" =<< ( use @(Name "arr" :.: AnIndex Int32) ( n *   row      + ( col - 1 ) ) )+    +    _ <- def @"up" @RW @Float 1+    when ( row > 0 ) do+      put @"up"   =<< ( use @(Name "arr" :.: AnIndex Int32) ( n * ( row - 1 ) +  col       ) )++    left <- get @"left"+    up   <- get @"up"+    assign @(Name "arr" :.: AnIndex Int32) ( n * row + col ) ( left + up )++    modify @"entry" (+1)++  pure (Lit ())
+ test/Tests/Optics/ASTIndices.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Optics.ASTIndices where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs =+  '[ "nested" ':-> Uniform '[ Binding 0, DescriptorSet 0 ]+        ( Array 4 ( Struct '[ "r" ':-> Float, "ijk" ':-> V 3 Float ] ) )+   , "out1"    ':-> Output '[Location 0] ( V 4 Float )+   , "out2"    ':-> Output '[Location 1] ( M 3 2 Float )+   , "main"   ':-> EntryPoint '[] Vertex+   ]++type TwoFloats+  = Struct+  '[ "1" ':-> Float+   , "2" ':-> Float+   ]++program :: Module Defs+program = Module $ entryPoint @"main" @Vertex do++  r <- use @(Name "nested" :.: AnIndex Word32 :.: Name "r") 3++  twoFloats+    <- use @(   Name "nested"+            :.: Prod @_ @_ @_ @TwoFloats+                 (   ( AnIndex Word32 :.: Name "ijk" :.: AnIndex Word32 )+                 :*: ( AnIndex Word32 :.: Name "ijk" :.: AnIndex Word32 )+                 :*: EndProd+                 )+            )+            ( ConsHList :$ 1 :$ ( ConsHList :$ 2 :$ NilHList ) )+            ( ConsHList :$ 4 :$ ( ConsHList :$ 3 :$ NilHList ) )+  let f = view @(Index 1) twoFloats++  assign @(Name "out1" :.: AnIndex Word32) 0 (r + f)++  let+    mat :: Code (M 3 4 Float)+    mat = Mat34+      0 1  2  3+      4 5  6  7+      8 9 10 11++    mat' :: Code (M 3 2 Float)+    mat' = view @( Prod ( Col 1 :*: Col 3 :*: EndProd ) ) mat++  assign @(Name "out2") mat'++  assign @(Name "out2" :.: Rows) (Vec2 1 3)
+ test/Tests/Optics/ASTProducts.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Optics.ASTProducts where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs =+  '[ "ubo"  ':-> Uniform    '[Binding 0, DescriptorSet 0] ( Struct '[ "mvp" ':-> M 4 4 Float ] )+   , "out"  ':-> Output     '[Location 0] ( M 4 4 Float )+   , "main" ':-> EntryPoint '[] Vertex+   ]++program :: Module Defs+program = Module $ entryPoint @"main" @Vertex do++  row <- use @(Name "ubo" :.: Name "mvp" :.: Row 0)+  col <- use @(Name "ubo" :.: Name "mvp" :.: Col 2)+  dia <- use @(Name "ubo" :.: Name "mvp" :.: Diag)+  ( mid :: Code (M 2 2 Float) )+    <- use @(Name "ubo" :.: Name "mvp" :.: Prod (Entry 1 1 :*: Entry 1 2 :*: Entry 2 1 :*: Entry 2 2 :*: EndProd))+  ( flatMid :: Code (V 4 Float) )+    <- use @(Name "ubo" :.: Name "mvp" :.: Prod (Entry 1 1 :*: Entry 1 2 :*: Entry 2 1 :*: Entry 2 2 :*: EndProd))++  assign @(Name "out") identity+  assign @(Name "out" :.: Diag) dia+  assign @(Name "out" :.: Prod (Entry 1 1 :*: Entry 1 2 :*: Entry 2 1 :*: Entry 2 2 :*: EndProd)) mid+  assign @(Name "out" :.: Col 3) col+  assign @(Name "out" :.: Row 2) row+  assign @(Name "out" :.: Row 1) flatMid
+ test/Tests/Optics/MVP1.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Optics.MVP1 where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs = '[ "ubo"     ':-> Uniform '[ Binding 0, DescriptorSet 0 ]+                                ( Struct '[ "mvp" ':-> M 4 4 Float ] )+             , "in_pos"  ':-> Input  '[ Location 0 ] (V 4 Float) +             , "out_pos" ':-> Output '[ Location 0 ] (V 4 Float) +             , "main"    ':-> EntryPoint '[] Vertex+             ]++program :: Module Defs+program =+  Module $ entryPoint @"main" @Vertex do+    mvp    <- use @(Name "ubo" :.: Name "mvp")+    in_pos <- get @"in_pos"+    put @"out_pos" (mvp !*^ in_pos)
+ test/Tests/Optics/MVP2.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Optics.MVP2 where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs = '[ "ubo"     ':-> Uniform '[ Binding 0, DescriptorSet 0 ]+                                ( Struct '[ "mvp" ':-> M 4 4 Float ] )+             , "in_pos"  ':-> Input  '[ Location 0 ] (V 4 Float) +             , "out_pos" ':-> Output '[ Location 0 ] (V 4 Float) +             , "main"    ':-> EntryPoint '[] Vertex+             ]++program :: Module Defs+program =+  Module $ entryPoint @"main" @Vertex do+    ubo    <- use @(Name "ubo")+    let mvp = view @(Name "mvp") ubo+    in_pos <- get @"in_pos"+    let out_pos = set @(Index 3) 1 $ mvp !*^ in_pos+    put @"out_pos" out_pos
+ test/Tests/Optics/NestedOfType.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE BlockArguments   #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE PolyKinds        #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators    #-}++module Tests.Optics.NestedOfType where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- setting all components of a given type, nested inside arrays and structures++type S =+  Struct+    '[ "a" ':-> Array 2 Float+     , "b" ':-> Array 3 ( V 2 Float )+     , "c" ':-> Struct '[ "x" ':-> Word32, "y" ':-> Array 2 ( Struct '[ "z" ':-> Float ] ) ]+     , "m" ':-> M 2 2 Float+     ]++type Defs =+  '[ "out"  ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ] ( Struct '[ "s" ':-> S, "v" ':-> V 2 Float ] )+   , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute+   ]++program :: Module Defs+program = Module do+  entryPoint @"main" @Compute do+    assign @( Name "out" :.: OfType Float ) 5+    assign @( Name "out" :.: Name "s" :.: Name "b" :.: OfType Float ) 3+    assign @( Name "out" :.: OfType ( V 2 Float ) :.: Index 1 ) ( 7 :: Code Float )
+ test/Tests/Optics/NoMatrixIndex.golden view
@@ -0,0 +1,18 @@+test/Tests/Optics/NoMatrixIndex.hs:31:10: error: [GHC-64725]+    • Matrix column index 4 is out of bounds.+      This matrix has 3 rows, 4 columns.+      Note: indexing starts from 0.+    • In a stmt of a 'do' block:+        c <- use @(Name "vertexData" :.: Entry 1 4)+      In the third argument of ‘entryPoint’, namely+        ‘do c <- use @(Name "vertexData" :.: Entry 1 4)+            put @"gl_Position" (Vec4 c c c 1)’+      In a stmt of a 'do' block:+        entryPoint+          @"main" @Vertex+          do c <- use @(Name "vertexData" :.: Entry 1 4)+             put @"gl_Position" (Vec4 c c c 1)+   |+31 |     c <- use @( Name "vertexData" :.: Entry 1 4 )+   |          ^^^+
+ test/Tests/Optics/NoMatrixIndex.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Optics.NoMatrixIndex where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs+  = '[ "vertexData" ':-> Input '[ Location 0 ] ( M 3 4 Float )+     , "main"       ':-> EntryPoint '[] Vertex+     ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Vertex do++    c <- use @( Name "vertexData" :.: Entry 1 4 )++    put @"gl_Position" (Vec4 c c c 1)
+ test/Tests/Optics/NoStructField.golden view
@@ -0,0 +1,19 @@+test/Tests/Optics/NoStructField.hs:37:17: error: [GHC-64725]+    • Structure has no field with name "inexistent".+      This structure has the following fields:+      ["position" ':-> V 3 Float, "colour" ':-> V 4 Float,+       "size" ':-> Float, "weight" ':-> Float]+    • In a stmt of a 'do' block:+        position <- use @(Name "vertexData" :.: Name "inexistent")+      In the third argument of ‘entryPoint’, namely+        ‘do position <- use @(Name "vertexData" :.: Name "inexistent")+            put @"gl_Position" position’+      In a stmt of a 'do' block:+        entryPoint+          @"main" @Vertex+          do position <- use @(Name "vertexData" :.: Name "inexistent")+             put @"gl_Position" position+   |+37 |     position <- use @( Name "vertexData" :.: Name "inexistent" )+   |                 ^^^+
+ test/Tests/Optics/NoStructField.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Optics.NoStructField where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs+  = '[ "vertexData" ':-> Uniform '[ Binding 0, DescriptorSet 0 ]+          ( Struct [ "position" ':-> V 3 Float+                   , "colour"   ':-> V 4 Float+                   , "size"     ':-> Float+                   , "weight"   ':-> Float+                   ]+          )+     , "main" ':-> EntryPoint '[] Vertex+     ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Vertex do++    position <- use @( Name "vertexData" :.: Name "inexistent" )++    put @"gl_Position" position
+ test/Tests/Optics/NoStructIndex.golden view
@@ -0,0 +1,20 @@+test/Tests/Optics/NoStructIndex.hs:42:17: error: [GHC-64725]+    • Index 5 out of bounds when accessing structure with fields+      ["position" ':-> V 3 Float, "colour" ':-> V 4 Float,+       "size" ':-> Float, "weight" ':-> Float]+      Structure has only 4 fields.+      Note: indexing starts from 0.+    • In a stmt of a 'do' block:+        position <- use @(Name "vertexData" :.: Index 5)+      In the third argument of ‘entryPoint’, namely+        ‘do position <- use @(Name "vertexData" :.: Index 5)+            #gl_Position .= position’+      In a stmt of a 'do' block:+        entryPoint+          @"main" @Vertex+          do position <- use @(Name "vertexData" :.: Index 5)+             #gl_Position .= position+   |+42 |     position <- use @( Name "vertexData" :.: Index 5 )+   |                 ^^^+
+ test/Tests/Optics/NoStructIndex.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Optics.NoStructIndex where++-- vector+import qualified Data.Vector as Array++-- fir+import FIR+import FIR.Syntax.Labels+import Math.Linear++------------------------------------------------+-- program++type Defs+  = '[ "vertexData"':-> Uniform '[ Binding 0, DescriptorSet 0 ]+          ( Struct [ "position" ':-> V 3 Float+                   , "colour"   ':-> V 4 Float+                   , "size"     ':-> Float+                   , "weight"   ':-> Float+                   ]+         )+     , "main" ':-> EntryPoint '[] Vertex+     ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Vertex do++    position <- use @( Name "vertexData" :.: Index 5 )++    #gl_Position .= position
+ test/Tests/Optics/NoVectorIndex.golden view
@@ -0,0 +1,18 @@+test/Tests/Optics/NoVectorIndex.hs:36:17: error: [GHC-64725]+    • Vector index 4 is out of bounds.+      Vector dimension is 4.+      Note: indexing starts from 0.+    • In a stmt of a 'do' block:+        position <- use @(Name "vertexData" :.: Index 4)+      In the third argument of ‘entryPoint’, namely+        ‘do position <- use @(Name "vertexData" :.: Index 4)+            #gl_Position .= position’+      In a stmt of a 'do' block:+        entryPoint+          @"main" @Vertex+          do position <- use @(Name "vertexData" :.: Index 4)+             #gl_Position .= position+   |+36 |     position <- use @( Name "vertexData" :.: Index 4 )+   |                 ^^^+
+ test/Tests/Optics/NoVectorIndex.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Optics.NoVectorIndex where++-- vector+import qualified Data.Vector as Array++-- fir+import FIR+import FIR.Syntax.Labels+import Math.Linear++------------------------------------------------+-- program++type Defs+  = '[ "vertexData" ':-> Input '[Location 0] ( V 4 Float )+     , "main"       ':-> EntryPoint '[] Vertex+     ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Vertex do++    position <- use @( Name "vertexData" :.: Index 4 )++    #gl_Position .= position
+ test/Tests/Optics/Overlapping.golden view
@@ -0,0 +1,36 @@+test/Tests/Optics/Overlapping.hs:33:5: error: [GHC-64725]+    • Cannot create product setter at type:+        Struct ["field_0" ':-> Float, "field_1" ':-> Bool]+      Overlap between optics+        - Name "field_0",+        - Index 0,+                 at index 0.+    • In a stmt of a 'do' block:+        assign+          @(Name "struct"+            :.:+            (Prod (Name "field_0"+                   :*: Index 0 :*: EndProd) :: Optic '[] MyStruct OtherStruct))+          (Lit (4 :& 5 :& End))+      In the third argument of ‘entryPoint’, namely+        ‘do def @"struct" @RW @MyStruct (Lit (3 :& True :& End))+            assign+              @(Name "struct"+                :.:+                (Prod (Name "field_0"+                       :*: Index 0 :*: EndProd) :: Optic '[] MyStruct OtherStruct))+              (Lit (4 :& 5 :& End))’+      In a stmt of a 'do' block:+        entryPoint+          @"main" @Vertex+          do def @"struct" @RW @MyStruct (Lit (3 :& True :& End))+             assign+               @(Name "struct"+                 :.:+                 (Prod (Name "field_0"+                        :*: Index 0 :*: EndProd) :: Optic '[] MyStruct OtherStruct))+               (Lit (4 :& 5 :& End))+   |+33 |     assign+   |     ^^^^^^+
+ test/Tests/Optics/Overlapping.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Optics.Overlapping where++-- fir+import FIR+import FIR.Syntax.Labels+import Math.Linear++------------------------------------------------+-- program++type MyStruct = Struct '[ "field_0" ':-> Float, "field_1" ':-> Bool ]+type OtherStruct = Struct '[ "x" ':-> Float, "y" ':-> Float ]++program :: Module '[ "main" ':-> EntryPoint '[] Vertex ]+program = Module do++  entryPoint @"main" @Vertex do++    def @"struct" @RW @MyStruct+      ( Lit ( 3 :& True :& End ) )++    assign+      @(    Name "struct"+        :.: ( Prod (Name "field_0" :*: Index 0 :*: EndProd)+               :: Optic '[]+                    MyStruct+                    OtherStruct+            )+       )+      ( Lit ( 4 :& 5 :& End ) )
+ test/Tests/Optics/ProductIndices.golden view
@@ -0,0 +1,1 @@+No type-checking errors.
+ test/Tests/Optics/ProductIndices.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Optics.ProductIndices where++-- prelude+import qualified Prelude+  ( Functor(fmap) )+import Data.Maybe+  ( fromJust )++-- vector-sized+import qualified Data.Vector.Sized as Vector++-- fir+import FIR+import Math.Linear++-- fir+import FIR++------------------------------------------------+-- testing product runtime indices++arr1 :: Array 12 Float+arr1 = MkArray ( fromJust $ Vector.fromList [10..21] )++test1 :: (Float, Float, Float)+test1 = view @( Prod (AnIndex Word32 :*: AnIndex Word32 :*: AnIndex Word32 :*: EndProd) )+          ( 2 :> 7 :> 3 :> HNil )+          arr1++-- > test1+-- (12.0,17.0,13.0)++test2 :: HList '[ Float, Float, Float ]+test2 = view @( Prod (AnIndex Word32 :*: AnIndex Word32 :*: AnIndex Word32 :*: EndProd) )+          ( 2 :> 7 :> 3 :> HNil )+          arr1++-- > test2+-- 12.0 :> 17.0 :> 13.0 :> HNil+++arr2 :: Array 2 ( Array 12 Float )+arr2 = MkArray ( fromJust $ Vector.fromList [ Prelude.fmap (+10) arr1, arr1 ] )++test3 :: ( Float, Float )+test3 = view @( AnIndex Word32 :.: ( Prod (AnIndex Word32 :*: AnIndex Word32 :*: EndProd) ) )+          0+          ( 11 :> 0 :> HNil )+          arr2++-- > test3+-- (31.0,20.0)++-- doesn't work+--test4 :: ( Float, Float )+--test4 = view @( ( Prod (AnIndex Word32 :*: AnIndex Word32 :*: EndProd) ) :.: AnIndex Word32 )+--          ( 1 :> 0 :> HNil )+--          7+--          arr2
+ test/Tests/Optics/PureProducts.golden view
@@ -0,0 +1,1 @@+No type-checking errors.
+ test/Tests/Optics/PureProducts.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Optics.PureProducts where++-- base+import qualified Prelude++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- testing product getters++-- structs++struct1 :: Struct '[ "x" ':-> Float, "y" ':-> Float, "z" ':-> Float ]+struct1 = 11.1 :& 7 :& 3.0 :& End++struct2 :: Struct '[ "x" ':-> Float, "z" ':-> Float ]+struct2 = view @(Prod (Name "x" :*: Name "z" :*: EndProd)) struct1++struct3 :: Struct '[ "x" ':-> Float, "z" ':-> Float, "x" ':-> Float ]+struct3 = view @(Prod (Name "x" :*: Name "z" :*: Name "x" :*: EndProd)) struct1++nested1+  :: Struct+      '[ "a" ':-> Float+       , "b" ':-> Struct+           '[ "r" ':-> V 3 Float+            , "s" ':-> M 4 4 Double+            , "t" ':-> Struct+                '[ "u" ':-> Double+                 , "v" ':-> Double+                 ]+            ]+       ]+nested1 = 17.3 :& ( Prelude.pure 7.77 :& diag 4.1 :& ( 3 :& 4 :& End ) :& End ) :& End++nested2 :: Struct '[ "a" ':-> Float, "r" ':-> V 3 Float ]+nested2 = view @(Prod ( Name "a" :*: (Name "b" :.: Index 0) :*: EndProd)) nested1++nested3 :: Struct '[ "r" ':-> V 3 Float+                   , "s" ':-> M 4 4 Double+                   ]+nested3 = view @(Name "b" :.: (Prod (Name "r" :*: Name "s" :*: EndProd))) nested1+++type RS+  = Struct+    '[ "r" ':-> V 3 Float+     , "s" ':-> M 4 4 Double+     ]++nested4 :: Struct '[ "a" ':-> Float+                   , "b" ':-> Struct '[ "r" ':-> V 3 Float+                                      , "s" ':-> M 4 4 Double+                                      ]+                   ]+nested4 = view @( Prod+                    (   Index 0+                    :*: ( Name "b" :.: (Prod @_ @_ @_ @RS (Name "r" :*: Name "s" :*: EndProd)) )+                    :*: EndProd+                    )+                )+           nested1+++-- vectors++v1 :: V 3 Double+v1 = 0 :. 11 :. 77 :. VNil++v2 :: V 2 Double+v2 = view @(Prod (Index 2 :*: Index 0 :*: EndProd)) v1++-- matrices++m1 :: M 4 4 Float+m1 = identity++m2 :: M 4 2 Float+m2 = view @(Prod (Col 2 :*: Col 1 :*: EndProd)) m1++m3 :: M 4 2 Float+m3 = view @(Prod (Col 2 :*: Col 3 :*: EndProd)) m1++m4 :: M 2 2 Float+m4 = view @(Prod (Entry 1 1 :*: Entry 1 2 :*: Entry 2 1 :*: Entry 2 2 :*: EndProd)) m1++m5 :: V 3 Float+m5 = view @(Prod (Entry 1 1 :*: Entry 3 3 :*: Entry 2 0 :*: EndProd)) m1++------------------------------------------------+-- testing product setters++struct4 :: Struct '[ "x" ':-> Float, "y" ':-> Float, "z" ':-> Float ]+struct4 =+  let part :: Struct '[ "y" ':-> Float, "z" ':-> Float ]+      part = 8.8 :& 11.0 :& End+  in set @( Prod ( (Name "y" :*: Name "z" :*: EndProd) ) )+        part+        struct1++struct5 :: Struct '[ "x" ':-> Float, "y" ':-> Float, "z" ':-> Float ]+struct5 =+  let part :: Struct '[ "field1" ':-> Float, "field2" ':-> Float ]+      part = 8.8 :& 11.0 :& End+  in set @( Prod ( (Name "y" :*: Name "x" :*: EndProd) ) )+        part+        struct1++nested5+  :: Struct+      '[ "a" ':-> Float+       , "b" ':-> Struct+           '[ "r" ':-> V 3 Float+            , "s" ':-> M 4 4 Double+            , "t" ':-> Struct+                '[ "u" ':-> Double+                 , "v" ':-> Double+                 ]+            ]+       ]+nested5 =+  let part :: Struct '[ "a" ':-> Float, "s" ':-> M 4 4 Double ]+      part = 0 :& identity :& End+  in set @( Prod ( Index 0 :*: (Name "b" :.: Name "s") :*: EndProd ))+       part+       nested1++m6 :: M 3 3 Float+m6 = M ( V3+          (V3 0 1 2)+          (V3 3 4 5)+          (V3 6 7 8)+       )++m7 :: M 3 3 Float+m7 = set @( Prod @_ @_ @_ @(V 3 Float) ( Entry 0 0 :*: Entry 0 2 :*: Entry 2 2 :*: EndProd ) :.: OfType Float ) 9 m6++m8 :: M 3 3 Float+m8 = set @Center 9 m6++m9 :: M 3 3 Float+m9 = set @( Prod ( Entry 0 0 :*: Entry 2 0 :*: Entry 0 2 :*: Entry 2 2 :*: EndProd ) ) m4 m6
+ test/Tests/Optics/UnarySwizzle.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PartialTypeSignatures #-}++module UnarySwizzle where++import FIR+import Math.Linear++type ComputeDefs =+  '[ "positions" ':-> StorageBuffer [DescriptorSet 1, Binding 0      ]+                      (Struct '["posArray" ':-> RuntimeArray (Struct '[ "pos" ':-> V 2 Float ])])+   , "main"      ':-> EntryPoint   '[LocalSize 256 1 1] Compute+   ]++program :: Module ComputeDefs+program = Module $ entryPoint @"main" @Compute do+  positions <- use @(Name "positions" :.: Name "posArray" :.: AnIndex Word32) 0+  pos' <- let' $ over @(Name "pos" :.: O) (+ 0.01) positions+  assign @(Name "positions" :.: Name "posArray" :.: AnIndex Word32) 0 positions++type O =+  ( Prod ( ( Index 0 :: Optic '[] (Code (V 2 Float)) (Code Float) ) :*: EndProd )+      :: Optic '[] (Code (V 2 Float)) (Code Float) )
+ test/Tests/Optics/Various.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Optics.Various where++-- base+import Data.Maybe+  ( fromJust )++-- vector-sized+import qualified Data.Vector.Sized as Vector++-- fir+import FIR+import FIR.Syntax.Labels+import Math.Linear++------------------------------------------------+-- program++type Defs+  = '[ "ubo" ':-> Uniform '[ Binding 0, DescriptorSet 0 ]+          ( Struct+            [ "modelMatrix"      ':-> M 4 4 Float+            , "viewMatrix"       ':-> M 4 4 Float+            , "projectionMatrix" ':-> M 4 4 Float+            ]+          )+     , "vertexData" ':->+          Uniform '[ Binding 1, DescriptorSet 0 ]+            ( Struct+              [ "position" ':-> V 3 Float+              , "colour"   ':-> V 4 Float+              , "size"     ':-> Float+              , "weight"   ':-> Float+              ]+            )+     , "arr1" ':->+          Uniform '[ Binding 2, DescriptorSet 0 ]+            ( Array 12+                  ( Struct+                      [ "label1" ':-> V 3 Float+                      , "label2" ':-> Array 3 Float+                      ]+                  )+            )+     , "arr2" ':->+          StorageBuffer '[ Binding 3, DescriptorSet 0 ]+            ( Struct+              [ "x1" ':-> V 4 Float+              , "x2" ':-> Float+              , "rt" ':-> RuntimeArray Float+              ]+            )+     , "main" ':-> EntryPoint '[] Vertex+     , "out_col" ':-> Output '[Location 0] ( V 4 Float )+     ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Vertex do++    modelMatrix       <- use @(Name "ubo" :.: Name "modelMatrix"      )+    viewMatrix        <- use @(Name "ubo" :.: Name "viewMatrix"       )+    projectionMatrix  <- use @(Name "ubo" :.: Name "projectionMatrix" )+    let mvp = modelMatrix !*! viewMatrix !*! projectionMatrix++    vertexData <- use @( Name "vertexData" )+    let vertexDataColour = view @(Name "colour") vertexData+    row <- use @( Name "ubo" :.: Name "modelMatrix" :.: Row 2 )+    diagonal <- use @(Name "ubo" :.: Name "modelMatrix" :.: Diag )+    lensTest <- use @(Name "arr1" :.: AnIndex Word32 :.: Index 0 :.: Index 2) 7+    rtTest1 <- use @(Name "arr2" :.: Name "rt" :.: AnIndex Word32) 6+    rtTest2 <- use @(Name "arr2" :.: Name "rt" :.: Index 6)++    #array @(Array 10 Float) #= (Lit $ MkArray (fromJust $ Vector.fromList [1,17,23,4,5,90,88,17,22,21]))+    #gl_Position .=  (rtTest1 * rtTest2 + abs lensTest) *^ ( mvp !*^ diagonal )+    #out_col .= vertexDataColour ^+^ row
+ test/Tests/PrimOps/Rounding.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE NamedWildCards      #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.PrimOps.Rounding where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs = '[ "x"    ':-> Input  '[Location 0] Float+             , "y"    ':-> Input  '[Location 1] Int32+             , "z"    ':-> Input  '[Location 2] Float+             , "out"  ':-> Output '[Location 0] (V 4 Float)+             , "main" ':-> EntryPoint '[] Vertex+             ]++program :: Module Defs+program = Module $ entryPoint @"main" @Vertex do++  x <- get @"x"+  let x' = x - floor x+  z <- get @"z"+  z1 :: Code Int32 <- round ( get @"z" )+  let z2 :: Code Int32+      z2 = truncate z+  y' <- convert $ get @"y" + pure z1 - pure z2+  let w = ceiling x + z++  put @"out" (Vec4 x' y' z w)
+ test/Tests/ProgramState/Shadowing.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE NamedWildCards        #-}+{-# LANGUAGE OverloadedLabels      #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.ProgramState.Shadowing where++-- fir+import FIR++------------------------------------------------+-- program++type Defs = '[ "out"  ':-> Output     '[Location 0] Float+             , "main" ':-> EntryPoint '[OriginUpperLeft] Fragment+             ]++program :: Module Defs+program = Module $ entryPoint @"main" @Fragment do++  t <- def @"t" @R @Float 5.5++  inner++  s  <- def @"s" @R @Float 7.7+  t' <- get @"t"++  put @"out" (t + s + t')+++inner :: Program i i (Code Word32)+inner = purely do+  def @"t" @R @Word32 3+  def @"s" @R @Word32 4
+ test/Tests/Small/HalfArithmetic.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Small.HalfArithmetic where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs+  =  '[ "in_col"  ':-> Input      '[ Location 0      ] (V 4 Float)+      , "out_col" ':-> Output     '[ Location 0      ] (V 4 Float)+      , "main"    ':-> EntryPoint '[ OriginUpperLeft ] Fragment+      ]++program :: Module Defs+program =+  Module $ entryPoint @"main" @Fragment do+    def @"h" @R @Half (5 * pi / 4)+    h <- get @"h"+    if abs (cos h) > sqrt 2+    then put @"out_col" =<< get @"in_col"+    else put @"out_col" (Vec4 0 0 0 1)
+ test/Tests/Small/HalfInputOutput.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Small.HalfInputOutput where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs+  =  '[ "in_col"  ':-> Input      '[ Location 0 ] (V 4 Half)+      , "out_col" ':-> Output     '[ Location 0 ] (V 4 Half)+      , "main"    ':-> EntryPoint '[ ]            Vertex+      ]++program :: Module Defs+program =+  Module $ entryPoint @"main" @Vertex do+    put @"out_col" =<< get @"in_col"
+ test/Tests/Small/IntArithmetic.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Small.IntArithmetic where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs+  =  '[ "in_col"  ':-> Input      '[ Location 0      ] (V 4 Float)+      , "out_col" ':-> Output     '[ Location 0      ] (V 4 Float)+      , "main"    ':-> EntryPoint '[ OriginUpperLeft ] Fragment+      ]++program :: Module Defs+program =+  Module $ entryPoint @"main" @Fragment do+    _ <- def @"i" @R @Int16 ( - 5 * 4  )+    _ <- def @"j" @R @Word8 (   7 + 11 )+    i <- get @"i"+    j <- get @"j"+    if 3 * abs i + convert j > 0+    then put @"out_col" =<< get @"in_col"+    else put @"out_col" (Vec4 0 0 0 1)
+ test/Tests/Small/IntInputOutput.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Small.IntInputOutput where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs+  =  '[ "in_a"  ':-> Input      '[ Location 0 ] (V 4 Int8  )+      , "in_b"  ':-> Input      '[ Location 1 ] (V 4 Word8 )+      , "in_c"  ':-> Input      '[ Location 2 ] (V 4 Int16 )+      , "in_d"  ':-> Input      '[ Location 3 ] (V 4 Word16)+      , "out_a" ':-> Output     '[ Location 0 ] (V 4 Int8  )+      , "out_b" ':-> Output     '[ Location 1 ] (V 4 Word8 )+      , "out_c" ':-> Output     '[ Location 2 ] (V 4 Int16 )+      , "out_d" ':-> Output     '[ Location 3 ] (V 4 Word16)+      , "main"  ':-> EntryPoint '[ ]            Vertex+      ]++program :: Module Defs+program =+  Module $ entryPoint @"main" @Vertex do+    put @"out_a" =<< get @"in_a"+    put @"out_b" =<< get @"in_b"+    put @"out_c" =<< get @"in_c"+    put @"out_d" =<< get @"in_d"
+ test/Tests/Tessellation/Control.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Tessellation.Control where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs =+  '[ "in_col"   ':-> Input  '[ Location 0 ] (Array 3 (V 4 Float))+   , "out_col"  ':-> Output '[ Location 0 ] (Array 3 (V 4 Float))+   , "patchOut" ':-> Output '[ Location 1, Patch ]+                          ( Struct '[ "center" ':-> V 4 Float ] )+   , "main"    ':-> EntryPoint '[ SpacingEqual, VertexOrderCw, OutputVertices 3 ]+                      TessellationControl+   ]++program :: Module Defs+program = Module $ entryPoint @"main" @TessellationControl do+  +  i <- get @"gl_InvocationID"+  in_pos <- use @(Name "gl_in" :.: AnIndex Word32 :.: Name "gl_Position") i+  in_col <- use @(Name "in_col" :.: AnIndex Word32) i+  center <-+    ( recip 3 *^ ) $  use @(Name "gl_in" :.: Index 0 :.: Name "gl_Position")+                  ^+^ use @(Name "gl_in" :.: Index 1 :.: Name "gl_Position")+                  ^+^ use @(Name "gl_in" :.: Index 2 :.: Name "gl_Position")++  assign @(Name "gl_TessLevelInner" :.: Index 0) 16+  assign @(Name "gl_TessLevelInner" :.: Index 1) 16+  assign @(Name "gl_TessLevelOuter" :.: Index 0) 16+  assign @(Name "gl_TessLevelOuter" :.: Index 1) 16+  assign @(Name "gl_TessLevelOuter" :.: Index 2) 16+  assign @(Name "gl_TessLevelOuter" :.: Index 3) 16++  assign @(Name "gl_out"   :.: AnIndex Word32 :.: Name "gl_Position") i in_pos+  assign @(Name "out_col"  :.: AnIndex Word32) i in_col+  assign @(Name "patchOut" :.: Name "center") center
+ test/Tests/Tessellation/Evaluation.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Tessellation.Evaluation where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs =+  '[ "in_cols" ':-> Input      '[ Location 0 ] (Array 3 (V 4 Float))+   , "out_col" ':-> Output     '[ Location 0 ] (V 4 Float)+   , "ubo"     ':-> Uniform '[ Binding 0, DescriptorSet 0 ]+                      ( Struct '[ "mvp"    ':-> M 4 4 Float+                                , "origin" ':-> V 4 Float+                                ]+                      )+   , "main"    ':-> EntryPoint '[ Triangles ] TessellationEvaluation+   ]++program :: Module Defs+program = Module $ entryPoint @"main" @TessellationEvaluation do+  ~(Vec3 u v w) <- get @"gl_TessCoord"+  +  in_cols <- get @"in_cols"+  put @"out_col" (     u *^ (view @(Index 0) in_cols)+                   ^+^ v *^ (view @(Index 1) in_cols)+                   ^+^ w *^ (view @(Index 2) in_cols)+                 )++  pos0 <- use @(Name "gl_in" :.: Index 0 :.: Name "gl_Position")+  pos1 <- use @(Name "gl_in" :.: Index 1 :.: Name "gl_Position")+  pos2 <- use @(Name "gl_in" :.: Index 2 :.: Name "gl_Position")+  orig <- use @(Name "ubo" :.: Name "origin")+  let t = 0.5 - (2*u - 1)**2 * (2*v - 1)**2 * (2*w - 1)**2+  put @"gl_Position"+    ( t *^ orig ^+^ (1-t) *^ ( u *^ pos0 ^+^ v *^ pos1 ^+^ w *^ pos2 ) )
+ test/Tests/Unicode/Syntax.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE UnicodeSyntax       #-}++module Tests.Unicode.Syntax where++-- fir+import FIR++------------------------------------------------+-- program++type Defs = '[ "υβο"    ':-> Uniform '[ Binding 0, DescriptorSet 0 ]+                               ( Struct '[ "φ" ':-> Float ] )+             , "προϊόν" ':-> Output '[ Location 0 ] Float+             , "κύριος" ':-> EntryPoint '[] Vertex+             ]++program :: Module Defs+program = Module $ entryPoint @"κύριος" @Vertex do++  φ <- use @(Name "υβο" :.: Name "φ")+  δ₀ <- def @"δ₀" @R @Float $ 0.1 * φ+  put @"προϊόν" δ₀
+ test/Tests/Vector/Applicative.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Vector.Applicative where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- program++type Defs = '[ "in_col1" ':-> Input      '[Location 0] (V 3 Float)+             , "in_col2" ':-> Input      '[Location 1] (V 3 Float)+             , "in_col3" ':-> Input      '[Location 2] (V 3 Float)+             , "out_col" ':-> Output     '[Location 0] (V 3 Float)+             , "main"    ':-> EntryPoint '[OriginUpperLeft] Fragment+             ]++program :: Module Defs+program = Module do++  entryPoint @"main" @Fragment do++    in_col1 <- get @"in_col1"+    in_col2 <- get @"in_col2"+    in_col3 <- get @"in_col3"++    let func :: Code Float -> Code Float -> Code Float -> Code Float+        func x y z = 2 * z - y + abs x+        out_col :: Code (V 3 Float)+        out_col = func <$$> in_col1 <**> in_col2 <**> in_col3++    put @"out_col" out_col
+ test/Tests/Vector/Functor.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RebindableSyntax    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Tests.Vector.Functor where++-- fir+import FIR+import FIR.Syntax.Labels+import Math.Linear++------------------------------------------------+-- program++type Defs+  = '[ "ubo"      ':-> Uniform  '[ Binding 0, DescriptorSet 0 ] ( Struct '[ "mvp" ':-> M 4 4 Float ] )+     , "position" ':-> Input    '[ Location 0 ] ( V 4 Float )+     , "f"        ':-> Function '[ "u" ':-> Var R Float ] Float+     , "main"     ':-> EntryPoint '[] Vertex+     ]+++program :: Module Defs+program = Module do++  (f :: Code Float -> Code Float) <- fundef @"f" do+    u <- use @(Name "u")+    t <- def @"t" @RW ( 11 :: Code Float ) -- local variable+    pure (u + t)++  entryPoint @"main" @Vertex do++    mvp      <- use @(Name "ubo" :.: Name "mvp")+    position <- get @"position"++    ~(Vec4 x y z _) <- def @"pos" @R ( mvp !*^ (fmapAST (f . (*3) . f) position) )++    #gl_Position .= Vec4 x z y 1
+ test/Tests/Vector/MixedSwizzle.golden view
@@ -0,0 +1,36 @@+test/Tests/Vector/MixedSwizzle.hs:35:12: error: [GHC-64725]+    • Cannot mix and match different swizzle sets.+      Swizzle set of "g" is "rgba".+      Swizzle set of "x" is "xyzw".+    • In a stmt of a 'do' block:+        col <- use @(Name "in_col" :.: Swizzle "rgxb")+      In the third argument of ‘entryPoint’, namely+        ‘do col <- use @(Name "in_col" :.: Swizzle "rgxb")+            put @"out_col" col’+      In the second argument of ‘($)’, namely+        ‘entryPoint+           @"main" @Fragment+           do col <- use @(Name "in_col" :.: Swizzle "rgxb")+              put @"out_col" col’+   |+35 |     col <- use @(Name "in_col" :.: Swizzle "rgxb") -- cannot mix "rgba" and "xyzw"+   |            ^^^++test/Tests/Vector/MixedSwizzle.hs:35:12: error: [GHC-64725]+    • Cannot mix and match different swizzle sets.+      Swizzle set of "g" is "rgba".+      Swizzle set of "x" is "xyzw".+    • In a stmt of a 'do' block:+        col <- use @(Name "in_col" :.: Swizzle "rgxb")+      In the third argument of ‘entryPoint’, namely+        ‘do col <- use @(Name "in_col" :.: Swizzle "rgxb")+            put @"out_col" col’+      In the second argument of ‘($)’, namely+        ‘entryPoint+           @"main" @Fragment+           do col <- use @(Name "in_col" :.: Swizzle "rgxb")+              put @"out_col" col’+   |+35 |     col <- use @(Name "in_col" :.: Swizzle "rgxb") -- cannot mix "rgba" and "xyzw"+   |            ^^^+
+ test/Tests/Vector/MixedSwizzle.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE NamedWildCards        #-}+{-# LANGUAGE OverloadedLabels      #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++module Tests.Vector.MixedSwizzle where++-- fir+import FIR+import Math.Linear++---------------------------------------------------------------------------------++type Defs = '[ "in_col"  ':-> Input      '[Location 0] (V 4 Float)+             , "out_col" ':-> Output     '[Location 0] (V 4 Float)+             , "main"    ':-> EntryPoint '[OriginUpperLeft] Fragment+             ]+++program :: Module Defs+program = Module $ entryPoint @"main" @Fragment do++    col <- use @(Name "in_col" :.: Swizzle "rgxb") -- cannot mix "rgba" and "xyzw"++    put @"out_col" col
+ test/Tests/Vector/Swizzle.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE NamedWildCards        #-}+{-# LANGUAGE OverloadedLabels      #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++module Tests.Vector.Swizzle where++-- fir+import FIR+import Math.Linear++---------------------------------------------------------------------------------++type Defs = '[ "in_col"  ':-> Input      '[Location 0] (V 4 Float)+             , "out_col" ':-> Output     '[Location 0] (V 3 Float)+             , "main"    ':-> EntryPoint '[OriginUpperLeft] Fragment+             ]++blue1 :: V 4 Float+blue1 = V4 0.2 0.8 1 1++darkGrey :: V 3 Float+darkGrey = view @(Swizzle "rrr") blue1++blue2 :: V 3 Float+blue2 = view @(Swizzle "rgb") blue1+++program :: Module Defs+program = Module $ entryPoint @"main" @Fragment do++    col1 <- use @(Name "in_col" :.: Swizzle "rgb")+    col2 <- use @(Name "in_col")+    let col3 = view @(Swizzle "bgr") col2+        col = 0.25 *^ ( col1 ^+^ col3 ^+^ Lit darkGrey ^+^ Lit blue2 )++    r <- use @( Name "in_col" :.: Swizzle "r" )+++    put @"out_col" col+    +    assign @(Name "out_col" :.: Index 1 ) r
+ test/Tests/VertexInput/CompatibleTypes.golden view
@@ -0,0 +1,1 @@+No type-checking errors.
+ test/Tests/VertexInput/CompatibleTypes.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.VertexInput.CompatibleTypes where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- test implicit Int32 - Word32 conversion+-- between vertex input and vertex shader++------------------------------------------------+-- pipeline input++type VertexInput+  = '[ Slot 0 0 ':-> V 4 Int32 ]++------------------------------------------------+-- vertex shader++type VertexDefs =+  '[ "in"   ':-> Input      '[ Location 0 ] ( V 4 Word32 )+   , "out"  ':-> Output     '[ Location 0 ] ( V 4 Float  )+   , "main" ':-> EntryPoint '[            ] Vertex+   ]++vertex :: ShaderModule "main" VertexShader VertexDefs _+vertex = shader do+  vec <- get @"in"+  put @"out" ( ( convert :: Code Word32 -> Code Float ) <$$> vec )++------------------------------------------------+-- fragment shader++type FragmentDefs =+  '[ "in"   ':-> Input      '[ Location 0      ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0      ] ( V 4 Float )+   , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment+   ]++fragment :: ShaderModule "main" FragmentShader FragmentDefs _+fragment = shader do+    put @"out" =<< get @"in"++------------------------------------------------+-- pipeline++shaderPipeline :: ShaderPipeline FilePath+shaderPipeline+  = ShaderPipeline+  $    StructInput @VertexInput @(Triangle List)+  :>-> (vertex  ,   "vertex.spv")+  :>-> (fragment, "fragment.spv")
+ test/Tests/VertexInput/ComponentOutOfRange.golden view
@@ -0,0 +1,18 @@+test/Tests/VertexInput/ComponentOutOfRange.hs:38:10: error: [GHC-64725]+    • Cannot position scalar of type Float+       at Location 0, Component 4.+    • In the expression:+        shader+          do ~(Vec4 x y z _) <- get @"in1"+             w <- get @"in2"+             put @"out" (Vec4 x y z w)+      In an equation for ‘vertex’:+          vertex+            = shader+                do ~(Vec4 x y z _) <- get @"in1"+                   w <- get @"in2"+                   put @"out" (Vec4 x y z w)+   |+38 | vertex = shader do+   |          ^^^^^^+
+ test/Tests/VertexInput/ComponentOutOfRange.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.VertexInput.ComponentOutOfRange where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- test vertex input specifying disallowed component+-- ( greater than 3 )++------------------------------------------------+-- pipeline input++type VertexInput+  = '[ Slot 0 0 ':-> V 4 Float+     , Slot 0 4 ':-> Float+     ]++------------------------------------------------+-- vertex shader++type VertexDefs =+  '[ "in1"  ':-> Input      '[ Location 0              ] ( V 4 Float )+   , "in2"  ':-> Input      '[ Location 0, Component 4 ] Float+   , "out"  ':-> Output     '[ Location 0              ] ( V 4 Float )+   , "main" ':-> EntryPoint '[                         ] Vertex+   ]++vertex :: ShaderModule "main" VertexShader VertexDefs _+vertex = shader do+  ~(Vec4 x y z _) <- get @"in1"+  w <- get @"in2"+  put @"out" ( Vec4 x y z w )++------------------------------------------------+-- fragment shader++type FragmentDefs =+  '[ "in"   ':-> Input      '[ Location 0      ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0      ] ( V 4 Float )+   , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment+   ]++fragment :: ShaderModule "main" FragmentShader FragmentDefs _+fragment = shader do+    put @"out" =<< get @"in"++------------------------------------------------+-- pipeline++shaderPipeline :: ShaderPipeline FilePath+shaderPipeline+  = ShaderPipeline+  $    StructInput @VertexInput @(Triangle List)+  :>-> (vertex  ,   "vertex.spv")+  :>-> (fragment, "fragment.spv")
+ test/Tests/VertexInput/DoubleComponents.golden view
@@ -0,0 +1,1 @@+No type-checking errors.
+ test/Tests/VertexInput/DoubleComponents.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.VertexInput.DoubleComponents where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- test placing Doubles in various (valid) components+++------------------------------------------------+-- pipeline input++type VertexInput+  = '[ Slot 0 0 ':-> Double+     , Slot 0 2 ':-> Double+     , Slot 1 0 ':-> V 2 Double+     ]++------------------------------------------------+-- vertex shader++type VertexDefs =+  '[ "in_x" ':-> Input      '[ Location 0              ] Double+   , "in_y" ':-> Input      '[ Location 0, Component 2 ] Double+   , "in_z" ':-> Input      '[ Location 1              ] Double+   , "in_w" ':-> Input      '[ Location 1, Component 2 ] Double+   , "out"  ':-> Output     '[ Location 0              ] ( V 4 Float )+   , "main" ':-> EntryPoint '[                         ] Vertex+   ]++vertex :: ShaderModule "main" VertexShader VertexDefs _+vertex = shader do+  x <- get @"in_x"+  y <- get @"in_y"+  z <- get @"in_z"+  w <- get @"in_w"+  put @"out" ( ( convert :: Code Double -> Code Float ) <$$> Vec4 x y z w )++------------------------------------------------+-- fragment shader++type FragmentDefs =+  '[ "in"   ':-> Input      '[ Location 0      ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0      ] ( V 4 Float )+   , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment+   ]++fragment :: ShaderModule "main" FragmentShader FragmentDefs _+fragment = shader do+    put @"out" =<< get @"in"++------------------------------------------------+-- pipeline++shaderPipeline :: ShaderPipeline FilePath+shaderPipeline+  = ShaderPipeline+  $    StructInput @VertexInput @(Triangle List)+  :>-> (vertex  ,   "vertex.spv")+  :>-> (fragment, "fragment.spv")
+ test/Tests/VertexInput/EquivalentComponents.golden view
@@ -0,0 +1,1 @@+No type-checking errors.
+ test/Tests/VertexInput/EquivalentComponents.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.VertexInput.EquivalentComponents where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- test splitting up / merging data+-- between vertex input and vertex shader input++------------------------------------------------+-- pipeline input++type VertexInput+  = '[ Slot 0 0 ':-> V 3 Float, Slot 0 3 ':-> Float -- split1+     , Slot 1 0 ':-> V 3 Float, Slot 1 3 ':-> Float -- split2+     , Slot 2 0 ':-> V 4 Float                      -- nonsplit1+     , Slot 3 0 ':-> V 4 Float                      -- nonsplit2+     ]++------------------------------------------------+-- vertex shader++type VertexDefs =+  '[ "in_split1a"    ':-> Input '[ Location 0 ]              ( V 3 Float )+   , "in_split1b"    ':-> Input '[ Location 0, Component 3 ] Float+   , "in_split2"     ':-> Input '[ Location 1 ]              ( V 4 Float )+   , "in_nonsplit1a" ':-> Input '[ Location 2 ]              ( V 3 Float )+   , "in_nonsplit1b" ':-> Input '[ Location 2, Component 3 ] Float+   , "in_nonsplit2"  ':-> Input '[ Location 3 ]              ( V 4 Float )++   , "out_split1a"    ':-> Output '[ Location 0 ]              ( V 3 Float )+   , "out_split1b"    ':-> Output '[ Location 0, Component 3 ] Float+   , "out_split2"     ':-> Output '[ Location 1 ]              ( V 4 Float )+   , "out_nonsplit1a" ':-> Output '[ Location 2 ]              ( V 3 Float )+   , "out_nonsplit1b" ':-> Output '[ Location 2, Component 3 ] Float+   , "out_nonsplit2"  ':-> Output '[ Location 3 ]              ( V 4 Float )++   , "main"           ':-> EntryPoint '[ ] Vertex+   ]++vertex :: ShaderModule "main" VertexShader VertexDefs _+vertex = shader do++  put @"out_split1a"    =<< get @"in_split1a"+  put @"out_split1b"    =<< get @"in_split1b"+  put @"out_split2"     =<< get @"in_split2"+  put @"out_nonsplit1a" =<< get @"in_nonsplit1a"+  put @"out_nonsplit1b" =<< get @"in_nonsplit1b"+  put @"out_nonsplit2"  =<< get @"in_nonsplit2"++------------------------------------------------+-- fragment shader++type FragmentDefs =+  '[ "in_split1a"    ':-> Input  '[ Location 0 ]              ( V 3 Float )+   , "in_split1b"    ':-> Input  '[ Location 0, Component 3 ] Float+   , "in_split2"     ':-> Input  '[ Location 1 ]              ( V 4 Float )+   , "in_nonsplit1a" ':-> Input  '[ Location 2 ]              ( V 3 Float )+   , "in_nonsplit1b" ':-> Input  '[ Location 2, Component 3 ] Float+   , "in_nonsplit2"  ':-> Input  '[ Location 3 ]              ( V 4 Float )+   , "out_colour"    ':-> Output '[ Location 0 ]              ( V 4 Float )+   , "main"          ':-> EntryPoint '[ OriginUpperLeft ] Fragment+   ]++fragment :: ShaderModule "main" FragmentShader FragmentDefs _+fragment = shader do+    put @"out_colour" =<< get @"in_split2"++------------------------------------------------+-- pipeline++shaderPipeline :: ShaderPipeline FilePath+shaderPipeline+  = ShaderPipeline+  $    StructInput @VertexInput @(Triangle List)+  :>-> (vertex  ,   "vertex.spv")+  :>-> (fragment, "fragment.spv")
+ test/Tests/VertexInput/IncompatibleTypes.golden view
@@ -0,0 +1,1 @@+Should error: expecting Float but given Int32, which are not compatible.
+ test/Tests/VertexInput/IncompatibleTypes.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.VertexInput.IncompatibleTypes where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- check that vertex input scalar types+-- match with vertex shader input+-- ( mismatch: Int32 vs Float )++------------------------------------------------+-- pipeline input++type VertexInput+  = '[ Slot 0 0 ':-> V 4 Int32+     ]++------------------------------------------------+-- vertex shader++type VertexDefs =+  '[ "in"   ':-> Input      '[ Location 0 ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0 ] ( V 4 Float )+   , "main" ':-> EntryPoint '[            ] Vertex+   ]++vertex :: ShaderModule "main" VertexShader VertexDefs _+vertex = shader do+  put @"out" =<< get @"in"++------------------------------------------------+-- fragment shader++type FragmentDefs =+  '[ "in"   ':-> Input      '[ Location 0      ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0      ] ( V 4 Float )+   , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment+   ]++fragment :: ShaderModule "main" FragmentShader FragmentDefs _+fragment = shader do+    put @"out" =<< get @"in"++------------------------------------------------+-- pipeline++shaderPipeline :: ShaderPipeline FilePath+shaderPipeline+  = ShaderPipeline+  $    StructInput @VertexInput @(Triangle List)+  :>-> (vertex  ,   "vertex.spv")+  :>-> (fragment, "fragment.spv")
+ test/Tests/VertexInput/IncompatibleWidths.golden view
@@ -0,0 +1,1 @@+Should error: expecting Float but given Double, which are not compatible.
+ test/Tests/VertexInput/IncompatibleWidths.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.VertexInput.IncompatibleWidths where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- check that vertex input scalar types+-- match with vertex shader input+-- ( mismatch: Float vs Double )++------------------------------------------------+-- pipeline input++type VertexInput+  = '[ Slot 0 0 ':-> V 2 Double+     ]++------------------------------------------------+-- vertex shader++type VertexDefs =+  '[ "in"   ':-> Input      '[ Location 0 ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0 ] ( V 4 Float )+   , "main" ':-> EntryPoint '[            ] Vertex+   ]++vertex :: ShaderModule "main" VertexShader VertexDefs _+vertex = shader do+  put @"out" =<< get @"in"++------------------------------------------------+-- fragment shader++type FragmentDefs =+  '[ "in"   ':-> Input      '[ Location 0      ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0      ] ( V 4 Float )+   , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment+   ]++fragment :: ShaderModule "main" FragmentShader FragmentDefs _+fragment = shader do+    put @"out" =<< get @"in"++------------------------------------------------+-- pipeline++shaderPipeline :: ShaderPipeline FilePath+shaderPipeline+  = ShaderPipeline+  $    StructInput @VertexInput @(Triangle List)+  :>-> (vertex  ,   "vertex.spv")+  :>-> (fragment, "fragment.spv")
+ test/Tests/VertexInput/InvalidDoubleComponent.golden view
@@ -0,0 +1,10 @@+test/Tests/VertexInput/InvalidDoubleComponent.hs:37:10: error: [GHC-64725]+    • Cannot position scalar of type Double+       at Location 1, Component 1.+    • In the expression: shader do put @"out" =<< get @"in"+      In an equation for ‘vertex’:+          vertex = shader do put @"out" =<< get @"in"+   |+37 | vertex = shader do+   |          ^^^^^^+
+ test/Tests/VertexInput/InvalidDoubleComponent.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.VertexInput.InvalidDoubleComponent where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- test placing Doubles in invalid (odd) components++------------------------------------------------+-- pipeline input++type VertexInput+  = '[ Slot 0 0 ':-> V 4 Float+     , Slot 1 1 ':-> Double+     ]++------------------------------------------------+-- vertex shader++type VertexDefs =+  '[ "in"   ':-> Input      '[ Location 0 ] ( V 4 Float )+   , "d"    ':-> Input      '[ Location 1, Component 1 ] Double+   , "out"  ':-> Output     '[ Location 0 ] ( V 4 Float )+   , "main" ':-> EntryPoint '[            ] Vertex+   ]++vertex :: ShaderModule "main" VertexShader VertexDefs _+vertex = shader do+  put @"out" =<< get @"in"++------------------------------------------------+-- fragment shader++type FragmentDefs =+  '[ "in"   ':-> Input      '[ Location 0      ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0      ] ( V 4 Float )+   , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment+   ]++fragment :: ShaderModule "main" FragmentShader FragmentDefs _+fragment = shader do+    put @"out" =<< get @"in"++------------------------------------------------+-- pipeline++shaderPipeline :: ShaderPipeline FilePath+shaderPipeline+  = ShaderPipeline+  $    StructInput @VertexInput @(Triangle List)+  :>-> (vertex  ,   "vertex.spv")+  :>-> (fragment, "fragment.spv")
+ test/Tests/VertexInput/InvalidVectorComponent.golden view
@@ -0,0 +1,10 @@+test/Tests/VertexInput/InvalidVectorComponent.hs:39:10: error: [GHC-64725]+    • Cannot position vector of type V 4 Float+       at Location 0, Component 2.+    • In the expression: shader do put @"out" =<< get @"in_yz"+      In an equation for ‘vertex’:+          vertex = shader do put @"out" =<< get @"in_yz"+   |+39 | vertex = shader do+   |          ^^^^^^+
+ test/Tests/VertexInput/InvalidVectorComponent.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.VertexInput.InvalidVectorComponent where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- test placing vectors in invalid components++------------------------------------------------+-- pipeline input++type VertexInput+  = '[ Slot 0 0 ':-> V 2 Float+     , Slot 0 2 ':-> V 4 Float+     , Slot 1 2 ':-> V 2 Float+     ]++------------------------------------------------+-- vertex shader++type VertexDefs =+  '[ "in_x"  ':-> Input      '[ Location 0              ] ( V 2 Float )+   , "in_yz" ':-> Input      '[ Location 0, Component 2 ] ( V 4 Float )+   , "in_w"  ':-> Input      '[ Location 1, Component 2 ] ( V 2 Float )+   , "out"   ':-> Output     '[ Location 0              ] ( V 4 Float )+   , "main"  ':-> EntryPoint '[                         ] Vertex+   ]++vertex :: ShaderModule "main" VertexShader VertexDefs _+vertex = shader do+  put @"out" =<< get @"in_yz"++------------------------------------------------+-- fragment shader++type FragmentDefs =+  '[ "in"   ':-> Input      '[ Location 0      ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0      ] ( V 4 Float )+   , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment+   ]++fragment :: ShaderModule "main" FragmentShader FragmentDefs _+fragment = shader do+    put @"out" =<< get @"in"++------------------------------------------------+-- pipeline++shaderPipeline :: ShaderPipeline FilePath+shaderPipeline+  = ShaderPipeline+  $    StructInput @VertexInput @(Triangle List)+  :>-> (vertex  ,   "vertex.spv")+  :>-> (fragment, "fragment.spv")
+ test/Tests/VertexInput/MissingComponents.golden view
@@ -0,0 +1,1 @@+Should error: consuming location 0 components 0, 1, 2, 3, but only provided location 0 component 0
+ test/Tests/VertexInput/MissingComponents.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.VertexInput.MissingComponents where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- test vertex shader accessing data+-- not specified in vertex input+-- ( validation should disallow this )++------------------------------------------------+-- pipeline input++type VertexInput+  = '[ Slot 0 0 ':-> Float ]++------------------------------------------------+-- vertex shader++type VertexDefs =+  '[ "in"   ':-> Input      '[ Location 0 ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0 ] ( V 4 Float )+   , "main" ':-> EntryPoint '[            ] Vertex+   ]++vertex :: ShaderModule "main" VertexShader VertexDefs _+vertex = shader do+  put @"out" =<< get @"in"++------------------------------------------------+-- fragment shader++type FragmentDefs =+  '[ "in"   ':-> Input      '[ Location 0      ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0      ] ( V 4 Float )+   , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment+   ]++fragment :: ShaderModule "main" FragmentShader FragmentDefs _+fragment = shader do+    put @"out" =<< get @"in"++------------------------------------------------+-- pipeline++shaderPipeline :: ShaderPipeline FilePath+shaderPipeline+  = ShaderPipeline+  $    StructInput @VertexInput @(Triangle List)+  :>-> (vertex  ,   "vertex.spv")+  :>-> (fragment, "fragment.spv")
+ test/Tests/VertexInput/Overlap.golden view
@@ -0,0 +1,38 @@+
+test\Tests\VertexInput\Overlap.hs:59:5: error:
+    * Overlap at Location 1, Component 0:
+        - V 4 Double with Location 0, Component 0,
+        - V 4 Float with Location 1, Component 0.
+    * In the expression:
+        ShaderPipeline
+          $ StructInput @VertexInput @(Triangle List)
+              :>-> (vertex, "vertex.spv")
+              :>-> (fragment, "fragment.spv")
+      In an equation for `shaderPipeline':
+          shaderPipeline
+            = ShaderPipeline
+                $ StructInput @VertexInput @(Triangle List)
+                    :>-> (vertex, "vertex.spv")
+                    :>-> (fragment, "fragment.spv")
+   |+59 |   = ShaderPipeline

+   |     ^^^^^^^^^^^^^^^...
+
+test\Tests\VertexInput\Overlap.hs:59:5: error:
+    * Overlap at Location 1, Component 0:
+        - V 4 Double with Location 0, Component 0,
+        - V 4 Float with Location 1, Component 0.
+    * In the expression:
+        ShaderPipeline
+          $ StructInput @VertexInput @(Triangle List)
+              :>-> (vertex, "vertex.spv")
+              :>-> (fragment, "fragment.spv")
+      In an equation for `shaderPipeline':
+          shaderPipeline
+            = ShaderPipeline
+                $ StructInput @VertexInput @(Triangle List)
+                    :>-> (vertex, "vertex.spv")
+                    :>-> (fragment, "fragment.spv")
+   |+59 |   = ShaderPipeline

+   |     ^^^^^^^^^^^^^^^...
+ test/Tests/VertexInput/Overlap.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.VertexInput.Overlap where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- check overlap in vertex input+-- ( V 4 Double spilling into next location slot )++------------------------------------------------+-- pipeline input++type VertexInput+  = '[ Slot 0 0 ':-> V 4 Double+     , Slot 1 0 ':-> V 4 Float -- unused by the vertex shader but overlapping with the previous location+     ]++------------------------------------------------+-- vertex shader++type VertexDefs =+  '[ "in"   ':-> Input      '[ Location 0 ] ( V 4 Double )+   , "out"  ':-> Output     '[ Location 0 ] ( V 4 Float  )+   , "main" ':-> EntryPoint '[            ] Vertex+   ]++vertex :: ShaderModule "main" VertexShader VertexDefs _+vertex = shader do+  vec <- get @"in"+  put @"out" ( ( convert :: Code Double -> Code Float ) <$$> vec )++------------------------------------------------+-- fragment shader++type FragmentDefs =+  '[ "in"   ':-> Input      '[ Location 0      ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0      ] ( V 4 Float )+   , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment+   ]++fragment :: ShaderModule "main" FragmentShader FragmentDefs _+fragment = shader do+    put @"out" =<< get @"in"++------------------------------------------------+-- pipeline++shaderPipeline :: ShaderPipeline FilePath+shaderPipeline+  = ShaderPipeline+  $    StructInput @VertexInput @(Triangle List)+  :>-> (vertex  ,   "vertex.spv")+  :>-> (fragment, "fragment.spv")
+ test/Tests/VertexInput/V3Double_Double.golden view
@@ -0,0 +1,1 @@+No type-checking errors.
+ test/Tests/VertexInput/V3Double_Double.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE BlockArguments        #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Tests.VertexInput.V3Double_Double where++-- fir+import FIR+import Math.Linear++------------------------------------------------+-- check for valid placement of doubles++------------------------------------------------+-- pipeline input++type VertexInput+  = '[ Slot 0 0 ':-> V 3 Double+     , Slot 1 2 ':-> Double+     ]++------------------------------------------------+-- vertex shader++type VertexDefs =+  '[ "in"   ':-> Input      '[ Location 0 ] ( V 4 Double )+   , "out"  ':-> Output     '[ Location 0 ] ( V 4 Float  )+   , "main" ':-> EntryPoint '[            ] Vertex+   ]++vertex :: ShaderModule "main" VertexShader VertexDefs _+vertex = shader do+  v <- get @"in"+  put @"out" ( ( convert :: Code Double -> Code Float ) <$$> v )++------------------------------------------------+-- fragment shader++type FragmentDefs =+  '[ "in"   ':-> Input      '[ Location 0      ] ( V 4 Float )+   , "out"  ':-> Output     '[ Location 0      ] ( V 4 Float )+   , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment+   ]++fragment :: ShaderModule "main" FragmentShader FragmentDefs _+fragment = shader do+    put @"out" =<< get @"in"++------------------------------------------------+-- pipeline++shaderPipeline :: ShaderPipeline FilePath+shaderPipeline+  = ShaderPipeline+  $    StructInput @VertexInput @(Triangle List)+  :>-> (vertex  ,   "vertex.spv")+  :>-> (fragment, "fragment.spv")