flatbuffers-0.3.0.0: test/FlatBuffers/Internal/Compiler/THSpec.hs
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE ExplicitForAll #-}
module FlatBuffers.Internal.Compiler.THSpec where
import Control.Arrow ( second )
import Data.Bits ( (.&.) )
import Data.Int
import Data.Text ( Text )
import qualified Data.Text as T
import Data.Word
import FlatBuffers.Internal.Build
import qualified FlatBuffers.Internal.Compiler.Parser 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.Cleanup ( simplifiedTH )
import Language.Haskell.TH.Syntax
import System.IO.Unsafe ( unsafePerformIO )
import TestImports
import Text.Megaparsec ( ParseErrorBundle, ShowErrorComponent, Stream, 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 :: WriteUnion U1 -> WriteTable T1
t1 x = writeTable
[ writeUnionTypeTableField x
, writeUnionValueTableField x
]
t1X :: Table T1 -> Either ReadError (Union U1)
t1X = readTableFieldUnion 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 = readTableFieldUnion 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'
|]
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) =
let LitE (StringL s) = unsafePerformIO . runQ . simplifiedTH $ decs
in s
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
-- | 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 -> TyVarBndr
normalizeTyVarBndr tv =
case tv of
PlainTV n -> PlainTV (normalizeName n)
KindedTV n k -> KindedTV (normalizeName n) (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 pats -> ConP (normalizeName n) (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 -> 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