flatbuffers 0.3.0.0 → 0.4.0.0

raw patch · 35 files changed

+865/−1082 lines, 35 filesdep +hex-textdep +hspec-hedgehogdep −hw-hspec-hedgehogdep −th-pprintdep ~basedep ~binarydep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: hex-text, hspec-hedgehog

Dependencies removed: hw-hspec-hedgehog, th-pprint

Dependency ranges changed: base, binary, bytestring, containers, directory, filepath, megaparsec, mono-traversable, mtl, parser-combinators, scientific, template-haskell, text, text-manipulate

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README.md +4/−3
• bench/DecodeVectors.hs +11/−16
• bench/Encode.hs +3/−3
• bench/EncodeVectors.hs +16/−20
• bench/Main.hs +4/−4
• bench/Types.hs +1/−3
• cbits/cbits.c +0/−78
• flatbuffers.cabal +117/−53
• src/FlatBuffers.hs +5/−7
• src/FlatBuffers/Internal/Build.hs +4/−6
• src/FlatBuffers/Internal/Compiler/Display.hs +6/−7
• src/FlatBuffers/Internal/Compiler/NamingConventions.hs +6/−8
• src/FlatBuffers/Internal/Compiler/Parser.hs +21/−24
• src/FlatBuffers/Internal/Compiler/ParserIO.hs +16/−19
• src/FlatBuffers/Internal/Compiler/SemanticAnalysis.hs +61/−67
• src/FlatBuffers/Internal/Compiler/SyntaxTree.hs +8/−14
• src/FlatBuffers/Internal/Compiler/TH.hs +61/−53
• src/FlatBuffers/Internal/Compiler/ValidSyntaxTree.hs +24/−26
• src/FlatBuffers/Internal/FileIdentifier.hs +5/−7
• src/FlatBuffers/Internal/Read.hs +49/−39
• src/FlatBuffers/Internal/Types.hs +2/−7
• src/FlatBuffers/Internal/Write.hs +47/−91
• src/FlatBuffers/Vector.hs +2/−2
• test/Examples/Generated.hs +1/−4
• test/Examples/HandWritten.hs +34/−35
• test/FlatBuffers/AlignmentSpec.hs +76/−86
• test/FlatBuffers/Integration/HaskellToScalaSpec.hs +0/−98
• test/FlatBuffers/Integration/RoundTripThroughFlatcSpec.hs +96/−51
• test/FlatBuffers/Internal/Compiler/ParserSpec.hs +8/−17
• test/FlatBuffers/Internal/Compiler/SemanticAnalysisSpec.hs +24/−32
• test/FlatBuffers/Internal/Compiler/THSpec.hs +45/−58
• test/FlatBuffers/ReadSpec.hs +34/−63
• test/FlatBuffers/RoundTripSpec.hs +27/−57
• test/TestImports.hs +41/−24

@@ -1,5 +1,11 @@ # Changelog +## 0.4.0.0 (2024-02-06)++* Added support for `text` >= 2.0 and `template-haskell` >= 2.18.0.0, removed support for older versions.+* Tested with GHC 9.2.5, 9.4.8 and 9.6.4.+* Forbid writing/reading `Nothing` to/from union vectors and required unions fields.+ ## 0.3.0.0 (2020-11-14)  * `FlatBuffers.Vector.toByteString` renamed to `FlatBuffers.Vector.toLazyByteString`

@@ -111,7 +111,7 @@  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.+In particular, `test/Examples/schema.fbs` contains a variety of data structures and `Examples.HandWritten` demonstrates what the code generated by `mkFlatBuffers` would look like.  ### Enums @@ -121,7 +121,7 @@ } ``` -Given the enum declarationa above, the following code will be generated:+Given the enum declaration above, the following code will be generated:  ```haskell data Color@@ -174,7 +174,7 @@ } ``` -Given the enum declarationa above, the following code will be generated:+Given the enum declaration above, the following code will be generated:  ```haskell colorsRed, colorsGreen, colorsBlue :: Word16@@ -413,6 +413,7 @@ - [ ] DSL that allows sharing of data (e.g. reuse an offset to a string/table) - [ ] `shared` attribute     - [Docs](https://google.github.io/flatbuffers/flatbuffers_guide_use_cpp.html#flatbuffers_cpp_object_based_api)+- [ ] Attach [Haddock documentation to the generated code](https://hackage.haskell.org/package/template-haskell-2.21.0.0/docs/Language-Haskell-TH-Lib.html#g:32).  ### Other 

@@ -1,28 +1,25 @@-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}- {-# OPTIONS_GHC -Wno-incomplete-patterns #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  {- HLINT ignore "Avoid lambda" -} {- HLINT ignore "Use >=>" -}  module DecodeVectors where -import           Control.Monad+import Control.Monad -import           Criterion+import Criterion -import           Data.Functor       ( (<&>) )-import           Data.Int-import qualified Data.List          as L-import qualified Data.Text          as T+import Data.Functor ((<&>))+import Data.Int+import Data.List qualified as L+import Data.Text qualified as T -import           FlatBuffers-import qualified FlatBuffers.Vector as Vec-import           FlatBuffers.Vector ( index, unsafeIndex )+import FlatBuffers+import FlatBuffers.Vector (index, unsafeIndex)+import FlatBuffers.Vector qualified as Vec -import           Types+import Types  n :: Num a => a n = 10000@@ -121,5 +118,3 @@       if odd i         then weaponUnionSword (swordTable (Just i))         else weaponUnionAxe  (axeTable (Just i))--

@@ -1,10 +1,10 @@ module Encode where -import           Criterion+import Criterion -import           FlatBuffers+import FlatBuffers -import           Types+import Types   groups :: [Benchmark]

@@ -1,28 +1,24 @@-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}- module EncodeVectors where  {- HLINT ignore "Avoid lambda" -} -import           Criterion+import Criterion -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.Vector.Storable as VS-import qualified Data.Vector.Unboxed  as VU+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BSL+import Data.Foldable as F+import Data.Functor ((<&>))+import Data.Int+import Data.List qualified as L+import Data.Text (Text)+import Data.Vector qualified as V+import Data.Vector.Storable qualified as VS+import Data.Vector.Unboxed qualified as VU -import           FlatBuffers-import qualified FlatBuffers.Vector   as Vec+import FlatBuffers+import FlatBuffers.Vector qualified as Vec -import           Types+import Types   n :: Num a => a@@ -168,8 +164,8 @@   ]  data User = User-  { userId :: !Int32-  , userAge :: !Int32+  { userId   :: !Int32+  , userAge  :: !Int32   , userName :: !Text   } 

@@ -1,9 +1,9 @@ module Main where -import           DecodeVectors-import           Encode-import           EncodeVectors-import           Criterion.Main+import Criterion.Main+import DecodeVectors+import Encode+import EncodeVectors  main :: IO () main =

@@ -1,7 +1,5 @@-{-# LANGUAGE TemplateHaskell #-}- module Types where -import           FlatBuffers+import FlatBuffers  $(mkFlatBuffers "bench/types.fbs" defaultOptions)

@@ -1,78 +0,0 @@-/*- * See https://github.com/haskell/text/blob/9fac5db9b048b7d68fa2fb68513ba86c791b3630/cbits/cbits.c for details.- */--#include <string.h>-#include <stdint.h>-#include <stdio.h>--uint32_t-_hs_text_length_utf8(const uint16_t *src, size_t srcoff,-		     size_t srclen)-{-  const uint16_t *srcend;--  int32_t counter = 0;--  src += srcoff;-  srcend = src + srclen;-- ascii:-#if defined(__x86_64__)-  while (srcend - src >= 4) {-    uint64_t w = *((uint64_t *) src);--    if (w & 0xFF80FF80FF80FF80ULL) {-      if (!(w & 0x000000000000FF80ULL)) {-	++counter;-	src++;-	if (!(w & 0x00000000FF800000ULL)) {-	  ++counter;-	  src++;-	  if (!(w & 0x0000FF8000000000ULL)) {-	    ++counter;-	    src++;-	  }-	}-      }-      break;-    }-    counter += 4;-    src += 4;-  }-#endif--#if defined(__i386__)-  while (srcend - src >= 2) {-    uint32_t w = *((uint32_t *) src);--    if (w & 0xFF80FF80)-      break;-    counter += 2;-    src += 2;-  }-#endif--  while (src < srcend) {-    uint16_t w = *src++;--    if (w <= 0x7F) {-      ++counter;-      /* An ASCII byte is likely to begin a run of ASCII bytes.-	 Falling back into the fast path really helps performance. */-      goto ascii;-    }-    else if (w <= 0x7FF) {-      counter += 2;-    }-    else if (w < 0xD800 || w > 0xDBFF) {-      counter += 3;-    } else {-      uint32_t c = ((((uint32_t) w) - 0xD800) << 10) +-	(((uint32_t) *src++) - 0xDC00) + 0x10000;-      counter += 4;-    }-  }--  return counter;-}

@@ -1,13 +1,11 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack------ hash: 0541ef367d9894ad47a27fd28156838bbc8c0b22f763bf1c95c6e41e7f96a8a3  name:           flatbuffers-version:        0.3.0.0+version:        0.4.0.0 synopsis:       Haskell implementation of the FlatBuffers protocol. description:    Haskell implementation of the FlatBuffers protocol.                 .@@ -20,12 +18,12 @@ copyright:      2019 Diogo Castro license:        BSD3 license-file:   LICENSE-tested-with:    GHC == 8.4.3 , GHC == 8.6.5 build-type:     Simple+tested-with:+    GHC == 9.2.5 , GHC == 9.4.8 , GHC == 9.6.4 extra-source-files:     README.md     CHANGELOG.md-    cbits/cbits.c extra-doc-files:     README.md @@ -55,24 +53,45 @@       Paths_flatbuffers   hs-source-dirs:       src+  default-extensions:+      AllowAmbiguousTypes+      BangPatterns+      BlockArguments+      DeriveTraversable+      DeriveTraversable+      DerivingStrategies+      GeneralizedNewtypeDeriving+      ImportQualifiedPost+      InstanceSigs+      LambdaCase+      NegativeLiterals+      OverloadedRecordDot+      OverloadedStrings+      QuasiQuotes+      RecordWildCards+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TypeApplications+      TypeFamilies+      TypeOperators+      ViewPatterns   ghc-options: -Wall -Wno-name-shadowing -Wincomplete-record-updates -Wredundant-constraints-  c-sources:-      cbits/cbits.c   build-depends:-      base >=4.11 && <5-    , binary >=0.8.4.0-    , bytestring >=0.10.8.0-    , containers >=0.5.11.0-    , directory >=1.3.1.2-    , filepath >=1.4.2-    , megaparsec >=7.0-    , mono-traversable >=1.0.1.2-    , mtl >=2.2.1-    , parser-combinators >=1.0-    , scientific >=0.3.5.2-    , template-haskell >=2.13.0.0-    , text >=1.2.3.0-    , text-manipulate >=0.1.0+      base >=4.16 && <5+    , binary >=0.8.9.0+    , bytestring >=0.11.3.1+    , containers >=0.6.4.1+    , directory >=1.3.6.2+    , filepath >=1.4.2.2+    , megaparsec >=9.2.2+    , mono-traversable >=1.0.15.3+    , mtl >=2.2.2+    , parser-combinators >=1.3.0+    , scientific >=0.3.7.0+    , template-haskell >=2.18.0.0+    , text >=2.0+    , text-manipulate >=0.3.1.0   default-language: Haskell2010  test-suite test@@ -83,7 +102,6 @@       Examples.Generated       Examples.HandWritten       FlatBuffers.AlignmentSpec-      FlatBuffers.Integration.HaskellToScalaSpec       FlatBuffers.Integration.RoundTripThroughFlatcSpec       FlatBuffers.Internal.Compiler.ParserSpec       FlatBuffers.Internal.Compiler.SemanticAnalysisSpec@@ -94,38 +112,61 @@       Paths_flatbuffers   hs-source-dirs:       test/+  default-extensions:+      AllowAmbiguousTypes+      BangPatterns+      BlockArguments+      DeriveTraversable+      DeriveTraversable+      DerivingStrategies+      GeneralizedNewtypeDeriving+      ImportQualifiedPost+      InstanceSigs+      LambdaCase+      NegativeLiterals+      OverloadedRecordDot+      OverloadedStrings+      QuasiQuotes+      RecordWildCards+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TypeApplications+      TypeFamilies+      TypeOperators+      ViewPatterns   ghc-options: -Wall -Wno-name-shadowing -Wincomplete-record-updates -Wredundant-constraints   build-depends:       HUnit     , aeson     , aeson-pretty-    , base >=4.11 && <5-    , binary >=0.8.4.0-    , bytestring >=0.10.8.0-    , containers >=0.5.11.0-    , directory >=1.3.1.2-    , filepath >=1.4.2+    , base >=4.16 && <5+    , binary >=0.8.9.0+    , bytestring >=0.11.3.1+    , containers >=0.6.4.1+    , directory >=1.3.6.2+    , filepath >=1.4.2.2     , flatbuffers     , hedgehog+    , hex-text     , hspec     , hspec-core     , hspec-expectations-pretty-diff+    , hspec-hedgehog     , hspec-megaparsec     , http-client     , http-types-    , hw-hspec-hedgehog-    , megaparsec >=7.0-    , mono-traversable >=1.0.1.2-    , mtl >=2.2.1-    , parser-combinators >=1.0+    , megaparsec >=9.2.2+    , mono-traversable >=1.0.15.3+    , mtl >=2.2.2+    , parser-combinators >=1.3.0     , pretty-simple     , process     , raw-strings-qq-    , scientific >=0.3.5.2-    , template-haskell >=2.13.0.0-    , text >=1.2.3.0-    , text-manipulate >=0.1.0-    , th-pprint+    , scientific >=0.3.7.0+    , template-haskell >=2.18.0.0+    , text >=2.0+    , text-manipulate >=0.3.1.0     , utf8-string   default-language: Haskell2010 @@ -140,24 +181,47 @@       Paths_flatbuffers   hs-source-dirs:       bench/+  default-extensions:+      AllowAmbiguousTypes+      BangPatterns+      BlockArguments+      DeriveTraversable+      DeriveTraversable+      DerivingStrategies+      GeneralizedNewtypeDeriving+      ImportQualifiedPost+      InstanceSigs+      LambdaCase+      NegativeLiterals+      OverloadedRecordDot+      OverloadedStrings+      QuasiQuotes+      RecordWildCards+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TypeApplications+      TypeFamilies+      TypeOperators+      ViewPatterns   ghc-options: -Wall -Wno-name-shadowing -Wincomplete-record-updates -Wredundant-constraints -threaded -rtsopts   build-depends:       aeson-    , base >=4.11 && <5-    , binary >=0.8.4.0-    , bytestring >=0.10.8.0-    , containers >=0.5.11.0+    , base >=4.16 && <5+    , binary >=0.8.9.0+    , bytestring >=0.11.3.1+    , containers >=0.6.4.1     , criterion-    , directory >=1.3.1.2-    , filepath >=1.4.2+    , directory >=1.3.6.2+    , filepath >=1.4.2.2     , flatbuffers-    , megaparsec >=7.0-    , mono-traversable >=1.0.1.2-    , mtl >=2.2.1-    , parser-combinators >=1.0-    , scientific >=0.3.5.2-    , template-haskell >=2.13.0.0-    , text >=1.2.3.0-    , text-manipulate >=0.1.0+    , megaparsec >=9.2.2+    , mono-traversable >=1.0.15.3+    , mtl >=2.2.2+    , parser-combinators >=1.3.0+    , scientific >=0.3.7.0+    , template-haskell >=2.18.0.0+    , text >=2.0+    , text-manipulate >=0.3.1.0     , vector   default-language: Haskell2010

@@ -8,7 +8,6 @@     -- * Creating a flatbuffer   , W.encode   , W.encodeWithFileIdentifier-  , W.none      -- * Reading a flatbuffer   , R.decode@@ -31,9 +30,8 @@   , R.ReadError   ) where -import           FlatBuffers.Internal.Compiler.TH    as TH-import           FlatBuffers.Internal.FileIdentifier as FI-import           FlatBuffers.Internal.Read           as R-import           FlatBuffers.Internal.Types          as T-import           FlatBuffers.Internal.Write          as W-+import FlatBuffers.Internal.Compiler.TH as TH+import FlatBuffers.Internal.FileIdentifier as FI+import FlatBuffers.Internal.Read as R+import FlatBuffers.Internal.Types as T+import FlatBuffers.Internal.Write as W

@@ -1,11 +1,9 @@-{-# LANGUAGE BangPatterns #-}- module FlatBuffers.Internal.Build where -import           Data.ByteString.Builder ( Builder )-import qualified Data.ByteString.Builder as B-import           Data.Int-import           Data.Word+import Data.ByteString.Builder (Builder)+import Data.ByteString.Builder qualified as B+import Data.Int+import Data.Word  {-# INLINE buildWord8 #-} buildWord8 :: Word8 -> Builder

@@ -2,12 +2,12 @@  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.Word+import Data.Int+import Data.List qualified as List+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NE+import Data.Text qualified as T+import Data.Word  -- | Maps a value of type @a@ into a string that can be displayed to the user. class Display a where@@ -35,4 +35,3 @@ instance Display Word16  where display = show instance Display Word32  where display = show instance Display Word64  where display = show-

@@ -1,14 +1,12 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-}- module FlatBuffers.Internal.Compiler.NamingConventions where -import qualified Data.Set                                      as Set-import           Data.Text                                     ( Text )-import qualified Data.Text                                     as T-import qualified Data.Text.Manipulate                          as TM+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Manipulate qualified as TM -import           FlatBuffers.Internal.Compiler.ValidSyntaxTree ( EnumDecl, EnumVal, 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 

@@ -1,35 +1,32 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}- {- HLINT ignore structField "Reduce duplication" -} {- HLINT ignore typeRef "Use <$>" -}  module FlatBuffers.Internal.Compiler.Parser where -import           Control.Monad                            ( when )-import qualified Control.Monad.Combinators.NonEmpty       as NE+import Control.Monad (when)+import Control.Monad.Combinators.NonEmpty qualified as NE -import qualified Data.ByteString                          as BS-import           Data.Coerce                              ( coerce )-import           Data.Functor                             ( (<&>), void )-import           Data.List.NonEmpty                       ( NonEmpty((:|)) )-import qualified Data.List.NonEmpty                       as NE-import qualified Data.Map.Strict                          as Map-import           Data.Maybe                               ( catMaybes )-import           Data.Scientific                          ( Scientific )-import           Data.Text                                ( Text )-import qualified Data.Text                                as T-import qualified Data.Text.Encoding                       as T-import           Data.Void                                ( Void )-import           Data.Word                                ( Word8 )+import Data.ByteString qualified as BS+import Data.Coerce (coerce)+import Data.Functor (void, (<&>))+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as Map+import Data.Maybe (catMaybes)+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Void (Void)+import Data.Word (Word8) -import           FlatBuffers.Internal.Compiler.SyntaxTree-import           FlatBuffers.Internal.Constants           ( fileIdentifierSize )+import FlatBuffers.Internal.Compiler.SyntaxTree+import FlatBuffers.Internal.Constants (fileIdentifierSize) -import           Text.Megaparsec-import           Text.Megaparsec.Char-import qualified Text.Megaparsec.Char.Lexer               as L-import           Text.Read                                ( readMaybe )+import Text.Megaparsec+import Text.Megaparsec.Char+import Text.Megaparsec.Char.Lexer qualified as L+import Text.Read (readMaybe)   type Parser = Parsec Void String

@@ -1,26 +1,23 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}  module FlatBuffers.Internal.Compiler.ParserIO where -import           Control.Monad                            ( when )-import           Control.Monad.Except                     ( MonadError, MonadIO, liftIO, throwError )-import           Control.Monad.State                      ( MonadState, execStateT, get, put )--import           Data.Coerce                              ( coerce )-import           Data.Foldable                            ( traverse_ )-import           Data.Map.Strict                          ( Map )-import qualified Data.Map.Strict                          as Map-import qualified Data.Text                                as T--import           FlatBuffers.Internal.Compiler.Display    ( display )-import           FlatBuffers.Internal.Compiler.Parser     ( schema )-import           FlatBuffers.Internal.Compiler.SyntaxTree ( FileTree(..), Include(..), Schema, StringLiteral(..), includes )--import qualified System.Directory                         as Dir-import qualified System.FilePath                          as FP--import           Text.Megaparsec                          ( errorBundlePretty, parse )+import Control.Monad (when)+import Control.Monad.Except (MonadError, throwError)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.State (MonadState, execStateT, get, put)+import Data.Coerce (coerce)+import Data.Foldable (traverse_)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import FlatBuffers.Internal.Compiler.Display (display)+import FlatBuffers.Internal.Compiler.Parser (schema)+import FlatBuffers.Internal.Compiler.SyntaxTree+  (FileTree(..), Include(..), Schema, StringLiteral(..), includes)+import System.Directory qualified as Dir+import System.FilePath qualified as FP+import Text.Megaparsec (errorBundlePretty, parse)  parseSchemas ::      MonadIO m

