flatbuffers 0.1.0.0 → 0.2.0.0

raw patch · 27 files changed

+2409/−985 lines, 27 filesdep +mono-traversablePVP ok

version bump matches the API change (PVP)

Dependencies added: mono-traversable

API changes (from Hackage documentation)

Files

• CHANGELOG.md +24/−0
• README.md +133/−53
• bench/DecodeVectors.hs +11/−0
• bench/EncodeVectors.hs +66/−21
• flatbuffers.cabal +6/−3
• src/FlatBuffers/Internal/Compiler/Display.hs +20/−12
• src/FlatBuffers/Internal/Compiler/NamingConventions.hs +19/−3
• src/FlatBuffers/Internal/Compiler/Parser.hs +16/−3
• src/FlatBuffers/Internal/Compiler/ParserIO.hs +8/−10
• src/FlatBuffers/Internal/Compiler/SemanticAnalysis.hs +378/−241
• src/FlatBuffers/Internal/Compiler/SyntaxTree.hs +10/−5
• src/FlatBuffers/Internal/Compiler/TH.hs +148/−30
• src/FlatBuffers/Internal/Compiler/ValidSyntaxTree.hs +11/−10
• src/FlatBuffers/Internal/Read.hs +196/−130
• src/FlatBuffers/Internal/Types.hs +3/−2
• src/FlatBuffers/Internal/Util.hs +0/−35
• src/FlatBuffers/Internal/Write.hs +141/−84
• src/FlatBuffers/Vector.hs +6/−0
• test/Examples/Generated.hs +1/−1
• test/Examples/HandWritten.hs +102/−7
• test/FlatBuffers/AlignmentSpec.hs +1/−1
• test/FlatBuffers/Integration/RoundTripThroughFlatcSpec.hs +84/−6
• test/FlatBuffers/Internal/Compiler/ParserSpec.hs +253/−208
• test/FlatBuffers/Internal/Compiler/SemanticAnalysisSpec.hs +337/−66
• test/FlatBuffers/Internal/Compiler/THSpec.hs +193/−10
• test/FlatBuffers/ReadSpec.hs +169/−26
• test/FlatBuffers/RoundTripSpec.hs +73/−18

@@ -0,0 +1,24 @@+# Changelog+++## 0.2.0.0 (2019-10-21)+++* Add support for bitmasks, i.e. enums with the `bit_flags` attribute.+* `FlatBuffers.Vector.length` changed from `Either ReadError Int32` to `Int32`.+  * Vector length is now read once upfront, rather than on every access.+* Added to `FlatBuffers.Vector`:+  * `fromByteString`+  * `fromLazyByteString`+  * `fromMonoFoldable` (supports `Data.Vector.Unboxed` and `Data.Vector.Storable`)+  * `take`+  * `drop`+  * `toByteString`+* TemplateHaskell:+  * Added `colorName` for enums.+  * Fixed error messages when running `ghcid` (they used to be truncated).+++## 0.1.0.0 (2019-09-22)++* First version.

@@ -6,11 +6,12 @@ [![Hackage](https://img.shields.io/hackage/v/flatbuffers)](http://hackage.haskell.org/package/flatbuffers)  - [Getting started](#getting-started)+  - [Codegen](#codegen)   - [Enums](#enums)+  - [Bit flags / Bitmasks](#bit-flags--bitmasks)   - [Structs](#structs)   - [Unions](#unions)   - [File Identifiers](#file-identifiers)-- [Codegen](#codegen) - [TODO](#todo)  @@ -57,18 +58,20 @@ ```haskell {-# LANGUAGE OverloadedStrings #-} +import           Data.ByteString.Lazy (ByteString) import           FlatBuffers import qualified FlatBuffers.Vector as Vector  -- Writing-let byteString = encode $+byteString = encode $       monster         (Just "Poring")         (Just 50)         (Vector.fromList 2 ["Prontera Field", "Payon Forest"])  -- Reading-do+readMonster :: ByteString -> Either ReadError String+readMonster byteString = do   someMonster <- decode byteString   name        <- monsterName someMonster   hp          <- monsterHp someMonster@@ -76,12 +79,46 @@   Right ("Monster: " <> show name <> " (" <> show hp <> " HP) can be found in " <> show locations) ``` -For more info on code generation and examples, see [codegen](#codegen).+For the rest of this document, we'll assume these imports/extensions are enabled: +```haskell+{-# LANGUAGE OverloadedStrings #-}++import           Data.ByteString.Lazy (ByteString)+import           Data.Text (Text)+import qualified Data.Text as Text+import           FlatBuffers+import qualified FlatBuffers.Vector as Vector+```++### 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.+ ### Enums  ```-enum Color: short { Red, Green, Blue }+enum Color: short {+  Red, Green, Blue+} ```  Given the enum declarationa above, the following code will be generated:@@ -95,6 +132,8 @@  toColor   :: Int16 -> Maybe Color fromColor :: Color -> Int16++colorName :: Color -> Text ```  Usage:@@ -110,22 +149,81 @@  monster      :: Maybe Int16 -> WriteTable Monster monsterColor :: Table Monster -> Either ReadError Int16+``` +```haskell -- Writing-let byteString = encode $+byteString = encode $       monster (Just (fromColor ColorBlue))  -- Reading-do+readMonster :: ByteString -> Either ReadError Text+readMonster byteString = 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+  i           <- monsterColor someMonster+  case toColor i of+    Just color -> Right ("This monster is " <> colorName color)+    Nothing    -> Left ("Unknown color: " <> show i) -- Forwards compatibility ``` +### Bit flags / Bitmasks++```+enum Colors: uint16 (bit_flags) {+  Red, Green, Blue+}+```++Given the enum declarationa above, the following code will be generated:++```haskell+colorsRed, colorsGreen, colorsBlue :: Word16+colorsRed = 1+colorsGreen = 2+colorsBlue = 4++allColors :: [Word16]++colorsNames :: Word16 -> [Text]+```++Usage:++```+table Monster {+  colors: Colors = "Red Blue";+}+```++```haskell+data Monster++monster       :: Maybe Word16 -> WriteTable Monster+monsterColors :: Table Monster -> Either ReadError Word16+```++```haskell+import Control.Monad.Except (MonadError, MonadIO, liftEither, liftIO)+import Data.Bits ((.|.), (.&.))+import qualified Data.Text.IO as Text++-- Writing+byteString = encode $+      monster (Just (colorsBlue .|. colorsGreen))++-- Reading+readMonster :: (MonadIO m, MonadError ReadError m) => ByteString -> m ()+readMonster byteString = do+  someMonster <- liftEither $ decode byteString+  colors      <- liftEither $ monsterColors someMonster++  let isRed = colors .&. colorsRed /= 0+  liftIO $ putStrLn $ "Is this monster red? " <> if isRed then "Yes" else "No"++  liftIO $ Text.putStrLn $ "Monster colors: " <> Text.intercalate ", " (colorsNames colors)+```++ ### Structs  ```@@ -162,13 +260,16 @@  monster         :: WriteStruct Coord -> WriteTable Monster monsterPosition :: Table Monster -> Either ReadError (Struct Coord)+``` +```haskell -- Writing-let byteString = encode $+byteString = encode $       monster (coord 123 456)  -- Reading-do+readMonster :: ByteString -> Either ReadError String+readMonster byteString = do   someMonster <- decode byteString   pos         <- monsterPosition someMonster   x           <- coordX pos@@ -210,14 +311,17 @@  character       :: WriteUnion Weapon -> WriteTable Character characterWeapon :: Table Character -> Either ReadError (Union Weapon)+``` +```haskell -- Writing-let byteString = encode $+byteString = encode $       character         (weaponSword (sword (Just 1000)))  -- Reading-do+readCharacter :: ByteString -> Either ReadError String+readCharacter byteString = do   someCharacter <- decode byteString   weapon        <- characterWeapon someCharacter   case weapon of@@ -237,7 +341,7 @@ To create a character with no weapon, use `none :: WriteUnion a`  ```haskell-let byteString = encode $+byteString = encode $       character none ``` @@ -270,42 +374,22 @@ {-# LANGUAGE TypeApplications #-}  -- Writing-let byteString = encodeWithFileIdentifier $+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+readName :: ByteString -> Either ReadError (Maybe Text)+readName byteString = do+  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" ``` -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@@ -323,7 +407,6 @@     - [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)@@ -334,13 +417,10 @@ ### 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

@@ -5,6 +5,7 @@ {-# OPTIONS_GHC -Wno-incomplete-patterns #-}  {- HLINT ignore "Avoid lambda" -}+{- HLINT ignore "Use >=>" -}  module DecodeVectors where @@ -62,6 +63,11 @@             )             $ vectorsTable >>= vectorsG +        , bench "struct" $ nf (\(Right (Just vec)) ->+              forM [0..(n-1)] (\i -> vec `unsafeIndex` i >>= structWithOneIntX)+            )+            $ vectorsTable >>= vectorsM+         , bench "string" $ nf (\(Right (Just vec)) ->               forM [0..(n-1)] (\i -> vec `unsafeIndex` i)             )@@ -77,6 +83,11 @@               forM [0..(n-1)] (\i -> vec `index` i)             )             $ vectorsTable >>= vectorsG++        , bench "struct" $ nf (\(Right (Just vec)) ->+              forM [0..(n-1)] (\i -> vec `index` i >>= structWithOneIntX)+            )+            $ vectorsTable >>= vectorsM          , bench "string" $ nf (\(Right (Just vec)) ->               forM [0..(n-1)] (\i -> vec `index` i)

@@ -4,20 +4,27 @@  module EncodeVectors where +{- HLINT ignore "Avoid lambda" -}+ import           Criterion -import           Data.Foldable      as F-import           Data.Functor       ( (<&>) )+import qualified Data.ByteString      as BS+import qualified Data.ByteString.Lazy as BSL+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 qualified Data.List            as L+import           Data.Text            ( Text )+import qualified Data.Vector          as V+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed  as VU  import           FlatBuffers-import qualified FlatBuffers.Vector as Vec+import qualified FlatBuffers.Vector   as Vec  import           Types + n :: Num a => a n = 10000 @@ -28,7 +35,7 @@       [ bench "of ints" $ nf (\xs ->           encode . vectorOfInts . Just . Vec.fromList (fromIntegral (F.length xs)) $             xs-        ) $ mkIntList n+        ) $ mkNumList n        , bench "of ints (with fusion)" $ nf (\xs ->           encode . vectorOfInts . Just . Vec.fromList (fromIntegral (F.length xs)) $@@ -38,7 +45,7 @@       , bench "of structs (1 int field)" $ nf (\xs ->           encode . vectorOfStructWithOneInt . Just . Vec.fromList (fromIntegral (F.length xs)) $             structWithOneInt <$> xs-        ) $ mkIntList n+        ) $ mkNumList n        , bench "of structs (2 ints fields)" $ nf (\xs ->           encode . vectorOfPairs . Just . Vec.fromList (fromIntegral (F.length xs)) $@@ -80,57 +87,83 @@      , bgroup "from vector"       [ bench "of ints" $ nf (\xs ->-          encode . vectorOfInts . Just . Vec.fromFoldable (fromIntegral (F.length xs)) $+          encode . vectorOfInts . Just . Vec.fromMonoFoldable (fromIntegral (F.length xs)) $             xs         ) $ mkIntVector n        , bench "of ints (with fusion)" $ nf (\xs ->-          encode . vectorOfInts . Just . Vec.fromFoldable (fromIntegral (F.length xs)) $+          encode . vectorOfInts . Just . Vec.fromMonoFoldable (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)) $+          encode . vectorOfStructWithOneInt . Just . Vec.fromMonoFoldable (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)) $+          encode . vectorOfPairs . Just . Vec.fromMonoFoldable (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)) $+          encode . vectorOfStrings . Just . Vec.fromMonoFoldable (fromIntegral (F.length xs)) $             xs         ) $ mkTextVector n        , bench "of short strings (with fusion)" $ nf (\xs ->-          encode . vectorOfStrings . Just . Vec.fromFoldable (fromIntegral (F.length xs)) $+          encode . vectorOfStrings . Just . Vec.fromMonoFoldable (fromIntegral (F.length xs)) $             userName <$> xs         ) $ mkUserVector n        , bench "of long strings" $ nf (\xs ->-          encode . vectorOfStrings . Just . Vec.fromFoldable (fromIntegral (F.length xs)) $+          encode . vectorOfStrings . Just . Vec.fromMonoFoldable (fromIntegral (F.length xs)) $             xs         ) $ mkLongTextVector n        , bench "of tables (2 int fields)" $ nf (\xs ->-          encode . vectorOfTables . Just . Vec.fromFoldable (fromIntegral (F.length xs)) $+          encode . vectorOfTables . Just . Vec.fromMonoFoldable (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)) $+          encode . vectorOfUsers . Just . Vec.fromMonoFoldable (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)) $+          encode . vectorOfUnions . Just . Vec.fromMonoFoldable (fromIntegral (F.length xs)) $             xs <&> \case               Sword x -> weaponUnionSword (swordTable (Just x))               Axe x   -> weaponUnionAxe   (axeTable   (Just x))         ) $ mkWeaponVector n       ]++    , bgroup "from unboxed vector"+      [ bench "of ints" $ nf (\xs ->+          encode . vectorOfInts . Just . Vec.fromMonoFoldable (fromIntegral (VU.length xs)) $+            xs+        ) $ mkIntUnboxedVector n+      ]++    , bgroup "from storable vector"+      [ bench "of ints" $ nf (\xs ->+          encode . vectorOfInts . Just . Vec.fromMonoFoldable (fromIntegral (VS.length xs)) $+            xs+        ) $ mkIntStorableVector n+      ]++    , bgroup "from bytestring"+      [ bench "strict" $ nf (\xs ->+          encode . vectorOfBytes . Just . Vec.fromByteString $+            xs+        ) $ mkByteString n++      , bench "lazy" $ nf (\xs ->+          encode . vectorOfBytes . Just . Vec.fromLazyByteString $+            xs+        ) $ mkLazyByteString n+      ]     ]   ] @@ -154,8 +187,8 @@       then Sword i       else Axe i -mkIntList :: Int32 -> [Int32]-mkIntList n = [1..n]+mkNumList :: Num a => Int32 -> [a]+mkNumList len = fromIntegral <$> [1 .. len]  mkTextList :: Int -> [Text] mkTextList n = L.replicate n "abcdefghijk"@@ -173,7 +206,19 @@ mkWeaponVector n = V.fromList (mkWeaponList n)  mkIntVector :: Int32 -> V.Vector Int32-mkIntVector n = V.fromList (mkIntList n)+mkIntVector n = V.fromList (mkNumList n)++mkIntUnboxedVector :: Int32 -> VU.Vector Int32+mkIntUnboxedVector n = VU.fromList (mkNumList n)++mkIntStorableVector :: Int32 -> VS.Vector Int32+mkIntStorableVector n = VS.fromList (mkNumList n)++mkByteString :: Int32 -> BS.ByteString+mkByteString = BS.pack . mkNumList++mkLazyByteString :: Int32 -> BSL.ByteString+mkLazyByteString = BSL.pack . mkNumList  mkTextVector :: Int -> V.Vector Text mkTextVector n = V.fromList (mkTextList n)

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 772c6499fd4f79ba88bf1b70ce28991443be358e6e1e5b7dddc77d61585751ba+-- hash: 0fec28e13f905ed1bcbecf99c8430313dbcfab66b57aa92451de82fd8804e5ea  name:           flatbuffers-version:        0.1.0.0+version:        0.2.0.0 synopsis:       Haskell implementation of the FlatBuffers protocol. description:    Haskell implementation of the FlatBuffers protocol.                 .@@ -24,6 +24,7 @@ build-type:     Simple extra-source-files:     README.md+    CHANGELOG.md     cbits/cbits.c extra-doc-files:     README.md@@ -48,7 +49,6 @@       FlatBuffers.Internal.FileIdentifier       FlatBuffers.Internal.Read       FlatBuffers.Internal.Types-      FlatBuffers.Internal.Util       FlatBuffers.Internal.Write       FlatBuffers.Vector   other-modules:@@ -66,6 +66,7 @@     , directory >=1.3.1.2     , filepath >=1.4.2     , megaparsec >=7.0+    , mono-traversable >=1.0.1.2     , mtl >=2.2.1     , parser-combinators >=1.0     , scientific >=0.3.5.2@@ -114,6 +115,7 @@     , http-types     , hw-hspec-hedgehog     , megaparsec >=7.0+    , mono-traversable >=1.0.1.2     , mtl >=2.2.1     , parser-combinators >=1.0     , process@@ -149,6 +151,7 @@     , filepath >=1.4.2     , flatbuffers     , megaparsec >=7.0+    , mono-traversable >=1.0.1.2     , mtl >=2.2.1     , parser-combinators >=1.0     , scientific >=0.3.5.2

@@ -1,30 +1,38 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}  module FlatBuffers.Internal.Compiler.Display where +import           Data.Int+import qualified Data.List          as List import           Data.List.NonEmpty ( NonEmpty ) import qualified Data.List.NonEmpty as NE import qualified Data.Text          as T-import           Data.Text          ( Text )+import           Data.Word  -- | 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+  display :: a -> String -instance Display Text where+instance {-# OVERLAPPING #-} Display String where   display = id +instance Display T.Text where+  display = T.unpack+ 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 <> "'"+  display xs = List.intercalate ", " (fmap display xs) -instance Display Integer where-  display = displayFromShow+instance Display Int     where display = show+instance Display Integer where display = show+instance Display Int8    where display = show+instance Display Int16   where display = show+instance Display Int32   where display = show+instance Display Int64   where display = show+instance Display Word8   where display = show+instance Display Word16  where display = show+instance Display Word32  where display = show+instance Display Word64  where display = show -displayFromShow :: Show a => a -> Text-displayFromShow = T.pack . show

@@ -7,7 +7,7 @@ import qualified Data.Text                                     as T import qualified Data.Text.Manipulate                          as TM -import           FlatBuffers.Internal.Compiler.ValidSyntaxTree ( EnumDecl, HasIdent(..), Ident(..), Namespace(..), UnionDecl, UnionVal )+import           FlatBuffers.Internal.Compiler.ValidSyntaxTree ( EnumDecl, EnumVal, HasIdent(..), Ident(..), Namespace(..), UnionDecl, UnionVal )  -- Style guide: https://google.github.io/flatbuffers/flatbuffers_guide_writing_schema.html @@ -39,9 +39,25 @@ enumUnionMember (getIdent -> Ident parentIdent) (getIdent -> Ident valIdent) =   TM.toPascal parentIdent <> TM.toPascal valIdent +enumBitFlagsConstant :: EnumDecl -> EnumVal -> Text+enumBitFlagsConstant (getIdent -> Ident enumIdent) (getIdent -> Ident enumValIdent) =+  TM.toCamel enumIdent <> TM.toPascal enumValIdent++enumBitFlagsAllFun :: EnumDecl -> Text+enumBitFlagsAllFun (getIdent -> Ident enumIdent) =+  "all" <> TM.toPascal enumIdent++enumBitFlagsNamesFun :: EnumDecl -> Text+enumBitFlagsNamesFun (getIdent -> Ident enumIdent) =+  TM.toCamel enumIdent <> "Names"++enumNameFun :: EnumDecl -> Text+enumNameFun (getIdent -> Ident enumIdent) =+  TM.toCamel enumIdent <> "Name"+ unionConstructor :: UnionDecl -> UnionVal -> Text-unionConstructor union unionVal =-  TM.toCamel (unIdent $ getIdent union) <> TM.toPascal (unIdent $ getIdent unionVal)+unionConstructor (getIdent -> Ident unionIdent) (getIdent -> Ident unionValIdent) =+  TM.toCamel unionIdent <> TM.toPascal unionValIdent  readUnionFun :: HasIdent union => union -> Text readUnionFun (getIdent -> Ident unionIdent) =

@@ -11,11 +11,12 @@  import qualified Data.ByteString                          as BS import           Data.Coerce                              ( coerce )-import           Data.Functor                             ( void )-import           Data.List.NonEmpty                       ( NonEmpty )+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.Scientific                          ( Scientific ) import           Data.Text                                ( Text ) import qualified Data.Text                                as T import qualified Data.Text.Encoding                       as T@@ -28,6 +29,7 @@ import           Text.Megaparsec import           Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer               as L+import           Text.Read                                ( readMaybe )   type Parser = Parsec Void String@@ -231,7 +233,18 @@     [ DefaultBool True <$ rword "true"     , DefaultBool False <$ rword "false"     , DefaultNum <$> label "number literal" (lexeme (L.signed sc L.scientific))-    , DefaultRef <$> ident+    , ident <&> \(Ident ref) -> DefaultRef (ref :| [])+    , stringLiteral >>= \(StringLiteral str) ->+        case T.strip str of+          "true"  -> pure $ DefaultBool True+          "false" -> pure $ DefaultBool False+          other ->+            case readMaybe @Scientific (T.unpack other) of+              Just n  -> pure $ DefaultNum n+              Nothing ->+                case NE.nonEmpty (T.words str) of+                  Just refs -> pure $ DefaultRef refs+                  Nothing   -> fail "Expected 'true', 'false', a number, or one or more identifiers"     ]  metadata :: Parser Metadata

@@ -11,7 +11,6 @@ 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 )@@ -25,14 +24,14 @@  parseSchemas ::      MonadIO m-  => MonadError Text m+  => MonadError String 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+    Left err -> throwError $ errorBundlePretty err     Right rootSchema -> do       rootFilePathCanon <- liftIO $ Dir.canonicalizePath rootFilePath       let importedFilePaths = T.unpack . coerce <$> includes rootSchema@@ -50,7 +49,7 @@ parseImportedSchema ::      MonadState (Map FilePath Schema) m   => MonadIO m-  => MonadError Text m+  => MonadError String m   => [FilePath]   -> FilePath   -> FilePath@@ -68,18 +67,17 @@       case actualFilePathCanonMaybe of         Nothing -> throwError $           "File '"-          <> T.pack filePath+          <> filePath           <> "' (imported from '"-          <> T.pack parentSchemaPath-          <> "') not found.\n Searched in these directories: ["-          <> display (T.pack <$> dirCandidates)-          <> "]"+          <> parentSchemaPath+          <> "') not found.\nSearched in these directories: "+          <> display 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+              Left err -> throwError $ errorBundlePretty err               Right importedSchema -> do                 put (Map.insert actualFilePathCanon importedSchema importedSchemas)                 traverse_ (go actualFilePathCanon . T.unpack . coerce) (includes importedSchema)

