diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for language-wgsl + +## 0.1.0.0 -- 2026-11-03 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). diff --git a/language-wgsl.cabal b/language-wgsl.cabal new file mode 100644 --- /dev/null +++ b/language-wgsl.cabal @@ -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 + + (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 +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 diff --git a/src/Language/WGSL.hs b/src/Language/WGSL.hs new file mode 100644 --- /dev/null +++ b/src/Language/WGSL.hs @@ -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(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 <> ";" diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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@, 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", + testCase "with access mode" $ + render (Ptr I32 Function (Just ReadWrite)) + @?= "ptr", + testCase "uniform" $ + render (Ptr F32 Uniform Nothing) + @?= "ptr", + testCase "vector store type" $ + render (Ptr (Vec3 F32) Workgroup (Just Read)) + @?= "ptr, read>", + testCase "storage" $ + render (Ptr I32 Storage (Just Read)) + @?= "ptr" + ] + +-- | 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 x : i32;", + testCase "with access mode" $ + render (GlobalVariable [] Storage (Just ReadWrite) "x" (Just (Array I32 Nothing)) Nothing) + @?= "var x : array;", + testCase "private" $ + render (GlobalVariable [] Private Nothing "x" (Just F32) Nothing) + @?= "var x : f32;", + testCase "immediate" $ + render (GlobalVariable [] Immediate Nothing "x" (Just (Named "S")) Nothing) + @?= "var x : S;", + testCase "with attributes" $ + render (GlobalVariable (bindingAttribs 0 1) Storage (Just Read) "x" (Just (Array F32 Nothing)) Nothing) + @?= "@group(0) @binding(1)\nvar x : array;" + ] + +-- | 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 {\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(1, 1)", + testCase "bitcast" $ + render (bitcast I32 (ExpIdent "x")) @?= "bitcast(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>(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" $ layout (Vec2 F32) @?= Just (8, 8), + testCase "vec3" $ layout (Vec3 F32) @?= Just (16, 12), + testCase "vec4" $ layout (Vec4 F32) @?= Just (16, 16), + testCase "vec2" $ layout (Vec2 F16) @?= Just (4, 4), + testCase "vec3" $ layout (Vec3 F16) @?= Just (8, 6), + testCase "vec4" $ 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", + "texture_2d", + "texture_2d_array", + "texture_3d", + "texture_cube", + "texture_cube_array" + ], + testCase "multisampled" $ + render (TextureMultisampled F32) @?= "texture_multisampled_2d", + 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", + "texture_storage_2d", + "texture_storage_2d_array", + "texture_storage_3d" + ], + 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@. See +-- https://www.w3.org/TR/WGSL/#alignment-and-size. +matrixLayoutTests :: TestTree +matrixLayoutTests = + testGroup + "matrices" + [ testCase "mat2x2" $ layout (Mat2x2 F32) @?= Just (8, 16), + testCase "mat3x2" $ layout (Mat3x2 F32) @?= Just (8, 24), + testCase "mat4x2" $ layout (Mat4x2 F32) @?= Just (8, 32), + -- The columns are padded from 12 bytes to a stride of 16. + testCase "mat2x3" $ layout (Mat2x3 F32) @?= Just (16, 32), + testCase "mat3x3" $ layout (Mat3x3 F32) @?= Just (16, 48), + testCase "mat4x3" $ layout (Mat4x3 F32) @?= Just (16, 64), + testCase "mat2x4" $ layout (Mat2x4 F32) @?= Just (16, 32), + testCase "mat3x4" $ layout (Mat3x4 F32) @?= Just (16, 48), + testCase "mat4x4" $ layout (Mat4x4 F32) @?= Just (16, 64), + testCase "mat2x2" $ layout (Mat2x2 F16) @?= Just (4, 8), + testCase "mat4x2" $ layout (Mat4x2 F16) @?= Just (4, 16), + testCase "mat2x3" $ layout (Mat2x3 F16) @?= Just (8, 16), + testCase "mat4x3" $ layout (Mat4x3 F16) @?= Just (8, 32), + testCase "mat4x4" $ 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", + testCase "matrix" $ render (Mat4x3 F16) @?= "mat4x3", + testCase "atomic" $ render (Atomic U32) @?= "atomic", + testCase "runtime-sized array" $ render (Array F32 Nothing) @?= "array", + testCase "fixed-size array" $ + render (Array F32 (Just (ExpInt 8 AbstractInt))) @?= "array", + -- Element and store types are no longer restricted to scalars. + testCase "array of struct" $ + render (Array (Named "S") (Just (ExpInt 3 AbstractInt))) @?= "array", + testCase "array of array" $ + render + ( Array + (Array F32 (Just (ExpInt 2 AbstractInt))) + (Just (ExpInt 3 AbstractInt)) + ) + @?= "array, 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>", + 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" $ + layout (Array F32 (Just (ExpInt 8 AbstractInt))) @?= Just (4, 32), + -- The element is padded from 12 bytes to a stride of 16. + testCase "array, 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 x : f16;", + testCase "without directives" $ + render (Module [] [GlobalVariable [] Private Nothing "x" (Just F32) Nothing]) + @?= "var 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 x : f32;", "var x = 1;", "var 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