language-wgsl (empty) → 0.1.0.0

raw patch · 6 files changed

+2489/−0 lines, 6 filesdep +basedep +language-wgsldep +prettyprinter

Dependencies added: base, language-wgsl, prettyprinter, tasty, tasty-hunit, text

Files

• CHANGELOG.md +5/−0
• LICENSE +13/−0
• README.md +6/−0
• language-wgsl.cabal +58/−0
• src/Language/WGSL.hs +1329/−0
• test/Test.hs +1078/−0

@@ -0,0 +1,5 @@+# Revision history for language-wgsl++## 0.1.0.0 -- 2026-11-03++* First version. Released on an unsuspecting world.

@@ -0,0 +1,13 @@+Copyright (c) 2024-2026 Sebastian Paarmann and the University of Copenhagen++Permission to use, copy, modify, and/or distribute this software for any purpose+with or without fee is hereby granted, provided that the above copyright notice+and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS+OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER+TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF+THIS SOFTWARE.

@@ -0,0 +1,6 @@+# language-wgsl++A simple Haskell package for representing [WGSL](https://www.w3.org/TR/WGSL),+intended to closely match the specification. This package does not currently+include a parser, and also does not represent purely syntactic details (such as+whether an integer is hex or decimal).

@@ -0,0 +1,58 @@+cabal-version:      3.4+name:               language-wgsl+version:            0.1.0.0+synopsis:           AST, prettyprinter, and other tools for the WebGPU Shading Language.++description:        A package for working with the+                    <https://www.w3.org/TR/WGSL/ WebGPU Shading Language>+                    (WGSL).+                    .+                    The package is currently fairly minimalistic, and mostly+                    useful for programs that want to generate WGSL.++license:            ISC+license-file:       LICENSE+author:             Sebastian Paarmann+maintainer:         Troels Henriksen <athas@sigkill.dk>+copyright:          Sebastian Paarmann and the University of Copenhagen+category:           Language+homepage:           https://github.com/diku-dk/language-wgsl+bug-reports:        https://github.com/diku-dk/language-wgsl/issues+build-type:         Simple+tested-with:        GHC == 9.10.*, GHC == 9.12.*, GHC == 9.14.*+extra-doc-files:    CHANGELOG.md+                    README.md++source-repository head+    type:     git+    location: https://github.com/diku-dk/language-wgsl.git++common warnings+    ghc-options: -Wall -Wcompat++library+    import:           warnings+    exposed-modules:  Language.WGSL+    build-depends:    base >=4.15 && <5,+                      text >=1.2 && <2.2,+                      prettyprinter >=1.7 && <1.8+    hs-source-dirs:   src+    default-language: GHC2021+    default-extensions:+      OverloadedStrings++test-suite language-wgsl-test+    import:           warnings+    default-language: GHC2021+    default-extensions:+      OverloadedStrings+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          Test.hs+    build-depends:+        base >=4.15 && <5,+        text >=1.2 && <2.2,+        prettyprinter >=1.7 && <1.8,+        language-wgsl,+        tasty >=1.4 && <1.6,+        tasty-hunit >=0.10 && <0.11