@@ -5,14 +5,18 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  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           Control.Monad.Except                          ( throwError )+import           Control.Monad.Reader                          ( ReaderT, asks, local, runReaderT )+import           Control.Monad.State                           ( MonadState, State, StateT, evalState, evalStateT, get, mapStateT, modify, put )+import           Control.Monad.Trans                           ( lift ) +import           Data.Bits                                     ( (.&.), (.|.), Bits, FiniteBits, bit, finiteBitSize ) import           Data.Coerce                                   ( coerce ) import           Data.Foldable                                 ( asum, find, foldlM, traverse_ ) import qualified Data.Foldable                                 as Foldable@@ -20,7 +24,7 @@ import           Data.Int import           Data.Ix                                       ( inRange ) import qualified Data.List                                     as List-import           Data.List.NonEmpty                            ( NonEmpty )+import           Data.List.NonEmpty                            ( NonEmpty((:|)) ) import qualified Data.List.NonEmpty                            as NE import           Data.Map.Strict                               ( Map ) import qualified Data.Map.Strict                               as Map@@ -41,31 +45,75 @@ 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)+----------------------------------+------- MonadValidation ----------+----------------------------------+newtype Validation a = Validation+  { runValidation :: ReaderT ValidationState (Either String) a+  }+  deriving newtype (Functor, Applicative, Monad)  data ValidationState = ValidationState-  { validationStateCurrentContext :: !Ident+  { 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).   } +class Monad m => MonadValidation m where+  -- | Start validating an item @a@+  validating :: HasIdent a => a -> m b -> m b+  -- | Clear validation context, i.e. forget which item is currently being validated, if any.+  resetContext :: m a -> m a+  -- | Get the path to the item currently being validated+  getContext :: m [Ident]+  -- | Get a list of all the attributes declared in every loaded schema+  getDeclaredAttributes :: m (Set ST.AttributeDecl)+  -- | Fail validation with a message+  throwErrorMsg :: String -> m a -modifyContext :: ValidationCtx m => (Ident -> Ident) -> m a -> m a-modifyContext f =-  local $ \s ->-    s { validationStateCurrentContext = f (validationStateCurrentContext s) }+instance MonadValidation Validation where+  validating a (Validation v) = Validation (local addIdent v)+    where+      addIdent (ValidationState ctx attrs) = ValidationState (getIdent a : ctx) attrs+  resetContext (Validation v) = Validation (local reset v)+    where+      reset (ValidationState _ attrs) = ValidationState [] attrs+  getContext            = Validation (asks (List.reverse . validationStateCurrentContext))+  getDeclaredAttributes = Validation (asks validationStateAllAttributes)+  throwErrorMsg msg = do+    idents <- getContext+    if null idents+      then Validation (throwError msg)+      else Validation . throwError $ "[" <> List.intercalate "." (T.unpack . unIdent <$> idents) <> "]: " <> msg +instance MonadValidation m => MonadValidation (StateT s m)  where+  validating            = mapStateT . validating+  resetContext          = mapStateT resetContext+  getContext            = lift getContext+  getDeclaredAttributes = lift getDeclaredAttributes+  throwErrorMsg         = lift . throwErrorMsg++----------------------------------+------- Validation stages --------+----------------------------------+{-+During validation, we translate `SyntaxTree.XDecl` declarations into+`ValidSyntaxTree.XDecl` declarations.++This is done in stages: we first translate enums, then structs, then tables,+and lastly unions.+-}+ data SymbolTable enum struct table union = SymbolTable-  { allEnums   :: ![(Namespace, enum)]-  , allStructs :: ![(Namespace, struct)]-  , allTables  :: ![(Namespace, table)]-  , allUnions  :: ![(Namespace, union)]+  { allEnums   :: !(Map (Namespace, Ident) enum)+  , allStructs :: !(Map (Namespace, Ident) struct)+  , allTables  :: !(Map (Namespace, Ident) table)+  , allUnions  :: !(Map (Namespace, Ident) union)   }   deriving (Eq, Show) @@ -74,7 +122,7 @@     SymbolTable (e1 <> e2) (s1 <> s2) (t1 <> t2) (u1 <> u2)  instance Monoid (SymbolTable e s t u) where-  mempty = SymbolTable [] [] [] []+  mempty = SymbolTable mempty mempty mempty mempty  type Stage1     = SymbolTable ST.EnumDecl ST.StructDecl ST.TableDecl ST.UnionDecl type Stage2     = SymbolTable    EnumDecl ST.StructDecl ST.TableDecl ST.UnionDecl@@ -82,42 +130,24 @@ 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 :: FileTree Schema -> Either String (FileTree ValidDecls) validateSchemas schemas =-  flip runReaderT (ValidationState "" allAttributes) $ do-    checkDuplicateIdentifiers allQualifiedTopLevelIdentifiers+  flip runReaderT (ValidationState [] allAttributes) $ runValidation $ do+    symbolTables <- createSymbolTables schemas+    checkDuplicateIdentifiers (allQualifiedTopLevelIdentifiers symbolTables)     validateEnums symbolTables       >>= validateStructs       >>= validateTables       >>= validateUnions       >>= updateRootTable (fileTreeRoot schemas)   where-    symbolTables = createSymbolTables schemas--    allQualifiedTopLevelIdentifiers =+    allQualifiedTopLevelIdentifiers symbolTables =       flip concatMap symbolTables $ \symbolTable ->         join-          [ uncurry qualify <$> allEnums symbolTable-          , uncurry qualify <$> allStructs symbolTable-          , uncurry qualify <$> allTables symbolTable-          , uncurry qualify <$> allUnions symbolTable+          [ uncurry qualify <$> Map.keys (allEnums symbolTable)+          , uncurry qualify <$> Map.keys (allStructs symbolTable)+          , uncurry qualify <$> Map.keys (allTables symbolTable)+          , uncurry qualify <$> Map.keys (allUnions symbolTable)           ]      declaredAttributes =@@ -126,6 +156,38 @@      allAttributes = Set.fromList $ declaredAttributes <> knownAttributes +-- | Takes a collection of schemas, and pairs each type declaration with its corresponding namespace+createSymbolTables :: FileTree Schema -> Validation (FileTree Stage1)+createSymbolTables = traverse (createSymbolTable . ST.decls)+  where+    createSymbolTable :: [ST.Decl] -> Validation Stage1+    createSymbolTable decls = snd <$> foldlM go ("", mempty) decls++    go :: (Namespace, Stage1) -> ST.Decl -> Validation (Namespace, Stage1)+    go (currentNamespace, symbolTable) decl =+      case decl of+        ST.DeclE enum   -> addEnum symbolTable currentNamespace enum     <&> \symbolTable' -> (currentNamespace, symbolTable')+        ST.DeclS struct -> addStruct symbolTable currentNamespace struct <&> \symbolTable' -> (currentNamespace, symbolTable')+        ST.DeclT table  -> addTable symbolTable currentNamespace table   <&> \symbolTable' -> (currentNamespace, symbolTable')+        ST.DeclU union  -> addUnion symbolTable currentNamespace union   <&> \symbolTable' -> (currentNamespace, symbolTable')+        ST.DeclN (ST.NamespaceDecl newNamespace) -> pure (newNamespace, symbolTable)+        _               -> pure (currentNamespace, symbolTable)++    addEnum (SymbolTable es ss ts us) namespace enum     = insertSymbol namespace enum es   <&> \es' -> SymbolTable es' ss ts us+    addStruct (SymbolTable es ss ts us) namespace struct = insertSymbol namespace struct ss <&> \ss' -> SymbolTable es ss' ts us+    addTable (SymbolTable es ss ts us) namespace table   = insertSymbol namespace table ts  <&> \ts' -> SymbolTable es ss ts' us+    addUnion (SymbolTable es ss ts us) namespace union   = insertSymbol namespace union us  <&> \us' -> SymbolTable es ss ts us'++-- | Fails if the key is already present in the map.+insertSymbol :: HasIdent a => Namespace -> a -> Map (Namespace, Ident) a -> Validation (Map (Namespace, Ident) a)+insertSymbol namespace symbol map =+  if Map.member key map+    then throwErrorMsg $ display (qualify namespace symbol) <> " declared more than once"+    else pure $ Map.insert key symbol map+  where+    key = (namespace, getIdent symbol)++ ---------------------------------- ------------ Root Type ----------- ----------------------------------@@ -138,7 +200,7 @@ -- | 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 -> FileTree ValidDecls -> Validation (FileTree ValidDecls) updateRootTable schema symbolTables =   getRootInfo schema symbolTables <&> \case     Just rootInfo -> updateSymbolTable rootInfo <$> symbolTables@@ -146,32 +208,31 @@    where     updateSymbolTable :: RootInfo -> ValidDecls -> ValidDecls-    updateSymbolTable rootInfo st = st { allTables = updateTable rootInfo <$> allTables st}+    updateSymbolTable rootInfo st = st { allTables = Map.mapWithKey (updateTable rootInfo) (allTables st) } -    updateTable :: RootInfo -> (Namespace, TableDecl) -> (Namespace, TableDecl)-    updateTable (RootInfo rootTableNamespace rootTable fileIdent) pair@(namespace, table) =+    updateTable :: RootInfo -> (Namespace, Ident) -> TableDecl -> TableDecl+    updateTable (RootInfo rootTableNamespace rootTable fileIdent) (namespace, _) table =       if namespace == rootTableNamespace && table == rootTable-        then (namespace, table { tableIsRoot = IsRoot fileIdent })-        else pair+        then table { tableIsRoot = IsRoot fileIdent }+        else table -getRootInfo :: forall m. ValidationCtx m => Schema -> FileTree ValidDecls -> m (Maybe RootInfo)+getRootInfo :: Schema -> FileTree ValidDecls -> Validation (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 :: (Namespace, Maybe (Namespace, TableDecl), Maybe Text) -> ST.Decl -> Validation (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"+            MatchT rootTableNamespace rootTable  -> pure (currentNamespace, Just (rootTableNamespace, rootTable), fileIdent)+            _                                    -> throwErrorMsg "root type must be a table"         _ -> pure state - ---------------------------------- ----------- Attributes ----------- ----------------------------------@@ -217,16 +278,14 @@ --------- Symbol search ---------- ---------------------------------- data Match enum struct table union-  = MatchE !(Namespace, enum)-  | MatchS !(Namespace, struct)-  | MatchT !(Namespace, table)-  | MatchU !(Namespace, 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)+     MonadValidation m   => Namespace   -> FileTree (SymbolTable e s t u)   -> TypeRef@@ -238,10 +297,10 @@         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)+                [ MatchE candidateNamespace <$> Map.lookup (candidateNamespace, refIdent) (allEnums symbolTable)+                , MatchS candidateNamespace <$> Map.lookup (candidateNamespace, refIdent) (allStructs symbolTable)+                , MatchT candidateNamespace <$> Map.lookup (candidateNamespace, refIdent) (allTables symbolTable)+                , MatchU candidateNamespace <$> Map.lookup (candidateNamespace, refIdent) (allUnions symbolTable)                 ]         pure $ asum $ fmap searchSymbolTable symbolTables   in@@ -249,9 +308,9 @@       Just match -> pure match       Nothing    ->         throwErrorMsg $-          "type '"+          "type "           <> display typeRef-          <> "' does not exist (checked in these namespaces: "+          <> " does not exist (checked in these namespaces: "           <> display parentNamespaces'           <> ")" @@ -267,25 +326,21 @@ ---------------------------------- ------------- Enums -------------- -----------------------------------validateEnums :: forall m. ValidationCtx m => FileTree Stage1 -> m (FileTree Stage2)+validateEnums :: FileTree Stage1 -> Validation (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+    validEnums <- Map.traverseWithKey validateEnum (allEnums symbolTable)     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+validateEnum :: (Namespace, Ident) -> ST.EnumDecl -> Validation EnumDecl+validateEnum (currentNamespace, _) enum =+  validating (qualify currentNamespace enum) $ do     checkDuplicateFields     checkUndeclaredAttributes enum     validEnum   where+    isBitFlags = hasAttribute bitFlagsAttr (ST.enumMetadata enum)+     validEnum = do       enumType <- validateEnumType (ST.enumType enum)       let enumVals = flip evalState Nothing . traverse mapEnumVal $ ST.enumVals enum@@ -294,7 +349,8 @@       pure EnumDecl         { enumIdent = getIdent enum         , enumType = enumType-        , enumVals = enumVals+        , enumBitFlags = isBitFlags+        , enumVals = shiftBitFlags <$> enumVals         }      mapEnumVal :: ST.EnumVal -> State (Maybe Integer) EnumVal@@ -310,15 +366,27 @@       put (Just thisInt)       pure (EnumVal (getIdent enumVal) thisInt) -    validateOrder :: NonEmpty EnumVal -> m ()+    validateOrder :: NonEmpty EnumVal -> Validation ()     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"+      let consecutivePairs = NE.toList xs `zip` NE.tail xs+          outOfOrderPais = filter (\(x, y) -> enumValInt x >= enumValInt y) consecutivePairs+      in+          case outOfOrderPais of+            []         -> pure ()+            (x, y) : _ -> throwErrorMsg $+              "enum values must be specified in ascending order. "+              <> display (enumValIdent y)+              <> " ("+              <> display (enumValInt y)+              <> ") should be greater than "+              <> display (enumValIdent x)+              <> " ("+              <> display (enumValInt x)+              <> ")" -    validateBounds :: EnumType -> EnumVal -> m ()+    validateBounds :: EnumType -> EnumVal -> Validation ()     validateBounds enumType enumVal =-      modifyContext (\context -> context <> "." <> getIdent enumVal) $+      validating enumVal $         case enumType of           EInt8 -> validateBounds' @Int8 enumVal           EInt16 -> validateBounds' @Int16 enumVal@@ -329,59 +397,72 @@           EWord32 -> validateBounds' @Word32 enumVal           EWord64 -> validateBounds' @Word64 enumVal -    validateBounds' :: forall a. (Integral a, Bounded a, Show a) => EnumVal -> m ()+    validateBounds' :: forall a. (FiniteBits a, Integral a, Bounded a) => EnumVal -> Validation ()     validateBounds' e =-      if inRange (toInteger (minBound @a), toInteger (maxBound @a)) (enumValInt e)+      if inRange (lower, upper) (enumValInt e)         then pure ()         else throwErrorMsg $-              "enum value does not fit ["-              <> T.pack (show (minBound @a))+              "enum value of "+              <> display (enumValInt e)+              <> " does not fit ["+              <> display lower               <> "; "-              <> T.pack (show (maxBound @a))+              <> display upper               <> "]"+      where+        lower = if isBitFlags+                  then 0+                  else toInteger (minBound @a)+        upper = if isBitFlags+                  then toInteger (finiteBitSize @a (undefined :: a) - 1)+                  else toInteger (maxBound @a) -    validateEnumType :: ST.Type -> m EnumType+    validateEnumType :: ST.Type -> Validation 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.TInt8   -> unlessIsBitFlags EInt8+        ST.TInt16  -> unlessIsBitFlags EInt16+        ST.TInt32  -> unlessIsBitFlags EInt32+        ST.TInt64  -> unlessIsBitFlags EInt64+        ST.TWord8  -> pure EWord8         ST.TWord16 -> pure EWord16         ST.TWord32 -> pure EWord32         ST.TWord64 -> pure EWord64         _          -> throwErrorMsg "underlying enum type must be integral"+      where+        unlessIsBitFlags x =+          if isBitFlags+            then throwErrorMsg "underlying type of bit_flags enum must be unsigned"+            else pure x -    checkDuplicateFields :: m ()+    -- If this enum has the `bit_flags` attribute, convert its int value to the corresponding bitmask.+    -- E.g., 2 -> 00000100+    shiftBitFlags :: EnumVal -> EnumVal+    shiftBitFlags e =+      if isBitFlags+        then e { enumValInt = bit (fromIntegral @Integer @Int (enumValInt e)) }+        else e++    checkDuplicateFields :: Validation ()     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 :: FileTree Stage3 -> Validation (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+    validTables <- Map.traverseWithKey (validateTable symbolTables) (allTables symbolTable)     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+validateTable :: FileTree Stage3 -> (Namespace, Ident) -> ST.TableDecl -> Validation TableDecl+validateTable symbolTables (currentNamespace, _) table =+  validating (qualify currentNamespace table) $ do      let fields = ST.tableFields table     let fieldsMetadata = ST.tableFieldMetadata <$> fields@@ -399,10 +480,10 @@       }    where-    checkDuplicateFields :: [ST.TableField] -> m ()+    checkDuplicateFields :: [ST.TableField] -> Validation ()     checkDuplicateFields = checkDuplicateIdentifiers -    assignFieldIds :: [ST.Metadata] -> [TableFieldWithoutId] -> m [TableField]+    assignFieldIds :: [ST.Metadata] -> [TableFieldWithoutId] -> Validation [TableField]     assignFieldIds metadata fieldsWithoutIds = do       ids <- catMaybes <$> traverse (findIntAttr idAttr) metadata       if null ids@@ -427,10 +508,10 @@       put fieldId       pure (TableField fieldId ident typ depr) -    checkFieldId :: TableField -> StateT Integer m ()+    checkFieldId :: TableField -> StateT Integer Validation ()     checkFieldId field = do       lastId <- get-      modifyContext (\context -> context <> "." <> getIdent field) $ do+      validating field $ do         case tableFieldType field of           TUnion _ _ ->             when (tableFieldId field /= lastId + 2) $@@ -443,9 +524,9 @@               throwErrorMsg $ "field ids must be consecutive from 0; id " <> display (lastId + 1) <> " is missing"         put (tableFieldId field) -    validateTableField :: ST.TableField -> m TableFieldWithoutId+    validateTableField :: ST.TableField -> Validation TableFieldWithoutId     validateTableField tf =-      modifyContext (\context -> context <> "." <> getIdent tf) $ do+      validating tf $ do         checkUndeclaredAttributes tf         validFieldType <- validateTableFieldType (ST.tableFieldMetadata tf) (ST.tableFieldDefault tf) (ST.tableFieldType tf) @@ -454,30 +535,30 @@           validFieldType           (hasAttribute deprecatedAttr (ST.tableFieldMetadata tf)) -    validateTableFieldType :: ST.Metadata -> Maybe ST.DefaultVal -> ST.Type -> m TableFieldType+    validateTableFieldType :: ST.Metadata -> Maybe ST.DefaultVal -> ST.Type -> Validation 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.TInt8 -> checkNoRequired md >> validateDefaultValAsInt @Int8 dflt <&> TInt8+        ST.TInt16 -> checkNoRequired md >> validateDefaultValAsInt @Int16 dflt <&> TInt16+        ST.TInt32 -> checkNoRequired md >> validateDefaultValAsInt @Int32 dflt <&> TInt32+        ST.TInt64 -> checkNoRequired md >> validateDefaultValAsInt @Int64 dflt <&> TInt64+        ST.TWord8 -> checkNoRequired md >> validateDefaultValAsInt @Word8 dflt <&> TWord8+        ST.TWord16 -> checkNoRequired md >> validateDefaultValAsInt @Word16 dflt <&> TWord16+        ST.TWord32 -> checkNoRequired md >> validateDefaultValAsInt @Word32 dflt <&> TWord32+        ST.TWord64 -> checkNoRequired md >> validateDefaultValAsInt @Word64 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+            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)+            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@@ -496,20 +577,20 @@               ST.TVector _ -> throwErrorMsg "nested vector types not supported"               ST.TRef typeRef ->                 findDecl currentNamespace symbolTables typeRef <&> \case-                  MatchE (ns, enum) ->+                  MatchE ns enum ->                     VEnum (TypeRef ns (getIdent enum))                           (enumType enum)-                  MatchS (ns, struct) ->+                  MatchS ns struct ->                     VStruct (TypeRef ns (getIdent struct))-                  MatchT (ns, table) -> VTable (TypeRef ns (getIdent table))-                  MatchU (ns, union) -> VUnion (TypeRef ns (getIdent union))+                  MatchT ns table -> VTable (TypeRef ns (getIdent table))+                  MatchU ns union -> VUnion (TypeRef ns (getIdent union)) -checkNoRequired :: ValidationCtx m => ST.Metadata -> m ()+checkNoRequired :: ST.Metadata -> Validation () 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 :: Maybe ST.DefaultVal -> Validation () checkNoDefault dflt =   when (isJust dflt) $     throwErrorMsg@@ -518,77 +599,118 @@ 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 :: forall a. (Integral a, Bounded a, Display a) => Maybe ST.DefaultVal -> Validation (DefaultVal Integer) 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"+    Nothing                -> pure (DefaultVal 0)+    Just (ST.DefaultNum n) -> scientificToInteger @a n "default value must be integral"+    Just _                 -> throwErrorMsg "default value must be integral" -validateDefaultValAsScientific :: ValidationCtx m => Maybe ST.DefaultVal -> m (DefaultVal Scientific)+validateDefaultValAsScientific :: Maybe ST.DefaultVal -> Validation (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 :: Maybe ST.DefaultVal -> Validation (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 :: Maybe ST.DefaultVal -> EnumDecl -> Validation (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)+  case dflt of+    Nothing ->+      if enumBitFlags enum+        then pure 0+        else+          case find (\val -> enumValInt val == 0) (enumVals enum) of+            Just _  -> pure 0+            Nothing -> throwErrorMsg "enum does not have a 0 value; please manually specify a default for this field"+    Just (ST.DefaultNum n) ->+      if enumBitFlags enum+        then+          case enumType enum of+            EWord8  -> scientificToInteger @Word8  n defaultErrorMsg+            EWord16 -> scientificToInteger @Word16 n defaultErrorMsg+            EWord32 -> scientificToInteger @Word32 n defaultErrorMsg+            EWord64 -> scientificToInteger @Word64 n defaultErrorMsg+            _       -> throwErrorMsg "The 'impossible' has happened: bit_flags enum with signed integer"+        else+          case Scientific.floatingOrInteger @Float n of+            Left _float -> throwErrorMsg defaultErrorMsg+            Right i ->+              case find (\val -> enumValInt val == i) (enumVals enum) of+                Just matchingVal -> pure (DefaultVal (enumValInt matchingVal))+                Nothing -> throwErrorMsg $ "default value of " <> display i <> " is not part of enum " <> display (getIdent enum)+    Just (ST.DefaultRef refs) ->+      if enumBitFlags enum+        then+          foldr1 (.|.) <$> traverse findEnumByRef refs+        else+          case refs of+            ref :| [] -> findEnumByRef ref+            _         -> throwErrorMsg $ "default value must be a single identifier, found "+                          <> display (NE.length refs)+                          <> ": "+                          <> display (fmap (\ref -> "'" <> ref <> "'") refs)+    Just (ST.DefaultBool _) ->+      throwErrorMsg defaultErrorMsg+  where+    defaultErrorMsg =+      if enumBitFlags enum+        then case enumVals enum of+          x :| y : _ ->+            "default value must be integral, one of ["+            <> display (getIdent <$> enumVals enum)+            <> "], or a combination of the latter in double quotes (e.g. \""+            <> T.unpack (unIdent (getIdent x))+            <> " "+            <> T.unpack (unIdent (getIdent y))+            <> "\")"+          _ ->+            "default value must be integral or one of: " <> display (getIdent <$> enumVals enum)+        else+          "default value must be integral or one of: " <> display (getIdent <$> enumVals enum) -      Just (ST.DefaultBool _) -> throwErrorMsg $ "default value must be integral or one of: " <> display (getIdent <$> enumVals enum)+    findEnumByRef :: Text -> Validation (DefaultVal Integer)+    findEnumByRef ref =+      case find (\val -> unIdent (getIdent val) == ref) (enumVals enum) of+        Just matchingVal -> pure (DefaultVal (enumValInt matchingVal))+        Nothing          -> throwErrorMsg $ "default value of " <> display ref <> " is not part of enum " <> display (getIdent enum) +scientificToInteger ::+  forall a. (Integral a, Bounded a, Display a)+  => Scientific -> String -> Validation (DefaultVal Integer)+scientificToInteger n notIntegerErrorMsg =+  if not (Scientific.isInteger n)+    then throwErrorMsg notIntegerErrorMsg+    else+      case Scientific.toBoundedInteger @a n of+        Nothing ->+          throwErrorMsg $+            "default value does not fit ["+            <> display (minBound @a)+            <> "; "+            <> display (maxBound @a)+            <> "]"+        Just i -> pure (DefaultVal (toInteger i))  ---------------------------------- ------------ Unions -------------- -----------------------------------validateUnions :: ValidationCtx m => FileTree Stage4 -> m (FileTree ValidDecls)+validateUnions :: FileTree Stage4 -> Validation (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+    validUnions <- Map.traverseWithKey (validateUnion symbolTables) (allUnions symbolTable)     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+validateUnion :: FileTree Stage4 -> (Namespace, Ident) -> ST.UnionDecl -> Validation UnionDecl+validateUnion symbolTables (currentNamespace, _) union =+  validating (qualify currentNamespace union) $ do     validUnionVals <- traverse validateUnionVal (ST.unionVals union)     checkDuplicateVals validUnionVals     checkUndeclaredAttributes union@@ -597,67 +719,79 @@       , unionVals = validUnionVals       }   where-    validateUnionVal :: ST.UnionVal -> m UnionVal+    validateUnionVal :: ST.UnionVal -> Validation 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+      validating identFormatted $ do         tableRef <- validateUnionValType tref         pure $ UnionVal           { unionValIdent = identFormatted           , unionValTableRef = tableRef           } -    validateUnionValType :: TypeRef -> m TypeRef+    validateUnionValType :: TypeRef -> Validation TypeRef     validateUnionValType typeRef =       findDecl currentNamespace symbolTables typeRef >>= \case-        MatchT (ns, table)        -> pure $ TypeRef ns (getIdent table)-        _                         -> throwErrorMsg "union members may only be tables"+        MatchT ns table -> pure $ TypeRef ns (getIdent table)+        _               -> throwErrorMsg "union members may only be tables" -    checkDuplicateVals :: NonEmpty UnionVal -> m ()+    checkDuplicateVals :: NonEmpty UnionVal -> Validation ()     checkDuplicateVals vals = checkDuplicateIdentifiers (NE.cons "NONE" (fmap getIdent vals))   ---------------------------------- ------------ Structs ------------- -----------------------------------validateStructs :: ValidationCtx m => FileTree Stage2 -> m (FileTree Stage3)++-- | Cache of already validated structs.+--+-- When we're validating a struct @A@, it may contain an inner struct @B@ which also needs validating.+-- @B@ needs to be fully validated before we can consider @A@ valid.+--+-- If we've validated @B@ in a previous iteration, we will find it in this Map+-- and therefore avoid re-validating it.+type ValidatedStructs = Map (Namespace, Ident) StructDecl+++validateStructs :: FileTree Stage2 -> Validation (FileTree Stage3) validateStructs symbolTables =-  flip evalStateT [] $ traverse validateFile symbolTables+  flip evalStateT Map.empty $ traverse validateFile symbolTables   where-  validateFile :: (MonadState [(Namespace, StructDecl)] m, ValidationCtx m) => Stage2 -> m Stage3+  validateFile :: Stage2 -> StateT ValidatedStructs Validation Stage3   validateFile symbolTable = do     let structs = allStructs symbolTable -    traverse_ (checkStructCycles symbolTables) structs-    validStructs <- traverse (validateStruct symbolTables) structs+    traverse_ (\((ns, _), struct) -> checkStructCycles symbolTables (ns, struct)) (Map.toList structs)+    validStructs <- Map.traverseWithKey (\(ns, _) struct -> validateStruct symbolTables ns struct) structs      pure symbolTable { allStructs = validStructs } -checkStructCycles :: forall m. ValidationCtx m => FileTree Stage2 -> (Namespace, ST.StructDecl) -> m ()+checkStructCycles :: forall m. MonadValidation m => FileTree Stage2 -> (Namespace, ST.StructDecl) -> m () checkStructCycles symbolTables = go []   where     go :: [Ident] -> (Namespace, ST.StructDecl) -> m ()-    go visited (currentNamespace, struct) =+    go visited (currentNamespace, struct) = do       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+      resetContext $+        validating 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 ->+                validating field $+                  case ST.structFieldType field of+                    ST.TRef typeRef ->+                      findDecl currentNamespace symbolTables typeRef >>= \case+                        MatchS ns struct -> go (qualifiedName : visited) (ns, 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@@ -665,15 +799,17 @@   } deriving (Show, Eq)  validateStruct ::-     forall m. (MonadState [(Namespace, StructDecl)] m, ValidationCtx m)+     forall m. (MonadState ValidatedStructs m, MonadValidation m)   => FileTree Stage2-  -> (Namespace, ST.StructDecl)-  -> m (Namespace, StructDecl)-validateStruct symbolTables (currentNamespace, struct) =-  modifyContext (\_ -> qualify currentNamespace struct) $ do+  -> Namespace+  -> ST.StructDecl+  -> m StructDecl+validateStruct symbolTables currentNamespace struct =+  resetContext $+  validating (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+    case Map.lookup (currentNamespace, getIdent struct) validStructs of       Just match -> pure match       Nothing -> do         checkDuplicateFields@@ -696,8 +832,8 @@               , structSize       = size               , structFields     = paddedFields               }-        modify ((currentNamespace, validStruct) :)-        pure (currentNamespace, validStruct)+        modify (Map.insert (currentNamespace, getIdent validStruct) validStruct)+        pure validStruct    where     invalidStructFieldType = "struct fields may only be integers, floating point, bool, enums, or other structs"@@ -742,7 +878,7 @@      validateStructField :: ST.StructField -> m UnpaddedStructField     validateStructField sf =-      modifyContext (\context -> context <> "." <> getIdent sf) $ do+      validating sf $ do         checkUnsupportedAttributes sf         checkUndeclaredAttributes sf         structFieldType <- validateStructFieldType (ST.structFieldType sf)@@ -769,11 +905,12 @@         ST.TVector _ -> throwErrorMsg invalidStructFieldType         ST.TRef typeRef ->           findDecl currentNamespace symbolTables typeRef >>= \case-            MatchE (enumNamespace, enum) ->+            MatchE enumNamespace enum ->               pure (SEnum (TypeRef enumNamespace (getIdent enum)) (enumType enum))-            MatchS (nestedNamespace, nestedStruct) ->+            MatchS nestedNamespace nestedStruct -> do               -- if this is a reference to a struct, we need to validate it first-              SStruct <$> validateStruct symbolTables (nestedNamespace, nestedStruct)+              validNestedStruct <- validateStruct symbolTables nestedNamespace nestedStruct+              pure $ SStruct (nestedNamespace, validNestedStruct)             _ -> throwErrorMsg invalidStructFieldType      checkUnsupportedAttributes :: ST.StructField -> m ()@@ -795,7 +932,7 @@         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)+              <> display naturalAlignment               <> ") to 16"      checkDuplicateFields :: m ()@@ -856,7 +993,7 @@     SEnum _ enumType -> fromIntegral @Word8 @InlineSize (enumSize enumType)     SStruct (_, nestedStruct) -> structSize nestedStruct -checkDuplicateIdentifiers :: (ValidationCtx m, Foldable f, Functor f, HasIdent a) => f a -> m ()+checkDuplicateIdentifiers :: (MonadValidation m, Foldable f, Functor f, HasIdent a) => f a -> m () checkDuplicateIdentifiers xs =   case findDups (getIdent <$> xs) of     [] -> pure ()@@ -871,17 +1008,17 @@     occurrences xs =       Map.unionsWith (<>) $ Foldable.toList $ fmap (\x -> Map.singleton x (Sum 1)) xs -checkUndeclaredAttributes :: (ValidationCtx m, HasMetadata a) => a -> m ()+checkUndeclaredAttributes :: (MonadValidation m, HasMetadata a) => a -> m () checkUndeclaredAttributes a = do-  allAttributes <- asks validationStateAllAttributes+  allAttributes <- getDeclaredAttributes   forM_ (Map.keys . ST.unMetadata . getMetadata $ a) $ \attr ->     when (coerce attr `Set.notMember` allAttributes) $-      throwErrorMsg $ "user defined attributes must be declared before use: " <> attr+      throwErrorMsg $ "user defined attributes must be declared before use: " <> display 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 :: MonadValidation m => Text -> ST.Metadata -> m (Maybe Integer) findIntAttr name (ST.Metadata attrs) =   case Map.lookup name attrs of     Nothing                  -> pure Nothing@@ -895,12 +1032,12 @@     err =       throwErrorMsg $         "expected attribute '"-        <> name+        <> display name         <> "' to have an integer value, e.g. '"-        <> name+        <> display name         <> ": 123'" -findStringAttr :: ValidationCtx m => Text -> ST.Metadata -> m (Maybe Text)+findStringAttr :: Text -> ST.Metadata -> Validation (Maybe Text) findStringAttr name (ST.Metadata attrs) =   case Map.lookup name attrs of     Nothing                  -> pure Nothing@@ -908,17 +1045,17 @@     Just _ ->       throwErrorMsg $         "expected attribute '"-        <> name+        <> display name         <> "' to have a string value, e.g. '"-        <> name+        <> display name         <> ": \"abc\"'" -throwErrorMsg :: ValidationCtx m => Text -> m a-throwErrorMsg msg = do-  context <- asks validationStateCurrentContext-  if context == ""-    then throwError msg-    else throwError $ "[" <> display context <> "]: " <> msg--+isPowerOfTwo :: (Num a, Bits a) => a -> Bool+isPowerOfTwo 0 = False+isPowerOfTwo n = (n .&. (n - 1)) == 0 +roundUpToNearestMultipleOf :: Integral n => n -> n -> n+roundUpToNearestMultipleOf x y =+  case x `rem` y of+    0         -> x+    remainder -> (y - remainder) + x

@@ -2,6 +2,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}  module FlatBuffers.Internal.Compiler.SyntaxTree where @@ -39,8 +40,11 @@  newtype Ident = Ident   { unIdent :: Text-  } deriving newtype (Show, Eq, IsString, Ord, Semigroup, Display)+  } deriving newtype (Show, Eq, IsString, Ord, Semigroup) +instance Display Ident where+  display (Ident i) = "'" <> display i <> "'"+ newtype Include = Include   { unInclude :: StringLiteral   } deriving newtype (Show, Eq, IsString)@@ -61,7 +65,7 @@ data DefaultVal   = DefaultNum !Scientific   | DefaultBool !Bool-  | DefaultRef !Ident+  | DefaultRef !(NonEmpty Text)   deriving (Show, Eq)  newtype Metadata = Metadata@@ -161,10 +165,10 @@   deriving newtype (Eq, Ord, Semigroup)  instance Display Namespace where-  display (Namespace ns) = T.intercalate "." ns+  display (Namespace ns) = "'" <> T.unpack (T.intercalate "." ns) <> "'"  instance Show Namespace where-  show = show . T.unpack . display+  show = show . display  instance IsString Namespace where   fromString "" = Namespace []@@ -172,7 +176,8 @@  qualify :: HasIdent a => Namespace -> a -> Ident qualify "" a = getIdent a-qualify ns a = Ident (display ns <> "." <> display (getIdent a))+qualify (Namespace ns) (getIdent -> Ident ident) =+  Ident (T.intercalate "." ns <> "." <> ident)  class HasIdent a where   getIdent :: a -> Ident

@@ -6,9 +6,11 @@ import           Control.Monad                                   ( join ) import           Control.Monad.Except                            ( runExceptT ) +import           Data.Bits                                       ( (.&.) ) import           Data.Foldable                                   ( traverse_ ) import           Data.Functor                                    ( (<&>) ) import           Data.Int+import qualified Data.List                                       as List import           Data.List.NonEmpty                              ( NonEmpty(..) ) import qualified Data.List.NonEmpty                              as NE import qualified Data.Map.Strict                                 as Map@@ -26,7 +28,6 @@ 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@@ -77,7 +78,6 @@ -- > {-# LANGUAGE TemplateHaskell #-} -- > -- > module Data.Game where--- > -- > import FlatBuffers -- > -- > $(mkFlatBuffers "schemas/game.fbs" defaultOptions)@@ -87,11 +87,11 @@    parseResult <- runIO $ runExceptT $ ParserIO.parseSchemas rootFilePath (includeDirectories opts) -  schemaFileTree <- either (fail . T.unpack) pure parseResult+  schemaFileTree <- either (fail . fixMsg) pure parseResult    registerFiles schemaFileTree -  symbolTables <- either (fail . T.unpack) pure $ SemanticAnalysis.validateSchemas schemaFileTree+  symbolTables <- either (fail . fixMsg) pure $ SemanticAnalysis.validateSchemas schemaFileTree    let symbolTable =         if compileAllSchemas opts@@ -110,39 +110,124 @@      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+        { allEnums   = Map.filterWithKey (isCurrentModule currentModule) enums+        , allStructs = Map.filterWithKey (isCurrentModule currentModule) structs+        , allTables  = Map.filterWithKey (isCurrentModule currentModule) tables+        , allUnions  = Map.filterWithKey (isCurrentModule currentModule) unions         } -    isCurrentModule currentModule (ns, _) = NC.namespace ns == currentModule+    isCurrentModule currentModule (ns, _) _ = NC.namespace ns == currentModule +-- | This does two things:+--+-- 1. ghcid stops parsing an error when it finds a line that start with alphabetical characters or an empty lines,+--    so we prepend each line with an empty space to avoid this.+-- 2. we also remove any trailing \n, otherwise ghcid would stop parsing here and not show the source code location.+fixMsg :: String -> String+fixMsg = List.intercalate "\n" . fmap fixLine . lines+  where+    fixLine line = " " <> line+ 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)+  enumDecs <- join <$> traverse mkEnum (Map.elems (allEnums symbolTable))+  structDecs <- join <$> traverse mkStruct (Map.elems (allStructs symbolTable))+  tableDecs <- join <$> traverse mkTable (Map.elems (allTables symbolTable))+  unionDecs <- join <$> traverse mkUnion (Map.elems (allUnions symbolTable))   pure $ enumDecs <> structDecs <> tableDecs <> unionDecs -mkEnum :: (Namespace, EnumDecl) -> Q [Dec]-mkEnum (_, enum) = do-  enumName <- newName' $ NC.dataTypeName enum+mkEnum :: EnumDecl -> Q [Dec]+mkEnum enum =+  if enumBitFlags enum+    then mkEnumBitFlags enum+    else mkEnumNormal enum ++mkEnumBitFlags :: EnumDecl -> Q [Dec]+mkEnumBitFlags enum = do+  nameFun <- mkEnumBitFlagsNames enum enumValNames+  pure $+    mkEnumBitFlagsConstants enum enumValNames+    <> mkEnumBitFlagsAllValls enum enumValNames+    <> nameFun+  where+    enumValNames = mkName . T.unpack . NC.enumBitFlagsConstant enum <$> NE.toList (enumVals enum)++mkEnumBitFlagsConstants :: EnumDecl -> [Name] -> [Dec]+mkEnumBitFlagsConstants enum enumValNames =+  NE.toList (enumVals enum) `zip` enumValNames >>= \(enumVal, enumValName) ->+    let sig = SigD enumValName (enumTypeToType (enumType enum))+        fun = FunD enumValName [Clause [] (NormalB (intLitE (enumValInt enumVal))) []]+    in  [sig, fun]++-- | Generates a list with all the enum values, e.g.+--+-- > allColors = [colorsRed, colorsGreen, colorsBlue]+mkEnumBitFlagsAllValls :: EnumDecl -> [Name] -> [Dec]+mkEnumBitFlagsAllValls enum enumValNames =+  let name = mkName $ T.unpack $ NC.enumBitFlagsAllFun enum+      sig = SigD name (ListT `AppT` enumTypeToType (enumType enum))+      fun = FunD name [ Clause [] (NormalB body)  []]+      body = ListE (VarE <$> enumValNames)+  in  [sig, fun, inlinePragma name]++-- | Generates @colorsNames@.+mkEnumBitFlagsNames :: EnumDecl -> [Name] -> Q [Dec]+mkEnumBitFlagsNames enum enumValNames = do+  inputName <- newName "c"+  firstRes <- newName "res0"+  firstClause <- [d| $(varP firstRes) = [] |]+  (clauses, lastRes) <- mkClauses namesAndIdentifiers 1 inputName firstRes firstClause+  let fun = FunD funName+        [ Clause+            [VarP inputName]+            (NormalB (VarE lastRes))+            (List.reverse clauses)+        ]+  pure+    [ sig+    , fun+    , inlinePragma funName+    ]+  where+    funName = mkName $ T.unpack $ NC.enumBitFlagsNamesFun enum+    sig = SigD funName (enumTypeToType (enumType enum) ~> ListT `AppT` ConT ''Text)++    namesAndIdentifiers :: [(Name, Ident)]+    namesAndIdentifiers = List.reverse (enumValNames `zip` fmap enumValIdent (NE.toList (enumVals enum)))++    mkClauses :: [(Name, Ident)] -> Int -> Name -> Name -> [Dec] -> Q ([Dec], Name)+    mkClauses [] _ _ previousRes clauses = pure (clauses, previousRes)+    mkClauses ((name, Ident ident) : rest) ix inputName previousRes clauses = do+      res <- newName ("res" <> show ix)+      clause <-+        [d|+          $(varP res) = if $(varE name) .&. $(varE inputName) /= 0+                            then $(pure (textLitE ident)) : $(varE previousRes)+                            else $(varE previousRes)+        |]+      mkClauses rest (ix + 1) inputName res (clause <> clauses)++-- | Generated declarations for a non-bit-flags enum.+mkEnumNormal :: EnumDecl -> Q [Dec]+mkEnumNormal enum = do+  let enumName = mkName' $ 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)+  let enumValsAndNames = enumVals enum `NE.zip` enumValNames+  toEnumDecs <- mkToEnum enumName enum enumValsAndNames+  fromEnumDecs <- mkFromEnum enumName enum enumValsAndNames+  enumNameDecs <- mkEnumNameFun enumName enum enumValsAndNames -  pure $ enumDec : toEnumDecs <> fromEnumDecs+  pure $ enumDec : toEnumDecs <> fromEnumDecs <> enumNameDecs  mkEnumDataDec :: Name -> NonEmpty Name -> Dec mkEnumDataDec enumName enumValNames =   DataD [] enumName [] Nothing-    (NE.toList $ fmap (\n -> NormalC n []) enumValNames)+    (fmap (\n -> NormalC n []) (NE.toList enumValNames))     [ DerivClause Nothing       [ ConT ''Eq       , ConT ''Show@@ -164,7 +249,7 @@         (NormalB (CaseE (VarE argName) matches))         []       ]-    , PragmaD $ InlineP funName Inline FunLike AllPhases+    , inlinePragma funName     ]   where     matches =@@ -194,7 +279,7 @@         (NormalB (CaseE (VarE argName) (mkMatch <$> NE.toList enumValsAndNames)))         []       ]-    , PragmaD $ InlineP funName Inline FunLike AllPhases+    , inlinePragma funName     ]   where     mkMatch (enumVal, enumName) =@@ -203,9 +288,31 @@         (NormalB (intLitE (enumValInt enumVal)))         [] +-- | Generates @colorsName@.+mkEnumNameFun :: Name -> EnumDecl -> NonEmpty (EnumVal, Name) -> Q [Dec]+mkEnumNameFun enumName enum enumValsAndNames = do+  let funName = mkName' $ NC.enumNameFun enum+  argName <- newName "c"+  pure+    [ SigD funName (ConT enumName ~> ConT ''Text)+    , FunD funName+      [ Clause+        [VarP argName]+        (NormalB (CaseE (VarE argName) (mkMatch <$> NE.toList enumValsAndNames)))+        []+      ]+    , inlinePragma funName+    ]+  where+    mkMatch (enumVal, enumName) =+      Match+        (ConP enumName [])+        (NormalB (textLitE (unIdent (getIdent enumVal))))+        [] -mkStruct :: (Namespace, StructDecl) -> Q [Dec]-mkStruct (_, struct) = do++mkStruct :: StructDecl -> Q [Dec]+mkStruct struct = do   let structName = mkName' $ NC.dataTypeName struct   isStructInstance <- mkIsStructInstance structName struct @@ -322,8 +429,8 @@         SEnum _ enumType -> mkReadExp $ enumTypeToStructFieldType enumType         SStruct _ -> VarE 'readStruct -mkTable :: (Namespace, TableDecl) -> Q [Dec]-mkTable (_, table) = do+mkTable :: TableDecl -> Q [Dec]+mkTable table = do   let tableName = mkName' $ NC.dataTypeName table   (consSig, cons) <- mkTableConstructor tableName table @@ -499,7 +606,7 @@         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+        VStruct _        -> mkFunWithBody $ bodyForNonScalar req $ VarE 'readPrimVector `AppE` ConE 'VectorStruct         VTable _         -> mkFunWithBody $ bodyForNonScalar req $ VarE 'readTableVector         VUnion (TypeRef ns ident) ->           mkFunWithBody $@@ -544,9 +651,9 @@         , defaultValExp         ] -mkUnion :: (Namespace, UnionDecl) -> Q [Dec]-mkUnion (_, union) = do-  unionName <- newName' $ NC.dataTypeName union+mkUnion :: UnionDecl -> Q [Dec]+mkUnion union = do+  let unionName = mkName' $ NC.dataTypeName union   let unionValNames = unionVals union <&> \unionVal ->         mkName $ T.unpack $ NC.enumUnionMember union unionVal @@ -840,9 +947,20 @@ stringLitE :: Text -> Exp stringLitE t = LitE (StringL (T.unpack t)) +inlinePragma :: Name -> Dec+inlinePragma funName = PragmaD $ InlineP funName Inline FunLike AllPhases+ -- | 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))+++nonEmptyUnzip3 :: NonEmpty (a,b,c) -> (NonEmpty a, NonEmpty b, NonEmpty c)+nonEmptyUnzip3 xs =+  ( (\(x, _, _) -> x) <$> xs+  , (\(_, x, _) -> x) <$> xs+  , (\(_, _, x) -> x) <$> xs+  )

@@ -28,7 +28,7 @@   , UnionVal(..)   ) where -import           Data.Int+import           Data.Bits                                ( Bits ) import           Data.List.NonEmpty                       ( NonEmpty ) import           Data.Scientific                          ( Scientific ) import           Data.String                              ( IsString(..) )@@ -53,6 +53,7 @@ data EnumDecl = EnumDecl   { enumIdent     :: !Ident   , enumType      :: !EnumType+  , enumBitFlags  :: !Bool   , enumVals      :: !(NonEmpty EnumVal)   } deriving (Show, Eq) @@ -111,7 +112,7 @@ ------------ Tables -------------- ---------------------------------- newtype DefaultVal a = DefaultVal a-  deriving newtype (Eq, Show, Num, IsString, Ord, Enum, Real, Integral, Fractional)+  deriving newtype (Eq, Show, Num, IsString, Ord, Enum, Real, Integral, Fractional, Bits)  data Required = Req | Opt   deriving (Eq, Show)@@ -135,14 +136,14 @@   } 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)+  = TInt8   !(DefaultVal Integer)+  | TInt16  !(DefaultVal Integer)+  | TInt32  !(DefaultVal Integer)+  | TInt64  !(DefaultVal Integer)+  | TWord8  !(DefaultVal Integer)+  | TWord16 !(DefaultVal Integer)+  | TWord32 !(DefaultVal Integer)+  | TWord64 !(DefaultVal Integer)   | TFloat  !(DefaultVal Scientific)   | TDouble !(DefaultVal Scientific)   | TBool   !(DefaultVal Bool)

