flatbuffers-0.4.0.0: test/FlatBuffers/Internal/Compiler/THSpec.hs
module FlatBuffers.Internal.Compiler.THSpec where
import Control.Arrow (second)
import Data.Bits ((.&.))
import Data.Int
import Data.Text (Text)
import Data.Text qualified as T
import Data.Word
import FlatBuffers.Internal.Build
import FlatBuffers.Internal.Compiler.Parser qualified as P
import FlatBuffers.Internal.Compiler.SemanticAnalysis (validateSchemas)
import FlatBuffers.Internal.Compiler.SyntaxTree (FileTree(..))
import FlatBuffers.Internal.Compiler.TH
import FlatBuffers.Internal.FileIdentifier (HasFileIdentifier(..), unsafeFileIdentifier)
import FlatBuffers.Internal.Read
import FlatBuffers.Internal.Types
import FlatBuffers.Internal.Write
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import TestImports
import Text.Megaparsec
(ParseErrorBundle, ShowErrorComponent, TraversableStream, VisualStream, errorBundlePretty, parse)
import Text.RawString.QQ (r)
spec :: Spec
spec =
describe "TH" $ do
describe "Tables" $ do
it "with file identifier" $
[r|
table t {}
root_type t;
file_identifier "ABCD";
|] `shouldCompileTo`
[d|
data T
t :: WriteTable T
t = writeTable []
instance HasFileIdentifier T where
getFileIdentifier = unsafeFileIdentifier (T.pack "ABCD")
|]
it "naming conventions" $ do
let expected =
[d|
data SomePerson
somePerson :: Maybe Int32 -> WriteTable SomePerson
somePerson personAge = writeTable [ optionalDef 0 writeInt32TableField personAge ]
somePersonPersonAge :: Table SomePerson -> Either ReadError Int32
somePersonPersonAge = readTableFieldWithDef readInt32 0 0
|]
[r| table some_person { person_age: int; }|] `shouldCompileTo` expected
[r| table Some_Person { Person_Age: int; }|] `shouldCompileTo` expected
[r| table SomePerson { PersonAge: int; }|] `shouldCompileTo` expected
[r| table somePerson { personAge: int; }|] `shouldCompileTo` expected
it "with keyword as name" $
[r| table Type {} |] `shouldCompileTo`
[d|
data Type
type_ :: WriteTable Type
type_ = writeTable []
|]
describe "numeric fields + boolean" $ do
it "normal fields" $
[r|
table Scalars {
// scalars
a: uint8;
b: uint16;
c: uint32;
d: uint64;
e: int8;
f: int16;
g: int32;
h: int64;
i: float32;
j: float64;
k: bool;
}
|] `shouldCompileTo`
[d|
data Scalars
scalars ::
Maybe Word8
-> Maybe Word16
-> Maybe Word32
-> Maybe Word64
-> Maybe Int8
-> Maybe Int16
-> Maybe Int32
-> Maybe Int64
-> Maybe Float
-> Maybe Double
-> Maybe Bool
-> WriteTable Scalars
scalars a b c d e f g h i j k =
writeTable
[ optionalDef 0 writeWord8TableField a
, optionalDef 0 writeWord16TableField b
, optionalDef 0 writeWord32TableField c
, optionalDef 0 writeWord64TableField d
, optionalDef 0 writeInt8TableField e
, optionalDef 0 writeInt16TableField f
, optionalDef 0 writeInt32TableField g
, optionalDef 0 writeInt64TableField h
, optionalDef 0.0 writeFloatTableField i
, optionalDef 0.0 writeDoubleTableField j
, optionalDef False writeBoolTableField k
]
scalarsA :: Table Scalars -> Either ReadError Word8
scalarsA = readTableFieldWithDef readWord8 0 0
scalarsB :: Table Scalars -> Either ReadError Word16
scalarsB = readTableFieldWithDef readWord16 1 0
scalarsC :: Table Scalars -> Either ReadError Word32
scalarsC = readTableFieldWithDef readWord32 2 0
scalarsD :: Table Scalars -> Either ReadError Word64
scalarsD = readTableFieldWithDef readWord64 3 0
scalarsE :: Table Scalars -> Either ReadError Int8
scalarsE = readTableFieldWithDef readInt8 4 0
scalarsF :: Table Scalars -> Either ReadError Int16
scalarsF = readTableFieldWithDef readInt16 5 0
scalarsG :: Table Scalars -> Either ReadError Int32
scalarsG = readTableFieldWithDef readInt32 6 0
scalarsH :: Table Scalars -> Either ReadError Int64
scalarsH = readTableFieldWithDef readInt64 7 0
scalarsI :: Table Scalars -> Either ReadError Float
scalarsI = readTableFieldWithDef readFloat 8 0.0
scalarsJ :: Table Scalars -> Either ReadError Double
scalarsJ = readTableFieldWithDef readDouble 9 0.0
scalarsK :: Table Scalars -> Either ReadError Bool
scalarsK = readTableFieldWithDef readBool 10 False
|]
it "deprecated fields" $
[r|
table Scalars {
a: uint8 (deprecated);
b: uint16 (deprecated);
c: uint32 (deprecated);
d: uint64 (deprecated);
e: int8 (deprecated);
f: int16 (deprecated);
g: int32 (deprecated);
h: int64 (deprecated);
i: float32 (deprecated);
j: float64 (deprecated);
k: bool (deprecated);
}
|] `shouldCompileTo`
[d|
data Scalars
scalars :: WriteTable Scalars
scalars =
writeTable
[ deprecated, deprecated, deprecated, deprecated, deprecated, deprecated, deprecated, deprecated, deprecated, deprecated, deprecated
]
|]
it "with default values" $
[r|
table Scalars {
// scalars
a: uint8 = 8;
b: uint16 = 16;
c: uint32 = 32;
d: uint64 = 64;
e: int8 = -1;
f: int16 = -2;
g: int32 = -4;
h: int64 = -8;
i: float32 = 3.9;
j: float64 = -2.3e10;
k: bool = true;
}
|] `shouldCompileTo`
[d|
data Scalars
scalars ::
Maybe Word8
-> Maybe Word16
-> Maybe Word32
-> Maybe Word64
-> Maybe Int8
-> Maybe Int16
-> Maybe Int32
-> Maybe Int64
-> Maybe Float
-> Maybe Double
-> Maybe Bool
-> WriteTable Scalars
scalars a b c d e f g h i j k =
writeTable
[ optionalDef 8 writeWord8TableField a
, optionalDef 16 writeWord16TableField b
, optionalDef 32 writeWord32TableField c
, optionalDef 64 writeWord64TableField d
, optionalDef (-1) writeInt8TableField e
, optionalDef (-2) writeInt16TableField f
, optionalDef (-4) writeInt32TableField g
, optionalDef (-8) writeInt64TableField h
, optionalDef 3.9 writeFloatTableField i
, optionalDef (-2.3e10) writeDoubleTableField j
, optionalDef True writeBoolTableField k
]
scalarsA :: Table Scalars -> Either ReadError Word8
scalarsA = readTableFieldWithDef readWord8 0 8
scalarsB :: Table Scalars -> Either ReadError Word16
scalarsB = readTableFieldWithDef readWord16 1 16
scalarsC :: Table Scalars -> Either ReadError Word32
scalarsC = readTableFieldWithDef readWord32 2 32
scalarsD :: Table Scalars -> Either ReadError Word64
scalarsD = readTableFieldWithDef readWord64 3 64
scalarsE :: Table Scalars -> Either ReadError Int8
scalarsE = readTableFieldWithDef readInt8 4 (-1)
scalarsF :: Table Scalars -> Either ReadError Int16
scalarsF = readTableFieldWithDef readInt16 5 -2
scalarsG :: Table Scalars -> Either ReadError Int32
scalarsG = readTableFieldWithDef readInt32 6 -4
scalarsH :: Table Scalars -> Either ReadError Int64
scalarsH = readTableFieldWithDef readInt64 7 -8
scalarsI :: Table Scalars -> Either ReadError Float
scalarsI = readTableFieldWithDef readFloat 8 3.9
scalarsJ :: Table Scalars -> Either ReadError Double
scalarsJ = readTableFieldWithDef readDouble 9 -2.3e10
scalarsK :: Table Scalars -> Either ReadError Bool
scalarsK = readTableFieldWithDef readBool 10 True
|]
describe "string fields" $ do
it "normal field" $
[r| table T {s: string;} |] `shouldCompileTo`
[d|
data T
t :: Maybe Text -> WriteTable T
t s = writeTable [optional writeTextTableField s]
tS :: Table T -> Either ReadError (Maybe Text)
tS = readTableFieldOpt readText 0
|]
it "deprecated" $
[r| table T {s: string (deprecated);} |] `shouldCompileTo`
[d|
data T
t :: WriteTable T
t = writeTable [deprecated]
|]
it "required" $
[r| table T {s: string (required);} |] `shouldCompileTo`
[d|
data T
t :: Text -> WriteTable T
t s = writeTable [writeTextTableField s]
tS :: Table T -> Either ReadError Text
tS = readTableFieldReq readText 0 "s"
|]
describe "enum fields" $
it "are encoded as fields of the underlying type" $
[r|
enum Color:int8 { Red = 1, Blue }
table T {x: Color = Blue; }
|] `shouldCompileTo`
[d|
data Color = ColorRed | ColorBlue
deriving (Eq, Show, Read, Ord, Bounded)
toColor :: Int8 -> Maybe Color
toColor n =
case n of
1 -> Just ColorRed
2 -> Just ColorBlue
_ -> Nothing
{-# INLINE toColor #-}
fromColor :: Color -> Int8
fromColor n =
case n of
ColorRed -> 1
ColorBlue -> 2
{-# INLINE fromColor #-}
colorName :: Color -> Text
colorName c =
case c of
ColorRed -> T.pack "Red"
ColorBlue -> T.pack "Blue"
{-# INLINE colorName #-}
data T
t :: Maybe Int8 -> WriteTable T
t x = writeTable [ optionalDef 2 writeInt8TableField x ]
tX :: Table T -> Either ReadError Int8
tX = readTableFieldWithDef readInt8 0 2
|]
describe "enum fields with bit_flags" $
it "are encoded as fields of the underlying type" $
[r|
enum Colors: ubyte (bit_flags) { Red = 2, Blue }
table T {x: Colors = Blue; }
|] `shouldCompileTo`
[d|
colorsRed :: Word8
colorsRed = 4
colorsBlue :: Word8
colorsBlue = 8
allColors :: [Word8]
allColors = [ colorsRed, colorsBlue ]
{-# INLINE allColors #-}
colorsNames :: Word8 -> [Text]
colorsNames c = res2
where
res0 = []
res1 = if colorsBlue .&. c /= 0 then T.pack "Blue" : res0 else res0
res2 = if colorsRed .&. c /= 0 then T.pack "Red" : res1 else res1
{-# INLINE colorsNames #-}
data T
t :: Maybe Word8 -> WriteTable T
t x = writeTable [ optionalDef 8 writeWord8TableField x ]
tX :: Table T -> Either ReadError Word8
tX = readTableFieldWithDef readWord8 0 8
|]
describe "struct fields" $ do
it "normal field" $
[r|
table T {x: S;}
struct S {x: int;}
|] `shouldCompileTo`
[d|
data S
instance IsStruct S where
structAlignmentOf = 4
structSizeOf = 4
s :: Int32 -> WriteStruct S
s x = WriteStruct (buildInt32 x)
sX :: Struct S -> Either ReadError Int32
sX = readStructField readInt32 0
data T
t :: Maybe (WriteStruct S) -> WriteTable T
t x = writeTable [optional writeStructTableField x]
tX :: Table T -> Either ReadError (Maybe (Struct S))
tX = readTableFieldOpt (Right . readStruct) 0
|]
it "deprecated" $
[r|
table T {x: S (deprecated);}
struct S {x: int;}
|] `shouldCompileTo`
[d|
data S
instance IsStruct S where
structAlignmentOf = 4
structSizeOf = 4
s :: Int32 -> WriteStruct S
s x = WriteStruct (buildInt32 x)
sX :: Struct S -> Either ReadError Int32
sX = readStructField readInt32 0
data T
t :: WriteTable T
t = writeTable [deprecated]
|]
it "required" $
[r|
table T {X: S (required) ;}
struct S {x: int;}
|] `shouldCompileTo`
[d|
data S
instance IsStruct S where
structAlignmentOf = 4
structSizeOf = 4
s :: Int32 -> WriteStruct S
s x = WriteStruct (buildInt32 x)
sX :: Struct S -> Either ReadError Int32
sX = readStructField readInt32 0
data T
t :: WriteStruct S -> WriteTable T
t x = writeTable [writeStructTableField x]
tX :: Table T -> Either ReadError (Struct S)
tX = readTableFieldReq (Right . readStruct) 0 "X"
|]
describe "table fields" $ do
it "normal field" $
[r|
table T1 {x: t2;}
table t2{}
|] `shouldCompileTo`
[d|
data T1
t1 :: Maybe (WriteTable T2) -> WriteTable T1
t1 x = writeTable [optional writeTableTableField x]
t1X :: Table T1 -> Either ReadError (Maybe (Table T2))
t1X = readTableFieldOpt readTable 0
data T2
t2 :: WriteTable T2
t2 = writeTable []
|]
it "deprecated" $
[r|
table T1 {x: t2 (deprecated) ;}
table t2{}
|] `shouldCompileTo`
[d|
data T1
t1 :: WriteTable T1
t1 = writeTable [deprecated]
data T2
t2 :: WriteTable T2
t2 = writeTable []
|]
it "required" $
[r|
table T1 {x: t2 (required) ;}
table t2{}
|] `shouldCompileTo`
[d|
data T1
t1 :: WriteTable T2 -> WriteTable T1
t1 x = writeTable [writeTableTableField x]
t1X :: Table T1 -> Either ReadError (Table T2)
t1X = readTableFieldReq readTable 0 "x"
data T2
t2 :: WriteTable T2
t2 = writeTable []
|]
describe "union fields" $ do
it "normal field" $
[r|
table t1 {x: u1;}
union u1{t1}
|] `shouldCompileTo`
[d|
data T1
t1 :: Maybe (WriteUnion U1) -> WriteTable T1
t1 x = writeTable
[ optional writeUnionTypeTableField x
, optional writeUnionValueTableField x
]
t1X :: Table T1 -> Either ReadError (Maybe (Union U1))
t1X = readTableFieldUnionOpt readU1 1
data U1
= U1T1 !(Table T1)
u1T1 :: WriteTable T1 -> WriteUnion U1
u1T1 = writeUnion 1
readU1 :: Positive Word8 -> PositionInfo -> Either ReadError (Union U1)
readU1 n pos =
case getPositive n of
1 -> Union . U1T1 <$> readTable' pos
n' -> pure $! UnionUnknown n'
|]
it "deprecated" $
[r|
table t1 {x: u1 (deprecated) ;}
union u1{t1}
|] `shouldCompileTo`
[d|
data T1
t1 :: WriteTable T1
t1 = writeTable
[ deprecated
, deprecated
]
data U1
= U1T1 !(Table T1)
u1T1 :: WriteTable T1 -> WriteUnion U1
u1T1 = writeUnion 1
readU1 :: Positive Word8 -> PositionInfo -> Either ReadError (Union U1)
readU1 n pos =
case getPositive n of
1 -> Union . U1T1 <$> readTable' pos
n' -> pure $! UnionUnknown n'
|]
it "required" $
[r|
table t1 {x: u1 (required) ;}
union u1{t1}
|] `shouldCompileTo`
[d|
data T1
t1 :: WriteUnion U1 -> WriteTable T1
t1 x = writeTable
[ writeUnionTypeTableField x
, writeUnionValueTableField x
]
t1X :: Table T1 -> Either ReadError (Union U1)
t1X = readTableFieldUnionReq readU1 1 "x"
data U1
= U1T1 !(Table T1)
u1T1 :: WriteTable T1 -> WriteUnion U1
u1T1 = writeUnion 1
readU1 :: Positive Word8 -> PositionInfo -> Either ReadError (Union U1)
readU1 n pos =
case getPositive n of
1 -> Union . U1T1 <$> readTable' pos
n' -> pure $! UnionUnknown n'
|]
describe "vector fields" $ do
it "deprecated" $
[r|
table t1 {
a: [int8] (deprecated);
b: [u1] (deprecated);
}
union u1{t1}
|] `shouldCompileTo`
[d|
data T1
t1 :: WriteTable T1
t1 = writeTable [ deprecated, deprecated, deprecated ]
data U1
= U1T1 !(Table T1)
u1T1 :: WriteTable T1 -> WriteUnion U1
u1T1 = writeUnion 1
readU1 :: Positive Word8 -> PositionInfo -> Either ReadError (Union U1)
readU1 n pos =
case getPositive n of
1 -> Union . U1T1 <$> readTable' pos
n' -> pure $! UnionUnknown n'
|]
describe "vector of numeric types / booolean" $ do
it "normal" $
[r|
table t1 {
a: [uint8];
b: [uint16];
c: [uint32];
d: [uint64];
e: [int8];
f: [int16];
g: [int32];
h: [int64];
i: [float32];
j: [float64];
k: [bool];
}
|] `shouldCompileTo`
[d|
data T1
t1 ::
Maybe (WriteVector Word8)
-> Maybe (WriteVector Word16)
-> Maybe (WriteVector Word32)
-> Maybe (WriteVector Word64)
-> Maybe (WriteVector Int8)
-> Maybe (WriteVector Int16)
-> Maybe (WriteVector Int32)
-> Maybe (WriteVector Int64)
-> Maybe (WriteVector Float)
-> Maybe (WriteVector Double)
-> Maybe (WriteVector Bool)
-> WriteTable T1
t1 a b c d e f g h i j k =
writeTable
[ optional writeVectorWord8TableField a
, optional writeVectorWord16TableField b
, optional writeVectorWord32TableField c
, optional writeVectorWord64TableField d
, optional writeVectorInt8TableField e
, optional writeVectorInt16TableField f
, optional writeVectorInt32TableField g
, optional writeVectorInt64TableField h
, optional writeVectorFloatTableField i
, optional writeVectorDoubleTableField j
, optional writeVectorBoolTableField k
]
t1A :: Table T1 -> Either ReadError (Maybe (Vector Word8))
t1A = readTableFieldOpt (readPrimVector VectorWord8) 0
t1B :: Table T1 -> Either ReadError (Maybe (Vector Word16))
t1B = readTableFieldOpt (readPrimVector VectorWord16) 1
t1C :: Table T1 -> Either ReadError (Maybe (Vector Word32))
t1C = readTableFieldOpt (readPrimVector VectorWord32) 2
t1D :: Table T1 -> Either ReadError (Maybe (Vector Word64))
t1D = readTableFieldOpt (readPrimVector VectorWord64) 3
t1E :: Table T1 -> Either ReadError (Maybe (Vector Int8))
t1E = readTableFieldOpt (readPrimVector VectorInt8) 4
t1F :: Table T1 -> Either ReadError (Maybe (Vector Int16))
t1F = readTableFieldOpt (readPrimVector VectorInt16) 5
t1G :: Table T1 -> Either ReadError (Maybe (Vector Int32))
t1G = readTableFieldOpt (readPrimVector VectorInt32) 6
t1H :: Table T1 -> Either ReadError (Maybe (Vector Int64))
t1H = readTableFieldOpt (readPrimVector VectorInt64) 7
t1I :: Table T1 -> Either ReadError (Maybe (Vector Float))
t1I = readTableFieldOpt (readPrimVector VectorFloat) 8
t1J :: Table T1 -> Either ReadError (Maybe (Vector Double))
t1J = readTableFieldOpt (readPrimVector VectorDouble) 9
t1K :: Table T1 -> Either ReadError (Maybe (Vector Bool))
t1K = readTableFieldOpt (readPrimVector VectorBool) 10
|]
it "required" $
[r|
table t1 {
a: [uint8] (required);
b: [uint16] (required);
c: [uint32] (required);
d: [uint64] (required);
e: [int8] (required);
f: [int16] (required);
g: [int32] (required);
h: [int64] (required);
i: [float32] (required);
j: [float64] (required);
k: [bool] (required);
}
|] `shouldCompileTo`
[d|
data T1
t1 ::
WriteVector Word8
-> WriteVector Word16
-> WriteVector Word32
-> WriteVector Word64
-> WriteVector Int8
-> WriteVector Int16
-> WriteVector Int32
-> WriteVector Int64
-> WriteVector Float
-> WriteVector Double
-> WriteVector Bool
-> WriteTable T1
t1 a b c d e f g h i j k =
writeTable
[ writeVectorWord8TableField a
, writeVectorWord16TableField b
, writeVectorWord32TableField c
, writeVectorWord64TableField d
, writeVectorInt8TableField e
, writeVectorInt16TableField f
, writeVectorInt32TableField g
, writeVectorInt64TableField h
, writeVectorFloatTableField i
, writeVectorDoubleTableField j
, writeVectorBoolTableField k
]
t1A :: Table T1 -> Either ReadError (Vector Word8)
t1A = readTableFieldReq (readPrimVector VectorWord8) 0 "a"
t1B :: Table T1 -> Either ReadError (Vector Word16)
t1B = readTableFieldReq (readPrimVector VectorWord16) 1 "b"
t1C :: Table T1 -> Either ReadError (Vector Word32)
t1C = readTableFieldReq (readPrimVector VectorWord32) 2 "c"
t1D :: Table T1 -> Either ReadError (Vector Word64)
t1D = readTableFieldReq (readPrimVector VectorWord64) 3 "d"
t1E :: Table T1 -> Either ReadError (Vector Int8)
t1E = readTableFieldReq (readPrimVector VectorInt8) 4 "e"
t1F :: Table T1 -> Either ReadError (Vector Int16)
t1F = readTableFieldReq (readPrimVector VectorInt16) 5 "f"
t1G :: Table T1 -> Either ReadError (Vector Int32)
t1G = readTableFieldReq (readPrimVector VectorInt32) 6 "g"
t1H :: Table T1 -> Either ReadError (Vector Int64)
t1H = readTableFieldReq (readPrimVector VectorInt64) 7 "h"
t1I :: Table T1 -> Either ReadError (Vector Float)
t1I = readTableFieldReq (readPrimVector VectorFloat) 8 "i"
t1J :: Table T1 -> Either ReadError (Vector Double)
t1J = readTableFieldReq (readPrimVector VectorDouble) 9 "j"
t1K :: Table T1 -> Either ReadError (Vector Bool)
t1K = readTableFieldReq (readPrimVector VectorBool) 10 "k"
|]
describe "vector of strings" $ do
it "normal" $
[r|
table t1 { a: [string]; }
|] `shouldCompileTo`
[d|
data T1
t1 :: Maybe (WriteVector Text) -> WriteTable T1
t1 a = writeTable [ optional writeVectorTextTableField a ]
t1A :: Table T1 -> Either ReadError (Maybe (Vector Text))
t1A = readTableFieldOpt (readPrimVector VectorText) 0
|]
it "required" $
[r|
table t1 { a: [string] (required); }
|] `shouldCompileTo`
[d|
data T1
t1 :: WriteVector Text -> WriteTable T1
t1 a = writeTable [ writeVectorTextTableField a ]
t1A :: Table T1 -> Either ReadError (Vector Text)
t1A = readTableFieldReq (readPrimVector VectorText) 0 "a"
|]
describe "vector of enums" $ do
it "normal" $
[r|
table t1 { a: [color]; }
enum color : short { red }
|] `shouldCompileTo`
[d|
data Color = ColorRed
deriving (Eq, Show, Read, Ord, Bounded)
toColor :: Int16 -> Maybe Color
toColor n =
case n of
0 -> Just ColorRed
_ -> Nothing
{-# INLINE toColor #-}
fromColor :: Color -> Int16
fromColor n = case n of ColorRed -> 0
{-# INLINE fromColor #-}
colorName :: Color -> Text
colorName c = case c of ColorRed -> T.pack "red"
{-# INLINE colorName #-}
data T1
t1 :: Maybe (WriteVector Int16) -> WriteTable T1
t1 a = writeTable
[ optional writeVectorInt16TableField a
]
t1A :: Table T1 -> Either ReadError (Maybe (Vector Int16))
t1A = readTableFieldOpt (readPrimVector VectorInt16) 0
|]
it "required" $
[r|
table t1 { a: [color] (required); }
enum color : short { red }
|] `shouldCompileTo`
[d|
data Color = ColorRed
deriving (Eq, Show, Read, Ord, Bounded)
toColor :: Int16 -> Maybe Color
toColor n =
case n of
0 -> Just ColorRed
_ -> Nothing
{-# INLINE toColor #-}
fromColor :: Color -> Int16
fromColor n = case n of ColorRed -> 0
{-# INLINE fromColor #-}
colorName :: Color -> Text
colorName c = case c of ColorRed -> T.pack "red"
{-# INLINE colorName #-}
data T1
t1 :: WriteVector Int16 -> WriteTable T1
t1 a = writeTable
[ writeVectorInt16TableField a
]
t1A :: Table T1 -> Either ReadError (Vector Int16)
t1A = readTableFieldReq (readPrimVector VectorInt16) 0 "a"
|]
describe "vector of enums with bit_flags" $ do
it "normal" $
[r|
table t1 { a: [colors]; }
enum colors : ulong (bit_flags) { red = 20 }
|] `shouldCompileTo`
[d|
colorsRed :: Word64
colorsRed = 1048576
allColors :: [Word64]
allColors = [ colorsRed ]
{-# INLINE allColors #-}
colorsNames :: Word64 -> [Text]
colorsNames c = res1
where
res0 = []
res1 = if colorsRed .&. c /= 0 then T.pack "red" : res0 else res0
{-# INLINE colorsNames #-}
data T1
t1 :: Maybe (WriteVector Word64) -> WriteTable T1
t1 a = writeTable
[ optional writeVectorWord64TableField a
]
t1A :: Table T1 -> Either ReadError (Maybe (Vector Word64))
t1A = readTableFieldOpt (readPrimVector VectorWord64) 0
|]
it "required" $
[r|
table t1 { a: [colors] (required); }
enum colors : uint64 (bit_flags) { red = 63 }
|] `shouldCompileTo`
[d|
colorsRed :: Word64
colorsRed = 9223372036854775808
allColors :: [Word64]
allColors = [ colorsRed ]
{-# INLINE allColors #-}
colorsNames :: Word64 -> [Text]
colorsNames c = res1
where
res0 = []
res1 = if colorsRed .&. c /= 0 then T.pack "red" : res0 else res0
{-# INLINE colorsNames #-}
data T1
t1 :: WriteVector Word64 -> WriteTable T1
t1 a = writeTable
[ writeVectorWord64TableField a
]
t1A :: Table T1 -> Either ReadError (Vector Word64)
t1A = readTableFieldReq (readPrimVector VectorWord64) 0 "a"
|]
describe "vector of structs" $ do
it "normal" $
[r|
table t1 { a: [s1]; }
struct s1 (force_align: 8) { a: ubyte; }
|] `shouldCompileTo`
[d|
data S1
instance IsStruct S1 where
structAlignmentOf = 8
structSizeOf = 8
s1 :: Word8 -> WriteStruct S1
s1 a = WriteStruct (buildWord8 a <> buildPadding 7)
s1A :: Struct S1 -> Either ReadError Word8
s1A = readStructField readWord8 0
data T1
t1 :: Maybe (WriteVector (WriteStruct S1)) -> WriteTable T1
t1 a = writeTable
[ optional writeVectorStructTableField a
]
t1A :: Table T1 -> Either ReadError (Maybe (Vector (Struct S1)))
t1A = readTableFieldOpt (readPrimVector VectorStruct) 0
|]
it "required" $
[r|
table t1 { a: [s1] (required); }
struct s1 (force_align: 8) { a: ubyte; }
|] `shouldCompileTo`
[d|
data S1
instance IsStruct S1 where
structAlignmentOf = 8
structSizeOf = 8
s1 :: Word8 -> WriteStruct S1
s1 a = WriteStruct (buildWord8 a <> buildPadding 7)
s1A :: Struct S1 -> Either ReadError Word8
s1A = readStructField readWord8 0
data T1
t1 :: WriteVector (WriteStruct S1) -> WriteTable T1
t1 a = writeTable
[ writeVectorStructTableField a
]
t1A :: Table T1 -> Either ReadError (Vector (Struct S1))
t1A = readTableFieldReq (readPrimVector VectorStruct) 0 "a"
|]
describe "vector of tables" $ do
it "normal" $
[r|
table t1 { a: [t1]; }
|] `shouldCompileTo`
[d|
data T1
t1 :: Maybe (WriteVector (WriteTable T1)) -> WriteTable T1
t1 a = writeTable
[ optional writeVectorTableTableField a
]
t1A :: Table T1 -> Either ReadError (Maybe (Vector (Table T1)))
t1A = readTableFieldOpt readTableVector 0
|]
it "required" $
[r|
table t1 { a: [t1] (required); }
|] `shouldCompileTo`
[d|
data T1
t1 :: WriteVector (WriteTable T1) -> WriteTable T1
t1 a = writeTable
[ writeVectorTableTableField a
]
t1A :: Table T1 -> Either ReadError (Vector (Table T1))
t1A = readTableFieldReq readTableVector 0 "a"
|]
describe "vector of unions" $ do
it "normal" $
[r|
table t1 {x: [u1];}
union u1{t1}
|] `shouldCompileTo`
[d|
data T1
t1 :: Maybe (WriteVector (WriteUnion U1)) -> WriteTable T1
t1 x = writeTable
[ optional writeUnionTypesVectorTableField x
, optional writeUnionValuesVectorTableField x
]
t1X :: Table T1 -> Either ReadError (Maybe (Vector (Union U1)))
t1X = readTableFieldUnionVectorOpt readU1 1
data U1
= U1T1 !(Table T1)
u1T1 :: WriteTable T1 -> WriteUnion U1
u1T1 = writeUnion 1
readU1 :: Positive Word8 -> PositionInfo -> Either ReadError (Union U1)
readU1 n pos =
case getPositive n of
1 -> Union . U1T1 <$> readTable' pos
n' -> pure $! UnionUnknown n'
|]
it "required" $
[r|
table t1 {x: [u1] (required);}
union u1{t1}
|] `shouldCompileTo`
[d|
data T1
t1 :: WriteVector (WriteUnion U1) -> WriteTable T1
t1 x = writeTable
[ writeUnionTypesVectorTableField x
, writeUnionValuesVectorTableField x
]
t1X :: Table T1 -> Either ReadError (Vector (Union U1))
t1X = readTableFieldUnionVectorReq readU1 1 "x"
data U1
= U1T1 !(Table T1)
u1T1 :: WriteTable T1 -> WriteUnion U1
u1T1 = writeUnion 1
readU1 :: Positive Word8 -> PositionInfo -> Either ReadError (Union U1)
readU1 n pos =
case getPositive n of
1 -> Union . U1T1 <$> readTable' pos
n' -> pure $! UnionUnknown n'
|]
describe "Enums" $
it "naming conventions" $ do
let expected redName greenName =
[d|
data MyColor = MyColorIsRed | MyColorIsGreen
deriving (Eq, Show, Read, Ord, Bounded)
toMyColor :: Int16 -> Maybe MyColor
toMyColor n =
case n of
-2 -> Just MyColorIsRed
-1 -> Just MyColorIsGreen
_ -> Nothing
{-# INLINE toMyColor #-}
fromMyColor :: MyColor -> Int16
fromMyColor n =
case n of
MyColorIsRed -> -2
MyColorIsGreen -> -1
{-# INLINE fromMyColor #-}
myColorName :: MyColor -> Text
myColorName c =
case c of
MyColorIsRed -> T.pack $(stringE redName)
MyColorIsGreen -> T.pack $(stringE greenName)
{-# INLINE myColorName #-}
|]
[r| enum my_color: int16 { is_red = -2, is_green } |] `shouldCompileTo` expected "is_red" "is_green"
[r| enum My_Color: int16 { Is_Red = -2, Is_Green } |] `shouldCompileTo` expected "Is_Red" "Is_Green"
[r| enum MyColor: int16 { IsRed = -2, IsGreen } |] `shouldCompileTo` expected "IsRed" "IsGreen"
[r| enum myColor: int16 { isRed = -2, isGreen } |] `shouldCompileTo` expected "isRed" "isGreen"
describe "Enums with bit_flags" $
it "naming conventions" $ do
let expected redName greenName =
[d|
myColorsIsRed :: Word16
myColorsIsRed = 4
myColorsIsGreen :: Word16
myColorsIsGreen = 8
allMyColors :: [Word16]
allMyColors = [ myColorsIsRed, myColorsIsGreen ]
{-# INLINE allMyColors #-}
myColorsNames :: Word16 -> [Text]
myColorsNames c = res2
where
res0 = []
res1 = if myColorsIsGreen .&. c /= 0 then T.pack $(stringE greenName) : res0 else res0
res2 = if myColorsIsRed .&. c /= 0 then T.pack $(stringE redName) : res1 else res1
{-# INLINE myColorsNames #-}
|]
[r| enum my_colors: ushort (bit_flags) { is_red = 2, is_green } |] `shouldCompileTo` expected "is_red" "is_green"
[r| enum My_Colors: ushort (bit_flags) { Is_Red = 2, Is_Green } |] `shouldCompileTo` expected "Is_Red" "Is_Green"
[r| enum MyColors: ushort (bit_flags) { IsRed = 2, IsGreen } |] `shouldCompileTo` expected "IsRed" "IsGreen"
[r| enum myColors: ushort (bit_flags) { isRed = 2, isGreen } |] `shouldCompileTo` expected "isRed" "isGreen"
describe "Structs" $ do
it "naming conventions" $ do
let expected =
[d|
data MyStruct
instance IsStruct MyStruct where
structAlignmentOf = 4
structSizeOf = 4
myStruct :: Int32 -> WriteStruct MyStruct
myStruct myField = WriteStruct (buildInt32 myField)
myStructMyField :: Struct MyStruct -> Either ReadError Int32
myStructMyField = readStructField readInt32 0
|]
[r| struct my_struct { my_field: int; } |] `shouldCompileTo` expected
[r| struct My_Struct { My_Field: int; } |] `shouldCompileTo` expected
[r| struct MyStruct { MyField: int; } |] `shouldCompileTo` expected
[r| struct myStruct { myField: int; } |] `shouldCompileTo` expected
it "with primitive fields" $
[r|
struct Scalars {
a: uint8;
b: uint16;
c: uint32;
d: uint64;
e: int8;
f: int16;
g: int32;
h: int64;
i: float32;
j: float64;
k: bool;
}
|] `shouldCompileTo`
[d|
data Scalars
instance IsStruct Scalars where
structAlignmentOf = 8
structSizeOf = 56
scalars ::
Word8
-> Word16
-> Word32
-> Word64
-> Int8
-> Int16
-> Int32
-> Int64
-> Float
-> Double
-> Bool
-> WriteStruct Scalars
scalars a b c d e f g h i j k =
WriteStruct (
buildWord8 a <> buildPadding 1 <> buildWord16 b <> buildWord32 c
<> buildWord64 d
<> buildInt8 e <> buildPadding 1 <> buildInt16 f <> buildInt32 g
<> buildInt64 h
<> buildFloat i <> buildPadding 4
<> buildDouble j
<> buildBool k <> buildPadding 7
)
scalarsA :: Struct Scalars -> Either ReadError Word8
scalarsA = readStructField readWord8 0
scalarsB :: Struct Scalars -> Either ReadError Word16
scalarsB = readStructField readWord16 2
scalarsC :: Struct Scalars -> Either ReadError Word32
scalarsC = readStructField readWord32 4
scalarsD :: Struct Scalars -> Either ReadError Word64
scalarsD = readStructField readWord64 8
scalarsE :: Struct Scalars -> Either ReadError Int8
scalarsE = readStructField readInt8 16
scalarsF :: Struct Scalars -> Either ReadError Int16
scalarsF = readStructField readInt16 18
scalarsG :: Struct Scalars -> Either ReadError Int32
scalarsG = readStructField readInt32 20
scalarsH :: Struct Scalars -> Either ReadError Int64
scalarsH = readStructField readInt64 24
scalarsI :: Struct Scalars -> Either ReadError Float
scalarsI = readStructField readFloat 32
scalarsJ :: Struct Scalars -> Either ReadError Double
scalarsJ = readStructField readDouble 40
scalarsK :: Struct Scalars -> Either ReadError Bool
scalarsK = readStructField readBool 48
|]
it "with enum fields" $
[r|
struct S { e: E; }
enum E : byte { X }
|] `shouldCompileTo`
[d|
data E = EX
deriving (Eq, Show, Read, Ord, Bounded)
toE :: Int8 -> Maybe E
toE n = case n of
0 -> Just EX
_ -> Nothing
{-# INLINE toE #-}
fromE :: E -> Int8
fromE n = case n of EX -> 0
{-# INLINE fromE #-}
eName :: E -> Text
eName c = case c of EX -> T.pack "X"
{-# INLINE eName #-}
data S
instance IsStruct S where
structAlignmentOf = 1
structSizeOf = 1
s :: Int8 -> WriteStruct S
s e = WriteStruct (buildInt8 e)
sE :: Struct S -> Either ReadError Int8
sE = readStructField readInt8 0
|]
it "with enum fields with bit_flags" $
[r|
struct S { e: E; }
enum E : ubyte (bit_flags) { X }
|] `shouldCompileTo`
[d|
eX :: Word8
eX = 1
allE :: [Word8]
allE = [ eX ]
{-# INLINE allE #-}
eNames :: Word8 -> [Text]
eNames c = res1
where
res0 = []
res1 = if eX .&. c /= 0 then T.pack "X" : res0 else res0
{-# INLINE eNames #-}
data S
instance IsStruct S where
structAlignmentOf = 1
structSizeOf = 1
s :: Word8 -> WriteStruct S
s e = WriteStruct (buildWord8 e)
sE :: Struct S -> Either ReadError Word8
sE = readStructField readWord8 0
|]
it "with nested structs" $
[r|
struct S1 (force_align: 2) { s2: S2; }
struct S2 { x: int8; }
|] `shouldCompileTo`
[d|
data S1
instance IsStruct S1 where
structAlignmentOf = 2
structSizeOf = 2
s1 :: WriteStruct S2 -> WriteStruct S1
s1 s2 = WriteStruct (buildStruct s2 <> buildPadding 1)
s1S2 :: Struct S1 -> Struct S2
s1S2 = readStructField readStruct 0
data S2
instance IsStruct S2 where
structAlignmentOf = 1
structSizeOf = 1
s2 :: Int8 -> WriteStruct S2
s2 x = WriteStruct (buildInt8 x)
s2X :: Struct S2 -> Either ReadError Int8
s2X = readStructField readInt8 0
|]
it "with keyword as name" $
[r| struct Type { x : byte; } |] `shouldCompileTo`
[d|
data Type
instance IsStruct Type
where structAlignmentOf = 1
structSizeOf = 1
type_ :: Int8 -> WriteStruct Type
type_ x = WriteStruct (buildInt8 x)
typeX :: Struct Type -> Either ReadError Int8
typeX = readStructField readInt8 0
|]
describe "Unions" $
it "naming conventions" $ do
let expected =
[d|
data MySword
mySword :: WriteTable MySword
mySword = writeTable []
data MyWeapon
= MyWeaponMySword !(Table MySword)
| MyWeaponMyAlias !(Table MySword)
myWeaponMySword :: WriteTable MySword -> WriteUnion MyWeapon
myWeaponMySword = writeUnion 1
myWeaponMyAlias :: WriteTable MySword -> WriteUnion MyWeapon
myWeaponMyAlias = writeUnion 2
readMyWeapon :: Positive Word8 -> PositionInfo -> Either ReadError (Union MyWeapon)
readMyWeapon n pos =
case getPositive n of
1 -> Union . MyWeaponMySword <$> readTable' pos
2 -> Union . MyWeaponMyAlias <$> readTable' pos
n' -> pure $! UnionUnknown n'
|]
[r| table my_sword{} union my_weapon { my_sword, my_alias: my_sword } |] `shouldCompileTo` expected
[r| table My_sword{} union My_weapon { My_sword, My_alias: My_sword } |] `shouldCompileTo` expected
[r| table MySword{} union MyWeapon { MySword, MyAlias: MySword } |] `shouldCompileTo` expected
[r| table mySword{} union myWeapon { mySword, myAlias: mySword } |] `shouldCompileTo` expected
shouldCompileTo :: HasCallStack => String -> Q [Dec] -> Expectation
shouldCompileTo input expectedQ =
case parse P.schema "" input of
Left e -> expectationFailure $ "Parsing failed with error:\n" <> showBundle e
Right schema ->
let schemas = FileTree "" schema mempty
in case validateSchemas schemas of
Left err -> expectationFailure err
Right (FileTree _ root _) -> do
ast <- runQ (compileSymbolTable root)
expected <- runQ expectedQ
PrettyAst (normalizeDec <$> ast) `shouldBe` PrettyAst (normalizeDec <$> expected)
newtype PrettyAst = PrettyAst [Dec]
deriving Eq
instance Show PrettyAst where
show (PrettyAst decs) = pprint decs
showBundle :: (ShowErrorComponent e, TraversableStream s, VisualStream s) => ParseErrorBundle s e -> String
showBundle = unlines . fmap indent . lines . errorBundlePretty
where
indent x = if null x
then x
else " " ++ x
-- | This function normalize ASTs to make them comparable.
-- * ASTs obtained from quasiquotes (like what we're doing in these tests) use `newName`, whereas we often use `mkName`.
-- So we have to normalize names here.
-- * Declarations like `x = 5` are interpreted as a value declaration, but they're equivalent to a
-- function declaration with a single clause and a single pattern.
normalizeDec :: Dec -> Dec
normalizeDec dec = valToFun $
case dec of
DataD a name b c cons e -> DataD a (normalizeName name) b c (normalizeCon <$> cons) e
SigD n t -> SigD (normalizeName n) (normalizeType t)
FunD n clauses -> FunD (normalizeName n) (normalizeClause <$> clauses)
ValD pat body decs -> ValD (normalizePat pat) (normalizeBody body) (normalizeDec <$> decs)
PragmaD p -> PragmaD (normalizePragma p)
ClassD cxt n tvs funDeps decs ->
ClassD
(normalizeType <$> cxt)
(normalizeName n)
(normalizeTyVarBndr <$> tvs)
funDeps
(normalizeDec <$> decs)
InstanceD overlap cxt typ decs ->
InstanceD
overlap
(normalizeType <$> cxt)
(normalizeType typ)
(normalizeDec <$> decs)
_ -> dec
-- | values with a simple variable pattern (e.g. `x = 5`) are equivalent to functions with only one clause and no parameters
valToFun :: Dec -> Dec
valToFun dec =
case dec of
ValD (VarP name) body decs -> FunD name [Clause [] body decs]
_ -> dec
normalizePragma :: Pragma -> Pragma
normalizePragma p =
case p of
InlineP n i rm p -> InlineP (normalizeName n) i rm p
_ -> p
normalizeCon :: Con -> Con
normalizeCon c =
case c of
NormalC name bangTypes -> NormalC (normalizeName name) (second normalizeType <$> bangTypes)
_ -> c
normalizeType :: Type -> Type
normalizeType t =
case t of
ConT n -> ConT (normalizeName n)
VarT n -> VarT (normalizeName n)
AppT t1 t2 -> AppT (normalizeType t1) (normalizeType t2)
ForallT tvs cxt t -> ForallT (normalizeTyVarBndr <$> tvs) (normalizeType <$> cxt) (normalizeType t)
_ -> t
normalizeTyVarBndr :: TyVarBndr flag -> TyVarBndr flag
normalizeTyVarBndr tv =
case tv of
PlainTV n flag -> PlainTV (normalizeName n) flag
KindedTV n flag k -> KindedTV (normalizeName n) flag (normalizeType k)
normalizeClause :: Clause -> Clause
normalizeClause (Clause pats body decs) = Clause (normalizePat <$> pats) (normalizeBody body) (normalizeDec <$> decs)
normalizePat :: Pat -> Pat
normalizePat p =
case p of
VarP n -> VarP (normalizeName n)
ConP n types pats -> ConP (normalizeName n) (normalizeType <$> types) (normalizePat <$> pats)
TupP pats -> TupP (normalizePat <$> pats)
_ -> p
normalizeBody :: Body -> Body
normalizeBody b =
case b of
NormalB e -> NormalB (normalizeExp e)
_ -> b
normalizeExp :: Exp -> Exp
normalizeExp e =
case e of
VarE n -> VarE (normalizeName n)
AppE e1 e2 -> AppE (normalizeExp e1) (normalizeExp e2)
ListE es -> ListE (normalizeExp <$> es)
CaseE e matches -> CaseE (normalizeExp e) (normalizeMatch <$> matches)
ConE name
| name == '[] -> ListE []
| otherwise -> ConE (normalizeName name)
InfixE l op r -> InfixE (normalizeExp <$> l) (normalizeExp op) (normalizeExp <$> r)
CondE b t f -> CondE (normalizeExp b) (normalizeExp t) (normalizeExp f)
_ -> e
normalizeMatch :: Match -> Match
normalizeMatch (Match pat body decs) =
Match (normalizePat pat) (normalizeBody body) (normalizeDec <$> decs)
normalizeName :: Name -> Name
normalizeName (Name (OccName occ) (NameU _)) = mkName occ
normalizeName name = name