protobuf 0.2.1.3 → 0.2.1.4
raw patch · 10 files changed
+269/−151 lines, 10 filesdep +binarydep +criteriondep −cerealdep ~basedep ~bytestringdep ~deepseq
Dependencies added: binary, criterion
Dependencies removed: cereal
Dependency ranges changed: base, bytestring, deepseq, mtl, semigroups, text, unordered-containers
Files
- CHANGELOG +3/−6
- bench/Bench.hs +46/−0
- protobuf.cabal +30/−7
- src/Data/Binary/Builder/Sized.hs +56/−0
- src/Data/ProtocolBuffers.hs +5/−5
- src/Data/ProtocolBuffers/Decode.hs +8/−8
- src/Data/ProtocolBuffers/Encode.hs +15/−16
- src/Data/ProtocolBuffers/Message.hs +4/−8
- src/Data/ProtocolBuffers/Wire.hs +78/−78
- tests/Main.hs +24/−23
CHANGELOG view
@@ -1,9 +1,6 @@-0.2.1.2:-- Fix #36: Compile on GHC >= 8.0--0.2.1.1:- - Fix #26: Import orphan Foldable Last instance from base-orphans- - Fix #27: Fix failure when decoding empty [packed] fields+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
+ 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.1.3+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@@ -48,19 +49,17 @@ 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 - if impl(ghc < 8.0)- build-depends: semigroups == 0.18.*- -- executable protoc-gen-hs -- default-language: -- Haskell2010@@ -93,7 +92,7 @@ build-depends: base >= 4.7 && < 5, bytestring,- cereal,+ binary, containers, hex, mtl,@@ -106,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
@@ -20,7 +20,7 @@ --import "GHC.Generics" ('GHC.Generics.Generic') --import "GHC.TypeLits" --import "Data.Monoid"---import "Data.Serialize"+--import "Data.Binary" --import "Data.Hex" -- cabal install hex (for testing) -- -- data Foo = Foo@@ -41,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.@@ -51,12 +51,12 @@ {-# 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
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 its length.-encodeLengthPrefixedMessage :: Encode a => a -> Put+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
@@ -18,8 +18,7 @@ import Control.DeepSeq (NFData(..)) import Data.Foldable import Data.Monoid hiding ((<>))-import Data.Serialize.Get-import Data.Serialize.Put+import Data.Binary.Get import Data.Traversable import Data.Semigroup (Semigroup(..)) @@ -30,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.@@ -160,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/Wire.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -30,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 @@ -60,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@@ -79,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 = legacyFail $ "Wire tag out of range: " ++ show tag- | otherwise = legacyFail $ "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@@ -104,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@@ -135,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@@ -147,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 = legacyFail "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@@ -285,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@@ -311,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@@ -320,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@@ -329,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@@ -339,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@@ -349,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@@ -359,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@@ -369,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@@ -379,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@@ -389,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@@ -398,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@@ -425,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@@ -433,7 +440,7 @@ 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 @@ -461,10 +468,3 @@ zzDecode32 w = fromIntegral (w `shiftR` 1) `xor` negate (fromIntegral (w .&. 1)) zzDecode64 :: Word64 -> Int64 zzDecode64 w = fromIntegral (w `shiftR` 1) `xor` negate (fromIntegral (w .&. 1))--legacyFail :: Monad m => String -> m a-#if __GLASGOW_HASKELL__ <= 710-legacyFail = fail-#else-legacyFail = errorWithoutStackTrace-#endif
tests/Main.hs view
@@ -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@@ -297,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@@ -314,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 @@ -409,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