@@ -41,9 +41,8 @@ import           FlatBuffers.Internal.Constants import           FlatBuffers.Internal.FileIdentifier ( FileIdentifier(..), HasFileIdentifier(..) ) import           FlatBuffers.Internal.Types-import           FlatBuffers.Internal.Util           ( Positive, positive ) -import           Prelude                             hiding ( length )+import           Prelude                             hiding ( drop, length, take )  type ReadError = String @@ -68,7 +67,6 @@   { structPos :: Position   } - -- | A union that is being read from a flatbuffer. data Union a   = Union !a@@ -129,15 +127,21 @@         BSL.drop uoffsetSize $           bs +-- | 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+ ---------------------------------- ------------ Vectors ------------- ---------------------------------- {-# INLINE moveToElem #-} moveToElem :: HasPosition pos => pos -> Int32 -> Int32 -> pos moveToElem pos elemSize ix =-  let elemOffset = int32Size + (ix * elemSize)-  in  move pos elemOffset+  move pos (ix * elemSize)  {-# INLINE checkIndexBounds #-} checkIndexBounds :: Int32 -> Int32 -> Int32@@ -147,181 +151,238 @@   | otherwise    = ix  {-# INLINE inlineVectorToList #-}-inlineVectorToList :: HasPosition pos => Get a -> pos -> Either ReadError [a]-inlineVectorToList get (getPosition -> pos) =-  flip runGet pos $ do-    len <- G.getInt32le+inlineVectorToList :: Get a -> Int32 -> Position -> Either ReadError [a]+inlineVectorToList get len pos =+  runGet pos $     sequence $ L.replicate (fromIntegral @Int32 @Int len) get +-- | @clamp n upperBound@ truncates a value to stay between @0@ and @upperBound@.+clamp :: Int32 -> Int32 -> Int32+clamp n upperBound = n `min` upperBound `max` 0+ 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+  --+  -- /O(1)/.+  length :: Vector a -> Int32    -- | 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).+  --+  -- /O(c)/, where /c/ is the number of chunks in the underlying `ByteString`.   unsafeIndex :: Vector a -> Int32 -> Either ReadError a    -- | Converts the vector to a list.+  --+  -- /O(n)/.   toList :: Vector a -> Either ReadError [a] +  -- | @take n xs@ returns the prefix of @xs@ of length @n@, or @xs@ itself if @n > length xs@.+  --+  -- /O(1)/.+  --+  -- @since 0.2.0.0+  take :: Int32 -> Vector a -> Vector a +  -- | @drop n xs@ returns the suffix of @xs@ after the first @n@ elements, or @[]@ if @n > length xs@.+  --+  -- /O(c)/, where /c/ is the number of chunks in the underlying `ByteString`.+  --+  -- @since 0.2.0.0+  drop :: Int32 -> Vector a -> Vector a++-- | Returns the item at the given index.+-- If the given index is negative or too large, an `error` is thrown.+--+-- /O(c)/, where /c/ is the number of chunks in the underlying `ByteString`.+index :: VectorElement a => Vector a -> Int32 -> Either ReadError a+index vec ix = unsafeIndex vec . checkIndexBounds ix $ length vec++-- | Convert the vector to a lazy `ByteString`.+--+-- /O(c)/, where /c/ is the number of chunks in the underlying `ByteString`.+--+-- @since 0.2.0.0+toByteString :: Vector Word8 -> ByteString+toByteString (VectorWord8 len pos) =+  BSL.take (fromIntegral @Int32 @Int64 len) pos++ instance VectorElement Word8 where-  newtype Vector Word8 = VectorWord8 Position-    deriving newtype HasPosition+  data Vector Word8 = VectorWord8 !Int32 !Position -  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)+  length (VectorWord8 len _)      = len+  unsafeIndex (VectorWord8 _ pos) = byteStringSafeIndex pos+  take n (VectorWord8 len pos)    = VectorWord8 (clamp n len) pos+  drop n (VectorWord8 len pos)    = VectorWord8 (clamp (len - n) len) (BSL.drop (fromIntegral @Int32 @Int64 n) pos)+  toList                          = Right . BSL.unpack . toByteString  instance VectorElement Word16 where-  newtype Vector Word16 = VectorWord16 Position-    deriving newtype HasPosition+  data Vector Word16 = VectorWord16 !Int32 !Position -  length = readInt32-  unsafeIndex vec = readWord16 . moveToElem vec word16Size-  toList = inlineVectorToList G.getWord16le+  length (VectorWord16 len _)      = len+  unsafeIndex (VectorWord16 _ pos) = readWord16 . moveToElem pos word16Size+  take n (VectorWord16 len pos)    = VectorWord16 (clamp n len) pos+  drop n (VectorWord16 len pos)    = VectorWord16 (len - n') (moveToElem pos word16Size n')+    where n' = clamp n len+  toList (VectorWord16 len pos)    = inlineVectorToList G.getWord16le len pos  instance VectorElement Word32 where-  newtype Vector Word32 = VectorWord32 Position-    deriving newtype HasPosition+  data Vector Word32 = VectorWord32 !Int32 !Position -  length = readInt32-  unsafeIndex vec = readWord32 . moveToElem vec word32Size-  toList = inlineVectorToList G.getWord32le+  length (VectorWord32 len _)      = len+  unsafeIndex (VectorWord32 _ pos) = readWord32 . moveToElem pos word32Size+  take n (VectorWord32 len pos)    = VectorWord32 (clamp n len) pos+  drop n (VectorWord32 len pos)    = VectorWord32 (len - n') (moveToElem pos word32Size n')+    where n' = clamp n len+  toList (VectorWord32 len pos)    = inlineVectorToList G.getWord32le len pos  instance VectorElement Word64 where-  newtype Vector Word64 = VectorWord64 Position-    deriving newtype HasPosition+  data Vector Word64 = VectorWord64 !Int32 !Position -  length = readInt32-  unsafeIndex vec = readWord64 . moveToElem vec word64Size-  toList = inlineVectorToList G.getWord64le+  length (VectorWord64 len _)      = len+  unsafeIndex (VectorWord64 _ pos) = readWord64 . moveToElem pos word64Size+  take n (VectorWord64 len pos)    = VectorWord64 (clamp n len) pos+  drop n (VectorWord64 len pos)    = VectorWord64 (len - n') (moveToElem pos word64Size n')+    where n' = clamp n len+  toList (VectorWord64 len pos)    = inlineVectorToList G.getWord64le len pos  instance VectorElement Int8 where-  newtype Vector Int8 = VectorInt8 Position-    deriving newtype HasPosition+  data Vector Int8 = VectorInt8 !Int32 !Position -  length = readInt32-  unsafeIndex vec = readInt8 . moveToElem vec int8Size-  toList = inlineVectorToList G.getInt8+  length (VectorInt8 len _)        = len+  unsafeIndex (VectorInt8 _ pos)   = readInt8 . moveToElem pos int8Size+  take n (VectorInt8 len pos)      = VectorInt8 (clamp n len) pos+  drop n (VectorInt8 len pos)      = VectorInt8 (len - n') (moveToElem pos int8Size n')+    where n' = clamp n len+  toList (VectorInt8 len pos)      = inlineVectorToList G.getInt8 len pos  instance VectorElement Int16 where-  newtype Vector Int16 = VectorInt16 Position-    deriving newtype HasPosition+  data Vector Int16 = VectorInt16 !Int32 !Position -  length = readInt32-  unsafeIndex vec = readInt16 . moveToElem vec int16Size-  toList = inlineVectorToList G.getInt16le+  length (VectorInt16 len _)       = len+  unsafeIndex (VectorInt16 _ pos)  = readInt16 . moveToElem pos int16Size+  take n (VectorInt16 len pos)     = VectorInt16 (clamp n len) pos+  drop n (VectorInt16 len pos)     = VectorInt16 (len - n') (moveToElem pos int16Size n')+    where n' = clamp n len+  toList (VectorInt16 len pos)     = inlineVectorToList G.getInt16le len pos  instance VectorElement Int32 where-  newtype Vector Int32 = VectorInt32 Position-    deriving newtype HasPosition+  data Vector Int32 = VectorInt32 !Int32 !Position -  length = readInt32-  unsafeIndex vec = readInt32 . moveToElem vec int32Size-  toList = inlineVectorToList G.getInt32le+  length (VectorInt32 len _)       = len+  unsafeIndex (VectorInt32 _ pos)  = readInt32 . moveToElem pos int32Size+  take n (VectorInt32 len pos)     = VectorInt32 (clamp n len) pos+  drop n (VectorInt32 len pos)     = VectorInt32 (len - n') (moveToElem pos int32Size n')+    where n' = clamp n len+  toList (VectorInt32 len pos)     = inlineVectorToList G.getInt32le len pos  instance VectorElement Int64 where-  newtype Vector Int64 = VectorInt64 Position-    deriving newtype HasPosition+  data Vector Int64 = VectorInt64 !Int32 !Position -  length = readInt32-  unsafeIndex vec = readInt64 . moveToElem vec int64Size-  toList = inlineVectorToList G.getInt64le+  length (VectorInt64 len _)       = len+  unsafeIndex (VectorInt64 _ pos)  = readInt64 . moveToElem pos int64Size+  take n (VectorInt64 len pos)     = VectorInt64 (clamp n len) pos+  drop n (VectorInt64 len pos)     = VectorInt64 (len - n') (moveToElem pos int64Size n')+    where n' = clamp n len+  toList (VectorInt64 len pos)     = inlineVectorToList G.getInt64le len pos  instance VectorElement Float where-  newtype Vector Float = VectorFloat Position-    deriving newtype HasPosition+  data Vector Float = VectorFloat !Int32 !Position -  length = readInt32-  unsafeIndex vec = readFloat . moveToElem vec floatSize-  toList = inlineVectorToList G.getFloatle+  length (VectorFloat len _)       = len+  unsafeIndex (VectorFloat _ pos)  = readFloat . moveToElem pos floatSize+  take n (VectorFloat len pos)     = VectorFloat (clamp n len) pos+  drop n (VectorFloat len pos)     = VectorFloat (len - n') (moveToElem pos floatSize n')+    where n' = clamp n len+  toList (VectorFloat len pos)     = inlineVectorToList G.getFloatle len pos  instance VectorElement Double where-  newtype Vector Double = VectorDouble Position-    deriving newtype HasPosition+  data Vector Double = VectorDouble !Int32 !Position -  length = readInt32-  unsafeIndex vec = readDouble . moveToElem vec doubleSize-  toList = inlineVectorToList G.getDoublele+  length (VectorDouble len _)      = len+  unsafeIndex (VectorDouble _ pos) = readDouble . moveToElem pos doubleSize+  take n (VectorDouble len pos)    = VectorDouble (clamp n len) pos+  drop n (VectorDouble len pos)    = VectorDouble (len - n') (moveToElem pos doubleSize n')+    where n' = clamp n len+  toList (VectorDouble len pos)    = inlineVectorToList G.getDoublele len pos  instance VectorElement Bool where-  newtype Vector Bool = VectorBool Position-    deriving newtype HasPosition+  data Vector Bool = VectorBool !Int32 !Position -  length = readInt32-  unsafeIndex vec = readBool . moveToElem vec boolSize-  toList (VectorBool pos) = fmap word8ToBool <$> toList (VectorWord8 pos)+  length (VectorBool len _)      = len+  unsafeIndex (VectorBool _ pos) = readBool . moveToElem pos boolSize+  take n (VectorBool len pos)    = VectorBool (clamp n len) pos+  drop n (VectorBool len pos)    = VectorBool (len - n') (moveToElem pos boolSize n')+    where n' = clamp n len+  toList (VectorBool len pos)    = fmap word8ToBool <$> toList (VectorWord8 len pos)  instance VectorElement Text where-  newtype Vector Text = VectorText Position-  length (VectorText pos) = readInt32 pos-  unsafeIndex (VectorText pos) = readText . moveToElem pos textRefSize+  data Vector Text = VectorText !Int32 !Position +  length (VectorText len _)      = len+  unsafeIndex (VectorText _ pos) = readText . moveToElem pos textRefSize+  take n (VectorText len pos)    = VectorText (clamp n len) pos+  drop n (VectorText len pos)    = VectorText (len - n') (moveToElem pos textRefSize n')+    where n' = clamp n len+   toList :: Vector Text -> Either ReadError [Text]-  toList (VectorText pos) = do-    offsets <- toList (VectorInt32 pos)+  toList (VectorText len pos) = do+    offsets <- inlineVectorToList G.getInt32le len 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+        let textPos = move pos (offset + (ix * 4))+        text <- join $ runGet textPos readText'         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))++instance IsStruct a => VectorElement (Struct a) where+  data Vector (Struct a) = VectorStruct !Int32 !Position++  length (VectorStruct len _)      = len+  unsafeIndex (VectorStruct _ pos) = Right . readStruct . moveToElem pos (fromIntegral (structSizeOf @a))+  take n (VectorStruct len pos)    = VectorStruct (clamp n len) pos+  drop n (VectorStruct len pos)    = VectorStruct (len - n') (moveToElem pos (fromIntegral (structSizeOf @a)) n')+    where n' = clamp n len++  toList (VectorStruct len pos) =+    Right (go len pos)     where       go :: Int32 -> Position -> [Struct a]       go 0 _ = []       go !len pos =         let head = readStruct pos-            tail = go (len - 1) (move pos structSize)+            tail = go (len - 1) (move pos (structSizeOf @a))         in  head : tail  instance VectorElement (Table a) where-  newtype Vector (Table a) = VectorTable PositionInfo-    deriving newtype HasPosition+  data Vector (Table a) = VectorTable !Int32 !PositionInfo -  length = readInt32-  unsafeIndex vec = readTable . coerce . moveToElem vec tableRefSize-  toList (VectorTable vectorPos) = do-    offsets <- toList (VectorInt32 (posCurrent vectorPos))++  length (VectorTable len _)      = len+  unsafeIndex (VectorTable _ pos) = readTable . moveToElem pos tableRefSize+  take n (VectorTable len pos)    = VectorTable (clamp n len) pos+  drop n (VectorTable len pos)    = VectorTable (len - n') (moveToElem pos tableRefSize n')+    where n' = clamp n len++  toList (VectorTable len vectorPos) = do+    offsets <- inlineVectorToList G.getInt32le len (getPosition 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)+        let tablePos = move vectorPos (offset + (ix * 4))         table <- readTable' tablePos         tables <- go offsets (ix + 1)         pure (table : tables)@@ -347,9 +408,13 @@         tablePos <- readUOffsetAndSkip $ moveToElem valuesPos tableRefSize ix         readElem unionType' tablePos -  toList (VectorUnion typesPos valuesPos readElem) = do+  take n (VectorUnion typesPos valuesPos readElem)     = VectorUnion (take n typesPos) valuesPos readElem+  drop n vec@(VectorUnion typesPos valuesPos readElem) = VectorUnion (drop n typesPos) (moveToElem valuesPos tableRefSize n') readElem+    where n' = clamp n (length vec)++  toList vec@(VectorUnion typesPos valuesPos readElem) = do     unionTypes <- toList typesPos-    offsets <- toList (VectorInt32 (posCurrent valuesPos))+    offsets <- inlineVectorToList G.getInt32le (length vec) (getPosition valuesPos)     go unionTypes offsets 0     where       go :: [Word8] -> [Int32] -> Int32 -> Either ReadError [Union a]@@ -359,7 +424,7 @@           case positive unionType of             Nothing -> Right UnionNone             Just unionType' ->-              let tablePos = move valuesPos (offset + (ix * 4) + 4)+              let tablePos = move valuesPos (offset + (ix * 4))               in  readElem unionType' tablePos         unions <- go unionTypes offsets (ix + 1)         pure (union : unions)@@ -439,43 +504,43 @@ ---------------------------------- {-# INLINE readInt8 #-} readInt8 :: HasPosition a => a -> Either ReadError Int8-readInt8 (getPosition -> pos) = runGet G.getInt8 pos+readInt8 (getPosition -> pos) = runGet pos G.getInt8  {-# INLINE readInt16 #-} readInt16 :: HasPosition a => a -> Either ReadError Int16-readInt16 (getPosition -> pos) = runGet G.getInt16le pos+readInt16 (getPosition -> pos) = runGet pos G.getInt16le  {-# INLINE readInt32 #-} readInt32 :: HasPosition a => a -> Either ReadError Int32-readInt32 (getPosition -> pos) = runGet G.getInt32le pos+readInt32 (getPosition -> pos) = runGet pos G.getInt32le  {-# INLINE readInt64 #-} readInt64 :: HasPosition a => a -> Either ReadError Int64-readInt64 (getPosition -> pos) = runGet G.getInt64le pos+readInt64 (getPosition -> pos) = runGet pos G.getInt64le  {-# INLINE readWord8 #-} readWord8 :: HasPosition a => a -> Either ReadError Word8-readWord8 (getPosition -> pos) = runGet G.getWord8 pos+readWord8 (getPosition -> pos) = runGet pos G.getWord8  {-# INLINE readWord16 #-} readWord16 :: HasPosition a => a -> Either ReadError Word16-readWord16 (getPosition -> pos) = runGet G.getWord16le pos+readWord16 (getPosition -> pos) = runGet pos G.getWord16le  {-# INLINE readWord32 #-} readWord32 :: HasPosition a => a -> Either ReadError Word32-readWord32 (getPosition -> pos) = runGet G.getWord32le pos+readWord32 (getPosition -> pos) = runGet pos G.getWord32le  {-# INLINE readWord64 #-} readWord64 :: HasPosition a => a -> Either ReadError Word64-readWord64 (getPosition -> pos) = runGet G.getWord64le pos+readWord64 (getPosition -> pos) = runGet pos G.getWord64le  {-# INLINE readFloat #-} readFloat :: HasPosition a => a -> Either ReadError Float-readFloat (getPosition -> pos) = runGet G.getFloatle pos+readFloat (getPosition -> pos) = runGet pos G.getFloatle  {-# INLINE readDouble #-} readDouble :: HasPosition a => a -> Either ReadError Double-readDouble (getPosition -> pos) = runGet G.getDoublele pos+readDouble (getPosition -> pos) = runGet pos G.getDoublele  {-# INLINE readBool #-} readBool :: HasPosition a => a -> Either ReadError Bool@@ -486,20 +551,21 @@ word8ToBool 0 = False word8ToBool _ = True + readPrimVector ::-     (Position -> Vector a)+     (Int32 -> Position -> Vector a)   -> PositionInfo   -> Either ReadError (Vector a)-readPrimVector vecConstructor (posCurrent -> pos) =-  vecConstructor <$> readUOffsetAndSkip pos+readPrimVector vecConstructor (posCurrent -> pos) = do+  vecPos <- readUOffsetAndSkip pos+  vecLength <- readInt32 vecPos+  Right $! vecConstructor vecLength (move vecPos (int32Size :: Int64))  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+readTableVector pos = do+  vecPos <- readUOffsetAndSkip pos+  vecLength <- readInt32 vecPos+  Right $! VectorTable vecLength (move vecPos (int32Size :: Int64))  readUnionVector ::      (Positive Word8 -> PositionInfo -> Either ReadError (Union a))@@ -512,14 +578,14 @@     valuesVec <- readUOffsetAndSkip valuesPos     Right $! VectorUnion       typesVec-      valuesVec+      (move valuesVec (int32Size :: Int64))       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+  join $ 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))@@ -566,7 +632,7 @@ {-# INLINE tableIndexToVOffset #-} tableIndexToVOffset :: Table t -> TableIndex -> Either ReadError (Maybe VOffset) tableIndexToVOffset Table{..} ix =-  flip runGet vtable $ do+  runGet vtable $ do     vtableSize <- G.getWord16le     let vtableIndex = 4 + (unTableIndex ix * 2)     if vtableIndex >= vtableSize@@ -583,8 +649,8 @@   move pos <$> readInt32 pos  {-# INLINE runGet #-}-runGet :: Get a -> ByteString -> Either ReadError a-runGet get bs =+runGet :: ByteString -> Get a -> Either ReadError a+runGet bs get =   case G.runGetOrFail get bs of     Right (_, _, a)  -> Right a     Left (_, _, msg) -> Left msg

@@ -6,7 +6,8 @@  module FlatBuffers.Internal.Types where -import Data.Word+import           Data.Word+import           FlatBuffers.Internal.Compiler.Display ( Display )  -- | Metadata for a struct type. class IsStruct a where@@ -24,5 +25,5 @@ -- 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)+  deriving newtype (Show, Eq, Num, Enum, Ord, Real, Integral, Bounded, Display) 