@@ -1,51 +1,45 @@-{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# 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                          ( 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 Control.Monad (forM_, join, when)+import Control.Monad.Except (throwError)+import Control.Monad.Reader (ReaderT, asks, local, runReaderT)+import Control.Monad.State+  (MonadState, State, StateT, evalState, evalStateT, get, gets, 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-import           Data.Functor                                  ( ($>), (<&>) )-import           Data.Int-import           Data.Ix                                       ( inRange )-import qualified Data.List                                     as List-import           Data.List.NonEmpty                            ( NonEmpty((:|)) )-import qualified Data.List.NonEmpty                            as NE-import           Data.Map.Strict                               ( Map )-import qualified Data.Map.Strict                               as Map-import           Data.Maybe                                    ( catMaybes, fromMaybe, isJust )-import           Data.Monoid                                   ( Sum(..) )-import           Data.Scientific                               ( Scientific )-import qualified Data.Scientific                               as Scientific-import           Data.Set                                      ( Set )-import qualified Data.Set                                      as Set-import           Data.Text                                     ( Text )-import qualified Data.Text                                     as T-import           Data.Traversable                              ( for )-import           Data.Word+import Data.Bits (Bits, FiniteBits, bit, finiteBitSize, (.&.), (.|.))+import Data.Coerce (coerce)+import Data.Foldable (asum, find, foldlM, traverse_)+import Data.Foldable qualified as Foldable+import Data.Functor (($>), (<&>))+import Data.Int+import Data.Ix (inRange)+import Data.List qualified as List+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (catMaybes, fromMaybe, isJust)+import Data.Monoid (Sum(..))+import Data.Scientific (Scientific)+import Data.Scientific qualified as Scientific+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.Traversable (for)+import Data.Word -import           FlatBuffers.Internal.Compiler.Display         ( Display(..) )-import           FlatBuffers.Internal.Compiler.SyntaxTree      ( FileTree(..), HasMetadata(..), Schema, qualify )-import qualified FlatBuffers.Internal.Compiler.SyntaxTree      as ST-import           FlatBuffers.Internal.Compiler.ValidSyntaxTree-import           FlatBuffers.Internal.Constants-import           FlatBuffers.Internal.Types+import FlatBuffers.Internal.Compiler.Display (Display(..))+import FlatBuffers.Internal.Compiler.SyntaxTree (FileTree(..), HasMetadata(..), Schema, qualify)+import FlatBuffers.Internal.Compiler.SyntaxTree qualified as ST+import FlatBuffers.Internal.Compiler.ValidSyntaxTree+import FlatBuffers.Internal.Constants+import FlatBuffers.Internal.Types -import           Text.Read                                     ( readMaybe )+import Text.Read (readMaybe)   ----------------------------------@@ -365,7 +359,7 @@           Just (ST.IntLiteral thisInt) ->             pure thisInt           Nothing ->-            get <&> \case+            gets \case               Just lastInt -> lastInt + 1               Nothing      -> 0       put (Just thisInt)@@ -393,11 +387,11 @@     validateBounds enumType enumVal =       validating enumVal $         case enumType of-          EInt8 -> validateBounds' @Int8 enumVal-          EInt16 -> validateBounds' @Int16 enumVal-          EInt32 -> validateBounds' @Int32 enumVal-          EInt64 -> validateBounds' @Int64 enumVal-          EWord8 -> validateBounds' @Word8 enumVal+          EInt8   -> validateBounds' @Int8 enumVal+          EInt16  -> validateBounds' @Int16 enumVal+          EInt32  -> validateBounds' @Int32 enumVal+          EInt64  -> validateBounds' @Int64 enumVal+          EWord8  -> validateBounds' @Word8 enumVal           EWord16 -> validateBounds' @Word16 enumVal           EWord32 -> validateBounds' @Word32 enumVal           EWord64 -> validateBounds' @Word64 enumVal@@ -614,9 +608,9 @@ 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"+    Nothing                -> pure (DefaultVal 0)+    Just (ST.DefaultNum n) -> pure (DefaultVal n)+    Just _                 -> throwErrorMsg "default value must be a number"  validateDefaultValAsBool :: Maybe ST.DefaultVal -> Validation (DefaultVal Bool) validateDefaultValAsBool dflt =@@ -951,18 +945,18 @@ structFieldAlignment :: UnpaddedStructField -> Alignment structFieldAlignment usf =   case unpaddedStructFieldType usf of-    SInt8 -> int8Size-    SInt16 -> int16Size-    SInt32 -> int32Size-    SInt64 -> int64Size-    SWord8 -> word8Size-    SWord16 -> word16Size-    SWord32 -> word32Size-    SWord64 -> word64Size-    SFloat -> floatSize-    SDouble -> doubleSize-    SBool -> boolSize-    SEnum _ enumType -> enumAlignment enumType+    SInt8                     -> int8Size+    SInt16                    -> int16Size+    SInt32                    -> int32Size+    SInt64                    -> int64Size+    SWord8                    -> word8Size+    SWord16                   -> word16Size+    SWord32                   -> word32Size+    SWord64                   -> word64Size+    SFloat                    -> floatSize+    SDouble                   -> doubleSize+    SBool                     -> boolSize+    SEnum _ enumType          -> enumAlignment enumType     SStruct (_, nestedStruct) -> structAlignment nestedStruct  enumAlignment :: EnumType -> Alignment@@ -972,11 +966,11 @@ enumSize :: EnumType -> Word8 enumSize e =   case e of-    EInt8 -> int8Size-    EInt16 -> int16Size-    EInt32 -> int32Size-    EInt64 -> int64Size-    EWord8 -> word8Size+    EInt8   -> int8Size+    EInt16  -> int16Size+    EInt32  -> int32Size+    EInt64  -> int64Size+    EWord8  -> word8Size     EWord16 -> word16Size     EWord32 -> word32Size     EWord64 -> word64Size

@@ -1,19 +1,13 @@-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-}- module FlatBuffers.Internal.Compiler.SyntaxTree where -import           Data.List.NonEmpty                    ( NonEmpty )-import           Data.Map.Strict                       ( Map )-import           Data.Scientific                       ( Scientific )-import           Data.String                           ( IsString(..) )-import           Data.Text                             ( Text )-import qualified Data.Text                             as T+import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict (Map)+import Data.Scientific (Scientific)+import Data.String (IsString(..))+import Data.Text (Text)+import Data.Text qualified as T -import           FlatBuffers.Internal.Compiler.Display ( Display(..) )+import FlatBuffers.Internal.Compiler.Display (Display(..))  data FileTree a = FileTree   { fileTreeFilePath :: !FilePath@@ -172,7 +166,7 @@  instance IsString Namespace where   fromString "" = Namespace []-  fromString s = Namespace $ filter (/= "") $ T.splitOn "." $ T.pack s+  fromString s  = Namespace $ filter (/= "") $ T.splitOn "." $ T.pack s  qualify :: HasIdent a => Namespace -> a -> Ident qualify "" a = getIdent a

@@ -1,38 +1,37 @@ {-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE TemplateHaskell #-}  module FlatBuffers.Internal.Compiler.TH where -import           Control.Monad                                   ( join )-import           Control.Monad.Except                            ( runExceptT )+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-import           Data.Text                                       ( Text )-import qualified Data.Text                                       as T-import           Data.Word+import Data.Bits ((.&.))+import Data.Foldable (traverse_)+import Data.Functor ((<&>))+import Data.Int+import Data.List qualified as List+import Data.List.NonEmpty (NonEmpty(..))+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Data.Word -import           FlatBuffers.Internal.Build-import qualified FlatBuffers.Internal.Compiler.NamingConventions as NC-import qualified FlatBuffers.Internal.Compiler.ParserIO          as ParserIO-import           FlatBuffers.Internal.Compiler.SemanticAnalysis  ( SymbolTable(..) )-import qualified FlatBuffers.Internal.Compiler.SemanticAnalysis  as SemanticAnalysis-import qualified FlatBuffers.Internal.Compiler.SyntaxTree        as SyntaxTree-import           FlatBuffers.Internal.Compiler.ValidSyntaxTree-import           FlatBuffers.Internal.FileIdentifier             ( HasFileIdentifier(..), unsafeFileIdentifier )-import           FlatBuffers.Internal.Read-import           FlatBuffers.Internal.Types-import           FlatBuffers.Internal.Write+import FlatBuffers.Internal.Build+import FlatBuffers.Internal.Compiler.NamingConventions qualified as NC+import FlatBuffers.Internal.Compiler.ParserIO qualified as ParserIO+import FlatBuffers.Internal.Compiler.SemanticAnalysis (SymbolTable(..))+import FlatBuffers.Internal.Compiler.SemanticAnalysis qualified as SemanticAnalysis+import FlatBuffers.Internal.Compiler.SyntaxTree qualified as SyntaxTree+import FlatBuffers.Internal.Compiler.ValidSyntaxTree+import FlatBuffers.Internal.FileIdentifier (HasFileIdentifier(..), unsafeFileIdentifier)+import FlatBuffers.Internal.Read+import FlatBuffers.Internal.Types+import FlatBuffers.Internal.Write -import           Language.Haskell.TH-import           Language.Haskell.TH.Syntax                      ( lift )-import qualified Language.Haskell.TH.Syntax                      as TH+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (lift)+import Language.Haskell.TH.Syntax qualified as TH   -- | Helper method to create function types.@@ -52,7 +51,7 @@     -- | Generate code not just for the root schema,     -- but for all schemas it includes as well     -- (same as flatc @--gen-all@ option).-  , compileAllSchemas :: Bool+  , compileAllSchemas  :: Bool   }   deriving (Show, Eq) @@ -284,7 +283,7 @@   where     mkMatch (enumVal, enumName) =       Match-        (ConP enumName [])+        (ConP enumName [] [])         (NormalB (intLitE (enumValInt enumVal)))         [] @@ -306,7 +305,7 @@   where     mkMatch (enumVal, enumName) =       Match-        (ConP enumName [])+        (ConP enumName [] [])         (NormalB (textLitE (unIdent (getIdent enumVal))))         [] @@ -415,19 +414,19 @@      mkReadExp sft =       case sft of-        SInt8   -> VarE 'readInt8-        SInt16  -> VarE 'readInt16-        SInt32  -> VarE 'readInt32-        SInt64  -> VarE 'readInt64-        SWord8  -> VarE 'readWord8-        SWord16 -> VarE 'readWord16-        SWord32 -> VarE 'readWord32-        SWord64 -> VarE 'readWord64-        SFloat  -> VarE 'readFloat-        SDouble -> VarE 'readDouble-        SBool   -> VarE 'readBool+        SInt8            -> VarE 'readInt8+        SInt16           -> VarE 'readInt16+        SInt32           -> VarE 'readInt32+        SInt64           -> VarE 'readInt64+        SWord8           -> VarE 'readWord8+        SWord16          -> VarE 'readWord16+        SWord32          -> VarE 'readWord32+        SWord64          -> VarE 'readWord64+        SFloat           -> VarE 'readFloat+        SDouble          -> VarE 'readDouble+        SBool            -> VarE 'readBool         SEnum _ enumType -> mkReadExp $ enumTypeToStructFieldType enumType-        SStruct _ -> VarE 'readStruct+        SStruct _        -> VarE 'readStruct  mkTable :: TableDecl -> Q [Dec] mkTable table = do@@ -522,9 +521,9 @@           TEnum _ enumType dflt  -> mkExps argRef (enumTypeToTableFieldType enumType dflt)           TStruct _ req          -> pure $ expForNonScalar req (VarE 'writeStructTableField) argRef           TTable _ req           -> pure $ expForNonScalar req (VarE 'writeTableTableField) argRef-          TUnion _ _             ->-            [ VarE 'writeUnionTypeTableField `AppE` argRef-            , VarE 'writeUnionValueTableField `AppE` argRef+          TUnion _ req             ->+            [ expForNonScalar req (VarE 'writeUnionTypeTableField) argRef+            , expForNonScalar req (VarE 'writeUnionValueTableField) argRef             ]           TVector req vecElemType -> mkExpForVector argRef req vecElemType @@ -582,12 +581,21 @@         TEnum _ enumType dflt   -> mkFun $ enumTypeToTableFieldType enumType dflt         TStruct _ req           -> mkFunWithBody (bodyForNonScalar req (compose [ConE 'Right, VarE 'readStruct]))         TTable _ req            -> mkFunWithBody (bodyForNonScalar req (VarE 'readTable))-        TUnion (TypeRef ns ident) _req ->+        TUnion (TypeRef ns ident) req -> do+          let readUnionFunName = VarE . mkName . T.unpack . NC.withModulePrefix ns $ NC.readUnionFun ident           mkFunWithBody $ app-            [ VarE 'readTableFieldUnion-            , VarE . mkName . T.unpack . NC.withModulePrefix ns $ NC.readUnionFun ident-            , fieldIndex-            ]+            case req of+              Req ->+                [ VarE 'readTableFieldUnionReq+                , readUnionFunName+                , fieldIndex+                , stringLitE . unIdent . getIdent $ tf+                ]+              Opt ->+                [ VarE 'readTableFieldUnionOpt+                , readUnionFunName+                , fieldIndex+                ]         TVector req vecElemType -> mkFunForVector req vecElemType      mkFunForVector :: Required -> VectorElementType -> Dec@@ -853,7 +861,7 @@     TEnum _ enumType _      -> ConT ''Maybe `AppT` enumTypeToType enumType     TStruct typeRef req     -> requiredType req (ConT ''WriteStruct `AppT` typeRefToType typeRef)     TTable typeRef req      -> requiredType req (ConT ''WriteTable  `AppT` typeRefToType typeRef)-    TUnion typeRef _        -> ConT ''WriteUnion  `AppT` typeRefToType typeRef+    TUnion typeRef req      -> requiredType req (ConT ''WriteUnion  `AppT` typeRefToType typeRef)     TVector req vecElemType -> requiredType req (vectorElementTypeToWriteType vecElemType)  tableFieldTypeToReadType :: TableFieldType -> Type@@ -874,7 +882,7 @@     TEnum _ enumType _      -> enumTypeToType enumType     TStruct typeRef req     -> requiredType req (ConT ''Struct `AppT` typeRefToType typeRef)     TTable typeRef req      -> requiredType req (ConT ''Table  `AppT` typeRefToType typeRef)-    TUnion typeRef _        -> ConT ''Union  `AppT` typeRefToType typeRef+    TUnion typeRef req      -> requiredType req (ConT ''Union  `AppT` typeRefToType typeRef)     TVector req vecElemType -> requiredType req (vectorElementTypeToReadType vecElemType)  vectorElementTypeToWriteType :: VectorElementType -> Type

@@ -1,6 +1,3 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}- module FlatBuffers.Internal.Compiler.ValidSyntaxTree   ( -- * Re-exports from `FlatBuffers.Internal.Compiler.SyntaxTree`     FlatBuffers.Internal.Compiler.SyntaxTree.Namespace(..)@@ -28,15 +25,16 @@   , UnionVal(..)   ) where -import           Data.Bits                                ( Bits )-import           Data.List.NonEmpty                       ( NonEmpty )-import           Data.Scientific                          ( Scientific )-import           Data.String                              ( IsString(..) )-import           Data.Text                                ( Text )-import           Data.Word+import Data.Bits (Bits)+import Data.List.NonEmpty (NonEmpty)+import Data.Scientific (Scientific)+import Data.String (IsString(..))+import Data.Text (Text)+import Data.Word -import           FlatBuffers.Internal.Compiler.SyntaxTree ( HasIdent(..), Ident(..), Namespace(..), TypeRef(..) )-import           FlatBuffers.Internal.Types+import FlatBuffers.Internal.Compiler.SyntaxTree+  (HasIdent(..), Ident(..), Namespace(..), TypeRef(..))+import FlatBuffers.Internal.Types  instance HasIdent EnumDecl    where getIdent = enumIdent instance HasIdent EnumVal     where getIdent = enumValIdent@@ -51,10 +49,10 @@ ------------- Enums -------------- ---------------------------------- data EnumDecl = EnumDecl-  { enumIdent     :: !Ident-  , enumType      :: !EnumType-  , enumBitFlags  :: !Bool-  , enumVals      :: !(NonEmpty EnumVal)+  { enumIdent    :: !Ident+  , enumType     :: !EnumType+  , enumBitFlags :: !Bool+  , enumVals     :: !(NonEmpty EnumVal)   } deriving (Show, Eq)  data EnumVal = EnumVal@@ -77,17 +75,17 @@ ------------ Structs ------------- ---------------------------------- data StructDecl = StructDecl-  { structIdent      :: !Ident-  , structAlignment  :: !Alignment-  , structSize       :: !InlineSize-  , structFields     :: !(NonEmpty StructField)+  { structIdent     :: !Ident+  , structAlignment :: !Alignment+  , structSize      :: !InlineSize+  , structFields    :: !(NonEmpty StructField)   } deriving (Show, Eq)  data StructField = StructField-  { structFieldIdent    :: !Ident-  , structFieldPadding  :: !Word8  -- ^ How many zeros to write after this field.-  , structFieldOffset   :: !Word16 -- ^ This field's offset from the struct's root.-  , structFieldType     :: !StructFieldType+  { structFieldIdent   :: !Ident+  , structFieldPadding :: !Word8  -- ^ How many zeros to write after this field.+  , structFieldOffset  :: !Word16 -- ^ This field's offset from the struct's root.+  , structFieldType    :: !StructFieldType   } deriving (Show, Eq)  data StructFieldType@@ -123,9 +121,9 @@   deriving (Eq, Show)  data TableDecl = TableDecl-  { tableIdent     :: !Ident-  , tableIsRoot    :: !IsRoot-  , tableFields    :: ![TableField]+  { tableIdent  :: !Ident+  , tableIsRoot :: !IsRoot+  , tableFields :: ![TableField]   } deriving (Eq, Show)  data TableField = TableField

@@ -1,5 +1,3 @@-{-# LANGUAGE AllowAmbiguousTypes #-}- module FlatBuffers.Internal.FileIdentifier   ( HasFileIdentifier(..)   , FileIdentifier(unFileIdentifier)@@ -10,12 +8,12 @@   ) where  -import           Data.ByteString                ( ByteString )-import qualified Data.ByteString                as BS-import           Data.Text                      ( Text )-import qualified Data.Text.Encoding             as T+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.Text (Text)+import Data.Text.Encoding qualified as T -import           FlatBuffers.Internal.Constants ( fileIdentifierSize )+import FlatBuffers.Internal.Constants (fileIdentifierSize)  -- | An identifier that's used to "mark" a buffer. -- To add this marker to a buffer, use `FlatBuffers.encodeWithFileIdentifier`.

@@ -1,15 +1,3 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE InstanceSigs #-}  {-# OPTIONS_HADDOCK not-home #-} @@ -20,29 +8,29 @@  module FlatBuffers.Internal.Read where -import           Control.Monad                       ( (>=>), join )+import Control.Monad (join, (>=>)) -import           Data.Binary.Get                     ( Get )-import qualified Data.Binary.Get                     as G-import qualified Data.ByteString                     as BS-import           Data.ByteString.Lazy                ( ByteString )-import qualified Data.ByteString.Lazy                as BSL-import qualified Data.ByteString.Lazy.Internal       as BSL-import qualified Data.ByteString.Unsafe              as BSU-import           Data.Coerce                         ( coerce )-import           Data.Functor                        ( (<&>) )-import           Data.Int-import qualified Data.List                           as L-import           Data.Text                           ( Text )-import qualified Data.Text.Encoding                  as T-import qualified Data.Text.Encoding.Error            as T-import           Data.Word+import Data.Binary.Get (Get)+import Data.Binary.Get qualified as G+import Data.ByteString qualified as BS+import Data.ByteString.Lazy (ByteString)+import Data.ByteString.Lazy qualified as BSL+import Data.ByteString.Lazy.Internal qualified as BSL+import Data.ByteString.Unsafe qualified as BSU+import Data.Coerce (coerce)+import Data.Functor ((<&>))+import Data.Int+import Data.List qualified as L+import Data.Text (Text)+import Data.Text.Encoding qualified as T+import Data.Text.Encoding.Error qualified as T+import Data.Word -import           FlatBuffers.Internal.Constants-import           FlatBuffers.Internal.FileIdentifier ( FileIdentifier(..), HasFileIdentifier(..) )-import           FlatBuffers.Internal.Types+import FlatBuffers.Internal.Constants+import FlatBuffers.Internal.FileIdentifier (FileIdentifier(..), HasFileIdentifier(..))+import FlatBuffers.Internal.Types -import           Prelude                             hiding ( drop, length, take )+import Prelude hiding (drop, length, take)  type ReadError = String @@ -70,7 +58,6 @@ -- | A union that is being read from a flatbuffer. data Union a   = Union !a-  | UnionNone   | UnionUnknown !Word8  @@ -403,7 +390,7 @@   unsafeIndex (VectorUnion typesPos valuesPos readElem) ix = do     unionType <- unsafeIndex typesPos ix     case positive unionType of-      Nothing         -> Right UnionNone+      Nothing         -> Left "Union vector: 'None' is not allowed in vectors."       Just unionType' -> do         tablePos <- readUOffsetAndSkip $ moveToElem valuesPos tableRefSize ix         readElem unionType' tablePos@@ -422,7 +409,7 @@       go (unionType : unionTypes) (offset : offsets) !ix = do         union <-           case positive unionType of-            Nothing -> Right UnionNone+            Nothing -> Left "Union vector: 'None' is not allowed in vectors."             Just unionType' ->               let tablePos = move valuesPos (offset + (ix * 4))               in  readElem unionType' tablePos@@ -459,12 +446,35 @@     Nothing -> Right dflt     Just offset -> read (move (tablePos t) offset) -{-# INLINE readTableFieldUnion #-}-readTableFieldUnion :: (Positive Word8 -> PositionInfo -> Either ReadError (Union a)) -> TableIndex -> Table t -> Either ReadError (Union a)-readTableFieldUnion read ix t =+{-# INLINE readTableFieldUnionOpt #-}+readTableFieldUnionOpt ::+     (Positive Word8 -> PositionInfo -> Either ReadError (Union a))+  -> TableIndex+  -> Table t+  -> Either ReadError (Maybe (Union a))+readTableFieldUnionOpt read ix t =   readTableFieldWithDef readWord8 (ix - 1) 0 t >>= \unionType ->     case positive unionType of-      Nothing         -> Right UnionNone+      Nothing         -> Right Nothing+      Just unionType' ->+        tableIndexToVOffset t ix >>= \case+          Nothing     -> Left "Union: 'union type' found but 'union value' is missing."+          Just offset ->+            readUOffsetAndSkip (move (tablePos t) offset)+              >>= read unionType'+              <&> Just++{-# INLINE readTableFieldUnionReq #-}+readTableFieldUnionReq ::+     (Positive Word8 -> PositionInfo -> Either ReadError (Union a))+  -> TableIndex+  -> String+  -> Table t+  -> Either ReadError (Union a)+readTableFieldUnionReq read ix name t =+  readTableFieldWithDef readWord8 (ix - 1) 0 t >>= \unionType ->+    case positive unionType of+      Nothing         -> missingField name       Just unionType' ->         tableIndexToVOffset t ix >>= \case           Nothing     -> Left "Union: 'union type' found but 'union value' is missing."

@@ -1,13 +1,9 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE AllowAmbiguousTypes #-}- {-# OPTIONS_HADDOCK not-home #-}  module FlatBuffers.Internal.Types where -import           Data.Word-import           FlatBuffers.Internal.Compiler.Display ( Display )+import Data.Word+import FlatBuffers.Internal.Compiler.Display (Display)  -- | Metadata for a struct type. class IsStruct a where@@ -26,4 +22,3 @@ -- 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, Display)-

@@ -1,53 +1,36 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnliftedFFITypes #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}- {-# OPTIONS_HADDOCK not-home #-}  {- HLINT ignore writeTable uoffsetFrom "Eta reduce" -}  module FlatBuffers.Internal.Write where -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           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 )-import qualified Data.Text.Array                     as A-import qualified Data.Text.Encoding                  as T-import qualified Data.Text.Internal                  as TI-import           Data.Word--import           FlatBuffers.Internal.Build-import           FlatBuffers.Internal.Constants-import           FlatBuffers.Internal.FileIdentifier ( FileIdentifier(unFileIdentifier), HasFileIdentifier(getFileIdentifier) )-import           FlatBuffers.Internal.Types--import           Foreign.C.Types                     ( CSize(CSize) )--import           GHC.Base                            ( ByteArray# )+import Control.Monad (forM)+import Control.Monad.State.Strict+  (MonadState(..), State, StateT(..), execState, gets, modify', runState) -import           System.IO.Unsafe                    ( unsafeDupablePerformIO )+import Data.Bits (complement, (.&.))+import Data.ByteString qualified as BS+import Data.ByteString.Builder (Builder)+import Data.ByteString.Builder qualified as B+import Data.ByteString.Lazy qualified as BSL+import Data.Coerce (coerce)+import Data.Int+import Data.List qualified as L+import Data.Map.Strict qualified as M+import Data.Monoid (Sum(..))+import Data.MonoTraversable (Element, MonoFoldable)+import Data.MonoTraversable qualified as Mono+import Data.Semigroup (Max(..))+import Data.Text (Text)+import Data.Text.Encoding qualified as T+import Data.Text.Internal qualified as TI+import Data.Word +import FlatBuffers.Internal.Build+import FlatBuffers.Internal.Constants+import FlatBuffers.Internal.FileIdentifier+  (FileIdentifier(unFileIdentifier), HasFileIdentifier(getFileIdentifier))+import FlatBuffers.Internal.Types  type BufferSize = Sum Int32 @@ -55,10 +38,10 @@ type Position = Int32  data FBState = FBState-  { builder      :: !Builder-  , bufferSize   :: {-# UNPACK #-} !BufferSize-  , maxAlign     :: {-# UNPACK #-} !(Max Alignment)-  , cache        :: !(M.Map BSL.ByteString Position)+  { builder    :: !Builder+  , bufferSize :: {-# UNPACK #-} !BufferSize+  , maxAlign   :: {-# UNPACK #-} !(Max Alignment)+  , cache      :: !(M.Map BSL.ByteString Position)   }  newtype WriteTableField = WriteTableField { unWriteTableField :: State FBState (FBState -> FBState) }@@ -70,12 +53,10 @@ newtype WriteTable a = WriteTable (State FBState Position)  -- | A union to be written to a flatbuffer.-data WriteUnion a-  = Some-      {-# UNPACK #-} !Word8-      !(State FBState Position)-  | None-+data WriteUnion a = WriteUnion+  { wuUnionType :: {-# UNPACK #-} !Word8+  , wuUnionValue :: !(State FBState Position)+  }  -- | Serializes a flatbuffer table as a lazy `BSL.ByteString`. {-# INLINE encode #-}@@ -243,27 +224,15 @@  {-# INLINE writeUnionTypeTableField #-} writeUnionTypeTableField :: WriteUnion a -> WriteTableField-writeUnionTypeTableField !wu =-  case wu of-    None             -> missing-    Some unionType _ -> writeWord8TableField unionType-+writeUnionTypeTableField wu = writeWord8TableField wu.wuUnionType  {-# INLINE writeUnionValueTableField #-} writeUnionValueTableField :: WriteUnion a -> WriteTableField-writeUnionValueTableField !wu =-  case wu of-    None              -> missing-    Some _ unionValue -> writeTableTableField (WriteTable unionValue)---- | Constructs a missing union table field / vector element.-{-# INLINE none #-}-none :: WriteUnion a-none = None+writeUnionValueTableField wu = writeTableTableField (WriteTable wu.wuUnionValue)  {-# INLINE writeUnion #-} writeUnion :: Word8 -> WriteTable a -> WriteUnion b-writeUnion n (WriteTable st) = Some n st+writeUnion n (WriteTable st) = WriteUnion n st  {-# INLINE vtable #-} vtable :: [Word16] -> Word16 -> BSL.ByteString@@ -697,11 +666,11 @@      coerce $ fromMonoFoldable elemCount offsets -data Vecs a = Vecs ![Word8] ![Maybe (State FBState Position)]+data Vecs a = Vecs ![Word8] ![State FBState Position]  data UnionTableInfo = UnionTableInfo   { utiState          :: !FBState-  , utiTablePositions :: ![Maybe Position]+  , utiTablePositions :: ![Position]   }  instance WriteVectorElement (WriteUnion a) where@@ -715,23 +684,19 @@             go             (Vecs [] [])             unions++        go :: WriteUnion a -> Vecs a -> Vecs a         go writeUnion (Vecs types values) =-          case writeUnion of-            None         -> Vecs (0 : types) (Nothing : values)-            Some typ val -> Vecs (typ : types) (Just val : values)+          Vecs (writeUnion.wuUnionType : types) (writeUnion.wuUnionValue : values)          writeUnionTables :: WriteTableField         writeUnionTables = WriteTableField $ do               fbs1 <- get               let !(UnionTableInfo fbs2 positions) =                     foldr-                      (\unionTableOpt (UnionTableInfo fbs positions) ->-                        case unionTableOpt of-                          Just t ->-                            let (pos, fbs') = runState t fbs-                            in  UnionTableInfo fbs' (Just pos : positions)-                          Nothing ->-                            UnionTableInfo fbs (Nothing : positions)+                      (\unionTable (UnionTableInfo fbs positions) ->+                          let (pos, fbs') = runState unionTable fbs+                          in  UnionTableInfo fbs' (pos : positions)                       )                       (UnionTableInfo fbs1 [])                       values@@ -742,11 +707,8 @@               bsize <- gets (getSum . bufferSize)               let OffsetInfo _ offsets =                     foldr-                      (\positionOpt (OffsetInfo ix os) ->-                        let offset =-                              case positionOpt of-                                Just position -> bsize + (ix * 4) + 4 - position-                                Nothing       -> 0+                      (\position (OffsetInfo ix os) ->+                        let offset = bsize + (ix * 4) + 4 - position                         in  OffsetInfo                               (ix + 1)                               (offset : os)@@ -797,10 +759,4 @@  {-# INLINE utf8length #-} utf8length :: Text -> Int32-utf8length (TI.Text arr off len)-  | len == 0  = 0-  | otherwise = unsafeDupablePerformIO $-    c_length_utf8 (A.aBA arr) (fromIntegral off) (fromIntegral len)--foreign import ccall unsafe "_hs_text_length_utf8" c_length_utf8-  :: ByteArray# -> CSize -> CSize -> IO Int32+utf8length (TI.Text _array _offset len) = fromIntegral @Int @Int32 len

@@ -23,8 +23,8 @@   , R.toLazyByteString   ) where -import           FlatBuffers.Internal.Read  as R-import           FlatBuffers.Internal.Write as W+import FlatBuffers.Internal.Read as R+import FlatBuffers.Internal.Write as W   

@@ -1,8 +1,5 @@-{-# LANGUAGE TemplateHaskell #-}- module Examples.Generated where -import           FlatBuffers ( defaultOptions, mkFlatBuffers )+import FlatBuffers (defaultOptions, mkFlatBuffers)  $(mkFlatBuffers "test/Examples/schema.fbs"           defaultOptions)-$(mkFlatBuffers "test/Examples/vector_of_unions.fbs" defaultOptions)

@@ -1,17 +1,15 @@-{-# LANGUAGE OverloadedStrings #-}- module Examples.HandWritten where -import           Data.Bits                           ( (.&.) )-import           Data.Int-import           Data.Text                           ( Text )-import           Data.Word+import Data.Bits ((.&.))+import Data.Int+import Data.Text (Text)+import Data.Word -import           FlatBuffers.Internal.Build-import           FlatBuffers.Internal.FileIdentifier ( HasFileIdentifier(..), unsafeFileIdentifier )-import           FlatBuffers.Internal.Read-import           FlatBuffers.Internal.Types-import           FlatBuffers.Internal.Write+import FlatBuffers.Internal.Build+import FlatBuffers.Internal.FileIdentifier (HasFileIdentifier(..), unsafeFileIdentifier)+import FlatBuffers.Internal.Read+import FlatBuffers.Internal.Types+import FlatBuffers.Internal.Write  ---------------------------------- ---------- Empty table -----------@@ -100,11 +98,11 @@ toColor n =   case n of     -2 -> Just ColorRed-    0 -> Just ColorGreen-    1 -> Just ColorBlue-    5 -> Just ColorGray-    8 -> Just ColorBlack-    _ -> Nothing+    0  -> Just ColorGreen+    1  -> Just ColorBlue+    5  -> Just ColorGray+    8  -> Just ColorBlack+    _  -> Nothing  {-# INLINE fromColor #-} fromColor :: Color -> Int16@@ -442,14 +440,14 @@ ---------------------------------- data TableWithUnion -tableWithUnion :: WriteUnion Weapon -> WriteTable TableWithUnion+tableWithUnion :: Maybe (WriteUnion Weapon) -> WriteTable TableWithUnion tableWithUnion uni = writeTable-  [ writeUnionTypeTableField uni-  , writeUnionValueTableField uni+  [ optional writeUnionTypeTableField uni+  , optional writeUnionValueTableField uni   ] -tableWithUnionUni :: Table TableWithUnion -> Either ReadError (Union Weapon)-tableWithUnionUni = readTableFieldUnion readWeapon 1+tableWithUnionUni :: Table TableWithUnion -> Either ReadError (Maybe (Union Weapon))+tableWithUnionUni = readTableFieldUnionOpt readWeapon 1  ---------------------------------- ------------ Vectors -------------@@ -562,24 +560,15 @@  vectorOfUnions ::      Maybe (WriteVector (WriteUnion Weapon))-  -> WriteVector (WriteUnion Weapon)   -> WriteTable VectorOfUnions-vectorOfUnions xs xsReq = writeTable+vectorOfUnions xs = writeTable   [ optional writeUnionTypesVectorTableField xs   , optional writeUnionValuesVectorTableField xs-  , deprecated-  , deprecated-  , writeUnionTypesVectorTableField xsReq-  , writeUnionValuesVectorTableField xsReq   ]  vectorOfUnionsXs :: Table VectorOfUnions -> Either ReadError (Maybe (Vector (Union Weapon))) vectorOfUnionsXs = readTableFieldUnionVectorOpt readWeapon 1 -vectorOfUnionsXsReq :: Table VectorOfUnions -> Either ReadError (Vector (Union Weapon))-vectorOfUnionsXsReq = readTableFieldUnionVectorReq readWeapon 5 "xsReq"-- ---------------------------------- ---- Scalars with defaults ------- ----------------------------------@@ -670,8 +659,8 @@ ---------------------------------- data DeprecatedFields -deprecatedFields :: Maybe Int8 -> Maybe Int8 -> Maybe Int8 -> Maybe Int8 -> WriteTable DeprecatedFields-deprecatedFields a c e g = writeTable+deprecatedFields :: Maybe Int8 -> Maybe Int8 -> Maybe Int8 -> Maybe Int8 -> Maybe Int8 -> WriteTable DeprecatedFields+deprecatedFields a c e g i = writeTable   [ optionalDef 0 writeInt8TableField a   , deprecated   , optionalDef 0 writeInt8TableField c@@ -680,6 +669,9 @@   , deprecated   , deprecated   , optionalDef 0 writeInt8TableField g+  , deprecated+  , deprecated+  , optionalDef 0 writeInt8TableField i   ]  deprecatedFieldsA :: Table DeprecatedFields -> Either ReadError Int8@@ -694,6 +686,8 @@ deprecatedFieldsG :: Table DeprecatedFields -> Either ReadError Int8 deprecatedFieldsG = readTableFieldWithDef readInt8 7 0 +deprecatedFieldsI :: Table DeprecatedFields -> Either ReadError Int8+deprecatedFieldsI = readTableFieldWithDef readInt8 10 0  ---------------------------------- -------- Required fields ---------@@ -706,14 +700,17 @@   -> WriteTable Axe   -> WriteUnion Weapon   -> WriteVector Int32+  -> WriteVector (WriteUnion Weapon)   -> WriteTable RequiredFields-requiredFields a b c d e = writeTable+requiredFields a b c d e f = writeTable   [ writeTextTableField a   , writeStructTableField b   , writeTableTableField c   , writeUnionTypeTableField d   , writeUnionValueTableField d   , writeVectorInt32TableField e+  , writeUnionTypesVectorTableField f+  , writeUnionValuesVectorTableField f   ]  requiredFieldsA :: Table RequiredFields -> Either ReadError Text@@ -726,8 +723,10 @@ requiredFieldsC = readTableFieldReq readTable 2 "c"  requiredFieldsD :: Table RequiredFields -> Either ReadError (Union Weapon)-requiredFieldsD = readTableFieldUnion readWeapon 4+requiredFieldsD = readTableFieldUnionReq readWeapon 4 "d"  requiredFieldsE :: Table RequiredFields -> Either ReadError (Vector Int32) requiredFieldsE = readTableFieldReq (readPrimVector VectorInt32) 5 "e" +requiredFieldsF :: Table RequiredFields -> Either ReadError (Vector (Union Weapon))+requiredFieldsF = readTableFieldUnionVectorReq readWeapon 7 "f"

@@ -1,9 +1,4 @@-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}  {-# OPTIONS_GHC -Wno-orphans #-} @@ -11,163 +6,158 @@  module FlatBuffers.AlignmentSpec where -import           Control.Monad.State.Strict--import qualified Data.Binary.Get                     as G-import qualified Data.ByteString                     as BS-import qualified Data.ByteString.Builder             as B-import qualified Data.ByteString.Lazy                as BSL-import           Data.ByteString.Lazy                ( ByteString )-import           Data.Coerce-import           Data.Foldable                       ( fold, foldrM )-import           Data.Int-import qualified Data.List                           as List-import           Data.Monoid                         ( Sum(..) )-import           Data.Semigroup                      ( Max(..) )-import           Data.Text                           ( Text )-import qualified Data.Text.Encoding                  as T-import           Data.Word--import           Examples--import           FlatBuffers.Internal.FileIdentifier ( unsafeFileIdentifier )-import           FlatBuffers.Internal.Types          ( Alignment(..), IsStruct(..) )-import           FlatBuffers.Internal.Write-import qualified FlatBuffers.Vector                  as Vec--import qualified Hedgehog.Gen                        as Gen-import qualified Hedgehog.Range                      as Range--import           TestImports+import Control.Monad.State.Strict+import Data.Binary.Get qualified as G+import Data.ByteString qualified as BS+import Data.ByteString.Builder qualified as B+import Data.ByteString.Lazy (ByteString)+import Data.ByteString.Lazy qualified as BSL+import Data.Coerce+import Data.Foldable (fold, foldrM)+import Data.Int+import Data.List qualified as List+import Data.Monoid (Sum(..))+import Data.Semigroup (Max(..))+import Data.Text (Text)+import Data.Text.Encoding qualified as T+import Data.Word+import Examples+import FlatBuffers.Internal.FileIdentifier (unsafeFileIdentifier)+import FlatBuffers.Internal.Types (Alignment(..), IsStruct(..))+import FlatBuffers.Internal.Write+import FlatBuffers.Vector qualified as Vec+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import TestImports   spec :: Spec spec =   describe "alignment" $ do     describe "Int8 are aligned to 1 byte" $ do-      it "in table fields" $ require $+      it "in table fields" $ hedgehog $         prop_inlineTableFieldAlignment 1 1 (writeInt8TableField maxBound)-      it "in vectors" $ require $+      it "in vectors" $ hedgehog $         prop_inlineVectorAlignment 1 1 (maxBound @Int8)      describe "Int16 are aligned to 2 bytes" $ do-      it "in table fields" $ require $+      it "in table fields" $ hedgehog $         prop_inlineTableFieldAlignment 2 2 (writeInt16TableField maxBound)-      it "in vectors" $ require $+      it "in vectors" $ hedgehog $         prop_inlineVectorAlignment 2 2 (maxBound @Int16)      describe "Int32 are aligned to 4 bytes" $ do-      it "in table fields" $ require $+      it "in table fields" $ hedgehog $         prop_inlineTableFieldAlignment 4 4 (writeInt32TableField maxBound)-      it "in vectors" $ require $+      it "in vectors" $ hedgehog $         prop_inlineVectorAlignment 4 4 (maxBound @Int32)      describe "Int64 are aligned to 8 bytes" $ do-      it "in table fields" $ require $+      it "in table fields" $ hedgehog $         prop_inlineTableFieldAlignment 8 8 (writeInt64TableField maxBound)-      it "in vectors" $ require $+      it "in vectors" $ hedgehog $         prop_inlineVectorAlignment 8 8 (maxBound @Int64)      describe "Word8 are aligned to 1 byte" $ do-      it "in table fields" $ require $+      it "in table fields" $ hedgehog $         prop_inlineTableFieldAlignment 1 1 (writeWord8TableField maxBound)-      it "in vectors" $ require $+      it "in vectors" $ hedgehog $         prop_inlineVectorAlignment 1 1 (maxBound @Word8)      describe "Word16 are aligned to 2 bytes" $ do-      it "in table fields" $ require $+      it "in table fields" $ hedgehog $         prop_inlineTableFieldAlignment 2 2 (writeWord16TableField maxBound)-      it "in vectors" $ require $+      it "in vectors" $ hedgehog $         prop_inlineVectorAlignment 2 2 (maxBound @Word16)      describe "Word32 are aligned to 4 bytes" $ do-      it "in table fields" $ require $+      it "in table fields" $ hedgehog $         prop_inlineTableFieldAlignment 4 4 (writeWord32TableField maxBound)-      it "in vectors" $ require $+      it "in vectors" $ hedgehog $         prop_inlineVectorAlignment 4 4 (maxBound @Word32)      describe "Word64 are aligned to 8 bytes" $ do-      it "in table fields" $ require $+      it "in table fields" $ hedgehog $         prop_inlineTableFieldAlignment 8 8 (writeWord64TableField maxBound)-      it "in vectors" $ require $+      it "in vectors" $ hedgehog $         prop_inlineVectorAlignment 8 8 (maxBound @Word64)      describe "Float are aligned to 4 bytes" $ do-      it "in table fields" $ require $+      it "in table fields" $ hedgehog $         prop_inlineTableFieldAlignment 4 4 (writeFloatTableField 999.5)-      it "in vectors" $ require $+      it "in vectors" $ hedgehog $         prop_inlineVectorAlignment 4 4 (999.5 :: Float)      describe "Double are aligned to 8 bytes" $ do-      it "in table fields" $ require $+      it "in table fields" $ hedgehog $         prop_inlineTableFieldAlignment 8 8 (writeDoubleTableField 999.5)-      it "in vectors" $ require $+      it "in vectors" $ hedgehog $         prop_inlineVectorAlignment 8 8 (999.5 :: Double)      describe "Bool are aligned to 1 byte" $ do-      it "in table fields" $ require $+      it "in table fields" $ hedgehog $         prop_inlineTableFieldAlignment 1 1 (writeBoolTableField maxBound)-      it "in vectors" $ require $+      it "in vectors" $ hedgehog $         prop_inlineVectorAlignment 1 1 (maxBound @Bool)       describe "structs are aligned to the specified alignment" $ do       describe "in table fields" $ do-        it "Struct1" $ require $+        it "Struct1" $ hedgehog $           prop_inlineTableFieldAlignment (fromIntegral (structSizeOf @Struct1)) (structAlignmentOf @Struct1)             (writeStructTableField (struct1 1 2 3)) -        it "Struct2" $ require $+        it "Struct2" $ hedgehog $           prop_inlineTableFieldAlignment (fromIntegral (structSizeOf @Struct2)) (structAlignmentOf @Struct2)             (writeStructTableField (struct2 9)) -        it "Struct3" $ require $+        it "Struct3" $ hedgehog $           prop_inlineTableFieldAlignment (fromIntegral (structSizeOf @Struct3)) (structAlignmentOf @Struct3)             (writeStructTableField (struct3 (struct2 99) 2 3)) -        it "Struct4" $ require $+        it "Struct4" $ hedgehog $           prop_inlineTableFieldAlignment (fromIntegral (structSizeOf @Struct4)) (structAlignmentOf @Struct4)             (writeStructTableField (struct4 (struct2 99) 11 22 True))        describe "in vectors" $ do-        it "Struct1" $ require $+        it "Struct1" $ hedgehog $           prop_inlineVectorAlignment (fromIntegral (structSizeOf @Struct1)) (structAlignmentOf @Struct1)             (struct1 maxBound maxBound maxBound) -        it "Struct2" $ require $+        it "Struct2" $ hedgehog $           prop_inlineVectorAlignment (fromIntegral (structSizeOf @Struct2)) (structAlignmentOf @Struct2)             (struct2 maxBound) -        it "Struct3" $ require $+        it "Struct3" $ hedgehog $           prop_inlineVectorAlignment (fromIntegral (structSizeOf @Struct3)) (structAlignmentOf @Struct3)             (struct3 (struct2 maxBound) maxBound maxBound) -        it "Struct4" $ require $+        it "Struct4" $ hedgehog $           prop_inlineVectorAlignment (fromIntegral (structSizeOf @Struct4)) (structAlignmentOf @Struct4)             (struct4 (struct2 maxBound) maxBound maxBound True)      describe "Text are aligned to 4 bytes" $ do-      it "in table fields" $ require prop_textTableFieldAlignment-      it "in vectors" $ require prop_textVectorAlignment+      it "in table fields" $ hedgehog prop_textTableFieldAlignment+      it "in vectors" $ hedgehog prop_textVectorAlignment      describe "Tables are properly aligned" $ do-      it "in table fields" $ require prop_tableTableFieldAlignment-      it "in vectors" $ require $ prop_tableVectorAlignment $ \(byteFieldsList :: [[Word8]]) ->+      it "in table fields" $ hedgehog prop_tableTableFieldAlignment+      it "in vectors" $ hedgehog $ prop_tableVectorAlignment $ \(byteFieldsList :: [[Word8]]) ->         writeVectorTableTableField (Vec.fromList' (writeTable . fmap writeWord8TableField <$> byteFieldsList))      describe "Unions tables are properly aligned" $-      it "in vectors" $ require $ prop_tableVectorAlignment $ \(byteFieldsList :: [[Word8]]) ->+      it "in vectors" $ hedgehog $ prop_tableVectorAlignment $ \(byteFieldsList :: [[Word8]]) ->         writeUnionValuesVectorTableField (Vec.fromList' (writeUnion 1 . writeTable . fmap writeWord8TableField <$> byteFieldsList))  -    it "Root is aligned to `maxAlign`" $ require prop_rootAlignment-    it "Root with file identifier is aligned to `maxAlign`" $ require prop_rootWithFileIdentifierAlignment+    it "Root is aligned to `maxAlign`" $ hedgehog prop_rootAlignment+    it "Root with file identifier is aligned to `maxAlign`" $ hedgehog prop_rootWithFileIdentifierAlignment    -prop_inlineTableFieldAlignment :: Int32 -> Alignment -> WriteTableField -> Property-prop_inlineTableFieldAlignment size alignment tableField = property $ do+prop_inlineTableFieldAlignment :: Int32 -> Alignment -> WriteTableField -> PropertyT IO ()+prop_inlineTableFieldAlignment size alignment tableField = do   initialState <- forAllWith printFBState genInitialState   let (f, interimState) = runState (unWriteTableField tableField) initialState   let finalState = f interimState@@ -186,8 +176,8 @@ prop_inlineVectorAlignment ::      WriteVectorElement a   => Coercible (WriteVector a) WriteTableField-  => Int32 -> Alignment -> a -> Property-prop_inlineVectorAlignment elemSize elemAlignment sampleElem = property $ do+  => Int32 -> Alignment -> a -> PropertyT IO ()+prop_inlineVectorAlignment elemSize elemAlignment sampleElem = do   initialState <- forAllWith printFBState genInitialState   vectorLength <- forAll $ Gen.int (Range.linear 0 5) @@ -210,8 +200,8 @@   padding `isLessThan` (fromIntegral elemAlignment `max` 4)  -prop_textTableFieldAlignment :: Property-prop_textTableFieldAlignment = property $ do+prop_textTableFieldAlignment :: PropertyT IO ()+prop_textTableFieldAlignment = do   initialState <- forAllWith printFBState genInitialState   text <- forAll $ Gen.text (Range.linear 0 30) Gen.unicode @@ -228,8 +218,8 @@   padding `isLessThan` 4  -prop_textVectorAlignment :: Property-prop_textVectorAlignment = property $ do+prop_textVectorAlignment :: PropertyT IO ()+prop_textVectorAlignment = do   initialState <- forAllWith printFBState genInitialState   texts <- forAll $ Gen.list (Range.linear 0 5) (Gen.text (Range.linear 0 30) Gen.unicode) @@ -273,8 +263,8 @@   padding `isLessThan` 4  -prop_tableTableFieldAlignment :: Property-prop_tableTableFieldAlignment = property $ do+prop_tableTableFieldAlignment :: PropertyT IO ()+prop_tableTableFieldAlignment = do   initialState <- forAllWith printFBState genInitialState   byteFields <- forAll $ Gen.list (Range.linear 0 20) (Gen.word8 Range.linearBounded) @@ -302,8 +292,8 @@   vtablePadding === 0  -prop_tableVectorAlignment :: ([[Word8]] -> WriteTableField) -> Property-prop_tableVectorAlignment toVectorOfTables = property $  do+prop_tableVectorAlignment :: ([[Word8]] -> WriteTableField) -> PropertyT IO ()+prop_tableVectorAlignment toVectorOfTables = do   initialState <- forAllWith printFBState genInitialState   byteFieldsList <- forAll $ Gen.list (Range.linear 0 20) (Gen.list (Range.linear 0 20) (Gen.word8 Range.linearBounded)) @@ -360,8 +350,8 @@   -prop_rootAlignment :: Property-prop_rootAlignment = property $ do+prop_rootAlignment :: PropertyT IO ()+prop_rootAlignment = do   initialState <- forAllWith printFBState genInitialState   byteFields <- forAll $ Gen.list (Range.linear 0 20) (Gen.word8 Range.linearBounded) @@ -389,8 +379,8 @@   padding `isLessThan` 15  -prop_rootWithFileIdentifierAlignment :: Property-prop_rootWithFileIdentifierAlignment = property $ do+prop_rootWithFileIdentifierAlignment :: PropertyT IO ()+prop_rootWithFileIdentifierAlignment = do   initialState <- forAllWith printFBState genInitialState   byteFields <- forAll $ Gen.list (Range.linear 0 20) (Gen.word8 Range.linearBounded) 

@@ -1,98 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- {-# LANGUAGE TypeApplications  #-}--module FlatBuffers.Integration.HaskellToScalaSpec where---- import           Data.Aeson                ( (.=), Value(..), object )--- import qualified Data.Aeson                as J--- import qualified Data.ByteString.Lazy      as BSL--- import qualified Data.ByteString.Lazy.UTF8 as BSLU--- import           Data.Int---- import           Examples---- import           FlatBuffers--- import qualified FlatBuffers.Vector        as Vec---- import           Network.HTTP.Client--- import           Network.HTTP.Types.Status ( statusCode )--import           TestImports---spec :: Spec-spec =-  describe "Haskell encoders should be consistent with Scala decoders" $-    it "VectorOfUnions" $ do-      1 `shouldBe` (1 :: Int)---       testCase---         "VectorOfUnions"---         (encode $ vectorOfUnions---           (Just (Vec.singleton (weaponSword (sword (Just "hi")))))---           (Vec.singleton (weaponSword (sword (Just "hi2"))))---           )---         (object---           [ "xs" .= [object ["x" .= String "hi"]]---           , "xsReq" .= [object ["x" .= String "hi2"]]---           ]---         )---       testCase---         "VectorOfUnions"---         (encode $ vectorOfUnions---           (Just (Vec.singleton (weaponSword (sword Nothing))))---           (Vec.singleton (weaponAxe (axe Nothing)))---           )---         (object ["xs" .= [object ["x" .= Null]], "xsReq" .= [object ["y" .= Number 0]]])---       testCase---         "VectorOfUnions"---         (encode $ vectorOfUnions---           (Just $ Vec.fromList'---             [ weaponSword (sword (Just "hi"))---             , none---             , weaponAxe (axe (Just maxBound))---             , weaponSword (sword (Just "oi"))---             ]---           )---           (Vec.fromList'---             [ weaponSword (sword (Just "hi2"))---             , none---             , weaponAxe (axe (Just minBound))---             , weaponSword (sword (Just "oi2"))---             ]---           )---         )---         (object---           [ "xs" .=---             [ object ["x" .= String "hi"]---             , String "NONE"---             , object ["y" .= maxBound @Int32]---             , object ["x" .= String "oi"]---             ]---           , "xsReq" .=---             [ object ["x" .= String "hi2"]---             , String "NONE"---             , object ["y" .= minBound @Int32]---             , object ["x" .= String "oi2"]---             ]---           ])---       testCase---         "VectorOfUnions"---         (encode $ vectorOfUnions (Just Vec.empty) Vec.empty)---         (object ["xs" .= [] @Value, "xsReq" .= [] @Value])---       testCase---         "VectorOfUnions"---         (encode $ vectorOfUnions Nothing Vec.empty)---         (object ["xs" .= [] @Value, "xsReq" .= [] @Value])----- testCase :: HasCallStack => String -> BSL.ByteString -> J.Value -> IO ()--- testCase flatbufferName bs expectedJson = do---   man <- newManager defaultManagerSettings---   req <- parseRequest ("http://localhost:8080/" ++ flatbufferName)---   let req' = req {method = "POST", requestBody = RequestBodyLBS bs}---   rsp <- httpLbs req' man---   case statusCode $ responseStatus rsp of---     200 ->---       (PrettyJson <$> J.decode @J.Value (responseBody rsp)) `shouldBe`---       Just (PrettyJson expectedJson)---     _ -> expectationFailure ("Failed: " ++ BSLU.toString (responseBody rsp))

@@ -1,8 +1,3 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}- {-# OPTIONS_GHC -Wno-incomplete-patterns #-}  {- HLINT ignore "Reduce duplication" -}@@ -10,27 +5,25 @@  module FlatBuffers.Integration.RoundTripThroughFlatcSpec where -import           Control.Applicative  ( liftA3 )--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 )-import           Data.Proxy-import           Data.Typeable        ( Typeable, typeRep )-import           Data.Word--import           Examples--import           FlatBuffers-import qualified FlatBuffers.Vector   as Vec+import Control.Applicative (liftA3)+import Data.Aeson (Value(..), object, (.=))+import Data.Aeson qualified as J+import Data.Aeson.QQ.Simple (aesonQQ)+import Data.Bits ((.|.))+import Data.ByteString.Lazy qualified as BSL+import Data.Int+import Data.Maybe (isNothing)+import Data.Proxy+import Data.Typeable (Typeable, typeRep)+import Data.Word+import Examples+import FlatBuffers+import FlatBuffers.Vector qualified as Vec -import qualified System.Directory     as Dir-import qualified System.Process       as Sys+import System.Directory qualified as Dir+import System.Process qualified as Sys -import           TestImports+import TestImports  {- @@ -46,11 +39,6 @@ See "Using flatc as a Conversion Tool" at the bottom:   https://google.github.io/flatbuffers/flatbuffers_guide_tutorial.html -Note that flatc is not yet able to convert vector of unions from binary to json (even though-json -> binary works), so we can't use flatc to test this.-Instead, we check our encoders against java's decoders by-sending requests to a Scala server: FlatBuffers.Integration.HaskellToScalaSpec.- -}  spec :: Spec@@ -234,16 +222,16 @@             ]))          json `shouldBeJson` object-          [ "x" .= (colorsRed .|. colorsGreen)-          , "y" .= object [ "x" .= (colorsGreen .|. colorsGray) ]+          [ "x" .= String "Red Green"+          , "y" .= object [ "x" .= String "Green Gray" ]           , "xs" .=-            [ toJSON (colorsGreen .|. colorsGray)-            , toJSON (colorsBlack .|. colorsBlue)+            [ String "Green Gray"+            , String "Blue Black"             , String "Green"             ]           , "ys" .=-            [ object [ "x" .= (colorsGreen .|. colorsGray) ]-            , object [ "x" .= (colorsBlack .|. colorsBlue) ]+            [ object [ "x" .=  String "Green Gray" ]+            , object [ "x" .=  String "Blue Black" ]             , object [ "x" .= String "Green" ]             ]           ]@@ -371,7 +359,7 @@     describe "Union" $       describe "present" $ do         it "with sword" $ do-          (json, decoded) <- flatc $ tableWithUnion (weaponSword (sword (Just "hi")))+          (json, decoded) <- flatc $ tableWithUnion $ Just $ weaponSword $ sword $ Just "hi"            json `shouldBeJson` object             [ "uni"      .= object [ "x" .= String "hi" ]@@ -379,10 +367,10 @@             ]            tableWithUnionUni decoded `shouldBeRightAndExpect` \case-            Union (WeaponSword x) -> swordX x `shouldBe` Right (Just "hi")+            Just (Union (WeaponSword x)) -> swordX x `shouldBe` Right (Just "hi")          it "with axe" $ do-          (json, decoded) <- flatc $ tableWithUnion (weaponAxe (axe (Just maxBound)))+          (json, decoded) <- flatc $ tableWithUnion $ Just $ weaponAxe $ axe $ Just maxBound            json `shouldBeJson` object             [ "uni"      .= object [ "y" .= maxBound @Int32 ]@@ -390,15 +378,15 @@             ]            tableWithUnionUni decoded `shouldBeRightAndExpect` \case-            Union (WeaponAxe x) -> axeY x `shouldBe` Right maxBound+            Just (Union (WeaponAxe x)) -> axeY x `shouldBe` Right maxBound          it "with none" $ do-          (json, decoded) <- flatc $ tableWithUnion none+          (json, decoded) <- flatc $ tableWithUnion Nothing            json `shouldBeJson` object []            tableWithUnionUni decoded `shouldBeRightAndExpect` \case-            UnionNone -> pure ()+            Nothing -> pure ()       describe "Vectors" $ do@@ -606,7 +594,55 @@         vectorOfStructsCs decoded `shouldBeRightAnd` isNothing         vectorOfStructsDs decoded `shouldBeRightAnd` isNothing +    describe "VectorOfUnions" do+      it "non empty" do+        (json, decoded) <- flatc $ vectorOfUnions $ Just $ Vec.fromList'+          [ weaponSword (sword (Just "hi"))+          , weaponAxe (axe (Just maxBound))+          , weaponSword (sword Nothing)+          ] +        json `shouldBeJson`+          [aesonQQ|+            { "xs": [+                {"x": "hi"},+                {"y": 2147483647},+                {}+              ],+              "xs_type": [+                "Sword",+                "Axe",+                "Sword"+              ]+            }+          |]++        vec <- evalRightJust $ vectorOfUnionsXs decoded+        [x, y, z] <- evalRight $ Vec.toList vec+        case x of Union (WeaponSword sword) -> swordX sword `shouldBe` Right (Just "hi")+        case y of Union (WeaponAxe axe) -> axeY axe `shouldBe` Right (maxBound @Int32)+        case z of Union (WeaponSword sword) -> swordX sword `shouldBe` Right Nothing++      it "empty" do+        (json, decoded) <- flatc $ vectorOfUnions $ Just Vec.empty++        json `shouldBeJson`+          [aesonQQ|+            { "xs": [],+              "xs_type": []+            }+          |]++        vec <- evalRightJust $ vectorOfUnionsXs decoded+        Vec.length vec `shouldBe` 0++      it "missing" do+        (json, decoded) <- flatc $ vectorOfUnions Nothing++        json `shouldBeJson` [aesonQQ|{ }|]++        vectorOfUnionsXs decoded `shouldBeRightAnd` isNothing+     describe "ScalarsWithDefaults" $ do       let runTest buffer = do             (json, decoded) <- flatc buffer@@ -650,19 +686,21 @@         Nothing Nothing      it "DeprecatedFields" $ do-      (json, decoded) <- flatc $ deprecatedFields (Just 1) (Just 2) (Just 3) (Just 4)+      (json, decoded) <- flatc $ deprecatedFields (Just 1) (Just 2) (Just 3) (Just 4) (Just 5)        json `shouldBeJson` object         [ "a" .= Number 1         , "c" .= Number 2         , "e" .= Number 3         , "g" .= Number 4+        , "i" .= Number 5         ]        deprecatedFieldsA decoded `shouldBe` Right 1       deprecatedFieldsC decoded `shouldBe` Right 2       deprecatedFieldsE decoded `shouldBe` Right 3       deprecatedFieldsG decoded `shouldBe` Right 4+      deprecatedFieldsI decoded `shouldBe` Right 5      it "RequiredFields" $ do       let readStruct1 = (liftA3 . liftA3) (,,) struct1X struct1Y struct1Z@@ -672,15 +710,21 @@         (axe (Just 44))         (weaponSword (sword (Just "a")))         (Vec.fromList' [55, 66])+        (Vec.singleton $ weaponSword (sword (Just "b"))) -      json `shouldBeJson` object-        [ "a" .= String "hello"-        , "b" .= object ["x" .= Number 11, "y" .= Number 22, "z" .= Number 33]-        , "c" .= object ["y" .= Number 44]-        , "d" .= object ["x" .= String "a"]-        , "d_type" .= String "Sword"-        , "e" .= [Number 55, Number 66]-        ]+      json `shouldBeJson`+        [aesonQQ|+          {+            "a": "hello",+            "b": { "x": 11, "y": 22, "z": 33 },+            "c": { "y": 44 },+            "d": { "x": "a" },+            "d_type": "Sword",+            "e": [55, 66],+            "f": [ {"x": "b"} ],+            "f_type": [ "Sword" ]+          }+        |]        requiredFieldsA decoded `shouldBe` Right "hello"       (requiredFieldsB decoded >>= readStruct1) `shouldBe` Right (11, 22, 33)@@ -688,7 +732,8 @@       requiredFieldsD decoded `shouldBeRightAndExpect` \case         Union (WeaponSword x) -> swordX x `shouldBe` Right (Just "a")       (requiredFieldsE decoded >>= Vec.toList) `shouldBe` Right [55, 66]-+      (requiredFieldsF decoded >>= Vec.toList) `shouldBeRightAndExpect` \case+        [Union (WeaponSword x)] -> swordX x `shouldBe` Right (Just "b")  flatc :: forall a. Typeable a => WriteTable a -> IO (J.Value, Table a) flatc table = flatcAux False (encode table)

@@ -1,21 +1,14 @@ {-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE NegativeLiterals #-}  module FlatBuffers.Internal.Compiler.ParserSpec where -import           Data.Void                                ( Void )--import           FlatBuffers.Internal.Compiler.Parser-import           FlatBuffers.Internal.Compiler.SyntaxTree--import           Test.Hspec.Megaparsec--import           TestImports--import           Text.Megaparsec-import           Text.RawString.QQ                        ( r )+import Data.Void (Void)+import FlatBuffers.Internal.Compiler.Parser+import FlatBuffers.Internal.Compiler.SyntaxTree+import Test.Hspec.Megaparsec+import TestImports+import Text.Megaparsec+import Text.RawString.QQ (r)  spec :: Spec spec =@@ -333,7 +326,5 @@ parses :: HasCallStack => String -> Schema -> Expectation parses input expectedSchema =   case parse schema "" input of-    l@(Left _) -> l `shouldParse` expectedSchema+    l@(Left _)   -> l `shouldParse` expectedSchema     Right result -> result `shouldBe` expectedSchema--

@@ -1,35 +1,27 @@ {-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}  module FlatBuffers.Internal.Compiler.SemanticAnalysisSpec where -import           Control.Monad                                  ( forM_, replicateM )-import           Control.Monad.State                            ( StateT, evalStateT, get, lift, put )--import           Data.Bits                                      ( shiftL )-import           Data.Foldable                                  ( fold, foldlM )-import           Data.Int-import qualified Data.List.NonEmpty                             as NE-import           Data.List.NonEmpty                             ( NonEmpty((:|)) )-import qualified Data.Map.Strict                                as Map-import qualified Data.Text                                      as Text-import           Data.Text                                      ( Text )-import           Data.Word--import qualified FlatBuffers.Internal.Compiler.Parser           as P-import           FlatBuffers.Internal.Compiler.SemanticAnalysis-import qualified FlatBuffers.Internal.Compiler.SyntaxTree       as ST-import           FlatBuffers.Internal.Compiler.ValidSyntaxTree--import qualified Hedgehog.Gen                                   as Gen-import qualified Hedgehog.Range                                 as Range--import           TestImports--import           Text.Megaparsec-import           Text.RawString.QQ                              ( r )-+import Control.Monad (forM_, replicateM)+import Control.Monad.State (StateT, evalStateT, get, lift, put)+import Data.Bits (shiftL)+import Data.Foldable (fold, foldlM)+import Data.Int+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Word+import FlatBuffers.Internal.Compiler.Parser qualified as P+import FlatBuffers.Internal.Compiler.SemanticAnalysis+import FlatBuffers.Internal.Compiler.SyntaxTree qualified as ST+import FlatBuffers.Internal.Compiler.ValidSyntaxTree+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import TestImports+import Text.Megaparsec+import Text.RawString.QQ (r)  spec :: Spec spec =@@ -578,7 +570,7 @@           "[S1]: cyclic dependency detected [S1 -> S2 -> S3 -> S1] - structs cannot contain themselves, directly or indirectly"        it "struct size & alignment & field offsets are consistent" $-        require prop_structAlignment+        hedgehog prop_structAlignment      describe "tables" $ do       it "empty" $@@ -1377,8 +1369,8 @@           ]  -prop_structAlignment :: Property-prop_structAlignment = property $ do+prop_structAlignment :: PropertyT IO ()+prop_structAlignment = do    n <- forAll $ Gen.int (Range.linear 1 10)   structs <- forAll $ evalStateT (genStructs n []) 0@@ -1531,7 +1523,7 @@           fileTree = ST.FileTree "" schema importesFilepathsAndSchemas       in  validateSchemas fileTree `shouldBe` Left expectedErrorMsg -showBundle :: (ShowErrorComponent e, Stream s) => ParseErrorBundle s e -> String+showBundle :: (ShowErrorComponent e, TraversableStream s, VisualStream s) => ParseErrorBundle s e -> String showBundle = unlines . fmap indent . lines . errorBundlePretty   where     indent x = if null x

@@ -1,39 +1,27 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE NegativeLiterals #-}-{-# LANGUAGE ExplicitForAll #-}- module FlatBuffers.Internal.Compiler.THSpec where -import           Control.Arrow                                  ( second )--import           Data.Bits                                      ( (.&.) )-import           Data.Int-import           Data.Text                                      ( Text )-import qualified Data.Text                                      as T-import           Data.Word--import           FlatBuffers.Internal.Build-import qualified FlatBuffers.Internal.Compiler.Parser           as P-import           FlatBuffers.Internal.Compiler.SemanticAnalysis ( validateSchemas )-import           FlatBuffers.Internal.Compiler.SyntaxTree       ( FileTree(..) )-import           FlatBuffers.Internal.Compiler.TH-import           FlatBuffers.Internal.FileIdentifier            ( HasFileIdentifier(..), unsafeFileIdentifier )-import           FlatBuffers.Internal.Read-import           FlatBuffers.Internal.Types-import           FlatBuffers.Internal.Write--import           Language.Haskell.TH-import           Language.Haskell.TH.Cleanup                    ( simplifiedTH )-import           Language.Haskell.TH.Syntax--import           System.IO.Unsafe                               ( unsafePerformIO )--import           TestImports--import           Text.Megaparsec                                ( ParseErrorBundle, ShowErrorComponent, Stream, errorBundlePretty, parse )-import           Text.RawString.QQ                              ( r )+import Control.Arrow (second) +import Data.Bits ((.&.))+import Data.Int+import Data.Text (Text)+import Data.Text qualified as T+import Data.Word+import FlatBuffers.Internal.Build+import FlatBuffers.Internal.Compiler.Parser qualified as P+import FlatBuffers.Internal.Compiler.SemanticAnalysis (validateSchemas)+import FlatBuffers.Internal.Compiler.SyntaxTree (FileTree(..))+import FlatBuffers.Internal.Compiler.TH+import FlatBuffers.Internal.FileIdentifier (HasFileIdentifier(..), unsafeFileIdentifier)+import FlatBuffers.Internal.Read+import FlatBuffers.Internal.Types+import FlatBuffers.Internal.Write+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import TestImports+import Text.Megaparsec+  (ParseErrorBundle, ShowErrorComponent, TraversableStream, VisualStream, errorBundlePretty, parse)+import Text.RawString.QQ (r)  spec :: Spec spec =@@ -487,14 +475,14 @@           |] `shouldCompileTo`             [d|               data T1-              t1 :: WriteUnion U1 -> WriteTable T1+              t1 :: Maybe (WriteUnion U1) -> WriteTable T1               t1 x = writeTable-                [ writeUnionTypeTableField x-                , writeUnionValueTableField x+                [ optional writeUnionTypeTableField x+                , optional writeUnionValueTableField x                 ] -              t1X :: Table T1 -> Either ReadError (Union U1)-              t1X = readTableFieldUnion readU1 1+              t1X :: Table T1 -> Either ReadError (Maybe (Union U1))+              t1X = readTableFieldUnionOpt readU1 1                data U1                 = U1T1 !(Table T1)@@ -549,7 +537,7 @@                 ]                t1X :: Table T1 -> Either ReadError (Union U1)-              t1X = readTableFieldUnion readU1 1+              t1X = readTableFieldUnionReq readU1 1 "x"                data U1                 = U1T1 !(Table T1)@@ -1046,13 +1034,13 @@                   case n of                     -2 -> Just MyColorIsRed                     -1 -> Just MyColorIsGreen-                    _ -> Nothing+                    _  -> Nothing                 {-# INLINE toMyColor #-}                  fromMyColor :: MyColor -> Int16                 fromMyColor n =                   case n of-                    MyColorIsRed -> -2+                    MyColorIsRed   -> -2                     MyColorIsGreen -> -1                 {-# INLINE fromMyColor #-} @@ -1348,11 +1336,9 @@   deriving Eq  instance Show PrettyAst where-  show (PrettyAst decs) =-    let LitE (StringL s) = unsafePerformIO . runQ . simplifiedTH $ decs-    in  s+  show (PrettyAst decs) = pprint decs -showBundle :: (ShowErrorComponent e, Stream s) => ParseErrorBundle s e -> String+showBundle :: (ShowErrorComponent e, TraversableStream s, VisualStream s) => ParseErrorBundle s e -> String showBundle = unlines . fmap indent . lines . errorBundlePretty   where     indent x = if null x@@ -1393,13 +1379,13 @@ valToFun dec =   case dec of     ValD (VarP name) body decs -> FunD name [Clause [] body decs]-    _ -> dec+    _                          -> dec  normalizePragma :: Pragma -> Pragma normalizePragma p =   case p of     InlineP n i rm p -> InlineP (normalizeName n) i rm p-    _ -> p+    _                -> p  normalizeCon :: Con -> Con normalizeCon c =@@ -1416,11 +1402,11 @@     ForallT tvs cxt t ->  ForallT (normalizeTyVarBndr <$> tvs) (normalizeType <$> cxt) (normalizeType t)     _ -> t -normalizeTyVarBndr :: TyVarBndr -> TyVarBndr+normalizeTyVarBndr :: TyVarBndr flag -> TyVarBndr flag normalizeTyVarBndr tv =   case tv of-    PlainTV n -> PlainTV (normalizeName n)-    KindedTV n k -> KindedTV (normalizeName n) (normalizeType k)+    PlainTV n flag    -> PlainTV (normalizeName n) flag+    KindedTV n flag k -> KindedTV (normalizeName n) flag (normalizeType k)  normalizeClause :: Clause -> Clause normalizeClause (Clause pats body decs) = Clause (normalizePat <$> pats) (normalizeBody body) (normalizeDec <$> decs)@@ -1428,16 +1414,16 @@ normalizePat :: Pat -> Pat normalizePat p =   case p of-    VarP n -> VarP (normalizeName n)-    ConP n pats -> ConP (normalizeName n) (normalizePat <$> pats)-    TupP pats -> TupP (normalizePat <$> pats)-    _ -> p+    VarP n      -> VarP (normalizeName n)+    ConP n types pats -> ConP (normalizeName n) (normalizeType <$> types) (normalizePat <$> pats)+    TupP pats   -> TupP (normalizePat <$> pats)+    _           -> p  normalizeBody :: Body -> Body normalizeBody b =   case b of     NormalB e -> NormalB (normalizeExp e)-    _ -> b+    _         -> b  normalizeExp :: Exp -> Exp normalizeExp e =@@ -1446,7 +1432,9 @@     AppE e1 e2 -> AppE (normalizeExp e1) (normalizeExp e2)     ListE es -> ListE (normalizeExp <$> es)     CaseE e matches -> CaseE (normalizeExp e) (normalizeMatch <$> matches)-    ConE name -> ConE (normalizeName name)+    ConE name+      | name == '[] -> ListE []+      | otherwise -> 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@@ -1457,5 +1445,4 @@  normalizeName :: Name -> Name normalizeName (Name (OccName occ) (NameU _)) = mkName occ-normalizeName name = name-+normalizeName name                           = name

@@ -1,33 +1,22 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NegativeLiterals #-}-{-# LANGUAGE ScopedTypeVariables #-}- {-# OPTIONS_GHC -Wno-incomplete-patterns #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module FlatBuffers.ReadSpec where -import           Control.Exception          ( evaluate )--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--import           FlatBuffers.Internal.Read-import           FlatBuffers.Internal.Write-import qualified FlatBuffers.Vector         as Vec--import qualified Hedgehog.Gen               as Gen-import qualified Hedgehog.Range             as Range--import           TestImports-+import Control.Exception (evaluate)+import Data.Functor (($>))+import Data.Int+import Data.List qualified as List+import Data.Maybe qualified as Maybe+import Data.Text qualified as Text+import Data.Text.Read qualified as Text+import Examples+import FlatBuffers.Internal.Read+import FlatBuffers.Internal.Write+import FlatBuffers.Vector qualified as Vec+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import TestImports  spec :: Spec spec =@@ -43,58 +32,44 @@         , missing, missing, missing         , writeVectorWord8TableField text         ]-      primitivesL table `shouldBeLeft`-        "UTF8 decoding error (byte 255): Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"+      primitivesL table `shouldBeLeftAndExpect` \errMsg -> do+        errMsg `shouldStartWith` "UTF8 decoding error (byte 255)"+        errMsg `shouldEndWith` "Invalid UTF-8 stream"      it "fails when required field is missing" $ do       table <- evalRight $ decode @RequiredFields $ encode $ writeTable []       requiredFieldsA table `shouldBeLeft` "Missing required table field: a"       requiredFieldsB table `shouldBeLeft` "Missing required table field: b"       requiredFieldsC table `shouldBeLeft` "Missing required table field: c"+      requiredFieldsD table `shouldBeLeft` "Missing required table field: d"       requiredFieldsE table `shouldBeLeft` "Missing required table field: e"--      table <- evalRight $ decode @VectorOfUnions $ encode $ writeTable []-      vectorOfUnionsXsReq table `shouldBeLeft` "Missing required table field: xsReq"--    it "returns `UnionNone` when required union field is missing" $ do-      table <- evalRight $ decode @RequiredFields $ encode $ writeTable []-      requiredFieldsD table `shouldBeRightAndExpect` \case-        UnionNone -> pure ()--      table <- evalRight $ decode @RequiredFields $ encode $ writeTable [ missing ]-      requiredFieldsD table `shouldBeRightAndExpect` \case-        UnionNone -> pure ()+      requiredFieldsF table `shouldBeLeft` "Missing required table field: f"      it "throws when union type is present, but union value is missing" $ do       table <- evalRight $ decode $ encode $ writeTable [ writeWord8TableField 1]       tableWithUnionUni table `shouldBeLeft` "Union: 'union type' found but 'union value' is missing."      it "throws when union type vector is present, but union value vector is missing" $ do-      table <- evalRight $ decode $ encode $ writeTable+      table <- evalRight $ decode @VectorOfUnions $ encode $ writeTable         [ writeVectorWord8TableField Vec.empty         , missing-        , missing-        , missing-        , writeVectorWord8TableField Vec.empty-        , missing         ]       vectorOfUnionsXs table `shouldBeLeft` "Union vector: 'type vector' found but 'value vector' is missing."-      vectorOfUnionsXsReq table `shouldBeLeft` "Union vector: 'type vector' found but 'value vector' is missing."      describe "returns `UnionUnknown` when union type is not recognized" $ do       it "in union table fields" $ do         let union = writeUnion 99 (writeTable [])-        table <- evalRight $ decode $ encode $ tableWithUnion union+        table <- evalRight $ decode $ encode $ tableWithUnion $ Just union         tableWithUnionUni table `shouldBeRightAndExpect` \case-          UnionUnknown n -> n `shouldBe` 99+          Just (UnionUnknown n) -> n `shouldBe` 99        it "in union vectors" $ do         let union = writeUnion 99 (writeTable [])          result <- evalRight $ do-          table <- decode $ encode $ vectorOfUnions Nothing (Vec.singleton union)-          vec   <- vectorOfUnionsXsReq table-          vec `unsafeIndex` 0+          table <- decode $ encode $ vectorOfUnions $ Just $ Vec.singleton union+          vectorOfUnionsXs table >>= \case+            Just vec -> vec `unsafeIndex` 0          case result of           UnionUnknown n -> n `shouldBe` 99@@ -125,10 +100,10 @@       let testInvalidUnsafeIndex table getVector = do             case getIndex table getVector Vec.unsafeIndex 100 of               Right a -> evaluate a $> ()-              Left e -> evaluate e $> ()+              Left e  -> evaluate e $> ()             case getIndex table getVector Vec.unsafeIndex (-100) of               Right a -> evaluate a $> ()-              Left e -> evaluate e $> ()+              Left e  -> evaluate e $> ()        describe "of primitives" $ do         let Right table = decode $ encode $ vectors@@ -188,7 +163,7 @@           testLargeIndex table vectorsL          it "`take` and `drop` are consistent with Data.List.take and Data.List.drop" $-          requireProperty $ do+          hedgehog 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))@@ -262,7 +237,7 @@           testLargeIndex table vectorOfStructsAs          it "`take` and `drop` are consistent with Data.List.take and Data.List.drop" $-          requireProperty $ do+          hedgehog $ do             listInt16 <- forAll $ Gen.list (Range.linear 0 20) (Gen.int16 (Range.linear -20 20))             n <- forAll $ Gen.int32 (Range.linearFrom 0 -10 30) @@ -289,7 +264,7 @@           testLargeIndex table vectorOfTablesXs          it "`take` and `drop` are consistent with Data.List.take and Data.List.drop" $-          requireProperty $ do+          hedgehog $ do             listInt32 <- forAll $ Gen.list (Range.linear 0 20) (Gen.int32 (Range.linear -20 20))             n <- forAll $ Gen.int32 (Range.linearFrom 0 -10 30) @@ -302,7 +277,6 @@       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" $           testInvalidUnsafeIndex table vectorOfUnionsXs@@ -314,7 +288,7 @@           testLargeIndex table vectorOfUnionsXs          it "`take` and `drop` are consistent with Data.List.take and Data.List.drop" $-          requireProperty $ do+          hedgehog $ do             listOfPairs :: [(String, Int32)] <- forAll $ Gen.list (Range.linear 0 20) $ do               unionType <- Gen.element ["Axe", "Sword"]               unionVal <- Gen.int32 (Range.linear -20 20)@@ -340,9 +314,8 @@                           Right (intVal, _) ->                             pure ("Sword", intVal) -            table <- evalEither $ decode $ encode $ vectorOfUnions-              (Just (Vec.fromList' (pairToUnion <$> listOfPairs)))-              Vec.empty+            table <- evalEither $ decode $ encode $ vectorOfUnions $ Just $+              Vec.fromList' (pairToUnion <$> listOfPairs)              prop_takeConsistency n listOfPairs (vectorOfUnionsXs table) unionToPair             prop_dropConsistency n listOfPairs (vectorOfUnionsXs table) unionToPair@@ -371,5 +344,3 @@   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))--

@@ -1,27 +1,23 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}- {-# OPTIONS_GHC -Wno-incomplete-patterns #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  {- HLINT ignore "Reduce duplication" -} {- HLINT ignore "Avoid lambda" -}  module FlatBuffers.RoundTripSpec where -import           Control.Applicative ( liftA3 )+import Control.Applicative (liftA3) -import           Data.Bits           ( (.|.) )-import           Data.Functor        ( (<&>) )-import qualified Data.List           as L-import           Data.Maybe          ( isNothing )+import Data.Bits ((.|.))+import Data.List qualified as L+import Data.Maybe (isNothing) -import           Examples+import Examples -import           FlatBuffers-import           FlatBuffers.Vector  as Vec+import FlatBuffers+import FlatBuffers.Vector as Vec -import           TestImports+import TestImports   spec :: Spec@@ -210,17 +206,17 @@      describe "Union" $       it "present" $ do-        x <- evalRight $ decode $ encode $ tableWithUnion (weaponSword (sword (Just "hi")))+        x <- evalRight $ decode $ encode $ tableWithUnion $ Just $ weaponSword $ sword $ Just "hi"         tableWithUnionUni x `shouldBeRightAndExpect` \case-          Union (WeaponSword x) -> swordX x `shouldBe` Right (Just "hi")+          Just (Union (WeaponSword x)) -> swordX x `shouldBe` Right (Just "hi") -        x <- evalRight $ decode $ encode $ tableWithUnion (weaponAxe (axe (Just maxBound)))+        x <- evalRight $ decode $ encode $ tableWithUnion $ Just $ weaponAxe $ axe $ Just maxBound         tableWithUnionUni x `shouldBeRightAndExpect` \case-          Union (WeaponAxe x) -> axeY x `shouldBe` Right maxBound+          Just (Union (WeaponAxe x)) -> axeY x `shouldBe` Right maxBound -        x <- evalRight $ decode $ encode $ tableWithUnion none+        x <- evalRight $ decode $ encode $ tableWithUnion Nothing         tableWithUnionUni x `shouldBeRightAndExpect` \case-          UnionNone -> pure ()+          Nothing -> pure ()      describe "Vectors" $ do       let Right nonEmptyVecs = decode $ encode $ vectors@@ -372,60 +368,30 @@       it "non empty" $ do         let           shouldBeSword x (Union (WeaponSword s)) = swordX s `shouldBe` Right (Just x)-           shouldBeAxe y (Union (WeaponAxe s)) = axeY s `shouldBe` Right y -          shouldBeNone UnionNone = pure ()--        x <- evalRight $ decode $ encode $ vectorOfUnions-          (Just $ Vec.fromList'+        x <- evalRight $ decode $ encode $ vectorOfUnions $+          Just $ Vec.fromList'             [ weaponSword (sword (Just "hi"))-            , none             , weaponAxe (axe (Just 98))             ]-          )-          (Vec.fromList'-            [ weaponSword (sword (Just "hi2"))-            , none-            , weaponAxe (axe (Just 100))-            ]-          )          Just xs <- evalRight $ vectorOfUnionsXs x-        Vec.length xs `shouldBe` 3-        L.length <$> toList xs `shouldBe` Right 3+        Vec.length xs `shouldBe` 2+        L.length <$> toList xs `shouldBe` Right 2         xs `unsafeIndex` 0 `shouldBeRightAndExpect` shouldBeSword "hi"-        xs `unsafeIndex` 1 `shouldBeRightAndExpect` shouldBeNone-        xs `unsafeIndex` 2 `shouldBeRightAndExpect` shouldBeAxe 98-        (toList xs <&> (!! 0)) `shouldBeRightAndExpect` shouldBeSword "hi"-        (toList xs <&> (!! 1)) `shouldBeRightAndExpect` shouldBeNone-        (toList xs <&> (!! 2)) `shouldBeRightAndExpect` shouldBeAxe 98--        xsReq <- evalRight $ vectorOfUnionsXsReq x-        Vec.length xsReq `shouldBe` 3-        L.length <$> toList xsReq `shouldBe` Right 3-        xsReq `unsafeIndex` 0 `shouldBeRightAndExpect` shouldBeSword "hi2"-        xsReq `unsafeIndex` 1 `shouldBeRightAndExpect` shouldBeNone-        xsReq `unsafeIndex` 2 `shouldBeRightAndExpect` shouldBeAxe 100-        (toList xsReq <&> (!! 0)) `shouldBeRightAndExpect` shouldBeSword "hi2"-        (toList xsReq <&> (!! 1)) `shouldBeRightAndExpect` shouldBeNone-        (toList xsReq <&> (!! 2)) `shouldBeRightAndExpect` shouldBeAxe 100+        xs `unsafeIndex` 1 `shouldBeRightAndExpect` shouldBeAxe 98        it "empty" $ do-        x <- evalRight $ decode $ encode $ vectorOfUnions (Just Vec.empty) Vec.empty+        x <- evalRight $ decode $ encode $ vectorOfUnions $ Just Vec.empty          Just xs <- evalRight $ vectorOfUnionsXs x         Vec.length xs `shouldBe` 0         L.length <$> toList xs `shouldBe` Right 0 -        xsReq <- evalRight $ vectorOfUnionsXsReq x-        Vec.length xsReq `shouldBe` 0-        L.length <$> toList xsReq `shouldBe` Right 0-       it "missing" $ do-        x <- evalRight $ decode $ encode $ vectorOfUnions Nothing Vec.empty+        x <- evalRight $ decode $ encode $ vectorOfUnions Nothing         vectorOfUnionsXs x `shouldBeRightAnd` isNothing-        (Vec.length <$> vectorOfUnionsXsReq x) `shouldBe` Right 0      describe "ScalarsWithDefaults" $ do       let runTest buffer = do@@ -468,12 +434,13 @@         Nothing Nothing      it "DeprecatedFields" $ do-      x <- evalRight $ decode $ encode $ deprecatedFields (Just 1) (Just 2) (Just 3) (Just 4)+      x <- evalRight $ decode $ encode $ deprecatedFields (Just 1) (Just 2) (Just 3) (Just 4) (Just 5)        deprecatedFieldsA x `shouldBe` Right 1       deprecatedFieldsC x `shouldBe` Right 2       deprecatedFieldsE x `shouldBe` Right 3       deprecatedFieldsG x `shouldBe` Right 4+      deprecatedFieldsI x `shouldBe` Right 5      it "RequiredFields" $ do       let readStruct1 = (liftA3 . liftA3) (,,) struct1X struct1Y struct1Z@@ -483,6 +450,7 @@         (axe (Just 44))         (weaponSword (sword (Just "a")))         (Vec.fromList' [55, 66])+        (Vec.singleton $ weaponSword (sword (Just "b")))        requiredFieldsA x `shouldBe` Right "hello"       (requiredFieldsB x >>= readStruct1) `shouldBe` Right (11, 22, 33)@@ -490,3 +458,5 @@       requiredFieldsD x `shouldBeRightAndExpect` \case         Union (WeaponSword x) -> swordX x `shouldBe` Right (Just "a")       (requiredFieldsE x >>= toList) `shouldBe` Right [55, 66]+      (requiredFieldsF x >>= toList) `shouldBeRightAndExpect` \case+        [Union (WeaponSword x)] -> swordX x `shouldBe` Right (Just "b")

@@ -1,8 +1,8 @@ module TestImports   ( module Hspec   , module Hedgehog-  , HasCallStack   , shouldBeLeft+  , shouldBeLeftAndExpect   , shouldBeRightAnd   , shouldBeRightAndExpect   , evalRight@@ -13,30 +13,28 @@   , shouldBeJson   , showBuffer   , traceBufferM+  , showBufferHex+  , traceBufferHexM   ) where -import           Control.Monad                  ( (>=>) )--import qualified Data.Aeson                     as J-import           Data.Aeson.Encode.Pretty       ( encodePretty )-import qualified Data.ByteString.Lazy           as BSL-import qualified Data.ByteString.Lazy.UTF8      as BSLU-import qualified Data.List                      as List--import           Debug.Trace--import           GHC.Stack                      ( HasCallStack )--import           HaskellWorks.Hspec.Hedgehog    as Hedgehog--import           Hedgehog--import           Test.HUnit                     ( assertFailure )-import           Test.Hspec.Core.Hooks          as Hspec-import           Test.Hspec.Core.Spec           as Hspec-import           Test.Hspec.Expectations.Pretty as Hspec-import           Test.Hspec.Runner              as Hspec-+import Control.Monad ((>=>))+import Data.Aeson qualified as J+import Data.Aeson.Encode.Pretty (encodePretty)+import Data.ByteString.Lazy qualified as BSL+import Data.ByteString.Lazy.UTF8 qualified as BSLU+import Data.Function ((&))+import Data.Functor ((<&>))+import Data.List qualified as List+import Data.Text qualified as T+import Debug.Trace+import Hedgehog+import Test.Hspec.Core.Hooks as Hspec+import Test.Hspec.Core.Spec as Hspec+import Test.Hspec.Expectations.Pretty as Hspec hiding (Expectation)+import Test.Hspec.Hedgehog as Hedgehog+import Test.Hspec.Runner as Hspec+import Test.HUnit (assertFailure)+import Text.Hex  -- | Useful when there's no `Show`/`Eq` instances for @a@. shouldBeLeft :: HasCallStack => Show e => Eq e => Either e a -> e -> Expectation@@ -44,6 +42,11 @@     Left e  -> e `shouldBe` expected     Right _ -> expectationFailure "Expected 'Left', got 'Right'" +shouldBeLeftAndExpect :: HasCallStack => Show a => Either e a -> (e -> Expectation) -> Expectation+shouldBeLeftAndExpect ea expect = case ea of+    Left e  -> expect e+    Right a -> expectationFailure $ "Expected 'Left', got 'Right':\n" <> show a+ shouldBeRightAnd :: HasCallStack => Show e => Either e a -> (a -> Bool) -> Expectation shouldBeRightAnd ea pred = case ea of     Left e  -> expectationFailure $ "Expected 'Right', got 'Left':\n" <> show e@@ -95,8 +98,22 @@   List.intercalate "\n" . fmap (List.intercalate ", ") . groupsOf 4 . fmap show $   BSL.unpack bs +traceBufferHexM :: Applicative m => BSL.ByteString -> m ()+traceBufferHexM = traceM . showBufferHex++showBufferHex :: BSL.ByteString -> String+showBufferHex bs =+  bs+    & BSL.toStrict+    & encodeHex+    & T.unpack+    & groupsOf 2+    & groupsOf 4+    <&> List.intercalate ", "+    & List.intercalate "\n"+ groupsOf :: Int -> [a] -> [[a]] groupsOf n xs =   case take n xs of-    [] -> []+    []    -> []     group -> group : groupsOf n (drop n xs)