diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -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) + ] + ] + ] diff --git a/protobuf.cabal b/protobuf.cabal --- a/protobuf.cabal +++ b/protobuf.cabal @@ -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 diff --git a/src/Data/Binary/Builder/Sized.hs b/src/Data/Binary/Builder/Sized.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Builder/Sized.hs @@ -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 diff --git a/src/Data/ProtocolBuffers.hs b/src/Data/ProtocolBuffers.hs --- a/src/Data/ProtocolBuffers.hs +++ b/src/Data/ProtocolBuffers.hs @@ -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 diff --git a/src/Data/ProtocolBuffers/Decode.hs b/src/Data/ProtocolBuffers/Decode.hs --- a/src/Data/ProtocolBuffers/Decode.hs +++ b/src/Data/ProtocolBuffers/Decode.hs @@ -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 diff --git a/src/Data/ProtocolBuffers/Encode.hs b/src/Data/ProtocolBuffers/Encode.hs --- a/src/Data/ProtocolBuffers/Encode.hs +++ b/src/Data/ProtocolBuffers/Encode.hs @@ -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 diff --git a/src/Data/ProtocolBuffers/Message.hs b/src/Data/ProtocolBuffers/Message.hs --- a/src/Data/ProtocolBuffers/Message.hs +++ b/src/Data/ProtocolBuffers/Message.hs @@ -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 @ diff --git a/src/Data/ProtocolBuffers/Wire.hs b/src/Data/ProtocolBuffers/Wire.hs --- a/src/Data/ProtocolBuffers/Wire.hs +++ b/src/Data/ProtocolBuffers/Wire.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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