@@ -1,35 +0,0 @@-{-# 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

@@ -7,6 +7,8 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  {-# OPTIONS_HADDOCK not-home #-} @@ -16,14 +18,17 @@  import           Control.Monad.State.Strict +import           Data.Bits                           ( (.&.), complement )+import qualified Data.ByteString                     as BS 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.MonoTraversable                ( Element, MonoFoldable )+import qualified Data.MonoTraversable                as Mono import           Data.Monoid                         ( Sum(..) ) import           Data.Semigroup                      ( Max(..) ) import           Data.Text                           ( Text )@@ -343,56 +348,60 @@   -- 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:+  -- Note: `fromMonoFoldable` asks for the collection's length to be passed in as an argument rather than use `Mono.olength` 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.+  -- 1. `Mono.olength` 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 `Mono.olength` inside `fromMonoFoldable` can inhibit some fusions which would otherwise be possible.+  --+  -- @since 0.2.0.0     -- Implementer's note:   -- To elaborate on point 2., here's an example.-  -- This version of `fromFoldable` that calls @Foldable.length@ internally:+  -- This version of `fromMonoFoldable` that calls `Mono.olength` internally:   --   -- > encodeUserIds' :: [User] -> BSL.ByteString-  -- > encodeUserIds' = encode . userIdsTable $ fromFoldable (userId <$> users))+  -- > encodeUserIds' = encode . userIdsTable $ fromMonoFoldable (userId <$> users))   -- >-  -- > {-# INLINE fromFoldable #-}-  -- > fromFoldable xs =-  -- >   let length = Foldable.length xs+  -- > {-# INLINE fromMonoFoldable #-}+  -- > fromMonoFoldable xs =+  -- >   let length = Mono.olength 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))+  -- > encodeUserIds = encode . userIdsTable $ fromMonoFoldable (userId <$> users) (fromIntegral (Mono.olength users))   -- >-  -- > {-# INLINE fromFoldable #-}-  -- > fromFoldable xs length =+  -- > {-# INLINE fromMonoFoldable #-}+  -- > fromMonoFoldable xs length =   -- >   let buffer = foldr ... ... xs   -- >   in  ...-  fromFoldable ::-       Foldable f+  fromMonoFoldable ::+       (MonoFoldable mono, Element mono ~ a)     => Int32      -- ^ @n@: the number of elements in @xs@-    -> f a        -- ^ @xs@: a collection+    -> mono       -- ^ @xs@: a collection     -> WriteVector a  -- | Convenience function, equivalent to: ----- > fromFoldable' xs = fromFoldable (fromIntegral (Foldable.length xs)) xs+-- > fromMonoFoldable' xs = fromMonoFoldable (fromIntegral (olength 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+-- In some cases it may be slower than using `fromMonoFoldable` directly.+--+-- @since 0.2.0.0+{-# INLINE fromMonoFoldable' #-}+fromMonoFoldable' :: (WriteVectorElement a, MonoFoldable mono, Element mono ~ a) => mono -> WriteVector a+fromMonoFoldable' xs = fromMonoFoldable (fromIntegral $ Mono.olength xs) xs --- | `fromFoldable` specialized to list+-- | `fromMonoFoldable` specialized to list fromList :: WriteVectorElement a => Int32 -> [a] -> WriteVector a-fromList = fromFoldable+fromList = fromMonoFoldable --- | `fromFoldable'` specialized to list+-- | `fromMonoFoldable'` specialized to list fromList' :: WriteVectorElement a => [a] -> WriteVector a-fromList' = fromFoldable'+fromList' = fromMonoFoldable'  -- | Creates a flatbuffers vector with a single element singleton :: WriteVectorElement a => a -> WriteVector a@@ -403,9 +412,63 @@ empty = fromList 0 []  +newtype FromFoldable f a = FromFoldable (f a)+  deriving newtype Foldable +type instance Element (FromFoldable f a) = a+instance Foldable f => MonoFoldable (FromFoldable f a)++-- | `fromMonoFoldable` for types that implement `Foldable` but not `MonoFoldable`.+fromFoldable :: (WriteVectorElement a, Foldable f) => Int32 -> f a -> WriteVector a+fromFoldable n = fromMonoFoldable n . FromFoldable++-- | `fromMonoFoldable'` for types that implement `Foldable` but not `MonoFoldable`.+fromFoldable' :: (WriteVectorElement a, Foldable f) => f a -> WriteVector a+fromFoldable' = fromMonoFoldable' . FromFoldable++-- | Efficiently creates a vector from a `BS.ByteString`.+-- Large `BS.ByteString`s are inserted directly, but small ones are copied to ensure that the generated chunks are large on average.+--+-- @since 0.2.0.0+fromByteString :: BS.ByteString -> WriteVector Word8+fromByteString bs = WriteVectorWord8 . WriteTableField $ do+  modify' $!+    writeInt32 len . writeByteString . alignTo int32Size len+  uoffsetFromHere+  where+    len = fromIntegral @Int @Int32 (BS.length bs)+    writeByteString fbs =+      fbs+        { builder = B.byteString bs <> builder fbs+        , bufferSize = bufferSize fbs <> Sum len+        }++-- | Efficiently creates a vector from a lazy `BSL.ByteString`.+--  Large chunks of the `BSL.ByteString` are inserted directly, but small ones are copied to ensure that the generated chunks are large on average.+--+-- @since 0.2.0.0+fromLazyByteString :: BSL.ByteString -> WriteVector Word8+fromLazyByteString bs = WriteVectorWord8 . WriteTableField $ do+  modify' $!+    writeInt32 len . writeByteString . alignTo int32Size len+  uoffsetFromHere+  where+    len = fromIntegral @Int64 @Int32 (BSL.length bs)+    writeByteString fbs =+      fbs+        { builder = B.lazyByteString bs <> builder fbs+        , bufferSize = bufferSize fbs <> Sum len+        }+ {-# INLINE inlineVector #-}-inlineVector :: Foldable f => (a -> Builder) -> Alignment -> InlineSize -> Int32 -> f a -> WriteTableField+inlineVector ::+     (MonoFoldable mono, Element mono ~ a)+  => (a -> Builder)+  -> Alignment+  -> InlineSize+  -> Int32+  -> mono+  -> WriteTableField inlineVector build elemAlignment elemSize elemCount elems = WriteTableField $ do   modify' $!     writeInt32 elemCount . writeVec . alignTo (coerce elemAlignment `max` int32Size) vecByteLength@@ -413,7 +476,7 @@   uoffsetFromHere   where     vecByteLength = elemCount * fromIntegral @InlineSize @Int32 elemSize-    vecBuilder = foldr (\a b -> build a <> b) mempty elems+    vecBuilder = Mono.ofoldr (\a b -> build a <> b) mempty elems     writeVec fbs =       fbs         { builder = vecBuilder <> builder fbs@@ -423,86 +486,86 @@ 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+  {-# INLINE fromMonoFoldable #-}+  fromMonoFoldable :: (MonoFoldable mono, Element mono ~ Word8) => Int32 -> mono -> WriteVector Word8+  fromMonoFoldable 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+  {-# INLINE fromMonoFoldable #-}+  fromMonoFoldable :: (MonoFoldable mono, Element mono ~ Word16) => Int32 -> mono -> WriteVector Word16+  fromMonoFoldable 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+  {-# INLINE fromMonoFoldable #-}+  fromMonoFoldable :: (MonoFoldable mono, Element mono ~ Word32) => Int32 -> mono -> WriteVector Word32+  fromMonoFoldable 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+  {-# INLINE fromMonoFoldable #-}+  fromMonoFoldable :: (MonoFoldable mono, Element mono ~ Word64) => Int32 -> mono -> WriteVector Word64+  fromMonoFoldable 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+  {-# INLINE fromMonoFoldable #-}+  fromMonoFoldable :: (MonoFoldable mono, Element mono ~ Int8) => Int32 -> mono -> WriteVector Int8+  fromMonoFoldable 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+  {-# INLINE fromMonoFoldable #-}+  fromMonoFoldable :: (MonoFoldable mono, Element mono ~ Int16) => Int32 -> mono -> WriteVector Int16+  fromMonoFoldable 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+  {-# INLINE fromMonoFoldable #-}+  fromMonoFoldable :: (MonoFoldable mono, Element mono ~ Int32) => Int32 -> mono -> WriteVector Int32+  fromMonoFoldable 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+  {-# INLINE fromMonoFoldable #-}+  fromMonoFoldable :: (MonoFoldable mono, Element mono ~ Int64) => Int32 -> mono -> WriteVector Int64+  fromMonoFoldable 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+  {-# INLINE fromMonoFoldable #-}+  fromMonoFoldable :: (MonoFoldable mono, Element mono ~ Float) => Int32 -> mono -> WriteVector Float+  fromMonoFoldable 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+  {-# INLINE fromMonoFoldable #-}+  fromMonoFoldable :: (MonoFoldable mono, Element mono ~ Double) => Int32 -> mono -> WriteVector Double+  fromMonoFoldable 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+  {-# INLINE fromMonoFoldable #-}+  fromMonoFoldable :: (MonoFoldable mono, Element mono ~ Bool) => Int32 -> mono -> WriteVector Bool+  fromMonoFoldable 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+  {-# INLINE fromMonoFoldable #-}+  fromMonoFoldable :: (MonoFoldable mono, Element mono ~ WriteStruct a) => Int32 -> mono -> WriteVector (WriteStruct a)+  fromMonoFoldable n = WriteVectorStruct . inlineVector coerce (structAlignmentOf @a) (structSizeOf @a) n   data TextInfos = TextInfos ![TextInfo] {-# UNPACK #-} !BufferSize@@ -522,9 +585,9 @@ 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+  {-# INLINE fromMonoFoldable #-}+  fromMonoFoldable :: (MonoFoldable mono, Element mono ~ Text) => Int32 -> mono -> WriteVector Text+  fromMonoFoldable elemCount texts = WriteVectorText . WriteTableField $ do     modify' $ \fbs ->       let (builder2, bsize2) =             writeVectorSizePrefix . writeOffsets . align . writeStrings $ (builder fbs, bufferSize fbs)@@ -542,7 +605,7 @@           -- 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+              Mono.ofoldr                 (\t (TextInfos infos bsize) ->                   let textLength = utf8length t                       padding = calcPadding 4 (textLength + 1) bsize@@ -606,12 +669,12 @@ 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+  {-# INLINE fromMonoFoldable #-}+  fromMonoFoldable :: (MonoFoldable mono, Element mono ~ WriteTable a) => Int32 -> mono -> WriteVector (WriteTable a)+  fromMonoFoldable elemCount tables = WriteVectorTable . WriteTableField $ do     fbs1 <- get     let !(TableInfo fbs2 positions) =-          foldr+          Mono.ofoldr             (\(WriteTable writeTable) (TableInfo fbs positions) ->               let (pos, fbs') = runState writeTable fbs               in  TableInfo fbs' (pos : positions)@@ -632,7 +695,7 @@             (OffsetInfo 0 [])             positions -    coerce $ fromFoldable elemCount offsets+    coerce $ fromMonoFoldable elemCount offsets  data Vecs a = Vecs ![Word8] ![Maybe (State FBState Position)] @@ -644,11 +707,11 @@ 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 =+  {-# INLINE fromMonoFoldable #-}+  fromMonoFoldable :: (MonoFoldable mono, Element mono ~ WriteUnion a) => Int32 -> mono -> WriteVector (WriteUnion a)+  fromMonoFoldable elemCount unions =     let Vecs types values =-          foldr+          Mono.ofoldr             go             (Vecs [] [])             unions@@ -691,9 +754,9 @@                       (OffsetInfo 0 [])                       positions -              coerce $ fromFoldable elemCount offsets+              coerce $ fromMonoFoldable elemCount offsets -    in  WriteVectorUnion (coerce $ fromFoldable elemCount types) writeUnionTables+    in  WriteVectorUnion (coerce $ fromMonoFoldable elemCount types) writeUnionTables   @@ -702,13 +765,7 @@ {-# 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+  (complement (size + additionalBytes) + 1) .&. (fromIntegral n - 1)  -- | Add enough 0-padding so that the buffer becomes aligned to @n@ after writing @additionalBytes@. {-# INLINE alignTo #-}

@@ -7,14 +7,20 @@   (     -- * Creating a vector     W.WriteVectorElement(..)+  , W.fromMonoFoldable'+  , W.fromFoldable   , W.fromFoldable'   , W.fromList   , W.fromList'   , W.singleton   , W.empty+  , W.fromByteString+  , W.fromLazyByteString      -- * Reading a vector   , R.VectorElement(..)+  , R.index+  , R.toByteString   ) where  import           FlatBuffers.Internal.Read  as R

@@ -2,7 +2,7 @@  module Examples.Generated where -import           FlatBuffers+import           FlatBuffers ( defaultOptions, mkFlatBuffers )  $(mkFlatBuffers "test/Examples/schema.fbs"           defaultOptions) $(mkFlatBuffers "test/Examples/vector_of_unions.fbs" defaultOptions)

@@ -2,6 +2,7 @@  module Examples.HandWritten where +import           Data.Bits                           ( (.&.) ) import           Data.Int import           Data.Text                           ( Text ) import           Data.Word@@ -10,7 +11,6 @@ import           FlatBuffers.Internal.FileIdentifier ( HasFileIdentifier(..), unsafeFileIdentifier ) import           FlatBuffers.Internal.Read import           FlatBuffers.Internal.Types-import           FlatBuffers.Internal.Util           ( Positive(getPositive) ) import           FlatBuffers.Internal.Write  ----------------------------------@@ -116,6 +116,16 @@     ColorGray  -> 5     ColorBlack -> 8 +{-# INLINE colorName #-}+colorName :: Color -> Text+colorName c =+  case c of+    ColorRed   -> "Red"+    ColorGreen -> "Green"+    ColorBlue  -> "Blue"+    ColorGray  -> "Gray"+    ColorBlack -> "Black"+ ---------------------------------- ------------- Enums -------------- ----------------------------------@@ -144,7 +154,7 @@ enumsXs = readTableFieldOpt (readPrimVector VectorInt16) 2  enumsYs :: Table Enums -> Either ReadError (Maybe (Vector (Struct StructWithEnum)))-enumsYs = readTableFieldOpt readStructVector 3+enumsYs = readTableFieldOpt (readPrimVector VectorStruct) 3   @@ -169,7 +179,76 @@ structWithEnumZ :: Struct StructWithEnum -> Either ReadError Int8 structWithEnumZ = readStructField readInt8 4 + ----------------------------------+--------- EnumsBitFlags ----------+----------------------------------+colorsRed, colorsGreen, colorsBlue, colorsGray, colorsBlack :: Word16+colorsRed = 1+colorsGreen = 4+colorsBlue = 8+colorsGray = 16+colorsBlack = 32++{-# INLINE allColors #-}+allColors :: [Word16]+allColors = [colorsRed, colorsGreen, colorsBlue, colorsGray, colorsBlack]++{-# INLINE colorsNames #-}+colorsNames :: Word16 -> [Text]+colorsNames c = res5+  where+    res0 = []+    res1 = if colorsBlack .&. c /= 0 then "Black" : res0 else res0+    res2 = if colorsGray  .&. c /= 0 then "Gray"  : res1 else res1+    res3 = if colorsBlue  .&. c /= 0 then "Blue"  : res2 else res2+    res4 = if colorsGreen .&. c /= 0 then "Green" : res3 else res3+    res5 = if colorsRed   .&. c /= 0 then "Red"   : res4 else res4+++data EnumsBitFlags++enumsBitFlags ::+    Maybe Word16+  -> Maybe (WriteStruct StructWithEnumBitFlags)+  -> Maybe (WriteVector Word16)+  -> Maybe (WriteVector (WriteStruct StructWithEnumBitFlags))+  -> WriteTable EnumsBitFlags+enumsBitFlags x y xs ys = writeTable+  [ optionalDef 0 writeWord16TableField x+  , optional writeStructTableField y+  , optional writeVectorWord16TableField xs+  , optional writeVectorStructTableField ys+  ]++enumsBitFlagsX :: Table EnumsBitFlags -> Either ReadError Word16+enumsBitFlagsX = readTableFieldWithDef readWord16 0 0++enumsBitFlagsY :: Table EnumsBitFlags -> Either ReadError (Maybe (Struct StructWithEnumBitFlags))+enumsBitFlagsY = readTableFieldOpt (Right . readStruct) 1++enumsBitFlagsXs :: Table EnumsBitFlags -> Either ReadError (Maybe (Vector Word16))+enumsBitFlagsXs = readTableFieldOpt (readPrimVector VectorWord16) 2++enumsBitFlagsYs :: Table EnumsBitFlags -> Either ReadError (Maybe (Vector (Struct StructWithEnumBitFlags)))+enumsBitFlagsYs = readTableFieldOpt (readPrimVector VectorStruct) 3++++data StructWithEnumBitFlags++instance IsStruct StructWithEnumBitFlags where+  structAlignmentOf = 2+  structSizeOf = 2++structWithEnumBitFlags :: Word16 -> WriteStruct StructWithEnumBitFlags+structWithEnumBitFlags x = WriteStruct $+  buildWord16 x++structWithEnumBitFlagsX :: Struct StructWithEnumBitFlags -> Either ReadError Word16+structWithEnumBitFlagsX = readStructField readWord16 0++---------------------------------- ------------- Structs ------------ ---------------------------------- data Struct1@@ -464,16 +543,16 @@   ]  vectorOfStructsAs :: Table VectorOfStructs -> Either ReadError (Maybe (Vector (Struct Struct1)))-vectorOfStructsAs = readTableFieldOpt readStructVector 0+vectorOfStructsAs = readTableFieldOpt (readPrimVector VectorStruct) 0  vectorOfStructsBs :: Table VectorOfStructs -> Either ReadError (Maybe (Vector (Struct Struct2)))-vectorOfStructsBs = readTableFieldOpt readStructVector 1+vectorOfStructsBs = readTableFieldOpt (readPrimVector VectorStruct) 1  vectorOfStructsCs :: Table VectorOfStructs -> Either ReadError (Maybe (Vector (Struct Struct3)))-vectorOfStructsCs = readTableFieldOpt readStructVector 2+vectorOfStructsCs = readTableFieldOpt (readPrimVector VectorStruct) 2  vectorOfStructsDs :: Table VectorOfStructs -> Either ReadError (Maybe (Vector (Struct Struct4)))-vectorOfStructsDs = readTableFieldOpt readStructVector 3+vectorOfStructsDs = readTableFieldOpt (readPrimVector VectorStruct) 3   ----------------------------------@@ -521,8 +600,12 @@   -> Maybe Bool   -> Maybe Int16   -> Maybe Int16+  -> Maybe Word16+  -> Maybe Word16+  -> Maybe Word16+  -> Maybe Word16   -> WriteTable ScalarsWithDefaults-scalarsWithDefaults a b c d e f g h i j k l m n =+scalarsWithDefaults a b c d e f g h i j k l m n o p q r =   writeTable     [ optionalDef 8 writeWord8TableField          a     , optionalDef 16 writeWord16TableField        b@@ -538,6 +621,10 @@     , optionalDef False writeBoolTableField       l     , optionalDef 1 writeInt16TableField          m     , optionalDef 5 writeInt16TableField          n+    , optionalDef 0 writeWord16TableField         o+    , optionalDef 12 writeWord16TableField        p+    , optionalDef 1 writeWord16TableField         q+    , optionalDef 20 writeWord16TableField        r     ]  scalarsWithDefaultsA :: Table ScalarsWithDefaults -> Either ReadError Word8@@ -554,6 +641,10 @@ scalarsWithDefaultsL :: Table ScalarsWithDefaults -> Either ReadError Bool scalarsWithDefaultsM :: Table ScalarsWithDefaults -> Either ReadError Int16 scalarsWithDefaultsN :: Table ScalarsWithDefaults -> Either ReadError Int16+scalarsWithDefaultsO :: Table ScalarsWithDefaults -> Either ReadError Word16+scalarsWithDefaultsP :: Table ScalarsWithDefaults -> Either ReadError Word16+scalarsWithDefaultsQ :: Table ScalarsWithDefaults -> Either ReadError Word16+scalarsWithDefaultsR :: Table ScalarsWithDefaults -> Either ReadError Word16 scalarsWithDefaultsA = readTableFieldWithDef readWord8   0 8 scalarsWithDefaultsB = readTableFieldWithDef readWord16  1 16 scalarsWithDefaultsC = readTableFieldWithDef readWord32  2 32@@ -568,6 +659,10 @@ scalarsWithDefaultsL = readTableFieldWithDef readBool    11 False scalarsWithDefaultsM = readTableFieldWithDef readInt16   12 1 scalarsWithDefaultsN = readTableFieldWithDef readInt16   13 5+scalarsWithDefaultsO = readTableFieldWithDef readWord16  14 0+scalarsWithDefaultsP = readTableFieldWithDef readWord16  15 12+scalarsWithDefaultsQ = readTableFieldWithDef readWord16  16 1+scalarsWithDefaultsR = readTableFieldWithDef readWord16  17 20   ----------------------------------

@@ -180,7 +180,7 @@   padding `isLessThan` fromIntegral alignment    -- The buffer is aligned to `alignment` bytes-  getSum (bufferSize finalState) `mod` fromIntegral alignment === 0+  bufferSize finalState `isAlignedTo` fromIntegral alignment   prop_inlineVectorAlignment ::

@@ -12,8 +12,9 @@  import           Control.Applicative  ( liftA3 ) -import           Data.Aeson           ( (.=), Value(..), object )+import           Data.Aeson           ( (.=), Value(..), object, toJSON ) import qualified Data.Aeson           as J+import           Data.Bits            ( (.|.) ) import qualified Data.ByteString.Lazy as BSL import           Data.Int import           Data.Maybe           ( isNothing )@@ -216,6 +217,74 @@         enumsXs decoded `shouldBeRightAnd` isNothing         enumsYs decoded `shouldBeRightAnd` isNothing +    describe "Enums with bit_flags" $ do+      it "present" $ do+        (json, decoded) <- flatc $ enumsBitFlags+          (Just (colorsRed .|. colorsGreen))+          (Just (structWithEnumBitFlags (colorsGreen .|. colorsGray)))+          (Just (Vec.fromList'+            [ colorsGreen .|. colorsGray+            , colorsBlack .|. colorsBlue+            , colorsGreen+            ]))+          (Just (Vec.fromList'+            [ structWithEnumBitFlags (colorsGreen .|. colorsGray)+            , structWithEnumBitFlags (colorsBlack .|. colorsBlue)+            , structWithEnumBitFlags colorsGreen+            ]))++        json `shouldBeJson` object+          [ "x" .= (colorsRed .|. colorsGreen)+          , "y" .= object [ "x" .= (colorsGreen .|. colorsGray) ]+          , "xs" .=+            [ toJSON (colorsGreen .|. colorsGray)+            , toJSON (colorsBlack .|. colorsBlue)+            , String "Green"+            ]+          , "ys" .=+            [ object [ "x" .= (colorsGreen .|. colorsGray) ]+            , object [ "x" .= (colorsBlack .|. colorsBlue) ]+            , object [ "x" .= String "Green" ]+            ]+          ]++        enumsBitFlagsX decoded `shouldBe` Right (colorsRed .|. colorsGreen)+        (enumsBitFlagsY decoded >>= traverse structWithEnumBitFlagsX) `shouldBe` Right (Just (colorsGreen .|. colorsGray))+        (enumsBitFlagsXs decoded >>= traverse Vec.toList) `shouldBe` Right (Just+          [ colorsGreen .|. colorsGray+          , colorsBlack .|. colorsBlue+          , colorsGreen+          ])+        (enumsBitFlagsYs decoded >>= traverse Vec.toList >>= traverse (traverse structWithEnumBitFlagsX)) `shouldBe` Right (Just+          [ colorsGreen .|. colorsGray+          , colorsBlack .|. colorsBlue+          , colorsGreen+          ])++      it "present with defaults" $ do+        (json, decoded) <- flatc $ enumsBitFlags+          (Just 0)+          Nothing+          Nothing+          Nothing++        json `shouldBeJson` object [ ]++        enumsBitFlagsX decoded `shouldBe` Right 0+        enumsBitFlagsY decoded `shouldBeRightAnd` isNothing+        enumsBitFlagsXs decoded `shouldBeRightAnd` isNothing+        enumsBitFlagsYs decoded `shouldBeRightAnd` isNothing++      it "missing" $ do+        (json, decoded) <- flatc $ enumsBitFlags Nothing Nothing Nothing Nothing++        json `shouldBeJson` object [ ]++        enumsBitFlagsX decoded `shouldBe` Right 0+        enumsBitFlagsY decoded `shouldBeRightAnd` isNothing+        enumsBitFlagsXs decoded `shouldBeRightAnd` isNothing+        enumsBitFlagsYs decoded `shouldBeRightAnd` isNothing+     describe "Structs" $ do       it "present" $ do         let readStruct1 = (liftA3 . liftA3) (,,) struct1X struct1Y struct1Z@@ -458,7 +527,7 @@         json `shouldBeJson` object [ "xs" .= [] @Value]          xs <- evalRightJust $ vectorOfTablesXs decoded-        Vec.length xs `shouldBe` Right 0+        Vec.length xs `shouldBe` 0        it "missing" $ do         (json, decoded) <- flatc $ vectorOfTables Nothing@@ -522,10 +591,10 @@         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+        Vec.length as `shouldBe` 0+        Vec.length bs `shouldBe` 0+        Vec.length cs `shouldBe` 0+        Vec.length ds `shouldBe` 0        it "missing" $ do         (json, decoded) <- flatc $ vectorOfStructs Nothing Nothing Nothing Nothing@@ -558,14 +627,23 @@             scalarsWithDefaultsL decoded `shouldBe` Right False             toColor <$> scalarsWithDefaultsM decoded `shouldBe` Right (Just ColorBlue)             toColor <$> scalarsWithDefaultsN decoded `shouldBe` Right (Just ColorGray)+            scalarsWithDefaultsO decoded `shouldBe` Right 0+            scalarsWithDefaultsP decoded `shouldBe` Right (colorsGreen .|. colorsBlue)+            scalarsWithDefaultsQ decoded `shouldBe` Right colorsRed+            scalarsWithDefaultsR decoded `shouldBe` Right (colorsGreen .|. colorsGray)        it "present with defaults" $ runTest $ scalarsWithDefaults         (Just 8) (Just 16) (Just 32) (Just 64)         (Just (-1)) (Just (-2)) (Just (-4)) (Just (-8))         (Just 3.9) (Just (-2.3e10)) (Just True) (Just False)         (Just (fromColor ColorBlue)) (Just (fromColor ColorGray))+        (Just 0)+        (Just (colorsGreen .|. colorsBlue))+        (Just colorsRed)+        (Just (colorsGreen .|. colorsGray))        it "missing" $ runTest $ scalarsWithDefaults+        Nothing Nothing Nothing Nothing         Nothing Nothing Nothing Nothing         Nothing Nothing Nothing Nothing         Nothing Nothing Nothing Nothing

@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE NegativeLiterals #-}  module FlatBuffers.Internal.Compiler.ParserSpec where @@ -19,237 +20,281 @@ 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 "empty schema" $+      [r||] `parses` Schema [] [] -      it "includes" $-        [r|-          include "somefile";-          include "other \"escaped\" File";-        |] `parses` Schema ["somefile", "other \"escaped\" File"] []+    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 "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 "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 {}+    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)-              ]+        table ATable {+          abc : bool;+          b1 : bool = true;+          b2 : bool = false;+          d : Ref;+          d : uint;+          d : uint_;+          d : X.uint;+          d : X.uint_;+          e : [uint] ;+          f : [uint_];+          g : My . Api . Ref ;+          h : [ MyApi.abc_ ] ;+          i: Color;+        }+      |] `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")) Nothing (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) Nothing (Metadata mempty)+            , TableField "f" (TVector (TRef (TypeRef "" "uint_"))) Nothing (Metadata mempty)+            , TableField "g" (TRef (TypeRef "My.Api" "Ref")) Nothing (Metadata mempty)+            , TableField "h" (TVector (TRef (TypeRef "MyApi" "abc_"))) Nothing (Metadata mempty)+            , TableField "i" (TRef (TypeRef "" "Color")) Nothing (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 default values" $+      [r|+        table T {+          a : int = true;+          a : int=true ;+          a : int = "true";+          a : int = " true ";+          a : int = false;+          a : int = "false";+          a : int = 123;+          a : int = "123";+          a : int = -123;+          a : int = "-123";+          a : int = " -123 ";+          a : int = -99.2e9;+          a : int = - 99.2e9;+          a : int = "-99.2e9";+          a : int = " -99.2e9 ";+          a : int = 99992873786287637862.298736756627897654e99;+          a : int = Red;+          a : int = "Red";+          a : int = " Red ";+          a : int = " Red Blue ";+          a : int = "Red\nBlue";+          a : int = "Red 4";+          a : int = "1 4";+        }+      |] `parses`+        Schema+          []+          [ DeclT $ TableDecl "T" (Metadata mempty)+            [ TableField "a" TInt32 (Just (DefaultBool True)) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultBool True)) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultBool True)) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultBool True)) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultBool False)) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultBool False)) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultNum 123)) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultNum 123)) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultNum -123)) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultNum -123)) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultNum -123)) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultNum -99.2e9)) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultNum -99.2e9)) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultNum -99.2e9)) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultNum -99.2e9)) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultNum 99992873786287637862.298736756627897654e99)) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultRef ["Red"])) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultRef ["Red"])) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultRef ["Red"])) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultRef ["Red", "Blue"])) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultRef ["Red", "Blue"])) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultRef ["Red", "4"])) (Metadata mempty)+            , TableField "a" TInt32 (Just (DefaultRef ["1", "4"])) (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 "default value cannot be an empty string" $ do+      parseEof schema [r| table T { a:int = "";     } |] `shouldFailWithError` "Expected 'true', 'false', a number, or one or more identifiers\n"+      parseEof schema [r| table T { a:int = " ";    } |] `shouldFailWithError` "Expected 'true', 'false', a number, or one or more identifiers\n"+      parseEof schema [r| table T { a:int = " \n "; } |] `shouldFailWithError` "Expected 'true', 'false', a number, or one or more identifiers\n" -      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 "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 "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 "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 "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 "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 "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"+    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")+              ]+          ] -        [r| file_identifier "abcd"; |] `parses` Schema [] [ DeclFI "abcd" ]-        [r| file_identifier "👬";   |] `parses` Schema [] [ DeclFI "👬" ]+    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 "json objects" $-        [r|-          include "a";+    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" -          {-            "a" : 3 ,-            b : "e" ,-            c : [ { d: [ [ ] , [ "a" , null , true , false , - 3 , -239.223e3 ] ] } ]-          }+      [r| file_identifier "abcd"; |] `parses` Schema [] [ DeclFI "abcd" ]+      [r| file_identifier "👬";   |] `parses` Schema [] [ DeclFI "👬" ] -          attribute b;-        |] `parses`-          Schema-            [ Include "a" ]-            [ DeclA $ AttributeDecl "b" ]+    it "json objects" $+      [r|+        include "a"; -      it "RPC services" $-        [r|-          include "a";+        {+          "a" : 3 ,+          b : "e" ,+          c : [ { d: [ [ ] , [ "a" , null , true , false , - 3 , -239.223e3 ] ] } ]+        } -          rpc_service MonsterStorage {-            Store(Monster) : Stat ;-            Retrieve(Stat) : Monster ( streaming : "server" , idempotent ) ;-          }+        attribute b;+      |] `parses`+        Schema+          [ Include "a" ]+          [ DeclA $ AttributeDecl "b" ] -        |] `parses`-          Schema-            [ Include "a" ] []+    it "RPC services" $+      [r|+        include "a"; -shouldFailWithError :: Show a => Either (ParseErrorBundle String Void) a -> String -> Expectation+        rpc_service MonsterStorage {+          Store(Monster) : Stat ;+          Retrieve(Stat) : Monster ( streaming : "server" , idempotent ) ;+        }++      |] `parses`+        Schema+          [ Include "a" ] []++shouldFailWithError :: (HasCallStack, Show a) => Either (ParseErrorBundle String Void) a -> String -> Expectation shouldFailWithError p s =   case p of     Left (ParseErrorBundle [x] _) -> parseErrorTextPretty x `shouldBe` s@@ -259,7 +304,7 @@ parseEof :: Parser a -> String -> Either (ParseErrorBundle String Void) a parseEof p = parse (p <* eof) "" -parses :: String -> Schema -> Expectation+parses :: HasCallStack => String -> Schema -> Expectation parses input expectedSchema =   case parse schema "" input of     l@(Left _) -> l `shouldParse` expectedSchema

@@ -4,10 +4,11 @@  module FlatBuffers.Internal.Compiler.SemanticAnalysisSpec where +import           Data.Bits                                      ( shiftL ) import           Data.Foldable                                  ( fold ) import           Data.Int-import           Data.Text                                      ( Text )-import qualified Data.Text                                      as T+import           Data.List.NonEmpty                             ( NonEmpty((:|)) )+import qualified Data.Map.Strict                                as Map  import qualified FlatBuffers.Internal.Compiler.Parser           as P import           FlatBuffers.Internal.Compiler.SemanticAnalysis@@ -19,18 +20,32 @@ 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"+      [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| namespace A; union X{x}        table X{}         |] `shouldFail` "'A.X' declared more than once"+      [r|              union X{x}        table X{}         |] `shouldFail` "'X' declared more than once" +    it "top-level identifiers cannot have duplicates in the same namespace, in different files" $ do+      [   [r| namespace A; enum E:int{x} |]+        , [r| namespace A; enum E:int{y} |]+        ] `shouldFail'` "'A.E' declared more than once"++      [   [r| namespace A; enum X:int{x} |]+        , [r| namespace A; table X {y: int;} |]+        ] `shouldFail'` "'A.X' declared more than once"++      [   [r| enum X:int{x} |]+        , [r| table X {y: int;} |]+        ] `shouldFail'` "'X' declared more than once"+     it "top-level identifiers can be duplicates, if they live in different namespaces" $       [r|         namespace A;@@ -139,7 +154,7 @@           namespace Ns;           enum Color : uint32 { Red, Green, Blue }         |] `shouldValidate`-          enum ("Ns", EnumDecl "Color" EWord32+          enum ("Ns", EnumDecl "Color" EWord32 False             [ EnumVal "Red" 0             , EnumVal "Green" 1             , EnumVal "Blue" 2@@ -158,14 +173,14 @@           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] )+          [ enum ("A",      EnumDecl "Color1" EWord32 False [EnumVal "Red" 0] )+          , enum ("",       EnumDecl "Color2" EWord32 False [EnumVal "Green" 0] )+          , enum ("A.B.C",  EnumDecl "Color3" EWord32 False [EnumVal "Blue" 0] )           ]        it "with explicit values" $         [r| enum Color : int32 { Red = -2, Green, Blue = 2 } |] `shouldValidate`-          enum ("", EnumDecl "Color" EInt32+          enum ("", EnumDecl "Color" EInt32 False             [ EnumVal "Red" (-2)             , EnumVal "Green" (-1)             , EnumVal "Blue" 2@@ -173,7 +188,7 @@        it "with explicit values (min/maxBound)" $         [r| enum Color : int8 { Red = -128, Green, Blue = 127 } |] `shouldValidate`-          enum ("", EnumDecl "Color" EInt8+          enum ("", EnumDecl "Color" EInt8 False           [ EnumVal "Red" (toInteger (minBound :: Int8))           , EnumVal "Green" (-127)           , EnumVal "Blue" (toInteger (maxBound :: Int8))@@ -184,34 +199,108 @@           namespace A.B;           enum Color : int8 { Red = -129, Green, Blue }         |] `shouldFail`-          "[A.B.Color.Red]: enum value does not fit [-128; 127]"+          "[A.B.Color.Red]: enum value of -129 does not fit [-128; 127]"         [r|           enum Color : int8 { Red, Green, Blue = 128 }         |] `shouldFail`-          "[Color.Blue]: enum value does not fit [-128; 127]"+          "[Color.Blue]: enum value of 128 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"+          "[Color]: enum values must be specified in ascending order. 'Green' (2) should be greater than 'Red' (3)"         [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"+          "[Color]: enum values must be specified in ascending order. 'Green' (3) should be greater than 'Red' (3)"        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"+        let expected = "[Color]: underlying enum type must be integral"+        [r| enum Color : double  { Red, Green, Blue } |] `shouldFail` expected+        [r| enum Color : TypeRef { Red, Green, Blue } |] `shouldFail` expected+        [r| enum Color : [int]   { Red, Green, Blue } |] `shouldFail` expected +    describe "enums with bit_flags" $ do+      it "simple" $+        [r|+          namespace Ns;+          enum Color : uint32 (bit_flags) { Red, Green, Blue }+        |] `shouldValidate`+          enum ("Ns", EnumDecl "Color" EWord32 True+            [ EnumVal "Red" 1+            , EnumVal "Green" 2+            , EnumVal "Blue" 4+            ])++      it "multiple enums in different namespaces" $+        [r|+          namespace A;+          enum Color1 : uint32 (bit_flags) { Red }++          namespace B;+          namespace ;+          enum Color2 : uint32 (bit_flags) { Green }++          namespace A.B.C;+          enum Color3 : uint32 (bit_flags) { Blue }++        |] `shouldValidate` foldDecls+          [ enum ("A",      EnumDecl "Color1" EWord32 True [EnumVal "Red" 1] )+          , enum ("",       EnumDecl "Color2" EWord32 True [EnumVal "Green" 1] )+          , enum ("A.B.C",  EnumDecl "Color3" EWord32 True [EnumVal "Blue" 1] )+          ]++      it "with explicit values" $+        [r| enum Color : uint8 (bit_flags) { Red = 2, Green, Blue = 6 } |] `shouldValidate`+          enum ("", EnumDecl "Color" EWord8 True+            [ EnumVal "Red" 4+            , EnumVal "Green" 8+            , EnumVal "Blue" 64+            ])++      it "with explicit values (min/maxBound)" $+        [r| enum Color : uint (bit_flags) { Red = 0, Green, Blue = 31 } |] `shouldValidate`+          enum ("", EnumDecl "Color" EWord32 True+          [ EnumVal "Red" 1+          , EnumVal "Green" 2+          , EnumVal "Blue" (1 `shiftL` 31)+          ])++      it "with out-of-bounds values" $ do+        [r|+          namespace A.B;+          enum Color : uint (bit_flags) { Red = -1, Green, Blue }+        |] `shouldFail`+          "[A.B.Color.Red]: enum value of -1 does not fit [0; 31]"+        [r|+          enum Color : uint (bit_flags) { Red, Green, Blue = 32 }+        |] `shouldFail`+          "[Color.Blue]: enum value of 32 does not fit [0; 31]"++      it "with values out of order" $ do+        [r| enum Color : uint8 (bit_flags) { Red = 3, Green = 2, Blue } |] `shouldFail`+          "[Color]: enum values must be specified in ascending order. 'Green' (2) should be greater than 'Red' (3)"+        [r| enum Color : uint8 (bit_flags) { Red = 3, Green = 3, Blue } |] `shouldFail`+          "[Color]: enum values must be specified in ascending order. 'Green' (3) should be greater than 'Red' (3)"++      it "with duplicate values" $+        [r| enum Color : uint8 (bit_flags) { Red, Green, Red, Gray, Green, Green, Black } |] `shouldFail`+          "[Color]: 'Green', 'Red' declared more than once"++      it "with invalid underlying type" $ do+        let expected = "[Color]: underlying enum type must be integral"+        [r| enum Color : double  (bit_flags) { Red, Green, Blue } |] `shouldFail` expected+        [r| enum Color : TypeRef (bit_flags) { Red, Green, Blue } |] `shouldFail` expected+        [r| enum Color : [int]   (bit_flags) { Red, Green, Blue } |] `shouldFail` expected++      it "with signed underlying type" $ do+        let expected = "[Color]: underlying type of bit_flags enum must be unsigned"+        [r| enum Color : int8  (bit_flags) { Red, Green, Blue } |] `shouldFail` expected+        [r| enum Color : int16 (bit_flags) { Red, Green, Blue } |] `shouldFail` expected+        [r| enum Color : int32 (bit_flags) { Red, Green, Blue } |] `shouldFail` expected+        [r| enum Color : int64 (bit_flags) { Red, Green, Blue } |] `shouldFail` expected+     describe "structs" $ do       it "simple" $         [r|@@ -240,7 +329,7 @@        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])+            mkEnum namespace ident = enum (namespace, EnumDecl ident EInt16 False [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}@@ -267,7 +356,7 @@        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])+            mkEnum namespace ident = enum (namespace, EnumDecl ident EInt16 False [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}@@ -316,12 +405,28 @@             x: Color;           }         |] `shouldValidate` foldDecls-          [ enum ("A", EnumDecl "Color" EWord16 [EnumVal "Blue" 0])+          [ enum ("A", EnumDecl "Color" EWord16 False [EnumVal "Blue" 0])           , struct ("A", StructDecl "S" 2 2               [ StructField "x" 0 0 (SEnum (TypeRef "A" "Color") EWord16)               ])           ] ++      it "with field referencing an enum with bit_flags" $+        [r|+          namespace A;+          enum Color : ushort (bit_flags) { Blue }++          struct S {+            x: Color;+          }+        |] `shouldValidate` foldDecls+          [ enum ("A", EnumDecl "Color" EWord16 True [EnumVal "Blue" 1])+          , 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) ])@@ -387,6 +492,11 @@         [r| struct S { x: string; } |] `shouldFail`           "[S.x]: struct fields may only be integers, floating point, bool, enums, or other structs" +      it "with invalid nested struct" $ do+        let expectedErrorMsg = "[S2.x]: struct fields may only be integers, floating point, bool, enums, or other structs"+        [r| struct S1 { x: S2; }     struct S2 { x: string; } |] `shouldFail` expectedErrorMsg+        [r| struct S2 { x: string; } struct S1 { x: S2; }     |] `shouldFail` expectedErrorMsg+       it "with duplicate fields" $         [r| struct S { x: byte; x: int; } |] `shouldFail`           "[S]: 'x' declared more than once"@@ -683,52 +793,73 @@               x: B.E;             }           |] `shouldValidate` foldDecls-            [ enum ("A.B", EnumDecl "E" EInt16 [ EnumVal "A" 0 ])+            [ enum ("A.B", EnumDecl "E" EInt16 False [ 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`+          [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 ])+          [r|+            table T { x: E (deprecated); }+            enum E : short{A}+          |] `shouldValidate` foldDecls+            [ enum ("", EnumDecl "E" EInt16 False [ 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 ])+          [r|+            table T { x: E; }+            enum E : short{ A = -1, B = 0, C = 1}+          |] `shouldValidate` foldDecls+            [ enum ("", EnumDecl "E" EInt16 False [ 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`+          [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 ])+            [r|+              table T { x: E = 1; }+              enum E : short{ A, B, C }+            |] `shouldValidate` foldDecls+              [ enum ("", EnumDecl "E" EInt16 False [ 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 "integral must match one of the enum values" $+            [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 ])+            [r|+              table T { x: E = B; }+              enum E : short{ A, B, C }+            |] `shouldValidate` foldDecls+              [ enum ("", EnumDecl "E" EInt16 False [ EnumVal "A" 0, EnumVal "B" 1, EnumVal "C" 2 ])               , table ("", TableDecl "T" NotRoot                   [ TableField 0 "x" (TEnum (TypeRef "" "E") EInt16 1) False ]                 )@@ -736,16 +867,135 @@            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"+              "[T.x]: default value of D is not part of enum 'E'" +          it "multiple identifiers" $+            [r| table T { x: E = "B C"; } enum E : short{ A, B, C } |] `shouldFail`+              "[T.x]: default value must be a single identifier, found 2: 'B', 'C'"+           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`+            [r| table T { x: E = true; } enum E : short{ A, B, C } |] `shouldFail`               "[T.x]: default value must be integral or one of: 'A', 'B', 'C'" +      describe "with reference to enum with bit_flags" $ do+        it "simple" $+          [r|+            namespace A.B;+            enum E : ushort (bit_flags) { A }+            table T {+              x: B.E;+            }+          |] `shouldValidate` foldDecls+            [ enum ("A.B", EnumDecl "E" EWord16 True [ EnumVal "A" 1 ])+            , table ("A.B", TableDecl "T" NotRoot+                [ TableField 0 "x" (TEnum (TypeRef "A.B" "E") EWord16 0) False ]+              )+            ]++        it "with `required` attribute" $+          [r|+            table T { x: E (required); }+            enum E : ushort (bit_flags) {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 : ushort (bit_flags) {A}+          |] `shouldValidate` foldDecls+            [ enum ("", EnumDecl "E" EWord16 True [ EnumVal "A" 1 ])+            , table ("", TableDecl "T" NotRoot+                [ TableField 0 "x" (TEnum (TypeRef "" "E") EWord16 0) True ]+              )+            ]++        it "without default value, when enum doesn't have 1-value" $+          [r|+            table T { x: E; }+            enum E : ushort (bit_flags) { A = 9 }+          |] `shouldValidate` foldDecls+            [ enum ("", EnumDecl "E" EWord16 True [ EnumVal "A" 512 ])+            , table ("", TableDecl "T" NotRoot+                [ TableField 0 "x" (TEnum (TypeRef "" "E") EWord16 0) False ]+              )+            ]++        describe "with default value" $ do+          it "valid integral" $+            [r|+              table T { x: E = 2; }+              enum E : ushort (bit_flags) { A, B, C }+            |] `shouldValidate` foldDecls+              [ enum ("", EnumDecl "E" EWord16 True [ EnumVal "A" 1, EnumVal "B" 2, EnumVal "C" 4 ])+              , table ("", TableDecl "T" NotRoot+                  [ TableField 0 "x" (TEnum (TypeRef "" "E") EWord16 2) False ]+                )+              ]++          it "integral doesn't have to match any enum value" $+            [r|+              table T { x: E = 65535; }+              enum E : ushort (bit_flags) { A, B, C }+            |] `shouldValidate` foldDecls+              [ enum ("", EnumDecl "E" EWord16 True [ EnumVal "A" 1, EnumVal "B" 2, EnumVal "C" 4 ])+              , table ("", TableDecl "T" NotRoot+                  [ TableField 0 "x" (TEnum (TypeRef "" "E") EWord16 65535) False ]+                )+              ]++          it "must be within the range of the enum's underlying type" $+            [r|+              table T { x: E = 65536; }+              enum E : ushort (bit_flags) { A, B, C }+            |] `shouldFail`+              "[T.x]: default value does not fit [0; 65535]"++          it "valid identifier" $+            [r|+              table T { x: E = B; }+              enum E : ushort (bit_flags) { A, B, C }+            |] `shouldValidate` foldDecls+              [ enum ("", EnumDecl "E" EWord16 True [ EnumVal "A" 1, EnumVal "B" 2, EnumVal "C" 4 ])+              , table ("", TableDecl "T" NotRoot+                  [ TableField 0 "x" (TEnum (TypeRef "" "E") EWord16 2) False ]+                )+              ]++          it "invalid identifier" $+            [r| table T { x: E = D; } enum E : ushort (bit_flags) { A, B, C } |] `shouldFail`+              "[T.x]: default value of D is not part of enum 'E'"++          it "multiple valid identifiers" $+            [r|+              table T { x: E = "B C"; }+              enum E : ushort (bit_flags) { A, B, C }+            |] `shouldValidate` foldDecls+              [ enum ("", EnumDecl "E" EWord16 True [ EnumVal "A" 1, EnumVal "B" 2, EnumVal "C" 4 ])+              , table ("", TableDecl "T" NotRoot+                  [ TableField 0 "x" (TEnum (TypeRef "" "E") EWord16 6) False ]+                )+              ]++          it "mix of valid and invalid identifiers" $+            [r|+              table T { x: E = "B X C"; }+              enum E : ushort (bit_flags) { A, B, C }+            |] `shouldFail`+              "[T.x]: default value of X is not part of enum 'E'"++          it "decimal number" $+            [r| table T { x: E = 1.5; } enum E : ushort (bit_flags) { A, B, C } |] `shouldFail`+              "[T.x]: default value must be integral, one of ['A', 'B', 'C'], or a combination of the latter in double quotes (e.g. \"A B\")"++          it "boolean" $+            [r| table T { x: E = true; } enum E : ushort (bit_flags) { A, B, C } |] `shouldFail`+              "[T.x]: default value must be integral, one of ['A', 'B', 'C'], or a combination of the latter in double quotes (e.g. \"A B\")"+       describe "with reference to structs/table/union" $ do         it "simple" $           [r|@@ -831,24 +1081,27 @@               , TableField 2 "z" (TVector Opt VBool) False               ]) -        it "where the elements are references" $+        it "where the elements are references (enum, struct, table, union)" $           [r|             namespace A;-            table Table { w: [B.E]; x: [B.S]; y: [B.T]; z: [B.U]; }+            table Table { a: [B.E]; b: [B.EBF]; c: [B.S]; d: [B.T]; e: [B.U]; }              namespace A.B;             enum   E : int16 { EA }+            enum   EBF : uint16 (bit_flags) { 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+                [ TableField 0 "a" (TVector Opt (VEnum   (TypeRef "A.B" "E") EInt16)) False+                , TableField 1 "b" (TVector Opt (VEnum   (TypeRef "A.B" "EBF") EWord16)) False+                , TableField 2 "c" (TVector Opt (VStruct (TypeRef "A.B" "S"))) False+                , TableField 3 "d" (TVector Opt (VTable  (TypeRef "A.B" "T"))) False+                , TableField 5 "e" (TVector Opt (VUnion  (TypeRef "A.B" "U"))) False                 ])-            , enum   ("A.B", EnumDecl "E" EInt16 [EnumVal "EA" 0])+            , enum   ("A.B", EnumDecl "E" EInt16 False [EnumVal "EA" 0])+            , enum   ("A.B", EnumDecl "EBF" EWord16 True [EnumVal "EA" 1])             , 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")])@@ -1097,28 +1350,36 @@               ])           ] -+      it "can use the same table twice, if using a qualified name and an alias" $+        [r|+          namespace A;+          table T{}+          union U {T, alias:A.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] [] [] []+enum (ns, e) = SymbolTable (Map.singleton (ns, getIdent e) e) Map.empty Map.empty Map.empty  struct :: (Namespace, StructDecl) -> ValidDecls-struct s = SymbolTable [] [s] [] []+struct (ns, s) = SymbolTable Map.empty (Map.singleton (ns, getIdent s) s) Map.empty Map.empty  table :: (Namespace, TableDecl) -> ValidDecls-table t = SymbolTable [] [] [t] []+table (ns, t) = SymbolTable Map.empty Map.empty (Map.singleton (ns, getIdent t) t) Map.empty  union :: (Namespace, UnionDecl) -> ValidDecls-union u = SymbolTable [] [] [] [u]+union (ns, u) = SymbolTable Map.empty Map.empty Map.empty (Map.singleton (ns, getIdent u) u)  shouldSucceed :: HasCallStack => String -> Expectation shouldSucceed input =@@ -1127,8 +1388,8 @@     Right schema ->       let schemas = FileTree "" schema []       in  case validateSchemas schemas of-            Right _ -> pure ()-            Left err -> expectationFailure (T.unpack err)+            Right _  -> pure ()+            Left err -> expectationFailure err  shouldValidate :: HasCallStack => String -> ValidDecls -> Expectation shouldValidate input expectation =@@ -1138,13 +1399,23 @@       let schemas = FileTree "" schema []       in  validateSchemas schemas `shouldBe` Right (FileTree "" expectation []) -shouldFail :: String -> Text -> Expectation+shouldFail :: HasCallStack => String -> String -> 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+++shouldFail' :: HasCallStack => NonEmpty String -> String -> Expectation+shouldFail' inputs expectedErrorMsg =+  case traverse (parse P.schema "") inputs of+    Left e -> expectationFailure $ "Parsing failed with error:\n" <> showBundle e+    Right (schema :| schemas) ->+      let importesFilepathsAndSchemas = Map.fromList (fmap (\s -> ("", s)) schemas)+          fileTree = FileTree "" schema importesFilepathsAndSchemas+      in  validateSchemas fileTree `shouldBe` Left expectedErrorMsg  showBundle :: (ShowErrorComponent e, Stream s) => ParseErrorBundle s e -> String showBundle = unlines . fmap indent . lines . errorBundlePretty

@@ -7,6 +7,7 @@  import           Control.Arrow                                  ( second ) +import           Data.Bits                                      ( (.&.) ) import           Data.Int import           Data.Text                                      ( Text ) import qualified Data.Text                                      as T@@ -20,7 +21,6 @@ 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@@ -294,10 +294,17 @@               fromColor :: Color -> Int8               fromColor n =                 case n of-                  ColorRed -> 1+                  ColorRed  -> 1                   ColorBlue -> 2               {-# INLINE fromColor #-} +              colorName :: Color -> Text+              colorName c =+                case c of+                  ColorRed  -> T.pack "Red"+                  ColorBlue -> T.pack "Blue"+              {-# INLINE colorName #-}+               data T                t :: Maybe Int8 -> WriteTable T@@ -307,6 +314,40 @@               tX = readTableFieldWithDef readInt8 0 2             |] +      describe "enum fields with bit_flags" $+        it "are encoded as fields of the underlying type" $+          [r|+            enum Colors: ubyte (bit_flags) { Red = 2, Blue }+            table T {x: Colors = Blue; }+          |] `shouldCompileTo`+            [d|+              colorsRed :: Word8+              colorsRed = 4++              colorsBlue :: Word8+              colorsBlue = 8++              allColors :: [Word8]+              allColors = [ colorsRed, colorsBlue ]+              {-# INLINE allColors #-}++              colorsNames :: Word8 -> [Text]+              colorsNames c = res2+                where+                  res0 = []+                  res1 = if colorsBlue .&. c /= 0 then T.pack "Blue" : res0 else res0+                  res2 = if colorsRed  .&. c /= 0 then T.pack "Red"  : res1 else res1+              {-# INLINE colorsNames #-}++              data T++              t :: Maybe Word8 -> WriteTable T+              t x = writeTable [ optionalDef 8 writeWord8TableField x ]++              tX :: Table T -> Either ReadError Word8+              tX = readTableFieldWithDef readWord8 0 8+            |]+       describe "struct fields" $ do         it "normal field" $           [r|@@ -732,6 +773,10 @@                 fromColor n = case n of ColorRed -> 0                 {-# INLINE fromColor #-} +                colorName :: Color -> Text+                colorName c = case c of ColorRed -> T.pack "red"+                {-# INLINE colorName #-}+                 data T1                 t1 :: Maybe (WriteVector Int16) -> WriteTable T1                 t1 a = writeTable@@ -741,6 +786,7 @@                 t1A :: Table T1 -> Either ReadError (Maybe (Vector Int16))                 t1A = readTableFieldOpt (readPrimVector VectorInt16) 0               |]+           it "required" $             [r|               table t1 { a: [color] (required); }@@ -761,6 +807,10 @@                 fromColor n = case n of ColorRed -> 0                 {-# INLINE fromColor #-} +                colorName :: Color -> Text+                colorName c = case c of ColorRed -> T.pack "red"+                {-# INLINE colorName #-}+                 data T1                 t1 :: WriteVector Int16 -> WriteTable T1                 t1 a = writeTable@@ -771,6 +821,67 @@                 t1A = readTableFieldReq (readPrimVector VectorInt16) 0 "a"               |] +        describe "vector of enums with bit_flags" $ do+          it "normal" $+            [r|+              table t1 { a: [colors]; }+              enum colors : ulong (bit_flags) { red = 20 }+            |] `shouldCompileTo`+              [d|+                colorsRed :: Word64+                colorsRed = 1048576++                allColors :: [Word64]+                allColors = [ colorsRed ]+                {-# INLINE allColors #-}++                colorsNames :: Word64 -> [Text]+                colorsNames c = res1+                  where+                    res0 = []+                    res1 = if colorsRed .&. c /= 0 then T.pack "red" : res0 else res0+                {-# INLINE colorsNames #-}++                data T1+                t1 :: Maybe (WriteVector Word64) -> WriteTable T1+                t1 a = writeTable+                  [ optional writeVectorWord64TableField a+                  ]++                t1A :: Table T1 -> Either ReadError (Maybe (Vector Word64))+                t1A = readTableFieldOpt (readPrimVector VectorWord64) 0+              |]++          it "required" $+            [r|+              table t1 { a: [colors] (required); }+              enum colors : uint64 (bit_flags) { red = 63 }+            |] `shouldCompileTo`+              [d|+                colorsRed :: Word64+                colorsRed = 9223372036854775808++                allColors :: [Word64]+                allColors = [ colorsRed ]+                {-# INLINE allColors #-}++                colorsNames :: Word64 -> [Text]+                colorsNames c = res1+                  where+                    res0 = []+                    res1 = if colorsRed .&. c /= 0 then T.pack "red" : res0 else res0+                {-# INLINE colorsNames #-}++                data T1+                t1 :: WriteVector Word64 -> WriteTable T1+                t1 a = writeTable+                  [ writeVectorWord64TableField a+                  ]++                t1A :: Table T1 -> Either ReadError (Vector Word64)+                t1A = readTableFieldReq (readPrimVector VectorWord64) 0 "a"+              |]+         describe "vector of structs" $ do           it "normal" $             [r|@@ -796,7 +907,7 @@                   ]                  t1A :: Table T1 -> Either ReadError (Maybe (Vector (Struct S1)))-                t1A = readTableFieldOpt readStructVector 0+                t1A = readTableFieldOpt (readPrimVector VectorStruct) 0               |]            it "required" $@@ -823,7 +934,7 @@                   ]                  t1A :: Table T1 -> Either ReadError (Vector (Struct S1))-                t1A = readTableFieldReq readStructVector 0 "a"+                t1A = readTableFieldReq (readPrimVector VectorStruct) 0 "a"               |]          describe "vector of tables" $ do@@ -917,7 +1028,7 @@      describe "Enums" $       it "naming conventions" $ do-        let expected =+        let expected redName greenName =               [d|                 data MyColor = MyColorIsRed | MyColorIsGreen                   deriving (Eq, Show, Read, Ord, Bounded)@@ -936,13 +1047,48 @@                     MyColorIsRed -> -2                     MyColorIsGreen -> -1                 {-# INLINE fromMyColor #-}++                myColorName :: MyColor -> Text+                myColorName c =+                  case c of+                    MyColorIsRed   -> T.pack $(stringE redName)+                    MyColorIsGreen -> T.pack $(stringE greenName)+                {-# INLINE myColorName #-}               |] -        [r| enum my_color: int16 { is_red = -2, is_green  } |] `shouldCompileTo` expected-        [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+        [r| enum my_color: int16 { is_red = -2, is_green  } |] `shouldCompileTo` expected "is_red" "is_green"+        [r| enum My_Color: int16 { Is_Red = -2, Is_Green  } |] `shouldCompileTo` expected "Is_Red" "Is_Green"+        [r| enum MyColor:  int16 { IsRed = -2,  IsGreen   } |] `shouldCompileTo` expected "IsRed"  "IsGreen"+        [r| enum myColor:  int16 { isRed = -2,  isGreen   } |] `shouldCompileTo` expected "isRed"  "isGreen" ++    describe "Enums with bit_flags" $+      it "naming conventions" $ do+        let expected redName greenName =+              [d|+                myColorsIsRed :: Word16+                myColorsIsRed = 4+                myColorsIsGreen :: Word16+                myColorsIsGreen = 8++                allMyColors :: [Word16]+                allMyColors = [ myColorsIsRed, myColorsIsGreen ]+                {-# INLINE allMyColors #-}++                myColorsNames :: Word16 -> [Text]+                myColorsNames c = res2+                  where+                    res0 = []+                    res1 = if myColorsIsGreen .&. c /= 0 then T.pack $(stringE greenName) : res0 else res0+                    res2 = if myColorsIsRed   .&. c /= 0 then T.pack $(stringE redName)   : res1 else res1+                {-# INLINE myColorsNames #-}+              |]++        [r| enum my_colors: ushort (bit_flags) { is_red = 2, is_green  } |] `shouldCompileTo` expected "is_red" "is_green"+        [r| enum My_Colors: ushort (bit_flags) { Is_Red = 2, Is_Green  } |] `shouldCompileTo` expected "Is_Red" "Is_Green"+        [r| enum MyColors:  ushort (bit_flags) { IsRed = 2,  IsGreen   } |] `shouldCompileTo` expected "IsRed"  "IsGreen"+        [r| enum myColors:  ushort (bit_flags) { isRed = 2,  isGreen   } |] `shouldCompileTo` expected "isRed"  "isGreen"+     describe "Structs" $ do       it "naming conventions" $ do         let expected =@@ -1052,6 +1198,10 @@             fromE n = case n of EX -> 0             {-# INLINE fromE #-} +            eName :: E -> Text+            eName c = case c of EX -> T.pack "X"+            {-# INLINE eName #-}+             data S             instance IsStruct S where               structAlignmentOf = 1@@ -1064,6 +1214,38 @@             sE = readStructField readInt8 0           |] +      it "with enum fields with bit_flags" $+        [r|+          struct S { e: E; }+          enum E : ubyte (bit_flags) { X }+        |] `shouldCompileTo`+          [d|+            eX :: Word8+            eX = 1++            allE :: [Word8]+            allE = [ eX ]+            {-# INLINE allE #-}++            eNames :: Word8 -> [Text]+            eNames c = res1+              where+                res0 = []+                res1 = if eX .&. c /= 0 then T.pack "X" : res0 else res0+            {-# INLINE eNames #-}++            data S+            instance IsStruct S where+              structAlignmentOf = 1+              structSizeOf = 1++            s :: Word8 -> WriteStruct S+            s e = WriteStruct (buildWord8 e)++            sE :: Struct S -> Either ReadError Word8+            sE = readStructField readWord8 0+          |]+       it "with nested structs" $         [r|           struct S1 (force_align: 2) { s2: S2; }@@ -1133,7 +1315,7 @@     Right schema ->       let schemas = FileTree "" schema mempty       in  case validateSchemas schemas of-        Left err                  -> expectationFailure $ T.unpack err+        Left err                  -> expectationFailure err         Right (FileTree _ root _) -> do           ast <- runQ (compileSymbolTable root)           expected <- runQ expectedQ@@ -1243,6 +1425,7 @@     CaseE e matches -> CaseE (normalizeExp e) (normalizeMatch <$> matches)     ConE name -> ConE (normalizeName name)     InfixE l op r -> InfixE (normalizeExp <$> l) (normalizeExp op) (normalizeExp <$> r)+    CondE b t f -> CondE (normalizeExp b) (normalizeExp t) (normalizeExp f)     _ -> e  normalizeMatch :: Match -> Match

@@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NegativeLiterals #-}+{-# LANGUAGE ScopedTypeVariables #-}  {-# OPTIONS_GHC -Wno-incomplete-patterns #-} @@ -10,7 +12,10 @@  import           Data.Functor               ( ($>) ) import           Data.Int+import qualified Data.List                  as List import qualified Data.Maybe                 as Maybe+import qualified Data.Text                  as Text+import qualified Data.Text.Read             as Text  import           Examples @@ -18,8 +23,12 @@ 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 "read" $ do@@ -72,16 +81,6 @@       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 [])@@ -123,7 +122,7 @@               Left e  -> evaluate e $> ()             ) `shouldThrow` errorCall "FlatBuffers.Internal.Read.index: index too large: 98" -      let testLargeUnsafeIndex table getVector = do+      let testInvalidUnsafeIndex table getVector = do             case getIndex table getVector Vec.unsafeIndex 100 of               Right a -> evaluate a $> ()               Left e -> evaluate e $> ()@@ -147,18 +146,18 @@               (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+          testInvalidUnsafeIndex table vectorsA+          testInvalidUnsafeIndex table vectorsB+          testInvalidUnsafeIndex table vectorsC+          testInvalidUnsafeIndex table vectorsD+          testInvalidUnsafeIndex table vectorsE+          testInvalidUnsafeIndex table vectorsF+          testInvalidUnsafeIndex table vectorsG+          testInvalidUnsafeIndex table vectorsH+          testInvalidUnsafeIndex table vectorsI+          testInvalidUnsafeIndex table vectorsJ+          testInvalidUnsafeIndex table vectorsK+          testInvalidUnsafeIndex table vectorsL          it "`index` throws when index is negative" $ do           testNegativeIndex table vectorsA@@ -188,6 +187,64 @@           testLargeIndex table vectorsK           testLargeIndex table vectorsL +        it "`take` and `drop` are consistent with Data.List.take and Data.List.drop" $+          requireProperty $ do+            listWord8  <- forAll $ Gen.list (Range.linear 0 20) (Gen.word8  (Range.linear 0 20))+            listWord16 <- forAll $ Gen.list (Range.linear 0 20) (Gen.word16 (Range.linear 0 20))+            listWord32 <- forAll $ Gen.list (Range.linear 0 20) (Gen.word32 (Range.linear 0 20))+            listWord64 <- forAll $ Gen.list (Range.linear 0 20) (Gen.word64 (Range.linear 0 20))+            listInt8   <- forAll $ Gen.list (Range.linear 0 20) (Gen.int8   (Range.linear -20 20))+            listInt16  <- forAll $ Gen.list (Range.linear 0 20) (Gen.int16  (Range.linear -20 20))+            listInt32  <- forAll $ Gen.list (Range.linear 0 20) (Gen.int32  (Range.linear -20 20))+            listInt64  <- forAll $ Gen.list (Range.linear 0 20) (Gen.int64  (Range.linear -20 20))+            listFloat  <- forAll $ Gen.list (Range.linear 0 20) (Gen.float  (Range.linearFrac -20 20))+            listDouble <- forAll $ Gen.list (Range.linear 0 20) (Gen.double (Range.linearFrac -20 20))+            listBool   <- forAll $ Gen.list (Range.linear 0 20) Gen.bool+            listText   <- forAll $ Gen.list (Range.linear 0 20) (Gen.text (Range.singleton 3) Gen.alpha)++            n <- forAll $ Gen.int32 (Range.linearFrom 0 -10 30)++            table <- evalEither $ decode $ encode $ vectors+              (Just (Vec.fromList' listWord8))+              (Just (Vec.fromList' listWord16))+              (Just (Vec.fromList' listWord32))+              (Just (Vec.fromList' listWord64))+              (Just (Vec.fromList' listInt8))+              (Just (Vec.fromList' listInt16))+              (Just (Vec.fromList' listInt32))+              (Just (Vec.fromList' listInt64))+              (Just (Vec.fromList' listFloat))+              (Just (Vec.fromList' listDouble))+              (Just (Vec.fromList' listBool))+              (Just (Vec.fromList' listText))++            prop_takeConsistency n listWord8  (vectorsA table) pure+            prop_takeConsistency n listWord16 (vectorsB table) pure+            prop_takeConsistency n listWord32 (vectorsC table) pure+            prop_takeConsistency n listWord64 (vectorsD table) pure+            prop_takeConsistency n listInt8   (vectorsE table) pure+            prop_takeConsistency n listInt16  (vectorsF table) pure+            prop_takeConsistency n listInt32  (vectorsG table) pure+            prop_takeConsistency n listInt64  (vectorsH table) pure+            prop_takeConsistency n listFloat  (vectorsI table) pure+            prop_takeConsistency n listDouble (vectorsJ table) pure+            prop_takeConsistency n listBool   (vectorsK table) pure+            prop_takeConsistency n listText   (vectorsL table) pure++            prop_dropConsistency n listWord8  (vectorsA table) pure+            prop_dropConsistency n listWord16 (vectorsB table) pure+            prop_dropConsistency n listWord32 (vectorsC table) pure+            prop_dropConsistency n listWord64 (vectorsD table) pure+            prop_dropConsistency n listInt8   (vectorsE table) pure+            prop_dropConsistency n listInt16  (vectorsF table) pure+            prop_dropConsistency n listInt32  (vectorsG table) pure+            prop_dropConsistency n listInt64  (vectorsH table) pure+            prop_dropConsistency n listFloat  (vectorsI table) pure+            prop_dropConsistency n listDouble (vectorsJ table) pure+            prop_dropConsistency n listBool   (vectorsK table) pure+            prop_dropConsistency n listText   (vectorsL table) pure++       describe "of structs" $ do         let Right table = decode $ encode $ vectorOfStructs               (Just Vec.empty)@@ -196,7 +253,7 @@               (Just Vec.empty)          it "`unsafeIndex` does not throw when index is negative / too large" $-          testLargeUnsafeIndex table vectorOfStructsAs+          testInvalidUnsafeIndex table vectorOfStructsAs          it "`index` throws when index is negative" $           testNegativeIndex table vectorOfStructsAs@@ -204,12 +261,26 @@         it "`index` throws when index is too large" $           testLargeIndex table vectorOfStructsAs +        it "`take` and `drop` are consistent with Data.List.take and Data.List.drop" $+          requireProperty $ do+            listInt16 <- forAll $ Gen.list (Range.linear 0 20) (Gen.int16 (Range.linear -20 20))+            n <- forAll $ Gen.int32 (Range.linearFrom 0 -10 30)++            table <- evalEither $ decode $ encode $ vectorOfStructs+              Nothing+              (Just (Vec.fromList' (struct2 <$> listInt16)))+              Nothing+              Nothing++            prop_takeConsistency n listInt16 (vectorOfStructsBs table) struct2X+            prop_dropConsistency n listInt16 (vectorOfStructsBs table) struct2X+       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+          testInvalidUnsafeIndex table vectorOfTablesXs          it "`index` throws when index is negative" $           testNegativeIndex table vectorOfTablesXs@@ -217,16 +288,88 @@         it "`index` throws when index is too large" $           testLargeIndex table vectorOfTablesXs +        it "`take` and `drop` are consistent with Data.List.take and Data.List.drop" $+          requireProperty $ do+            listInt32 <- forAll $ Gen.list (Range.linear 0 20) (Gen.int32 (Range.linear -20 20))+            n <- forAll $ Gen.int32 (Range.linearFrom 0 -10 30)++            table <- evalEither $ decode $ encode $ vectorOfTables+              (Just (Vec.fromList' (axe . Just <$> listInt32)))++            prop_takeConsistency n listInt32 (vectorOfTablesXs table) axeY+            prop_dropConsistency n listInt32 (vectorOfTablesXs table) axeY+       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+          testInvalidUnsafeIndex table vectorOfUnionsXs          it "`index` throws when index is negative" $           testNegativeIndex table vectorOfUnionsXs          it "`index` throws when index is too large" $           testLargeIndex table vectorOfUnionsXs++        it "`take` and `drop` are consistent with Data.List.take and Data.List.drop" $+          requireProperty $ do+            listOfPairs :: [(String, Int32)] <- forAll $ Gen.list (Range.linear 0 20) $ do+              unionType <- Gen.element ["Axe", "Sword"]+              unionVal <- Gen.int32 (Range.linear -20 20)+              pure (unionType, unionVal)++            n <- forAll $ Gen.int32 (Range.linearFrom 0 -10 30)++            let pairToUnion :: (String, Int32) -> WriteUnion Weapon+                pairToUnion = \case+                  ("Axe", val)   -> weaponAxe (axe (Just val))+                  ("Sword", val) -> weaponSword (sword (Just (Text.pack (show val))))++            let unionToPair :: Union Weapon -> Either ReadError (String, Int32)+                unionToPair = \case+                  Union (WeaponAxe axe) -> do+                    val <- axeY axe+                    pure ("Axe", val)+                  Union (WeaponSword sword) -> do+                    textValMaybe <- swordX sword+                    case textValMaybe of+                      Just textVal ->+                        case Text.signed Text.decimal textVal of+                          Right (intVal, _) ->+                            pure ("Sword", intVal)++            table <- evalEither $ decode $ encode $ vectorOfUnions+              (Just (Vec.fromList' (pairToUnion <$> listOfPairs)))+              Vec.empty++            prop_takeConsistency n listOfPairs (vectorOfUnionsXs table) unionToPair+            prop_dropConsistency n listOfPairs (vectorOfUnionsXs table) unionToPair+++prop_takeConsistency ::+  (Eq a, Show a, VectorElement b)+  => Int32+  -> [a]+  -> Either ReadError (Maybe (Vector b))+  -> (b -> Either ReadError a)+  -> PropertyT IO ()+prop_takeConsistency n list vec extract = do+  Just vec <- evalEither vec+  (Vec.toList (Vec.take n vec) >>= traverse extract) === Right (List.take (fromIntegral n) list)+  Vec.length (Vec.take n vec) === fromIntegral (List.length (List.take (fromIntegral n) list))++prop_dropConsistency ::+  (Eq a, Show a, VectorElement b)+  => Int32+  -> [a]+  -> Either ReadError (Maybe (Vector b))+  -> (b -> Either ReadError a)+  -> PropertyT IO ()+prop_dropConsistency n list vec extract = do+  Just vec <- evalEither vec+  (Vec.toList (Vec.drop n vec) >>= traverse extract) === Right (List.drop (fromIntegral n) list)+  Vec.length (Vec.drop n vec) === fromIntegral (List.length (List.drop (fromIntegral n) list))++

@@ -11,6 +11,7 @@  import           Control.Applicative ( liftA3 ) +import           Data.Bits           ( (.|.) ) import           Data.Functor        ( (<&>) ) import qualified Data.List           as L import           Data.Maybe          ( isNothing )@@ -95,7 +96,7 @@         (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+        x <- evalRight $ decode @Enums $ encode $ enums (Just 0) Nothing Nothing Nothing          toColor <$> enumsX x `shouldBe` Right (Just ColorGreen)         enumsY x `shouldBeRightAnd` isNothing@@ -110,6 +111,51 @@         enumsXs x `shouldBeRightAnd` isNothing         enumsYs x `shouldBeRightAnd` isNothing +    describe "Enums with bit_flags" $ do+      it "present" $ do+        x <- evalRight $ decode $ encode $ enumsBitFlags+          (Just (colorsRed .|. colorsGreen))+          (Just (structWithEnumBitFlags (colorsGreen .|. colorsGray)))+          (Just (Vec.fromList'+            [ colorsGreen .|. colorsGray+            , colorsBlack .|. colorsBlue+            , colorsGreen+            ]))+          (Just (Vec.fromList'+            [ structWithEnumBitFlags (colorsGreen .|. colorsGray)+            , structWithEnumBitFlags (colorsBlack .|. colorsBlue)+            , structWithEnumBitFlags colorsGreen+            ]))++        enumsBitFlagsX x `shouldBe` Right (colorsRed .|. colorsGreen)+        (enumsBitFlagsY x >>= traverse structWithEnumBitFlagsX) `shouldBe` Right (Just (colorsGreen .|. colorsGray))+        (enumsBitFlagsXs x >>= traverse toList) `shouldBe` Right (Just+          [ colorsGreen .|. colorsGray+          , colorsBlack .|. colorsBlue+          , colorsGreen+          ])+        (enumsBitFlagsYs x >>= traverse toList >>= traverse (traverse structWithEnumBitFlagsX)) `shouldBe` Right (Just+          [ colorsGreen .|. colorsGray+          , colorsBlack .|. colorsBlue+          , colorsGreen+          ])++      it "present with defaults" $ do+        x <- evalRight $ decode @EnumsBitFlags $ encode $ enumsBitFlags (Just 0) Nothing Nothing Nothing++        enumsBitFlagsX x `shouldBe` Right 0+        enumsBitFlagsY x `shouldBeRightAnd` isNothing+        enumsBitFlagsXs x `shouldBeRightAnd` isNothing+        enumsBitFlagsYs x `shouldBeRightAnd` isNothing++      it "missing" $ do+        x <- evalRight $ decode @EnumsBitFlags $ encode $ enumsBitFlags Nothing Nothing Nothing Nothing++        enumsBitFlagsX x `shouldBe` Right 0+        enumsBitFlagsY x `shouldBeRightAnd` isNothing+        enumsBitFlagsXs x `shouldBeRightAnd` isNothing+        enumsBitFlagsYs x `shouldBeRightAnd` isNothing+     describe "Structs" $ do       let readStruct1 = (liftA3 . liftA3) (,,) struct1X struct1Y struct1Z       let readStruct2 = struct2X@@ -209,13 +255,13 @@         testPrimVector getVec expectedList = do           it "non empty" $ do             vec <- evalRightJust (getVec nonEmptyVecs)-            Vec.length vec `shouldBe` Right (L.genericLength expectedList)+            Vec.length vec `shouldBe` L.genericLength expectedList             Vec.toList vec `shouldBe` Right expectedList             traverse (\i -> vec `unsafeIndex` i) [0 .. L.genericLength expectedList - 1] `shouldBe` Right expectedList            it "empty" $ do             vec <- evalRightJust (getVec emptyVecs)-            Vec.length vec `shouldBe` Right 0+            Vec.length vec `shouldBe` 0             Vec.toList vec `shouldBe` Right []            it "missing" $@@ -245,7 +291,7 @@           )          Just xs <- evalRight $ vectorOfTablesXs x-        Vec.length xs `shouldBe` Right 3+        Vec.length xs `shouldBe` 3         (toList xs >>= traverse axeY) `shouldBe` Right [minBound, 0, maxBound]         (traverse (unsafeIndex xs) [0..2] >>= traverse axeY) `shouldBe` Right [minBound, 0, maxBound] @@ -253,7 +299,7 @@         x <- evalRight $ decode $ encode $ vectorOfTables (Just Vec.empty)          xs <- evalRightJust $ vectorOfTablesXs x-        Vec.length xs `shouldBe` Right 0+        Vec.length xs `shouldBe` 0         (toList xs >>= traverse axeY) `shouldBe` Right []        it "missing" $ do@@ -278,19 +324,19 @@         cs <- evalRightJust $ vectorOfStructsCs x         ds <- evalRightJust $ vectorOfStructsDs x -        Vec.length as `shouldBe` Right 2+        Vec.length as `shouldBe` 2         (toList as >>= traverse readStruct1) `shouldBe` Right [(1,2,3), (4,5,6)]         (traverse (unsafeIndex as) [0..1] >>= traverse readStruct1) `shouldBe` Right [(1,2,3), (4,5,6)] -        Vec.length bs `shouldBe` Right 3+        Vec.length bs `shouldBe` 3         (toList bs >>= traverse readStruct2) `shouldBe` Right [101, 102, 103]         (traverse (unsafeIndex bs) [0..2] >>= traverse readStruct2) `shouldBe` Right [101, 102, 103] -        Vec.length cs `shouldBe` Right 3+        Vec.length cs `shouldBe` 3         (toList cs >>= traverse readStruct3) `shouldBe` Right [(104, 105, 106), (107, 108, 109), (110, 111, 112)]         (traverse (unsafeIndex cs) [0..2] >>= traverse readStruct3) `shouldBe` Right [(104, 105, 106), (107, 108, 109), (110, 111, 112)] -        Vec.length ds `shouldBe` Right 3+        Vec.length ds `shouldBe` 3         (toList ds >>= traverse readStruct4) `shouldBe` Right [(120, 121, 122, True), (123, 124, 125, False), (126, 127, 128, True)]         (traverse (unsafeIndex ds) [0..2] >>= traverse readStruct4) `shouldBe` Right [(120, 121, 122, True), (123, 124, 125, False), (126, 127, 128, True)] @@ -303,16 +349,16 @@         cs <- evalRightJust $ vectorOfStructsCs x         ds <- evalRightJust $ vectorOfStructsDs x -        Vec.length as `shouldBe` Right 0+        Vec.length as `shouldBe` 0         (toList as >>= traverse readStruct1) `shouldBe` Right [] -        Vec.length bs `shouldBe` Right 0+        Vec.length bs `shouldBe` 0         (toList bs >>= traverse readStruct2) `shouldBe` Right [] -        Vec.length cs `shouldBe` Right 0+        Vec.length cs `shouldBe` 0         (toList cs >>= traverse readStruct3) `shouldBe` Right [] -        Vec.length ds `shouldBe` Right 0+        Vec.length ds `shouldBe` 0         (toList ds >>= traverse readStruct4) `shouldBe` Right []        it "missing" $ do@@ -346,7 +392,7 @@           )          Just xs <- evalRight $ vectorOfUnionsXs x-        Vec.length xs `shouldBe` Right 3+        Vec.length xs `shouldBe` 3         L.length <$> toList xs `shouldBe` Right 3         xs `unsafeIndex` 0 `shouldBeRightAndExpect` shouldBeSword "hi"         xs `unsafeIndex` 1 `shouldBeRightAndExpect` shouldBeNone@@ -356,7 +402,7 @@         (toList xs <&> (!! 2)) `shouldBeRightAndExpect` shouldBeAxe 98          xsReq <- evalRight $ vectorOfUnionsXsReq x-        Vec.length xsReq `shouldBe` Right 3+        Vec.length xsReq `shouldBe` 3         L.length <$> toList xsReq `shouldBe` Right 3         xsReq `unsafeIndex` 0 `shouldBeRightAndExpect` shouldBeSword "hi2"         xsReq `unsafeIndex` 1 `shouldBeRightAndExpect` shouldBeNone@@ -369,17 +415,17 @@         x <- evalRight $ decode $ encode $ vectorOfUnions (Just Vec.empty) Vec.empty          Just xs <- evalRight $ vectorOfUnionsXs x-        Vec.length xs `shouldBe` Right 0+        Vec.length xs `shouldBe` 0         L.length <$> toList xs `shouldBe` Right 0          xsReq <- evalRight $ vectorOfUnionsXsReq x-        Vec.length xsReq `shouldBe` Right 0+        Vec.length xsReq `shouldBe` 0         L.length <$> toList xsReq `shouldBe` Right 0        it "missing" $ do         x <- evalRight $ decode $ encode $ vectorOfUnions Nothing Vec.empty         vectorOfUnionsXs x `shouldBeRightAnd` isNothing-        (vectorOfUnionsXsReq x >>= Vec.length) `shouldBe` Right 0+        (Vec.length <$> vectorOfUnionsXsReq x) `shouldBe` Right 0      describe "ScalarsWithDefaults" $ do       let runTest buffer = do@@ -399,14 +445,23 @@             scalarsWithDefaultsL x `shouldBe` Right False             toColor <$> scalarsWithDefaultsM x `shouldBe` Right (Just ColorBlue)             toColor <$> scalarsWithDefaultsN x `shouldBe` Right (Just ColorGray)+            scalarsWithDefaultsO x `shouldBe` Right 0+            scalarsWithDefaultsP x `shouldBe` Right (colorsGreen .|. colorsBlue)+            scalarsWithDefaultsQ x `shouldBe` Right colorsRed+            scalarsWithDefaultsR x `shouldBe` Right (colorsGreen .|. colorsGray)        it "present with defaults" $ runTest $ scalarsWithDefaults         (Just 8) (Just 16) (Just 32) (Just 64)         (Just (-1)) (Just (-2)) (Just (-4)) (Just (-8))         (Just 3.9) (Just (-2.3e10)) (Just True) (Just False)         (Just (fromColor ColorBlue)) (Just (fromColor ColorGray))+        (Just 0)+        (Just (colorsGreen .|. colorsBlue))+        (Just colorsRed)+        (Just (colorsGreen .|. colorsGray))        it "missing" $ runTest $ scalarsWithDefaults+        Nothing Nothing Nothing Nothing         Nothing Nothing Nothing Nothing         Nothing Nothing Nothing Nothing         Nothing Nothing Nothing Nothing