{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module FlatBuffers.Internal.Compiler.SemanticAnalysisSpec where import Data.Foldable ( fold ) import Data.Int import Data.Text ( Text ) import qualified Data.Text as T import qualified FlatBuffers.Internal.Compiler.Parser as P import FlatBuffers.Internal.Compiler.SemanticAnalysis import FlatBuffers.Internal.Compiler.SyntaxTree ( FileTree(..) ) import FlatBuffers.Internal.Compiler.ValidSyntaxTree import TestImports import Text.Megaparsec import Text.RawString.QQ ( r ) spec :: Spec spec = describe "SemanticAnalysis" $ do it "top-level identifiers cannot have duplicates in the same namespace" $ do [r| namespace A; enum E:int{x} enum E:int{x} |] `shouldFail` "'A.E' declared more than once" [r| enum E:int{x} enum E:int{x} |] `shouldFail` "'E' declared more than once" [r| struct S{x:int;} struct S{x:int;} |] `shouldFail` "'S' declared more than once" [r| table T{} table T{} |] `shouldFail` "'T' declared more than once" [r| union U{x} union U{x} |] `shouldFail` "'U' declared more than once" [r| union U{x} union U{x} |] `shouldFail` "'U' declared more than once" [r| union X{x} table X{} |] `shouldFail` "'X' declared more than once" it "top-level identifiers can be duplicates, if they live in different namespaces" $ [r| namespace A; union X{B.X} namespace B; table X{} |] `shouldValidate` foldDecls [ union ("A", UnionDecl "X" [UnionVal "B_X" (TypeRef "B" "X")]) , table ("B", TableDecl "X" NotRoot []) ] describe "attributes" $ do it "user defined attributes must be declared" $ do [r| enum E : int (x) {Y} |] `shouldFail` "[E]: user defined attributes must be declared before use: x" [r| struct S (x) { y: int;} |] `shouldFail` "[S]: user defined attributes must be declared before use: x" [r| struct S { y: int (x);} |] `shouldFail` "[S.y]: user defined attributes must be declared before use: x" [r| table T (x) {} |] `shouldFail` "[T]: user defined attributes must be declared before use: x" [r| table T { y: int (x); } |] `shouldFail` "[T.y]: user defined attributes must be declared before use: x" [r| union U (x) {Y} table Y{} |] `shouldFail` "[U]: user defined attributes must be declared before use: x" it "user defined attributes can be used when declared" $ do shouldSucceed [r| attribute x; enum E : int (x) {Y} |] shouldSucceed [r| attribute x; struct S (x) { y: int;} |] shouldSucceed [r| attribute x; struct S { y: int (x);} |] shouldSucceed [r| attribute x; table T (x) {} |] shouldSucceed [r| attribute x; table T { y: int (x); } |] shouldSucceed [r| attribute x; union U (x) {Y} table Y{} |] it "built-in attributes can be used without being declared" $ shouldSucceed [r| table T (id, deprecated, required, force_align, bit_flags, nested_flatbuffer, flexbuffer, key, hash, original_order, native_inline, native_default, native_custom_alloc, native_type ) {} |] describe "root type" $ do it "flips the `isRoot` flag" $ [r| table T{} root_type T; |] `shouldValidate` table ("", TableDecl "T" (IsRoot Nothing) []) it "can be paired with a file_identifier" $ [r| table T{} file_identifier "abcd"; root_type T; |] `shouldValidate` table ("", TableDecl "T" (IsRoot (Just "abcd")) []) it "when set multiple times, the last declaration wins" $ [r| file_identifier "abcd"; root_type T; root_type T2; file_identifier "efgh"; table T2{} table T{} |] `shouldValidate` foldDecls [ table ("", TableDecl "T2" (IsRoot (Just "efgh")) []) , table ("", TableDecl "T" NotRoot []) ] it "must reference a table" $ do [r| root_type E; enum E:int{x} |] `shouldFail` "root type must be a table" [r| root_type S; struct S{x:int;} |] `shouldFail` "root type must be a table" [r| root_type U; union U{T} table T{} |] `shouldFail` "root type must be a table" [r| root_type string; |] `shouldFail` "type 'string' does not exist (checked in these namespaces: '')" it "can reference tables in other namespaces" $ [r| namespace A; root_type B.T; namespace A.B; table T{} file_identifier "abcd"; |] `shouldValidate` table ("A.B", TableDecl "T" (IsRoot (Just "abcd")) []) it "a file identifier on its own doesn't do anything" $ [r| table T{} file_identifier "abcd"; |] `shouldValidate` table ("", TableDecl "T" NotRoot []) describe "enums" $ do it "simple" $ [r| namespace Ns; enum Color : uint32 { Red, Green, Blue } |] `shouldValidate` enum ("Ns", EnumDecl "Color" EWord32 [ EnumVal "Red" 0 , EnumVal "Green" 1 , EnumVal "Blue" 2 ]) it "multiple enums in different namespaces" $ [r| namespace A; enum Color1 : uint32 { Red } namespace B; namespace ; enum Color2 : uint32 { Green } namespace A.B.C; enum Color3 : uint32 { Blue } |] `shouldValidate` foldDecls [ enum ("A", EnumDecl "Color1" EWord32 [EnumVal "Red" 0] ) , enum ("", EnumDecl "Color2" EWord32 [EnumVal "Green" 0] ) , enum ("A.B.C", EnumDecl "Color3" EWord32 [EnumVal "Blue" 0] ) ] it "with explicit values" $ [r| enum Color : int32 { Red = -2, Green, Blue = 2 } |] `shouldValidate` enum ("", EnumDecl "Color" EInt32 [ EnumVal "Red" (-2) , EnumVal "Green" (-1) , EnumVal "Blue" 2 ]) it "with explicit values (min/maxBound)" $ [r| enum Color : int8 { Red = -128, Green, Blue = 127 } |] `shouldValidate` enum ("", EnumDecl "Color" EInt8 [ EnumVal "Red" (toInteger (minBound :: Int8)) , EnumVal "Green" (-127) , EnumVal "Blue" (toInteger (maxBound :: Int8)) ]) it "with out-of-bounds values" $ do [r| namespace A.B; enum Color : int8 { Red = -129, Green, Blue } |] `shouldFail` "[A.B.Color.Red]: enum value does not fit [-128; 127]" [r| enum Color : int8 { Red, Green, Blue = 128 } |] `shouldFail` "[Color.Blue]: enum value does not fit [-128; 127]" it "with values out of order" $ do [r| enum Color : int8 { Red = 3, Green = 2, Blue } |] `shouldFail` "[Color]: enum values must be specified in ascending order" [r| enum Color : int8 { Red = 3, Green = 3, Blue } |] `shouldFail` "[Color]: enum values must be specified in ascending order" it "with bit_flags" $ [r| enum Color : int8 (bit_flags) { Red, Green, Blue } |] `shouldFail` "[Color]: `bit_flags` are not supported yet" it "with duplicate values" $ [r| enum Color : int8 { Red, Green, Red, Gray, Green, Green, Black } |] `shouldFail` "[Color]: 'Green', 'Red' declared more than once" it "with invalid underlying type" $ do [r| enum Color : double { Red, Green, Blue } |] `shouldFail` "[Color]: underlying enum type must be integral" [r| enum Color : TypeRef { Red, Green, Blue } |] `shouldFail` "[Color]: underlying enum type must be integral" [r| enum Color : [int] { Red, Green, Blue } |] `shouldFail` "[Color]: underlying enum type must be integral" describe "structs" $ do it "simple" $ [r| namespace Ns; struct S { x: int; } |] `shouldValidate` struct ("Ns", StructDecl "S" 4 4 [ StructField "x" 0 0 SInt32 ]) it "multiple fields" $ [r| struct S { x: ubyte; y: double; z: bool; } |] `shouldValidate` struct ("", StructDecl "S" 8 24 [ StructField "x" 7 0 SWord8 , StructField "y" 0 8 SDouble , StructField "z" 7 16 SBool ]) it "when unqualified TypeRef is ambiguous, types in namespaces closer to the struct are preferred" $ do let enumVal = EnumVal "x" 0 mkEnum namespace ident = enum (namespace, EnumDecl ident EInt16 [enumVal]) [r| namespace ; enum E1 : short{x} enum E2 : short{x} enum E3 : short{x} namespace A; enum E1 : short{x} enum E2 : short{x} namespace A.B; enum E1 : short{x} namespace A.B.C; enum E1 : short{x} enum E2 : short{x} enum E3 : short{x} namespace A.B; struct S { x: E1; // should be A.B.E1 y: E2; // should be A.E2 z: E3; // should be E3 } |] `shouldValidate` foldDecls [ mkEnum "" "E1", mkEnum "" "E2", mkEnum "" "E3" , mkEnum "A" "E1", mkEnum "A" "E2" , mkEnum "A.B" "E1" , mkEnum "A.B.C" "E1", mkEnum "A.B.C" "E2", mkEnum "A.B.C" "E3" , struct ("A.B", StructDecl "S" 2 6 [ StructField "x" 0 0 (SEnum (TypeRef "A.B" "E1") EInt16) , StructField "y" 0 2 (SEnum (TypeRef "A" "E2") EInt16) , StructField "z" 0 4 (SEnum (TypeRef "" "E3") EInt16) ]) ] it "when qualified TypeRef is ambiguous, types in namespaces closer to the struct are preferred" $ do let enumVal = EnumVal "x" 0 mkEnum namespace ident = enum (namespace, EnumDecl ident EInt16 [enumVal]) [r| namespace ; enum E1 : short{x} enum E2 : short{x} enum E3 : short{x} namespace A; enum E1 : short{x} enum E2 : short{x} enum E3 : short{x} namespace A.B; enum E1 : short{x} enum E2 : short{x} enum E3 : short{x} namespace A.A; enum E1 : short{x} enum E2 : short{x} namespace A.B.A; enum E1 : short{x} namespace A.B.C.A; enum E1 : short{x} enum E2 : short{x} enum E3 : short{x} namespace A.B; struct S { x: A.E1; // should be A.B.A.E1 y: A.E2; // should be A.A.E2 z: A.E3; // should be A.E3 } |] `shouldValidate` foldDecls [ mkEnum "" "E1", mkEnum "" "E2", mkEnum "" "E3" , mkEnum "A" "E1", mkEnum "A" "E2", mkEnum "A" "E3" , mkEnum "A.B" "E1", mkEnum "A.B" "E2", mkEnum "A.B" "E3" , mkEnum "A.A" "E1", mkEnum "A.A" "E2" , mkEnum "A.B.A" "E1" , mkEnum "A.B.C.A" "E1", mkEnum "A.B.C.A" "E2", mkEnum "A.B.C.A" "E3" , struct ("A.B", StructDecl "S" 2 6 [ StructField "x" 0 0 (SEnum (TypeRef "A.B.A" "E1") EInt16) , StructField "y" 0 2 (SEnum (TypeRef "A.A" "E2") EInt16) , StructField "z" 0 4 (SEnum (TypeRef "A" "E3") EInt16) ]) ] it "when TypeRef is ambiguous, types in namespaces closer to the struct are preferred, even if they're not valid" $ [r| namespace A; struct X {x: int;} namespace A.B; table X {} struct S { x: X; } |] `shouldFail` "[A.B.S.x]: struct fields may only be integers, floating point, bool, enums, or other structs" it "with field referencing an enum" $ [r| namespace A; enum Color : ushort { Blue } struct S { x: Color; } |] `shouldValidate` foldDecls [ enum ("A", EnumDecl "Color" EWord16 [EnumVal "Blue" 0]) , struct ("A", StructDecl "S" 2 2 [ StructField "x" 0 0 (SEnum (TypeRef "A" "Color") EWord16) ]) ] it "with nested structs (backwards/forwards references)" $ do let backwards = ("A.B", StructDecl "Backwards" 4 4 [ StructField "x" 0 0 SFloat ]) let forwards = ("A.B", StructDecl "Forwards" 4 4 [ StructField "y" 0 0 (SStruct backwards) ]) [r| namespace A.B; struct Backwards { x: float; } struct S { x1: B.Backwards; x2: A.B.Forwards; } struct Forwards { y: Backwards; } |] `shouldValidate` foldDecls [ struct backwards , struct ("A.B", StructDecl "S" 4 8 [ StructField "x1" 0 0 (SStruct backwards) , StructField "x2" 0 4 (SStruct forwards) ]) , struct forwards ] it "with reference to a table" $ [r| namespace A; table T {} struct S { x: A.T; } |] `shouldFail` "[A.S.x]: struct fields may only be integers, floating point, bool, enums, or other structs" it "with reference to a union" $ [r| namespace A.B; union U { X } struct S { x: U; } |] `shouldFail` "[A.B.S.x]: struct fields may only be integers, floating point, bool, enums, or other structs" it "with invalid reference" $ [r| namespace X.Y.Z; struct S { x: A.T; } |] `shouldFail` "[X.Y.Z.S.x]: type 'A.T' does not exist (checked in these namespaces: 'X.Y.Z', 'X.Y', 'X', '')" it "with reference to a vector" $ [r| struct S { x: [byte]; } |] `shouldFail` "[S.x]: struct fields may only be integers, floating point, bool, enums, or other structs" it "with reference to a string" $ [r| struct S { x: string; } |] `shouldFail` "[S.x]: struct fields may only be integers, floating point, bool, enums, or other structs" it "with duplicate fields" $ [r| struct S { x: byte; x: int; } |] `shouldFail` "[S]: 'x' declared more than once" it "with `force_align` attribute" $ do -- just 1 field [r| struct S (force_align: 4) { x: int; } |] `shouldValidate` struct ("", StructDecl "S" 4 4 [StructField "x" 0 0 SInt32]) [r| struct S (force_align: 8) { x: int; } |] `shouldValidate` struct ("", StructDecl "S" 8 8 [StructField "x" 4 0 SInt32]) [r| struct S (force_align: 16) { x: int; } |] `shouldValidate` struct ("", StructDecl "S" 16 16 [StructField "x" 12 0 SInt32]) -- multiple fields [r| struct S (force_align: 2) { x: byte; y: ushort; } |] `shouldValidate` struct ("", StructDecl "S" 2 4 [StructField "x" 1 0 SInt8, StructField "y" 0 2 SWord16]) [r| struct S (force_align: 4) { x: byte; y: ushort; } |] `shouldValidate` struct ("", StructDecl "S" 4 4 [StructField "x" 1 0 SInt8, StructField "y" 0 2 SWord16]) [r| struct S (force_align: 8) { x: byte; y: ushort; } |] `shouldValidate` struct ("", StructDecl "S" 8 8 [StructField "x" 1 0 SInt8, StructField "y" 4 2 SWord16]) [r| struct S (force_align: 16) { x: byte; y: ushort; } |] `shouldValidate` struct ("", StructDecl "S" 16 16 [StructField "x" 1 0 SInt8, StructField "y" 12 2 SWord16]) -- nested structs let s1 = ("", StructDecl "S1" 2 2 [StructField "x" 1 0 SInt8]) let s2 = ("", StructDecl "S2" 4 4 [StructField "x" 0 0 SInt32]) let s = ("", StructDecl "S" 4 12 [ StructField "x" 2 0 (SStruct s1) , StructField "y" 0 4 (SStruct s2) , StructField "z" 3 8 SBool ]) [r| struct S (force_align: 4) { x: S1; y: S2; z: bool; } struct S1 (force_align: 2) { x: byte; } struct S2 { x: int; } |] `shouldValidate` foldDecls [ struct s , struct s1 , struct s2 ] it "with `force_align` attribute less than the struct's natural alignment" $ [r| struct S (force_align: 2) { x: byte; y: int; } |] `shouldFail` "[S]: force_align must be a power of two integer ranging from the struct's natural alignment (in this case, 4) to 16" it "with `force_align` attribute greater than 16" $ [r| struct S (force_align: 32) { x: int; } |] `shouldFail` "[S]: force_align must be a power of two integer ranging from the struct's natural alignment (in this case, 4) to 16" it "with `force_align` not a power of 2" $ [r| struct S (force_align: 9) { x: int; } |] `shouldFail` "[S]: force_align must be a power of two integer ranging from the struct's natural alignment (in this case, 4) to 16" it "with `force_align` given as a string" $ [r| struct S (force_align: "hello") { x: byte; } |] `shouldFail` "[S]: expected attribute 'force_align' to have an integer value, e.g. 'force_align: 123'" it "with deprecated field" $ [r| struct S { x: byte (deprecated); } |] `shouldFail` "[S.x]: can't deprecate fields in a struct" it "with required field" $ [r| struct S { x: byte (required); } |] `shouldFail` "[S.x]: struct fields are already required, the 'required' attribute is redundant" it "with id field" $ [r| struct S { x: byte (id: 0); } |] `shouldFail` "[S.x]: struct fields cannot be reordered using the 'id' attribute" it "with cyclic dependency" $ [r| struct S {x: S1;} struct S1 {x: S4; y: S2;} struct S2 {x: byte; y: S3;} struct S3 {x: S4; y: S1;} struct S4 {x: byte;} |] `shouldFail` "[S1]: cyclic dependency detected [S1 -> S2 -> S3 -> S1] - structs cannot contain themselves, directly or indirectly" describe "tables" $ do it "empty" $ [r| table T{} |] `shouldValidate` table ("", TableDecl "T" NotRoot []) it "with cyclic reference" $ [r| table T{x: T;} |] `shouldValidate` table ("", TableDecl "T" NotRoot [ TableField 0 "x" (TTable (TypeRef "" "T") Opt) False ]) it "with invalid reference" $ do [r| table T { x: A.X; } |] `shouldFail` "[T.x]: type 'A.X' does not exist (checked in these namespaces: '')" [r| table T { x: [A.X]; } |] `shouldFail` "[T.x]: type 'A.X' does not exist (checked in these namespaces: '')" it "with duplicate fields" $ [r| table T { x: byte; x: int; } |] `shouldFail` "[T]: 'x' declared more than once" describe "with numeric/bool fields" $ do it "simple" $ [r| namespace A.B; table T { a: byte; b: short; c: int; d: long; e: ubyte; f: ushort; g: uint; h: ulong; i: float; j: double; k: bool; } |] `shouldValidate` table ("A.B", TableDecl "T" NotRoot [ TableField 0 "a" (TInt8 0) False , TableField 1 "b" (TInt16 0) False , TableField 2 "c" (TInt32 0) False , TableField 3 "d" (TInt64 0) False , TableField 4 "e" (TWord8 0) False , TableField 5 "f" (TWord16 0) False , TableField 6 "g" (TWord32 0) False , TableField 7 "h" (TWord64 0) False , TableField 8 "i" (TFloat 0) False , TableField 9 "j" (TDouble 0) False , TableField 10"k" (TBool (DefaultVal False)) False ] ) it "with `required` attribute" $ do let errorMsg = "[T.x]: only non-scalar fields (strings, vectors, unions, structs, tables) may be 'required'" [r| table T {x: byte (required); } |] `shouldFail` errorMsg [r| table T {x: short (required); } |] `shouldFail` errorMsg [r| table T {x: int (required); } |] `shouldFail` errorMsg [r| table T {x: long (required); } |] `shouldFail` errorMsg [r| table T {x: ubyte (required); } |] `shouldFail` errorMsg [r| table T {x: ushort (required); } |] `shouldFail` errorMsg [r| table T {x: uint (required); } |] `shouldFail` errorMsg [r| table T {x: ulong (required); } |] `shouldFail` errorMsg [r| table T {x: float (required); } |] `shouldFail` errorMsg [r| table T {x: double (required); } |] `shouldFail` errorMsg [r| table T {x: bool (required); } |] `shouldFail` errorMsg it "with `deprecated` attribute" $ [r| namespace A.B; table T { a: byte (deprecated); b: short (deprecated); c: int (deprecated); d: long (deprecated); e: ubyte (deprecated); f: ushort (deprecated); g: uint (deprecated); h: ulong (deprecated); i: float (deprecated); j: double (deprecated); k: bool (deprecated); } |] `shouldValidate` table ("A.B", TableDecl "T" NotRoot [ TableField 0 "a" (TInt8 0) True , TableField 1 "b" (TInt16 0) True , TableField 2 "c" (TInt32 0) True , TableField 3 "d" (TInt64 0) True , TableField 4 "e" (TWord8 0) True , TableField 5 "f" (TWord16 0) True , TableField 6 "g" (TWord32 0) True , TableField 7 "h" (TWord64 0) True , TableField 8 "i" (TFloat 0) True , TableField 9 "j" (TDouble 0) True , TableField 10 "k" (TBool (DefaultVal False)) True ] ) describe "with integer fields" $ do it "with integer default values" $ [r| table T { a: byte = 127; b: short = -32768; c: int = 1; d: long = 1.00; e: ubyte = 2e1; f: ushort = 200e-1; } |] `shouldValidate` table ("", TableDecl "T" NotRoot [ TableField 0 "a" (TInt8 127) False , TableField 1 "b" (TInt16 (-32768)) False , TableField 2 "c" (TInt32 1) False , TableField 3 "d" (TInt64 1) False , TableField 4 "e" (TWord8 20) False , TableField 5 "f" (TWord16 20) False ] ) it "with out-of-bounds default values" $ do [r| table T { a: byte = -129; } |] `shouldFail` "[T.a]: default value does not fit [-128; 127]" [r| table T { a: byte = 128; } |] `shouldFail` "[T.a]: default value does not fit [-128; 127]" let errorMsg = "[T.a]: default value must be integral" it "with decimal default values" $ do [r| table T { a: byte = 1.1; } |] `shouldFail` errorMsg [r| table T { a: byte = 2e-1; } |] `shouldFail` errorMsg [r| table T { a: byte = 2.22e1; } |] `shouldFail` errorMsg it "with boolean default values" $ [r| table T { a: byte = true; } |] `shouldFail` errorMsg it "with identifier default values" $ [r| table T { a: byte = Red; } |] `shouldFail` errorMsg describe "with floating point fields" $ do it "with integer default values" $ [r| table T { a: float = 127; b: float = -32768; c: float = 1; d: double = 1.00; e: double = 2e1; f: double = 200e-1; } |] `shouldValidate` table ("", TableDecl "T" NotRoot [ TableField 0 "a" (TFloat 127) False , TableField 1 "b" (TFloat (-32768)) False , TableField 2 "c" (TFloat 1) False , TableField 3 "d" (TDouble 1) False , TableField 4 "e" (TDouble 20) False , TableField 5 "f" (TDouble 20) False ] ) it "with decimal default values" $ [r| table T { a: double = 1.1; b: double = 2e-1; c: double = 2.22e1; } |] `shouldValidate` table ("", TableDecl "T" NotRoot [ TableField 0 "a" (TDouble 1.1) False , TableField 1 "b" (TDouble 0.2) False , TableField 2 "c" (TDouble 22.2) False ] ) it "with boolean default values" $ [r| table T { a: double = true; } |] `shouldFail` "[T.a]: default value must be a number" it "with identifier default values" $ [r| table T { a: double = Red; } |] `shouldFail` "[T.a]: default value must be a number" describe "with boolean fields" $ do it "with integer default values" $ [r| table T { a: bool = 1; } |] `shouldFail` "[T.a]: default value must be a boolean" it "with decimal default values" $ [r| table T { a: bool = 1.1; } |] `shouldFail` "[T.a]: default value must be a boolean" it "with boolean default values" $ [r| table T { a: bool = true; b: bool = false; } |] `shouldValidate` table ("", TableDecl "T" NotRoot [ TableField 0 "a" (TBool (DefaultVal True)) False , TableField 1 "b" (TBool (DefaultVal False)) False ] ) it "with identifier default values" $ [r| table T { a: bool = Red; } |] `shouldFail` "[T.a]: default value must be a boolean" describe "with string fields" $ do it "simple" $ [r| table T { x: string; } |] `shouldValidate` table ("", TableDecl "T" NotRoot [ TableField 0 "x" (TString Opt) False ]) it "with `required` attribute" $ [r| table T { x: string (required); } |] `shouldValidate` table ("", TableDecl "T" NotRoot [ TableField 0 "x" (TString Req) False ]) it "with `deprecated` attribute" $ [r| table T { x: string (deprecated); } |] `shouldValidate` table ("", TableDecl "T" NotRoot [ TableField 0 "x" (TString Opt) True ]) it "with default value" $ do let errorMsg = "[T.x]: default values currently only supported for scalar fields (integers, floating point, bool, enums)" [r| table T { x: string = a; } |] `shouldFail` errorMsg [r| table T { x: string = 0; } |] `shouldFail` errorMsg [r| table T { x: string = 0.0; } |] `shouldFail` errorMsg describe "with reference to enum" $ do it "simple" $ [r| namespace A.B; enum E : short { A } table T { x: B.E; } |] `shouldValidate` foldDecls [ enum ("A.B", EnumDecl "E" EInt16 [ EnumVal "A" 0 ]) , table ("A.B", TableDecl "T" NotRoot [ TableField 0 "x" (TEnum (TypeRef "A.B" "E") EInt16 0) False ] ) ] it "with `required` attribute" $ [r| table T { x: E (required); } enum E : short{A} |] `shouldFail` "[T.x]: only non-scalar fields (strings, vectors, unions, structs, tables) may be 'required'" it "with `deprecated` attribute" $ [r| table T { x: E (deprecated); } enum E : short{A} |] `shouldValidate` foldDecls [ enum ("", EnumDecl "E" EInt16 [ EnumVal "A" 0 ]) , table ("", TableDecl "T" NotRoot [ TableField 0 "x" (TEnum (TypeRef "" "E") EInt16 0) True ] ) ] it "without default value, when enum has 0-value" $ [r| table T { x: E; } enum E : short{ A = -1, B = 0, C = 1} |] `shouldValidate` foldDecls [ enum ("", EnumDecl "E" EInt16 [ EnumVal "A" (-1), EnumVal "B" 0, EnumVal "C" 1 ]) , table ("", TableDecl "T" NotRoot [ TableField 0 "x" (TEnum (TypeRef "" "E") EInt16 0) False ] ) ] it "without default value, when enum doesn't have 0-value" $ [r| table T { x: E; } enum E : short{ A = -1, B = 1, C = 2} |] `shouldFail` "[T.x]: enum does not have a 0 value; please manually specify a default for this field" describe "with default value" $ do it "valid integral" $ [r| table T { x: E = 1; } enum E : short{ A, B, C } |] `shouldValidate` foldDecls [ enum ("", EnumDecl "E" EInt16 [ EnumVal "A" 0, EnumVal "B" 1, EnumVal "C" 2 ]) , table ("", TableDecl "T" NotRoot [ TableField 0 "x" (TEnum (TypeRef "" "E") EInt16 1) False ] ) ] it "invalid integral" $ [r| table T { x: E = 3; } enum E : short{ A, B, C } |] `shouldFail` "[T.x]: default value of 3 is not part of enum E" it "valid identifier" $ [r| table T { x: E = B; } enum E : short{ A, B, C } |] `shouldValidate` foldDecls [ enum ("", EnumDecl "E" EInt16 [ EnumVal "A" 0, EnumVal "B" 1, EnumVal "C" 2 ]) , table ("", TableDecl "T" NotRoot [ TableField 0 "x" (TEnum (TypeRef "" "E") EInt16 1) False ] ) ] it "invalid identifier" $ [r| table T { x: E = D; } enum E : short{ A, B, C } |] `shouldFail` "[T.x]: default value of D is not part of enum E" it "decimal number" $ [r| table T { x: E = 1.5; } enum E : short{ A, B, C } |] `shouldFail` "[T.x]: default value must be integral or one of: 'A', 'B', 'C'" it "boolean" $ [r| table T { x: E = 1.5; } enum E : short{ A, B, C } |] `shouldFail` "[T.x]: default value must be integral or one of: 'A', 'B', 'C'" describe "with reference to structs/table/union" $ do it "simple" $ [r| namespace A; struct S { x: int; } table T {} union U {A.T} table Table { x: S; y: T; z: U; } |] `shouldValidate` foldDecls [ struct ("A", StructDecl "S" 4 4 [ StructField "x" 0 0 SInt32 ]) , table ("A", TableDecl "T" NotRoot []) , union ("A", UnionDecl "U" [UnionVal "A_T" (TypeRef "A" "T")]) , table ("A", TableDecl "Table" NotRoot [ TableField 0 "x" (TStruct (TypeRef "A" "S") Opt) False , TableField 1 "y" (TTable (TypeRef "A" "T") Opt) False , TableField 3 "z" (TUnion (TypeRef "A" "U") Opt) False ] ) ] it "with `required` attribute" $ [r| namespace A; struct S { x: int; } table T {} union U {A.T} table Table { x: S (required); y: T (required); z: U (required); } |] `shouldValidate` foldDecls [ struct ("A", StructDecl "S" 4 4 [ StructField "x" 0 0 SInt32 ]) , table ("A", TableDecl "T" NotRoot []) , union ("A", UnionDecl "U" [UnionVal "A_T" (TypeRef "A" "T")]) , table ("A", TableDecl "Table" NotRoot [ TableField 0 "x" (TStruct (TypeRef "A" "S") Req) False , TableField 1 "y" (TTable (TypeRef "A" "T") Req) False , TableField 3 "z" (TUnion (TypeRef "A" "U") Req) False ] ) ] it "with `deprecated` attribute" $ [r| namespace A; struct S { x: int; } table T {} union U {A.T} table Table { x: S (deprecated); y: T (deprecated); z: U (deprecated); } |] `shouldValidate` foldDecls [ struct ("A", StructDecl "S" 4 4 [ StructField "x" 0 0 SInt32 ]) , table ("A", TableDecl "T" NotRoot []) , union ("A", UnionDecl "U" [UnionVal "A_T" (TypeRef "A" "T")]) , table ("A", TableDecl "Table" NotRoot [ TableField 0 "x" (TStruct (TypeRef "A" "S") Opt) True , TableField 1 "y" (TTable (TypeRef "A" "T") Opt) True , TableField 3 "z" (TUnion (TypeRef "A" "U") Opt) True ] ) ] it "with default value" $ do let errorMsg = "[Table.x]: default values currently only supported for scalar fields (integers, floating point, bool, enums)" [r| table Table { x: S = 0; } struct S { x: int; } |] `shouldFail` errorMsg [r| table Table { x: T = 0; } table T{} |] `shouldFail` errorMsg [r| table Table { x: U = 0; } union U{T} |] `shouldFail` errorMsg describe "with vector fields" $ do it "simple" $ [r| table T { x: [string]; y: [int]; z: [bool]; } |] `shouldValidate` table ("", TableDecl "T" NotRoot [ TableField 0 "x" (TVector Opt VString) False , TableField 1 "y" (TVector Opt VInt32) False , TableField 2 "z" (TVector Opt VBool) False ]) it "where the elements are references" $ [r| namespace A; table Table { w: [B.E]; x: [B.S]; y: [B.T]; z: [B.U]; } namespace A.B; enum E : int16 { EA } struct S { x: ubyte; y: int64; } table T {} union U { T } |] `shouldValidate` foldDecls [ table ("A", TableDecl "Table" NotRoot [ TableField 0 "w" (TVector Opt (VEnum (TypeRef "A.B" "E") EInt16)) False , TableField 1 "x" (TVector Opt (VStruct (TypeRef "A.B" "S"))) False , TableField 2 "y" (TVector Opt (VTable (TypeRef "A.B" "T"))) False , TableField 4 "z" (TVector Opt (VUnion (TypeRef "A.B" "U"))) False ]) , enum ("A.B", EnumDecl "E" EInt16 [EnumVal "EA" 0]) , struct ("A.B", StructDecl "S" 8 16 [StructField "x" 7 0 SWord8, StructField "y" 0 8 SInt64]) , table ("A.B", TableDecl "T" NotRoot []) , union ("A.B", UnionDecl "U" [UnionVal "T" (TypeRef "A.B" "T")]) ] it "with `required` attribute" $ [r| table T { x: [byte] (required); } |] `shouldValidate` table ("", TableDecl "T" NotRoot [ TableField 0 "x" (TVector Req VInt8) False ]) it "with `deprecated` attribute" $ [r| table T { x: [string] (deprecated); } |] `shouldValidate` table ("", TableDecl "T" NotRoot [ TableField 0 "x" (TVector Opt VString) True ]) it "with default value" $ do let errorMsg = "[T.x]: default values currently only supported for scalar fields (integers, floating point, bool, enums)" [r| table T { x: [int] = a; } |] `shouldFail` errorMsg [r| table T { x: [int] = 0; } |] `shouldFail` errorMsg [r| table T { x: [int] = 0.0; } |] `shouldFail` errorMsg describe "with `id` attribute" $ do it "sorts fields" $ [r| table T { w: byte (id: 2); x: byte (id: 1); y: byte (id: 3); z: byte (id: 0); } |] `shouldValidate` foldDecls [ table ("", TableDecl "T" NotRoot [ TableField 0 "z" (TInt8 0) False , TableField 1 "x" (TInt8 0) False , TableField 2 "w" (TInt8 0) False , TableField 3 "y" (TInt8 0) False ] ) ] it "id must be skipped when field is a union" $ do [r| union U { T } table T { x: U (id: 2); y: byte (id: 3); z: byte (id: 0); } |] `shouldValidate` foldDecls [ table ("", TableDecl "T" NotRoot [ TableField 0 "z" (TInt8 0) False , TableField 2 "x" (TUnion (TypeRef "" "U") Opt) False , TableField 3 "y" (TInt8 0) False ] ) , union ("", UnionDecl "U" [UnionVal "T" (TypeRef "" "T")]) ] [r| union U { T } table T { x: U (id: 1); y: byte (id: 2); z: byte (id: 0); } |] `shouldFail` "[T.x]: the id of a union field must be the last field's id + 2" it "id must be skipped when field is a vector of unions" $ do [r| union U { T } table T { x: [U] (id: 2); y: byte (id: 3); z: byte (id: 0); } |] `shouldValidate` foldDecls [ table ("", TableDecl "T" NotRoot [ TableField 0 "z" (TInt8 0) False , TableField 2 "x" (TVector Opt (VUnion (TypeRef "" "U"))) False , TableField 3 "y" (TInt8 0) False ] ) , union ("", UnionDecl "U" [UnionVal "T" (TypeRef "" "T")]) ] [r| union U { T } table T { x: [U] (id: 1); y: byte (id: 2); z: byte (id: 0); } |] `shouldFail` "[T.x]: the id of a vector of unions field must be the last field's id + 2" it "id can be a string, if it's coercible to an integer" $ [r| table T { x: byte (id: "1"); y: byte (id: " 02 "); z: byte (id: "0"); } |] `shouldValidate` foldDecls [ table ("", TableDecl "T" NotRoot [ TableField 0 "z" (TInt8 0) False , TableField 1 "x" (TInt8 0) False , TableField 2 "y" (TInt8 0) False ] ) ] it "ids cannot be non-integral string" $ do [r| table T { x: byte (id: "0.3"); } |] `shouldFail` "[T]: expected attribute 'id' to have an integer value, e.g. 'id: 123'" [r| table T { x: byte (id: "hello"); } |] `shouldFail` "[T]: expected attribute 'id' to have an integer value, e.g. 'id: 123'" it "when one field has it, all other fields must have it as well" $ [r| table T { x: byte (id: 0); y: int; } |] `shouldFail` "[T]: either all fields or no fields must have an 'id' attribute" it "ids must be consecutive" $ [r| table T { x: byte (id: 0); y: int (id: 2); } |] `shouldFail` "[T.y]: field ids must be consecutive from 0; id 1 is missing" it "ids must start from 0" $ [r| table T { x: byte (id: 2); y: int (id: 1); } |] `shouldFail` "[T.y]: field ids must be consecutive from 0; id 0 is missing" it "can't have duplicate ids" $ [r| table T { x: byte (id: 0); y: int (id: 0); } |] `shouldFail` "[T.y]: field ids must be consecutive from 0; id 1 is missing" describe "unions" $ do it "simple" $ [r| table T1{} table T2{} union U { T1, T2 } |] `shouldValidate` foldDecls [ table ("", TableDecl "T1" NotRoot []) , table ("", TableDecl "T2" NotRoot []) , union ("", UnionDecl "U" [ UnionVal "T1" (TypeRef "" "T1") , UnionVal "T2" (TypeRef "" "T2") ]) ] it "with partially qualified type reference" $ [r| namespace A.B; table T1{} table T2{} namespace A; union U { A.B.T1, B.T2 } |] `shouldValidate` foldDecls [ table ("A.B", TableDecl "T1" NotRoot []) , table ("A.B", TableDecl "T2" NotRoot []) , union ("A", UnionDecl "U" [ UnionVal "A_B_T1" (TypeRef "A.B" "T1") , UnionVal "B_T2" (TypeRef "A.B" "T2") ]) ] it "with alias" $ [r| namespace A.B; table T1{} table T2{} namespace A; union U { Alias1 : A.B.T1, Alias2:B.T2 } |] `shouldValidate` foldDecls [ table ("A.B", TableDecl "T1" NotRoot []) , table ("A.B", TableDecl "T2" NotRoot []) , union ("A", UnionDecl "U" [ UnionVal "Alias1" (TypeRef "A.B" "T1") , UnionVal "Alias2" (TypeRef "A.B" "T2") ]) ] it "union member must be a valid reference" $ [r| union U { T } |] `shouldFail` "[U.T]: type 'T' does not exist (checked in these namespaces: '')" it "union members must be tables" $ do [r| union U { S } struct S {x: byte;} |] `shouldFail` "[U.S]: union members may only be tables" [r| union U { U2 } union U2 {T} table T{} |] `shouldFail` "[U.U2]: union members may only be tables" [r| union U { E } enum E : int {X} |] `shouldFail` "[U.E]: union members may only be tables" [r| union U { string } |] `shouldFail` "[U.string]: type 'string' does not exist (checked in these namespaces: '')" it "can't have duplicate identifiers" $ do [r| table T{} union U {T, T} |] `shouldFail` "[U]: 'T' declared more than once" [r| namespace A; table T{} union U {A.T, A.T} |] `shouldFail` "[A.U]: 'A_T' declared more than once" [r| namespace A; table T{} union U {A.T, A_T: T} |] `shouldFail` "[A.U]: 'A_T' declared more than once" it "can't use NONE as an alias" $ [r| table T{} union U {NONE: T} |] `shouldFail` "[U]: 'NONE' declared more than once" it "can't refer to a table named NONE" $ [r| table NONE {} union U {NONE} |] `shouldFail` "[U]: 'NONE' declared more than once" it "can refer to a table named NONE, if using a qualified name" $ [r| namespace A; table NONE {} union U {A.NONE} |] `shouldValidate` foldDecls [ table ("A", TableDecl "NONE" NotRoot []) , union ("A", UnionDecl "U" [ UnionVal "A_NONE" (TypeRef "A" "NONE") ]) ] it "can refer to a table named NONE, if using an alias" $ [r| namespace A; table NONE {} union U {alias: NONE} |] `shouldValidate` foldDecls [ table ("A", TableDecl "NONE" NotRoot []) , union ("A", UnionDecl "U" [ UnionVal "alias" (TypeRef "A" "NONE") ]) ] it "can use the same table twice, if using a qualified name" $ [r| namespace A; table T{} union U {T, A.T} |] `shouldValidate` foldDecls [ table ("A", TableDecl "T" NotRoot []) , union ("A", UnionDecl "U" [ UnionVal "T" (TypeRef "A" "T") , UnionVal "A_T" (TypeRef "A" "T") ]) ] it "can use the same table twice, if using an alias" $ [r| namespace A; table T{} union U {T, alias:T} |] `shouldValidate` foldDecls [ table ("A", TableDecl "T" NotRoot []) , union ("A", UnionDecl "U" [ UnionVal "T" (TypeRef "A" "T") , UnionVal "alias" (TypeRef "A" "T") ]) ] -- -- property: struct size (including paddings) = multiple of alignment -- -- property: alignment max alignment ??? foldDecls :: [ValidDecls] -> ValidDecls foldDecls = fold enum :: (Namespace, EnumDecl) -> ValidDecls enum e = SymbolTable [e] [] [] [] struct :: (Namespace, StructDecl) -> ValidDecls struct s = SymbolTable [] [s] [] [] table :: (Namespace, TableDecl) -> ValidDecls table t = SymbolTable [] [] [t] [] union :: (Namespace, UnionDecl) -> ValidDecls union u = SymbolTable [] [] [] [u] shouldSucceed :: HasCallStack => String -> Expectation shouldSucceed input = case parse P.schema "" input of Left e -> expectationFailure $ "Parsing failed with error:\n" <> showBundle e Right schema -> let schemas = FileTree "" schema [] in case validateSchemas schemas of Right _ -> pure () Left err -> expectationFailure (T.unpack err) shouldValidate :: HasCallStack => String -> ValidDecls -> Expectation shouldValidate input expectation = case parse P.schema "" input of Left e -> expectationFailure $ "Parsing failed with error:\n" <> showBundle e Right schema -> let schemas = FileTree "" schema [] in validateSchemas schemas `shouldBe` Right (FileTree "" expectation []) shouldFail :: String -> Text -> Expectation shouldFail input expectedErrorMsg = case parse P.schema "" input of Left e -> expectationFailure $ "Parsing failed with error:\n" <> showBundle e Right schema -> let schemas = FileTree "" schema [] in validateSchemas schemas `shouldBe` Left expectedErrorMsg showBundle :: (ShowErrorComponent e, Stream s) => ParseErrorBundle s e -> String showBundle = unlines . fmap indent . lines . errorBundlePretty where indent x = if null x then x else " " ++ x