flatbuffers (empty) → 0.1.0.0
raw patch · 40 files changed
+10584/−0 lines, 40 filesdep +HUnitdep +aesondep +aeson-prettysetup-changed
Dependencies added: HUnit, aeson, aeson-pretty, base, binary, bytestring, containers, criterion, directory, filepath, flatbuffers, hedgehog, hspec, hspec-core, hspec-expectations-pretty-diff, hspec-megaparsec, http-client, http-types, hw-hspec-hedgehog, megaparsec, mtl, parser-combinators, process, raw-strings-qq, scientific, template-haskell, text, text-manipulate, th-pprint, utf8-string, vector
Files
- LICENSE +30/−0
- README.md +348/−0
- Setup.hs +2/−0
- bench/DecodeVectors.hs +114/−0
- bench/Encode.hs +29/−0
- bench/EncodeVectors.hs +182/−0
- bench/Main.hs +15/−0
- bench/Types.hs +7/−0
- cbits/cbits.c +78/−0
- flatbuffers.cabal +159/−0
- src/FlatBuffers.hs +39/−0
- src/FlatBuffers/Internal/Build.hs +62/−0
- src/FlatBuffers/Internal/Compiler/Display.hs +30/−0
- src/FlatBuffers/Internal/Compiler/NamingConventions.hs +55/−0
- src/FlatBuffers/Internal/Compiler/Parser.hs +304/−0
- src/FlatBuffers/Internal/Compiler/ParserIO.hs +85/−0
- src/FlatBuffers/Internal/Compiler/SemanticAnalysis.hs +924/−0
- src/FlatBuffers/Internal/Compiler/SyntaxTree.hs +198/−0
- src/FlatBuffers/Internal/Compiler/TH.hs +848/−0
- src/FlatBuffers/Internal/Compiler/ValidSyntaxTree.hs +187/−0
- src/FlatBuffers/Internal/Constants.hs +49/−0
- src/FlatBuffers/Internal/FileIdentifier.hs +59/−0
- src/FlatBuffers/Internal/Read.hs +611/−0
- src/FlatBuffers/Internal/Types.hs +28/−0
- src/FlatBuffers/Internal/Util.hs +35/−0
- src/FlatBuffers/Internal/Write.hs +749/−0
- src/FlatBuffers/Vector.hs +24/−0
- test/Examples.hs +5/−0
- test/Examples/Generated.hs +8/−0
- test/Examples/HandWritten.hs +638/−0
- test/FlatBuffers/AlignmentSpec.hs +478/−0
- test/FlatBuffers/Integration/HaskellToScalaSpec.hs +97/−0
- test/FlatBuffers/Integration/RoundTripThroughFlatcSpec.hs +658/−0
- test/FlatBuffers/Internal/Compiler/ParserSpec.hs +268/−0
- test/FlatBuffers/Internal/Compiler/SemanticAnalysisSpec.hs +1154/−0
- test/FlatBuffers/Internal/Compiler/THSpec.hs +1255/−0
- test/FlatBuffers/ReadSpec.hs +232/−0
- test/FlatBuffers/RoundTripSpec.hs +437/−0
- test/Spec.hs +1/−0
- test/TestImports.hs +102/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,348 @@+# Haskell Flatbuffers++An implementation of the [flatbuffers protocol][flatbuffers] in Haskell.++[](https://travis-ci.com/dcastro/haskell-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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/DecodeVectors.hs view
@@ -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))++
+ bench/Encode.hs view
@@ -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+ ]+ ]++
+ bench/EncodeVectors.hs view
@@ -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)
+ bench/Main.hs view
@@ -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+ ]
+ bench/Types.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-}++module Types where++import FlatBuffers++$(mkFlatBuffers "bench/types.fbs" defaultOptions)
+ cbits/cbits.c view
@@ -0,0 +1,78 @@+/*+ * See https://github.com/haskell/text/blob/9fac5db9b048b7d68fa2fb68513ba86c791b3630/cbits/cbits.c for details.+ */++#include <string.h>+#include <stdint.h>+#include <stdio.h>++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;+}
+ flatbuffers.cabal view
@@ -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: <https://github.com/dcastro/haskell-flatbuffers>+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
+ src/FlatBuffers.hs view
@@ -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+
+ src/FlatBuffers/Internal/Build.hs view
@@ -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
+ src/FlatBuffers/Internal/Compiler/Display.hs view
@@ -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
+ src/FlatBuffers/Internal/Compiler/NamingConventions.hs view
@@ -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+
+ src/FlatBuffers/Internal/Compiler/Parser.hs view
@@ -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
+ src/FlatBuffers/Internal/Compiler/ParserIO.hs view
@@ -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)
+ src/FlatBuffers/Internal/Compiler/SemanticAnalysis.hs view
@@ -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+++
+ src/FlatBuffers/Internal/Compiler/SyntaxTree.hs view
@@ -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
+ src/FlatBuffers/Internal/Compiler/TH.hs view
@@ -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))
+ src/FlatBuffers/Internal/Compiler/ValidSyntaxTree.hs view
@@ -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)
+ src/FlatBuffers/Internal/Constants.hs view
@@ -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 #-}++
+ src/FlatBuffers/Internal/FileIdentifier.hs view
@@ -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
+ src/FlatBuffers/Internal/Read.hs view
@@ -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)
+ src/FlatBuffers/Internal/Types.hs view
@@ -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)+
+ src/FlatBuffers/Internal/Util.hs view
@@ -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
+ src/FlatBuffers/Internal/Write.hs view
@@ -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
+ src/FlatBuffers/Vector.hs view
@@ -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+++
+ test/Examples.hs view
@@ -0,0 +1,5 @@+module Examples+ ( module Examples.Generated+ ) where++import Examples.Generated
+ test/Examples/Generated.hs view
@@ -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)
+ test/Examples/HandWritten.hs view
@@ -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"+
+ test/FlatBuffers/AlignmentSpec.hs view
@@ -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)
+ test/FlatBuffers/Integration/HaskellToScalaSpec.hs view
@@ -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))
+ test/FlatBuffers/Integration/RoundTripThroughFlatcSpec.hs view
@@ -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
+ test/FlatBuffers/Internal/Compiler/ParserSpec.hs view
@@ -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++
+ test/FlatBuffers/Internal/Compiler/SemanticAnalysisSpec.hs view
@@ -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
+ test/FlatBuffers/Internal/Compiler/THSpec.hs view
@@ -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+
+ test/FlatBuffers/ReadSpec.hs view
@@ -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
+ test/FlatBuffers/RoundTripSpec.hs view
@@ -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]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/TestImports.hs view
@@ -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)