packages feed

protobuf (empty) → 0.1

raw patch · 14 files changed

+1940/−0 lines, 14 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, bytestring, cereal, data-binary-ieee754, deepseq, ghc-prim, haskell-src-exts, hex, mtl, protobuf, tagged, test-framework, test-framework-hunit, test-framework-quickcheck2, text, type-level, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2012, Alpha Heavy Industries, Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+  this list of conditions and the following disclaimer.+- Redistributions in binary form must reproduce the above copyright+  notice, this list of conditions and the following disclaimer in the+  documentation and/or other materials provided with the distribution.+- Neither the names of the copyright owners nor the names of the+  contributors may be used to endorse or promote products derived+  from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ LICENSE.google-protobuf view
@@ -0,0 +1,33 @@+Copyright 2008, Google Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above+copyright notice, this list of conditions and the following disclaimer+in the documentation and/or other materials provided with the+distribution.+    * Neither the name of Google Inc. nor the names of its+contributors may be used to endorse or promote products derived from+this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++Code generated by the Protocol Buffer compiler is owned by the owner+of the input file used when generating it.  This code is not+standalone and requires a support library to be linked with it.  This+support library is itself covered by the above license.
+ LICENSE.haskell-protocol-buffers view
@@ -0,0 +1,10 @@+Copyright (c) 2008, Christopher Edward Kuklewicz+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+    * Neither the name of the copyright holder nor the names of the contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ plugin/Main.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Monad.Identity+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as Bl+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Int+import Data.Monoid+import Data.ProtocolBuffers+import Data.ProtocolBuffers.Internal+import Data.Serialize+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TextL+import qualified Data.Text.Lazy.Encoding as TextL+import qualified Data.Text.Lazy.IO as TextL+import Debug.Trace+import qualified Data.TypeLevel as Tl+import GHC.Generics+import Language.Haskell.Exts+import Language.Haskell.Exts.Pretty (prettyPrint)+import Language.Haskell.Exts.SrcLoc (noLoc)++data FieldDescriptorProto_Type+  = TYPE_DOUBLE+  | TYPE_FLOAT+  | TYPE_INT64+  | TYPE_UINT64+  | TYPE_INT32+  | TYPE_FIXED64+  | TYPE_FIXED32+  | TYPE_BOOL+  | TYPE_STRING+  | TYPE_GROUP+  | TYPE_MESSAGE+  | TYPE_BYTES+  | TYPE_UINT32+  | TYPE_ENUM+  | TYPE_SFIXED32+  | TYPE_SFIXED64+  | TYPE_SINT32+  | TYPE_SINT64+    deriving (Eq, Show)++instance Enum FieldDescriptorProto_Type where+  toEnum 1 = TYPE_DOUBLE+  toEnum 2 = TYPE_FLOAT+  toEnum 3 = TYPE_INT64+  toEnum 4 = TYPE_UINT64+  toEnum 5 = TYPE_INT32+  toEnum 6 = TYPE_FIXED64+  toEnum 7 = TYPE_FIXED32+  toEnum 8 = TYPE_BOOL+  toEnum 9 = TYPE_STRING+  toEnum 10 = TYPE_GROUP+  toEnum 11 = TYPE_MESSAGE+  toEnum 12 = TYPE_BYTES+  toEnum 13 = TYPE_UINT32+  toEnum 14 = TYPE_ENUM+  toEnum 15 = TYPE_SFIXED32+  toEnum 16 = TYPE_SFIXED64+  toEnum 17 = TYPE_SINT32+  toEnum 18 = TYPE_SINT64+  fromEnum TYPE_DOUBLE         = 1+  fromEnum TYPE_FLOAT          = 2+  fromEnum TYPE_INT64          = 3+  fromEnum TYPE_UINT64         = 4+  fromEnum TYPE_INT32          = 5+  fromEnum TYPE_FIXED64        = 6+  fromEnum TYPE_FIXED32        = 7+  fromEnum TYPE_BOOL           = 8+  fromEnum TYPE_STRING         = 9+  fromEnum TYPE_GROUP          = 10+  fromEnum TYPE_MESSAGE        = 11+  fromEnum TYPE_BYTES          = 12+  fromEnum TYPE_UINT32         = 13+  fromEnum TYPE_ENUM           = 14+  fromEnum TYPE_SFIXED32       = 15+  fromEnum TYPE_SFIXED64       = 16+  fromEnum TYPE_SINT32         = 17+  fromEnum TYPE_SINT64         = 18++data FieldDescriptorProto_Label+  = LABEL_OPTIONAL+  | LABEL_REQUIRED+  | LABEL_REPEATED+    deriving (Eq, Show)++instance Enum FieldDescriptorProto_Label where+    toEnum 1 = LABEL_OPTIONAL+    toEnum 2 = LABEL_REQUIRED+    toEnum 3 = LABEL_REPEATED+    fromEnum LABEL_OPTIONAL      = 1+    fromEnum LABEL_REQUIRED      = 2+    fromEnum LABEL_REPEATED      = 3++data FieldOptions = FieldOptions+  { fieldOptionsPacked     :: Optional Tl.D2 (Value Bool)+  , fieldOptionsDeprecated :: Optional Tl.D3 (Value Bool)+  , fieldOptionsLazy       :: Optional Tl.D5 (Value Bool) -- disable strict field?+  -- optional CType ctype = 1 [default = STRING];+  } deriving (Generic, Show)++instance Decode FieldOptions++data FieldDescriptorProto = FieldDescriptorProto+  { fieldDescriptorName         :: Optional Tl.D1 (Value Text)+  , fieldDescriptorNumber       :: Optional Tl.D3 (Value Int32)+  , fieldDescriptorLabel        :: Optional Tl.D4 (Enumeration FieldDescriptorProto_Label)+  , fieldDescriptorType         :: Optional Tl.D5 (Enumeration FieldDescriptorProto_Type)+  , fieldDescriptorTypeName     :: Optional Tl.D6 (Value Text)+  , fieldDescriptorExtendee     :: Optional Tl.D2 (Value Text)+  , fieldDescriptorDefaultValue :: Optional Tl.D7 (Value Text)+  , fieldDescriptorOptions      :: Optional Tl.D8 (Message FieldOptions)+  } deriving (Generic, Show)++instance Decode FieldDescriptorProto++data DescriptorProto = DescriptorProto+  { descriptorName       :: Optional Tl.D1 (Value Text)+  , descriptorField      :: Repeated Tl.D2 (Message FieldDescriptorProto)+  , descriptorExtension  :: Repeated Tl.D6 (Message FieldDescriptorProto)+  , descriptorNestedType :: Repeated Tl.D3 (Message DescriptorProto)+  -- repeated EnumDescriptorProto enum_type = 4;++  -- message ExtensionRange {+    -- optional int32 start = 1;+    -- optional int32 end = 2;+  -- }+  -- repeated ExtensionRange extension_range = 5;++  -- optional MessageOptions options = 7;+  } deriving (Generic, Show)++instance Decode DescriptorProto++data FileDescriptorProto = FileDescriptorProto+  { fileDescriptorName             :: Optional Tl.D1 (Value Text)+  , fileDescriptorPackage          :: Optional Tl.D2 (Value Text)+  , fileDescriptorDependency       :: Repeated Tl.D3 (Value Text)+  , fileDescriptorPublicDependency :: Repeated Tl.D10 (Value Int32)+  , fileDescriptorWeakDependency   :: Repeated Tl.D11 (Value Int32)++  -- All top-level definitions in this file.+  , fileDescriptorMessageType      :: Repeated Tl.D4 (Message DescriptorProto)+  -- repeated EnumDescriptorProto enum_type = 5;+  -- repeated ServiceDescriptorProto service = 6;+  , fileDescriptorExtension        :: Repeated Tl.D7 (Message FieldDescriptorProto)++  -- optional FileOptions options = 8;++  -- This field contains optional information about the original source code.+  -- You may safely remove this entire field whithout harming runtime+  -- functionality of the descriptors -- the information is needed only by+  -- development tools.+  -- optional SourceCodeInfo source_code_info = 9;+  } deriving (Generic, Show)++instance Decode FileDescriptorProto++data CodeGeneratorRequest = CodeGeneratorRequest+  { fileToGenerate :: Repeated Tl.D1 (Value Text)+  , parameter      :: Optional Tl.D2 (Value Text)+  , protoFile      :: Repeated Tl.D15 (Message FileDescriptorProto)+  } deriving (Generic, Show)++instance Decode CodeGeneratorRequest++data CodeGeneratorResponse_File = CodeGeneratorResponse_File+  { responseFileName       :: Optional Tl.D1 (Value Text)+  , responseInsertionPoint :: Optional Tl.D2 (Value Text)+  , responseContent        :: Optional Tl.D15 (Value Text)+  } deriving (Generic, Show)++instance Encode CodeGeneratorResponse_File++data CodeGeneratorResponse = CodeGeneratorResponse+  { errorStr :: Optional Tl.D1 (Value String)+  , responseFiles :: Repeated Tl.D15 (Message CodeGeneratorResponse_File)+  } deriving (Generic, Show)++instance Encode CodeGeneratorResponse++blah :: FileDescriptorProto -> Text+blah fdp = T.pack $ prettyPrint m where+  m = Module noLoc (ModuleName "Foo") pragmas Nothing exports imports decls+  pragmas = [LanguagePragma noLoc [Ident "DataKinds"]]+  exports = Nothing+  imports = []+  decls = []++blahs :: [FileDescriptorProto] -> [CodeGeneratorResponse_File]+blahs = fmap step where+  step fpd = CodeGeneratorResponse_File+    { responseFileName = putField $ Just "test.hs"+    , responseInsertionPoint = putField Nothing+    , responseContent = putField . Just $ blah fpd+    }++-- getCodeFor :: HashMap Tag [Field] -> Bl.ByteString+getCodeFor :: CodeGeneratorRequest -> CodeGeneratorResponse+getCodeFor val = traceShow val CodeGeneratorResponse+  { errorStr = putField Nothing -- some failure string"+  , responseFiles = putField . blahs . getField $ protoFile val+  }++main :: IO ()+main = Bl.interact $ \ input ->+  runPutLazy . encodeMessage $+    case runGetLazy decodeMessage input of+      Right val -> getCodeFor val+      Left  err -> CodeGeneratorResponse+       { errorStr = putField $ Just err+       , responseFiles = putField []+       }
+ protobuf.cabal view
@@ -0,0 +1,111 @@+name:                protobuf+version:             0.1+synopsis:            Google Protocol Buffers via GHC.Generics+description:+  Google Protocol Buffers via GHC.Generics.+  .+  Protocol Buffers are a way of encoding structured data in an efficient yet extensible format.+  Google uses Protocol Buffers for almost all of its internal RPC protocols and file formats.+  .+  This library supports a useful subset of Google Protocol Buffers message specifications+  in a Haskell. No preprocessor or additional build steps are required for message encoding and decoding.+  .+  Record specifications are built by defining records with specially defined fields that+  capture most of the Protocol Buffers specification language.+  .+license:             BSD3+license-file:        LICENSE+extra-source-files:  LICENSE.google-protobuf, LICENSE.haskell-protocol-buffers+author:              Steve Severance, Nathan Howell+maintainer:          sseverance@alphaheavy.com, nhowell@alphaheavy.com+homepage:            https://github.com/alphaHeavy/protobuf+bug-reports:         https://github.com/alphaHeavy/protobuf/issues+category:            Data++build-type:          Simple+cabal-version:       >= 1.10++extra-source-files:+  tests/Main.hs++library+  default-language:+    Haskell2010+  hs-source-dirs:+    src+  exposed-modules:+    Data.ProtocolBuffers+    Data.ProtocolBuffers.Internal+  other-modules:+    Data.ProtocolBuffers.Decode+    Data.ProtocolBuffers.Encode+    Data.ProtocolBuffers.Message+    -- Data.ProtocolBuffers.Ppr+    Data.ProtocolBuffers.Types+    Data.ProtocolBuffers.Wire+  build-depends:+    base                       >= 4.5 && < 5,+    bytestring                 >= 0.9,+    cereal                     >= 0.3,+    data-binary-ieee754        >= 0.4,+    deepseq                    >= 1.1,+    ghc-prim,+    mtl                        == 2.*,+    -- pretty,+    text                       >= 0.10,+    type-level                 >= 0.2,+    unordered-containers       >= 0.2+  ghc-options:+    -Wall++executable protoc-gen-hs+  default-language:+    Haskell2010+  hs-source-dirs:+    plugin+  main-is:+    Main.hs+  build-depends:+    base                       >= 4.5 && < 5,+    bytestring,+    cereal,+    ghc-prim,+    haskell-src-exts,+    mtl,+    protobuf,+    text,+    type-level,+    unordered-containers+  ghc-options:+    -Wall++test-suite protobuf-test+  default-language:+    Haskell2010+  hs-source-dirs:+    tests+  type:+    exitcode-stdio-1.0+  main-is:+    Main.hs+  build-depends:+    base                       >= 4.5 && < 5,+    ghc-prim,+    bytestring,+    cereal,+    hex,+    mtl,+    protobuf,+    tagged,+    text,+    type-level,+    unordered-containers,+    test-framework             >= 0.4,+    test-framework-hunit       >= 0.2,+    test-framework-quickcheck2 >= 0.2,+    HUnit                      >= 1.2,+    QuickCheck                 >= 2.4++source-repository head+  type:     git+  location: https://github.com/alphaHeavy/protobuf.git
+ src/Data/ProtocolBuffers.hs view
@@ -0,0 +1,162 @@+-- |+--+-- An implementation of Protocol Buffers in pure Haskell.+--+-- Extensive documentation is available at <https://developers.google.com/protocol-buffers/docs/overview>+-- 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.+--+-- The "Data.TypeLevel" dependency is required due to <http://hackage.haskell.org/trac/ghc/ticket/7459>.+-- I believe the partial fix already committed will allow migrating to "GHC.TypeLits" once GHC 7.8.1 is released.+--+-- Given a message definition:+--+-- @+--{-\# LANGUAGE DeriveGeneric \#-}+--+-- import "Data.Int"+--import "Data.ProtocolBuffers"+--import "Data.TypeLevel" ('Data.TypeLevel.D1', 'Data.TypeLevel.D2', 'Data.TypeLevel.D3')+--import "Data.Text"+--import "GHC.Generics" ('GHC.Generics.Generic')+--+-- data Foo = Foo+--   { field1 :: 'Required' 'Data.TypeLevel.D1' ('Value' 'Data.Int.Int64') -- ^ The last field with tag = 1+--   , field2 :: 'Optional' 'Data.TypeLevel.D2' ('Value' 'Data.Text.Text') -- ^ The last field with tag = 2+--   , field3 :: 'Repeated' 'Data.TypeLevel.D3' ('Value' 'Prelude.Bool') -- ^ All fields with tag = 3, ordering is preserved+--   } deriving ('GHC.Generics.Generic', 'Prelude.Show')+--+-- instance 'Encode' Foo+--instance 'Decode' Foo+-- @+--+-- It can then be used for encoding and decoding.+--+-- 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:+--+-- >>> 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'.+--+-- >>> fmap hex runPut $ encodeMessage msg+-- "082A18011800"+--+-- Decoding is done with the inverse functions: 'decodeMessage'+-- and 'Data.Serialize.runGet', or 'Data.Serialize.runGetLazy'.+--+-- >>> runGet decodeMessage =<< unhex "082A18011800" :: Either String Foo+-- Right+--   (Foo+--     { field1 = Field {runField = Required {runRequired = Always {runAlways = Value {runValue = 42}}}}+--     , field2 = Field {runField = Optional {runOptional = Last {getLast = Nothing}}}+--     , field3 = Field {runField = Repeated {runRepeated = [Value {runValue = True},Value {runValue = False}]}}+--     }+--   )+--+-- Use 'getField' to read fields from a message:+--+-- >>> let Right msg = runGet decodeMessage =<< unhex "082A18011800" :: Either String Foo+-- >>> getField $ field1 msg+-- 42+-- >>> getField $ field2 msg+-- Nothing+-- >>> getField $ field3 msg+-- [True,False]+--+-- Some Protocol Buffers features are not currently implemented:+--+--   * Default values for 'Optional' fields+--+--   * Extension fields+--+--   * Storing unknown fields, those without a mapped field tag in message record+--+--   * Tag-delimited Groups, deprecated in lieu of 'Message'+--+module Data.ProtocolBuffers+  ( -- * Message Serialization+    --+    -- ** Encoding+    --+    Encode(..)+  , encodeMessage+  , encodeLengthPrefixedMessage++    -- ** Decoding+    --+  , Decode(..)+  , decodeMessage+  , decodeLengthPrefixedMessage++    -- * Fields+    --+    -- ** Tags+    -- |+    --+    -- Restricted type aliases of 'Field'. These are used to attach a field tag (a numeric id) to a field.+    -- Each tag must be unique within a given message, though this is not currently checked or enforced.+    --+  , Required+  , Optional+  , Repeated+  , Packed++    -- ** Accessors+    -- |+    --+    -- Fields tend to have rather complex types that are unpleasant to interact with.+    -- 'HasField' was designed to hide this complexity and provide a consistent way of+    -- getting and setting fields.+    --+  , HasField(..)++    -- ** Selectors+    -- |+    --+    -- Follow these rules to define fields supported by the generic encoder/decoder:+    --+    -- * The 'n' phantom type parameter specifies the Protocol Buffers field tag (id).+    --+    -- * Field tags /must/ be an instance of 'Data.TypeLevel.Nat'.+    --+    -- * Field selectors /must/ be an instance of 'Data.Foldable.Foldable' to support encoding.+    --+    -- * Value selectors /must/ be an instance of 'Data.Monoid.Monoid' to support decoding.+    --+  , Field++    -- * Values+    --+    -- ** Selectors+    -- |+    --+    -- Each field value needs to specify the way it should be encoded.+    --+    -- There are three built-in value selectors: 'Value', 'Enumeration' and 'Message'.+    --+    -- If you're unsure what value selector to use, 'Value' is probably the correct one.+    --+  , Value+  , Enumeration+  , Message++  -- * Wire Coding+  -- |+  --+  -- Some primitive values can be more compactly represented. Fields that typically contain+  -- negative or very large numbers should use the 'Signed' or 'Fixed' wrappers to select+  -- their respective (efficient) formats.+  --+  , Signed(..)+  , Fixed(..)+  ) where++import Data.ProtocolBuffers.Decode+import Data.ProtocolBuffers.Message+import Data.ProtocolBuffers.Encode+import Data.ProtocolBuffers.Types
+ src/Data/ProtocolBuffers/Decode.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Data.ProtocolBuffers.Decode+  ( Decode(..)+  , decodeMessage+  , decodeLengthPrefixedMessage+  , GDecode(..)+  , fieldDecode+  ) where++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+import Data.Int (Int32, Int64)+import Data.Maybe (fromMaybe)+import Data.Monoid+import Data.Serialize.Get+import Data.Traversable (traverse)+import qualified Data.TypeLevel as Tl++import GHC.Generics++import Data.ProtocolBuffers.Types+import Data.ProtocolBuffers.Wire++-- |+-- Decode a Protocol Buffers message.+decodeMessage :: Decode a => Get a+{-# INLINE decodeMessage #-}+decodeMessage = decode =<< go HashMap.empty where+  go :: HashMap Tag [WireField] -> Get (HashMap Tag [WireField])+  go msg = do+    mfield <- Just <$> getWireField <|> return Nothing+    case mfield of+      Just v  -> go $! HashMap.insertWith (flip (++)) (wireFieldTag v) [v] msg+      Nothing -> return msg++-- |+-- Decode a Protocol Buffers message prefixed with a zz-encoded 32-bit integer describing it's 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++class Decode (a :: *) where+  decode :: HashMap Tag [WireField] -> Get a+  default decode :: (Generic a, GDecode (Rep a)) => HashMap Tag [WireField] -> Get a+  decode = fmap to . gdecode++-- | Untyped message decoding, @ 'decode' = 'id' @+instance Decode (HashMap Tag [WireField]) where+  decode = pure++class GDecode (f :: * -> *) where+  gdecode :: HashMap Tag [WireField] -> Get (f a)++instance GDecode a => GDecode (M1 i c a) where+  gdecode = fmap M1 . gdecode++instance (GDecode a, GDecode b) => GDecode (a :*: b) where+  gdecode msg = liftA2 (:*:) (gdecode msg) (gdecode msg)++instance (GDecode x, GDecode y) => GDecode (x :+: y) where+  gdecode msg = L1 <$> gdecode msg <|> R1 <$> gdecode msg++fieldDecode+  :: forall a b i n p . (DecodeWire a, Monoid a, Tl.Nat n)+  => (a -> b)+  -> HashMap Tag [WireField]+  -> Get (K1 i (Field n b) p)+{-# INLINE fieldDecode #-}+fieldDecode c msg =+  let tag = fromIntegral $ Tl.toInt (undefined :: n)+  in case HashMap.lookup tag msg of+    Just val -> K1 . Field . c <$> foldMapM decodeWire val+    Nothing  -> empty++instance (DecodeWire a, Tl.Nat n) => GDecode (K1 i (Field n (OptionalField (Last (Value a))))) where+  gdecode msg = fieldDecode Optional msg <|> pure (K1 mempty)++instance (Enum a, Tl.Nat n) => GDecode (K1 i (Field n (RequiredField (Always (Enumeration a))))) where+  gdecode msg = do+    K1 mx <- fieldDecode Required msg+    case mx :: Field n (RequiredField (Always (Value Int32))) of+      Field (Required (Always (Value x))) ->+        return . K1 . Field . Required . Always . Enumeration . toEnum $ fromIntegral x++instance (Enum a, Tl.Nat n) => GDecode (K1 i (Field n (OptionalField (Last (Enumeration a))))) where+  gdecode msg = do+    K1 mx <- fieldDecode Optional msg+    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+      _ -> pure (K1 mempty)++instance (DecodeWire a, Tl.Nat n) => GDecode (K1 i (Repeated n a)) where+  gdecode msg =+    let tag = fromIntegral $ Tl.toInt (undefined :: n)+    in case HashMap.lookup tag msg of+      Just val -> K1 . Field . Repeated <$> traverse decodeWire val+      Nothing  -> pure $ K1 mempty++instance (DecodeWire a, Tl.Nat n) => GDecode (K1 i (Field n (RequiredField (Always (Value a))))) where+  gdecode msg = fieldDecode Required msg++instance (DecodeWire (PackedList a), Tl.Nat n) => GDecode (K1 i (Packed n a)) where+  gdecode msg = fieldDecode PackedField msg++-- |+-- foldMapM implemented in a way that defers using (mempty :: b) unless the+-- Foldable is empty, this allows the gross hack of pretending Always is+-- a Monoid while strictly evaluating the accumulator+foldMapM :: (Monad m, Foldable t, Monoid b) => (a -> m b) -> t a -> m b+foldMapM f = liftM (fromMaybe mempty) . foldlM go Nothing where+  go (Just !acc) = liftM (Just . mappend acc) . f+  go Nothing     = liftM Just . f
+ src/Data/ProtocolBuffers/Encode.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Data.ProtocolBuffers.Encode+  ( Encode(..)+  , encodeMessage+  , encodeLengthPrefixedMessage+  ) where++import qualified Data.ByteString as B+import Data.Foldable+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Serialize.Put+import qualified Data.TypeLevel as Tl++import GHC.Generics++import Data.ProtocolBuffers.Types+import Data.ProtocolBuffers.Wire++-- |+-- Encode a Protocol Buffers message.+encodeMessage :: Encode a => a -> Put+encodeMessage = encode++-- |+-- Encode a Protocol Buffers message prefixed with a zz-encoded 32-bit integer describing it's length.+encodeLengthPrefixedMessage :: Encode a => a -> Put+{-# INLINE encodeLengthPrefixedMessage #-}+encodeLengthPrefixedMessage msg = do+  let msg' = runPut $ encodeMessage msg+  putVarUInt $ B.length msg'+  putByteString msg'++class Encode (a :: *) where+  encode :: a -> Put+  default encode :: (Generic a, GEncode (Rep a)) => a -> Put+  encode = gencode . from++-- | Untyped message encoding+instance Encode (HashMap Tag [WireField]) where+  encode = traverse_ step . HashMap.toList where+    step = uncurry (traverse_ . encodeWire)++class GEncode (f :: * -> *) where+  gencode :: f a -> Put++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++instance (GEncode a, GEncode b) => GEncode (a :+: b) where+  gencode (L1 x) = gencode x+  gencode (R1 y) = gencode y++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)
+ src/Data/ProtocolBuffers/Internal.hs view
@@ -0,0 +1,26 @@+module Data.ProtocolBuffers.Internal+  ( Tag+  , WireField(..)+  , wireFieldTag+  , getWireField+  , EncodeWire(..)+  , DecodeWire(..)+  , zzEncode32+  , zzEncode64+  , zzDecode32+  , zzDecode64+  , Field(..)+  , Value(..)+  , Always(..)+  , Enumeration(..)+  , RequiredField(..)+  , OptionalField(..)+  , RepeatedField(..)+  , PackedField(..)+  , PackedList(..)+  , Message(..)+  ) where++import Data.ProtocolBuffers.Message+import Data.ProtocolBuffers.Types+import Data.ProtocolBuffers.Wire
+ src/Data/ProtocolBuffers/Message.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.ProtocolBuffers.Message+  ( Message(..)+  ) where++import Control.Applicative+import Control.DeepSeq (NFData(..))+import Data.Foldable+import Data.Monoid+import Data.Serialize.Get+import Data.Serialize.Put+import Data.Traversable+import qualified Data.TypeLevel as Tl++import GHC.Generics++import Data.ProtocolBuffers.Decode+import Data.ProtocolBuffers.Encode+import Data.ProtocolBuffers.Types+import Data.ProtocolBuffers.Wire++-- |+-- The way to embed a message within another message.+-- These embedded messages are stored as length-delimited fields.+--+-- For example:+--+-- @+--data Inner = Inner+--   { innerField :: 'Data.ProtocolBuffers.Required' 'Data.TypeLevel.D1' ('Data.ProtocolBuffers.Value' 'Data.Int.Int64')+--   } deriving ('GHC.Generics.Generic', 'Prelude.Show')+--+-- instance 'Encode' Inner+--instance 'Decode' Inner+--+-- data Outer = Outer+--   { outerField :: 'Data.ProtocolBuffers.Required' 'Data.TypeLevel.D1' ('Data.ProtocolBuffers.Message' Inner)+--   } deriving ('GHC.Generics.Generic', 'Prelude.Show')+--+-- instance 'Encode' Outer+--instance 'Decode' Outer+-- @+--+newtype Message m = Message {runMessage :: m}+  deriving (Eq, Foldable, Functor, Ord, Show, Traversable)++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)++instance (Decode a, Monoid (Message a), Tl.Nat n) => GDecode (K1 i (Field n (RequiredField (Always (Message a))))) where+  gdecode = fieldDecode (Required . Always)++instance (Decode a, Monoid (Message a), Tl.Nat n) => GDecode (K1 i (Field n (OptionalField (Maybe (Message a))))) where+  gdecode msg = fieldDecode (Optional . Just) msg <|> pure (K1 mempty)++class GMessageMonoid (f :: * -> *) where+  gmempty :: f a+  gmappend :: f a -> f a -> f a++instance GMessageMonoid f => GMessageMonoid (M1 i c f) where+  gmempty = M1 gmempty+  gmappend (M1 x) (M1 y) = M1 (gmappend x y)++instance (GMessageMonoid x, GMessageMonoid y) => GMessageMonoid (x :*: y) where+  gmempty = gmempty :*: gmempty+  gmappend (x1 :*: x2) (y1 :*: y2) = gmappend x1 y1 :*: gmappend x2 y2++instance (GMessageMonoid x, GMessageMonoid y) => GMessageMonoid (x :+: y) where+  gmempty = L1 gmempty+  gmappend _ = id++instance (Monoid c) => GMessageMonoid (K1 i c) where+  gmempty = K1 mempty+  gmappend (K1 x) (K1 y) = K1 $ mappend x y++instance GMessageMonoid U1 where+  gmempty = U1+  gmappend _ = id++instance (Generic m, GMessageNFData (Rep m)) => NFData (Message m) where+  rnf = grnf . from . runMessage++class GMessageNFData f where+  grnf :: f a -> ()++instance GMessageNFData f => GMessageNFData (M1 i c f) where+  grnf = grnf . unM1++instance (GMessageNFData x, GMessageNFData y) => GMessageNFData (x :*: y) where+  grnf (x :*: y) = grnf x `seq` grnf y++instance (GMessageNFData x, GMessageNFData y) => GMessageNFData (x :+: y) where+  grnf (L1 x) = grnf x+  grnf (R1 y) = grnf y++instance NFData c => GMessageNFData (K1 i c) where+  grnf = rnf . unK1++instance GMessageNFData U1 where+  grnf U1 = ()++type instance Optional n (Message a) = Field n (OptionalField (Maybe (Message a)))+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)++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 _ = empty++-- | Iso: @ 'FieldType' ('Required' n ('Message' a)) = a @+instance HasField (Field n (RequiredField (Always (Message a)))) where+  type FieldType (Field n (RequiredField (Always (Message a)))) = a+  getField = runMessage . runAlways. runRequired . runField+  putField = Field . Required . Always . Message++-- | Iso: @ 'FieldType' ('Optional' n ('Message' a)) = 'Maybe' a @+instance HasField (Field n (OptionalField (Maybe (Message a)))) where+  type FieldType (Field n (OptionalField (Maybe (Message a)))) = Maybe a+  getField = fmap runMessage . runOptional . runField+  putField = Field . Optional . fmap Message++-- | Iso: @ 'FieldType' ('Repeated' n ('Message' a)) = [a] @+instance HasField (Field n (RepeatedField [Message a])) where+  type FieldType (Field n (RepeatedField [Message a])) = [a]+  getField = fmap runMessage . runRepeated . runField+  putField = Field . Repeated . fmap Message
+ src/Data/ProtocolBuffers/Types.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module Data.ProtocolBuffers.Types+  ( Field(..)+  , HasField(..)+  , Required+  , RequiredField(..)+  , Optional+  , OptionalField(..)+  , Repeated+  , RepeatedField(..)+  , Packed+  , Value(..)+  , Enumeration(..)+  , Fixed(..)+  , Signed(..)+  , Always(..)+  , PackedList(..)+  , PackedField(..)+  ) where++import Control.DeepSeq (NFData)+import Data.Bits+import Data.Foldable as Fold+import Data.Monoid+import Data.Traversable+import Data.Typeable++-- |+-- '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)++-- |+-- '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)++-- |+-- '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)++-- |+-- '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)++-- |+-- Fields are merely a way to hold a field tag along with its type, this shouldn't normally be referenced directly.+--+-- This provides better error messages than older versions which used 'Data.Tagged.Tagged'+--+newtype Field (n :: *) a = Field {runField :: a}+  deriving (Bounded, Eq, Enum, Foldable, Functor, Monoid, Ord, NFData, Show, Traversable, Typeable)++-- |+-- To provide consistent instances for serialization a 'Traversable' 'Functor' is needed to+-- make 'Required' fields have the same shape as 'Optional', 'Repeated' and 'Packed'.+--+-- This is the 'Data.Functor.Identity.Identity' 'Functor' with a 'Show' instance.+newtype Always a = Always {runAlways :: a}+  deriving (Bounded, Eq, Enum, Foldable, Functor, Ord, NFData, Show, Traversable, Typeable)++instance Monoid (Always a) where+  mempty = error "Always is not a Monoid"+  mappend _ y = y++-- |+-- Functions for wrapping and unwrapping record fields.+-- When applied they will have types similar to these:+--+-- @+--'getField' :: 'Required' 'Data.TypeLevel.D1' ('Value' 'Data.Text.Text') -> 'Data.Text.Text'+--'putField' :: 'Data.Text.Text' -> 'Required' 'Data.TypeLevel.D1' ('Value' 'Data.Text.Text')+--+--'getField' :: 'Optional' 'Data.TypeLevel.D2' ('Value' 'Data.Int.Int32') -> 'Maybe' 'Data.Int.Int32'+--'putField' :: 'Maybe' 'Data.Int.Int32' -> 'Optional' 'Data.TypeLevel.D2' ('Value' 'Data.Int.Int32')+--+--'getField' :: 'Repeated' 'Data.TypeLevel.D3' ('Value' 'Double') -> ['Double']+--'putField' :: ['Double'] -> 'Repeated' 'Data.TypeLevel.D3' ('Value' 'Double')+--+--'getField' :: 'Packed' 'Data.TypeLevel.D4' ('Value' 'Data.Word.Word64') -> ['Data.Word.Word64']+--'putField' :: ['Data.Word.Word64'] -> 'Packed' 'Data.TypeLevel.D4' ('Value' 'Data.Word.Word64')+-- @+class HasField a where+  type FieldType a :: *++  -- | Extract a value from it's 'Field' representation.+  getField :: a -> FieldType a++  -- | Wrap it back up again.+  putField :: FieldType a -> a++  -- | An isomorphism lens compatible with the lens package+  field :: Functor f => (FieldType a -> f (FieldType a)) -> a -> f a+  field f = fmap putField . f . getField++-- | Iso: @ 'FieldType' ('Required' n ('Value' a)) = a @+instance HasField (Field n (RequiredField (Always (Value a)))) where+  type FieldType (Field n (RequiredField (Always (Value a)))) = a+  getField = runValue . runAlways . runRequired . runField+  putField = Field . Required . Always . Value++-- | Iso: @ 'FieldType' ('Required' n ('Enumeration' a)) = a @+instance HasField (Field n (RequiredField (Always (Enumeration a)))) where+  type FieldType (Field n (RequiredField (Always (Enumeration a)))) = a+  getField = runEnumeration . runAlways . runRequired . runField+  putField = Field . Required . Always . Enumeration++-- | Iso: @ 'FieldType' ('Optional' n ('Value' a)) = 'Maybe' a @+instance HasField (Field n (OptionalField (Last (Value a)))) where+  type FieldType (Field n (OptionalField (Last (Value a)))) = Maybe a+  getField = fmap runValue . getLast . runOptional . runField+  putField = Field . Optional . Last . fmap Value++-- | Iso: @ 'FieldType' ('Optional' n ('Enumeration' a)) = 'Maybe' a @+instance HasField (Field n (OptionalField (Last (Enumeration a)))) where+  type FieldType (Field n (OptionalField (Last (Enumeration a)))) = Maybe a+  getField = fmap runEnumeration . getLast . runOptional . runField+  putField = Field . Optional . Last . fmap Enumeration++-- | Iso: @ 'FieldType' ('Repeated' n ('Value' a)) = [a] @+instance HasField (Field n (RepeatedField [Value a])) where+  type FieldType (Field n (RepeatedField [Value a])) = [a]+  getField = fmap runValue . runRepeated . runField+  putField = Field . Repeated . fmap Value++-- | Iso: @ 'FieldType' ('Repeated' n ('Enumeration' a)) = [a] @+instance HasField (Field n (RepeatedField [Enumeration a])) where+  type FieldType (Field n (RepeatedField [Enumeration a])) = [a]+  getField = fmap runEnumeration . runRepeated . runField+  putField = Field . Repeated . fmap Enumeration++-- | Iso: @ 'FieldType' ('Packed' n ('Value' a)) = [a] @+instance HasField (Field n (PackedField (PackedList (Value a)))) where+  type FieldType (Field n (PackedField (PackedList (Value a)))) = [a]+  getField = fmap runValue . unPackedList . runPackedField . runField+  putField = Field . PackedField . PackedList . fmap Value++-- | Iso: @ 'FieldType' ('Packed' n ('Enumeration' a)) = [a] @+instance HasField (Field n (PackedField (PackedList (Enumeration a)))) where+  type FieldType (Field n (PackedField (PackedList (Enumeration a)))) = [a]+  getField = fmap runEnumeration . unPackedList . runPackedField . runField+  putField = Field . PackedField . PackedList . fmap Enumeration++-- | Optional fields. Values that are not found will return 'Nothing'.+type family Optional (n :: *) (a :: *) :: *+type instance Optional n (Value a)       = Field n (OptionalField (Last (Value a)))+type instance Optional n (Enumeration a) = Field n (OptionalField (Last (Enumeration a)))++-- | Required fields. Parsing will return 'Control.Alternative.empty' if a 'Required' value is not found while decoding.+type family Required (n :: *) (a :: *) :: *+type instance Required n (Value a)       = Field n (RequiredField (Always (Value a)))+type instance Required n (Enumeration a) = Field n (RequiredField (Always (Enumeration a)))++-- | Lists of values.+type Repeated n a = Field n (RepeatedField [a])++-- | Packed values.+type Packed n a = Field n (PackedField (PackedList a))++-- |+-- '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)++-- |+-- 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)++-- |+-- 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)++-- |+-- 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)++-- |+-- 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)
+ src/Data/ProtocolBuffers/Wire.hs view
@@ -0,0 +1,453 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}++module Data.ProtocolBuffers.Wire+  ( Enumeration(..)+  , WireField(..)+  , Tag+  , EncodeWire(..)+  , DecodeWire(..)+  , wireFieldTag+  , getWireField+  , getVarInt+  , getVarintPrefixedBS+  , putVarSInt+  , putVarUInt+  , zzEncode32+  , zzEncode64+  , zzDecode32+  , zzDecode64+  ) where++import Control.Applicative+import Data.Bits+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Foldable+import Data.Int+import Data.Monoid+import Data.Serialize.Get+import Data.Serialize.IEEE754+import Data.Serialize.Put+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++-- |+-- Field identifiers+type Tag = Word32++-- |+-- A representation of the wire format as described in+-- <https://developers.google.com/protocol-buffers/docs/encoding#structure>+data WireField+  = VarintField    {-# UNPACK #-} !Tag {-# UNPACK #-} !Word64 -- ^ For: int32, int64, uint32, uint64, sint32, sint64, bool, enum+  | Fixed64Field   {-# UNPACK #-} !Tag {-# UNPACK #-} !Word64 -- ^ For: fixed64, sfixed64, double+  | DelimitedField {-# UNPACK #-} !Tag !ByteString -- ^ For: string, bytes, embedded messages, packed repeated fields+  | StartField     {-# UNPACK #-} !Tag -- ^ For: groups (deprecated)+  | EndField       {-# UNPACK #-} !Tag -- ^ For: groups (deprecated)+  | Fixed32Field   {-# UNPACK #-} !Tag {-# UNPACK #-} !Word32 -- ^ For: fixed32, sfixed32, float+    deriving (Eq, Ord, Show, Typeable)++getVarintPrefixedBS :: Get ByteString+getVarintPrefixedBS = getBytes =<< getVarInt++getWireField :: Get WireField+getWireField = do+  wireTag <- getVarInt+  let tag = wireTag `shiftR` 3+  case wireTag .&. 7 of+    0 -> VarintField    tag <$> getVarInt+    1 -> Fixed64Field   tag <$> getWord64le+    2 -> DelimitedField tag <$> getVarintPrefixedBS+    3 -> return $! StartField tag+    4 -> return $! EndField   tag+    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 >> putVarUInt (B.length val) >> putByteString val+putWireField (StartField     t    ) = putWireTag t 3+putWireField (EndField       t    ) = putWireTag t 4+putWireField (Fixed32Field   t val) = putWireTag t 5 >> putWord32le val++putWireTag :: Tag -> Word32 -> Put+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++getVarInt :: (Integral a, Bits a) => Get a+getVarInt = go 0 0 where+  go n !val = do+    b <- getWord8+    if testBit b 7+      then go (n+7) (val .|. (fromIntegral (b .&. 0x7F) `shiftL` n))+      else return $! val .|. (fromIntegral b `shiftL` n)++-- 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 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)+          in go b len+    EQ -> putWord8 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 i+  | i < 0x80  = putWord8 (fromIntegral i)+  | otherwise = putWord8 (fromIntegral (i .&. 0x7F) .|. 0x80) >> putVarUInt (i `shiftR` 7)++wireFieldTag :: WireField -> Tag+wireFieldTag f = case f of+  VarintField    t _ -> t+  Fixed64Field   t _ -> t+  DelimitedField t _ -> t+  StartField     t   -> t+  EndField       t   -> t+  Fixed32Field   t _ -> t++class EncodeWire a where+  encodeWire :: Tag -> a -> Put++class DecodeWire a where+  decodeWire :: WireField -> Get a++deriving instance EncodeWire a => EncodeWire (Always (Value a))+deriving instance EncodeWire a => EncodeWire (Last (Value a))++deriving instance DecodeWire a => DecodeWire (Always (Value a))+deriving instance DecodeWire a => DecodeWire (Last (Value a))++instance EncodeWire a => EncodeWire [Value a] where+  encodeWire t = traverse_ (encodeWire t)++instance EncodeWire WireField where+  encodeWire t f+    | t == wireFieldTag f = putWireField f+    | otherwise           = fail "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)++instance DecodeWire a => DecodeWire (Value a) where+  decodeWire = fmap Value . decodeWire++instance EncodeWire a => EncodeWire (Maybe (Value a)) where+  encodeWire t = traverse_ (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++instance DecodeWire Int32 where+  decodeWire (VarintField  _ val) = pure $ fromIntegral val+  decodeWire _ = empty++instance EncodeWire Int64 where+  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++instance DecodeWire Word32 where+  decodeWire (VarintField  _ val) = pure $ fromIntegral val+  decodeWire _ = empty++instance EncodeWire Word64 where+  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)++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)++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)++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)++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++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++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))++instance DecodeWire Bool where+  decodeWire (VarintField _ val) = pure $ val /= 0+  decodeWire _ = empty++instance EncodeWire Float where+  encodeWire t val = putWireTag t 5 >> putFloat32le val++instance DecodeWire Float where+  decodeWire (Fixed32Field _ val) = pure $ wordToFloat val+  decodeWire _ = empty++instance EncodeWire Double where+  encodeWire t val = putWireTag t 1 >> putFloat64le val++instance DecodeWire Double where+  decodeWire (Fixed64Field _ val) = pure $ wordToDouble val+  decodeWire _ = empty++instance EncodeWire ByteString where+  encodeWire t val = putWireTag t 2 >> putVarUInt (B.length val) >> putByteString val++instance DecodeWire ByteString where+  decodeWire (DelimitedField _ bs) = pure bs+  decodeWire _ = empty++instance EncodeWire String where+  encodeWire t = encodeWire t . T.pack++instance DecodeWire String where+  decodeWire = fmap T.unpack . decodeWire++instance EncodeWire T.Text where+  encodeWire t = encodeWire t . T.encodeUtf8++instance DecodeWire T.Text where+  decodeWire (DelimitedField _ bs) =+    case T.decodeUtf8' bs of+      Right val -> pure val+      Left err  -> fail $ "Decoding failed: " ++ show err+  decodeWire _ = empty++instance EncodeWire (PackedList (Value Int32)) where+  encodeWire t (PackedList xs) =+    encodeWire t . runPut $ 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++instance EncodeWire (PackedList (Value Int64)) where+  encodeWire t (PackedList xs) =+    encodeWire t . runPut $ 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++instance EncodeWire (PackedList (Value Word32)) where+  encodeWire t (PackedList xs) =+    encodeWire t . runPut $ 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++instance EncodeWire (PackedList (Value Word64)) where+  encodeWire t (PackedList xs) =+    encodeWire t . runPut $ 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++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++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++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++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++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++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++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++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++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++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++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++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++instance EncodeWire (PackedList (Value Float)) where+  encodeWire t (PackedList xs) =+    encodeWire t . runPut $ 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++instance EncodeWire (PackedList (Value Double)) where+  encodeWire t (PackedList xs) =+    encodeWire t . runPut $ 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++instance EncodeWire (PackedList (Value Bool)) where+  encodeWire t (PackedList xs) =+    encodeWire t . runPut $ 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++instance (Foldable f, Enum a) => EncodeWire (Enumeration (f a)) where+  encodeWire t = traverse_ (encodeWire t . c) . runEnumeration where+    c :: a -> Int32+    c = fromIntegral . fromEnum++instance Enum a => DecodeWire (Enumeration (Maybe a)) where+  decodeWire f = c <$> decodeWire f where+    c :: Int32 -> Enumeration (Maybe a)+    c = Enumeration . Just . toEnum . fromIntegral++instance Enum a => DecodeWire (Enumeration (Always a)) where+  decodeWire f = c <$> decodeWire f where+    c :: Int32 -> Enumeration (Always a)+    c = Enumeration . Always . toEnum . fromIntegral++-- Taken from google's code, but I had to explcitly add fromIntegral in the right places:+zzEncode32 :: Int32 -> Word32+zzEncode32 x = fromIntegral ((x `shiftL` 1) `xor` x `shiftR` 31)+zzEncode64 :: Int64 -> Word64+zzEncode64 x = fromIntegral ((x `shiftL` 1) `xor` x `shiftR` 63)+zzDecode32 :: Word32 -> Int32+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))
+ tests/Main.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++import Test.Framework (Test, defaultMain, testGroup)+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit (Assertion, assert, assertEqual, assertFailure)+import Test.QuickCheck+import Test.QuickCheck.Modifiers+import Test.QuickCheck.Property++import GHC.Generics (Generic)++import Control.Applicative+import Control.Exception (SomeException, evaluate, try)+import Control.Monad+import Control.Monad.Identity+import qualified Data.ByteString as B+import Data.ByteString.Char8 ()+import Data.ProtocolBuffers as Pb+import Data.ProtocolBuffers.Internal as Pb+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Hex+import Data.Int+import Data.List+import Data.Monoid+import Data.Serialize (runGet, runPut)+import Data.Proxy+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable+import Data.Word+import Data.TypeLevel (D1, D2, D3, D4, Nat, reifyIntegral)++main :: IO ()+main = defaultMain tests++tests =+  [ testGroup "Primitive Wire" primitiveWireTests+  , testGroup "Packed Wire" packedWireTests+  , testGroup "Required Single Values" requiredSingleValueTests+  , testGroup "Optional Single Values" optionalSingleValueTests+  , testGroup "Tags Out of Range" tagsOutOfRangeTests+  , testProperty "Generic message coding" prop_generic+  , testProperty "Generic length prefixed message coding" prop_generic_length_prefixed+  , testCase "Google Reference Test1" test1+  , testCase "Google Reference Test2" test2+  , testCase "Google Reference Test3" test3+  , testCase "Google Reference Test4" test4+  , testCase "Google WireFormatTest ZigZag" wireFormatZZ+  ]++primitiveTests :: (forall a . (Eq a, Typeable a, Arbitrary a, EncodeWire a, DecodeWire a) => Proxy a -> Property) -> [Test]+primitiveTests f =+  [ testProperty "int32"    (f (Proxy :: Proxy Int32))+  , testProperty "int64"    (f (Proxy :: Proxy Int64))+  , testProperty "word32"   (f (Proxy :: Proxy Word32))+  , testProperty "word64"   (f (Proxy :: Proxy Word64))+  , testProperty "sint32"   (f (Proxy :: Proxy (Signed Int32)))+  , testProperty "sint64"   (f (Proxy :: Proxy (Signed Int64)))+  , testProperty "fixed32"  (f (Proxy :: Proxy (Pb.Fixed Word32)))+  , testProperty "fixed64"  (f (Proxy :: Proxy (Pb.Fixed Word64)))+  , testProperty "sfixed32" (f (Proxy :: Proxy (Pb.Fixed Int32)))+  , testProperty "sfixed64" (f (Proxy :: Proxy (Pb.Fixed Int64)))+  , testProperty "float"    (f (Proxy :: Proxy Float))+  , testProperty "double"   (f (Proxy :: Proxy Double))+  , testProperty "bool"     (f (Proxy :: Proxy Bool))+  ]++primitiveWireTests :: [Test]+primitiveWireTests = primitiveTests prop_wire++packedWireTests :: [Test]+packedWireTests =+  [ testProperty "int32"    (prop_wire (Proxy :: Proxy (PackedList (Value Int32))))+  , testProperty "int64"    (prop_wire (Proxy :: Proxy (PackedList (Value Int64))))+  , testProperty "word32"   (prop_wire (Proxy :: Proxy (PackedList (Value Word32))))+  , testProperty "word64"   (prop_wire (Proxy :: Proxy (PackedList (Value Word64))))+  , testProperty "sint32"   (prop_wire (Proxy :: Proxy (PackedList (Value (Signed Int32)))))+  , testProperty "sint64"   (prop_wire (Proxy :: Proxy (PackedList (Value (Signed Int64)))))+  , testProperty "fixed32"  (prop_wire (Proxy :: Proxy (PackedList (Value (Pb.Fixed Word32)))))+  , testProperty "fixed64"  (prop_wire (Proxy :: Proxy (PackedList (Value (Pb.Fixed Word64)))))+  , testProperty "sfixed32" (prop_wire (Proxy :: Proxy (PackedList (Value (Pb.Fixed Int32)))))+  , testProperty "sfixed64" (prop_wire (Proxy :: Proxy (PackedList (Value (Pb.Fixed Int64)))))+  , testProperty "float"    (prop_wire (Proxy :: Proxy (PackedList (Value Float))))+  , testProperty "double"   (prop_wire (Proxy :: Proxy (PackedList (Value Double))))+  , testProperty "bool"     (prop_wire (Proxy :: Proxy (PackedList (Value Bool))))+  ]++requiredSingleValueTests :: [Test]+requiredSingleValueTests = primitiveTests prop_req++optionalSingleValueTests :: [Test]+optionalSingleValueTests = primitiveTests prop_opt++tagsOutOfRangeTests :: [Test]+tagsOutOfRangeTests = primitiveTests prop_req_out_of_range++instance Arbitrary a => Arbitrary (Field n (RequiredField (Always (Value a)))) where+  arbitrary = putField <$> arbitrary+  shrink = fmap putField . shrink . getField++instance Arbitrary a => Arbitrary (Field n (OptionalField (Last (Value a)))) where+  arbitrary = putField <$> arbitrary+  shrink = fmap putField . shrink . getField++instance Arbitrary a => Arbitrary (Field n (RepeatedField [Value a])) where+  arbitrary = putField <$> listOf1 arbitrary+  shrink = fmap putField . shrink . getField++instance Arbitrary a => Arbitrary (PackedList a) where+  arbitrary = PackedList <$> listOf1 arbitrary+  shrink = fmap PackedList . shrink . unPackedList++instance Arbitrary a => Arbitrary (Signed a) where+  arbitrary = Signed <$> arbitrary+  shrink (Signed x) = fmap Signed $ shrink x++instance Arbitrary a => Arbitrary (Value a) where+  arbitrary = Value <$> arbitrary+  shrink (Value x) = fmap Value $ shrink x++instance Arbitrary a => Arbitrary (Pb.Fixed a) where+  arbitrary = Pb.Fixed <$> arbitrary+  shrink (Pb.Fixed x) = fmap Pb.Fixed $ shrink x++instance Arbitrary WireField where+  arbitrary = do+    tag <- choose (0, 536870912)+    oneof+      [ VarintField tag             <$> arbitrary+      , Fixed64Field tag            <$> arbitrary+      , DelimitedField tag . B.pack <$> arbitrary+      , Fixed32Field tag            <$> arbitrary+      ]++  shrink (VarintField t v)    = VarintField    <$> shrink t <*> shrink v+  shrink (Fixed64Field t v)   = Fixed64Field   <$> shrink t <*> shrink v+  shrink (DelimitedField t v) = DelimitedField <$> shrink t <*> fmap B.pack (shrink (B.unpack v))+  shrink (Fixed32Field t v)   = Fixed32Field   <$> shrink t <*> shrink v++newtype RequiredValue n a = RequiredValue (Required n (Value a))+  deriving (Eq, Generic)++instance (EncodeWire a, Nat n) => Encode (RequiredValue n a)+instance (DecodeWire a, Nat n) => Decode (RequiredValue n a)++newtype OptionalValue n a = OptionalValue (Optional n (Value a))+  deriving (Eq, Generic)++instance (EncodeWire a, Nat n) => Encode (OptionalValue n a)+instance (DecodeWire a, Nat n) => Decode (OptionalValue n a)++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)+  val <- arbitrary+  let bs = runPut (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++prop_generic :: Property+prop_generic = do+  msg <- HashMap.fromListWith (++) . fmap (\ c -> (wireFieldTag c, [c])) <$> listOf1 arbitrary+  prop_roundtrip msg++prop_generic_length_prefixed :: 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' -> printTestCase "foo" $ msg == msg'+    Left err   -> fail err++prop_roundtrip :: (Eq a, Encode a, Decode a) => a -> Property+prop_roundtrip msg = do+  let bs = runPut $ encodeMessage msg+  case runGet decodeMessage bs of+    Right msg' -> property $ msg == msg'+    Left err   -> fail err++prop_encode_fail :: Encode a => a -> Property+prop_encode_fail msg = morallyDubiousIOProperty $ do+  res <- try . evaluate . runPut $ encodeMessage msg+  return $ case res :: Either SomeException B.ByteString of+    Left  _ -> True+    Right _ -> False++prop_req_reify_out_of_range :: forall a r . a -> (forall n . Nat n => RequiredValue n a -> Gen r) -> Gen r+prop_req_reify_out_of_range a f = do+  let g :: forall n . Nat n => n -> Gen r+      g _ = f (RequiredValue (putField a) :: RequiredValue n a)+  -- according to https://developers.google.com/protocol-buffers/docs/proto+  -- the max is 2^^29 - 1, or 536,870,911.+  --+  -- the min is set to 0 since reifyIntegral only supports naturals, which+  -- is also recommended since these are encoded as varints which have+  -- fairly high overhead for negative tags+  n <- choose (536870912, maxBound)+  reifyIntegral (n :: Int32) g++prop_req_reify :: forall a r . a -> (forall n . Nat n => RequiredValue n a -> Gen r) -> Gen r+prop_req_reify a f = do+  let g :: forall n . Nat n => n -> Gen r+      g _ = f (RequiredValue (putField a) :: RequiredValue n a)+  -- according to https://developers.google.com/protocol-buffers/docs/proto+  -- the max is 2^^29 - 1, or 536,870,911.+  --+  -- the min is set to 0 since reifyIntegral only supports naturals, which+  -- is also recommended since these are encoded as varints which have+  -- fairly high overhead for negative tags+  n <- choose (0, 536870911)+  reifyIntegral (n :: Int32) g++prop_req_out_of_range :: forall a . (Arbitrary a, EncodeWire a) => Proxy a -> Property+prop_req_out_of_range _ = do+  val <- Just <$> arbitrary+  prop_req_reify_out_of_range (val :: Maybe (Value a)) prop_encode_fail++prop_req :: forall a . (Arbitrary a, Eq a, EncodeWire a, DecodeWire a, Typeable a) => Proxy a -> Property+prop_req _ = label ("prop_req :: " ++ show (typeOf (undefined :: a))) $ do+  val <- Just <$> arbitrary+  prop_req_reify (val :: Maybe (Value a)) prop_roundtrip++prop_opt_reify :: forall a r . Maybe a -> (forall n . Nat n => OptionalValue n a -> Gen r) -> Gen r+prop_opt_reify a f = do+  let g :: forall n . Nat n => n -> Gen r+      g _ = f (OptionalValue (putField a) :: OptionalValue n a)+  -- according to https://developers.google.com/protocol-buffers/docs/proto+  -- the max is 2^^29 - 1, or 536,870,911.+  --+  -- the min is set to 0 since reifyIntegral only supports naturals, which+  -- is also recommended since these are encoded as varints which have+  -- fairly high overhead for negative tags+  n <- choose (0, 536870911)+  reifyIntegral (n :: Int32) g++prop_opt :: forall a . (Arbitrary a, Eq a, EncodeWire a, DecodeWire a, Typeable a) => Proxy a -> Property+prop_opt _ = label ("prop_opt :: " ++ show (typeOf (undefined :: a))) $ do+  val <- arbitrary+  prop_opt_reify (val :: Maybe a) prop_roundtrip++-- implement the examples from https://developers.google.com/protocol-buffers/docs/encoding+testSpecific msg ref = do+  let bs = runPut $ encodeMessage msg+  assertEqual "Encoded message mismatch" bs ref++  case runGet decodeMessage bs of+    Right msg' -> assertEqual "Decoded message mismatch" msg msg'+    Left err   -> assertFailure err++data Test1 = Test1{test1_a :: Required D1 (Value Int32)} deriving (Generic)+deriving instance Eq Test1+deriving instance Show Test1+instance Encode Test1+instance Decode Test1++test1 :: Assertion+test1 = testSpecific msg =<< unhex "089601" where+  msg = Test1{test1_a = putField 150}++data Test2 = Test2{test2_b :: Required D2 (Value Text)} deriving (Generic)+deriving instance Eq Test2+deriving instance Show Test2+instance Encode Test2+instance Decode Test2++test2 :: Assertion+test2 = testSpecific msg =<< unhex "120774657374696e67" where+  msg = Test2{test2_b = putField "testing"}++data Test3 = Test3{test3_c :: Required D3 (Message Test1)} deriving (Generic, Eq, Show)+instance Encode Test3+instance Decode Test3++test3 :: Assertion+test3 = testSpecific msg =<< unhex "1a03089601" where+  msg = Test3{test3_c = putField Test1{test1_a = putField 150}}++data Test4 = Test4{test4_d :: Packed D4 (Value Word32)} deriving (Generic, Eq, Show)+instance Encode Test4+instance Decode Test4++test4 :: Assertion+test4 = testSpecific msg =<< unhex "2206038e029ea705" where+  msg = Test4{test4_d = putField [3,270,86942]}++-- some from http://code.google.com/p/protobuf/source/browse/trunk/src/google/protobuf/wire_format_unittest.cc+wireFormatZZ :: Assertion+wireFormatZZ = do+  assert $ 0 == zzEncode32   0+  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 $   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 $ 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 $   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++  -- these tests are already covered by QuickCheck properties:+  -- Some easier-to-verify round-trip tests.  The inputs (other than 0, 1, -1)+  -- were chosen semi-randomly via keyboard bashing.+  let rt32 = zzDecode32 . zzEncode32+      rt64 = zzDecode64 . zzEncode64++  assert $      0  == rt32      0+  assert $      1  == rt32      1+  assert $ (   -1) == rt32 (   -1)+  assert $  14927  == rt32  14927+  assert $ (-3612) == rt32 (-3612)++  assert $      0  == rt64      0+  assert $      1  == rt64      1+  assert $ (   -1) == rt64 (   -1)+  assert $  14927  == rt64  14927+  assert $ (-3612) == rt64 (-3612)++  assert $     856912304801416  == rt64     856912304801416+  assert $ (-75123905439571256) == rt64 (-75123905439571256)