{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
{- HLINT ignore "Reduce duplication" -}
{- HLINT ignore "Avoid lambda" -}
module FlatBuffers.RoundTripSpec where
import Control.Applicative ( liftA3 )
import Data.Bits ( (.|.) )
import Data.Functor ( (<&>) )
import qualified Data.List as L
import Data.Maybe ( isNothing )
import Examples
import FlatBuffers
import FlatBuffers.Vector as Vec
import TestImports
spec :: Spec
spec =
describe "Round Trip" $ do
describe "Primitives" $ do
it "writes file identifier to buffer" $ do
let bs1 = encodeWithFileIdentifier $ primitives
Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
checkFileIdentifier @Primitives bs1 `shouldBe` True
let bs2 = encode $ primitives
Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
checkFileIdentifier @Primitives bs2 `shouldBe` False
it "present" $ do
x <- evalRight $ decode @Primitives $ encodeWithFileIdentifier $ primitives
(Just maxBound) (Just maxBound) (Just maxBound) (Just maxBound)
(Just maxBound) (Just maxBound) (Just maxBound) (Just maxBound)
(Just 1234.56) (Just 2873242.82782) (Just True) (Just "hi 👬 bye")
primitivesA x `shouldBe` Right maxBound
primitivesB x `shouldBe` Right maxBound
primitivesC x `shouldBe` Right maxBound
primitivesD x `shouldBe` Right maxBound
primitivesE x `shouldBe` Right maxBound
primitivesF x `shouldBe` Right maxBound
primitivesG x `shouldBe` Right maxBound
primitivesH x `shouldBe` Right maxBound
primitivesI x `shouldBe` Right 1234.56
primitivesJ x `shouldBe` Right 2873242.82782
primitivesK x `shouldBe` Right True
primitivesL x `shouldBe` Right (Just "hi 👬 bye")
it "missing" $ do
x <- evalRight $ decode @Primitives $ encodeWithFileIdentifier $ primitives
Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
primitivesA x `shouldBe` Right 0
primitivesB x `shouldBe` Right 0
primitivesC x `shouldBe` Right 0
primitivesD x `shouldBe` Right 0
primitivesE x `shouldBe` Right 0
primitivesF x `shouldBe` Right 0
primitivesG x `shouldBe` Right 0
primitivesH x `shouldBe` Right 0
primitivesI x `shouldBe` Right 0
primitivesJ x `shouldBe` Right 0
primitivesK x `shouldBe` Right False
primitivesL x `shouldBe` Right Nothing
describe "Enums" $ do
let readStructWithEnum = (liftA3 . liftA3) (,,) structWithEnumX (fmap toColor <$> structWithEnumY) structWithEnumZ
it "present" $ do
x <- evalRight $ decode $ encode $ enums
(Just (fromColor ColorGray))
(Just (structWithEnum 11 (fromColor ColorRed) 22))
(Just (Vec.fromList' [fromColor ColorBlack, fromColor ColorBlue, fromColor ColorGreen]))
(Just (Vec.fromList' [structWithEnum 33 (fromColor ColorRed) 44, structWithEnum 55 (fromColor ColorGreen) 66]))
toColor <$> enumsX x `shouldBe` Right (Just ColorGray)
(enumsY x >>= traverse readStructWithEnum) `shouldBe` Right (Just (11, Just ColorRed, 22))
(enumsXs x >>= traverse toList) `shouldBe` Right (Just [fromColor ColorBlack, fromColor ColorBlue, fromColor ColorGreen])
(enumsYs x >>= traverse toList >>= traverse (traverse readStructWithEnum)) `shouldBe` Right (Just [(33, Just ColorRed, 44), (55, Just ColorGreen, 66)])
it "present with defaults" $ do
x <- evalRight $ decode @Enums $ encode $ enums (Just 0) Nothing Nothing Nothing
toColor <$> enumsX x `shouldBe` Right (Just ColorGreen)
enumsY x `shouldBeRightAnd` isNothing
enumsXs x `shouldBeRightAnd` isNothing
enumsYs x `shouldBeRightAnd` isNothing
it "missing" $ do
x <- evalRight $ decode @Enums $ encode $ enums Nothing Nothing Nothing Nothing
toColor <$> enumsX x `shouldBe` Right (Just ColorGreen)
enumsY x `shouldBeRightAnd` isNothing
enumsXs x `shouldBeRightAnd` isNothing
enumsYs x `shouldBeRightAnd` isNothing
describe "Enums with bit_flags" $ do
it "present" $ do
x <- evalRight $ decode $ encode $ enumsBitFlags
(Just (colorsRed .|. colorsGreen))
(Just (structWithEnumBitFlags (colorsGreen .|. colorsGray)))
(Just (Vec.fromList'
[ colorsGreen .|. colorsGray
, colorsBlack .|. colorsBlue
, colorsGreen
]))
(Just (Vec.fromList'
[ structWithEnumBitFlags (colorsGreen .|. colorsGray)
, structWithEnumBitFlags (colorsBlack .|. colorsBlue)
, structWithEnumBitFlags colorsGreen
]))
enumsBitFlagsX x `shouldBe` Right (colorsRed .|. colorsGreen)
(enumsBitFlagsY x >>= traverse structWithEnumBitFlagsX) `shouldBe` Right (Just (colorsGreen .|. colorsGray))
(enumsBitFlagsXs x >>= traverse toList) `shouldBe` Right (Just
[ colorsGreen .|. colorsGray
, colorsBlack .|. colorsBlue
, colorsGreen
])
(enumsBitFlagsYs x >>= traverse toList >>= traverse (traverse structWithEnumBitFlagsX)) `shouldBe` Right (Just
[ colorsGreen .|. colorsGray
, colorsBlack .|. colorsBlue
, colorsGreen
])
it "present with defaults" $ do
x <- evalRight $ decode @EnumsBitFlags $ encode $ enumsBitFlags (Just 0) Nothing Nothing Nothing
enumsBitFlagsX x `shouldBe` Right 0
enumsBitFlagsY x `shouldBeRightAnd` isNothing
enumsBitFlagsXs x `shouldBeRightAnd` isNothing
enumsBitFlagsYs x `shouldBeRightAnd` isNothing
it "missing" $ do
x <- evalRight $ decode @EnumsBitFlags $ encode $ enumsBitFlags Nothing Nothing Nothing Nothing
enumsBitFlagsX x `shouldBe` Right 0
enumsBitFlagsY x `shouldBeRightAnd` isNothing
enumsBitFlagsXs x `shouldBeRightAnd` isNothing
enumsBitFlagsYs x `shouldBeRightAnd` isNothing
describe "Structs" $ do
let readStruct1 = (liftA3 . liftA3) (,,) struct1X struct1Y struct1Z
let readStruct2 = struct2X
let readStruct3 = (liftA3 . liftA3) (,,) (struct2X . struct3X) struct3Y struct3Z
let readStruct4 = (liftA4 . liftA4) (,,,) (struct2X . struct4W) struct4X struct4Y struct4Z
it "present" $ do
root <- evalRight $ decode $ encode $ structs
(Just (struct1 1 2 3))
(Just (struct2 11))
(Just (struct3 (struct2 22) 33 44))
(Just (struct4 (struct2 55) 66 77 True))
s1 <- evalRightJust $ structsA root
s2 <- evalRightJust $ structsB root
s3 <- evalRightJust $ structsC root
s4 <- evalRightJust $ structsD root
readStruct1 s1 `shouldBe` Right (1, 2, 3)
readStruct2 s2 `shouldBe` Right 11
readStruct3 s3 `shouldBe` Right (22, 33, 44)
readStruct4 s4 `shouldBe` Right (55, 66, 77, True)
it "missing" $ do
root <- evalRight $ decode $ encode $ structs Nothing Nothing Nothing Nothing
structsA root `shouldBeRightAnd` isNothing
structsB root `shouldBeRightAnd` isNothing
structsC root `shouldBeRightAnd` isNothing
structsD root `shouldBeRightAnd` isNothing
describe "Nested tables" $ do
it "present" $ do
root <- evalRight $ decode $ encode $ nestedTables (Just (table1 (Just (table2 (Just 11))) (Just 22)))
t1 <- evalRightJust $ nestedTablesX root
t2 <- evalRightJust $ table1X t1
table1Y t1 `shouldBe` Right 22
table2X t2 `shouldBe` Right 11
it "missing table2" $ do
root <- evalRight $ decode $ encode $ nestedTables (Just (table1 Nothing (Just 22)))
t1 <- evalRightJust $ nestedTablesX root
table1X t1 `shouldBeRightAnd` isNothing
table1Y t1 `shouldBe` Right 22
it "missing table1" $ do
root <- evalRight $ decode $ encode $ nestedTables Nothing
nestedTablesX root `shouldBeRightAnd` isNothing
describe "Union" $
it "present" $ do
x <- evalRight $ decode $ encode $ tableWithUnion (weaponSword (sword (Just "hi")))
tableWithUnionUni x `shouldBeRightAndExpect` \case
Union (WeaponSword x) -> swordX x `shouldBe` Right (Just "hi")
x <- evalRight $ decode $ encode $ tableWithUnion (weaponAxe (axe (Just maxBound)))
tableWithUnionUni x `shouldBeRightAndExpect` \case
Union (WeaponAxe x) -> axeY x `shouldBe` Right maxBound
x <- evalRight $ decode $ encode $ tableWithUnion none
tableWithUnionUni x `shouldBeRightAndExpect` \case
UnionNone -> pure ()
describe "Vectors" $ do
let Right nonEmptyVecs = decode $ encode $ vectors
(Just (Vec.fromList' [minBound, 0, maxBound]))
(Just (Vec.fromList' [minBound, 0, maxBound]))
(Just (Vec.fromList' [minBound, 0, maxBound]))
(Just (Vec.fromList' [minBound, 0, maxBound]))
(Just (Vec.fromList' [minBound, 0, maxBound]))
(Just (Vec.fromList' [minBound, 0, maxBound]))
(Just (Vec.fromList' [minBound, 0, maxBound]))
(Just (Vec.fromList' [minBound, 0, maxBound]))
(Just (Vec.fromList' [-12e9, 0, 3.33333333333333333333]))
(Just (Vec.fromList' [-12e98, 0, 3.33333333333333333333]))
(Just (Vec.fromList' [True, False, True]))
(Just (Vec.fromList' ["hi 👬 bye", "", "world"]))
let Right emptyVecs = decode $ encode $ vectors
(Just Vec.empty) (Just Vec.empty) (Just Vec.empty) (Just Vec.empty)
(Just Vec.empty) (Just Vec.empty) (Just Vec.empty) (Just Vec.empty)
(Just Vec.empty) (Just Vec.empty) (Just Vec.empty) (Just Vec.empty)
let Right missingVecs = decode $ encode $ vectors
Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
let
testPrimVector :: (VectorElement a, Show a, Eq a)
=> (Table Vectors -> Either ReadError (Maybe (Vector a)))
-> [a]
-> Spec
testPrimVector getVec expectedList = do
it "non empty" $ do
vec <- evalRightJust (getVec nonEmptyVecs)
Vec.length vec `shouldBe` L.genericLength expectedList
Vec.toList vec `shouldBe` Right expectedList
traverse (\i -> vec `unsafeIndex` i) [0 .. L.genericLength expectedList - 1] `shouldBe` Right expectedList
it "empty" $ do
vec <- evalRightJust (getVec emptyVecs)
Vec.length vec `shouldBe` 0
Vec.toList vec `shouldBe` Right []
it "missing" $
getVec missingVecs `shouldBeRightAnd` isNothing
describe "word8 vector" $ testPrimVector vectorsA [minBound, 0, maxBound]
describe "word16 vector" $ testPrimVector vectorsB [minBound, 0, maxBound]
describe "word32 vector" $ testPrimVector vectorsC [minBound, 0, maxBound]
describe "word64 vector" $ testPrimVector vectorsD [minBound, 0, maxBound]
describe "int8 vector" $ testPrimVector vectorsE [minBound, 0, maxBound]
describe "int16 vector" $ testPrimVector vectorsF [minBound, 0, maxBound]
describe "int32 vector" $ testPrimVector vectorsG [minBound, 0, maxBound]
describe "int64 vector" $ testPrimVector vectorsH [minBound, 0, maxBound]
describe "float vector" $ testPrimVector vectorsI [-12e9, 0, 3.33333333333333333333]
describe "double vector" $ testPrimVector vectorsJ [-12e98, 0, 3.33333333333333333333]
describe "bool vector" $ testPrimVector vectorsK [True, False, True]
describe "string vector" $ testPrimVector vectorsL ["hi 👬 bye", "", "world"]
describe "VectorOfTables" $ do
it "non empty" $ do
x <- evalRight $ decode $ encode $ vectorOfTables
(Just $ Vec.fromList'
[ axe (Just minBound)
, axe (Just 0)
, axe (Just maxBound)
]
)
Just xs <- evalRight $ vectorOfTablesXs x
Vec.length xs `shouldBe` 3
(toList xs >>= traverse axeY) `shouldBe` Right [minBound, 0, maxBound]
(traverse (unsafeIndex xs) [0..2] >>= traverse axeY) `shouldBe` Right [minBound, 0, maxBound]
it "empty" $ do
x <- evalRight $ decode $ encode $ vectorOfTables (Just Vec.empty)
xs <- evalRightJust $ vectorOfTablesXs x
Vec.length xs `shouldBe` 0
(toList xs >>= traverse axeY) `shouldBe` Right []
it "missing" $ do
x <- evalRight $ decode $ encode $ vectorOfTables Nothing
vectorOfTablesXs x `shouldBeRightAnd` isNothing
describe "VectorOfStructs" $ do
let readStruct1 = (liftA3 . liftA3) (,,) struct1X struct1Y struct1Z
let readStruct2 = struct2X
let readStruct3 = (liftA3 . liftA3) (,,) (struct2X . struct3X) struct3Y struct3Z
let readStruct4 = (liftA4 . liftA4) (,,,) (struct2X . struct4W) struct4X struct4Y struct4Z
it "non empty" $ do
x <- evalRight $ decode $ encode $ vectorOfStructs
(Just (Vec.fromList' [struct1 1 2 3, struct1 4 5 6]))
(Just (Vec.fromList' [struct2 101, struct2 102, struct2 103]))
(Just (Vec.fromList' [struct3 (struct2 104) 105 106, struct3 (struct2 107) 108 109, struct3 (struct2 110) 111 112]))
(Just (Vec.fromList' [struct4 (struct2 120) 121 122 True, struct4 (struct2 123) 124 125 False, struct4 (struct2 126) 127 128 True]))
as <- evalRightJust $ vectorOfStructsAs x
bs <- evalRightJust $ vectorOfStructsBs x
cs <- evalRightJust $ vectorOfStructsCs x
ds <- evalRightJust $ vectorOfStructsDs x
Vec.length as `shouldBe` 2
(toList as >>= traverse readStruct1) `shouldBe` Right [(1,2,3), (4,5,6)]
(traverse (unsafeIndex as) [0..1] >>= traverse readStruct1) `shouldBe` Right [(1,2,3), (4,5,6)]
Vec.length bs `shouldBe` 3
(toList bs >>= traverse readStruct2) `shouldBe` Right [101, 102, 103]
(traverse (unsafeIndex bs) [0..2] >>= traverse readStruct2) `shouldBe` Right [101, 102, 103]
Vec.length cs `shouldBe` 3
(toList cs >>= traverse readStruct3) `shouldBe` Right [(104, 105, 106), (107, 108, 109), (110, 111, 112)]
(traverse (unsafeIndex cs) [0..2] >>= traverse readStruct3) `shouldBe` Right [(104, 105, 106), (107, 108, 109), (110, 111, 112)]
Vec.length ds `shouldBe` 3
(toList ds >>= traverse readStruct4) `shouldBe` Right [(120, 121, 122, True), (123, 124, 125, False), (126, 127, 128, True)]
(traverse (unsafeIndex ds) [0..2] >>= traverse readStruct4) `shouldBe` Right [(120, 121, 122, True), (123, 124, 125, False), (126, 127, 128, True)]
it "empty" $ do
x <- evalRight $ decode $ encode $ vectorOfStructs
(Just Vec.empty) (Just Vec.empty) (Just Vec.empty) (Just Vec.empty)
as <- evalRightJust $ vectorOfStructsAs x
bs <- evalRightJust $ vectorOfStructsBs x
cs <- evalRightJust $ vectorOfStructsCs x
ds <- evalRightJust $ vectorOfStructsDs x
Vec.length as `shouldBe` 0
(toList as >>= traverse readStruct1) `shouldBe` Right []
Vec.length bs `shouldBe` 0
(toList bs >>= traverse readStruct2) `shouldBe` Right []
Vec.length cs `shouldBe` 0
(toList cs >>= traverse readStruct3) `shouldBe` Right []
Vec.length ds `shouldBe` 0
(toList ds >>= traverse readStruct4) `shouldBe` Right []
it "missing" $ do
x <- evalRight $ decode @VectorOfStructs $ encode $ vectorOfStructs Nothing Nothing Nothing Nothing
vectorOfStructsAs x `shouldBeRightAnd` isNothing
vectorOfStructsBs x `shouldBeRightAnd` isNothing
vectorOfStructsCs x `shouldBeRightAnd` isNothing
vectorOfStructsDs x `shouldBeRightAnd` isNothing
describe "VectorOfUnions" $ do
it "non empty" $ do
let
shouldBeSword x (Union (WeaponSword s)) = swordX s `shouldBe` Right (Just x)
shouldBeAxe y (Union (WeaponAxe s)) = axeY s `shouldBe` Right y
shouldBeNone UnionNone = pure ()
x <- evalRight $ decode $ encode $ vectorOfUnions
(Just $ Vec.fromList'
[ weaponSword (sword (Just "hi"))
, none
, weaponAxe (axe (Just 98))
]
)
(Vec.fromList'
[ weaponSword (sword (Just "hi2"))
, none
, weaponAxe (axe (Just 100))
]
)
Just xs <- evalRight $ vectorOfUnionsXs x
Vec.length xs `shouldBe` 3
L.length <$> toList xs `shouldBe` Right 3
xs `unsafeIndex` 0 `shouldBeRightAndExpect` shouldBeSword "hi"
xs `unsafeIndex` 1 `shouldBeRightAndExpect` shouldBeNone
xs `unsafeIndex` 2 `shouldBeRightAndExpect` shouldBeAxe 98
(toList xs <&> (!! 0)) `shouldBeRightAndExpect` shouldBeSword "hi"
(toList xs <&> (!! 1)) `shouldBeRightAndExpect` shouldBeNone
(toList xs <&> (!! 2)) `shouldBeRightAndExpect` shouldBeAxe 98
xsReq <- evalRight $ vectorOfUnionsXsReq x
Vec.length xsReq `shouldBe` 3
L.length <$> toList xsReq `shouldBe` Right 3
xsReq `unsafeIndex` 0 `shouldBeRightAndExpect` shouldBeSword "hi2"
xsReq `unsafeIndex` 1 `shouldBeRightAndExpect` shouldBeNone
xsReq `unsafeIndex` 2 `shouldBeRightAndExpect` shouldBeAxe 100
(toList xsReq <&> (!! 0)) `shouldBeRightAndExpect` shouldBeSword "hi2"
(toList xsReq <&> (!! 1)) `shouldBeRightAndExpect` shouldBeNone
(toList xsReq <&> (!! 2)) `shouldBeRightAndExpect` shouldBeAxe 100
it "empty" $ do
x <- evalRight $ decode $ encode $ vectorOfUnions (Just Vec.empty) Vec.empty
Just xs <- evalRight $ vectorOfUnionsXs x
Vec.length xs `shouldBe` 0
L.length <$> toList xs `shouldBe` Right 0
xsReq <- evalRight $ vectorOfUnionsXsReq x
Vec.length xsReq `shouldBe` 0
L.length <$> toList xsReq `shouldBe` Right 0
it "missing" $ do
x <- evalRight $ decode $ encode $ vectorOfUnions Nothing Vec.empty
vectorOfUnionsXs x `shouldBeRightAnd` isNothing
(Vec.length <$> vectorOfUnionsXsReq x) `shouldBe` Right 0
describe "ScalarsWithDefaults" $ do
let runTest buffer = do
x <- evalRight $ decode $ encode buffer
scalarsWithDefaultsA x `shouldBe` Right 8
scalarsWithDefaultsB x `shouldBe` Right 16
scalarsWithDefaultsC x `shouldBe` Right 32
scalarsWithDefaultsD x `shouldBe` Right 64
scalarsWithDefaultsE x `shouldBe` Right (-1)
scalarsWithDefaultsF x `shouldBe` Right (-2)
scalarsWithDefaultsG x `shouldBe` Right (-4)
scalarsWithDefaultsH x `shouldBe` Right (-8)
scalarsWithDefaultsI x `shouldBe` Right 3.9
scalarsWithDefaultsJ x `shouldBe` Right (-2.3e10)
scalarsWithDefaultsK x `shouldBe` Right True
scalarsWithDefaultsL x `shouldBe` Right False
toColor <$> scalarsWithDefaultsM x `shouldBe` Right (Just ColorBlue)
toColor <$> scalarsWithDefaultsN x `shouldBe` Right (Just ColorGray)
scalarsWithDefaultsO x `shouldBe` Right 0
scalarsWithDefaultsP x `shouldBe` Right (colorsGreen .|. colorsBlue)
scalarsWithDefaultsQ x `shouldBe` Right colorsRed
scalarsWithDefaultsR x `shouldBe` Right (colorsGreen .|. colorsGray)
it "present with defaults" $ runTest $ scalarsWithDefaults
(Just 8) (Just 16) (Just 32) (Just 64)
(Just (-1)) (Just (-2)) (Just (-4)) (Just (-8))
(Just 3.9) (Just (-2.3e10)) (Just True) (Just False)
(Just (fromColor ColorBlue)) (Just (fromColor ColorGray))
(Just 0)
(Just (colorsGreen .|. colorsBlue))
(Just colorsRed)
(Just (colorsGreen .|. colorsGray))
it "missing" $ runTest $ scalarsWithDefaults
Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
Nothing Nothing
it "DeprecatedFields" $ do
x <- evalRight $ decode $ encode $ deprecatedFields (Just 1) (Just 2) (Just 3) (Just 4)
deprecatedFieldsA x `shouldBe` Right 1
deprecatedFieldsC x `shouldBe` Right 2
deprecatedFieldsE x `shouldBe` Right 3
deprecatedFieldsG x `shouldBe` Right 4
it "RequiredFields" $ do
let readStruct1 = (liftA3 . liftA3) (,,) struct1X struct1Y struct1Z
x <- evalRight $ decode $ encode $ requiredFields
"hello"
(struct1 11 22 33)
(axe (Just 44))
(weaponSword (sword (Just "a")))
(Vec.fromList' [55, 66])
requiredFieldsA x `shouldBe` Right "hello"
(requiredFieldsB x >>= readStruct1) `shouldBe` Right (11, 22, 33)
(requiredFieldsC x >>= axeY) `shouldBe` Right 44
requiredFieldsD x `shouldBeRightAndExpect` \case
Union (WeaponSword x) -> swordX x `shouldBe` Right (Just "a")
(requiredFieldsE x >>= toList) `shouldBe` Right [55, 66]