packages feed

protobuf 0.2.0.3 → 0.2.0.4

raw patch · 7 files changed

+131/−26 lines, 7 filesdep +containers

Dependencies added: containers

Files

CHANGELOG view
@@ -1,3 +1,6 @@+0.2.0.4:+  - 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"
protobuf.cabal view
@@ -1,5 +1,5 @@ name:                protobuf-version:             0.2.0.3+version:             0.2.0.4 synopsis:            Google Protocol Buffers via GHC.Generics description:   Google Protocol Buffers via GHC.Generics.@@ -90,6 +90,7 @@     base                       >= 4.7 && < 5,     bytestring,     cereal,+    containers,     hex,     mtl,     protobuf,
src/Data/ProtocolBuffers/Decode.hs view
@@ -89,7 +89,7 @@   let tag = fromIntegral $ natVal (Proxy :: Proxy n)   in case HashMap.lookup tag msg of     Just val -> K1 . Field . c <$> foldMapM decodeWire val-    Nothing  -> pure . K1 . Field $ c mempty+    Nothing  -> empty  instance (DecodeWire a, KnownNat n) => GDecode (K1 i (Field n (OptionalField (Last (Value a))))) where   gdecode msg = fieldDecode Optional msg <|> pure (K1 mempty)@@ -103,7 +103,7 @@  instance (Enum a, KnownNat n) => GDecode (K1 i (Field n (OptionalField (Last (Enumeration a))))) where   gdecode msg = do-    K1 mx <- fieldDecode Optional msg+    K1 mx <- fieldDecode Optional msg <|> pure (K1 mempty)     case mx :: Field n (OptionalField (Last (Value Int32))) of       Field (Optional (Last (Just (Value x)))) ->         return . K1 . Field . Optional . Last . Just . Enumeration . toEnum $ fromIntegral x
src/Data/ProtocolBuffers/Encode.hs view
@@ -9,6 +9,7 @@   ( Encode(..)   , encodeMessage   , encodeLengthPrefixedMessage+  , GEncode   ) where  import qualified Data.ByteString as B
src/Data/ProtocolBuffers/Internal.hs view
@@ -21,8 +21,13 @@   , PackedField(..)   , PackedList(..)   , Message(..)+  , GDecode+  , GEncode+  , GMessageMonoid   ) where +import Data.ProtocolBuffers.Decode+import Data.ProtocolBuffers.Encode import Data.ProtocolBuffers.Message import Data.ProtocolBuffers.Types import Data.ProtocolBuffers.Wire
src/Data/ProtocolBuffers/Message.hs view
@@ -11,6 +11,7 @@  module Data.ProtocolBuffers.Message   ( Message(..)+  , GMessageMonoid   ) where  import Control.Applicative
tests/Main.hs view
@@ -18,7 +18,7 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck -import GHC.Generics (Generic)+import GHC.Generics import GHC.TypeLits  import Control.Applicative@@ -33,6 +33,8 @@ import qualified Data.HashMap.Strict as HashMap import Data.Hex import Data.Int+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet import Data.Monoid import Data.Serialize (Get, Putter, runGet, runPut) import Data.Proxy@@ -61,6 +63,7 @@   , testProperty "Generic message coding" prop_generic   , testProperty "Generic length prefixed message coding" prop_generic_length_prefixed   , testProperty "Varint prefixed bytestring" prop_varint_prefixed_bytestring+  , testProperty "Random message" prop_message   , testCase "Google Reference Test1" test1   , testCase "Google Reference Test2" test2   , testCase "Google Reference Test3" test3@@ -190,6 +193,97 @@ instance (EncodeWire a, KnownNat n) => Encode (RepeatedValue n a) instance (DecodeWire a, KnownNat n) => Decode (RepeatedValue n a) +arbitraryField :: forall r . Int -> (forall a . (Monoid a, GEncode (K1 R a), GDecode (K1 R a), Eq a, Show a) => a -> Gen r) -> Gen r+arbitraryField i f =+  case someNatVal (fromIntegral i) of+    Nothing -> fail $ "someNatVal failed for " ++ show i+    Just (SomeNat (n :: Proxy n)) -> do+      flavor <- choose (1, 3)+      case flavor :: Int of+        0 -> do -- Packed+          which <- choose (0, 5)+          case which :: Int of+            0 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Float))+            1 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Double))+            2 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Int32))+            3 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Int64))+            4 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Word32))+            5 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Word64))+            -- 6 -> arbitraryMessage (\ (msg :: msg) -> oneof [return (Just msg), return Nothing] >>= \ msg' -> f (putField msg' :: Optional n (Message msg)))+            -- 7 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Text))+            -- 8 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value B.ByteString))+        1 -> do -- Repeated+          which <- choose (0, 5)+          case which :: Int of+            0 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Float))+            1 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Double))+            2 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Int32))+            3 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Int64))+            4 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Word32))+            5 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Word64))+            -- 6 -> arbitraryMessage (\ (msg :: msg) -> oneof [return (Just msg), return Nothing] >>= \ msg' -> f (putField msg' :: Optional n (Message msg)))+            -- 7 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Text))+            -- 8 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value B.ByteString))++        2 -> do -- Optional+          which <- choose (0, 6)+          case which :: Int of+            0 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Float))+            1 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Double))+            2 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Int32))+            3 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Int64))+            4 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Word32))+            5 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Word64))+            6 -> arbitraryMessage (\ (msg :: msg) -> oneof [return (Just msg), return Nothing] >>= \ msg' -> f (putField msg' :: Optional n (Message msg)))+            -- 7 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Text))+            -- 8 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value B.ByteString))+        3 -> do -- Required+          which <- choose (0, 6)+          case which :: Int of+            0 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Float))+            1 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Double))+            2 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Int32))+            3 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Int64))+            4 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Word32))+            5 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Word64))+            6 -> arbitraryMessage (\ (msg :: msg) -> f (putField msg :: Required n (Message msg)))+            -- 7 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Text))+            -- 8 -> arbitrary >>= \ x -> f (putField x :: Required n (Value B.ByteString))++data T1 a = T1 a deriving (Show, Eq,Generic)+instance GEncode (K1 R a) => Encode (T1 a)+instance GDecode (K1 R a) => Decode (T1 a)++data T2 a b = T2 a b deriving (Show, Eq,Generic)+instance (GEncode (K1 R a), GEncode (K1 R b)) => Encode (T2 a b)+instance (GDecode (K1 R a), GDecode (K1 R b)) => Decode (T2 a b)++data T3 a b c = T3 a b c deriving (Show, Eq,Generic)+instance (GEncode (K1 R a), GEncode (K1 R b), GEncode (K1 R c)) => Encode (T3 a b c)+instance (GDecode (K1 R a), GDecode (K1 R b), GDecode (K1 R c)) => Decode (T3 a b c)++arbitraryMessage :: forall r . (forall a . (Encode a, Decode a, Generic a, GMessageMonoid (Rep a), Eq a, Show a) => a -> Gen r) -> Gen r+arbitraryMessage f = do+  fieldCount <- choose (1, 3)+  xs <- fieldTags fieldCount+  case fieldCount of+    1 -> arbitraryField (xs !! 0) (\ f1 -> f (T1 f1))+    2 -> arbitraryField (xs !! 0) (\ f1 -> arbitraryField (xs !! 1) (\ f2 -> f (T2 f1 f2)))+    3 -> arbitraryField (xs !! 0) (\ f1 -> arbitraryField (xs !! 1) (\ f2 -> arbitraryField (xs !! 2) (\ f3 -> f (T3 f1 f2 f3))))++fieldTags :: Int -> Gen [Int]+fieldTags i = go IntSet.empty [] where+  go xs ys+    | IntSet.size xs >= i = return ys+    | otherwise = do+        next <- choose (0, 536870912)+        if next `IntSet.member` xs+          then go xs ys+          else go (IntSet.insert next xs) (next:ys)++prop_message :: Gen Property+prop_message = arbitraryMessage prop_roundtrip_msg+ prop_wire :: forall a . (Eq a, Arbitrary a, EncodeWire a, DecodeWire a, Typeable a) => Proxy a -> Property prop_wire _ = label ("prop_wire :: " ++ show (typeOf (undefined :: a))) $ do   tag <- choose (0, 536870912)@@ -203,12 +297,12 @@     Right val' -> return $ val == val'     Left err   -> fail err -prop_generic :: (Arbitrary WireField) => Gen Property+prop_generic :: Gen Property prop_generic = do   msg <- HashMap.fromListWith (++) . fmap (\ c -> (wireFieldTag c, [c])) <$> listOf1 arbitrary   prop_roundtrip_msg msg -prop_generic_length_prefixed :: (Arbitrary WireField) => Gen Property+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])@@ -373,41 +467,41 @@   assert $ 1 == zzEncode32 (-1)   assert $ 2 == zzEncode32   1   assert $ 3 == zzEncode32 (-2)-  assert $ 0x7FFFFFFE == zzEncode32 0x3FFFFFFF-  assert $ 0x7FFFFFFF == zzEncode32 0xC0000000-  assert $ 0xFFFFFFFE == zzEncode32 0x7FFFFFFF-  assert $ 0xFFFFFFFF == zzEncode32 0x80000000+  assert $ 0x7FFFFFFE == zzEncode32 (fromIntegral 0x3FFFFFFF)+  assert $ 0x7FFFFFFF == zzEncode32 (fromIntegral 0xC0000000)+  assert $ 0xFFFFFFFE == zzEncode32 (fromIntegral 0x7FFFFFFF)+  assert $ 0xFFFFFFFF == zzEncode32 (fromIntegral 0x80000000)    assert $   0  == zzDecode32 0   assert $ (-1) == zzDecode32 1   assert $   1  == zzDecode32 2   assert $ (-2) == zzDecode32 3-  assert $ 0x3FFFFFFF == zzDecode32 0x7FFFFFFE-  assert $ 0xC0000000 == zzDecode32 0x7FFFFFFF-  assert $ 0x7FFFFFFF == zzDecode32 0xFFFFFFFE-  assert $ 0x80000000 == zzDecode32 0xFFFFFFFF+  assert $ fromIntegral 0x3FFFFFFF == zzDecode32 0x7FFFFFFE+  assert $ fromIntegral 0xC0000000 == zzDecode32 0x7FFFFFFF+  assert $ fromIntegral 0x7FFFFFFF == zzDecode32 0xFFFFFFFE+  assert $ fromIntegral 0x80000000 == zzDecode32 0xFFFFFFFF    assert $ 0 == zzEncode64   0   assert $ 1 == zzEncode64 (-1)   assert $ 2 == zzEncode64   1   assert $ 3 == zzEncode64 (-2)-  assert $ 0x000000007FFFFFFE == zzEncode64 0x000000003FFFFFFF-  assert $ 0x000000007FFFFFFF == zzEncode64 0xFFFFFFFFC0000000-  assert $ 0x00000000FFFFFFFE == zzEncode64 0x000000007FFFFFFF-  assert $ 0x00000000FFFFFFFF == zzEncode64 0xFFFFFFFF80000000-  assert $ 0xFFFFFFFFFFFFFFFE == zzEncode64 0x7FFFFFFFFFFFFFFF-  assert $ 0xFFFFFFFFFFFFFFFF == zzEncode64 0x8000000000000000+  assert $ 0x000000007FFFFFFE == zzEncode64 (fromIntegral 0x000000003FFFFFFF)+  assert $ 0x000000007FFFFFFF == zzEncode64 (fromIntegral 0xFFFFFFFFC0000000)+  assert $ 0x00000000FFFFFFFE == zzEncode64 (fromIntegral 0x000000007FFFFFFF)+  assert $ 0x00000000FFFFFFFF == zzEncode64 (fromIntegral 0xFFFFFFFF80000000)+  assert $ 0xFFFFFFFFFFFFFFFE == zzEncode64 (fromIntegral 0x7FFFFFFFFFFFFFFF)+  assert $ 0xFFFFFFFFFFFFFFFF == zzEncode64 (fromIntegral 0x8000000000000000)    assert $   0  == zzDecode64 0   assert $ (-1) == zzDecode64 1   assert $   1  == zzDecode64 2   assert $ (-2) == zzDecode64 3-  assert $ 0x000000003FFFFFFF == zzDecode64 0x000000007FFFFFFE-  assert $ 0xFFFFFFFFC0000000 == zzDecode64 0x000000007FFFFFFF-  assert $ 0x000000007FFFFFFF == zzDecode64 0x00000000FFFFFFFE-  assert $ 0xFFFFFFFF80000000 == zzDecode64 0x00000000FFFFFFFF-  assert $ 0x7FFFFFFFFFFFFFFF == zzDecode64 0xFFFFFFFFFFFFFFFE-  assert $ 0x8000000000000000 == zzDecode64 0xFFFFFFFFFFFFFFFF+  assert $ fromIntegral 0x000000003FFFFFFF == zzDecode64 0x000000007FFFFFFE+  assert $ fromIntegral 0xFFFFFFFFC0000000 == zzDecode64 0x000000007FFFFFFF+  assert $ fromIntegral 0x000000007FFFFFFF == zzDecode64 0x00000000FFFFFFFE+  assert $ fromIntegral 0xFFFFFFFF80000000 == zzDecode64 0x00000000FFFFFFFF+  assert $ fromIntegral 0x7FFFFFFFFFFFFFFF == zzDecode64 0xFFFFFFFFFFFFFFFE+  assert $ fromIntegral 0x8000000000000000 == zzDecode64 0xFFFFFFFFFFFFFFFF    -- these tests are already covered by QuickCheck properties:   -- Some easier-to-verify round-trip tests.  The inputs (other than 0, 1, -1)