diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,8 +5,8 @@ `protocol-buffers-descriptors`, and `hprotoc`. These are three interdependent Haskell packages originally written by Chris Kuklewicz. -Currently, maintainership was taken by Kostiantyn Rybnikov. It is -planned to only support GHC 7.8 and newer unless someone explicitly +Currently, maintainership was taken by Timo von Holtz. It is +planned to only support GHC 7.10 and newer unless someone explicitly asks for support of earlier versions. (Needs check) This README was updated most recently to reflect version @@ -299,7 +299,7 @@ ADT, so we implement the feature. In `hprotoc/oneoftest`, we have an example for this. `school.proto` defines -a collection of members in a school, which is organized into dormitories. +a collection of members in a school, which is organized into dormitories. Each member should have common attributes like `id` and `name`, but there are attributes only specific to students, faculties or administrators. @@ -308,7 +308,7 @@ Once `protocol-buffers` is installed, using `hprotoc`, we can generate Haskell source codes. Assuming we run `hprotoc` on the `oneoftest` directory and generate -source code in `hs` directory: +source code in `hs` directory: ``` oneoftest> hprotoc --proto_path=. --haskell_out=hs school.proto @@ -327,13 +327,13 @@ data Property = Prop_student {prop_student :: Student } | Prop_faculty {prop_faculty :: Faculty } | Prop_admin {prop_admin :: Admin } -``` +``` where `Student`, `Faculty` and `Admin` are defined as ordinary nested message data types in separate modules, respectively. Therefore, the `oneof` feature is smoothly matched with Haskell sum types. Note that `Maybe` will be always present for a `oneof` field in the owner data type definition (Here, `Maybe Property` in the definition of `Member`). This is because of compatibility with other language -implementations that treat `oneof` as a collection of `optional` fields. +implementations that treat `oneof` as a collection of `optional` fields. In the `oneoftest` directory, we provides a Haskell example in `hprotoc/oneoftest/hs`, modification of the previous example using lenses in `hprotoc/oneoftest/hs-lens` @@ -372,7 +372,7 @@ grade: 5 specialty: "defense of dark arts" } -} +} ``` ``` diff --git a/Text/ProtocolBuffers/Extensions.hs b/Text/ProtocolBuffers/Extensions.hs --- a/Text/ProtocolBuffers/Extensions.hs +++ b/Text/ProtocolBuffers/Extensions.hs @@ -24,7 +24,7 @@ , Key(..),ExtKey(..),MessageAPI(..) , PackedSeq(..), EP(..) -- * Internal types, functions, and classes - , wireSizeExtField,wirePutExtField,loadExtension,notExtension + , wireSizeExtField,wirePutExtField,wirePutExtFieldWithSize,loadExtension,notExtension , wireGetKeyToUnPacked, wireGetKeyToPacked , GPB,ExtField(..),ExtendMessage(..),ExtFieldValue(..) ) where @@ -693,6 +693,11 @@ aPut (fi,(ExtOptional ft (GPDyn d))) = wirePutOpt (toWireTag fi ft) ft (Just d) aPut (fi,(ExtRepeated ft (GPDynSeq s))) = wirePutRep (toWireTag fi ft) ft s aPut (fi,(ExtPacked ft (GPDynSeq s))) = wirePutPacked (toPackedWireTag fi) ft s + +-- FIXME: implement this directly +-- | This is used by the generated code +wirePutExtFieldWithSize :: ExtField -> PutM WireSize +wirePutExtFieldWithSize m = wirePutExtField m >> return (wireSizeExtField m) notExtension :: (ReflectDescriptor a, ExtendMessage a,Typeable a) => FieldId -> WireType -> a -> Get a notExtension fieldId _wireType msg = throwError ("Field id "++show fieldId++" is not a valid extension field id for "++show (typeOf (undefined `asTypeOf` msg))) diff --git a/Text/ProtocolBuffers/Header.hs b/Text/ProtocolBuffers/Header.hs --- a/Text/ProtocolBuffers/Header.hs +++ b/Text/ProtocolBuffers/Header.hs @@ -29,7 +29,8 @@ import Text.ProtocolBuffers.Basic -- all import Text.ProtocolBuffers.Extensions - ( wireSizeExtField,wirePutExtField,loadExtension,notExtension + ( wireSizeExtField,wirePutExtField,wirePutExtFieldWithSize + , loadExtension,notExtension , wireGetKeyToUnPacked, wireGetKeyToPacked , GPB,Key(..),ExtField,ExtendMessage(..),MessageAPI(..),ExtKey(wireGetKey),PackedSeq ) import Text.ProtocolBuffers.Identifiers(FIName(..),MName(..),FName(..)) @@ -38,15 +39,18 @@ , GetMessageInfo(GetMessageInfo),DescriptorInfo(extRanges),makePNF ) import Text.ProtocolBuffers.TextMessage -- all import Text.ProtocolBuffers.Unknown - ( UnknownField,UnknownMessage(..),wireSizeUnknownField,wirePutUnknownField,catch'Unknown ) + ( UnknownField,UnknownMessage(..),wireSizeUnknownField,wirePutUnknownField,wirePutUnknownFieldWithSize,catch'Unknown ) import Text.ProtocolBuffers.WireMessage ( Wire(..) , prependMessageSize,putSize,splitWireTag + , runPutM , wireSizeReq,wireSizeOpt,wireSizeRep , wirePutReq,wirePutOpt,wirePutRep - , wirePutPacked,wireSizePacked + , wirePutReqWithSize,wirePutOptWithSize,wirePutRepWithSize + , sequencePutWithSize + , wirePutPacked,wirePutPackedWithSize,wireSizePacked , getMessageWith,getBareMessageWith,wireGetEnum,wireGetPackedEnum - , wireSizeErr,wirePutErr,wireGetErr + , wireSizeErr,wirePutErr,wireGetErr,size'WireSize , unknown,unknownField , fieldIdOf) diff --git a/Text/ProtocolBuffers/Unknown.hs b/Text/ProtocolBuffers/Unknown.hs --- a/Text/ProtocolBuffers/Unknown.hs +++ b/Text/ProtocolBuffers/Unknown.hs @@ -4,7 +4,7 @@ -- notice. Importer beware. module Text.ProtocolBuffers.Unknown ( UnknownField(..),UnknownMessage(..),UnknownFieldValue(..) - , wireSizeUnknownField,wirePutUnknownField,catch'Unknown + , wireSizeUnknownField,wirePutUnknownField, wirePutUnknownFieldWithSize,catch'Unknown ) where import qualified Data.ByteString.Lazy as L @@ -52,6 +52,11 @@ wirePutUnknownField :: UnknownField -> Put wirePutUnknownField (UnknownField m) = F.mapM_ aPut m where aPut (UFV tag bs) = putVarUInt (getWireTag tag) >> putLazyByteString bs + +-- | This is used by the generated code +wirePutUnknownFieldWithSize :: UnknownField -> PutM WireSize +wirePutUnknownFieldWithSize m = + wirePutUnknownField m >> return (wireSizeUnknownField m) {-# INLINE catch'Unknown #-} -- | This is used by the generated code diff --git a/Text/ProtocolBuffers/WireMessage.hs b/Text/ProtocolBuffers/WireMessage.hs --- a/Text/ProtocolBuffers/WireMessage.hs +++ b/Text/ProtocolBuffers/WireMessage.hs @@ -21,14 +21,16 @@ -- ** Encoding to write or read a single message field (good for delimited messages or incremental use) , messageAsFieldSize,messageAsFieldPutM,messageAsFieldGetM -- ** The Put monad from the binary package, and a custom binary Get monad ("Text.ProtocolBuffers.Get") - , Put,Get,runPut,runGet,runGetOnLazy,getFromBS + , Put,PutM,Get,runPut,runPutM,runGet,runGetOnLazy,getFromBS -- * The Wire monad itself. Users should beware that passing an incompatible 'FieldType' is a runtime error or fail , Wire(..) -- * The internal exports, for use by generated code and the "Text.ProtcolBuffer.Extensions" module - , size'WireTag,toWireType,toWireTag,toPackedWireTag,mkWireTag + , size'WireTag,size'WireSize,toWireType,toWireTag,toPackedWireTag,mkWireTag , prependMessageSize,putSize,putVarUInt,getVarInt,putLazyByteString,splitWireTag,fieldIdOf , wireSizeReq,wireSizeOpt,wireSizeRep,wireSizePacked , wirePutReq,wirePutOpt,wirePutRep,wirePutPacked + , wirePutReqWithSize,wirePutOptWithSize,wirePutRepWithSize,wirePutPackedWithSize + , sequencePutWithSize , wireSizeErr,wirePutErr,wireGetErr , getMessageWith,getBareMessageWith,wireGetEnum,wireGetPackedEnum , unknownField,unknown,wireGetFromWire @@ -36,7 +38,7 @@ , zzEncode64,zzEncode32,zzDecode64,zzDecode32 ) where -import Control.Monad(when) +import Control.Monad(when,foldM) import Control.Monad.Error.Class(throwError) import Control.Monad.ST import Data.Array.ST(newArray,readArray) @@ -45,7 +47,7 @@ --import qualified Data.ByteString as S(last) --import qualified Data.ByteString.Unsafe as S(unsafeIndex) import qualified Data.ByteString.Lazy as BS (length) -import qualified Data.Foldable as F(foldl',forM_) +import qualified Data.Foldable as F(foldl', Foldable) --import Data.List (genericLength) import Data.Maybe(fromMaybe) import Data.Sequence ((|>)) @@ -57,7 +59,7 @@ --import GHC.Exts (Double(D#),Float(F#),unsafeCoerce#) --import GHC.Word (Word64(W64#)) -- ,Word32(W32#)) -- binary package -import Data.Binary.Put (Put,runPut,putWord8,putWord32le,putWord64le,putLazyByteString) +import Data.Binary.Put (Put,PutM,runPutM,runPut,putWord8,putWord32le,putWord64le,putLazyByteString) import Text.ProtocolBuffers.Basic import Text.ProtocolBuffers.Get as Get (Result(..),Get,runGet,runGetAll,bytesRead,isReallyEmpty,decode7unrolled @@ -179,7 +181,7 @@ Left msg -> error msg Right (r,_) -> r --- This is like 'runGet', without the ability to pass in more input +-- | This is like 'runGet', without the ability to pass in more input -- beyond the initial ByteString. Thus the 'ByteString' argument is -- taken to be the entire input. To be able to incrementally feed in -- more input you should use 'runGet' and respond to 'Partial' @@ -195,33 +197,68 @@ prependMessageSize :: WireSize -> WireSize prependMessageSize n = n + size'WireSize n +{-# INLINE sequencePutWithSize #-} +-- | Used in generated code. +sequencePutWithSize :: F.Foldable f => f (PutM WireSize) -> PutM WireSize +sequencePutWithSize = + let combine size act = + do size2 <- act + return $! size + size2 + in foldM combine 0 + +{-# INLINE wirePutReqWithSize #-} +-- | Used in generated code. +wirePutReqWithSize :: Wire v => WireTag -> FieldType -> v -> PutM WireSize +wirePutReqWithSize wireTag fieldType v = + let startTag = getWireTag wireTag + endTag = succ startTag + putTag tag = putVarUInt tag >> return (size'Word32 tag) + putAct = wirePutWithSize fieldType v + in case fieldType of + 10 -> sequencePutWithSize [putTag startTag, putAct, putTag endTag] + _ -> sequencePutWithSize [putTag startTag, putAct] + +{-# INLINE wirePutOptWithSize #-} +-- | Used in generated code. +wirePutOptWithSize :: Wire v => WireTag -> FieldType -> Maybe v -> PutM WireSize +wirePutOptWithSize _wireTag _fieldType Nothing = return 0 +wirePutOptWithSize wireTag fieldType (Just v) = wirePutReqWithSize wireTag fieldType v + +{-# INLINE wirePutRepWithSize #-} +-- | Used in generated code. +wirePutRepWithSize :: Wire v => WireTag -> FieldType -> Seq v -> PutM WireSize +wirePutRepWithSize wireTag fieldType vs = + sequencePutWithSize $ fmap (wirePutReqWithSize wireTag fieldType) vs + +{-# INLINE wirePutPackedWithSize #-} +-- | Used in generated code. +wirePutPackedWithSize :: Wire v => WireTag -> FieldType -> Seq v -> PutM WireSize +wirePutPackedWithSize wireTag fieldType vs = + let actInner = sequencePutWithSize $ fmap (wirePutWithSize fieldType) vs + (size, _) = runPutM actInner -- This should be lazy enough not to allocate the ByteString + tagSize = size'WireTag wireTag + putTag tag = putVarUInt (getWireTag tag) >> return tagSize + in sequencePutWithSize [putTag wireTag, putSize size>>return (size'WireSize size), actInner] + {-# INLINE wirePutReq #-} -- | Used in generated code. wirePutReq :: Wire v => WireTag -> FieldType -> v -> Put -wirePutReq wireTag 10 v = let startTag = getWireTag wireTag - endTag = succ startTag - in putVarUInt startTag >> wirePut 10 v >> putVarUInt endTag -wirePutReq wireTag fieldType v = putVarUInt (getWireTag wireTag) >> wirePut fieldType v +wirePutReq wireTag fieldType v = wirePutReqWithSize wireTag fieldType v >> return () {-# INLINE wirePutOpt #-} -- | Used in generated code. wirePutOpt :: Wire v => WireTag -> FieldType -> Maybe v -> Put -wirePutOpt _wireTag _fieldType Nothing = return () -wirePutOpt wireTag fieldType (Just v) = wirePutReq wireTag fieldType v +wirePutOpt wireTag fieldType v = wirePutOptWithSize wireTag fieldType v >> return () {-# INLINE wirePutRep #-} -- | Used in generated code. wirePutRep :: Wire v => WireTag -> FieldType -> Seq v -> Put -wirePutRep wireTag fieldType vs = F.forM_ vs (\v -> wirePutReq wireTag fieldType v) +wirePutRep wireTag fieldType vs = wirePutRepWithSize wireTag fieldType vs >> return () {-# INLINE wirePutPacked #-} -- | Used in generated code. wirePutPacked :: Wire v => WireTag -> FieldType -> Seq v -> Put -wirePutPacked wireTag fieldType vs = do - putVarUInt (getWireTag wireTag) - let size = F.foldl' (\n v -> n + wireSize fieldType v) 0 vs - putSize size - F.forM_ vs (\v -> wirePut fieldType v) +wirePutPacked wireTag fieldType vs = wirePutPackedWithSize wireTag fieldType vs >> return () {-# INLINE wireSizeReq #-} -- | Used in generated code. @@ -431,7 +468,7 @@ wireSizeErr :: Typeable a => FieldType -> a -> WireSize wireSizeErr ft x = error $ concat [ "Impossible? wireSize field type mismatch error: Field type number ", show ft , " does not match internal type ", show (typeOf x) ] -wirePutErr :: Typeable a => FieldType -> a -> Put +wirePutErr :: Typeable a => FieldType -> a -> PutM b wirePutErr ft x = fail $ concat [ "Impossible? wirePut field type mismatch error: Field type number ", show ft , " does not match internal type ", show (typeOf x) ] wireGetErr :: Typeable a => FieldType -> Get a @@ -449,8 +486,14 @@ -- "Text.ProtocolBuffers.WireMessage" and exported to use user by -- "Text.ProtocolBuffers". These are less likely to change. class Wire b where + {-# MINIMAL wireGet, wireSize, (wirePut | wirePutWithSize) #-} wireSize :: FieldType -> b -> WireSize + {-# INLINE wirePut #-} wirePut :: FieldType -> b -> Put + wirePut ft x = wirePutWithSize ft x >> return () + {-# INLINE wirePutWithSize #-} + wirePutWithSize :: FieldType -> b -> PutM WireSize + wirePutWithSize ft x = wirePut ft x >> return (wireSize ft x) wireGet :: FieldType -> Get b {-# INLINE wireGetPacked #-} wireGetPacked :: FieldType -> Get (Seq b) diff --git a/protocol-buffers.cabal b/protocol-buffers.cabal --- a/protocol-buffers.cabal +++ b/protocol-buffers.cabal @@ -1,12 +1,12 @@ name: protocol-buffers -version: 2.4.10 +version: 2.4.11 cabal-version: >= 1.6 build-type: Simple license: BSD3 license-file: LICENSE copyright: (c) 2008-2015 Christopher Edward Kuklewicz author: Christopher Edward Kuklewicz -maintainer: Kostiantyn Rybnikov +maintainer: Timo von Holtz , Kostiantyn Rybnikov homepage: https://github.com/k-bx/protocol-buffers package-url: http://hackage.haskell.org/package/protocol-buffers synopsis: Parse Google Protocol Buffer specifications @@ -20,7 +20,7 @@ Library -- Added -fspec-constr-count=10 to quiet ghc-7.0.2. - ghc-options: -Wall -O2 -fspec-constr-count=10 + ghc-options: -Wall -O2 -fspec-constr-count=10 -- ghc-prof-options: -auto-all -prof exposed-modules: Text.ProtocolBuffers Text.ProtocolBuffers.Basic