diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7fa4a95..f990ba3 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -14,7 +14,14 @@ jobs: ghc: - 8107 - 902 - - 924 + - 928 + - 948 + - 965 + - 982 + - 9101 + exclude: + - os: macos-latest + ghc: 902 runs-on: ${{ matrix.os }} steps: @@ -57,7 +64,7 @@ jobs: stack-version: 2.11 - name: Cache dependencies - uses: actions/cache@v3.3.1 + uses: actions/cache@v3.4.0 with: path: ~/.stack key: ${{ runner.os }}-${{ matrix.ghc }}-stack diff --git a/CHANGELOG.md b/CHANGELOG.md index 17ac95f..80fc094 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,20 @@ +1.4.5 + - Add encoders for packed repeated fields that can iterate in + reverse order for speed when practical and will predict size + when it is inexpensive to do so. + - Add bytesIfNonempty, etaMessageBuilder, unsafeFromByteString, + unsafeFromShortByteString, repeatedMessageBuilder. + +1.4.4 + - Support GHC 9.10 + +1.4.3 + - Support GHC 9.8 + - Support GHC 9.6 + +1.4.2 + - Support GHC 9.4 + 1.4.1 - Support ShortByteString and ShortText diff --git a/README.md b/README.md index 99aa4c2..c433faf 100644 --- a/README.md +++ b/README.md @@ -25,3 +25,34 @@ To run tests or generate documentation, use ```text stack build [--test] [--haddock] ``` + +### GHC Versions + +#### GHC 9.10 + +Supported on Linux and Darwin. + +#### GHC 9.8 + +Supported on Linux and Darwin. + +#### GHC 9.6 + +Supported on Linux and Darwin. + +#### GHC 9.4 + +Supported on Linux and Darwin. + +#### GHC 9.2 + +Supported on Linux and Darwin. + +#### GHC 9.0 + +Supported only on Linux because "crypton" fails a test on Darwin, +probably due to [this issue](https://github.com/kazu-yamamoto/crypton/issues/35). + +#### GHC 8.10.7 + +Supported on Linux and Darwin. diff --git a/bench/Main.hs b/bench/Main.hs index b8aa5c4..6b0649d 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -15,7 +15,6 @@ import Proto3.Wire import Control.Applicative (liftA2, liftA3) import Control.Monad (forM) -import Data.Maybe import Data.Word import Data.IORef @@ -39,7 +38,7 @@ instance Foldable Tree where in a + a1 + a2 instance Foldable Rose where - foldMap f Bud = mempty + foldMap _ Bud = mempty foldMap f (Rose x rs) = f x <> ((foldMap.foldMap) f rs) intTreeParser :: De.Parser De.RawMessage (Tree Word64) @@ -123,9 +122,9 @@ pullInt :: IORef [Word64] -> IO Word64 pullInt xs = do xs' <- readIORef xs case xs' of - [] -> pure (-1) - x : xs' -> do - writeIORef xs xs' + [] -> pure (negate 1) + x : xs'' -> do + writeIORef xs xs'' pure x mkTree0 :: IO Word64 -> IO En.MessageBuilder diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..51051bb --- /dev/null +++ b/cabal.project @@ -0,0 +1,3 @@ +packages: . +benchmarks: True +tests: True diff --git a/nix/haskell-packages.nix b/nix/haskell-packages.nix index 6580ff6..b32bb36 100644 --- a/nix/haskell-packages.nix +++ b/nix/haskell-packages.nix @@ -5,15 +5,158 @@ pkgsNew: pkgsOld: { haskellPackages = pkgsOld.haskell.packages."${compiler}".override (old: { overrides = - pkgsOld.lib.composeExtensions + pkgsNew.lib.fold pkgsNew.lib.composeExtensions (old.overrides or (_: _: {})) - (haskellPackagesFinal: haskellPackagesPrev: { - proto3-wire = haskellPackagesFinal.callCabal2nix "proto3-wire" ../. { }; - - # ghc-9.2 requires word-compat-0.0.6 - word-compat = haskellPackagesFinal.callPackage ./word-compat.nix { }; - # Use newer version 4.7.1.0 for ghc-9.x support - data-diverse = haskellPackagesFinal.callPackage ./data-diverse.nix { }; - }); + [ (pkgsNew.haskell.lib.packagesFromDirectory { directory = ./packages; }) + (haskellPackagesFinal: haskellPackagesPrev: { + # With nixpkgs-23.11 and ghc981, adjunctions wants hspec for testing, + # which causes problems. + adjunctions = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.adjunctions; + + # With nixpkgs-24.11 and our overrides, and when building with GHC 8.10, + # aeson thinks that th-abstraction is out of bounds. + aeson = + pkgsNew.haskell.lib.doJailbreak haskellPackagesPrev.aeson; + + # With nixpkgs-23.11 and ghc981, base-compat-batteries wants hspec for testing, + # which causes problems. + base-compat-batteries = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.base-compat-batteries; + + # With nixpkgs-23.11 and ghc981, base-orphans wants hspec for testing, + # which causes problems. + base-orphans = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.base-orphans; + + # With nixpkgs-23.11 and ghc981, bifunctors wants hspec for testing, + # which causes problems. + bifunctors = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.bifunctors; + + # With nixpkgs-23.11 and ghc981, conduit wants hspec for testing, + # which causes problems. + conduit = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.conduit; + + # With nixpkgs-23.11 and ghc981, data-diverse wants hspec for testing, + # which causes problems. + data-diverse = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.data-diverse; + + # With nixpkgs-23.11 and ghc981, distribution-nixpkgs wants hspec for testing, + # which causes problems. + distribution-nixpkgs = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.distribution-nixpkgs; + + # With nixpkgs-23.11 and ghc981, distributive wants hspec for testing, + # which causes problems. + distributive = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.distributive; + + # With ghc981, doctest-0.22.2 complains about the version of the base + # package and depends on hspec for testing, which causes problems. + doctest = + pkgsNew.haskell.lib.dontCheck + (pkgsNew.haskell.lib.doJailbreak haskellPackagesPrev.doctest); + + # With nixpkgs-23.11 and ghc981, generic-deriving wants hspec for testing, + # which causes problems. Also, it generic-deriving thinks that + # th-abstraction is out of bounds. + generic-deriving = + pkgsNew.haskell.lib.dontCheck + (pkgsNew.haskell.lib.doJailbreak haskellPackagesPrev.generic-deriving); + + # With nixpkgs-23.11 and ghc981, hourglass does not support the version + # of the time package that is provided, but that matters only to tests. + hourglass = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.hourglass; + + # With nixpkgs-23.11 and ghc981, hpack-0.36.0 wants hspec for testing, + # which causes problems. + hpack = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.hpack; + + # With nixpkgs-23.11 and ghc981, http-types wants hspec for testing, + # which causes problems. + http-types = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.http-types; + + # With nixpkgs-23.11 and ghc981, infer-license wants hspec for testing, + # which causes problems. + infer-license = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.infer-license; + + # With nixpkgs-23.11 and ghc981, invariant indirectly depends on hspec for testing, + # which causes problems. Also, it generic-deriving thinks that + # th-abstraction is out of bounds. + invariant = + pkgsNew.haskell.lib.dontCheck + (pkgsNew.haskell.lib.doJailbreak haskellPackagesPrev.invariant); + + # With nixpkgs-23.11 and ghc981, iproute wants hspec for testing, + # which causes problems. + iproute = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.iproute; + + # With nixpkgs-24.11 and our overrides, lens thinks that template-haskell is out of bounds. + lens = + pkgsNew.haskell.lib.doJailbreak haskellPackagesPrev.lens; + + # With nixpkgs-23.11 and ghc981, monad-par wants test-framework for testing, which + # wants language-haskell-extract, which does not support modern template-haskell. + monad-par = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.monad-par; + + # With nixpkgs-23.11 and ghc981, mono-traversable wants hspec for testing, + # which causes problems. + mono-traversable = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.mono-traversable; + + # With nixpkgs-23.11 and ghc981, streaming-commons wants hspec for testing, + # which causes problems. + streaming-commons = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.streaming-commons; + + # With nixpkgs-23.11 and ghc981, reflection indirectly depends on hspec for testing, + # which causes problems. + reflection = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.reflection; + + # With nixpkgs-23.11 and ghc981, resourcet wants hspec for testing, + # which causes problems. + resourcet = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.resourcet; + + # Suppress: + # warning: non-portable path to file '"dist/build/Test/autogen/cabal_macros.h"'; specified path differs in case from file name on disk [-Wnonportable-include-path] + tasty-golden = + pkgsNew.haskell.lib.appendConfigureFlags haskellPackagesPrev.tasty-golden + [ "--ghc-option=-Wno-nonportable-include-path" ]; + + # With nixpkgs-23.11 and ghc981, text-metrics wants hspec for testing, + # which causes problems. + text-metrics = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.text-metrics; + + # With nixpkgs-23.11 and ghc981, th-compat wants hspec for testing, + # which causes problems. + th-compat = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.th-compat; + + # With nixpkgs-23.11 and ghc981, hpack-0.36.0 wants hspec for testing, + # which causes problems. + unix-time = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.unix-time; + + # With nixpkgs-23.11 and ghc981, yaml wants hspec for testing, + # which causes problems. + yaml = + pkgsNew.haskell.lib.dontCheck haskellPackagesPrev.yaml; + }) + (haskellPackagesFinal: haskellPackagesPrev: { + proto3-wire = haskellPackagesFinal.callCabal2nix "proto3-wire" ../. { }; + }) + ]; }); } diff --git a/nix/nixpkgs.nix b/nix/nixpkgs.nix index b278184..f32361d 100644 --- a/nix/nixpkgs.nix +++ b/nix/nixpkgs.nix @@ -2,8 +2,10 @@ args: let nixpkgs = builtins.fetchTarball { - # nixos-22.05 as on 2023-07-17 - url = "https://github.com/NixOS/nixpkgs/archive/380be19fbd2d9079f677978361792cb25e8a3635.tar.gz"; - sha256 = "154x9swf494mqwi4z8nbq2f0sp8pwp4fvx51lqzindjfbb9yxxv5"; + # from: https://hydra.nixos.org/job/nixos/release-24.11/nixpkgs.tarball + # build: https://hydra.nixos.org/build/284195557 + # commit: cbd8ec4de4469333c82ff40d057350c30e9f7d36 + url = "https://hydra.nixos.org/build/284195557/download/2/nixpkgs-24.11pre712431.cbd8ec4de446.tar.xz"; + sha256 = "0ljq084fq784fgvm7n9081dmnjhksz20vwzca2zics0kkkzjxh5k"; }; in import nixpkgs ({ config = { }; } // args) diff --git a/nix/packages/bifunctors.nix b/nix/packages/bifunctors.nix new file mode 100644 index 0000000..f4cf326 --- /dev/null +++ b/nix/packages/bifunctors.nix @@ -0,0 +1,22 @@ +{ mkDerivation, assoc, base, comonad, containers +, foldable1-classes-compat, hspec, hspec-discover, lib, QuickCheck +, tagged, template-haskell, th-abstraction, transformers +, transformers-compat +}: +mkDerivation { + pname = "bifunctors"; + version = "5.6.2"; + sha256 = "1086a9285061eed0c2c5d3cb65aa223defd52fca6d0515bb69ddf2dbc3d9697a"; + libraryHaskellDepends = [ + assoc base comonad containers foldable1-classes-compat tagged + template-haskell th-abstraction transformers + ]; + testHaskellDepends = [ + base hspec QuickCheck template-haskell transformers + transformers-compat + ]; + testToolDepends = [ hspec-discover ]; + homepage = "http://github.com/ekmett/bifunctors/"; + description = "Bifunctors"; + license = lib.licenses.bsd3; +} diff --git a/nix/packages/doctest.nix b/nix/packages/doctest.nix new file mode 100644 index 0000000..9e64520 --- /dev/null +++ b/nix/packages/doctest.nix @@ -0,0 +1,30 @@ +{ mkDerivation, base, code-page, deepseq, directory, exceptions +, filepath, ghc, ghc-paths, hspec, hspec-core, hspec-discover +, HUnit, lib, mockery, process, QuickCheck, setenv, silently +, stringbuilder, syb, transformers +}: +mkDerivation { + pname = "doctest"; + version = "0.22.2"; + sha256 = "afb839c14019c17e3ec7900871a9fc104226028858c724932d53225ae382c6e5"; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ + base code-page deepseq directory exceptions filepath ghc ghc-paths + process syb transformers + ]; + executableHaskellDepends = [ + base code-page deepseq directory exceptions filepath ghc ghc-paths + process syb transformers + ]; + testHaskellDepends = [ + base code-page deepseq directory exceptions filepath ghc ghc-paths + hspec hspec-core HUnit mockery process QuickCheck setenv silently + stringbuilder syb transformers + ]; + testToolDepends = [ hspec-discover ]; + homepage = "https://github.com/sol/doctest#readme"; + description = "Test interactive Haskell examples"; + license = lib.licenses.mit; + mainProgram = "doctest"; +} diff --git a/nix/packages/http-client-tls.nix b/nix/packages/http-client-tls.nix new file mode 100644 index 0000000..327b264 --- /dev/null +++ b/nix/packages/http-client-tls.nix @@ -0,0 +1,23 @@ +{ mkDerivation, base, bytestring, case-insensitive, containers +, crypton, crypton-connection, data-default-class, exceptions +, gauge, hspec, http-client, http-types, lib, memory, network +, network-uri, text, tls, transformers +}: +mkDerivation { + pname = "http-client-tls"; + version = "0.3.6.3"; + sha256 = "38dcfc3d772eb6898b4a8856d6159824d13f65eb291733619f625a802dad9095"; + libraryHaskellDepends = [ + base bytestring case-insensitive containers crypton + crypton-connection data-default-class exceptions http-client + http-types memory network network-uri text tls transformers + ]; + testHaskellDepends = [ + base crypton-connection hspec http-client http-types + ]; + benchmarkHaskellDepends = [ base gauge http-client ]; + doCheck = false; + homepage = "https://github.com/snoyberg/http-client"; + description = "http-client backend using the connection package and tls library"; + license = lib.licenses.mit; +} diff --git a/nix/packages/lens.nix b/nix/packages/lens.nix new file mode 100644 index 0000000..d495523 --- /dev/null +++ b/nix/packages/lens.nix @@ -0,0 +1,37 @@ +{ mkDerivation, array, assoc, base, base-orphans, bifunctors +, bytestring, call-stack, comonad, containers, contravariant +, criterion, deepseq, distributive, exceptions, filepath, free +, generic-deriving, ghc-prim, hashable, HUnit, indexed-traversable +, indexed-traversable-instances, kan-extensions, lib, mtl, parallel +, profunctors, QuickCheck, reflection, semigroupoids +, simple-reflect, strict, tagged, template-haskell, test-framework +, test-framework-hunit, test-framework-quickcheck2, text +, th-abstraction, these, transformers, transformers-compat +, unordered-containers, vector +}: +mkDerivation { + pname = "lens"; + version = "5.3.1"; + sha256 = "dac3ff7abd483ef36956882631fdcde922e086b51f459c0c02e690c6b7f24b6c"; + libraryHaskellDepends = [ + array assoc base base-orphans bifunctors bytestring call-stack + comonad containers contravariant distributive exceptions filepath + free ghc-prim hashable indexed-traversable + indexed-traversable-instances kan-extensions mtl parallel + profunctors reflection semigroupoids strict tagged template-haskell + text th-abstraction these transformers transformers-compat + unordered-containers vector + ]; + testHaskellDepends = [ + base bytestring containers deepseq HUnit mtl QuickCheck + simple-reflect test-framework test-framework-hunit + test-framework-quickcheck2 text transformers + ]; + benchmarkHaskellDepends = [ + base bytestring comonad containers criterion deepseq + generic-deriving transformers unordered-containers vector + ]; + homepage = "http://github.com/ekmett/lens/"; + description = "Lenses, Folds and Traversals"; + license = lib.licenses.bsd2; +} diff --git a/nix/packages/parsec-class.nix b/nix/packages/parsec-class.nix new file mode 100644 index 0000000..ebb55dd --- /dev/null +++ b/nix/packages/parsec-class.nix @@ -0,0 +1,10 @@ +{ mkDerivation, base, lib, parsec }: +mkDerivation { + pname = "parsec-class"; + version = "1.0.1.0"; + sha256 = "068686c03627ffca77128a762de295c4a43095b9e8dbe3829efc91fed00c418c"; + libraryHaskellDepends = [ base parsec ]; + homepage = "https://github.com/peti/parsec-class"; + description = "Class of types that can be constructed from their text representation"; + license = lib.licenses.mit; +} diff --git a/nix/packages/semigroupoids.nix b/nix/packages/semigroupoids.nix new file mode 100644 index 0000000..0058ab1 --- /dev/null +++ b/nix/packages/semigroupoids.nix @@ -0,0 +1,19 @@ +{ mkDerivation, base, base-orphans, bifunctors, comonad, containers +, contravariant, distributive, foldable1-classes-compat, hashable +, lib, tagged, template-haskell, transformers, transformers-compat +, unordered-containers +}: +mkDerivation { + pname = "semigroupoids"; + version = "6.0.1"; + sha256 = "1d532030862414f5d4f2f6f001783f77aa14e5f05ee8e3c4a2d2129fca29cc1f"; + libraryHaskellDepends = [ + base base-orphans bifunctors comonad containers contravariant + distributive foldable1-classes-compat hashable tagged + template-haskell transformers transformers-compat + unordered-containers + ]; + homepage = "http://github.com/ekmett/semigroupoids"; + description = "Semigroupoids: Category sans id"; + license = lib.licenses.bsd2; +} diff --git a/nix/packages/tagged.nix b/nix/packages/tagged.nix new file mode 100644 index 0000000..c773cf6 --- /dev/null +++ b/nix/packages/tagged.nix @@ -0,0 +1,15 @@ +{ mkDerivation, base, deepseq, lib, template-haskell, transformers +}: +mkDerivation { + pname = "tagged"; + version = "0.8.8"; + sha256 = "a083fa7835516203c168433a1c8dfc0290a94b05fedab566ad0640fc9137a6a7"; + revision = "1"; + editedCabalFile = "0chbxdppgpsrjqzf28z53x9wqwz0ncfimhfc6rr9knixvvxxx4wi"; + libraryHaskellDepends = [ + base deepseq template-haskell transformers + ]; + homepage = "http://github.com/ekmett/tagged"; + description = "Haskell 98 phantom types to avoid unsafely passing dummy arguments"; + license = lib.licenses.bsd3; +} diff --git a/nix/packages/th-abstraction.nix b/nix/packages/th-abstraction.nix new file mode 100644 index 0000000..abce3dd --- /dev/null +++ b/nix/packages/th-abstraction.nix @@ -0,0 +1,14 @@ +{ mkDerivation, base, containers, ghc-prim, lib, template-haskell +}: +mkDerivation { + pname = "th-abstraction"; + version = "0.7.0.0"; + sha256 = "b2854c612f2fa4adfa1ecbb4089a2211fd9cb3210aec17ba4a455ae486b22721"; + libraryHaskellDepends = [ + base containers ghc-prim template-haskell + ]; + testHaskellDepends = [ base containers template-haskell ]; + homepage = "https://github.com/glguy/th-abstraction"; + description = "Nicer interface for reified information about data types"; + license = lib.licenses.isc; +} diff --git a/nix/patches/aeson-2.1.2.1.patch b/nix/patches/aeson-2.1.2.1.patch new file mode 100644 index 0000000..d08277b --- /dev/null +++ b/nix/patches/aeson-2.1.2.1.patch @@ -0,0 +1,11 @@ +--- a/src/Data/Aeson/Internal/Text.hs 2001-09-08 18:46:40.000000000 -0700 ++++ b/src/Data/Aeson/Internal/Text.hs 2024-05-09 21:16:49.964743729 -0700 +@@ -8,5 +8,5 @@ + import qualified Data.Text as T + + #if MIN_VERSION_text(2,0,0) +-import Data.Text.Array (Array (..)) ++import Data.Text.Array + import qualified Data.Text.Internal as T (Text (..)) + + import qualified Data.ByteString.Short.Internal as SBS diff --git a/nix/patches/pantry-0.9.3.2.patch b/nix/patches/pantry-0.9.3.2.patch new file mode 100644 index 0000000..05e1b2f --- /dev/null +++ b/nix/patches/pantry-0.9.3.2.patch @@ -0,0 +1,13 @@ +--- a/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs 2023-11-02 09:37:03.000000000 -0700 ++++ b/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs 2024-05-14 12:44:48.812084736 -0700 +@@ -81,8 +81,9 @@ + -- NOTE: The only other exception defined in @http-client@ is @TimeoutTriggered@ + -- but it is currently disabled + wrapCustomEx :: ++ Throws SomeRemoteError => + (Throws HTTP.HttpException => IO a) +- -> (Throws SomeRemoteError => IO a) ++ -> IO a + wrapCustomEx = handleChecked (\(ex :: HTTP.HttpException) -> go ex) + where + go ex = throwChecked (SomeRemoteError ex) diff --git a/proto3-wire.cabal b/proto3-wire.cabal index 66dac05..0fb5a9b 100644 --- a/proto3-wire.cabal +++ b/proto3-wire.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.10 name: proto3-wire -version: 1.4.1 +version: 1.4.5 synopsis: A low-level implementation of the Protocol Buffers (version 3) wire format license: Apache-2.0 license-file: LICENSE @@ -35,19 +35,18 @@ library build-depends: base >=4.12 && <=5.0 - , bytestring >=0.10.6.0 && <0.12.0 + , bytestring >=0.10.6.0 && <0.13.0 , cereal >= 0.5.1 && <0.6 - , containers >=0.5 && < 0.7 - , deepseq ==1.4.* - , ghc-prim >=0.5.3 && <0.9 - , hashable <1.5 + , containers >=0.5 && <0.8 + , deepseq >=1.4 && <1.6 + , hashable <1.6 , parameterized >=0.5.0.0 && <1 - , primitive >=0.6.4 && <0.8 + , primitive >=0.6.4 && <0.10 , safe ==0.3.* - , template-haskell >= 2.15.0 && < 2.20 - , text >= 0.2 && <1.3 + , template-haskell >= 2.15.0 && < 2.23 + , text >= 0.2 && <2.2 , text-short ==0.1.* - , transformers >=0.5.6.2 && <0.6 + , transformers >=0.5.6.2 && <0.7 , unordered-containers >= 0.1.0.0 && <0.3 , vector >=0.12.0.2 && <0.14 , QuickCheck >=2.8 && <3.0 @@ -59,11 +58,13 @@ library Proto3.Wire.Class Proto3.Wire.Decode Proto3.Wire.Encode + Proto3.Wire.Encode.Repeated + Proto3.Wire.FoldR Proto3.Wire.Reverse + Proto3.Wire.Reverse.Internal Proto3.Wire.Reverse.Prim Proto3.Wire.Tutorial Proto3.Wire.Types - Proto3.Wire.Reverse.Internal other-modules: Proto3.Wire.Reverse.Width @@ -76,17 +77,18 @@ test-suite tests build-depends: base >=4.9 && <=5.0 - , bytestring >=0.10.6.0 && <0.12.0 + , bytestring >=0.10.6.0 && <0.13.0 , cereal >= 0.5.1 && <0.6 - , doctest >= 0.7.0 && <0.21.0 + , containers >=0.5 && <0.8 + , doctest >= 0.7.0 && <0.24.0 , proto3-wire , QuickCheck >=2.8 && <3.0 - , tasty >= 0.11 && <1.5 + , tasty >= 0.11 && <1.6 , tasty-hunit >= 0.9 && <0.11 - , tasty-quickcheck >= 0.8.4 && <0.11 - , text >= 0.2 && <1.3 + , tasty-quickcheck >= 0.8.4 && <0.12 + , text >= 0.2 && <2.2 , text-short ==0.1.* - , transformers >=0.5.6.2 && <0.6 + , transformers >=0.5.6.2 && <0.7 , vector >=0.12.0.2 && <0.14 benchmark bench @@ -105,4 +107,3 @@ benchmark bench , criterion , proto3-wire , random - diff --git a/shell.nix b/shell.nix index 86e14fd..5c2df74 100644 --- a/shell.nix +++ b/shell.nix @@ -1,15 +1,17 @@ -{ compiler ? "ghc8107" }: +{ compiler ? "ghc982", enableStack ? false }: let pkgs = import ./nix/pkgs.nix { inherit compiler; }; - proto3-wire = pkgs.haskellPackages.proto3-wire; +in pkgs.haskellPackages.shellFor { + packages = hpkgs: [ + hpkgs.proto3-wire + ]; -in proto3-wire.env.overrideAttrs (old: { - buildInputs = (old.buildInputs or []) ++ [ + nativeBuildInputs = [ pkgs.cabal-install - pkgs.stack - ]; -}) + pkgs.cabal2nix + ] ++ (if enableStack then [ pkgs.stack ] else []); +} diff --git a/src/Proto3/Wire/Decode.hs b/src/Proto3/Wire/Decode.hs index 20c1b04..2119a65 100644 --- a/src/Proto3/Wire/Decode.hs +++ b/src/Proto3/Wire/Decode.hs @@ -23,6 +23,7 @@ -- from the untyped 'Map' representation obtained from 'decodeWire'. {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -86,7 +87,9 @@ import Data.Bits import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Short as BS +#if !MIN_VERSION_base(4,20,0) import Data.Foldable ( foldl' ) +#endif import qualified Data.IntMap.Strict as M -- TODO intmap import Data.Maybe ( fromMaybe ) import Data.Serialize.Get ( Get, getWord8, getInt32le diff --git a/src/Proto3/Wire/Encode.hs b/src/Proto3/Wire/Encode.hs index c6c7f4f..1db1d6b 100644 --- a/src/Proto3/Wire/Encode.hs +++ b/src/Proto3/Wire/Encode.hs @@ -40,6 +40,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -54,10 +57,13 @@ module Proto3.Wire.Encode ( -- * `MessageBuilder` type MessageBuilder , reverseMessageBuilder + , etaMessageBuilder , vectorMessageBuilder , messageLength , toLazyByteString , unsafeFromLazyByteString + , unsafeFromByteString + , unsafeFromShortByteString -- * Standard Integers , int32 @@ -79,6 +85,7 @@ module Proto3.Wire.Encode , bool -- * Strings , bytes + , bytesIfNonempty , string , text , shortText @@ -87,17 +94,32 @@ module Proto3.Wire.Encode , shortByteString -- * Embedded Messages , embedded + -- * Folds + , repeatedMessageBuilder -- * Packed repeated fields , packedVarints , packedVarintsV + , packedInt32R + , packedInt64R + , packedUInt32R + , packedUInt64R + , packedSInt32R + , packedSInt64R + , packedBoolsR , packedBoolsV , packedFixed32 + , packedFixed32R , packedFixed32V , packedFixed64 + , packedFixed64R , packedFixed64V + , packedSFixed32R + , packedSFixed64R , packedFloats + , packedFloatsR , packedFloatsV , packedDoubles + , packedDoublesR , packedDoublesV -- * ZigZag codec , zigZagEncode @@ -118,13 +140,14 @@ import GHC.TypeLits ( KnownNat, Nat, type (+) ) import Parameterized.Data.Semigroup ( PNullary, PSemigroup(..), (&<>) ) import Parameterized.Data.Monoid ( PMEmpty(..) ) +import Proto3.Wire.Encode.Repeated ( ToRepeated, mapRepeated ) import qualified Proto3.Wire.Reverse as RB import qualified Proto3.Wire.Reverse.Prim as Prim import Proto3.Wire.Class import Proto3.Wire.Types -- $setup --- >>> :set -XOverloadedStrings -XOverloadedLists +-- >>> :set -XOverloadedStrings -XOverloadedLists -XTypeApplications -- >>> :module Proto3.Wire.Encode Proto3.Wire.Class Data.Word -- | zigzag-encoded numeric type. @@ -142,7 +165,7 @@ zigZagEncode i = (i `shiftL` 1) `xor` (i `shiftR` n) -- -- Use `toLazyByteString` when you're done assembling the `MessageBuilder` newtype MessageBuilder = MessageBuilder { unMessageBuilder :: RB.BuildR } - deriving (Monoid, Semigroup) + deriving newtype (Monoid, Semigroup) instance Show MessageBuilder where showsPrec prec builder = @@ -176,14 +199,21 @@ messageLength = fromIntegral . fst . RB.runBuildR . unMessageBuilder toLazyByteString :: MessageBuilder -> BL.ByteString toLazyByteString = RB.toLazyByteString . unMessageBuilder --- | This lets you cast an arbitrary `ByteString` to a `MessageBuilder`, whether +-- | This lets you cast an arbitrary 'BL.ByteString' to a `MessageBuilder`, whether -- or not the `ByteString` corresponds to a valid serialized protobuf message -- -- Do not use this function unless you know what you're doing because it lets --- you assemble malformed protobuf `MessageBuilder`s +-- you assemble malformed protobuf `MessageBuilder`s. unsafeFromLazyByteString :: BL.ByteString -> MessageBuilder -unsafeFromLazyByteString bytes' = - MessageBuilder { unMessageBuilder = RB.lazyByteString bytes' } +unsafeFromLazyByteString = coerce RB.lazyByteString + +-- | Like 'unsafeFromLazyByteString' only for strict 'B.ByteString's. +unsafeFromByteString :: B.ByteString -> MessageBuilder +unsafeFromByteString = coerce RB.byteString + +-- | Like 'unsafeFromLazyByteString' only for 'BS.ShortByteString's. +unsafeFromShortByteString :: BS.ShortByteString -> MessageBuilder +unsafeFromShortByteString = coerce RB.shortByteString newtype MessageBoundedPrim w = MessageBoundedPrim { unMessageBoundedPrim :: Prim.BoundedPrim w } @@ -276,7 +306,7 @@ fieldHeader = \num wt -> base128Varint64_inline -- a negative number, the resulting varint is always ten bytes long..." -- int32 :: FieldNumber -> Int32 -> MessageBuilder -int32 = \num i -> liftBoundedPrim $ +int32 = \(!num) i -> liftBoundedPrim $ fieldHeader num Varint &<> base128Varint64 (fromIntegral i) {-# INLINE int32 #-} @@ -289,7 +319,7 @@ int32 = \num i -> liftBoundedPrim $ -- >>> 1 `int64` (-42) -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\214\255\255\255\255\255\255\255\255\SOH" int64 :: FieldNumber -> Int64 -> MessageBuilder -int64 = \num i -> liftBoundedPrim $ +int64 = \(!num) i -> liftBoundedPrim $ fieldHeader num Varint &<> base128Varint64 (fromIntegral i) {-# INLINE int64 #-} @@ -300,7 +330,7 @@ int64 = \num i -> liftBoundedPrim $ -- >>> 1 `uint32` 42 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b*" uint32 :: FieldNumber -> Word32 -> MessageBuilder -uint32 = \num i -> liftBoundedPrim $ +uint32 = \(!num) i -> liftBoundedPrim $ fieldHeader num Varint &<> base128Varint32 i {-# INLINE uint32 #-} @@ -311,7 +341,7 @@ uint32 = \num i -> liftBoundedPrim $ -- >>> 1 `uint64` 42 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b*" uint64 :: FieldNumber -> Word64 -> MessageBuilder -uint64 = \num i -> liftBoundedPrim $ +uint64 = \(!num) i -> liftBoundedPrim $ fieldHeader num Varint &<> base128Varint64 i {-# INLINE uint64 #-} @@ -326,7 +356,7 @@ uint64 = \num i -> liftBoundedPrim $ -- >>> 1 `sint32` minBound -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\255\255\255\255\SI" sint32 :: FieldNumber -> Int32 -> MessageBuilder -sint32 = \num i -> +sint32 = \(!num) i -> uint32 num (fromIntegral (zigZagEncode i)) {-# INLINE sint32 #-} @@ -341,7 +371,7 @@ sint32 = \num i -> -- >>> 1 `sint64` minBound -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\255\255\255\255\255\255\255\255\255\SOH" sint64 :: FieldNumber -> Int64 -> MessageBuilder -sint64 = \num i -> +sint64 = \(!num) i -> uint64 num (fromIntegral (zigZagEncode i)) {-# INLINE sint64 #-} @@ -352,7 +382,7 @@ sint64 = \num i -> -- >>> 1 `fixed32` 42 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\r*\NUL\NUL\NUL" fixed32 :: FieldNumber -> Word32 -> MessageBuilder -fixed32 = \num i -> liftBoundedPrim $ +fixed32 = \(!num) i -> liftBoundedPrim $ fieldHeader num Fixed32 &<> MessageBoundedPrim (Prim.liftFixedPrim (Prim.word32LE i)) {-# INLINE fixed32 #-} @@ -364,7 +394,7 @@ fixed32 = \num i -> liftBoundedPrim $ -- >>> 1 `fixed64` 42 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\t*\NUL\NUL\NUL\NUL\NUL\NUL\NUL" fixed64 :: FieldNumber -> Word64 -> MessageBuilder -fixed64 = \num i -> liftBoundedPrim $ +fixed64 = \(!num) i -> liftBoundedPrim $ fieldHeader num Fixed64 &<> MessageBoundedPrim (Prim.liftFixedPrim (Prim.word64LE i)) {-# INLINE fixed64 #-} @@ -375,7 +405,7 @@ fixed64 = \num i -> liftBoundedPrim $ -- -- > 1 `sfixed32` (-42) sfixed32 :: FieldNumber -> Int32 -> MessageBuilder -sfixed32 = \num i -> liftBoundedPrim $ +sfixed32 = \(!num) i -> liftBoundedPrim $ fieldHeader num Fixed32 &<> MessageBoundedPrim (Prim.liftFixedPrim (Prim.int32LE i)) {-# INLINE sfixed32 #-} @@ -387,7 +417,7 @@ sfixed32 = \num i -> liftBoundedPrim $ -- >>> 1 `sfixed64` (-42) -- Proto3.Wire.Encode.unsafeFromLazyByteString "\t\214\255\255\255\255\255\255\255" sfixed64 :: FieldNumber -> Int64 -> MessageBuilder -sfixed64 = \num i -> liftBoundedPrim $ +sfixed64 = \(!num) i -> liftBoundedPrim $ fieldHeader num Fixed64 &<> MessageBoundedPrim (Prim.liftFixedPrim (Prim.int64LE i)) {-# INLINE sfixed64 #-} @@ -399,7 +429,7 @@ sfixed64 = \num i -> liftBoundedPrim $ -- >>> 1 `float` 3.14 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\r\195\245H@" float :: FieldNumber -> Float -> MessageBuilder -float = \num f -> liftBoundedPrim $ +float = \(!num) f -> liftBoundedPrim $ fieldHeader num Fixed32 &<> MessageBoundedPrim (Prim.liftFixedPrim (Prim.floatLE f)) {-# INLINE float #-} @@ -411,7 +441,7 @@ float = \num f -> liftBoundedPrim $ -- >>> 1 `double` 3.14 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\t\US\133\235Q\184\RS\t@" double :: FieldNumber -> Double -> MessageBuilder -double = \num d -> liftBoundedPrim $ +double = \(!num) d -> liftBoundedPrim $ fieldHeader num Fixed64 &<> MessageBoundedPrim (Prim.liftFixedPrim (Prim.doubleLE d)) {-# INLINE double #-} @@ -440,7 +470,7 @@ double = \num d -> liftBoundedPrim $ -- >>> 1 `enum` Triangle <> 2 `enum` Gap3 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\STX\DLE\ETX" enum :: ProtoEnum e => FieldNumber -> e -> MessageBuilder -enum = \num e -> liftBoundedPrim $ +enum = \(!num) e -> liftBoundedPrim $ fieldHeader num Varint &<> base128Varint32 (fromIntegral @Int32 @Word32 (fromProtoEnum e)) {-# INLINE enum #-} @@ -452,7 +482,7 @@ enum = \num e -> liftBoundedPrim $ -- >>> 1 `bool` True -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\SOH" bool :: FieldNumber -> Bool -> MessageBuilder -bool = \num b -> liftBoundedPrim $ +bool = \(!num) b -> liftBoundedPrim $ fieldHeader num Varint &<> MessageBoundedPrim (Prim.liftFixedPrim (Prim.word8 (fromIntegral (fromEnum b)))) @@ -461,12 +491,39 @@ bool = \num b -> liftBoundedPrim $ -- | Encode a sequence of octets as a field of type 'bytes'. -- +-- But unless the field is @optional@ or part of a @oneof@, +-- you may wish to to use 'bytesIfNonempty' to skip the field +-- when the payload built by the argument turns out to be empty. +-- +-- >>> 1 `bytes` (Proto3.Wire.Reverse.stringUtf8 "") +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\NUL" -- >>> 1 `bytes` (Proto3.Wire.Reverse.stringUtf8 "testing") -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" bytes :: FieldNumber -> RB.BuildR -> MessageBuilder -bytes num = embedded num . MessageBuilder +bytes !num = embedded num . MessageBuilder {-# INLINE bytes #-} +-- | Like 'bytes' but omits the field if it would be empty, which +-- is useful when the field is not @optional@ and is not part of +-- a @oneof@, and therefore may be omitted entirely when empty. +-- +-- >>> 1 `bytesIfNonempty` (Proto3.Wire.Reverse.stringUtf8 "") +-- Proto3.Wire.Encode.unsafeFromLazyByteString "" +-- >>> 1 `bytesIfNonempty` (Proto3.Wire.Reverse.stringUtf8 "testing") +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" +bytesIfNonempty :: FieldNumber -> RB.BuildR -> MessageBuilder +bytesIfNonempty !num bb = + MessageBuilder (RB.withLengthOf prefix bb) + where + prefix len + | 0 < len = Prim.liftBoundedPrim $ + unMessageBoundedPrim (fieldHeader num LengthDelimited) &<> + Prim.wordBase128LEVar (fromIntegral @Int @Word len) + | otherwise = + mempty + {-# INLINE prefix #-} +{-# INLINE bytesIfNonempty #-} + -- | Encode a UTF-8 string. -- -- For example: @@ -474,7 +531,7 @@ bytes num = embedded num . MessageBuilder -- >>> 1 `string` "testing" -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" string :: FieldNumber -> String -> MessageBuilder -string num = embedded num . MessageBuilder . RB.stringUtf8 +string !num = embedded num . MessageBuilder . RB.stringUtf8 {-# INLINE string #-} -- | Encode lazy `Text` as UTF-8 @@ -484,7 +541,7 @@ string num = embedded num . MessageBuilder . RB.stringUtf8 -- >>> 1 `text` "testing" -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" text :: FieldNumber -> Text.Lazy.Text -> MessageBuilder -text num = embedded num . MessageBuilder . RB.lazyTextUtf8 +text !num = embedded num . MessageBuilder . RB.lazyTextUtf8 {-# INLINE text #-} -- | Encode a `Text.Short.ShortText` as UTF-8. @@ -494,7 +551,7 @@ text num = embedded num . MessageBuilder . RB.lazyTextUtf8 -- >>> 1 `shortText` "testing" -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" shortText :: FieldNumber -> Text.Short.ShortText -> MessageBuilder -shortText num = embedded num . MessageBuilder . RB.shortTextUtf8 +shortText !num = embedded num . MessageBuilder . RB.shortTextUtf8 {-# INLINE shortText #-} -- | Encode a collection of bytes in the form of a strict 'B.ByteString'. @@ -504,7 +561,7 @@ shortText num = embedded num . MessageBuilder . RB.shortTextUtf8 -- >>> 1 `byteString` "testing" -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" byteString :: FieldNumber -> B.ByteString -> MessageBuilder -byteString num = embedded num . MessageBuilder . RB.byteString +byteString !num = embedded num . unsafeFromByteString {-# INLINE byteString #-} -- | Encode a lazy bytestring. @@ -514,7 +571,7 @@ byteString num = embedded num . MessageBuilder . RB.byteString -- >>> 1 `lazyByteString` "testing" -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" lazyByteString :: FieldNumber -> BL.ByteString -> MessageBuilder -lazyByteString num = embedded num . MessageBuilder . RB.lazyByteString +lazyByteString !num = embedded num . unsafeFromLazyByteString {-# INLINE lazyByteString #-} -- | Encode a `BS.ShortByteString`. @@ -524,22 +581,60 @@ lazyByteString num = embedded num . MessageBuilder . RB.lazyByteString -- >>> 1 `shortByteString` "testing" -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" shortByteString :: FieldNumber -> BS.ShortByteString -> MessageBuilder -shortByteString num = embedded num . MessageBuilder . RB.shortByteString +shortByteString !num = embedded num . unsafeFromShortByteString {-# INLINE shortByteString #-} --- | Encode varints in the space-efficient packed format. --- But consider 'packedVarintsV', which may be faster. +-- | Concatenates the given builders, which typically build fields within the same message. -- --- The values to be encoded are specified by mapping the elements of a vector. +-- For example: +-- +-- >>> repeatedMessageBuilder @[MessageBuilder] [1 `bool` True, 2 `int32` 42] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\SOH\DLE*" +repeatedMessageBuilder :: ToRepeated c MessageBuilder => c -> MessageBuilder +repeatedMessageBuilder = + etaMessageBuilder (MessageBuilder . RB.repeatedBuildR . mapRepeated reverseMessageBuilder) +{-# INLINE repeatedMessageBuilder #-} + +-- | Encodes a packed repeated field whose elements may vary in width. +packedVariableWidthFieldR :: + ToRepeated c a => (a -> RB.BuildR) -> FieldNumber -> c -> MessageBuilder +packedVariableWidthFieldR f !num = + etaMessageBuilder (embedded num . MessageBuilder . RB.repeatedBuildR . mapRepeated f) +{-# INLINE packedVariableWidthFieldR #-} + +-- | Encodes a packed repeated field whose elements never vary in width. +packedFixedWidthFieldR :: + (ToRepeated c a, KnownNat w) => (a -> Prim.FixedPrim w) -> FieldNumber -> c -> MessageBuilder +packedFixedWidthFieldR f !num = + etaMessageBuilder (embedded num . MessageBuilder . RB.repeatedFixedPrimR . mapRepeated f) +{-# INLINE packedFixedWidthFieldR #-} + +-- | Encode varints in the space-efficient packed format. +-- But consider 'packedVarintsV' or 'packedVarintsR', either of which may be faster. -- -- >>> packedVarints 1 [1, 2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\ETX\SOH\STX\ETX" packedVarints :: Foldable f => FieldNumber -> f Word64 -> MessageBuilder -packedVarints num = - etaMessageBuilder - (embedded num . foldMap (liftBoundedPrim . base128Varint64)) +packedVarints !num = etaMessageBuilder (embedded num . payload) + where + payload = foldMap (liftBoundedPrim . base128Varint64) {-# INLINE packedVarints #-} +-- | A faster but more specialized variant of 'packedVarints'. +-- +-- Generalizes 'packedVarintsV', provided that any new instance +-- of 'Vector' is given a corresponding instance of 'ToRepeated'. +packedVarints64R :: ToRepeated c Word64 => FieldNumber -> c -> MessageBuilder +packedVarints64R = packedVariableWidthFieldR RB.word64Base128LEVar +{-# INLINE packedVarints64R #-} + +-- | Like 'packedVarints64R' but supports only 32-bit inputs, +-- which reduces on executable size in situations where we do +-- not need to support larger values. +packedVarints32R :: ToRepeated c Word32 => FieldNumber -> c -> MessageBuilder +packedVarints32R = packedVariableWidthFieldR RB.word32Base128LEVar +{-# INLINE packedVarints32R #-} + -- | A faster but more specialized variant of: -- -- > \f num -> packedVarints num . fmap f @@ -548,36 +643,128 @@ packedVarints num = -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\ETX\SOH\STX\ETX" packedVarintsV :: Vector v a => (a -> Word64) -> FieldNumber -> v a -> MessageBuilder -packedVarintsV f num = - embedded num . vectorMessageBuilder (liftBoundedPrim . base128Varint64 . f) +packedVarintsV f !num = embedded num . payload + where + payload = vectorMessageBuilder (liftBoundedPrim . base128Varint64 . f) {-# INLINE packedVarintsV #-} +-- | Encodes a packed repeated @int32@ field. +-- +-- >>> packedInt32R @[_] 1 [42, -42] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\v*\214\255\255\255\255\255\255\255\255\SOH" +-- +-- NOTE: Protobuf encoding converts an @int32@ to a 64-bit unsigned value +-- before encoding it, not a 32-bit value (which would be more efficient). +-- +-- To quote the specification: "If you use int32 or int64 as the type for +-- a negative number, the resulting varint is always ten bytes long..." +-- +packedInt32R :: ToRepeated c Int32 => FieldNumber -> c -> MessageBuilder +packedInt32R !num xs = + packedVarints64R num (mapRepeated (fromIntegral @Int32 @Word64) xs) +{-# INLINE packedInt32R #-} + +-- | Encodes a packed repeated @int64@ field. +-- +-- For example: +-- +-- >>> packedInt64R @[_] 1 [42, -42] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\v*\214\255\255\255\255\255\255\255\255\SOH" +packedInt64R :: ToRepeated c Int64 => FieldNumber -> c -> MessageBuilder +packedInt64R !num xs = + packedVarints64R num (mapRepeated (fromIntegral @Int64 @Word64) xs) +{-# INLINE packedInt64R #-} + +-- | Encodes a packed repeated @uint32@ field. +-- +-- For example: +-- +-- >>> packedUInt32R @[_] 1 [42, 43, maxBound] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\a*+\255\255\255\255\SI" +packedUInt32R :: ToRepeated c Word32 => FieldNumber -> c -> MessageBuilder +packedUInt32R = packedVarints32R +{-# INLINE packedUInt32R #-} + +-- | Encodes a packed repeated @uint64@ field. +-- +-- For example: +-- +-- >>> packedUInt64R @[_] 1 [42, 43, maxBound] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f*+\255\255\255\255\255\255\255\255\255\SOH" +packedUInt64R :: ToRepeated c Word64 => FieldNumber -> c -> MessageBuilder +packedUInt64R = packedVarints64R +{-# INLINE packedUInt64R #-} + +-- | Encodes a packed repeated @sint32@ field. +-- +-- For example: +-- +-- >>> packedSInt32R @[_] 1 [-42, maxBound, minBound] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\vS\254\255\255\255\SI\255\255\255\255\SI" +packedSInt32R :: ToRepeated c Int32 => FieldNumber -> c -> MessageBuilder +packedSInt32R !num xs = + packedVarints32R num (mapRepeated (fromIntegral @Int32 @Word32 . zigZagEncode) xs) +{-# INLINE packedSInt32R #-} + +-- | Encodes a packed repeated @sint64@ field. +-- +-- For example: +-- +-- >>> packedSInt64R @[_] 1 [-42, maxBound, minBound] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\NAKS\254\255\255\255\255\255\255\255\255\SOH\255\255\255\255\255\255\255\255\255\SOH" +packedSInt64R :: ToRepeated c Int64 => FieldNumber -> c -> MessageBuilder +packedSInt64R !num xs = + packedVarints64R num (mapRepeated (fromIntegral @Int64 @Word64 . zigZagEncode) xs) +{-# INLINE packedSInt64R #-} + -- | A faster but more specialized variant of: -- --- > packedVarintsV (fromIntegral . fromEnum) num +-- > \f -> packedVarintsR (fromIntegral . fromEnum . f) +-- +-- Generalizes 'packedBoolsV', provided that any new instance +-- of 'Vector' is given a corresponding instance of 'ToRepeated'. +-- +-- >>> packedBoolsR @[_] 1 [True, False] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\STX\SOH\NUL" +packedBoolsR :: ToRepeated c Bool => FieldNumber -> c -> MessageBuilder +packedBoolsR = packedFixedWidthFieldR (Prim.word8 . fromIntegral . fromEnum) +{-# INLINE packedBoolsR #-} + +-- | A faster but more specialized variant of: +-- +-- > \f -> packedVarintsV (fromIntegral . fromEnum . f) -- -- >>> packedBoolsV not 1 ([False, True] :: Data.Vector.Vector Bool) -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\STX\SOH\NUL" packedBoolsV :: Vector v a => (a -> Bool) -> FieldNumber -> v a -> MessageBuilder -packedBoolsV f num = - embedded num . MessageBuilder . Prim.vectorFixedPrim op +packedBoolsV f !num = embedded num . MessageBuilder . payload where - op = Prim.word8 . fromIntegral . fromEnum . f + payload = Prim.vectorFixedPrim (Prim.word8 . fromIntegral . fromEnum . f) {-# INLINE packedBoolsV #-} -- | Encode fixed-width Word32s in the space-efficient packed format. --- But consider 'packedFixed32V', which may be faster. --- --- The values to be encoded are specified by mapping the elements of a vector. +-- But consider 'packedFixed32V' or 'packedFixed32R', either of which may be faster. -- -- >>> packedFixed32 1 [1, 2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\SOH\NUL\NUL\NUL\STX\NUL\NUL\NUL\ETX\NUL\NUL\NUL" packedFixed32 :: Foldable f => FieldNumber -> f Word32 -> MessageBuilder -packedFixed32 num = - etaMessageBuilder (embedded num . foldMap (MessageBuilder . RB.word32LE)) +packedFixed32 !num = etaMessageBuilder (embedded num . payload) + where + payload = foldMap (MessageBuilder . RB.word32LE) {-# INLINE packedFixed32 #-} +-- | A faster but more specialized variant of 'packedFixed32'. +-- +-- Generalizes 'packedFixed32V', provided that any new instance +-- of 'Vector' is given a corresponding instance of 'ToRepeated'. +-- +-- >>> packedFixed32R @[_] 1 [1, 2, 3] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\SOH\NUL\NUL\NUL\STX\NUL\NUL\NUL\ETX\NUL\NUL\NUL" +packedFixed32R :: ToRepeated c Word32 => FieldNumber -> c -> MessageBuilder +packedFixed32R = packedFixedWidthFieldR Prim.word32LE +{-# INLINE packedFixed32R #-} + -- | A faster but more specialized variant of: -- -- > \f num -> packedFixed32 num . fmap f @@ -586,22 +773,32 @@ packedFixed32 num = -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\SOH\NUL\NUL\NUL\STX\NUL\NUL\NUL\ETX\NUL\NUL\NUL" packedFixed32V :: Vector v a => (a -> Word32) -> FieldNumber -> v a -> MessageBuilder -packedFixed32V f num = - embedded num . MessageBuilder . Prim.vectorFixedPrim (Prim.word32LE . f) +packedFixed32V f !num = etaMessageBuilder (embedded num . payload) + where + payload = MessageBuilder . Prim.vectorFixedPrim (Prim.word32LE . f) {-# INLINE packedFixed32V #-} --- | Encode fixed-width Word64s in the space-efficient packed format. --- But consider 'packedFixed64V', which may be faster. --- --- The values to be encoded are specified by mapping the elements of a vector. +-- But consider 'packedFixed64V' or 'packedFixed64R', either of which may be faster. -- -- >>> packedFixed64 1 [1, 2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\STX\NUL\NUL\NUL\NUL\NUL\NUL\NUL\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NUL" packedFixed64 :: Foldable f => FieldNumber -> f Word64 -> MessageBuilder -packedFixed64 num = - etaMessageBuilder (embedded num . foldMap (MessageBuilder . RB.word64LE)) +packedFixed64 !num = etaMessageBuilder (embedded num . payload) + where + payload = foldMap (MessageBuilder . RB.word64LE) {-# INLINE packedFixed64 #-} +-- | A faster but more specialized variant of 'packedFixed64'. +-- +-- Generalizes 'packedFixed64V', provided that any new instance +-- of 'Vector' is given a corresponding instance of 'ToRepeated'. +-- +-- >>> packedFixed64R @[_] 1 [1, 2, 3] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\STX\NUL\NUL\NUL\NUL\NUL\NUL\NUL\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NUL" +packedFixed64R :: ToRepeated c Word64 => FieldNumber -> c -> MessageBuilder +packedFixed64R = packedFixedWidthFieldR Prim.word64LE +{-# INLINE packedFixed64R #-} + -- | A faster but more specialized variant of: -- -- > \f num -> packedFixed64 num . fmap f @@ -610,20 +807,53 @@ packedFixed64 num = -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\STX\NUL\NUL\NUL\NUL\NUL\NUL\NUL\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NUL" packedFixed64V :: Vector v a => (a -> Word64) -> FieldNumber -> v a -> MessageBuilder -packedFixed64V f num = - embedded num . MessageBuilder . Prim.vectorFixedPrim (Prim.word64LE . f) +packedFixed64V f !num = etaMessageBuilder (embedded num . payload) + where + payload = MessageBuilder . Prim.vectorFixedPrim (Prim.word64LE . f) {-# INLINE packedFixed64V #-} +-- | Encodes a packed repeated @sfixed32@ field. +-- +-- For example: +-- +-- >>> packedSFixed32R @[_] 1 [1, -2, 3] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\SOH\NUL\NUL\NUL\254\255\255\255\ETX\NUL\NUL\NUL" +packedSFixed32R :: ToRepeated c Int32 => FieldNumber -> c -> MessageBuilder +packedSFixed32R = packedFixedWidthFieldR Prim.int32LE +{-# INLINE packedSFixed32R #-} + +-- | Encodes a packed repeated @sfixed64@ field. +-- +-- For example: +-- +-- >>> packedSFixed64R @[_] 1 [1, -2, 3] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\254\255\255\255\255\255\255\255\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NUL" +packedSFixed64R :: ToRepeated c Int64 => FieldNumber -> c -> MessageBuilder +packedSFixed64R = packedFixedWidthFieldR Prim.int64LE +{-# INLINE packedSFixed64R #-} + -- | Encode floats in the space-efficient packed format. --- But consider 'packedFloatsV', which may be faster. +-- But consider 'packedFloatsV' or 'packedFloatsR', either of which may be faster. -- -- >>> 1 `packedFloats` [1, 2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\NUL\NUL\128?\NUL\NUL\NUL@\NUL\NUL@@" packedFloats :: Foldable f => FieldNumber -> f Float -> MessageBuilder -packedFloats num = - etaMessageBuilder (embedded num . foldMap (MessageBuilder . RB.floatLE)) +packedFloats !num = etaMessageBuilder (embedded num . payload) + where + payload = foldMap (MessageBuilder . RB.floatLE) {-# INLINE packedFloats #-} +-- | A faster but more specialized variant of 'packedFloats'. +-- +-- Generalizes 'packedFloatsV', provided that any new instance +-- of 'Vector' is given a corresponding instance of 'ToRepeated'. +-- +-- >>> packedFloatsR @[_] 1 [1, 2, 3] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\NUL\NUL\128?\NUL\NUL\NUL@\NUL\NUL@@" +packedFloatsR :: ToRepeated c Float => FieldNumber -> c -> MessageBuilder +packedFloatsR = packedFixedWidthFieldR Prim.floatLE +{-# INLINE packedFloatsR #-} + -- | A faster but more specialized variant of: -- -- > \f num -> packedFloats num . fmap f @@ -632,20 +862,33 @@ packedFloats num = -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\NUL\NUL\128?\NUL\NUL\NUL@\NUL\NUL@@" packedFloatsV :: Vector v a => (a -> Float) -> FieldNumber -> v a -> MessageBuilder -packedFloatsV f num = - embedded num . MessageBuilder . Prim.vectorFixedPrim (Prim.floatLE . f) +packedFloatsV f !num = etaMessageBuilder (embedded num . payload) + where + payload = MessageBuilder . Prim.vectorFixedPrim (Prim.floatLE . f) {-# INLINE packedFloatsV #-} -- | Encode doubles in the space-efficient packed format. --- But consider 'packedDoublesV', which may be faster. +-- But consider 'packedDoublesV' or 'packedDoublesR', either of which may be faster. -- -- >>> 1 `packedDoubles` [1, 2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\NUL\NUL\NUL\NUL\NUL\NUL\240?\NUL\NUL\NUL\NUL\NUL\NUL\NUL@\NUL\NUL\NUL\NUL\NUL\NUL\b@" packedDoubles :: Foldable f => FieldNumber -> f Double -> MessageBuilder -packedDoubles num = - etaMessageBuilder (embedded num . foldMap (MessageBuilder . RB.doubleLE)) +packedDoubles !num = etaMessageBuilder (embedded num . payload) + where + payload = foldMap (MessageBuilder . RB.doubleLE) {-# INLINE packedDoubles #-} +-- | A faster but more specialized variant of 'packedDoubles'. +-- +-- Generalizes 'packedDoublesV', provided that any new instance +-- of 'Vector' is given a corresponding instance of 'ToRepeated'. +-- +-- >>> packedDoublesR @[_] 1 [1, 2, 3] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\NUL\NUL\NUL\NUL\NUL\NUL\240?\NUL\NUL\NUL\NUL\NUL\NUL\NUL@\NUL\NUL\NUL\NUL\NUL\NUL\b@" +packedDoublesR :: ToRepeated c Double => FieldNumber -> c -> MessageBuilder +packedDoublesR = packedFixedWidthFieldR Prim.doubleLE +{-# INLINE packedDoublesR #-} + -- | A faster but more specialized variant of: -- -- > \f num -> packedDoubles num . fmap f @@ -654,8 +897,9 @@ packedDoubles num = -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\NUL\NUL\NUL\NUL\NUL\NUL\240?\NUL\NUL\NUL\NUL\NUL\NUL\NUL@\NUL\NUL\NUL\NUL\NUL\NUL\b@" packedDoublesV :: Vector v a => (a -> Double) -> FieldNumber -> v a -> MessageBuilder -packedDoublesV f num = - embedded num . MessageBuilder . Prim.vectorFixedPrim (Prim.doubleLE . f) +packedDoublesV f !num = etaMessageBuilder (embedded num . payload) + where + payload = MessageBuilder . Prim.vectorFixedPrim (Prim.doubleLE . f) {-# INLINE packedDoublesV #-} -- | Encode an embedded message. @@ -665,13 +909,16 @@ packedDoublesV f num = -- -- For example: -- +-- >>> 1 `embedded` mempty +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\NUL" -- >>> 1 `embedded` (1 `string` "this message" <> 2 `string` " is embedded") -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\FS\n\fthis message\DC2\f is embedded" embedded :: FieldNumber -> MessageBuilder -> MessageBuilder -embedded = \num (MessageBuilder bb) -> - MessageBuilder (RB.withLengthOf (Prim.liftBoundedPrim . prefix num) bb) +embedded = \(!num) (MessageBuilder bb) -> + MessageBuilder (RB.withLengthOf (prefix num) bb) where - prefix num len = + prefix !num len = Prim.liftBoundedPrim $ unMessageBoundedPrim (fieldHeader num LengthDelimited) &<> Prim.wordBase128LEVar (fromIntegral @Int @Word len) + {-# INLINE prefix #-} {-# INLINE embedded #-} diff --git a/src/Proto3/Wire/Encode/Repeated.hs b/src/Proto3/Wire/Encode/Repeated.hs new file mode 100644 index 0000000..4fe2595 --- /dev/null +++ b/src/Proto3/Wire/Encode/Repeated.hs @@ -0,0 +1,185 @@ +{- + Copyright 2025 Arista Networks + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +-- | Presents right-associative folds as 'Foldable' sequences. +module Proto3.Wire.Encode.Repeated + ( Repeated(..) + , nullRepeated + , ToRepeated(..) + , mapRepeated + ) where + +import Data.Functor.Identity (Identity(..)) +import Data.IntMap.Lazy qualified +import Data.IntSet qualified +import Data.Kind (Type) +import Data.List.NonEmpty qualified +import Data.Map.Lazy qualified +import Data.Sequence qualified +import Data.Set qualified +import Data.Vector qualified +import Data.Vector.Storable qualified +import Data.Vector.Unboxed qualified +import Foreign (Storable) +import GHC.Exts (Constraint, TYPE) +import GHC.Generics (Generic) +import Proto3.Wire.FoldR (FoldR(..), fromFoldR) + +-- | Expresses a sequence of values /in reverse order/ for encoding as a repeated field. +type Repeated :: forall er . TYPE er -> Type +data Repeated e = ReverseRepeated + { countRepeated :: Maybe Int + -- ^ Optionally predicts the number of elements in the sequence. Predict + -- the count only when it is practical to do so accurately and quickly. + -- + -- A prediction that is too low causes undefined behavior--possibly + -- a crash. A length prediction that is too high overallocates + -- output space, as if the sequence really were that length. + , reverseRepeated :: FoldR e + -- ^ A lazy right-associative fold over the /reverse/ + -- of the desired sequence of field values. + -- + -- Design Note: We could have used a lazy left-associative fold, but + -- vectors perform such folds using a left-to-right iteration, instead + -- of the right-to-left iteration that would yield best performance. + -- + -- Therefore in order to avoid accidental misuse of 'foldl', we ask + -- for sequence reversal explicitly. Thanks to vector fusion rules, + -- it is fast to 'foldr' on the result of reversing a vector. + } + deriving stock (Functor, Generic) + +deriving stock instance Eq e => Eq (Repeated e) +deriving stock instance Read e => Read (Repeated e) +deriving stock instance Show e => Show (Repeated e) + +nullRepeated :: Repeated e -> Bool +nullRepeated c = null (reverseRepeated c) +{-# INLINE nullRepeated #-} + +-- | For each container type, specifies the optimal method for reverse iteration. +type ToRepeated :: forall cr . TYPE cr -> forall er . TYPE er -> Constraint +class ToRepeated c e | c -> e + where + -- | Converts to a reverse iteration over the elements. + toRepeated :: c -> Repeated e + +instance forall er (e :: TYPE er) . + ToRepeated (Repeated e) e + where + toRepeated = id + {-# INLINE toRepeated #-} + +instance ToRepeated (Identity a) a + where + toRepeated x = ReverseRepeated (Just 1) (FoldR (\f z -> f (runIdentity x) z)) + {-# INLINE toRepeated #-} + +instance ToRepeated [a] a + where + toRepeated xs = ReverseRepeated Nothing (FoldR (\f z -> foldl (flip f) z xs)) + -- Unavoidably reads to the end of the list before presenting the last element. + {-# INLINE toRepeated #-} + +instance ToRepeated (Data.List.NonEmpty.NonEmpty a) a + where + toRepeated xs = ReverseRepeated Nothing (FoldR (\f z -> foldl (flip f) z xs)) + -- Unavoidably reads to the end of the list before presenting the last element. + {-# INLINE toRepeated #-} + +instance ToRepeated (Data.Vector.Vector a) a + where + toRepeated xs = ReverseRepeated + (Just (Data.Vector.length xs)) + (fromFoldR (Data.Vector.reverse xs)) + -- Vector fusion should convert this to right-to-left iteration. + {-# INLINE toRepeated #-} + +instance Storable a => + ToRepeated (Data.Vector.Storable.Vector a) a + where + toRepeated xs = ReverseRepeated + (Just (Data.Vector.Storable.length xs)) + (FoldR (\f z -> Data.Vector.Storable.foldr f z (Data.Vector.Storable.reverse xs))) + -- Vector fusion should convert this to right-to-left iteration. + {-# INLINE toRepeated #-} + +instance Data.Vector.Unboxed.Unbox a => + ToRepeated (Data.Vector.Unboxed.Vector a) a + where + toRepeated xs = ReverseRepeated + (Just (Data.Vector.Unboxed.length xs)) + (FoldR (\f z -> Data.Vector.Unboxed.foldr f z (Data.Vector.Unboxed.reverse xs))) + -- Vector fusion should convert this to right-to-left iteration. + {-# INLINE toRepeated #-} + +instance ToRepeated (Data.Sequence.Seq a) a + where + toRepeated xs = ReverseRepeated + (Just (Data.Sequence.length xs)) + (FoldR (\f z -> foldl (flip f) z xs)) + -- Should present the last element without having to read through the whole sequence. + {-# INLINE toRepeated #-} + +instance ToRepeated (Data.Set.Set a) a + where + toRepeated xs = ReverseRepeated + (Just (Data.Set.size xs)) + (FoldR (\f z -> foldl (flip f) z xs)) + -- Should present the last element without having to read through the whole sequence. + {-# INLINE toRepeated #-} + +instance ToRepeated Data.IntSet.IntSet Int + where + toRepeated xs = ReverseRepeated Nothing (FoldR (\f z -> Data.IntSet.foldl (flip f) z xs)) + -- Should present the last element without having to read through the whole sequence. + {-# INLINE toRepeated #-} + +instance ToRepeated (Data.Map.Lazy.Map k a) (k, a) + where + toRepeated xs = ReverseRepeated + (Just (Data.Map.Lazy.size xs)) + (FoldR (\f z -> Data.Map.Lazy.foldlWithKey (\a k v -> f (k, v) a) z xs)) + -- Should present the last key-value pair without having to read through the whole map. + {-# INLINE toRepeated #-} + +instance ToRepeated (Data.IntMap.Lazy.IntMap a) (Int, a) + where + toRepeated xs = ReverseRepeated + Nothing + (FoldR (\f z -> Data.IntMap.Lazy.foldlWithKey (\a k v -> f (k, v) a) z xs)) + -- Should present the last key-value pair without having to read through the whole map. + {-# INLINE toRepeated #-} + +-- | A convenience function that maps a function over a sequence, +-- provided that the relevant types are all lifted. +mapRepeated :: + forall (c :: Type) (e :: Type) (a :: Type) . ToRepeated c e => (e -> a) -> c -> Repeated a +mapRepeated f xs = fmap f (toRepeated xs) +{-# INLINE mapRepeated #-} diff --git a/src/Proto3/Wire/FoldR.hs b/src/Proto3/Wire/FoldR.hs new file mode 100644 index 0000000..314e346 --- /dev/null +++ b/src/Proto3/Wire/FoldR.hs @@ -0,0 +1,80 @@ +{- + Copyright 2025 Arista Networks + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Presents right-associative folds as 'Foldable' sequences. +module Proto3.Wire.FoldR + ( FoldR(..) + , fromFoldR + ) where + +import Data.Foldable qualified +import Data.Kind (Type) +import GHC.Exts (TYPE) +import GHC.Exts qualified +import Text.Read (Read(..)) + +-- | Presents a right-associative fold as a 'Foldable' sequence. +-- +-- Similar to the @FRList@ example in the documentation for "Data.Foldable", +-- but for generality the element type may be unlifted. For compatibility +-- with the 'Foldable' type class and to avoid limitations on runtime +-- representation polymorphism, the fold supports only lifted results. +newtype FoldR (a :: TYPE r) = FoldR { applyFoldR :: forall (b :: Type) . (a -> b -> b) -> b -> b } + deriving stock (Functor) + +instance Foldable FoldR + where + foldr f z xs = applyFoldR xs f z + +instance GHC.Exts.IsList (FoldR a) + where + type Item (FoldR a) = a + fromList = fromFoldR + toList = Data.Foldable.toList + +instance Eq a => + Eq (FoldR a) + where + x == y = GHC.Exts.toList x == GHC.Exts.toList y + +instance Ord a => + Ord (FoldR a) + where + x <= y = GHC.Exts.toList x <= GHC.Exts.toList y + x `compare` y = GHC.Exts.toList x `compare` GHC.Exts.toList y + +instance Read a => + Read (FoldR a) + where + readPrec = fmap GHC.Exts.fromList readPrec + +instance Show a => + Show (FoldR a) + where + showsPrec d = showsPrec d . GHC.Exts.toList + +-- | Creates a 'FoldR' from the 'foldr' of the given 'Foldable' sequence. +fromFoldR :: Foldable t => t a -> FoldR a +fromFoldR xs = FoldR { applyFoldR = \f z -> foldr f z xs } diff --git a/src/Proto3/Wire/Reverse.hs b/src/Proto3/Wire/Reverse.hs index 4501b04..91e57ac 100644 --- a/src/Proto3/Wire/Reverse.hs +++ b/src/Proto3/Wire/Reverse.hs @@ -25,6 +25,9 @@ -- [6,0,0,0,42,206,187] {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} module Proto3.Wire.Reverse ( -- * `BuildR` type @@ -78,6 +81,8 @@ module Proto3.Wire.Reverse -- * Helpful combinators , foldlRVector + , repeatedBuildR + , repeatedFixedPrimR -- * Exported for testing purposes only. , testWithUnused @@ -95,15 +100,28 @@ import Data.Char ( ord ) import Data.Int ( Int8, Int16, Int32, Int64 ) import qualified Data.Text as T import qualified Data.Text.Internal as TI -import qualified Data.Text.Internal.Fusion as TIF import qualified Data.Text.Lazy as TL import qualified Data.Text.Short as TS import Data.Vector.Generic ( Vector ) import Data.Word ( Word8, Word16, Word32, Word64 ) -import Foreign ( castPtr ) +import Foreign ( castPtr, copyBytes ) +import GHC.Exts ( Addr#, Int(..), Int# ) +#if !MIN_VERSION_bytestring(0,11,0) +import GHC.Exts ( plusAddr# ) +#endif +import GHC.ForeignPtr ( ForeignPtr(..), ForeignPtrContents ) +import GHC.TypeLits ( KnownNat ) +import Proto3.Wire.Encode.Repeated ( Repeated(..), ToRepeated(..) ) import Proto3.Wire.Reverse.Internal import qualified Proto3.Wire.Reverse.Prim as Prim +#if MIN_VERSION_text(2,0,0) +import Control.Monad.ST.Unsafe (unsafeSTToIO) +import qualified Data.Text.Array as TA +#else +import qualified Data.Text.Internal.Fusion as TIF +#endif + -- $setup -- >>> :set -XOverloadedStrings -- >>> :module Proto3.Wire.Reverse @@ -128,15 +146,32 @@ toLazyByteString = snd . runBuildR -- >>> byteString "ABC" -- Proto3.Wire.Reverse.lazyByteString "ABC" byteString :: B.ByteString -> BuildR -byteString bs = withUnused $ \unused -> - let len = B.length bs in - if len <= unused - then - unsafeConsume len $ \dst -> - BU.unsafeUseAsCString bs $ \src -> - BI.memcpy dst (castPtr src) len - else - prependChunk bs +#if MIN_VERSION_bytestring(0,11,0) +byteString (BI.BS (ForeignPtr ad ct) (I# len)) = byteStringImpl ad ct len +#else +byteString (BI.PS (ForeignPtr ad ct) (I# off) (I# len)) = byteStringImpl (plusAddr# ad off) ct len +#endif +{-# INLINE byteString #-} + +byteStringImpl :: Addr# -> ForeignPtrContents -> Int# -> BuildR +byteStringImpl ad ct len = +#if MIN_VERSION_bytestring(0,11,0) + let bs = BI.BS (ForeignPtr ad ct) (I# len) in +#else + let bs = BI.PS (ForeignPtr ad ct) 0 (I# len) in +#endif + withUnused $ \unused -> + if I# len <= unused + then + unsafeConsume (I# len) $ \dst -> + BU.unsafeUseAsCString bs $ \src -> + copyBytes dst (castPtr src) (I# len) + else + prependChunk bs +{-# NOINLINE [1] byteStringImpl #-} +{-# RULES + "byteStringImpl/empty" forall ad ct . byteStringImpl ad ct 0# = mempty + #-} -- | Convert a lazy `BL.ByteString` to a `BuildR` -- @@ -170,9 +205,13 @@ lazyByteString = etaBuildR $ scan (ReverseChunks BL.empty) (prepend (ReverseChunks cs) <>) $ unsafeConsume len $ \dst -> BU.unsafeUseAsCString c $ \src -> - BI.memcpy dst (castPtr src) len + copyBytes dst (castPtr src) len else prependReverseChunks (ReverseChunks(BLI.Chunk c cs)) +{-# NOINLINE [1] lazyByteString #-} +{-# RULES + "lazyByteString/empty" lazyByteString BLI.Empty = mempty + #-} -- | Convert a `BS.ShortByteString` to a `BuildR` -- @@ -508,7 +547,26 @@ stringUtf8 = foldMap charUtf8 -- >>> textUtf8 "←↑→↓" -- Proto3.Wire.Reverse.lazyByteString "\226\134\144\226\134\145\226\134\146\226\134\147" textUtf8 :: T.Text -> BuildR +#if MIN_VERSION_text(2,0,0) +textUtf8 = etaBuildR $ \(TI.Text arr off word8Count) -> + -- For version 2 of the "text" package, the in-memory + -- representation is UTF-8. We can just write it out. + withUnused $ \unused -> + if word8Count <= unused + then + writeChunk arr off word8Count + else + let rest = word8Count - unused in + writeChunk arr off rest <> + reallocate rest <> writeChunk arr (off + rest) unused + where + writeChunk src off len = + unsafeConsume len $ \dst -> unsafeSTToIO $ + TA.copyToPointer src off dst len +#else textUtf8 = etaBuildR $ \txt@(TI.Text _ _ word16Count) -> + -- For version 1 of the "text" package, the in-memory + -- representation is UTF-16. We must transcode to UTF-8. case TIF.reverseStream txt of TIF.Stream next t0 _ -> ensure bound (go t0) where @@ -533,6 +591,7 @@ textUtf8 = etaBuildR $ \txt@(TI.Text _ _ word16Count) -> TIF.Skip t2 -> go t2 TIF.Yield !ch t2 -> go t2 <> Prim.unsafeBuildBoundedPrim (Prim.charUtf8 ch) +#endif -- | Convert a Unicode lazy `TL.Text` to a `BuildR` using a @UTF-8@ encoding -- @@ -797,10 +856,41 @@ word64Base128LEVar_inline = \x -> {-# INLINE word64Base128LEVar_inline #-} -- | Essentially 'foldMap', but iterates right to left for efficiency. +-- +-- See also: 'repeatedBuildR' vectorBuildR :: Vector v a => (a -> BuildR) -> v a -> BuildR vectorBuildR f = etaBuildR (foldlRVector (\acc x -> acc <> f x) mempty) {-# INLINE vectorBuildR #-} +-- | Concatenates the given builders, iterating right to left where practical. +-- +-- For example: +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (repeatedBuildR (map word8 [42,67]))) +-- [42,67] +-- +-- See also: 'repeatedFixedPrimR', 'vectorBuildR' +repeatedBuildR :: ToRepeated c BuildR => c -> BuildR +repeatedBuildR = etaBuildR (foldr (flip (<>)) mempty . reverseRepeated . toRepeated) +{-# INLINE repeatedBuildR #-} + +-- | Concatenates the given fixed-width primitives, iterating right to left where practical +-- and consolidating space checks if the number of primitives has been predicted. +-- +-- For example: +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (repeatedFixedPrimR (map Proto3.Wire.Reverse.Prim.word8 [42,67]))) +-- [42,67] +-- +-- See also: 'repeatedBuildR' +repeatedFixedPrimR :: (ToRepeated c (Prim.FixedPrim w), KnownNat w) => c -> BuildR +repeatedFixedPrimR = etaBuildR $ \c -> + let ReverseRepeated prediction prims = toRepeated c in + case prediction of + Nothing -> foldr (\p a -> a <> Prim.liftBoundedPrim (Prim.liftFixedPrim p)) mempty prims + Just count -> Prim.unsafeReverseFoldMapFixedPrim id count prims +{-# INLINE repeatedFixedPrimR #-} + -- | Exported for testing purposes only. testWithUnused :: (Int -> BuildR) -> BuildR testWithUnused = withUnused diff --git a/src/Proto3/Wire/Reverse/Internal.hs b/src/Proto3/Wire/Reverse/Internal.hs index 25e0fbe..ba55552 100644 --- a/src/Proto3/Wire/Reverse/Internal.hs +++ b/src/Proto3/Wire/Reverse/Internal.hs @@ -462,7 +462,7 @@ sealBuffer# addr unused s0 = -- until a state action frees the stable pointer or modifies the state -- variable, the stable pointer will reference the state variable, -- which in turn will reference the current buffer. - let allocation = P.sizeofMutableByteArray buffer - metaDataSize + allocation <- subtract metaDataSize <$> P.getSizeofMutableByteArray buffer if allocation <= I# unused then pure (oldSealed, total, stateVar, statePtr, Just buffer) @@ -573,8 +573,8 @@ afterPrependChunks# SealedState Just buf -> do -- Recycle the old current buffer, from which -- we already copied what we wished to keep. - let u1 = P.sizeofMutableByteArray buf - metaDataSize - !(PTR base) = P.mutableByteArrayContents buf + u1 <- subtract metaDataSize <$> P.getSizeofMutableByteArray buf + let !(PTR base) = P.mutableByteArrayContents buf !v1 = plusPtr (Ptr base) (metaDataSize + u1) !m = plusPtr (Ptr base) metaDataSize writeSpace m (u1 + total) diff --git a/src/Proto3/Wire/Reverse/Prim.hs b/src/Proto3/Wire/Reverse/Prim.hs index 33dacec..68c276c 100644 --- a/src/Proto3/Wire/Reverse/Prim.hs +++ b/src/Proto3/Wire/Reverse/Prim.hs @@ -99,6 +99,7 @@ module Proto3.Wire.Reverse.Prim , word64Base128LEVar , word64Base128LEVar_inline , vectorFixedPrim + , unsafeReverseFoldMapFixedPrim ) where import Data.Bits ( Bits(..) ) @@ -711,8 +712,13 @@ wordBase128LEVar_inline (W# w) = word64Base128LEVar_inline (W64# w) -- | The bounded primitive implementing -- `Proto3.Wire.Reverse.word32Base128LEVar`. word32Base128LEVar :: Word32 -> BoundedPrim 5 -word32Base128LEVar = word32Base128LEVar_inline -{-# INLINE word32Base128LEVar #-} +word32Base128LEVar (W32# x0) = + ( wordBase128LEVar_choose 1 wordBase128LE_p1 $ + wordBase128LEVar_choose 2 wordBase128LE_p2 $ + wordBase128LEVar_choose 3 wordBase128LE_p3 $ + wordBase128LEVar_choose 4 wordBase128LE_p4 $ + (\x -> liftFixedPrim (wordBase128LE_p5 0## x)) + ) x0 -- | Like 'word32Base128LEVar' but inlined, which currently means -- that it is just the same as 'word32Base128LEVar', which we inline. @@ -798,14 +804,13 @@ word64Base128LEVar = \(W64# x) -> pif (W64# x <= fromIntegral (maxBound :: Word32)) (word32Base128LEVar (fromIntegral (W64# x))) (word64Base128LEVar_big x) -{-# INLINE word64Base128LEVar #-} -- | Like 'word64Base128LEVar' but inlined, possibly bloating your code. On -- the other hand, inlining an application to a constant may shrink your code. word64Base128LEVar_inline :: Word64 -> BoundedPrim 10 word64Base128LEVar_inline = \(W64# x) -> pif (W64# x <= fromIntegral (maxBound :: Word32)) - (word32Base128LEVar (fromIntegral (W64# x))) + (word32Base128LEVar_inline (fromIntegral (W64# x))) (inline (word64Base128LEVar_big x)) {-# INLINE word64Base128LEVar_inline #-} @@ -840,3 +845,30 @@ vectorFixedPrim f = etaBuildR $ \v -> where w = fromInteger (natVal' (proxy# :: Proxy# w)) {-# INLINE vectorFixedPrim #-} + +-- | Generalizes 'vectorFixedPrim' by mapping the elements +-- of a sequence of known length to fixed-width primitives +-- and concatenating those primitives /in reverse order/. +-- +-- This action is unsafe because a length prediction that is too short +-- causes undefined behavior--possibly a crash. By contrast, a length +-- prediction that is too long merely overallocates output space. +-- +-- (To see how this function could be used to implement 'vectorFixedPrim', +-- note that we can iterate over a vector from right to left by reversing +-- the vector and then performing a right fold on the reversed vector; +-- vector fusion rules should eliminate the intermediate vector.) +unsafeReverseFoldMapFixedPrim :: + forall w t a . + (KnownNat w, Foldable t) => + (a -> FixedPrim w) -> + -- | Maximum number of elements. Overapproximation causes + -- overallocation; passing an undercount may cause a crash. + Int -> + t a -> + BuildR +unsafeReverseFoldMapFixedPrim f !n = etaBuildR $ \xs -> + ensure (w * n) (foldr (\x acc -> acc <> unsafeBuildBoundedPrim (liftFixedPrim (f x))) mempty xs) + where + w = fromInteger (natVal' (proxy# :: Proxy# w)) +{-# INLINE unsafeReverseFoldMapFixedPrim #-} diff --git a/test/Main.hs b/test/Main.hs index 9ecd5b1..bc64bb7 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -14,9 +14,11 @@ limitations under the License. -} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-warnings-deprecations #-} @@ -32,19 +34,34 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Short as BS import qualified Data.ByteString.Builder.Internal as BBI import Data.Either ( isLeft ) -import Data.Maybe ( fromMaybe ) +import Data.Foldable ( toList ) +import Data.Functor.Identity ( Identity ) import Data.Int -import Data.List ( group, sort ) +import qualified Data.IntMap.Lazy +import qualified Data.IntSet +import qualified Data.Map.Lazy +import Data.Maybe ( fromMaybe ) +import Data.List ( sort ) +import qualified Data.List.NonEmpty as NE +import Data.Proxy ( Proxy(..) ) +import qualified Data.Sequence +import qualified Data.Set import qualified Data.Text.Lazy as T import qualified Data.Text.Short as TS +import Data.Typeable ( Typeable, showsTypeRep, typeRep ) import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU import Data.Word ( Word8, Word64 ) import Foreign ( sizeOf ) +import qualified GHC.Exts import Proto3.Wire +import Proto3.Wire.FoldR ( FoldR ) import qualified Proto3.Wire.Builder as Builder import qualified Proto3.Wire.Reverse as Reverse import qualified Proto3.Wire.Encode as Encode +import Proto3.Wire.Encode.Repeated ( Repeated(..), ToRepeated(..), nullRepeated ) import qualified Proto3.Wire.Decode as Decode import qualified Test.DocTest @@ -76,6 +93,7 @@ tests = testGroup "Tests" [ roundTripTests , varIntHeavyTests , packedLargeTests , decodeWireRoundTrip + , toRepeatedTests ] data StringOrInt64 = TString T.Text | TInt64 Int64 @@ -320,7 +338,7 @@ parseWhile p = StateT (Just . BL.span p) -- | Run-length encode lazy a 'BL.ByteString' -- for concise display in test results. rle :: BL.ByteString -> [(Int, Word8)] -rle = map (length &&& head) . group . BL.unpack +rle = map (NE.length &&& NE.head) . NE.group . BL.unpack -- | Please adjust this expected size of the metadata header -- to match that expected of the current implementation. @@ -782,3 +800,73 @@ packedDoublesV_large = HU.testCase "Large packedDoublesV" $ do decoded = Decode.parse (one Decode.packedDoubles [] `at` fieldNumber 13) (BL.toStrict encoded) HU.assertEqual "round trip" (Right [2 .. count + 1]) decoded + +data ExpectedCountPrediction c = NoCP | CorrectCP | SameCP (c -> Maybe Int) + +toRepeatedTests :: TestTree +toRepeatedTests = testGroup "ToRepeated" + [ test_nullRepeated + , test_ToRepeated (SameCP countRepeated) genRepeated (reverse . toList . reverseRepeated) + , test_ToRepeated CorrectCP QC.arbitrary (toList @Identity @Word8) + , test_ToRepeated NoCP QC.arbitrary (id @[Word8]) + , test_ToRepeated NoCP ((NE.:|) <$> QC.arbitrary <*> QC.arbitrary) (toList @NE.NonEmpty @Word8) + , test_ToRepeated CorrectCP (fmap V.fromList QC.arbitrary) (V.toList @Word8) + , test_ToRepeated CorrectCP (fmap VS.fromList QC.arbitrary) (VS.toList @Word8) + , test_ToRepeated CorrectCP (fmap VU.fromList QC.arbitrary) (VU.toList @Word8) + , test_ToRepeated CorrectCP QC.arbitrary (toList @Data.Sequence.Seq @Word8) + , test_ToRepeated CorrectCP QC.arbitrary (Data.Set.toAscList @Word8) + , test_ToRepeated NoCP QC.arbitrary Data.IntSet.toAscList + , test_ToRepeated CorrectCP QC.arbitrary (Data.Map.Lazy.toAscList @Int8 @Word8) + , test_ToRepeated NoCP QC.arbitrary (Data.IntMap.Lazy.toAscList @Word8) + ] + where + genRepeated :: QC.Gen (Repeated Word8) + genRepeated = do + predict <- QC.arbitrary + xs <- QC.arbitrary + pure ReverseRepeated + { countRepeated = if predict then Just (length xs) else Nothing + , reverseRepeated = GHC.Exts.fromList xs + } + + test_nullRepeated :: TestTree + test_nullRepeated = + QC.testProperty "nullRepeated" $ + QC.forAll genRepeated $ \c -> + nullRepeated c === null (reverseRepeated c) + + test_ToRepeated :: + forall c e . + ( ToRepeated c e + , Show c + , Typeable c + , Eq e + , Show e + ) => + ExpectedCountPrediction c -> + (QC.Gen c) -> + (c -> [e]) -> + TestTree + test_ToRepeated expectedCP gen cToList = + let cRep = typeRep (Proxy :: Proxy c) in + QC.testProperty (showString "toRepeated @(" $ showsTypeRep cRep ")") $ + QC.forAll gen $ \(c :: c) -> + let es :: [e] + es = cToList c + + prediction :: Maybe Int + reversed :: FoldR e + ReverseRepeated prediction reversed = toRepeated c + in + QC.counterexample "correctly reversed elements" (toList reversed === reverse es) + QC..&&. + QC.counterexample "correct count prediction if any" + (all @Maybe (== length es) prediction) + QC..&&. + case expectedCP of + NoCP -> + QC.counterexample "no count prediction" (prediction === Nothing) + CorrectCP -> + QC.counterexample "correct count prediction" (prediction === Just (length es)) + SameCP expected -> + QC.counterexample "unchanged count prediction" (prediction === expected c)