diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,16 @@ +1.5.0 + - As a breaking change, modify `Repeated` and `ToRepeated` to use `foldMap`-style + folds and thereby avoid allocation of `BuildR` functions on the heap. Use + of `FoldR` seemed to force such allocation, even when using `oneShot`. + - Use `oneShot` in `BuildR` and `FixedPrim` to discourage allocation + of such function newtypes on the heap in other scenarios. + - Add `BuildM` and associated features for monadic building. + - Add `PackedField` to support packed fields in a uniform fashion, + and directly implement omission of such a field when it is empty. + - Add `embeddedIfNonempty` as a way to omit empty length-delimited fields. + - Deprecate `FoldR` and `unsafeReverseFoldMapFixedPrim` because + we have stopped using them and plan to remove them in future. + 1.4.6 - Add a decoder combinator named `optional` for optional fields of primitive type. diff --git a/proto3-wire.cabal b/proto3-wire.cabal --- a/proto3-wire.cabal +++ b/proto3-wire.cabal @@ -1,13 +1,13 @@ cabal-version: >=1.10 name: proto3-wire -version: 1.4.6 +version: 1.5.0 synopsis: A low-level implementation of the Protocol Buffers (version 3) wire format license: Apache-2.0 license-file: LICENSE author: Arista Networks maintainer: Arista Networks -copyright: 2017 Awake Security, 2021 Arista Networks +copyright: 2017 Awake Security, 2021-2026 Arista Networks category: Codec build-type: Simple @@ -27,6 +27,8 @@ -O2 -fobject-code -Wall + -Wmissing-deriving-strategies + -Wunused-packages -- 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. @@ -47,7 +49,6 @@ , text >= 0.2 && <2.2 , text-short ==0.1.* , transformers >=0.5.6.2 && <0.7 - , unordered-containers >= 0.1.0.0 && <0.3 , vector >=0.12.0.2 && <0.14 , QuickCheck >=2.8 && <3.0 , word-compat >= 0.0.6 @@ -100,6 +101,8 @@ ghc-options: -O2 -Wall + -Wmissing-deriving-strategies + -Wunused-packages build-depends: base >= 4 && < 5 diff --git a/src/Proto3/Wire/Decode.hs b/src/Proto3/Wire/Decode.hs --- a/src/Proto3/Wire/Decode.hs +++ b/src/Proto3/Wire/Decode.hs @@ -25,6 +25,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} @@ -124,7 +125,7 @@ | Fixed32Field B.ByteString | Fixed64Field B.ByteString | LengthDelimitedField B.ByteString - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Convert key-value pairs to a map of keys to a sequence of values with that -- key, in their reverse occurrence order. @@ -257,7 +258,7 @@ -- embedded message. EmbeddedError Text (Maybe ParseError) - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord) -- | This library does not use this instance, but it is provided for convenience, -- so that 'ParseError' may be used with functions like `throwIO` @@ -277,7 +278,7 @@ -- 'Parser's can be combined using the 'Applicative', 'Monad' and 'Alternative' -- instances. newtype Parser input a = Parser { runParser :: input -> Either ParseError a } - deriving Functor + deriving stock Functor instance Applicative (Parser input) where pure = Parser . const . pure 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 @@ -1,5 +1,5 @@ {- - Copyright 2016 Awake Networks + Copyright 2016-2026 Awake Networks Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -38,6 +38,7 @@ -- > 1 `strings` Just "some string" <> -- > 2 `strings` [ "foo", "bar", "baz" ] +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} @@ -94,9 +95,11 @@ , shortByteString -- * Embedded Messages , embedded + , embeddedIfNonempty -- * Folds , repeatedMessageBuilder -- * Packed repeated fields + , PackedField(..) , packedVarints , packedVarintsV , packedInt32R @@ -135,7 +138,7 @@ import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Text.Short as Text.Short import Data.Vector.Generic ( Vector ) -import Data.Word ( Word8, Word32, Word64 ) +import Data.Word ( Word8, Word16, Word32, Word64 ) import GHC.TypeLits ( KnownNat, Nat, type (+) ) import Parameterized.Data.Semigroup ( PNullary, PSemigroup(..), (&<>) ) @@ -512,16 +515,7 @@ -- >>> 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 #-} +bytesIfNonempty !num = embeddedIfNonempty num . MessageBuilder {-# INLINE bytesIfNonempty #-} -- | Encode a UTF-8 string. @@ -602,6 +596,13 @@ etaMessageBuilder (embedded num . MessageBuilder . RB.repeatedBuildR . mapRepeated f) {-# INLINE packedVariableWidthFieldR #-} +-- | Like 'packedVariableWidthFieldR' but uses omission for zero elements. +packedVariableWidthFieldRIfNonempty :: + ToRepeated c a => (a -> RB.BuildR) -> FieldNumber -> c -> MessageBuilder +packedVariableWidthFieldRIfNonempty f !num = + etaMessageBuilder (embeddedIfNonempty num . MessageBuilder . RB.repeatedBuildR . mapRepeated f) +{-# INLINE packedVariableWidthFieldRIfNonempty #-} + -- | Encodes a packed repeated field whose elements never vary in width. packedFixedWidthFieldR :: (ToRepeated c a, KnownNat w) => (a -> Prim.FixedPrim w) -> FieldNumber -> c -> MessageBuilder @@ -609,6 +610,83 @@ etaMessageBuilder (embedded num . MessageBuilder . RB.repeatedFixedPrimR . mapRepeated f) {-# INLINE packedFixedWidthFieldR #-} +-- | Like 'packedFixedWidthFieldR' but uses omission for zero elements. +packedFixedWidthFieldRIfNonempty :: + (ToRepeated c a, KnownNat w) => (a -> Prim.FixedPrim w) -> FieldNumber -> c -> MessageBuilder +packedFixedWidthFieldRIfNonempty f !num = + etaMessageBuilder (embeddedIfNonempty num . MessageBuilder . RB.repeatedFixedPrimR . mapRepeated f) +{-# INLINE packedFixedWidthFieldRIfNonempty #-} + +-- | Chooses an appropriate encoder for the specified packed repeated field and sequence type. +class ToRepeated c e => + PackedField wt c e + where + -- | Normally emits a packed repeated field. But if there is exactly + -- one element in the sequence, then this method uses unpacked format + -- because it is slightly shorter. And if the sequence is empty then + -- this method omits the encoding entirely. + -- + -- The caller must specify the wire type and must also perform + -- any required integral conversions such as zig-zag encoding + -- (perhaps by using 'mapRepeated'.) + packedField :: FieldNumber -> c -> MessageBuilder + +instance ToRepeated c Word64 => + PackedField 'Varint c Word64 + where + packedField = packedVariableWidthFieldRIfNonempty RB.word64Base128LEVar + {-# INLINE packedField #-} + +instance ToRepeated c Word32 => + PackedField 'Varint c Word32 + where + packedField = packedVariableWidthFieldRIfNonempty RB.word32Base128LEVar + {-# INLINE packedField #-} + +instance ToRepeated c Word16 => + PackedField 'Varint c Word16 + where + packedField = packedVariableWidthFieldRIfNonempty (RB.word32Base128LEVar . fromIntegral) + -- In future we might add a more specialized, more compact function named @word16Base128LEVar@. + {-# INLINE packedField #-} + +instance ToRepeated c Word8 => + PackedField 'Varint c Word8 + where + packedField = packedVariableWidthFieldRIfNonempty (RB.word32Base128LEVar . fromIntegral) + -- In future we might add a more specialized, more compact function named @word8Base128LEVar@. + {-# INLINE packedField #-} + +instance ToRepeated c Bool => + PackedField 'Varint c Bool + where + packedField = packedFixedWidthFieldRIfNonempty (Prim.word8 . fromIntegral . fromEnum) + {-# INLINE packedField #-} + +instance ToRepeated c Word32 => + PackedField 'Fixed32 c Word32 + where + packedField = packedFixedWidthFieldRIfNonempty Prim.word32LE + {-# INLINE packedField #-} + +instance ToRepeated c Float => + PackedField 'Fixed32 c Float + where + packedField = packedFixedWidthFieldRIfNonempty Prim.floatLE + {-# INLINE packedField #-} + +instance ToRepeated c Word64 => + PackedField 'Fixed64 c Word64 + where + packedField = packedFixedWidthFieldRIfNonempty Prim.word64LE + {-# INLINE packedField #-} + +instance ToRepeated c Double => + PackedField 'Fixed64 c Double + where + packedField = packedFixedWidthFieldRIfNonempty Prim.doubleLE + {-# INLINE packedField #-} + -- | Encode varints in the space-efficient packed format. -- But consider 'packedVarintsV' or 'packedVarintsR', either of which may be faster. -- @@ -624,6 +702,8 @@ -- -- Generalizes 'packedVarintsV', provided that any new instance -- of 'Vector' is given a corresponding instance of 'ToRepeated'. +-- +-- But use 'packedField' to omit the field when there are zero elements. packedVarints64R :: ToRepeated c Word64 => FieldNumber -> c -> MessageBuilder packedVarints64R = packedVariableWidthFieldR RB.word64Base128LEVar {-# INLINE packedVarints64R #-} @@ -631,6 +711,8 @@ -- | Like 'packedVarints64R' but supports only 32-bit inputs, -- which reduces on executable size in situations where we do -- not need to support larger values. +-- +-- But use 'packedField' to omit the field when there are zero elements. packedVarints32R :: ToRepeated c Word32 => FieldNumber -> c -> MessageBuilder packedVarints32R = packedVariableWidthFieldR RB.word32Base128LEVar {-# INLINE packedVarints32R #-} @@ -659,6 +741,8 @@ -- 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..." -- +-- +-- But use 'packedField' to omit the field when there are zero elements. packedInt32R :: ToRepeated c Int32 => FieldNumber -> c -> MessageBuilder packedInt32R !num xs = packedVarints64R num (mapRepeated (fromIntegral @Int32 @Word64) xs) @@ -670,6 +754,8 @@ -- -- >>> packedInt64R @[_] 1 [42, -42] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\v*\214\255\255\255\255\255\255\255\255\SOH" +-- +-- But use 'packedField' to omit the field when there are zero elements. packedInt64R :: ToRepeated c Int64 => FieldNumber -> c -> MessageBuilder packedInt64R !num xs = packedVarints64R num (mapRepeated (fromIntegral @Int64 @Word64) xs) @@ -681,6 +767,8 @@ -- -- >>> packedUInt32R @[_] 1 [42, 43, maxBound] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\a*+\255\255\255\255\SI" +-- +-- But use 'packedField' to omit the field when there are zero elements. packedUInt32R :: ToRepeated c Word32 => FieldNumber -> c -> MessageBuilder packedUInt32R = packedVarints32R {-# INLINE packedUInt32R #-} @@ -691,6 +779,8 @@ -- -- >>> packedUInt64R @[_] 1 [42, 43, maxBound] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f*+\255\255\255\255\255\255\255\255\255\SOH" +-- +-- But use 'packedField' to omit the field when there are zero elements. packedUInt64R :: ToRepeated c Word64 => FieldNumber -> c -> MessageBuilder packedUInt64R = packedVarints64R {-# INLINE packedUInt64R #-} @@ -701,6 +791,8 @@ -- -- >>> packedSInt32R @[_] 1 [-42, maxBound, minBound] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\vS\254\255\255\255\SI\255\255\255\255\SI" +-- +-- But use 'packedField' to omit the field when there are zero elements. packedSInt32R :: ToRepeated c Int32 => FieldNumber -> c -> MessageBuilder packedSInt32R !num xs = packedVarints32R num (mapRepeated (fromIntegral @Int32 @Word32 . zigZagEncode) xs) @@ -712,6 +804,8 @@ -- -- >>> 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" +-- +-- But use 'packedField' to omit the field when there are zero elements. packedSInt64R :: ToRepeated c Int64 => FieldNumber -> c -> MessageBuilder packedSInt64R !num xs = packedVarints64R num (mapRepeated (fromIntegral @Int64 @Word64 . zigZagEncode) xs) @@ -726,6 +820,8 @@ -- -- >>> packedBoolsR @[_] 1 [True, False] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\STX\SOH\NUL" +-- +-- But use 'packedField' to omit the field when there are zero elements. packedBoolsR :: ToRepeated c Bool => FieldNumber -> c -> MessageBuilder packedBoolsR = packedFixedWidthFieldR (Prim.word8 . fromIntegral . fromEnum) {-# INLINE packedBoolsR #-} @@ -761,6 +857,8 @@ -- -- >>> packedFixed32R @[_] 1 [1, 2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\SOH\NUL\NUL\NUL\STX\NUL\NUL\NUL\ETX\NUL\NUL\NUL" +-- +-- But use 'packedField' to omit the field when there are zero elements. packedFixed32R :: ToRepeated c Word32 => FieldNumber -> c -> MessageBuilder packedFixed32R = packedFixedWidthFieldR Prim.word32LE {-# INLINE packedFixed32R #-} @@ -795,6 +893,8 @@ -- -- >>> 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" +-- +-- But use 'packedField' to omit the field when there are zero elements. packedFixed64R :: ToRepeated c Word64 => FieldNumber -> c -> MessageBuilder packedFixed64R = packedFixedWidthFieldR Prim.word64LE {-# INLINE packedFixed64R #-} @@ -818,6 +918,8 @@ -- -- >>> packedSFixed32R @[_] 1 [1, -2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\SOH\NUL\NUL\NUL\254\255\255\255\ETX\NUL\NUL\NUL" +-- +-- But use 'packedField' to omit the field when there are zero elements. packedSFixed32R :: ToRepeated c Int32 => FieldNumber -> c -> MessageBuilder packedSFixed32R = packedFixedWidthFieldR Prim.int32LE {-# INLINE packedSFixed32R #-} @@ -828,6 +930,8 @@ -- -- >>> 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" +-- +-- But use 'packedField' to omit the field when there are zero elements. packedSFixed64R :: ToRepeated c Int64 => FieldNumber -> c -> MessageBuilder packedSFixed64R = packedFixedWidthFieldR Prim.int64LE {-# INLINE packedSFixed64R #-} @@ -850,6 +954,8 @@ -- -- >>> packedFloatsR @[_] 1 [1, 2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\NUL\NUL\128?\NUL\NUL\NUL@\NUL\NUL@@" +-- +-- But use 'packedField' to omit the field when there are zero elements. packedFloatsR :: ToRepeated c Float => FieldNumber -> c -> MessageBuilder packedFloatsR = packedFixedWidthFieldR Prim.floatLE {-# INLINE packedFloatsR #-} @@ -885,6 +991,8 @@ -- -- >>> 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@" +-- +-- But use 'packedField' to omit the field when there are zero elements. packedDoublesR :: ToRepeated c Double => FieldNumber -> c -> MessageBuilder packedDoublesR = packedFixedWidthFieldR Prim.doubleLE {-# INLINE packedDoublesR #-} @@ -922,3 +1030,26 @@ Prim.wordBase128LEVar (fromIntegral @Int @Word len) {-# INLINE prefix #-} {-# INLINE embedded #-} + +-- | Like 'embedded' 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. +-- +-- For example: +-- +-- >>> 1 `embeddedIfNonempty` mempty +-- Proto3.Wire.Encode.unsafeFromLazyByteString "" +-- >>> 1 `embeddedIfNonempty` (1 `string` "this message" <> 2 `string` " is embedded") +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\FS\n\fthis message\DC2\f is embedded" +embeddedIfNonempty :: FieldNumber -> MessageBuilder -> MessageBuilder +embeddedIfNonempty = \(!num) (MessageBuilder bb) -> + MessageBuilder (RB.withLengthOf (prefix num) bb) + where + prefix !num len + | 0 < len = Prim.liftBoundedPrim $ + unMessageBoundedPrim (fieldHeader num LengthDelimited) &<> + Prim.wordBase128LEVar (fromIntegral @Int @Word len) + | otherwise = + mempty + {-# INLINE prefix #-} +{-# INLINE embeddedIfNonempty #-} diff --git a/src/Proto3/Wire/Encode/Repeated.hs b/src/Proto3/Wire/Encode/Repeated.hs --- a/src/Proto3/Wire/Encode/Repeated.hs +++ b/src/Proto3/Wire/Encode/Repeated.hs @@ -1,5 +1,5 @@ {- - Copyright 2025 Arista Networks + Copyright 2025-2026 Arista Networks Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -14,172 +14,552 @@ limitations under the License. -} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | Presents right-associative folds as 'Foldable' sequences. module Proto3.Wire.Encode.Repeated - ( Repeated(..) + ( Repeated , nullRepeated - , ToRepeated(..) + , predictRepeated + , foldMapRepeated + , foldMapRepeated' + , foldlRepeated + , foldrRepeated' + , toRepeated , mapRepeated + , mapMaybeRepeated + , mapFoldRepeated + , Reverse(..) + , Count(Count, ..) + , ToRepeated(..) ) where +import Data.Coerce (coerce) 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.List.NonEmpty (NonEmpty) import Data.Map.Lazy qualified +import Data.Monoid (Endo(..)) +import Data.Semigroup (All(..), Dual(..)) 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) +import GHC.Exts (inline, oneShot) +import GHC.Exts qualified (IsList(..)) +import Text.Read (Read(..)) --- | 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. +-- | Expresses a sequence of values for encoding as a repeated field. +-- +-- This type constructor is not 'Foldable' because it would not satisfy +-- the efficiency assumptions of that type class. In particular, it is +-- optimized for left associativity. +data Repeated e + where + MapRepeated :: + forall c a e . + ToRepeated c a => + -- | Maps the elements of the sequence individually. + -- /without/ modifing the number or order of elements. -- - -- 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. + -- In this case 'predictRepeatedSource' remains useful. + (a -> e) -> + -- | The container providing the sequence. + c -> + Repeated e + + BindRepeated :: + forall c a e . + ToRepeated c a => + -- | Maps each element of the sequence to zero or more new + -- elements and concatenates the results by transforming + -- the fold to be passed to 'foldMapRepeatedSource'. -- - -- 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) + -- We cannot make use of 'predictRepeatedSource' in this case. + (forall m . Monoid m => (e -> m) -> a -> m) -> + -- | The container providing the sequence. + c -> + Repeated e -deriving stock instance Eq e => Eq (Repeated e) -deriving stock instance Read e => Read (Repeated e) -deriving stock instance Show e => Show (Repeated e) +instance Functor Repeated + where + fmap f (MapRepeated g xs) = MapRepeated (\x -> f (g x)) xs + fmap f (BindRepeated g xs) = BindRepeated (\j x -> g (\y -> j (f y)) x) xs + {-# INLINE fmap #-} +instance GHC.Exts.IsList (Repeated e) + where + type Item (Repeated e) = e + + fromList xs = MapRepeated id xs + + fromListN n xs = MapRepeated id (UnsafeCount n xs) + + toList (MapRepeated g xs) = appEndo (foldMapRepeatedSource (\x -> Endo (g x :)) xs) [] + toList (BindRepeated g xs) = appEndo (foldMapRepeatedSource (\x -> g (\y -> Endo (y :)) x) xs) [] + +instance Eq e => + Eq (Repeated e) + where + x == y = GHC.Exts.toList x == GHC.Exts.toList y + +instance Read e => + Read (Repeated e) + where + readPrec = fmap GHC.Exts.fromList readListPrec + +instance Show e => + Show (Repeated e) + where + showsPrec _ = showList . GHC.Exts.toList + +-- | Is the given sequence empty? nullRepeated :: Repeated e -> Bool -nullRepeated c = null (reverseRepeated c) +nullRepeated (MapRepeated _ xs) = + case predictRepeatedSource xs of + Just c -> c <= 0 + Nothing -> getAll (getDual (foldMapRepeatedSource (\_ -> Dual (All False)) xs)) +nullRepeated (BindRepeated g xs) = + getAll (getDual (foldMapRepeatedSource (\x -> g (\_ -> Dual (All False)) x) xs)) {-# INLINE nullRepeated #-} +-- | May predict the number of elements in the sequence, but does +-- so only when it is practical to do so accurately and quickly. +-- +-- More specifically, this function delegates to 'predictRepeatedSource' +-- but only when the source sequence has not been filtered by functions +-- such as 'mapMaybeRepeated', and 'predictRepeatedSource' may itself +-- decline to predict the number of elements in the source sequence. +-- +-- For example, it is easy to predict the length of a vector, but +-- we would have to prescan a lazy list to discover its length. +predictRepeated :: ToRepeated c e => c -> Maybe Int +predictRepeated = predictRepeatedSource . toRepeated +{-# INLINE predictRepeated #-} + +-- | Equivalent to a lazy 'foldMap' over the given sequence. +foldMapRepeated :: (ToRepeated c e, Monoid m) => (e -> m) -> c -> m +foldMapRepeated f = foldMapRepeatedSource f . toRepeated +{-# INLINE foldMapRepeated #-} + +-- | Like 'foldMapRepeated', but strictly accumulates from the end of the sequence. +-- +-- Typically you should not use this fold with builders, but it can be +-- used to gather statistics about a sequence, or for other purposes. +foldMapRepeated' :: (ToRepeated c e, Monoid m) => (e -> m) -> c -> m +foldMapRepeated' f = foldrRepeated' (\x acc -> f x <> acc) mempty + -- Curiously, a newtype around the 'Monoid' that strictifies the right operand + -- is insufficient to cause GHC 9.8.2 to pass the accumulator to recursive calls + -- instead of applying '<>' after making the recursive call. It is not clear why. + -- That is why we instead use `foldrRepeated'` here. +{-# INLINE foldMapRepeated' #-} + +-- | A left-associative lazy fold that accumulates from the beginning of the sequence. +-- +-- Typically you should not use this fold with builders, but it can +-- be used to gather information from the end of the sequence, such +-- as the last element having a particular property. +foldlRepeated :: ToRepeated c e => (b -> e -> b) -> b -> c -> b +foldlRepeated f = \z xs -> + getDual (foldMapRepeated (\x -> Dual (Endo (\b -> f b x))) xs) `appEndo` z +{-# INLINE foldlRepeated #-} + +-- | A right-associative strict fold that accumulates from the end of the sequence. +-- +-- Typically you should not use this fold with builders, but it can be +-- used to gather statistics about a sequence, or for other purposes. +foldrRepeated' :: ToRepeated c e => (e -> b -> b) -> b -> c -> b +foldrRepeated' f = \z xs -> + foldMapRepeated (\x -> Endo (oneShot (\b -> b `seq` f x b))) xs `appEndo` z +{-# INLINE foldrRepeated' #-} + +-- | Converts to 'Repeated' from a sequence supporting 'ToRepeated'. +toRepeated :: ToRepeated c e => c -> Repeated e +toRepeated = MapRepeated id +{-# INLINE [1] toRepeated #-} +{-# RULES "toRepeated@Repeated" toRepeated = id #-} + +-- | Maps a function over the elements of a 'Repeated' sequence. +mapRepeated :: ToRepeated c a => (a -> e) -> c -> Repeated e +mapRepeated f = fmap f . toRepeated +{-# INLINE mapRepeated #-} + +-- | Maps and filters a 'Repeated' sequence, with +-- the same semantics as `Data.Maybe.mapMaybe`. +-- +-- Necessarily invalidates any predicted number of elements. +mapMaybeRepeated :: ToRepeated c a => (a -> Maybe e) -> c -> Repeated e +mapMaybeRepeated f = mapFoldRepeated (\j a -> foldMap j (f a)) +{-# INLINE mapMaybeRepeated #-} + +-- | Maps each element of the sequence to zero or more new +-- elements and concatenates the results by transforming +-- the fold to be passed to 'foldMapRepeatedSource'. +-- +-- The semantics are similar to 'foldMap' and 'foldMapRepeated', +-- but in this case the result is another 'Repeated' rather than +-- a final monoidal result. (Though conceptually one can view +-- 'Repeated' as a 'Monoid' under concatenation, in practice +-- we have not yet implemented such an operation.) +-- +-- NOTE: As with 'foldMapRepeatedSource', it is preferred that +-- the fold transformation that you pass to this function allow +-- the fold that is eventually passed in to demand the elements +-- that it expects in /reverse/ order without harming efficiency +-- (because that fold typically creates a reverse builder). +-- +-- For example, the given fold transformer might create a subsequence +-- of new elements from a single element of the original sequence, +-- then use 'foldMapRepeated' on that subsequence in order to present +-- the new elements in reverse order to the extent that is practical. +-- +-- Necessarily invalidates any predicted number of elements. +-- +-- For example, @mapMaybeRepeated f = mapFoldRepeated (\h -> foldMap h . f)@. +mapFoldRepeated :: ToRepeated c a => (forall m . Monoid m => (e -> m) -> a -> m) -> c -> Repeated e +mapFoldRepeated f = \xs -> case toRepeated xs of + MapRepeated g ys -> BindRepeated (\j y -> inline (f (inline j) (inline (g y)))) ys + BindRepeated g ys -> BindRepeated (\j y -> inline (g (inline f (\e -> inline (j e))) y)) ys +{-# INLINE mapFoldRepeated #-} + -- | For each container type, specifies the optimal method for reverse iteration. -type ToRepeated :: forall cr . TYPE cr -> forall er . TYPE er -> Constraint +-- +-- When instantiating this type class for a particular data structure, please also +-- instantiate it for 'Reverse' of that data structure, in the process exploiting +-- any special features that speed iteration in the indicated order. (The exception +-- is the instance for 'Repeated' itself, for which there is no general reversal.) +-- +-- See Also: 'Reverse' class ToRepeated c e | c -> e where - -- | Converts to a reverse iteration over the elements. - toRepeated :: c -> Repeated e + -- | 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, and may + -- cause use of packed format where unpacked format would be smaller. + -- And there may be other, unpredictable effects from incorrect + -- predictions. Therefore if you are in doubt, use 'Nothing'. + predictRepeatedSource :: c -> Maybe Int -instance forall er (e :: TYPE er) . - ToRepeated (Repeated e) e + -- | Performs a lazy 'foldMap' of the given function over the desired + -- sequence of field values, preferably but not necessarily optimized + -- so that demanding the elements in /reverse/ order is efficient + -- (because we encode using a reverse builder). + -- + -- The worst case arises when folding over a list because we must go + -- to the end before we can build the last element, which is the one + -- we must encode first. In this case we build up calling context + -- for the other elements. But allocating a reversed list would be + -- about the same overhead, so there is no point in doing that. But + -- if you can build the original list in reverse order to start with, + -- then you can wrap the list in 'Reverse' to semantically reverse + -- it while iterating in the natural order for a list data structure. + -- + -- With vectors we can semantically reverse the vector and then use + -- 'Dual' within our fold to restore the original order. Thanks to + -- vector fusion rules, the actual effect will be to iterate backward + -- through the existing vector, /not/ to allocate a reversed vector. + foldMapRepeatedSource :: Monoid m => (e -> m) -> c -> m + +instance ToRepeated (Repeated e) e where - toRepeated = id - {-# INLINE toRepeated #-} + predictRepeatedSource (MapRepeated _ ys) = predictRepeatedSource ys + predictRepeatedSource (BindRepeated _ _) = Nothing + {-# INLINE predictRepeatedSource #-} -instance ToRepeated (Identity a) a + foldMapRepeatedSource f (MapRepeated g ys) = foldMapRepeatedSource (\y -> f (g y)) ys + foldMapRepeatedSource f (BindRepeated g ys) = foldMapRepeatedSource (\y -> g f y) ys + {-# INLINE foldMapRepeatedSource #-} + +-- | As viewed through 'ToRepeated', reverses the order of a sequence. But +-- this conceptual reversal cannot alter its performance characteristics. +-- +-- For example, conceptually reversing @"CBA"@ is functionally +-- equivalent to using @"ABC"@ as-is, but performs better with reverse +-- builders because @\'C\'@ is the most accessible element of @"CBA"@. +-- +-- We intentionally avoid defining a general instance of +-- @'ToRepeated' (Reverse c) e@ in terms of @'ToRepeated' c e@ +-- because different data structures provide different options +-- for iterating in a particular order. In particular, vectors +-- allow fast iteration in either order but we need to know that +-- they are vectors in order to exploit those features. +newtype Reverse c = Reverse c + +-- | As viewed through 'ToRepeated', predicts the number of elements in a sequence, +-- replacing the behavior of 'predictRepeatedSource' for the underlying sequence. +-- +-- For example, if you happen to know the length of a list specifying the elements +-- of a repeated field of fixed-width type, you can improve encoder performance by +-- providing that information to the encoder by means of this wrapper. +-- +-- 'Count' should be the outer wrapper if 'Reverse' is also used. That way +-- the generic instance of 'ToRepeated' for 'Counter' can apply, regardless +-- of the more specific instance for 'Reverse' of a specific sequence type. +data Count c = UnsafeCount Int c + -- ^ This data constructor is unsafe because it /ASSUMES/ the element count is accurate. + -- See 'predictRepeatedSource' for what can happen if this count is incorrect. + +{-# COMPLETE Count #-} + +pattern Count :: Int -> c -> Count c +pattern Count n c <- UnsafeCount n c + +instance ToRepeated c e => + ToRepeated (Count c) e where - toRepeated x = ReverseRepeated (Just 1) (FoldR (\f z -> f (runIdentity x) z)) - {-# INLINE toRepeated #-} + predictRepeatedSource = \(Count n _) -> Just n + {-# INLINE predictRepeatedSource #-} -instance ToRepeated [a] a + foldMapRepeatedSource = \f (Count _ xs) -> foldMapRepeatedSource f xs + {-# INLINE foldMapRepeatedSource #-} + +-- | Presents the elements of a list in order. +-- +-- Note that @'Reverse' [e]@ performs better, but +-- requires you to build the list in reverse order. +instance ToRepeated [e] e 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 #-} + predictRepeatedSource = \_ -> Nothing + {-# INLINE predictRepeatedSource #-} -instance ToRepeated (Data.List.NonEmpty.NonEmpty a) a + foldMapRepeatedSource = foldMap + -- Reads to the end of the list before presenting the last element, + -- but we think that explicitly reversing the list would be slower. + {-# INLINE foldMapRepeatedSource #-} + +-- | Presents the elements of a list in /reverse/ order. +-- +-- Performs better than plain @[e]@, but requires +-- that you to build the list in reverse order. +instance ToRepeated (Reverse [e]) e 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 #-} + predictRepeatedSource = \_ -> Nothing + {-# INLINE predictRepeatedSource #-} + foldMapRepeatedSource = \f (Reverse xs) -> getDual (foldMap (\x -> Dual (f x)) xs) + {-# INLINE foldMapRepeatedSource #-} + +instance ToRepeated (NonEmpty e) e + where + predictRepeatedSource = \_ -> Nothing + {-# INLINE predictRepeatedSource #-} + + foldMapRepeatedSource = foldMap + -- Reads to the end of the list before presenting the last element, + -- but we think that explicitly reversing the list would be slower. + {-# INLINE foldMapRepeatedSource #-} + +instance ToRepeated (Reverse (NonEmpty e)) e + where + predictRepeatedSource = \_ -> Nothing + {-# INLINE predictRepeatedSource #-} + + foldMapRepeatedSource = \f (Reverse xs) -> getDual (foldMap (\x -> Dual (f x)) xs) + {-# INLINE foldMapRepeatedSource #-} + +instance ToRepeated (Identity a) a + where + predictRepeatedSource = \_ -> Just 1 + {-# INLINE predictRepeatedSource #-} + + foldMapRepeatedSource = coerce + {-# INLINE foldMapRepeatedSource #-} + +instance ToRepeated (Reverse (Identity a)) a + where + predictRepeatedSource = \_ -> Just 1 + {-# INLINE predictRepeatedSource #-} + + foldMapRepeatedSource = coerce + {-# INLINE foldMapRepeatedSource #-} + 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 #-} + predictRepeatedSource = Just . Data.Vector.length + {-# INLINE predictRepeatedSource #-} + foldMapRepeatedSource = + \f xs -> getDual (Data.Vector.foldMap (Dual . f) (Data.Vector.reverse xs)) + -- Vector fusion should convert this to reverse iteration. + {-# INLINE foldMapRepeatedSource #-} + +instance ToRepeated (Reverse (Data.Vector.Vector a)) a + where + predictRepeatedSource = \(Reverse xs) -> Just (Data.Vector.length xs) + {-# INLINE predictRepeatedSource #-} + + foldMapRepeatedSource = \f (Reverse xs) -> getDual (Data.Vector.foldMap (\x -> Dual (f x)) xs) + {-# INLINE foldMapRepeatedSource #-} + 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 #-} + predictRepeatedSource = Just . Data.Vector.Storable.length + {-# INLINE predictRepeatedSource #-} + foldMapRepeatedSource = \f xs -> + getDual (Data.Vector.Storable.foldMap (\x -> Dual (f x)) (Data.Vector.Storable.reverse xs)) + -- Vector fusion should convert this to reverse iteration. + {-# INLINE foldMapRepeatedSource #-} + +instance Storable a => + ToRepeated (Reverse (Data.Vector.Storable.Vector a)) a + where + predictRepeatedSource = \(Reverse xs) -> Just (Data.Vector.Storable.length xs) + {-# INLINE predictRepeatedSource #-} + + foldMapRepeatedSource = \f (Reverse xs) -> + getDual (Data.Vector.Storable.foldMap (\x -> Dual (f x)) xs) + {-# INLINE foldMapRepeatedSource #-} + 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 #-} + predictRepeatedSource = Just . Data.Vector.Unboxed.length + {-# INLINE predictRepeatedSource #-} + foldMapRepeatedSource = \f xs -> + getDual (Data.Vector.Unboxed.foldMap (\x -> Dual (f x)) (Data.Vector.Unboxed.reverse xs)) + -- Vector fusion should convert this to reverse iteration. + {-# INLINE foldMapRepeatedSource #-} + +instance Data.Vector.Unboxed.Unbox a => + ToRepeated (Reverse (Data.Vector.Unboxed.Vector a)) a + where + predictRepeatedSource = \(Reverse xs) -> Just (Data.Vector.Unboxed.length xs) + {-# INLINE predictRepeatedSource #-} + + foldMapRepeatedSource = \f (Reverse xs) -> + getDual (Data.Vector.Unboxed.foldMap (\x -> Dual (f x)) xs) + {-# INLINE foldMapRepeatedSource #-} + 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 #-} + predictRepeatedSource = Just . Data.Sequence.length + {-# INLINE predictRepeatedSource #-} + foldMapRepeatedSource = foldMap + -- Should present the last element without having to read through the whole sequence, + -- though we may have to descend to the bottom of the tree. + {-# INLINE foldMapRepeatedSource #-} + +instance ToRepeated (Reverse (Data.Sequence.Seq a)) a + where + predictRepeatedSource = \(Reverse xs) -> Just (Data.Sequence.length xs) + {-# INLINE predictRepeatedSource #-} + + foldMapRepeatedSource = \f (Reverse xs) -> getDual (foldMap (\x -> Dual (f x)) xs) + -- Should present the first element without having to read through the whole sequence, + -- though we may have to descend to the bottom of the tree. + {-# INLINE foldMapRepeatedSource #-} + 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 #-} + predictRepeatedSource = Just . Data.Set.size + {-# INLINE predictRepeatedSource #-} -instance ToRepeated Data.IntSet.IntSet Int + foldMapRepeatedSource = foldMap + -- Should present the last element without having to read through the whole sequence, + -- though we may have to descend to the bottom of the tree. + {-# INLINE foldMapRepeatedSource #-} + +instance ToRepeated (Reverse (Data.Set.Set a)) a 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 #-} + predictRepeatedSource = \(Reverse xs) -> Just (Data.Set.size xs) + {-# INLINE predictRepeatedSource #-} + foldMapRepeatedSource = \f (Reverse xs) -> getDual (foldMap (\x -> Dual (f x)) xs) + -- Should present the first element without having to read through the whole sequence, + -- though we may have to descend to the bottom of the tree. + {-# INLINE foldMapRepeatedSource #-} + +instance ToRepeated Data.IntSet.IntSet Data.IntSet.Key + where + predictRepeatedSource = \_ -> Nothing + {-# INLINE predictRepeatedSource #-} + + foldMapRepeatedSource = +#if MIN_VERSION_containers(0,8,0) + Data.IntSet.foldMap +#else + \f xs -> Data.IntSet.foldl (\a x -> a <> f x) mempty xs +#endif + -- Should present the last element without having to read through the whole sequence, + -- though we may have to descend to the bottom of the tree. + {-# INLINE foldMapRepeatedSource #-} + +instance ToRepeated (Reverse Data.IntSet.IntSet) Data.IntSet.Key + where + predictRepeatedSource = \_ -> Nothing + {-# INLINE predictRepeatedSource #-} + + foldMapRepeatedSource = +#if MIN_VERSION_containers(0,8,0) + \f (Reverse xs) -> getDual (Data.IntSet.foldMap (\x -> Dual (f x)) xs +#else + \f (Reverse xs) -> Data.IntSet.foldr (\x a -> a <> f x) mempty xs +#endif + -- Should present the first element without having to read through the whole sequence, + -- though we may have to descend to the bottom of the tree. + {-# INLINE foldMapRepeatedSource #-} + 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 #-} + predictRepeatedSource = Just . Data.Map.Lazy.size + {-# INLINE predictRepeatedSource #-} -instance ToRepeated (Data.IntMap.Lazy.IntMap a) (Int, a) + foldMapRepeatedSource = \f -> Data.Map.Lazy.foldMapWithKey (\k v -> f (k, v)) + -- Should present the last key-value pair without having to read through the whole map, + -- though we may have to descend to the bottom of the tree. + {-# INLINE foldMapRepeatedSource #-} + +instance ToRepeated (Reverse (Data.Map.Lazy.Map k a)) (k, 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 #-} + predictRepeatedSource = \(Reverse xs) -> Just (Data.Map.Lazy.size xs) + {-# INLINE predictRepeatedSource #-} --- | 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 #-} + foldMapRepeatedSource = \f (Reverse xs) -> + getDual (Data.Map.Lazy.foldMapWithKey (\k v -> Dual (f (k, v))) xs) + -- Should present the first key-value pair without having to read through the whole map, + -- though we may have to descend to the bottom of the tree. + {-# INLINE foldMapRepeatedSource #-} + +instance ToRepeated (Data.IntMap.Lazy.IntMap a) (Data.IntMap.Lazy.Key, a) + where + predictRepeatedSource = \_ -> Nothing + {-# INLINE predictRepeatedSource #-} + + foldMapRepeatedSource = \f -> Data.IntMap.Lazy.foldMapWithKey (\k v -> f (k, v)) + -- Should present the last key-value pair without having to read through the whole map, + -- though we may have to descend to the bottom of the tree. + {-# INLINE foldMapRepeatedSource #-} + +instance ToRepeated (Reverse (Data.IntMap.Lazy.IntMap a)) (Data.IntMap.Lazy.Key, a) + where + predictRepeatedSource = \_ -> Nothing + {-# INLINE predictRepeatedSource #-} + + foldMapRepeatedSource = \f (Reverse xs) -> + getDual (Data.IntMap.Lazy.foldMapWithKey (\k v -> Dual (f (k, v))) xs) + -- Should present the last key-value pair without having to read through the whole map, + -- though we may have to descend to the bottom of the tree. + {-# INLINE foldMapRepeatedSource #-} diff --git a/src/Proto3/Wire/FoldR.hs b/src/Proto3/Wire/FoldR.hs --- a/src/Proto3/Wire/FoldR.hs +++ b/src/Proto3/Wire/FoldR.hs @@ -25,6 +25,7 @@ -- | Presents right-associative folds as 'Foldable' sequences. module Proto3.Wire.FoldR + {-# DEPRECATED "This module is no longer used by the rest of the proto3-wire package." #-} ( FoldR(..) , fromFoldR ) where 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 @@ -1,5 +1,5 @@ {- - Copyright 2020 Awake Networks + Copyright 2020-2026 Awake Networks Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -28,6 +28,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} module Proto3.Wire.Reverse ( -- * `BuildR` type @@ -105,13 +107,14 @@ import Data.Vector.Generic ( Vector ) import Data.Word ( Word8, Word16, Word32, Word64 ) import Foreign ( castPtr, copyBytes ) -import GHC.Exts ( Addr#, Int(..), Int# ) +import GHC.Exts ( Addr#, Int(..), Int#, Proxy#, proxy# ) #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 GHC.TypeLits ( KnownNat, natVal' ) +import Proto3.Wire.Encode.Repeated ( ToRepeated, foldMapRepeated, + predictRepeated, toRepeated ) import Proto3.Wire.Reverse.Internal import qualified Proto3.Wire.Reverse.Prim as Prim @@ -871,7 +874,7 @@ -- -- See also: 'repeatedFixedPrimR', 'vectorBuildR' repeatedBuildR :: ToRepeated c BuildR => c -> BuildR -repeatedBuildR = etaBuildR (foldr (flip (<>)) mempty . reverseRepeated . toRepeated) +repeatedBuildR = etaBuildR (foldMapRepeated id) {-# INLINE repeatedBuildR #-} -- | Concatenates the given fixed-width primitives, iterating right to left where practical @@ -883,12 +886,13 @@ -- [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 +repeatedFixedPrimR :: forall c w . (ToRepeated c (Prim.FixedPrim w), KnownNat w) => c -> BuildR +repeatedFixedPrimR = etaBuildR $ \(toRepeated -> xs) -> case predictRepeated xs of + Nothing -> + foldMapRepeated (Prim.liftBoundedPrim . Prim.liftFixedPrim) xs + Just c -> + let w = fromInteger (natVal' (proxy# :: Proxy# w)) + in ensure (w * c) (foldMapRepeated (Prim.unsafeBuildBoundedPrim . Prim.liftFixedPrim) xs) {-# INLINE repeatedFixedPrimR #-} -- | Exported for testing purposes only. diff --git a/src/Proto3/Wire/Reverse/Internal.hs b/src/Proto3/Wire/Reverse/Internal.hs --- a/src/Proto3/Wire/Reverse/Internal.hs +++ b/src/Proto3/Wire/Reverse/Internal.hs @@ -1,5 +1,5 @@ {- - Copyright 2020 Awake Networks + Copyright 2020-2026 Awake Networks Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -19,17 +19,34 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ViewPatterns #-} module Proto3.Wire.Reverse.Internal - ( BuildR (..) + ( BuildM (BuildM) + , buildMToBuildR# + , buildRToBuildM# + , buildMToBuildR + , buildRToBuildM + , BuildR (BuildR) , BuildRState (..) , appendBuildR , foldlRVector + , toBuildM + , fromBuildM , toBuildR , fromBuildR , etaBuildR + , runBuildM , runBuildR , SealedState (SealedState, sealedSB, totalSB, stateVarSB, statePtrSB, recycledSB) , sealBuffer @@ -40,7 +57,9 @@ , writeSpace , metaDataSize , metaDataAlign + , readUnused , withUnused + , readUsed , withTotal , readTotal , withLengthOf @@ -56,6 +75,9 @@ , doubleToWord64 ) where +#if !MIN_VERSION_base(4,18,0) +import Control.Applicative ( Applicative(..) ) +#endif import Control.Exception ( bracket ) import Control.Monad.Trans.State.Strict ( State, runState, state ) import qualified Data.ByteString as B @@ -63,8 +85,10 @@ 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.Coerce ( coerce ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import Data.Kind ( Type ) import qualified Data.Primitive as P import qualified Data.Vector.Generic as VG import Data.Vector.Generic ( Vector ) @@ -76,8 +100,8 @@ deRefStablePtr ) import GHC.Exts ( Addr#, Int#, MutVar#, RealWorld, StablePtr#, State#, - addrToAny#, int2Addr#, - touch# ) + TYPE, addrToAny#, int2Addr#, + oneShot, touch# ) import GHC.ForeignPtr ( ForeignPtr(..), ForeignPtrContents(..) ) import GHC.IO ( IO(..) ) @@ -97,6 +121,90 @@ -- $setup -- >>> :set -XOverloadedStrings +-- | Like 'BuildR' but provides a way for builders to +-- return values monadically, not just emit octets. +#if defined(__GLASGOW_HASKELL__) && 904 <= __GLASGOW_HASKELL__ +type BuildM :: forall {ar} . TYPE ar -> Type +#else +type BuildM :: forall ar . TYPE ar -> Type +#endif +newtype BuildM a + -- | If you directly use this constructor, without also using 'oneShot', + -- then the compiler may allocate a function object on the heap. That + -- is almost never desirable, because a 'B.ByteString' holding output + -- of a builder tends to be a better way of memoizing an octet sequence. + -- Use the pattern synonym @BuildM@ instead. + = MemoBuildM (Addr# -> Int# -> State# RealWorld -> (# a, Addr#, Int#, State# RealWorld #)) + -- It seems we cannot preserve register allocation between the arguments + -- and the returned components, even though we place the monadic return + -- where it might sometimes replace the implicit closure argument (when + -- its runtime representation uses one pointer register). + -- + -- 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 components of + -- the builder state between registers in many cases. In this scenario, + -- @a -> b -> 'BuildR'@ and 'BuildR' could 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. + -- + -- Fortunately inlining erases this concern, and even where it + -- does not, register movements often 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. + deriving stock (Functor) + +{-# COMPLETE BuildM #-} + +-- ^ The arguments to the builder function 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). +-- +-- The components of the returned unboxed tuple are the same, except +-- for the addition of the monadic return as the final component. +pattern BuildM :: +#if defined(__GLASGOW_HASKELL__) && 904 <= __GLASGOW_HASKELL__ + forall {ar} (a :: TYPE ar) . +#else + forall ar (a :: TYPE ar) . +#endif + (Addr# -> Int# -> State# RealWorld -> (# a, Addr#, Int#, State# RealWorld #)) -> + BuildM a +pattern BuildM f <- MemoBuildM f + where + BuildM f = MemoBuildM (oneShot (\v -> oneShot (\u -> oneShot (\s -> f v u s)))) + +instance Applicative BuildM + where + pure a = BuildM (\v u s -> (# a, v, u, s #)) + + BuildM f <*> BuildM x = BuildM + ( \v0 u0 s0 -> case f v0 u0 s0 of + (# g, v1, u1, s1 #) -> case x v1 u1 s1 of + (# y, v2, u2, s2 #) -> (# g y, v2, u2, s2 #) + ) + + liftA2 f (BuildM x) (BuildM y) = BuildM + ( \v0 u0 s0 -> case x v0 u0 s0 of + (# w, v1, u1, s1 #) -> case y v1 u1 s1 of + (# z, v2, u2, s2 #) -> (# f w z, v2, u2, s2 #) + ) + +instance Monad BuildM + where + BuildM x >>= k = BuildM + ( \v0 u0 s0 -> case x v0 u0 s0 of + (# w, v1, u1, s1 #) -> let BuildM g = k w in g v1 u1 s1 + ) + -- | Writes bytes in reverse order, updating the current state. -- -- It is the responsibility of the execution context and buffer @@ -109,33 +217,92 @@ -- 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 +-- or `Proto3.Wire.Encode.Repeated.foldMapRepeated` instead of 'foldMap'. +newtype BuildR = BuildRFromBuildM (BuildM (# #)) + +{-# COMPLETE BuildR #-} + +-- | Converts a 'BuildM (# #)' into the equivalent 'BuildR' (currently without cost). +buildMToBuildR# :: BuildM (# #) -> BuildR +buildMToBuildR# = coerce + +-- | Converts a 'BuildR' into the equivalent 'BuildM (# #)' (currently without cost). +buildRToBuildM# :: BuildR -> BuildM (# #) +buildRToBuildM# = coerce + +-- | Like 'buildMToBuildR#' but uses a lifted unit type. +-- +-- Ignores any distinction between terminating and non-terminating unit values. +buildMToBuildR :: BuildM () -> BuildR +buildMToBuildR = coerce + ( ( \f -> oneShot + (\v0 -> oneShot + (\u0 -> oneShot + (\s0 -> case f v0 u0 s0 of + (# _ :: (), v1, u1, s1 #) -> (# (# #), v1, u1, s1 #) + ) + ) + ) + ) + :: (Addr# -> Int# -> State# RealWorld -> (# (), Addr#, Int#, State# RealWorld #)) -> + (Addr# -> Int# -> State# RealWorld -> (# (# #), Addr#, Int#, State# RealWorld #)) + ) + +-- | Like 'buildRToBuildM#' but uses a lifted unit type. +-- +-- The returned unit value is always terminating. +buildRToBuildM :: BuildR -> BuildM () +buildRToBuildM = coerce + ( ( \f -> oneShot + (\v0 -> oneShot + (\u0 -> oneShot + (\s0 -> case f v0 u0 s0 of + (# (# #), v1, u1, s1 #) -> (# (), v1, u1, s1 #) + ) + ) + ) + ) + :: (Addr# -> Int# -> State# RealWorld -> (# (# #), Addr#, Int#, State# RealWorld #)) -> + (Addr# -> Int# -> State# RealWorld -> (# (), Addr#, Int#, State# RealWorld #)) + ) + +-- | This pattern synonym uses 'oneShot' as described in the comments for 'MemoBuildM'. +pattern BuildR :: + (Addr# -> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)) -> + BuildR +pattern BuildR f <- (eliminateBuildR -> f) + where + BuildR f = introduceBuildR f + +introduceBuildR :: + (Addr# -> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)) -> + BuildR +introduceBuildR = coerce + ( \(f :: (Addr# -> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #))) -> oneShot + (\v0 -> oneShot + (\u0 -> oneShot + (\s0 -> case f v0 u0 s0 of + (# v1, u1, s1 #) -> (# (# #), v1, u1, s1 #) + ) + ) + ) + ) +{-# INLINE introduceBuildR #-} + +eliminateBuildR :: + 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. +eliminateBuildR = coerce + ( \(f :: (Addr# -> Int# -> State# RealWorld -> (# (# #), Addr#, Int#, State# RealWorld #))) -> oneShot + (\v0 -> oneShot + (\u0 -> oneShot + (\s0 -> case f v0 u0 s0 of + (# (# #), v1, u1, s1 #) -> (# v1, u1, s1 #) + ) + ) + ) + ) +{-# INLINE eliminateBuildR #-} instance Semigroup BuildR where @@ -180,6 +347,16 @@ -- allocated, and instead we directly stream elements from right to left. {-# INLINE foldlRVector #-} +toBuildM :: (Ptr Word8 -> Int -> IO (Ptr Word8, Int, a)) -> BuildM a +toBuildM f = + BuildM $ \v0 u0 s0 -> + let IO g = f (Ptr v0) (I# u0) in + case g s0 of (# s1, (Ptr v1, I# u1, a) #) -> (# a, v1, u1, s1 #) + +fromBuildM :: BuildM a -> (Ptr Word8 -> Int -> IO (Ptr Word8, Int, a)) +fromBuildM (BuildM f) (Ptr v0) (I# u0) = + IO $ \s0 -> case f v0 u0 s0 of (# a, v1, u1, s1 #) -> (# s1, (Ptr v1, I# u1, a) #) + toBuildR :: (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR toBuildR f = BuildR $ \v0 u0 s0 -> @@ -298,7 +475,8 @@ writeSpace :: Ptr MetaData -> Int -> IO () writeSpace m = pokeByteOff m spaceOffset --- | The arguments are the same as the 'BuildR' arguments. +-- | Reads the total bytes used across all buffers. +-- 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 @@ -480,8 +658,25 @@ else finish (B.copy untrimmed) (Just buffer) -- | Like `Proto3.Wire.Reverse.toLazyByteString` but also +-- reports the monadic return and the total length of the lazy +-- 'BL.ByteString', which is computed as a side effect of encoding. +-- +-- See also 'runBuildR'. +runBuildM :: BuildM a -> (Int, BL.ByteString, a) +runBuildM 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, a) <- fromBuildM f v0 u0 + SealedState { sealedSB = bytes, totalSB = total } <- sealBuffer v1 u1 + pure (total, bytes, a) + +-- | 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. +-- +-- See also 'runBuildM'. runBuildR :: BuildR -> (Int, BL.ByteString) runBuildR f = unsafePerformIO $ do stateVar <- newIORef undefined -- undefined only until 'newBuffer' @@ -492,10 +687,20 @@ SealedState { sealedSB = bytes, totalSB = total } <- sealBuffer v1 u1 pure (total, bytes) +-- | Reads the number of unused bytes in the current buffer. +-- Note that reallocation provides more unused bytes. +readUnused :: BuildM Int +readUnused = BuildM (\v u s -> (# I# u, v, u, s #)) + -- | First reads the number of unused bytes in the current buffer. +-- Note that reallocation provides more unused bytes. withUnused :: (Int -> BuildR) -> BuildR withUnused f = toBuildR $ \v u -> fromBuildR (f u) v u +-- | Reads the total bytes used across all buffers. +readUsed :: BuildM Int +readUsed = toBuildM (\v u -> (v, u, ) <$> readTotal v u) + -- | First reads the number of bytes previously written. withTotal :: (Int -> BuildR) -> BuildR withTotal f = withTotal# (\total -> f (I# total)) @@ -695,10 +900,12 @@ 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 +ensure# required (BuildR f) = BuildR $ \v0 u0 s0 -> + let BuildR g + | I# required <= I# u0 = mempty + | otherwise = reallocate# required + in case g v0 u0 s0 of + (# v1, u1, s1 #) -> f v1 u1 s1 -- | 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, 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 @@ -1,5 +1,5 @@ {- - Copyright 2020 Awake Networks + Copyright 2020-2026 Awake Networks Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -20,10 +20,12 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -111,7 +113,7 @@ import Foreign ( Storable(..) ) import GHC.Exts ( Addr#, Int#, Proxy#, RealWorld, State#, (+#), - and#, inline, or#, + and#, inline, oneShot, or#, plusAddr#, plusWord#, proxy#, uncheckedShiftRL# ) import GHC.IO ( IO(..) ) @@ -151,7 +153,7 @@ -- | Are we restricted to aligned writes only? data StoreMethod = StoreAligned | StoreUnaligned - deriving (Eq, Show) + deriving stock (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 @@ -167,7 +169,7 @@ data ByteOrder = BigEndian -- ^ Most significant byte first. | LittleEndian -- ^ Least significant byte first. - deriving (Eq, Show) + deriving stock (Eq, Show) -- | The 'ByteOrder' native to the current architecture. -- @@ -304,11 +306,23 @@ -- -- (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 #) - ) +newtype FixedPrim (w :: Nat) = + -- | If you directly use this constructor, without also using 'oneShot', + -- then the compiler may allocate a function object on the heap. That + -- is almost never desirable, especially for primitive combinators. + MemoFixedPrim (Addr# -> Int# -> State# RealWorld -> Int# -> (# Addr#, Int#, State# RealWorld #)) +{-# COMPLETE FixedPrim #-} + +-- | This pattern synonym uses 'oneShot' as described in the comments for 'FixedPrim'. +pattern FixedPrim :: + (Addr# -> Int# -> State# RealWorld -> Int# -> (# Addr#, Int#, State# RealWorld #)) -> + FixedPrim w +pattern FixedPrim f <- MemoFixedPrim f + where + FixedPrim f = MemoFixedPrim + (oneShot (\v -> oneShot (\u -> oneShot (\s -> oneShot (\o -> f v u s o))))) + type role FixedPrim nominal type instance PNullary FixedPrim width = FixedPrim width @@ -343,12 +357,13 @@ -- | 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 #-} +liftFixedPrim = \(FixedPrim f) -> + let !(I# o) = - fromInteger (natVal' (proxy# :: Proxy# w)) + g = \v0 u0 s0 -> case f v0 u0 s0 o of + (# v1, u1, s1 #) -> (# plusAddr# v1 o, u1 +# o, s1 #) + {-# INLINE g #-} + in + BoundedPrim (BuildR g) {-# INLINE CONLIKE [1] liftFixedPrim #-} {-# RULES @@ -404,11 +419,11 @@ -- | 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 = +primPoke !x = FixedPrim + ( \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 @@ -584,24 +599,24 @@ -- | 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 +floatBE !x = FixedPrim + ( \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 +floatLE !x = FixedPrim + ( \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. @@ -617,24 +632,24 @@ -- | 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 +doubleBE !x = FixedPrim + ( \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 +doubleLE !x = FixedPrim + ( \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. @@ -872,3 +887,5 @@ where w = fromInteger (natVal' (proxy# :: Proxy# w)) {-# INLINE unsafeReverseFoldMapFixedPrim #-} +{-# DEPRECATED unsafeReverseFoldMapFixedPrim + "This function is no longer used by the rest of the proto3-wire package." #-} diff --git a/src/Proto3/Wire/Types.hs b/src/Proto3/Wire/Types.hs --- a/src/Proto3/Wire/Types.hs +++ b/src/Proto3/Wire/Types.hs @@ -1,10 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- - Copyright 2016 Awake Networks + Copyright 2016-2026 Awake Networks Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -44,7 +45,8 @@ -- left to other, higher-level libraries. newtype FieldNumber = FieldNumber { getFieldNumber :: Word64 } - deriving (Bounded, Data, Enum, Eq, Generic, Hashable, Lift, NFData, Num, Ord) + deriving stock (Data, Generic, Lift) + deriving newtype (Bounded, Enum, Eq, Hashable, NFData, Num, Ord) instance Show FieldNumber where show (FieldNumber n) = show n @@ -64,4 +66,4 @@ | Fixed32 | Fixed64 | LengthDelimited - deriving (Bounded, Data, Enum, Eq, Generic, Lift, Ord, Show) + deriving stock (Bounded, Data, Enum, Eq, Generic, Lift, Ord, Show) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,5 +1,5 @@ {- - Copyright 2016 Awake Networks + Copyright 2016-2026 Awake Networks Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -14,11 +14,17 @@ limitations under the License. -} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-warnings-deprecations #-} @@ -34,13 +40,13 @@ import qualified Data.ByteString.Short as BS import qualified Data.ByteString.Builder.Internal as BBI import Data.Either ( isLeft ) -import Data.Foldable ( toList ) +import Data.Foldable 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.Maybe ( fromMaybe, mapMaybe ) import Data.List ( sort ) import qualified Data.List.NonEmpty as NE import Data.Proxy ( Proxy(..) ) @@ -52,17 +58,23 @@ 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 Data.Word ( Word8, Word16, Word32, Word64 ) import Foreign ( sizeOf ) import qualified GHC.Exts +import Text.Read ( readEither ) 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 Proto3.Wire.Encode as Encode +import Proto3.Wire.Encode.Repeated + ( Count(..), Repeated, Reverse(..), ToRepeated(..), + foldMapRepeated, foldMapRepeated', foldlRepeated, + foldrRepeated', mapFoldRepeated, mapMaybeRepeated, + mapRepeated, nullRepeated, predictRepeated, toRepeated ) +import qualified Proto3.Wire.Reverse as Reverse +import qualified Proto3.Wire.Reverse.Internal as Reverse +import Proto3.Wire.Types ( WireType(..) ) import qualified Test.DocTest import Test.QuickCheck ( (===), Arbitrary ) @@ -84,7 +96,8 @@ defaultMain tests tests :: TestTree -tests = testGroup "Tests" [ roundTripTests +tests = testGroup "Tests" [ buildMTests + , roundTripTests , buildSingleChunk , buildRBufferSizes , strictByteString @@ -96,8 +109,68 @@ , toRepeatedTests ] +buildMTests :: TestTree +buildMTests = testGroup "BuildM tests" + [ QC.testProperty "buildRToBuildM" $ + QC.forAll QC.arbitrary $ \x -> + Reverse.runBuildM (Reverse.buildRToBuildM (Reverse.word8 x)) === (1, BL.singleton x, ()) + , QC.testProperty "buildMToBuildR" $ + QC.forAll QC.arbitrary $ \x -> + Reverse.runBuildR (Reverse.buildMToBuildR (Reverse.buildRToBuildM (Reverse.word8 x))) + === (1, BL.singleton x) + , QC.testProperty "Applicative BuildM" $ + QC.forAll QC.arbitrary $ \x -> + QC.forAll QC.arbitrary $ \y -> + let w8 = Reverse.buildRToBuildM . Reverse.word8 + pureB = pure x + applyB = ((y -) <$ w8 y) <*> (x <$ w8 x) + in + Reverse.runBuildM pureB === (0, mempty, x) QC..&&. + Reverse.runBuildM applyB === (2, BL.pack [x, y], y - x) + , QC.testProperty "Monad BuildM" $ + QC.forAll QC.arbitrary $ \x -> + QC.forAll QC.arbitrary $ \y -> + let w8 = Reverse.buildRToBuildM . Reverse.word8 + bindB = (y <$ w8 y) >>= \z -> (z - x) <$ w8 x + in + Reverse.runBuildM bindB === (2, BL.pack [x, y], y - x) + , QC.testProperty "toBuildM . fromBuildM" $ + QC.forAll QC.arbitrary $ \x -> + let builder :: Reverse.BuildM Word16 + builder = Reverse.toBuildM . Reverse.fromBuildM $ + (x + 5) <$ Reverse.buildRToBuildM (Reverse.word16BE x) + in + Reverse.runBuildM builder === + (2, BL.pack [fromIntegral (x `quot` 256), fromIntegral (x `rem` 256)], x + 5) + , QC.testProperty "readUsed" $ + QC.forAll QC.arbitrary $ \x -> + QC.forAll QC.arbitrary $ \y -> + let w8 = Reverse.buildRToBuildM . Reverse.word8 + builder = do + w8 y + u <- Reverse.readUsed + w8 x + v <- Reverse.readUsed + pure (u, v) + in + Reverse.runBuildM builder === (2, BL.pack [x, y], (1, 2)) + , QC.testProperty "readUnused" $ + QC.forAll QC.arbitrary $ \x -> + QC.forAll QC.arbitrary $ \y -> + let w8 = Reverse.buildRToBuildM . Reverse.word8 + builder = do + w8 y + u <- Reverse.readUnused + w8 x + v <- Reverse.readUnused + pure (u, v) + in + Reverse.runBuildM builder + === (2, BL.pack [x, y], (Reverse.smallChunkSize - 1, Reverse.smallChunkSize - 2)) + ] + data StringOrInt64 = TString T.Text | TInt64 Int64 - deriving (Show,Eq) + deriving stock (Eq, Show) instance QC.Arbitrary StringOrInt64 where arbitrary = QC.oneof [ TString . T.pack <$> QC.arbitrary, TInt64 <$> QC.arbitrary ] @@ -181,7 +254,15 @@ 0 `at` fieldNumber 1)) `at` fieldNumber 1) - , roundTrip "embeddedListPackedVarints" + , roundTrip "embeddedIfNonempty" + (Encode.embeddedIfNonempty (fieldNumber 1) . + Encode.int32 (fieldNumber 2)) + (fmap (fromMaybe 0) + (Decode.embedded (one Decode.int32 + 0 `at` + fieldNumber 2)) + `at` fieldNumber 1) + , roundTrip "embeddedListPackedVarints - Function" (Encode.embedded (fieldNumber 1) . Encode.packedVarints (fieldNumber 1)) (fmap (fromMaybe [0,1,2,3,4]) @@ -189,38 +270,111 @@ `at` fieldNumber 1)) `at` fieldNumber 1) - , roundTrip "embeddedListPackedFixed32" + , roundTrip "embeddedListPackedVarints - Method Word64" (Encode.embedded (fieldNumber 1) . + Encode.packedField @'Varint @[Word64] (fieldNumber 2)) + (fmap (fromMaybe [0,1,2,3,4]) + (Decode.embedded (one Decode.packedVarints [] + `at` + fieldNumber 2)) + `at` fieldNumber 1) + , roundTrip "embeddedListPackedVarints - Method Word32" + (Encode.embedded (fieldNumber 1) . + Encode.packedField @'Varint @[Word32] (fieldNumber 2)) + (fmap (fromMaybe [0,1,2,3,4]) + (Decode.embedded (one Decode.packedVarints [] + `at` + fieldNumber 2)) + `at` fieldNumber 1) + , roundTrip "embeddedListPackedVarints - Method Word16" + (Encode.embedded (fieldNumber 1) . + Encode.packedField @'Varint @[Word16] (fieldNumber 2)) + (fmap (fromMaybe [0,1,2,3,4]) + (Decode.embedded (one Decode.packedVarints [] + `at` + fieldNumber 2)) + `at` fieldNumber 1) + , roundTrip "embeddedListPackedVarints - Method Word8" + (Encode.embedded (fieldNumber 1) . + Encode.packedField @'Varint @[Word8] (fieldNumber 2)) + (fmap (fromMaybe [0,1,2,3,4]) + (Decode.embedded (one Decode.packedVarints [] + `at` + fieldNumber 2)) + `at` fieldNumber 1) + , roundTrip "embeddedListPackedVarints - Method Bool" + (Encode.embedded (fieldNumber 1) . + Encode.packedField @'Varint @[Bool] (fieldNumber 2)) + (fmap (fromMaybe [False,True,False,True,False]) + (fmap (map ((0 :: Int32) /=)) <$> + Decode.embedded (one Decode.packedVarints [] + `at` + fieldNumber 2)) + `at` fieldNumber 1) + , roundTrip "embeddedListPackedFixed32 - Function" + (Encode.embedded (fieldNumber 1) . Encode.packedFixed32 (fieldNumber 1)) (fmap (fromMaybe [0,1,2,3,4]) (Decode.embedded (one Decode.packedFixed32 [] `at` fieldNumber 1)) `at` fieldNumber 1) - , roundTrip "embeddedListPackedFixed64" + , roundTrip "embeddedListPackedFixed32 - Method Word32" (Encode.embedded (fieldNumber 1) . + Encode.packedField @'Fixed32 @[Word32] (fieldNumber 2)) + (fmap (fromMaybe [0,1,2,3,4]) + (Decode.embedded (one Decode.packedFixed32 [] + `at` + fieldNumber 2)) + `at` fieldNumber 1) + , roundTrip "embeddedListPackedFixed64 - Function" + (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" + , roundTrip "embeddedListPackedFixed64 - Method Word64" (Encode.embedded (fieldNumber 1) . + Encode.packedField @'Fixed64 @[Word64] (fieldNumber 2)) + (fmap (fromMaybe [0,1,2,3,4]) + (Decode.embedded (one Decode.packedFixed64 [] + `at` + fieldNumber 2)) + `at` fieldNumber 1) + , roundTrip "embeddedListPackedFloats - Function" + (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" + , roundTrip "embeddedListPackedFloats - Method Float" (Encode.embedded (fieldNumber 1) . + Encode.packedField @'Fixed32 @[Float] (fieldNumber 2)) + (fmap (fromMaybe [0,1,2,3,4]) + (Decode.embedded (one Decode.packedFloats [] + `at` + fieldNumber 2)) + `at` fieldNumber 1) + , roundTrip "embeddedListPackedDoubles - Function" + (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 "embeddedListPackedDoubles - Method Double" + (Encode.embedded (fieldNumber 1) . + Encode.packedField @'Fixed64 @[Double] (fieldNumber 2)) + (fmap (fromMaybe [0,1,2,3,4]) + (Decode.embedded (one Decode.packedDoubles [] + `at` + fieldNumber 2)) + `at` fieldNumber 1) , roundTrip "embeddedListUnpacked" (Encode.embedded (fieldNumber 1) . (foldMap . Encode.int32) (fieldNumber 1)) @@ -278,7 +432,7 @@ \x -> let bytes = Encode.toLazyByteString (encode x) in case Decode.parse decode (BL.toStrict bytes) of - Left _ -> error "Could not decode encoded message" + Left e -> error $ "Could not decode encoded message: " ++ show e Right x' -> x === x' genManyOctets :: QC.Gen [Word8] @@ -801,12 +955,27 @@ (BL.toStrict encoded) HU.assertEqual "round trip" (Right [2 .. count + 1]) decoded -data ExpectedCountPrediction c = NoCP | CorrectCP | SameCP (c -> Maybe Int) +data ExpectedCountPrediction c = NoCP | CorrectCP toRepeatedTests :: TestTree toRepeatedTests = testGroup "ToRepeated" - [ test_nullRepeated - , test_ToRepeated (SameCP countRepeated) genRepeated (reverse . toList . reverseRepeated) + [ test_genRepeated + , test_Eq_Repeated + , test_Show_Repeated + , test_Read_Repeated + , test_IsList_Repeated + , test_Functor_Repeated + , test_nullRepeated + , test_predictRepeated + , test_foldMapRepeated + , test_foldMapRepeated' + , test_foldlRepeated + , test_foldrRepeated' + , test_toRepeated + , test_mapRepeated + , test_mapMaybeRepeated + , test_mapFoldRepeated + , test_ToRepeated_Repeated , 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) @@ -818,55 +987,340 @@ , 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) + , test_RULES_toRepeated_Repeated ] + +data TestSequenceNE e = LeafSequenceNE e | NodeSequenceNE (TestSequenceNE e) (TestSequenceNE e) + +data TestSequence e = TestSequence (Maybe Int) (Maybe (TestSequenceNE e)) + +instance ToRepeated (TestSequence e) e 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 - } + predictRepeatedSource (TestSequence maybeCount _) = maybeCount + {-# INLINE predictRepeatedSource #-} - test_nullRepeated :: TestTree - test_nullRepeated = - QC.testProperty "nullRepeated" $ - QC.forAll genRepeated $ \c -> - nullRepeated c === null (reverseRepeated c) + foldMapRepeatedSource _ (TestSequence _ Nothing) = mempty + foldMapRepeatedSource f (TestSequence _ (Just xs)) = go xs + where + go (LeafSequenceNE x) = f x + go (NodeSequenceNE l r) = go l <> go r + {-# INLINE foldMapRepeatedSource #-} - 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 +instance ToRepeated (Reverse (TestSequence e)) e + where + predictRepeatedSource (Reverse (TestSequence maybeCount _)) = maybeCount + {-# INLINE predictRepeatedSource #-} - prediction :: Maybe Int - reversed :: FoldR e - ReverseRepeated prediction reversed = toRepeated c + foldMapRepeatedSource _ (Reverse (TestSequence _ Nothing)) = mempty + foldMapRepeatedSource f (Reverse (TestSequence _ (Just xs))) = go xs + where + go (LeafSequenceNE x) = f x + go (NodeSequenceNE l r) = go r <> go l + {-# INLINE foldMapRepeatedSource #-} + +toNonEmptyTestSequenceNE :: TestSequenceNE e -> NE.NonEmpty e +toNonEmptyTestSequenceNE = \case + LeafSequenceNE x -> x NE.:| [] + NodeSequenceNE l r -> toNonEmptyTestSequenceNE l <> toNonEmptyTestSequenceNE r + +-- NOTE: Does not preserve order, nor does it need to preserve +-- order because we use it only during random generation. +splitAndReorderTestSequenceNE :: NE.NonEmpty e -> QC.Gen (TestSequenceNE e) +splitAndReorderTestSequenceNE (x NE.:| []) = pure (LeafSequenceNE x) +splitAndReorderTestSequenceNE (y NE.:| z : xs) = do + index <- QC.choose (0, length xs) + let (ys, zs) = splitAt index xs + NodeSequenceNE + <$> splitAndReorderTestSequenceNE (y NE.:| ys) + <*> splitAndReorderTestSequenceNE (z NE.:| zs) + +toListTestSequence :: Maybe (TestSequenceNE e) -> [e] +toListTestSequence = maybe [] (NE.toList . toNonEmptyTestSequenceNE) + +splitAndReorderTestSequence :: [e] -> QC.Gen (Maybe (TestSequenceNE e)) +splitAndReorderTestSequence [] = pure Nothing +splitAndReorderTestSequence (x : xs) = Just <$> splitAndReorderTestSequenceNE (x NE.:| xs) + +genTestSequence :: QC.Arbitrary e => QC.Gen (TestSequence e) +genTestSequence = do + xs <- QC.arbitrary + ys <- splitAndReorderTestSequence xs + predict <- QC.arbitrary + pure $ TestSequence (if predict then (Just (length (toListTestSequence ys))) else Nothing) ys + +-- | Generates a list of words and a 'Repeated' containing those same words in the same +-- order, sometimes with a length prediction and sometimes without a length prediction. +-- Also reports any count prediction that we expect to be made by the generated 'Repeated'. +genRepeated :: QC.Gen (Maybe Int, [Word8], Repeated Word8) +genRepeated = do + (xs :: TestSequence Int8) <- genTestSequence + let TestSequence maybeCount (toListTestSequence -> ys) = xs + oddFactor <- (1 Bits..|.) <$> QC.arbitrary + f <- QC.frequency + [ (2, pure (Left ((oddFactor *) . fromIntegral))) + , (1, pure (Right (\(fromIntegral -> x) -> if mod x 3 == 0 then [] else [oddFactor * x]))) + , (1, pure (Right (\(fromIntegral -> x) -> if mod x 3 == 1 then [] else [oddFactor * x, x]))) + ] + pure $ case f of + Left g -> (maybeCount, map g ys, mapRepeated g xs) + Right g -> (Nothing, concatMap g ys, mapFoldRepeated (\j -> foldMap j . g) xs) + +-- | Performs basic validation of a value of type 'Repeated' against +-- the information it is expected to contain. While these checks +-- are sometimes redundant with the checks made by particular tests, +-- it is probably better to check redundantly than to omit a check, +-- and the extra time required for these particular checks is tiny. +validateRepeated :: (Eq e, Show e) => Maybe Int -> [e] -> Repeated e -> QC.Property +validateRepeated expectedMaybeCount expectedElements xr = + foldMapRepeatedSource (: []) xr === expectedElements + QC..&&. + predictRepeated xr === expectedMaybeCount + QC..&&. + case expectedMaybeCount of + Nothing -> QC.property True + Just n -> n === length expectedElements + +-- NOTE: This test verifies the test infrastructure against itself. +-- It is not intended to check the code under test. +test_genRepeated :: TestTree +test_genRepeated = + QC.testProperty "genRepeated" $ + QC.forAll genRepeated $ \(xc, xs, xr) -> + validateRepeated xc xs xr + +test_Eq_Repeated :: TestTree +test_Eq_Repeated = + QC.testProperty "Eq (Repeated Word8)" $ + QC.forAll genRepeated $ \(_, xs, xr) -> + QC.forAll genRepeated $ \(_, ys, yr) -> + (xr == yr) === (xs == ys) + +test_Show_Repeated :: TestTree +test_Show_Repeated = + QC.testProperty "Show (Repeated Word8)" $ + QC.forAll genRepeated $ \(_, xs, xr) -> + QC.forAll (QC.choose (0, 12)) $ \d -> + showsPrec d xr "xyz" === showsPrec d xs "xyz" + +test_Read_Repeated :: TestTree +test_Read_Repeated = + QC.testProperty "Read (Repeated Word8)" $ + QC.forAll genRepeated $ \(_, xs, xr) -> + readEither (show xs) === Right xr -- can consume expected form + QC..&&. + readEither (show xr) === Right xr -- round trip with 'show' + +test_IsList_Repeated :: TestTree +test_IsList_Repeated = + QC.testProperty "IsList (Repeated Word8)" $ + QC.forAll genRepeated $ \(_, xs, xr) -> + QC.counterexample "GHC.Exts.toList" + (GHC.Exts.toList xr === xs) + QC..&&. + QC.counterexample "GHC.Exts.fromList" + ( let xr' = GHC.Exts.fromList xs in - QC.counterexample "correctly reversed elements" (toList reversed === reverse es) + validateRepeated Nothing xs xr' QC..&&. - QC.counterexample "correct count prediction if any" - (all @Maybe (== length es) prediction) + xr' === xr 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) + predictRepeated xr' === Nothing + ) + QC..&&. + QC.counterexample "GHC.Exts.fromListN" + ( let n = length xs + xr' = GHC.Exts.fromListN n xs + in + validateRepeated (Just n) xs xr' + QC..&&. + xr' === xr + QC..&&. + predictRepeated xr' === Just n + ) + +test_Functor_Repeated :: TestTree +test_Functor_Repeated = + QC.testProperty "Functor Repeated" $ + QC.forAll genRepeated $ \(xc, xs, xr) -> + QC.forAll QC.arbitrary $ \pivot -> + GHC.Exts.toList (fmap (pivot -) xr) === map (pivot -) xs + QC..&&. + predictRepeated (fmap (pivot -) xr) === xc + +test_nullRepeated :: TestTree +test_nullRepeated = + QC.testProperty "nullRepeated" $ + QC.forAll genRepeated $ \(_, xs, xr) -> + nullRepeated xr === null xs + +test_predictRepeated :: TestTree +test_predictRepeated = + QC.testProperty "predictRepeated" $ + QC.forAll genRepeated $ \(xc, xs, xr) -> + QC.forAll QC.arbitrary $ \pivot -> + QC.forAll QC.arbitrary $ \probablyIncorrectCount -> + let f y = pivot - y + g y + | even y = Nothing + | otherwise = Just (pivot - y) + in + predictRepeated (mapRepeated f xr) === xc + QC..&&. + predictRepeated (mapMaybeRepeated g xr) === Nothing + QC..&&. + predictRepeated (UnsafeCount probablyIncorrectCount xs) === Just probablyIncorrectCount + +test_foldMapRepeated :: TestTree +test_foldMapRepeated = + QC.testProperty "foldMapRepeated" $ + QC.forAll genRepeated $ \(_, xs, xr) -> + QC.forAll QC.arbitrary $ \pivot -> + let f y = [pivot - y] + in + GHC.Exts.toList (foldMapRepeated f xr) === foldMap f xs + +-- NOTE: Does not currently attempt to test strictness. +test_foldMapRepeated' :: TestTree +test_foldMapRepeated' = + QC.testProperty "foldMapRepeated'" $ + QC.forAll genRepeated $ \(_, xs, xr) -> + QC.forAll QC.arbitrary $ \pivot -> + let f y = [pivot - y] + in + GHC.Exts.toList (foldMapRepeated' f xr) === foldMap' f xs + +test_foldlRepeated :: TestTree +test_foldlRepeated = + QC.testProperty "foldlRepeated" $ + QC.forAll genRepeated $ \(_, xs, xr) -> + QC.forAll QC.arbitrary $ \pivot -> + let f a y = pivot - y : a + in + GHC.Exts.toList (foldlRepeated f [] xr) === foldl f [] xs + +-- NOTE: Does not currently attempt to test strictness. +test_foldrRepeated' :: TestTree +test_foldrRepeated' = + QC.testProperty "foldrRepeated'" $ + QC.forAll genRepeated $ \(_, xs, xr) -> + QC.forAll QC.arbitrary $ \pivot -> + let f y a = pivot - y : a + in + GHC.Exts.toList (foldrRepeated' f [] xr) === foldr' f [] xs + +test_toRepeated :: TestTree +test_toRepeated = + QC.testProperty "toRepeated" $ + QC.forAll genRepeated $ \(xc, xs, xr) -> + GHC.Exts.toList (toRepeated xr) === xs + QC..&&. + predictRepeated (toRepeated xr) === xc + +test_mapRepeated :: TestTree +test_mapRepeated = + QC.testProperty "mapRepeated" $ + QC.forAll genRepeated $ \(xc, xs, xr) -> + QC.forAll QC.arbitrary $ \pivot -> + GHC.Exts.toList (mapRepeated (pivot -) xr) === map (pivot -) xs + QC..&&. + predictRepeated (mapRepeated (pivot -) xr) === xc + +test_mapMaybeRepeated :: TestTree +test_mapMaybeRepeated = + QC.testProperty "mapMaybeRepeated" $ + QC.forAll genRepeated $ \(_, xs, xr) -> + QC.forAll QC.arbitrary $ \pivot -> + let f y + | even y = Nothing + | otherwise = Just (pivot - y) + in + GHC.Exts.toList (mapMaybeRepeated f xr) === mapMaybe f xs + QC..&&. + predictRepeated (mapMaybeRepeated f xr) === Nothing + QC..&&. + -- Verify a related identity from the documentation for 'mapFoldRepeated': + mapMaybeRepeated f xr === mapFoldRepeated (\h -> foldMap h . f) xr + +test_mapFoldRepeated :: TestTree +test_mapFoldRepeated = + QC.testProperty "mapFoldRepeated" $ + QC.forAll genRepeated $ \(_, xs, xr) -> + QC.forAll QC.arbitrary $ \pivot -> + let f y = case mod y 3 of + 0 -> [pivot - y] + 1 -> [pivot - y, y] + _ -> [] + g j y = foldMap j (f y) + in + GHC.Exts.toList (mapFoldRepeated g xr) === concatMap f xs + QC..&&. + predictRepeated (mapFoldRepeated g xr) === Nothing + +test_ToRepeated_Repeated :: TestTree +test_ToRepeated_Repeated = + QC.testProperty "ToRepeated (Repeated Word8) Word8" $ + QC.forAll genRepeated $ \(xc, xs, xr) -> + validateRepeated xc xs xr + QC..&&. + QC.counterexample "correctly ordered elements" (foldMapRepeated (: []) xr === xs) + QC..&&. + QC.counterexample "expected count prediction" (predictRepeated xr === xc) + +test_ToRepeated :: + forall c e . + ( ToRepeated c e + , ToRepeated (Reverse c) e + , Show c + , Typeable c + , Typeable e + , Eq e + , Ord e + , Show e + ) => + ExpectedCountPrediction c -> + (QC.Gen c) -> + (c -> [e]) -> + TestTree +test_ToRepeated expectedCP gen cToList = + let cRep = typeRep (Proxy :: Proxy c) + eRep = typeRep (Proxy :: Proxy e) + testName = showString "ToRepeated " $ showsTypeRep cRep $ showChar ' ' $ showsTypeRep eRep "" + in QC.testProperty testName $ + QC.forAll gen $ \(c :: c) -> + let xs :: [e] + xs = cToList c + xr, rr :: Repeated e + xr = toRepeated c + rr = toRepeated (Reverse c) + expectedMaybeCount :: Maybe Int + expectedMaybeCount = case expectedCP of + NoCP -> Nothing + CorrectCP -> Just (length xs) + in + QC.counterexample "correctly ordered elements" (foldMapRepeated (: []) c === xs) + QC..&&. + QC.counterexample "correct count prediction if any" + (all @Maybe (== length xs) (predictRepeated xr)) + QC..&&. + QC.counterexample "expected count prediction" (predictRepeated xr === expectedMaybeCount) + QC..&&. + QC.counterexample "valid result from toRepeated" (validateRepeated expectedMaybeCount xs xr) + QC..&&. + QC.counterexample "correctly reversed elements" (foldMapRepeated (: []) rr === reverse xs) + QC..&&. + QC.counterexample "same count prediction when reversed" + (predictRepeated rr === predictRepeated xr) + QC..&&. + QC.counterexample "valid result from reverseRepeated" + (validateRepeated expectedMaybeCount (reverse xs) rr) + +test_RULES_toRepeated_Repeated :: TestTree +test_RULES_toRepeated_Repeated = + QC.testProperty "RULES toRepeated@Repeated" $ + QC.forAll genRepeated $ \(_, _, xr :: Repeated Word8) -> + toRepeated xr === toRepeated_NOINLINE xr + +-- | @NOINLINE@ and still polymorphic in order to avoid triggering rewrite rules. +toRepeated_NOINLINE :: ToRepeated c e => c -> Repeated e +toRepeated_NOINLINE = toRepeated +{-# NOINLINE toRepeated_NOINLINE #-}