diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Diogo Castro (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Diogo Castro nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,348 @@ +# Haskell Flatbuffers + +An implementation of the [flatbuffers protocol][flatbuffers] in Haskell. + +[![Build Status](https://travis-ci.com/dcastro/haskell-flatbuffers.svg?branch=master)](https://travis-ci.com/dcastro/haskell-flatbuffers) +[![Hackage](https://img.shields.io/hackage/v/flatbuffers)](http://hackage.haskell.org/package/flatbuffers) + +- [Getting started](#getting-started) + - [Enums](#enums) + - [Structs](#structs) + - [Unions](#unions) + - [File Identifiers](#file-identifiers) +- [Codegen](#codegen) +- [TODO](#todo) + + +## Getting started + +1. Start off by writing a [flatbuffers schema][schema] with the data structures you want to serialize/deserialize. + ``` + namespace Data.Game; + + table Monster { + name: string; + hp: int; + locations: [string] (required); + } + ``` +2. Create a Haskell module named after the namespace in the schema. + ```haskell + module Data.Game where + ``` +3. Use `mkFlatBuffers` to generate constructors and accessors for the data types in your schema. + ```haskell + {-# LANGUAGE TemplateHaskell #-} + + module Data.Game where + import FlatBuffers + + $(mkFlatBuffers "schemas/game.fbs" defaultOptions) + ``` +4. The following declarations will be generated for you. + ```haskell + data Monster + + -- Constructor + monster :: Maybe Text -> Maybe Int32 -> WriteVector Text -> WriteTable Monster + + -- Accessors + monsterName :: Table Monster -> Either ReadError (Maybe Text) + monsterHp :: Table Monster -> Either ReadError Int32 + monsterLocations :: Table Monster -> Either ReadError (Vector Text) + ``` + +We can now construct a flatbuffer using `encode` and read it using `decode`: + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +import FlatBuffers +import qualified FlatBuffers.Vector as Vector + +-- Writing +let byteString = encode $ + monster + (Just "Poring") + (Just 50) + (Vector.fromList 2 ["Prontera Field", "Payon Forest"]) + +-- Reading +do + someMonster <- decode byteString + name <- monsterName someMonster + hp <- monsterHp someMonster + locations <- monsterLocations someMonster >>= Vector.toList + Right ("Monster: " <> show name <> " (" <> show hp <> " HP) can be found in " <> show locations) +``` + +For more info on code generation and examples, see [codegen](#codegen). + +### Enums + +``` +enum Color: short { Red, Green, Blue } +``` + +Given the enum declarationa above, the following code will be generated: + +```haskell +data Color + = ColorRed + | ColorGreen + | ColorBlue + deriving (Eq, Show, Read, Ord, Bounded) + +toColor :: Int16 -> Maybe Color +fromColor :: Color -> Int16 +``` + +Usage: + +``` +table Monster { + color: Color; +} +``` + +```haskell +data Monster + +monster :: Maybe Int16 -> WriteTable Monster +monsterColor :: Table Monster -> Either ReadError Int16 + +-- Writing +let byteString = encode $ + monster (Just (fromColor ColorBlue)) + +-- Reading +do + someMonster <- decode byteString + short <- monsterColor someMonster + case toColor short of + Just ColorRed -> Right "This monster is red" + Just ColorGreen -> Right "This monster is green" + Just ColorBlue -> Right "This monster is blue" + Nothing -> Left ("Unknown color: " <> show short) -- Forwards compatibility +``` + +### Structs + +``` +struct Coord { + x: long; + y: long; +} +``` + +Given the struct declaration above, the following code will be generated: + +```haskell +data Coord +instance IsStruct Coord + +-- Constructor +coord :: Int64 -> Int64 -> WriteStruct Coord + +-- Accessors +coordX :: Struct Coord -> Either ReadError Int64 +coordY :: Struct Coord -> Either ReadError Int64 +``` + +Usage: + +``` +table Monster { + position: Coord (required); +} +``` + +```haskell +data Monster + +monster :: WriteStruct Coord -> WriteTable Monster +monsterPosition :: Table Monster -> Either ReadError (Struct Coord) + +-- Writing +let byteString = encode $ + monster (coord 123 456) + +-- Reading +do + someMonster <- decode byteString + pos <- monsterPosition someMonster + x <- coordX pos + y <- coordY pos + Right ("Monster is located at " <> show x <> ", " <> show y) +``` + +### Unions + +``` +table Sword { power: int; } +table Axe { power: int; } +union Weapon { Sword, Axe } +``` + +Given the union declaration above, the following code will be generated: + +```haskell +-- Accessors +data Weapon + = WeaponSword !(Table Sword) + | WeaponAxe !(Table Axe) + +-- Constructors +weaponSword :: WriteTable Sword -> WriteUnion Weapon +weaponAxe :: WriteTable Axe -> WriteUnion Weapon +``` + +Usage: + +``` +table Character { + weapon: Weapon; +} +``` + +```haskell +data Character + +character :: WriteUnion Weapon -> WriteTable Character +characterWeapon :: Table Character -> Either ReadError (Union Weapon) + +-- Writing +let byteString = encode $ + character + (weaponSword (sword (Just 1000))) + +-- Reading +do + someCharacter <- decode byteString + weapon <- characterWeapon someCharacter + case weapon of + Union (WeaponSword sword) -> do + power <- swordPower sword + Right ("Weilding a sword with " <> show power <> " Power.") + Union (WeaponAxe axe) -> do + power <- axePower axe + Right ("Weilding an axe with " <> show power <> " Power.") + UnionNone -> Right "Character has no weapon" + UnionUnknown byte -> Left "Unknown weapon" -- Forwards compatibility +``` + +Note that, like in the official FlatBuffers implementation, unions are *always* optional. +Adding the `required` attribute to a union field has no effect. + +To create a character with no weapon, use `none :: WriteUnion a` + +```haskell +let byteString = encode $ + character none +``` + + +### File Identifiers + +From ["File identification and extension"][schema]: + +> Typically, a FlatBuffer binary buffer is not self-describing, i.e. it needs you to know its schema to parse it correctly. But if you want to use a FlatBuffer as a file format, it would be convenient to be able to have a "magic number" in there, like most file formats have, to be able to do a sanity check to see if you're reading the kind of file you're expecting. +> +> Now, you can always prefix a FlatBuffer with your own file header, but FlatBuffers has a built-in way to add an identifier to a FlatBuffer that takes up minimal space, and keeps the buffer compatible with buffers that don't have such an identifier. + +``` +table Monster { name: string; } + +root_type Monster; +file_identifier "MONS"; +``` + +```haskell +data Monster +instance HasFileIdentifier Monster + +-- Usual constructor and accessors... +``` + +We can now construct a flatbuffer using `encodeWithFileIdentifier` and use `checkFileIdentifier` to check if it's safe to decode it to a specific type: + +```haskell +{-# LANGUAGE TypeApplications #-} + +-- Writing +let byteString = encodeWithFileIdentifier $ + monster (Just "Poring") + +-- Reading +if checkFileIdentifier @Monster byteString then do + someMonster <- decode byteString + monsterName someMonster +else if checkFileIdentifier @Character byteString then do + someCharacter <- decode byteString + characterName someCharacter +else + Left "Unexpected flatbuffer identifier" +``` + +## Codegen + +You can check exactly which declarations were generated by browsing your module in ghci: + +```plain +λ> :m Data.Game FlatBuffers FlatBuffers.Vector +λ> :browse Data.Game +data Monster +monster :: Maybe Int32 -> WriteTable Monster +monsterHp :: Table Monster -> Either ReadError Int32 +``` + +Or by launching a local hoogle server with Stack: + +```plain +> stack hoogle --rebuild --server +``` + +There are lots of examples in the [test/Examples][examples] folder and the [`THSpec`][thspec] module. + +In particular, `test/Examples/schema.fbs` and `test/Examples/vector_of_unions.fbs` contain a variety of data structures and `Examples.HandWritten` demonstrates what the code generated by `mkFlatBuffers` would look like. + +## TODO + +### Features + +- [ ] gRPC support +- [ ] Size-prefixed buffers (needed for streaming multiple messages) + - [flatbuffers/3898](https://github.com/google/flatbuffers/issues/3898) + - [FlatCC](https://github.com/dvidelabs/flatcc/blob/master/doc/binary-format.md#nested-flatbuffers) +- [ ] Fixed length arrays in structs + - [flatbuffers/63](https://github.com/google/flatbuffers/issues/63) + - [flatbuffers/3987](https://github.com/google/flatbuffers/pull/3987) + - [flatbuffers/5313](https://github.com/google/flatbuffers/pull/5313) + - [FlatCC](https://github.com/dvidelabs/flatcc/blob/master/doc/binary-format.md#fixed-length-arrays) +- [ ] unions of strings / structs + - [FlatCC](https://github.com/dvidelabs/flatcc/blob/master/doc/binary-format.md#unions) +- [ ] `key` attribute (See ["Storing dictionaries in a FlatBuffer" section](https://google.github.io/flatbuffers/flatbuffers_guide_use_java_c-sharp.html)) +- [ ] `nested_flatbuffer` attribute +- [ ] `bit_flags` attribute +- [ ] `hash` attribute + - [Docs](https://google.github.io/flatbuffers/flatbuffers_guide_writing_schema.html) + - [Docs](https://google.github.io/flatbuffers/flatbuffers_guide_use_cpp.html#flatbuffers_cpp_object_based_api) +- [ ] DSL that allows sharing of data (e.g. reuse an offset to a string/table) +- [ ] `shared` attribute + - [Docs](https://google.github.io/flatbuffers/flatbuffers_guide_use_cpp.html#flatbuffers_cpp_object_based_api) + +### Other + +- [ ] TH: sort table fields by size + support `original_order` attribute +- [ ] Add support for storing unboxed vectors, which do not have a `Foldable` instance. Maybe use `MonoFoldable` from the `mono-traversable` package +- [ ] Enrich `Vector` API: drop, take, null, folds, sum, elem, for_, traverse_, ideally support most of operations in `Data.Foldable` +- [ ] Add `MonoFoldable (Vector a)` instance +- [ ] Improve error messages during `SemanticAnalysis` stage, provide source code location +- [ ] Try alternative bytestring builders: `fast-builder`, `blaze-builder` +- [ ] Try alternative bytestring parsers: `cereal` +- [ ] Better support for enums + + [flatbuffers]: https://google.github.io/flatbuffers/ + [schema]: https://google.github.io/flatbuffers/flatbuffers_guide_writing_schema.html + [examples]: https://github.com/dcastro/haskell-flatbuffers/tree/master/test/Examples + [thspec]: https://github.com/dcastro/haskell-flatbuffers/blob/master/test/FlatBuffers/Internal/Compiler/THSpec.hs diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/DecodeVectors.hs b/bench/DecodeVectors.hs new file mode 100644 --- /dev/null +++ b/bench/DecodeVectors.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} + +{- HLINT ignore "Avoid lambda" -} + +module DecodeVectors where + +import Control.Monad + +import Criterion + +import Data.Functor ( (<&>) ) +import Data.Int +import qualified Data.List as L +import qualified Data.Text as T + +import FlatBuffers +import qualified FlatBuffers.Vector as Vec +import FlatBuffers.Vector ( index, unsafeIndex ) + +import Types + +n :: Num a => a +n = 10000 + +groups :: [Benchmark] +groups = + [ bgroup ("decode vectors (" <> show @Int n <> " elements)") + [ bgroup "toList" + [ bench "word8" $ nf (\(Right (Just vec)) -> Vec.toList vec ) $ vectorsTable >>= vectorsA + , bench "word16" $ nf (\(Right (Just vec)) -> Vec.toList vec ) $ vectorsTable >>= vectorsB + , bench "word32" $ nf (\(Right (Just vec)) -> Vec.toList vec ) $ vectorsTable >>= vectorsC + , bench "word64" $ nf (\(Right (Just vec)) -> Vec.toList vec ) $ vectorsTable >>= vectorsD + , bench "int8" $ nf (\(Right (Just vec)) -> Vec.toList vec ) $ vectorsTable >>= vectorsE + , bench "int16" $ nf (\(Right (Just vec)) -> Vec.toList vec ) $ vectorsTable >>= vectorsF + , bench "int32" $ nf (\(Right (Just vec)) -> Vec.toList vec ) $ vectorsTable >>= vectorsG + , bench "int64" $ nf (\(Right (Just vec)) -> Vec.toList vec ) $ vectorsTable >>= vectorsH + , bench "float" $ nf (\(Right (Just vec)) -> Vec.toList vec ) $ vectorsTable >>= vectorsI + , bench "double" $ nf (\(Right (Just vec)) -> Vec.toList vec ) $ vectorsTable >>= vectorsJ + , bench "bool" $ nf (\(Right (Just vec)) -> Vec.toList vec ) $ vectorsTable >>= vectorsK + , bench "string" $ nf (\(Right (Just vec)) -> Vec.toList vec ) $ vectorsTable >>= vectorsL + , bench "struct" $ nf (\(Right (Just vec)) -> Vec.toList vec >>= traverse structWithOneIntX) $ vectorsTable >>= vectorsM + , bench "table" $ nf (\(Right (Just vec)) -> Vec.toList vec >>= traverse pairTableX) $ vectorsTable >>= vectorsN + , bench "union" $ nf (\(Right (Just vec)) -> do + list <- Vec.toList vec + forM list $ \case + Union (WeaponUnionSword sword) -> swordTableX sword + Union (WeaponUnionAxe axe) -> axeTableX axe + ) $ vectorsTable >>= vectorsO + ] + , bgroup "unsafeIndex" + [ bench "word8" $ nf (\(Right (Just vec)) -> + forM [0..(n-1)] (\i -> vec `unsafeIndex` i) + ) + $ vectorsTable >>= vectorsA + + , bench "int32" $ nf (\(Right (Just vec)) -> + forM [0..(n-1)] (\i -> vec `unsafeIndex` i) + ) + $ vectorsTable >>= vectorsG + + , bench "string" $ nf (\(Right (Just vec)) -> + forM [0..(n-1)] (\i -> vec `unsafeIndex` i) + ) + $ vectorsTable >>= vectorsL + ] + , bgroup "index" + [ bench "word8" $ nf (\(Right (Just vec)) -> + forM [0..(n-1)] (\i -> vec `index` i) + ) + $ vectorsTable >>= vectorsA + + , bench "int32" $ nf (\(Right (Just vec)) -> + forM [0..(n-1)] (\i -> vec `index` i) + ) + $ vectorsTable >>= vectorsG + + , bench "string" $ nf (\(Right (Just vec)) -> + forM [0..(n-1)] (\i -> vec `index` i) + ) + $ vectorsTable >>= vectorsL + ] + ] + ] + +mkNumList :: Num a => Int32 -> [a] +mkNumList len = fromIntegral <$> [1 .. len] + +mkNumVec :: (Num a, Vec.WriteVectorElement a) => Maybe (Vec.WriteVector a) +mkNumVec = Just (Vec.fromList n (mkNumList n)) + +vectorsTable :: Either ReadError (Table Vectors) +vectorsTable = + decode . encode $ + vectors + mkNumVec mkNumVec mkNumVec mkNumVec + mkNumVec mkNumVec mkNumVec mkNumVec + mkNumVec mkNumVec + (Just . Vec.fromList n . L.replicate n $ True) + (Just . Vec.fromList n $ [1..n] <&> \i -> T.take (i `rem` 15) "abcghjkel;jhgx") + (Just . Vec.fromList n . fmap structWithOneInt $ mkNumList n) + (Just . Vec.fromList n . fmap (\i -> pairTable (Just i) (Just i)) $ mkNumList n) + (Just . Vec.fromList n . fmap mkUnion $ mkNumList n + ) + where + mkUnion i = + if odd i + then weaponUnionSword (swordTable (Just i)) + else weaponUnionAxe (axeTable (Just i)) + + diff --git a/bench/Encode.hs b/bench/Encode.hs new file mode 100644 --- /dev/null +++ b/bench/Encode.hs @@ -0,0 +1,29 @@ +module Encode where + +import Criterion + +import FlatBuffers + +import Types + + +groups :: [Benchmark] +groups = + [ bgroup "encode" + [ bench "scalars" $ nf encode $ + scalars + (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 $ + scalars + (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 $ + scalars + (Just maxBound) (Just maxBound) (Just maxBound) (Just maxBound) + (Just maxBound) (Just maxBound) (Just maxBound) (Just maxBound) + (Just 1234.56) (Just 2873242.82782) (Just True) Nothing + ] + ] + + diff --git a/bench/EncodeVectors.hs b/bench/EncodeVectors.hs new file mode 100644 --- /dev/null +++ b/bench/EncodeVectors.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +module EncodeVectors where + +import Criterion + +import Data.Foldable as F +import Data.Functor ( (<&>) ) +import Data.Int +import qualified Data.List as L +import Data.Text ( Text ) +import qualified Data.Vector as V + +import FlatBuffers +import qualified FlatBuffers.Vector as Vec + +import Types + +n :: Num a => a +n = 10000 + +groups :: [Benchmark] +groups = + [ bgroup ("encode vectors (" <> show @Int n <> " elements)") + [ bgroup "from list" + [ bench "of ints" $ nf (\xs -> + encode . vectorOfInts . Just . Vec.fromList (fromIntegral (F.length xs)) $ + xs + ) $ mkIntList n + + , bench "of ints (with fusion)" $ nf (\xs -> + encode . vectorOfInts . Just . Vec.fromList (fromIntegral (F.length xs)) $ + userId <$> xs + ) $ mkUserList n + + , bench "of structs (1 int field)" $ nf (\xs -> + encode . vectorOfStructWithOneInt . Just . Vec.fromList (fromIntegral (F.length xs)) $ + structWithOneInt <$> xs + ) $ mkIntList n + + , bench "of structs (2 ints fields)" $ nf (\xs -> + encode . vectorOfPairs . Just . Vec.fromList (fromIntegral (F.length xs)) $ + (\(User id age _) -> pair id age) <$> xs + ) $ mkUserList n + + , bench "of short strings" $ nf (\xs -> + encode . vectorOfStrings . Just . Vec.fromList (fromIntegral (F.length xs)) $ + xs + ) $ mkTextList n + + , bench "of short strings (with fusion)" $ nf (\xs -> + encode . vectorOfStrings . Just . Vec.fromList (fromIntegral (F.length xs)) $ + userName <$> xs + ) $ mkUserList n + + , bench "of long strings" $ nf (\xs -> + encode . vectorOfStrings . Just . Vec.fromList (fromIntegral (F.length xs)) $ + xs + ) $ mkLongTextList n + + , bench "of tables (2 int fields)" $ nf (\xs -> + encode . vectorOfTables . Just . Vec.fromList (fromIntegral (F.length xs)) $ + (\(User id age _) -> pairTable (Just id) (Just age)) <$> xs + ) $ mkUserList n + + , bench "of tables (1 int field, 1 string field)" $ nf (\xs -> + encode . vectorOfUsers . Just . Vec.fromList (fromIntegral (F.length xs)) $ + (\(User id _ name) -> userTable (Just id) (Just name)) <$> xs + ) $ mkUserList n + + , bench "of unions (1 int field each)" $ nf (\xs -> + encode . vectorOfUnions . Just . Vec.fromList (fromIntegral (F.length xs)) $ + xs <&> \case + Sword x -> weaponUnionSword (swordTable (Just x)) + Axe x -> weaponUnionAxe (axeTable (Just x)) + ) $ mkWeaponList n + ] + + , bgroup "from vector" + [ bench "of ints" $ nf (\xs -> + encode . vectorOfInts . Just . Vec.fromFoldable (fromIntegral (F.length xs)) $ + xs + ) $ mkIntVector n + + , bench "of ints (with fusion)" $ nf (\xs -> + encode . vectorOfInts . Just . Vec.fromFoldable (fromIntegral (F.length xs)) $ + userId <$> xs + ) $ mkUserVector n + + , bench "of structs (1 int field)" $ nf (\xs -> + encode . vectorOfStructWithOneInt . Just . Vec.fromFoldable (fromIntegral (F.length xs)) $ + structWithOneInt <$> xs + ) $ mkIntVector n + + , bench "of structs (2 ints fields)" $ nf (\xs -> + encode . vectorOfPairs . Just . Vec.fromFoldable (fromIntegral (F.length xs)) $ + (\(User id age _) -> pair id age) <$> xs + ) $ mkUserVector n + + , bench "of short strings" $ nf (\xs -> + encode . vectorOfStrings . Just . Vec.fromFoldable (fromIntegral (F.length xs)) $ + xs + ) $ mkTextVector n + + , bench "of short strings (with fusion)" $ nf (\xs -> + encode . vectorOfStrings . Just . Vec.fromFoldable (fromIntegral (F.length xs)) $ + userName <$> xs + ) $ mkUserVector n + + , bench "of long strings" $ nf (\xs -> + encode . vectorOfStrings . Just . Vec.fromFoldable (fromIntegral (F.length xs)) $ + xs + ) $ mkLongTextVector n + + , bench "of tables (2 int fields)" $ nf (\xs -> + encode . vectorOfTables . Just . Vec.fromFoldable (fromIntegral (F.length xs)) $ + (\(User id age _) -> pairTable (Just id) (Just age)) <$> xs + ) $ mkUserVector n + + , bench "of tables (1 int field, 1 string field)" $ nf (\xs -> + encode . vectorOfUsers . Just . Vec.fromFoldable (fromIntegral (F.length xs)) $ + (\(User id _ name) -> userTable (Just id) (Just name)) <$> xs + ) $ mkUserVector n + + , bench "of unions (1 int field each)" $ nf (\xs -> + encode . vectorOfUnions . Just . Vec.fromFoldable (fromIntegral (F.length xs)) $ + xs <&> \case + Sword x -> weaponUnionSword (swordTable (Just x)) + Axe x -> weaponUnionAxe (axeTable (Just x)) + ) $ mkWeaponVector n + ] + ] + ] + +data User = User + { userId :: !Int32 + , userAge :: !Int32 + , userName :: !Text + } + +data Weapon + = Sword !Int32 + | Axe !Int32 + +mkUserList :: Int32 -> [User] +mkUserList n = (\i -> User i (i+1) "abcdefghijk" ) <$> [1..n] + +mkWeaponList :: Int32 -> [Weapon] +mkWeaponList n = + [1..n] <&> \i -> + if odd i + then Sword i + else Axe i + +mkIntList :: Int32 -> [Int32] +mkIntList n = [1..n] + +mkTextList :: Int -> [Text] +mkTextList n = L.replicate n "abcdefghijk" + +mkLongTextList :: Int -> [Text] +mkLongTextList n = L.replicate n "abcghjkel;jhgxwflh;eokjclhukgwyfteci;owmnubyicvutywfygn;emo'pcnwhuegfcjkjkwelhgdfwgklked;lwjhkejvhjnwekndjkvwejhbjxknwejkvcxhwoipoqoyiugs" + + + + +mkUserVector :: Int32 -> V.Vector User +mkUserVector n = V.fromList (mkUserList n) + +mkWeaponVector :: Int32 -> V.Vector Weapon +mkWeaponVector n = V.fromList (mkWeaponList n) + +mkIntVector :: Int32 -> V.Vector Int32 +mkIntVector n = V.fromList (mkIntList n) + +mkTextVector :: Int -> V.Vector Text +mkTextVector n = V.fromList (mkTextList n) + +mkLongTextVector :: Int -> V.Vector Text +mkLongTextVector n = V.fromList (mkLongTextList n) diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,15 @@ +module Main where + +import DecodeVectors +import Encode +import EncodeVectors +import Criterion.Main + +main :: IO () +main = + defaultMain $ + mconcat + [ Encode.groups + , EncodeVectors.groups + , DecodeVectors.groups + ] diff --git a/bench/Types.hs b/bench/Types.hs new file mode 100644 --- /dev/null +++ b/bench/Types.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Types where + +import FlatBuffers + +$(mkFlatBuffers "bench/types.fbs" defaultOptions) diff --git a/cbits/cbits.c b/cbits/cbits.c new file mode 100644 --- /dev/null +++ b/cbits/cbits.c @@ -0,0 +1,78 @@ +/* + * See https://github.com/haskell/text/blob/9fac5db9b048b7d68fa2fb68513ba86c791b3630/cbits/cbits.c for details. + */ + +#include +#include +#include + +uint32_t +_hs_text_length_utf8(const uint16_t *src, size_t srcoff, + size_t srclen) +{ + const uint16_t *srcend; + + int32_t counter = 0; + + src += srcoff; + srcend = src + srclen; + + ascii: +#if defined(__x86_64__) + while (srcend - src >= 4) { + uint64_t w = *((uint64_t *) src); + + if (w & 0xFF80FF80FF80FF80ULL) { + if (!(w & 0x000000000000FF80ULL)) { + ++counter; + src++; + if (!(w & 0x00000000FF800000ULL)) { + ++counter; + src++; + if (!(w & 0x0000FF8000000000ULL)) { + ++counter; + src++; + } + } + } + break; + } + counter += 4; + src += 4; + } +#endif + +#if defined(__i386__) + while (srcend - src >= 2) { + uint32_t w = *((uint32_t *) src); + + if (w & 0xFF80FF80) + break; + counter += 2; + src += 2; + } +#endif + + while (src < srcend) { + uint16_t w = *src++; + + if (w <= 0x7F) { + ++counter; + /* An ASCII byte is likely to begin a run of ASCII bytes. + Falling back into the fast path really helps performance. */ + goto ascii; + } + else if (w <= 0x7FF) { + counter += 2; + } + else if (w < 0xD800 || w > 0xDBFF) { + counter += 3; + } else { + uint32_t c = ((((uint32_t) w) - 0xD800) << 10) + + (((uint32_t) *src++) - 0xDC00) + 0x10000; + counter += 4; + } + } + + return counter; +} diff --git a/flatbuffers.cabal b/flatbuffers.cabal new file mode 100644 --- /dev/null +++ b/flatbuffers.cabal @@ -0,0 +1,159 @@ +cabal-version: 1.18 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 772c6499fd4f79ba88bf1b70ce28991443be358e6e1e5b7dddc77d61585751ba + +name: flatbuffers +version: 0.1.0.0 +synopsis: Haskell implementation of the FlatBuffers protocol. +description: Haskell implementation of the FlatBuffers protocol. + . + See the GitHub page for documentation: +category: Data, Serialization, Network +homepage: https://github.com/dcastro/haskell-flatbuffers +bug-reports: https://github.com/dcastro/haskell-flatbuffers/issues +author: Diogo Castro +maintainer: dc@diogocastro.com +copyright: 2019 Diogo Castro +license: BSD3 +license-file: LICENSE +tested-with: GHC == 8.4.3 , GHC == 8.6.5 +build-type: Simple +extra-source-files: + README.md + cbits/cbits.c +extra-doc-files: + README.md + +source-repository head + type: git + location: https://github.com/dcastro/haskell-flatbuffers + +library + exposed-modules: + FlatBuffers + FlatBuffers.Internal.Build + FlatBuffers.Internal.Compiler.Display + FlatBuffers.Internal.Compiler.NamingConventions + FlatBuffers.Internal.Compiler.Parser + FlatBuffers.Internal.Compiler.ParserIO + FlatBuffers.Internal.Compiler.SemanticAnalysis + FlatBuffers.Internal.Compiler.SyntaxTree + FlatBuffers.Internal.Compiler.TH + FlatBuffers.Internal.Compiler.ValidSyntaxTree + FlatBuffers.Internal.Constants + FlatBuffers.Internal.FileIdentifier + FlatBuffers.Internal.Read + FlatBuffers.Internal.Types + FlatBuffers.Internal.Util + FlatBuffers.Internal.Write + FlatBuffers.Vector + other-modules: + Paths_flatbuffers + hs-source-dirs: + src + ghc-options: -Wall -Wno-name-shadowing -Wincomplete-record-updates -Wredundant-constraints + c-sources: + cbits/cbits.c + build-depends: + base >=4.11 && <5 + , binary >=0.8.4.0 + , bytestring >=0.10.8.0 + , containers >=0.5.11.0 + , directory >=1.3.1.2 + , filepath >=1.4.2 + , megaparsec >=7.0 + , mtl >=2.2.1 + , parser-combinators >=1.0 + , scientific >=0.3.5.2 + , template-haskell >=2.13.0.0 + , text >=1.2.3.0 + , text-manipulate >=0.1.0 + default-language: Haskell2010 + +test-suite test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Examples + Examples.Generated + Examples.HandWritten + FlatBuffers.AlignmentSpec + FlatBuffers.Integration.HaskellToScalaSpec + FlatBuffers.Integration.RoundTripThroughFlatcSpec + FlatBuffers.Internal.Compiler.ParserSpec + FlatBuffers.Internal.Compiler.SemanticAnalysisSpec + FlatBuffers.Internal.Compiler.THSpec + FlatBuffers.ReadSpec + FlatBuffers.RoundTripSpec + TestImports + Paths_flatbuffers + hs-source-dirs: + test/ + ghc-options: -Wall -Wno-name-shadowing -Wincomplete-record-updates -Wredundant-constraints + build-depends: + HUnit + , aeson + , aeson-pretty + , base >=4.11 && <5 + , binary >=0.8.4.0 + , bytestring >=0.10.8.0 + , containers >=0.5.11.0 + , directory >=1.3.1.2 + , filepath >=1.4.2 + , flatbuffers + , hedgehog + , hspec + , hspec-core + , hspec-expectations-pretty-diff + , hspec-megaparsec + , http-client + , http-types + , hw-hspec-hedgehog + , megaparsec >=7.0 + , mtl >=2.2.1 + , parser-combinators >=1.0 + , process + , raw-strings-qq + , scientific >=0.3.5.2 + , template-haskell >=2.13.0.0 + , text >=1.2.3.0 + , text-manipulate >=0.1.0 + , th-pprint + , utf8-string + default-language: Haskell2010 + +benchmark criterion-bench + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + DecodeVectors + Encode + EncodeVectors + Types + Paths_flatbuffers + hs-source-dirs: + bench/ + ghc-options: -Wall -Wno-name-shadowing -Wincomplete-record-updates -Wredundant-constraints -threaded -rtsopts + build-depends: + aeson + , base >=4.11 && <5 + , binary >=0.8.4.0 + , bytestring >=0.10.8.0 + , containers >=0.5.11.0 + , criterion + , directory >=1.3.1.2 + , filepath >=1.4.2 + , flatbuffers + , megaparsec >=7.0 + , mtl >=2.2.1 + , parser-combinators >=1.0 + , scientific >=0.3.5.2 + , template-haskell >=2.13.0.0 + , text >=1.2.3.0 + , text-manipulate >=0.1.0 + , vector + default-language: Haskell2010 diff --git a/src/FlatBuffers.hs b/src/FlatBuffers.hs new file mode 100644 --- /dev/null +++ b/src/FlatBuffers.hs @@ -0,0 +1,39 @@ +module FlatBuffers + ( + -- * TemplateHaskell + TH.mkFlatBuffers + , TH.defaultOptions + , TH.Options(..) + + -- * Creating a flatbuffer + , W.encode + , W.encodeWithFileIdentifier + , W.none + + -- * Reading a flatbuffer + , R.decode + , R.checkFileIdentifier + + -- * File Identifier + , FI.FileIdentifier + , FI.HasFileIdentifier(..) + + -- * Types + , W.WriteStruct + , W.WriteTable + , W.WriteUnion + , R.Struct + , R.Table + , R.Union(..) + , T.InlineSize(..) + , T.Alignment(..) + , T.IsStruct(..) + , R.ReadError + ) where + +import FlatBuffers.Internal.Compiler.TH as TH +import FlatBuffers.Internal.FileIdentifier as FI +import FlatBuffers.Internal.Read as R +import FlatBuffers.Internal.Types as T +import FlatBuffers.Internal.Write as W + diff --git a/src/FlatBuffers/Internal/Build.hs b/src/FlatBuffers/Internal/Build.hs new file mode 100644 --- /dev/null +++ b/src/FlatBuffers/Internal/Build.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE BangPatterns #-} + +module FlatBuffers.Internal.Build where + +import Data.ByteString.Builder ( Builder ) +import qualified Data.ByteString.Builder as B +import Data.Int +import Data.Word + +{-# INLINE buildWord8 #-} +buildWord8 :: Word8 -> Builder +buildWord8 = B.word8 + +{-# INLINE buildWord16 #-} +buildWord16 :: Word16 -> Builder +buildWord16 = B.word16LE + +{-# INLINE buildWord32 #-} +buildWord32 :: Word32 -> Builder +buildWord32 = B.word32LE + +{-# INLINE buildWord64 #-} +buildWord64 :: Word64 -> Builder +buildWord64 = B.word64LE + +{-# INLINE buildInt8 #-} +buildInt8 :: Int8 -> Builder +buildInt8 = B.int8 + +{-# INLINE buildInt16 #-} +buildInt16 :: Int16 -> Builder +buildInt16 = B.int16LE + +{-# INLINE buildInt32 #-} +buildInt32 :: Int32 -> Builder +buildInt32 = B.int32LE + +{-# INLINE buildInt64 #-} +buildInt64 :: Int64 -> Builder +buildInt64 = B.int64LE + +{-# INLINE buildFloat #-} +buildFloat :: Float -> Builder +buildFloat = B.floatLE + +{-# INLINE buildDouble #-} +buildDouble :: Double -> Builder +buildDouble = B.doubleLE + +{-# INLINE buildBool #-} +buildBool :: Bool -> Builder +buildBool = buildWord8 . boolToWord8 + +{-# INLINE buildPadding #-} +buildPadding :: Int32 -> Builder +buildPadding !n = + foldMap (\_ -> B.word8 0) [0..n-1] + +{-# INLINE boolToWord8 #-} +boolToWord8 :: Bool -> Word8 +boolToWord8 False = 0 +boolToWord8 True = 1 diff --git a/src/FlatBuffers/Internal/Compiler/Display.hs b/src/FlatBuffers/Internal/Compiler/Display.hs new file mode 100644 --- /dev/null +++ b/src/FlatBuffers/Internal/Compiler/Display.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} + +module FlatBuffers.Internal.Compiler.Display where + +import Data.List.NonEmpty ( NonEmpty ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T +import Data.Text ( Text ) + +-- | Maps a value of type @a@ into a string that can be displayed to the user. +-- move this to its own file +class Display a where + display :: a -> Text + +instance Display Text where + display = id + +instance Display a => Display (NonEmpty a) where + display = display . NE.toList + +instance Display a => Display [a] where + display xs = T.intercalate ", " (fmap displayOne xs) + where + displayOne x = "'" <> display x <> "'" + +instance Display Integer where + display = displayFromShow + +displayFromShow :: Show a => a -> Text +displayFromShow = T.pack . show diff --git a/src/FlatBuffers/Internal/Compiler/NamingConventions.hs b/src/FlatBuffers/Internal/Compiler/NamingConventions.hs new file mode 100644 --- /dev/null +++ b/src/FlatBuffers/Internal/Compiler/NamingConventions.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module FlatBuffers.Internal.Compiler.NamingConventions where + +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.Manipulate as TM + +import FlatBuffers.Internal.Compiler.ValidSyntaxTree ( EnumDecl, HasIdent(..), Ident(..), Namespace(..), UnionDecl, UnionVal ) + +-- Style guide: https://google.github.io/flatbuffers/flatbuffers_guide_writing_schema.html + +dataTypeConstructor :: HasIdent a => a -> Text +dataTypeConstructor = TM.toCamel . unIdent . getIdent + +arg :: HasIdent a => a -> Text +arg = TM.toCamel . unIdent . getIdent + +dataTypeName :: HasIdent a => a -> Text +dataTypeName = TM.toPascal . unIdent . getIdent + +namespace :: Namespace -> Text +namespace (Namespace fragments) = T.intercalate "." (TM.toPascal <$> fragments) + +getter :: (HasIdent parent, HasIdent field) => parent -> field -> Text +getter (getIdent -> Ident parent) (getIdent -> Ident field) = + TM.toCamel parent <> TM.toPascal field + +toEnumFun :: EnumDecl -> Text +toEnumFun enum = + "to" <> TM.toPascal (unIdent (getIdent enum)) + +fromEnumFun :: EnumDecl -> Text +fromEnumFun enum = + "from" <> TM.toPascal (unIdent (getIdent enum)) + +enumUnionMember :: (HasIdent parent, HasIdent val) => parent -> val -> Text +enumUnionMember (getIdent -> Ident parentIdent) (getIdent -> Ident valIdent) = + TM.toPascal parentIdent <> TM.toPascal valIdent + +unionConstructor :: UnionDecl -> UnionVal -> Text +unionConstructor union unionVal = + TM.toCamel (unIdent $ getIdent union) <> TM.toPascal (unIdent $ getIdent unionVal) + +readUnionFun :: HasIdent union => union -> Text +readUnionFun (getIdent -> Ident unionIdent) = + "read" <> TM.toPascal unionIdent + +withModulePrefix :: Namespace -> Text -> Text +withModulePrefix ns text = + if ns == "" + then text + else namespace ns <> "." <> text + diff --git a/src/FlatBuffers/Internal/Compiler/Parser.hs b/src/FlatBuffers/Internal/Compiler/Parser.hs new file mode 100644 --- /dev/null +++ b/src/FlatBuffers/Internal/Compiler/Parser.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +{- HLINT ignore structField "Reduce duplication" -} +{- HLINT ignore typeRef "Use <$>" -} + +module FlatBuffers.Internal.Compiler.Parser where + +import Control.Monad ( when ) +import qualified Control.Monad.Combinators.NonEmpty as NE + +import qualified Data.ByteString as BS +import Data.Coerce ( coerce ) +import Data.Functor ( void ) +import Data.List.NonEmpty ( NonEmpty ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Maybe ( catMaybes ) +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Void ( Void ) +import Data.Word ( Word8 ) + +import FlatBuffers.Internal.Compiler.SyntaxTree +import FlatBuffers.Internal.Constants ( fileIdentifierSize ) + +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L + + +type Parser = Parsec Void String + +-- | Roughly based on: https://google.github.io/flatbuffers/flatbuffers_grammar.html. +-- Differences between this parser and the above grammar: +-- +-- * Unions members now support aliases. +-- * An enum's underlying type used to be optional (defaulting to @short@), but now it's mandatory. +-- * Attributes can be reffered to either as an identifier or as a string literal (e.g. @attr@ or @"attr"@). +-- * Struct fields can't have default values. +-- * The grammar states that table/struct field defaults can only be scalars (integer/floating point constants), +-- when in reality, it could be also be a boolean or an enum identifier. +-- * The grammar says attribute values can be integers, floats or string literals. +-- Flatc only allows integers and string literals. To make things simpler, we decided to go with flatc's +-- approach and disallow floats. +-- * The grammar says namespaces must include at least one fragment, but an empty namespace +-- (i.e. @namespace ;@) is perfectly valid. +-- * This supports @native_include@ statements +-- (see: https://google.github.io/flatbuffers/flatbuffers_guide_use_cpp.html#flatbuffers_cpp_object_based_api) +schema :: Parser Schema +schema = do + sc + includes <- catMaybes <$> many (Just <$> include <|> Nothing <$ nativeInclude) + decls <- many (decl <|> failOnInclude) + eof + pure $ Schema includes (catMaybes decls) + where + failOnInclude = + rword "include" *> fail "\"include\" statements must be at the beginning of the file." + <|> (rword "native_include" *> fail "\"native_include\" statements must be at the beginning of the file.") + +decl :: Parser (Maybe Decl) +decl = + choice + [ Just . DeclN <$> namespaceDecl + , Just . DeclT <$> tableDecl + , Just . DeclS <$> structDecl + , Just . DeclE <$> enumDecl + , Just . DeclU <$> unionDecl + , Just . DeclR <$> rootDecl + , Just . DeclFI <$> fileIdentifierDecl + , Just . DeclA <$> attributeDecl + , Nothing <$ fileExtensionDecl + , Nothing <$ jsonObj + , Nothing <$ rpcDecl + ] + +-- | space consumer - this consumes and ignores any whitespace + comments +sc :: Parser () +sc = L.space space1 lineCmnt blockCmnt + where + lineCmnt = L.skipLineComment "//" + blockCmnt = L.skipBlockComment "/*" "*/" + +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +symbol :: String -> Parser String +symbol = L.symbol sc + +rword :: String -> Parser () +rword w = (lexeme . try) (string w *> notFollowedBy (alphaNumChar <|> char '_')) + +curly, square, parens :: Parser a -> Parser a +curly = between (symbol "{") (symbol "}") +square = between (symbol "[") (symbol "]") +parens = between (symbol "(") (symbol ")") + + +commaSep :: Parser a -> Parser [a] +commaSep p = sepBy p (symbol ",") + +commaSep1 :: Parser a -> Parser (NonEmpty a) +commaSep1 p = NE.sepBy1 p (symbol ",") + +semi, colon :: Parser () +semi = void $ symbol ";" +colon = void $ symbol ":" + +ident :: Parser Ident +ident = label "identifier" $ (lexeme . try) identifier + where + identifier = fmap (Ident . T.pack) $ (:) <$> letterChar <*> many (alphaNumChar <|> char '_') + +typ :: Parser Type +typ = + TInt8 <$ (rword "int8" <|> rword "byte") <|> + TInt16 <$ (rword "int16" <|> rword "short") <|> + TInt32 <$ (rword "int32" <|> rword "int") <|> + TInt64 <$ (rword "int64" <|> rword "long") <|> + TWord8 <$ (rword "uint8" <|> rword "ubyte") <|> + TWord16 <$ (rword "uint16" <|> rword "ushort") <|> + TWord32 <$ (rword "uint32" <|> rword "uint") <|> + TWord64 <$ (rword "uint64" <|> rword "ulong") <|> + + TFloat <$ (rword "float32" <|> rword "float") <|> + TDouble <$ (rword "float64" <|> rword "double") <|> + + TBool <$ rword "bool" <|> + TString <$ rword "string" <|> + label "type identifier" (TRef <$> typeRef) <|> + label "vector type" vector + where + vector = TVector <$> between + (symbol "[" *> (notFollowedBy (symbol "[") <|> fail "nested vector types not supported" )) + (symbol "]") + typ + +typeRef :: Parser TypeRef +typeRef = do + idents <- many (try (ident <* symbol ".")) + i <- ident + pure $ TypeRef (Namespace (coerce idents)) i + +tableField :: Parser TableField +tableField = do + i <- ident + colon + t <- typ + def <- optional (symbol "=" *> defaultVal) + md <- metadata + semi + pure $ TableField i t def md + +structField :: Parser StructField +structField = do + i <- ident + colon + t <- typ + md <- metadata + semi + pure $ StructField i t md + +tableDecl :: Parser TableDecl +tableDecl = do + rword "table" + i <- ident + md <- metadata + fs <- curly (many tableField) + pure $ TableDecl i md fs + +structDecl :: Parser StructDecl +structDecl = do + rword "struct" + i <- ident + md <- metadata + fs <- curly (NE.some structField) + pure $ StructDecl i md fs + +enumDecl :: Parser EnumDecl +enumDecl = do + rword "enum" + i <- ident + colon + t <- typ + md <- metadata + v <- curly (commaSep1 enumVal) + pure $ EnumDecl i t md v + +enumVal :: Parser EnumVal +enumVal = EnumVal <$> ident <*> optional (symbol "=" *> intLiteral) + +unionDecl :: Parser UnionDecl +unionDecl = do + rword "union" + i <- ident + md <- metadata + v <- curly (commaSep1 unionVal) + pure $ UnionDecl i md v + +unionVal :: Parser UnionVal +unionVal = UnionVal <$> optional (try (ident <* colon)) <*> typeRef + +namespaceDecl :: Parser NamespaceDecl +namespaceDecl = + NamespaceDecl . Namespace . coerce <$> + (rword "namespace" *> sepBy ident (symbol ".") <* semi) + +stringLiteral :: Parser StringLiteral +stringLiteral = + label "string literal" $ + fmap (StringLiteral . T.pack) . lexeme $ + char '"' >> manyTill L.charLiteral (char '"') + +intLiteral :: Parser IntLiteral +intLiteral = + label "integer literal" . lexeme $ + L.signed sc L.decimal + +attributeVal :: Parser AttributeVal +attributeVal = + choice + [ AttrI . unIntLiteral <$> intLiteral + , AttrS . unStringLiteral <$> stringLiteral + ] + +defaultVal :: Parser DefaultVal +defaultVal = + choice + [ DefaultBool True <$ rword "true" + , DefaultBool False <$ rword "false" + , DefaultNum <$> label "number literal" (lexeme (L.signed sc L.scientific)) + , DefaultRef <$> ident + ] + +metadata :: Parser Metadata +metadata = + label "metadata" + . fmap (Metadata . Map.fromList . maybe [] NE.toList) + . optional + . parens + . commaSep1 $ + (,) <$> attributeName <*> optional (colon *> attributeVal) + +include :: Parser Include +include = Include <$> (rword "include" *> stringLiteral <* semi) + +-- | See: https://google.github.io/flatbuffers/flatbuffers_guide_use_cpp.html#flatbuffers_cpp_object_based_api +nativeInclude :: Parser () +nativeInclude = void (rword "native_include" >> stringLiteral >> semi) + +rootDecl :: Parser RootDecl +rootDecl = RootDecl <$> (rword "root_type" *> typeRef <* semi) + +fileExtensionDecl :: Parser () +fileExtensionDecl = void (rword "file_extension" *> stringLiteral <* semi) + +fileIdentifierDecl :: Parser FileIdentifierDecl +fileIdentifierDecl = do + rword "file_identifier" + fi <- coerce stringLiteral + + let byteCount = BS.length (T.encodeUtf8 fi) + let codePointCount = T.length fi + + when (byteCount /= fileIdentifierSize) $ + if codePointCount == byteCount + -- if the user is using ASCII characters + then fail $ "file_identifier must be exactly " <> show (fileIdentifierSize @Word8) <> " characters" + -- if the user is using multi UTF-8 code unit characters, show a more detailed error message + else fail $ "file_identifier must be exactly " <> show (fileIdentifierSize @Word8) <> " UTF-8 code units" + + semi + pure (FileIdentifierDecl fi) + +attributeDecl :: Parser AttributeDecl +attributeDecl = AttributeDecl <$> (rword "attribute" *> attributeName <* semi) + +attributeName :: Parser Text +attributeName = coerce stringLiteral <|> coerce ident + +jsonObj :: Parser () +jsonObj = + label "JSON object" (void jobject) + where + json = choice [void jstring, void jnumber, jbool, jnull, void jarray, void jobject] + jnull = rword "null" + jbool = rword "true" <|> rword "false" + jstring = stringLiteral + jnumber = lexeme $ L.signed sc L.scientific + jarray = square (commaSep json) + jobject = curly (commaSep keyValuePair) + + keyValuePair = do + void stringLiteral <|> void ident + colon + json + +rpcDecl :: Parser () +rpcDecl = void $ rword "rpc_service" >> ident >> curly (NE.some rpcMethod) + +rpcMethod :: Parser () +rpcMethod = ident >> parens ident >> colon >> ident >> metadata >> void semi diff --git a/src/FlatBuffers/Internal/Compiler/ParserIO.hs b/src/FlatBuffers/Internal/Compiler/ParserIO.hs new file mode 100644 --- /dev/null +++ b/src/FlatBuffers/Internal/Compiler/ParserIO.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module FlatBuffers.Internal.Compiler.ParserIO where + +import Control.Monad ( when ) +import Control.Monad.Except ( MonadError, MonadIO, liftIO, throwError ) +import Control.Monad.State ( MonadState, execStateT, get, put ) + +import Data.Coerce ( coerce ) +import Data.Foldable ( traverse_ ) +import Data.Map.Strict ( Map ) +import qualified Data.Map.Strict as Map +import Data.Text ( Text ) +import qualified Data.Text as T + +import FlatBuffers.Internal.Compiler.Display ( display ) +import FlatBuffers.Internal.Compiler.Parser ( schema ) +import FlatBuffers.Internal.Compiler.SyntaxTree ( FileTree(..), Include(..), Schema, StringLiteral(..), includes ) + +import qualified System.Directory as Dir +import qualified System.FilePath as FP + +import Text.Megaparsec ( errorBundlePretty, parse ) + +parseSchemas :: + MonadIO m + => MonadError Text m + => FilePath -- ^ Filepath of the root schema. It must be a path relative to the project root or an absolute path. + -> [FilePath] -- ^ Directories to search for @include@s. + -> m (FileTree Schema) +parseSchemas rootFilePath includeDirs = do + fileContent <- liftIO $ readFile rootFilePath + case parse schema rootFilePath fileContent of + Left err -> throwError . T.pack . errorBundlePretty $ err + Right rootSchema -> do + rootFilePathCanon <- liftIO $ Dir.canonicalizePath rootFilePath + let importedFilePaths = T.unpack . coerce <$> includes rootSchema + + importedSchemas <- flip execStateT Map.empty $ + traverse_ + (parseImportedSchema includeDirs rootFilePathCanon) + importedFilePaths + pure FileTree + { fileTreeFilePath = rootFilePathCanon + , fileTreeRoot = rootSchema + , fileTreeForest = importedSchemas + } + +parseImportedSchema :: + MonadState (Map FilePath Schema) m + => MonadIO m + => MonadError Text m + => [FilePath] + -> FilePath + -> FilePath + -> m () +parseImportedSchema includeDirs rootFilePathCanon filePath = + go rootFilePathCanon filePath + where + go parentSchemaPath filePath = do + + let parentSchemaDir = FP.takeDirectory parentSchemaPath + let dirCandidates = parentSchemaDir : includeDirs + + actualFilePathCanonMaybe <- liftIO $ Dir.findFile dirCandidates filePath >>= traverse Dir.canonicalizePath + + case actualFilePathCanonMaybe of + Nothing -> throwError $ + "File '" + <> T.pack filePath + <> "' (imported from '" + <> T.pack parentSchemaPath + <> "') not found.\n Searched in these directories: [" + <> display (T.pack <$> dirCandidates) + <> "]" + Just actualFilePathCanon -> do + importedSchemas <- get + when (actualFilePathCanon /= rootFilePathCanon && actualFilePathCanon `Map.notMember` importedSchemas) $ do + fileContent <- liftIO $ readFile actualFilePathCanon + case parse schema actualFilePathCanon fileContent of + Left err -> throwError . T.pack . errorBundlePretty $ err + Right importedSchema -> do + put (Map.insert actualFilePathCanon importedSchema importedSchemas) + traverse_ (go actualFilePathCanon . T.unpack . coerce) (includes importedSchema) diff --git a/src/FlatBuffers/Internal/Compiler/SemanticAnalysis.hs b/src/FlatBuffers/Internal/Compiler/SemanticAnalysis.hs new file mode 100644 --- /dev/null +++ b/src/FlatBuffers/Internal/Compiler/SemanticAnalysis.hs @@ -0,0 +1,924 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module FlatBuffers.Internal.Compiler.SemanticAnalysis where + +import Control.Monad ( forM_, join, when ) +import Control.Monad.Except ( MonadError, throwError ) +import Control.Monad.Reader ( MonadReader(..), asks, runReaderT ) +import Control.Monad.State ( MonadState, State, StateT, evalState, evalStateT, get, modify, put ) + +import Data.Coerce ( coerce ) +import Data.Foldable ( asum, find, foldlM, traverse_ ) +import qualified Data.Foldable as Foldable +import Data.Functor ( ($>), (<&>) ) +import Data.Int +import Data.Ix ( inRange ) +import qualified Data.List as List +import Data.List.NonEmpty ( NonEmpty ) +import qualified Data.List.NonEmpty as NE +import Data.Map.Strict ( Map ) +import qualified Data.Map.Strict as Map +import Data.Maybe ( catMaybes, fromMaybe, isJust ) +import Data.Monoid ( Sum(..) ) +import Data.Scientific ( Scientific ) +import qualified Data.Scientific as Scientific +import Data.Set ( Set ) +import qualified Data.Set as Set +import Data.Text ( Text ) +import qualified Data.Text as T +import Data.Traversable ( for ) +import Data.Word + +import FlatBuffers.Internal.Compiler.Display ( Display(..) ) +import FlatBuffers.Internal.Compiler.SyntaxTree ( FileTree(..), HasIdent(..), HasMetadata(..), Ident, Namespace, Schema, TypeRef(..), qualify ) +import qualified FlatBuffers.Internal.Compiler.SyntaxTree as ST +import FlatBuffers.Internal.Compiler.ValidSyntaxTree +import FlatBuffers.Internal.Constants +import FlatBuffers.Internal.Types +import FlatBuffers.Internal.Util ( isPowerOfTwo, roundUpToNearestMultipleOf ) + +import Text.Read ( readMaybe ) + + +type ValidationCtx m = (MonadError Text m, MonadReader ValidationState m) + +data ValidationState = ValidationState + { validationStateCurrentContext :: !Ident + -- ^ The thing being validated (e.g. a fully-qualified struct name, or a table field name). + , validationStateAllAttributes :: !(Set ST.AttributeDecl) + -- ^ All the attributes declared in all the schemas (including imported ones). + } + + +modifyContext :: ValidationCtx m => (Ident -> Ident) -> m a -> m a +modifyContext f = + local $ \s -> + s { validationStateCurrentContext = f (validationStateCurrentContext s) } + +data SymbolTable enum struct table union = SymbolTable + { allEnums :: ![(Namespace, enum)] + , allStructs :: ![(Namespace, struct)] + , allTables :: ![(Namespace, table)] + , allUnions :: ![(Namespace, union)] + } + deriving (Eq, Show) + +instance Semigroup (SymbolTable e s t u) where + SymbolTable e1 s1 t1 u1 <> SymbolTable e2 s2 t2 u2 = + SymbolTable (e1 <> e2) (s1 <> s2) (t1 <> t2) (u1 <> u2) + +instance Monoid (SymbolTable e s t u) where + mempty = SymbolTable [] [] [] [] + +type Stage1 = SymbolTable ST.EnumDecl ST.StructDecl ST.TableDecl ST.UnionDecl +type Stage2 = SymbolTable EnumDecl ST.StructDecl ST.TableDecl ST.UnionDecl +type Stage3 = SymbolTable EnumDecl StructDecl ST.TableDecl ST.UnionDecl +type Stage4 = SymbolTable EnumDecl StructDecl TableDecl ST.UnionDecl +type ValidDecls = SymbolTable EnumDecl StructDecl TableDecl UnionDecl + +-- | Takes a collection of schemas, and pairs each type declaration with its corresponding namespace +createSymbolTables :: FileTree Schema -> FileTree Stage1 +createSymbolTables = fmap (pairDeclsWithNamespaces . ST.decls) + where + pairDeclsWithNamespaces :: [ST.Decl] -> Stage1 + pairDeclsWithNamespaces = snd . foldl go ("", mempty) + + go :: (Namespace, Stage1) -> ST.Decl -> (Namespace, Stage1) + go (currentNamespace, decls) decl = + case decl of + ST.DeclN (ST.NamespaceDecl newNamespace) -> (newNamespace, decls) + ST.DeclE enum -> (currentNamespace, decls <> SymbolTable [(currentNamespace, enum)] [] [] []) + ST.DeclS struct -> (currentNamespace, decls <> SymbolTable [] [(currentNamespace, struct)] [] []) + ST.DeclT table -> (currentNamespace, decls <> SymbolTable [] [] [(currentNamespace, table)] []) + ST.DeclU union -> (currentNamespace, decls <> SymbolTable [] [] [] [(currentNamespace, union)]) + _ -> (currentNamespace, decls) + +validateSchemas :: MonadError Text m => FileTree Schema -> m (FileTree ValidDecls) +validateSchemas schemas = + flip runReaderT (ValidationState "" allAttributes) $ do + checkDuplicateIdentifiers allQualifiedTopLevelIdentifiers + validateEnums symbolTables + >>= validateStructs + >>= validateTables + >>= validateUnions + >>= updateRootTable (fileTreeRoot schemas) + where + symbolTables = createSymbolTables schemas + + allQualifiedTopLevelIdentifiers = + flip concatMap symbolTables $ \symbolTable -> + join + [ uncurry qualify <$> allEnums symbolTable + , uncurry qualify <$> allStructs symbolTable + , uncurry qualify <$> allTables symbolTable + , uncurry qualify <$> allUnions symbolTable + ] + + declaredAttributes = + flip concatMap schemas $ \schema -> + [ attr | ST.DeclA attr <- ST.decls schema ] + + allAttributes = Set.fromList $ declaredAttributes <> knownAttributes + +---------------------------------- +------------ Root Type ----------- +---------------------------------- +data RootInfo = RootInfo + { rootTableNamespace :: !Namespace + , rootTable :: !TableDecl + , rootFileIdent :: !(Maybe Text) + } + +-- | Finds the root table (if any) and sets the `tableIsRoot` flag accordingly. +-- We only care about @root_type@ declarations in the root schema. Imported schemas are not scanned for @root_type@s. +-- The root type declaration can point to a table in any schema (root or imported). +updateRootTable :: forall m. ValidationCtx m => Schema -> FileTree ValidDecls -> m (FileTree ValidDecls) +updateRootTable schema symbolTables = + getRootInfo schema symbolTables <&> \case + Just rootInfo -> updateSymbolTable rootInfo <$> symbolTables + Nothing -> symbolTables + + where + updateSymbolTable :: RootInfo -> ValidDecls -> ValidDecls + updateSymbolTable rootInfo st = st { allTables = updateTable rootInfo <$> allTables st} + + updateTable :: RootInfo -> (Namespace, TableDecl) -> (Namespace, TableDecl) + updateTable (RootInfo rootTableNamespace rootTable fileIdent) pair@(namespace, table) = + if namespace == rootTableNamespace && table == rootTable + then (namespace, table { tableIsRoot = IsRoot fileIdent }) + else pair + +getRootInfo :: forall m. ValidationCtx m => Schema -> FileTree ValidDecls -> m (Maybe RootInfo) +getRootInfo schema symbolTables = + foldlM go ("", Nothing, Nothing) (ST.decls schema) <&> \case + (_, Just (rootTableNamespace, rootTable), fileIdent) -> Just $ RootInfo rootTableNamespace rootTable fileIdent + _ -> Nothing + where + go :: (Namespace, Maybe (Namespace, TableDecl), Maybe Text) -> ST.Decl -> m (Namespace, Maybe (Namespace, TableDecl), Maybe Text) + go state@(currentNamespace, rootInfo, fileIdent) decl = + case decl of + ST.DeclN (ST.NamespaceDecl newNamespace) -> pure (newNamespace, rootInfo, fileIdent) + ST.DeclFI (ST.FileIdentifierDecl newFileIdent) -> pure (currentNamespace, rootInfo, Just (coerce newFileIdent)) + ST.DeclR (ST.RootDecl typeRef) -> + findDecl currentNamespace symbolTables typeRef >>= \case + MatchT (rootTableNamespace, rootTable) -> pure (currentNamespace, Just (rootTableNamespace, rootTable), fileIdent) + _ -> throwErrorMsg "root type must be a table" + _ -> pure state + + +---------------------------------- +----------- Attributes ----------- +---------------------------------- +knownAttributes :: [ST.AttributeDecl] +knownAttributes = + coerce + [ idAttr + , deprecatedAttr + , requiredAttr + , forceAlignAttr + , bitFlagsAttr + ] + <> otherKnownAttributes + +idAttr, deprecatedAttr, requiredAttr, forceAlignAttr, bitFlagsAttr :: Text +idAttr = "id" +deprecatedAttr = "deprecated" +requiredAttr = "required" +forceAlignAttr = "force_align" +bitFlagsAttr = "bit_flags" + +otherKnownAttributes :: [ST.AttributeDecl] +otherKnownAttributes = + -- https://google.github.io/flatbuffers/flatbuffers_guide_writing_schema.html + [ "nested_flatbuffer" + , "flexbuffer" + , "key" + , "hash" + , "original_order" + -- https://google.github.io/flatbuffers/flatbuffers_guide_use_cpp.html#flatbuffers_cpp_object_based_api + , "native_inline" + , "native_default" + , "native_custom_alloc" + , "native_type" + , "cpp_type" + , "cpp_ptr_type" + , "cpp_str_type" + , "cpp_str_flex_ctor" + , "shared" + ] + +---------------------------------- +--------- Symbol search ---------- +---------------------------------- +data Match enum struct table union + = MatchE !(Namespace, enum) + | MatchS !(Namespace, struct) + | MatchT !(Namespace, table) + | MatchU !(Namespace, union) + +-- | Looks for a type reference in a set of type declarations. +-- If none is found, the list of namespaces in which the type reference was searched for is returned. +findDecl :: + ValidationCtx m + => (HasIdent e, HasIdent s, HasIdent t, HasIdent u) + => Namespace + -> FileTree (SymbolTable e s t u) + -> TypeRef + -> m (Match e s t u) +findDecl currentNamespace symbolTables typeRef@(TypeRef refNamespace refIdent) = + let parentNamespaces' = parentNamespaces currentNamespace + results = do + parentNamespace <- parentNamespaces' + let candidateNamespace = parentNamespace <> refNamespace + let searchSymbolTable symbolTable = + asum + [ MatchE <$> find (\(ns, e) -> ns == candidateNamespace && getIdent e == refIdent) (allEnums symbolTable) + , MatchS <$> find (\(ns, e) -> ns == candidateNamespace && getIdent e == refIdent) (allStructs symbolTable) + , MatchT <$> find (\(ns, e) -> ns == candidateNamespace && getIdent e == refIdent) (allTables symbolTable) + , MatchU <$> find (\(ns, e) -> ns == candidateNamespace && getIdent e == refIdent) (allUnions symbolTable) + ] + pure $ asum $ fmap searchSymbolTable symbolTables + in + case asum results of + Just match -> pure match + Nothing -> + throwErrorMsg $ + "type '" + <> display typeRef + <> "' does not exist (checked in these namespaces: " + <> display parentNamespaces' + <> ")" + +-- | Returns a list of all the namespaces "between" the current namespace +-- and the root namespace, in that order. +-- See: https://github.com/google/flatbuffers/issues/5234#issuecomment-471680403 +-- +-- > parentNamespaces "A.B.C" == ["A.B.C", "A.B", "A", ""] +parentNamespaces :: ST.Namespace -> NonEmpty ST.Namespace +parentNamespaces (ST.Namespace ns) = + coerce $ NE.reverse $ NE.inits ns + +---------------------------------- +------------- Enums -------------- +---------------------------------- +validateEnums :: forall m. ValidationCtx m => FileTree Stage1 -> m (FileTree Stage2) +validateEnums symbolTables = + for symbolTables $ \symbolTable -> do + let enums = allEnums symbolTable + let validate (namespace, enum) = do + validEnum <- validateEnum (namespace, enum) + pure (namespace, validEnum) + validEnums <- traverse validate enums + pure symbolTable { allEnums = validEnums } + +-- TODO: add support for `bit_flags` attribute +validateEnum :: forall m. ValidationCtx m => (Namespace, ST.EnumDecl) -> m EnumDecl +validateEnum (currentNamespace, enum) = + modifyContext (\_ -> qualify currentNamespace enum) $ do + checkBitFlags + checkDuplicateFields + checkUndeclaredAttributes enum + validEnum + where + validEnum = do + enumType <- validateEnumType (ST.enumType enum) + let enumVals = flip evalState Nothing . traverse mapEnumVal $ ST.enumVals enum + validateOrder enumVals + traverse_ (validateBounds enumType) enumVals + pure EnumDecl + { enumIdent = getIdent enum + , enumType = enumType + , enumVals = enumVals + } + + mapEnumVal :: ST.EnumVal -> State (Maybe Integer) EnumVal + mapEnumVal enumVal = do + thisInt <- + case ST.enumValLiteral enumVal of + Just (ST.IntLiteral thisInt) -> + pure thisInt + Nothing -> + get <&> \case + Just lastInt -> lastInt + 1 + Nothing -> 0 + put (Just thisInt) + pure (EnumVal (getIdent enumVal) thisInt) + + validateOrder :: NonEmpty EnumVal -> m () + validateOrder xs = + if all (\(x, y) -> enumValInt x < enumValInt y) (NE.toList xs `zip` NE.tail xs) + then pure () + else throwErrorMsg "enum values must be specified in ascending order" + + validateBounds :: EnumType -> EnumVal -> m () + validateBounds enumType enumVal = + modifyContext (\context -> context <> "." <> getIdent enumVal) $ + case enumType of + EInt8 -> validateBounds' @Int8 enumVal + EInt16 -> validateBounds' @Int16 enumVal + EInt32 -> validateBounds' @Int32 enumVal + EInt64 -> validateBounds' @Int64 enumVal + EWord8 -> validateBounds' @Word8 enumVal + EWord16 -> validateBounds' @Word16 enumVal + EWord32 -> validateBounds' @Word32 enumVal + EWord64 -> validateBounds' @Word64 enumVal + + validateBounds' :: forall a. (Integral a, Bounded a, Show a) => EnumVal -> m () + validateBounds' e = + if inRange (toInteger (minBound @a), toInteger (maxBound @a)) (enumValInt e) + then pure () + else throwErrorMsg $ + "enum value does not fit [" + <> T.pack (show (minBound @a)) + <> "; " + <> T.pack (show (maxBound @a)) + <> "]" + + validateEnumType :: ST.Type -> m EnumType + validateEnumType t = + case t of + ST.TInt8 -> pure EInt8 + ST.TInt16 -> pure EInt16 + ST.TInt32 -> pure EInt32 + ST.TInt64 -> pure EInt64 + ST.TWord8 -> pure EWord8 + ST.TWord16 -> pure EWord16 + ST.TWord32 -> pure EWord32 + ST.TWord64 -> pure EWord64 + _ -> throwErrorMsg "underlying enum type must be integral" + + checkDuplicateFields :: m () + checkDuplicateFields = + checkDuplicateIdentifiers + (ST.enumVals enum) + + checkBitFlags :: m () + checkBitFlags = + when (hasAttribute bitFlagsAttr (ST.enumMetadata enum)) $ + throwErrorMsg "`bit_flags` are not supported yet" + + +---------------------------------- +------------ Tables -------------- +---------------------------------- +data TableFieldWithoutId = TableFieldWithoutId !Ident !TableFieldType !Bool + +validateTables :: ValidationCtx m => FileTree Stage3 -> m (FileTree Stage4) +validateTables symbolTables = + for symbolTables $ \symbolTable -> do + let tables = allTables symbolTable + let validate (namespace, table) = do + validTable <- validateTable symbolTables (namespace, table) + pure (namespace, validTable) + validTables <- traverse validate tables + pure symbolTable { allTables = validTables } + +validateTable :: forall m. ValidationCtx m => FileTree Stage3 -> (Namespace, ST.TableDecl) -> m TableDecl +validateTable symbolTables (currentNamespace, table) = + modifyContext (\_ -> qualify currentNamespace table) $ do + + let fields = ST.tableFields table + let fieldsMetadata = ST.tableFieldMetadata <$> fields + + checkDuplicateFields fields + checkUndeclaredAttributes table + + validFieldsWithoutIds <- traverse validateTableField fields + validFields <- assignFieldIds fieldsMetadata validFieldsWithoutIds + + pure TableDecl + { tableIdent = getIdent table + , tableIsRoot = NotRoot + , tableFields = validFields + } + + where + checkDuplicateFields :: [ST.TableField] -> m () + checkDuplicateFields = checkDuplicateIdentifiers + + assignFieldIds :: [ST.Metadata] -> [TableFieldWithoutId] -> m [TableField] + assignFieldIds metadata fieldsWithoutIds = do + ids <- catMaybes <$> traverse (findIntAttr idAttr) metadata + if null ids + then pure $ evalState (traverse assignFieldId fieldsWithoutIds) (-1) + else if length ids == length fieldsWithoutIds + then do + let fields = zipWith (\(TableFieldWithoutId ident typ depr) id -> TableField id ident typ depr) fieldsWithoutIds ids + let sorted = List.sortOn tableFieldId fields + evalStateT (traverse_ checkFieldId sorted) (-1) + pure sorted + else + throwErrorMsg "either all fields or no fields must have an 'id' attribute" + + assignFieldId :: TableFieldWithoutId -> State Integer TableField + assignFieldId (TableFieldWithoutId ident typ depr) = do + lastId <- get + let fieldId = + case typ of + TUnion _ _ -> lastId + 2 + TVector _ (VUnion _) -> lastId + 2 + _ -> lastId + 1 + put fieldId + pure (TableField fieldId ident typ depr) + + checkFieldId :: TableField -> StateT Integer m () + checkFieldId field = do + lastId <- get + modifyContext (\context -> context <> "." <> getIdent field) $ do + case tableFieldType field of + TUnion _ _ -> + when (tableFieldId field /= lastId + 2) $ + throwErrorMsg "the id of a union field must be the last field's id + 2" + TVector _ (VUnion _) -> + when (tableFieldId field /= lastId + 2) $ + throwErrorMsg "the id of a vector of unions field must be the last field's id + 2" + _ -> + when (tableFieldId field /= lastId + 1) $ + throwErrorMsg $ "field ids must be consecutive from 0; id " <> display (lastId + 1) <> " is missing" + put (tableFieldId field) + + validateTableField :: ST.TableField -> m TableFieldWithoutId + validateTableField tf = + modifyContext (\context -> context <> "." <> getIdent tf) $ do + checkUndeclaredAttributes tf + validFieldType <- validateTableFieldType (ST.tableFieldMetadata tf) (ST.tableFieldDefault tf) (ST.tableFieldType tf) + + pure $ TableFieldWithoutId + (getIdent tf) + validFieldType + (hasAttribute deprecatedAttr (ST.tableFieldMetadata tf)) + + validateTableFieldType :: ST.Metadata -> Maybe ST.DefaultVal -> ST.Type -> m TableFieldType + validateTableFieldType md dflt tableFieldType = + case tableFieldType of + ST.TInt8 -> checkNoRequired md >> validateDefaultValAsInt dflt <&> TInt8 + ST.TInt16 -> checkNoRequired md >> validateDefaultValAsInt dflt <&> TInt16 + ST.TInt32 -> checkNoRequired md >> validateDefaultValAsInt dflt <&> TInt32 + ST.TInt64 -> checkNoRequired md >> validateDefaultValAsInt dflt <&> TInt64 + ST.TWord8 -> checkNoRequired md >> validateDefaultValAsInt dflt <&> TWord8 + ST.TWord16 -> checkNoRequired md >> validateDefaultValAsInt dflt <&> TWord16 + ST.TWord32 -> checkNoRequired md >> validateDefaultValAsInt dflt <&> TWord32 + ST.TWord64 -> checkNoRequired md >> validateDefaultValAsInt dflt <&> TWord64 + ST.TFloat -> checkNoRequired md >> validateDefaultValAsScientific dflt <&> TFloat + ST.TDouble -> checkNoRequired md >> validateDefaultValAsScientific dflt <&> TDouble + ST.TBool -> checkNoRequired md >> validateDefaultValAsBool dflt <&> TBool + ST.TString -> checkNoDefault dflt $> TString (isRequired md) + ST.TRef typeRef -> + findDecl currentNamespace symbolTables typeRef >>= \case + MatchE (ns, enum) -> do + checkNoRequired md + validDefault <- validateDefaultAsEnum dflt enum + pure $ TEnum (TypeRef ns (getIdent enum)) (enumType enum) validDefault + MatchS (ns, struct) -> checkNoDefault dflt $> TStruct (TypeRef ns (getIdent struct)) (isRequired md) + MatchT (ns, table) -> checkNoDefault dflt $> TTable (TypeRef ns (getIdent table)) (isRequired md) + MatchU (ns, union) -> checkNoDefault dflt $> TUnion (TypeRef ns (getIdent union)) (isRequired md) + ST.TVector vecType -> + checkNoDefault dflt >> TVector (isRequired md) <$> + case vecType of + ST.TInt8 -> pure VInt8 + ST.TInt16 -> pure VInt16 + ST.TInt32 -> pure VInt32 + ST.TInt64 -> pure VInt64 + ST.TWord8 -> pure VWord8 + ST.TWord16 -> pure VWord16 + ST.TWord32 -> pure VWord32 + ST.TWord64 -> pure VWord64 + ST.TFloat -> pure VFloat + ST.TDouble -> pure VDouble + ST.TBool -> pure VBool + ST.TString -> pure VString + ST.TVector _ -> throwErrorMsg "nested vector types not supported" + ST.TRef typeRef -> + findDecl currentNamespace symbolTables typeRef <&> \case + MatchE (ns, enum) -> + VEnum (TypeRef ns (getIdent enum)) + (enumType enum) + MatchS (ns, struct) -> + VStruct (TypeRef ns (getIdent struct)) + MatchT (ns, table) -> VTable (TypeRef ns (getIdent table)) + MatchU (ns, union) -> VUnion (TypeRef ns (getIdent union)) + +checkNoRequired :: ValidationCtx m => ST.Metadata -> m () +checkNoRequired md = + when (hasAttribute requiredAttr md) $ + throwErrorMsg "only non-scalar fields (strings, vectors, unions, structs, tables) may be 'required'" + +checkNoDefault :: ValidationCtx m => Maybe ST.DefaultVal -> m () +checkNoDefault dflt = + when (isJust dflt) $ + throwErrorMsg + "default values currently only supported for scalar fields (integers, floating point, bool, enums)" + +isRequired :: ST.Metadata -> Required +isRequired md = if hasAttribute requiredAttr md then Req else Opt + +validateDefaultValAsInt :: forall m a. (ValidationCtx m, Integral a, Bounded a, Show a) => Maybe ST.DefaultVal -> m (DefaultVal a) +validateDefaultValAsInt dflt = + case dflt of + Nothing -> pure (DefaultVal 0) + Just (ST.DefaultNum n) -> + if not (Scientific.isInteger n) + then throwErrorMsg "default value must be integral" + else case Scientific.toBoundedInteger @a n of + Nothing -> + throwErrorMsg $ + "default value does not fit [" + <> T.pack (show (minBound @a)) + <> "; " + <> T.pack (show (maxBound @a)) + <> "]" + Just i -> pure (DefaultVal i) + Just _ -> throwErrorMsg "default value must be integral" + +validateDefaultValAsScientific :: ValidationCtx m => Maybe ST.DefaultVal -> m (DefaultVal Scientific) +validateDefaultValAsScientific dflt = + case dflt of + Nothing -> pure (DefaultVal 0) + Just (ST.DefaultNum n) -> pure (DefaultVal n) + Just _ -> throwErrorMsg "default value must be a number" + +validateDefaultValAsBool :: ValidationCtx m => Maybe ST.DefaultVal -> m (DefaultVal Bool) +validateDefaultValAsBool dflt = + case dflt of + Nothing -> pure (DefaultVal False) + Just (ST.DefaultBool b) -> pure (DefaultVal b) + Just _ -> throwErrorMsg "default value must be a boolean" + +validateDefaultAsEnum :: ValidationCtx m => Maybe ST.DefaultVal -> EnumDecl -> m (DefaultVal Integer) +validateDefaultAsEnum dflt enum = + DefaultVal <$> + case dflt of + Nothing -> + case find (\val -> enumValInt val == 0) (enumVals enum) of + Just zeroVal -> pure (enumValInt zeroVal) + Nothing -> throwErrorMsg "enum does not have a 0 value; please manually specify a default for this field" + Just (ST.DefaultNum n) -> + case Scientific.floatingOrInteger @Float n of + Left _float -> throwErrorMsg $ "default value must be integral or one of: " <> display (getIdent <$> enumVals enum) + Right i -> + case find (\val -> enumValInt val == i) (enumVals enum) of + Just matchingVal -> pure (enumValInt matchingVal) + Nothing -> throwErrorMsg $ "default value of " <> display i <> " is not part of enum " <> display (getIdent enum) + Just (ST.DefaultRef ref) -> + case find (\val -> getIdent val == ref) (enumVals enum) of + Just matchingVal -> pure (enumValInt matchingVal) + Nothing -> throwErrorMsg $ "default value of " <> display ref <> " is not part of enum " <> display (getIdent enum) + + Just (ST.DefaultBool _) -> throwErrorMsg $ "default value must be integral or one of: " <> display (getIdent <$> enumVals enum) + + +---------------------------------- +------------ Unions -------------- +---------------------------------- +validateUnions :: ValidationCtx m => FileTree Stage4 -> m (FileTree ValidDecls) +validateUnions symbolTables = + for symbolTables $ \symbolTable -> do + let unions = allUnions symbolTable + let validate (namespace, union) = do + validUnion <- validateUnion symbolTables (namespace, union) + pure (namespace, validUnion) + validUnions <- traverse validate unions + pure symbolTable { allUnions = validUnions } + +validateUnion :: forall m. ValidationCtx m => FileTree Stage4 -> (Namespace, ST.UnionDecl) -> m UnionDecl +validateUnion symbolTables (currentNamespace, union) = + modifyContext (\_ -> qualify currentNamespace union) $ do + validUnionVals <- traverse validateUnionVal (ST.unionVals union) + checkDuplicateVals validUnionVals + checkUndeclaredAttributes union + pure $ UnionDecl + { unionIdent = getIdent union + , unionVals = validUnionVals + } + where + validateUnionVal :: ST.UnionVal -> m UnionVal + validateUnionVal uv = do + let tref = ST.unionValTypeRef uv + let partiallyQualifiedTypeRef = qualify (typeRefNamespace tref) (typeRefIdent tref) + let ident = fromMaybe partiallyQualifiedTypeRef (ST.unionValIdent uv) + let identFormatted = coerce $ T.replace "." "_" $ coerce ident + modifyContext (\context -> context <> "." <> identFormatted) $ do + tableRef <- validateUnionValType tref + pure $ UnionVal + { unionValIdent = identFormatted + , unionValTableRef = tableRef + } + + validateUnionValType :: TypeRef -> m TypeRef + validateUnionValType typeRef = + findDecl currentNamespace symbolTables typeRef >>= \case + MatchT (ns, table) -> pure $ TypeRef ns (getIdent table) + _ -> throwErrorMsg "union members may only be tables" + + checkDuplicateVals :: NonEmpty UnionVal -> m () + checkDuplicateVals vals = checkDuplicateIdentifiers (NE.cons "NONE" (fmap getIdent vals)) + + +---------------------------------- +------------ Structs ------------- +---------------------------------- +validateStructs :: ValidationCtx m => FileTree Stage2 -> m (FileTree Stage3) +validateStructs symbolTables = + flip evalStateT [] $ traverse validateFile symbolTables + where + validateFile :: (MonadState [(Namespace, StructDecl)] m, ValidationCtx m) => Stage2 -> m Stage3 + validateFile symbolTable = do + let structs = allStructs symbolTable + + traverse_ (checkStructCycles symbolTables) structs + validStructs <- traverse (validateStruct symbolTables) structs + + pure symbolTable { allStructs = validStructs } + +checkStructCycles :: forall m. ValidationCtx m => FileTree Stage2 -> (Namespace, ST.StructDecl) -> m () +checkStructCycles symbolTables = go [] + where + go :: [Ident] -> (Namespace, ST.StructDecl) -> m () + go visited (currentNamespace, struct) = + let qualifiedName = qualify currentNamespace struct + in modifyContext (const qualifiedName) $ + if qualifiedName `elem` visited + then + throwErrorMsg $ + "cyclic dependency detected [" + <> display (T.intercalate " -> " . coerce $ List.dropWhile (/= qualifiedName) $ List.reverse (qualifiedName : visited)) + <>"] - structs cannot contain themselves, directly or indirectly" + else + forM_ (ST.structFields struct) $ \field -> + modifyContext (\context -> context <> "." <> getIdent field) $ + case ST.structFieldType field of + ST.TRef typeRef -> + findDecl currentNamespace symbolTables typeRef >>= \case + MatchS struct -> go (qualifiedName : visited) struct + _ -> pure () -- The TypeRef points to an enum (or is invalid), so no further validation is needed at this point + _ -> pure () -- Field is not a TypeRef, no validation needed + +data UnpaddedStructField = UnpaddedStructField + { unpaddedStructFieldIdent :: !Ident + , unpaddedStructFieldType :: !StructFieldType + } deriving (Show, Eq) + +validateStruct :: + forall m. (MonadState [(Namespace, StructDecl)] m, ValidationCtx m) + => FileTree Stage2 + -> (Namespace, ST.StructDecl) + -> m (Namespace, StructDecl) +validateStruct symbolTables (currentNamespace, struct) = + modifyContext (\_ -> qualify currentNamespace struct) $ do + validStructs <- get + -- Check if this struct has already been validated in a previous iteration + case find (\(ns, s) -> ns == currentNamespace && getIdent s == getIdent struct) validStructs of + Just match -> pure match + Nothing -> do + checkDuplicateFields + checkUndeclaredAttributes struct + + fields <- traverse validateStructField (ST.structFields struct) + let naturalAlignment = maximum (structFieldAlignment <$> fields) + forceAlignAttrVal <- getForceAlignAttr + forceAlign <- traverse (validateForceAlign naturalAlignment) forceAlignAttrVal + let alignment = fromMaybe naturalAlignment forceAlign + + -- In order to calculate the padding between fields, we must first know the fields' and the struct's + -- alignment. Which means we must first validate all the struct's fields, and then do a second + -- pass to calculate the padding. + let (size, paddedFields) = addFieldPadding alignment fields + + let validStruct = StructDecl + { structIdent = getIdent struct + , structAlignment = alignment + , structSize = size + , structFields = paddedFields + } + modify ((currentNamespace, validStruct) :) + pure (currentNamespace, validStruct) + + where + invalidStructFieldType = "struct fields may only be integers, floating point, bool, enums, or other structs" + + -- | Calculates how much padding each field needs, and returns the struct's total size + -- and a list of fields with padding information. + addFieldPadding :: Alignment -> NonEmpty UnpaddedStructField -> (InlineSize, NonEmpty StructField) + addFieldPadding structAlignment unpaddedFields = + (size, NE.fromList (reverse paddedFields)) + where + + (size, paddedFields) = go 0 [] (NE.toList unpaddedFields) + + go :: InlineSize -> [StructField] -> [UnpaddedStructField] -> (InlineSize, [StructField]) + go size paddedFields [] = (size, paddedFields) + go size paddedFields (x : y : tail) = + let size' = size + structFieldTypeSize (unpaddedStructFieldType x) + nextFieldsAlignment = fromIntegral @Alignment @InlineSize (structFieldAlignment y) + paddingNeeded = (size' `roundUpToNearestMultipleOf` nextFieldsAlignment) - size' + size'' = size' + paddingNeeded + paddedField = StructField + { structFieldIdent = unpaddedStructFieldIdent x + -- NOTE: it is safe to narrow `paddingNeeded` to a word8 here because it's always smaller than `nextFieldsAlignment` + , structFieldPadding = fromIntegral @InlineSize @Word8 paddingNeeded + , structFieldOffset = coerce size + , structFieldType = unpaddedStructFieldType x + } + in go size'' (paddedField : paddedFields) (y : tail) + go size paddedFields [x] = + let size' = size + structFieldTypeSize (unpaddedStructFieldType x) + structAlignment' = fromIntegral @Alignment @InlineSize structAlignment + paddingNeeded = (size' `roundUpToNearestMultipleOf` structAlignment') - size' + size'' = size' + paddingNeeded + paddedField = StructField + { structFieldIdent = unpaddedStructFieldIdent x + -- NOTE: it is safe to narrow `paddingNeeded` to a word8 here because it's always smaller than `nextFieldsAlignment` + , structFieldPadding = fromIntegral @InlineSize @Word8 paddingNeeded + , structFieldOffset = coerce size + , structFieldType = unpaddedStructFieldType x + } + in (size'', paddedField : paddedFields) + + validateStructField :: ST.StructField -> m UnpaddedStructField + validateStructField sf = + modifyContext (\context -> context <> "." <> getIdent sf) $ do + checkUnsupportedAttributes sf + checkUndeclaredAttributes sf + structFieldType <- validateStructFieldType (ST.structFieldType sf) + pure $ UnpaddedStructField + { unpaddedStructFieldIdent = getIdent sf + , unpaddedStructFieldType = structFieldType + } + + validateStructFieldType :: ST.Type -> m StructFieldType + validateStructFieldType structFieldType = + case structFieldType of + ST.TInt8 -> pure SInt8 + ST.TInt16 -> pure SInt16 + ST.TInt32 -> pure SInt32 + ST.TInt64 -> pure SInt64 + ST.TWord8 -> pure SWord8 + ST.TWord16 -> pure SWord16 + ST.TWord32 -> pure SWord32 + ST.TWord64 -> pure SWord64 + ST.TFloat -> pure SFloat + ST.TDouble -> pure SDouble + ST.TBool -> pure SBool + ST.TString -> throwErrorMsg invalidStructFieldType + ST.TVector _ -> throwErrorMsg invalidStructFieldType + ST.TRef typeRef -> + findDecl currentNamespace symbolTables typeRef >>= \case + MatchE (enumNamespace, enum) -> + pure (SEnum (TypeRef enumNamespace (getIdent enum)) (enumType enum)) + MatchS (nestedNamespace, nestedStruct) -> + -- if this is a reference to a struct, we need to validate it first + SStruct <$> validateStruct symbolTables (nestedNamespace, nestedStruct) + _ -> throwErrorMsg invalidStructFieldType + + checkUnsupportedAttributes :: ST.StructField -> m () + checkUnsupportedAttributes structField = do + when (hasAttribute deprecatedAttr (ST.structFieldMetadata structField)) $ + throwErrorMsg "can't deprecate fields in a struct" + when (hasAttribute requiredAttr (ST.structFieldMetadata structField)) $ + throwErrorMsg "struct fields are already required, the 'required' attribute is redundant" + when (hasAttribute idAttr (ST.structFieldMetadata structField)) $ + throwErrorMsg "struct fields cannot be reordered using the 'id' attribute" + + getForceAlignAttr :: m (Maybe Integer) + getForceAlignAttr = findIntAttr forceAlignAttr (ST.structMetadata struct) + + validateForceAlign :: Alignment -> Integer -> m Alignment + validateForceAlign naturalAlignment forceAlign = + if isPowerOfTwo forceAlign + && inRange (fromIntegral @Alignment @Integer naturalAlignment, 16) forceAlign + then pure (fromIntegral @Integer @Alignment forceAlign) + else throwErrorMsg $ + "force_align must be a power of two integer ranging from the struct's natural alignment (in this case, " + <> T.pack (show naturalAlignment) + <> ") to 16" + + checkDuplicateFields :: m () + checkDuplicateFields = + checkDuplicateIdentifiers + (ST.structFields struct) + +---------------------------------- +------------ Helpers ------------- +---------------------------------- +structFieldAlignment :: UnpaddedStructField -> Alignment +structFieldAlignment usf = + case unpaddedStructFieldType usf of + SInt8 -> int8Size + SInt16 -> int16Size + SInt32 -> int32Size + SInt64 -> int64Size + SWord8 -> word8Size + SWord16 -> word16Size + SWord32 -> word32Size + SWord64 -> word64Size + SFloat -> floatSize + SDouble -> doubleSize + SBool -> boolSize + SEnum _ enumType -> enumAlignment enumType + SStruct (_, nestedStruct) -> structAlignment nestedStruct + +enumAlignment :: EnumType -> Alignment +enumAlignment = Alignment . enumSize + +-- | The size of an enum is either 1, 2, 4 or 8 bytes, so its size fits in a Word8 +enumSize :: EnumType -> Word8 +enumSize e = + case e of + EInt8 -> int8Size + EInt16 -> int16Size + EInt32 -> int32Size + EInt64 -> int64Size + EWord8 -> word8Size + EWord16 -> word16Size + EWord32 -> word32Size + EWord64 -> word64Size + +structFieldTypeSize :: StructFieldType -> InlineSize +structFieldTypeSize sft = + case sft of + SInt8 -> int8Size + SInt16 -> int16Size + SInt32 -> int32Size + SInt64 -> int64Size + SWord8 -> word8Size + SWord16 -> word16Size + SWord32 -> word32Size + SWord64 -> word64Size + SFloat -> floatSize + SDouble -> doubleSize + SBool -> boolSize + SEnum _ enumType -> fromIntegral @Word8 @InlineSize (enumSize enumType) + SStruct (_, nestedStruct) -> structSize nestedStruct + +checkDuplicateIdentifiers :: (ValidationCtx m, Foldable f, Functor f, HasIdent a) => f a -> m () +checkDuplicateIdentifiers xs = + case findDups (getIdent <$> xs) of + [] -> pure () + dups -> + throwErrorMsg $ + display dups <> " declared more than once" + where + findDups :: (Foldable f, Functor f, Ord a) => f a -> [a] + findDups xs = Map.keys $ Map.filter (>1) $ occurrences xs + + occurrences :: (Foldable f, Functor f, Ord a) => f a -> Map a (Sum Int) + occurrences xs = + Map.unionsWith (<>) $ Foldable.toList $ fmap (\x -> Map.singleton x (Sum 1)) xs + +checkUndeclaredAttributes :: (ValidationCtx m, HasMetadata a) => a -> m () +checkUndeclaredAttributes a = do + allAttributes <- asks validationStateAllAttributes + forM_ (Map.keys . ST.unMetadata . getMetadata $ a) $ \attr -> + when (coerce attr `Set.notMember` allAttributes) $ + throwErrorMsg $ "user defined attributes must be declared before use: " <> attr + +hasAttribute :: Text -> ST.Metadata -> Bool +hasAttribute name (ST.Metadata attrs) = Map.member name attrs + +findIntAttr :: ValidationCtx m => Text -> ST.Metadata -> m (Maybe Integer) +findIntAttr name (ST.Metadata attrs) = + case Map.lookup name attrs of + Nothing -> pure Nothing + Just Nothing -> err + Just (Just (ST.AttrI i)) -> pure (Just i) + Just (Just (ST.AttrS t)) -> + case readMaybe @Integer (T.unpack t) of + Just i -> pure (Just i) + Nothing -> err + where + err = + throwErrorMsg $ + "expected attribute '" + <> name + <> "' to have an integer value, e.g. '" + <> name + <> ": 123'" + +findStringAttr :: ValidationCtx m => Text -> ST.Metadata -> m (Maybe Text) +findStringAttr name (ST.Metadata attrs) = + case Map.lookup name attrs of + Nothing -> pure Nothing + Just (Just (ST.AttrS s)) -> pure (Just s) + Just _ -> + throwErrorMsg $ + "expected attribute '" + <> name + <> "' to have a string value, e.g. '" + <> name + <> ": \"abc\"'" + +throwErrorMsg :: ValidationCtx m => Text -> m a +throwErrorMsg msg = do + context <- asks validationStateCurrentContext + if context == "" + then throwError msg + else throwError $ "[" <> display context <> "]: " <> msg + + + diff --git a/src/FlatBuffers/Internal/Compiler/SyntaxTree.hs b/src/FlatBuffers/Internal/Compiler/SyntaxTree.hs new file mode 100644 --- /dev/null +++ b/src/FlatBuffers/Internal/Compiler/SyntaxTree.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module FlatBuffers.Internal.Compiler.SyntaxTree where + +import Data.List.NonEmpty ( NonEmpty ) +import Data.Map.Strict ( Map ) +import Data.Scientific ( Scientific ) +import Data.String ( IsString(..) ) +import Data.Text ( Text ) +import qualified Data.Text as T + +import FlatBuffers.Internal.Compiler.Display ( Display(..) ) + +data FileTree a = FileTree + { fileTreeFilePath :: !FilePath + , fileTreeRoot :: !a + , fileTreeForest :: !(Map FilePath a) + } + deriving (Show, Eq, Foldable, Functor, Traversable) + +data Schema = Schema + { includes :: ![Include] + , decls :: ![Decl] + } deriving (Show, Eq) + +data Decl + = DeclN !NamespaceDecl + | DeclT !TableDecl + | DeclS !StructDecl + | DeclE !EnumDecl + | DeclU !UnionDecl + | DeclR !RootDecl + | DeclFI !FileIdentifierDecl + | DeclA !AttributeDecl + deriving (Show, Eq) + +newtype Ident = Ident + { unIdent :: Text + } deriving newtype (Show, Eq, IsString, Ord, Semigroup, Display) + +newtype Include = Include + { unInclude :: StringLiteral + } deriving newtype (Show, Eq, IsString) + +newtype StringLiteral = StringLiteral + { unStringLiteral :: Text + } deriving newtype (Show, Eq, IsString) + +newtype IntLiteral = IntLiteral + { unIntLiteral :: Integer + } deriving newtype (Show, Eq, Num, Enum, Ord, Real, Integral) + +data AttributeVal + = AttrI !Integer + | AttrS !Text + deriving (Show, Eq) + +data DefaultVal + = DefaultNum !Scientific + | DefaultBool !Bool + | DefaultRef !Ident + deriving (Show, Eq) + +newtype Metadata = Metadata + { unMetadata :: Map Text (Maybe AttributeVal) + } deriving newtype (Show, Eq) + +newtype NamespaceDecl = NamespaceDecl + { unNamespaceDecl :: Namespace + } deriving newtype (Show, Eq, IsString) + +data TableDecl = TableDecl + { tableIdent :: !Ident + , tableMetadata :: !Metadata + , tableFields :: ![TableField] + } deriving (Show, Eq) + +data TableField = TableField + { tableFieldIdent :: !Ident + , tableFieldType :: !Type + , tableFieldDefault :: !(Maybe DefaultVal) + , tableFieldMetadata :: !Metadata + } deriving (Show, Eq) + +data StructDecl = StructDecl + { structIdent :: !Ident + , structMetadata :: !Metadata + , structFields :: !(NonEmpty StructField) + } deriving (Show, Eq) + +data StructField = StructField + { structFieldIdent :: !Ident + , structFieldType :: !Type + , structFieldMetadata :: !Metadata + } deriving (Show, Eq) + +data EnumDecl = EnumDecl + { enumIdent :: !Ident + , enumType :: !Type + , enumMetadata :: !Metadata + , enumVals :: !(NonEmpty EnumVal) + } deriving (Show, Eq) + +data EnumVal = EnumVal + { enumValIdent :: !Ident + , enumValLiteral :: !(Maybe IntLiteral) + } deriving (Show, Eq) + +data UnionDecl = UnionDecl + { unionIdent :: !Ident + , unionMetadata :: !Metadata + , unionVals :: !(NonEmpty UnionVal) + } deriving (Show, Eq) + +data UnionVal = UnionVal + { unionValIdent :: !(Maybe Ident) + , unionValTypeRef :: !TypeRef + } deriving (Show, Eq) + +data Type + -- numeric + = TInt8 + | TInt16 + | TInt32 + | TInt64 + | TWord8 + | TWord16 + | TWord32 + | TWord64 + -- floating point + | TFloat + | TDouble + -- others + | TBool + | TString + | TRef !TypeRef + | TVector !Type + deriving (Show, Eq) + +data TypeRef = TypeRef + { typeRefNamespace :: !Namespace + , typeRefIdent :: !Ident + } deriving (Show, Eq) + +instance Display TypeRef where + display (TypeRef ns id) = display (qualify ns id) + +newtype RootDecl = RootDecl TypeRef + deriving newtype (Show, Eq) + +newtype FileIdentifierDecl = FileIdentifierDecl Text + deriving newtype (Show, Eq, IsString) + +newtype AttributeDecl = AttributeDecl Text + deriving newtype (Show, Eq, IsString, Ord) + +newtype Namespace = Namespace {unNamespace :: [Text] } + deriving newtype (Eq, Ord, Semigroup) + +instance Display Namespace where + display (Namespace ns) = T.intercalate "." ns + +instance Show Namespace where + show = show . T.unpack . display + +instance IsString Namespace where + fromString "" = Namespace [] + fromString s = Namespace $ filter (/= "") $ T.splitOn "." $ T.pack s + +qualify :: HasIdent a => Namespace -> a -> Ident +qualify "" a = getIdent a +qualify ns a = Ident (display ns <> "." <> display (getIdent a)) + +class HasIdent a where + getIdent :: a -> Ident + +instance HasIdent Ident where getIdent = id +instance HasIdent EnumDecl where getIdent = enumIdent +instance HasIdent EnumVal where getIdent = enumValIdent +instance HasIdent StructDecl where getIdent = structIdent +instance HasIdent StructField where getIdent = structFieldIdent +instance HasIdent TableDecl where getIdent = tableIdent +instance HasIdent TableField where getIdent = tableFieldIdent +instance HasIdent UnionDecl where getIdent = unionIdent + + +class HasMetadata a where + getMetadata :: a -> Metadata + +instance HasMetadata EnumDecl where getMetadata = enumMetadata +instance HasMetadata StructDecl where getMetadata = structMetadata +instance HasMetadata StructField where getMetadata = structFieldMetadata +instance HasMetadata TableDecl where getMetadata = tableMetadata +instance HasMetadata TableField where getMetadata = tableFieldMetadata +instance HasMetadata UnionDecl where getMetadata = unionMetadata diff --git a/src/FlatBuffers/Internal/Compiler/TH.hs b/src/FlatBuffers/Internal/Compiler/TH.hs new file mode 100644 --- /dev/null +++ b/src/FlatBuffers/Internal/Compiler/TH.hs @@ -0,0 +1,848 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TemplateHaskell #-} + +module FlatBuffers.Internal.Compiler.TH where + +import Control.Monad ( join ) +import Control.Monad.Except ( runExceptT ) + +import Data.Foldable ( traverse_ ) +import Data.Functor ( (<&>) ) +import Data.Int +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Text ( Text ) +import qualified Data.Text as T +import Data.Word + +import FlatBuffers.Internal.Build +import qualified FlatBuffers.Internal.Compiler.NamingConventions as NC +import qualified FlatBuffers.Internal.Compiler.ParserIO as ParserIO +import FlatBuffers.Internal.Compiler.SemanticAnalysis ( SymbolTable(..) ) +import qualified FlatBuffers.Internal.Compiler.SemanticAnalysis as SemanticAnalysis +import qualified FlatBuffers.Internal.Compiler.SyntaxTree as SyntaxTree +import FlatBuffers.Internal.Compiler.ValidSyntaxTree +import FlatBuffers.Internal.FileIdentifier ( HasFileIdentifier(..), unsafeFileIdentifier ) +import FlatBuffers.Internal.Read +import FlatBuffers.Internal.Types +import FlatBuffers.Internal.Util ( Positive(getPositive), nonEmptyUnzip3 ) +import FlatBuffers.Internal.Write + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax ( lift ) +import qualified Language.Haskell.TH.Syntax as TH + + +-- | Helper method to create function types. +-- @ConT ''Int ~> ConT ''String === Int -> String@ +(~>) :: Type -> Type -> Type +a ~> b = ArrowT `AppT` a `AppT` b +infixr 1 ~> + +-- | Options to control how\/which flatbuffers constructors\/accessor should be generated. +-- +-- Options can be set using record syntax on `defaultOptions` with the fields below. +-- +-- > defaultOptions { compileAllSchemas = True } +data Options = Options + { -- | Directories to search for @include@s (same as flatc @-I@ option). + includeDirectories :: [FilePath] + -- | Generate code not just for the root schema, + -- but for all schemas it includes as well + -- (same as flatc @--gen-all@ option). + , compileAllSchemas :: Bool + } + deriving (Show, Eq) + +-- | Default flatbuffers options: +-- +-- > Options +-- > { includeDirectories = [] +-- > , compileAllSchemas = False +-- > } +defaultOptions :: Options +defaultOptions = Options + { includeDirectories = [] + , compileAllSchemas = False + } + +-- | Generates constructors and accessors for all data types declared in the given flatbuffers +-- schema whose namespace matches the current module. +-- +-- > namespace Data.Game; +-- > +-- > table Monster {} +-- +-- > {-# LANGUAGE TemplateHaskell #-} +-- > +-- > module Data.Game where +-- > +-- > import FlatBuffers +-- > +-- > $(mkFlatBuffers "schemas/game.fbs" defaultOptions) +mkFlatBuffers :: FilePath -> Options -> Q [Dec] +mkFlatBuffers rootFilePath opts = do + currentModule <- T.pack . loc_module <$> location + + parseResult <- runIO $ runExceptT $ ParserIO.parseSchemas rootFilePath (includeDirectories opts) + + schemaFileTree <- either (fail . T.unpack) pure parseResult + + registerFiles schemaFileTree + + symbolTables <- either (fail . T.unpack) pure $ SemanticAnalysis.validateSchemas schemaFileTree + + let symbolTable = + if compileAllSchemas opts + then SyntaxTree.fileTreeRoot symbolTables + <> mconcat (Map.elems $ SyntaxTree.fileTreeForest symbolTables) + else SyntaxTree.fileTreeRoot symbolTables + + let symbolTable' = filterByCurrentModule currentModule symbolTable + + compileSymbolTable symbolTable' + + where + registerFiles (SyntaxTree.FileTree rootFilePath _ includedFiles) = do + TH.addDependentFile rootFilePath + traverse_ TH.addDependentFile $ Map.keys includedFiles + + filterByCurrentModule currentModule (SymbolTable enums structs tables unions) = + SymbolTable + { allEnums = filter (isCurrentModule currentModule) enums + , allStructs = filter (isCurrentModule currentModule) structs + , allTables = filter (isCurrentModule currentModule) tables + , allUnions = filter (isCurrentModule currentModule) unions + } + + isCurrentModule currentModule (ns, _) = NC.namespace ns == currentModule + +compileSymbolTable :: SemanticAnalysis.ValidDecls -> Q [Dec] +compileSymbolTable symbolTable = do + enumDecs <- join <$> traverse mkEnum (allEnums symbolTable) + structDecs <- join <$> traverse mkStruct (allStructs symbolTable) + tableDecs <- join <$> traverse mkTable (allTables symbolTable) + unionDecs <- join <$> traverse mkUnion (allUnions symbolTable) + pure $ enumDecs <> structDecs <> tableDecs <> unionDecs + +mkEnum :: (Namespace, EnumDecl) -> Q [Dec] +mkEnum (_, enum) = do + enumName <- newName' $ NC.dataTypeName enum + + let enumValNames = enumVals enum <&> \enumVal -> + mkName $ T.unpack $ NC.enumUnionMember enum enumVal + + let enumDec = mkEnumDataDec enumName enumValNames + toEnumDecs <- mkToEnum enumName enum (enumVals enum `NE.zip` enumValNames) + fromEnumDecs <- mkFromEnum enumName enum (enumVals enum `NE.zip` enumValNames) + + pure $ enumDec : toEnumDecs <> fromEnumDecs + +mkEnumDataDec :: Name -> NonEmpty Name -> Dec +mkEnumDataDec enumName enumValNames = + DataD [] enumName [] Nothing + (NE.toList $ fmap (\n -> NormalC n []) enumValNames) + [ DerivClause Nothing + [ ConT ''Eq + , ConT ''Show + , ConT ''Read + , ConT ''Ord + , ConT ''Bounded + ] + ] + +mkToEnum :: Name -> EnumDecl -> NonEmpty (EnumVal, Name) -> Q [Dec] +mkToEnum enumName enum enumValsAndNames = do + let funName = mkName' $ NC.toEnumFun enum + argName <- newName "n" + pure + [ SigD funName (enumTypeToType (enumType enum) ~> ConT ''Maybe `AppT` ConT enumName) + , FunD funName + [ Clause + [VarP argName] + (NormalB (CaseE (VarE argName) matches)) + [] + ] + , PragmaD $ InlineP funName Inline FunLike AllPhases + ] + where + matches = + (mkMatch <$> NE.toList enumValsAndNames) <> [matchWildcard] + + mkMatch (enumVal, enumName) = + Match + (intLitP (enumValInt enumVal)) + (NormalB (ConE 'Just `AppE` ConE enumName)) + [] + + matchWildcard = + Match + WildP + (NormalB (ConE 'Nothing)) + [] + +mkFromEnum :: Name -> EnumDecl -> NonEmpty (EnumVal, Name) -> Q [Dec] +mkFromEnum enumName enum enumValsAndNames = do + let funName = mkName' $ NC.fromEnumFun enum + argName <- newName "n" + pure + [ SigD funName (ConT enumName ~> enumTypeToType (enumType enum)) + , FunD funName + [ Clause + [VarP argName] + (NormalB (CaseE (VarE argName) (mkMatch <$> NE.toList enumValsAndNames))) + [] + ] + , PragmaD $ InlineP funName Inline FunLike AllPhases + ] + where + mkMatch (enumVal, enumName) = + Match + (ConP enumName []) + (NormalB (intLitE (enumValInt enumVal))) + [] + + +mkStruct :: (Namespace, StructDecl) -> Q [Dec] +mkStruct (_, struct) = do + let structName = mkName' $ NC.dataTypeName struct + isStructInstance <- mkIsStructInstance structName struct + + let dataDec = DataD [] structName [] Nothing [] [] + (consSig, cons) <- mkStructConstructor structName struct + + let getters = foldMap (mkStructFieldGetter structName struct) (structFields struct) + + pure $ + dataDec : + isStructInstance <> + [ consSig, cons ] <> + getters + +mkIsStructInstance :: Name -> StructDecl -> Q [Dec] +mkIsStructInstance structName struct = + [d| + instance IsStruct $(conT structName) where + structAlignmentOf = $(lift . unAlignment . structAlignment $ struct) + structSizeOf = $(lift . unInlineSize . structSize $ struct) + |] + +mkStructConstructor :: Name -> StructDecl -> Q (Dec, Dec) +mkStructConstructor structName struct = do + argsInfo <- traverse mkStructConstructorArg (structFields struct) + let (argTypes, pats, exps) = nonEmptyUnzip3 argsInfo + + let retType = AppT (ConT ''WriteStruct) (ConT structName) + let sigType = foldr (~>) retType argTypes + + let consName = mkName' $ NC.dataTypeConstructor struct + let consSig = SigD consName sigType + + let exp = foldr1 (\e acc -> InfixE (Just e) (VarE '(<>)) (Just acc)) (join exps) + let body = NormalB $ ConE 'WriteStruct `AppE` exp + + let cons = FunD consName [ Clause (NE.toList pats) body [] ] + + pure (consSig, cons) + + +mkStructConstructorArg :: StructField -> Q (Type, Pat, NonEmpty Exp) +mkStructConstructorArg sf = do + argName <- newName' $ NC.arg sf + let argPat = VarP argName + let argRef = VarE argName + let argType = structFieldTypeToWriteType (structFieldType sf) + + let mkWriteExp sft = + case sft of + SInt8 -> VarE 'buildInt8 + SInt16 -> VarE 'buildInt16 + SInt32 -> VarE 'buildInt32 + SInt64 -> VarE 'buildInt64 + SWord8 -> VarE 'buildWord8 + SWord16 -> VarE 'buildWord16 + SWord32 -> VarE 'buildWord32 + SWord64 -> VarE 'buildWord64 + SFloat -> VarE 'buildFloat + SDouble -> VarE 'buildDouble + SBool -> VarE 'buildBool + SEnum _ enumType -> mkWriteExp (enumTypeToStructFieldType enumType) + SStruct _ -> VarE 'buildStruct + + let exp = mkWriteExp (structFieldType sf) `AppE` argRef + + let exps = + if structFieldPadding sf == 0 + then [ exp ] + else + [ exp + , VarE 'buildPadding `AppE` intLitE (structFieldPadding sf) + ] + + pure (argType, argPat, exps) + +mkStructFieldGetter :: Name -> StructDecl -> StructField -> [Dec] +mkStructFieldGetter structName struct sf = + [sig, fun] + where + funName = mkName (T.unpack (NC.getter struct sf)) + fieldOffsetExp = intLitE (structFieldOffset sf) + + retType = structFieldTypeToReadType (structFieldType sf) + sig = + SigD funName $ + case structFieldType sf of + SStruct _ -> + ConT ''Struct `AppT` ConT structName ~> retType + _ -> + ConT ''Struct `AppT` ConT structName ~> ConT ''Either `AppT` ConT ''ReadError `AppT` retType + + fun = FunD funName [ Clause [] (NormalB body) [] ] + + body = app + [ VarE 'readStructField + , mkReadExp (structFieldType sf) + , fieldOffsetExp + ] + + mkReadExp sft = + case sft of + SInt8 -> VarE 'readInt8 + SInt16 -> VarE 'readInt16 + SInt32 -> VarE 'readInt32 + SInt64 -> VarE 'readInt64 + SWord8 -> VarE 'readWord8 + SWord16 -> VarE 'readWord16 + SWord32 -> VarE 'readWord32 + SWord64 -> VarE 'readWord64 + SFloat -> VarE 'readFloat + SDouble -> VarE 'readDouble + SBool -> VarE 'readBool + SEnum _ enumType -> mkReadExp $ enumTypeToStructFieldType enumType + SStruct _ -> VarE 'readStruct + +mkTable :: (Namespace, TableDecl) -> Q [Dec] +mkTable (_, table) = do + let tableName = mkName' $ NC.dataTypeName table + (consSig, cons) <- mkTableConstructor tableName table + + let fileIdentifierDec = mkTableFileIdentifier tableName (tableIsRoot table) + let getters = foldMap (mkTableFieldGetter tableName table) (tableFields table) + + pure $ + [ DataD [] tableName [] Nothing [] [] + , consSig + , cons + ] <> fileIdentifierDec + <> getters + +mkTableFileIdentifier :: Name -> IsRoot -> [Dec] +mkTableFileIdentifier tableName isRoot = + case isRoot of + NotRoot -> [] + IsRoot Nothing -> [] + IsRoot (Just fileIdentifier) -> + [ InstanceD + Nothing + [] + (ConT ''HasFileIdentifier `AppT` ConT tableName) + [ FunD 'getFileIdentifier + [ Clause + [] + (NormalB $ VarE 'unsafeFileIdentifier `AppE` textLitE fileIdentifier) + [] + ] + ] + ] + +mkTableConstructor :: Name -> TableDecl -> Q (Dec, Dec) +mkTableConstructor tableName table = do + (argTypes, pats, exps) <- mconcat <$> traverse mkTableContructorArg (tableFields table) + + let retType = AppT (ConT ''WriteTable) (ConT tableName) + let sigType = foldr (~>) retType argTypes + + let consName = mkName' $ NC.dataTypeConstructor table + let consSig = SigD consName sigType + + let body = NormalB $ AppE (VarE 'writeTable) (ListE exps) + let cons = FunD consName [ Clause pats body [] ] + + pure (consSig, cons) + +mkTableContructorArg :: TableField -> Q ([Type], [Pat], [Exp]) +mkTableContructorArg tf = + if tableFieldDeprecated tf + then + case tableFieldType tf of + TUnion _ _ -> pure ([], [], [VarE 'deprecated, VarE 'deprecated]) + TVector _ (VUnion _) -> pure ([], [], [VarE 'deprecated, VarE 'deprecated]) + _ -> pure ([], [], [VarE 'deprecated]) + else do + argName <- newName' $ NC.arg tf + let argPat = VarP argName + let argRef = VarE argName + let argType = tableFieldTypeToWriteType (tableFieldType tf) + let exps = mkExps argRef (tableFieldType tf) + + pure ([argType], [argPat], exps) + + where + expForScalar :: Exp -> Exp -> Exp -> Exp + expForScalar defaultValExp writeExp varExp = + VarE 'optionalDef `AppE` defaultValExp `AppE` writeExp `AppE` varExp + + expForNonScalar :: Required -> Exp -> Exp -> Exp + expForNonScalar Req exp argRef = exp `AppE` argRef + expForNonScalar Opt exp argRef = VarE 'optional `AppE` exp `AppE` argRef + + mkExps :: Exp -> TableFieldType -> [Exp] + mkExps argRef tfType = + case tfType of + TInt8 (DefaultVal n) -> pure $ expForScalar (intLitE n) (VarE 'writeInt8TableField ) argRef + TInt16 (DefaultVal n) -> pure $ expForScalar (intLitE n) (VarE 'writeInt16TableField ) argRef + TInt32 (DefaultVal n) -> pure $ expForScalar (intLitE n) (VarE 'writeInt32TableField ) argRef + TInt64 (DefaultVal n) -> pure $ expForScalar (intLitE n) (VarE 'writeInt64TableField ) argRef + TWord8 (DefaultVal n) -> pure $ expForScalar (intLitE n) (VarE 'writeWord8TableField ) argRef + TWord16 (DefaultVal n) -> pure $ expForScalar (intLitE n) (VarE 'writeWord16TableField ) argRef + TWord32 (DefaultVal n) -> pure $ expForScalar (intLitE n) (VarE 'writeWord32TableField ) argRef + TWord64 (DefaultVal n) -> pure $ expForScalar (intLitE n) (VarE 'writeWord64TableField ) argRef + TFloat (DefaultVal n) -> pure $ expForScalar (realLitE n) (VarE 'writeFloatTableField ) argRef + TDouble (DefaultVal n) -> pure $ expForScalar (realLitE n) (VarE 'writeDoubleTableField ) argRef + TBool (DefaultVal b) -> pure $ expForScalar (if b then ConE 'True else ConE 'False) (VarE 'writeBoolTableField) argRef + TString req     -> pure $ expForNonScalar req (VarE 'writeTextTableField) argRef + TEnum _ enumType dflt -> mkExps argRef (enumTypeToTableFieldType enumType dflt) + TStruct _ req -> pure $ expForNonScalar req (VarE 'writeStructTableField) argRef + TTable _ req -> pure $ expForNonScalar req (VarE 'writeTableTableField) argRef + TUnion _ _ -> + [ VarE 'writeUnionTypeTableField `AppE` argRef + , VarE 'writeUnionValueTableField `AppE` argRef + ] + TVector req vecElemType -> mkExpForVector argRef req vecElemType + + mkExpForVector :: Exp -> Required -> VectorElementType -> [Exp] + mkExpForVector argRef req vecElemType = + case vecElemType of + VInt8 -> [ expForNonScalar req (VarE 'writeVectorInt8TableField) argRef ] + VInt16 -> [ expForNonScalar req (VarE 'writeVectorInt16TableField) argRef ] + VInt32 -> [ expForNonScalar req (VarE 'writeVectorInt32TableField) argRef ] + VInt64 -> [ expForNonScalar req (VarE 'writeVectorInt64TableField) argRef ] + VWord8 -> [ expForNonScalar req (VarE 'writeVectorWord8TableField) argRef ] + VWord16 -> [ expForNonScalar req (VarE 'writeVectorWord16TableField) argRef ] + VWord32 -> [ expForNonScalar req (VarE 'writeVectorWord32TableField) argRef ] + VWord64 -> [ expForNonScalar req (VarE 'writeVectorWord64TableField) argRef ] + VFloat -> [ expForNonScalar req (VarE 'writeVectorFloatTableField) argRef ] + VDouble -> [ expForNonScalar req (VarE 'writeVectorDoubleTableField) argRef ] + VBool -> [ expForNonScalar req (VarE 'writeVectorBoolTableField) argRef ] + VString -> [ expForNonScalar req (VarE 'writeVectorTextTableField) argRef ] + VEnum _ enumType -> mkExpForVector argRef req (enumTypeToVectorElementType enumType) + VStruct _ -> [ expForNonScalar req (VarE 'writeVectorStructTableField) argRef ] + VTable _ -> [ expForNonScalar req (VarE 'writeVectorTableTableField) argRef ] + VUnion _ -> + [ expForNonScalar req (VarE 'writeUnionTypesVectorTableField) argRef + , expForNonScalar req (VarE 'writeUnionValuesVectorTableField) argRef + ] + +mkTableFieldGetter :: Name -> TableDecl -> TableField -> [Dec] +mkTableFieldGetter tableName table tf = + if tableFieldDeprecated tf + then [] + else [sig, mkFun (tableFieldType tf)] + where + funName = mkName (T.unpack (NC.getter table tf)) + fieldIndex = intLitE (tableFieldId tf) + + sig = + SigD funName $ + ConT ''Table `AppT` ConT tableName ~> ConT ''Either `AppT` ConT ''ReadError `AppT` tableFieldTypeToReadType (tableFieldType tf) + + mkFun :: TableFieldType -> Dec + mkFun tft = + case tft of + TWord8 (DefaultVal n) -> mkFunWithBody (bodyForScalar (intLitE n) (VarE 'readWord8)) + TWord16 (DefaultVal n) -> mkFunWithBody (bodyForScalar (intLitE n) (VarE 'readWord16)) + TWord32 (DefaultVal n) -> mkFunWithBody (bodyForScalar (intLitE n) (VarE 'readWord32)) + TWord64 (DefaultVal n) -> mkFunWithBody (bodyForScalar (intLitE n) (VarE 'readWord64)) + TInt8 (DefaultVal n) -> mkFunWithBody (bodyForScalar (intLitE n) (VarE 'readInt8)) + TInt16 (DefaultVal n) -> mkFunWithBody (bodyForScalar (intLitE n) (VarE 'readInt16)) + TInt32 (DefaultVal n) -> mkFunWithBody (bodyForScalar (intLitE n) (VarE 'readInt32)) + TInt64 (DefaultVal n) -> mkFunWithBody (bodyForScalar (intLitE n) (VarE 'readInt64)) + TFloat (DefaultVal n) -> mkFunWithBody (bodyForScalar (realLitE n) (VarE 'readFloat)) + TDouble (DefaultVal n) -> mkFunWithBody (bodyForScalar (realLitE n) (VarE 'readDouble)) + TBool (DefaultVal b) -> mkFunWithBody (bodyForScalar (if b then ConE 'True else ConE 'False) (VarE 'readBool)) + TString req -> mkFunWithBody (bodyForNonScalar req (VarE 'readText)) + TEnum _ enumType dflt -> mkFun $ enumTypeToTableFieldType enumType dflt + TStruct _ req -> mkFunWithBody (bodyForNonScalar req (compose [ConE 'Right, VarE 'readStruct])) + TTable _ req -> mkFunWithBody (bodyForNonScalar req (VarE 'readTable)) + TUnion (TypeRef ns ident) _req -> + mkFunWithBody $ app + [ VarE 'readTableFieldUnion + , VarE . mkName . T.unpack . NC.withModulePrefix ns $ NC.readUnionFun ident + , fieldIndex + ] + TVector req vecElemType -> mkFunForVector req vecElemType + + mkFunForVector :: Required -> VectorElementType -> Dec + mkFunForVector req vecElemType = + case vecElemType of + VInt8 -> mkFunWithBody $ bodyForNonScalar req $ VarE 'readPrimVector `AppE` ConE 'VectorInt8 + VInt16 -> mkFunWithBody $ bodyForNonScalar req $ VarE 'readPrimVector `AppE` ConE 'VectorInt16 + VInt32 -> mkFunWithBody $ bodyForNonScalar req $ VarE 'readPrimVector `AppE` ConE 'VectorInt32 + VInt64 -> mkFunWithBody $ bodyForNonScalar req $ VarE 'readPrimVector `AppE` ConE 'VectorInt64 + VWord8 -> mkFunWithBody $ bodyForNonScalar req $ VarE 'readPrimVector `AppE` ConE 'VectorWord8 + VWord16 -> mkFunWithBody $ bodyForNonScalar req $ VarE 'readPrimVector `AppE` ConE 'VectorWord16 + VWord32 -> mkFunWithBody $ bodyForNonScalar req $ VarE 'readPrimVector `AppE` ConE 'VectorWord32 + VWord64 -> mkFunWithBody $ bodyForNonScalar req $ VarE 'readPrimVector `AppE` ConE 'VectorWord64 + VFloat -> mkFunWithBody $ bodyForNonScalar req $ VarE 'readPrimVector `AppE` ConE 'VectorFloat + VDouble -> mkFunWithBody $ bodyForNonScalar req $ VarE 'readPrimVector `AppE` ConE 'VectorDouble + VBool -> mkFunWithBody $ bodyForNonScalar req $ VarE 'readPrimVector `AppE` ConE 'VectorBool + VString -> mkFunWithBody $ bodyForNonScalar req $ VarE 'readPrimVector `AppE` ConE 'VectorText + VEnum _ enumType -> mkFunForVector req (enumTypeToVectorElementType enumType) + VStruct _ -> mkFunWithBody $ bodyForNonScalar req $ VarE 'readStructVector + VTable _ -> mkFunWithBody $ bodyForNonScalar req $ VarE 'readTableVector + VUnion (TypeRef ns ident) -> + mkFunWithBody $ + case req of + Opt -> app + [ VarE 'readTableFieldUnionVectorOpt + , VarE . mkName . T.unpack . NC.withModulePrefix ns $ NC.readUnionFun ident + , fieldIndex + ] + Req -> app + [ VarE 'readTableFieldUnionVectorReq + , VarE . mkName . T.unpack . NC.withModulePrefix ns $ NC.readUnionFun ident + , fieldIndex + , stringLitE . unIdent . getIdent $ tf + ] + + + mkFunWithBody :: Exp -> Dec + mkFunWithBody body = FunD funName [ Clause [] (NormalB body) [] ] + + bodyForNonScalar req readExp = + case req of + Req -> + app + [ VarE 'readTableFieldReq + , readExp + , fieldIndex + , stringLitE . unIdent . getIdent $ tf + ] + Opt -> + app + [ VarE 'readTableFieldOpt + , readExp + , fieldIndex + ] + + bodyForScalar defaultValExp readExp = + app + [ VarE 'readTableFieldWithDef + , readExp + , fieldIndex + , defaultValExp + ] + +mkUnion :: (Namespace, UnionDecl) -> Q [Dec] +mkUnion (_, union) = do + unionName <- newName' $ NC.dataTypeName union + let unionValNames = unionVals union <&> \unionVal -> + mkName $ T.unpack $ NC.enumUnionMember union unionVal + + unionConstructors <- mkUnionConstructors unionName union + + readFun <- mkReadUnionFun unionName unionValNames union + + pure $ + mkUnionDataDec unionName (unionVals union `NE.zip` unionValNames) + : unionConstructors + <> readFun + + +mkUnionDataDec :: Name -> NonEmpty (UnionVal, Name) -> Dec +mkUnionDataDec unionName unionValsAndNames = + DataD [] unionName [] Nothing + (NE.toList $ fmap mkCons unionValsAndNames) + [] + where + mkCons (unionVal, unionValName) = + NormalC unionValName [(bang, ConT ''Table `AppT` typeRefToType (unionValTableRef unionVal))] + + bang = Bang NoSourceUnpackedness SourceStrict + +mkUnionConstructors :: Name -> UnionDecl -> Q [Dec] +mkUnionConstructors unionName union = + fmap join . traverse mkUnionConstructor $ NE.toList (unionVals union) `zip` [1..] + where + mkUnionConstructor :: (UnionVal, Integer) -> Q [Dec] + mkUnionConstructor (unionVal, ix) = do + let constructorName = mkName' $ NC.unionConstructor union unionVal + pure + [ SigD constructorName $ + ConT ''WriteTable `AppT` typeRefToType (unionValTableRef unionVal) + ~> ConT ''WriteUnion `AppT` ConT unionName + , FunD constructorName + [ Clause + [] + (NormalB $ VarE 'writeUnion `AppE` intLitE ix) + [] + ] + ] + +mkReadUnionFun :: Name -> NonEmpty Name -> UnionDecl -> Q [Dec] +mkReadUnionFun unionName unionValNames union = do + nArg <- newName "n" + posArg <- newName "pos" + wildcard <- newName "n'" + + let funName = mkName $ T.unpack $ NC.readUnionFun union + let sig = + SigD funName $ + ConT ''Positive `AppT` ConT ''Word8 + ~> ConT ''PositionInfo + ~> ConT ''Either `AppT` ConT ''ReadError `AppT` (ConT ''Union `AppT` ConT unionName) + + let + mkMatch :: Name -> Integer -> Match + mkMatch unionValName ix = + Match + (intLitP ix) + (NormalB $ + InfixE + (Just (compose [ConE 'Union, ConE unionValName])) + (VarE '(<$>)) + (Just (VarE 'readTable' `AppE` VarE posArg)) + ) + [] + + let matchWildcard = + Match + (VarP wildcard) + (NormalB $ + InfixE + (Just (VarE 'pure)) + (VarE '($!)) + (Just (ConE 'UnionUnknown `AppE` VarE wildcard)) + ) + [] + + let matches = (uncurry mkMatch <$> NE.toList unionValNames `zip` [1..]) <> [matchWildcard] + + let funBody = + NormalB $ + CaseE + (VarE 'getPositive `AppE` VarE nArg) + matches + + let fun = + FunD funName + [ Clause + [VarP nArg, VarP posArg] + funBody + [] + ] + pure [sig, fun] + +enumTypeToType :: EnumType -> Type +enumTypeToType et = + case et of + EInt8 -> ConT ''Int8 + EInt16 -> ConT ''Int16 + EInt32 -> ConT ''Int32 + EInt64 -> ConT ''Int64 + EWord8 -> ConT ''Word8 + EWord16 -> ConT ''Word16 + EWord32 -> ConT ''Word32 + EWord64 -> ConT ''Word64 + +enumTypeToTableFieldType :: Integral a => EnumType -> DefaultVal a -> TableFieldType +enumTypeToTableFieldType et dflt = + case et of + EInt8 -> TInt8 (fromIntegral dflt) + EInt16 -> TInt16 (fromIntegral dflt) + EInt32 -> TInt32 (fromIntegral dflt) + EInt64 -> TInt64 (fromIntegral dflt) + EWord8 -> TWord8 (fromIntegral dflt) + EWord16 -> TWord16 (fromIntegral dflt) + EWord32 -> TWord32 (fromIntegral dflt) + EWord64 -> TWord64 (fromIntegral dflt) + +enumTypeToStructFieldType :: EnumType -> StructFieldType +enumTypeToStructFieldType et = + case et of + EInt8 -> SInt8 + EInt16 -> SInt16 + EInt32 -> SInt32 + EInt64 -> SInt64 + EWord8 -> SWord8 + EWord16 -> SWord16 + EWord32 -> SWord32 + EWord64 -> SWord64 + +enumTypeToVectorElementType :: EnumType -> VectorElementType +enumTypeToVectorElementType et = + case et of + EInt8 -> VInt8 + EInt16 -> VInt16 + EInt32 -> VInt32 + EInt64 -> VInt64 + EWord8 -> VWord8 + EWord16 -> VWord16 + EWord32 -> VWord32 + EWord64 -> VWord64 + +structFieldTypeToWriteType :: StructFieldType -> Type +structFieldTypeToWriteType sft = + case sft of + SInt8 -> ConT ''Int8 + SInt16 -> ConT ''Int16 + SInt32 -> ConT ''Int32 + SInt64 -> ConT ''Int64 + SWord8 -> ConT ''Word8 + SWord16 -> ConT ''Word16 + SWord32 -> ConT ''Word32 + SWord64 -> ConT ''Word64 + SFloat -> ConT ''Float + SDouble -> ConT ''Double + SBool -> ConT ''Bool + SEnum _ enumType -> enumTypeToType enumType + SStruct (namespace, structDecl) -> + ConT ''WriteStruct `AppT` typeRefToType (TypeRef namespace (getIdent structDecl)) + +structFieldTypeToReadType :: StructFieldType -> Type +structFieldTypeToReadType sft = + case sft of + SInt8 -> ConT ''Int8 + SInt16 -> ConT ''Int16 + SInt32 -> ConT ''Int32 + SInt64 -> ConT ''Int64 + SWord8 -> ConT ''Word8 + SWord16 -> ConT ''Word16 + SWord32 -> ConT ''Word32 + SWord64 -> ConT ''Word64 + SFloat -> ConT ''Float + SDouble -> ConT ''Double + SBool -> ConT ''Bool + SEnum _ enumType -> enumTypeToType enumType + SStruct (namespace, structDecl) -> + ConT ''Struct `AppT` typeRefToType (TypeRef namespace (getIdent structDecl)) + +tableFieldTypeToWriteType :: TableFieldType -> Type +tableFieldTypeToWriteType tft = + case tft of + TInt8 _ -> ConT ''Maybe `AppT` ConT ''Int8 + TInt16 _ -> ConT ''Maybe `AppT` ConT ''Int16 + TInt32 _ -> ConT ''Maybe `AppT` ConT ''Int32 + TInt64 _ -> ConT ''Maybe `AppT` ConT ''Int64 + TWord8 _ -> ConT ''Maybe `AppT` ConT ''Word8 + TWord16 _ -> ConT ''Maybe `AppT` ConT ''Word16 + TWord32 _ -> ConT ''Maybe `AppT` ConT ''Word32 + TWord64 _ -> ConT ''Maybe `AppT` ConT ''Word64 + TFloat _ -> ConT ''Maybe `AppT` ConT ''Float + TDouble _ -> ConT ''Maybe `AppT` ConT ''Double + TBool _ -> ConT ''Maybe `AppT` ConT ''Bool + TString req -> requiredType req (ConT ''Text) + TEnum _ enumType _ -> ConT ''Maybe `AppT` enumTypeToType enumType + TStruct typeRef req -> requiredType req (ConT ''WriteStruct `AppT` typeRefToType typeRef) + TTable typeRef req -> requiredType req (ConT ''WriteTable `AppT` typeRefToType typeRef) + TUnion typeRef _ -> ConT ''WriteUnion `AppT` typeRefToType typeRef + TVector req vecElemType -> requiredType req (vectorElementTypeToWriteType vecElemType) + +tableFieldTypeToReadType :: TableFieldType -> Type +tableFieldTypeToReadType tft = + case tft of + TInt8 _ -> ConT ''Int8 + TInt16 _ -> ConT ''Int16 + TInt32 _ -> ConT ''Int32 + TInt64 _ -> ConT ''Int64 + TWord8 _ -> ConT ''Word8 + TWord16 _ -> ConT ''Word16 + TWord32 _ -> ConT ''Word32 + TWord64 _ -> ConT ''Word64 + TFloat _ -> ConT ''Float + TDouble _ -> ConT ''Double + TBool _ -> ConT ''Bool + TString req -> requiredType req (ConT ''Text) + TEnum _ enumType _ -> enumTypeToType enumType + TStruct typeRef req -> requiredType req (ConT ''Struct `AppT` typeRefToType typeRef) + TTable typeRef req -> requiredType req (ConT ''Table `AppT` typeRefToType typeRef) + TUnion typeRef _ -> ConT ''Union `AppT` typeRefToType typeRef + TVector req vecElemType -> requiredType req (vectorElementTypeToReadType vecElemType) + +vectorElementTypeToWriteType :: VectorElementType -> Type +vectorElementTypeToWriteType vet = + case vet of + VInt8 -> ConT ''WriteVector `AppT` ConT ''Int8 + VInt16 -> ConT ''WriteVector `AppT` ConT ''Int16 + VInt32 -> ConT ''WriteVector `AppT` ConT ''Int32 + VInt64 -> ConT ''WriteVector `AppT` ConT ''Int64 + VWord8 -> ConT ''WriteVector `AppT` ConT ''Word8 + VWord16 -> ConT ''WriteVector `AppT` ConT ''Word16 + VWord32 -> ConT ''WriteVector `AppT` ConT ''Word32 + VWord64 -> ConT ''WriteVector `AppT` ConT ''Word64 + VFloat -> ConT ''WriteVector `AppT` ConT ''Float + VDouble -> ConT ''WriteVector `AppT` ConT ''Double + VBool -> ConT ''WriteVector `AppT` ConT ''Bool + VString -> ConT ''WriteVector `AppT` ConT ''Text + VEnum _ enumType -> ConT ''WriteVector `AppT` enumTypeToType enumType + VStruct typeRef -> ConT ''WriteVector `AppT` (ConT ''WriteStruct `AppT` typeRefToType typeRef) + VTable typeRef -> ConT ''WriteVector `AppT` (ConT ''WriteTable `AppT` typeRefToType typeRef) + VUnion typeRef -> ConT ''WriteVector `AppT` (ConT ''WriteUnion `AppT` typeRefToType typeRef) + +vectorElementTypeToReadType :: VectorElementType -> Type +vectorElementTypeToReadType vet = + case vet of + VInt8 -> ConT ''Vector `AppT` ConT ''Int8 + VInt16 -> ConT ''Vector `AppT` ConT ''Int16 + VInt32 -> ConT ''Vector `AppT` ConT ''Int32 + VInt64 -> ConT ''Vector `AppT` ConT ''Int64 + VWord8 -> ConT ''Vector `AppT` ConT ''Word8 + VWord16 -> ConT ''Vector `AppT` ConT ''Word16 + VWord32 -> ConT ''Vector `AppT` ConT ''Word32 + VWord64 -> ConT ''Vector `AppT` ConT ''Word64 + VFloat -> ConT ''Vector `AppT` ConT ''Float + VDouble -> ConT ''Vector `AppT` ConT ''Double + VBool -> ConT ''Vector `AppT` ConT ''Bool + VString -> ConT ''Vector `AppT` ConT ''Text + VEnum _ enumType -> ConT ''Vector `AppT` enumTypeToType enumType + VStruct typeRef -> ConT ''Vector `AppT` (ConT ''Struct `AppT` typeRefToType typeRef) + VTable typeRef -> ConT ''Vector `AppT` (ConT ''Table `AppT` typeRefToType typeRef) + VUnion typeRef -> ConT ''Vector `AppT` (ConT ''Union `AppT` typeRefToType typeRef) + +typeRefToType :: TypeRef -> Type +typeRefToType (TypeRef ns ident) = + ConT . mkName' . NC.withModulePrefix ns . NC.dataTypeName $ ident + +requiredType :: Required -> Type -> Type +requiredType Req t = t +requiredType Opt t = AppT (ConT ''Maybe) t + +mkName' :: Text -> Name +mkName' = mkName . T.unpack + +newName' :: Text -> Q Name +newName' = newName . T.unpack + + +intLitP :: Integral i => i -> Pat +intLitP = LitP . IntegerL . toInteger + +intLitE :: Integral i => i -> Exp +intLitE = LitE . IntegerL . toInteger + +realLitE :: Real i => i -> Exp +realLitE = LitE . RationalL . toRational + +textLitE :: Text -> Exp +textLitE t = VarE 'T.pack `AppE` LitE (StringL (T.unpack t)) + +stringLitE :: Text -> Exp +stringLitE t = LitE (StringL (T.unpack t)) + +-- | Applies a function to multiple arguments. Assumes the list is not empty. +app :: [Exp] -> Exp +app = foldl1 AppE + +compose :: [Exp] -> Exp +compose = foldr1 (\e1 e2 -> InfixE (Just e1) (VarE '(.)) (Just e2)) diff --git a/src/FlatBuffers/Internal/Compiler/ValidSyntaxTree.hs b/src/FlatBuffers/Internal/Compiler/ValidSyntaxTree.hs new file mode 100644 --- /dev/null +++ b/src/FlatBuffers/Internal/Compiler/ValidSyntaxTree.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module FlatBuffers.Internal.Compiler.ValidSyntaxTree + ( -- * Re-exports from `FlatBuffers.Internal.Compiler.SyntaxTree` + FlatBuffers.Internal.Compiler.SyntaxTree.Namespace(..) + , FlatBuffers.Internal.Compiler.SyntaxTree.Ident(..) + , FlatBuffers.Internal.Compiler.SyntaxTree.TypeRef(..) + , FlatBuffers.Internal.Compiler.SyntaxTree.HasIdent(..) + -- * Enums + , EnumDecl(..) + , EnumVal(..) + , EnumType(..) + -- * Structs + , StructDecl(..) + , StructField(..) + , StructFieldType(..) + -- * Tables + , DefaultVal(..) + , Required(..) + , IsRoot(..) + , TableDecl(..) + , TableField(..) + , TableFieldType(..) + , VectorElementType(..) + -- * Unions + , UnionDecl(..) + , UnionVal(..) + ) where + +import Data.Int +import Data.List.NonEmpty ( NonEmpty ) +import Data.Scientific ( Scientific ) +import Data.String ( IsString(..) ) +import Data.Text ( Text ) +import Data.Word + +import FlatBuffers.Internal.Compiler.SyntaxTree ( HasIdent(..), Ident(..), Namespace(..), TypeRef(..) ) +import FlatBuffers.Internal.Types + +instance HasIdent EnumDecl where getIdent = enumIdent +instance HasIdent EnumVal where getIdent = enumValIdent +instance HasIdent StructDecl where getIdent = structIdent +instance HasIdent StructField where getIdent = structFieldIdent +instance HasIdent TableDecl where getIdent = tableIdent +instance HasIdent TableField where getIdent = tableFieldIdent +instance HasIdent UnionDecl where getIdent = unionIdent +instance HasIdent UnionVal where getIdent = unionValIdent + +---------------------------------- +------------- Enums -------------- +---------------------------------- +data EnumDecl = EnumDecl + { enumIdent :: !Ident + , enumType :: !EnumType + , enumVals :: !(NonEmpty EnumVal) + } deriving (Show, Eq) + +data EnumVal = EnumVal + { enumValIdent :: !Ident + , enumValInt :: !Integer + } deriving (Show, Eq) + +data EnumType + = EInt8 + | EInt16 + | EInt32 + | EInt64 + | EWord8 + | EWord16 + | EWord32 + | EWord64 + deriving (Show, Eq) + +---------------------------------- +------------ Structs ------------- +---------------------------------- +data StructDecl = StructDecl + { structIdent :: !Ident + , structAlignment :: !Alignment + , structSize :: !InlineSize + , structFields :: !(NonEmpty StructField) + } deriving (Show, Eq) + +data StructField = StructField + { structFieldIdent :: !Ident + , structFieldPadding :: !Word8 -- ^ How many zeros to write after this field. + , structFieldOffset :: !Word16 -- ^ This field's offset from the struct's root. + , structFieldType :: !StructFieldType + } deriving (Show, Eq) + +data StructFieldType + = SInt8 + | SInt16 + | SInt32 + | SInt64 + | SWord8 + | SWord16 + | SWord32 + | SWord64 + | SFloat + | SDouble + | SBool + | SEnum + !TypeRef + !EnumType + | SStruct !(Namespace, StructDecl) + deriving (Show, Eq) + +---------------------------------- +------------ Tables -------------- +---------------------------------- +newtype DefaultVal a = DefaultVal a + deriving newtype (Eq, Show, Num, IsString, Ord, Enum, Real, Integral, Fractional) + +data Required = Req | Opt + deriving (Eq, Show) + +data IsRoot + = NotRoot -- ^ This table is not the root table. + | IsRoot !(Maybe Text) -- ^ This table is the root table, and has an optional file identifier. + deriving (Eq, Show) + +data TableDecl = TableDecl + { tableIdent :: !Ident + , tableIsRoot :: !IsRoot + , tableFields :: ![TableField] + } deriving (Eq, Show) + +data TableField = TableField + { tableFieldId :: !Integer + , tableFieldIdent :: !Ident + , tableFieldType :: !TableFieldType + , tableFieldDeprecated :: !Bool + } deriving (Eq, Show) + +data TableFieldType + = TInt8 !(DefaultVal Int8) + | TInt16 !(DefaultVal Int16) + | TInt32 !(DefaultVal Int32) + | TInt64 !(DefaultVal Int64) + | TWord8 !(DefaultVal Word8) + | TWord16 !(DefaultVal Word16) + | TWord32 !(DefaultVal Word32) + | TWord64 !(DefaultVal Word64) + | TFloat !(DefaultVal Scientific) + | TDouble !(DefaultVal Scientific) + | TBool !(DefaultVal Bool) + | TString !Required + | TEnum !TypeRef !EnumType !(DefaultVal Integer) + | TStruct !TypeRef !Required + | TTable !TypeRef !Required + | TUnion !TypeRef !Required + | TVector !Required !VectorElementType + deriving (Eq, Show) + +data VectorElementType + = VInt8 + | VInt16 + | VInt32 + | VInt64 + | VWord8 + | VWord16 + | VWord32 + | VWord64 + | VFloat + | VDouble + | VBool + | VString + | VEnum !TypeRef !EnumType + | VStruct !TypeRef + | VTable !TypeRef + | VUnion !TypeRef + deriving (Eq, Show) + +---------------------------------- +------------ Unions -------------- +---------------------------------- +data UnionDecl = UnionDecl + { unionIdent :: !Ident + , unionVals :: !(NonEmpty UnionVal) + } deriving (Show, Eq) + +data UnionVal = UnionVal + { unionValIdent :: !Ident + , unionValTableRef :: !TypeRef + } deriving (Show, Eq) diff --git a/src/FlatBuffers/Internal/Constants.hs b/src/FlatBuffers/Internal/Constants.hs new file mode 100644 --- /dev/null +++ b/src/FlatBuffers/Internal/Constants.hs @@ -0,0 +1,49 @@ +module FlatBuffers.Internal.Constants where + +voffsetSize, uoffsetSize, soffsetSize :: Num a => a +voffsetSize = word16Size +uoffsetSize = word32Size +soffsetSize = int32Size +{-# INLINE voffsetSize #-} +{-# INLINE uoffsetSize #-} +{-# INLINE soffsetSize #-} + +fileIdentifierSize :: Num a => a +fileIdentifierSize = 4 +{-# INLINE fileIdentifierSize #-} + +textRefSize, tableRefSize :: Num a => a +textRefSize = uoffsetSize +tableRefSize = uoffsetSize +{-# INLINE textRefSize #-} +{-# INLINE tableRefSize #-} + +word8Size, word16Size, word32Size, word64Size :: Num a => a +word8Size = 1 +word16Size = 2 +word32Size = 4 +word64Size = 8 +{-# INLINE word8Size #-} +{-# INLINE word16Size #-} +{-# INLINE word32Size #-} +{-# INLINE word64Size #-} + +int8Size, int16Size, int32Size, int64Size :: Num a => a +int8Size = 1 +int16Size = 2 +int32Size = 4 +int64Size = 8 +{-# INLINE int8Size #-} +{-# INLINE int16Size #-} +{-# INLINE int32Size #-} +{-# INLINE int64Size #-} + +boolSize, floatSize, doubleSize :: Num a => a +boolSize = 1 +floatSize = 4 +doubleSize = 8 +{-# INLINE boolSize #-} +{-# INLINE floatSize #-} +{-# INLINE doubleSize #-} + + diff --git a/src/FlatBuffers/Internal/FileIdentifier.hs b/src/FlatBuffers/Internal/FileIdentifier.hs new file mode 100644 --- /dev/null +++ b/src/FlatBuffers/Internal/FileIdentifier.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module FlatBuffers.Internal.FileIdentifier + ( HasFileIdentifier(..) + , FileIdentifier(unFileIdentifier) + , fileIdentifier + , fileIdentifier' + , unsafeFileIdentifier + , unsafeFileIdentifier' + ) where + + +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import Data.Text ( Text ) +import qualified Data.Text.Encoding as T + +import FlatBuffers.Internal.Constants ( fileIdentifierSize ) + +-- | An identifier that's used to "mark" a buffer. +-- To add this marker to a buffer, use `FlatBuffers.encodeWithFileIdentifier`. +-- To check whether a buffer contains the marker before decoding it, use `FlatBuffers.checkFileIdentifier`. +-- +-- For more information on file identifiers, see : +-- +-- * The [library's docs](https://github.com/dcastro/haskell-flatbuffers#file-identifiers) +-- * Section "File identification and extension" of the [official docs](https://google.github.io/flatbuffers/flatbuffers_guide_writing_schema.html) +newtype FileIdentifier = FileIdentifier { unFileIdentifier :: ByteString } + deriving (Eq, Show) + +-- | Encodes the input text as UTF-8 and returns a @Just FileIdentifier@ if it has exactly 4 bytes, +-- otherwise `Nothing`. +fileIdentifier :: Text -> Maybe FileIdentifier +fileIdentifier = fileIdentifier' . T.encodeUtf8 + +-- | Returns a @Just FileIdentifier@ if the input `ByteString` has exactly 4 bytes, +-- otherwise `Nothing`. +fileIdentifier' :: ByteString -> Maybe FileIdentifier +fileIdentifier' bs = + if BS.length bs /= fileIdentifierSize + then Nothing + else Just (FileIdentifier bs) + +-- | Constructs a new `FileIdentifier` without checking its length. +unsafeFileIdentifier :: Text -> FileIdentifier +unsafeFileIdentifier = unsafeFileIdentifier' . T.encodeUtf8 + +-- | Constructs a new `FileIdentifier` without checking its length. +unsafeFileIdentifier' :: ByteString -> FileIdentifier +unsafeFileIdentifier' = FileIdentifier + +-- | Associates a type with a file identifier. +-- To create an association, declare a @root_type@ and @file_identifier@ in your schema. +-- +-- > table Player {} +-- > root_type Player; +-- > file_identifier "PLYR"; +class HasFileIdentifier a where + getFileIdentifier :: FileIdentifier diff --git a/src/FlatBuffers/Internal/Read.hs b/src/FlatBuffers/Internal/Read.hs new file mode 100644 --- /dev/null +++ b/src/FlatBuffers/Internal/Read.hs @@ -0,0 +1,611 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE InstanceSigs #-} + +{-# OPTIONS_HADDOCK not-home #-} + +{- HLINT ignore readTableFieldOpt "Avoid lambda" -} + +-- Using `replicateM` here causes a performance regression. +{- HLINT ignore inlineVectorToList "Use replicateM" -} + +module FlatBuffers.Internal.Read where + +import Control.Monad ( (>=>), join ) + +import Data.Binary.Get ( Get ) +import qualified Data.Binary.Get as G +import qualified Data.ByteString as BS +import Data.ByteString.Lazy ( ByteString ) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Internal as BSL +import qualified Data.ByteString.Unsafe as BSU +import Data.Coerce ( coerce ) +import Data.Functor ( (<&>) ) +import Data.Int +import qualified Data.List as L +import Data.Text ( Text ) +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import Data.Word + +import FlatBuffers.Internal.Constants +import FlatBuffers.Internal.FileIdentifier ( FileIdentifier(..), HasFileIdentifier(..) ) +import FlatBuffers.Internal.Types +import FlatBuffers.Internal.Util ( Positive, positive ) + +import Prelude hiding ( length ) + +type ReadError = String + +newtype TableIndex = TableIndex { unTableIndex :: Word16 } + deriving newtype (Show, Num) + +newtype VOffset = VOffset { unVOffset :: Word16 } + deriving newtype (Show, Num, Real, Ord, Enum, Integral, Eq) + +-- NOTE: this is an Int32 because a buffer is assumed to respect the size limit of 2^31 - 1. +newtype OffsetFromRoot = OffsetFromRoot Int32 + deriving newtype (Show, Num, Real, Ord, Enum, Integral, Eq) + +-- | A table that is being read from a flatbuffer. +data Table a = Table + { vtable :: !Position + , tablePos :: !PositionInfo + } + +-- | A struct that is being read from a flatbuffer. +newtype Struct a = Struct + { structPos :: Position + } + + +-- | A union that is being read from a flatbuffer. +data Union a + = Union !a + | UnionNone + | UnionUnknown !Word8 + + +type Position = ByteString + +-- | Current position in the buffer +data PositionInfo = PositionInfo + { posRoot :: !Position -- ^ Pointer to the buffer root + , posCurrent :: !Position -- ^ Pointer to current position + , posOffsetFromRoot :: !OffsetFromRoot -- ^ Number of bytes between current position and root + } + +class HasPosition a where + getPosition :: a -> Position + move :: Integral i => a -> i -> a + +instance HasPosition ByteString where + getPosition = id + move bs offset = BSL.drop (fromIntegral @_ @Int64 offset) bs + +instance HasPosition PositionInfo where + getPosition = posCurrent + move PositionInfo{..} offset = + PositionInfo + { posRoot = posRoot + , posCurrent = move posCurrent offset + , posOffsetFromRoot = posOffsetFromRoot + OffsetFromRoot (fromIntegral @_ @Int32 offset) + } + +-- | Deserializes a flatbuffer from a lazy `ByteString`. +decode :: ByteString -> Either ReadError (Table a) +decode root = readTable initialPos + where + initialPos = PositionInfo root root 0 + +-- | Checks if a buffer contains the file identifier for a root table @a@, to see if it's +-- safe to decode it to a `Table`. +-- It should be used in conjunction with @-XTypeApplications@. +-- +-- > {-# LANGUAGE TypeApplications #-} +-- > +-- > if checkFileIdentifier @Monster bs +-- > then decode @Monster bs +-- > else return someMonster +checkFileIdentifier :: forall a. HasFileIdentifier a => ByteString -> Bool +checkFileIdentifier = checkFileIdentifier' (getFileIdentifier @a) + +checkFileIdentifier' :: FileIdentifier -> ByteString -> Bool +checkFileIdentifier' (unFileIdentifier -> fileIdent) bs = + actualFileIdent == BSL.fromStrict fileIdent + where + actualFileIdent = + BSL.take fileIdentifierSize . + BSL.drop uoffsetSize $ + bs + + +---------------------------------- +------------ Vectors ------------- +---------------------------------- +{-# INLINE moveToElem #-} +moveToElem :: HasPosition pos => pos -> Int32 -> Int32 -> pos +moveToElem pos elemSize ix = + let elemOffset = int32Size + (ix * elemSize) + in move pos elemOffset + +{-# INLINE checkIndexBounds #-} +checkIndexBounds :: Int32 -> Int32 -> Int32 +checkIndexBounds ix length + | ix < 0 = error ("FlatBuffers.Internal.Read.index: negative index: " <> show ix) + | ix >= length = error ("FlatBuffers.Internal.Read.index: index too large: " <> show ix) + | otherwise = ix + +{-# INLINE inlineVectorToList #-} +inlineVectorToList :: HasPosition pos => Get a -> pos -> Either ReadError [a] +inlineVectorToList get (getPosition -> pos) = + flip runGet pos $ do + len <- G.getInt32le + sequence $ L.replicate (fromIntegral @Int32 @Int len) get + +class VectorElement a where + + -- | A vector that is being read from a flatbuffer. + data Vector a + + -- | Returns the size of the vector. + length :: Vector a -> Either ReadError Int32 + + -- | Returns the item at the given index. + -- If the given index is negative or too large, an `error` is thrown. + index :: Vector a -> Int32 -> Either ReadError a + index vec ix = unsafeIndex vec . checkIndexBounds ix =<< length vec + + -- | Returns the item at the given index without performing the bounds check. + -- + -- Given an invalid index, @unsafeIndex@ will likely read garbage data or return a `ReadError`. + -- In the case of @Vector Word8@, using a negative index carries the same risks as `BSU.unsafeIndex` + -- (i.e. reading from outside the buffer's boundaries). + unsafeIndex :: Vector a -> Int32 -> Either ReadError a + + -- | Converts the vector to a list. + toList :: Vector a -> Either ReadError [a] + + +instance VectorElement Word8 where + newtype Vector Word8 = VectorWord8 Position + deriving newtype HasPosition + + length = readInt32 + index vec ix = byteStringSafeIndex (coerce vec) . (+ int32Size) . checkIndexBounds ix =<< length vec + unsafeIndex vec ix = byteStringSafeIndex (coerce vec) (int32Size + ix) + toList vec = + length vec <&> \len -> + BSL.unpack $ + BSL.take (fromIntegral @Int32 @Int64 len) $ + BSL.drop int32Size + (coerce vec) + +instance VectorElement Word16 where + newtype Vector Word16 = VectorWord16 Position + deriving newtype HasPosition + + length = readInt32 + unsafeIndex vec = readWord16 . moveToElem vec word16Size + toList = inlineVectorToList G.getWord16le + +instance VectorElement Word32 where + newtype Vector Word32 = VectorWord32 Position + deriving newtype HasPosition + + length = readInt32 + unsafeIndex vec = readWord32 . moveToElem vec word32Size + toList = inlineVectorToList G.getWord32le + +instance VectorElement Word64 where + newtype Vector Word64 = VectorWord64 Position + deriving newtype HasPosition + + length = readInt32 + unsafeIndex vec = readWord64 . moveToElem vec word64Size + toList = inlineVectorToList G.getWord64le + +instance VectorElement Int8 where + newtype Vector Int8 = VectorInt8 Position + deriving newtype HasPosition + + length = readInt32 + unsafeIndex vec = readInt8 . moveToElem vec int8Size + toList = inlineVectorToList G.getInt8 + +instance VectorElement Int16 where + newtype Vector Int16 = VectorInt16 Position + deriving newtype HasPosition + + length = readInt32 + unsafeIndex vec = readInt16 . moveToElem vec int16Size + toList = inlineVectorToList G.getInt16le + +instance VectorElement Int32 where + newtype Vector Int32 = VectorInt32 Position + deriving newtype HasPosition + + length = readInt32 + unsafeIndex vec = readInt32 . moveToElem vec int32Size + toList = inlineVectorToList G.getInt32le + +instance VectorElement Int64 where + newtype Vector Int64 = VectorInt64 Position + deriving newtype HasPosition + + length = readInt32 + unsafeIndex vec = readInt64 . moveToElem vec int64Size + toList = inlineVectorToList G.getInt64le + +instance VectorElement Float where + newtype Vector Float = VectorFloat Position + deriving newtype HasPosition + + length = readInt32 + unsafeIndex vec = readFloat . moveToElem vec floatSize + toList = inlineVectorToList G.getFloatle + +instance VectorElement Double where + newtype Vector Double = VectorDouble Position + deriving newtype HasPosition + + length = readInt32 + unsafeIndex vec = readDouble . moveToElem vec doubleSize + toList = inlineVectorToList G.getDoublele + +instance VectorElement Bool where + newtype Vector Bool = VectorBool Position + deriving newtype HasPosition + + length = readInt32 + unsafeIndex vec = readBool . moveToElem vec boolSize + toList (VectorBool pos) = fmap word8ToBool <$> toList (VectorWord8 pos) + +instance VectorElement Text where + newtype Vector Text = VectorText Position + length (VectorText pos) = readInt32 pos + unsafeIndex (VectorText pos) = readText . moveToElem pos textRefSize + + toList :: Vector Text -> Either ReadError [Text] + toList (VectorText pos) = do + offsets <- toList (VectorInt32 pos) + L.reverse <$> go offsets 0 [] + where + go :: [Int32] -> Int32 -> [Text] -> Either ReadError [Text] + go [] _ acc = Right acc + go (offset : xs) ix acc = do + let textPos = move pos (offset + (ix * 4) + 4) + text <- join $ runGet readText' textPos + go xs (ix + 1) (text : acc) + +instance VectorElement (Struct a) where + data Vector (Struct a) = VectorStruct + { vectorStructStructSize :: !InlineSize + , vectorStructPos :: !Position + } + length = readInt32 . vectorStructPos + unsafeIndex (VectorStruct structSize pos) = + let elemSize = fromIntegral @InlineSize @Int32 structSize + in Right . readStruct . moveToElem pos elemSize + toList vec@(VectorStruct structSize pos) = + length vec <&> \len -> + go len (move pos (int32Size :: Int64)) + where + go :: Int32 -> Position -> [Struct a] + go 0 _ = [] + go !len pos = + let head = readStruct pos + tail = go (len - 1) (move pos structSize) + in head : tail + +instance VectorElement (Table a) where + newtype Vector (Table a) = VectorTable PositionInfo + deriving newtype HasPosition + + length = readInt32 + unsafeIndex vec = readTable . coerce . moveToElem vec tableRefSize + toList (VectorTable vectorPos) = do + offsets <- toList (VectorInt32 (posCurrent vectorPos)) + go offsets 0 + where + go :: [Int32] -> Int32 -> Either ReadError [Table a] + go [] _ = Right [] + go (offset : offsets) !ix = do + let tablePos = move vectorPos (offset + (ix * 4) + 4) + table <- readTable' tablePos + tables <- go offsets (ix + 1) + pure (table : tables) + +instance VectorElement (Union a) where + data Vector (Union a) = VectorUnion + { vectorUnionTypesPos :: !(Vector Word8) + -- ^ A byte-vector, where each byte represents the type of each "union value" in the vector + , vectorUnionValuesPos :: !PositionInfo + -- ^ A table vector, with the actual union values + , vectorUnionReadElem :: !(Positive Word8 -> PositionInfo -> Either ReadError (Union a)) + -- ^ A function to read a union value from this vector + } + + -- NOTE: we assume the two vectors have the same length + length = length . vectorUnionTypesPos + + unsafeIndex (VectorUnion typesPos valuesPos readElem) ix = do + unionType <- unsafeIndex typesPos ix + case positive unionType of + Nothing -> Right UnionNone + Just unionType' -> do + tablePos <- readUOffsetAndSkip $ moveToElem valuesPos tableRefSize ix + readElem unionType' tablePos + + toList (VectorUnion typesPos valuesPos readElem) = do + unionTypes <- toList typesPos + offsets <- toList (VectorInt32 (posCurrent valuesPos)) + go unionTypes offsets 0 + where + go :: [Word8] -> [Int32] -> Int32 -> Either ReadError [Union a] + go [] [] _ = Right [] + go (unionType : unionTypes) (offset : offsets) !ix = do + union <- + case positive unionType of + Nothing -> Right UnionNone + Just unionType' -> + let tablePos = move valuesPos (offset + (ix * 4) + 4) + in readElem unionType' tablePos + unions <- go unionTypes offsets (ix + 1) + pure (union : unions) + go _ _ _ = Left "Union vector: 'type vector' and 'value vector' do not have the same length." + +---------------------------------- +----- Read from Struct/Table ----- +---------------------------------- +{-# INLINE readStructField #-} +readStructField :: (Position -> a) -> VOffset -> Struct s -> a +readStructField read voffset (Struct bs) = + read (move bs voffset) + +{-# INLINE readTableFieldOpt #-} +readTableFieldOpt :: (PositionInfo -> Either ReadError a) -> TableIndex -> Table t -> Either ReadError (Maybe a) +readTableFieldOpt read ix t = do + mbOffset <- tableIndexToVOffset t ix + traverse (\offset -> read (move (tablePos t) offset)) mbOffset + +{-# INLINE readTableFieldReq #-} +readTableFieldReq :: (PositionInfo -> Either ReadError a) -> TableIndex -> String -> Table t -> Either ReadError a +readTableFieldReq read ix name t = do + mbOffset <- tableIndexToVOffset t ix + case mbOffset of + Nothing -> missingField name + Just offset -> read (move (tablePos t) offset) + +{-# INLINE readTableFieldWithDef #-} +readTableFieldWithDef :: (PositionInfo -> Either ReadError a) -> TableIndex -> a -> Table t -> Either ReadError a +readTableFieldWithDef read ix dflt t = + tableIndexToVOffset t ix >>= \case + Nothing -> Right dflt + Just offset -> read (move (tablePos t) offset) + +{-# INLINE readTableFieldUnion #-} +readTableFieldUnion :: (Positive Word8 -> PositionInfo -> Either ReadError (Union a)) -> TableIndex -> Table t -> Either ReadError (Union a) +readTableFieldUnion read ix t = + readTableFieldWithDef readWord8 (ix - 1) 0 t >>= \unionType -> + case positive unionType of + Nothing -> Right UnionNone + Just unionType' -> + tableIndexToVOffset t ix >>= \case + Nothing -> Left "Union: 'union type' found but 'union value' is missing." + Just offset -> readUOffsetAndSkip (move (tablePos t) offset) >>= read unionType' + +readTableFieldUnionVectorOpt :: + (Positive Word8 -> PositionInfo -> Either ReadError (Union a)) + -> TableIndex + -> Table t + -> Either ReadError (Maybe (Vector (Union a))) +readTableFieldUnionVectorOpt read ix t = + tableIndexToVOffset t (ix - 1) >>= \case + Nothing -> Right Nothing + Just typesOffset -> + tableIndexToVOffset t ix >>= \case + Nothing -> Left "Union vector: 'type vector' found but 'value vector' is missing." + Just valuesOffset -> + Just <$> readUnionVector read (move (tablePos t) typesOffset) (move (tablePos t) valuesOffset) + +readTableFieldUnionVectorReq :: + (Positive Word8 -> PositionInfo -> Either ReadError (Union a)) + -> TableIndex + -> String + -> Table t + -> Either ReadError (Vector (Union a)) +readTableFieldUnionVectorReq read ix name t = + tableIndexToVOffset t (ix - 1) >>= \case + Nothing -> missingField name + Just typesOffset -> + tableIndexToVOffset t ix >>= \case + Nothing -> Left "Union vector: 'type vector' found but 'value vector' is missing." + Just valuesOffset -> + readUnionVector read (move (tablePos t) typesOffset) (move (tablePos t) valuesOffset) + +---------------------------------- +------ Read from `Position` ------ +---------------------------------- +{-# INLINE readInt8 #-} +readInt8 :: HasPosition a => a -> Either ReadError Int8 +readInt8 (getPosition -> pos) = runGet G.getInt8 pos + +{-# INLINE readInt16 #-} +readInt16 :: HasPosition a => a -> Either ReadError Int16 +readInt16 (getPosition -> pos) = runGet G.getInt16le pos + +{-# INLINE readInt32 #-} +readInt32 :: HasPosition a => a -> Either ReadError Int32 +readInt32 (getPosition -> pos) = runGet G.getInt32le pos + +{-# INLINE readInt64 #-} +readInt64 :: HasPosition a => a -> Either ReadError Int64 +readInt64 (getPosition -> pos) = runGet G.getInt64le pos + +{-# INLINE readWord8 #-} +readWord8 :: HasPosition a => a -> Either ReadError Word8 +readWord8 (getPosition -> pos) = runGet G.getWord8 pos + +{-# INLINE readWord16 #-} +readWord16 :: HasPosition a => a -> Either ReadError Word16 +readWord16 (getPosition -> pos) = runGet G.getWord16le pos + +{-# INLINE readWord32 #-} +readWord32 :: HasPosition a => a -> Either ReadError Word32 +readWord32 (getPosition -> pos) = runGet G.getWord32le pos + +{-# INLINE readWord64 #-} +readWord64 :: HasPosition a => a -> Either ReadError Word64 +readWord64 (getPosition -> pos) = runGet G.getWord64le pos + +{-# INLINE readFloat #-} +readFloat :: HasPosition a => a -> Either ReadError Float +readFloat (getPosition -> pos) = runGet G.getFloatle pos + +{-# INLINE readDouble #-} +readDouble :: HasPosition a => a -> Either ReadError Double +readDouble (getPosition -> pos) = runGet G.getDoublele pos + +{-# INLINE readBool #-} +readBool :: HasPosition a => a -> Either ReadError Bool +readBool p = word8ToBool <$> readWord8 p + +{-# INLINE word8ToBool #-} +word8ToBool :: Word8 -> Bool +word8ToBool 0 = False +word8ToBool _ = True + +readPrimVector :: + (Position -> Vector a) + -> PositionInfo + -> Either ReadError (Vector a) +readPrimVector vecConstructor (posCurrent -> pos) = + vecConstructor <$> readUOffsetAndSkip pos + +readTableVector :: PositionInfo -> Either ReadError (Vector (Table a)) +readTableVector pos = + VectorTable <$> readUOffsetAndSkip pos + +readStructVector :: forall a. IsStruct a => PositionInfo -> Either ReadError (Vector (Struct a)) +readStructVector (posCurrent -> pos) = + VectorStruct (structSizeOf @a) <$> readUOffsetAndSkip pos + +readUnionVector :: + (Positive Word8 -> PositionInfo -> Either ReadError (Union a)) + -> PositionInfo + -> PositionInfo + -> Either ReadError (Vector (Union a)) +readUnionVector readUnion typesPos valuesPos = + do + typesVec <- readPrimVector VectorWord8 typesPos + valuesVec <- readUOffsetAndSkip valuesPos + Right $! VectorUnion + typesVec + valuesVec + readUnion + +-- | Follow a pointer to the position of a string and read it. +{-# INLINE readText #-} +readText :: HasPosition a => a -> Either ReadError Text +readText (getPosition -> pos) = + join $ flip runGet pos $ do + uoffset <- G.getInt32le + -- NOTE: this might overflow in systems where Int has less than 32 bits + G.skip (fromIntegral @Int32 @Int (uoffset - uoffsetSize)) + readText' + +-- | Read a string from the current buffer position. +{-# INLINE readText' #-} +readText' :: Get (Either ReadError Text) +readText' = do + strLength <- G.getInt32le + -- NOTE: this might overflow in systems where Int has less than 32 bits + bs <- G.getByteString $ fromIntegral @Int32 @Int strLength + pure $! case T.decodeUtf8' bs of + Right t -> Right t + Left (T.DecodeError msg byteMaybe) -> + case byteMaybe of + Just byte -> Left $ "UTF8 decoding error (byte " <> show byte <> "): " <> msg + Nothing -> Left $ "UTF8 decoding error: " <> msg + -- The `EncodeError` constructor is deprecated and not used + -- https://hackage.haskell.org/package/text-1.2.3.1/docs/Data-Text-Encoding-Error.html#t:UnicodeException + Left _ -> error "the impossible happened" + +-- | Follow a pointer to the position of a table and read it. +{-# INLINE readTable #-} +readTable :: PositionInfo -> Either ReadError (Table t) +readTable = readUOffsetAndSkip >=> readTable' + +-- | Read a table from the current buffer position. +{-# INLINE readTable' #-} +readTable' :: PositionInfo -> Either ReadError (Table t) +readTable' tablePos = + readInt32 tablePos <&> \soffset -> + let vtableOffsetFromRoot = coerce (posOffsetFromRoot tablePos) - soffset + vtable = move (posRoot tablePos) vtableOffsetFromRoot + in Table vtable tablePos + +{-# INLINE readStruct #-} +readStruct :: HasPosition a => a -> Struct s +readStruct = Struct . getPosition + +---------------------------------- +---------- Primitives ------------ +---------------------------------- +{-# INLINE tableIndexToVOffset #-} +tableIndexToVOffset :: Table t -> TableIndex -> Either ReadError (Maybe VOffset) +tableIndexToVOffset Table{..} ix = + flip runGet vtable $ do + vtableSize <- G.getWord16le + let vtableIndex = 4 + (unTableIndex ix * 2) + if vtableIndex >= vtableSize + then pure Nothing + else do + G.skip (fromIntegral @Word16 @Int vtableIndex - 2) + G.getWord16le <&> \case + 0 -> Nothing + word16 -> Just (VOffset word16) + +{-# INLINE readUOffsetAndSkip #-} +readUOffsetAndSkip :: HasPosition pos => pos -> Either ReadError pos +readUOffsetAndSkip pos = + move pos <$> readInt32 pos + +{-# INLINE runGet #-} +runGet :: Get a -> ByteString -> Either ReadError a +runGet get bs = + case G.runGetOrFail get bs of + Right (_, _, a) -> Right a + Left (_, _, msg) -> Left msg + +{-# NOINLINE missingField #-} +missingField :: String -> Either ReadError a +missingField fieldName = + Left $ "Missing required table field: " <> fieldName + +-- | Safer version of `Data.ByteString.Lazy.index` that doesn't throw when index is too large. +-- Assumes @i > 0@. + +-- Adapted from `Data.ByteString.Lazy.index`: https://hackage.haskell.org/package/bytestring-0.10.8.2/docs/src/Data.ByteString.Lazy.html#index +{-# INLINE byteStringSafeIndex #-} +byteStringSafeIndex :: ByteString -> Int32 -> Either ReadError Word8 +byteStringSafeIndex !cs0 !i = + index' cs0 i + where index' BSL.Empty _ = Left "not enough bytes" + index' (BSL.Chunk c cs) n + -- NOTE: this might overflow in systems where Int has less than 32 bits + | fromIntegral @Int32 @Int n >= BS.length c = + -- Note: it's safe to narrow `BS.length` to an int32 here, the line above proves it. + index' cs (n - fromIntegral @Int @Int32 (BS.length c)) + | otherwise = Right $! BSU.unsafeIndex c (fromIntegral @Int32 @Int n) diff --git a/src/FlatBuffers/Internal/Types.hs b/src/FlatBuffers/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/FlatBuffers/Internal/Types.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +{-# OPTIONS_HADDOCK not-home #-} + +module FlatBuffers.Internal.Types where + +import Data.Word + +-- | Metadata for a struct type. +class IsStruct a where + structAlignmentOf :: Alignment + structSizeOf :: InlineSize + +-- | The number of bytes occupied by a piece of data that's stored "inline" +-- +-- "inline" here means "stored directly in a table or a vector, and not by reference". +-- E.g.: numeric types, booleans, structs, offsets. +newtype InlineSize = InlineSize { unInlineSize :: Word16 } + deriving newtype (Show, Eq, Num, Enum, Ord, Real, Integral, Bounded) + +-- | The memory alignment (in bytes) for a piece of data in a flatbuffer. +-- E.g., `Data.Int.Int32` are always aligned to 4 bytes. +-- This number should always be a power of 2 in the range [1, 16]. +newtype Alignment = Alignment { unAlignment :: Word8 } + deriving newtype (Show, Eq, Num, Enum, Ord, Real, Integral, Bounded) + diff --git a/src/FlatBuffers/Internal/Util.hs b/src/FlatBuffers/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/FlatBuffers/Internal/Util.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module FlatBuffers.Internal.Util where + +import Data.Bits ( (.&.), Bits ) +import Data.List.NonEmpty ( NonEmpty(..) ) + +{-# INLINE isPowerOfTwo #-} +isPowerOfTwo :: (Num a, Bits a) => a -> Bool +isPowerOfTwo 0 = False +isPowerOfTwo n = (n .&. (n - 1)) == 0 + +{-# INLINE roundUpToNearestMultipleOf #-} +roundUpToNearestMultipleOf :: Integral n => n -> n -> n +roundUpToNearestMultipleOf x y = + case x `rem` y of + 0 -> x + remainder -> (y - remainder) + x + +{-# INLINE nonEmptyUnzip3 #-} +nonEmptyUnzip3 :: NonEmpty (a,b,c) -> (NonEmpty a, NonEmpty b, NonEmpty c) +nonEmptyUnzip3 xs = + ( (\(x, _, _) -> x) <$> xs + , (\(_, x, _) -> x) <$> xs + , (\(_, _, x) -> x) <$> xs + ) + +-- | Proof that a number is strictly positive. +newtype Positive a = Positive { getPositive :: a } + deriving newtype (Eq, Show) + +{-# INLINE positive #-} +positive :: (Num a, Ord a) => a -> Maybe (Positive a) +positive n = if n > 0 then Just (Positive n) else Nothing diff --git a/src/FlatBuffers/Internal/Write.hs b/src/FlatBuffers/Internal/Write.hs new file mode 100644 --- /dev/null +++ b/src/FlatBuffers/Internal/Write.hs @@ -0,0 +1,749 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnliftedFFITypes #-} + +{-# OPTIONS_HADDOCK not-home #-} + +{- HLINT ignore writeTable uoffsetFrom "Eta reduce" -} + +module FlatBuffers.Internal.Write where + +import Control.Monad.State.Strict + +import Data.ByteString.Builder ( Builder ) +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Lazy as BSL +import Data.Coerce ( coerce ) +import qualified Data.Foldable as Foldable +import Data.Int +import qualified Data.List as L +import qualified Data.Map.Strict as M +import Data.Monoid ( Sum(..) ) +import Data.Semigroup ( Max(..) ) +import Data.Text ( Text ) +import qualified Data.Text.Array as A +import qualified Data.Text.Encoding as T +import qualified Data.Text.Internal as TI +import Data.Word + +import FlatBuffers.Internal.Build +import FlatBuffers.Internal.Constants +import FlatBuffers.Internal.FileIdentifier ( FileIdentifier(unFileIdentifier), HasFileIdentifier(getFileIdentifier) ) +import FlatBuffers.Internal.Types + +import Foreign.C.Types ( CSize(CSize) ) + +import GHC.Base ( ByteArray# ) + +import System.IO.Unsafe ( unsafeDupablePerformIO ) + + +type BufferSize = Sum Int32 + +-- | The position of something in a buffer, expressed as the number of bytes counting from the end. +type Position = Int32 + +data FBState = FBState + { builder :: !Builder + , bufferSize :: {-# UNPACK #-} !BufferSize + , maxAlign :: {-# UNPACK #-} !(Max Alignment) + , cache :: !(M.Map BSL.ByteString Position) + } + +newtype WriteTableField = WriteTableField { unWriteTableField :: State FBState (FBState -> FBState) } + +-- | A struct to be written to a flatbuffer. +newtype WriteStruct a = WriteStruct { buildStruct :: Builder } + +-- | A table to be written to a flatbuffer. +newtype WriteTable a = WriteTable (State FBState Position) + +-- | A union to be written to a flatbuffer. +data WriteUnion a + = Some + {-# UNPACK #-} !Word8 + !(State FBState Position) + | None + + +-- | Serializes a flatbuffer table as a lazy `BSL.ByteString`. +{-# INLINE encode #-} +encode :: WriteTable a -> BSL.ByteString +encode = encodeState (FBState mempty (Sum 0) (Max 1) mempty) + +{-# INLINE encodeState #-} +encodeState :: FBState -> WriteTable a -> BSL.ByteString +encodeState state (WriteTable writeTable) = + B.toLazyByteString $ + builder $ + execState + (do pos <- writeTable + maxAlignment <- gets (getMax . maxAlign) + modify' $ alignTo maxAlignment uoffsetSize + modify' $ uoffsetFrom pos + ) + state + +-- | Serializes a flatbuffer table as a lazy `BSL.ByteString` and adds a File Identifier. +{-# INLINE encodeWithFileIdentifier #-} +encodeWithFileIdentifier :: forall a. HasFileIdentifier a => WriteTable a -> BSL.ByteString +encodeWithFileIdentifier = + encodeStateWithFileIdentifier (FBState mempty (Sum 0) (Max 1) mempty) (getFileIdentifier @a) + +{-# INLINE encodeStateWithFileIdentifier #-} +encodeStateWithFileIdentifier :: FBState -> FileIdentifier -> WriteTable a -> BSL.ByteString +encodeStateWithFileIdentifier state fi (WriteTable writeTable) = + B.toLazyByteString $ + builder $ + execState + (do pos <- writeTable + maxAlignment <- gets (getMax . maxAlign) + modify' $ alignTo maxAlignment (uoffsetSize + fileIdentifierSize) + modify' $ writeFileIdentifier fi + modify' $ uoffsetFrom pos + ) + state + + +-- | Writes something (unaligned) to the buffer. +{-# INLINE write #-} +write :: Int32 -> Builder -> FBState -> FBState +write bsize b fbs = fbs + { builder = b <> builder fbs + , bufferSize = bufferSize fbs <> Sum bsize + } + +-- | Writes a 32-bit int (unaligned) to the buffer. +{-# INLINE writeInt32 #-} +writeInt32 :: Int32 -> FBState -> FBState +writeInt32 n = write int32Size (B.int32LE n) + +{-# INLINE writeFileIdentifier #-} +writeFileIdentifier :: FileIdentifier -> FBState -> FBState +writeFileIdentifier fi = write fileIdentifierSize (B.byteString (unFileIdentifier fi)) + +{-# INLINE missing #-} +missing :: WriteTableField +missing = WriteTableField . pure $! id + +{-# INLINE deprecated #-} +deprecated :: WriteTableField +deprecated = missing + +{-# INLINE optional #-} +optional :: (a -> WriteTableField) -> (Maybe a -> WriteTableField) +optional = maybe missing + +{-# INLINE optionalDef #-} +optionalDef :: Eq a => a -> (a -> WriteTableField) -> (Maybe a -> WriteTableField) +optionalDef dflt write ma = + case ma of + Just a | a /= dflt -> write a + _ -> missing + + +{-# INLINE writeWord8TableField #-} +writeWord8TableField :: Word8 -> WriteTableField +writeWord8TableField n = WriteTableField . pure $! write word8Size (B.word8 n) . alignTo word8Size 0 + +{-# INLINE writeWord16TableField #-} +writeWord16TableField :: Word16 -> WriteTableField +writeWord16TableField n = WriteTableField . pure $! write word16Size (B.word16LE n) . alignTo word16Size 0 + +{-# INLINE writeWord32TableField #-} +writeWord32TableField :: Word32 -> WriteTableField +writeWord32TableField n = WriteTableField . pure $! write word32Size (B.word32LE n) . alignTo word32Size 0 + +{-# INLINE writeWord64TableField #-} +writeWord64TableField :: Word64 -> WriteTableField +writeWord64TableField n = WriteTableField . pure $! write word64Size (B.word64LE n) . alignTo word64Size 0 + +{-# INLINE writeInt8TableField #-} +writeInt8TableField :: Int8 -> WriteTableField +writeInt8TableField n = WriteTableField . pure $! write int8Size (B.int8 n) . alignTo int8Size 0 + +{-# INLINE writeInt16TableField #-} +writeInt16TableField :: Int16 -> WriteTableField +writeInt16TableField n = WriteTableField . pure $! write int16Size (B.int16LE n) . alignTo int16Size 0 + +{-# INLINE writeInt32TableField #-} +writeInt32TableField :: Int32 -> WriteTableField +writeInt32TableField n = WriteTableField . pure $! write int32Size (B.int32LE n) . alignTo int32Size 0 + +{-# INLINE writeInt64TableField #-} +writeInt64TableField :: Int64 -> WriteTableField +writeInt64TableField n = WriteTableField . pure $! write int64Size (B.int64LE n) . alignTo int64Size 0 + +{-# INLINE writeFloatTableField #-} +writeFloatTableField :: Float -> WriteTableField +writeFloatTableField n = WriteTableField . pure $! write floatSize (B.floatLE n) . alignTo floatSize 0 + +{-# INLINE writeDoubleTableField #-} +writeDoubleTableField :: Double -> WriteTableField +writeDoubleTableField n = WriteTableField . pure $! write doubleSize (B.doubleLE n) . alignTo doubleSize 0 + +{-# INLINE writeBoolTableField #-} +writeBoolTableField :: Bool -> WriteTableField +writeBoolTableField = writeWord8TableField . boolToWord8 + +{-# INLINE writeTextTableField #-} +writeTextTableField :: Text -> WriteTableField +writeTextTableField text = WriteTableField $ do + modify' (writeInt32 len . encodeText . alignTo int32Size (len + 1)) + uoffsetFromHere + where + len = utf8length text + encodeText fbs = + fbs + -- strings must have a trailing zero + { builder = T.encodeUtf8Builder text <> B.word8 0 <> builder fbs + , bufferSize = Sum len <> Sum 1 <> bufferSize fbs + } + +{-# INLINE writeTableTableField #-} +writeTableTableField :: WriteTable a -> WriteTableField +writeTableTableField (WriteTable writeTable) = WriteTableField $ do + loc <- writeTable + pure $! uoffsetFrom loc + +{-# INLINE writeStructTableField #-} +writeStructTableField :: forall a. IsStruct a => WriteStruct a -> WriteTableField +writeStructTableField (WriteStruct b) = + writeStructTableField' (structAlignmentOf @a) (structSizeOf @a) b + +{-# INLINE writeStructTableField' #-} +writeStructTableField' :: Alignment -> InlineSize -> Builder -> WriteTableField +writeStructTableField' structAlignment structSize structBuilder = + WriteTableField . pure $! writeStruct . alignTo structAlignment 0 + where + writeStruct fbs = fbs + { builder = structBuilder <> builder fbs + , bufferSize = bufferSize fbs <> Sum (fromIntegral @InlineSize @Int32 structSize) + } + +{-# INLINE writeUnionTypesVectorTableField #-} +writeUnionTypesVectorTableField :: WriteVector (WriteUnion a) -> WriteTableField +writeUnionTypesVectorTableField (WriteVectorUnion tf _) = tf + +{-# INLINE writeUnionValuesVectorTableField #-} +writeUnionValuesVectorTableField :: WriteVector (WriteUnion a) -> WriteTableField +writeUnionValuesVectorTableField (WriteVectorUnion _ tf) = tf + + +{-# INLINE writeUnionTypeTableField #-} +writeUnionTypeTableField :: WriteUnion a -> WriteTableField +writeUnionTypeTableField !wu = + case wu of + None -> missing + Some unionType _ -> writeWord8TableField unionType + + +{-# INLINE writeUnionValueTableField #-} +writeUnionValueTableField :: WriteUnion a -> WriteTableField +writeUnionValueTableField !wu = + case wu of + None -> missing + Some _ unionValue -> writeTableTableField (WriteTable unionValue) + +-- | Constructs a missing union table field / vector element. +{-# INLINE none #-} +none :: WriteUnion a +none = None + +{-# INLINE writeUnion #-} +writeUnion :: Word8 -> WriteTable a -> WriteUnion b +writeUnion n (WriteTable st) = Some n st + +{-# INLINE vtable #-} +vtable :: [Word16] -> Word16 -> BSL.ByteString +vtable fieldVOffsets tableSize = bytestring + where + vtableSize = voffsetSize + voffsetSize + voffsetSize * fromIntegral @Int @Word16 (L.length fieldVOffsets) + bytestring = B.toLazyByteString + ( B.word16LE vtableSize + <> B.word16LE (coerce tableSize) + <> foldMap (B.word16LE . coerce) fieldVOffsets + ) + + +{-# INLINE writeTable #-} +writeTable :: [WriteTableField] -> WriteTable a +writeTable fields = WriteTable $ do + + inlineFields <- sequence (coerce fields) + + -- table + tableEnd <- gets (getSum . bufferSize) + + inlineFieldPositions <- + forM inlineFields $ \f -> do + before <- gets bufferSize + modify' f + after <- gets bufferSize + if after == before + then pure 0 + else pure (getSum after) + + modify' $ alignTo soffsetSize 0 + tableFieldsPosition <- gets (getSum . bufferSize) + + let tablePosition = tableFieldsPosition + soffsetSize + -- Note: This might overflow if the table has too many fields + let tableSize = fromIntegral @Int32 @Word16 $ tablePosition - tableEnd + let fieldVOffsets = flip fmap inlineFieldPositions $ \case + 0 -> 0 + -- Note: This might overflow if the table has too many fields + fieldPosition -> fromIntegral @Int32 @Word16 (tablePosition - fieldPosition) + + -- TODO: trim trailing 0 voffsets + + let newVtable = vtable fieldVOffsets tableSize + let newVtableSize = fromIntegral @Int64 @Int32 (BSL.length newVtable) + let newVtablePosition = tablePosition + newVtableSize + + map <- gets cache + case M.insertLookupWithKey (\_k _new old -> old) newVtable newVtablePosition map of + (Nothing, map') -> + -- vtable, pointer to vtable, update the cache + modify' (writeVtable map' newVtable newVtableSize . writeVtableSoffset newVtableSize) + + (Just oldVtablePosition, _) -> + -- pointer to vtable + modify' . writeInt32 . negate $ tablePosition - oldVtablePosition + + pure $! tablePosition + + where + writeVtable newCache newVtable newVtableSize fbs = fbs + { cache = newCache + , builder = B.lazyByteString newVtable <> builder fbs + , bufferSize = bufferSize fbs <> Sum newVtableSize + } + + -- The vtable is located right before the table, so the offset + -- between the table and the vtable is equal to the vtable size + writeVtableSoffset newVtableSize = writeInt32 newVtableSize + + + +class WriteVectorElement a where + + -- | A vector to be written to a flatbuffer. + data WriteVector a + + -- | Constructs a flatbuffers vector. + -- + -- If @n@ is larger than the length of @xs@, this will result in a malformed buffer. + -- If @n@ is smaller than the length of @xs@, all elements of @xs@ will still be written to the buffer, + -- but the client will only be able to read the first @n@ elements. + -- + -- Note: `fromFoldable` asks for the collection's length to be passed in as an argument rather than use @Foldable.length@ because: + -- + -- 1. @Foldable.length@ is often O(n), and in some use cases there may be a better way to know the collection's length ahead of time. + -- 2. Calling @Foldable.length@ inside `fromFoldable` can inhibit some fusions which would otherwise be possible. + + + -- Implementer's note: + -- To elaborate on point 2., here's an example. + -- This version of `fromFoldable` that calls @Foldable.length@ internally: + -- + -- > encodeUserIds' :: [User] -> BSL.ByteString + -- > encodeUserIds' = encode . userIdsTable $ fromFoldable (userId <$> users)) + -- > + -- > {-# INLINE fromFoldable #-} + -- > fromFoldable xs = + -- > let length = Foldable.length xs + -- > buffer = foldr ... ... xs + -- > in ... + -- + -- ...prevents `<$>` and `foldr` from being fused, and so it's much slower than when the length is passed in: + -- + -- > encodeUserIds :: [User] -> BSL.ByteString + -- > encodeUserIds = encode . userIdsTable $ fromFoldable (userId <$> users) (fromIntegral (Foldable.length users)) + -- > + -- > {-# INLINE fromFoldable #-} + -- > fromFoldable xs length = + -- > let buffer = foldr ... ... xs + -- > in ... + fromFoldable :: + Foldable f + => Int32 -- ^ @n@: the number of elements in @xs@ + -> f a -- ^ @xs@: a collection + -> WriteVector a + +-- | Convenience function, equivalent to: +-- +-- > fromFoldable' xs = fromFoldable (fromIntegral (Foldable.length xs)) xs +-- +-- In some cases it may be slower than using `fromFoldable` directly. +{-# INLINE fromFoldable' #-} +fromFoldable' :: WriteVectorElement a => Foldable f => f a -> WriteVector a +fromFoldable' xs = fromFoldable (fromIntegral $ Foldable.length xs) xs + +-- | `fromFoldable` specialized to list +fromList :: WriteVectorElement a => Int32 -> [a] -> WriteVector a +fromList = fromFoldable + +-- | `fromFoldable'` specialized to list +fromList' :: WriteVectorElement a => [a] -> WriteVector a +fromList' = fromFoldable' + +-- | Creates a flatbuffers vector with a single element +singleton :: WriteVectorElement a => a -> WriteVector a +singleton a = fromList 1 [a] + +-- | Creates an empty flatbuffers vector +empty :: WriteVectorElement a => WriteVector a +empty = fromList 0 [] + + + +{-# INLINE inlineVector #-} +inlineVector :: Foldable f => (a -> Builder) -> Alignment -> InlineSize -> Int32 -> f a -> WriteTableField +inlineVector build elemAlignment elemSize elemCount elems = WriteTableField $ do + modify' $! + writeInt32 elemCount . writeVec . alignTo (coerce elemAlignment `max` int32Size) vecByteLength + + uoffsetFromHere + where + vecByteLength = elemCount * fromIntegral @InlineSize @Int32 elemSize + vecBuilder = foldr (\a b -> build a <> b) mempty elems + writeVec fbs = + fbs + { builder = vecBuilder <> builder fbs + , bufferSize = bufferSize fbs <> Sum vecByteLength + } + +instance WriteVectorElement Word8 where + newtype WriteVector Word8 = WriteVectorWord8 { writeVectorWord8TableField :: WriteTableField } + + {-# INLINE fromFoldable #-} + fromFoldable :: Foldable f => Int32 -> f Word8 -> WriteVector Word8 + fromFoldable n = WriteVectorWord8 . inlineVector B.word8 word8Size word8Size n + +instance WriteVectorElement Word16 where + newtype WriteVector Word16 = WriteVectorWord16 { writeVectorWord16TableField :: WriteTableField } + + {-# INLINE fromFoldable #-} + fromFoldable :: Foldable f => Int32 -> f Word16 -> WriteVector Word16 + fromFoldable n = WriteVectorWord16 . inlineVector B.word16LE word16Size word16Size n + +instance WriteVectorElement Word32 where + newtype WriteVector Word32 = WriteVectorWord32 { writeVectorWord32TableField :: WriteTableField } + + {-# INLINE fromFoldable #-} + fromFoldable :: Foldable f => Int32 -> f Word32 -> WriteVector Word32 + fromFoldable n = WriteVectorWord32 . inlineVector B.word32LE word32Size word32Size n + +instance WriteVectorElement Word64 where + newtype WriteVector Word64 = WriteVectorWord64 { writeVectorWord64TableField :: WriteTableField } + + {-# INLINE fromFoldable #-} + fromFoldable :: Foldable f => Int32 -> f Word64 -> WriteVector Word64 + fromFoldable n = WriteVectorWord64 . inlineVector B.word64LE word64Size word64Size n + +instance WriteVectorElement Int8 where + newtype WriteVector Int8 = WriteVectorInt8 { writeVectorInt8TableField :: WriteTableField } + + {-# INLINE fromFoldable #-} + fromFoldable :: Foldable f => Int32 -> f Int8 -> WriteVector Int8 + fromFoldable n = WriteVectorInt8 . inlineVector B.int8 int8Size int8Size n + +instance WriteVectorElement Int16 where + newtype WriteVector Int16 = WriteVectorInt16 { writeVectorInt16TableField :: WriteTableField } + + {-# INLINE fromFoldable #-} + fromFoldable :: Foldable f => Int32 -> f Int16 -> WriteVector Int16 + fromFoldable n = WriteVectorInt16 . inlineVector B.int16LE int16Size int16Size n + +instance WriteVectorElement Int32 where + newtype WriteVector Int32 = WriteVectorInt32 { writeVectorInt32TableField :: WriteTableField } + + {-# INLINE fromFoldable #-} + fromFoldable :: Foldable f => Int32 -> f Int32 -> WriteVector Int32 + fromFoldable n = WriteVectorInt32 . inlineVector B.int32LE int32Size int32Size n + +instance WriteVectorElement Int64 where + newtype WriteVector Int64 = WriteVectorInt64 { writeVectorInt64TableField :: WriteTableField } + + {-# INLINE fromFoldable #-} + fromFoldable :: Foldable f => Int32 -> f Int64 -> WriteVector Int64 + fromFoldable n = WriteVectorInt64 . inlineVector B.int64LE int64Size int64Size n + +instance WriteVectorElement Float where + newtype WriteVector Float = WriteVectorFloat { writeVectorFloatTableField :: WriteTableField } + + {-# INLINE fromFoldable #-} + fromFoldable :: Foldable f => Int32 -> f Float -> WriteVector Float + fromFoldable n = WriteVectorFloat . inlineVector B.floatLE floatSize floatSize n + +instance WriteVectorElement Double where + newtype WriteVector Double = WriteVectorDouble { writeVectorDoubleTableField :: WriteTableField } + + {-# INLINE fromFoldable #-} + fromFoldable :: Foldable f => Int32 -> f Double -> WriteVector Double + fromFoldable n = WriteVectorDouble . inlineVector B.doubleLE doubleSize doubleSize n + +instance WriteVectorElement Bool where + newtype WriteVector Bool = WriteVectorBool { writeVectorBoolTableField :: WriteTableField } + + {-# INLINE fromFoldable #-} + fromFoldable :: Foldable f => Int32 -> f Bool -> WriteVector Bool + fromFoldable n = WriteVectorBool . inlineVector (B.word8 . boolToWord8) word8Size word8Size n + +instance IsStruct a => WriteVectorElement (WriteStruct a) where + newtype WriteVector (WriteStruct a) = WriteVectorStruct { writeVectorStructTableField :: WriteTableField } + + {-# INLINE fromFoldable #-} + fromFoldable :: Foldable f => Int32 -> f (WriteStruct a) -> WriteVector (WriteStruct a) + fromFoldable n = WriteVectorStruct . inlineVector coerce (structAlignmentOf @a) (structSizeOf @a) n + + +data TextInfos = TextInfos ![TextInfo] {-# UNPACK #-} !BufferSize + +data TextInfo = TextInfo + { tiText :: !Text + , tiUtf8len :: {-# UNPACK #-} !Int32 + , tiPadding :: {-# UNPACK #-} !Int32 + , tiPosition :: {-# UNPACK #-} !Position + } + +data OffsetInfo = OffsetInfo + { oiIndex :: {-# UNPACK #-} !Int32 + , oiOffsets :: ![Int32] + } + +instance WriteVectorElement Text where + newtype WriteVector Text = WriteVectorText { writeVectorTextTableField :: WriteTableField } + + {-# INLINE fromFoldable #-} + fromFoldable :: Foldable f => Int32 -> f Text -> WriteVector Text + fromFoldable elemCount texts = WriteVectorText . WriteTableField $ do + modify' $ \fbs -> + let (builder2, bsize2) = + writeVectorSizePrefix . writeOffsets . align . writeStrings $ (builder fbs, bufferSize fbs) + in fbs + { builder = builder2 + , bufferSize = bsize2 + , maxAlign = maxAlign fbs <> Max int32Size + } + uoffsetFromHere + where + writeStrings :: (Builder, BufferSize) -> (Builder, BufferSize, [TextInfo]) + writeStrings (builder1, bsize1) = + -- Collect info about the strings. + -- NOTE: this loop *could* be merged with the one below, but + -- we have loops dedicated to merging Builders to avoid wrapping Builders in data structures. + -- See "Performance tips": http://hackage.haskell.org/package/fast-builder-0.1.0.1/docs/Data-ByteString-FastBuilder.html + let TextInfos textInfos bsize2 = + foldr + (\t (TextInfos infos bsize) -> + let textLength = utf8length t + padding = calcPadding 4 (textLength + 1) bsize + newBsize = bsize <> Sum (padding + textLength + 1 + 4) + in TextInfos (TextInfo t textLength padding (getSum newBsize) : infos) newBsize + ) + (TextInfos [] bsize1) + texts + + builder2 = + foldr + (\(TextInfo t tlength padding _) b -> + B.int32LE tlength + <> T.encodeUtf8Builder t + <> B.word8 0 -- strings must have a trailing zero + <> buildPadding padding + <> b + ) + mempty + textInfos + in (builder2 <> builder1, bsize2, textInfos) + + align :: (Builder, BufferSize, [TextInfo]) -> (Builder, BufferSize, [TextInfo]) + align (builder1, bsize1, textInfos) = + let vectorPadding = calcPadding int32Size 0 bsize1 + bsize2 = bsize1 <> Sum vectorPadding + builder2 = buildPadding vectorPadding + in (builder2 <> builder1, bsize2, textInfos) + + writeOffsets :: (Builder, BufferSize, [TextInfo]) -> (Builder, BufferSize) + writeOffsets (builder1, bsize1, textInfos) = + let OffsetInfo _ offsets = + foldr + (\(TextInfo _ _ _ position) (OffsetInfo ix os) -> + OffsetInfo + (ix + 1) + (getSum bsize1 + (ix * 4) + 4 - position : os) + ) + (OffsetInfo 0 []) + textInfos + + bsize2 = bsize1 <> Sum (elemCount * 4) + builder2 = + foldr + (\o b -> B.int32LE o <> b) + mempty + offsets + in (builder2 <> builder1, bsize2) + + writeVectorSizePrefix :: (Builder, BufferSize) -> (Builder, BufferSize) + writeVectorSizePrefix (builder1, bsize1) = + (B.int32LE elemCount <> builder1, bsize1 + int32Size) + + + +data TableInfo = TableInfo + { tiState :: !FBState + , tiTablePositions :: ![Position] + } + +instance WriteVectorElement (WriteTable a) where + newtype WriteVector (WriteTable a) = WriteVectorTable { writeVectorTableTableField :: WriteTableField } + + {-# INLINE fromFoldable #-} + fromFoldable :: Foldable f => Int32 -> f (WriteTable a) -> WriteVector (WriteTable a) + fromFoldable elemCount tables = WriteVectorTable . WriteTableField $ do + fbs1 <- get + let !(TableInfo fbs2 positions) = + foldr + (\(WriteTable writeTable) (TableInfo fbs positions) -> + let (pos, fbs') = runState writeTable fbs + in TableInfo fbs' (pos : positions) + ) + (TableInfo fbs1 []) + tables + put $! alignTo int32Size 0 fbs2 + + -- Write offsets + bsize <- gets (getSum . bufferSize) + let OffsetInfo _ offsets = + foldr + (\position (OffsetInfo ix os) -> + OffsetInfo + (ix + 1) + (bsize + (ix * 4) + 4 - position : os) + ) + (OffsetInfo 0 []) + positions + + coerce $ fromFoldable elemCount offsets + +data Vecs a = Vecs ![Word8] ![Maybe (State FBState Position)] + +data UnionTableInfo = UnionTableInfo + { utiState :: !FBState + , utiTablePositions :: ![Maybe Position] + } + +instance WriteVectorElement (WriteUnion a) where + data WriteVector (WriteUnion a) = WriteVectorUnion !WriteTableField !WriteTableField + + {-# INLINE fromFoldable #-} + fromFoldable :: Foldable f => Int32 -> f (WriteUnion a) -> WriteVector (WriteUnion a) + fromFoldable elemCount unions = + let Vecs types values = + foldr + go + (Vecs [] []) + unions + go writeUnion (Vecs types values) = + case writeUnion of + None -> Vecs (0 : types) (Nothing : values) + Some typ val -> Vecs (typ : types) (Just val : values) + + writeUnionTables :: WriteTableField + writeUnionTables = WriteTableField $ do + fbs1 <- get + let !(UnionTableInfo fbs2 positions) = + foldr + (\unionTableOpt (UnionTableInfo fbs positions) -> + case unionTableOpt of + Just t -> + let (pos, fbs') = runState t fbs + in UnionTableInfo fbs' (Just pos : positions) + Nothing -> + UnionTableInfo fbs (Nothing : positions) + ) + (UnionTableInfo fbs1 []) + values + put $! alignTo int32Size 0 fbs2 + + + -- Write offsets + bsize <- gets (getSum . bufferSize) + let OffsetInfo _ offsets = + foldr + (\positionOpt (OffsetInfo ix os) -> + let offset = + case positionOpt of + Just position -> bsize + (ix * 4) + 4 - position + Nothing -> 0 + in OffsetInfo + (ix + 1) + (offset : os) + ) + (OffsetInfo 0 []) + positions + + coerce $ fromFoldable elemCount offsets + + in WriteVectorUnion (coerce $ fromFoldable elemCount types) writeUnionTables + + + +-- | Calculate how much 0-padding is needed so that, after writing @additionalBytes@, +-- the buffer becomes aligned to @n@ bytes. +{-# INLINE calcPadding #-} +calcPadding :: Alignment {- ^ n -} -> Int32 {- ^ additionalBytes -} -> BufferSize -> Int32 +calcPadding !n !additionalBytes (Sum size) = + -- TODO: optimize this: https://hackage.haskell.org/package/base-4.12.0.0/docs/Data-Bits.html + if n == 0 + then 0 + else + let remainder = (size + additionalBytes) `rem` fromIntegral @Alignment @Int32 n + needed = if remainder == 0 then 0 else fromIntegral @Alignment @Int32 n - remainder + in needed + +-- | Add enough 0-padding so that the buffer becomes aligned to @n@ after writing @additionalBytes@. +{-# INLINE alignTo #-} +alignTo :: Alignment{- ^ n -} -> Int32 {- ^ additionalBytes -} -> FBState -> FBState +alignTo !n !additionalBytes fbs@(FBState b bsize ma cache) = + if padding == 0 + then fbs { maxAlign = ma <> coerce n } + else FBState + (buildPadding padding <> b) + (bsize <> Sum padding) + (ma <> coerce n) + cache + where + padding = calcPadding n additionalBytes bsize + + +{-# INLINE uoffsetFromHere #-} +uoffsetFromHere :: State FBState (FBState -> FBState) +uoffsetFromHere = gets (uoffsetFrom . coerce . bufferSize) + +{-# INLINE uoffsetFrom #-} +uoffsetFrom :: Position -> FBState -> FBState +uoffsetFrom pos = writeUOffset . align + where + align fbs = alignTo int32Size 0 fbs + writeUOffset fbs = + let currentPos = coerce bufferSize fbs + in writeInt32 (currentPos - pos + uoffsetSize) fbs + +{-# INLINE utf8length #-} +utf8length :: Text -> Int32 +utf8length (TI.Text arr off len) + | len == 0 = 0 + | otherwise = unsafeDupablePerformIO $ + c_length_utf8 (A.aBA arr) (fromIntegral off) (fromIntegral len) + +foreign import ccall unsafe "_hs_text_length_utf8" c_length_utf8 + :: ByteArray# -> CSize -> CSize -> IO Int32 diff --git a/src/FlatBuffers/Vector.hs b/src/FlatBuffers/Vector.hs new file mode 100644 --- /dev/null +++ b/src/FlatBuffers/Vector.hs @@ -0,0 +1,24 @@ +-- | This module is intended to be imported qualified to avoid name clashes with Prelude. +-- E.g.: +-- +-- > import     FlatBuffers.Vector (Vector, WriteVector) +-- > import qualified FlatBuffers.Vector as Vector +module FlatBuffers.Vector + ( + -- * Creating a vector + W.WriteVectorElement(..) + , W.fromFoldable' + , W.fromList + , W.fromList' + , W.singleton + , W.empty + + -- * Reading a vector + , R.VectorElement(..) + ) where + +import FlatBuffers.Internal.Read as R +import FlatBuffers.Internal.Write as W + + + diff --git a/test/Examples.hs b/test/Examples.hs new file mode 100644 --- /dev/null +++ b/test/Examples.hs @@ -0,0 +1,5 @@ +module Examples + ( module Examples.Generated + ) where + +import Examples.Generated diff --git a/test/Examples/Generated.hs b/test/Examples/Generated.hs new file mode 100644 --- /dev/null +++ b/test/Examples/Generated.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Examples.Generated where + +import FlatBuffers + +$(mkFlatBuffers "test/Examples/schema.fbs" defaultOptions) +$(mkFlatBuffers "test/Examples/vector_of_unions.fbs" defaultOptions) diff --git a/test/Examples/HandWritten.hs b/test/Examples/HandWritten.hs new file mode 100644 --- /dev/null +++ b/test/Examples/HandWritten.hs @@ -0,0 +1,638 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Examples.HandWritten where + +import Data.Int +import Data.Text ( Text ) +import Data.Word + +import FlatBuffers.Internal.Build +import FlatBuffers.Internal.FileIdentifier ( HasFileIdentifier(..), unsafeFileIdentifier ) +import FlatBuffers.Internal.Read +import FlatBuffers.Internal.Types +import FlatBuffers.Internal.Util ( Positive(getPositive) ) +import FlatBuffers.Internal.Write + +---------------------------------- +---------- Empty table ----------- +---------------------------------- +data EmptyTable + +emptyTable :: WriteTable EmptyTable +emptyTable = writeTable [] + +---------------------------------- +---------- Primitives ------------ +---------------------------------- +data Primitives + +instance HasFileIdentifier Primitives where + getFileIdentifier = unsafeFileIdentifier "PRIM" + +primitives :: + Maybe Word8 + -> Maybe Word16 + -> Maybe Word32 + -> Maybe Word64 + -> Maybe Int8 + -> Maybe Int16 + -> Maybe Int32 + -> Maybe Int64 + -> Maybe Float + -> Maybe Double + -> Maybe Bool + -> Maybe Text + -> WriteTable Primitives +primitives a b c d e f g h i j k l = + 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 writeFloatTableField i + , optionalDef 0 writeDoubleTableField j + , optionalDef False writeBoolTableField k + , optional writeTextTableField l + ] + +primitivesA :: Table Primitives -> Either ReadError Word8 +primitivesB :: Table Primitives -> Either ReadError Word16 +primitivesC :: Table Primitives -> Either ReadError Word32 +primitivesD :: Table Primitives -> Either ReadError Word64 +primitivesE :: Table Primitives -> Either ReadError Int8 +primitivesF :: Table Primitives -> Either ReadError Int16 +primitivesG :: Table Primitives -> Either ReadError Int32 +primitivesH :: Table Primitives -> Either ReadError Int64 +primitivesI :: Table Primitives -> Either ReadError Float +primitivesJ :: Table Primitives -> Either ReadError Double +primitivesK :: Table Primitives -> Either ReadError Bool +primitivesL :: Table Primitives -> Either ReadError (Maybe Text) +primitivesA = readTableFieldWithDef readWord8 0 0 +primitivesB = readTableFieldWithDef readWord16 1 0 +primitivesC = readTableFieldWithDef readWord32 2 0 +primitivesD = readTableFieldWithDef readWord64 3 0 +primitivesE = readTableFieldWithDef readInt8 4 0 +primitivesF = readTableFieldWithDef readInt16 5 0 +primitivesG = readTableFieldWithDef readInt32 6 0 +primitivesH = readTableFieldWithDef readInt64 7 0 +primitivesI = readTableFieldWithDef readFloat 8 0 +primitivesJ = readTableFieldWithDef readDouble 9 0 +primitivesK = readTableFieldWithDef readBool 10 False +primitivesL = readTableFieldOpt readText 11 + +---------------------------------- +------------- Color -------------- +---------------------------------- +data Color + = ColorRed + | ColorGreen + | ColorBlue + | ColorGray + | ColorBlack + deriving (Eq, Show, Read, Ord, Bounded) + +{-# INLINE toColor #-} +toColor :: Int16 -> Maybe Color +toColor n = + case n of + -2 -> Just ColorRed + 0 -> Just ColorGreen + 1 -> Just ColorBlue + 5 -> Just ColorGray + 8 -> Just ColorBlack + _ -> Nothing + +{-# INLINE fromColor #-} +fromColor :: Color -> Int16 +fromColor n = + case n of + ColorRed -> -2 + ColorGreen -> 0 + ColorBlue -> 1 + ColorGray -> 5 + ColorBlack -> 8 + +---------------------------------- +------------- Enums -------------- +---------------------------------- +data Enums + +enums :: + Maybe Int16 + -> Maybe (WriteStruct StructWithEnum) + -> Maybe (WriteVector Int16) + -> Maybe (WriteVector (WriteStruct StructWithEnum)) + -> WriteTable Enums +enums x y xs ys = writeTable + [ optionalDef 0 writeInt16TableField x + , optional writeStructTableField y + , optional writeVectorInt16TableField xs + , optional writeVectorStructTableField ys + ] + +enumsX :: Table Enums -> Either ReadError Int16 +enumsX = readTableFieldWithDef readInt16 0 0 + +enumsY :: Table Enums -> Either ReadError (Maybe (Struct StructWithEnum)) +enumsY = readTableFieldOpt (Right . readStruct) 1 + +enumsXs :: Table Enums -> Either ReadError (Maybe (Vector Int16)) +enumsXs = readTableFieldOpt (readPrimVector VectorInt16) 2 + +enumsYs :: Table Enums -> Either ReadError (Maybe (Vector (Struct StructWithEnum))) +enumsYs = readTableFieldOpt readStructVector 3 + + + +data StructWithEnum + +instance IsStruct StructWithEnum where + structAlignmentOf = 2 + structSizeOf = 6 + +structWithEnum :: Int8 -> Int16 -> Int8 -> WriteStruct StructWithEnum +structWithEnum x y z = WriteStruct $ + buildInt8 x <> buildPadding 1 + <> buildInt16 y + <> buildInt8 z <> buildPadding 1 + +structWithEnumX :: Struct StructWithEnum -> Either ReadError Int8 +structWithEnumX = readStructField readInt8 0 + +structWithEnumY :: Struct StructWithEnum -> Either ReadError Int16 +structWithEnumY = readStructField readInt16 2 + +structWithEnumZ :: Struct StructWithEnum -> Either ReadError Int8 +structWithEnumZ = readStructField readInt8 4 + +---------------------------------- +------------- Structs ------------ +---------------------------------- +data Struct1 +instance IsStruct Struct1 where + structAlignmentOf = 1 + structSizeOf = 3 + +struct1 :: Word8 -> Int8 -> Int8 -> WriteStruct Struct1 +struct1 x y z = + WriteStruct $ + buildWord8 x <> buildInt8 y <> buildInt8 z + +struct1X :: Struct Struct1 -> Either ReadError Word8 +struct1X = readStructField readWord8 0 + +struct1Y :: Struct Struct1 -> Either ReadError Int8 +struct1Y = readStructField readInt8 1 + +struct1Z :: Struct Struct1 -> Either ReadError Int8 +struct1Z = readStructField readInt8 2 + + +data Struct2 +instance IsStruct Struct2 where + structAlignmentOf = 2 + structSizeOf = 4 + +struct2 :: Int16 -> WriteStruct Struct2 +struct2 x = WriteStruct $ + buildInt16 x <> buildPadding 2 + +struct2X :: Struct Struct2 -> Either ReadError Int16 +struct2X = readStructField readInt16 0 + + +data Struct3 +instance IsStruct Struct3 where + structAlignmentOf = 8 + structSizeOf = 24 + +struct3 :: WriteStruct Struct2 -> Word64 -> Word8 -> WriteStruct Struct3 +struct3 x y z = WriteStruct $ + buildStruct x <> buildPadding 4 + <> buildWord64 y + <> buildWord8 z <> buildPadding 7 + +struct3X :: Struct Struct3 -> Struct Struct2 +struct3X = readStructField readStruct 0 + +struct3Y :: Struct Struct3 -> Either ReadError Word64 +struct3Y = readStructField readWord64 8 + +struct3Z :: Struct Struct3 -> Either ReadError Word8 +struct3Z = readStructField readWord8 16 + + +data Struct4 +instance IsStruct Struct4 where + structAlignmentOf = 8 + structSizeOf = 24 + +struct4 :: WriteStruct Struct2 -> Int8 -> Int64 -> Bool -> WriteStruct Struct4 +struct4 w x y z = WriteStruct $ + buildStruct w + <> buildInt8 x <> buildPadding 3 + <> buildInt64 y + <> buildBool z <> buildPadding 7 + +struct4W :: Struct Struct4 -> Struct Struct2 +struct4W = readStructField readStruct 0 + +struct4X :: Struct Struct4 -> Either ReadError Int8 +struct4X = readStructField readInt8 4 + +struct4Y :: Struct Struct4 -> Either ReadError Int64 +struct4Y = readStructField readInt64 8 + +struct4Z :: Struct Struct4 -> Either ReadError Bool +struct4Z = readStructField readBool 16 + + +data Structs + +structs :: + Maybe (WriteStruct Struct1) + -> Maybe (WriteStruct Struct2) + -> Maybe (WriteStruct Struct3) + -> Maybe (WriteStruct Struct4) + -> WriteTable Structs +structs a b c d = writeTable + [ optional writeStructTableField a + , optional writeStructTableField b + , optional writeStructTableField c + , optional writeStructTableField d + ] + +structsA :: Table Structs -> Either ReadError (Maybe (Struct Struct1)) +structsA = readTableFieldOpt (Right . readStruct) 0 + +structsB :: Table Structs -> Either ReadError (Maybe (Struct Struct2)) +structsB = readTableFieldOpt (Right . readStruct) 1 + +structsC :: Table Structs -> Either ReadError (Maybe (Struct Struct3)) +structsC = readTableFieldOpt (Right . readStruct) 2 + +structsD :: Table Structs -> Either ReadError (Maybe (Struct Struct4)) +structsD = readTableFieldOpt (Right . readStruct) 3 + + +---------------------------------- +--------- Nested Tables ---------- +---------------------------------- +data NestedTables + +nestedTables :: Maybe (WriteTable Table1) -> WriteTable NestedTables +nestedTables x = writeTable + [ optional writeTableTableField x + ] + +nestedTablesX :: Table NestedTables -> Either ReadError (Maybe (Table Table1)) +nestedTablesX = readTableFieldOpt readTable 0 + + +data Table1 + +table1 :: Maybe (WriteTable Table2) -> Maybe Int32 -> WriteTable Table1 +table1 x y = writeTable + [ optional writeTableTableField x + , optionalDef 0 writeInt32TableField y + ] + +table1X :: Table Table1 -> Either ReadError (Maybe (Table Table2)) +table1X = readTableFieldOpt readTable 0 + +table1Y :: Table Table1 -> Either ReadError Int16 +table1Y = readTableFieldWithDef readInt16 1 0 + + +data Table2 + +table2 :: Maybe Int16 -> WriteTable Table2 +table2 x = writeTable [ optionalDef 0 writeInt16TableField x ] + +table2X :: Table Table2 -> Either ReadError Int16 +table2X = readTableFieldWithDef readInt16 0 0 + +---------------------------------- +------------- Sword -------------- +---------------------------------- +data Sword + +sword :: Maybe Text -> WriteTable Sword +sword x = writeTable [optional writeTextTableField x] + +swordX :: Table Sword -> Either ReadError (Maybe Text) +swordX = readTableFieldOpt readText 0 + +---------------------------------- +------------- Axe ---------------- +---------------------------------- +data Axe + +axe :: Maybe Int32 -> WriteTable Axe +axe y = writeTable [optionalDef 0 writeInt32TableField y] + +axeY :: Table Axe -> Either ReadError Int32 +axeY = readTableFieldWithDef readInt32 0 0 + +---------------------------------- +------------- Weapon ------------- +---------------------------------- +data Weapon + = WeaponSword !(Table Sword) + | WeaponAxe !(Table Axe) + +weaponSword :: WriteTable Sword -> WriteUnion Weapon +weaponSword = writeUnion 1 + +weaponAxe :: WriteTable Axe -> WriteUnion Weapon +weaponAxe = writeUnion 2 + +readWeapon :: Positive Word8 -> PositionInfo -> Either ReadError (Union Weapon) +readWeapon n pos = + case getPositive n of + 1 -> Union . WeaponSword <$> readTable' pos + 2 -> Union . WeaponAxe <$> readTable' pos + n' -> pure $! UnionUnknown n' + +---------------------------------- +------- TableWithUnion ----------- +---------------------------------- +data TableWithUnion + +tableWithUnion :: WriteUnion Weapon -> WriteTable TableWithUnion +tableWithUnion uni = writeTable + [ writeUnionTypeTableField uni + , writeUnionValueTableField uni + ] + +tableWithUnionUni :: Table TableWithUnion -> Either ReadError (Union Weapon) +tableWithUnionUni = readTableFieldUnion readWeapon 1 + +---------------------------------- +------------ Vectors ------------- +---------------------------------- +data Vectors + +vectors :: + 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) + -> Maybe (WriteVector Text) + -> WriteTable Vectors +vectors a b c d e f g h i j k l = + 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 + , optional writeVectorTextTableField l + ] + +vectorsA :: Table Vectors -> Either ReadError (Maybe (Vector Word8)) +vectorsB :: Table Vectors -> Either ReadError (Maybe (Vector Word16)) +vectorsC :: Table Vectors -> Either ReadError (Maybe (Vector Word32)) +vectorsD :: Table Vectors -> Either ReadError (Maybe (Vector Word64)) +vectorsE :: Table Vectors -> Either ReadError (Maybe (Vector Int8)) +vectorsF :: Table Vectors -> Either ReadError (Maybe (Vector Int16)) +vectorsG :: Table Vectors -> Either ReadError (Maybe (Vector Int32)) +vectorsH :: Table Vectors -> Either ReadError (Maybe (Vector Int64)) +vectorsI :: Table Vectors -> Either ReadError (Maybe (Vector Float)) +vectorsJ :: Table Vectors -> Either ReadError (Maybe (Vector Double)) +vectorsK :: Table Vectors -> Either ReadError (Maybe (Vector Bool)) +vectorsL :: Table Vectors -> Either ReadError (Maybe (Vector Text)) +vectorsA = readTableFieldOpt (readPrimVector VectorWord8) 0 +vectorsB = readTableFieldOpt (readPrimVector VectorWord16) 1 +vectorsC = readTableFieldOpt (readPrimVector VectorWord32) 2 +vectorsD = readTableFieldOpt (readPrimVector VectorWord64) 3 +vectorsE = readTableFieldOpt (readPrimVector VectorInt8) 4 +vectorsF = readTableFieldOpt (readPrimVector VectorInt16) 5 +vectorsG = readTableFieldOpt (readPrimVector VectorInt32) 6 +vectorsH = readTableFieldOpt (readPrimVector VectorInt64) 7 +vectorsI = readTableFieldOpt (readPrimVector VectorFloat) 8 +vectorsJ = readTableFieldOpt (readPrimVector VectorDouble) 9 +vectorsK = readTableFieldOpt (readPrimVector VectorBool) 10 +vectorsL = readTableFieldOpt (readPrimVector VectorText) 11 + +---------------------------------- +-------- VectorOfTables ---------- +---------------------------------- +data VectorOfTables + +vectorOfTables :: Maybe (WriteVector (WriteTable Axe)) -> WriteTable VectorOfTables +vectorOfTables xs = writeTable + [ optional writeVectorTableTableField xs + ] + +vectorOfTablesXs :: Table VectorOfTables -> Either ReadError (Maybe (Vector (Table Axe))) +vectorOfTablesXs = readTableFieldOpt readTableVector 0 + +---------------------------------- +------- VectorOfStructs ---------- +---------------------------------- +data VectorOfStructs + +vectorOfStructs :: + Maybe (WriteVector (WriteStruct Struct1)) + -> Maybe (WriteVector (WriteStruct Struct2)) + -> Maybe (WriteVector (WriteStruct Struct3)) + -> Maybe (WriteVector (WriteStruct Struct4)) + -> WriteTable VectorOfStructs +vectorOfStructs as bs cs ds = writeTable + [ optional writeVectorStructTableField as + , optional writeVectorStructTableField bs + , optional writeVectorStructTableField cs + , optional writeVectorStructTableField ds + ] + +vectorOfStructsAs :: Table VectorOfStructs -> Either ReadError (Maybe (Vector (Struct Struct1))) +vectorOfStructsAs = readTableFieldOpt readStructVector 0 + +vectorOfStructsBs :: Table VectorOfStructs -> Either ReadError (Maybe (Vector (Struct Struct2))) +vectorOfStructsBs = readTableFieldOpt readStructVector 1 + +vectorOfStructsCs :: Table VectorOfStructs -> Either ReadError (Maybe (Vector (Struct Struct3))) +vectorOfStructsCs = readTableFieldOpt readStructVector 2 + +vectorOfStructsDs :: Table VectorOfStructs -> Either ReadError (Maybe (Vector (Struct Struct4))) +vectorOfStructsDs = readTableFieldOpt readStructVector 3 + + +---------------------------------- +------- VectorOfUnions ----------- +---------------------------------- +data VectorOfUnions + +vectorOfUnions :: + Maybe (WriteVector (WriteUnion Weapon)) + -> WriteVector (WriteUnion Weapon) + -> WriteTable VectorOfUnions +vectorOfUnions xs xsReq = writeTable + [ optional writeUnionTypesVectorTableField xs + , optional writeUnionValuesVectorTableField xs + , deprecated + , deprecated + , writeUnionTypesVectorTableField xsReq + , writeUnionValuesVectorTableField xsReq + ] + +vectorOfUnionsXs :: Table VectorOfUnions -> Either ReadError (Maybe (Vector (Union Weapon))) +vectorOfUnionsXs = readTableFieldUnionVectorOpt readWeapon 1 + +vectorOfUnionsXsReq :: Table VectorOfUnions -> Either ReadError (Vector (Union Weapon)) +vectorOfUnionsXsReq = readTableFieldUnionVectorReq readWeapon 5 "xsReq" + + +---------------------------------- +---- Scalars with defaults ------- +---------------------------------- +data ScalarsWithDefaults + +scalarsWithDefaults :: + Maybe Word8 + -> Maybe Word16 + -> Maybe Word32 + -> Maybe Word64 + -> Maybe Int8 + -> Maybe Int16 + -> Maybe Int32 + -> Maybe Int64 + -> Maybe Float + -> Maybe Double + -> Maybe Bool + -> Maybe Bool + -> Maybe Int16 + -> Maybe Int16 + -> WriteTable ScalarsWithDefaults +scalarsWithDefaults a b c d e f g h i j k l m n = + 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 + , optionalDef False writeBoolTableField l + , optionalDef 1 writeInt16TableField m + , optionalDef 5 writeInt16TableField n + ] + +scalarsWithDefaultsA :: Table ScalarsWithDefaults -> Either ReadError Word8 +scalarsWithDefaultsB :: Table ScalarsWithDefaults -> Either ReadError Word16 +scalarsWithDefaultsC :: Table ScalarsWithDefaults -> Either ReadError Word32 +scalarsWithDefaultsD :: Table ScalarsWithDefaults -> Either ReadError Word64 +scalarsWithDefaultsE :: Table ScalarsWithDefaults -> Either ReadError Int8 +scalarsWithDefaultsF :: Table ScalarsWithDefaults -> Either ReadError Int16 +scalarsWithDefaultsG :: Table ScalarsWithDefaults -> Either ReadError Int32 +scalarsWithDefaultsH :: Table ScalarsWithDefaults -> Either ReadError Int64 +scalarsWithDefaultsI :: Table ScalarsWithDefaults -> Either ReadError Float +scalarsWithDefaultsJ :: Table ScalarsWithDefaults -> Either ReadError Double +scalarsWithDefaultsK :: Table ScalarsWithDefaults -> Either ReadError Bool +scalarsWithDefaultsL :: Table ScalarsWithDefaults -> Either ReadError Bool +scalarsWithDefaultsM :: Table ScalarsWithDefaults -> Either ReadError Int16 +scalarsWithDefaultsN :: Table ScalarsWithDefaults -> Either ReadError Int16 +scalarsWithDefaultsA = readTableFieldWithDef readWord8 0 8 +scalarsWithDefaultsB = readTableFieldWithDef readWord16 1 16 +scalarsWithDefaultsC = readTableFieldWithDef readWord32 2 32 +scalarsWithDefaultsD = readTableFieldWithDef readWord64 3 64 +scalarsWithDefaultsE = readTableFieldWithDef readInt8 4 (-1) +scalarsWithDefaultsF = readTableFieldWithDef readInt16 5 (-2) +scalarsWithDefaultsG = readTableFieldWithDef readInt32 6 (-4) +scalarsWithDefaultsH = readTableFieldWithDef readInt64 7 (-8) +scalarsWithDefaultsI = readTableFieldWithDef readFloat 8 3.9 +scalarsWithDefaultsJ = readTableFieldWithDef readDouble 9 (-2.3e10) +scalarsWithDefaultsK = readTableFieldWithDef readBool 10 True +scalarsWithDefaultsL = readTableFieldWithDef readBool 11 False +scalarsWithDefaultsM = readTableFieldWithDef readInt16 12 1 +scalarsWithDefaultsN = readTableFieldWithDef readInt16 13 5 + + +---------------------------------- +------ Deprecated fields --------- +---------------------------------- +data DeprecatedFields + +deprecatedFields :: Maybe Int8 -> Maybe Int8 -> Maybe Int8 -> Maybe Int8 -> WriteTable DeprecatedFields +deprecatedFields a c e g = writeTable + [ optionalDef 0 writeInt8TableField a + , deprecated + , optionalDef 0 writeInt8TableField c + , deprecated + , optionalDef 0 writeInt8TableField e + , deprecated + , deprecated + , optionalDef 0 writeInt8TableField g + ] + +deprecatedFieldsA :: Table DeprecatedFields -> Either ReadError Int8 +deprecatedFieldsA = readTableFieldWithDef readInt8 0 0 + +deprecatedFieldsC :: Table DeprecatedFields -> Either ReadError Int8 +deprecatedFieldsC = readTableFieldWithDef readInt8 2 0 + +deprecatedFieldsE :: Table DeprecatedFields -> Either ReadError Int8 +deprecatedFieldsE = readTableFieldWithDef readInt8 4 0 + +deprecatedFieldsG :: Table DeprecatedFields -> Either ReadError Int8 +deprecatedFieldsG = readTableFieldWithDef readInt8 7 0 + + +---------------------------------- +-------- Required fields --------- +---------------------------------- +data RequiredFields + +requiredFields :: + Text + -> WriteStruct Struct1 + -> WriteTable Axe + -> WriteUnion Weapon + -> WriteVector Int32 + -> WriteTable RequiredFields +requiredFields a b c d e = writeTable + [ writeTextTableField a + , writeStructTableField b + , writeTableTableField c + , writeUnionTypeTableField d + , writeUnionValueTableField d + , writeVectorInt32TableField e + ] + +requiredFieldsA :: Table RequiredFields -> Either ReadError Text +requiredFieldsA = readTableFieldReq readText 0 "a" + +requiredFieldsB :: Table RequiredFields -> Either ReadError (Struct Struct1) +requiredFieldsB = readTableFieldReq (Right . readStruct) 1 "b" + +requiredFieldsC :: Table RequiredFields -> Either ReadError (Table Axe) +requiredFieldsC = readTableFieldReq readTable 2 "c" + +requiredFieldsD :: Table RequiredFields -> Either ReadError (Union Weapon) +requiredFieldsD = readTableFieldUnion readWeapon 4 + +requiredFieldsE :: Table RequiredFields -> Either ReadError (Vector Int32) +requiredFieldsE = readTableFieldReq (readPrimVector VectorInt32) 5 "e" + diff --git a/test/FlatBuffers/AlignmentSpec.hs b/test/FlatBuffers/AlignmentSpec.hs new file mode 100644 --- /dev/null +++ b/test/FlatBuffers/AlignmentSpec.hs @@ -0,0 +1,478 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +{- HLINT ignore "Reduce duplication" -} + +module FlatBuffers.AlignmentSpec where + +import Control.Monad.State.Strict + +import qualified Data.Binary.Get as G +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Lazy as BSL +import Data.ByteString.Lazy ( ByteString ) +import Data.Coerce +import Data.Foldable ( fold, foldrM ) +import Data.Int +import qualified Data.List as List +import Data.Monoid ( Sum(..) ) +import Data.Semigroup ( Max(..) ) +import Data.Text ( Text ) +import qualified Data.Text.Encoding as T +import Data.Word + +import Examples + +import FlatBuffers.Internal.FileIdentifier ( unsafeFileIdentifier ) +import FlatBuffers.Internal.Types ( Alignment(..), IsStruct(..) ) +import FlatBuffers.Internal.Write +import qualified FlatBuffers.Vector as Vec + +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import TestImports + + +spec :: Spec +spec = + describe "alignment" $ do + describe "Int8 are aligned to 1 byte" $ do + it "in table fields" $ require $ + prop_inlineTableFieldAlignment 1 1 (writeInt8TableField maxBound) + it "in vectors" $ require $ + prop_inlineVectorAlignment 1 1 (maxBound @Int8) + + describe "Int16 are aligned to 2 bytes" $ do + it "in table fields" $ require $ + prop_inlineTableFieldAlignment 2 2 (writeInt16TableField maxBound) + it "in vectors" $ require $ + prop_inlineVectorAlignment 2 2 (maxBound @Int16) + + describe "Int32 are aligned to 4 bytes" $ do + it "in table fields" $ require $ + prop_inlineTableFieldAlignment 4 4 (writeInt32TableField maxBound) + it "in vectors" $ require $ + prop_inlineVectorAlignment 4 4 (maxBound @Int32) + + describe "Int64 are aligned to 8 bytes" $ do + it "in table fields" $ require $ + prop_inlineTableFieldAlignment 8 8 (writeInt64TableField maxBound) + it "in vectors" $ require $ + prop_inlineVectorAlignment 8 8 (maxBound @Int64) + + describe "Word8 are aligned to 1 byte" $ do + it "in table fields" $ require $ + prop_inlineTableFieldAlignment 1 1 (writeWord8TableField maxBound) + it "in vectors" $ require $ + prop_inlineVectorAlignment 1 1 (maxBound @Word8) + + describe "Word16 are aligned to 2 bytes" $ do + it "in table fields" $ require $ + prop_inlineTableFieldAlignment 2 2 (writeWord16TableField maxBound) + it "in vectors" $ require $ + prop_inlineVectorAlignment 2 2 (maxBound @Word16) + + describe "Word32 are aligned to 4 bytes" $ do + it "in table fields" $ require $ + prop_inlineTableFieldAlignment 4 4 (writeWord32TableField maxBound) + it "in vectors" $ require $ + prop_inlineVectorAlignment 4 4 (maxBound @Word32) + + describe "Word64 are aligned to 8 bytes" $ do + it "in table fields" $ require $ + prop_inlineTableFieldAlignment 8 8 (writeWord64TableField maxBound) + it "in vectors" $ require $ + prop_inlineVectorAlignment 8 8 (maxBound @Word64) + + describe "Float are aligned to 4 bytes" $ do + it "in table fields" $ require $ + prop_inlineTableFieldAlignment 4 4 (writeFloatTableField 999.5) + it "in vectors" $ require $ + prop_inlineVectorAlignment 4 4 (999.5 :: Float) + + describe "Double are aligned to 8 bytes" $ do + it "in table fields" $ require $ + prop_inlineTableFieldAlignment 8 8 (writeDoubleTableField 999.5) + it "in vectors" $ require $ + prop_inlineVectorAlignment 8 8 (999.5 :: Double) + + describe "Bool are aligned to 1 byte" $ do + it "in table fields" $ require $ + prop_inlineTableFieldAlignment 1 1 (writeBoolTableField maxBound) + it "in vectors" $ require $ + prop_inlineVectorAlignment 1 1 (maxBound @Bool) + + + describe "structs are aligned to the specified alignment" $ do + describe "in table fields" $ do + it "Struct1" $ require $ + prop_inlineTableFieldAlignment (fromIntegral (structSizeOf @Struct1)) (structAlignmentOf @Struct1) + (writeStructTableField (struct1 1 2 3)) + + it "Struct2" $ require $ + prop_inlineTableFieldAlignment (fromIntegral (structSizeOf @Struct2)) (structAlignmentOf @Struct2) + (writeStructTableField (struct2 9)) + + it "Struct3" $ require $ + prop_inlineTableFieldAlignment (fromIntegral (structSizeOf @Struct3)) (structAlignmentOf @Struct3) + (writeStructTableField (struct3 (struct2 99) 2 3)) + + it "Struct4" $ require $ + prop_inlineTableFieldAlignment (fromIntegral (structSizeOf @Struct4)) (structAlignmentOf @Struct4) + (writeStructTableField (struct4 (struct2 99) 11 22 True)) + + describe "in vectors" $ do + it "Struct1" $ require $ + prop_inlineVectorAlignment (fromIntegral (structSizeOf @Struct1)) (structAlignmentOf @Struct1) + (struct1 maxBound maxBound maxBound) + + it "Struct2" $ require $ + prop_inlineVectorAlignment (fromIntegral (structSizeOf @Struct2)) (structAlignmentOf @Struct2) + (struct2 maxBound) + + it "Struct3" $ require $ + prop_inlineVectorAlignment (fromIntegral (structSizeOf @Struct3)) (structAlignmentOf @Struct3) + (struct3 (struct2 maxBound) maxBound maxBound) + + it "Struct4" $ require $ + prop_inlineVectorAlignment (fromIntegral (structSizeOf @Struct4)) (structAlignmentOf @Struct4) + (struct4 (struct2 maxBound) maxBound maxBound True) + + describe "Text are aligned to 4 bytes" $ do + it "in table fields" $ require prop_textTableFieldAlignment + it "in vectors" $ require prop_textVectorAlignment + + describe "Tables are properly aligned" $ do + it "in table fields" $ require prop_tableTableFieldAlignment + it "in vectors" $ require $ prop_tableVectorAlignment $ \(byteFieldsList :: [[Word8]]) -> + writeVectorTableTableField (Vec.fromList' (writeTable . fmap writeWord8TableField <$> byteFieldsList)) + + describe "Unions tables are properly aligned" $ + it "in vectors" $ require $ prop_tableVectorAlignment $ \(byteFieldsList :: [[Word8]]) -> + writeUnionValuesVectorTableField (Vec.fromList' (writeUnion 1 . writeTable . fmap writeWord8TableField <$> byteFieldsList)) + + + it "Root is aligned to `maxAlign`" $ require prop_rootAlignment + it "Root with file identifier is aligned to `maxAlign`" $ require prop_rootWithFileIdentifierAlignment + + + + +prop_inlineTableFieldAlignment :: Int32 -> Alignment -> WriteTableField -> Property +prop_inlineTableFieldAlignment size alignment tableField = property $ do + initialState <- forAllWith printFBState genInitialState + let (f, interimState) = runState (unWriteTableField tableField) initialState + let finalState = f interimState + + testBufferSizeIntegrity finalState + testMaxAlign initialState finalState alignment + + -- At most (alignment - 1) bytes can be added to the buffer as padding + let padding = coerce bufferSize finalState - coerce bufferSize initialState - size + padding `isLessThan` fromIntegral alignment + + -- The buffer is aligned to `alignment` bytes + getSum (bufferSize finalState) `mod` fromIntegral alignment === 0 + + +prop_inlineVectorAlignment :: + WriteVectorElement a + => Coercible (WriteVector a) WriteTableField + => Int32 -> Alignment -> a -> Property +prop_inlineVectorAlignment elemSize elemAlignment sampleElem = property $ do + initialState <- forAllWith printFBState genInitialState + vectorLength <- forAll $ Gen.int (Range.linear 0 5) + + let vec = Vec.fromList' (List.replicate vectorLength sampleElem) + let (writeUOffset, finalState) = runState (unWriteTableField (coerce vec)) initialState + + testBufferSizeIntegrity finalState + testMaxAlign initialState finalState (elemAlignment `max` 4) + testUOffsetAlignment writeUOffset + + -- The entire vector, with the size prefix, is aligned to 4 bytes + bufferSize finalState `isAlignedTo` 4 + -- The vector, without the size prefix, is aligned to `elemAlignment` bytes + (bufferSize finalState - 4) `isAlignedTo` fromIntegral elemAlignment + + -- At most `n` bytes can be added to the buffer as padding, + -- `n` being the biggest thing we're aligning to: the vector's elements or the size prefix. + let vectorByteCount = 4 + elemSize * fromIntegral vectorLength + let padding = coerce bufferSize finalState - coerce bufferSize initialState - vectorByteCount + padding `isLessThan` (fromIntegral elemAlignment `max` 4) + + +prop_textTableFieldAlignment :: Property +prop_textTableFieldAlignment = property $ do + initialState <- forAllWith printFBState genInitialState + text <- forAll $ Gen.text (Range.linear 0 30) Gen.unicode + + let (writeUOffset, finalState) = runState (unWriteTableField (writeTextTableField text)) initialState + + testBufferSizeIntegrity finalState + testMaxAlign initialState finalState 4 + testUOffsetAlignment writeUOffset + bufferSize finalState `isAlignedTo` 4 + + -- At most 4 bytes can be added to the buffer as padding + let textByteCount = BS.length (T.encodeUtf8 text) + 1 + let padding = bufferSize finalState - bufferSize initialState - fromIntegral textByteCount - 4 + padding `isLessThan` 4 + + +prop_textVectorAlignment :: Property +prop_textVectorAlignment = property $ do + initialState <- forAllWith printFBState genInitialState + texts <- forAll $ Gen.list (Range.linear 0 5) (Gen.text (Range.linear 0 30) Gen.unicode) + + let (writeUOffset, finalState) = runState (unWriteTableField (writeVectorTextTableField (Vec.fromList' texts))) initialState + + testBufferSizeIntegrity finalState + testMaxAlign initialState finalState 4 + testUOffsetAlignment writeUOffset + bufferSize finalState `isAlignedTo` 4 + + let initialBuffer = B.toLazyByteString (builder initialState) + let finalBuffer = B.toLazyByteString (builder finalState) + + let jumpToTextAtIndex :: Int -> ByteString + jumpToTextAtIndex index = + flip G.runGet finalBuffer $ do + G.skip (4 + index * 4) + offset <- G.getInt32le + G.skip (fromIntegral offset - 4) + G.getRemainingLazyByteString + + let checkTextAlignment :: (Text, Int) -> ByteString -> PropertyT IO ByteString + checkTextAlignment (text, index) previousBuffer = do + let bufferWithText = jumpToTextAtIndex index + BSL.length bufferWithText `isAlignedTo` 4 + + let textByteCount = BS.length (T.encodeUtf8 text) + 1 + let padding = BSL.length bufferWithText - BSL.length previousBuffer - fromIntegral textByteCount - 4 + padding `isLessThan` 4 + + pure bufferWithText + + -- Cycle through every text, right to left, see if it has been properly padded/aligned + -- relative to the bytestring that follows it. + -- When we're done, `bufferWithTexts` will point to the position where the texts begin. + bufferWithTexts <- foldrM checkTextAlignment initialBuffer (texts `zip` [0..]) + + -- At most 4 bytes can be added to the buffer as padding, + -- between the vector of offsets and the texts. + let padding = BSL.length finalBuffer - BSL.length bufferWithTexts - (4 + 4 * fromIntegral (List.length texts)) + padding `isLessThan` 4 + + +prop_tableTableFieldAlignment :: Property +prop_tableTableFieldAlignment = property $ do + initialState <- forAllWith printFBState genInitialState + byteFields <- forAll $ Gen.list (Range.linear 0 20) (Gen.word8 Range.linearBounded) + + let table = writeTable (writeWord8TableField <$> byteFields) + let (writeUOffset, finalState) = runState (unWriteTableField (writeTableTableField table)) initialState + + testBufferSizeIntegrity finalState + testMaxAlign initialState finalState 4 + testUOffsetAlignment writeUOffset + + let bufferWithVTable = B.toLazyByteString (builder finalState) + let bufferWithUOffset = B.toLazyByteString (builder (writeUOffset finalState)) + let bufferWithTable = flip G.runGet bufferWithUOffset $ do + uoffset <- G.getInt32le + G.skip (fromIntegral uoffset - 4) + G.getRemainingLazyByteString + + BSL.length bufferWithVTable `isAlignedTo` 2 + BSL.length bufferWithTable `isAlignedTo` 4 + + let tablePadding = BSL.length bufferWithTable - fromIntegral (bufferSize initialState) - 4 - fromIntegral (List.length byteFields) + let vtablePadding = BSL.length bufferWithVTable - BSL.length bufferWithTable - 2 - 2 - fromIntegral (2 * List.length byteFields) + + tablePadding `isLessThan` 4 + vtablePadding === 0 + + +prop_tableVectorAlignment :: ([[Word8]] -> WriteTableField) -> Property +prop_tableVectorAlignment toVectorOfTables = property $ do + initialState <- forAllWith printFBState genInitialState + byteFieldsList <- forAll $ Gen.list (Range.linear 0 20) (Gen.list (Range.linear 0 20) (Gen.word8 Range.linearBounded)) + + let (writeUOffset, finalState) = runState (unWriteTableField (toVectorOfTables byteFieldsList)) initialState + + testBufferSizeIntegrity finalState + testMaxAlign initialState finalState 4 + testUOffsetAlignment writeUOffset + bufferSize finalState `isAlignedTo` 4 + + let initialBuffer = B.toLazyByteString (builder initialState) + let finalBuffer = B.toLazyByteString (builder finalState) + + let jumpToTableAtIndex :: Int -> (ByteString, Maybe ByteString) + jumpToTableAtIndex index = + flip G.runGet finalBuffer $ do + G.skip (4 + index * 4) + offset <- G.getInt32le + G.skip (fromIntegral offset - 4) + soffset <- G.getInt32le + let table = BSL.drop (4 + (fromIntegral index * 4) + fromIntegral offset) finalBuffer + let vtableMaybe = + if soffset < 0 + then Nothing -- used a cached vtable, so there's no need to do any further checking + else Just $ BSL.drop (4 + (fromIntegral index * 4) + fromIntegral offset - fromIntegral soffset) finalBuffer + pure (table, vtableMaybe) + + let checkTableAlignment :: ([Word8], Int) -> ByteString -> PropertyT IO ByteString + checkTableAlignment (fields, index) previousBuffer = do + let (bufferWithTable, bufferWithVtableMaybe) = jumpToTableAtIndex index + + BSL.length bufferWithTable `isAlignedTo` 4 + + let tablePadding = BSL.length bufferWithTable - BSL.length previousBuffer - 4 - fromIntegral (List.length fields) + tablePadding `isLessThan` 4 + + case bufferWithVtableMaybe of + Nothing -> + pure bufferWithTable + Just bufferWithVtable -> do + BSL.length bufferWithVtable `isAlignedTo` 2 + + let vtablePadding = BSL.length bufferWithVtable - BSL.length bufferWithTable - 2 - 2 - fromIntegral (2 * List.length fields) + vtablePadding === 0 + + pure bufferWithVtable + + bufferWithTable <- foldrM checkTableAlignment initialBuffer (byteFieldsList `zip` [0..]) + + -- At most 4 bytes can be added to the buffer as padding, + -- between the vector of offsets and the tables. + let padding = BSL.length finalBuffer - BSL.length bufferWithTable - (4 + 4 * fromIntegral (List.length byteFieldsList)) + padding `isLessThan` 4 + + + +prop_rootAlignment :: Property +prop_rootAlignment = property $ do + initialState <- forAllWith printFBState genInitialState + byteFields <- forAll $ Gen.list (Range.linear 0 20) (Gen.word8 Range.linearBounded) + + let finalBuffer = encodeState initialState $ writeTable (writeWord8TableField <$> byteFields) + + let bufferWithVtable = + flip G.runGet finalBuffer $ do + uoffset <- G.getInt32le + G.skip (fromIntegral uoffset - 4) + soffset <- G.getInt32le + pure $ BSL.drop (fromIntegral (uoffset - soffset)) finalBuffer + + BSL.length finalBuffer `isAlignedTo` (fromIntegral (getMax (maxAlign initialState)) `max` 4) + + -- At most 14 bytes can be used as padding. + -- E.g. If the buffer contains 30 bytes and we need to align to 16 bytes, + -- we need to write 14 zeroes + 4 bytes for the root uoffste + -- (and end up with a buffer with 48 bytes, a multiple of 16). + -- + -- Note that the buffer cannot possibly contain 29 or 31 bytes because the last thing to be written + -- is a table or a vtable (aligned to 2 or 4 bytes). + -- If the buffer had 28 bytes, we wouldn't need to pad it. + -- If the buffer had 32 bytes, we'd pad it with 12 zeroes. + let padding = BSL.length finalBuffer - BSL.length bufferWithVtable - 4 + padding `isLessThan` 15 + + +prop_rootWithFileIdentifierAlignment :: Property +prop_rootWithFileIdentifierAlignment = property $ do + initialState <- forAllWith printFBState genInitialState + byteFields <- forAll $ Gen.list (Range.linear 0 20) (Gen.word8 Range.linearBounded) + + let finalBuffer = + encodeStateWithFileIdentifier initialState (unsafeFileIdentifier "ABCD") $ + writeTable (writeWord8TableField <$> byteFields) + + let bufferWithVtable = + flip G.runGet finalBuffer $ do + uoffset <- G.getInt32le + G.skip (fromIntegral uoffset - 4) + soffset <- G.getInt32le + pure $ BSL.drop (fromIntegral (uoffset - soffset)) finalBuffer + + BSL.length finalBuffer `isAlignedTo` (fromIntegral (getMax (maxAlign initialState)) `max` 4) + + -- At most 14 bytes can be used as padding. + -- E.g. If the buffer contains 26 bytes and we need to align to 16 bytes, + -- we need to write 14 zeroes + 4 bytes for the file identifier + 4 bytes for the root uoffset + -- (and end up with a buffer with 48 bytes, a multiple of 16). + let padding = BSL.length finalBuffer - BSL.length bufferWithVtable - 4 - 4 + padding `isLessThan` 15 + + + +testUOffsetAlignment :: (FBState -> FBState) -> PropertyT IO () +testUOffsetAlignment writeUOffset = do + initialState <- forAllWith printFBState genInitialState + let finalState = writeUOffset initialState + + testBufferSizeIntegrity finalState + testMaxAlign initialState finalState 4 + bufferSize finalState `isAlignedTo` 4 + + -- At most 4 bytes can be added to the buffer as padding + let padding = bufferSize finalState - bufferSize initialState - 4 + padding `isLessThan` 4 + + +-- | `bufferSize` should always be equal to the size of the bytestring produced by the builder +testBufferSizeIntegrity :: FBState -> PropertyT IO () +testBufferSizeIntegrity state = + bufferSize state === fromIntegral (BSL.length (B.toLazyByteString (builder state))) + +-- | `maxAlign` is either the previous `maxAlign` or the alignment of the last thing we wrote +-- to the buffer, whichever's greatest +testMaxAlign :: FBState -> FBState -> Alignment -> PropertyT IO () +testMaxAlign initialState finalState alignment = + maxAlign finalState === maxAlign initialState `max` coerce alignment + +isAlignedTo :: Integral bufferSize => bufferSize -> Int32 -> PropertyT IO () +isAlignedTo size alignment = + fromIntegral size `mod` alignment === 0 + +isLessThan :: (HasCallStack, MonadTest m, Show a, Num a, Ord a) => a -> a -> m () +isLessThan x upper = do + diff x (>=) 0 + diff x (<) upper + +genInitialState :: Gen FBState +genInitialState = do + bytes <- Gen.bytes (Range.linear 0 50) + maxAlign <- Gen.element [1, 2, 4, 8, 16] + pure $ FBState + { builder = B.byteString bytes + , bufferSize = fromIntegral $ BS.length bytes + , maxAlign = maxAlign + , cache = mempty + } + +printFBState :: FBState -> String +printFBState (FBState builder bufferSize maxAlign cache) = + fold + [ "FBState" + , "\n { builder = " + , "\n[ " <> showBuffer (B.toLazyByteString builder) <> " ]" + , "\n , bufferSize = " <> show bufferSize + , "\n , maxAlign = " <> show maxAlign + , "\n , cache = " <> show cache + , "\n }" + ] + +deriving instance Real a => Real (Sum a) +deriving instance Enum a => Enum (Sum a) +deriving instance Integral a => Integral (Sum a) diff --git a/test/FlatBuffers/Integration/HaskellToScalaSpec.hs b/test/FlatBuffers/Integration/HaskellToScalaSpec.hs new file mode 100644 --- /dev/null +++ b/test/FlatBuffers/Integration/HaskellToScalaSpec.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module FlatBuffers.Integration.HaskellToScalaSpec where + +import Data.Aeson ( (.=), Value(..), object ) +import qualified Data.Aeson as J +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.UTF8 as BSLU +import Data.Int + +import Examples + +import FlatBuffers +import qualified FlatBuffers.Vector as Vec + +import Network.HTTP.Client +import Network.HTTP.Types.Status ( statusCode ) + +import TestImports + + +spec :: Spec +spec = + describe "Haskell encoders should be consistent with Scala decoders" $ + it "VectorOfUnions" $ do + testCase + "VectorOfUnions" + (encode $ vectorOfUnions + (Just (Vec.singleton (weaponSword (sword (Just "hi"))))) + (Vec.singleton (weaponSword (sword (Just "hi2")))) + ) + (object + [ "xs" .= [object ["x" .= String "hi"]] + , "xsReq" .= [object ["x" .= String "hi2"]] + ] + ) + testCase + "VectorOfUnions" + (encode $ vectorOfUnions + (Just (Vec.singleton (weaponSword (sword Nothing)))) + (Vec.singleton (weaponAxe (axe Nothing))) + ) + (object ["xs" .= [object ["x" .= Null]], "xsReq" .= [object ["y" .= Number 0]]]) + testCase + "VectorOfUnions" + (encode $ vectorOfUnions + (Just $ Vec.fromList' + [ weaponSword (sword (Just "hi")) + , none + , weaponAxe (axe (Just maxBound)) + , weaponSword (sword (Just "oi")) + ] + ) + (Vec.fromList' + [ weaponSword (sword (Just "hi2")) + , none + , weaponAxe (axe (Just minBound)) + , weaponSword (sword (Just "oi2")) + ] + ) + ) + (object + [ "xs" .= + [ object ["x" .= String "hi"] + , String "NONE" + , object ["y" .= maxBound @Int32] + , object ["x" .= String "oi"] + ] + , "xsReq" .= + [ object ["x" .= String "hi2"] + , String "NONE" + , object ["y" .= minBound @Int32] + , object ["x" .= String "oi2"] + ] + ]) + testCase + "VectorOfUnions" + (encode $ vectorOfUnions (Just Vec.empty) Vec.empty) + (object ["xs" .= [] @Value, "xsReq" .= [] @Value]) + testCase + "VectorOfUnions" + (encode $ vectorOfUnions Nothing Vec.empty) + (object ["xs" .= [] @Value, "xsReq" .= [] @Value]) + + +testCase :: HasCallStack => String -> BSL.ByteString -> J.Value -> IO () +testCase flatbufferName bs expectedJson = do + man <- newManager defaultManagerSettings + req <- parseRequest ("http://localhost:8080/" ++ flatbufferName) + let req' = req {method = "POST", requestBody = RequestBodyLBS bs} + rsp <- httpLbs req' man + case statusCode $ responseStatus rsp of + 200 -> + (PrettyJson <$> J.decode @J.Value (responseBody rsp)) `shouldBe` + Just (PrettyJson expectedJson) + _ -> expectationFailure ("Failed: " ++ BSLU.toString (responseBody rsp)) diff --git a/test/FlatBuffers/Integration/RoundTripThroughFlatcSpec.hs b/test/FlatBuffers/Integration/RoundTripThroughFlatcSpec.hs new file mode 100644 --- /dev/null +++ b/test/FlatBuffers/Integration/RoundTripThroughFlatcSpec.hs @@ -0,0 +1,658 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} + +{- HLINT ignore "Reduce duplication" -} +{- HLINT ignore "Use list comprehension" -} + +module FlatBuffers.Integration.RoundTripThroughFlatcSpec where + +import Control.Applicative ( liftA3 ) + +import Data.Aeson ( (.=), Value(..), object ) +import qualified Data.Aeson as J +import qualified Data.ByteString.Lazy as BSL +import Data.Int +import Data.Maybe ( isNothing ) +import Data.Proxy +import Data.Typeable ( Typeable, typeRep ) +import Data.Word + +import Examples + +import FlatBuffers +import qualified FlatBuffers.Vector as Vec + +import qualified System.Directory as Dir +import qualified System.Process as Sys + +import TestImports + +{- + +These tests ensure our encoders/decoders are consistent with flatc's. +Each test: + - creates a flatbuffer using haskell's encoders + - saves it to a .bin file + - asks flatc to convert it to a .json file + - reads the json into memory, checks it against the expected json + - asks flatc to convert that .json file back to .bin + - reads the flatbuffer created by flatc into memory, checks that it contains the same data as we started with. + +See "Using flatc as a Conversion Tool" at the bottom: + https://google.github.io/flatbuffers/flatbuffers_guide_tutorial.html + +Note that flatc is not yet able to convert vector of unions from binary to json (even though +json -> binary works), so we can't use flatc to test this. +Instead, we check our encoders against java's decoders by +sending requests to a Scala server: FlatBuffers.Integration.HaskellToScalaSpec. + +-} + +spec :: Spec +spec = + describe "Haskell encoders/decoders should be consistent with flatc" $ + beforeAll_ (Dir.createDirectoryIfMissing True "temp") $ do + describe "Primitives" $ do + it "present with maxBound" $ do + (json, decoded) <- flatcWithFileIdentifier $ 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") + + json `shouldBeJson` object + [ "a" .= maxBound @Word8 + , "b" .= maxBound @Word16 + , "c" .= maxBound @Word32 + , "d" .= maxBound @Word64 + , "e" .= maxBound @Int8 + , "f" .= maxBound @Int16 + , "g" .= maxBound @Int32 + , "h" .= maxBound @Int64 + , "i" .= Number 1234.560059 + , "j" .= Number 2873242.827819999773 + , "k" .= True + , "l" .= String "hi 👬 bye" + ] + + primitivesA decoded `shouldBe` Right maxBound + primitivesB decoded `shouldBe` Right maxBound + primitivesC decoded `shouldBe` Right maxBound + primitivesD decoded `shouldBe` Right maxBound + primitivesE decoded `shouldBe` Right maxBound + primitivesF decoded `shouldBe` Right maxBound + primitivesG decoded `shouldBe` Right maxBound + primitivesH decoded `shouldBe` Right maxBound + primitivesI decoded `shouldBe` Right 1234.56 + primitivesJ decoded `shouldBe` Right 2873242.82782 + primitivesK decoded `shouldBe` Right True + primitivesL decoded `shouldBe` Right (Just "hi 👬 bye") + + it "present with minBound" $ do + (json, decoded) <- flatcWithFileIdentifier $ primitives + (Just minBound) (Just minBound) (Just minBound) (Just minBound) + (Just minBound) (Just minBound) (Just minBound) (Just minBound) + (Just 1234.56) (Just 2873242.82782) (Just False) (Just "hi 👬 bye") + + json `shouldBeJson` object + [ "e" .= minBound @Int8 + , "f" .= minBound @Int16 + , "g" .= minBound @Int32 + , "h" .= minBound @Int64 + , "i" .= Number 1234.560059 + , "j" .= Number 2873242.827819999773 + , "l" .= String "hi 👬 bye" + ] + + primitivesA decoded `shouldBe` Right minBound + primitivesB decoded `shouldBe` Right minBound + primitivesC decoded `shouldBe` Right minBound + primitivesD decoded `shouldBe` Right minBound + primitivesE decoded `shouldBe` Right minBound + primitivesF decoded `shouldBe` Right minBound + primitivesG decoded `shouldBe` Right minBound + primitivesH decoded `shouldBe` Right minBound + primitivesI decoded `shouldBe` Right 1234.56 + primitivesJ decoded `shouldBe` Right 2873242.82782 + primitivesK decoded `shouldBe` Right False + primitivesL decoded `shouldBe` Right (Just "hi 👬 bye") + + it "present with defaults" $ do + (json, decoded) <- flatcWithFileIdentifier $ primitives + (Just 0) (Just 0) (Just 0) (Just 0) + (Just 0) (Just 0) (Just 0) (Just 0) + (Just 0) (Just 0) (Just False) (Just "hi 👬 bye") + + json `shouldBeJson` object + [ "l" .= String "hi 👬 bye" + ] + + primitivesA decoded `shouldBe` Right 0 + primitivesB decoded `shouldBe` Right 0 + primitivesC decoded `shouldBe` Right 0 + primitivesD decoded `shouldBe` Right 0 + primitivesE decoded `shouldBe` Right 0 + primitivesF decoded `shouldBe` Right 0 + primitivesG decoded `shouldBe` Right 0 + primitivesH decoded `shouldBe` Right 0 + primitivesI decoded `shouldBe` Right 0 + primitivesJ decoded `shouldBe` Right 0 + primitivesK decoded `shouldBe` Right False + primitivesL decoded `shouldBe` Right (Just "hi 👬 bye") + + it "missing" $ do + (json, decoded) <- flatcWithFileIdentifier $ primitives + Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing + + json `shouldBeJson` object [] + + primitivesA decoded `shouldBe` Right 0 + primitivesB decoded `shouldBe` Right 0 + primitivesC decoded `shouldBe` Right 0 + primitivesD decoded `shouldBe` Right 0 + primitivesE decoded `shouldBe` Right 0 + primitivesF decoded `shouldBe` Right 0 + primitivesG decoded `shouldBe` Right 0 + primitivesH decoded `shouldBe` Right 0 + primitivesI decoded `shouldBe` Right 0 + primitivesJ decoded `shouldBe` Right 0 + primitivesK decoded `shouldBe` Right False + primitivesL decoded `shouldBe` Right Nothing + + describe "Enums" $ do + let readStructWithEnum = (liftA3 . liftA3) (,,) structWithEnumX (fmap toColor <$> structWithEnumY) structWithEnumZ + it "present" $ do + (json, decoded) <- flatc $ 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])) + + json `shouldBeJson` object + [ "x" .= String "Gray" + , "y" .= object [ "x" .= Number 11, "y" .= String "Red", "z" .= Number 22 ] + , "xs" .= [ String "Black", String "Blue", String "Green" ] + , "ys" .= + [ object [ "x" .= Number 33, "y" .= String "Red", "z" .= Number 44 ] + , object [ "x" .= Number 55, "y" .= String "Green", "z" .= Number 66 ] + ] + ] + + toColor <$> enumsX decoded `shouldBe` Right (Just ColorGray) + (enumsY decoded >>= traverse readStructWithEnum) `shouldBe` Right (Just (11, Just ColorRed, 22)) + (enumsXs decoded >>= traverse Vec.toList) `shouldBe` Right (Just [fromColor ColorBlack, fromColor ColorBlue, fromColor ColorGreen]) + (enumsYs decoded >>= traverse Vec.toList >>= traverse (traverse readStructWithEnum)) `shouldBe` + Right (Just + [ (33, Just ColorRed, 44) + , (55, Just ColorGreen, 66) + ]) + + it "present with defaults" $ do + (json, decoded) <- flatc $ enums + (Just (fromColor ColorGreen)) + Nothing + Nothing + Nothing + + json `shouldBeJson` object [ ] + + toColor <$> enumsX decoded `shouldBe` Right (Just ColorGreen) + enumsY decoded `shouldBeRightAnd` isNothing + enumsXs decoded `shouldBeRightAnd` isNothing + enumsYs decoded `shouldBeRightAnd` isNothing + + it "missing" $ do + (json, decoded) <- flatc $ enums Nothing Nothing Nothing Nothing + + json `shouldBeJson` object [ ] + + toColor <$> enumsX decoded `shouldBe` Right (Just ColorGreen) + enumsY decoded `shouldBeRightAnd` isNothing + enumsXs decoded `shouldBeRightAnd` isNothing + enumsYs decoded `shouldBeRightAnd` isNothing + + describe "Structs" $ do + it "present" $ 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 + (json, decoded) <- flatc $ structs + (Just (struct1 1 2 3)) + (Just (struct2 11)) + (Just (struct3 (struct2 22) 33 44)) + (Just (struct4 (struct2 55) 66 77 True)) + + json `shouldBeJson` object + [ "a" .= object ["x" .= Number 1, "y" .= Number 2, "z" .= Number 3] + , "b" .= object ["x" .= Number 11] + , "c" .= object ["x" .= object ["x" .= Number 22], "y" .= Number 33, "z" .= Number 44 ] + , "d" .= object ["w" .= object ["x" .= Number 55], "x" .= Number 66, "y" .= Number 77, "z" .= True ] + ] + + s1 <- evalRightJust $ structsA decoded + s2 <- evalRightJust $ structsB decoded + s3 <- evalRightJust $ structsC decoded + s4 <- evalRightJust $ structsD decoded + + 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 + (json, decoded) <- flatc $ structs + Nothing + Nothing + Nothing + Nothing + + json `shouldBeJson` object [ ] + + structsA decoded `shouldBeRightAnd` isNothing + structsB decoded `shouldBeRightAnd` isNothing + structsC decoded `shouldBeRightAnd` isNothing + structsD decoded `shouldBeRightAnd` isNothing + + describe "Nested tables" $ do + it "present" $ do + (json, decoded) <- flatc $ nestedTables (Just (table1 (Just (table2 (Just 11))) (Just 22))) + + json `shouldBeJson` object + [ "x" .= object + [ "x" .= object + [ "x" .= Number 11 + ] + , "y" .= Number 22 + ] + ] + + t1 <- evalRightJust $ nestedTablesX decoded + t2 <- evalRightJust $ table1X t1 + + table1Y t1 `shouldBe` Right 22 + table2X t2 `shouldBe` Right 11 + + it "missing table2" $ do + (json, decoded) <- flatc $ nestedTables (Just (table1 Nothing (Just 22))) + + json `shouldBeJson` object + [ "x" .= object + [ "y" .= Number 22 + ] + ] + + t1 <- evalRightJust $ nestedTablesX decoded + table1X t1 `shouldBeRightAnd` isNothing + table1Y t1 `shouldBe` Right 22 + + it "missing table1" $ do + (json, decoded) <- flatc $ nestedTables Nothing + + json `shouldBeJson` object [] + + nestedTablesX decoded `shouldBeRightAnd` isNothing + + + describe "Union" $ + describe "present" $ do + it "with sword" $ do + (json, decoded) <- flatc $ tableWithUnion (weaponSword (sword (Just "hi"))) + + json `shouldBeJson` object + [ "uni" .= object [ "x" .= String "hi" ] + , "uni_type" .= String "Sword" + ] + + tableWithUnionUni decoded `shouldBeRightAndExpect` \case + Union (WeaponSword x) -> swordX x `shouldBe` Right (Just "hi") + + it "with axe" $ do + (json, decoded) <- flatc $ tableWithUnion (weaponAxe (axe (Just maxBound))) + + json `shouldBeJson` object + [ "uni" .= object [ "y" .= maxBound @Int32 ] + , "uni_type" .= String "Axe" + ] + + tableWithUnionUni decoded `shouldBeRightAndExpect` \case + Union (WeaponAxe x) -> axeY x `shouldBe` Right maxBound + + it "with none" $ do + (json, decoded) <- flatc $ tableWithUnion none + + json `shouldBeJson` object [] + + tableWithUnionUni decoded `shouldBeRightAndExpect` \case + UnionNone -> pure () + + + describe "Vectors" $ do + it "non-empty" $ do + (json, decoded) <- flatc $ 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.333333])) + (Just (Vec.fromList' [-12e98, 0, 3.33333333333333333333])) + (Just (Vec.fromList' [True, False, True])) + (Just (Vec.fromList' ["hi 👬 bye", "", "world"])) + + json `shouldBeJson` object + [ "a" .= [ minBound @Word8, 0, maxBound @Word8 ] + , "b" .= [ minBound @Word16, 0, maxBound @Word16 ] + , "c" .= [ minBound @Word32, 0, maxBound @Word32 ] + , "d" .= [ minBound @Word64, 0, maxBound @Word64 ] + , "e" .= [ minBound @Int8, 0, maxBound @Int8 ] + , "f" .= [ minBound @Int16, 0, maxBound @Int16 ] + , "g" .= [ minBound @Int32, 0, maxBound @Int32 ] + , "h" .= [ minBound @Int64, 0, maxBound @Int64 ] + , "i" .= [ Number (-12e9), Number 0, Number 3.333333 ] + , "j" .= [ Number (-1.200000000000000057936847176226483074592535164143811899621896087972531077696693922075702102406987776e99), Number 0.0, Number 3.333333333333 ] + , "k" .= [ True, False, True ] + , "l" .= [ String "hi 👬 bye", String "", String "world"] + ] + + (vectorsA decoded >>= traverse Vec.toList) `shouldBe` Right (Just [minBound, 0, maxBound]) + (vectorsB decoded >>= traverse Vec.toList) `shouldBe` Right (Just [minBound, 0, maxBound]) + (vectorsC decoded >>= traverse Vec.toList) `shouldBe` Right (Just [minBound, 0, maxBound]) + (vectorsD decoded >>= traverse Vec.toList) `shouldBe` Right (Just [minBound, 0, maxBound]) + (vectorsE decoded >>= traverse Vec.toList) `shouldBe` Right (Just [minBound, 0, maxBound]) + (vectorsF decoded >>= traverse Vec.toList) `shouldBe` Right (Just [minBound, 0, maxBound]) + (vectorsG decoded >>= traverse Vec.toList) `shouldBe` Right (Just [minBound, 0, maxBound]) + (vectorsH decoded >>= traverse Vec.toList) `shouldBe` Right (Just [minBound, 0, maxBound]) + (vectorsI decoded >>= traverse Vec.toList) `shouldBe` Right (Just [-12e9, 0, 3.333333]) + (vectorsJ decoded >>= traverse Vec.toList) `shouldBe` Right (Just [-12e98, 0, 3.333333333333]) + (vectorsK decoded >>= traverse Vec.toList) `shouldBe` Right (Just [True, False, True]) + (vectorsL decoded >>= traverse Vec.toList) `shouldBe` Right (Just ["hi 👬 bye", "", "world"]) + + it "empty" $ do + (json, decoded) <- flatc $ 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) + + json `shouldBeJson` object + [ "a" .= [] @Value + , "b" .= [] @Value + , "c" .= [] @Value + , "d" .= [] @Value + , "e" .= [] @Value + , "f" .= [] @Value + , "g" .= [] @Value + , "h" .= [] @Value + , "i" .= [] @Value + , "j" .= [] @Value + , "k" .= [] @Value + , "l" .= [] @Value + ] + + (vectorsA decoded >>= traverse Vec.toList) `shouldBe` Right (Just []) + (vectorsB decoded >>= traverse Vec.toList) `shouldBe` Right (Just []) + (vectorsC decoded >>= traverse Vec.toList) `shouldBe` Right (Just []) + (vectorsD decoded >>= traverse Vec.toList) `shouldBe` Right (Just []) + (vectorsE decoded >>= traverse Vec.toList) `shouldBe` Right (Just []) + (vectorsF decoded >>= traverse Vec.toList) `shouldBe` Right (Just []) + (vectorsG decoded >>= traverse Vec.toList) `shouldBe` Right (Just []) + (vectorsH decoded >>= traverse Vec.toList) `shouldBe` Right (Just []) + (vectorsI decoded >>= traverse Vec.toList) `shouldBe` Right (Just []) + (vectorsJ decoded >>= traverse Vec.toList) `shouldBe` Right (Just []) + (vectorsK decoded >>= traverse Vec.toList) `shouldBe` Right (Just []) + (vectorsL decoded >>= traverse Vec.toList) `shouldBe` Right (Just []) + + it "missing" $ do + (json, decoded) <- flatc $ vectors + Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing + + json `shouldBeJson` object [] + + vectorsA decoded `shouldBeRightAnd` isNothing + vectorsB decoded `shouldBeRightAnd` isNothing + vectorsC decoded `shouldBeRightAnd` isNothing + vectorsD decoded `shouldBeRightAnd` isNothing + vectorsE decoded `shouldBeRightAnd` isNothing + vectorsF decoded `shouldBeRightAnd` isNothing + vectorsG decoded `shouldBeRightAnd` isNothing + vectorsH decoded `shouldBeRightAnd` isNothing + vectorsI decoded `shouldBeRightAnd` isNothing + vectorsJ decoded `shouldBeRightAnd` isNothing + vectorsK decoded `shouldBeRightAnd` isNothing + vectorsL decoded `shouldBeRightAnd` isNothing + + describe "VectorOfTables" $ do + it "non empty" $ do + (json, decoded) <- flatc $ vectorOfTables + (Just $ Vec.fromList' + [ axe (Just minBound) + , axe (Just 0) + , axe (Just maxBound) + ] + ) + + json `shouldBeJson` object + [ "xs" .= + [ object [ "y" .= minBound @Int32 ] + , object [ ] + , object [ "y" .= maxBound @Int32 ] + ] + ] + + xs <- evalRightJust $ vectorOfTablesXs decoded + (Vec.toList xs >>= traverse axeY) `shouldBe` Right [minBound, 0, maxBound] + + it "empty" $ do + (json, decoded) <- flatc $ vectorOfTables (Just Vec.empty) + + json `shouldBeJson` object [ "xs" .= [] @Value] + + xs <- evalRightJust $ vectorOfTablesXs decoded + Vec.length xs `shouldBe` Right 0 + + it "missing" $ do + (json, decoded) <- flatc $ vectorOfTables Nothing + + json `shouldBeJson` object [] + + vectorOfTablesXs decoded `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 + (json, decoded) <- flatc $ 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])) + + json `shouldBeJson` object + [ "as" .= + [ object [ "x" .= Number 1, "y" .= Number 2, "z" .= Number 3] + , object [ "x" .= Number 4, "y" .= Number 5, "z" .= Number 6] + ] + , "bs" .= + [ object ["x" .= Number 101] + , object ["x" .= Number 102] + , object ["x" .= Number 103] + ] + , "cs" .= + [ object ["x" .= object ["x" .= Number 104], "y" .= Number 105, "z" .= Number 106 ] + , object ["x" .= object ["x" .= Number 107], "y" .= Number 108, "z" .= Number 109 ] + , object ["x" .= object ["x" .= Number 110], "y" .= Number 111, "z" .= Number 112 ] + ] + , "ds" .= + [ object ["w" .= object ["x" .= Number 120], "x" .= Number 121, "y" .= Number 122, "z" .= True ] + , object ["w" .= object ["x" .= Number 123], "x" .= Number 124, "y" .= Number 125, "z" .= False ] + , object ["w" .= object ["x" .= Number 126], "x" .= Number 127, "y" .= Number 128, "z" .= True ] + ] + ] + + as <- evalRightJust (vectorOfStructsAs decoded) >>= (evalRight . Vec.toList) + bs <- evalRightJust (vectorOfStructsBs decoded) >>= (evalRight . Vec.toList) + cs <- evalRightJust (vectorOfStructsCs decoded) >>= (evalRight . Vec.toList) + ds <- evalRightJust (vectorOfStructsDs decoded) >>= (evalRight . Vec.toList) + + traverse readStruct1 as `shouldBe` Right [(1,2,3), (4,5,6)] + traverse readStruct2 bs `shouldBe` Right [101, 102, 103] + traverse readStruct3 cs `shouldBe` Right [(104, 105, 106), (107, 108, 109), (110, 111, 112)] + traverse readStruct4 ds `shouldBe` Right [(120, 121, 122, True), (123, 124, 125, False), (126, 127, 128, True)] + + it "empty" $ do + (json, decoded) <- flatc $ vectorOfStructs + (Just Vec.empty) (Just Vec.empty) (Just Vec.empty) (Just Vec.empty) + + json `shouldBeJson` object [ "as" .= [] @Value, "bs" .= [] @Value, "cs" .= [] @Value, "ds" .= [] @Value ] + + as <- evalRightJust $ vectorOfStructsAs decoded + bs <- evalRightJust $ vectorOfStructsBs decoded + cs <- evalRightJust $ vectorOfStructsCs decoded + ds <- evalRightJust $ vectorOfStructsCs decoded + Vec.length as `shouldBe` Right 0 + Vec.length bs `shouldBe` Right 0 + Vec.length cs `shouldBe` Right 0 + Vec.length ds `shouldBe` Right 0 + + it "missing" $ do + (json, decoded) <- flatc $ vectorOfStructs Nothing Nothing Nothing Nothing + + json `shouldBeJson` object [] + + vectorOfStructsAs decoded `shouldBeRightAnd` isNothing + vectorOfStructsBs decoded `shouldBeRightAnd` isNothing + vectorOfStructsCs decoded `shouldBeRightAnd` isNothing + vectorOfStructsDs decoded `shouldBeRightAnd` isNothing + + + describe "ScalarsWithDefaults" $ do + let runTest buffer = do + (json, decoded) <- flatc buffer + + json `shouldBeJson` object [ ] + + scalarsWithDefaultsA decoded `shouldBe` Right 8 + scalarsWithDefaultsB decoded `shouldBe` Right 16 + scalarsWithDefaultsC decoded `shouldBe` Right 32 + scalarsWithDefaultsD decoded `shouldBe` Right 64 + scalarsWithDefaultsE decoded `shouldBe` Right (-1) + scalarsWithDefaultsF decoded `shouldBe` Right (-2) + scalarsWithDefaultsG decoded `shouldBe` Right (-4) + scalarsWithDefaultsH decoded `shouldBe` Right (-8) + scalarsWithDefaultsI decoded `shouldBe` Right 3.9 + scalarsWithDefaultsJ decoded `shouldBe` Right (-2.3e10) + scalarsWithDefaultsK decoded `shouldBe` Right True + scalarsWithDefaultsL decoded `shouldBe` Right False + toColor <$> scalarsWithDefaultsM decoded `shouldBe` Right (Just ColorBlue) + toColor <$> scalarsWithDefaultsN decoded `shouldBe` Right (Just ColorGray) + + 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)) + + it "missing" $ runTest $ scalarsWithDefaults + Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing + Nothing Nothing + + it "DeprecatedFields" $ do + (json, decoded) <- flatc $ deprecatedFields (Just 1) (Just 2) (Just 3) (Just 4) + + json `shouldBeJson` object + [ "a" .= Number 1 + , "c" .= Number 2 + , "e" .= Number 3 + , "g" .= Number 4 + ] + + deprecatedFieldsA decoded `shouldBe` Right 1 + deprecatedFieldsC decoded `shouldBe` Right 2 + deprecatedFieldsE decoded `shouldBe` Right 3 + deprecatedFieldsG decoded `shouldBe` Right 4 + + it "RequiredFields" $ do + let readStruct1 = (liftA3 . liftA3) (,,) struct1X struct1Y struct1Z + (json, decoded) <- flatc $ requiredFields + "hello" + (struct1 11 22 33) + (axe (Just 44)) + (weaponSword (sword (Just "a"))) + (Vec.fromList' [55, 66]) + + json `shouldBeJson` object + [ "a" .= String "hello" + , "b" .= object ["x" .= Number 11, "y" .= Number 22, "z" .= Number 33] + , "c" .= object ["y" .= Number 44] + , "d" .= object ["x" .= String "a"] + , "d_type" .= String "Sword" + , "e" .= [Number 55, Number 66] + ] + + requiredFieldsA decoded `shouldBe` Right "hello" + (requiredFieldsB decoded >>= readStruct1) `shouldBe` Right (11, 22, 33) + (requiredFieldsC decoded >>= axeY) `shouldBe` Right 44 + requiredFieldsD decoded `shouldBeRightAndExpect` \case + Union (WeaponSword x) -> swordX x `shouldBe` Right (Just "a") + (requiredFieldsE decoded >>= Vec.toList) `shouldBe` Right [55, 66] + + +flatc :: forall a. Typeable a => WriteTable a -> IO (J.Value, Table a) +flatc table = flatcAux False (encode table) + +flatcWithFileIdentifier :: forall a. (HasFileIdentifier a, Typeable a) => WriteTable a -> IO (J.Value, Table a) +flatcWithFileIdentifier table = flatcAux True (encodeWithFileIdentifier table) + +flatcAux :: forall a. Typeable a => Bool -> BSL.ByteString -> IO (J.Value, Table a) +flatcAux withFileIdentifier bs = do + let tableName = show $ typeRep (Proxy @a) + + BSL.writeFile "temp/a.bin" bs + + Sys.callProcess "flatc" $ + (if not withFileIdentifier then ["--raw-binary"] else []) + <> + [ "-o", "./temp" + , "./test/Examples/schema.fbs" + , "--root-type", "examples.generated." <> tableName + , "--json" + , "--strict-json" + , "--" + , "temp/a.bin" + ] + + json <- J.eitherDecodeFileStrict' "temp/a.json" >>= \case + Left err -> fail $ "Failed to decode flatc's json:\n" <> err + Right val -> pure val + + Sys.callProcess "cp" ["temp/a.json", "temp/b.json"] + + Sys.callProcess "flatc" + [ "-o", "./temp" + , "./test/Examples/schema.fbs" + , "--root-type", "examples.generated." <> tableName + , "--binary" + , "--strict-json" + , "temp/b.json" + ] + + bs' <- BSL.readFile "temp/b.bin" + + case decode bs' of + Right table -> pure (json, table) + Left err -> fail err diff --git a/test/FlatBuffers/Internal/Compiler/ParserSpec.hs b/test/FlatBuffers/Internal/Compiler/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/FlatBuffers/Internal/Compiler/ParserSpec.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module FlatBuffers.Internal.Compiler.ParserSpec where + +import Data.Void ( Void ) + +import FlatBuffers.Internal.Compiler.Parser +import FlatBuffers.Internal.Compiler.SyntaxTree + +import Test.Hspec.Megaparsec + +import TestImports + +import Text.Megaparsec +import Text.RawString.QQ ( r ) + +spec :: Spec +spec = + describe "Parser" $ do + describe "include" $ do + it "parses correctly" $ + parseEof include [r|include "abc";|] `shouldParse` "abc" + it "parses strings with semicolons" $ + parseEof include [r|include "abc;";|] `shouldParse` "abc;" + it "parses escaped strings" $ do + parseEof include [r|include "abc \" " ;|] `shouldParse` "abc \" " + parseEof include [r|include "abc \" escaped \" rest" ;|] `shouldParse` "abc \" escaped \" rest" + describe "fails to parse" $ do + it "unmatched quotes" $ + parseEof include "include \"abc;" `shouldFailWithError` "unexpected end of input\nexpecting '\"' or literal character\n" + it "more than one string constant" $ + parseEof include "include \"abc\" \"def\";" `shouldFailWithError` "unexpected '\"'\nexpecting ';'\n" + it "if there's no semicolon" $ + parseEof include "include \"abc\"" `shouldFailWithError` "unexpected end of input\nexpecting ';'\n" + describe "schema" $ do + it "empty schema" $ + [r||] `parses` Schema [] [] + + it "includes" $ + [r| + include "somefile"; + include "other \"escaped\" File"; + |] `parses` Schema ["somefile", "other \"escaped\" File"] [] + + it "includes" $ + [r| + include "a"; + native_include "b"; + include "c"; + native_include "d"; + include "e"; + |] `parses` Schema ["a", "c", "e"] [] + + it "namespaces" $ + [r| + include "somefile"; + namespace Ns; + namespace My . Api . Domain; + namespace My.Api.Domain2; + namespace ; + |] `parses` + Schema + ["somefile"] + [ DeclN "Ns" + , DeclN "My.Api.Domain" + , DeclN "My.Api.Domain2" + , DeclN "" + ] + + it "table declarations" $ + [r| + table T {} + + table ATable { + abc : bool; + b1 : bool = true; + b2 : bool = false; + d : Ref = 123; + d : uint; + d : uint_; + d : X.uint; + d : X.uint_; + e : [uint] = - 99.2e9 ; + e : [uint] = 99992873786287637862.298736756627897654e99 ; + f : [uint_]; + g : My . Api . Ref = 123; + h : [ MyApi.abc_ ] ; + i: Color = Blue ; + } + |] `parses` + Schema + [] + [ DeclT $ TableDecl "T" (Metadata mempty) [] + , DeclT $ TableDecl "ATable" (Metadata mempty) + [ TableField "abc" TBool Nothing (Metadata mempty) + , TableField "b1" TBool (Just (DefaultBool True)) (Metadata mempty) + , TableField "b2" TBool (Just (DefaultBool False)) (Metadata mempty) + , TableField "d" (TRef (TypeRef "" "Ref")) (Just (DefaultNum 123)) (Metadata mempty) + , TableField "d" TWord32 Nothing (Metadata mempty) + , TableField "d" (TRef (TypeRef "" "uint_")) Nothing (Metadata mempty) + , TableField "d" (TRef (TypeRef "X" "uint")) Nothing (Metadata mempty) + , TableField "d" (TRef (TypeRef "X" "uint_")) Nothing (Metadata mempty) + , TableField "e" (TVector TWord32) (Just (DefaultNum (-99.2e9))) (Metadata mempty) + , TableField "e" (TVector TWord32) (Just (DefaultNum 99992873786287637862.298736756627897654e99)) (Metadata mempty) + , TableField "f" (TVector (TRef (TypeRef "" "uint_"))) Nothing (Metadata mempty) + , TableField "g" (TRef (TypeRef "My.Api" "Ref")) (Just (DefaultNum 123)) (Metadata mempty) + , TableField "h" (TVector (TRef (TypeRef "MyApi" "abc_"))) Nothing (Metadata mempty) + , TableField "i" (TRef (TypeRef "" "Color")) (Just (DefaultRef "Blue")) (Metadata mempty) + ] + ] + + it "struct declarations" $ + [r| + struct AStruct { + abc : bool; + d : Ref ; + e : [uint] ; + f : [uint_]; + g : My . Api . Ref ; + h : [ MyApi.abc_ ] ; + } + |] `parses` + Schema + [] + [ DeclS $ StructDecl "AStruct" (Metadata mempty) + [ StructField "abc" TBool (Metadata mempty) + , StructField "d" (TRef (TypeRef "" "Ref")) (Metadata mempty) + , StructField "e" (TVector TWord32) (Metadata mempty) + , StructField "f" (TVector (TRef (TypeRef "" "uint_"))) (Metadata mempty) + , StructField "g" (TRef (TypeRef "My.Api" "Ref")) (Metadata mempty) + , StructField "h" (TVector (TRef (TypeRef "MyApi" "abc_"))) (Metadata mempty) + ] + ] + + it "table declarations with metadata" $ + [r| + table ATable ( a , "b" : 9283 , c : "attr" ) { + abc : bool = 99 ( def ) ; + } + |] `parses` + Schema + [] + [ DeclT $ TableDecl "ATable" + (Metadata + [ ("a", Nothing) + , ("b", Just (AttrI 9283)) + , ("c", Just (AttrS "attr")) + ] + ) + (pure (TableField "abc" TBool (Just (DefaultNum 99)) (Metadata [("def", Nothing)]))) + ] + + it "enum declarations" $ + [r| + enum Color : short (attr) { + Red, + Blue = 18446744073709551615, + Gray = -18446744073709551615, + Black + } + |] `parses` + Schema + [] + [DeclE $ EnumDecl "Color" TInt16 (Metadata [("attr", Nothing)]) + [ EnumVal "Red" Nothing + , EnumVal "Blue" (Just 18446744073709551615) + , EnumVal "Gray" (Just (-18446744073709551615)) + , EnumVal "Black" Nothing + ] + ] + + it "union declarations" $ + [r| + union Weapon ( attr ) { + Sword, + mace: Stick, + mace2: My.Api.Stick, + Axe + } + |] `parses` + Schema + [] + [ DeclU $ UnionDecl + "Weapon" + (Metadata [("attr", Nothing)]) + [ UnionVal Nothing (TypeRef "" "Sword") + , UnionVal (Just "mace") (TypeRef "" "Stick") + , UnionVal (Just "mace2") (TypeRef "My.Api" "Stick") + , UnionVal Nothing (TypeRef "" "Axe") + ] + ] + + it "root types, file extensions / identifiers, attribute declarations" $ + [r| + attribute a; + attribute "b"; + root_type c; + root_type My.Api.C ; + file_extension "d"; + file_identifier "abcd"; + |] `parses` + Schema + [] + [ DeclA $ AttributeDecl "a" + , DeclA $ AttributeDecl "b" + , DeclR $ RootDecl (TypeRef "" "c") + , DeclR $ RootDecl (TypeRef "My.Api" "C") + , DeclFI $ FileIdentifierDecl "abcd" + ] + + it "file identifier must have exactly 4 UTF-8 code units" $ do + parseEof schema [r| file_identifier ""; |] `shouldFailWithError` "file_identifier must be exactly 4 characters\n" + parseEof schema [r| file_identifier "abc"; |] `shouldFailWithError` "file_identifier must be exactly 4 characters\n" + parseEof schema [r| file_identifier "abcde"; |] `shouldFailWithError` "file_identifier must be exactly 4 characters\n" + parseEof schema [r| file_identifier "abc👬"; |] `shouldFailWithError` "file_identifier must be exactly 4 UTF-8 code units\n" + parseEof schema [r| file_identifier "a👬"; |] `shouldFailWithError` "file_identifier must be exactly 4 UTF-8 code units\n" + + [r| file_identifier "abcd"; |] `parses` Schema [] [ DeclFI "abcd" ] + [r| file_identifier "👬"; |] `parses` Schema [] [ DeclFI "👬" ] + + it "json objects" $ + [r| + include "a"; + + { + "a" : 3 , + b : "e" , + c : [ { d: [ [ ] , [ "a" , null , true , false , - 3 , -239.223e3 ] ] } ] + } + + attribute b; + |] `parses` + Schema + [ Include "a" ] + [ DeclA $ AttributeDecl "b" ] + + it "RPC services" $ + [r| + include "a"; + + rpc_service MonsterStorage { + Store(Monster) : Stat ; + Retrieve(Stat) : Monster ( streaming : "server" , idempotent ) ; + } + + |] `parses` + Schema + [ Include "a" ] [] + +shouldFailWithError :: Show a => Either (ParseErrorBundle String Void) a -> String -> Expectation +shouldFailWithError p s = + case p of + Left (ParseErrorBundle [x] _) -> parseErrorTextPretty x `shouldBe` s + Left (ParseErrorBundle xs _) -> expectationFailure $ "Expected one parsing error, but got more:\n" ++ show xs + Right a -> expectationFailure $ "Expected parsing to fail, but succeeded with:\n" ++ show a + +parseEof :: Parser a -> String -> Either (ParseErrorBundle String Void) a +parseEof p = parse (p <* eof) "" + +parses :: String -> Schema -> Expectation +parses input expectedSchema = + case parse schema "" input of + l@(Left _) -> l `shouldParse` expectedSchema + Right result -> result `shouldBe` expectedSchema + + diff --git a/test/FlatBuffers/Internal/Compiler/SemanticAnalysisSpec.hs b/test/FlatBuffers/Internal/Compiler/SemanticAnalysisSpec.hs new file mode 100644 --- /dev/null +++ b/test/FlatBuffers/Internal/Compiler/SemanticAnalysisSpec.hs @@ -0,0 +1,1154 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module FlatBuffers.Internal.Compiler.SemanticAnalysisSpec where + +import Data.Foldable ( fold ) +import Data.Int +import Data.Text ( Text ) +import qualified Data.Text as T + +import qualified FlatBuffers.Internal.Compiler.Parser as P +import FlatBuffers.Internal.Compiler.SemanticAnalysis +import FlatBuffers.Internal.Compiler.SyntaxTree ( FileTree(..) ) +import FlatBuffers.Internal.Compiler.ValidSyntaxTree + +import TestImports + +import Text.Megaparsec +import Text.RawString.QQ ( r ) + +spec :: Spec +spec = + describe "SemanticAnalysis" $ do + it "top-level identifiers cannot have duplicates in the same namespace" $ do + [r| namespace A; enum E:int{x} enum E:int{x} |] `shouldFail` "'A.E' declared more than once" + [r| enum E:int{x} enum E:int{x} |] `shouldFail` "'E' declared more than once" + [r| struct S{x:int;} struct S{x:int;} |] `shouldFail` "'S' declared more than once" + [r| table T{} table T{} |] `shouldFail` "'T' declared more than once" + [r| union U{x} union U{x} |] `shouldFail` "'U' declared more than once" + [r| union U{x} union U{x} |] `shouldFail` "'U' declared more than once" + [r| union X{x} table X{} |] `shouldFail` "'X' declared more than once" + + it "top-level identifiers can be duplicates, if they live in different namespaces" $ + [r| + namespace A; + union X{B.X} + + namespace B; + table X{} + |] `shouldValidate` foldDecls + [ union ("A", UnionDecl "X" [UnionVal "B_X" (TypeRef "B" "X")]) + , table ("B", TableDecl "X" NotRoot []) + ] + + describe "attributes" $ do + it "user defined attributes must be declared" $ do + [r| enum E : int (x) {Y} |] `shouldFail` "[E]: user defined attributes must be declared before use: x" + [r| struct S (x) { y: int;} |] `shouldFail` "[S]: user defined attributes must be declared before use: x" + [r| struct S { y: int (x);} |] `shouldFail` "[S.y]: user defined attributes must be declared before use: x" + [r| table T (x) {} |] `shouldFail` "[T]: user defined attributes must be declared before use: x" + [r| table T { y: int (x); } |] `shouldFail` "[T.y]: user defined attributes must be declared before use: x" + [r| union U (x) {Y} table Y{} |] `shouldFail` "[U]: user defined attributes must be declared before use: x" + + it "user defined attributes can be used when declared" $ do + shouldSucceed [r| attribute x; enum E : int (x) {Y} |] + shouldSucceed [r| attribute x; struct S (x) { y: int;} |] + shouldSucceed [r| attribute x; struct S { y: int (x);} |] + shouldSucceed [r| attribute x; table T (x) {} |] + shouldSucceed [r| attribute x; table T { y: int (x); } |] + shouldSucceed [r| attribute x; union U (x) {Y} table Y{} |] + + it "built-in attributes can be used without being declared" $ + shouldSucceed + [r| + table T + (id, + deprecated, + required, + force_align, + bit_flags, + nested_flatbuffer, + flexbuffer, + key, + hash, + original_order, + native_inline, + native_default, + native_custom_alloc, + native_type + ) {} + |] + + describe "root type" $ do + it "flips the `isRoot` flag" $ + [r| + table T{} + root_type T; + |] `shouldValidate` + table ("", TableDecl "T" (IsRoot Nothing) []) + + it "can be paired with a file_identifier" $ + [r| + table T{} + file_identifier "abcd"; + root_type T; + |] `shouldValidate` + table ("", TableDecl "T" (IsRoot (Just "abcd")) []) + + it "when set multiple times, the last declaration wins" $ + [r| + file_identifier "abcd"; + root_type T; + root_type T2; + file_identifier "efgh"; + table T2{} + table T{} + |] `shouldValidate` foldDecls + [ table ("", TableDecl "T2" (IsRoot (Just "efgh")) []) + , table ("", TableDecl "T" NotRoot []) + ] + + it "must reference a table" $ do + [r| root_type E; enum E:int{x} |] `shouldFail` "root type must be a table" + [r| root_type S; struct S{x:int;} |] `shouldFail` "root type must be a table" + [r| root_type U; union U{T} table T{} |] `shouldFail` "root type must be a table" + [r| root_type string; |] `shouldFail` "type 'string' does not exist (checked in these namespaces: '')" + + it "can reference tables in other namespaces" $ + [r| + namespace A; + root_type B.T; + namespace A.B; + table T{} + file_identifier "abcd"; + |] `shouldValidate` + table ("A.B", TableDecl "T" (IsRoot (Just "abcd")) []) + + it "a file identifier on its own doesn't do anything" $ + [r| + table T{} + file_identifier "abcd"; + |] `shouldValidate` + table ("", TableDecl "T" NotRoot []) + + describe "enums" $ do + it "simple" $ + [r| + namespace Ns; + enum Color : uint32 { Red, Green, Blue } + |] `shouldValidate` + enum ("Ns", EnumDecl "Color" EWord32 + [ EnumVal "Red" 0 + , EnumVal "Green" 1 + , EnumVal "Blue" 2 + ]) + + it "multiple enums in different namespaces" $ + [r| + namespace A; + enum Color1 : uint32 { Red } + + namespace B; + namespace ; + enum Color2 : uint32 { Green } + + namespace A.B.C; + enum Color3 : uint32 { Blue } + + |] `shouldValidate` foldDecls + [ enum ("A", EnumDecl "Color1" EWord32 [EnumVal "Red" 0] ) + , enum ("", EnumDecl "Color2" EWord32 [EnumVal "Green" 0] ) + , enum ("A.B.C", EnumDecl "Color3" EWord32 [EnumVal "Blue" 0] ) + ] + + it "with explicit values" $ + [r| enum Color : int32 { Red = -2, Green, Blue = 2 } |] `shouldValidate` + enum ("", EnumDecl "Color" EInt32 + [ EnumVal "Red" (-2) + , EnumVal "Green" (-1) + , EnumVal "Blue" 2 + ]) + + it "with explicit values (min/maxBound)" $ + [r| enum Color : int8 { Red = -128, Green, Blue = 127 } |] `shouldValidate` + enum ("", EnumDecl "Color" EInt8 + [ EnumVal "Red" (toInteger (minBound :: Int8)) + , EnumVal "Green" (-127) + , EnumVal "Blue" (toInteger (maxBound :: Int8)) + ]) + + it "with out-of-bounds values" $ do + [r| + namespace A.B; + enum Color : int8 { Red = -129, Green, Blue } + |] `shouldFail` + "[A.B.Color.Red]: enum value does not fit [-128; 127]" + [r| + enum Color : int8 { Red, Green, Blue = 128 } + |] `shouldFail` + "[Color.Blue]: enum value does not fit [-128; 127]" + + it "with values out of order" $ do + [r| enum Color : int8 { Red = 3, Green = 2, Blue } |] `shouldFail` + "[Color]: enum values must be specified in ascending order" + [r| enum Color : int8 { Red = 3, Green = 3, Blue } |] `shouldFail` + "[Color]: enum values must be specified in ascending order" + + it "with bit_flags" $ + [r| enum Color : int8 (bit_flags) { Red, Green, Blue } |] `shouldFail` + "[Color]: `bit_flags` are not supported yet" + + it "with duplicate values" $ + [r| enum Color : int8 { Red, Green, Red, Gray, Green, Green, Black } |] `shouldFail` + "[Color]: 'Green', 'Red' declared more than once" + + it "with invalid underlying type" $ do + [r| enum Color : double { Red, Green, Blue } |] `shouldFail` + "[Color]: underlying enum type must be integral" + [r| enum Color : TypeRef { Red, Green, Blue } |] `shouldFail` + "[Color]: underlying enum type must be integral" + [r| enum Color : [int] { Red, Green, Blue } |] `shouldFail` + "[Color]: underlying enum type must be integral" + + describe "structs" $ do + it "simple" $ + [r| + namespace Ns; + struct S { + x: int; + } + |] `shouldValidate` + struct ("Ns", StructDecl "S" 4 4 + [ StructField "x" 0 0 SInt32 + ]) + + it "multiple fields" $ + [r| + struct S { + x: ubyte; + y: double; + z: bool; + } + |] `shouldValidate` + struct ("", StructDecl "S" 8 24 + [ StructField "x" 7 0 SWord8 + , StructField "y" 0 8 SDouble + , StructField "z" 7 16 SBool + ]) + + it "when unqualified TypeRef is ambiguous, types in namespaces closer to the struct are preferred" $ do + let enumVal = EnumVal "x" 0 + mkEnum namespace ident = enum (namespace, EnumDecl ident EInt16 [enumVal]) + [r| + namespace ; enum E1 : short{x} enum E2 : short{x} enum E3 : short{x} + namespace A; enum E1 : short{x} enum E2 : short{x} + namespace A.B; enum E1 : short{x} + namespace A.B.C; enum E1 : short{x} enum E2 : short{x} enum E3 : short{x} + + namespace A.B; + struct S { + x: E1; // should be A.B.E1 + y: E2; // should be A.E2 + z: E3; // should be E3 + } + |] `shouldValidate` foldDecls + [ mkEnum "" "E1", mkEnum "" "E2", mkEnum "" "E3" + , mkEnum "A" "E1", mkEnum "A" "E2" + , mkEnum "A.B" "E1" + , mkEnum "A.B.C" "E1", mkEnum "A.B.C" "E2", mkEnum "A.B.C" "E3" + , struct ("A.B", StructDecl "S" 2 6 + [ StructField "x" 0 0 (SEnum (TypeRef "A.B" "E1") EInt16) + , StructField "y" 0 2 (SEnum (TypeRef "A" "E2") EInt16) + , StructField "z" 0 4 (SEnum (TypeRef "" "E3") EInt16) + ]) + ] + + it "when qualified TypeRef is ambiguous, types in namespaces closer to the struct are preferred" $ do + let enumVal = EnumVal "x" 0 + mkEnum namespace ident = enum (namespace, EnumDecl ident EInt16 [enumVal]) + [r| + namespace ; enum E1 : short{x} enum E2 : short{x} enum E3 : short{x} + namespace A; enum E1 : short{x} enum E2 : short{x} enum E3 : short{x} + namespace A.B; enum E1 : short{x} enum E2 : short{x} enum E3 : short{x} + namespace A.A; enum E1 : short{x} enum E2 : short{x} + namespace A.B.A; enum E1 : short{x} + namespace A.B.C.A; enum E1 : short{x} enum E2 : short{x} enum E3 : short{x} + + namespace A.B; + struct S { + x: A.E1; // should be A.B.A.E1 + y: A.E2; // should be A.A.E2 + z: A.E3; // should be A.E3 + } + |] `shouldValidate` foldDecls + [ mkEnum "" "E1", mkEnum "" "E2", mkEnum "" "E3" + , mkEnum "A" "E1", mkEnum "A" "E2", mkEnum "A" "E3" + , mkEnum "A.B" "E1", mkEnum "A.B" "E2", mkEnum "A.B" "E3" + , mkEnum "A.A" "E1", mkEnum "A.A" "E2" + , mkEnum "A.B.A" "E1" + , mkEnum "A.B.C.A" "E1", mkEnum "A.B.C.A" "E2", mkEnum "A.B.C.A" "E3" + , struct ("A.B", StructDecl "S" 2 6 + [ StructField "x" 0 0 (SEnum (TypeRef "A.B.A" "E1") EInt16) + , StructField "y" 0 2 (SEnum (TypeRef "A.A" "E2") EInt16) + , StructField "z" 0 4 (SEnum (TypeRef "A" "E3") EInt16) + ]) + ] + + it "when TypeRef is ambiguous, types in namespaces closer to the struct are preferred, even if they're not valid" $ + [r| + namespace A; struct X {x: int;} + namespace A.B; table X {} + + struct S { + x: X; + } + |] `shouldFail` + "[A.B.S.x]: struct fields may only be integers, floating point, bool, enums, or other structs" + + it "with field referencing an enum" $ + [r| + namespace A; + enum Color : ushort { Blue } + + struct S { + x: Color; + } + |] `shouldValidate` foldDecls + [ enum ("A", EnumDecl "Color" EWord16 [EnumVal "Blue" 0]) + , struct ("A", StructDecl "S" 2 2 + [ StructField "x" 0 0 (SEnum (TypeRef "A" "Color") EWord16) + ]) + ] + + it "with nested structs (backwards/forwards references)" $ do + let backwards = ("A.B", StructDecl "Backwards" 4 4 [ StructField "x" 0 0 SFloat ]) + let forwards = ("A.B", StructDecl "Forwards" 4 4 [ StructField "y" 0 0 (SStruct backwards) ]) + [r| + namespace A.B; + struct Backwards { + x: float; + } + + struct S { + x1: B.Backwards; + x2: A.B.Forwards; + } + + struct Forwards { + y: Backwards; + } + |] `shouldValidate` foldDecls + [ struct backwards + , struct ("A.B", StructDecl "S" 4 8 + [ StructField "x1" 0 0 (SStruct backwards) + , StructField "x2" 0 4 (SStruct forwards) + ]) + , struct forwards + ] + + it "with reference to a table" $ + [r| + namespace A; + table T {} + + struct S { + x: A.T; + } + |] `shouldFail` + "[A.S.x]: struct fields may only be integers, floating point, bool, enums, or other structs" + + it "with reference to a union" $ + [r| + namespace A.B; + union U { X } + + struct S { + x: U; + } + |] `shouldFail` + "[A.B.S.x]: struct fields may only be integers, floating point, bool, enums, or other structs" + + it "with invalid reference" $ + [r| + namespace X.Y.Z; + struct S { + x: A.T; + } + |] `shouldFail` + "[X.Y.Z.S.x]: type 'A.T' does not exist (checked in these namespaces: 'X.Y.Z', 'X.Y', 'X', '')" + + it "with reference to a vector" $ + [r| struct S { x: [byte]; } |] `shouldFail` + "[S.x]: struct fields may only be integers, floating point, bool, enums, or other structs" + + it "with reference to a string" $ + [r| struct S { x: string; } |] `shouldFail` + "[S.x]: struct fields may only be integers, floating point, bool, enums, or other structs" + + it "with duplicate fields" $ + [r| struct S { x: byte; x: int; } |] `shouldFail` + "[S]: 'x' declared more than once" + + it "with `force_align` attribute" $ do + -- just 1 field + [r| struct S (force_align: 4) { x: int; } |] `shouldValidate` struct ("", StructDecl "S" 4 4 [StructField "x" 0 0 SInt32]) + [r| struct S (force_align: 8) { x: int; } |] `shouldValidate` struct ("", StructDecl "S" 8 8 [StructField "x" 4 0 SInt32]) + [r| struct S (force_align: 16) { x: int; } |] `shouldValidate` struct ("", StructDecl "S" 16 16 [StructField "x" 12 0 SInt32]) + -- multiple fields + [r| struct S (force_align: 2) { x: byte; y: ushort; } |] `shouldValidate` struct ("", StructDecl "S" 2 4 [StructField "x" 1 0 SInt8, StructField "y" 0 2 SWord16]) + [r| struct S (force_align: 4) { x: byte; y: ushort; } |] `shouldValidate` struct ("", StructDecl "S" 4 4 [StructField "x" 1 0 SInt8, StructField "y" 0 2 SWord16]) + [r| struct S (force_align: 8) { x: byte; y: ushort; } |] `shouldValidate` struct ("", StructDecl "S" 8 8 [StructField "x" 1 0 SInt8, StructField "y" 4 2 SWord16]) + [r| struct S (force_align: 16) { x: byte; y: ushort; } |] `shouldValidate` struct ("", StructDecl "S" 16 16 [StructField "x" 1 0 SInt8, StructField "y" 12 2 SWord16]) + -- nested structs + let s1 = ("", StructDecl "S1" 2 2 [StructField "x" 1 0 SInt8]) + let s2 = ("", StructDecl "S2" 4 4 [StructField "x" 0 0 SInt32]) + let s = ("", StructDecl "S" 4 12 + [ StructField "x" 2 0 (SStruct s1) + , StructField "y" 0 4 (SStruct s2) + , StructField "z" 3 8 SBool + ]) + [r| + struct S (force_align: 4) { x: S1; y: S2; z: bool; } + struct S1 (force_align: 2) { x: byte; } + struct S2 { x: int; } + |] `shouldValidate` foldDecls + [ struct s + , struct s1 + , struct s2 + ] + + it "with `force_align` attribute less than the struct's natural alignment" $ + [r| struct S (force_align: 2) { x: byte; y: int; } |] `shouldFail` + "[S]: force_align must be a power of two integer ranging from the struct's natural alignment (in this case, 4) to 16" + + it "with `force_align` attribute greater than 16" $ + [r| struct S (force_align: 32) { x: int; } |] `shouldFail` + "[S]: force_align must be a power of two integer ranging from the struct's natural alignment (in this case, 4) to 16" + + it "with `force_align` not a power of 2" $ + [r| struct S (force_align: 9) { x: int; } |] `shouldFail` + "[S]: force_align must be a power of two integer ranging from the struct's natural alignment (in this case, 4) to 16" + + it "with `force_align` given as a string" $ + [r| struct S (force_align: "hello") { x: byte; } |] `shouldFail` + "[S]: expected attribute 'force_align' to have an integer value, e.g. 'force_align: 123'" + + it "with deprecated field" $ + [r| struct S { x: byte (deprecated); } |] `shouldFail` + "[S.x]: can't deprecate fields in a struct" + + it "with required field" $ + [r| struct S { x: byte (required); } |] `shouldFail` + "[S.x]: struct fields are already required, the 'required' attribute is redundant" + + it "with id field" $ + [r| struct S { x: byte (id: 0); } |] `shouldFail` + "[S.x]: struct fields cannot be reordered using the 'id' attribute" + + it "with cyclic dependency" $ + [r| + struct S {x: S1;} + struct S1 {x: S4; y: S2;} + struct S2 {x: byte; y: S3;} + struct S3 {x: S4; y: S1;} + struct S4 {x: byte;} + |] `shouldFail` + "[S1]: cyclic dependency detected [S1 -> S2 -> S3 -> S1] - structs cannot contain themselves, directly or indirectly" + + describe "tables" $ do + it "empty" $ + [r| table T{} |] `shouldValidate` table ("", TableDecl "T" NotRoot []) + + it "with cyclic reference" $ + [r| table T{x: T;} |] `shouldValidate` + table ("", TableDecl "T" NotRoot + [ TableField 0 "x" (TTable (TypeRef "" "T") Opt) False + ]) + + it "with invalid reference" $ do + [r| table T { x: A.X; } |] `shouldFail` "[T.x]: type 'A.X' does not exist (checked in these namespaces: '')" + [r| table T { x: [A.X]; } |] `shouldFail` "[T.x]: type 'A.X' does not exist (checked in these namespaces: '')" + + it "with duplicate fields" $ + [r| table T { x: byte; x: int; } |] `shouldFail` + "[T]: 'x' declared more than once" + + describe "with numeric/bool fields" $ do + it "simple" $ + [r| + namespace A.B; + table T { + a: byte; + b: short; + c: int; + d: long; + e: ubyte; + f: ushort; + g: uint; + h: ulong; + i: float; + j: double; + k: bool; + } + |] `shouldValidate` + table ("A.B", TableDecl "T" NotRoot + [ TableField 0 "a" (TInt8 0) False + , TableField 1 "b" (TInt16 0) False + , TableField 2 "c" (TInt32 0) False + , TableField 3 "d" (TInt64 0) False + , TableField 4 "e" (TWord8 0) False + , TableField 5 "f" (TWord16 0) False + , TableField 6 "g" (TWord32 0) False + , TableField 7 "h" (TWord64 0) False + , TableField 8 "i" (TFloat 0) False + , TableField 9 "j" (TDouble 0) False + , TableField 10"k" (TBool (DefaultVal False)) False + ] + ) + + it "with `required` attribute" $ do + let errorMsg = "[T.x]: only non-scalar fields (strings, vectors, unions, structs, tables) may be 'required'" + [r| table T {x: byte (required); } |] `shouldFail` errorMsg + [r| table T {x: short (required); } |] `shouldFail` errorMsg + [r| table T {x: int (required); } |] `shouldFail` errorMsg + [r| table T {x: long (required); } |] `shouldFail` errorMsg + [r| table T {x: ubyte (required); } |] `shouldFail` errorMsg + [r| table T {x: ushort (required); } |] `shouldFail` errorMsg + [r| table T {x: uint (required); } |] `shouldFail` errorMsg + [r| table T {x: ulong (required); } |] `shouldFail` errorMsg + [r| table T {x: float (required); } |] `shouldFail` errorMsg + [r| table T {x: double (required); } |] `shouldFail` errorMsg + [r| table T {x: bool (required); } |] `shouldFail` errorMsg + + it "with `deprecated` attribute" $ + [r| + namespace A.B; + table T { + a: byte (deprecated); + b: short (deprecated); + c: int (deprecated); + d: long (deprecated); + e: ubyte (deprecated); + f: ushort (deprecated); + g: uint (deprecated); + h: ulong (deprecated); + i: float (deprecated); + j: double (deprecated); + k: bool (deprecated); + } + |] `shouldValidate` + table ("A.B", TableDecl "T" NotRoot + [ TableField 0 "a" (TInt8 0) True + , TableField 1 "b" (TInt16 0) True + , TableField 2 "c" (TInt32 0) True + , TableField 3 "d" (TInt64 0) True + , TableField 4 "e" (TWord8 0) True + , TableField 5 "f" (TWord16 0) True + , TableField 6 "g" (TWord32 0) True + , TableField 7 "h" (TWord64 0) True + , TableField 8 "i" (TFloat 0) True + , TableField 9 "j" (TDouble 0) True + , TableField 10 "k" (TBool (DefaultVal False)) True + ] + ) + + describe "with integer fields" $ do + it "with integer default values" $ + [r| + table T { + a: byte = 127; + b: short = -32768; + c: int = 1; + d: long = 1.00; + e: ubyte = 2e1; + f: ushort = 200e-1; + } + |] `shouldValidate` + table ("", TableDecl "T" NotRoot + [ TableField 0 "a" (TInt8 127) False + , TableField 1 "b" (TInt16 (-32768)) False + , TableField 2 "c" (TInt32 1) False + , TableField 3 "d" (TInt64 1) False + , TableField 4 "e" (TWord8 20) False + , TableField 5 "f" (TWord16 20) False + ] + ) + + it "with out-of-bounds default values" $ do + [r| table T { a: byte = -129; } |] `shouldFail` "[T.a]: default value does not fit [-128; 127]" + [r| table T { a: byte = 128; } |] `shouldFail` "[T.a]: default value does not fit [-128; 127]" + + let errorMsg = "[T.a]: default value must be integral" + it "with decimal default values" $ do + [r| table T { a: byte = 1.1; } |] `shouldFail` errorMsg + [r| table T { a: byte = 2e-1; } |] `shouldFail` errorMsg + [r| table T { a: byte = 2.22e1; } |] `shouldFail` errorMsg + + it "with boolean default values" $ + [r| table T { a: byte = true; } |] `shouldFail` errorMsg + + it "with identifier default values" $ + [r| table T { a: byte = Red; } |] `shouldFail` errorMsg + + describe "with floating point fields" $ do + it "with integer default values" $ + [r| + table T { + a: float = 127; + b: float = -32768; + c: float = 1; + d: double = 1.00; + e: double = 2e1; + f: double = 200e-1; + } + |] `shouldValidate` + table ("", TableDecl "T" NotRoot + [ TableField 0 "a" (TFloat 127) False + , TableField 1 "b" (TFloat (-32768)) False + , TableField 2 "c" (TFloat 1) False + , TableField 3 "d" (TDouble 1) False + , TableField 4 "e" (TDouble 20) False + , TableField 5 "f" (TDouble 20) False + ] + ) + + it "with decimal default values" $ + [r| + table T { + a: double = 1.1; + b: double = 2e-1; + c: double = 2.22e1; + } + |] `shouldValidate` + table ("", TableDecl "T" NotRoot + [ TableField 0 "a" (TDouble 1.1) False + , TableField 1 "b" (TDouble 0.2) False + , TableField 2 "c" (TDouble 22.2) False + ] + ) + + it "with boolean default values" $ + [r| table T { a: double = true; } |] `shouldFail` "[T.a]: default value must be a number" + + it "with identifier default values" $ + [r| table T { a: double = Red; } |] `shouldFail` "[T.a]: default value must be a number" + + describe "with boolean fields" $ do + it "with integer default values" $ + [r| table T { a: bool = 1; } |] `shouldFail` "[T.a]: default value must be a boolean" + + it "with decimal default values" $ + [r| table T { a: bool = 1.1; } |] `shouldFail` "[T.a]: default value must be a boolean" + + it "with boolean default values" $ + [r| + table T { + a: bool = true; + b: bool = false; + } + |] `shouldValidate` + table ("", TableDecl "T" NotRoot + [ TableField 0 "a" (TBool (DefaultVal True)) False + , TableField 1 "b" (TBool (DefaultVal False)) False + ] + ) + + it "with identifier default values" $ + [r| table T { a: bool = Red; } |] `shouldFail` "[T.a]: default value must be a boolean" + + describe "with string fields" $ do + it "simple" $ + [r| table T { x: string; } |] `shouldValidate` + table ("", TableDecl "T" NotRoot [ TableField 0 "x" (TString Opt) False ]) + it "with `required` attribute" $ + [r| table T { x: string (required); } |] `shouldValidate` + table ("", TableDecl "T" NotRoot [ TableField 0 "x" (TString Req) False ]) + it "with `deprecated` attribute" $ + [r| table T { x: string (deprecated); } |] `shouldValidate` + table ("", TableDecl "T" NotRoot [ TableField 0 "x" (TString Opt) True ]) + it "with default value" $ do + let errorMsg = "[T.x]: default values currently only supported for scalar fields (integers, floating point, bool, enums)" + [r| table T { x: string = a; } |] `shouldFail` errorMsg + [r| table T { x: string = 0; } |] `shouldFail` errorMsg + [r| table T { x: string = 0.0; } |] `shouldFail` errorMsg + + describe "with reference to enum" $ do + it "simple" $ + [r| + namespace A.B; + enum E : short { A } + table T { + x: B.E; + } + |] `shouldValidate` foldDecls + [ enum ("A.B", EnumDecl "E" EInt16 [ EnumVal "A" 0 ]) + , table ("A.B", TableDecl "T" NotRoot + [ TableField 0 "x" (TEnum (TypeRef "A.B" "E") EInt16 0) False ] + ) + ] + + it "with `required` attribute" $ + [r| table T { x: E (required); } enum E : short{A} |] `shouldFail` + "[T.x]: only non-scalar fields (strings, vectors, unions, structs, tables) may be 'required'" + + it "with `deprecated` attribute" $ + [r| table T { x: E (deprecated); } enum E : short{A} |] `shouldValidate` foldDecls + [ enum ("", EnumDecl "E" EInt16 [ EnumVal "A" 0 ]) + , table ("", TableDecl "T" NotRoot + [ TableField 0 "x" (TEnum (TypeRef "" "E") EInt16 0) True ] + ) + ] + + it "without default value, when enum has 0-value" $ + [r| table T { x: E; } enum E : short{ A = -1, B = 0, C = 1} |] `shouldValidate` foldDecls + [ enum ("", EnumDecl "E" EInt16 [ EnumVal "A" (-1), EnumVal "B" 0, EnumVal "C" 1 ]) + , table ("", TableDecl "T" NotRoot + [ TableField 0 "x" (TEnum (TypeRef "" "E") EInt16 0) False ] + ) + ] + + it "without default value, when enum doesn't have 0-value" $ + [r| table T { x: E; } enum E : short{ A = -1, B = 1, C = 2} |] `shouldFail` + "[T.x]: enum does not have a 0 value; please manually specify a default for this field" + + describe "with default value" $ do + it "valid integral" $ + [r| table T { x: E = 1; } enum E : short{ A, B, C } |] `shouldValidate` foldDecls + [ enum ("", EnumDecl "E" EInt16 [ EnumVal "A" 0, EnumVal "B" 1, EnumVal "C" 2 ]) + , table ("", TableDecl "T" NotRoot + [ TableField 0 "x" (TEnum (TypeRef "" "E") EInt16 1) False ] + ) + ] + + it "invalid integral" $ + [r| table T { x: E = 3; } enum E : short{ A, B, C } |] `shouldFail` + "[T.x]: default value of 3 is not part of enum E" + + it "valid identifier" $ + [r| table T { x: E = B; } enum E : short{ A, B, C } |] `shouldValidate` foldDecls + [ enum ("", EnumDecl "E" EInt16 [ EnumVal "A" 0, EnumVal "B" 1, EnumVal "C" 2 ]) + , table ("", TableDecl "T" NotRoot + [ TableField 0 "x" (TEnum (TypeRef "" "E") EInt16 1) False ] + ) + ] + + it "invalid identifier" $ + [r| table T { x: E = D; } enum E : short{ A, B, C } |] `shouldFail` + "[T.x]: default value of D is not part of enum E" + + it "decimal number" $ + [r| table T { x: E = 1.5; } enum E : short{ A, B, C } |] `shouldFail` + "[T.x]: default value must be integral or one of: 'A', 'B', 'C'" + + it "boolean" $ + [r| table T { x: E = 1.5; } enum E : short{ A, B, C } |] `shouldFail` + "[T.x]: default value must be integral or one of: 'A', 'B', 'C'" + + describe "with reference to structs/table/union" $ do + it "simple" $ + [r| + namespace A; + struct S { x: int; } + table T {} + union U {A.T} + table Table { + x: S; + y: T; + z: U; + } + |] `shouldValidate` foldDecls + [ struct ("A", StructDecl "S" 4 4 [ StructField "x" 0 0 SInt32 ]) + , table ("A", TableDecl "T" NotRoot []) + , union ("A", UnionDecl "U" [UnionVal "A_T" (TypeRef "A" "T")]) + , table ("A", TableDecl "Table" NotRoot + [ TableField 0 "x" (TStruct (TypeRef "A" "S") Opt) False + , TableField 1 "y" (TTable (TypeRef "A" "T") Opt) False + , TableField 3 "z" (TUnion (TypeRef "A" "U") Opt) False + ] + ) + ] + + it "with `required` attribute" $ + [r| + namespace A; + struct S { x: int; } + table T {} + union U {A.T} + table Table { + x: S (required); + y: T (required); + z: U (required); + } + |] `shouldValidate` foldDecls + [ struct ("A", StructDecl "S" 4 4 [ StructField "x" 0 0 SInt32 ]) + , table ("A", TableDecl "T" NotRoot []) + , union ("A", UnionDecl "U" [UnionVal "A_T" (TypeRef "A" "T")]) + , table ("A", TableDecl "Table" NotRoot + [ TableField 0 "x" (TStruct (TypeRef "A" "S") Req) False + , TableField 1 "y" (TTable (TypeRef "A" "T") Req) False + , TableField 3 "z" (TUnion (TypeRef "A" "U") Req) False + ] + ) + ] + + it "with `deprecated` attribute" $ + [r| + namespace A; + struct S { x: int; } + table T {} + union U {A.T} + table Table { + x: S (deprecated); + y: T (deprecated); + z: U (deprecated); + } + |] `shouldValidate` foldDecls + [ struct ("A", StructDecl "S" 4 4 [ StructField "x" 0 0 SInt32 ]) + , table ("A", TableDecl "T" NotRoot []) + , union ("A", UnionDecl "U" [UnionVal "A_T" (TypeRef "A" "T")]) + , table ("A", TableDecl "Table" NotRoot + [ TableField 0 "x" (TStruct (TypeRef "A" "S") Opt) True + , TableField 1 "y" (TTable (TypeRef "A" "T") Opt) True + , TableField 3 "z" (TUnion (TypeRef "A" "U") Opt) True + ] + ) + ] + + it "with default value" $ do + let errorMsg = "[Table.x]: default values currently only supported for scalar fields (integers, floating point, bool, enums)" + [r| table Table { x: S = 0; } struct S { x: int; } |] `shouldFail` errorMsg + [r| table Table { x: T = 0; } table T{} |] `shouldFail` errorMsg + [r| table Table { x: U = 0; } union U{T} |] `shouldFail` errorMsg + + describe "with vector fields" $ do + it "simple" $ + [r| table T { x: [string]; y: [int]; z: [bool]; } |] `shouldValidate` + table ("", TableDecl "T" NotRoot + [ TableField 0 "x" (TVector Opt VString) False + , TableField 1 "y" (TVector Opt VInt32) False + , TableField 2 "z" (TVector Opt VBool) False + ]) + + it "where the elements are references" $ + [r| + namespace A; + table Table { w: [B.E]; x: [B.S]; y: [B.T]; z: [B.U]; } + + namespace A.B; + enum E : int16 { EA } + struct S { x: ubyte; y: int64; } + table T {} + union U { T } + |] `shouldValidate` foldDecls + [ table ("A", TableDecl "Table" NotRoot + [ TableField 0 "w" (TVector Opt (VEnum (TypeRef "A.B" "E") EInt16)) False + , TableField 1 "x" (TVector Opt (VStruct (TypeRef "A.B" "S"))) False + , TableField 2 "y" (TVector Opt (VTable (TypeRef "A.B" "T"))) False + , TableField 4 "z" (TVector Opt (VUnion (TypeRef "A.B" "U"))) False + ]) + , enum ("A.B", EnumDecl "E" EInt16 [EnumVal "EA" 0]) + , struct ("A.B", StructDecl "S" 8 16 [StructField "x" 7 0 SWord8, StructField "y" 0 8 SInt64]) + , table ("A.B", TableDecl "T" NotRoot []) + , union ("A.B", UnionDecl "U" [UnionVal "T" (TypeRef "A.B" "T")]) + ] + + it "with `required` attribute" $ + [r| table T { x: [byte] (required); } |] `shouldValidate` + table ("", TableDecl "T" NotRoot [ TableField 0 "x" (TVector Req VInt8) False ]) + + it "with `deprecated` attribute" $ + [r| table T { x: [string] (deprecated); } |] `shouldValidate` + table ("", TableDecl "T" NotRoot [ TableField 0 "x" (TVector Opt VString) True ]) + + it "with default value" $ do + let errorMsg = "[T.x]: default values currently only supported for scalar fields (integers, floating point, bool, enums)" + [r| table T { x: [int] = a; } |] `shouldFail` errorMsg + [r| table T { x: [int] = 0; } |] `shouldFail` errorMsg + [r| table T { x: [int] = 0.0; } |] `shouldFail` errorMsg + + describe "with `id` attribute" $ do + it "sorts fields" $ + [r| + table T { + w: byte (id: 2); + x: byte (id: 1); + y: byte (id: 3); + z: byte (id: 0); + } + |] `shouldValidate` foldDecls + [ table ("", TableDecl "T" NotRoot + [ TableField 0 "z" (TInt8 0) False + , TableField 1 "x" (TInt8 0) False + , TableField 2 "w" (TInt8 0) False + , TableField 3 "y" (TInt8 0) False + ] + ) + ] + + it "id must be skipped when field is a union" $ do + [r| + union U { T } + table T { + x: U (id: 2); + y: byte (id: 3); + z: byte (id: 0); + } + |] `shouldValidate` foldDecls + [ table ("", TableDecl "T" NotRoot + [ TableField 0 "z" (TInt8 0) False + , TableField 2 "x" (TUnion (TypeRef "" "U") Opt) False + , TableField 3 "y" (TInt8 0) False + ] + ) + , union ("", UnionDecl "U" [UnionVal "T" (TypeRef "" "T")]) + ] + [r| + union U { T } + table T { + x: U (id: 1); + y: byte (id: 2); + z: byte (id: 0); + } + |] `shouldFail` + "[T.x]: the id of a union field must be the last field's id + 2" + + it "id must be skipped when field is a vector of unions" $ do + [r| + union U { T } + table T { + x: [U] (id: 2); + y: byte (id: 3); + z: byte (id: 0); + } + |] `shouldValidate` foldDecls + [ table ("", TableDecl "T" NotRoot + [ TableField 0 "z" (TInt8 0) False + , TableField 2 "x" (TVector Opt (VUnion (TypeRef "" "U"))) False + , TableField 3 "y" (TInt8 0) False + ] + ) + , union ("", UnionDecl "U" [UnionVal "T" (TypeRef "" "T")]) + ] + [r| + union U { T } + table T { + x: [U] (id: 1); + y: byte (id: 2); + z: byte (id: 0); + } + |] `shouldFail` + "[T.x]: the id of a vector of unions field must be the last field's id + 2" + + it "id can be a string, if it's coercible to an integer" $ + [r| + table T { + x: byte (id: "1"); + y: byte (id: " 02 "); + z: byte (id: "0"); + } + |] `shouldValidate` foldDecls + [ table ("", TableDecl "T" NotRoot + [ TableField 0 "z" (TInt8 0) False + , TableField 1 "x" (TInt8 0) False + , TableField 2 "y" (TInt8 0) False + ] + ) + ] + + it "ids cannot be non-integral string" $ do + [r| table T { x: byte (id: "0.3"); } |] `shouldFail` "[T]: expected attribute 'id' to have an integer value, e.g. 'id: 123'" + [r| table T { x: byte (id: "hello"); } |] `shouldFail` "[T]: expected attribute 'id' to have an integer value, e.g. 'id: 123'" + + it "when one field has it, all other fields must have it as well" $ + [r| table T { x: byte (id: 0); y: int; } |] `shouldFail` + "[T]: either all fields or no fields must have an 'id' attribute" + + it "ids must be consecutive" $ + [r| table T { x: byte (id: 0); y: int (id: 2); } |] `shouldFail` + "[T.y]: field ids must be consecutive from 0; id 1 is missing" + + it "ids must start from 0" $ + [r| table T { x: byte (id: 2); y: int (id: 1); } |] `shouldFail` + "[T.y]: field ids must be consecutive from 0; id 0 is missing" + + it "can't have duplicate ids" $ + [r| table T { x: byte (id: 0); y: int (id: 0); } |] `shouldFail` + "[T.y]: field ids must be consecutive from 0; id 1 is missing" + + describe "unions" $ do + it "simple" $ + [r| + table T1{} + table T2{} + union U { T1, T2 } + |] `shouldValidate` foldDecls + [ table ("", TableDecl "T1" NotRoot []) + , table ("", TableDecl "T2" NotRoot []) + , union ("", UnionDecl "U" + [ UnionVal "T1" (TypeRef "" "T1") + , UnionVal "T2" (TypeRef "" "T2") + ]) + ] + + it "with partially qualified type reference" $ + [r| + namespace A.B; + table T1{} + table T2{} + + namespace A; + union U { A.B.T1, B.T2 } + |] `shouldValidate` foldDecls + [ table ("A.B", TableDecl "T1" NotRoot []) + , table ("A.B", TableDecl "T2" NotRoot []) + , union ("A", UnionDecl "U" + [ UnionVal "A_B_T1" (TypeRef "A.B" "T1") + , UnionVal "B_T2" (TypeRef "A.B" "T2") + ]) + ] + + it "with alias" $ + [r| + namespace A.B; + table T1{} + table T2{} + + namespace A; + union U { Alias1 : A.B.T1, Alias2:B.T2 } + |] `shouldValidate` foldDecls + [ table ("A.B", TableDecl "T1" NotRoot []) + , table ("A.B", TableDecl "T2" NotRoot []) + , union ("A", UnionDecl "U" + [ UnionVal "Alias1" (TypeRef "A.B" "T1") + , UnionVal "Alias2" (TypeRef "A.B" "T2") + ]) + ] + + it "union member must be a valid reference" $ + [r| union U { T } |] `shouldFail` + "[U.T]: type 'T' does not exist (checked in these namespaces: '')" + + it "union members must be tables" $ do + [r| union U { S } struct S {x: byte;} |] `shouldFail` "[U.S]: union members may only be tables" + [r| union U { U2 } union U2 {T} table T{} |] `shouldFail` "[U.U2]: union members may only be tables" + [r| union U { E } enum E : int {X} |] `shouldFail` "[U.E]: union members may only be tables" + [r| union U { string } |] `shouldFail` "[U.string]: type 'string' does not exist (checked in these namespaces: '')" + + it "can't have duplicate identifiers" $ do + [r| table T{} union U {T, T} |] `shouldFail` "[U]: 'T' declared more than once" + [r| namespace A; table T{} union U {A.T, A.T} |] `shouldFail` "[A.U]: 'A_T' declared more than once" + [r| namespace A; table T{} union U {A.T, A_T: T} |] `shouldFail` "[A.U]: 'A_T' declared more than once" + + it "can't use NONE as an alias" $ + [r| table T{} union U {NONE: T} |] `shouldFail` "[U]: 'NONE' declared more than once" + + it "can't refer to a table named NONE" $ + [r| table NONE {} union U {NONE} |] `shouldFail` "[U]: 'NONE' declared more than once" + + it "can refer to a table named NONE, if using a qualified name" $ + [r| + namespace A; + table NONE {} + union U {A.NONE} + |] `shouldValidate` foldDecls + [ table ("A", TableDecl "NONE" NotRoot []) + , union ("A", UnionDecl "U" + [ UnionVal "A_NONE" (TypeRef "A" "NONE") + ]) + ] + + it "can refer to a table named NONE, if using an alias" $ + [r| + namespace A; + table NONE {} + union U {alias: NONE} + |] `shouldValidate` foldDecls + [ table ("A", TableDecl "NONE" NotRoot []) + , union ("A", UnionDecl "U" + [ UnionVal "alias" (TypeRef "A" "NONE") + ]) + ] + + it "can use the same table twice, if using a qualified name" $ + [r| + namespace A; + table T{} + union U {T, A.T} + |] `shouldValidate` foldDecls + [ table ("A", TableDecl "T" NotRoot []) + , union ("A", UnionDecl "U" + [ UnionVal "T" (TypeRef "A" "T") + , UnionVal "A_T" (TypeRef "A" "T") + ]) + ] + + it "can use the same table twice, if using an alias" $ + [r| + namespace A; + table T{} + union U {T, alias:T} + |] `shouldValidate` foldDecls + [ table ("A", TableDecl "T" NotRoot []) + , union ("A", UnionDecl "U" + [ UnionVal "T" (TypeRef "A" "T") + , UnionVal "alias" (TypeRef "A" "T") + ]) + ] + + + + + + +-- -- property: struct size (including paddings) = multiple of alignment +-- -- property: alignment max alignment ??? + +foldDecls :: [ValidDecls] -> ValidDecls +foldDecls = fold + +enum :: (Namespace, EnumDecl) -> ValidDecls +enum e = SymbolTable [e] [] [] [] + +struct :: (Namespace, StructDecl) -> ValidDecls +struct s = SymbolTable [] [s] [] [] + +table :: (Namespace, TableDecl) -> ValidDecls +table t = SymbolTable [] [] [t] [] + +union :: (Namespace, UnionDecl) -> ValidDecls +union u = SymbolTable [] [] [] [u] + +shouldSucceed :: HasCallStack => String -> Expectation +shouldSucceed input = + case parse P.schema "" input of + Left e -> expectationFailure $ "Parsing failed with error:\n" <> showBundle e + Right schema -> + let schemas = FileTree "" schema [] + in case validateSchemas schemas of + Right _ -> pure () + Left err -> expectationFailure (T.unpack err) + +shouldValidate :: HasCallStack => String -> ValidDecls -> Expectation +shouldValidate input expectation = + case parse P.schema "" input of + Left e -> expectationFailure $ "Parsing failed with error:\n" <> showBundle e + Right schema -> + let schemas = FileTree "" schema [] + in validateSchemas schemas `shouldBe` Right (FileTree "" expectation []) + +shouldFail :: String -> Text -> Expectation +shouldFail input expectedErrorMsg = + case parse P.schema "" input of + Left e -> expectationFailure $ "Parsing failed with error:\n" <> showBundle e + Right schema -> + let schemas = FileTree "" schema [] + in validateSchemas schemas `shouldBe` Left expectedErrorMsg + +showBundle :: (ShowErrorComponent e, Stream s) => ParseErrorBundle s e -> String +showBundle = unlines . fmap indent . lines . errorBundlePretty + where + indent x = if null x + then x + else " " ++ x diff --git a/test/FlatBuffers/Internal/Compiler/THSpec.hs b/test/FlatBuffers/Internal/Compiler/THSpec.hs new file mode 100644 --- /dev/null +++ b/test/FlatBuffers/Internal/Compiler/THSpec.hs @@ -0,0 +1,1255 @@ +{-# 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 + diff --git a/test/FlatBuffers/ReadSpec.hs b/test/FlatBuffers/ReadSpec.hs new file mode 100644 --- /dev/null +++ b/test/FlatBuffers/ReadSpec.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} + +module FlatBuffers.ReadSpec where + +import Control.Exception ( evaluate ) + +import Data.Functor ( ($>) ) +import Data.Int +import qualified Data.Maybe as Maybe + +import Examples + +import FlatBuffers.Internal.Read +import FlatBuffers.Internal.Write +import qualified FlatBuffers.Vector as Vec + +import TestImports + +spec :: Spec +spec = + describe "read" $ do + it "fails when buffer is exhausted" $ + decode @() "" `shouldBeLeft` "not enough bytes" + + it "fails when decoding string with invalid UTF-8 bytes" $ do + let text = Vec.singleton 255 + table <- evalRight $ decode $ encode $ writeTable + [ missing, missing, missing, missing + , missing, missing, missing, missing + , missing, missing, missing + , writeVectorWord8TableField text + ] + primitivesL table `shouldBeLeft` + "UTF8 decoding error (byte 255): Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" + + it "fails when required field is missing" $ do + table <- evalRight $ decode @RequiredFields $ encode $ writeTable [] + requiredFieldsA table `shouldBeLeft` "Missing required table field: a" + requiredFieldsB table `shouldBeLeft` "Missing required table field: b" + requiredFieldsC table `shouldBeLeft` "Missing required table field: c" + requiredFieldsE table `shouldBeLeft` "Missing required table field: e" + + table <- evalRight $ decode @VectorOfUnions $ encode $ writeTable [] + vectorOfUnionsXsReq table `shouldBeLeft` "Missing required table field: xsReq" + + it "returns `UnionNone` when required union field is missing" $ do + table <- evalRight $ decode @RequiredFields $ encode $ writeTable [] + requiredFieldsD table `shouldBeRightAndExpect` \case + UnionNone -> pure () + + table <- evalRight $ decode @RequiredFields $ encode $ writeTable [ missing ] + requiredFieldsD table `shouldBeRightAndExpect` \case + UnionNone -> pure () + + it "throws when union type is present, but union value is missing" $ do + table <- evalRight $ decode $ encode $ writeTable [ writeWord8TableField 1] + tableWithUnionUni table `shouldBeLeft` "Union: 'union type' found but 'union value' is missing." + + it "throws when union type vector is present, but union value vector is missing" $ do + table <- evalRight $ decode $ encode $ writeTable + [ writeVectorWord8TableField Vec.empty + , missing + , missing + , missing + , writeVectorWord8TableField Vec.empty + , missing + ] + vectorOfUnionsXs table `shouldBeLeft` "Union vector: 'type vector' found but 'value vector' is missing." + vectorOfUnionsXsReq table `shouldBeLeft` "Union vector: 'type vector' found but 'value vector' is missing." + + it "throws when union type vector and union value vector have different sizes" $ do + let typesVec = Vec.singleton 1 + let valuesVec = Vec.empty + table <- evalRight $ decode $ encode $ writeTable + [ writeVectorWord8TableField typesVec + , writeVectorTableTableField valuesVec + ] + vec <- evalRightJust $ vectorOfUnionsXs table + toList vec `shouldBeLeft` "Union vector: 'type vector' and 'value vector' do not have the same length." + + describe "returns `UnionUnknown` when union type is not recognized" $ do + it "in union table fields" $ do + let union = writeUnion 99 (writeTable []) + table <- evalRight $ decode $ encode $ tableWithUnion union + tableWithUnionUni table `shouldBeRightAndExpect` \case + UnionUnknown n -> n `shouldBe` 99 + + it "in union vectors" $ do + let union = writeUnion 99 (writeTable []) + + result <- evalRight $ do + table <- decode $ encode $ vectorOfUnions Nothing (Vec.singleton union) + vec <- vectorOfUnionsXsReq table + vec `unsafeIndex` 0 + + case result of + UnionUnknown n -> n `shouldBe` 99 + + describe "vectors" $ do + let getIndex :: Table b + -> (Table b -> Either ReadError (Maybe (Vector a))) + -> (Vector a -> Int32 -> Either ReadError a) + -> Int32 + -> Either ReadError a + getIndex table getVector indexFn ix = do + vec <- getVector table + Maybe.fromJust vec `indexFn` ix + + + let testNegativeIndex table getVector = + (case getIndex table getVector Vec.index (-1) of + Right a -> evaluate a $> () + Left e -> evaluate e $> () + ) `shouldThrow` errorCall "FlatBuffers.Internal.Read.index: negative index: -1" + + let testLargeIndex table getVector = + (case getIndex table getVector Vec.index 98 of + Right a -> evaluate a $> () + Left e -> evaluate e $> () + ) `shouldThrow` errorCall "FlatBuffers.Internal.Read.index: index too large: 98" + + let testLargeUnsafeIndex table getVector = do + case getIndex table getVector Vec.unsafeIndex 100 of + Right a -> evaluate a $> () + Left e -> evaluate e $> () + case getIndex table getVector Vec.unsafeIndex (-100) of + Right a -> evaluate a $> () + Left e -> evaluate e $> () + + describe "of primitives" $ do + let Right table = 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) + + it "`unsafeIndex` does not throw when index is negative / too large" $ do + testLargeUnsafeIndex table vectorsA + testLargeUnsafeIndex table vectorsB + testLargeUnsafeIndex table vectorsC + testLargeUnsafeIndex table vectorsD + testLargeUnsafeIndex table vectorsE + testLargeUnsafeIndex table vectorsF + testLargeUnsafeIndex table vectorsG + testLargeUnsafeIndex table vectorsH + testLargeUnsafeIndex table vectorsI + testLargeUnsafeIndex table vectorsJ + testLargeUnsafeIndex table vectorsK + testLargeUnsafeIndex table vectorsL + + it "`index` throws when index is negative" $ do + testNegativeIndex table vectorsA + testNegativeIndex table vectorsB + testNegativeIndex table vectorsC + testNegativeIndex table vectorsD + testNegativeIndex table vectorsE + testNegativeIndex table vectorsF + testNegativeIndex table vectorsG + testNegativeIndex table vectorsH + testNegativeIndex table vectorsI + testNegativeIndex table vectorsJ + testNegativeIndex table vectorsK + testNegativeIndex table vectorsL + + it "`index` throws when index is too large" $ do + testLargeIndex table vectorsA + testLargeIndex table vectorsB + testLargeIndex table vectorsC + testLargeIndex table vectorsD + testLargeIndex table vectorsE + testLargeIndex table vectorsF + testLargeIndex table vectorsG + testLargeIndex table vectorsH + testLargeIndex table vectorsI + testLargeIndex table vectorsJ + testLargeIndex table vectorsK + testLargeIndex table vectorsL + + describe "of structs" $ do + let Right table = decode $ encode $ vectorOfStructs + (Just Vec.empty) + (Just Vec.empty) + (Just Vec.empty) + (Just Vec.empty) + + it "`unsafeIndex` does not throw when index is negative / too large" $ + testLargeUnsafeIndex table vectorOfStructsAs + + it "`index` throws when index is negative" $ + testNegativeIndex table vectorOfStructsAs + + it "`index` throws when index is too large" $ + testLargeIndex table vectorOfStructsAs + + describe "of tables" $ do + let Right table = decode $ encode $ vectorOfTables + (Just Vec.empty) + + it "`unsafeIndex` does not throw when index is negative / too large" $ + testLargeUnsafeIndex table vectorOfTablesXs + + it "`index` throws when index is negative" $ + testNegativeIndex table vectorOfTablesXs + + it "`index` throws when index is too large" $ + testLargeIndex table vectorOfTablesXs + + describe "of unions" $ do + let Right table = decode $ encode $ vectorOfUnions + (Just Vec.empty) + Vec.empty + + it "`unsafeIndex` does not throw when index is negative / too large" $ + testLargeUnsafeIndex table vectorOfUnionsXs + + it "`index` throws when index is negative" $ + testNegativeIndex table vectorOfUnionsXs + + it "`index` throws when index is too large" $ + testLargeIndex table vectorOfUnionsXs diff --git a/test/FlatBuffers/RoundTripSpec.hs b/test/FlatBuffers/RoundTripSpec.hs new file mode 100644 --- /dev/null +++ b/test/FlatBuffers/RoundTripSpec.hs @@ -0,0 +1,437 @@ +{-# 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.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 (fromColor ColorGreen)) 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 "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` Right (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` Right 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` Right 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` Right 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` Right 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` Right 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` Right 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` Right 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` Right 0 + (toList as >>= traverse readStruct1) `shouldBe` Right [] + + Vec.length bs `shouldBe` Right 0 + (toList bs >>= traverse readStruct2) `shouldBe` Right [] + + Vec.length cs `shouldBe` Right 0 + (toList cs >>= traverse readStruct3) `shouldBe` Right [] + + Vec.length ds `shouldBe` Right 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` Right 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` Right 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` Right 0 + L.length <$> toList xs `shouldBe` Right 0 + + xsReq <- evalRight $ vectorOfUnionsXsReq x + Vec.length xsReq `shouldBe` Right 0 + L.length <$> toList xsReq `shouldBe` Right 0 + + it "missing" $ do + x <- evalRight $ decode $ encode $ vectorOfUnions Nothing Vec.empty + vectorOfUnionsXs x `shouldBeRightAnd` isNothing + (vectorOfUnionsXsReq x >>= Vec.length) `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) + + 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)) + + it "missing" $ runTest $ scalarsWithDefaults + 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] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/TestImports.hs b/test/TestImports.hs new file mode 100644 --- /dev/null +++ b/test/TestImports.hs @@ -0,0 +1,102 @@ +module TestImports + ( module Hspec + , module Hedgehog + , HasCallStack + , shouldBeLeft + , shouldBeRightAnd + , shouldBeRightAndExpect + , evalRight + , evalJust + , evalRightJust + , liftA4 + , PrettyJson(..) + , shouldBeJson + , showBuffer + , traceBufferM + ) where + +import Control.Monad ( (>=>) ) + +import qualified Data.Aeson as J +import Data.Aeson.Encode.Pretty ( encodePretty ) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.UTF8 as BSLU +import qualified Data.List as List + +import Debug.Trace + +import GHC.Stack ( HasCallStack ) + +import HaskellWorks.Hspec.Hedgehog as Hedgehog + +import Hedgehog + +import Test.HUnit ( assertFailure ) +import Test.Hspec.Core.Hooks as Hspec +import Test.Hspec.Core.Spec as Hspec +import Test.Hspec.Expectations.Pretty as Hspec +import Test.Hspec.Runner as Hspec + + +-- | Useful when there's no `Show`/`Eq` instances for @a@. +shouldBeLeft :: HasCallStack => Show e => Eq e => Either e a -> e -> Expectation +shouldBeLeft ea expected = case ea of + Left e -> e `shouldBe` expected + Right _ -> expectationFailure "Expected 'Left', got 'Right'" + +shouldBeRightAnd :: HasCallStack => Show e => Either e a -> (a -> Bool) -> Expectation +shouldBeRightAnd ea pred = case ea of + Left e -> expectationFailure $ "Expected 'Right', got 'Left':\n" <> show e + Right a -> pred a `shouldBe` True + +shouldBeRightAndExpect :: HasCallStack => Show e => Either e a -> (a -> Expectation) -> Expectation +shouldBeRightAndExpect ea expect = case ea of + Left e -> expectationFailure $ "Expected 'Right', got 'Left':\n" <> show e + Right a -> expect a + +evalRight :: HasCallStack => Show e => Either e a -> IO a +evalRight ea = case ea of + Left e -> expectationFailure' $ "Expected 'Right', got 'Left':\n" <> show e + Right a -> pure a + +evalJust :: HasCallStack => Maybe a -> IO a +evalJust mb = case mb of + Nothing -> expectationFailure' "Expected 'Just', got 'Nothing'" + Just a -> pure a + +evalRightJust :: HasCallStack => Show e => Either e (Maybe a) -> IO a +evalRightJust = evalRight >=> evalJust + +-- | Like `expectationFailure`, but returns @IO a@ instead of @IO ()@. +expectationFailure' :: HasCallStack => String -> IO a +expectationFailure' = Test.HUnit.assertFailure + +-- | Allows Json documents to be compared (using e.g. `shouldBe`) and pretty-printed in case the comparison fails. +newtype PrettyJson = PrettyJson J.Value + deriving Eq + +instance Show PrettyJson where + show (PrettyJson v) = BSLU.toString (encodePretty v) + +shouldBeJson :: HasCallStack => J.Value -> J.Value -> Expectation +shouldBeJson x y = PrettyJson x `shouldBe` PrettyJson y + +liftA4 :: + Applicative m => + (a -> b -> c -> d -> r) -> m a -> m b -> m c -> m d -> m r +liftA4 fn a b c d = fn <$> a <*> b <*> c <*> d + + +traceBufferM :: Applicative m => BSL.ByteString -> m () +traceBufferM = traceM . showBuffer + +showBuffer :: BSL.ByteString -> String +showBuffer bs = + List.intercalate "\n" . fmap (List.intercalate ", ") . groupsOf 4 . fmap show $ + BSL.unpack bs + +groupsOf :: Int -> [a] -> [[a]] +groupsOf n xs = + case take n xs of + [] -> [] + group -> group : groupsOf n (drop n xs)