protobuf 0.1.2 → 0.1.3
raw patch · 5 files changed
+52/−247 lines, 5 filesdep −haskell-src-extsdep ~bytestringdep ~cerealdep ~mtl
Dependencies removed: haskell-src-exts
Dependency ranges changed: bytestring, cereal, mtl, text, type-level, unordered-containers
Files
- plugin/Main.hs +0/−219
- protobuf.cabal +2/−22
- src/Data/ProtocolBuffers/Decode.hs +2/−2
- src/Data/ProtocolBuffers/Orphans.hs +17/−0
- tests/Main.hs +31/−4
− plugin/Main.hs
@@ -1,219 +0,0 @@-{-# 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
@@ -1,5 +1,5 @@ name: protobuf-version: 0.1.2+version: 0.1.3 synopsis: Google Protocol Buffers via GHC.Generics description: Google Protocol Buffers via GHC.Generics.@@ -36,6 +36,7 @@ exposed-modules: Data.ProtocolBuffers Data.ProtocolBuffers.Internal+ Data.ProtocolBuffers.Orphans other-modules: Data.ProtocolBuffers.Decode Data.ProtocolBuffers.Encode@@ -55,27 +56,6 @@ 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
src/Data/ProtocolBuffers/Decode.hs view
@@ -36,12 +36,12 @@ -- Decode a Protocol Buffers message. decodeMessage :: Decode a => Get a {-# INLINE decodeMessage #-}-decodeMessage = decode =<< go HashMap.empty where+decodeMessage = decode =<< HashMap.map reverse <$> 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+ Just v -> go $! HashMap.insertWith (\(x:[]) xs -> x:xs) (wireFieldTag v) [v] msg Nothing -> return msg -- |
+ src/Data/ProtocolBuffers/Orphans.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Messages containing 'Optional' 'Enumeration' fields fail to encode.+-- This module contains orphan instances required to make these functional.+--+-- For more information reference the associated ticket:+-- <https://github.com/alphaHeavy/protobuf/issues/3>++module Data.ProtocolBuffers.Orphans (Foldable) where++import Data.Foldable (Foldable)+import Data.Monoid (Last(..))++deriving instance Foldable Last
tests/Main.hs view
@@ -9,13 +9,13 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} 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)@@ -23,7 +23,6 @@ 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@@ -32,12 +31,10 @@ 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)@@ -51,11 +48,13 @@ | EnumFoo3 deriving (Bounded, Enum, Eq, Typeable) +tests :: [Test] tests = [ testGroup "Primitive Wire" primitiveWireTests , testGroup "Packed Wire" packedWireTests , testGroup "Required Single Values" requiredSingleValueTests , testGroup "Optional Single Values" optionalSingleValueTests+ , testGroup "Repeated Single Values" repeatedSingleValueTests , testGroup "Tags Out of Range" tagsOutOfRangeTests , testProperty "Generic message coding" prop_generic , testProperty "Generic length prefixed message coding" prop_generic_length_prefixed@@ -110,6 +109,9 @@ optionalSingleValueTests :: [Test] optionalSingleValueTests = primitiveTests prop_opt +repeatedSingleValueTests :: [Test]+repeatedSingleValueTests = primitiveTests prop_repeated+ tagsOutOfRangeTests :: [Test] tagsOutOfRangeTests = primitiveTests prop_req_out_of_range @@ -176,6 +178,12 @@ instance (EncodeWire a, Nat n) => Encode (OptionalValue n a) instance (DecodeWire a, Nat n) => Decode (OptionalValue n a) +newtype RepeatedValue n a = RepeatedValue (Repeated n (Value a))+ deriving (Eq, Generic)++instance (EncodeWire a, Nat n) => Encode (RepeatedValue n a)+instance (DecodeWire a, Nat n) => Decode (RepeatedValue 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)@@ -252,6 +260,24 @@ val <- Just <$> arbitrary prop_req_reify (val :: Maybe (Value a)) prop_roundtrip +prop_repeated_reify :: forall a r . [a] -> (forall n . Nat n => RepeatedValue n a -> Gen r) -> Gen r+prop_repeated_reify a f = do+ let g :: forall n . Nat n => n -> Gen r+ g _ = f (RepeatedValue (putField a) :: RepeatedValue 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_repeated :: forall a . (Arbitrary a, Eq a, EncodeWire a, DecodeWire a, Typeable a) => Proxy a -> Property+prop_repeated _ = label ("prop_repeated :: " ++ show (typeOf (undefined :: a))) $ do+ val <- arbitrary+ prop_repeated_reify (val :: [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@@ -271,6 +297,7 @@ prop_opt_reify (val :: Maybe a) prop_roundtrip -- implement the examples from https://developers.google.com/protocol-buffers/docs/encoding+testSpecific :: (Eq a, Show a, Encode a, Decode a) => a -> B.ByteString -> IO () testSpecific msg ref = do let bs = runPut $ encodeMessage msg assertEqual "Encoded message mismatch" bs ref