@@ -0,0 +1,1329 @@+-- | Basic WGSL definitions, including AST definitions. These are intended to+-- correspond closely with the terminology and structure of the WGSL+-- specification, but it is not automatically generated from the specification,+-- and so may have inconsistencies. This module is intended to be imported+-- qualified:+--+-- @+-- import Language.WGSL qualified as WGSL+-- @+--+-- The definitions here are abstract in the sense that they cannot represent+-- syntactic details of a WGSL program, e.g., whether an integer literal is+-- written hexadecimally. This makes these definitions less useful for parsing,+-- but fine for code generation. I would not be opposed to adding a concrete+-- syntax module in the future.+--+-- To produce WGSL code as text, use the 'Pretty' instance for the various+-- constructs.+--+-- Known and intentional deviations from the specification:+--+-- 1. Statements do not have attributes+--+-- 2. Assignment targets are ordinary expressions, not a separate+--    @lhs_expression@.+--+-- 3. When printed, expressions are always fully parenthesised, so operator+--    precedence is not modelled.+module Language.WGSL+  ( -- * Identifiers+    Ident,+    validIdent,+    keywords,+    reservedWords,++    -- * Types+    Type (..),+    TextureDim (..),+    StorageTextureDim (..),+    DepthTexture (..),+    TexelFormat (..),++    -- * Memory+    AccessMode (..),+    AddressSpace (..),++    -- ** Alignment and size+    roundUp,+    roundDown,+    alignOf,+    sizeOf,+    strideOf,+    hostShareable,+    alignOfMember,+    sizeOfMember,+    alignOfStruct,+    offsetOfMembers,+    sizeOfStruct,++    -- * Expressions+    Expression (..),+    BinaryOperator (..),+    UnaryOperator (..),+    IntLiteralType (..),+    FloatLiteralType (..),+    intExp,+    floatExp,+    bitcast,++    -- * Statements+    Statement (..),+    AssignmentOperator (..),+    ForUpdate (..),+    SwitchClause (..),+    CaseSelector (..),+    Continuing (..),++    -- * Declarations+    Attribute (..),+    bindingAttribs,+    Param (..),+    FunctionDecl (..),+    StructMember (..),+    StructDecl (..),+    GlobalDecl (..),++    -- * Modules+    Module (..),+    Directive (..),+    Severity (..),+    EnableExtension (..),+    LanguageExtension (..),+  )+where++import Data.Char (GeneralCategory (..), generalCategory, isAlpha, isDigit)+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NE+import Data.Text qualified as T+import Prettyprinter++-- | A WGSL identifier, which is not checked for validity.+type Ident = T.Text++-- | Whether a name is a valid WGSL identifier. See+-- https://www.w3.org/TR/WGSL/#identifiers.+validIdent :: Ident -> Bool+validIdent t =+  matchesPattern+    && not ("__" `T.isPrefixOf` t)+    && t `notElem` keywords+    && t `notElem` reservedWords+  where+    matchesPattern = case T.uncons t of+      Nothing -> False+      Just (c, rest)+        | T.null rest -> xidStart c+        | otherwise -> (c == '_' || xidStart c) && T.all xidContinue rest++-- | Approximates the Unicode @XID_Start@ property.+xidStart :: Char -> Bool+xidStart c = isAlpha c || generalCategory c == LetterNumber++-- | Approximates the Unicode @XID_Continue@ property.+xidContinue :: Char -> Bool+xidContinue c =+  xidStart c+    || isDigit c+    || generalCategory c+      `elem` [NonSpacingMark, SpacingCombiningMark, ConnectorPunctuation]++-- | The WGSL keywords. See https://www.w3.org/TR/WGSL/#keyword-summary.+keywords :: [Ident]+keywords =+  [ "alias",+    "break",+    "case",+    "const",+    "const_assert",+    "continue",+    "continuing",+    "default",+    "diagnostic",+    "discard",+    "else",+    "enable",+    "false",+    "fn",+    "for",+    "if",+    "let",+    "loop",+    "override",+    "requires",+    "return",+    "struct",+    "switch",+    "true",+    "var",+    "while"+  ]++-- | The WGSL reserved words. See https://www.w3.org/TR/WGSL/#reserved-words.+reservedWords :: [Ident]+reservedWords =+  [ "NULL",+    "Self",+    "abstract",+    "active",+    "alignas",+    "alignof",+    "as",+    "asm",+    "asm_fragment",+    "async",+    "attribute",+    "auto",+    "await",+    "become",+    "cast",+    "catch",+    "class",+    "co_await",+    "co_return",+    "co_yield",+    "coherent",+    "column_major",+    "common",+    "compile",+    "compile_fragment",+    "concept",+    "const_cast",+    "consteval",+    "constexpr",+    "constinit",+    "crate",+    "debugger",+    "decltype",+    "delete",+    "demote",+    "demote_to_helper",+    "do",+    "dynamic_cast",+    "enum",+    "explicit",+    "export",+    "extends",+    "extern",+    "external",+    "fallthrough",+    "filter",+    "final",+    "finally",+    "friend",+    "from",+    "fxgroup",+    "get",+    "goto",+    "groupshared",+    "highp",+    "impl",+    "implements",+    "import",+    "inline",+    "instanceof",+    "interface",+    "layout",+    "lowp",+    "macro",+    "macro_rules",+    "match",+    "mediump",+    "meta",+    "mod",+    "module",+    "move",+    "mut",+    "mutable",+    "namespace",+    "new",+    "nil",+    "noexcept",+    "noinline",+    "nointerpolation",+    "non_coherent",+    "noncoherent",+    "noperspective",+    "null",+    "nullptr",+    "of",+    "operator",+    "package",+    "packoffset",+    "partition",+    "pass",+    "patch",+    "pixelfragment",+    "precise",+    "precision",+    "premerge",+    "priv",+    "protected",+    "pub",+    "public",+    "readonly",+    "ref",+    "regardless",+    "register",+    "reinterpret_cast",+    "require",+    "resource",+    "restrict",+    "self",+    "set",+    "shared",+    "sizeof",+    "smooth",+    "snorm",+    "static",+    "static_assert",+    "static_cast",+    "std",+    "subroutine",+    "super",+    "target",+    "template",+    "this",+    "thread_local",+    "throw",+    "trait",+    "try",+    "type",+    "typedef",+    "typeid",+    "typename",+    "typeof",+    "union",+    "unless",+    "unorm",+    "unsafe",+    "unsized",+    "use",+    "using",+    "varying",+    "virtual",+    "volatile",+    "wgsl",+    "where",+    "with",+    "writeonly",+    "yield"+  ]++-- | A type as it occurs in WGSL source. See+-- https://www.w3.org/TR/WGSL/#type-specifiers.+data Type+  = Bool+  | I32+  | U32+  | F16+  | F32+  | Vec2 Type+  | Vec3 Type+  | Vec4 Type+  | -- | @matCxR@ has @C@ columns of @R@ rows.+    Mat2x2 Type+  | Mat2x3 Type+  | Mat2x4 Type+  | Mat3x2 Type+  | Mat3x3 Type+  | Mat3x4 Type+  | Mat4x2 Type+  | Mat4x3 Type+  | Mat4x4 Type+  | Atomic Type+  | -- | An array, which is runtime-sized when the element count is absent.+    Array Type (Maybe Expression)+  | Ptr Type AddressSpace (Maybe AccessMode)+  | -- | A structure or type alias, referred to by name. Its definition is not+    -- known here, so it has no layout.+    Named Ident+  | -- | See https://www.w3.org/TR/WGSL/#sampled-texture-type.+    TextureSampled TextureDim Type+  | -- | Always two-dimensional.  See+    -- https://www.w3.org/TR/WGSL/#multisampled-texture-type.+    TextureMultisampled Type+  | -- | An external sampled texture type.  See+    -- https://www.w3.org/TR/WGSL/#external-texture-type.+    TextureExternal+  | -- | A storage texture type.  See+    -- https://www.w3.org/TR/WGSL/#texture-storage.+    TextureStorage StorageTextureDim TexelFormat AccessMode+  | -- | A depth texture type.  See+    -- https://www.w3.org/TR/WGSL/#texture-depth.+    TextureDepth DepthTexture+  | -- | A sampler.  See https://www.w3.org/TR/WGSL/#sampler-type.+    Sampler+  | -- | A comparison sampler.+    SamplerComparison+  deriving (Eq, Ord, Show)++-- | The dimensionality and arrangement of a sampled texture.  See+-- https://www.w3.org/TR/WGSL/#sampled-texture-type.+data TextureDim+  = Tex1d+  | Tex2d+  | Tex2dArray+  | Tex3d+  | TexCube+  | TexCubeArray+  deriving (Eq, Ord, Show)++-- | The dimensionality and arrangement of a storage texture.  See+-- https://www.w3.org/TR/WGSL/#texture-storage.+data StorageTextureDim+  = StorageTex1d+  | StorageTex2d+  | StorageTex2dArray+  | StorageTex3d+  deriving (Eq, Ord, Show)++-- | A depth texture type.  See https://www.w3.org/TR/WGSL/#texture-depth.+data DepthTexture+  = Depth2d+  | Depth2dArray+  | DepthCube+  | DepthCubeArray+  | DepthMultisampled2d+  deriving (Eq, Ord, Show)++-- | A texel format, used to parameterise the storage texture types.  See+-- https://www.w3.org/TR/WGSL/#texel-formats.+data TexelFormat+  = Rgba8Unorm+  | Rgba8Snorm+  | Rgba8Uint+  | Rgba8Sint+  | Rgba16Unorm+  | Rgba16Snorm+  | Rgba16Uint+  | Rgba16Sint+  | Rgba16Float+  | Rg8Unorm+  | Rg8Snorm+  | Rg8Uint+  | Rg8Sint+  | Rg16Unorm+  | Rg16Snorm+  | Rg16Uint+  | Rg16Sint+  | Rg16Float+  | R32Uint+  | R32Sint+  | R32Float+  | Rg32Uint+  | Rg32Sint+  | Rg32Float+  | Rgba32Uint+  | Rgba32Sint+  | Rgba32Float+  | Bgra8Unorm+  | R8Unorm+  | R8Snorm+  | R8Uint+  | R8Sint+  | R16Unorm+  | R16Snorm+  | R16Uint+  | R16Sint+  | R16Float+  | Rgb10a2Unorm+  | Rgb10a2Uint+  | Rg11b10Ufloat+  deriving (Eq, Ord, Show)++-- | @roundUp(k, n)@, which is @ceiling(n / k) * k@, for positive integers.+-- See https://www.w3.org/TR/WGSL/#roundup.+roundUp :: Int -> Int -> Int+roundUp k n = ((n + k - 1) `div` k) * k++-- | @roundDown(k, n)@, which is @floor(n / k) * k@, for positive integers.+-- See https://www.w3.org/TR/WGSL/#rounddown.+roundDown :: Int -> Int -> Int+roundDown k n = (n `div` k) * k++-- | @AlignOf@ of a type.  'Nothing' for pointers, texture and sampler types,+-- and for a 'Named' type, which is not resolved here.  See+-- https://www.w3.org/TR/WGSL/#alignment-and-size.+alignOf :: Type -> Maybe Int+alignOf Bool = Just 4+alignOf I32 = Just 4+alignOf U32 = Just 4+alignOf F16 = Just 2+alignOf F32 = Just 4+alignOf (Vec2 t) = (2 *) <$> alignOf t+alignOf (Vec3 t) = (4 *) <$> alignOf t+alignOf (Vec4 t) = (4 *) <$> alignOf t+-- The alignment of a matrix is that of its columns.+alignOf (Mat2x2 t) = alignOf $ Vec2 t+alignOf (Mat3x2 t) = alignOf $ Vec2 t+alignOf (Mat4x2 t) = alignOf $ Vec2 t+alignOf (Mat2x3 t) = alignOf $ Vec3 t+alignOf (Mat3x3 t) = alignOf $ Vec3 t+alignOf (Mat4x3 t) = alignOf $ Vec3 t+alignOf (Mat2x4 t) = alignOf $ Vec4 t+alignOf (Mat3x4 t) = alignOf $ Vec4 t+alignOf (Mat4x4 t) = alignOf $ Vec4 t+alignOf (Atomic _) = Just 4+alignOf (Array t _) = alignOf t+alignOf Ptr {} = Nothing+alignOf (Named _) = Nothing+alignOf TextureSampled {} = Nothing+alignOf (TextureMultisampled _) = Nothing+alignOf TextureExternal = Nothing+alignOf TextureStorage {} = Nothing+alignOf (TextureDepth _) = Nothing+alignOf Sampler = Nothing+alignOf SamplerComparison = Nothing++-- | @SizeOf@ of a type.  'Nothing' as for 'alignOf', and also for an array+-- whose element count is not a literal.  See+-- https://www.w3.org/TR/WGSL/#alignment-and-size.+sizeOf :: Type -> Maybe Int+sizeOf Bool = Just 4+sizeOf I32 = Just 4+sizeOf U32 = Just 4+sizeOf F16 = Just 2+sizeOf F32 = Just 4+sizeOf (Vec2 t) = (2 *) <$> sizeOf t+sizeOf (Vec3 t) = (3 *) <$> sizeOf t+sizeOf (Vec4 t) = (4 *) <$> sizeOf t+-- A matrix is laid out as an array of its columns.+sizeOf (Mat2x2 t) = (2 *) <$> strideOf (Vec2 t)+sizeOf (Mat3x2 t) = (3 *) <$> strideOf (Vec2 t)+sizeOf (Mat4x2 t) = (4 *) <$> strideOf (Vec2 t)+sizeOf (Mat2x3 t) = (2 *) <$> strideOf (Vec3 t)+sizeOf (Mat3x3 t) = (3 *) <$> strideOf (Vec3 t)+sizeOf (Mat4x3 t) = (4 *) <$> strideOf (Vec3 t)+sizeOf (Mat2x4 t) = (2 *) <$> strideOf (Vec4 t)+sizeOf (Mat3x4 t) = (3 *) <$> strideOf (Vec4 t)+sizeOf (Mat4x4 t) = (4 *) <$> strideOf (Vec4 t)+sizeOf (Atomic _) = Just 4+sizeOf (Array t (Just (ExpInt n _)))+  | n >= 0 = (n *) <$> strideOf t+sizeOf Array {} = Nothing+sizeOf Ptr {} = Nothing+sizeOf (Named _) = Nothing+sizeOf TextureSampled {} = Nothing+sizeOf (TextureMultisampled _) = Nothing+sizeOf TextureExternal = Nothing+sizeOf TextureStorage {} = Nothing+sizeOf (TextureDepth _) = Nothing+sizeOf Sampler = Nothing+sizeOf SamplerComparison = Nothing++-- | @StrideOf@ of an array with the given element type.  See+-- https://www.w3.org/TR/WGSL/#internal-value-layout.+strideOf :: Type -> Maybe Int+strideOf t = roundUp <$> alignOf t <*> sizeOf t++-- | Whether a type is host-shareable.  A 'Named' type is not resolved here,+-- and so is reported as not host-shareable.  See+-- https://www.w3.org/TR/WGSL/#host-shareable-types.+hostShareable :: Type -> Bool+-- bool is not a numeric scalar type, and a vector of bool is not a numeric+-- vector type.+hostShareable Bool = False+hostShareable I32 = True+hostShareable U32 = True+hostShareable F16 = True+hostShareable F32 = True+hostShareable (Vec2 t) = hostShareable t+hostShareable (Vec3 t) = hostShareable t+hostShareable (Vec4 t) = hostShareable t+hostShareable (Mat2x2 t) = hostShareable t+hostShareable (Mat2x3 t) = hostShareable t+hostShareable (Mat2x4 t) = hostShareable t+hostShareable (Mat3x2 t) = hostShareable t+hostShareable (Mat3x3 t) = hostShareable t+hostShareable (Mat3x4 t) = hostShareable t+hostShareable (Mat4x2 t) = hostShareable t+hostShareable (Mat4x3 t) = hostShareable t+hostShareable (Mat4x4 t) = hostShareable t+hostShareable (Atomic _) = True+-- A fixed-size array is host-shareable only if it has a creation-fixed+-- footprint, so its element count must be a literal.  A runtime-sized array+-- has no count at all.+hostShareable (Array t Nothing) = hostShareable t+hostShareable (Array t (Just (ExpInt _ _))) = hostShareable t+hostShareable Array {} = False+hostShareable Ptr {} = False+hostShareable (Named _) = False+hostShareable TextureSampled {} = False+hostShareable (TextureMultisampled _) = False+hostShareable TextureExternal = False+hostShareable TextureStorage {} = False+hostShareable (TextureDepth _) = False+hostShareable Sampler = False+hostShareable SamplerComparison = False++-- | @AlignOfMember@ of a structure member.  'Nothing' if its @\@align@+-- argument is not a literal.  See+-- https://www.w3.org/TR/WGSL/#structure-member-layout.+alignOfMember :: StructMember -> Maybe Int+alignOfMember (StructMember attribs _ t) =+  case [args | Attribute name args <- attribs, name == "align"] of+    [] -> alignOf t+    [[ExpInt k _]] -> Just k+    _ -> Nothing++-- | @SizeOfMember@ of a structure member.  'Nothing' if its @\@size@+-- argument is not a literal.  See+-- https://www.w3.org/TR/WGSL/#structure-member-layout.+sizeOfMember :: StructMember -> Maybe Int+sizeOfMember (StructMember attribs _ t) =+  case [args | Attribute name args <- attribs, name == "size"] of+    [] -> sizeOf t+    [[ExpInt k _]] -> Just k+    _ -> Nothing++-- | @AlignOf@ of a structure with the given members.  'Nothing' if there are+-- no members.  See https://www.w3.org/TR/WGSL/#structure-member-layout.+alignOfStruct :: [StructMember] -> Maybe Int+alignOfStruct [] = Nothing+alignOfStruct members = maximum <$> mapM alignOfMember members++-- | @OffsetOfMember@ of every member of a structure, which is known even when+-- the structure has no @SizeOf@.  See+-- https://www.w3.org/TR/WGSL/#structure-member-layout.+offsetOfMembers :: [StructMember] -> Maybe [Int]+offsetOfMembers [] = Nothing+offsetOfMembers members = do+  aligns <- mapM alignOfMember $ drop 1 members+  sizes <- mapM sizeOfMember $ init members+  pure $+    scanl+      (\prev_off (al, prev_sz) -> roundUp al (prev_off + prev_sz))+      0+      (zip aligns sizes)++-- | @SizeOf@ of a structure with the given members.  'Nothing' if any member+-- has no @SizeOfMember@.  See+-- https://www.w3.org/TR/WGSL/#structure-member-layout.+sizeOfStruct :: [StructMember] -> Maybe Int+sizeOfStruct members = do+  struct_align <- alignOfStruct members+  offsets <- offsetOfMembers members+  last_size <- sizeOfMember $ last members+  pure $ roundUp struct_align (last offsets + last_size)++-- | A binary operator. See https://www.w3.org/TR/WGSL/#expressions.+data BinaryOperator+  = Add+  | Subtract+  | Multiply+  | Divide+  | Remainder+  | BitwiseAnd+  | BitwiseOr+  | BitwiseExclusiveOr+  | ShiftLeft+  | ShiftRight+  | Less+  | LessEqual+  | Greater+  | GreaterEqual+  | Equal+  | NotEqual+  | ShortCircuitAnd+  | ShortCircuitOr+  deriving (Eq, Ord, Show)++-- | A unary operator.  See https://www.w3.org/TR/WGSL/#expressions.+data UnaryOperator+  = Negate+  | LogicalNegate+  | BitwiseComplement+  | Indirection+  | AddressOf+  deriving (Eq, Ord, Show)++-- | The type denoted by an integer literal, which is determined by its+-- suffix.  See https://www.w3.org/TR/WGSL/#numeric-literals.+data IntLiteralType+  = -- | No suffix.+    AbstractInt+  | -- | The @i@ suffix.+    LitI32+  | -- | The @u@ suffix.+    LitU32+  deriving (Eq, Ord, Show)++-- | The type denoted by a floating point literal, which is determined by its+-- suffix.  See https://www.w3.org/TR/WGSL/#numeric-literals.+data FloatLiteralType+  = -- | No suffix.+    AbstractFloat+  | -- | The @f@ suffix.+    LitF32+  | -- | The @h@ suffix.  Using it requires the @enable f16;@ directive.+    LitF16+  deriving (Eq, Ord, Show)++-- | An expression.  See https://www.w3.org/TR/WGSL/#expressions.+data Expression+  = ExpBool Bool+  | -- | An integer literal.  Prefer 'intExp', which checks that the value can+    -- be denoted by a literal of the given type.+    ExpInt Int IntLiteralType+  | -- | A floating point literal.  Prefer 'floatExp'.+    ExpFloat Double FloatLiteralType+  | ExpIdent Ident+  | ExpBinary BinaryOperator Expression Expression+  | ExpUnary UnaryOperator Expression+  | -- | A call.  The first list is the callee's template arguments, as in+    -- @bitcast<i32>(x)@.+    ExpCall Ident [Expression] [Expression]+  | -- | A type in expression position, as a template argument is.+    ExpType Type+  | ExpIndex Expression Expression+  | ExpMember Expression Ident+  deriving (Eq, Ord, Show)++-- | A statement.  See https://www.w3.org/TR/WGSL/#statements.+data Statement+  = -- | The empty statement.+    Empty+  | -- | A line comment, which is not a statement in WGSL, but is useful in+    -- generated code.  May contain linebreaks.+    Comment T.Text+  | Compound [Statement]+  | -- | @let x = e@, with an optional type.+    Let Ident (Maybe Type) Expression+  | -- | @const x = e@, with an optional type.+    Const Ident (Maybe Type) Expression+  | -- | @var x : T = e@.+    Var Ident (Maybe Type) (Maybe Expression)+  | Assign Expression AssignmentOperator Expression+  | -- | @_ = e@.+    PhonyAssign Expression+  | Increment Expression+  | Decrement Expression+  | -- | @const_assert e@.  'GlobalAssert' is its module-scope counterpart.+    ConstAssert Expression+  | -- | An @if@, its @else if@ clauses, and its optional @else@ clause.+    If Expression [Statement] [(Expression, [Statement])] (Maybe [Statement])+  | Switch Expression (NonEmpty SwitchClause)+  | -- | A @loop@, with its optional @continuing@ block.+    Loop [Statement] (Maybe Continuing)+  | For Ident Expression Expression ForUpdate [Statement]+  | While Expression [Statement]+  | Break+  | Continue+  | Discard+  | Call Ident [Expression] [Expression]+  | Return (Maybe Expression)+  deriving (Eq, Ord, Show)++-- | A clause of a @switch@ statement.  See+-- https://www.w3.org/TR/WGSL/#switch-statement.+data SwitchClause+  = -- | A @case@ with one or more selectors.+    Case (NonEmpty CaseSelector) [Statement]+  | -- | A @default@ clause on its own.+    DefaultCase [Statement]+  deriving (Eq, Ord, Show)++-- | A selector of a @case@ clause.  See+-- https://www.w3.org/TR/WGSL/#switch-statement.+data CaseSelector+  = CaseExp Expression+  | CaseDefault+  deriving (Eq, Ord, Show)++-- | The @continuing@ block of a @loop@, which may end in a @break if@.  See+-- https://www.w3.org/TR/WGSL/#continuing-statement.+data Continuing = Continuing [Statement] (Maybe Expression)+  deriving (Eq, Ord, Show)++-- | The operator of an assignment: plain assignment, or one of the compound+-- assignment operators.  See https://www.w3.org/TR/WGSL/#assignment.+data AssignmentOperator+  = AssignSimple+  | AssignAdd+  | AssignSubtract+  | AssignMultiply+  | AssignDivide+  | AssignRemainder+  | AssignBitwiseAnd+  | AssignBitwiseOr+  | AssignBitwiseExclusiveOr+  | AssignShiftLeft+  | AssignShiftRight+  deriving (Eq, Ord, Show)++-- | The update of a @for@ loop, which the grammar restricts to the statements+-- that update a variable, or to a function call. These mirror the+-- correspondingly named statements. See+-- https://www.w3.org/TR/WGSL/#for-statement.+data ForUpdate+  = -- | The left-hand side must be an assignable expression.+    UpdateAssign Expression AssignmentOperator Expression+  | UpdatePhonyAssign Expression+  | UpdateIncrement Expression+  | UpdateDecrement Expression+  | UpdateCall Ident [Expression] [Expression]+  deriving (Eq, Ord, Show)++-- | An attribute.  See https://www.w3.org/TR/WGSL/#attributes.+data Attribute = Attribute Ident [Expression]+  deriving (Eq, Ord, Show)++-- | A formal parameter of a function.  See+-- https://www.w3.org/TR/WGSL/#function-declaration-sec.+data Param = Param [Attribute] Ident Type+  deriving (Eq, Ord, Show)++-- | A function declaration.  See+-- https://www.w3.org/TR/WGSL/#function-declaration-sec.+data FunctionDecl = FunctionDecl+  { functionName :: Ident,+    functionAttributes :: [Attribute],+    functionParams :: [Param],+    functionReturn :: Maybe ([Attribute], Type),+    functionBody :: [Statement]+  }+  deriving (Eq, Ord, Show)++-- | A structure member.  See https://www.w3.org/TR/WGSL/#struct-types.+data StructMember = StructMember [Attribute] Ident Type+  deriving (Eq, Ord, Show)++-- | A structure declaration.  See+-- https://www.w3.org/TR/WGSL/#struct-types.+data StructDecl = StructDecl Ident [StructMember]+  deriving (Eq, Ord, Show)++-- | The access modes supported by a memory view.  See+-- https://www.w3.org/TR/WGSL/#memory-access-mode.+data AccessMode = Read | Write | ReadWrite+  deriving (Eq, Ord, Show)++-- | An address space.  The @handle@ space is never written in WGSL source, so+-- it is not represented.  See https://www.w3.org/TR/WGSL/#address-spaces.+data AddressSpace+  = Function+  | Private+  | Workgroup+  | Uniform+  | Storage+  | Immediate+  deriving (Eq, Ord, Show)++-- | A module-scope declaration.  See+-- https://www.w3.org/TR/WGSL/#module-scope-declarations.+data GlobalDecl+  = GlobalFunction FunctionDecl+  | GlobalStruct StructDecl+  | -- | The access mode may only be given along with the address space, and+    -- defaults to the one of the address space when omitted.+    GlobalVariable [Attribute] AddressSpace (Maybe AccessMode) Ident (Maybe Type) (Maybe Expression)+  | GlobalOverride [Attribute] Ident (Maybe Type) (Maybe Expression)+  | -- | A module-scope @const@, which takes no attributes.+    GlobalConst Ident (Maybe Type) Expression+  | -- | A type alias.+    GlobalAlias Ident Type+  | -- | A module-scope @const_assert@.+    GlobalAssert Expression+  deriving (Eq, Ord, Show)++-- | A WGSL module: its directives, then its declarations.  See+-- https://www.w3.org/TR/WGSL/#wgsl-module-definition.+data Module = Module [Directive] [GlobalDecl]+  deriving (Eq, Ord, Show)++-- | A directive.  See https://www.w3.org/TR/WGSL/#directives.+data Directive+  = Enable (NonEmpty EnableExtension)+  | Requires (NonEmpty LanguageExtension)+  | -- | A diagnostic filter.  Rule names are not a closed set, so the rule is+    -- given as an identifier.+    Diagnostic Severity Ident+  deriving (Eq, Ord, Show)++-- | The severity of a diagnostic.  See+-- https://www.w3.org/TR/WGSL/#diagnostics.+data Severity = Error | Warning | Info | Off+  deriving (Eq, Ord, Show)++-- | An extension that an @enable@ directive may enable.  See+-- https://www.w3.org/TR/WGSL/#enable-extensions.+data EnableExtension+  = EnableF16+  | EnableClipDistances+  | EnableDualSourceBlending+  | EnableSubgroups+  | EnablePrimitiveIndex+  | EnableSubgroupSizeControl+  deriving (Eq, Ord, Show)++-- | A language extension that a @requires@ directive may require.  See+-- https://www.w3.org/TR/WGSL/#language-extensions.+data LanguageExtension+  = ReadonlyAndReadwriteStorageTextures+  | Packed4x8IntegerDotProduct+  | UnrestrictedPointerParameters+  | PointerCompositeAccess+  | UniformBufferStandardLayout+  | SubgroupId+  | SubgroupUniformity+  | TextureAndSamplerLet+  | TextureFormatsTier1+  | LinearIndexing+  | ImmediateAddressSpace+  | FragmentDepth+  | BufferView+  | SwizzleAssignment+  deriving (Eq, Ord, Show)++-- | The @\@group@ and @\@binding@ attributes for the given group and+-- binding.+bindingAttribs :: Int -> Int -> [Attribute]+bindingAttribs grp binding =+  [ Attribute "group" [ExpInt grp AbstractInt],+    Attribute "binding" [ExpInt binding AbstractInt]+  ]++-- | Construct an integer literal, or 'Nothing' if the value cannot be denoted+-- by a literal of the given type.+intExp :: Int -> IntLiteralType -> Maybe Expression+intExp v t+  | representable = Just $ ExpInt v t+  | otherwise = Nothing+  where+    representable = case t of+      AbstractInt -> magnitude <= 2 ^ (63 :: Int) - 1+      LitI32 -> magnitude <= 2 ^ (31 :: Int) - 1+      LitU32 -> toInteger v >= 0 && toInteger v <= 2 ^ (32 :: Int) - 1+    magnitude = abs $ toInteger v++-- | Construct a floating point literal, or 'Nothing' if the value cannot be+-- denoted by a literal of the given type.+floatExp :: Double -> FloatLiteralType -> Maybe Expression+floatExp v t+  | isNaN v || isInfinite v = Nothing+  | maybe False (abs v >) largestFinite = Nothing+  | otherwise = Just $ ExpFloat v t+  where+    largestFinite = case t of+      -- Any finite Double denotes an AbstractFloat.+      AbstractFloat -> Nothing+      LitF32 -> Just 3.40282346638528859812e38+      LitF16 -> Just 65504++-- | Reinterpret the bits of an expression as another type.  See+-- https://www.w3.org/TR/WGSL/#bitcast-builtin.+bitcast :: Type -> Expression -> Expression+bitcast t e = ExpCall "bitcast" [ExpType t] [e]++-- | A template argument list, which is omitted when empty.+templateArgs :: [Doc a] -> Doc a+templateArgs [] = mempty+templateArgs args = "<" <> commasep args <> ">"++templateList :: [Expression] -> Doc a+templateList = templateArgs . map pretty++-- | Separate with commas.+commasep :: [Doc a] -> Doc a+commasep = hsep . punctuate comma++-- | Like commasep, but a newline after every comma.+commastack :: [Doc a] -> Doc a+commastack = align . vsep . punctuate comma++-- | Separate with semicolons and newlines.+-- | Separate with linebreaks.+stack :: [Doc a] -> Doc a+stack = align . mconcat . punctuate line++(</>) :: Doc a -> Doc a -> Doc a+a </> b = a <> line <> b++instance Pretty Type where+  pretty Bool = "bool"+  pretty I32 = "i32"+  pretty U32 = "u32"+  pretty F16 = "f16"+  pretty F32 = "f32"+  pretty (Vec2 t) = generator "vec2" [pretty t]+  pretty (Vec3 t) = generator "vec3" [pretty t]+  pretty (Vec4 t) = generator "vec4" [pretty t]+  pretty (Mat2x2 t) = generator "mat2x2" [pretty t]+  pretty (Mat2x3 t) = generator "mat2x3" [pretty t]+  pretty (Mat2x4 t) = generator "mat2x4" [pretty t]+  pretty (Mat3x2 t) = generator "mat3x2" [pretty t]+  pretty (Mat3x3 t) = generator "mat3x3" [pretty t]+  pretty (Mat3x4 t) = generator "mat3x4" [pretty t]+  pretty (Mat4x2 t) = generator "mat4x2" [pretty t]+  pretty (Mat4x3 t) = generator "mat4x3" [pretty t]+  pretty (Mat4x4 t) = generator "mat4x4" [pretty t]+  pretty (Atomic t) = generator "atomic" [pretty t]+  pretty (Array t Nothing) = generator "array" [pretty t]+  pretty (Array t (Just n)) = generator "array" [pretty t, pretty n]+  pretty (Ptr t as am) =+    generator "ptr" $ [pretty as, pretty t] ++ maybe [] (pure . pretty) am+  pretty (Named t) = pretty t+  pretty (TextureSampled dim t) = generator (textureDim dim) [pretty t]+  pretty (TextureMultisampled t) =+    generator "texture_multisampled_2d" [pretty t]+  pretty TextureExternal = "texture_external"+  pretty (TextureStorage dim fmt am) =+    generator (storageTextureDim dim) [pretty fmt, pretty am]+  pretty (TextureDepth d) = pretty d+  pretty Sampler = "sampler"+  pretty SamplerComparison = "sampler_comparison"++-- | The name of the sampled texture type-generator for a dimensionality.+textureDim :: TextureDim -> Ident+textureDim Tex1d = "texture_1d"+textureDim Tex2d = "texture_2d"+textureDim Tex2dArray = "texture_2d_array"+textureDim Tex3d = "texture_3d"+textureDim TexCube = "texture_cube"+textureDim TexCubeArray = "texture_cube_array"++-- | The name of the storage texture type-generator for a dimensionality.+storageTextureDim :: StorageTextureDim -> Ident+storageTextureDim StorageTex1d = "texture_storage_1d"+storageTextureDim StorageTex2d = "texture_storage_2d"+storageTextureDim StorageTex2dArray = "texture_storage_2d_array"+storageTextureDim StorageTex3d = "texture_storage_3d"++instance Pretty DepthTexture where+  pretty Depth2d = "texture_depth_2d"+  pretty Depth2dArray = "texture_depth_2d_array"+  pretty DepthCube = "texture_depth_cube"+  pretty DepthCubeArray = "texture_depth_cube_array"+  pretty DepthMultisampled2d = "texture_depth_multisampled_2d"++instance Pretty TexelFormat where+  pretty Rgba8Unorm = "rgba8unorm"+  pretty Rgba8Snorm = "rgba8snorm"+  pretty Rgba8Uint = "rgba8uint"+  pretty Rgba8Sint = "rgba8sint"+  pretty Rgba16Unorm = "rgba16unorm"+  pretty Rgba16Snorm = "rgba16snorm"+  pretty Rgba16Uint = "rgba16uint"+  pretty Rgba16Sint = "rgba16sint"+  pretty Rgba16Float = "rgba16float"+  pretty Rg8Unorm = "rg8unorm"+  pretty Rg8Snorm = "rg8snorm"+  pretty Rg8Uint = "rg8uint"+  pretty Rg8Sint = "rg8sint"+  pretty Rg16Unorm = "rg16unorm"+  pretty Rg16Snorm = "rg16snorm"+  pretty Rg16Uint = "rg16uint"+  pretty Rg16Sint = "rg16sint"+  pretty Rg16Float = "rg16float"+  pretty R32Uint = "r32uint"+  pretty R32Sint = "r32sint"+  pretty R32Float = "r32float"+  pretty Rg32Uint = "rg32uint"+  pretty Rg32Sint = "rg32sint"+  pretty Rg32Float = "rg32float"+  pretty Rgba32Uint = "rgba32uint"+  pretty Rgba32Sint = "rgba32sint"+  pretty Rgba32Float = "rgba32float"+  pretty Bgra8Unorm = "bgra8unorm"+  pretty R8Unorm = "r8unorm"+  pretty R8Snorm = "r8snorm"+  pretty R8Uint = "r8uint"+  pretty R8Sint = "r8sint"+  pretty R16Unorm = "r16unorm"+  pretty R16Snorm = "r16snorm"+  pretty R16Uint = "r16uint"+  pretty R16Sint = "r16sint"+  pretty R16Float = "r16float"+  pretty Rgb10a2Unorm = "rgb10a2unorm"+  pretty Rgb10a2Uint = "rgb10a2uint"+  pretty Rg11b10Ufloat = "rg11b10ufloat"++-- | A predeclared type-generator applied to its template arguments.+generator :: Ident -> [Doc a] -> Doc a+generator name args = pretty name <> templateArgs args++intSuffix :: IntLiteralType -> Doc a+intSuffix AbstractInt = mempty+intSuffix LitI32 = "i"+intSuffix LitU32 = "u"++floatSuffix :: FloatLiteralType -> Doc a+floatSuffix AbstractFloat = mempty+floatSuffix LitF32 = "f"+floatSuffix LitF16 = "h"++instance Pretty BinaryOperator where+  pretty Add = "+"+  pretty Subtract = "-"+  pretty Multiply = "*"+  pretty Divide = "/"+  pretty Remainder = "%"+  pretty BitwiseAnd = "&"+  pretty BitwiseOr = "|"+  pretty BitwiseExclusiveOr = "^"+  pretty ShiftLeft = "<<"+  pretty ShiftRight = ">>"+  pretty Less = "<"+  pretty LessEqual = "<="+  pretty Greater = ">"+  pretty GreaterEqual = ">="+  pretty Equal = "=="+  pretty NotEqual = "!="+  pretty ShortCircuitAnd = "&&"+  pretty ShortCircuitOr = "||"++instance Pretty UnaryOperator where+  pretty Negate = "-"+  pretty LogicalNegate = "!"+  pretty BitwiseComplement = "~"+  pretty Indirection = "*"+  pretty AddressOf = "&"++instance Pretty Expression where+  pretty (ExpBool True) = "true"+  pretty (ExpBool False) = "false"+  pretty (ExpInt x t) = pretty x <> intSuffix t+  pretty (ExpFloat x t) = pretty x <> floatSuffix t+  pretty (ExpIdent x) = pretty x+  pretty (ExpUnary op e) = parens (pretty op <> pretty e)+  pretty (ExpBinary op e1 e2) = parens (pretty e1 <+> pretty op <+> pretty e2)+  pretty (ExpCall f targs args) =+    pretty f <> templateList targs <> parens (commasep $ map pretty args)+  pretty (ExpType t) = pretty t+  pretty (ExpIndex e i) = pretty e <> brackets (pretty i)+  pretty (ExpMember x y) = pretty x <> "." <> pretty y++instance Pretty Statement where+  pretty Empty = ";"+  pretty (Comment c) = vsep (map ("//" <+>) (pretty <$> T.lines c))+  pretty (Compound body) = block body+  pretty (Let x t e) =+    "let" <+> optionallyTyped x t <+> "=" <+> pretty e <> ";"+  pretty (Const x t e) =+    "const" <+> optionallyTyped x t <+> "=" <+> pretty e <> ";"+  pretty (Var x t e) =+    "var" <+> optionallyTyped x t <> prettyInit e <> ";"+  pretty (Assign lhs op e) = pretty lhs <+> pretty op <+> pretty e <> ";"+  pretty (PhonyAssign e) = "_" <+> "=" <+> pretty e <> ";"+  pretty (Increment e) = pretty e <> "++;"+  pretty (Decrement e) = pretty e <> "--;"+  pretty (ConstAssert e) = "const_assert" <+> pretty e <> ";"+  pretty (If cond th elifs el) =+    hsep $+      ["if" <+> pretty cond <+> block th]+        ++ map elseIf elifs+        ++ maybe [] (\body -> ["else" <+> block body]) el+    where+      elseIf (c, body) = "else if" <+> pretty c <+> block body+  pretty (Switch e clauses) =+    "switch" <+> pretty e <+> braceBlock (map pretty (NE.toList clauses))+  pretty (Loop body continuing) =+    "loop"+      <+> braceBlock (map pretty body ++ maybe [] (pure . pretty) continuing)+  pretty (For x initializer cond upd body) =+    "for"+      <+> parens+        ( "var"+            <+> pretty x+            <+> "="+            <+> pretty initializer+            <> ";"+            <+> pretty cond+            <> ";"+            <+> pretty upd+        )+      <+> block body+  pretty (While cond body) = "while" <+> pretty cond <+> block body+  pretty (Call f targs args) =+    pretty f <> templateList targs <> parens (commasep $ map pretty args) <> ";"+  pretty (Return Nothing) = "return;"+  pretty (Return (Just e)) = "return" <+> pretty e <> ";"+  pretty Break = "break;"+  pretty Continue = "continue;"+  pretty Discard = "discard;"++instance Pretty SwitchClause where+  pretty (Case selectors body) =+    "case"+      <+> commasep (map pretty (NE.toList selectors))+      <> ":"+      <+> block body+  pretty (DefaultCase body) = "default:" <+> block body++instance Pretty CaseSelector where+  pretty (CaseExp e) = pretty e+  pretty CaseDefault = "default"++instance Pretty Continuing where+  pretty (Continuing body breakIf) =+    "continuing"+      <+> braceBlock+        ( map pretty body+            ++ maybe [] (\e -> ["break if" <+> pretty e <> ";"]) breakIf+        )++-- | A brace-enclosed statement sequence, as every block in WGSL is.  See+-- https://www.w3.org/TR/WGSL/#compound-statement-section.+block :: [Statement] -> Doc a+block = braceBlock . map pretty++-- | An @optionally_typed_ident@.+optionallyTyped :: Ident -> Maybe Type -> Doc a+optionallyTyped x t = pretty x <> maybe mempty ((" :" <+>) . pretty) t++-- | An optional initialiser.+prettyInit :: Maybe Expression -> Doc a+prettyInit = maybe mempty ((" =" <+>) . pretty)++instance Pretty AssignmentOperator where+  pretty AssignSimple = "="+  pretty AssignAdd = "+="+  pretty AssignSubtract = "-="+  pretty AssignMultiply = "*="+  pretty AssignDivide = "/="+  pretty AssignRemainder = "%="+  pretty AssignBitwiseAnd = "&="+  pretty AssignBitwiseOr = "|="+  pretty AssignBitwiseExclusiveOr = "^="+  pretty AssignShiftLeft = "<<="+  pretty AssignShiftRight = ">>="++-- | A brace-enclosed, indented sequence.+braceBlock :: [Doc a] -> Doc a+braceBlock [] = "{ }"+braceBlock docs = "{" </> indent 2 (stack docs) </> "}"++instance Pretty ForUpdate where+  pretty (UpdateAssign lhs op e) = pretty lhs <+> pretty op <+> pretty e+  pretty (UpdatePhonyAssign e) = "_" <+> "=" <+> pretty e+  pretty (UpdateIncrement e) = pretty e <> "++"+  pretty (UpdateDecrement e) = pretty e <> "--"+  pretty (UpdateCall f targs args) =+    pretty f <> templateList targs <> parens (commasep $ map pretty args)++instance Pretty Attribute where+  pretty (Attribute name []) = "@" <> pretty name+  pretty (Attribute name args) =+    "@" <> pretty name <> parens (commasep $ map pretty args)++instance Pretty Param where+  pretty (Param attribs name typ) =+    hsep $ map pretty attribs ++ [pretty name <+> ":" <+> pretty typ]++prettyParams :: [Param] -> Doc a+prettyParams [] = "()"+prettyParams params = "(" </> indent 2 (commastack (map pretty params)) </> ")"++instance Pretty FunctionDecl where+  pretty (FunctionDecl name attribs params ret body) =+    prettyAttribs attribs <> header <+> block body+    where+      header = case ret of+        Nothing -> "fn" <+> pretty name <> prettyParams params+        Just (ret_attribs, t) ->+          "fn"+            <+> pretty name+            <> prettyParams params+            <+> "->"+            <+> hsep (map pretty ret_attribs ++ [pretty t])++-- | Attributes, followed by a line break if there are any at all.+prettyAttribs :: [Attribute] -> Doc a+prettyAttribs [] = mempty+prettyAttribs attribs = hsep (map pretty attribs) <> line++instance Pretty StructMember where+  pretty (StructMember attribs name typ) =+    hsep $ map pretty attribs ++ [pretty name <+> ":" <+> pretty typ]++instance Pretty StructDecl where+  pretty (StructDecl name fields) =+    "struct"+      <+> pretty name+      <+> "{"+        </> indent 2 (commastack (map pretty fields))+        </> "}"++instance Pretty AccessMode where+  pretty Read = "read"+  pretty Write = "write"+  pretty ReadWrite = "read_write"++instance Pretty AddressSpace where+  pretty Storage = "storage"+  pretty Private = "private"+  pretty Immediate = "immediate"+  pretty Uniform = "uniform"+  pretty Workgroup = "workgroup"+  pretty Function = "function"++instance Pretty Severity where+  pretty Error = "error"+  pretty Warning = "warning"+  pretty Info = "info"+  pretty Off = "off"++instance Pretty EnableExtension where+  pretty EnableF16 = "f16"+  pretty EnableClipDistances = "clip_distances"+  pretty EnableDualSourceBlending = "dual_source_blending"+  pretty EnableSubgroups = "subgroups"+  pretty EnablePrimitiveIndex = "primitive_index"+  pretty EnableSubgroupSizeControl = "subgroup_size_control"++instance Pretty LanguageExtension where+  pretty ReadonlyAndReadwriteStorageTextures =+    "readonly_and_readwrite_storage_textures"+  pretty Packed4x8IntegerDotProduct = "packed_4x8_integer_dot_product"+  pretty UnrestrictedPointerParameters = "unrestricted_pointer_parameters"+  pretty PointerCompositeAccess = "pointer_composite_access"+  pretty UniformBufferStandardLayout = "uniform_buffer_standard_layout"+  pretty SubgroupId = "subgroup_id"+  pretty SubgroupUniformity = "subgroup_uniformity"+  pretty TextureAndSamplerLet = "texture_and_sampler_let"+  pretty TextureFormatsTier1 = "texture_formats_tier1"+  pretty LinearIndexing = "linear_indexing"+  pretty ImmediateAddressSpace = "immediate_address_space"+  pretty FragmentDepth = "fragment_depth"+  pretty BufferView = "buffer_view"+  pretty SwizzleAssignment = "swizzle_assignment"++instance Pretty Directive where+  pretty (Enable exts) =+    "enable" <+> commasep (map pretty (NE.toList exts)) <> ";"+  pretty (Requires exts) =+    "requires" <+> commasep (map pretty (NE.toList exts)) <> ";"+  pretty (Diagnostic severity rule) =+    "diagnostic"+      <> parens (pretty severity <> "," <+> pretty rule)+      <> ";"++instance Pretty Module where+  pretty (Module directives decls) =+    stack $ map pretty directives ++ map pretty decls++instance Pretty GlobalDecl where+  pretty (GlobalFunction fun) = pretty fun+  pretty (GlobalStruct struct) = pretty struct+  pretty (GlobalVariable attribs as am name typ e) =+    prettyAttribs attribs+      <> "var<"+      <> pretty as+      <> maybe "" ((", " <>) . pretty) am+      <> ">"+      <+> optionallyTyped name typ+      <> prettyInit e+      <> ";"+  pretty (GlobalOverride attribs name typ e) =+    prettyAttribs attribs+      <> "override"+      <+> optionallyTyped name typ+      <> prettyInit e+      <> ";"+  pretty (GlobalConst name typ e) =+    "const" <+> optionallyTyped name typ <+> "=" <+> pretty e <> ";"+  pretty (GlobalAlias name t) =+    "alias" <+> pretty name <+> "=" <+> pretty t <> ";"+  pretty (GlobalAssert e) = "const_assert" <+> pretty e <> ";"

