protobuf 0.1 → 0.1.1

raw patch · 7 files changed

+134/−82 lines, 7 files

Files

• protobuf.cabal +1/−1
• src/Data/ProtocolBuffers.hs +2/−1
• src/Data/ProtocolBuffers/Decode.hs +4/−1
• src/Data/ProtocolBuffers/Encode.hs +4/−1
• src/Data/ProtocolBuffers/Message.hs +41/−0
• src/Data/ProtocolBuffers/Wire.hs +78/−78
• tests/Main.hs +4/−0

@@ -1,5 +1,5 @@ name:                protobuf-version:             0.1+version:             0.1.1 synopsis:            Google Protocol Buffers via GHC.Generics description:   Google Protocol Buffers via GHC.Generics.

@@ -32,7 +32,8 @@ --instance 'Decode' Foo -- @ ----- It can then be used for encoding and decoding.+-- It can then be used for encoding and decoding. The 'Encode' and 'Decode' instances are derived automatically+-- using DeriveGeneric and DefaultSignatures as outlined here: <http://www.haskell.org/haskellwiki/GHC.Generics#More_general_default_methods>. -- -- To construct a message, use 'putField' to set each field value. 'Optional', 'Repeated' and 'Packed' -- fields can be set to their empty value by using 'Data.Monoid.mempty'. An example using record syntax for clarity:

@@ -45,7 +45,7 @@       Nothing -> return msg  -- |--- Decode a Protocol Buffers message prefixed with a zz-encoded 32-bit integer describing it's length.+-- Decode a Protocol Buffers message prefixed with a varint encoded 32-bit integer describing it's length. decodeLengthPrefixedMessage :: Decode a => Get a {-# INLINE decodeLengthPrefixedMessage #-} decodeLengthPrefixedMessage = do@@ -120,6 +120,9 @@  instance (DecodeWire (PackedList a), Tl.Nat n) => GDecode (K1 i (Packed n a)) where   gdecode msg = fieldDecode PackedField msg++instance GDecode U1 where+  gdecode _ = return U1  -- | -- foldMapM implemented in a way that defers using (mempty :: b) unless the

@@ -29,7 +29,7 @@ encodeMessage = encode  -- |--- Encode a Protocol Buffers message prefixed with a zz-encoded 32-bit integer describing it's length.+-- Encode a Protocol Buffers message prefixed with a varint encoded 32-bit integer describing it's length. encodeLengthPrefixedMessage :: Encode a => a -> Put {-# INLINE encodeLengthPrefixedMessage #-} encodeLengthPrefixedMessage msg = do@@ -63,3 +63,6 @@ instance (EncodeWire a, Tl.Nat n, Foldable f) => GEncode (K1 i (Field n (f a))) where   gencode = traverse_ (encodeWire tag) . runField . unK1 where     tag = fromIntegral $ Tl.toInt (undefined :: n)++instance GEncode U1 where+  gencode _ = return ()

@@ -51,6 +51,47 @@ --instance 'Decode' Outer -- @ --+-- It's worth noting that @ 'Message' a @ is a 'Monoid' and 'NFData' instance. The 'Monoid' behavior models+-- that of the Protocol Buffers documentation, effectively 'Data.Monoid.Last'. It's done with a fairly big hammer+-- and it isn't possible to override this behavior. This can cause some less-obvious compile errors for+-- paramterized 'Message' types:+--+-- @+--data Inner = Inner{inner :: 'Required' 'D2' ('Value' 'Float')} deriving ('Generic', 'Show')+--instance 'Encode' Inner+--instance 'Decode' Inner+--+--data Outer a = Outer{outer :: 'Required' 'D3' ('Message' a)} deriving ('Generic', 'Show')+--instance 'Encode' a => 'Encode' (Outer a)+--instance 'Decode' a => 'Decode' (Outer a)+-- @+--+-- This fails because 'Decode' needs to know that the message can be merged. The resulting error+-- implies that you may want to add a constraint to the internal 'GMessageMonoid' class:+--+-- @+-- \/tmp\/tst.hs:18:10:+--   Could not deduce (protobuf-0.1:'Data.ProtocolBuffers.Message.GMessageMonoid' ('Rep' a))+--     arising from a use of `protobuf-0.1: 'Data.ProtocolBuffers.Decode' .$gdmdecode'+--   from the context ('Decode' a)+--     bound by the instance declaration at \/tmp\/tst.hs:18:10-39+--   Possible fix:+--     add an instance declaration for+--     (protobuf-0.1:'Data.ProtocolBuffers.Message.GMessageMonoid' ('Rep' a))+--   In the expression:+--     (protobuf-0.1:'Data.ProtocolBuffers.Decode'.$gdmdecode)+--   In an equation for `decode':+--       decode = (protobuf-0.1:'Data.ProtocolBuffers.Decode' .$gdmdecode)+--   In the instance declaration for `'Decode' (Outer a)'+-- @+--+-- The correct fix is to add the 'Monoid' constraint for the message:+--+-- @+-- - instance ('Encode' a) => 'Decode' (Outer a)+-- + instance ('Monoid' ('Message' a), 'Decode' a) => 'Decode' (Outer a)+-- @+-- newtype Message m = Message {runMessage :: m}   deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 

@@ -278,154 +278,154 @@       Left err  -> fail $ "Decoding failed: " ++ show err   decodeWire _ = empty +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 _ _ = empty++-- |+-- Empty lists are not written out+encodePackedList :: Tag -> Put -> Put+{-# INLINE encodePackedList #-}+encodePackedList t p+  | bs <- runPut p+  , not (B.null bs) = encodeWire t bs+  | otherwise = pure ()+ instance EncodeWire (PackedList (Value Int32)) where   encodeWire t (PackedList xs) =-    encodeWire t . runPut $ traverse_ (putVarSInt . runValue) xs+    encodePackedList t $ traverse_ (putVarSInt . runValue) xs  instance DecodeWire (PackedList (Value Int32)) where-  decodeWire (DelimitedField _ bs) =-    case runGet (some getVarInt) bs of-      Right val -> return . PackedList $ fmap Value val-      Left err  -> fail err-  decodeWire _ = empty+  decodeWire x = do+    xs <- decodePackedList getVarInt x+    return . PackedList $ Value <$> xs  instance EncodeWire (PackedList (Value Int64)) where   encodeWire t (PackedList xs) =-    encodeWire t . runPut $ traverse_ (putVarSInt . runValue) xs+    encodePackedList t $ traverse_ (putVarSInt . runValue) xs  instance DecodeWire (PackedList (Value Int64)) where-  decodeWire (DelimitedField _ bs) =-    case runGet (some getVarInt) bs of-      Right val -> return . PackedList $ fmap Value val-      Left err  -> fail err-  decodeWire _ = empty+  decodeWire x = do+    xs <- decodePackedList getVarInt x+    return . PackedList $ Value <$> xs  instance EncodeWire (PackedList (Value Word32)) where   encodeWire t (PackedList xs) =-    encodeWire t . runPut $ traverse_ (putVarUInt . runValue) xs+    encodePackedList t $ traverse_ (putVarUInt . runValue) xs  instance DecodeWire (PackedList (Value Word32)) where-  decodeWire (DelimitedField _ bs) =-    case runGet (some getVarInt) bs of-      Right val -> return . PackedList $ fmap Value val-      Left err  -> fail err-  decodeWire _ = empty+  decodeWire x = do+    xs <- decodePackedList getVarInt x+    return . PackedList $ Value <$> xs  instance EncodeWire (PackedList (Value Word64)) where   encodeWire t (PackedList xs) =-    encodeWire t . runPut $ traverse_ (putVarUInt . runValue) xs+    encodePackedList t $ traverse_ (putVarUInt . runValue) xs  instance DecodeWire (PackedList (Value Word64)) where-  decodeWire (DelimitedField _ bs) =-    case runGet (some getVarInt) bs of-      Right val -> return . PackedList $ fmap Value val-      Left err  -> fail err-  decodeWire _ = empty+  decodeWire x = do+    xs <- decodePackedList getVarInt x+    return . PackedList $ Value <$> xs  instance EncodeWire (PackedList (Value (Signed Int32))) where   encodeWire t (PackedList xs) = do     let c (Signed x) = putVarSInt $ zzEncode32 x-    encodeWire t . runPut $ traverse_ (c . runValue) xs+    encodePackedList t $ traverse_ (c . runValue) xs  instance DecodeWire (PackedList (Value (Signed Int32))) where-  decodeWire (DelimitedField _ bs) =-    case runGet (some getVarInt) bs of-      Right val -> return . PackedList $ fmap (Value . Signed . zzDecode32) val-      Left err  -> fail err-  decodeWire _ = empty+  decodeWire x = do+    xs <- decodePackedList getVarInt x+    return . PackedList $ Value . Signed . zzDecode32 <$> xs  instance EncodeWire (PackedList (Value (Signed Int64))) where   encodeWire t (PackedList xs) = do     let c (Signed x) = putVarSInt $ zzEncode64 x-    encodeWire t . runPut $ traverse_ (c . runValue) xs+    encodePackedList t $ traverse_ (c . runValue) xs  instance DecodeWire (PackedList (Value (Signed Int64))) where-  decodeWire (DelimitedField _ bs) =-    case runGet (some getVarInt) bs of-      Right val -> return . PackedList $ fmap (Value . Signed . zzDecode64) val-      Left err  -> fail err-  decodeWire _ = empty+  decodeWire x = do+    xs <- decodePackedList getVarInt x+    return . PackedList $ Value . Signed . zzDecode64 <$> xs  instance EncodeWire (PackedList (Value (Fixed Word32))) where   encodeWire t (PackedList xs) = do     let c (Fixed x) = putWord32le x-    encodeWire t . runPut $ traverse_ (c . runValue) xs+    encodePackedList t $ traverse_ (c . runValue) xs  instance DecodeWire (PackedList (Value (Fixed Word32))) where-  decodeWire (DelimitedField _ bs) =-    case runGet (some getWord32le) bs of-      Right val -> return . PackedList $ fmap (Value . Fixed) val-      Left err  -> fail err-  decodeWire _ = empty+  decodeWire x = do+    xs <- decodePackedList getWord32le x+    return . PackedList $ Value . Fixed <$> xs  instance EncodeWire (PackedList (Value (Fixed Word64))) where   encodeWire t (PackedList xs) = do     let c (Fixed x) = putWord64le x-    encodeWire t . runPut $ traverse_ (c . runValue) xs+    encodePackedList t $ traverse_ (c . runValue) xs  instance DecodeWire (PackedList (Value (Fixed Word64))) where-  decodeWire (DelimitedField _ bs) =-    case runGet (some getWord64le) bs of-      Right val -> return . PackedList $ fmap (Value . Fixed) val-      Left err  -> fail err-  decodeWire _ = empty+  decodeWire x = do+    xs <- decodePackedList getWord64le x+    return . PackedList $ Value . Fixed <$> xs  instance EncodeWire (PackedList (Value (Fixed Int32))) where   encodeWire t (PackedList xs) = do     let c (Fixed x) = putWord32le $ fromIntegral x-    encodeWire t . runPut $ traverse_ (c . runValue) xs+    encodePackedList t $ traverse_ (c . runValue) xs  instance DecodeWire (PackedList (Value (Fixed Int32))) where-  decodeWire (DelimitedField _ bs) =-    case runGet (some getWord32le) bs of-      Right val -> return . PackedList $ fmap (Value . Fixed . fromIntegral) val-      Left err  -> fail err-  decodeWire _ = empty+  decodeWire x = do+    xs <- decodePackedList getWord32le x+    return . PackedList $ Value . Fixed . fromIntegral <$> xs  instance EncodeWire (PackedList (Value (Fixed Int64))) where   encodeWire t (PackedList xs) = do     let c (Fixed x) = putWord64le $ fromIntegral x-    encodeWire t . runPut $ traverse_ (c . runValue) xs+    encodePackedList t $ traverse_ (c . runValue) xs  instance DecodeWire (PackedList (Value (Fixed Int64))) where-  decodeWire (DelimitedField _ bs) =-    case runGet (some getWord64le) bs of-      Right val -> return . PackedList $ fmap (Value . Fixed . fromIntegral) val-      Left err  -> fail err-  decodeWire _ = empty+  decodeWire x = do+    xs <- decodePackedList getWord64le x+    return . PackedList $ Value . Fixed . fromIntegral <$> xs  instance EncodeWire (PackedList (Value Float)) where   encodeWire t (PackedList xs) =-    encodeWire t . runPut $ traverse_ (putFloat32le . runValue) xs+    encodePackedList t $ traverse_ (putFloat32le . runValue) xs  instance DecodeWire (PackedList (Value Float)) where-  decodeWire (DelimitedField _ bs) =-    case runGet (some getFloat32le) bs of-      Right val -> return . PackedList $ fmap Value val-      Left err  -> fail err-  decodeWire _ = empty+  decodeWire x = do+    xs <- decodePackedList getFloat32le x+    return . PackedList $ Value <$> xs  instance EncodeWire (PackedList (Value Double)) where   encodeWire t (PackedList xs) =-    encodeWire t . runPut $ traverse_ (putFloat64le . runValue) xs+    encodePackedList t $ traverse_ (putFloat64le . runValue) xs  instance DecodeWire (PackedList (Value Double)) where-  decodeWire (DelimitedField _ bs) =-    case runGet (some getFloat64le) bs of-      Right val -> return . PackedList $ fmap Value val-      Left err  -> fail err-  decodeWire _ = empty+  decodeWire x = do+    xs <- decodePackedList getFloat64le x+    return . PackedList $ Value <$> xs  instance EncodeWire (PackedList (Value Bool)) where   encodeWire t (PackedList xs) =-    encodeWire t . runPut $ traverse_ (putVarUInt . fromEnum) xs+    encodePackedList t $ traverse_ (putVarUInt . fromEnum) xs  instance DecodeWire (PackedList (Value Bool)) where-  decodeWire (DelimitedField _ bs) =-    case runGet (some getVarInt) bs of-      Right val -> return . PackedList $ fmap toEnum val-      Left err  -> fail err-  decodeWire _ = empty+  decodeWire x = do+    xs <- decodePackedList getVarInt x+    return . PackedList $ toEnum <$> xs++instance Enum a => EncodeWire (PackedList (Enumeration a)) where+  encodeWire t (PackedList xs) =+    encodePackedList t $ traverse_ (putVarUInt . fromEnum) xs++instance Enum a => DecodeWire (PackedList (Enumeration a)) where+  decodeWire x = do+    xs <- decodePackedList getVarInt x+    return . PackedList $ toEnum <$> xs  instance (Foldable f, Enum a) => EncodeWire (Enumeration (f a)) where   encodeWire t = traverse_ (encodeWire t . c) . runEnumeration where

@@ -362,3 +362,7 @@    assert $     856912304801416  == rt64     856912304801416   assert $ (-75123905439571256) == rt64 (-75123905439571256)++data Test5 a = Test5{test5_e :: Required D3 (Message a)} deriving Generic -- (Generic, Eq, Show)+instance (Monoid (Message a), Encode a) => Encode (Test5 a)+instance (Monoid (Message a), Decode a) => Decode (Test5 a)