protobuf 0.2.0.4 → 0.2.1.4
raw patch · 12 files changed
Files
- CHANGELOG +9/−2
- bench/Bench.hs +46/−0
- protobuf.cabal +31/−4
- src/Data/Binary/Builder/Sized.hs +56/−0
- src/Data/ProtocolBuffers.hs +14/−10
- src/Data/ProtocolBuffers/Decode.hs +10/−10
- src/Data/ProtocolBuffers/Encode.hs +16/−17
- src/Data/ProtocolBuffers/Message.hs +10/−10
- src/Data/ProtocolBuffers/Orphans.hs +2/−9
- src/Data/ProtocolBuffers/Types.hs +16/−12
- src/Data/ProtocolBuffers/Wire.hs +83/−70
- tests/Main.hs +82/−26
CHANGELOG view
@@ -1,8 +1,15 @@+0.3.0.0:+ - Fix #19: Improve performance by using binary+ - Fix #4: Suspicious amount of time and allocation on decode path++0.2.1.0:+ - Fix #17: Repeated n (Enumeration a) difficulty+ 0.2.0.4:- - Fix #13 "Getting the error "Always is not a Monoid"+ - Fix #13: Getting the error "Always is not a Monoid 0.2.0.3:- - Fix #11 "Missing optional enum in incoming message causes decodeMessage to fail"+ - Fix #11: Missing optional enum in incoming message causes decodeMessage to fail 0.2.0.2: - Export {get,put}Varint* from Data.ProtocolBuffers.Internal
+ bench/Bench.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Criterion.Main+import Data+import Nested++main :: IO ()+main = defaultMain [+ bgroup "burst" [+ bgroup "encoding" [+ bench "1" $ nf enc (burst 1),+ bench "10" $ nf enc (burst 10),+ bench "100" $ nf enc (burst 100),+ bench "1000" $ nf enc (burst 1000)+ ],+ bgroup "decoding" [+ bench "1" $ nf decBurst (encodeBurst 1),+ bench "10" $ nf decBurst (encodeBurst 10),+ bench "100" $ nf decBurst (encodeBurst 100),+ bench "1000" $ nf decBurst (encodeBurst 1000)+ ]+ ],+ bgroup "nested" [+ bgroup "encoding" [+ bench "a1" $ nf enc (nested 1 1),+ bench "a10" $ nf enc (nested 1 10),+ bench "a100" $ nf enc (nested 1 100),+ bench "a1000" $ nf enc (nested 1 1000),+ bench "b10" $ nf enc (nested 10 1),+ bench "b100" $ nf enc (nested 100 1),+ bench "b1000" $ nf enc (nested 1000 1)+ ],+ bgroup "decoding" [+ bench "a1" $ nf decNested (enc $ nested 1 1),+ bench "a10" $ nf decNested (enc $ nested 1 10),+ bench "a100" $ nf decNested (enc $ nested 1 100),+ bench "a1000" $ nf decNested (enc $ nested 1 1000),+ bench "b10" $ nf decNested (enc $ nested 10 1),+ bench "b100" $ nf decNested (enc $ nested 100 1),+ bench "b1000" $ nf decNested (enc $ nested 1000 1)+ ]+ ]+ ]
protobuf.cabal view
@@ -1,5 +1,5 @@ name: protobuf-version: 0.2.0.4+version: 0.2.1.4 synopsis: Google Protocol Buffers via GHC.Generics description: Google Protocol Buffers via GHC.Generics.@@ -37,6 +37,7 @@ Data.ProtocolBuffers Data.ProtocolBuffers.Internal Data.ProtocolBuffers.Orphans+ Data.Binary.Builder.Sized other-modules: Data.ProtocolBuffers.Decode Data.ProtocolBuffers.Encode@@ -46,14 +47,16 @@ Data.ProtocolBuffers.Wire build-depends: base >= 4.7 && < 5,+ base-orphans >= 0.5, bytestring >= 0.9,- cereal >= 0.3,+ binary >= 0.7, data-binary-ieee754 >= 0.4, deepseq >= 1.1, mtl == 2.*, -- pretty, text >= 0.10,- unordered-containers >= 0.2+ unordered-containers >= 0.2,+ semigroups >= 0.18 ghc-options: -Wall @@ -89,7 +92,7 @@ build-depends: base >= 4.7 && < 5, bytestring,- cereal,+ binary, containers, hex, mtl,@@ -102,6 +105,30 @@ tasty-quickcheck, HUnit >= 1.2, QuickCheck >= 2.4+++benchmark bench+ default-language:+ Haskell2010+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ bench+ main-is:+ Bench.hs+ build-depends:+ base,+ criterion,+ deepseq,+ bytestring,+ binary,+ containers,+ hex,+ mtl,+ protobuf,+ tagged,+ text,+ unordered-containers source-repository head type: git
+ src/Data/Binary/Builder/Sized.hs view
@@ -0,0 +1,56 @@+module Data.Binary.Builder.Sized where++import qualified Data.ByteString.Builder as B+import Data.Monoid (mempty, mappend, Monoid)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString as BS+import Data.Semigroup (Semigroup, (<>))+import qualified Data.Word as W++data Builder = Builder {-# UNPACK #-} !Int B.Builder++instance Semigroup Builder where+ Builder i b <> Builder i' b' = Builder (i + i') (mappend b b')++instance Monoid Builder where+ mempty = Builder 0 mempty+ mappend = (<>)++toLazyByteString :: Builder -> LBS.ByteString+toLazyByteString (Builder _ b) = B.toLazyByteString b++size :: Builder -> Int+size (Builder i _) = i++empty :: Builder+empty = mempty++singleton :: W.Word8 -> Builder+singleton = Builder 1 . B.word8++append :: Builder -> Builder -> Builder+append = mappend++fromByteString :: BS.ByteString -> Builder+fromByteString s = Builder (BS.length s) $ B.byteString s++fromLazyByteString :: LBS.ByteString -> Builder+fromLazyByteString s = Builder (fromIntegral $ LBS.length s) $ B.lazyByteString s++putWord16be :: W.Word16 -> Builder+putWord16be = Builder 2 . B.word16BE++putWord32be :: W.Word32 -> Builder+putWord32be = Builder 4 . B.word32BE++putWord64be :: W.Word64 -> Builder+putWord64be = Builder 8 . B.word64BE++putWord16le :: W.Word16 -> Builder+putWord16le = Builder 2 . B.word16LE++putWord32le :: W.Word32 -> Builder+putWord32le = Builder 4 . B.word32LE++putWord64le :: W.Word64 -> Builder+putWord64le = Builder 8 . B.word64LE
src/Data/ProtocolBuffers.hs view
@@ -6,26 +6,30 @@ -- and Google's reference implementation can be found at <http://code.google.com/p/protobuf/>. -- -- It is intended to be used via "GHC.Generics" and does not require @ .proto @ files to function.--- Tools are being developed that will convert a Haskell Protobuf definition into a @ .proto @ and vise versa.+-- Tools are being developed that will convert a Haskell Protobuf definition into a @ .proto @ and vice versa. -- -- Given a message definition: -- -- @ --{-\# LANGUAGE DeriveGeneric \#-}+--{-\# LANGUAGE DataKinds \#-} ----- import "Data.Int"+--import "Data.Int" --import "Data.ProtocolBuffers" --import "Data.Text" --import "GHC.Generics" ('GHC.Generics.Generic') --import "GHC.TypeLits"+--import "Data.Monoid"+--import "Data.Binary"+--import "Data.Hex" -- cabal install hex (for testing) -- -- data Foo = Foo--- { field1 :: 'Required' '1' ('Value' 'Data.Int.Int64') -- ^ The last field with tag = 1--- , field2 :: 'Optional' '2' ('Value' 'Data.Text.Text') -- ^ The last field with tag = 2--- , field3 :: 'Repeated' '3' ('Value' 'Prelude.Bool') -- ^ All fields with tag = 3, ordering is preserved+-- { field1 :: 'Required' 1 ('Value' 'Data.Int.Int64') -- ^ The last field with tag = 1+-- , field2 :: 'Optional' 2 ('Value' 'Data.Text.Text') -- ^ The last field with tag = 2+-- , field3 :: 'Repeated' 3 ('Value' 'Prelude.Bool') -- ^ All fields with tag = 3, ordering is preserved -- } deriving ('GHC.Generics.Generic', 'Prelude.Show') ----- instance 'Encode' Foo+--instance 'Encode' Foo --instance 'Decode' Foo -- @ --@@ -37,15 +41,15 @@ -- -- >>> let msg = Foo{field1 = putField 42, field2 = mempty, field3 = putField [True, False]} ----- To serialize a message first convert it into a 'Data.Serialize.Put' by way of 'encodeMessage'--- and then to a 'Data.ByteString.ByteString' by using 'Data.Serialize.runPut'. Lazy--- 'Data.ByteString.Lazy.ByteString' serialization is done with 'Data.Serialize.runPutLazy'.+-- To serialize a message first convert it into a 'Data.Binary.Put' by way of 'encodeMessage'+-- and then to a 'Data.ByteString.ByteString' by using 'Data.Binary.runPut'. Lazy+-- 'Data.ByteString.Lazy.ByteString' serialization is done with 'Data.Binary.runPutLazy'. -- -- >>> fmap hex runPut $ encodeMessage msg -- "082A18011800" -- -- Decoding is done with the inverse functions: 'decodeMessage'--- and 'Data.Serialize.runGet', or 'Data.Serialize.runGetLazy'.+-- and 'Data.Binary.runGet'. -- -- >>> runGet decodeMessage =<< unhex "082A18011800" :: Either String Foo -- Right
src/Data/ProtocolBuffers/Decode.hs view
@@ -16,7 +16,6 @@ import Control.Applicative import Control.Monad-import qualified Data.ByteString as B import Data.Foldable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap@@ -24,7 +23,7 @@ import Data.Maybe (fromMaybe) import Data.Monoid import Data.Proxy-import Data.Serialize.Get+import Data.Binary.Get import Data.Traversable (traverse) import GHC.Generics@@ -32,6 +31,7 @@ import Data.ProtocolBuffers.Types import Data.ProtocolBuffers.Wire+import qualified Data.ByteString.Lazy as LBS -- | -- Decode a Protocol Buffers message.@@ -46,17 +46,17 @@ Nothing -> return msg -- |--- Decode a Protocol Buffers message prefixed with a varint encoded 32-bit integer describing it's length.+-- Decode a Protocol Buffers message prefixed with a varint encoded 32-bit integer describing its length. decodeLengthPrefixedMessage :: Decode a => Get a {-# INLINE decodeLengthPrefixedMessage #-} decodeLengthPrefixedMessage = do len :: Int64 <- getVarInt- bs <- getBytes $ fromIntegral len- case runGetState decodeMessage bs 0 of- Right (val, bs')- | B.null bs' -> return val- | otherwise -> fail $ "Unparsed bytes leftover in decodeLengthPrefixedMessage: " ++ show (B.length bs')- Left err -> fail err+ bs <- getByteString $ fromIntegral len+ case runGetOrFail decodeMessage (LBS.fromStrict bs) of+ Right (bs', _, val)+ | LBS.null bs' -> return val+ | otherwise -> fail $ "Unparsed bytes leftover in decodeLengthPrefixedMessage: " ++ show (LBS.length bs')+ Left (_, _, err) -> fail err class Decode (a :: *) where decode :: HashMap Tag [WireField] -> Get a@@ -120,7 +120,7 @@ gdecode msg = fieldDecode Required msg instance (DecodeWire (PackedList a), KnownNat n) => GDecode (K1 i (Packed n a)) where- gdecode msg = fieldDecode PackedField msg+ gdecode msg = fieldDecode PackedField msg <|> pure (K1 mempty) instance GDecode U1 where gdecode _ = return U1
src/Data/ProtocolBuffers/Encode.hs view
@@ -12,12 +12,12 @@ , GEncode ) where -import qualified Data.ByteString as B import Data.Foldable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Proxy-import Data.Serialize.Put+import Data.Binary.Builder.Sized+import Data.Monoid import GHC.Generics import GHC.TypeLits@@ -27,44 +27,43 @@ -- | -- Encode a Protocol Buffers message.-encodeMessage :: Encode a => a -> Put+encodeMessage :: Encode a => a -> Builder encodeMessage = encode -- |--- Encode a Protocol Buffers message prefixed with a varint encoded 32-bit integer describing it's length.-encodeLengthPrefixedMessage :: Encode a => a -> Put+-- Encode a Protocol Buffers message prefixed with a varint encoded 32-bit integer describing its length.+encodeLengthPrefixedMessage :: Encode a => a -> Builder {-# INLINE encodeLengthPrefixedMessage #-}-encodeLengthPrefixedMessage msg = do- let msg' = runPut $ encodeMessage msg- putVarUInt $ B.length msg'- putByteString msg'+encodeLengthPrefixedMessage msg = (putVarUInt $ size msg') <> msg'+ where+ msg' = encodeMessage msg class Encode (a :: *) where- encode :: a -> Put- default encode :: (Generic a, GEncode (Rep a)) => a -> Put+ encode :: a -> Builder+ default encode :: (Generic a, GEncode (Rep a)) => a -> Builder encode = gencode . from -- | Untyped message encoding instance Encode (HashMap Tag [WireField]) where- encode = traverse_ step . HashMap.toList where- step = uncurry (traverse_ . encodeWire)+ encode = foldMap step . HashMap.toList where+ step = uncurry (foldMap . encodeWire) class GEncode (f :: * -> *) where- gencode :: f a -> Put+ gencode :: f a -> Builder instance GEncode a => GEncode (M1 i c a) where gencode = gencode . unM1 instance (GEncode a, GEncode b) => GEncode (a :*: b) where- gencode (x :*: y) = gencode x >> gencode y+ gencode (x :*: y) = gencode x <> gencode y instance (GEncode a, GEncode b) => GEncode (a :+: b) where gencode (L1 x) = gencode x gencode (R1 y) = gencode y instance (EncodeWire a, KnownNat n, Foldable f) => GEncode (K1 i (Field n (f a))) where- gencode = traverse_ (encodeWire tag) . runField . unK1 where+ gencode = foldMap (encodeWire tag) . runField . unK1 where tag = fromIntegral $ natVal (Proxy :: Proxy n) instance GEncode U1 where- gencode _ = return ()+ gencode _ = empty
src/Data/ProtocolBuffers/Message.hs view
@@ -17,10 +17,10 @@ import Control.Applicative import Control.DeepSeq (NFData(..)) import Data.Foldable-import Data.Monoid-import Data.Serialize.Get-import Data.Serialize.Put+import Data.Monoid hiding ((<>))+import Data.Binary.Get import Data.Traversable+import Data.Semigroup (Semigroup(..)) import GHC.Generics import GHC.TypeLits@@ -29,6 +29,7 @@ import Data.ProtocolBuffers.Encode import Data.ProtocolBuffers.Types import Data.ProtocolBuffers.Wire+import qualified Data.ByteString.Lazy as LBS -- | -- The way to embed a message within another message.@@ -96,9 +97,12 @@ newtype Message m = Message {runMessage :: m} deriving (Eq, Foldable, Functor, Ord, Show, Traversable) +instance (Generic m, GMessageMonoid (Rep m)) => Semigroup (Message m) where+ Message x <> Message y = Message . to $ gmappend (from x) (from y)+ instance (Generic m, GMessageMonoid (Rep m)) => Monoid (Message m) where mempty = Message . to $ gmempty- Message x `mappend` Message y = Message . to $ gmappend (from x) (from y)+ mappend = (<>) instance (Decode a, Monoid (Message a), KnownNat n) => GDecode (K1 i (Field n (RequiredField (Always (Message a))))) where gdecode = fieldDecode (Required . Always)@@ -156,14 +160,10 @@ type instance Required n (Message a) = Field n (RequiredField (Always (Message a))) instance (Foldable f, Encode m) => EncodeWire (f (Message m)) where- encodeWire t =- traverse_ (encodeWire t . runPut . encode . runMessage)+ encodeWire t = foldMap (encodeWire t . encode . runMessage) instance Decode m => DecodeWire (Message m) where- decodeWire (DelimitedField _ bs) =- case runGet decodeMessage bs of- Right val -> pure $ Message val- Left err -> fail $ "Embedded message decoding failed: " ++ show err+ decodeWire (DelimitedField _ bs) = pure $ Message $ runGet decodeMessage $ LBS.fromStrict bs decodeWire _ = empty -- | Iso: @ 'FieldType' ('Required' n ('Message' a)) = a @
src/Data/ProtocolBuffers/Orphans.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}- -- | -- Messages containing 'Optional' 'Enumeration' fields fail to encode. -- This module contains orphan instances required to make these functional.@@ -9,9 +5,6 @@ -- For more information reference the associated ticket: -- <https://github.com/alphaHeavy/protobuf/issues/3> -module Data.ProtocolBuffers.Orphans (Foldable) where--import Data.Foldable (Foldable)-import Data.Monoid (Last(..))+module Data.ProtocolBuffers.Orphans () where -deriving instance Foldable Last+import Data.Orphans ()
src/Data/ProtocolBuffers/Types.hs view
@@ -29,7 +29,8 @@ import Control.DeepSeq (NFData) import Data.Bits import Data.Foldable as Fold-import Data.Monoid+import Data.Monoid hiding ((<>))+import Data.Semigroup (Semigroup(..)) import Data.Traversable import Data.Typeable @@ -38,25 +39,25 @@ -- | -- 'Value' selects the normal/typical way for encoding scalar (primitive) values. newtype Value a = Value {runValue :: a}- deriving (Bounded, Eq, Enum, Foldable, Functor, Monoid, Ord, NFData, Show, Traversable, Typeable)+ deriving (Bounded, Eq, Enum, Foldable, Functor, Semigroup, Monoid, Ord, NFData, Show, Traversable, Typeable) -- | -- 'RequiredField' is a newtype wrapped used to break overlapping instances -- for encoding and decoding values newtype RequiredField a = Required {runRequired :: a}- deriving (Bounded, Eq, Enum, Foldable, Functor, Monoid, Ord, NFData, Show, Traversable, Typeable)+ deriving (Bounded, Eq, Enum, Foldable, Functor, Semigroup, Monoid, Ord, NFData, Show, Traversable, Typeable) -- | -- 'OptionalField' is a newtype wrapped used to break overlapping instances -- for encoding and decoding values newtype OptionalField a = Optional {runOptional :: a}- deriving (Bounded, Eq, Enum, Foldable, Functor, Monoid, Ord, NFData, Show, Traversable, Typeable)+ deriving (Bounded, Eq, Enum, Foldable, Functor, Semigroup, Monoid, Ord, NFData, Show, Traversable, Typeable) -- | -- 'RepeatedField' is a newtype wrapped used to break overlapping instances -- for encoding and decoding values newtype RepeatedField a = Repeated {runRepeated :: a}- deriving (Bounded, Eq, Enum, Foldable, Functor, Monoid, Ord, NFData, Show, Traversable, Typeable)+ deriving (Bounded, Eq, Enum, Foldable, Functor, Semigroup, Monoid, Ord, NFData, Show, Traversable, Typeable) -- | -- Fields are merely a way to hold a field tag along with its type, this shouldn't normally be referenced directly.@@ -64,7 +65,7 @@ -- This provides better error messages than older versions which used 'Data.Tagged.Tagged' -- newtype Field (n :: Nat) a = Field {runField :: a}- deriving (Bounded, Eq, Enum, Foldable, Functor, Monoid, Ord, NFData, Show, Traversable, Typeable)+ deriving (Bounded, Eq, Enum, Foldable, Functor, Semigroup, Monoid, Ord, NFData, Show, Traversable, Typeable) -- | -- To provide consistent instances for serialization a 'Traversable' 'Functor' is needed to@@ -74,9 +75,12 @@ newtype Always a = Always {runAlways :: a} deriving (Bounded, Eq, Enum, Foldable, Functor, Ord, NFData, Show, Traversable, Typeable) +instance Semigroup (Always a) where+ _ <> y = y+ instance Monoid (Always a) where mempty = error "Always is not a Monoid"- mappend _ y = y+ mappend = (<>) -- | -- Functions for wrapping and unwrapping record fields.@@ -175,24 +179,24 @@ -- | -- 'Enumeration' fields use 'Prelude.fromEnum' and 'Prelude.toEnum' when encoding and decoding messages. newtype Enumeration a = Enumeration {runEnumeration :: a}- deriving (Bounded, Eq, Enum, Foldable, Functor, Ord, Monoid, NFData, Show, Traversable, Typeable)+ deriving (Bounded, Eq, Enum, Foldable, Functor, Ord, Semigroup, Monoid, NFData, Show, Traversable, Typeable) -- | -- A 'Traversable' 'Functor' used to select packed sequence encoding/decoding. newtype PackedField a = PackedField {runPackedField :: a}- deriving (Eq, Foldable, Functor, Monoid, NFData, Ord, Show, Traversable, Typeable)+ deriving (Eq, Foldable, Functor, Semigroup, Monoid, NFData, Ord, Show, Traversable, Typeable) -- | -- A list that is stored in a packed format. newtype PackedList a = PackedList {unPackedList :: [a]}- deriving (Eq, Foldable, Functor, Monoid, NFData, Ord, Show, Traversable, Typeable)+ deriving (Eq, Foldable, Functor, Semigroup, Monoid, NFData, Ord, Show, Traversable, Typeable) -- | -- Signed integers are stored in a zz-encoded form. newtype Signed a = Signed a- deriving (Bits, Bounded, Enum, Eq, Floating, Foldable, Fractional, Functor, Integral, Monoid, NFData, Num, Ord, Real, RealFloat, RealFrac, Show, Traversable, Typeable)+ deriving (Bits, Bounded, Enum, Eq, Floating, Foldable, Fractional, Functor, Integral, Semigroup, Monoid, NFData, Num, Ord, Real, RealFloat, RealFrac, Show, Traversable, Typeable) -- | -- Fixed integers are stored in little-endian form without additional encoding. newtype Fixed a = Fixed a- deriving (Bits, Bounded, Enum, Eq, Floating, Foldable, Fractional, Functor, Integral, Monoid, NFData, Num, Ord, Real, RealFloat, RealFrac, Show, Traversable, Typeable)+ deriving (Bits, Bounded, Enum, Eq, Floating, Foldable, Fractional, Functor, Integral, Semigroup, Monoid, NFData, Num, Ord, Real, RealFloat, RealFrac, Show, Traversable, Typeable)
src/Data/ProtocolBuffers/Wire.hs view
@@ -29,17 +29,17 @@ import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LBS import Data.Foldable import Data.Int import Data.Monoid-import Data.Serialize.Get-import Data.Serialize.IEEE754-import Data.Serialize.Put+import Data.Binary.Get+import qualified Data.Binary.IEEE754 as F+import Data.Binary.Builder.Sized hiding (empty) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Typeable import Data.Word-import Data.Binary.IEEE754 (wordToDouble, wordToFloat) import Data.ProtocolBuffers.Types @@ -59,11 +59,17 @@ | Fixed32Field {-# UNPACK #-} !Tag {-# UNPACK #-} !Word32 -- ^ For: fixed32, sfixed32, float deriving (Eq, Ord, Show, Typeable) +putFloat32le :: Float -> Builder+putFloat32le = putWord32le . F.floatToWord++putFloat64le :: Double -> Builder+putFloat64le = putWord64le . F.doubleToWord+ getVarintPrefixedBS :: Get ByteString-getVarintPrefixedBS = getBytes =<< getVarInt+getVarintPrefixedBS = getByteString =<< getVarInt -putVarintPrefixedBS :: ByteString -> Put-putVarintPrefixedBS bs = putVarUInt (B.length bs) >> putByteString bs+putVarintPrefixedBS :: ByteString -> Builder+putVarintPrefixedBS bs = putVarUInt (B.length bs) <> fromByteString bs getWireField :: Get WireField getWireField = do@@ -78,19 +84,19 @@ 5 -> Fixed32Field tag <$> getWord32le x -> fail $ "Wire type out of range: " ++ show x -putWireField :: WireField -> Put-putWireField (VarintField t val) = putWireTag t 0 >> putVarUInt val-putWireField (Fixed64Field t val) = putWireTag t 1 >> putWord64le val-putWireField (DelimitedField t val) = putWireTag t 2 >> putVarintPrefixedBS val+putWireField :: WireField -> Builder+putWireField (VarintField t val) = putWireTag t 0 <> putVarUInt val+putWireField (Fixed64Field t val) = putWireTag t 1 <> putWord64le val+putWireField (DelimitedField t val) = putWireTag t 2 <> putVarintPrefixedBS val putWireField (StartField t ) = putWireTag t 3 putWireField (EndField t ) = putWireTag t 4-putWireField (Fixed32Field t val) = putWireTag t 5 >> putWord32le val+putWireField (Fixed32Field t val) = putWireTag t 5 <> putWord32le val -putWireTag :: Tag -> Word32 -> Put+putWireTag :: Tag -> Word32 -> Builder putWireTag tag typ | tag <= 0x1FFFFFFF, typ <= 7 = putVarUInt $ tag `shiftL` 3 .|. (typ .&. 7)- | tag > 0x1FFFFFFF = fail $ "Wire tag out of range: " ++ show tag- | otherwise = fail $ "Wire type out of range: " ++ show typ+ | tag > 0x1FFFFFFF = error $ "Wire tag out of range: " ++ show tag+ | otherwise = error $ "Wire type out of range: " ++ show typ getVarInt :: (Integral a, Bits a) => Get a getVarInt = go 0 0 where@@ -103,26 +109,26 @@ -- | This can be used on any Integral type and is needed for signed types; unsigned can use putVarUInt below. -- This has been changed to handle only up to 64 bit integral values (to match documentation). {-# INLINE putVarSInt #-}-putVarSInt :: (Integral a, Bits a) => a -> Put+putVarSInt :: (Integral a, Bits a) => a -> Builder putVarSInt bIn = case compare bIn 0 of LT -> let -- upcast to 64 bit to match documentation of 10 bytes for all negative values b = fromIntegral bIn len = 10 -- (pred 10)*7 < 64 <= 10*7 last'Mask = 1 -- pred (1 `shiftL` 1)- go :: Int64 -> Int -> Put- go !i 1 = putWord8 (fromIntegral (i .&. last'Mask))- go !i n = putWord8 (fromIntegral (i .&. 0x7F) .|. 0x80) >> go (i `shiftR` 7) (pred n)+ go :: Int64 -> Int -> Builder+ go !i 1 = singleton (fromIntegral (i .&. last'Mask))+ go !i n = singleton (fromIntegral (i .&. 0x7F) .|. 0x80) <> go (i `shiftR` 7) (pred n) in go b len- EQ -> putWord8 0+ EQ -> singleton 0 GT -> putVarUInt bIn -- | This should be used on unsigned Integral types only (not checked) {-# INLINE putVarUInt #-}-putVarUInt :: (Integral a, Bits a) => a -> Put+putVarUInt :: (Integral a, Bits a) => a -> Builder putVarUInt i- | i < 0x80 = putWord8 (fromIntegral i)- | otherwise = putWord8 (fromIntegral (i .&. 0x7F) .|. 0x80) >> putVarUInt (i `shiftR` 7)+ | i < 0x80 = singleton (fromIntegral i)+ | otherwise = singleton (fromIntegral (i .&. 0x7F) .|. 0x80) <> putVarUInt (i `shiftR` 7) wireFieldTag :: WireField -> Tag wireFieldTag f = case f of@@ -134,7 +140,7 @@ Fixed32Field t _ -> t class EncodeWire a where- encodeWire :: Tag -> a -> Put+ encodeWire :: Tag -> a -> Builder class DecodeWire a where decodeWire :: WireField -> Get a@@ -146,121 +152,127 @@ deriving instance DecodeWire a => DecodeWire (Last (Value a)) instance EncodeWire a => EncodeWire [Value a] where- encodeWire t = traverse_ (encodeWire t)+ encodeWire t = foldMap (encodeWire t) instance EncodeWire WireField where encodeWire t f | t == wireFieldTag f = putWireField f- | otherwise = fail "Specified tag and field tag do not match"+ | otherwise = error "Specified tag and field tag do not match" instance DecodeWire WireField where decodeWire = pure instance EncodeWire a => EncodeWire (Value a) where- encodeWire t = traverse_ (encodeWire t)+ encodeWire t = foldMap (encodeWire t) instance DecodeWire a => DecodeWire (Value a) where decodeWire = fmap Value . decodeWire instance EncodeWire a => EncodeWire (Maybe (Value a)) where- encodeWire t = traverse_ (encodeWire t)+ encodeWire t = foldMap (encodeWire t) instance DecodeWire a => DecodeWire (Maybe (Value a)) where decodeWire = fmap (Just . Value) . decodeWire instance EncodeWire Int32 where- encodeWire t val = putWireTag t 0 >> putVarSInt val+ encodeWire t val = putWireTag t 0 <> putVarSInt val instance DecodeWire Int32 where decodeWire (VarintField _ val) = pure $ fromIntegral val decodeWire _ = empty instance EncodeWire Int64 where- encodeWire t val = putWireTag t 0 >> putVarSInt val+ encodeWire t val = putWireTag t 0 <> putVarSInt val instance DecodeWire Int64 where decodeWire (VarintField _ val) = pure $ fromIntegral val decodeWire _ = empty instance EncodeWire Word32 where- encodeWire t val = putWireTag t 0 >> putVarUInt val+ encodeWire t val = putWireTag t 0 <> putVarUInt val instance DecodeWire Word32 where decodeWire (VarintField _ val) = pure $ fromIntegral val decodeWire _ = empty instance EncodeWire Word64 where- encodeWire t val = putWireTag t 0 >> putVarUInt val+ encodeWire t val = putWireTag t 0 <> putVarUInt val instance DecodeWire Word64 where decodeWire (VarintField _ val) = pure val decodeWire _ = empty instance EncodeWire (Signed Int32) where- encodeWire t (Signed val) = putWireTag t 0 >> putVarSInt (zzEncode32 val)+ encodeWire t (Signed val) = putWireTag t 0 <> putVarSInt (zzEncode32 val) instance DecodeWire (Signed Int32) where decodeWire (VarintField _ val) = pure . Signed . zzDecode32 $ fromIntegral val decodeWire _ = empty instance EncodeWire (Signed Int64) where- encodeWire t (Signed val) = putWireTag t 0 >> putVarSInt (zzEncode64 val)+ encodeWire t (Signed val) = putWireTag t 0 <> putVarSInt (zzEncode64 val) instance DecodeWire (Signed Int64) where decodeWire (VarintField _ val) = pure . Signed . zzDecode64 $ fromIntegral val decodeWire _ = empty instance EncodeWire (Fixed Int32) where- encodeWire t (Fixed val) = putWireTag t 5 >> putWord32le (fromIntegral val)+ encodeWire t (Fixed val) = putWireTag t 5 <> putWord32le (fromIntegral val) instance DecodeWire (Fixed Int32) where decodeWire (Fixed32Field _ val) = pure . Fixed $ fromIntegral val decodeWire _ = empty instance EncodeWire (Fixed Int64) where- encodeWire t (Fixed val) = putWireTag t 1 >> putWord64le (fromIntegral val)+ encodeWire t (Fixed val) = putWireTag t 1 <> putWord64le (fromIntegral val) instance DecodeWire (Fixed Int64) where decodeWire (Fixed64Field _ val) = pure . Fixed $ fromIntegral val decodeWire _ = empty instance EncodeWire (Fixed Word32) where- encodeWire t (Fixed val) = putWireTag t 5 >> putWord32le val+ encodeWire t (Fixed val) = putWireTag t 5 <> putWord32le val instance DecodeWire (Fixed Word32) where decodeWire (Fixed32Field _ val) = pure $ Fixed val decodeWire _ = empty instance EncodeWire (Fixed Word64) where- encodeWire t (Fixed val) = putWireTag t 1 >> putWord64le val+ encodeWire t (Fixed val) = putWireTag t 1 <> putWord64le val instance DecodeWire (Fixed Word64) where decodeWire (Fixed64Field _ val) = pure $ Fixed val decodeWire _ = empty instance EncodeWire Bool where- encodeWire t val = putWireTag t 0 >> putVarUInt (if val then 1 else (0 :: Int32))+ encodeWire t val = putWireTag t 0 <> putVarUInt (if val then 1 else (0 :: Int32)) instance DecodeWire Bool where decodeWire (VarintField _ val) = pure $ val /= 0 decodeWire _ = empty instance EncodeWire Float where- encodeWire t val = putWireTag t 5 >> putFloat32le val+ encodeWire t val = putWireTag t 5 <> putFloat32le val instance DecodeWire Float where- decodeWire (Fixed32Field _ val) = pure $ wordToFloat val+ decodeWire (Fixed32Field _ val) = pure $ F.wordToFloat val decodeWire _ = empty instance EncodeWire Double where- encodeWire t val = putWireTag t 1 >> putFloat64le val+ encodeWire t val = putWireTag t 1 <> putFloat64le val instance DecodeWire Double where- decodeWire (Fixed64Field _ val) = pure $ wordToDouble val+ decodeWire (Fixed64Field _ val) = pure $ F.wordToDouble val decodeWire _ = empty +instance EncodeWire Builder where+ encodeWire t val = putWireTag t 2 <> putVarUInt (size val) <> val++instance EncodeWire LBS.ByteString where+ encodeWire t val = encodeWire t $ fromLazyByteString val+ instance EncodeWire ByteString where- encodeWire t val = putWireTag t 2 >> putVarUInt (B.length val) >> putByteString val+ encodeWire t val = encodeWire t $ fromByteString val instance DecodeWire ByteString where decodeWire (DelimitedField _ bs) = pure bs@@ -284,24 +296,20 @@ decodePackedList :: Get a -> WireField -> Get [a] {-# INLINE decodePackedList #-}-decodePackedList g (DelimitedField _ bs) =- case runGet (many g) bs of- Right val -> return val- Left err -> fail err+decodePackedList g (DelimitedField _ bs) = return $ runGet (many g) (LBS.fromStrict bs) decodePackedList _ _ = empty -- | -- Empty lists are not written out-encodePackedList :: Tag -> Put -> Put+encodePackedList :: Tag -> Builder -> Builder {-# INLINE encodePackedList #-}-encodePackedList t p- | bs <- runPut p- , not (B.null bs) = encodeWire t bs- | otherwise = pure ()+encodePackedList t p = case size p of+ 0 -> mempty+ _ -> encodeWire t p instance EncodeWire (PackedList (Value Int32)) where encodeWire t (PackedList xs) =- encodePackedList t $ traverse_ (putVarSInt . runValue) xs+ encodePackedList t $ foldMap (putVarSInt . runValue) xs instance DecodeWire (PackedList (Value Int32)) where decodeWire x = do@@ -310,7 +318,7 @@ instance EncodeWire (PackedList (Value Int64)) where encodeWire t (PackedList xs) =- encodePackedList t $ traverse_ (putVarSInt . runValue) xs+ encodePackedList t $ foldMap (putVarSInt . runValue) xs instance DecodeWire (PackedList (Value Int64)) where decodeWire x = do@@ -319,7 +327,7 @@ instance EncodeWire (PackedList (Value Word32)) where encodeWire t (PackedList xs) =- encodePackedList t $ traverse_ (putVarUInt . runValue) xs+ encodePackedList t $ foldMap (putVarUInt . runValue) xs instance DecodeWire (PackedList (Value Word32)) where decodeWire x = do@@ -328,7 +336,7 @@ instance EncodeWire (PackedList (Value Word64)) where encodeWire t (PackedList xs) =- encodePackedList t $ traverse_ (putVarUInt . runValue) xs+ encodePackedList t $ foldMap (putVarUInt . runValue) xs instance DecodeWire (PackedList (Value Word64)) where decodeWire x = do@@ -338,7 +346,7 @@ instance EncodeWire (PackedList (Value (Signed Int32))) where encodeWire t (PackedList xs) = do let c (Signed x) = putVarSInt $ zzEncode32 x- encodePackedList t $ traverse_ (c . runValue) xs+ encodePackedList t $ foldMap (c . runValue) xs instance DecodeWire (PackedList (Value (Signed Int32))) where decodeWire x = do@@ -348,7 +356,7 @@ instance EncodeWire (PackedList (Value (Signed Int64))) where encodeWire t (PackedList xs) = do let c (Signed x) = putVarSInt $ zzEncode64 x- encodePackedList t $ traverse_ (c . runValue) xs+ encodePackedList t $ foldMap (c . runValue) xs instance DecodeWire (PackedList (Value (Signed Int64))) where decodeWire x = do@@ -358,7 +366,7 @@ instance EncodeWire (PackedList (Value (Fixed Word32))) where encodeWire t (PackedList xs) = do let c (Fixed x) = putWord32le x- encodePackedList t $ traverse_ (c . runValue) xs+ encodePackedList t $ foldMap (c . runValue) xs instance DecodeWire (PackedList (Value (Fixed Word32))) where decodeWire x = do@@ -368,7 +376,7 @@ instance EncodeWire (PackedList (Value (Fixed Word64))) where encodeWire t (PackedList xs) = do let c (Fixed x) = putWord64le x- encodePackedList t $ traverse_ (c . runValue) xs+ encodePackedList t $ foldMap (c . runValue) xs instance DecodeWire (PackedList (Value (Fixed Word64))) where decodeWire x = do@@ -378,7 +386,7 @@ instance EncodeWire (PackedList (Value (Fixed Int32))) where encodeWire t (PackedList xs) = do let c (Fixed x) = putWord32le $ fromIntegral x- encodePackedList t $ traverse_ (c . runValue) xs+ encodePackedList t $ foldMap (c . runValue) xs instance DecodeWire (PackedList (Value (Fixed Int32))) where decodeWire x = do@@ -388,7 +396,7 @@ instance EncodeWire (PackedList (Value (Fixed Int64))) where encodeWire t (PackedList xs) = do let c (Fixed x) = putWord64le $ fromIntegral x- encodePackedList t $ traverse_ (c . runValue) xs+ encodePackedList t $ foldMap (c . runValue) xs instance DecodeWire (PackedList (Value (Fixed Int64))) where decodeWire x = do@@ -397,25 +405,25 @@ instance EncodeWire (PackedList (Value Float)) where encodeWire t (PackedList xs) =- encodePackedList t $ traverse_ (putFloat32le . runValue) xs+ encodePackedList t $ foldMap (putFloat32le . runValue) xs instance DecodeWire (PackedList (Value Float)) where decodeWire x = do- xs <- decodePackedList getFloat32le x+ xs <- decodePackedList F.getFloat32le x return . PackedList $ Value <$> xs instance EncodeWire (PackedList (Value Double)) where encodeWire t (PackedList xs) =- encodePackedList t $ traverse_ (putFloat64le . runValue) xs+ encodePackedList t $ foldMap (putFloat64le . runValue) xs instance DecodeWire (PackedList (Value Double)) where decodeWire x = do- xs <- decodePackedList getFloat64le x+ xs <- decodePackedList F.getFloat64le x return . PackedList $ Value <$> xs instance EncodeWire (PackedList (Value Bool)) where encodeWire t (PackedList xs) =- encodePackedList t $ traverse_ (putVarUInt . fromEnum) xs+ encodePackedList t $ foldMap (putVarUInt . fromEnum) xs instance DecodeWire (PackedList (Value Bool)) where decodeWire x = do@@ -424,7 +432,7 @@ instance Enum a => EncodeWire (PackedList (Enumeration a)) where encodeWire t (PackedList xs) =- encodePackedList t $ traverse_ (putVarUInt . fromEnum) xs+ encodePackedList t $ foldMap (putVarUInt . fromEnum) xs instance Enum a => DecodeWire (PackedList (Enumeration a)) where decodeWire x = do@@ -432,9 +440,14 @@ return . PackedList $ toEnum <$> xs instance (Foldable f, Enum a) => EncodeWire (f (Enumeration a)) where- encodeWire t = traverse_ (encodeWire t . c . runEnumeration) where+ encodeWire t = foldMap (encodeWire t . c . runEnumeration) where c :: a -> Int32 c = fromIntegral . fromEnum++instance Enum a => DecodeWire (Enumeration a) where+ decodeWire f = c <$> decodeWire f where+ c :: Int32 -> Enumeration a+ c = Enumeration . toEnum . fromIntegral instance Enum a => DecodeWire (Maybe (Enumeration a)) where decodeWire f = c <$> decodeWire f where
tests/Main.hs view
@@ -13,7 +13,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} import Test.QuickCheck-import Test.QuickCheck.Property+import Test.QuickCheck.Property hiding (testCase) import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck@@ -36,11 +36,14 @@ import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import Data.Monoid-import Data.Serialize (Get, Putter, runGet, runPut)+import Data.Binary.Get (Get, runGet)+import Data.Binary.Builder.Sized (Builder, toLazyByteString) import Data.Proxy import Data.Text (Text) import Data.Typeable import Data.Word+import qualified Data.ByteString.Lazy as LBS+import Data.Binary.Get (runGetOrFail) main :: IO () main = defaultMain tests@@ -68,9 +71,18 @@ , testCase "Google Reference Test2" test2 , testCase "Google Reference Test3" test3 , testCase "Google Reference Test4" test4+ , testCase "Packed empty fields" test4_empty , testCase "Optional Enum Test5: Nothing" test5 , testCase "Optional Enum Test5: Just Test5A" test6 , testCase "Optional Enum Test5: Just Test5B" test7+ , testCase "Repeated Enum Test6: []" test8+ , testCase "Repeated Enum Test6: [Test6A]" test9+ , testCase "Repeated Enum Test6: [Test6A, Test6B]" test10+ , testCase "Repeated Enum Test6: [Test6A, Test6A]" test11+ , testCase "Repeated Enum Test6: [Test6A, Test6B, Test6A]" test12+ , testCase "Repeated Enum Test7: []" test13+ , testCase "Repeated Enum Test7: [Test7]" test14+ , testCase "Repeated Enum Test7: [Test7, Test7]" test15 , testCase "Google WireFormatTest ZigZag" wireFormatZZ ] @@ -288,14 +300,14 @@ prop_wire _ = label ("prop_wire :: " ++ show (typeOf (undefined :: a))) $ do tag <- choose (0, 536870912) val <- arbitrary- let bs = runPut (encodeWire tag (val :: a))+ let bs = toLazyByteString (encodeWire tag (val :: a)) dec = do field <- getWireField guard $ tag == wireFieldTag field decodeWire field- case runGet dec bs of- Right val' -> return $ val == val'- Left err -> fail err+ case runGetOrFail dec bs of+ Right (_, _, val') -> return $ val == val'+ Left (_, _, err) -> fail err prop_generic :: Gen Property prop_generic = do@@ -305,34 +317,32 @@ prop_generic_length_prefixed :: Gen Property prop_generic_length_prefixed = do msg <- HashMap.fromListWith (++) . fmap (\ c -> (wireFieldTag c, [c])) <$> listOf1 arbitrary- let bs = runPut $ encodeLengthPrefixedMessage (msg :: HashMap Tag [WireField])- case runGet decodeLengthPrefixedMessage bs of- Right msg' -> return $ counterexample "foo" $ msg == msg'- Left err -> fail err+ let bs = toLazyByteString $ encodeLengthPrefixedMessage (msg :: HashMap Tag [WireField])+ case runGetOrFail decodeLengthPrefixedMessage bs of+ Right (_, _, msg') -> return $ counterexample "foo" $ msg == msg'+ Left (_, _, err) -> fail err prop_roundtrip_msg :: (Eq a, Encode a, Decode a) => a -> Gen Property prop_roundtrip_msg msg = do- let bs = runPut $ encodeMessage msg+ let bs = toLazyByteString $ encodeMessage msg case runGet decodeMessage bs of- Right msg' -> return . property $ msg == msg'- Left err -> fail err+ msg' -> return . property $ msg == msg' prop_varint_prefixed_bytestring :: Gen Property prop_varint_prefixed_bytestring = do bs <- B.pack <$> arbitrary prop_roundtrip_value getVarintPrefixedBS putVarintPrefixedBS bs -prop_roundtrip_value :: (Eq a, Show a) => Get a -> Putter a -> a -> Gen Property+prop_roundtrip_value :: (Eq a, Show a) => Get a -> (a -> Builder) -> a -> Gen Property prop_roundtrip_value get put val = do- let bs = runPut (put val)+ let bs = toLazyByteString (put val) case runGet get bs of- Right val' -> return $ val === val'- Left err -> fail err+ val' -> return $ val === val' prop_encode_fail :: Encode a => a -> Gen Prop prop_encode_fail msg = unProperty $ ioProperty $ do- res <- try . evaluate . runPut $ encodeMessage msg- return $ case res :: Either SomeException B.ByteString of+ res <- try . evaluate . toLazyByteString $ encodeMessage msg+ return $ case res :: Either SomeException LBS.ByteString of Left _ -> True Right _ -> False @@ -347,7 +357,7 @@ -- is also recommended since these are encoded as varints which have -- fairly high overhead for negative tags n <- choose (536870912, toInteger $ (maxBound :: Int))- case someNatVal n of + case someNatVal n of Just (SomeNat x) -> g x prop_reify_valid_tag :: forall r . (forall n . KnownNat n => Proxy n -> Gen r) -> Gen r@@ -359,7 +369,7 @@ -- is also recommended since these are encoded as varints which have -- fairly high overhead for negative tags n <- choose (0, 536870911)- case someNatVal n of + case someNatVal n of Just (SomeNat x) -> f x prop_req_reify :: forall a r . a -> (forall n . KnownNat n => RequiredValue n a -> Gen r) -> Gen r@@ -400,12 +410,12 @@ -- implement the examples from https://developers.google.com/protocol-buffers/docs/encoding testSpecific :: (Eq a, Show a, Encode a, Decode a) => a -> B.ByteString -> IO () testSpecific msg ref = do- let bs = runPut $ encodeMessage msg- assertEqual "Encoded message mismatch" bs ref+ let bs = toLazyByteString $ encodeMessage msg+ assertEqual "Encoded message mismatch" (LBS.toStrict bs) ref - case runGet decodeMessage bs of- Right msg' -> assertEqual "Decoded message mismatch" msg msg'- Left err -> assertFailure err+ case runGetOrFail decodeMessage bs of+ Right (_, _, msg') -> assertEqual "Decoded message mismatch" msg msg'+ Left (_, _, err) -> assertFailure err data Test1 = Test1{test1_a :: Required 1 (Value Int32)} deriving (Generic) deriving instance Eq Test1@@ -443,11 +453,25 @@ test4 = testSpecific msg =<< unhex "2206038e029ea705" where msg = Test4{test4_d = putField [3,270,86942]} +test4_empty :: Assertion+test4_empty = testSpecific msg =<< unhex "" where+ msg = Test4{test4_d = putField mempty}+ data Test5Enum = Test5A | Test5B deriving (Eq, Show, Enum) data Test5 = Test5{test5_e :: Optional 5 (Enumeration Test5Enum)} deriving (Generic, Eq, Show) instance Encode Test5 instance Decode Test5 +data Test6Enum = Test6A | Test6B deriving (Eq, Show, Enum)+data Test6 = Test6{test6_e :: Repeated 6 (Enumeration Test6Enum)} deriving (Generic, Eq, Show)+instance Encode Test6+instance Decode Test6++data Test7Enum = Test7A deriving (Eq, Show, Enum)+data Test7 = Test7{test7_e :: Repeated 7 (Enumeration Test7Enum)} deriving (Generic, Eq, Show)+instance Encode Test7+instance Decode Test7+ test5 :: Assertion test5 = testSpecific msg =<< unhex "" where msg = Test5{test5_e = putField Nothing}@@ -459,6 +483,38 @@ test7 :: Assertion test7 = testSpecific msg =<< unhex "2801" where msg = Test5{test5_e = putField $ Just Test5B }++test8 :: Assertion+test8 = testSpecific msg =<< unhex "" where+ msg = Test6{test6_e = putField $ [] }++test9 :: Assertion+test9 = testSpecific msg =<< unhex "3000" where+ msg = Test6{test6_e = putField $ [Test6A] }++test10 :: Assertion+test10 = testSpecific msg =<< unhex "30003001" where+ msg = Test6{test6_e = putField $ [Test6A, Test6B]}++test11 :: Assertion+test11 = testSpecific msg =<< unhex "30003000" where+ msg = Test6{test6_e = putField $ [Test6A, Test6A]}++test12 :: Assertion+test12 = testSpecific msg =<< unhex "300030013000" where+ msg = Test6{test6_e = putField $ [Test6A, Test6B, Test6A]}++test13 :: Assertion+test13 = testSpecific msg =<< unhex "" where+ msg = Test7{test7_e = putField $ [] }++test14 :: Assertion+test14 = testSpecific msg =<< unhex "3800" where+ msg = Test7{test7_e = putField $ [Test7A] }++test15 :: Assertion+test15 = testSpecific msg =<< unhex "38003800" where+ msg = Test7{test7_e = putField $ [Test7A, Test7A] } -- some from http://code.google.com/p/protobuf/source/browse/trunk/src/google/protobuf/wire_format_unittest.cc wireFormatZZ :: Assertion