@@ -0,0 +1,1078 @@+module Main (main) where++import Data.List (nub)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text qualified as T+import Language.WGSL+import Prettyprinter (Pretty, defaultLayoutOptions, layoutPretty, pretty, vsep)+import Prettyprinter.Render.Text (renderStrict)+import Test.Tasty+import Test.Tasty.HUnit++-- | The offsets, alignment and size of a structure, which the tests check+-- together.+structLayout :: [Type] -> (Maybe [Int], Maybe Int, Maybe Int)+structLayout = structLayoutOf . map (StructMember [] "m")++-- | As 'structLayout', but for members given in full, so that they may carry+-- layout attributes.+structLayoutOf :: [StructMember] -> (Maybe [Int], Maybe Int, Maybe Int)+structLayoutOf fs = (offsetOfMembers fs, alignOfStruct fs, sizeOfStruct fs)++-- | The alignment and size of a type, which the tests check together.+layout :: Type -> Maybe (Int, Int)+layout t = (,) <$> alignOf t <*> sizeOf t++-- | A convenient literal for tests that only need some expression.+one, two :: Expression+one = ExpInt 1 AbstractInt+two = ExpInt 2 AbstractInt++-- | Render a statement sequence, as a code generator would.+renderBody :: [Statement] -> T.Text+renderBody =+  renderStrict . layoutPretty defaultLayoutOptions . vsep . map pretty++-- | Render an AST fragment as a code generator would.+render :: (Pretty a) => a -> T.Text+render = renderStrict . layoutPretty defaultLayoutOptions . pretty++-- | A pointer type is spelled @ptr<AS,T,AM>@, where the access mode is+-- optional.  See https://www.w3.org/TR/WGSL/#ref-ptr-types.+pointerTests :: TestTree+pointerTests =+  testGroup+    "Ptr"+    [ testCase "without access mode" $+        render (Ptr I32 Function Nothing)+          @?= "ptr<function, i32>",+      testCase "with access mode" $+        render (Ptr I32 Function (Just ReadWrite))+          @?= "ptr<function, i32, read_write>",+      testCase "uniform" $+        render (Ptr F32 Uniform Nothing)+          @?= "ptr<uniform, f32>",+      testCase "vector store type" $+        render (Ptr (Vec3 F32) Workgroup (Just Read))+          @?= "ptr<workgroup, vec3<f32>, read>",+      testCase "storage" $+        render (Ptr I32 Storage (Just Read))+          @?= "ptr<storage, i32, read>"+    ]++-- | An access mode is a predeclared enumerant.  See+-- https://www.w3.org/TR/WGSL/#memory-access-mode.+accessModeTests :: TestTree+accessModeTests =+  testGroup+    "AccessMode"+    [ testCase "read" $ render Read @?= "read",+      testCase "write" $ render Write @?= "write",+      testCase "read_write" $ render ReadWrite @?= "read_write"+    ]++-- | The address space of a module-scope variable is given as a template list+-- after the @var@ keyword, with the access mode second if present.  See+-- https://www.w3.org/TR/WGSL/#var-decls.+globalVarTests :: TestTree+globalVarTests =+  testGroup+    "GlobalVariable"+    [ testCase "without access mode" $+        render (GlobalVariable [] Workgroup Nothing "x" (Just I32) Nothing)+          @?= "var<workgroup> x : i32;",+      testCase "with access mode" $+        render (GlobalVariable [] Storage (Just ReadWrite) "x" (Just (Array I32 Nothing)) Nothing)+          @?= "var<storage, read_write> x : array<i32>;",+      testCase "private" $+        render (GlobalVariable [] Private Nothing "x" (Just F32) Nothing)+          @?= "var<private> x : f32;",+      testCase "immediate" $+        render (GlobalVariable [] Immediate Nothing "x" (Just (Named "S")) Nothing)+          @?= "var<immediate> x : S;",+      testCase "with attributes" $+        render (GlobalVariable (bindingAttribs 0 1) Storage (Just Read) "x" (Just (Array F32 Nothing)) Nothing)+          @?= "@group(0) @binding(1)\nvar<storage, read> x : array<f32>;"+    ]++-- | A literal is never negative, and its suffix fixes its type.  See+-- https://www.w3.org/TR/WGSL/#numeric-literals.+intLitTests :: TestTree+intLitTests =+  testGroup+    "intExp"+    [ testCase "no suffix" $+        fmap render (intExp 5 AbstractInt) @?= Just "5",+      testCase "i suffix" $+        fmap render (intExp 5 LitI32) @?= Just "5i",+      testCase "u suffix" $+        fmap render (intExp 5 LitU32) @?= Just "5u",+      testCase "negated literal" $+        fmap render (intExp (-5) LitI32) @?= Just "-5i",+      testCase "largest i32" $+        fmap render (intExp 2147483647 LitI32) @?= Just "2147483647i",+      testCase "i32 overflow" $+        fmap render (intExp 2147483648 LitI32) @?= Nothing,+      -- The literal is 2147483648, which i32 cannot represent, even though+      -- the negated value can be.+      testCase "most negative i32" $+        fmap render (intExp (-2147483648) LitI32) @?= Nothing,+      testCase "largest u32" $+        fmap render (intExp 4294967295 LitU32) @?= Just "4294967295u",+      testCase "u32 overflow" $+        fmap render (intExp 4294967296 LitU32) @?= Nothing,+      testCase "negative u32" $+        fmap render (intExp (-1) LitU32) @?= Nothing,+      testCase "largest Nothing" $+        fmap render (intExp maxBound AbstractInt) @?= Just "9223372036854775807",+      testCase "Nothing overflow" $+        fmap render (intExp minBound AbstractInt) @?= Nothing+    ]++-- | WGSL has no literal for infinities or NaN, and the magnitude of a literal+-- must not exceed the largest finite value of its type.  See+-- https://www.w3.org/TR/WGSL/#floating-point-types.+floatLitTests :: TestTree+floatLitTests =+  testGroup+    "floatExp"+    [ testCase "no suffix" $+        fmap render (floatExp 1.5 AbstractFloat) @?= Just "1.5",+      testCase "f suffix" $+        fmap render (floatExp 1.5 LitF32) @?= Just "1.5f",+      testCase "h suffix" $+        fmap render (floatExp 1.5 LitF16) @?= Just "1.5h",+      testCase "negated literal" $+        fmap render (floatExp (-1.5) LitF32) @?= Just "-1.5f",+      testCase "exponent" $+        fmap render (floatExp 1.0e-2 LitF32) @?= Just "1.0e-2f",+      testCase "infinity" $+        fmap render (floatExp (1 / 0) AbstractFloat) @?= Nothing,+      testCase "negative infinity" $+        fmap render (floatExp (-1 / 0) LitF32) @?= Nothing,+      testCase "NaN" $+        fmap render (floatExp (0 / 0) LitF32) @?= Nothing,+      testCase "largest f32" $+        fmap render (floatExp 3.40282346638528859812e38 LitF32)+          @?= Just "3.4028234663852886e38f",+      testCase "f32 overflow" $+        fmap render (floatExp 1.0e300 LitF32) @?= Nothing,+      testCase "f64 magnitude is an Nothing" $+        fmap render (floatExp 1.0e300 AbstractFloat) @?= Just "1.0e300",+      testCase "largest f16" $+        fmap render (floatExp 65504 LitF16) @?= Just "65504.0h",+      testCase "f16 overflow" $+        fmap render (floatExp 65505 LitF16) @?= Nothing+    ]++-- | An assignment's left-hand side is an assignable expression.  See+-- https://www.w3.org/TR/WGSL/#assignment.+assignTests :: TestTree+assignTests =+  testGroup+    "Assign"+    [ testCase "variable" $+        render (Assign (ExpIdent "x") AssignSimple (ExpIdent "y")) @?= "x = y;",+      testCase "dereference" $+        render (Assign (ExpUnary Indirection (ExpIdent "p")) AssignSimple (ExpIdent "x")) @?= "(*p) = x;",+      testCase "index" $+        render (Assign (ExpIndex (ExpIdent "a") (ExpInt 0 AbstractInt)) AssignSimple (ExpInt 1 AbstractInt))+          @?= "a[0] = 1;",+      testCase "member" $+        render (Assign (ExpMember (ExpIdent "s") "f") AssignSimple (ExpIdent "y")) @?= "s.f = y;"+    ]++-- | A return statement supplies a value exactly when the enclosing function+-- has a return type.  See https://www.w3.org/TR/WGSL/#return-statement.+returnTests :: TestTree+returnTests =+  testGroup+    "Return"+    [ testCase "without value" $+        render (Return Nothing) @?= "return;",+      testCase "with value" $+        render (Return (Just (ExpIdent "x"))) @?= "return x;"+    ]++-- | A function declaration has at most one return type, which may carry+-- attributes.  See https://www.w3.org/TR/WGSL/#function-declaration-sec.+funDeclTests :: TestTree+funDeclTests =+  testGroup+    "FunctionDecl"+    [ testCase "without return type" $+        render (FunctionDecl "f" [] [Param [] "a" I32] Nothing [Call "g" [] [ExpIdent "a"]])+          @?= "fn f(\n  a : i32\n) {\n  g(a);\n}",+      testCase "with return type" $+        render+          (FunctionDecl "f" [] [] (Just ([], I32)) [Return (Just (ExpInt 1 AbstractInt))])+          @?= "fn f() -> i32 {\n  return 1;\n}",+      testCase "empty body" $+        render (FunctionDecl "f" [] [] Nothing []) @?= "fn f() { }",+      testCase "with return attributes" $+        render+          ( FunctionDecl+              "vs"+              [Attribute "vertex" []]+              []+              (Just ([Attribute "builtin" [ExpIdent "position"]], Vec4 F32))+              [Return (Just (ExpIdent "p"))]+          )+          @?= "@vertex\nfn vs() -> @builtin(position) vec4<f32> {\n  return p;\n}"+    ]++sequenceTests :: TestTree+sequenceTests =+  testGroup+    "sequences"+    [ testCase "semicolons" $+        renderBody [Call "f" [] [], Let "x" Nothing one, Call "g" [] []]+          @?= "f();\nlet x = 1;\ng();",+      -- The separator used to end up inside the comment.+      testCase "comment" $+        renderBody [Call "f" [] [], Comment "note", Call "g" [] []]+          @?= "f();\n// note\ng();",+      testCase "compound statement" $+        renderBody [If (ExpIdent "c") [Call "f" [] []] [] Nothing, Call "g" [] []]+          @?= "if c {\n  f();\n}\ng();",+      -- An empty body used to render as a stray empty statement.+      testCase "empty body" $+        render (While (ExpIdent "c") []) @?= "while c { }",+      testCase "empty statement" $+        render (While (ExpIdent "c") [Empty]) @?= "while c {\n  ;\n}",+      testCase "block introduces a scope" $+        render (Compound [Let "x" Nothing one]) @?= "{\n  let x = 1;\n}",+      -- An absent else clause is not the same as an empty one.+      testCase "absent else" $+        render (If (ExpIdent "c") [] [] Nothing) @?= "if c { }",+      testCase "empty else" $+        render (If (ExpIdent "c") [] [] (Just [])) @?= "if c { } else { }"+    ]++-- | A for loop's update is an assignment or a call. See+-- https://www.w3.org/TR/WGSL/#for-statement.+forTests :: TestTree+forTests =+  testGroup+    "For"+    [ testCase "assignment update" $+        render+          ( For+              "i"+              one+              (ExpBinary Less (ExpIdent "i") one)+              (UpdateAssign (ExpIdent "i") AssignSimple one)+              [Call "f" [] []]+          )+          @?= "for (var i = 1; (i < 1); i = 1) {\n  f();\n}",+      testCase "call update" $+        render (For "i" one (ExpIdent "c") (UpdateCall "step" [] [ExpIdent "i"]) [])+          @?= "for (var i = 1; c; step(i)) { }"+    ]++-- | A callee may carry a template argument list.  See+-- https://www.w3.org/TR/WGSL/#syntax-call_phrase.+callTests :: TestTree+callTests =+  testGroup+    "ExpCall"+    [ testCase "without template arguments" $+        render (ExpCall "f" [] [ExpIdent "x"]) @?= "f(x)",+      testCase "without arguments" $+        render (ExpCall "atomicLoad" [] []) @?= "atomicLoad()",+      testCase "with a type argument" $+        render (ExpCall "vec2" [ExpType F32] [one, one])+          @?= "vec2<f32>(1, 1)",+      testCase "bitcast" $+        render (bitcast I32 (ExpIdent "x")) @?= "bitcast<i32>(x)",+      -- The template argument list end is disambiguated by the grammar, so a+      -- nested list needs no space between the closing delimiters.+      testCase "nested template arguments" $+        render (bitcast (Vec2 F16) (ExpIdent "x"))+          @?= "bitcast<vec2<f16>>(x)"+    ]++-- | The alignment and size table.  See+-- https://www.w3.org/TR/WGSL/#alignment-and-size.+layoutTests :: TestTree+layoutTests =+  testGroup+    "alignOf and sizeOf"+    [ -- bool is not host-shareable, but it does have a fixed footprint.+      testCase "bool" $ layout Bool @?= Just (4, 4),+      testCase "i32" $ layout I32 @?= Just (4, 4),+      testCase "f16" $ layout F16 @?= Just (2, 2),+      testCase "atomic" $ layout (Atomic I32) @?= Just (4, 4),+      testCase "vec2<f32>" $ layout (Vec2 F32) @?= Just (8, 8),+      testCase "vec3<f32>" $ layout (Vec3 F32) @?= Just (16, 12),+      testCase "vec4<f32>" $ layout (Vec4 F32) @?= Just (16, 16),+      testCase "vec2<f16>" $ layout (Vec2 F16) @?= Just (4, 4),+      testCase "vec3<f16>" $ layout (Vec3 F16) @?= Just (8, 6),+      testCase "vec4<f16>" $ layout (Vec4 F16) @?= Just (8, 8),+      testCase "named type" $ layout (Named "S") @?= Nothing,+      testCase "pointer" $ layout (Ptr I32 Function Nothing) @?= Nothing,+      testCase "texture" $ layout (TextureSampled Tex2d F32) @?= Nothing,+      testCase "sampler" $ layout Sampler @?= Nothing+    ]++-- | Texture and sampler types are opaque: they have no layout, and are not+-- host-shareable.  There is no other way to spell them, so no type that does+-- have a layout can be mistaken for one.  See+-- https://www.w3.org/TR/WGSL/#texture-sampler-types.+opaqueTests :: TestTree+opaqueTests =+  testGroup+    "textures and samplers"+    [ testCase "no layout" $+        map layout opaques @?= map (const Nothing) opaques,+      testCase "not host-shareable" $+        filter hostShareable opaques @?= [],+      testCase "sampled" $+        map+          render+          [ TextureSampled Tex1d F32,+            TextureSampled Tex2d F32,+            TextureSampled Tex2dArray I32,+            TextureSampled Tex3d U32,+            TextureSampled TexCube F32,+            TextureSampled TexCubeArray U32+          ]+          @?= [ "texture_1d<f32>",+                "texture_2d<f32>",+                "texture_2d_array<i32>",+                "texture_3d<u32>",+                "texture_cube<f32>",+                "texture_cube_array<u32>"+              ],+      testCase "multisampled" $+        render (TextureMultisampled F32) @?= "texture_multisampled_2d<f32>",+      testCase "external" $ render TextureExternal @?= "texture_external",+      testCase "depth" $+        map+          render+          [ TextureDepth Depth2d,+            TextureDepth Depth2dArray,+            TextureDepth DepthCube,+            TextureDepth DepthCubeArray,+            TextureDepth DepthMultisampled2d+          ]+          @?= [ "texture_depth_2d",+                "texture_depth_2d_array",+                "texture_depth_cube",+                "texture_depth_cube_array",+                "texture_depth_multisampled_2d"+              ],+      testCase "storage" $+        map+          render+          [ TextureStorage StorageTex1d Rgba8Unorm Write,+            TextureStorage StorageTex2d R32Float Read,+            TextureStorage StorageTex2dArray Rgb10a2Uint ReadWrite,+            TextureStorage StorageTex3d Rg11b10Ufloat Write+          ]+          @?= [ "texture_storage_1d<rgba8unorm, write>",+                "texture_storage_2d<r32float, read>",+                "texture_storage_2d_array<rgb10a2uint, read_write>",+                "texture_storage_3d<rg11b10ufloat, write>"+              ],+      testCase "samplers" $+        map render [Sampler, SamplerComparison] @?= ["sampler", "sampler_comparison"]+    ]++-- | One of every texture and sampler family.+opaques :: [Type]+opaques =+  [ TextureSampled Tex2d F32,+    TextureMultisampled F32,+    TextureExternal,+    TextureStorage StorageTex2d Rgba8Unorm Write,+    TextureDepth Depth2d,+    Sampler,+    SamplerComparison+  ]++-- | A matrix is laid out as an array of its columns, so @matCxR@ has the+-- alignment of @vecR@ and the size of @array<vecR, C>@.  See+-- https://www.w3.org/TR/WGSL/#alignment-and-size.+matrixLayoutTests :: TestTree+matrixLayoutTests =+  testGroup+    "matrices"+    [ testCase "mat2x2<f32>" $ layout (Mat2x2 F32) @?= Just (8, 16),+      testCase "mat3x2<f32>" $ layout (Mat3x2 F32) @?= Just (8, 24),+      testCase "mat4x2<f32>" $ layout (Mat4x2 F32) @?= Just (8, 32),+      -- The columns are padded from 12 bytes to a stride of 16.+      testCase "mat2x3<f32>" $ layout (Mat2x3 F32) @?= Just (16, 32),+      testCase "mat3x3<f32>" $ layout (Mat3x3 F32) @?= Just (16, 48),+      testCase "mat4x3<f32>" $ layout (Mat4x3 F32) @?= Just (16, 64),+      testCase "mat2x4<f32>" $ layout (Mat2x4 F32) @?= Just (16, 32),+      testCase "mat3x4<f32>" $ layout (Mat3x4 F32) @?= Just (16, 48),+      testCase "mat4x4<f32>" $ layout (Mat4x4 F32) @?= Just (16, 64),+      testCase "mat2x2<f16>" $ layout (Mat2x2 F16) @?= Just (4, 8),+      testCase "mat4x2<f16>" $ layout (Mat4x2 F16) @?= Just (4, 16),+      testCase "mat2x3<f16>" $ layout (Mat2x3 F16) @?= Just (8, 16),+      testCase "mat4x3<f16>" $ layout (Mat4x3 F16) @?= Just (8, 32),+      testCase "mat4x4<f16>" $ layout (Mat4x4 F16) @?= Just (8, 32)+    ]++-- | At least one type of every shape, for properties that should hold of all+-- of them.+representativeTypes :: [Type]+representativeTypes =+  [Bool, I32, U32, F16, F32]+    ++ [Vec2 F32, Vec3 F32, Vec4 F32, Vec2 F16]+    ++ [ Mat2x2 F32,+         Mat2x3 F32,+         Mat2x4 F32,+         Mat3x2 F32,+         Mat3x3 F32,+         Mat3x4 F32,+         Mat4x2 F32,+         Mat4x3 F32,+         Mat4x4 F32,+         Mat2x2 F16+       ]+    ++ [Atomic I32, Atomic U32]+    ++ [ Array F32 Nothing,+         Array F32 (Just (ExpInt 8 AbstractInt)),+         Array F32 (Just (ExpInt 8 LitI32)),+         Array (Named "S") (Just (ExpInt 3 AbstractInt)),+         Array (Array F32 (Just (ExpInt 2 AbstractInt))) Nothing+       ]+    ++ [ Ptr I32 Function Nothing,+         Ptr I32 Function (Just ReadWrite),+         Ptr I32 Storage (Just Read),+         Ptr (Array F32 Nothing) Private Nothing+       ]+    ++ [Named "S", Named "T"]+    ++ [ TextureSampled Tex1d F32,+         TextureSampled Tex2d F32,+         TextureSampled Tex2d I32,+         TextureSampled Tex2dArray F32,+         TextureSampled Tex3d F32,+         TextureSampled TexCube F32,+         TextureSampled TexCubeArray F32,+         TextureMultisampled F32,+         TextureExternal,+         TextureStorage StorageTex1d Rgba8Unorm Write,+         TextureStorage StorageTex2d Rgba8Unorm Write,+         TextureStorage StorageTex2d R32Float Write,+         TextureStorage StorageTex2d R32Float Read,+         TextureStorage StorageTex2dArray Rgba8Unorm Write,+         TextureStorage StorageTex3d Rgba8Unorm Write,+         TextureDepth Depth2d,+         TextureDepth Depth2dArray,+         TextureDepth DepthCube,+         TextureDepth DepthCubeArray,+         TextureDepth DepthMultisampled2d,+         Sampler,+         SamplerComparison+       ]++-- | Distinct types must have distinct spellings.  Were two of them to spell+-- the same WGSL type, they could disagree about its layout, which is what an+-- open-ended escape hatch in 'Type' used to allow.+injectivityTests :: TestTree+injectivityTests =+  testGroup+    "spellings are distinct"+    [ testCase "the sample has no duplicates" $+        nub representativeTypes @?= representativeTypes,+      testCase "no two types spell the same" $+        let spellings = map render representativeTypes+         in nub spellings @?= spellings+    ]++-- | Every type is spelled as an identifier with an optional template argument+-- list.  See https://www.w3.org/TR/WGSL/#type-specifiers.+typeSpellingTests :: TestTree+typeSpellingTests =+  testGroup+    "spelling"+    [ testCase "scalars" $+        map render [Bool, I32, U32, F16, F32]+          @?= ["bool", "i32", "u32", "f16", "f32"],+      testCase "vector" $ render (Vec3 F32) @?= "vec3<f32>",+      testCase "matrix" $ render (Mat4x3 F16) @?= "mat4x3<f16>",+      testCase "atomic" $ render (Atomic U32) @?= "atomic<u32>",+      testCase "runtime-sized array" $ render (Array F32 Nothing) @?= "array<f32>",+      testCase "fixed-size array" $+        render (Array F32 (Just (ExpInt 8 AbstractInt))) @?= "array<f32, 8>",+      -- Element and store types are no longer restricted to scalars.+      testCase "array of struct" $+        render (Array (Named "S") (Just (ExpInt 3 AbstractInt))) @?= "array<S, 3>",+      testCase "array of array" $+        render+          ( Array+              (Array F32 (Just (ExpInt 2 AbstractInt)))+              (Just (ExpInt 3 AbstractInt))+          )+          @?= "array<array<f32, 2>, 3>",+      -- The specification's own example of a pointer type.+      testCase "pointer to array" $+        render (Ptr (Array F32 (Just (ExpInt 50 AbstractInt))) Private Nothing)+          @?= "ptr<private, array<f32, 50>>",+      testCase "sampler" $ render Sampler @?= "sampler"+    ]++-- | An array's size is its element count times the element stride.  See+-- https://www.w3.org/TR/WGSL/#array-layout-examples.+arrayLayoutTests :: TestTree+arrayLayoutTests =+  testGroup+    "arrays"+    [ testCase "strideOf" $+        map strideOf [F32, Vec3 F32, F16, Named "S"]+          @?= [Just 4, Just 16, Just 2, Nothing],+      testCase "array<f32, 8>" $+        layout (Array F32 (Just (ExpInt 8 AbstractInt))) @?= Just (4, 32),+      -- The element is padded from 12 bytes to a stride of 16.+      testCase "array<vec3<f32>, 8>" $+        layout (Array (Vec3 F32) (Just (ExpInt 8 AbstractInt)))+          @?= Just (16, 128),+      testCase "runtime-sized array" $+        (alignOf (Array F32 Nothing), sizeOf (Array F32 Nothing))+          @?= (Just 4, Nothing),+      testCase "overridable element count" $+        layout (Array F32 (Just (ExpIdent "n"))) @?= Nothing+    ]++-- | See https://www.w3.org/TR/WGSL/#structure-member-layout.+structLayoutTests :: TestTree+structLayoutTests =+  testGroup+    "structures"+    [ -- struct A from the specification's example.+      testCase "implicit padding" $+        structLayout [F32, F32, Vec2 F32, F32]+          @?= (Just [0, 4, 8, 16], Just 8, Just 24),+      -- The first four members of struct B from the same example.+      testCase "vector alignment" $+        structLayout+          [Vec2 F32, Vec3 F32, F32, F32]+          @?= (Just [0, 16, 28, 32], Just 16, Just 48),+      testCase "single member" $+        structLayout [I32] @?= (Just [0], Just 4, Just 4),+      -- The offsets and alignment of a storage buffer's header are known even+      -- though its size is not.+      testCase "trailing runtime-sized array" $+        structLayout [U32, Array F32 Nothing]+          @?= (Just [0, 4], Just 4, Nothing),+      -- A member without a size stops the offsets of later members from+      -- being known, but the alignment still is.+      testCase "member without a size" $+        structLayout [Array F32 Nothing, U32]+          @?= (Nothing, Just 4, Nothing),+      testCase "no members" $+        structLayout [] @?= (Nothing, Nothing, Nothing),+      testCase "member without a layout" $+        structLayout [I32, Named "S"]+          @?= (Nothing, Nothing, Nothing)+    ]++-- | @\@align@ and @\@size@ override a member's alignment and size.  See+-- https://www.w3.org/TR/WGSL/#structure-member-layout.+memberLayoutTests :: TestTree+memberLayoutTests =+  testGroup+    "layout attributes"+    [ testCase "alignOfMember" $+        ( alignOfMember (StructMember [] "m" F32),+          alignOfMember (StructMember [Attribute "align" [ExpInt 16 AbstractInt]] "m" F32)+        )+          @?= (Just 4, Just 16),+      testCase "sizeOfMember" $+        ( sizeOfMember (StructMember [] "m" F32),+          sizeOfMember (StructMember [Attribute "size" [ExpInt 16 AbstractInt]] "m" F32)+        )+          @?= (Just 4, Just 16),+      testCase "unrelated attribute" $+        alignOfMember (StructMember [Attribute "location" [ExpInt 0 AbstractInt]] "m" F32)+          @?= Just 4,+      -- The argument of @align or @size need only be a const-expression, and+      -- one that is not a literal leaves the member's layout unknown.  It+      -- must not fall back to the layout of the member's type.+      testCase "alignment that is not a literal" $+        ( alignOfMember (StructMember [Attribute "align" [ExpIdent "N"]] "m" F32),+          sizeOfMember (StructMember [Attribute "size" [ExpIdent "N"]] "m" F32)+        )+          @?= (Nothing, Nothing),+      testCase "structure with an unknown member alignment" $+        structLayoutOf+          [ StructMember [] "a" F32,+            StructMember [Attribute "align" [ExpIdent "N"]] "b" F32+          ]+          @?= (Nothing, Nothing, Nothing),+      -- struct A from the specification's example with explicit member sizes:+      -- the @size(16) on the last member grows the structure from 24 to 32.+      testCase "explicit size" $+        structLayoutOf+          [ StructMember [] "u" F32,+            StructMember [] "v" F32,+            StructMember [] "w" (Vec2 F32),+            StructMember [Attribute "size" [ExpInt 16 AbstractInt]] "x" F32+          ]+          @?= (Just [0, 4, 8, 16], Just 8, Just 32),+      -- The same example's struct B places its @align(16) member at offset 48+      -- rather than 40.+      testCase "explicit alignment" $+        structLayoutOf+          [ StructMember [] "a" (Vec2 F32),+            StructMember [] "b" (Vec3 F32),+            StructMember [] "c" F32,+            StructMember [] "d" F32,+            StructMember [Attribute "align" [ExpInt 16 AbstractInt]] "e" F32+          ]+          @?= (Just [0, 16, 28, 32, 48], Just 16, Just 64)+    ]++-- | A structure member may carry attributes, and so may an override+-- declaration.+attributeTests :: TestTree+attributeTests =+  testGroup+    "attributes"+    [ testCase "structure member" $+        render+          ( StructDecl+              "S"+              [ StructMember [] "a" I32,+                StructMember [Attribute "size" [ExpInt 16 AbstractInt]] "b" F32+              ]+          )+          @?= "struct S {\n  a : i32,\n  @size(16) b : f32\n}",+      testCase "override identifier" $+        render+          (GlobalOverride [Attribute "id" [ExpInt 7 AbstractInt]] "n" (Just I32) Nothing)+          @?= "@id(7)\noverride n : i32;",+      testCase "override without attributes" $+        render (GlobalOverride [] "n" (Just I32) (Just (ExpInt 0 AbstractInt)))+          @?= "override n : i32 = 0;"+    ]++-- | See https://www.w3.org/TR/WGSL/#host-shareable-types.+hostShareableTests :: TestTree+hostShareableTests =+  testGroup+    "hostShareable"+    [ testCase "numeric scalar" $ hostShareable I32 @?= True,+      testCase "bool" $ hostShareable Bool @?= False,+      testCase "numeric vector" $ hostShareable (Vec3 F32) @?= True,+      testCase "vector of bool" $ hostShareable (Vec3 Bool) @?= False,+      testCase "atomic" $ hostShareable (Atomic I32) @?= True,+      testCase "runtime-sized array" $+        hostShareable (Array F32 Nothing) @?= True,+      testCase "fixed-size array" $+        hostShareable (Array F32 (Just (ExpInt 8 AbstractInt))) @?= True,+      testCase "overridable element count" $+        hostShareable (Array F32 (Just (ExpIdent "n"))) @?= False,+      testCase "named type" $ hostShareable (Named "S") @?= False,+      testCase "pointer" $+        hostShareable (Ptr I32 Function Nothing) @?= False+    ]++-- | Operators are a closed set, spelled as the grammar spells them.  See+-- https://www.w3.org/TR/WGSL/#expressions.+operatorTests :: TestTree+operatorTests =+  testGroup+    "operators"+    [ testCase "binary" $+        map+          (\op -> render (ExpBinary op (ExpIdent "a") (ExpIdent "b")))+          [ Add,+            Subtract,+            Multiply,+            Divide,+            Remainder,+            BitwiseAnd,+            BitwiseOr,+            BitwiseExclusiveOr,+            ShiftLeft,+            ShiftRight,+            Less,+            LessEqual,+            Greater,+            GreaterEqual,+            Equal,+            NotEqual,+            ShortCircuitAnd,+            ShortCircuitOr+          ]+          @?= [ "(a + b)",+                "(a - b)",+                "(a * b)",+                "(a / b)",+                "(a % b)",+                "(a & b)",+                "(a | b)",+                "(a ^ b)",+                "(a << b)",+                "(a >> b)",+                "(a < b)",+                "(a <= b)",+                "(a > b)",+                "(a >= b)",+                "(a == b)",+                "(a != b)",+                "(a && b)",+                "(a || b)"+              ],+      testCase "unary" $+        map+          (\op -> render (ExpUnary op (ExpIdent "a")))+          [Negate, LogicalNegate, BitwiseComplement, Indirection, AddressOf]+          @?= ["(-a)", "(!a)", "(~a)", "(*a)", "(&a)"]+    ]++-- | Directives precede all declarations in a module.  See+-- https://www.w3.org/TR/WGSL/#directives.+directiveTests :: TestTree+directiveTests =+  testGroup+    "directives"+    [ testCase "enable" $+        render (Enable (EnableF16 :| [])) @?= "enable f16;",+      testCase "enable several" $+        render (Enable (EnableF16 :| [EnableSubgroups]))+          @?= "enable f16, subgroups;",+      testCase "every enable extension" $+        map+          (render . (\e -> Enable (e :| [])))+          [ EnableF16,+            EnableClipDistances,+            EnableDualSourceBlending,+            EnableSubgroups,+            EnablePrimitiveIndex,+            EnableSubgroupSizeControl+          ]+          @?= [ "enable f16;",+                "enable clip_distances;",+                "enable dual_source_blending;",+                "enable subgroups;",+                "enable primitive_index;",+                "enable subgroup_size_control;"+              ],+      testCase "requires" $+        render (Requires (TextureFormatsTier1 :| [PointerCompositeAccess]))+          @?= "requires texture_formats_tier1, pointer_composite_access;",+      testCase "diagnostic" $+        render (Diagnostic Off "derivative_uniformity")+          @?= "diagnostic(off, derivative_uniformity);",+      testCase "severities" $+        map (render . (`Diagnostic` "r")) [Error, Warning, Info, Off]+          @?= [ "diagnostic(error, r);",+                "diagnostic(warning, r);",+                "diagnostic(info, r);",+                "diagnostic(off, r);"+              ]+    ]++-- | A module is its directives followed by its declarations.  The f16 type+-- cannot legally be used without the directive that enables it, which is the+-- reason a module needs a representation of its own.+moduleTests :: TestTree+moduleTests =+  testGroup+    "Module"+    [ testCase "directives first" $+        render+          ( Module+              [Enable (EnableF16 :| [])]+              [GlobalVariable [] Private Nothing "x" (Just F16) Nothing]+          )+          @?= "enable f16;\nvar<private> x : f16;",+      testCase "without directives" $+        render (Module [] [GlobalVariable [] Private Nothing "x" (Just F32) Nothing])+          @?= "var<private> x : f32;",+      testCase "const_assert" $+        render (Module [] [GlobalAssert (ExpIdent "c")])+          @?= "const_assert c;",+      testCase "structure" $+        render+          ( Module+              []+              [GlobalStruct (StructDecl "S" [StructMember [] "a" I32, StructMember [] "b" F32])]+          )+          @?= "struct S {\n  a : i32,\n  b : f32\n}"+    ]++-- | An @if@ may be followed by any number of @else if@ clauses.  See+-- https://www.w3.org/TR/WGSL/#if-statement.+elseIfTests :: TestTree+elseIfTests =+  testGroup+    "else if"+    [ testCase "one clause" $+        render (If (ExpIdent "a") [Break] [(ExpIdent "b", [Continue])] Nothing)+          @?= "if a {\n  break;\n} else if b {\n  continue;\n}",+      testCase "chain with else" $+        render+          ( If+              (ExpIdent "a")+              [Break]+              [(ExpIdent "b", [Continue]), (ExpIdent "c", [Discard])]+              (Just [Return Nothing])+          )+          @?= "if a {\n  break;\n} else if b {\n  continue;\n}"+            <> " else if c {\n  discard;\n} else {\n  return;\n}"+    ]++-- | See https://www.w3.org/TR/WGSL/#switch-statement.+switchTests :: TestTree+switchTests =+  testGroup+    "switch"+    [ testCase "several selectors" $+        render (Switch (ExpIdent "x") (Case (CaseExp one :| [CaseExp two]) [Break] :| []))+          @?= "switch x {\n  case 1, 2: {\n    break;\n  }\n}",+      -- 'default' may appear among a case clause's selectors, as well as+      -- being a clause of its own.+      testCase "default as a selector" $+        render (Switch (ExpIdent "x") (Case (CaseExp one :| [CaseDefault]) [] :| []))+          @?= "switch x {\n  case 1, default: { }\n}",+      testCase "default clause" $+        render (Switch (ExpIdent "x") (DefaultCase [Discard] :| []))+          @?= "switch x {\n  default: {\n    discard;\n  }\n}",+      testCase "several clauses" $+        render+          ( Switch+              (ExpIdent "x")+              (Case (CaseExp one :| []) [Break] :| [DefaultCase []])+          )+          @?= "switch x {\n  case 1: {\n    break;\n  }\n  default: { }\n}"+    ]++-- | A @loop@ may end in a @continuing@ block, which may end in a @break if@.+-- See https://www.w3.org/TR/WGSL/#loop-statement.+loopTests :: TestTree+loopTests =+  testGroup+    "loop"+    [ testCase "without continuing" $+        render (Loop [Break] Nothing) @?= "loop {\n  break;\n}",+      testCase "with continuing" $+        render (Loop [Call "f" [] []] (Just (Continuing [Assign (ExpIdent "i") AssignSimple one] Nothing)))+          @?= "loop {\n  f();\n  continuing {\n    i = 1;\n  }\n}",+      testCase "with break if" $+        render (Loop [] (Just (Continuing [] (Just (ExpIdent "done")))))+          @?= "loop {\n  continuing {\n    break if done;\n  }\n}",+      testCase "jumps" $+        map render [Break, Continue, Discard]+          @?= ["break;", "continue;", "discard;"]+    ]++-- | An assignment carries an operator, which may be a compound one.  See+-- https://www.w3.org/TR/WGSL/#assignment.+assignOpTests :: TestTree+assignOpTests =+  testGroup+    "assignment operators"+    [ testCase "every operator" $+        map+          (\op -> render (Assign (ExpIdent "x") op one))+          [ AssignSimple,+            AssignAdd,+            AssignSubtract,+            AssignMultiply,+            AssignDivide,+            AssignRemainder,+            AssignBitwiseAnd,+            AssignBitwiseOr,+            AssignBitwiseExclusiveOr,+            AssignShiftLeft,+            AssignShiftRight+          ]+          @?= [ "x = 1;",+                "x += 1;",+                "x -= 1;",+                "x *= 1;",+                "x /= 1;",+                "x %= 1;",+                "x &= 1;",+                "x |= 1;",+                "x ^= 1;",+                "x <<= 1;",+                "x >>= 1;"+              ],+      testCase "phony assignment" $+        render (PhonyAssign (ExpCall "f" [] [])) @?= "_ = f();",+      testCase "increment and decrement" $+        map render [Increment (ExpIdent "x"), Decrement (ExpIndex (ExpIdent "a") one)]+          @?= ["x++;", "a[1]--;"],+      testCase "const_assert" $+        render (ConstAssert (ExpIdent "c")) @?= "const_assert c;"+    ]++-- | A @let@, @const@ or @var@ names an optionally typed identifier, and a+-- @var@ may have an initialiser.  See+-- https://www.w3.org/TR/WGSL/#var-and-value.+localDeclTests :: TestTree+localDeclTests =+  testGroup+    "local declarations"+    [ testCase "let" $+        map render [Let "a" Nothing one, Let "a" (Just F32) one]+          @?= ["let a = 1;", "let a : f32 = 1;"],+      testCase "const" $+        map render [Const "a" Nothing one, Const "a" (Just F32) one]+          @?= ["const a = 1;", "const a : f32 = 1;"],+      testCase "var" $+        map+          render+          [ Var "a" (Just I32) Nothing,+            Var "a" (Just I32) (Just one),+            Var "a" Nothing (Just one)+          ]+          @?= ["var a : i32;", "var a : i32 = 1;", "var a = 1;"]+    ]++-- | The update of a @for@ loop may be any of the variable-updating+-- statements, or a call.  See https://www.w3.org/TR/WGSL/#for-statement.+forUpdateTests :: TestTree+forUpdateTests =+  testGroup+    "for updates"+    [ testCase "every form" $+        map+          (\u -> render (For "i" one (ExpIdent "c") u []))+          [ UpdateAssign (ExpIdent "i") AssignAdd one,+            UpdatePhonyAssign (ExpIdent "i"),+            UpdateIncrement (ExpIdent "i"),+            UpdateDecrement (ExpIdent "i"),+            UpdateCall "step" [] [ExpIdent "i"]+          ]+          @?= [ "for (var i = 1; c; i += 1) { }",+                "for (var i = 1; c; _ = i) { }",+                "for (var i = 1; c; i++) { }",+                "for (var i = 1; c; i--) { }",+                "for (var i = 1; c; step(i)) { }"+              ]+    ]++-- | The remaining module-scope declarations.  See+-- https://www.w3.org/TR/WGSL/#module-scope-declarations.+globalDeclTests :: TestTree+globalDeclTests =+  testGroup+    "other declarations"+    [ testCase "alias" $+        render (GlobalAlias "i16" I32) @?= "alias i16 = i32;",+      testCase "const" $+        map render [GlobalConst "N" Nothing one, GlobalConst "N" (Just I32) one]+          @?= ["const N = 1;", "const N : i32 = 1;"],+      -- A module-scope variable's type is optional, and one in the private+      -- address space may have an initialiser.+      testCase "variable initialiser" $+        map+          render+          [ GlobalVariable [] Private Nothing "x" (Just F32) Nothing,+            GlobalVariable [] Private Nothing "x" Nothing (Just one),+            GlobalVariable [] Private Nothing "x" (Just F32) (Just one)+          ]+          @?= ["var<private> x : f32;", "var<private> x = 1;", "var<private> x : f32 = 1;"],+      testCase "override without a type" $+        render (GlobalOverride [] "k" Nothing (Just one)) @?= "override k = 1;"+    ]++-- | An index may be applied to any expression, and chained.  Swizzles use+-- the same slot as member access, so 'ExpMember' spells them.  See+-- https://www.w3.org/TR/WGSL/#component-reference-expr.+indexTests :: TestTree+indexTests =+  testGroup+    "indexing"+    [ testCase "identifier" $+        render (ExpIndex (ExpIdent "a") (ExpIdent "i")) @?= "a[i]",+      -- Indexing a nested array needs an index of an index.+      testCase "chained" $+        render (ExpIndex (ExpIndex (ExpIdent "a") (ExpIdent "i")) (ExpIdent "j"))+          @?= "a[i][j]",+      testCase "call result" $+        render (ExpIndex (ExpCall "f" [] [ExpIdent "x"]) (ExpIdent "i")) @?= "f(x)[i]",+      testCase "through a pointer" $+        render (ExpIndex (ExpUnary Indirection (ExpIdent "p")) (ExpIdent "i"))+          @?= "(*p)[i]",+      testCase "member" $+        render (ExpIndex (ExpMember (ExpIdent "s") "f") (ExpIdent "i")) @?= "s.f[i]",+      testCase "swizzle of an index" $+        render (ExpMember (ExpIndex (ExpIdent "a") (ExpIdent "i")) "xyz") @?= "a[i].xyz",+      testCase "as an assignment target" $+        render+          ( Assign+              (ExpIndex (ExpIndex (ExpIdent "a") (ExpIdent "i")) (ExpIdent "j"))+              AssignSimple+              one+          )+          @?= "a[i][j] = 1;"+    ]++-- | An identifier matches the identifier pattern, is neither a keyword nor a+-- reserved word, and does not begin with two underscores.  See+-- https://www.w3.org/TR/WGSL/#identifiers.+identTests :: TestTree+identTests =+  testGroup+    "validIdent"+    [ testCase "accepted" $+        filter (not . validIdent) ["x", "A", "a1", "_a", "a_", "foo_bar"]+          @?= [],+      testCase "empty" $ validIdent "" @?= False,+      -- A lone underscore is not an identifier, and neither is a name+      -- beginning with two of them.+      testCase "underscores" $+        filter validIdent ["_", "__", "__a", "__frexp_result_f32"] @?= [],+      testCase "pattern" $+        filter validIdent ["1a", "a-b", "a b", "a.b"] @?= [],+      testCase "keywords" $ filter validIdent keywords @?= [],+      testCase "reserved words" $ filter validIdent reservedWords @?= [],+      testCase "list sizes" $+        (length keywords, length reservedWords) @?= (26, 146)+    ]++tests :: TestTree+tests =+  testGroup+    "Language.WGSL"+    [ testGroup "identifiers" [identTests],+      testGroup "types" [typeSpellingTests, injectivityTests, pointerTests],+      testGroup+        "memory"+        [ accessModeTests,+          layoutTests,+          matrixLayoutTests,+          opaqueTests,+          arrayLayoutTests,+          structLayoutTests,+          memberLayoutTests,+          hostShareableTests+        ],+      testGroup+        "expressions"+        [operatorTests, intLitTests, floatLitTests, callTests, indexTests],+      testGroup+        "statements"+        [ sequenceTests,+          assignTests,+          returnTests,+          forTests,+          elseIfTests,+          switchTests,+          loopTests,+          assignOpTests,+          localDeclTests,+          forUpdateTests+        ],+      testGroup+        "declarations"+        [ globalVarTests,+          globalDeclTests,+          funDeclTests,+          attributeTests,+          directiveTests,+          moduleTests+        ]+    ]++main :: IO ()+main = defaultMain tests