summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorrashad1030 <>2020-08-10 20:07:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-08-10 20:07:00 (GMT)
commit00c2952088b1e7792a828d0a5f46f2a9229e9ef6 (patch)
tree230dd71f7a2ba044b78beddda44fb4f647625137
parentc05789908a6f352c0ab5a342156a570c6ceb2fa7 (diff)
version 1.2.0HEAD1.2.0master
-rw-r--r--CHANGELOG.md3
-rw-r--r--proto3-wire.cabal28
-rw-r--r--src/Proto3/Wire/Builder.hs7
-rw-r--r--src/Proto3/Wire/Decode.hs7
-rw-r--r--src/Proto3/Wire/Encode.hs379
-rw-r--r--src/Proto3/Wire/Reverse.hs792
-rw-r--r--src/Proto3/Wire/Reverse/Internal.hs715
-rw-r--r--src/Proto3/Wire/Reverse/Prim.hs838
-rw-r--r--src/Proto3/Wire/Reverse/Width.hs113
-rw-r--r--test/Main.hs535
10 files changed, 3336 insertions, 81 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
index 0000000..5a02360
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,3 @@
+1.2.0
+ - Encode protobuf wire messages in reverse order to improve perfomance
+ - Miscellaneous maintenance changes
diff --git a/proto3-wire.cabal b/proto3-wire.cabal
index 45cb9c2..3baece6 100644
--- a/proto3-wire.cabal
+++ b/proto3-wire.cabal
@@ -1,5 +1,5 @@
name: proto3-wire
-version: 1.1.0
+version: 1.2.0
synopsis: A low-level implementation of the Protocol Buffers (version 3) wire format
license: Apache-2.0
license-file: LICENSE
@@ -9,6 +9,7 @@ copyright: 2016 Awake Networks
category: Codec
build-type: Simple
cabal-version: >=1.10
+extra-source-files: CHANGELOG.md
library
exposed-modules: Proto3.Wire
@@ -16,22 +17,35 @@ library
Proto3.Wire.Class
Proto3.Wire.Decode
Proto3.Wire.Encode
+ Proto3.Wire.Reverse
+ Proto3.Wire.Reverse.Prim
Proto3.Wire.Tutorial
Proto3.Wire.Types
- build-depends: base >=4.9 && <=5.0,
+ other-modules: Proto3.Wire.Reverse.Internal
+ Proto3.Wire.Reverse.Width
+ build-depends: base >=4.12 && <=5.0,
bytestring >=0.10.6.0 && <0.11.0,
cereal >= 0.5.1 && <0.6,
containers >=0.5 && < 0.7,
deepseq ==1.4.*,
- hashable <1.3,
+ ghc-prim >=0.5.3 && <0.7,
+ hashable <1.4,
+ parameterized >=0.5.0.0 && <1,
+ primitive >=0.6.4 && <0.8,
safe ==0.3.*,
text >= 0.2 && <1.3,
+ transformers >=0.5.6.2 && <0.6,
unordered-containers >= 0.1.0.0 && <0.3,
+ vector >=0.12.0.2 && <0.13,
QuickCheck >=2.8 && <3.0
hs-source-dirs: src
default-language: Haskell2010
- ghc-options: -O2 -Wall
+ ghc-options: -O2 -Wall -fobject-code
+ -- Add any other architectures on which an unaligned poke of a multibyte
+ -- value would succeed and be faster than writing the bytes one by one.
+ if arch(x86_64) || arch(i386)
+ cpp-options: -DUNALIGNED_POKES
test-suite tests
type: exitcode-stdio-1.0
@@ -41,10 +55,12 @@ test-suite tests
build-depends: base >=4.9 && <=5.0,
bytestring >=0.10.6.0 && <0.11.0,
cereal >= 0.5.1 && <0.6,
- doctest >= 0.7.0 && <0.17,
+ doctest >= 0.7.0 && <0.18,
proto3-wire,
QuickCheck >=2.8 && <3.0,
tasty >= 0.11 && <1.3,
tasty-hunit >= 0.9 && <0.11,
tasty-quickcheck >= 0.8.4 && <0.11,
- text >= 0.2 && <1.3
+ text >= 0.2 && <1.3,
+ transformers >=0.5.6.2 && <0.6,
+ vector >=0.12.0.2 && <0.13
diff --git a/src/Proto3/Wire/Builder.hs b/src/Proto3/Wire/Builder.hs
index acfdffd..f6a152e 100644
--- a/src/Proto3/Wire/Builder.hs
+++ b/src/Proto3/Wire/Builder.hs
@@ -26,6 +26,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Proto3.Wire.Builder
+ {-# DEPRECATED "This module is no longer used by the rest of the proto3-wire package." #-}
(
-- * `Builder` type
Builder
@@ -78,13 +79,13 @@ import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Short as BS
import Data.Char ( ord )
import Data.Int ( Int8, Int16, Int32, Int64 )
-import Data.Semigroup ( Semigroup(..), Sum(..) )
+import Data.Semigroup ( Sum(..) )
import Data.Word ( Word8, Word16, Word32, Word64 )
import System.IO ( Handle )
-- $setup
--- >>> :set -XOverloadedStrings
--- >>> import Data.Semigroup
+-- >>> :set -XOverloadedStrings -Wno-warnings-deprecations
+-- >>> :module Proto3.Wire.Builder
-- | A `Builder` is like a @"Data.ByteString.Builder".`BB.Builder`@, but also
-- memoizes the resulting length so that we can efficiently encode nested
diff --git a/src/Proto3/Wire/Decode.hs b/src/Proto3/Wire/Decode.hs
index d90a0a8..dd47743 100644
--- a/src/Proto3/Wire/Decode.hs
+++ b/src/Proto3/Wire/Decode.hs
@@ -72,6 +72,8 @@ module Proto3.Wire.Decode
, repeated
, embedded
, embedded'
+ -- * Exported For Doctest Only
+ , toMap
) where
import Control.Applicative
@@ -97,6 +99,10 @@ import Data.Word ( Word8, Word32, Word64 )
import Proto3.Wire.Class
import Proto3.Wire.Types
+-- $setup
+-- >>> :set -XOverloadedStrings
+-- >>> :module Proto3.Wire.Decode Proto3.Wire.Types
+
-- | Decode a zigzag-encoded numeric type.
-- See: http://stackoverflow.com/questions/2210923/zig-zag-decoding
zigZagDecode :: (Num a, Bits a) => a -> a
@@ -122,6 +128,7 @@ data ParsedField = VarintField Word64
toMap :: [(FieldNumber, v)] -> M.IntMap [v]
toMap kvs0 = M.fromListWith (<>) . map (fmap (:[])) . map (first (fromIntegral . getFieldNumber)) $ kvs0
+-- | Parses data in the raw wire format into an untyped 'Map' representation.
decodeWire :: B.ByteString -> Either String [(FieldNumber, ParsedField)]
decodeWire bstr = drloop bstr []
where
diff --git a/src/Proto3/Wire/Encode.hs b/src/Proto3/Wire/Encode.hs
index 1cf4ef9..c5084e1 100644
--- a/src/Proto3/Wire/Encode.hs
+++ b/src/Proto3/Wire/Encode.hs
@@ -38,14 +38,24 @@
-- > 1 `strings` Just "some string" <>
-- > 2 `strings` [ "foo", "bar", "baz" ]
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
module Proto3.Wire.Encode
( -- * `MessageBuilder` type
MessageBuilder
+ , reverseMessageBuilder
+ , vectorMessageBuilder
, messageLength
- , sizedMessageBuilder
- , rawMessageBuilder
, toLazyByteString
, unsafeFromLazyByteString
@@ -77,30 +87,38 @@ module Proto3.Wire.Encode
, embedded
-- * Packed repeated fields
, packedVarints
+ , packedVarintsV
+ , packedBoolsV
, packedFixed32
+ , packedFixed32V
, packedFixed64
+ , packedFixed64V
, packedFloats
+ , packedFloatsV
, packedDoubles
+ , packedDoublesV
) where
import Data.Bits ( (.|.), shiftL, shiftR, xor )
import qualified Data.ByteString as B
-import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BL
+import Data.Coerce ( coerce )
import Data.Int ( Int32, Int64 )
-import Data.Monoid ( (<>) )
-import Data.Semigroup ( Semigroup )
-import qualified Data.Text.Encoding as Text.Encoding
import qualified Data.Text.Lazy as Text.Lazy
-import qualified Data.Text.Lazy.Encoding as Text.Lazy.Encoding
+import Data.Vector.Generic ( Vector )
import Data.Word ( Word8, Word32, Word64 )
-import qualified Proto3.Wire.Builder as WB
+import GHC.TypeLits ( KnownNat, Nat, type (+) )
+import Parameterized.Data.Semigroup ( PNullary, PSemigroup(..),
+ (&<>) )
+import Parameterized.Data.Monoid ( PMEmpty(..) )
+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
+-- >>> :set -XOverloadedStrings -XOverloadedLists
+-- >>> :module Proto3.Wire.Encode Proto3.Wire.Class Data.Word
-- | A `MessageBuilder` represents a serialized protobuf message
--
@@ -110,8 +128,8 @@ import Proto3.Wire.Types
-- `MessageBuilder`
--
-- Use `toLazyByteString` when you're done assembling the `MessageBuilder`
-newtype MessageBuilder = MessageBuilder { unMessageBuilder :: WB.Builder }
- deriving (Semigroup, Monoid)
+newtype MessageBuilder = MessageBuilder { unMessageBuilder :: RB.BuildR }
+ deriving (Monoid, Semigroup)
instance Show MessageBuilder where
showsPrec prec builder =
@@ -120,21 +138,30 @@ instance Show MessageBuilder where
where
bytes' = toLazyByteString builder
--- | Retrieve the length of a message, in bytes
-messageLength :: MessageBuilder -> Word
-messageLength = WB.builderLength . unMessageBuilder
+-- | Convert a message builder to a 'RB.BuildR'.
+reverseMessageBuilder :: MessageBuilder -> RB.BuildR
+reverseMessageBuilder = unMessageBuilder
+
+-- | Eta-expands a function that produces a 'MessageBuilder', so that
+-- its input is not evaluated until the builder state is presented.
+--
+-- This odd combinator seems to help performance at times, though
+-- it may change behavior on nonterminating values of type @a@.
+etaMessageBuilder :: forall a . (a -> MessageBuilder) -> a -> MessageBuilder
+etaMessageBuilder = coerce (RB.etaBuildR @a)
--- | Convert a message to a @"Proto3.Wire.Builder".`WB.Builder`@
-sizedMessageBuilder :: MessageBuilder -> WB.Builder
-sizedMessageBuilder = unMessageBuilder
+-- | Essentially 'foldMap', but iterates right to left for efficiency.
+vectorMessageBuilder ::
+ forall v a . Vector v a => (a -> MessageBuilder) -> v a -> MessageBuilder
+vectorMessageBuilder = coerce (RB.vectorBuildR @v @a)
--- | Convert a message to a @"Data.ByteString.Builder".`BB.Builder`@
-rawMessageBuilder :: MessageBuilder -> BB.Builder
-rawMessageBuilder = WB.rawBuilder . unMessageBuilder
+-- | O(n): Retrieve the length of a message, in bytes.
+messageLength :: MessageBuilder -> Word
+messageLength = fromIntegral . fst . RB.runBuildR . unMessageBuilder
-- | Convert a message to a lazy `BL.ByteString`
toLazyByteString :: MessageBuilder -> BL.ByteString
-toLazyByteString = WB.toLazyByteString . unMessageBuilder
+toLazyByteString = RB.toLazyByteString . unMessageBuilder
-- | This lets you cast an arbitrary `ByteString` to a `MessageBuilder`, whether
-- or not the `ByteString` corresponds to a valid serialized protobuf message
@@ -143,10 +170,71 @@ toLazyByteString = WB.toLazyByteString . unMessageBuilder
-- you assemble malformed protobuf `MessageBuilder`s
unsafeFromLazyByteString :: BL.ByteString -> MessageBuilder
unsafeFromLazyByteString bytes' =
- MessageBuilder { unMessageBuilder = WB.lazyByteString bytes' }
+ MessageBuilder { unMessageBuilder = RB.lazyByteString bytes' }
+
+newtype MessageBoundedPrim w
+ = MessageBoundedPrim { unMessageBoundedPrim :: Prim.BoundedPrim w }
-base128Varint :: Word64 -> MessageBuilder
-base128Varint = MessageBuilder . WB.word64Base128LEVar
+type instance PNullary MessageBoundedPrim width = MessageBoundedPrim width
+
+instance (w1 + w2) ~ w3 =>
+ PSemigroup MessageBoundedPrim w1 w2 w3
+ where
+ pmappend = coerce (pmappend @Nat @Prim.BoundedPrim)
+ {-# INLINE CONLIKE pmappend #-}
+
+instance Prim.AssocPlusNat MessageBoundedPrim u v w
+ where
+ assocLPlusNat = \p -> coerce (Prim.assocLPlusNat @Prim.BoundedPrim p)
+ {-# INLINE CONLIKE assocLPlusNat #-}
+
+ assocRPlusNat = \p -> coerce (Prim.assocRPlusNat @Prim.BoundedPrim p)
+ {-# INLINE CONLIKE assocRPlusNat #-}
+
+instance Prim.CommPlusNat MessageBoundedPrim u v
+ where
+ commPlusNat = \p -> coerce (Prim.commPlusNat @Prim.BoundedPrim p)
+ {-# INLINE CONLIKE commPlusNat #-}
+
+instance PMEmpty MessageBoundedPrim 0
+ where
+ pmempty = coerce (pmempty @Nat @Prim.BoundedPrim)
+ {-# INLINE CONLIKE pmempty #-}
+
+instance Prim.Max u v ~ w =>
+ Prim.PChoose MessageBoundedPrim u v w
+ where
+ pbool = coerce (Prim.pbool @Prim.BoundedPrim)
+ {-# INLINE CONLIKE pbool #-}
+
+instance Prim.AssocMaxNat MessageBoundedPrim u v w
+ where
+ assocLMaxNat = \p -> coerce (Prim.assocLMaxNat @Prim.BoundedPrim p)
+ {-# INLINE CONLIKE assocLMaxNat #-}
+
+ assocRMaxNat = \p -> coerce (Prim.assocRMaxNat @Prim.BoundedPrim p)
+ {-# INLINE CONLIKE assocRMaxNat #-}
+
+instance Prim.CommMaxNat MessageBoundedPrim u v
+ where
+ commMaxNat = \p -> coerce (Prim.commMaxNat @Prim.BoundedPrim p)
+ {-# INLINE CONLIKE commMaxNat #-}
+
+liftBoundedPrim :: KnownNat w => MessageBoundedPrim w -> MessageBuilder
+liftBoundedPrim (MessageBoundedPrim p) = MessageBuilder (Prim.liftBoundedPrim p)
+{-# INLINE liftBoundedPrim #-}
+
+base128Varint32 :: Word32 -> MessageBoundedPrim 5
+base128Varint32 = MessageBoundedPrim . Prim.word32Base128LEVar
+{-# INLINE base128Varint32 #-}
+
+base128Varint64 :: Word64 -> MessageBoundedPrim 10
+base128Varint64 = MessageBoundedPrim . Prim.word64Base128LEVar
+{-# INLINE base128Varint64 #-}
+
+base128Varint64_inline :: Word64 -> MessageBoundedPrim 10
+base128Varint64_inline = MessageBoundedPrim . Prim.word64Base128LEVar_inline
+{-# INLINE base128Varint64_inline #-}
wireType :: WireType -> Word8
wireType Varint = 0
@@ -154,9 +242,10 @@ wireType Fixed32 = 5
wireType Fixed64 = 1
wireType LengthDelimited = 2
-fieldHeader :: FieldNumber -> WireType -> MessageBuilder
-fieldHeader num wt = base128Varint ((getFieldNumber num `shiftL` 3) .|.
- fromIntegral (wireType wt))
+fieldHeader :: FieldNumber -> WireType -> MessageBoundedPrim 10
+fieldHeader = \num wt -> base128Varint64_inline
+ ((getFieldNumber num `shiftL` 3) .|. fromIntegral (wireType wt))
+{-# INLINE fieldHeader #-}
-- | Encode a 32-bit "standard" integer
--
@@ -164,17 +253,32 @@ fieldHeader num wt = base128Varint ((getFieldNumber num `shiftL` 3) .|.
--
-- >>> 1 `int32` 42
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b*"
+-- >>> 1 `int64` (-42)
+-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\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..."
+-- <https://developers.google.com/protocol-buffers/docs/encoding#varints>
int32 :: FieldNumber -> Int32 -> MessageBuilder
-int32 num i = fieldHeader num Varint <> base128Varint (fromIntegral i)
+int32 = \num i -> liftBoundedPrim $
+ fieldHeader num Varint &<> base128Varint64 (fromIntegral i)
+{-# INLINE int32 #-}
-- | Encode a 64-bit "standard" integer
--
-- For example:
--
+-- >>> 1 `int32` 42
+-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b*"
-- >>> 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 = fieldHeader num Varint <> base128Varint (fromIntegral i)
+int64 = \num i -> liftBoundedPrim $
+ fieldHeader num Varint &<> base128Varint64 (fromIntegral i)
+{-# INLINE int64 #-}
-- | Encode a 32-bit unsigned integer
--
@@ -183,7 +287,9 @@ int64 num i = fieldHeader num Varint <> base128Varint (fromIntegral i)
-- >>> 1 `uint32` 42
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b*"
uint32 :: FieldNumber -> Word32 -> MessageBuilder
-uint32 num i = fieldHeader num Varint <> base128Varint (fromIntegral i)
+uint32 = \num i -> liftBoundedPrim $
+ fieldHeader num Varint &<> base128Varint32 i
+{-# INLINE uint32 #-}
-- | Encode a 64-bit unsigned integer
--
@@ -192,7 +298,9 @@ uint32 num i = fieldHeader num Varint <> base128Varint (fromIntegral i)
-- >>> 1 `uint64` 42
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b*"
uint64 :: FieldNumber -> Word64 -> MessageBuilder
-uint64 num i = fieldHeader num Varint <> base128Varint i
+uint64 = \num i -> liftBoundedPrim $
+ fieldHeader num Varint &<> base128Varint64 i
+{-# INLINE uint64 #-}
-- | Encode a 32-bit signed integer
--
@@ -200,8 +308,14 @@ uint64 num i = fieldHeader num Varint <> base128Varint i
--
-- >>> 1 `sint32` (-42)
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\bS"
+-- >>> 1 `sint32` maxBound
+-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\254\255\255\255\SI"
+-- >>> 1 `sint32` minBound
+-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\255\255\255\255\SI"
sint32 :: FieldNumber -> Int32 -> MessageBuilder
-sint32 num i = int32 num ((i `shiftL` 1) `xor` (i `shiftR` 31))
+sint32 = \num i ->
+ uint32 num (fromIntegral ((i `shiftL` 1) `xor` (i `shiftR` 31)))
+{-# INLINE sint32 #-}
-- | Encode a 64-bit signed integer
--
@@ -209,8 +323,14 @@ sint32 num i = int32 num ((i `shiftL` 1) `xor` (i `shiftR` 31))
--
-- >>> 1 `sint64` (-42)
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\bS"
+-- >>> 1 `sint64` maxBound
+-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\254\255\255\255\255\255\255\255\255\SOH"
+-- >>> 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 = int64 num ((i `shiftL` 1) `xor` (i `shiftR` 63))
+sint64 = \num i ->
+ uint64 num (fromIntegral ((i `shiftL` 1) `xor` (i `shiftR` 63)))
+{-# INLINE sint64 #-}
-- | Encode a fixed-width 32-bit integer
--
@@ -219,7 +339,10 @@ sint64 num i = int64 num ((i `shiftL` 1) `xor` (i `shiftR` 63))
-- >>> 1 `fixed32` 42
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\r*\NUL\NUL\NUL"
fixed32 :: FieldNumber -> Word32 -> MessageBuilder
-fixed32 num i = fieldHeader num Fixed32 <> MessageBuilder (WB.word32LE i)
+fixed32 = \num i -> liftBoundedPrim $
+ fieldHeader num Fixed32 &<>
+ MessageBoundedPrim (Prim.liftFixedPrim (Prim.word32LE i))
+{-# INLINE fixed32 #-}
-- | Encode a fixed-width 64-bit integer
--
@@ -228,7 +351,10 @@ fixed32 num i = fieldHeader num Fixed32 <> MessageBuilder (WB.word32LE i)
-- >>> 1 `fixed64` 42
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\t*\NUL\NUL\NUL\NUL\NUL\NUL\NUL"
fixed64 :: FieldNumber -> Word64 -> MessageBuilder
-fixed64 num i = fieldHeader num Fixed64 <> MessageBuilder (WB.word64LE i)
+fixed64 = \num i -> liftBoundedPrim $
+ fieldHeader num Fixed64 &<>
+ MessageBoundedPrim (Prim.liftFixedPrim (Prim.word64LE i))
+{-# INLINE fixed64 #-}
-- | Encode a fixed-width signed 32-bit integer
--
@@ -236,7 +362,10 @@ fixed64 num i = fieldHeader num Fixed64 <> MessageBuilder (WB.word64LE i)
--
-- > 1 `sfixed32` (-42)
sfixed32 :: FieldNumber -> Int32 -> MessageBuilder
-sfixed32 num i = fieldHeader num Fixed32 <> MessageBuilder (WB.int32LE i)
+sfixed32 = \num i -> liftBoundedPrim $
+ fieldHeader num Fixed32 &<>
+ MessageBoundedPrim (Prim.liftFixedPrim (Prim.int32LE i))
+{-# INLINE sfixed32 #-}
-- | Encode a fixed-width signed 64-bit integer
--
@@ -245,7 +374,10 @@ sfixed32 num i = fieldHeader num Fixed32 <> MessageBuilder (WB.int32LE i)
-- >>> 1 `sfixed64` (-42)
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\t\214\255\255\255\255\255\255\255"
sfixed64 :: FieldNumber -> Int64 -> MessageBuilder
-sfixed64 num i = fieldHeader num Fixed64 <> MessageBuilder (WB.int64LE i)
+sfixed64 = \num i -> liftBoundedPrim $
+ fieldHeader num Fixed64 &<>
+ MessageBoundedPrim (Prim.liftFixedPrim (Prim.int64LE i))
+{-# INLINE sfixed64 #-}
-- | Encode a floating point number
--
@@ -254,7 +386,10 @@ sfixed64 num i = fieldHeader num Fixed64 <> MessageBuilder (WB.int64LE i)
-- >>> 1 `float` 3.14
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\r\195\245H@"
float :: FieldNumber -> Float -> MessageBuilder
-float num f = fieldHeader num Fixed32 <> MessageBuilder (WB.floatLE f)
+float = \num f -> liftBoundedPrim $
+ fieldHeader num Fixed32 &<>
+ MessageBoundedPrim (Prim.liftFixedPrim (Prim.floatLE f))
+{-# INLINE float #-}
-- | Encode a double-precision number
--
@@ -263,7 +398,10 @@ float num f = fieldHeader num Fixed32 <> MessageBuilder (WB.floatLE f)
-- >>> 1 `double` 3.14
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\t\US\133\235Q\184\RS\t@"
double :: FieldNumber -> Double -> MessageBuilder
-double num d = fieldHeader num Fixed64 <> MessageBuilder (WB.doubleLE d)
+double = \num d -> liftBoundedPrim $
+ fieldHeader num Fixed64 &<>
+ MessageBoundedPrim (Prim.liftFixedPrim (Prim.doubleLE d))
+{-# INLINE double #-}
-- | Encode a value with an enumerable type.
--
@@ -289,8 +427,10 @@ double num d = fieldHeader num Fixed64 <> MessageBuilder (WB.doubleLE d)
-- >>> 1 `enum` Triangle <> 2 `enum` Gap3
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\STX\DLE\ETX"
enum :: ProtoEnum e => FieldNumber -> e -> MessageBuilder
-enum num e =
- fieldHeader num Varint <> base128Varint (fromIntegral (fromProtoEnum e))
+enum = \num e -> liftBoundedPrim $
+ fieldHeader num Varint &<>
+ base128Varint32 (fromIntegral @Int32 @Word32 (fromProtoEnum e))
+{-# INLINE enum #-}
-- | Encode a boolean value
--
@@ -299,14 +439,20 @@ enum num e =
-- >>> 1 `bool` True
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\SOH"
bool :: FieldNumber -> Bool -> MessageBuilder
-bool num i = fieldHeader num Varint <> base128Varint (fromIntegral (fromEnum i))
+bool = \num b -> liftBoundedPrim $
+ fieldHeader num Varint &<>
+ MessageBoundedPrim
+ (Prim.liftFixedPrim (Prim.word8 (fromIntegral (fromEnum b))))
+ -- Using word8 instead of a varint encoder shrinks the width bound.
+{-# INLINE bool #-}
-- | Encode a sequence of octets as a field of type 'bytes'.
--
--- >>> 1 `bytes` (Proto3.Wire.Builder.stringUtf8 "testing")
+-- >>> 1 `bytes` (Proto3.Wire.Reverse.stringUtf8 "testing")
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting"
-bytes :: FieldNumber -> WB.Builder -> MessageBuilder
+bytes :: FieldNumber -> RB.BuildR -> MessageBuilder
bytes num = embedded num . MessageBuilder
+{-# INLINE bytes #-}
-- | Encode a UTF-8 string.
--
@@ -315,7 +461,8 @@ bytes num = embedded num . MessageBuilder
-- >>> 1 `string` "testing"
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting"
string :: FieldNumber -> String -> MessageBuilder
-string num = embedded num . MessageBuilder . WB.stringUtf8
+string num = embedded num . MessageBuilder . RB.stringUtf8
+{-# INLINE string #-}
-- | Encode lazy `Text` as UTF-8
--
@@ -324,16 +471,8 @@ string num = embedded num . MessageBuilder . WB.stringUtf8
-- >>> 1 `text` "testing"
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting"
text :: FieldNumber -> Text.Lazy.Text -> MessageBuilder
-text num txt =
- embedded num (MessageBuilder (WB.unsafeMakeBuilder len (Text.Lazy.Encoding.encodeUtf8Builder txt)))
- where
- -- It would be nice to avoid actually allocating encoded chunks,
- -- but we leave that enhancement for a future time.
- len = Text.Lazy.foldrChunks op 0 txt
- op chnk acc = fromIntegral (B.length (Text.Encoding.encodeUtf8 chnk)) + acc
-{-# INLINABLE text #-}
- -- INLINABLE so that if the input is constant, the compiler
- -- has the opportunity to express its length as a CAF.
+text num = embedded num . MessageBuilder . RB.lazyTextUtf8
+{-# INLINE text #-}
-- | Encode a collection of bytes in the form of a strict 'B.ByteString'.
--
@@ -342,7 +481,8 @@ text num txt =
-- >>> 1 `byteString` "testing"
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting"
byteString :: FieldNumber -> B.ByteString -> MessageBuilder
-byteString num bs = embedded num (MessageBuilder (WB.byteString bs))
+byteString num = embedded num . MessageBuilder . RB.byteString
+{-# INLINE byteString #-}
-- | Encode a lazy bytestring.
--
@@ -351,42 +491,139 @@ byteString num bs = embedded num (MessageBuilder (WB.byteString bs))
-- >>> 1 `lazyByteString` "testing"
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting"
lazyByteString :: FieldNumber -> BL.ByteString -> MessageBuilder
-lazyByteString num bl = embedded num (MessageBuilder (WB.lazyByteString bl))
+lazyByteString num = embedded num . MessageBuilder . RB.lazyByteString
+{-# INLINE lazyByteString #-}
-- | Encode varints in the space-efficient packed format.
+-- But consider 'packedVarintsV', which may be faster.
--
--- >>> 1 `packedVarints` [1, 2, 3]
+-- The values to be encoded are specified by mapping the elements of a vector.
+--
+-- >>> packedVarints 1 [1, 2, 3]
-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\ETX\SOH\STX\ETX"
packedVarints :: Foldable f => FieldNumber -> f Word64 -> MessageBuilder
-packedVarints num = embedded num . foldMap base128Varint
+packedVarints num =
+ etaMessageBuilder
+ (embedded num . foldMap (liftBoundedPrim . base128Varint64))
+{-# INLINE packedVarints #-}
+
+-- | A faster but more specialized variant of:
+--
+-- > \f num -> packedVarints num . fmap f
+--
+-- >>> packedVarintsV (subtract 10) 1 ([11, 12, 13] :: Data.Vector.Vector Word64)
+-- 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)
+{-# INLINE packedVarintsV #-}
+
+-- | A faster but more specialized variant of:
+--
+-- > packedVarintsV (fromIntegral . fromEnum) num
+--
+-- >>> 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
+ where
+ op = Prim.word8 . fromIntegral . fromEnum . f
+{-# INLINE packedBoolsV #-}
-- | Encode fixed-width Word32s in the space-efficient packed format.
+-- But consider 'packedFixed32V', which may be faster.
--
--- >>> 1 `packedFixed32` [1, 2, 3]
+-- The values to be encoded are specified by mapping the elements of a vector.
+--
+-- >>> 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 = embedded num . foldMap (MessageBuilder . WB.word32LE)
+packedFixed32 num =
+ etaMessageBuilder (embedded num . foldMap (MessageBuilder . RB.word32LE))
+{-# INLINE packedFixed32 #-}
+
+-- | A faster but more specialized variant of:
+--
+-- > \f num -> packedFixed32 num . fmap f
+--
+-- >>> packedFixed32V (subtract 10) 1 ([11, 12, 13] :: Data.Vector.Vector Word32)
+-- 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)
+{-# INLINE packedFixed32V #-}
-- | Encode fixed-width Word64s in the space-efficient packed format.
+-- But consider 'packedFixed64V', which may be faster.
--
--- >>> 1 `packedFixed64` [1, 2, 3]
+-- The values to be encoded are specified by mapping the elements of a vector.
+--
+-- >>> 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 = embedded num . foldMap (MessageBuilder . WB.word64LE)
+packedFixed64 num =
+ etaMessageBuilder (embedded num . foldMap (MessageBuilder . RB.word64LE))
+{-# INLINE packedFixed64 #-}
+
+-- | A faster but more specialized variant of:
+--
+-- > \f num -> packedFixed64 num . fmap f
+--
+-- >>> packedFixed64V (subtract 10) 1 ([11, 12, 13] :: Data.Vector.Vector Word64)
+-- 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)
+{-# INLINE packedFixed64V #-}
-- | Encode floats in the space-efficient packed format.
+-- But consider 'packedFloatsV', 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 = embedded num . foldMap (MessageBuilder . WB.floatLE)
+packedFloats num =
+ etaMessageBuilder (embedded num . foldMap (MessageBuilder . RB.floatLE))
+{-# INLINE packedFloats #-}
+
+-- | A faster but more specialized variant of:
+--
+-- > \f num -> packedFloats num . fmap f
+--
+-- >>> packedFloatsV (subtract 10) 1 ([11, 12, 13] :: Data.Vector.Vector Float)
+-- 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)
+{-# INLINE packedFloatsV #-}
-- | Encode doubles in the space-efficient packed format.
+-- But consider 'packedDoublesV', 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 = embedded num . foldMap (MessageBuilder . WB.doubleLE)
+packedDoubles num =
+ etaMessageBuilder (embedded num . foldMap (MessageBuilder . RB.doubleLE))
+{-# INLINE packedDoubles #-}
+
+-- | A faster but more specialized variant of:
+--
+-- > \f num -> packedDoubles num . fmap f
+--
+-- >>> packedDoublesV (subtract 10) 1 ([11, 12, 13] :: Data.Vector.Vector Double)
+-- 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)
+{-# INLINE packedDoublesV #-}
-- | Encode an embedded message.
--
@@ -398,6 +635,10 @@ packedDoubles num = embedded num . foldMap (MessageBuilder . WB.doubleLE)
-- >>> 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 bb = fieldHeader num LengthDelimited <>
- base128Varint (fromIntegral (messageLength bb)) <>
- bb
+embedded = \num (MessageBuilder bb) ->
+ MessageBuilder (RB.withLengthOf (Prim.liftBoundedPrim . prefix num) bb)
+ where
+ prefix num len =
+ unMessageBoundedPrim (fieldHeader num LengthDelimited) &<>
+ Prim.wordBase128LEVar (fromIntegral @Int @Word len)
+{-# INLINE embedded #-}
diff --git a/src/Proto3/Wire/Reverse.hs b/src/Proto3/Wire/Reverse.hs
new file mode 100644
index 0000000..dcf87cf
--- /dev/null
+++ b/src/Proto3/Wire/Reverse.hs
@@ -0,0 +1,792 @@
+{-
+ Copyright 2020 Awake 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.
+-}
+
+-- | This module differs from the "Data.ByteString.Builder" module by
+-- writing the octets in reverse order, which lets us compute the length
+-- of a submessage by writing that submessage and measuring its length
+-- before we write a variadic integer prefix encoding that length.
+--
+-- Example use:
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (withLengthOf (word64Base128LEVar . fromIntegral) (word32BE 42 <> charUtf8 'λ')))
+-- [6,0,0,0,42,206,187]
+
+{-# LANGUAGE BangPatterns #-}
+
+module Proto3.Wire.Reverse
+ ( -- * `BuildR` type
+ BuildR
+
+ -- * Create `BuildR`s
+ , etaBuildR
+ , ensure
+ , withLengthOf
+ , byteString
+ , lazyByteString
+ , shortByteString
+ , word8
+ , int8
+ , word16BE
+ , word16LE
+ , int16BE
+ , int16LE
+ , word32BE
+ , word32LE
+ , int32BE
+ , int32LE
+ , word64BE
+ , word64LE
+ , int64BE
+ , int64LE
+ , floatBE
+ , floatLE
+ , doubleBE
+ , doubleLE
+ , char7
+ , string7
+ , char8
+ , string8
+ , charUtf8
+ , stringUtf8
+ , textUtf8
+ , lazyTextUtf8
+ , wordBase128LEVar
+ , wordBase128LEVar_inline
+ , word32Base128LEVar
+ , word32Base128LEVar_inline
+ , word64Base128LEVar
+ , word64Base128LEVar_inline
+ , vectorBuildR
+
+ -- * Consume `BuildR`s
+ , runBuildR
+ , toLazyByteString
+
+ -- * Helpful combinators
+ , foldlRVector
+
+ -- * Exported for testing purposes only.
+ , testWithUnused
+ ) where
+
+import Data.Bits ( (.&.) )
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Internal as BI
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Lazy.Internal as BLI
+import qualified Data.ByteString.Short as BS
+import qualified Data.ByteString.Short.Internal as BSI
+import qualified Data.ByteString.Unsafe as BU
+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 Data.Vector.Generic ( Vector )
+import Data.Word ( Word8, Word16, Word32, Word64 )
+import Foreign ( castPtr )
+import Proto3.Wire.Reverse.Internal
+import qualified Proto3.Wire.Reverse.Prim as Prim
+
+-- $setup
+-- >>> :set -XOverloadedStrings
+-- >>> :module Proto3.Wire.Reverse
+
+-- | Create a lazy `BL.ByteString` from a `BuildR`
+--
+-- > toLazyByteString (x <> y) = toLazyByteString x <> toLazyByteString y
+-- >
+-- > toLazyByteString mempty = mempty
+--
+-- >>> toLazyByteString (stringUtf8 "ABC")
+-- "ABC"
+toLazyByteString :: BuildR -> BL.ByteString
+toLazyByteString = snd . runBuildR
+
+-- | Convert a strict `B.ByteString` to a `BuildR`
+--
+-- > byteString (x <> y) = byteString x <> byteString y
+-- >
+-- > byteString mempty = mempty
+--
+-- >>> 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
+
+-- | Convert a lazy `BL.ByteString` to a `BuildR`
+--
+-- Warning: evaluating the length will force the lazy `BL.ByteString`'s chunks,
+-- and they will remain allocated until you finish using the builder.
+--
+-- > lazyByteString (x <> y) = lazyByteString x <> lazyByteString y
+-- >
+-- > lazyByteString mempty = mempty
+--
+-- > lazyByteString . toLazyByteString = id
+-- >
+-- > toLazyByteString . lazyByteString = id
+--
+-- >>> lazyByteString "ABC"
+-- Proto3.Wire.Reverse.lazyByteString "ABC"
+lazyByteString :: BL.ByteString -> BuildR
+lazyByteString = etaBuildR $ scan (ReverseChunks BL.empty)
+ where
+ scan :: ReverseChunks -> BL.ByteString -> BuildR
+ scan r BLI.Empty = prepend r
+ scan (ReverseChunks r) (BLI.Chunk c cs) =
+ scan (ReverseChunks (BLI.Chunk c r)) cs
+
+ prepend :: ReverseChunks -> BuildR
+ prepend (ReverseChunks BLI.Empty) = mempty
+ prepend (ReverseChunks (BLI.Chunk c cs)) = withUnused $ \unused ->
+ let len = B.length c in
+ if len <= unused
+ then
+ (prepend (ReverseChunks cs) <>) $
+ unsafeConsume len $ \dst ->
+ BU.unsafeUseAsCString c $ \src ->
+ BI.memcpy dst (castPtr src) len
+ else
+ prependReverseChunks (ReverseChunks(BLI.Chunk c cs))
+
+-- | Convert a `BS.ShortByteString` to a `BuildR`
+--
+-- > shortByteString (x <> y) = shortByteString x <> shortByteString y
+-- >
+-- > shortByteString mempty = mempty
+--
+-- >>> shortByteString "ABC"
+-- Proto3.Wire.Reverse.lazyByteString "ABC"
+shortByteString :: BS.ShortByteString -> BuildR
+shortByteString bs = withUnused $ \unused ->
+ let len = BS.length bs in
+ if len <= unused
+ then
+ writeChunk bs 0 len
+ else
+ let rest = len - unused in
+ writeChunk bs unused rest <> reallocate rest <> writeChunk bs 0 unused
+ where
+ writeChunk src off len =
+ unsafeConsume len $ \dst ->
+ BSI.copyToPtr src off dst len
+
+-- | Convert a `Word8` to a `BuildR`
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word8 42))
+-- [42]
+word8 :: Word8 -> BuildR
+word8 = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.word8 x))
+{-# INLINE word8 #-}
+
+-- | Convert a `Int8` to a `BuildR`
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int8 (-5)))
+-- [251]
+int8 :: Int8 -> BuildR
+int8 = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.int8 x))
+{-# INLINE int8 #-}
+
+-- | Convert a `Word16` to a `BuildR` by storing the bytes in big-endian order
+--
+-- In other words, the most significant byte is stored first and the least
+-- significant byte is stored last
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word16BE 42))
+-- [0,42]
+word16BE :: Word16 -> BuildR
+word16BE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.word16BE x))
+{-# INLINE word16BE #-}
+
+-- | Convert a `Word16` to a `BuildR` by storing the bytes in little-endian
+-- order
+--
+-- In other words, the least significant byte is stored first and the most
+-- significant byte is stored last
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word16LE 42))
+-- [42,0]
+word16LE :: Word16 -> BuildR
+word16LE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.word16LE x))
+{-# INLINE word16LE #-}
+
+-- | Convert an `Int16` to a `BuildR` by storing the bytes in big-endian order
+--
+-- In other words, the most significant byte is stored first and the least
+-- significant byte is stored last
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int16BE (-5)))
+-- [255,251]
+int16BE :: Int16 -> BuildR
+int16BE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.int16BE x))
+{-# INLINE int16BE #-}
+
+-- | Convert an `Int16` to a `BuildR` by storing the bytes in little-endian
+-- order
+--
+-- In other words, the least significant byte is stored first and the most
+-- significant byte is stored last
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int16LE (-5)))
+-- [251,255]
+int16LE :: Int16 -> BuildR
+int16LE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.int16LE x))
+{-# INLINE int16LE #-}
+
+-- | Convert a `Word32` to a `BuildR` by storing the bytes in big-endian order
+--
+-- In other words, the most significant byte is stored first and the least
+-- significant byte is stored last
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32BE 42))
+-- [0,0,0,42]
+word32BE :: Word32 -> BuildR
+word32BE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.word32BE x))
+{-# INLINE word32BE #-}
+
+-- | Convert a `Word32` to a `BuildR` by storing the bytes in little-endian
+-- order
+--
+-- In other words, the least significant byte is stored first and the most
+-- significant byte is stored last
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32LE 42))
+-- [42,0,0,0]
+word32LE :: Word32 -> BuildR
+word32LE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.word32LE x))
+{-# INLINE word32LE #-}
+
+-- | Convert an `Int32` to a `BuildR` by storing the bytes in big-endian order
+--
+-- In other words, the most significant byte is stored first and the least
+-- significant byte is stored last
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int32BE (-5)))
+-- [255,255,255,251]
+int32BE :: Int32 -> BuildR
+int32BE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.int32BE x))
+{-# INLINE int32BE #-}
+
+-- | Convert an `Int32` to a `BuildR` by storing the bytes in little-endian
+-- order
+--
+-- In other words, the least significant byte is stored first and the most
+-- significant byte is stored last
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int32LE (-5)))
+-- [251,255,255,255]
+int32LE :: Int32 -> BuildR
+int32LE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.int32LE x))
+{-# INLINE int32LE #-}
+
+-- | Convert a `Word64` to a `BuildR` by storing the bytes in big-endian order
+--
+-- In other words, the most significant byte is stored first and the least
+-- significant byte is stored last
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64BE 42))
+-- [0,0,0,0,0,0,0,42]
+word64BE :: Word64 -> BuildR
+word64BE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.word64BE x))
+{-# INLINE word64BE #-}
+
+-- | Convert a `Word64` to a `BuildR` by storing the bytes in little-endian
+-- order
+--
+-- In other words, the least significant byte is stored first and the most
+-- significant byte is stored last
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64LE 42))
+-- [42,0,0,0,0,0,0,0]
+word64LE :: Word64 -> BuildR
+word64LE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.word64LE x))
+{-# INLINE word64LE #-}
+
+-- | Convert an `Int64` to a `BuildR` by storing the bytes in big-endian order
+--
+-- In other words, the most significant byte is stored first and the least
+-- significant byte is stored last
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int64BE (-5)))
+-- [255,255,255,255,255,255,255,251]
+int64BE :: Int64 -> BuildR
+int64BE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.int64BE x))
+{-# INLINE int64BE #-}
+
+-- | Convert an `Int64` to a `BuildR` by storing the bytes in little-endian
+-- order
+--
+-- In other words, the least significant byte is stored first and the most
+-- significant byte is stored last
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int64LE (-5)))
+-- [251,255,255,255,255,255,255,255]
+int64LE :: Int64 -> BuildR
+int64LE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.int64LE x))
+{-# INLINE int64LE #-}
+
+-- | Convert a `Float` to a `BuildR` by storing the bytes in IEEE-754 format in
+-- big-endian order
+--
+-- In other words, the most significant byte is stored first and the least
+-- significant byte is stored last
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (floatBE 4.2))
+-- [64,134,102,102]
+floatBE :: Float -> BuildR
+floatBE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.floatBE x))
+{-# INLINE floatBE #-}
+
+-- | Convert a `Float` to a `BuildR` by storing the bytes in IEEE-754 format in
+-- little-endian order
+--
+-- In other words, the least significant byte is stored first and the most
+-- significant byte is stored last
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (floatLE 4.2))
+-- [102,102,134,64]
+floatLE :: Float -> BuildR
+floatLE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.floatLE x))
+{-# INLINE floatLE #-}
+
+-- | Convert a `Double` to a `BuildR` by storing the bytes in IEEE-754 format
+-- in big-endian order
+--
+-- In other words, the most significant byte is stored first and the least
+-- significant byte is stored last
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (doubleBE 4.2))
+-- [64,16,204,204,204,204,204,205]
+doubleBE :: Double -> BuildR
+doubleBE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.doubleBE x))
+{-# INLINE doubleBE #-}
+
+-- | Convert a `Double` to a `BuildR` by storing the bytes in IEEE-754 format
+-- in little-endian order
+--
+-- In other words, the least significant byte is stored first and the most
+-- significant byte is stored last
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (doubleLE 4.2))
+-- [205,204,204,204,204,204,16,64]
+doubleLE :: Double -> BuildR
+doubleLE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.doubleLE x))
+{-# INLINE doubleLE #-}
+
+-- | Convert an @ASCII@ `Char` to a `BuildR`
+--
+-- __Careful:__ If you provide a Unicode character that is not part of the
+-- @ASCII@ alphabet this will only encode the lowest 7 bits
+--
+-- >>> char7 ';'
+-- Proto3.Wire.Reverse.lazyByteString ";"
+-- >>> char7 'λ' -- Example of truncation
+-- Proto3.Wire.Reverse.lazyByteString ";"
+char7 :: Char -> BuildR
+char7 = word8 . (0x7F .&.) . fromIntegral . ord
+{-# INLINE char7 #-}
+
+-- | Convert an @ASCII@ `String` to a `BuildR`
+--
+-- __Careful:__ If you provide a Unicode `String` that has non-@ASCII@
+-- characters then this will only encode the lowest 7 bits of each character
+--
+-- > string7 (x <> y) = string7 x <> string7 y
+-- >
+-- > string7 mempty = mempty
+--
+-- >>> string7 "ABC"
+-- Proto3.Wire.Reverse.lazyByteString "ABC"
+-- >>> string7 "←↑→↓" -- Example of truncation
+-- Proto3.Wire.Reverse.lazyByteString "\DLE\DC1\DC2\DC3"
+string7 :: String -> BuildR
+string7 = foldMap char7
+ -- TO DO: 'Data.ByteString.Builder' goes to considerably more effort.
+ -- Could we do better here?
+
+-- | Convert an @ISO/IEC 8859-1@ `Char` to a `BuildR`
+--
+-- __Careful:__ If you provide a Unicode character that is not part of the
+-- @ISO/IEC 8859-1@ alphabet then this will only encode the lowest 8 bits
+--
+-- >>> char8 ';'
+-- Proto3.Wire.Reverse.lazyByteString ";"
+-- >>> char8 'λ' -- Example of truncation
+-- Proto3.Wire.Reverse.lazyByteString "\187"
+char8 :: Char -> BuildR
+char8 = word8 . fromIntegral . ord
+{-# INLINE char8 #-}
+
+-- | Convert an @ISO/IEC 8859-1@ `String` to a `BuildR`
+--
+-- __Careful:__ If you provide a Unicode `String` that has non-@ISO/IEC 8859-1@
+-- characters then this will only encode the lowest 8 bits of each character
+--
+-- > string8 (x <> y) = string8 x <> string8 y
+-- >
+-- > string8 mempty = mempty
+--
+-- >>> string8 "ABC"
+-- Proto3.Wire.Reverse.lazyByteString "ABC"
+-- >>> string8 "←↑→↓" -- Example of truncation
+-- Proto3.Wire.Reverse.lazyByteString "\144\145\146\147"
+string8 :: String -> BuildR
+string8 = foldMap char8
+ -- TO DO: 'Data.ByteString.Builder' goes to considerably more effort.
+ -- Could we do better here?
+
+-- | Convert a Unicode `Char` to a `BuildR` using a @UTF-8@ encoding
+--
+-- >>> charUtf8 'A'
+-- Proto3.Wire.Reverse.lazyByteString "A"
+-- >>> charUtf8 'λ'
+-- Proto3.Wire.Reverse.lazyByteString "\206\187"
+-- >>> charUtf8 (Data.Char.chr 0x7FF)
+-- Proto3.Wire.Reverse.lazyByteString "\223\191"
+-- >>> charUtf8 (Data.Char.chr 0x800)
+-- Proto3.Wire.Reverse.lazyByteString "\224\160\128"
+-- >>> charUtf8 (Data.Char.chr 0xFFFF)
+-- Proto3.Wire.Reverse.lazyByteString "\239\191\191"
+-- >>> charUtf8 (Data.Char.chr 0x10000)
+-- Proto3.Wire.Reverse.lazyByteString "\240\144\128\128"
+-- >>> charUtf8 (Data.Char.chr 0x10FFFF)
+-- Proto3.Wire.Reverse.lazyByteString "\244\143\191\191"
+charUtf8 :: Char -> BuildR
+charUtf8 = \x -> Prim.liftBoundedPrim (Prim.charUtf8 x)
+{-# INLINE charUtf8 #-}
+
+-- | Convert a Unicode `String` to a `BuildR` using a @UTF-8@ encoding
+--
+-- > stringUtf8 (x <> y) = stringUtf8 x <> stringUtf8 y
+-- >
+-- > stringUtf8 mempty = mempty
+--
+-- >>> stringUtf8 "ABC"
+-- Proto3.Wire.Reverse.lazyByteString "ABC"
+-- >>> stringUtf8 "←↑→↓"
+-- Proto3.Wire.Reverse.lazyByteString "\226\134\144\226\134\145\226\134\146\226\134\147"
+-- >>> Data.ByteString.Lazy.hPutStr System.IO.stdout (toLazyByteString (stringUtf8 "←↑→↓\n"))
+-- ←↑→↓
+stringUtf8 :: String -> BuildR
+stringUtf8 = foldMap charUtf8
+ -- TO DO: 'Data.ByteString.Builder' goes to considerably more effort.
+ -- Could we do better here?
+
+-- | Convert a Unicode strict `T.Text` to a `BuildR` using a @UTF-8@ encoding
+--
+-- > textUtf8 (x <> y) = textUtf8 x <> textUtf8 y
+-- >
+-- > textUtf8 mempty = mempty
+--
+-- >>> textUtf8 "ABC"
+-- Proto3.Wire.Reverse.lazyByteString "ABC"
+-- >>> textUtf8 "←↑→↓"
+-- Proto3.Wire.Reverse.lazyByteString "\226\134\144\226\134\145\226\134\146\226\134\147"
+textUtf8 :: T.Text -> BuildR
+textUtf8 = etaBuildR $ \txt@(TI.Text _ _ word16Count) ->
+ case TIF.reverseStream txt of
+ TIF.Stream next t0 _ -> ensure bound (go t0)
+ where
+ -- Any non-surrogate UTF-16 word encodes a 'Char' whose UTF-8
+ -- encoding involves at most 3 octets. Any surrogate pair is
+ -- two UTF-16 words that give rise to 4 octets. Therefore we
+ -- will see at most 3 UTF-8 bytes per UTF-16 word of input.
+ --
+ -- This is a significant overallocation in the ASCII case,
+ -- where we see only one UTF-8 byte per UTF-16 word of input.
+ -- If such overallocation becomes a problem, we could implement
+ -- a prescan that computes the exact size required.
+ --
+ -- However, we anticipate that in most cases we will be
+ -- building from many text chunks that individually much
+ -- smaller than the overall size of the combined result,
+ -- making overallocation relatively harmless.
+ bound = 3 * word16Count
+
+ go = etaBuildR $ \t1 -> case next t1 of
+ TIF.Done -> mempty
+ TIF.Skip t2 -> go t2
+ TIF.Yield !ch t2 ->
+ go t2 <> Prim.unsafeBuildBoundedPrim (Prim.charUtf8 ch)
+
+-- | Convert a Unicode lazy `TL.Text` to a `BuildR` using a @UTF-8@ encoding
+--
+-- > lazyTextUtf8 (x <> y) = lazyTextUtf8 x <> lazyTextUtf8 y
+-- >
+-- > lazyTextUtf8 mempty = mempty
+--
+-- >>> lazyTextUtf8 "ABC"
+-- Proto3.Wire.Reverse.lazyByteString "ABC"
+-- >>> lazyTextUtf8 "←↑→↓"
+-- Proto3.Wire.Reverse.lazyByteString "\226\134\144\226\134\145\226\134\146\226\134\147"
+lazyTextUtf8 :: TL.Text -> BuildR
+lazyTextUtf8 = TL.foldrChunks ((<>) . textUtf8) mempty
+
+-- | Convert a `Word` to a `BuildR` using this variable-length encoding:
+--
+-- 1. Convert the given value to a base 128 representation
+-- without unnecessary digits (that is, omit zero digits
+-- unless they are less significant than nonzero digits).
+--
+-- 2. Present those base-128 digits in order of increasing
+-- significance (that is, in little-endian order).
+--
+-- 3. Add 128 to every digit except the most significant digit,
+-- yielding a sequence of octets terminated by one that is <= 127.
+--
+-- This encoding is used in the wire format of Protocol Buffers version 3.
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar 42))
+-- [42]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar 5376))
+-- [128,42]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 7 - 1)))
+-- [127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 7)))
+-- [128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 14 - 1)))
+-- [255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 14)))
+-- [128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 21 - 1)))
+-- [255,255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 21)))
+-- [128,128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 28 - 1)))
+-- [255,255,255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 28)))
+-- [128,128,128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 32 - 1)))
+-- [255,255,255,255,15]
+wordBase128LEVar :: Word -> BuildR
+wordBase128LEVar = \x -> Prim.liftBoundedPrim (Prim.wordBase128LEVar x)
+{-# INLINE wordBase128LEVar #-}
+
+-- | Like 'wordBase128LEVar' but inlined, which may bloat your code. On
+-- the other hand, inlining an application to a constant may shrink your code.
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline 42))
+-- [42]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline 5376))
+-- [128,42]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 7 - 1)))
+-- [127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 7)))
+-- [128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 14 - 1)))
+-- [255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 14)))
+-- [128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 21 - 1)))
+-- [255,255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 21)))
+-- [128,128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 28 - 1)))
+-- [255,255,255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 28)))
+-- [128,128,128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 32 - 1)))
+-- [255,255,255,255,15]
+wordBase128LEVar_inline :: Word -> BuildR
+wordBase128LEVar_inline = \x ->
+ Prim.liftBoundedPrim (Prim.wordBase128LEVar_inline x)
+{-# INLINE wordBase128LEVar_inline #-}
+
+-- | Convert a `Word32` to a `BuildR` using this variable-length encoding:
+--
+-- 1. Convert the given value to a base 128 representation
+-- without unnecessary digits (that is, omit zero digits
+-- unless they are less significant than nonzero digits).
+--
+-- 2. Present those base-128 digits in order of increasing
+-- significance (that is, in little-endian order).
+--
+-- 3. Add 128 to every digit except the most significant digit,
+-- yielding a sequence of octets terminated by one that is <= 127.
+--
+-- This encoding is used in the wire format of Protocol Buffers version 3.
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar 42))
+-- [42]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar 5376))
+-- [128,42]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 7 - 1)))
+-- [127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 7)))
+-- [128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 14 - 1)))
+-- [255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 14)))
+-- [128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 21 - 1)))
+-- [255,255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 21)))
+-- [128,128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 28 - 1)))
+-- [255,255,255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 28)))
+-- [128,128,128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 32 - 1)))
+-- [255,255,255,255,15]
+word32Base128LEVar :: Word32 -> BuildR
+word32Base128LEVar = \x -> Prim.liftBoundedPrim (Prim.word32Base128LEVar x)
+{-# INLINE word32Base128LEVar #-}
+
+-- | Like 'word32Base128LEVar' but inlined, which may bloat your code. On
+-- the other hand, inlining an application to a constant may shrink your code.
+--
+-- Currently 'word32Base128LEVar' is fully inline, so this makes no difference,
+-- but in future we might make different default space/speed tradeoffs.
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline 42))
+-- [42]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline 5376))
+-- [128,42]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 7 - 1)))
+-- [127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 7)))
+-- [128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 14 - 1)))
+-- [255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 14)))
+-- [128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 21 - 1)))
+-- [255,255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 21)))
+-- [128,128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 28 - 1)))
+-- [255,255,255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 28)))
+-- [128,128,128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 32 - 1)))
+-- [255,255,255,255,15]
+word32Base128LEVar_inline :: Word32 -> BuildR
+word32Base128LEVar_inline = \x ->
+ Prim.liftBoundedPrim (Prim.word32Base128LEVar_inline x)
+{-# INLINE word32Base128LEVar_inline #-}
+
+-- | Like 'word32Base128LEVar' but for 64-bit inputs.
+--
+-- Inlines when the value fits within 32 bits, but see
+-- also 'word64Base128LEVar_inline', which always inlines.
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar 42))
+-- [42]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar 5376))
+-- [128,42]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 7 - 1)))
+-- [127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 7)))
+-- [128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 14 - 1)))
+-- [255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 14)))
+-- [128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 21 - 1)))
+-- [255,255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 21)))
+-- [128,128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 28 - 1)))
+-- [255,255,255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 28)))
+-- [128,128,128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 32 - 1)))
+-- [255,255,255,255,15]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 32)))
+-- [128,128,128,128,16]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 56 - 1)))
+-- [255,255,255,255,255,255,255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 56)))
+-- [128,128,128,128,128,128,128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 60 - 1)))
+-- [255,255,255,255,255,255,255,255,15]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 60)))
+-- [128,128,128,128,128,128,128,128,16]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 63 - 1)))
+-- [255,255,255,255,255,255,255,255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 63)))
+-- [128,128,128,128,128,128,128,128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (- (1 :: Data.Word.Word64))))
+-- [255,255,255,255,255,255,255,255,255,1]
+word64Base128LEVar :: Word64 -> BuildR
+word64Base128LEVar = \x -> Prim.liftBoundedPrim (Prim.word64Base128LEVar x)
+{-# INLINE word64Base128LEVar #-}
+
+-- | Like 'word64Base128LEVar' but inlined, which may bloat your code. On
+-- the other hand, inlining an application to a constant may shrink your code.
+--
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline 42))
+-- [42]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline 5376))
+-- [128,42]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 7 - 1)))
+-- [127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 7)))
+-- [128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 14 - 1)))
+-- [255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 14)))
+-- [128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 21 - 1)))
+-- [255,255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 21)))
+-- [128,128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 28 - 1)))
+-- [255,255,255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 28)))
+-- [128,128,128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 32 - 1)))
+-- [255,255,255,255,15]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 32)))
+-- [128,128,128,128,16]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 56 - 1)))
+-- [255,255,255,255,255,255,255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 56)))
+-- [128,128,128,128,128,128,128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 60 - 1)))
+-- [255,255,255,255,255,255,255,255,15]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 60)))
+-- [128,128,128,128,128,128,128,128,16]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 63 - 1)))
+-- [255,255,255,255,255,255,255,255,127]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 63)))
+-- [128,128,128,128,128,128,128,128,128,1]
+-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (- (1 :: Data.Word.Word64))))
+-- [255,255,255,255,255,255,255,255,255,1]
+word64Base128LEVar_inline :: Word64 -> BuildR
+word64Base128LEVar_inline = \x ->
+ Prim.liftBoundedPrim (Prim.word64Base128LEVar_inline x)
+{-# INLINE word64Base128LEVar_inline #-}
+
+-- | Essentially 'foldMap', but iterates right to left for efficiency.
+vectorBuildR :: Vector v a => (a -> BuildR) -> v a -> BuildR
+vectorBuildR f = etaBuildR (foldlRVector (\acc x -> acc <> f x) mempty)
+{-# INLINE vectorBuildR #-}
+
+-- | Exported for testing purposes only.
+testWithUnused :: (Int -> BuildR) -> BuildR
+testWithUnused = withUnused
+{-# WARNING testWithUnused "Exported for testing purposes only." #-}
diff --git a/src/Proto3/Wire/Reverse/Internal.hs b/src/Proto3/Wire/Reverse/Internal.hs
new file mode 100644
index 0000000..193c10d
--- /dev/null
+++ b/src/Proto3/Wire/Reverse/Internal.hs
@@ -0,0 +1,715 @@
+{-
+ Copyright 2020 Awake 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.
+-}
+
+-- | Implementation details of the "Data.ByteString.Reverse" module.
+-- Breaking changes will be more frequent in this module; use with caution.
+
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Proto3.Wire.Reverse.Internal
+ ( BuildR(..)
+ , appendBuildR
+ , foldlRVector
+ , toBuildR
+ , fromBuildR
+ , etaBuildR
+ , runBuildR
+ , withUnused
+ , withTotal
+ , withLengthOf
+ , withLengthOf#
+ , reallocate
+ , prependChunk
+ , ReverseChunks(..)
+ , prependReverseChunks
+ , ensure
+ , ensure#
+ , unsafeConsume
+ , floatToWord32
+ , doubleToWord64
+ ) where
+
+import Control.Exception ( bracket )
+import Control.Monad.Trans.State.Strict ( State, runState, state )
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Internal as BI
+import qualified Data.ByteString.Builder.Extra as BB
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Lazy.Internal as BLI
+import Data.IORef ( IORef, newIORef,
+ readIORef, writeIORef )
+import qualified Data.Primitive as P
+import qualified Data.Vector.Generic as VG
+import Data.Vector.Generic ( Vector )
+import Data.Word ( Word8, Word32, Word64 )
+import Foreign ( Storable(..),
+ castPtrToStablePtr,
+ castStablePtrToPtr,
+ freeStablePtr, newStablePtr,
+ deRefStablePtr )
+import GHC.Exts ( Addr#, Int#, MutVar#,
+ RealWorld, StablePtr#, State#,
+ addrToAny#, int2Addr#,
+ touch# )
+import GHC.ForeignPtr ( ForeignPtr(..),
+ ForeignPtrContents(..) )
+import GHC.IO ( IO(..) )
+import GHC.IORef ( IORef(..) )
+import GHC.Int ( Int(..) )
+import GHC.Ptr ( Ptr(..), plusPtr )
+import GHC.Stable ( StablePtr(..) )
+import GHC.STRef ( STRef(..) )
+import System.IO.Unsafe ( unsafePerformIO )
+
+#if MIN_VERSION_primitive(0,7,0)
+#define PTR P.Ptr
+#else
+#define PTR P.Addr
+#endif
+
+-- $setup
+-- >>> :set -XOverloadedStrings
+
+-- | Writes bytes in reverse order, updating the current state.
+--
+-- It is the responsibility of the execution context and buffer
+-- management primitives to ensure that the current buffer remains
+-- reachable during builder execution, though completed buffers
+-- may be copied to new storage at any time. Aside from those
+-- primitives, 'BuildR' implementations may ignore that issue.
+--
+-- When combining `BuildR`s with '<>' we expect the best performance
+-- when associating to the left. For example @'foldl' ('<>') 'mempty'@,
+-- though unless your 'foldl' iteration starts from the right there may
+-- still be issues. Consider using `Proto3.Wire.Reverse.vectorBuildR`
+-- instead of 'foldMap'.
+newtype BuildR = BuildR
+ (Addr# -> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #))
+ -- ^ Both the builder arguments and the returned values are:
+ --
+ -- 1. The starting address of the *used* portion of the current buffer.
+ --
+ -- 2. The number of *unused* bytes in the current buffer.
+ --
+ -- 3. The state token (which does not consume any machine registers).
+ --
+ -- It seems we cannot preserve register allocation between the arguments
+ -- and the returned components, even by including padding. If GHC were to
+ -- allocate registers right-to-left (instead of the current left-to-right),
+ -- and if it made sure to allocate the register that it uses for closure
+ -- arguments *last* when allocating return registers, then we would stand
+ -- a chance of not having to move the state components between registers.
+ -- That way @a -> b -> 'BuildR'@ and 'BuildR' would use the same registers
+ -- for state components as each other, and a non-inline return from one
+ -- could be used to call the other without moving state components.
+ --
+ -- But in many cases register movements combine with increments.
+ -- Also, we have arranged to put only the most frequently-used state
+ -- components into registers, which reduces the costs of both moves
+ -- and of save/reload pairs. For example, our tracking of the total
+ -- bytes written involves metadata at the start of the current buffer
+ -- rather than an additional state register.
+
+instance Semigroup BuildR
+ where
+ (<>) = appendBuildR
+ {-# INLINE (<>) #-}
+
+instance Monoid BuildR
+ where
+ mempty = BuildR (\v u s -> (# v, u, s #))
+ {-# INLINE mempty #-}
+
+ mappend = (<>)
+ {-# INLINE mappend #-}
+
+instance Show BuildR
+ where
+ showsPrec prec builder =
+ showParen (prec > 10)
+ (showString "Proto3.Wire.Reverse.lazyByteString " . shows bytes)
+ where
+ bytes = snd (runBuildR builder)
+
+-- | Needed for rewrite rules; normally you would use '<>'.
+appendBuildR :: BuildR -> BuildR -> BuildR
+appendBuildR = \b c ->
+ let BuildR f = b
+ BuildR g = c
+ in
+ BuildR (\v0 u0 s0 -> case g v0 u0 s0 of (# v1, u1, s1 #) -> f v1 u1 s1)
+{-# INLINE CONLIKE [1] appendBuildR #-}
+
+-- | Like 'foldl' but iterates right-to-left, which
+-- is often useful when creating reverse builders.
+foldlRVector :: Vector v a => (b -> a -> b) -> b -> v a -> b
+foldlRVector f = \z v -> VG.foldr (flip f) z (VG.reverse v)
+ -- It may look like we create a reversed vector here, but thanks to
+ -- the rewrite rules in the vector library the vector is never actually
+ -- allocated, and instead we directly stream elements from right to left.
+{-# INLINE foldlRVector #-}
+
+toBuildR :: (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR
+toBuildR f =
+ BuildR $ \v0 u0 s0 ->
+ let IO g = f (Ptr v0) (I# u0) in
+ case g s0 of (# s1, (Ptr v1, I# u1) #) -> (# v1, u1, s1 #)
+
+fromBuildR :: BuildR -> Ptr Word8 -> Int -> IO (Ptr Word8, Int)
+fromBuildR (BuildR f) (Ptr v0) (I# u0) =
+ IO $ \s0 -> case f v0 u0 s0 of (# v1, u1, s1 #) -> (# s1, (Ptr v1, I# u1) #)
+
+-- | Eta-expands a function that produces a 'BuildR', so that
+-- its input is not evaluated until the builder state is presented.
+--
+-- This odd combinator seems to help performance at times, though
+-- it may change behavior on nonterminating values of type @a@.
+etaBuildR :: (a -> BuildR) -> a -> BuildR
+etaBuildR f x = toBuildR $ \v u -> fromBuildR (f x) v u
+
+-- | The current state of execution of a builder
+-- is a @'StablePtr' ('IORef' 'BuildRState')@.
+--
+-- Current Buffer Layout:
+--
+-- We devote the first few octets of the current buffer
+-- to metadata that does not change very frequently:
+--
+-- * 'Addr#': cast to 'StablePtr# (IORef BuildRState)'; indirect acceses
+-- to the full builder state, which is used relatively infrequently.
+--
+-- * 'Int#': the total number of non-metadata bytes originally available
+-- within the current buffer before we started consuming them,
+-- *plus* the number of bytes actually written to previous buffers.
+-- We subtract the current unused figure to get the total bytes written.
+--
+-- * `GHC.Float.Double#`: suitably-aligned scratch space for serialization
+-- of 'Double' and 'Float' values.
+--
+-- Though this choice imposes a small memory overhead in every buffer,
+-- it reduces the time and space required to save and restore metadata
+-- around the many non-inline calls that typically occur while writing
+-- data into the buffer.
+data BuildRState = BuildRState
+ { currentBuffer :: {-# UNPACK #-}!(P.MutableByteArray RealWorld)
+ -- ^ Specifies the current buffer. Note that through this field
+ -- every @'StablePtr' ('IORef' 'BuildRState')@ keeps one buffer
+ -- reachable until that stable pointer is explicitly destroyed.
+ , sealedBuffers :: BL.ByteString
+ -- ^ Holds the bytes written to previous buffers. We arrange for
+ -- this field to be in normal form (not just weak head normal form).
+ -- But to avoid redundant evaluation we do not mark it strict.
+ }
+
+-- | Allocates fields backward from offset 0 relative to some hypothetical
+-- address, yielding the total size and alignment requirements, respectively,
+-- along with the monadic return value. The total size includes any padding
+-- at the end that is needed to make it a multiple of the overall alignment.
+allocateFields :: State (Int, Int) a -> (a, Int, Int)
+allocateFields fields = (x, size, align)
+ where
+ (x, (off, align)) = runState fields (0, 1)
+ size = mod off align - off
+ -- Aligns the overall size @- off@ by prepending @mod off align@ padding
+ -- bytes. Because @mod off align@ is in @[0, align)@ we are are neither
+ -- removing bytes nor adding more than we need. And for some @k@ we have
+ --
+ -- > mod off align == off + k * align
+ --
+ -- and therefore we achieve the precise alignment desired:
+ --
+ -- > size = (off + k * align) - off == k * align
+
+-- | Within the monadic context established by 'allocateFields',
+-- allocates one suitably-aligned field and returns its offset.
+-- The argument is only a proxy for its type; we never evaluate it,
+-- and therefore you may pass 'undefined'.
+--
+-- WARNING: We assume that 'max' is the same as 'lcm' for any pair of
+-- alignment values, so that we can avoid using 'lcm', which does not
+-- evaluate at compile time. Compile-time evaluation helps our speed.
+allocatePrimitiveField :: Storable a => a -> State (Int, Int) Int
+allocatePrimitiveField proxy = state $ \(prevOff, prevAlign) ->
+ let fieldWidth = sizeOf proxy
+ fieldAlign = alignment proxy
+ unaligned = prevOff - fieldWidth
+ nextOff = unaligned - mod unaligned fieldAlign
+ nextAlign = max prevAlign fieldAlign
+ in (nextOff, (nextOff, nextAlign))
+
+scratchOffset, spaceOffset, stateOffset, metaDataSize, metaDataAlign :: Int
+((scratchOffset, spaceOffset, stateOffset), metaDataSize, metaDataAlign) =
+ allocateFields $
+ (,,) <$> allocatePrimitiveField (undefined :: Double)
+ <*> allocatePrimitiveField (undefined :: Int)
+ <*> allocatePrimitiveField (undefined :: Ptr ())
+ -- Note that we are allocating backward, so this
+ -- will put the pointer at the lowest address.
+
+smallChunkSize, defaultChunkSize :: Int
+smallChunkSize = BB.smallChunkSize - metaDataSize
+defaultChunkSize = BB.defaultChunkSize - metaDataSize
+
+data MetaData
+
+metaPtr :: Ptr Word8 -> Int -> Ptr MetaData
+metaPtr v = plusPtr v . negate
+
+readState :: Ptr MetaData -> IO (StablePtr (IORef BuildRState))
+readState m = castPtrToStablePtr <$> peekByteOff m stateOffset
+
+writeState :: Ptr MetaData -> StablePtr (IORef BuildRState) -> IO ()
+writeState m = pokeByteOff m stateOffset . castStablePtrToPtr
+
+readSpace :: Ptr MetaData -> IO Int
+readSpace m = peekByteOff m spaceOffset
+
+writeSpace :: Ptr MetaData -> Int -> IO ()
+writeSpace m = pokeByteOff m spaceOffset
+
+-- | The arguments are the same as the 'BuildR' arguments.
+readTotal :: Ptr Word8 -> Int -> IO Int
+readTotal v unused = do
+ -- Because we do not wish to update a record of the total
+ -- every time we write a byte, instead we record "space",
+ -- which changes rarely, and subtract "unused" from it
+ -- when we need to compute the total, which is somewhat
+ -- frequent but not as frequent as updates to "unused".
+ space <- readSpace (metaPtr v unused)
+ let !total = space - unused
+
+ -- GHC (at least v8.2.2 and v8.6.5) seems quite eager to delay the above
+ -- subtraction, even though we have indicated that the computation of
+ -- "total" is strict, and even though delaying the subtraction across
+ -- a non-inline call requires saving and restoring two registers
+ -- ("space" and "unused") instead of one ("total"). Unless we were to
+ -- completely ignore the result of the subtraction, which would be quite
+ -- unusual, an eager subtraction is faster. Therefore we force it:
+ strictify total
+
+-- | Sometimes GHC (at least v8.2.2 and v8.6.5) appears to be lazy even with
+-- unlifted values, and we apply this combination to force computation so that
+-- we do not have to save and restore the several inputs to the computation.
+--
+-- The implementation requires converting the 'Int#' to a lifted pointer
+-- type and then invoking 'touch#' on it, which is slightly questionable
+-- because we would crash if the garbage collector actually followed the
+-- converted value. But there would be no reason to collect between the
+-- conversion and the 'touch#' because that span involves no computation.
+strictify :: Int -> IO Int
+strictify (I# x) = IO $ \s0 ->
+ case addrToAny# (int2Addr# x) of
+ (# y #) -> case touch# y s0 of
+ s1 -> (# s1, I# x #)
+
+-- | Allocates a new buffer and stores a pointer to that buffer in
+-- the 'currentBuffer' field of the overall builder state, along with the
+-- first argument, then returns a pointer to the end of the payload area.
+--
+-- (This is a manual wrapper around 'newBuffer#'.)
+newBuffer ::
+ -- | All bytes previously written.
+ --
+ -- It is ASSUMED that the caller already fully
+ -- evaluated this otherwise-lazy 'BL.ByteString'.
+ BL.ByteString ->
+ -- | Total number of bytes previously written.
+ Int ->
+ -- | Builder state variable. The old value of this variable
+ -- will NOT be used; rather, it will be overwritten.
+ -- Therefore that old value may be 'undefined'.
+ IORef BuildRState ->
+ -- | Stable pointer to builder state variable.
+ StablePtr (IORef BuildRState) ->
+ -- | Desired payload size of new current buffer, not counting metadata.
+ Int ->
+ IO (Ptr Word8)
+newBuffer sealed (I# total) (IORef (STRef stateVar)) (StablePtr stateSP)
+ (I# unused) =
+ IO $ \s0 ->
+ case newBuffer# sealed total stateVar stateSP unused s0 of
+ (# s1, addr #) -> (# s1, Ptr addr #)
+
+newBuffer# ::
+ BL.ByteString ->
+ Int# ->
+ MutVar# RealWorld BuildRState ->
+ StablePtr# (IORef BuildRState) ->
+ Int# ->
+ State# RealWorld ->
+ (# State# RealWorld, Addr# #)
+newBuffer# sealed total stateVar stateSP unused s0 =
+ case go s0 of
+ (# s1, Ptr addr #) -> (# s1, addr #)
+ where
+ IO go = do
+ let allocation = metaDataSize + I# unused
+ buf <- P.newAlignedPinnedByteArray allocation metaDataAlign
+ let !(PTR base) = P.mutableByteArrayContents buf
+ !v = plusPtr (Ptr base) (metaDataSize + I# unused)
+ !m = plusPtr (Ptr base) metaDataSize
+ writeState m (StablePtr stateSP)
+ writeSpace m (I# unused + I# total)
+ let !nextState = BuildRState{currentBuffer = buf, sealedBuffers = sealed}
+ writeIORef (IORef (STRef stateVar)) nextState
+ pure v
+
+-- | The result of a call to 'sealBuffer'.
+data SealedState = SealedState
+ { sealedSB :: BL.ByteString
+ -- ^ All bytes written thus far.
+ , totalSB :: {-# UNPACK #-}!Int
+ -- ^ The total number of bytes written thus far.
+ , stateVarSB :: {-# UNPACK #-}!(IORef BuildRState)
+ -- ^ The builder state variable.
+ -- This function does NOT modify that variable--it will still
+ -- refer to the old buffer unless and until you modify it.
+ , statePtrSB :: {-# UNPACK #-}!(StablePtr (IORef BuildRState))
+ -- ^ The stable pointer to the variable referenced by 'stateVarSB'.
+ , recycledSB :: Maybe (P.MutableByteArray RealWorld)
+ -- ^ Returns ownership of the old current buffer to the caller
+ -- if it is no longer needed to track the already-written bytes.
+ --
+ -- If you reuse it within the same builder then there is
+ -- no need to reset the stable pointer to the state variable,
+ -- but please be sure to update the "space" metadatum.
+ }
+
+-- | Takes ownership of the current buffer,
+-- but sometimes hands it back for reuse.
+--
+-- If more building is required then please allocate a new current buffer
+-- and update the builder state variable accordingly.
+--
+-- (This is a manual wrapper around 'sealBuffer#'.)
+sealBuffer ::
+ -- | Pointer to the used portion of the current buffer.
+ Ptr Word8 ->
+ -- | The number of bytes still unused in the current buffer.
+ Int ->
+ IO SealedState
+sealBuffer (Ptr addr) (I# u) = IO $ \s0 ->
+ case sealBuffer# addr u s0 of
+ (# s1, sealed, total, stateVar, statePtr, recycled #) ->
+ (# s1
+ , SealedState
+ { sealedSB = sealed
+ , totalSB = I# total
+ , stateVarSB = IORef (STRef stateVar)
+ , statePtrSB = StablePtr statePtr
+ , recycledSB = recycled
+ }
+ #)
+
+sealBuffer# ::
+ Addr# ->
+ Int# ->
+ State# RealWorld ->
+ (# State# RealWorld
+ , BL.ByteString
+ , Int#
+ , MutVar# RealWorld BuildRState
+ , StablePtr# (IORef BuildRState)
+ , Maybe (P.MutableByteArray RealWorld)
+ #)
+sealBuffer# addr unused s0 =
+ case go s0 of
+ (# s1, (sealed, I# total, IORef (STRef sv), StablePtr sp, re) #) ->
+ (# s1, sealed, total, sv, sp, re #)
+ where
+ IO go = do
+ let v = Ptr addr
+ statePtr <- readState (metaPtr v (I# unused))
+ stateVar <- deRefStablePtr statePtr
+ BuildRState { currentBuffer = buffer, sealedBuffers = oldSealed } <-
+ readIORef stateVar
+ total <- readTotal v (I# unused)
+ -- The above call to 'readTotal' is the last access of the current
+ -- buffer through a raw pointer made by this function. Therefore
+ -- we must be sure that the current buffer remains reachable at this
+ -- point in the state thread. And we are sure of that fact, because
+ -- 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
+ if allocation <= I# unused
+ then
+ pure (oldSealed, total, stateVar, statePtr, Just buffer)
+ else do
+ let !(PTR base) = P.mutableByteArrayContents buffer
+ !(P.MutableByteArray mba) = buffer
+ fp = ForeignPtr base (PlainPtr mba)
+ offset = metaDataSize + I# unused
+ finish trimmed recycled = do
+ let !newSealed = BLI.Chunk trimmed oldSealed
+ pure (newSealed, total, stateVar, statePtr, recycled)
+ untrimmed = BI.fromForeignPtr fp offset (allocation - I# unused)
+ if offset <= B.length untrimmed
+ then finish untrimmed Nothing
+ else finish (B.copy untrimmed) (Just buffer)
+
+-- | Like `Proto3.Wire.Reverse.toLazyByteString` but also
+-- returns the total length of the lazy 'BL.ByteString',
+-- which is computed as a side effect of encoding.
+runBuildR :: BuildR -> (Int, BL.ByteString)
+runBuildR f = unsafePerformIO $ do
+ stateVar <- newIORef undefined -- undefined only until 'newBuffer'
+ bracket (newStablePtr stateVar) freeStablePtr $ \statePtr -> do
+ let u0 = smallChunkSize
+ v0 <- newBuffer BL.empty 0 stateVar statePtr u0
+ (v1, u1) <- fromBuildR f v0 u0
+ SealedState { sealedSB = bytes, totalSB = total } <- sealBuffer v1 u1
+ pure (total, bytes)
+
+-- | First reads the number of unused bytes in the current buffer.
+withUnused :: (Int -> BuildR) -> BuildR
+withUnused f = toBuildR $ \v u -> fromBuildR (f u) v u
+
+-- | First reads the number of bytes previously written.
+withTotal :: (Int -> BuildR) -> BuildR
+withTotal f = withTotal# (\total -> f (I# total))
+
+-- | First reads the number of bytes previously written.
+withTotal# :: (Int# -> BuildR) -> BuildR
+withTotal# f = toBuildR $ \v u -> do
+ I# total <- readTotal v u
+ fromBuildR (f total) v u
+
+-- | Executes the right builder, measuring how many bytes
+-- it writes, then provides that figure to the left builder.
+withLengthOf :: (Int -> BuildR) -> BuildR -> BuildR
+withLengthOf = \f g -> withLengthOf# (\len -> f (I# len)) g
+{-# INLINE CONLIKE withLengthOf #-}
+
+-- | Executes the right builder, measuring how many bytes
+-- it writes, then provides that figure to the left builder.
+withLengthOf# :: (Int# -> BuildR) -> BuildR -> BuildR
+withLengthOf# = \f g -> toBuildR $ \v0 u0 -> do
+ !before <- readTotal v0 u0
+ (v1, u1) <- fromBuildR g v0 u0
+ !after <- readTotal v1 u1
+ let !(I# len) = after - before
+ fromBuildR (f len) v1 u1
+{-# INLINE CONLIKE [1] withLengthOf# #-} -- See Prim module for rules.
+
+-- | Seals the current buffer and creates a new
+-- one with at least the given number of bytes.
+reallocate :: Int -> BuildR
+reallocate (I# required) = reallocate# required
+
+reallocate# :: Int# -> BuildR
+reallocate# required = toBuildR $ \v0 u0 -> do
+ SealedState
+ { sealedSB = bytes
+ , totalSB = total
+ , stateVarSB = IORef (STRef stateVar)
+ , statePtrSB = StablePtr statePtr
+ } <- sealBuffer v0 u0
+ let !u1 = max (I# required) defaultChunkSize
+ v1 <- newBuffer bytes total (IORef (STRef stateVar)) (StablePtr statePtr) u1
+ pure (v1, u1)
+{-# NOINLINE reallocate# #-} -- Avoid code bloat in library clients.
+
+-- | Called by 'prependChunk' and 'prependReverseChunks'
+-- to prepare a current buffer.
+--
+-- (This is a manual wrapper around 'afterPrependChunks#'.)
+afterPrependChunks :: SealedState -> IO (Ptr Word8, Int)
+afterPrependChunks !st = IO $ \s0 ->
+ case afterPrependChunks# st s0 of
+ (# v1, u1, s1 #) -> (# s1, (Ptr v1, I# u1) #)
+
+afterPrependChunks# ::
+ SealedState ->
+ State# RealWorld ->
+ (# Addr#, Int#, State# RealWorld #)
+afterPrependChunks# SealedState
+ { sealedSB = sealed
+ , totalSB = total
+ , stateVarSB = stateVar
+ , statePtrSB = statePtr
+ , recycledSB = recycled
+ } s0 =
+ case go s0 of (# s2, (Ptr v2, I# u2) #) -> (# v2, u2, s2 #)
+ where
+ IO go = case recycled of
+ Nothing -> do
+ -- The old buffer is part of 'sealed'. Allocate a new buffer.
+ let u1 = defaultChunkSize
+ v1 <- newBuffer sealed total stateVar statePtr u1
+ pure (v1, u1)
+
+ 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
+ !v1 = plusPtr (Ptr base) (metaDataSize + u1)
+ !m = plusPtr (Ptr base) metaDataSize
+ writeSpace m (u1 + total)
+ let !nextState = BuildRState
+ { currentBuffer = buf, sealedBuffers = sealed }
+ writeIORef stateVar nextState
+ pure (v1, u1)
+
+-- | Prepends a 'B.ByteString' to the output.
+--
+-- NOTE: This is a relatively heavyweight operation. For small
+-- strings it may be faster to copy them to the current buffer.
+prependChunk :: B.ByteString -> BuildR
+prependChunk (BI.PS (ForeignPtr ad ct) (I# off) (I# len))
+ | I# len == 0 = mempty
+ | otherwise = BuildR (\v u s -> prependChunk# v u s ad ct off len)
+
+prependChunk# ::
+ -- | Used bytes.
+ Addr# ->
+ -- | Count of unused bytes.
+ Int# ->
+ -- | State token.
+ State# RealWorld ->
+ -- | Base address of 'B.ByteString'.
+ Addr# ->
+ -- | Finalizer for 'B.ByteString'.
+ ForeignPtrContents ->
+ -- | Offset from base of 'B.ByteString'.
+ Int# ->
+ -- | Length of 'B.ByteString'.
+ Int# ->
+ (# Addr#, Int#, State# RealWorld #)
+prependChunk# v u s ad ct off len = go v u s
+ where
+ BuildR go = toBuildR $ \v1 u1 -> do
+ SealedState
+ { sealedSB = oldSealed
+ , totalSB = oldTotal
+ , stateVarSB = stateVar
+ , statePtrSB = statePtr
+ , recycledSB = recycled
+ } <- sealBuffer v1 u1
+
+ let chunk = BI.PS (ForeignPtr ad ct) (I# off) (I# len)
+
+ afterPrependChunks SealedState
+ { sealedSB = BLI.Chunk chunk oldSealed
+ , totalSB = I# len + oldTotal
+ , stateVarSB = stateVar
+ , statePtrSB = statePtr
+ , recycledSB = recycled
+ }
+
+-- | Like 'BL.ByteString', but with the chunks in reverse order,
+-- even though the bytes within each chunk are in forward order.
+newtype ReverseChunks = ReverseChunks { getReverseChunks :: BL.ByteString }
+
+-- | Equivalent to the following, but faster:
+--
+-- > foldMap prependChunk . reverse . getReverseChunks
+--
+-- NOTE: This is a relatively heavyweight operation. For small
+-- strings it may be faster to copy them to the current buffer.
+prependReverseChunks :: ReverseChunks -> BuildR
+prependReverseChunks (ReverseChunks BLI.Empty) = mempty
+prependReverseChunks
+ (ReverseChunks (BLI.Chunk (BI.PS (ForeignPtr ad ct) (I# off) (I# len)) cs)) =
+ BuildR (\v u s -> prependReverseChunks# v u s ad ct off len cs)
+
+prependReverseChunks# ::
+ -- | Used bytes.
+ Addr# ->
+ -- | Count of unused bytes.
+ Int# ->
+ -- | State token.
+ State# RealWorld ->
+ -- | Base address of first 'B.ByteString' chunk.
+ Addr# ->
+ -- | Finalizer for first 'B.ByteString' chunk.
+ ForeignPtrContents ->
+ -- | Offset from base of first 'B.ByteString' chunk.
+ Int# ->
+ -- | Length of first 'B.ByteString' chunk.
+ Int# ->
+ -- | Other chunks.
+ BL.ByteString ->
+ (# Addr#, Int#, State# RealWorld #)
+prependReverseChunks# v0 u0 s0 ad ct off len cs0 = go v0 u0 s0
+ where
+ BuildR go = toBuildR $ \v1 u1 -> do
+ SealedState
+ { sealedSB = oldSealed
+ , totalSB = oldTotal
+ , stateVarSB = stateVar
+ , statePtrSB = statePtr
+ , recycledSB = recycled
+ } <- sealBuffer v1 u1
+
+ let appendChunks !total sealed (BLI.Chunk c cs) =
+ appendChunks (B.length c + total) (BLI.Chunk c sealed) cs
+ appendChunks newTotal newSealed BLI.Empty =
+ afterPrependChunks SealedState
+ { sealedSB = newSealed
+ , totalSB = newTotal
+ , stateVarSB = stateVar
+ , statePtrSB = statePtr
+ , recycledSB = recycled
+ }
+
+ let rchunks = BLI.Chunk (BI.PS (ForeignPtr ad ct) (I# off) (I# len)) cs0
+
+ appendChunks oldTotal oldSealed rchunks
+
+-- | Ensures that the current buffer has at least the given
+-- number of bytes before executing the given builder.
+ensure :: Int -> BuildR -> BuildR
+ensure (I# required) f = ensure# required f
+
+ensure# :: Int# -> BuildR -> BuildR
+ensure# required (BuildR f) = BuildR $ \v u s ->
+ if I# required <= I# u
+ then f v u s
+ else let BuildR g = BuildR f <> reallocate# required in g v u s
+
+-- | ASSUMES that the specified number of bytes is both nonnegative and
+-- less than or equal to the number of unused bytes in the current buffer,
+-- consumes that number of unused bytes, and provides their starting address.
+unsafeConsume :: Int -> (Ptr Word8 -> IO ()) -> BuildR
+unsafeConsume = \width f ->
+ toBuildR $ \v0 u0 -> do
+ let !m = - width
+ !v1 = plusPtr v0 m
+ !u1 = u0 + m
+ f v1
+ pure (v1, u1)
+{-# INLINE unsafeConsume #-}
+
+-- | Given the builder inputs and a 'Float', converts
+-- that number to its bit pattern in native byte order.
+floatToWord32 :: Ptr Word8 -> Int -> Float -> IO Word32
+floatToWord32 v u x = do
+ let m = metaPtr v u
+ pokeByteOff m scratchOffset x
+ peekByteOff m scratchOffset
+
+-- | Given the builder inputs and a 'Double', converts
+-- that number to its bit pattern in native byte order.
+doubleToWord64 :: Ptr Word8 -> Int -> Double -> IO Word64
+doubleToWord64 v u x = do
+ let m = metaPtr v u
+ pokeByteOff m scratchOffset x
+ peekByteOff m scratchOffset
diff --git a/src/Proto3/Wire/Reverse/Prim.hs b/src/Proto3/Wire/Reverse/Prim.hs
new file mode 100644
index 0000000..3113baa
--- /dev/null
+++ b/src/Proto3/Wire/Reverse/Prim.hs
@@ -0,0 +1,838 @@
+{-
+ Copyright 2020 Awake 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.
+-}
+
+-- | Implementation details of the "Data.ByteString.Reverse" module.
+-- Breaking changes will be more frequent in this module; use with caution.
+
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Proto3.Wire.Reverse.Prim
+ ( -- * Combine types such as `BoundedPrim` and `FixedPrim`.
+ AssocPlusNat(..)
+ , CommPlusNat(..)
+ , PChoose(..)
+ , Max
+ , AssocMaxNat(..)
+ , CommMaxNat(..)
+
+ -- * Architectural attributes.
+ , StoreMethod(..)
+ , storeMethod
+ , ByteOrder(..)
+ , systemByteOrder
+
+ -- * Bounded primitives.
+ , BoundedPrim(..)
+ , liftBoundedPrim
+ , composeBoundedPrim
+ , unsafeBuildBoundedPrim
+
+ -- * Fixed-width primitives.
+ , FixedPrim
+ , liftFixedPrim
+ , word8
+ , word16
+ , word16Native
+ , word16BE
+ , word16LE
+ , word32
+ , word32Native
+ , word32BE
+ , word32LE
+ , word64
+ , word64Native
+ , word64BE
+ , word64LE
+ , int8
+ , int16
+ , int16Native
+ , int16BE
+ , int16LE
+ , int32
+ , int32Native
+ , int32BE
+ , int32LE
+ , int64
+ , int64Native
+ , int64BE
+ , int64LE
+ , float
+ , floatNative
+ , floatBE
+ , floatLE
+ , double
+ , doubleNative
+ , doubleBE
+ , doubleLE
+ , charUtf8
+ , wordBase128LEVar
+ , wordBase128LEVar_inline
+ , word32Base128LEVar
+ , word32Base128LEVar_inline
+ , word64Base128LEVar
+ , word64Base128LEVar_inline
+ , vectorFixedPrim
+ ) where
+
+import Data.Bits ( Bits(..) )
+import Data.Bool ( bool )
+import Data.Char ( ord )
+import Data.Int ( Int8, Int16, Int32, Int64 )
+import Data.Kind ( Type )
+import qualified Data.Vector.Generic
+import Data.Word ( Word16,
+ byteSwap16, byteSwap32,
+ byteSwap64 )
+import Foreign ( Storable(..) )
+import GHC.Exts ( Addr#, Int#, Proxy#,
+ RealWorld, State#, (+#),
+ and#, inline, or#,
+ plusAddr#, plusWord#, proxy#,
+ uncheckedShiftRL# )
+import GHC.IO ( IO(..) )
+import GHC.Int ( Int(..) )
+import GHC.Ptr ( Ptr(..) )
+import GHC.TypeLits ( KnownNat, Nat,
+ type (+), natVal' )
+import GHC.Word ( Word(..), Word8(..),
+ Word32(..), Word64(..) )
+import Parameterized.Data.Semigroup ( PNullary, PSemigroup(..),
+ (&<>) )
+import Parameterized.Data.Monoid ( PMEmpty(..) )
+import Proto3.Wire.Reverse.Internal
+import Proto3.Wire.Reverse.Width ( AssocPlusNat(..),
+ CommPlusNat(..),
+ PChoose(..),
+ Max, AssocMaxNat(..),
+ CommMaxNat(..) )
+
+#include <MachDeps.h> /* for WORDS_BIGENDIAN and WORD_SIZE_IN_BITS */
+
+-- "ghc-prim" v0.6.1 defines `GHC.Prim.Ext.WORD64`, but we do not wish
+-- to require that version of "ghc-prim". Therefore we define it locally.
+#if WORD_SIZE_IN_BITS < 64
+import GHC.IntWord64 (Word64#)
+type WORD64 = Word64#
+#else
+import GHC.Exts (Word#)
+type WORD64 = Word#
+#endif
+
+-- $setup
+-- >>> :set -XOverloadedStrings
+
+-- | Are we restricted to aligned writes only?
+data StoreMethod = StoreAligned | StoreUnaligned
+ deriving (Eq, Show)
+
+-- | 'StoreUnaligned' if the Cabal file defines @UNALIGNED_POKES@, which it
+-- does on architectures where that approach is known to be safe and faster
+-- then writing bytes one by one. Otherwise 'StoreAligned'.
+storeMethod :: StoreMethod
+#if defined(UNALIGNED_POKES)
+storeMethod = StoreUnaligned
+#else
+storeMethod = StoreAligned
+#endif
+
+-- | Specifies order in which the bytes of an integer are encoded.
+data ByteOrder
+ = BigEndian -- ^ Most significant byte first.
+ | LittleEndian -- ^ Least significant byte first.
+ deriving (Eq, Show)
+
+-- | The 'ByteOrder' native to the current architecture.
+--
+-- For example, the order of the bytes when you poke a 'Word32'.
+systemByteOrder :: ByteOrder
+-- WORDS_BIGENDIAN is defined for big-endian architectures
+-- by the GHC header <MachDeps.h>.
+#if defined(WORDS_BIGENDIAN)
+systemByteOrder = BigEndian
+#else
+systemByteOrder = LittleEndian
+#endif
+
+-- | A 'BuildR' together with a type-level bound on the number of bytes
+-- written and a requirement that the current buffer already contain at
+-- least that many bytes.
+--
+-- As in the "bytestring" package, the purpose of a bounded primitive is to
+-- improve speed by consolidating the space checks of several small builders.
+newtype BoundedPrim (w :: Nat) = BoundedPrim BuildR
+
+type role BoundedPrim nominal
+
+type instance PNullary BoundedPrim width = BoundedPrim width
+
+instance (w1 + w2) ~ w3 =>
+ PSemigroup BoundedPrim w1 w2 w3
+ where
+ pmappend = composeBoundedPrim
+ {-# INLINE CONLIKE pmappend #-}
+
+instance AssocPlusNat BoundedPrim u v w
+ where
+ assocLPlusNat = assocLPlusNatBoundedPrim
+ {-# INLINE CONLIKE assocLPlusNat #-}
+
+ assocRPlusNat = assocRPlusNatBoundedPrim
+ {-# INLINE CONLIKE assocRPlusNat #-}
+
+instance CommPlusNat BoundedPrim u v
+ where
+ commPlusNat _ (BoundedPrim f) = BoundedPrim f
+ {-# INLINE CONLIKE commPlusNat #-}
+
+instance PMEmpty BoundedPrim 0
+ where
+ pmempty = BoundedPrim mempty
+ {-# INLINE CONLIKE pmempty #-}
+
+instance Max u v ~ w =>
+ PChoose BoundedPrim u v w
+ where
+ pbool = \(BoundedPrim f) (BoundedPrim g) -> BoundedPrim . bool f g
+ {-# INLINE CONLIKE pbool #-}
+
+instance AssocMaxNat BoundedPrim u v w
+ where
+ assocLMaxNat = \_ (BoundedPrim f) -> BoundedPrim f
+ {-# INLINE CONLIKE assocLMaxNat #-}
+
+ assocRMaxNat = \_ (BoundedPrim f) -> BoundedPrim f
+ {-# INLINE CONLIKE assocRMaxNat #-}
+
+instance CommMaxNat BoundedPrim u v
+ where
+ commMaxNat = \_ (BoundedPrim f) -> BoundedPrim f
+ {-# INLINE CONLIKE commMaxNat #-}
+
+-- | Like 'assocLPlusNat' but can be used in rules without
+-- causing GHC to think the class dictionary is recursive.
+assocLPlusNatBoundedPrim ::
+ forall u v w .
+ Proxy# '(u, v, w) -> BoundedPrim (u + (v + w)) -> BoundedPrim ((u + v) + w)
+assocLPlusNatBoundedPrim = \_ (BoundedPrim f) -> BoundedPrim f
+{-# INLINE CONLIKE assocLPlusNatBoundedPrim #-}
+
+-- | Like 'assocRPlusNat' but can be used in rules without
+-- causing GHC to think the class dictionary is recursive.
+assocRPlusNatBoundedPrim ::
+ forall u v w .
+ Proxy# '(u, v, w) -> BoundedPrim ((u + v) + w) -> BoundedPrim (u + (v + w))
+assocRPlusNatBoundedPrim = \_ (BoundedPrim f) -> BoundedPrim f
+{-# INLINE CONLIKE assocRPlusNatBoundedPrim #-}
+
+-- | Needed for rewrite rules; normally you would use 'pmappend' or '(&<>)'.
+composeBoundedPrim :: BoundedPrim v -> BoundedPrim w -> BoundedPrim (v + w)
+composeBoundedPrim =
+ \(BoundedPrim f) (BoundedPrim g) -> BoundedPrim (f <> g)
+{-# INLINE CONLIKE [1] composeBoundedPrim #-}
+
+-- | Executes the bounded primitive WITHOUT first ensuring it has enough space.
+unsafeBuildBoundedPrim :: BoundedPrim w -> BuildR
+unsafeBuildBoundedPrim (BoundedPrim build) = build
+
+-- | Executes the given bounded primitive
+-- after obtaining the space it requires.
+liftBoundedPrim :: forall w . KnownNat w => BoundedPrim w -> BuildR
+liftBoundedPrim = case fromInteger (natVal' (proxy# :: Proxy# w)) of
+ I# w -> unsafeLiftBoundedPrim w
+{-# INLINE CONLIKE liftBoundedPrim #-}
+
+-- | Needed for rewrite rules; normally you would use 'liftBoundedPrim'.
+unsafeLiftBoundedPrim :: Int# -> BoundedPrim w -> BuildR
+unsafeLiftBoundedPrim = \w (BoundedPrim f) -> ensure# w f
+{-# INLINE CONLIKE [1] unsafeLiftBoundedPrim #-}
+
+{-# RULES
+
+"appendBuildR/unsafeLiftBoundedPrim" forall w1 w2 f1 f2 .
+ appendBuildR (unsafeLiftBoundedPrim w1 f1) (unsafeLiftBoundedPrim w2 f2)
+ = unsafeLiftBoundedPrim (w1 +# w2) (composeBoundedPrim f1 f2)
+
+"appendBuildR/unsafeLiftBoundedPrim/assoc_r" forall w1 w2 f1 f2 b .
+ appendBuildR (unsafeLiftBoundedPrim w1 f1)
+ (appendBuildR (unsafeLiftBoundedPrim w2 f2) b)
+ = appendBuildR (unsafeLiftBoundedPrim (w1 +# w2) (composeBoundedPrim f1 f2)) b
+
+"appendBuildR/unsafeLiftBoundedPrim/assoc_l" forall w1 w2 f1 f2 b .
+ appendBuildR (appendBuildR b (unsafeLiftBoundedPrim w1 f1))
+ (unsafeLiftBoundedPrim w2 f2)
+ = appendBuildR b (unsafeLiftBoundedPrim (w1 +# w2) (composeBoundedPrim f1 f2))
+
+ #-}
+
+-- | Similar to a 'BoundedPrim' but also consolidates address updates in
+-- order to take advantage of machine instructions that write at an offset.
+--
+-- The additional input is an offset from the current address
+-- that specifies the beginning of the region being encoded.
+--
+-- (If GHC learns to consolidate address offsets automatically
+-- then we might be able to just use 'BoundedPrim' instead.)
+newtype FixedPrim (w :: Nat) = FixedPrim
+ ( Addr# -> Int# -> State# RealWorld -> Int# ->
+ (# Addr#, Int#, State# RealWorld #)
+ )
+
+type role FixedPrim nominal
+
+type instance PNullary FixedPrim width = FixedPrim width
+
+instance ((w1 + w2) ~ w3, KnownNat w1) =>
+ PSemigroup FixedPrim w1 w2 w3
+ where
+ pmappend = \(FixedPrim f) (FixedPrim g) ->
+ case fromInteger (natVal' (proxy# :: Proxy# w1)) of
+ I# w1 -> FixedPrim
+ ( \v0 u0 s0 o -> case g v0 u0 s0 (o +# w1) of
+ (# v1, u1, s1 #) -> f v1 u1 s1 o )
+ {-# INLINE CONLIKE pmappend #-}
+
+instance AssocPlusNat FixedPrim u v w
+ where
+ assocLPlusNat = \_ (FixedPrim f) -> FixedPrim f
+ {-# INLINE CONLIKE assocLPlusNat #-}
+
+ assocRPlusNat = \_ (FixedPrim f) -> FixedPrim f
+ {-# INLINE CONLIKE assocRPlusNat #-}
+
+instance CommPlusNat FixedPrim u v
+ where
+ commPlusNat = \_ (FixedPrim f) -> FixedPrim f
+ {-# INLINE CONLIKE commPlusNat #-}
+
+instance PMEmpty FixedPrim 0
+ where
+ pmempty = FixedPrim (\v u s _ -> (# v, u, s #))
+ {-# INLINE CONLIKE pmempty #-}
+
+-- | Executes the given fixed primitive and adjusts the current address.
+liftFixedPrim :: forall w . KnownNat w => FixedPrim w -> BoundedPrim w
+liftFixedPrim = \(FixedPrim f) -> BoundedPrim (BuildR (g f))
+ where
+ !(I# o) = - fromInteger (natVal' (proxy# :: Proxy# w))
+ g = \f v0 u0 s0 -> case f v0 u0 s0 o of
+ (# v1, u1, s1 #) -> (# plusAddr# v1 o, u1 +# o, s1 #)
+ {-# INLINE g #-}
+{-# INLINE CONLIKE [1] liftFixedPrim #-}
+
+{-# RULES
+
+"composeBoundedPrim/liftFixedPrim"
+ forall (f1 :: KnownNat w1 => FixedPrim w1)
+ (f2 :: KnownNat (w1 + w2) => FixedPrim w2).
+ composeBoundedPrim (liftFixedPrim f1) (liftFixedPrim f2)
+ = liftFixedPrim (pmappend f1 f2)
+
+"composeBoundedPrim/liftFixedPrim/assoc_r"
+ forall (f1 :: KnownNat w1 => FixedPrim w1)
+ (f2 :: KnownNat (w1 + w2) => FixedPrim w2)
+ (b3 :: BoundedPrim w3) .
+ composeBoundedPrim (liftFixedPrim f1)
+ (composeBoundedPrim (liftFixedPrim f2) b3)
+ = assocRPlusNatBoundedPrim (proxy# :: Proxy# '(w1, w2, w3))
+ (composeBoundedPrim (liftFixedPrim (pmappend f1 f2)) b3)
+
+"composeBoundedPrim/liftFixedPrim/assoc_l"
+ forall (b1 :: BoundedPrim w1)
+ (f2 :: KnownNat w2 => FixedPrim w2)
+ (f3 :: KnownNat (w2 + w3) => FixedPrim w3) .
+ composeBoundedPrim (composeBoundedPrim b1 (liftFixedPrim f2))
+ (liftFixedPrim f3)
+ = assocLPlusNatBoundedPrim (proxy# :: Proxy# '(w1, w2, w3))
+ (composeBoundedPrim b1 (liftFixedPrim (pmappend f2 f3)))
+
+"withLengthOf#/unsafeLiftBoundedPrim/liftFixedPrim" forall f w g .
+ withLengthOf# f (unsafeLiftBoundedPrim w (liftFixedPrim g))
+ = appendBuildR (f w) (unsafeLiftBoundedPrim w (liftFixedPrim g))
+
+ #-}
+
+-- | Required:
+--
+-- > fromInteger (natVal' (proxy# :: Proxy# (StorableWidth a))) =
+-- > sizeOf (undefined :: x)
+type family StorableWidth (a :: Type) :: Nat
+
+type instance StorableWidth Word8 = 1
+type instance StorableWidth Word16 = 2
+type instance StorableWidth Word32 = 4
+type instance StorableWidth Word64 = 8
+
+type instance StorableWidth Int8 = 1
+type instance StorableWidth Int16 = 2
+type instance StorableWidth Int32 = 4
+type instance StorableWidth Int64 = 8
+
+type instance StorableWidth Float = 4
+type instance StorableWidth Double = 8
+
+-- | WARNING: The write may be unaligned; check 'storeMethod' first.
+primPoke :: Storable x => x -> FixedPrim (StorableWidth x)
+primPoke !x = FixedPrim p
+ where
+ p v u s0 o =
+ let IO q = pokeByteOff (Ptr v) (I# o) x
+ in case q s0 of (# s1, (_ :: ()) #) -> (# v, u, s1 #)
+
+-- | Fixed-width primitive that writes a single byte as-is.
+word8 :: Word8 -> FixedPrim 1
+word8 = primPoke
+ -- Byte order and alignment do not matter for a single byte.
+
+-- | Shifts right by @s@ bits, then writes the least significant byte.
+word8Shift :: Int -> Word -> FixedPrim 1
+word8Shift s x = word8 (fromIntegral (shiftR x s))
+
+-- | Shifts right by @s@ bits, then writes the least significant 16-bit word.
+word16Shift :: ByteOrder -> Int -> Word -> FixedPrim 2
+word16Shift bo = case bo of
+ BigEndian -> \(!s) (!x) -> p (s + h) x &<> p s x
+ LittleEndian -> \(!s) (!x) -> p s x &<> p (s + h) x
+ where
+ h = 8
+ p = word8Shift
+
+-- | Writes the least significant 32-bit word, one byte at a time.
+word32Shift :: ByteOrder -> Word -> FixedPrim 4
+word32Shift bo = case bo of
+ BigEndian -> \(!x) -> p h x &<> p 0 x
+ LittleEndian -> \(!x) -> p 0 x &<> p h x
+ where
+ h = 16
+ p = word16Shift bo
+
+-- | Writes one byte at a time.
+word64Shift :: ByteOrder -> Word64 -> FixedPrim 8
+word64Shift bo = case bo of
+ BigEndian -> \(!x) -> p (h x) &<> p x
+ LittleEndian -> \(!x) -> p x &<> p (h x)
+ where
+ h x = shiftR x 32
+ p = word32Shift bo . fromIntegral @Word64 @Word
+
+-- | Fixed-width primitive that writes a 16-bit word
+-- in the specified byte order.
+word16 :: ByteOrder -> Word16 -> FixedPrim 2
+word16 !bo !x = case storeMethod of
+ StoreAligned -> word16Shift bo 0 (fromIntegral x)
+ StoreUnaligned
+ | systemByteOrder == bo -> primPoke x
+ | otherwise -> primPoke (byteSwap16 x)
+
+-- | Fixed-width primitive that writes a 16-bit word
+-- in native byte order.
+word16Native :: Word16 -> FixedPrim 2
+word16Native = word16 systemByteOrder
+
+-- | Fixed-width primitive that writes a 16-bit word
+-- in big-endian byte order.
+word16BE :: Word16 -> FixedPrim 2
+word16BE = word16 BigEndian
+
+-- | Fixed-width primitive that writes a 16-bit word
+-- in little-endian byte order.
+word16LE :: Word16 -> FixedPrim 2
+word16LE = word16 LittleEndian
+
+-- | Fixed-width primitive that writes a 32-bit word
+-- in the specified byte order.
+word32 :: ByteOrder -> Word32 -> FixedPrim 4
+word32 !bo !x = case storeMethod of
+ StoreAligned -> word32Shift bo (fromIntegral x)
+ StoreUnaligned
+ | systemByteOrder == bo -> primPoke x
+ | otherwise -> primPoke (byteSwap32 x)
+
+-- | Fixed-width primitive that writes a 32-bit word
+-- in native byte order.
+word32Native :: Word32 -> FixedPrim 4
+word32Native = word32 systemByteOrder
+
+-- | Fixed-width primitive that writes a 32-bit word
+-- in big-endian byte order.
+word32BE :: Word32 -> FixedPrim 4
+word32BE = word32 BigEndian
+
+-- | Fixed-width primitive that writes a 32-bit word
+-- in little-endian byte order.
+word32LE :: Word32 -> FixedPrim 4
+word32LE = word32 LittleEndian
+
+-- | Fixed-width primitive that writes a 64-bit word
+-- in the specified byte order.
+word64 :: ByteOrder -> Word64 -> FixedPrim 8
+word64 !bo !x = case storeMethod of
+ StoreAligned -> word64Shift bo (fromIntegral x)
+ StoreUnaligned
+ | systemByteOrder == bo -> primPoke x
+ | otherwise -> primPoke (byteSwap64 x)
+
+-- | Fixed-width primitive that writes a 64-bit word
+-- in native byte order.
+word64Native :: Word64 -> FixedPrim 8
+word64Native = word64 systemByteOrder
+
+-- | Fixed-width primitive that writes a 64-bit word
+-- in big-endian byte order.
+word64BE :: Word64 -> FixedPrim 8
+word64BE = word64 BigEndian
+
+-- | Fixed-width primitive that writes a 64-bit word
+-- in little-endian byte order.
+word64LE :: Word64 -> FixedPrim 8
+word64LE = word64 LittleEndian
+
+-- | @'word8' . 'fromIntegral'@
+int8 :: Int8 -> FixedPrim 1
+int8 = word8 . fromIntegral
+
+-- | @\bo -> 'word16' bo . 'fromIntegral'@
+int16 :: ByteOrder -> Int16 -> FixedPrim 2
+int16 !bo = word16 bo . fromIntegral
+
+-- | @'word16Native' . 'fromIntegral'@
+int16Native :: Int16 -> FixedPrim 2
+int16Native = word16Native . fromIntegral
+
+-- | @'word16BE' . 'fromIntegral'@
+int16BE :: Int16 -> FixedPrim 2
+int16BE = word16BE . fromIntegral
+
+-- | @'word16LE' . 'fromIntegral'@
+int16LE :: Int16 -> FixedPrim 2
+int16LE = word16LE . fromIntegral
+
+-- | @\bo -> 'word32' bo . 'fromIntegral'@
+int32 :: ByteOrder -> Int32 -> FixedPrim 4
+int32 bo = word32 bo . fromIntegral
+
+-- | @'word32Native' . 'fromIntegral'@
+int32Native :: Int32 -> FixedPrim 4
+int32Native = word32Native . fromIntegral
+
+-- | @'word32BE' . 'fromIntegral'@
+int32BE :: Int32 -> FixedPrim 4
+int32BE = word32BE . fromIntegral
+
+-- | @'word32LE' . 'fromIntegral'@
+int32LE :: Int32 -> FixedPrim 4
+int32LE = word32LE . fromIntegral
+
+-- | @\bo -> 'word64' bo . 'fromIntegral'@
+int64 :: ByteOrder -> Int64 -> FixedPrim 8
+int64 bo = word64 bo . fromIntegral
+
+-- | @'word64Native' . 'fromIntegral'@
+int64Native :: Int64 -> FixedPrim 8
+int64Native = word64Native . fromIntegral
+
+-- | @'word64BE' . 'fromIntegral'@
+int64BE :: Int64 -> FixedPrim 8
+int64BE = word64BE . fromIntegral
+
+-- | @'word64LE' . 'fromIntegral'@
+int64LE :: Int64 -> FixedPrim 8
+int64LE = word64LE . fromIntegral
+
+-- | Fixed-width primitive that writes a 'Float'
+-- in the specified byte order.
+float :: ByteOrder -> Float -> FixedPrim 4
+float BigEndian = floatBE
+float LittleEndian = floatLE
+
+-- | Fixed-width primitive that writes a 'Float'
+-- in native byte order.
+floatNative :: Float -> FixedPrim 4
+floatNative = float systemByteOrder
+
+-- | Fixed-width primitive that writes a 'Float'
+-- in big-endian byte order.
+floatBE :: Float -> FixedPrim 4
+floatBE !x = FixedPrim g
+ where
+ g v u s0 o = case floatToWord32 (Ptr v) (I# u) x of
+ IO h -> case h s0 of
+ (# s1, y #) ->
+ let FixedPrim f = word32BE y
+ in f v u s1 o
+
+-- | Fixed-width primitive that writes a 'Float'
+-- in little-endian byte order.
+floatLE :: Float -> FixedPrim 4
+floatLE !x = FixedPrim g
+ where
+ g v u s0 o = case floatToWord32 (Ptr v) (I# u) x of
+ IO h -> case h s0 of
+ (# s1, y #) ->
+ let FixedPrim f = word32LE y
+ in f v u s1 o
+
+-- | Fixed-width primitive that writes a 'Double'
+-- in the specified byte order.
+double :: ByteOrder -> Double -> FixedPrim 8
+double BigEndian = doubleBE
+double LittleEndian = doubleLE
+
+-- | Fixed-width primitive that writes a 'Double'
+-- in native byte order.
+doubleNative :: Double -> FixedPrim 8
+doubleNative = double systemByteOrder
+
+-- | Fixed-width primitive that writes a 'Double'
+-- in big-endian byte order.
+doubleBE :: Double -> FixedPrim 8
+doubleBE !x = FixedPrim g
+ where
+ g v u s0 o = case doubleToWord64 (Ptr v) (I# u) x of
+ IO h -> case h s0 of
+ (# s1, y #) ->
+ let FixedPrim f = word64BE y
+ in f v u s1 o
+
+-- | Fixed-width primitive that writes a 'Double'
+-- in little-endian byte order.
+doubleLE :: Double -> FixedPrim 8
+doubleLE !x = FixedPrim g
+ where
+ g v u s0 o = case doubleToWord64 (Ptr v) (I# u) x of
+ IO h -> case h s0 of
+ (# s1, y #) ->
+ let FixedPrim f = word64LE y
+ in f v u s1 o
+
+-- | Bounded-width primitive that writes a 'Char'
+-- according to the UTF-8 encoding.
+charUtf8 :: Char -> BoundedPrim 4
+charUtf8 = \ch -> case fromIntegral (ord ch) of W# x -> wordUtf8 x
+ where
+ wordUtf8 :: Word# -> BoundedPrim 4
+ wordUtf8 =
+ choose 0x7F p1 $
+ choose 0x7FF p2 $
+ choose 0xFFFF p3 $
+ (\y -> liftFixedPrim (p4 y))
+ {-# INLINE wordUtf8 #-}
+
+ choose ::
+ forall v w .
+ (KnownNat v, KnownNat w) =>
+ Word ->
+ (Word# -> FixedPrim v) ->
+ (Word# -> BoundedPrim w) ->
+ Word# -> BoundedPrim (Max w v)
+ choose = \t f g x -> pif (W# x <= t) (liftFixedPrim (f x)) (g x)
+ -- We have observed GHC v8.6.5 jumping on the 'False' branch
+ -- and falling through on the 'True' branch. We set up our
+ -- condition to favor lower character codes.
+ {-# INLINE choose #-}
+
+ lsb ::
+ KnownNat n =>
+ (Word# -> FixedPrim n) ->
+ Word# ->
+ FixedPrim (n + 1)
+ lsb = \p x -> p (uncheckedShiftRL# x 6#) &<>
+ word8 (W8# (plusWord# 0x80## (and# x 0x3F##)))
+ {-# INLINE lsb #-}
+
+ p1 :: Word# -> FixedPrim 1
+ p2 :: Word# -> FixedPrim 2
+ p3 :: Word# -> FixedPrim 3
+ p4 :: Word# -> FixedPrim 4
+
+ p1 x = word8 (W8# x)
+ p2 = lsb (\x -> word8 (W8# (plusWord# 0xC0## x)))
+ p3 = lsb (lsb (\x -> word8 (W8# (plusWord# 0xE0## x))))
+ p4 = lsb (lsb (lsb (\x -> word8 (W8# (plusWord# 0xF0## x)))))
+
+ {-# INLINE p1 #-}
+ {-# INLINE p2 #-}
+ {-# INLINE p3 #-}
+ {-# INLINE p4 #-}
+{-# INLINE charUtf8 #-}
+
+-- | The bounded primitive implementing
+-- `Proto3.Wire.Reverse.wordBase128LEVar`.
+#if WORD_SIZE_IN_BITS < 64
+wordBase128LEVar :: Word -> BoundedPrim 5
+wordBase128LEVar (W# w) = word32Base128LEVar (W32# w)
+#else
+wordBase128LEVar :: Word -> BoundedPrim 10
+wordBase128LEVar (W# w) = word64Base128LEVar (W64# w)
+#endif
+{-# INLINE wordBase128LEVar #-}
+
+-- | Like 'wordBase128LEVar' but inlined, possibly bloating your code. On
+-- the other hand, inlining an application to a constant may shrink your code.
+#if WORD_SIZE_IN_BITS < 64
+wordBase128LEVar_inline :: Word -> BoundedPrim 5
+wordBase128LEVar_inline (W# w) = word32Base128LEVar_inline (W32# w)
+#else
+wordBase128LEVar_inline :: Word -> BoundedPrim 10
+wordBase128LEVar_inline (W# w) = word64Base128LEVar_inline (W64# w)
+#endif
+{-# INLINE wordBase128LEVar_inline #-}
+
+-- | The bounded primitive implementing
+-- `Proto3.Wire.Reverse.word32Base128LEVar`.
+word32Base128LEVar :: Word32 -> BoundedPrim 5
+word32Base128LEVar = word32Base128LEVar_inline
+{-# INLINE word32Base128LEVar #-}
+
+-- | Like 'word32Base128LEVar' but inlined, which currently means
+-- that it is just the same as 'word32Base128LEVar', which we inline.
+word32Base128LEVar_inline :: Word32 -> BoundedPrim 5
+word32Base128LEVar_inline = \(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
+{-# INLINE word32Base128LEVar_inline #-}
+
+wordBase128LEVar_choose ::
+ forall v w .
+ (KnownNat v, KnownNat w) =>
+ Int ->
+ (Word# -> Word# -> FixedPrim v) ->
+ (Word# -> BoundedPrim w) ->
+ Word# -> BoundedPrim (Max w v)
+wordBase128LEVar_choose = \d f g x ->
+ pif (W# x <= shiftL 1 (7 * d) - 1) (liftFixedPrim (f 0## x)) (g x)
+ -- We have observed GHC v8.6.5 jumping on the 'False' branch
+ -- and falling through on the 'True' branch. We set up our
+ -- condition to favor lower numeric values.
+{-# INLINE wordBase128LEVar_choose #-}
+
+wordBase128LE_msb ::
+ forall n .
+ KnownNat n =>
+ (Word# -> Word# -> FixedPrim n) ->
+ Word# -> Word# -> FixedPrim (n + 1)
+wordBase128LE_msb = \p m x ->
+ p 0x80## x &<> word8 (W8# (or# m (uncheckedShiftRL# x s)))
+ where
+ !(I# s) = 7 * fromInteger (natVal' (proxy# :: Proxy# n))
+{-# INLINE wordBase128LE_msb #-}
+
+wordBase128LE_p1 :: Word# -> Word# -> FixedPrim 1
+wordBase128LE_p1 = \m x -> word8 (W8# (or# m x))
+{-# INLINE wordBase128LE_p1 #-}
+
+wordBase128LE_p2 :: Word# -> Word# -> FixedPrim 2
+wordBase128LE_p2 = wordBase128LE_msb wordBase128LE_p1
+{-# INLINE wordBase128LE_p2 #-}
+
+wordBase128LE_p3 :: Word# -> Word# -> FixedPrim 3
+wordBase128LE_p3 = wordBase128LE_msb wordBase128LE_p2
+{-# INLINE wordBase128LE_p3 #-}
+
+wordBase128LE_p4 :: Word# -> Word# -> FixedPrim 4
+wordBase128LE_p4 = wordBase128LE_msb wordBase128LE_p3
+{-# INLINE wordBase128LE_p4 #-}
+
+wordBase128LE_p5 :: Word# -> Word# -> FixedPrim 5
+wordBase128LE_p5 = wordBase128LE_msb wordBase128LE_p4
+{-# INLINE wordBase128LE_p5 #-}
+
+-- | Writes 1 or 2 base-128 digits in little-endian order;
+-- in the 2-digit case the high bit of the containing byte of
+-- the low digit is set, and the other byte has a clear high bit.
+--
+-- WARNING: The argument is ASSUMED to be in [0 .. 2^14 - 1].
+word14Base128LEVar :: Word# -> BoundedPrim 2
+word14Base128LEVar = \x0 ->
+ ( wordBase128LEVar_choose 1 wordBase128LE_p1 $
+ (\x -> liftFixedPrim (wordBase128LE_p2 0## x))
+ ) x0
+{-# INLINE word14Base128LEVar #-}
+
+-- | Writes four base-128 digits, one per byte, with
+-- the high bit of each byte set, in little-endian order.
+--
+-- There is no requirement that the argument be @< 2^28@.
+word28Base128LE :: Word# -> FixedPrim 4
+word28Base128LE = wordBase128LE_p4 0x80##
+{-# INLINE word28Base128LE #-}
+
+-- | The bounded primitive implementing
+-- `Proto3.Wire.Reverse.word64Base128LEVar`.
+word64Base128LEVar :: Word64 -> BoundedPrim 10
+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)))
+ (inline (word64Base128LEVar_big x))
+{-# INLINE word64Base128LEVar_inline #-}
+
+-- | The input must be at least 2^32.
+word64Base128LEVar_big :: WORD64 -> BoundedPrim 10
+word64Base128LEVar_big x = pif (W64# x <= shiftL 1 60 - 1) p60 p64
+ where
+ p60 = liftFixedPrim (word28Base128LE x32) &<>
+ word32Base128LEVar (W32# (shR 28))
+
+ p64 = ( liftFixedPrim (word28Base128LE x32) &<>
+ liftFixedPrim (word28Base128LE (shR 28)) ) &<>
+ word14Base128LEVar (shR 56)
+
+ x32 = case fromIntegral (W64# x) of W32# y -> y
+
+ shR s = case fromIntegral (shiftR (W64# x) s) of W32# y -> y
+{-# NOINLINE word64Base128LEVar_big #-}
+
+-- | The analog of `Proto3.Wire.Reverse.vectorBuildR` for when fixed-width
+-- primitives encode the elements of the vector. In this special case we
+-- can predict the overall length.
+vectorFixedPrim ::
+ forall w v a .
+ (KnownNat w, Data.Vector.Generic.Vector v a) =>
+ (a -> FixedPrim w) ->
+ v a ->
+ BuildR
+vectorFixedPrim f = etaBuildR $ \v ->
+ let op acc x = acc <> unsafeBuildBoundedPrim (liftFixedPrim (f x))
+ in ensure (w * Data.Vector.Generic.length v) (foldlRVector op mempty v)
+ where
+ w = fromInteger (natVal' (proxy# :: Proxy# w))
+{-# INLINE vectorFixedPrim #-}
diff --git a/src/Proto3/Wire/Reverse/Width.hs b/src/Proto3/Wire/Reverse/Width.hs
new file mode 100644
index 0000000..876d997
--- /dev/null
+++ b/src/Proto3/Wire/Reverse/Width.hs
@@ -0,0 +1,113 @@
+{-
+ Copyright 2020 Awake 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 FunctionalDependencies #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | Augmentations to type classes such as 'Semigroup' and 'Monoid' that may
+-- be used to track the type-level width information of builder primitives.
+module Proto3.Wire.Reverse.Width
+ ( AssocPlusNat(..)
+ , CommPlusNat(..)
+ , PChoose(..)
+ , Max
+ , AssocMaxNat(..)
+ , CommMaxNat(..)
+ ) where
+
+import Data.Type.Bool (If)
+import GHC.Exts (Proxy#)
+import GHC.TypeLits (type (<=?), type (+))
+import Parameterized.Data.Semigroup (PNullary)
+
+-- | Associativity of '+' in type parameters.
+class AssocPlusNat n u v w
+ where
+ assocLPlusNat ::
+ Proxy# '(u, v, w) ->
+ PNullary n (u + (v + w)) ->
+ PNullary n ((u + v) + w)
+
+ assocRPlusNat ::
+ Proxy# '(u, v, w) ->
+ PNullary n ((u + v) + w) ->
+ PNullary n (u + (v + w))
+
+-- | Commutativity of '+' in type parameters.
+class CommPlusNat n u v
+ where
+ commPlusNat ::
+ Proxy# '(u, v) ->
+ PNullary n (u + v) ->
+ PNullary n (v + u)
+
+-- | Chooses between alternatives based on a condition,
+-- adjusting a type-level parameter appropriately.
+--
+-- Note that while this type class makes sense for bounded builder primitives,
+-- it should not be instantiated for fixed-width primitives of differing
+-- widths (at least, not without padding to equalize the widths) because
+-- the choice between alternatives introduces a run-time variation in width.
+-- Instead please use ordinary `Data.Bool.bool` or @if _ then _ else _@.
+class PChoose n f t w | f t -> w
+ where
+ -- | Like `Data.Bool.bool`, chooses the first argument on 'False'
+ -- and the second on 'True', either way promoting the type-level
+ -- `GHC.TypeLits.Nat` to the larger of the given `GHC.TypeLits.Nat`s.
+ --
+ -- Defaults to the natural implementation in terms of 'pif'.
+ pbool :: PNullary n f -> PNullary n t -> Bool -> PNullary n w
+ pbool f t b = pif b t f
+ {-# INLINE CONLIKE pbool #-}
+
+ -- | Like @if _ then _ else@, chooses the first argument on 'True'
+ -- and the second on 'False', either way promoting the type-level
+ -- `GHC.TypeLits.Nat` to the larger of the given `GHC.TypeLits.Nat`s.
+ --
+ -- Defaults to the natural implementation in terms of 'pbool'.
+ pif :: Bool -> PNullary n t -> PNullary n f -> PNullary n w
+ pif c t e = pbool e t c
+ {-# INLINE CONLIKE pif #-}
+
+ {-# MINIMAL pbool | pif #-}
+
+-- | The larger of two `GHC.TypeLits.Nat`s.
+type Max u v = If (v <=? u) u v
+
+-- | Associativity of 'Max' in type parameters.
+class AssocMaxNat n u v w
+ where
+ assocLMaxNat ::
+ Proxy# '(u, v, w) ->
+ PNullary n (Max u (Max v w)) ->
+ PNullary n (Max (Max u v) w)
+
+ assocRMaxNat ::
+ Proxy# '(u, v, w) ->
+ PNullary n (Max (Max u v) w) ->
+ PNullary n (Max u (Max v w))
+
+-- | Commutativity of 'Max' in type parameters.
+class CommMaxNat n u v
+ where
+ commMaxNat ::
+ Proxy# '(u, v) ->
+ PNullary n (Max u v) ->
+ PNullary n (Max v u)
diff --git a/test/Main.hs b/test/Main.hs
index 601893c..bed0324 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -17,8 +17,14 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
+{-# OPTIONS_GHC -Wno-warnings-deprecations #-}
+
module Main where
+import Control.Arrow ( (&&&), first, second )
+import Control.Monad ( guard, void )
+import Control.Monad.Trans.State ( StateT(..) )
+import qualified Data.Bits as Bits
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Builder.Internal as BBI
@@ -26,10 +32,16 @@ import Data.Either ( isLeft )
import Data.Maybe ( fromMaybe )
import Data.Monoid ( (<>) )
import Data.Int
+import Data.List ( group )
import qualified Data.Text.Lazy as T
+import qualified Data.Vector as V
+import Data.Word ( Word8, Word64 )
+import Foreign ( sizeOf )
import Proto3.Wire
import qualified Proto3.Wire.Builder as Builder
+import qualified Proto3.Wire.Reverse as Reverse
+import qualified Proto3.Wire.Reverse.Prim as Prim
import qualified Proto3.Wire.Encode as Encode
import qualified Proto3.Wire.Decode as Decode
@@ -44,7 +56,9 @@ main :: IO ()
main = do
Test.DocTest.doctest
[ "-isrc"
+ , "-fobject-code"
, "src/Proto3/Wire/Builder.hs"
+ , "src/Proto3/Wire/Reverse.hs"
, "src/Proto3/Wire/Encode.hs"
, "src/Proto3/Wire/Decode.hs"
]
@@ -53,8 +67,12 @@ main = do
tests :: TestTree
tests = testGroup "Tests" [ roundTripTests
, buildSingleChunk
+ , buildRBufferSizes
+ , strictByteString
+ , lazyByteString
, decodeNonsense
, varIntHeavyTests
+ , packedLargeTests
]
data StringOrInt64 = TString T.Text | TInt64 Int64
@@ -63,7 +81,7 @@ data StringOrInt64 = TString T.Text | TInt64 Int64
instance QC.Arbitrary StringOrInt64 where
arbitrary = QC.oneof [ TString . T.pack <$> QC.arbitrary, TInt64 <$> QC.arbitrary ]
--- this just stress tesses the fancy varint encodings with more randomness
+-- This just stress tests the fancy varint encodings with more randomness.
varIntHeavyTests :: TestTree
varIntHeavyTests = adjustOption (const $ QC.QuickCheckTests 10000) $
roundTrip "varInt uint test"
@@ -123,7 +141,15 @@ roundTripTests = testGroup "Roundtrip tests"
0 `at`
fieldNumber 1))
`at` fieldNumber 1)
- , roundTrip "embeddedList"
+ , roundTrip "embeddedListPackedVarints"
+ (Encode.embedded (fieldNumber 1) .
+ Encode.packedVarints (fieldNumber 1))
+ (fmap (fromMaybe [0,1,2,3,4])
+ (Decode.embedded (one Decode.packedVarints []
+ `at`
+ fieldNumber 1))
+ `at` fieldNumber 1)
+ , roundTrip "embeddedListPackedFixed32"
(Encode.embedded (fieldNumber 1) .
Encode.packedFixed32 (fieldNumber 1))
(fmap (fromMaybe [0,1,2,3,4])
@@ -131,6 +157,30 @@ roundTripTests = testGroup "Roundtrip tests"
`at`
fieldNumber 1))
`at` fieldNumber 1)
+ , roundTrip "embeddedListPackedFixed64"
+ (Encode.embedded (fieldNumber 1) .
+ Encode.packedFixed64 (fieldNumber 1))
+ (fmap (fromMaybe [0,1,2,3,4])
+ (Decode.embedded (one Decode.packedFixed64 []
+ `at`
+ fieldNumber 1))
+ `at` fieldNumber 1)
+ , roundTrip "embeddedListPackedFloats"
+ (Encode.embedded (fieldNumber 1) .
+ Encode.packedFloats (fieldNumber 1))
+ (fmap (fromMaybe [0,1,2,3,4])
+ (Decode.embedded (one Decode.packedFloats []
+ `at`
+ fieldNumber 1))
+ `at` fieldNumber 1)
+ , roundTrip "embeddedListPackedDoubles"
+ (Encode.embedded (fieldNumber 1) .
+ Encode.packedDoubles (fieldNumber 1))
+ (fmap (fromMaybe [0,1,2,3,4])
+ (Decode.embedded (one Decode.packedDoubles []
+ `at`
+ fieldNumber 1))
+ `at` fieldNumber 1)
, roundTrip "embeddedListUnpacked"
(Encode.embedded (fieldNumber 1) .
(foldMap . Encode.int32) (fieldNumber 1))
@@ -185,7 +235,7 @@ roundTrip name encode decode =
Right x' -> x === x'
buildSingleChunk :: TestTree
-buildSingleChunk = HU.testCase "Builder creates a single chunk" $ do
+buildSingleChunk = HU.testCase "Legacy Builder creates a single chunk" $ do
let chunks = length . BL.toChunks . Builder.toLazyByteString
huge = B.replicate (BBI.maximalCopySize + 16) 1
@@ -197,7 +247,486 @@ buildSingleChunk = HU.testCase "Builder creates a single chunk" $ do
HU.assertBool "single chunk (strict)" $ chunks huge2 == 1
HU.assertBool "single chunk (lazy)" $ chunks hugeL2 == 1
+parseBytes :: Int64 -> StateT BL.ByteString Maybe BL.ByteString
+parseBytes n = StateT $ \bl -> do
+ let (before, after) = BL.splitAt n bl
+ guard (BL.length before == n)
+ pure (before, after)
+
+-- | Parses a big-endian 64-bit unsigned integer.
+parseWord64BE :: StateT BL.ByteString Maybe Word64
+parseWord64BE = do
+ let be n bl = maybe n (j n) (BL.uncons bl)
+ j n (h, t) = be (256 * n + fromIntegral h) t
+ be 0 <$> parseBytes 8
+
+-- | Consumes and returns the longest prefix whose bytes
+-- all satisfy the given predicate. Never fails.
+parseWhile :: (Word8 -> Bool) -> StateT BL.ByteString Maybe BL.ByteString
+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
+
+-- | Please adjust this expected size of the metadata header
+-- to match that expected of the current implementation.
+buildRMeta :: Int
+buildRMeta = 2 * sizeOf (undefined :: Word) + sizeOf (undefined :: Double)
+
+buildRSmallChunkSize :: Int
+buildRSmallChunkSize = BBI.smallChunkSize - buildRMeta
+
+buildRDefaultChunkSize :: Int
+buildRDefaultChunkSize = BBI.defaultChunkSize - buildRMeta
+
+-- | Encodes the given 64-bit unsigned integer in big-endian format.
+encodeWord64BE :: Word64 -> B.ByteString
+encodeWord64BE = B.pack . go 8
+ where
+ go n w
+ | n <= 0 = []
+ | otherwise = fromIntegral (Bits.shiftR w (8 * (n - 1))) : go (n - 1) w
+
+-- | Writes the given byte into all the previously-unused
+-- bytes in the current buffer.
+fillUnused :: Word8 -> Reverse.BuildR
+fillUnused = fillUnusedExcept 0
+
+-- | Like 'fillUnused', but writes fewer bytes in order to leave
+-- the specified number of bytes unused, unless we start with fewer,
+-- in which case there is no change at all.
+fillUnusedExcept :: Int -> Word8 -> Reverse.BuildR
+fillUnusedExcept unusedRemaining w8 = Reverse.testWithUnused $ \u ->
+ foldMap (const (Reverse.word8 w8)) [unusedRemaining + 1 .. u]
+{-# NOINLINE fillUnusedExcept #-}
+ -- In case rewrite rules would interfere with buffer boundaries,
+ -- which may be fine normally, we forbid inlining of this probe.
+
+buildRBufferSizes :: TestTree
+buildRBufferSizes = HU.testCase "BuildR buffer sizes" $ do
+ let builder1 m = Reverse.ensure (max 8 m) $ Reverse.testWithUnused $ \u ->
+ Reverse.word64BE (fromIntegral u) <> fillUnusedExcept 8 7
+ {-# NOINLINE builder1 #-}
+
+ let builder3 =
+ builder1 (buildRDefaultChunkSize + 1) <> builder1 0 <> builder1 0
+
+ let encodedBytes :: BL.ByteString
+ encodedBytes = Reverse.toLazyByteString builder3
+
+ let parseBuffer :: StateT BL.ByteString Maybe Word64
+ parseBuffer = do
+ n <- parseWord64BE
+ _ <- parseBytes (max 0 (fromIntegral n - 8))
+ pure n
+
+ let parseBuffer3 :: StateT BL.ByteString Maybe (Word64, Word64, Word64)
+ parseBuffer3 = do
+ x <- parseBuffer
+ y <- parseBuffer
+ z <- parseBuffer
+ pure (x, y, z)
+
+ let actual, expected :: Maybe ((Word64, Word64, Word64), [(Int, Word8)])
+ actual = second rle <$> runStateT parseBuffer3 encodedBytes
+ expected = Just ((t, s, f), [])
+ -- We build in reverse but parser forward; therefore
+ -- the initial allocation is the final component.
+ where
+ t = fromIntegral buildRDefaultChunkSize + 1
+ s = fromIntegral buildRDefaultChunkSize
+ f = fromIntegral buildRSmallChunkSize
+
+ let msg = "run-length encoding of built bytes: " ++ show (rle encodedBytes)
+ HU.assertEqual msg expected actual
+
+strictByteString :: TestTree
+strictByteString = HU.testCase "Strict ByteString BuildR" $ do
+ -- Because the initial buffer has a distinctive size we can use
+ -- to distinguish it from other buffers, we start with a string
+ -- that does not fit in that buffer, so that we can check that
+ -- the buffer is reused as-is after those strings, not reallocated.
+ let builder1 = Reverse.testWithUnused $ \u -> Reverse.byteString $
+ B.replicate (buildRSmallChunkSize + 1) 10 <>
+ encodeWord64BE (fromIntegral u)
+ {-# NOINLINE builder1 #-}
+
+ -- Then we write strings that do fit within the initial buffer.
+ let builder2 = Reverse.testWithUnused $ \u -> Reverse.byteString $
+ B.replicate 3 20 <> encodeWord64BE (fromIntegral u)
+ {-# NOINLINE builder2 #-}
+
+ let builder3 = Reverse.testWithUnused $ \u -> Reverse.byteString $
+ B.replicate 3 30 <> encodeWord64BE (fromIntegral u)
+ {-# NOINLINE builder3 #-}
+
+ -- Then we check the just-enough-room case, which incidentally
+ -- ensures that we use enough of the initial buffer that it
+ -- will not be recycled.
+ let builder4 = ( Reverse.testWithUnused $ \u -> Reverse.byteString $
+ B.replicate 3 40 <> encodeWord64BE (fromIntegral u) )
+ <> fillUnusedExcept 11 (0xD0 - 4) <>
+ ( Reverse.testWithUnused $ \u -> Reverse.byteString $
+ encodeWord64BE (fromIntegral u) )
+ {-# NOINLINE builder4 #-}
+
+ -- Then the case of the almost-full-buffer with not quite enough room.
+ let builder5 = ( Reverse.testWithUnused $ \u -> Reverse.byteString $
+ B.replicate 3 50 <> encodeWord64BE (fromIntegral u) )
+ <> fillUnusedExcept 10 (0xD0 - 5) <>
+ ( Reverse.testWithUnused $ \u -> Reverse.byteString $
+ encodeWord64BE (fromIntegral u) )
+ {-# NOINLINE builder5 #-}
+
+ -- Then the full-buffer case.
+ let builder6 = ( Reverse.testWithUnused $ \u -> Reverse.byteString $
+ B.replicate 3 60 <> encodeWord64BE (fromIntegral u) )
+ <> fillUnused (0xD0 - 6) <>
+ ( Reverse.testWithUnused $ \u -> Reverse.byteString $
+ encodeWord64BE (fromIntegral u) )
+ {-# NOINLINE builder6 #-}
+
+ -- Check final unused.
+ let builder7 = ( Reverse.testWithUnused $ \u -> Reverse.byteString $
+ B.replicate 3 70 <> encodeWord64BE (fromIntegral u) )
+ {-# NOINLINE builder7 #-}
+
+ let buildAll = builder7 <> builder6 <> builder5 <>
+ builder4 <> builder3 <> builder2 <> builder1
+
+ let encodedBytes :: BL.ByteString
+ encodedBytes = Reverse.toLazyByteString buildAll
+
+ let parseFixed :: Int64 -> Word8 -> StateT BL.ByteString Maybe ()
+ parseFixed n w = do
+ bl <- parseBytes n
+ guard (BL.all (w ==) bl)
+
+ let parsePad :: Word8 -> StateT BL.ByteString Maybe ()
+ parsePad = void . parseWhile . (==)
+
+ let parseAll :: StateT BL.ByteString Maybe
+ ( Word64, (Word64, Word64), (Word64, Word64),
+ (Word64, Word64), Word64, Word64, Word64 )
+ parseAll = do
+ parseFixed 3 70
+ u7 <- parseWord64BE
+
+ parseFixed 3 60
+ u6B <- parseWord64BE
+ parsePad (0xD0 - 6)
+ u6A <- parseWord64BE
+
+ parseFixed 3 50
+ u5B <- parseWord64BE
+ parsePad (0xD0 - 5)
+ u5A <- parseWord64BE
+
+ parseFixed 3 40
+ u4B <- parseWord64BE
+ parsePad (0xD0 - 4)
+ u4A <- parseWord64BE
+
+ parseFixed 3 30
+ u3 <- parseWord64BE
+
+ parseFixed 3 20
+ u2 <- parseWord64BE
+
+ parseFixed (fromIntegral (buildRSmallChunkSize + 1)) 10
+ u1 <- parseWord64BE
+
+ pure (u7, (u6B, u6A), (u5B, u5A), (u4B, u4A), u3, u2, u1)
+
+ let actual, expected ::
+ Maybe ( ( Word64, (Word64, Word64), (Word64, Word64)
+ , (Word64, Word64), Word64, Word64, Word64 )
+ , [(Int, Word8)]
+ )
+ actual = second rle <$> runStateT parseAll encodedBytes
+ expected = Just ((u7, (u6B,u6A), (u5B,u5A), (u4B, u4A), u3, u2, u1), [])
+ where
+ u1 = fromIntegral $ buildRSmallChunkSize -- before we wrote anything
+ u2 = fromIntegral $ buildRSmallChunkSize -- bypassed unused buffer
+ u3 = fromIntegral $ buildRSmallChunkSize - 11 -- after second write
+ u4A = fromIntegral $ buildRSmallChunkSize - 22 -- after third write
+ u4B = 11 -- after padding
+ u5A = 0 -- buffer full from previous write
+ u5B = 10 -- after padding
+ u6A = fromIntegral $ buildRDefaultChunkSize
+ -- new buffer after bypassing used buffer
+ u6B = 0 -- buffer completely full
+ u7 = fromIntegral $ buildRDefaultChunkSize
+ -- new buffer after bypassing used buffer
+
+ let msg = "run-length encoding of built bytes: " ++ show (rle encodedBytes)
+ HU.assertEqual msg expected actual
+
+lazyByteString :: TestTree
+lazyByteString = HU.testCase "Strict ByteString BuildR" $ do
+ -- Because the initial buffer has a distinctive size we can use
+ -- to distinguish it from other buffers, we start with a string
+ -- whose chunks do not fit in that buffer, so that we can check that
+ -- the buffer is reused as-is after those strings, not reallocated.
+ let builder1 = Reverse.testWithUnused $ \u -> Reverse.lazyByteString $
+ BL.fromStrict ( B.replicate (buildRSmallChunkSize + 1) 12 ) <>
+ BL.fromStrict ( B.replicate (buildRSmallChunkSize + 1) 11 ) <>
+ BL.fromStrict ( B.replicate (buildRSmallChunkSize + 1) 10 <>
+ encodeWord64BE (fromIntegral u) )
+ {-# NOINLINE builder1 #-}
+
+ -- Then we write a string whose rightmost two chunks do fit
+ -- within the initial buffer but whose leftmost chunk does
+ -- not fit after the others are written. We ensure that most
+ -- of the initial buffer is consumed because otherwise it might
+ -- be recycled, which would prevent us from detecting that some
+ -- chunks were actually written to the buffer.
+ let builder2 = Reverse.testWithUnused $ \u -> Reverse.lazyByteString $
+ BL.fromStrict ( B.replicate 3 22 ) <>
+ BL.fromStrict ( B.replicate (buildRSmallChunkSize + 1 - 14) 21 ) <>
+ BL.fromStrict ( B.replicate 3 20 <> encodeWord64BE (fromIntegral u) )
+ {-# NOINLINE builder2 #-}
+
+ -- And a string that fits entirely within the second buffer.
+ let builder3 = Reverse.testWithUnused $ \u -> Reverse.lazyByteString $
+ BL.fromStrict ( B.replicate 3 32 ) <>
+ BL.fromStrict ( B.replicate 3 31 ) <>
+ BL.fromStrict ( B.replicate 3 30 <> encodeWord64BE (fromIntegral u) )
+ {-# NOINLINE builder3 #-}
+
+ -- Then we check the just-enough-room case.
+ let builder4 =
+ ( Reverse.testWithUnused $ \u -> Reverse.lazyByteString $
+ BL.fromStrict (B.replicate 3 41) <>
+ BL.fromStrict (B.replicate 3 40 <> encodeWord64BE (fromIntegral u))
+ ) <> fillUnusedExcept 14 (0xD0 - 4) <>
+ ( Reverse.testWithUnused $ \u -> Reverse.lazyByteString $
+ BL.fromStrict (encodeWord64BE (fromIntegral u))
+ )
+ {-# NOINLINE builder4 #-}
+
+ -- Then the case of the almost-full-buffer with not quite enough room.
+ let builder5 =
+ ( Reverse.testWithUnused $ \u -> Reverse.lazyByteString $
+ BL.fromStrict (B.replicate 3 51) <>
+ BL.fromStrict (B.replicate 3 50 <> encodeWord64BE (fromIntegral u))
+ ) <> fillUnusedExcept 13 (0xD0 - 5) <>
+ ( Reverse.testWithUnused $ \u -> Reverse.lazyByteString $
+ BL.fromStrict (encodeWord64BE (fromIntegral u))
+ )
+ {-# NOINLINE builder5 #-}
+
+ -- Then the full-buffer case.
+ let builder6 =
+ ( Reverse.testWithUnused $ \u -> Reverse.lazyByteString $
+ BL.fromStrict (B.replicate 3 61) <>
+ BL.fromStrict (B.replicate 3 60 <> encodeWord64BE (fromIntegral u))
+ ) <> fillUnused (0xD0 - 6) <>
+ ( Reverse.testWithUnused $ \u -> Reverse.lazyByteString $
+ BL.fromStrict (encodeWord64BE (fromIntegral u))
+ )
+ {-# NOINLINE builder6 #-}
+
+ -- Check final unused.
+ let builder7 =
+ ( Reverse.testWithUnused $ \u -> Reverse.lazyByteString $
+ BL.fromStrict (B.replicate 3 70 <> encodeWord64BE (fromIntegral u))
+ )
+ {-# NOINLINE builder7 #-}
+
+ let buildAll = builder7 <> builder6 <> builder5 <>
+ builder4 <> builder3 <> builder2 <> builder1
+
+ let encodedBytes :: BL.ByteString
+ encodedBytes = Reverse.toLazyByteString buildAll
+
+ let parseFixed :: Int64 -> Word8 -> StateT BL.ByteString Maybe ()
+ parseFixed n w = do
+ bl <- parseBytes n
+ guard (BL.all (w ==) bl)
+
+ let parsePad :: Word8 -> StateT BL.ByteString Maybe ()
+ parsePad = void . parseWhile . (==)
+
+ let parseAll :: StateT BL.ByteString Maybe
+ ( Word64, (Word64, Word64), (Word64, Word64),
+ (Word64, Word64), Word64, Word64, Word64 )
+ parseAll = do
+ parseFixed 3 70
+ u7 <- parseWord64BE
+
+ parseFixed 3 61
+ parseFixed 3 60
+ u6B <- parseWord64BE
+ parsePad (0xD0 - 6)
+ u6A <- parseWord64BE
+
+ parseFixed 3 51
+ parseFixed 3 50
+ u5B <- parseWord64BE
+ parsePad (0xD0 - 5)
+ u5A <- parseWord64BE
+
+ parseFixed 3 41
+ parseFixed 3 40
+ u4B <- parseWord64BE
+ parsePad (0xD0 - 4)
+ u4A <- parseWord64BE
+
+ parseFixed 3 32
+ parseFixed 3 31
+ parseFixed 3 30
+ u3 <- parseWord64BE
+
+ parseFixed 3 22
+ parseFixed (fromIntegral (buildRSmallChunkSize + 1 - 14)) 21
+ parseFixed 3 20
+ u2 <- parseWord64BE
+
+ parseFixed (fromIntegral (buildRSmallChunkSize + 1)) 12
+ parseFixed (fromIntegral (buildRSmallChunkSize + 1)) 11
+ parseFixed (fromIntegral (buildRSmallChunkSize + 1)) 10
+ u1 <- parseWord64BE
+
+ pure (u7, (u6B, u6A), (u5B, u5A), (u4B, u4A), u3, u2, u1)
+
+ let actual, expected ::
+ Maybe ( ( Word64, (Word64, Word64), (Word64, Word64)
+ , (Word64, Word64), Word64, Word64, Word64 )
+ , [(Int, Word8)]
+ )
+ actual = second rle <$> runStateT parseAll encodedBytes
+ expected = Just ((u7, (u6B,u6A), (u5B,u5A), (u4B, u4A), u3, u2, u1), [])
+ where
+ u1 = fromIntegral $ buildRSmallChunkSize -- before we wrote anything
+ u2 = fromIntegral $ buildRSmallChunkSize -- bypassed unused buffer
+ u3 = fromIntegral $ buildRDefaultChunkSize -- after second write
+ u4A = fromIntegral $ buildRDefaultChunkSize - 17 -- after third write
+ u4B = 14 -- after padding
+ u5A = 0 -- buffer full from previous write
+ u5B = 13 -- after padding
+ u6A = fromIntegral $ buildRDefaultChunkSize
+ -- new buffer after bypassing used buffer
+ u6B = 0 -- buffer completely full
+ u7 = fromIntegral $ buildRDefaultChunkSize
+ -- new buffer after bypassing used buffer
+
+ let msg = "run-length encoding of built bytes: " ++ show (rle encodedBytes)
+ HU.assertEqual msg expected actual
+
decodeNonsense :: TestTree
decodeNonsense = HU.testCase "Decoding a nonsensical string fails." $ do
let decoded = Decode.parse (one Decode.fixed64 0 `at` fieldNumber 1) "test"
HU.assertBool "decode fails" $ isLeft decoded
+
+packedLargeTests :: TestTree
+packedLargeTests = testGroup "Test packed encoders on large inputs"
+ [ packedVarints_large
+ , packedVarintsV_large
+ , packedBoolsV_large
+ , packedFixed32_large
+ , packedFixed32V_large
+ , packedFixed64_large
+ , packedFixed64V_large
+ , packedFloats_large
+ , packedFloatsV_large
+ , packedDoubles_large
+ , packedDoublesV_large
+ ]
+
+packedVarints_large :: TestTree
+packedVarints_large = HU.testCase "Large packedVarints" $ do
+ let count = 40000
+ encoded = Encode.toLazyByteString (Encode.packedVarints 13 [1 .. count])
+ decoded = Decode.parse (one Decode.packedVarints [] `at` fieldNumber 13)
+ (BL.toStrict encoded)
+ HU.assertEqual "round trip" (Right [1 .. count]) decoded
+
+packedVarintsV_large :: TestTree
+packedVarintsV_large = HU.testCase "Large packedVarintsV" $ do
+ let count = 40000
+ encoded = Encode.toLazyByteString
+ (Encode.packedVarintsV (1 +) 13 (V.fromList [1 .. count]))
+ decoded = Decode.parse (one Decode.packedVarints [] `at` fieldNumber 13)
+ (BL.toStrict encoded)
+ HU.assertEqual "round trip" (Right [2 .. count + 1]) decoded
+
+packedBoolsV_large :: TestTree
+packedBoolsV_large = HU.testCase "Large packedBoolsV" $ do
+ let count = 40000 :: Int
+ values = map (flip Bits.testBit 0) [1 .. count]
+ encoded = Encode.toLazyByteString
+ (Encode.packedBoolsV not 13 (V.fromList values))
+ decoded = Decode.parse (one Decode.packedVarints [] `at` fieldNumber 13)
+ (BL.toStrict encoded)
+ HU.assertEqual "round trip" (Right (map (fromEnum . not) values)) decoded
+
+packedFixed32_large :: TestTree
+packedFixed32_large = HU.testCase "Large packedFixed32" $ do
+ let count = 40000
+ encoded = Encode.toLazyByteString (Encode.packedFixed32 13 [1 .. count])
+ decoded = Decode.parse (one Decode.packedFixed32 [] `at` fieldNumber 13)
+ (BL.toStrict encoded)
+ HU.assertEqual "round trip" (Right [1 .. count]) decoded
+
+packedFixed32V_large :: TestTree
+packedFixed32V_large = HU.testCase "Large packedFixed32V" $ do
+ let count = 40000
+ encoded = Encode.toLazyByteString
+ (Encode.packedFixed32V (1 +) 13 (V.fromList [1 .. count]))
+ decoded = Decode.parse (one Decode.packedFixed32 [] `at` fieldNumber 13)
+ (BL.toStrict encoded)
+ HU.assertEqual "round trip" (Right [2 .. count + 1]) decoded
+
+packedFixed64_large :: TestTree
+packedFixed64_large = HU.testCase "Large packedFixed64" $ do
+ let count = 40000
+ encoded = Encode.toLazyByteString (Encode.packedFixed64 13 [1 .. count])
+ decoded = Decode.parse (one Decode.packedFixed64 [] `at` fieldNumber 13)
+ (BL.toStrict encoded)
+ HU.assertEqual "round trip" (Right [1 .. count]) decoded
+
+packedFixed64V_large :: TestTree
+packedFixed64V_large = HU.testCase "Large packedFixed64V" $ do
+ let count = 40000
+ encoded = Encode.toLazyByteString
+ (Encode.packedFixed64V (1 +) 13 (V.fromList [1 .. count]))
+ decoded = Decode.parse (one Decode.packedFixed64 [] `at` fieldNumber 13)
+ (BL.toStrict encoded)
+ HU.assertEqual "round trip" (Right [2 .. count + 1]) decoded
+
+packedFloats_large :: TestTree
+packedFloats_large = HU.testCase "Large packedFloats" $ do
+ let count = 40000
+ encoded = Encode.toLazyByteString (Encode.packedFloats 13 [1 .. count])
+ decoded = Decode.parse (one Decode.packedFloats [] `at` fieldNumber 13)
+ (BL.toStrict encoded)
+ HU.assertEqual "round trip" (Right [1 .. count]) decoded
+
+packedFloatsV_large :: TestTree
+packedFloatsV_large = HU.testCase "Large packedFloatsV" $ do
+ let count = 40000
+ encoded = Encode.toLazyByteString
+ (Encode.packedFloatsV (1 +) 13 (V.fromList [1 .. count]))
+ decoded = Decode.parse (one Decode.packedFloats [] `at` fieldNumber 13)
+ (BL.toStrict encoded)
+ HU.assertEqual "round trip" (Right [2 .. count + 1]) decoded
+
+packedDoubles_large :: TestTree
+packedDoubles_large = HU.testCase "Large packedDoubles" $ do
+ let count = 40000
+ encoded = Encode.toLazyByteString (Encode.packedDoubles 13 [1 .. count])
+ decoded = Decode.parse (one Decode.packedDoubles [] `at` fieldNumber 13)
+ (BL.toStrict encoded)
+ HU.assertEqual "round trip" (Right [1 .. count]) decoded
+
+packedDoublesV_large :: TestTree
+packedDoublesV_large = HU.testCase "Large packedDoublesV" $ do
+ let count = 40000
+ encoded = Encode.toLazyByteString
+ (Encode.packedDoublesV (1 +) 13 (V.fromList [1 .. count]))
+ decoded = Decode.parse (one Decode.packedDoubles [] `at` fieldNumber 13)
+ (BL.toStrict encoded)
+ HU.assertEqual "round trip" (Right [2 .. count + 1]) decoded