diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/bench/DecodeVectors.hs b/bench/DecodeVectors.hs --- a/bench/DecodeVectors.hs +++ b/bench/DecodeVectors.hs @@ -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)) - - diff --git a/bench/Encode.hs b/bench/Encode.hs --- a/bench/Encode.hs +++ b/bench/Encode.hs @@ -1,10 +1,10 @@ module Encode where -import Criterion +import Criterion -import FlatBuffers +import FlatBuffers -import Types +import Types groups :: [Benchmark] diff --git a/bench/EncodeVectors.hs b/bench/EncodeVectors.hs --- a/bench/EncodeVectors.hs +++ b/bench/EncodeVectors.hs @@ -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 } diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -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 = diff --git a/bench/Types.hs b/bench/Types.hs --- a/bench/Types.hs +++ b/bench/Types.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE TemplateHaskell #-} - module Types where -import FlatBuffers +import FlatBuffers $(mkFlatBuffers "bench/types.fbs" defaultOptions) diff --git a/cbits/cbits.c b/cbits/cbits.c deleted file mode 100644 --- a/cbits/cbits.c +++ /dev/null @@ -1,78 +0,0 @@ -/* - * See https://github.com/haskell/text/blob/9fac5db9b048b7d68fa2fb68513ba86c791b3630/cbits/cbits.c for details. - */ - -#include -#include -#include - -uint32_t -_hs_text_length_utf8(const uint16_t *src, size_t srcoff, - size_t srclen) -{ - const uint16_t *srcend; - - int32_t counter = 0; - - src += srcoff; - srcend = src + srclen; - - ascii: -#if defined(__x86_64__) - while (srcend - src >= 4) { - uint64_t w = *((uint64_t *) src); - - if (w & 0xFF80FF80FF80FF80ULL) { - if (!(w & 0x000000000000FF80ULL)) { - ++counter; - src++; - if (!(w & 0x00000000FF800000ULL)) { - ++counter; - src++; - if (!(w & 0x0000FF8000000000ULL)) { - ++counter; - src++; - } - } - } - break; - } - counter += 4; - src += 4; - } -#endif - -#if defined(__i386__) - while (srcend - src >= 2) { - uint32_t w = *((uint32_t *) src); - - if (w & 0xFF80FF80) - break; - counter += 2; - src += 2; - } -#endif - - while (src < srcend) { - uint16_t w = *src++; - - if (w <= 0x7F) { - ++counter; - /* An ASCII byte is likely to begin a run of ASCII bytes. - Falling back into the fast path really helps performance. */ - goto ascii; - } - else if (w <= 0x7FF) { - counter += 2; - } - else if (w < 0xD800 || w > 0xDBFF) { - counter += 3; - } else { - uint32_t c = ((((uint32_t) w) - 0xD800) << 10) + - (((uint32_t) *src++) - 0xDC00) + 0x10000; - counter += 4; - } - } - - return counter; -} diff --git a/flatbuffers.cabal b/flatbuffers.cabal --- a/flatbuffers.cabal +++ b/flatbuffers.cabal @@ -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 diff --git a/src/FlatBuffers.hs b/src/FlatBuffers.hs --- a/src/FlatBuffers.hs +++ b/src/FlatBuffers.hs @@ -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 diff --git a/src/FlatBuffers/Internal/Build.hs b/src/FlatBuffers/Internal/Build.hs --- a/src/FlatBuffers/Internal/Build.hs +++ b/src/FlatBuffers/Internal/Build.hs @@ -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 diff --git a/src/FlatBuffers/Internal/Compiler/Display.hs b/src/FlatBuffers/Internal/Compiler/Display.hs --- a/src/FlatBuffers/Internal/Compiler/Display.hs +++ b/src/FlatBuffers/Internal/Compiler/Display.hs @@ -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 - diff --git a/src/FlatBuffers/Internal/Compiler/NamingConventions.hs b/src/FlatBuffers/Internal/Compiler/NamingConventions.hs --- a/src/FlatBuffers/Internal/Compiler/NamingConventions.hs +++ b/src/FlatBuffers/Internal/Compiler/NamingConventions.hs @@ -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 diff --git a/src/FlatBuffers/Internal/Compiler/Parser.hs b/src/FlatBuffers/Internal/Compiler/Parser.hs --- a/src/FlatBuffers/Internal/Compiler/Parser.hs +++ b/src/FlatBuffers/Internal/Compiler/Parser.hs @@ -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 diff --git a/src/FlatBuffers/Internal/Compiler/ParserIO.hs b/src/FlatBuffers/Internal/Compiler/ParserIO.hs --- a/src/FlatBuffers/Internal/Compiler/ParserIO.hs +++ b/src/FlatBuffers/Internal/Compiler/ParserIO.hs @@ -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 diff --git a/src/FlatBuffers/Internal/Compiler/SemanticAnalysis.hs b/src/FlatBuffers/Internal/Compiler/SemanticAnalysis.hs --- a/src/FlatBuffers/Internal/Compiler/SemanticAnalysis.hs +++ b/src/FlatBuffers/Internal/Compiler/SemanticAnalysis.hs @@ -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 diff --git a/src/FlatBuffers/Internal/Compiler/SyntaxTree.hs b/src/FlatBuffers/Internal/Compiler/SyntaxTree.hs --- a/src/FlatBuffers/Internal/Compiler/SyntaxTree.hs +++ b/src/FlatBuffers/Internal/Compiler/SyntaxTree.hs @@ -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 diff --git a/src/FlatBuffers/Internal/Compiler/TH.hs b/src/FlatBuffers/Internal/Compiler/TH.hs --- a/src/FlatBuffers/Internal/Compiler/TH.hs +++ b/src/FlatBuffers/Internal/Compiler/TH.hs @@ -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 diff --git a/src/FlatBuffers/Internal/Compiler/ValidSyntaxTree.hs b/src/FlatBuffers/Internal/Compiler/ValidSyntaxTree.hs --- a/src/FlatBuffers/Internal/Compiler/ValidSyntaxTree.hs +++ b/src/FlatBuffers/Internal/Compiler/ValidSyntaxTree.hs @@ -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 diff --git a/src/FlatBuffers/Internal/FileIdentifier.hs b/src/FlatBuffers/Internal/FileIdentifier.hs --- a/src/FlatBuffers/Internal/FileIdentifier.hs +++ b/src/FlatBuffers/Internal/FileIdentifier.hs @@ -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`. diff --git a/src/FlatBuffers/Internal/Read.hs b/src/FlatBuffers/Internal/Read.hs --- a/src/FlatBuffers/Internal/Read.hs +++ b/src/FlatBuffers/Internal/Read.hs @@ -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." diff --git a/src/FlatBuffers/Internal/Types.hs b/src/FlatBuffers/Internal/Types.hs --- a/src/FlatBuffers/Internal/Types.hs +++ b/src/FlatBuffers/Internal/Types.hs @@ -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) - diff --git a/src/FlatBuffers/Internal/Write.hs b/src/FlatBuffers/Internal/Write.hs --- a/src/FlatBuffers/Internal/Write.hs +++ b/src/FlatBuffers/Internal/Write.hs @@ -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 diff --git a/src/FlatBuffers/Vector.hs b/src/FlatBuffers/Vector.hs --- a/src/FlatBuffers/Vector.hs +++ b/src/FlatBuffers/Vector.hs @@ -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 diff --git a/test/Examples/Generated.hs b/test/Examples/Generated.hs --- a/test/Examples/Generated.hs +++ b/test/Examples/Generated.hs @@ -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) diff --git a/test/Examples/HandWritten.hs b/test/Examples/HandWritten.hs --- a/test/Examples/HandWritten.hs +++ b/test/Examples/HandWritten.hs @@ -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" diff --git a/test/FlatBuffers/AlignmentSpec.hs b/test/FlatBuffers/AlignmentSpec.hs --- a/test/FlatBuffers/AlignmentSpec.hs +++ b/test/FlatBuffers/AlignmentSpec.hs @@ -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) diff --git a/test/FlatBuffers/Integration/HaskellToScalaSpec.hs b/test/FlatBuffers/Integration/HaskellToScalaSpec.hs deleted file mode 100644 --- a/test/FlatBuffers/Integration/HaskellToScalaSpec.hs +++ /dev/null @@ -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)) diff --git a/test/FlatBuffers/Integration/RoundTripThroughFlatcSpec.hs b/test/FlatBuffers/Integration/RoundTripThroughFlatcSpec.hs --- a/test/FlatBuffers/Integration/RoundTripThroughFlatcSpec.hs +++ b/test/FlatBuffers/Integration/RoundTripThroughFlatcSpec.hs @@ -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) diff --git a/test/FlatBuffers/Internal/Compiler/ParserSpec.hs b/test/FlatBuffers/Internal/Compiler/ParserSpec.hs --- a/test/FlatBuffers/Internal/Compiler/ParserSpec.hs +++ b/test/FlatBuffers/Internal/Compiler/ParserSpec.hs @@ -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 - - diff --git a/test/FlatBuffers/Internal/Compiler/SemanticAnalysisSpec.hs b/test/FlatBuffers/Internal/Compiler/SemanticAnalysisSpec.hs --- a/test/FlatBuffers/Internal/Compiler/SemanticAnalysisSpec.hs +++ b/test/FlatBuffers/Internal/Compiler/SemanticAnalysisSpec.hs @@ -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 diff --git a/test/FlatBuffers/Internal/Compiler/THSpec.hs b/test/FlatBuffers/Internal/Compiler/THSpec.hs --- a/test/FlatBuffers/Internal/Compiler/THSpec.hs +++ b/test/FlatBuffers/Internal/Compiler/THSpec.hs @@ -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 diff --git a/test/FlatBuffers/ReadSpec.hs b/test/FlatBuffers/ReadSpec.hs --- a/test/FlatBuffers/ReadSpec.hs +++ b/test/FlatBuffers/ReadSpec.hs @@ -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)) - - diff --git a/test/FlatBuffers/RoundTripSpec.hs b/test/FlatBuffers/RoundTripSpec.hs --- a/test/FlatBuffers/RoundTripSpec.hs +++ b/test/FlatBuffers/RoundTripSpec.hs @@ -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") diff --git a/test/TestImports.hs b/test/TestImports.hs --- a/test/TestImports.hs +++ b/test/TestImports.hs @@ -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)