{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE ExplicitForAll #-}

module FlatBuffers.Internal.Compiler.THSpec where

import           Control.Arrow                                  ( second )

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.Util                      ( Positive(getPositive) )
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

      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 #-}

              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 "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 #-}

                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 #-}

                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 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 readStructVector 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 readStructVector 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 =
              [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 #-}
              |]

        [r| enum my_color: int16 { is_red = -2, is_green  } |] `shouldCompileTo` expected
        [r| enum My_Color: int16 { Is_Red = -2, Is_Green  } |] `shouldCompileTo` expected
        [r| enum MyColor:  int16 { IsRed = -2,  IsGreen   } |] `shouldCompileTo` expected
        [r| enum myColor:  int16 { isRed = -2,  isGreen   } |] `shouldCompileTo` expected

    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 #-}

            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 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
          |]

    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 $ T.unpack 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)
    _ -> 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

