diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +1.4.5 + - Add encoders for packed repeated fields that can iterate in + reverse order for speed when practical and will predict size + when it is inexpensive to do so. + - Add bytesIfNonempty, etaMessageBuilder, unsafeFromByteString, + unsafeFromShortByteString, repeatedMessageBuilder. + 1.4.4 - Support GHC 9.10 diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -15,7 +15,6 @@ import Control.Applicative (liftA2, liftA3) import Control.Monad (forM) -import Data.Maybe import Data.Word import Data.IORef @@ -39,7 +38,7 @@ in a + a1 + a2 instance Foldable Rose where - foldMap f Bud = mempty + foldMap _ Bud = mempty foldMap f (Rose x rs) = f x <> ((foldMap.foldMap) f rs) intTreeParser :: De.Parser De.RawMessage (Tree Word64) @@ -123,9 +122,9 @@ pullInt xs = do xs' <- readIORef xs case xs' of - [] -> pure (-1) - x : xs' -> do - writeIORef xs xs' + [] -> pure (negate 1) + x : xs'' -> do + writeIORef xs xs'' pure x mkTree0 :: IO Word64 -> IO En.MessageBuilder diff --git a/proto3-wire.cabal b/proto3-wire.cabal --- a/proto3-wire.cabal +++ b/proto3-wire.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.10 name: proto3-wire -version: 1.4.4 +version: 1.4.5 synopsis: A low-level implementation of the Protocol Buffers (version 3) wire format license: Apache-2.0 license-file: LICENSE @@ -37,7 +37,7 @@ base >=4.12 && <=5.0 , bytestring >=0.10.6.0 && <0.13.0 , cereal >= 0.5.1 && <0.6 - , containers >=0.5 && < 0.8 + , containers >=0.5 && <0.8 , deepseq >=1.4 && <1.6 , hashable <1.6 , parameterized >=0.5.0.0 && <1 @@ -58,11 +58,13 @@ Proto3.Wire.Class Proto3.Wire.Decode Proto3.Wire.Encode + Proto3.Wire.Encode.Repeated + Proto3.Wire.FoldR Proto3.Wire.Reverse + Proto3.Wire.Reverse.Internal Proto3.Wire.Reverse.Prim Proto3.Wire.Tutorial Proto3.Wire.Types - Proto3.Wire.Reverse.Internal other-modules: Proto3.Wire.Reverse.Width @@ -77,6 +79,7 @@ base >=4.9 && <=5.0 , bytestring >=0.10.6.0 && <0.13.0 , cereal >= 0.5.1 && <0.6 + , containers >=0.5 && <0.8 , doctest >= 0.7.0 && <0.24.0 , proto3-wire , QuickCheck >=2.8 && <3.0 diff --git a/src/Proto3/Wire/Encode.hs b/src/Proto3/Wire/Encode.hs --- a/src/Proto3/Wire/Encode.hs +++ b/src/Proto3/Wire/Encode.hs @@ -40,6 +40,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -54,10 +57,13 @@ ( -- * `MessageBuilder` type MessageBuilder , reverseMessageBuilder + , etaMessageBuilder , vectorMessageBuilder , messageLength , toLazyByteString , unsafeFromLazyByteString + , unsafeFromByteString + , unsafeFromShortByteString -- * Standard Integers , int32 @@ -79,6 +85,7 @@ , bool -- * Strings , bytes + , bytesIfNonempty , string , text , shortText @@ -87,17 +94,32 @@ , shortByteString -- * Embedded Messages , embedded + -- * Folds + , repeatedMessageBuilder -- * Packed repeated fields , packedVarints , packedVarintsV + , packedInt32R + , packedInt64R + , packedUInt32R + , packedUInt64R + , packedSInt32R + , packedSInt64R + , packedBoolsR , packedBoolsV , packedFixed32 + , packedFixed32R , packedFixed32V , packedFixed64 + , packedFixed64R , packedFixed64V + , packedSFixed32R + , packedSFixed64R , packedFloats + , packedFloatsR , packedFloatsV , packedDoubles + , packedDoublesR , packedDoublesV -- * ZigZag codec , zigZagEncode @@ -118,13 +140,14 @@ import Parameterized.Data.Semigroup ( PNullary, PSemigroup(..), (&<>) ) import Parameterized.Data.Monoid ( PMEmpty(..) ) +import Proto3.Wire.Encode.Repeated ( ToRepeated, mapRepeated ) import qualified Proto3.Wire.Reverse as RB import qualified Proto3.Wire.Reverse.Prim as Prim import Proto3.Wire.Class import Proto3.Wire.Types -- $setup --- >>> :set -XOverloadedStrings -XOverloadedLists +-- >>> :set -XOverloadedStrings -XOverloadedLists -XTypeApplications -- >>> :module Proto3.Wire.Encode Proto3.Wire.Class Data.Word -- | zigzag-encoded numeric type. @@ -142,7 +165,7 @@ -- -- Use `toLazyByteString` when you're done assembling the `MessageBuilder` newtype MessageBuilder = MessageBuilder { unMessageBuilder :: RB.BuildR } - deriving (Monoid, Semigroup) + deriving newtype (Monoid, Semigroup) instance Show MessageBuilder where showsPrec prec builder = @@ -176,15 +199,22 @@ toLazyByteString :: MessageBuilder -> BL.ByteString toLazyByteString = RB.toLazyByteString . unMessageBuilder --- | This lets you cast an arbitrary `ByteString` to a `MessageBuilder`, whether +-- | This lets you cast an arbitrary 'BL.ByteString' to a `MessageBuilder`, whether -- or not the `ByteString` corresponds to a valid serialized protobuf message -- -- Do not use this function unless you know what you're doing because it lets --- you assemble malformed protobuf `MessageBuilder`s +-- you assemble malformed protobuf `MessageBuilder`s. unsafeFromLazyByteString :: BL.ByteString -> MessageBuilder -unsafeFromLazyByteString bytes' = - MessageBuilder { unMessageBuilder = RB.lazyByteString bytes' } +unsafeFromLazyByteString = coerce RB.lazyByteString +-- | Like 'unsafeFromLazyByteString' only for strict 'B.ByteString's. +unsafeFromByteString :: B.ByteString -> MessageBuilder +unsafeFromByteString = coerce RB.byteString + +-- | Like 'unsafeFromLazyByteString' only for 'BS.ShortByteString's. +unsafeFromShortByteString :: BS.ShortByteString -> MessageBuilder +unsafeFromShortByteString = coerce RB.shortByteString + newtype MessageBoundedPrim w = MessageBoundedPrim { unMessageBoundedPrim :: Prim.BoundedPrim w } @@ -276,7 +306,7 @@ -- a negative number, the resulting varint is always ten bytes long..." -- int32 :: FieldNumber -> Int32 -> MessageBuilder -int32 = \num i -> liftBoundedPrim $ +int32 = \(!num) i -> liftBoundedPrim $ fieldHeader num Varint &<> base128Varint64 (fromIntegral i) {-# INLINE int32 #-} @@ -289,7 +319,7 @@ -- >>> 1 `int64` (-42) -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\214\255\255\255\255\255\255\255\255\SOH" int64 :: FieldNumber -> Int64 -> MessageBuilder -int64 = \num i -> liftBoundedPrim $ +int64 = \(!num) i -> liftBoundedPrim $ fieldHeader num Varint &<> base128Varint64 (fromIntegral i) {-# INLINE int64 #-} @@ -300,7 +330,7 @@ -- >>> 1 `uint32` 42 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b*" uint32 :: FieldNumber -> Word32 -> MessageBuilder -uint32 = \num i -> liftBoundedPrim $ +uint32 = \(!num) i -> liftBoundedPrim $ fieldHeader num Varint &<> base128Varint32 i {-# INLINE uint32 #-} @@ -311,7 +341,7 @@ -- >>> 1 `uint64` 42 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b*" uint64 :: FieldNumber -> Word64 -> MessageBuilder -uint64 = \num i -> liftBoundedPrim $ +uint64 = \(!num) i -> liftBoundedPrim $ fieldHeader num Varint &<> base128Varint64 i {-# INLINE uint64 #-} @@ -326,7 +356,7 @@ -- >>> 1 `sint32` minBound -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\255\255\255\255\SI" sint32 :: FieldNumber -> Int32 -> MessageBuilder -sint32 = \num i -> +sint32 = \(!num) i -> uint32 num (fromIntegral (zigZagEncode i)) {-# INLINE sint32 #-} @@ -341,7 +371,7 @@ -- >>> 1 `sint64` minBound -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\255\255\255\255\255\255\255\255\255\SOH" sint64 :: FieldNumber -> Int64 -> MessageBuilder -sint64 = \num i -> +sint64 = \(!num) i -> uint64 num (fromIntegral (zigZagEncode i)) {-# INLINE sint64 #-} @@ -352,7 +382,7 @@ -- >>> 1 `fixed32` 42 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\r*\NUL\NUL\NUL" fixed32 :: FieldNumber -> Word32 -> MessageBuilder -fixed32 = \num i -> liftBoundedPrim $ +fixed32 = \(!num) i -> liftBoundedPrim $ fieldHeader num Fixed32 &<> MessageBoundedPrim (Prim.liftFixedPrim (Prim.word32LE i)) {-# INLINE fixed32 #-} @@ -364,7 +394,7 @@ -- >>> 1 `fixed64` 42 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\t*\NUL\NUL\NUL\NUL\NUL\NUL\NUL" fixed64 :: FieldNumber -> Word64 -> MessageBuilder -fixed64 = \num i -> liftBoundedPrim $ +fixed64 = \(!num) i -> liftBoundedPrim $ fieldHeader num Fixed64 &<> MessageBoundedPrim (Prim.liftFixedPrim (Prim.word64LE i)) {-# INLINE fixed64 #-} @@ -375,7 +405,7 @@ -- -- > 1 `sfixed32` (-42) sfixed32 :: FieldNumber -> Int32 -> MessageBuilder -sfixed32 = \num i -> liftBoundedPrim $ +sfixed32 = \(!num) i -> liftBoundedPrim $ fieldHeader num Fixed32 &<> MessageBoundedPrim (Prim.liftFixedPrim (Prim.int32LE i)) {-# INLINE sfixed32 #-} @@ -387,7 +417,7 @@ -- >>> 1 `sfixed64` (-42) -- Proto3.Wire.Encode.unsafeFromLazyByteString "\t\214\255\255\255\255\255\255\255" sfixed64 :: FieldNumber -> Int64 -> MessageBuilder -sfixed64 = \num i -> liftBoundedPrim $ +sfixed64 = \(!num) i -> liftBoundedPrim $ fieldHeader num Fixed64 &<> MessageBoundedPrim (Prim.liftFixedPrim (Prim.int64LE i)) {-# INLINE sfixed64 #-} @@ -399,7 +429,7 @@ -- >>> 1 `float` 3.14 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\r\195\245H@" float :: FieldNumber -> Float -> MessageBuilder -float = \num f -> liftBoundedPrim $ +float = \(!num) f -> liftBoundedPrim $ fieldHeader num Fixed32 &<> MessageBoundedPrim (Prim.liftFixedPrim (Prim.floatLE f)) {-# INLINE float #-} @@ -411,7 +441,7 @@ -- >>> 1 `double` 3.14 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\t\US\133\235Q\184\RS\t@" double :: FieldNumber -> Double -> MessageBuilder -double = \num d -> liftBoundedPrim $ +double = \(!num) d -> liftBoundedPrim $ fieldHeader num Fixed64 &<> MessageBoundedPrim (Prim.liftFixedPrim (Prim.doubleLE d)) {-# INLINE double #-} @@ -440,7 +470,7 @@ -- >>> 1 `enum` Triangle <> 2 `enum` Gap3 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\STX\DLE\ETX" enum :: ProtoEnum e => FieldNumber -> e -> MessageBuilder -enum = \num e -> liftBoundedPrim $ +enum = \(!num) e -> liftBoundedPrim $ fieldHeader num Varint &<> base128Varint32 (fromIntegral @Int32 @Word32 (fromProtoEnum e)) {-# INLINE enum #-} @@ -452,7 +482,7 @@ -- >>> 1 `bool` True -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\SOH" bool :: FieldNumber -> Bool -> MessageBuilder -bool = \num b -> liftBoundedPrim $ +bool = \(!num) b -> liftBoundedPrim $ fieldHeader num Varint &<> MessageBoundedPrim (Prim.liftFixedPrim (Prim.word8 (fromIntegral (fromEnum b)))) @@ -461,12 +491,39 @@ -- | Encode a sequence of octets as a field of type 'bytes'. -- +-- But unless the field is @optional@ or part of a @oneof@, +-- you may wish to to use 'bytesIfNonempty' to skip the field +-- when the payload built by the argument turns out to be empty. +-- +-- >>> 1 `bytes` (Proto3.Wire.Reverse.stringUtf8 "") +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\NUL" -- >>> 1 `bytes` (Proto3.Wire.Reverse.stringUtf8 "testing") -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" bytes :: FieldNumber -> RB.BuildR -> MessageBuilder -bytes num = embedded num . MessageBuilder +bytes !num = embedded num . MessageBuilder {-# INLINE bytes #-} +-- | Like 'bytes' but omits the field if it would be empty, which +-- is useful when the field is not @optional@ and is not part of +-- a @oneof@, and therefore may be omitted entirely when empty. +-- +-- >>> 1 `bytesIfNonempty` (Proto3.Wire.Reverse.stringUtf8 "") +-- Proto3.Wire.Encode.unsafeFromLazyByteString "" +-- >>> 1 `bytesIfNonempty` (Proto3.Wire.Reverse.stringUtf8 "testing") +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" +bytesIfNonempty :: FieldNumber -> RB.BuildR -> MessageBuilder +bytesIfNonempty !num bb = + MessageBuilder (RB.withLengthOf prefix bb) + where + prefix len + | 0 < len = Prim.liftBoundedPrim $ + unMessageBoundedPrim (fieldHeader num LengthDelimited) &<> + Prim.wordBase128LEVar (fromIntegral @Int @Word len) + | otherwise = + mempty + {-# INLINE prefix #-} +{-# INLINE bytesIfNonempty #-} + -- | Encode a UTF-8 string. -- -- For example: @@ -474,7 +531,7 @@ -- >>> 1 `string` "testing" -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" string :: FieldNumber -> String -> MessageBuilder -string num = embedded num . MessageBuilder . RB.stringUtf8 +string !num = embedded num . MessageBuilder . RB.stringUtf8 {-# INLINE string #-} -- | Encode lazy `Text` as UTF-8 @@ -484,7 +541,7 @@ -- >>> 1 `text` "testing" -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" text :: FieldNumber -> Text.Lazy.Text -> MessageBuilder -text num = embedded num . MessageBuilder . RB.lazyTextUtf8 +text !num = embedded num . MessageBuilder . RB.lazyTextUtf8 {-# INLINE text #-} -- | Encode a `Text.Short.ShortText` as UTF-8. @@ -494,7 +551,7 @@ -- >>> 1 `shortText` "testing" -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" shortText :: FieldNumber -> Text.Short.ShortText -> MessageBuilder -shortText num = embedded num . MessageBuilder . RB.shortTextUtf8 +shortText !num = embedded num . MessageBuilder . RB.shortTextUtf8 {-# INLINE shortText #-} -- | Encode a collection of bytes in the form of a strict 'B.ByteString'. @@ -504,7 +561,7 @@ -- >>> 1 `byteString` "testing" -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" byteString :: FieldNumber -> B.ByteString -> MessageBuilder -byteString num = embedded num . MessageBuilder . RB.byteString +byteString !num = embedded num . unsafeFromByteString {-# INLINE byteString #-} -- | Encode a lazy bytestring. @@ -514,7 +571,7 @@ -- >>> 1 `lazyByteString` "testing" -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" lazyByteString :: FieldNumber -> BL.ByteString -> MessageBuilder -lazyByteString num = embedded num . MessageBuilder . RB.lazyByteString +lazyByteString !num = embedded num . unsafeFromLazyByteString {-# INLINE lazyByteString #-} -- | Encode a `BS.ShortByteString`. @@ -524,22 +581,60 @@ -- >>> 1 `shortByteString` "testing" -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" shortByteString :: FieldNumber -> BS.ShortByteString -> MessageBuilder -shortByteString num = embedded num . MessageBuilder . RB.shortByteString +shortByteString !num = embedded num . unsafeFromShortByteString {-# INLINE shortByteString #-} --- | Encode varints in the space-efficient packed format. --- But consider 'packedVarintsV', which may be faster. +-- | Concatenates the given builders, which typically build fields within the same message. -- --- The values to be encoded are specified by mapping the elements of a vector. +-- For example: -- +-- >>> repeatedMessageBuilder @[MessageBuilder] [1 `bool` True, 2 `int32` 42] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\SOH\DLE*" +repeatedMessageBuilder :: ToRepeated c MessageBuilder => c -> MessageBuilder +repeatedMessageBuilder = + etaMessageBuilder (MessageBuilder . RB.repeatedBuildR . mapRepeated reverseMessageBuilder) +{-# INLINE repeatedMessageBuilder #-} + +-- | Encodes a packed repeated field whose elements may vary in width. +packedVariableWidthFieldR :: + ToRepeated c a => (a -> RB.BuildR) -> FieldNumber -> c -> MessageBuilder +packedVariableWidthFieldR f !num = + etaMessageBuilder (embedded num . MessageBuilder . RB.repeatedBuildR . mapRepeated f) +{-# INLINE packedVariableWidthFieldR #-} + +-- | Encodes a packed repeated field whose elements never vary in width. +packedFixedWidthFieldR :: + (ToRepeated c a, KnownNat w) => (a -> Prim.FixedPrim w) -> FieldNumber -> c -> MessageBuilder +packedFixedWidthFieldR f !num = + etaMessageBuilder (embedded num . MessageBuilder . RB.repeatedFixedPrimR . mapRepeated f) +{-# INLINE packedFixedWidthFieldR #-} + +-- | Encode varints in the space-efficient packed format. +-- But consider 'packedVarintsV' or 'packedVarintsR', either of which may be faster. +-- -- >>> packedVarints 1 [1, 2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\ETX\SOH\STX\ETX" packedVarints :: Foldable f => FieldNumber -> f Word64 -> MessageBuilder -packedVarints num = etaMessageBuilder (embedded num . payload) +packedVarints !num = etaMessageBuilder (embedded num . payload) where payload = foldMap (liftBoundedPrim . base128Varint64) {-# INLINE packedVarints #-} +-- | A faster but more specialized variant of 'packedVarints'. +-- +-- Generalizes 'packedVarintsV', provided that any new instance +-- of 'Vector' is given a corresponding instance of 'ToRepeated'. +packedVarints64R :: ToRepeated c Word64 => FieldNumber -> c -> MessageBuilder +packedVarints64R = packedVariableWidthFieldR RB.word64Base128LEVar +{-# INLINE packedVarints64R #-} + +-- | Like 'packedVarints64R' but supports only 32-bit inputs, +-- which reduces on executable size in situations where we do +-- not need to support larger values. +packedVarints32R :: ToRepeated c Word32 => FieldNumber -> c -> MessageBuilder +packedVarints32R = packedVariableWidthFieldR RB.word32Base128LEVar +{-# INLINE packedVarints32R #-} + -- | A faster but more specialized variant of: -- -- > \f num -> packedVarints num . fmap f @@ -548,37 +643,128 @@ -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\ETX\SOH\STX\ETX" packedVarintsV :: Vector v a => (a -> Word64) -> FieldNumber -> v a -> MessageBuilder -packedVarintsV f num = embedded num . payload +packedVarintsV f !num = embedded num . payload where payload = vectorMessageBuilder (liftBoundedPrim . base128Varint64 . f) {-# INLINE packedVarintsV #-} +-- | Encodes a packed repeated @int32@ field. +-- +-- >>> packedInt32R @[_] 1 [42, -42] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\v*\214\255\255\255\255\255\255\255\255\SOH" +-- +-- NOTE: Protobuf encoding converts an @int32@ to a 64-bit unsigned value +-- before encoding it, not a 32-bit value (which would be more efficient). +-- +-- To quote the specification: "If you use int32 or int64 as the type for +-- a negative number, the resulting varint is always ten bytes long..." +-- +packedInt32R :: ToRepeated c Int32 => FieldNumber -> c -> MessageBuilder +packedInt32R !num xs = + packedVarints64R num (mapRepeated (fromIntegral @Int32 @Word64) xs) +{-# INLINE packedInt32R #-} + +-- | Encodes a packed repeated @int64@ field. +-- +-- For example: +-- +-- >>> packedInt64R @[_] 1 [42, -42] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\v*\214\255\255\255\255\255\255\255\255\SOH" +packedInt64R :: ToRepeated c Int64 => FieldNumber -> c -> MessageBuilder +packedInt64R !num xs = + packedVarints64R num (mapRepeated (fromIntegral @Int64 @Word64) xs) +{-# INLINE packedInt64R #-} + +-- | Encodes a packed repeated @uint32@ field. +-- +-- For example: +-- +-- >>> packedUInt32R @[_] 1 [42, 43, maxBound] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\a*+\255\255\255\255\SI" +packedUInt32R :: ToRepeated c Word32 => FieldNumber -> c -> MessageBuilder +packedUInt32R = packedVarints32R +{-# INLINE packedUInt32R #-} + +-- | Encodes a packed repeated @uint64@ field. +-- +-- For example: +-- +-- >>> packedUInt64R @[_] 1 [42, 43, maxBound] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f*+\255\255\255\255\255\255\255\255\255\SOH" +packedUInt64R :: ToRepeated c Word64 => FieldNumber -> c -> MessageBuilder +packedUInt64R = packedVarints64R +{-# INLINE packedUInt64R #-} + +-- | Encodes a packed repeated @sint32@ field. +-- +-- For example: +-- +-- >>> packedSInt32R @[_] 1 [-42, maxBound, minBound] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\vS\254\255\255\255\SI\255\255\255\255\SI" +packedSInt32R :: ToRepeated c Int32 => FieldNumber -> c -> MessageBuilder +packedSInt32R !num xs = + packedVarints32R num (mapRepeated (fromIntegral @Int32 @Word32 . zigZagEncode) xs) +{-# INLINE packedSInt32R #-} + +-- | Encodes a packed repeated @sint64@ field. +-- +-- For example: +-- +-- >>> packedSInt64R @[_] 1 [-42, maxBound, minBound] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\NAKS\254\255\255\255\255\255\255\255\255\SOH\255\255\255\255\255\255\255\255\255\SOH" +packedSInt64R :: ToRepeated c Int64 => FieldNumber -> c -> MessageBuilder +packedSInt64R !num xs = + packedVarints64R num (mapRepeated (fromIntegral @Int64 @Word64 . zigZagEncode) xs) +{-# INLINE packedSInt64R #-} + -- | A faster but more specialized variant of: -- --- > packedVarintsV (fromIntegral . fromEnum) num +-- > \f -> packedVarintsR (fromIntegral . fromEnum . f) -- +-- Generalizes 'packedBoolsV', provided that any new instance +-- of 'Vector' is given a corresponding instance of 'ToRepeated'. +-- +-- >>> packedBoolsR @[_] 1 [True, False] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\STX\SOH\NUL" +packedBoolsR :: ToRepeated c Bool => FieldNumber -> c -> MessageBuilder +packedBoolsR = packedFixedWidthFieldR (Prim.word8 . fromIntegral . fromEnum) +{-# INLINE packedBoolsR #-} + +-- | A faster but more specialized variant of: +-- +-- > \f -> packedVarintsV (fromIntegral . fromEnum . f) +-- -- >>> packedBoolsV not 1 ([False, True] :: Data.Vector.Vector Bool) -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\STX\SOH\NUL" packedBoolsV :: Vector v a => (a -> Bool) -> FieldNumber -> v a -> MessageBuilder -packedBoolsV f num = embedded num . MessageBuilder . payload +packedBoolsV f !num = embedded num . MessageBuilder . payload where payload = Prim.vectorFixedPrim (Prim.word8 . fromIntegral . fromEnum . f) {-# INLINE packedBoolsV #-} -- | Encode fixed-width Word32s in the space-efficient packed format. --- But consider 'packedFixed32V', which may be faster. --- --- The values to be encoded are specified by mapping the elements of a vector. +-- But consider 'packedFixed32V' or 'packedFixed32R', either of which may be faster. -- -- >>> packedFixed32 1 [1, 2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\SOH\NUL\NUL\NUL\STX\NUL\NUL\NUL\ETX\NUL\NUL\NUL" packedFixed32 :: Foldable f => FieldNumber -> f Word32 -> MessageBuilder -packedFixed32 num = etaMessageBuilder (embedded num . payload) +packedFixed32 !num = etaMessageBuilder (embedded num . payload) where payload = foldMap (MessageBuilder . RB.word32LE) {-# INLINE packedFixed32 #-} +-- | A faster but more specialized variant of 'packedFixed32'. +-- +-- Generalizes 'packedFixed32V', provided that any new instance +-- of 'Vector' is given a corresponding instance of 'ToRepeated'. +-- +-- >>> packedFixed32R @[_] 1 [1, 2, 3] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\SOH\NUL\NUL\NUL\STX\NUL\NUL\NUL\ETX\NUL\NUL\NUL" +packedFixed32R :: ToRepeated c Word32 => FieldNumber -> c -> MessageBuilder +packedFixed32R = packedFixedWidthFieldR Prim.word32LE +{-# INLINE packedFixed32R #-} + -- | A faster but more specialized variant of: -- -- > \f num -> packedFixed32 num . fmap f @@ -587,24 +773,32 @@ -- 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 = etaMessageBuilder (embedded num . payload) +packedFixed32V f !num = etaMessageBuilder (embedded num . payload) where payload = MessageBuilder . Prim.vectorFixedPrim (Prim.word32LE . f) {-# INLINE packedFixed32V #-} --- | Encode fixed-width Word64s in the space-efficient packed format. --- But consider 'packedFixed64V', which may be faster. --- --- The values to be encoded are specified by mapping the elements of a vector. +-- But consider 'packedFixed64V' or 'packedFixed64R', either of which may be faster. -- -- >>> packedFixed64 1 [1, 2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\STX\NUL\NUL\NUL\NUL\NUL\NUL\NUL\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NUL" packedFixed64 :: Foldable f => FieldNumber -> f Word64 -> MessageBuilder -packedFixed64 num = etaMessageBuilder (embedded num . payload) +packedFixed64 !num = etaMessageBuilder (embedded num . payload) where payload = foldMap (MessageBuilder . RB.word64LE) {-# INLINE packedFixed64 #-} +-- | A faster but more specialized variant of 'packedFixed64'. +-- +-- Generalizes 'packedFixed64V', provided that any new instance +-- of 'Vector' is given a corresponding instance of 'ToRepeated'. +-- +-- >>> packedFixed64R @[_] 1 [1, 2, 3] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\STX\NUL\NUL\NUL\NUL\NUL\NUL\NUL\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NUL" +packedFixed64R :: ToRepeated c Word64 => FieldNumber -> c -> MessageBuilder +packedFixed64R = packedFixedWidthFieldR Prim.word64LE +{-# INLINE packedFixed64R #-} + -- | A faster but more specialized variant of: -- -- > \f num -> packedFixed64 num . fmap f @@ -613,22 +807,53 @@ -- 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 = etaMessageBuilder (embedded num . payload) +packedFixed64V f !num = etaMessageBuilder (embedded num . payload) where payload = MessageBuilder . Prim.vectorFixedPrim (Prim.word64LE . f) {-# INLINE packedFixed64V #-} +-- | Encodes a packed repeated @sfixed32@ field. +-- +-- For example: +-- +-- >>> packedSFixed32R @[_] 1 [1, -2, 3] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\SOH\NUL\NUL\NUL\254\255\255\255\ETX\NUL\NUL\NUL" +packedSFixed32R :: ToRepeated c Int32 => FieldNumber -> c -> MessageBuilder +packedSFixed32R = packedFixedWidthFieldR Prim.int32LE +{-# INLINE packedSFixed32R #-} + +-- | Encodes a packed repeated @sfixed64@ field. +-- +-- For example: +-- +-- >>> packedSFixed64R @[_] 1 [1, -2, 3] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\254\255\255\255\255\255\255\255\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NUL" +packedSFixed64R :: ToRepeated c Int64 => FieldNumber -> c -> MessageBuilder +packedSFixed64R = packedFixedWidthFieldR Prim.int64LE +{-# INLINE packedSFixed64R #-} + -- | Encode floats in the space-efficient packed format. --- But consider 'packedFloatsV', which may be faster. +-- But consider 'packedFloatsV' or 'packedFloatsR', either of which may be faster. -- -- >>> 1 `packedFloats` [1, 2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\NUL\NUL\128?\NUL\NUL\NUL@\NUL\NUL@@" packedFloats :: Foldable f => FieldNumber -> f Float -> MessageBuilder -packedFloats num = etaMessageBuilder (embedded num . payload) +packedFloats !num = etaMessageBuilder (embedded num . payload) where payload = foldMap (MessageBuilder . RB.floatLE) {-# INLINE packedFloats #-} +-- | A faster but more specialized variant of 'packedFloats'. +-- +-- Generalizes 'packedFloatsV', provided that any new instance +-- of 'Vector' is given a corresponding instance of 'ToRepeated'. +-- +-- >>> packedFloatsR @[_] 1 [1, 2, 3] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\NUL\NUL\128?\NUL\NUL\NUL@\NUL\NUL@@" +packedFloatsR :: ToRepeated c Float => FieldNumber -> c -> MessageBuilder +packedFloatsR = packedFixedWidthFieldR Prim.floatLE +{-# INLINE packedFloatsR #-} + -- | A faster but more specialized variant of: -- -- > \f num -> packedFloats num . fmap f @@ -637,22 +862,33 @@ -- 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 = etaMessageBuilder (embedded num . payload) +packedFloatsV f !num = etaMessageBuilder (embedded num . payload) where payload = MessageBuilder . Prim.vectorFixedPrim (Prim.floatLE . f) {-# INLINE packedFloatsV #-} -- | Encode doubles in the space-efficient packed format. --- But consider 'packedDoublesV', which may be faster. +-- But consider 'packedDoublesV' or 'packedDoublesR', either of which may be faster. -- -- >>> 1 `packedDoubles` [1, 2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\NUL\NUL\NUL\NUL\NUL\NUL\240?\NUL\NUL\NUL\NUL\NUL\NUL\NUL@\NUL\NUL\NUL\NUL\NUL\NUL\b@" packedDoubles :: Foldable f => FieldNumber -> f Double -> MessageBuilder -packedDoubles num = etaMessageBuilder (embedded num . payload) +packedDoubles !num = etaMessageBuilder (embedded num . payload) where payload = foldMap (MessageBuilder . RB.doubleLE) {-# INLINE packedDoubles #-} +-- | A faster but more specialized variant of 'packedDoubles'. +-- +-- Generalizes 'packedDoublesV', provided that any new instance +-- of 'Vector' is given a corresponding instance of 'ToRepeated'. +-- +-- >>> packedDoublesR @[_] 1 [1, 2, 3] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\NUL\NUL\NUL\NUL\NUL\NUL\240?\NUL\NUL\NUL\NUL\NUL\NUL\NUL@\NUL\NUL\NUL\NUL\NUL\NUL\b@" +packedDoublesR :: ToRepeated c Double => FieldNumber -> c -> MessageBuilder +packedDoublesR = packedFixedWidthFieldR Prim.doubleLE +{-# INLINE packedDoublesR #-} + -- | A faster but more specialized variant of: -- -- > \f num -> packedDoubles num . fmap f @@ -661,7 +897,7 @@ -- 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 = etaMessageBuilder (embedded num . payload) +packedDoublesV f !num = etaMessageBuilder (embedded num . payload) where payload = MessageBuilder . Prim.vectorFixedPrim (Prim.doubleLE . f) {-# INLINE packedDoublesV #-} @@ -673,13 +909,16 @@ -- -- For example: -- +-- >>> 1 `embedded` mempty +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\NUL" -- >>> 1 `embedded` (1 `string` "this message" <> 2 `string` " is embedded") -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\FS\n\fthis message\DC2\f is embedded" embedded :: FieldNumber -> MessageBuilder -> MessageBuilder -embedded = \num (MessageBuilder bb) -> - MessageBuilder (RB.withLengthOf (Prim.liftBoundedPrim . prefix num) bb) +embedded = \(!num) (MessageBuilder bb) -> + MessageBuilder (RB.withLengthOf (prefix num) bb) where - prefix num len = + prefix !num len = Prim.liftBoundedPrim $ unMessageBoundedPrim (fieldHeader num LengthDelimited) &<> Prim.wordBase128LEVar (fromIntegral @Int @Word len) + {-# INLINE prefix #-} {-# INLINE embedded #-} diff --git a/src/Proto3/Wire/Encode/Repeated.hs b/src/Proto3/Wire/Encode/Repeated.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Wire/Encode/Repeated.hs @@ -0,0 +1,185 @@ +{- + Copyright 2025 Arista Networks + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +-- | Presents right-associative folds as 'Foldable' sequences. +module Proto3.Wire.Encode.Repeated + ( Repeated(..) + , nullRepeated + , ToRepeated(..) + , mapRepeated + ) where + +import Data.Functor.Identity (Identity(..)) +import Data.IntMap.Lazy qualified +import Data.IntSet qualified +import Data.Kind (Type) +import Data.List.NonEmpty qualified +import Data.Map.Lazy qualified +import Data.Sequence qualified +import Data.Set qualified +import Data.Vector qualified +import Data.Vector.Storable qualified +import Data.Vector.Unboxed qualified +import Foreign (Storable) +import GHC.Exts (Constraint, TYPE) +import GHC.Generics (Generic) +import Proto3.Wire.FoldR (FoldR(..), fromFoldR) + +-- | Expresses a sequence of values /in reverse order/ for encoding as a repeated field. +type Repeated :: forall er . TYPE er -> Type +data Repeated e = ReverseRepeated + { countRepeated :: Maybe Int + -- ^ Optionally predicts the number of elements in the sequence. Predict + -- the count only when it is practical to do so accurately and quickly. + -- + -- A prediction that is too low causes undefined behavior--possibly + -- a crash. A length prediction that is too high overallocates + -- output space, as if the sequence really were that length. + , reverseRepeated :: FoldR e + -- ^ A lazy right-associative fold over the /reverse/ + -- of the desired sequence of field values. + -- + -- Design Note: We could have used a lazy left-associative fold, but + -- vectors perform such folds using a left-to-right iteration, instead + -- of the right-to-left iteration that would yield best performance. + -- + -- Therefore in order to avoid accidental misuse of 'foldl', we ask + -- for sequence reversal explicitly. Thanks to vector fusion rules, + -- it is fast to 'foldr' on the result of reversing a vector. + } + deriving stock (Functor, Generic) + +deriving stock instance Eq e => Eq (Repeated e) +deriving stock instance Read e => Read (Repeated e) +deriving stock instance Show e => Show (Repeated e) + +nullRepeated :: Repeated e -> Bool +nullRepeated c = null (reverseRepeated c) +{-# INLINE nullRepeated #-} + +-- | For each container type, specifies the optimal method for reverse iteration. +type ToRepeated :: forall cr . TYPE cr -> forall er . TYPE er -> Constraint +class ToRepeated c e | c -> e + where + -- | Converts to a reverse iteration over the elements. + toRepeated :: c -> Repeated e + +instance forall er (e :: TYPE er) . + ToRepeated (Repeated e) e + where + toRepeated = id + {-# INLINE toRepeated #-} + +instance ToRepeated (Identity a) a + where + toRepeated x = ReverseRepeated (Just 1) (FoldR (\f z -> f (runIdentity x) z)) + {-# INLINE toRepeated #-} + +instance ToRepeated [a] a + where + toRepeated xs = ReverseRepeated Nothing (FoldR (\f z -> foldl (flip f) z xs)) + -- Unavoidably reads to the end of the list before presenting the last element. + {-# INLINE toRepeated #-} + +instance ToRepeated (Data.List.NonEmpty.NonEmpty a) a + where + toRepeated xs = ReverseRepeated Nothing (FoldR (\f z -> foldl (flip f) z xs)) + -- Unavoidably reads to the end of the list before presenting the last element. + {-# INLINE toRepeated #-} + +instance ToRepeated (Data.Vector.Vector a) a + where + toRepeated xs = ReverseRepeated + (Just (Data.Vector.length xs)) + (fromFoldR (Data.Vector.reverse xs)) + -- Vector fusion should convert this to right-to-left iteration. + {-# INLINE toRepeated #-} + +instance Storable a => + ToRepeated (Data.Vector.Storable.Vector a) a + where + toRepeated xs = ReverseRepeated + (Just (Data.Vector.Storable.length xs)) + (FoldR (\f z -> Data.Vector.Storable.foldr f z (Data.Vector.Storable.reverse xs))) + -- Vector fusion should convert this to right-to-left iteration. + {-# INLINE toRepeated #-} + +instance Data.Vector.Unboxed.Unbox a => + ToRepeated (Data.Vector.Unboxed.Vector a) a + where + toRepeated xs = ReverseRepeated + (Just (Data.Vector.Unboxed.length xs)) + (FoldR (\f z -> Data.Vector.Unboxed.foldr f z (Data.Vector.Unboxed.reverse xs))) + -- Vector fusion should convert this to right-to-left iteration. + {-# INLINE toRepeated #-} + +instance ToRepeated (Data.Sequence.Seq a) a + where + toRepeated xs = ReverseRepeated + (Just (Data.Sequence.length xs)) + (FoldR (\f z -> foldl (flip f) z xs)) + -- Should present the last element without having to read through the whole sequence. + {-# INLINE toRepeated #-} + +instance ToRepeated (Data.Set.Set a) a + where + toRepeated xs = ReverseRepeated + (Just (Data.Set.size xs)) + (FoldR (\f z -> foldl (flip f) z xs)) + -- Should present the last element without having to read through the whole sequence. + {-# INLINE toRepeated #-} + +instance ToRepeated Data.IntSet.IntSet Int + where + toRepeated xs = ReverseRepeated Nothing (FoldR (\f z -> Data.IntSet.foldl (flip f) z xs)) + -- Should present the last element without having to read through the whole sequence. + {-# INLINE toRepeated #-} + +instance ToRepeated (Data.Map.Lazy.Map k a) (k, a) + where + toRepeated xs = ReverseRepeated + (Just (Data.Map.Lazy.size xs)) + (FoldR (\f z -> Data.Map.Lazy.foldlWithKey (\a k v -> f (k, v) a) z xs)) + -- Should present the last key-value pair without having to read through the whole map. + {-# INLINE toRepeated #-} + +instance ToRepeated (Data.IntMap.Lazy.IntMap a) (Int, a) + where + toRepeated xs = ReverseRepeated + Nothing + (FoldR (\f z -> Data.IntMap.Lazy.foldlWithKey (\a k v -> f (k, v) a) z xs)) + -- Should present the last key-value pair without having to read through the whole map. + {-# INLINE toRepeated #-} + +-- | A convenience function that maps a function over a sequence, +-- provided that the relevant types are all lifted. +mapRepeated :: + forall (c :: Type) (e :: Type) (a :: Type) . ToRepeated c e => (e -> a) -> c -> Repeated a +mapRepeated f xs = fmap f (toRepeated xs) +{-# INLINE mapRepeated #-} diff --git a/src/Proto3/Wire/FoldR.hs b/src/Proto3/Wire/FoldR.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Wire/FoldR.hs @@ -0,0 +1,80 @@ +{- + Copyright 2025 Arista Networks + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Presents right-associative folds as 'Foldable' sequences. +module Proto3.Wire.FoldR + ( FoldR(..) + , fromFoldR + ) where + +import Data.Foldable qualified +import Data.Kind (Type) +import GHC.Exts (TYPE) +import GHC.Exts qualified +import Text.Read (Read(..)) + +-- | Presents a right-associative fold as a 'Foldable' sequence. +-- +-- Similar to the @FRList@ example in the documentation for "Data.Foldable", +-- but for generality the element type may be unlifted. For compatibility +-- with the 'Foldable' type class and to avoid limitations on runtime +-- representation polymorphism, the fold supports only lifted results. +newtype FoldR (a :: TYPE r) = FoldR { applyFoldR :: forall (b :: Type) . (a -> b -> b) -> b -> b } + deriving stock (Functor) + +instance Foldable FoldR + where + foldr f z xs = applyFoldR xs f z + +instance GHC.Exts.IsList (FoldR a) + where + type Item (FoldR a) = a + fromList = fromFoldR + toList = Data.Foldable.toList + +instance Eq a => + Eq (FoldR a) + where + x == y = GHC.Exts.toList x == GHC.Exts.toList y + +instance Ord a => + Ord (FoldR a) + where + x <= y = GHC.Exts.toList x <= GHC.Exts.toList y + x `compare` y = GHC.Exts.toList x `compare` GHC.Exts.toList y + +instance Read a => + Read (FoldR a) + where + readPrec = fmap GHC.Exts.fromList readPrec + +instance Show a => + Show (FoldR a) + where + showsPrec d = showsPrec d . GHC.Exts.toList + +-- | Creates a 'FoldR' from the 'foldr' of the given 'Foldable' sequence. +fromFoldR :: Foldable t => t a -> FoldR a +fromFoldR xs = FoldR { applyFoldR = \f z -> foldr f z xs } diff --git a/src/Proto3/Wire/Reverse.hs b/src/Proto3/Wire/Reverse.hs --- a/src/Proto3/Wire/Reverse.hs +++ b/src/Proto3/Wire/Reverse.hs @@ -26,6 +26,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} module Proto3.Wire.Reverse ( -- * `BuildR` type @@ -79,6 +81,8 @@ -- * Helpful combinators , foldlRVector + , repeatedBuildR + , repeatedFixedPrimR -- * Exported for testing purposes only. , testWithUnused @@ -86,6 +90,7 @@ 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 @@ -100,6 +105,13 @@ import Data.Vector.Generic ( Vector ) import Data.Word ( Word8, Word16, Word32, Word64 ) import Foreign ( castPtr, copyBytes ) +import GHC.Exts ( Addr#, Int(..), Int# ) +#if !MIN_VERSION_bytestring(0,11,0) +import GHC.Exts ( plusAddr# ) +#endif +import GHC.ForeignPtr ( ForeignPtr(..), ForeignPtrContents ) +import GHC.TypeLits ( KnownNat ) +import Proto3.Wire.Encode.Repeated ( Repeated(..), ToRepeated(..) ) import Proto3.Wire.Reverse.Internal import qualified Proto3.Wire.Reverse.Prim as Prim @@ -134,16 +146,33 @@ -- >>> 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 -> - copyBytes dst (castPtr src) len - else - prependChunk bs +#if MIN_VERSION_bytestring(0,11,0) +byteString (BI.BS (ForeignPtr ad ct) (I# len)) = byteStringImpl ad ct len +#else +byteString (BI.PS (ForeignPtr ad ct) (I# off) (I# len)) = byteStringImpl (plusAddr# ad off) ct len +#endif +{-# INLINE byteString #-} +byteStringImpl :: Addr# -> ForeignPtrContents -> Int# -> BuildR +byteStringImpl ad ct len = +#if MIN_VERSION_bytestring(0,11,0) + let bs = BI.BS (ForeignPtr ad ct) (I# len) in +#else + let bs = BI.PS (ForeignPtr ad ct) 0 (I# len) in +#endif + withUnused $ \unused -> + if I# len <= unused + then + unsafeConsume (I# len) $ \dst -> + BU.unsafeUseAsCString bs $ \src -> + copyBytes dst (castPtr src) (I# len) + else + prependChunk bs +{-# NOINLINE [1] byteStringImpl #-} +{-# RULES + "byteStringImpl/empty" forall ad ct . byteStringImpl ad ct 0# = mempty + #-} + -- | Convert a lazy `BL.ByteString` to a `BuildR` -- -- Warning: evaluating the length will force the lazy `BL.ByteString`'s chunks, @@ -179,6 +208,10 @@ copyBytes dst (castPtr src) len else prependReverseChunks (ReverseChunks(BLI.Chunk c cs)) +{-# NOINLINE [1] lazyByteString #-} +{-# RULES + "lazyByteString/empty" lazyByteString BLI.Empty = mempty + #-} -- | Convert a `BS.ShortByteString` to a `BuildR` -- @@ -823,9 +856,40 @@ {-# INLINE word64Base128LEVar_inline #-} -- | Essentially 'foldMap', but iterates right to left for efficiency. +-- +-- See also: 'repeatedBuildR' vectorBuildR :: Vector v a => (a -> BuildR) -> v a -> BuildR vectorBuildR f = etaBuildR (foldlRVector (\acc x -> acc <> f x) mempty) {-# INLINE vectorBuildR #-} + +-- | Concatenates the given builders, iterating right to left where practical. +-- +-- For example: +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (repeatedBuildR (map word8 [42,67]))) +-- [42,67] +-- +-- See also: 'repeatedFixedPrimR', 'vectorBuildR' +repeatedBuildR :: ToRepeated c BuildR => c -> BuildR +repeatedBuildR = etaBuildR (foldr (flip (<>)) mempty . reverseRepeated . toRepeated) +{-# INLINE repeatedBuildR #-} + +-- | Concatenates the given fixed-width primitives, iterating right to left where practical +-- and consolidating space checks if the number of primitives has been predicted. +-- +-- For example: +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (repeatedFixedPrimR (map Proto3.Wire.Reverse.Prim.word8 [42,67]))) +-- [42,67] +-- +-- See also: 'repeatedBuildR' +repeatedFixedPrimR :: (ToRepeated c (Prim.FixedPrim w), KnownNat w) => c -> BuildR +repeatedFixedPrimR = etaBuildR $ \c -> + let ReverseRepeated prediction prims = toRepeated c in + case prediction of + Nothing -> foldr (\p a -> a <> Prim.liftBoundedPrim (Prim.liftFixedPrim p)) mempty prims + Just count -> Prim.unsafeReverseFoldMapFixedPrim id count prims +{-# INLINE repeatedFixedPrimR #-} -- | Exported for testing purposes only. testWithUnused :: (Int -> BuildR) -> BuildR diff --git a/src/Proto3/Wire/Reverse/Prim.hs b/src/Proto3/Wire/Reverse/Prim.hs --- a/src/Proto3/Wire/Reverse/Prim.hs +++ b/src/Proto3/Wire/Reverse/Prim.hs @@ -99,6 +99,7 @@ , word64Base128LEVar , word64Base128LEVar_inline , vectorFixedPrim + , unsafeReverseFoldMapFixedPrim ) where import Data.Bits ( Bits(..) ) @@ -844,3 +845,30 @@ where w = fromInteger (natVal' (proxy# :: Proxy# w)) {-# INLINE vectorFixedPrim #-} + +-- | Generalizes 'vectorFixedPrim' by mapping the elements +-- of a sequence of known length to fixed-width primitives +-- and concatenating those primitives /in reverse order/. +-- +-- This action is unsafe because a length prediction that is too short +-- causes undefined behavior--possibly a crash. By contrast, a length +-- prediction that is too long merely overallocates output space. +-- +-- (To see how this function could be used to implement 'vectorFixedPrim', +-- note that we can iterate over a vector from right to left by reversing +-- the vector and then performing a right fold on the reversed vector; +-- vector fusion rules should eliminate the intermediate vector.) +unsafeReverseFoldMapFixedPrim :: + forall w t a . + (KnownNat w, Foldable t) => + (a -> FixedPrim w) -> + -- | Maximum number of elements. Overapproximation causes + -- overallocation; passing an undercount may cause a crash. + Int -> + t a -> + BuildR +unsafeReverseFoldMapFixedPrim f !n = etaBuildR $ \xs -> + ensure (w * n) (foldr (\x acc -> acc <> unsafeBuildBoundedPrim (liftFixedPrim (f x))) mempty xs) + where + w = fromInteger (natVal' (proxy# :: Proxy# w)) +{-# INLINE unsafeReverseFoldMapFixedPrim #-} diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -14,9 +14,11 @@ limitations under the License. -} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-warnings-deprecations #-} @@ -32,20 +34,34 @@ import qualified Data.ByteString.Short as BS import qualified Data.ByteString.Builder.Internal as BBI import Data.Either ( isLeft ) -import Data.Maybe ( fromMaybe ) +import Data.Foldable ( toList ) +import Data.Functor.Identity ( Identity ) import Data.Int +import qualified Data.IntMap.Lazy +import qualified Data.IntSet +import qualified Data.Map.Lazy +import Data.Maybe ( fromMaybe ) import Data.List ( sort ) import qualified Data.List.NonEmpty as NE +import Data.Proxy ( Proxy(..) ) +import qualified Data.Sequence +import qualified Data.Set import qualified Data.Text.Lazy as T import qualified Data.Text.Short as TS +import Data.Typeable ( Typeable, showsTypeRep, typeRep ) import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU import Data.Word ( Word8, Word64 ) import Foreign ( sizeOf ) +import qualified GHC.Exts import Proto3.Wire +import Proto3.Wire.FoldR ( FoldR ) import qualified Proto3.Wire.Builder as Builder import qualified Proto3.Wire.Reverse as Reverse import qualified Proto3.Wire.Encode as Encode +import Proto3.Wire.Encode.Repeated ( Repeated(..), ToRepeated(..), nullRepeated ) import qualified Proto3.Wire.Decode as Decode import qualified Test.DocTest @@ -77,6 +93,7 @@ , varIntHeavyTests , packedLargeTests , decodeWireRoundTrip + , toRepeatedTests ] data StringOrInt64 = TString T.Text | TInt64 Int64 @@ -783,3 +800,73 @@ decoded = Decode.parse (one Decode.packedDoubles [] `at` fieldNumber 13) (BL.toStrict encoded) HU.assertEqual "round trip" (Right [2 .. count + 1]) decoded + +data ExpectedCountPrediction c = NoCP | CorrectCP | SameCP (c -> Maybe Int) + +toRepeatedTests :: TestTree +toRepeatedTests = testGroup "ToRepeated" + [ test_nullRepeated + , test_ToRepeated (SameCP countRepeated) genRepeated (reverse . toList . reverseRepeated) + , test_ToRepeated CorrectCP QC.arbitrary (toList @Identity @Word8) + , test_ToRepeated NoCP QC.arbitrary (id @[Word8]) + , test_ToRepeated NoCP ((NE.:|) <$> QC.arbitrary <*> QC.arbitrary) (toList @NE.NonEmpty @Word8) + , test_ToRepeated CorrectCP (fmap V.fromList QC.arbitrary) (V.toList @Word8) + , test_ToRepeated CorrectCP (fmap VS.fromList QC.arbitrary) (VS.toList @Word8) + , test_ToRepeated CorrectCP (fmap VU.fromList QC.arbitrary) (VU.toList @Word8) + , test_ToRepeated CorrectCP QC.arbitrary (toList @Data.Sequence.Seq @Word8) + , test_ToRepeated CorrectCP QC.arbitrary (Data.Set.toAscList @Word8) + , test_ToRepeated NoCP QC.arbitrary Data.IntSet.toAscList + , test_ToRepeated CorrectCP QC.arbitrary (Data.Map.Lazy.toAscList @Int8 @Word8) + , test_ToRepeated NoCP QC.arbitrary (Data.IntMap.Lazy.toAscList @Word8) + ] + where + genRepeated :: QC.Gen (Repeated Word8) + genRepeated = do + predict <- QC.arbitrary + xs <- QC.arbitrary + pure ReverseRepeated + { countRepeated = if predict then Just (length xs) else Nothing + , reverseRepeated = GHC.Exts.fromList xs + } + + test_nullRepeated :: TestTree + test_nullRepeated = + QC.testProperty "nullRepeated" $ + QC.forAll genRepeated $ \c -> + nullRepeated c === null (reverseRepeated c) + + test_ToRepeated :: + forall c e . + ( ToRepeated c e + , Show c + , Typeable c + , Eq e + , Show e + ) => + ExpectedCountPrediction c -> + (QC.Gen c) -> + (c -> [e]) -> + TestTree + test_ToRepeated expectedCP gen cToList = + let cRep = typeRep (Proxy :: Proxy c) in + QC.testProperty (showString "toRepeated @(" $ showsTypeRep cRep ")") $ + QC.forAll gen $ \(c :: c) -> + let es :: [e] + es = cToList c + + prediction :: Maybe Int + reversed :: FoldR e + ReverseRepeated prediction reversed = toRepeated c + in + QC.counterexample "correctly reversed elements" (toList reversed === reverse es) + QC..&&. + QC.counterexample "correct count prediction if any" + (all @Maybe (== length es) prediction) + QC..&&. + case expectedCP of + NoCP -> + QC.counterexample "no count prediction" (prediction === Nothing) + CorrectCP -> + QC.counterexample "correct count prediction" (prediction === Just (length es)) + SameCP expected -> + QC.counterexample "unchanged count prediction" (prediction === expected c)