diff --git a/README b/README --- a/README +++ b/README @@ -1,11 +1,17 @@ This the README file for protocol-buffers, protocol-buffers-descriptors, and hprotoc. These are three interdependent Haskell packages by Chris Kuklewicz. -This README was updated most recently to reflect version 1.8.0 +This README was updated most recently to reflect version 2.0.7 This code should be compatible with Google protobuf version 2.3.0 Changes to keep up with Google protobuf version 2.4.0 are being considered. Questions and answers: + +Whats up with version 2.0.7 ? + +Version 2.0.5 and 2.0.6 had compile problems with GHC 7.4, this is now warning-free (as free as possible). + +The lack of a package name caused problems. Hopefully the new handling works for everyone. What is new in 1.8.0 ? diff --git a/Text/ProtocolBuffers/Extensions.hs b/Text/ProtocolBuffers/Extensions.hs --- a/Text/ProtocolBuffers/Extensions.hs +++ b/Text/ProtocolBuffers/Extensions.hs @@ -32,14 +32,14 @@ import Control.Monad.Error.Class(throwError) import qualified Data.ByteString.Lazy as L import qualified Data.Foldable as F -import Data.Generics import Data.Map(Map) import qualified Data.Map as M import Data.Maybe(fromMaybe,isJust) import Data.Monoid(mappend,mconcat) import Data.Sequence((|>),(><),viewl,ViewL(..)) import qualified Data.Sequence as Seq(singleton,null,empty) -import Data.Typeable() +import Data.Typeable(Typeable(typeOf),Typeable1(typeOf1),Typeable2(typeOf2),TypeRep,mkTyConApp,mkTyCon3,cast) +import Data.Data(Data(gfoldl,gunfold,toConstr),Constr,DataType,Fixity(Prefix),mkDataType,mkConstr,constrIndex,dataTypeOf) import Text.ProtocolBuffers.Basic import Text.ProtocolBuffers.WireMessage @@ -98,7 +98,7 @@ getKeyDefaultValue (Key _ _ md) = fromMaybe defaultValue md instance Typeable1 c => Typeable2 (Key c) where - typeOf2 _ = mkTyConApp (mkTyCon "Text.ProtocolBuffers.Extensions.Key") [typeOf1 (undefined :: c ())] + typeOf2 _ = mkTyConApp (mkTyCon3 "protocol-buffers" "Text.ProtocolBuffers.Extensions" "Key") [typeOf1 (undefined :: c ())] instance (Typeable1 c, Typeable msg, Typeable v) => Show (Key c msg v) where show key@(Key fieldId fieldType maybeDefaultValue) = @@ -136,12 +136,61 @@ | ExtRepeated !FieldType !GPDynSeq | ExtPacked !FieldType !GPDynSeq deriving (Typeable,Ord,Show) + +-- For making a Data instance for ExtField +data ExtDataPair = ExtDataPair FieldId (Seq EP) + deriving (Typeable,Data,Show) data EP = EP {-# UNPACK #-} !WireType !ByteString - deriving (Typeable,Eq,Ord,Show) + deriving (Typeable,Data,Eq,Ord,Show) data DummyMessageType deriving (Typeable) +-- | ExtField is a newtype'd map from the numeric FieldId key to the +-- ExtFieldValue. This allows for the needed class instances. +newtype ExtField = ExtField (Map FieldId ExtFieldValue) + deriving (Eq,Ord,Show) + +-- Used only in gfoldl for Data instance of ExtField +dataToList :: ExtField -> [ExtDataPair] +dataToList (ExtField ef) = map toEDP . M.toList $ ef where + toEDP (fi,ExtFromWire eps) = ExtDataPair fi eps + toEDP (fi,ExtOptional ft (GPDyn GPWitness d)) = + let p = wirePutOpt (toWireTag fi ft) ft (Just d) + ep = EP (toWireType ft) (runPut p) + in ExtDataPair fi (Seq.singleton ep) + toEDP (fi,ExtRepeated ft (GPDynSeq GPWitness s)) = + let f :: forall w. Wire w => w -> EP + f = EP (toWireType ft) . runPut . wirePutReq (toWireTag fi ft) ft + in ExtDataPair fi (fmap f s) + toEDP (fi,ExtPacked ft (GPDynSeq GPWitness s)) = + let p = wirePutPacked (toPackedWireTag fi) ft s + ep = EP (snd. splitWireTag $ toPackedWireTag fi) (runPut p) + in ExtDataPair fi (Seq.singleton ep) + +-- Used only in gfoldl and gunfold for Data instance of ExtField +dataFromList :: [ExtDataPair] -> ExtField +dataFromList = ExtField . M.fromList . map fromEDP where + fromEDP (ExtDataPair fid eps) = (fid,ExtFromWire eps) + +instance Typeable ExtField where + typeOf _ = tr_ExtField + +tr_ExtField :: TypeRep +tr_ExtField = mkTyConApp (mkTyCon3 "protocol-buffers" "Text.ProtocolBuffers.Extensions" "ExtField") [] + +ty_ExtField :: DataType +ty_ExtField = mkDataType "Text.ProtocolBuffers.Extensions.ExtField" [con_ExtField] +con_ExtField :: Constr +con_ExtField = mkConstr ty_ExtField "ExtField" [] Prefix + +instance Data ExtField where + gfoldl f z m = z dataFromList `f` dataToList m + gunfold k z c = case constrIndex c of + _ -> k (z dataFromList) + toConstr (ExtField _) = con_ExtField + dataTypeOf _ = ty_ExtField + instance ExtendMessage DummyMessageType where getExtField = undefined putExtField = undefined @@ -189,11 +238,6 @@ (==) y@(ExtFromWire {}) x@(ExtPacked {}) = x == y (==) _ _ = False --- | ExtField is a newtype'd map from the numeric FieldId key to the --- ExtFieldValue. This allows for the needed class instances. -newtype ExtField = ExtField (Map FieldId ExtFieldValue) - deriving (Typeable,Eq,Ord,Show) - -- | 'ExtendMessage' abstracts the operations of storing and -- retrieving the 'ExtField' from the message, and provides the -- reflection needed to know the valid field numbers. @@ -203,7 +247,6 @@ getExtField :: msg -> ExtField putExtField :: ExtField -> msg -> msg validExtRanges :: msg -> [(FieldId,FieldId)] - -- wireKeyToUnPacked is used to load a repeated packed format into a repeated non-packed extension key -- wireKeyToPacked is used to load a repeated unpacked format into a repeated packed extension key diff --git a/Text/ProtocolBuffers/Get.hs b/Text/ProtocolBuffers/Get.hs --- a/Text/ProtocolBuffers/Get.hs +++ b/Text/ProtocolBuffers/Get.hs @@ -85,7 +85,7 @@ import Data.Sequence(Seq,null,(|>)) -- used for future queue in handler state import Data.Word(Word,Word8,Word16,Word32,Word64) import Foreign.ForeignPtr(withForeignPtr) -import Foreign.Ptr(Ptr,castPtr,plusPtr,minusPtr) +import Foreign.Ptr(Ptr,castPtr,plusPtr,minusPtr,nullPtr) import Foreign.Storable(Storable(peek,sizeOf)) import System.IO.Unsafe(unsafePerformIO) #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) @@ -185,6 +185,9 @@ {-# INLINE ok #-} {-# INLINE more #-} {-# INLINE err #-} + + -- Next line is segfault fix for null bytestrings from Nathan Howell + if ptr0 == nullPtr then more else do let start = ptr0 `plusPtr` off :: Ptr Word8 b'1 <- peek start diff --git a/Text/ProtocolBuffers/Header.hs b/Text/ProtocolBuffers/Header.hs --- a/Text/ProtocolBuffers/Header.hs +++ b/Text/ProtocolBuffers/Header.hs @@ -7,7 +7,6 @@ , fromDistinctAscList, member , throwError,catchError , module Data.Generics - , module Data.Typeable , module Text.ProtocolBuffers.Basic , module Text.ProtocolBuffers.Extensions , module Text.ProtocolBuffers.Identifiers @@ -24,7 +23,6 @@ import Data.Maybe(fromMaybe) import Data.Sequence((|>)) -- for append, see below import Data.Set(fromDistinctAscList,member) -import Data.Typeable(Typeable(..)) import Text.ProtocolBuffers.Basic -- all import Text.ProtocolBuffers.Extensions diff --git a/Text/ProtocolBuffers/WireMessage.hs b/Text/ProtocolBuffers/WireMessage.hs --- a/Text/ProtocolBuffers/WireMessage.hs +++ b/Text/ProtocolBuffers/WireMessage.hs @@ -39,7 +39,8 @@ import Control.Monad(when) import Control.Monad.Error.Class(throwError) import Control.Monad.ST -import Data.Array.ST +import Data.Array.ST(newArray,readArray) +import Data.Array.Unsafe(castSTUArray) import Data.Bits (Bits(..)) --import qualified Data.ByteString as S(last) --import qualified Data.ByteString.Unsafe as S(unsafeIndex) @@ -448,11 +449,8 @@ -- "Text.ProtocolBuffers.WireMessage" and exported to use user by -- "Text.ProtocolBuffers". These are less likely to change. class Wire b where - {-# INLINE wireSize #-} wireSize :: FieldType -> b -> WireSize - {-# INLINE wirePut #-} wirePut :: FieldType -> b -> Put - {-# INLINE wireGet #-} wireGet :: FieldType -> Get b {-# INLINE wireGetPacked #-} wireGetPacked :: FieldType -> Get (Seq b) @@ -461,95 +459,122 @@ ++ ".\n Either there is a bug in this library or the wire format is has been updated.") instance Wire Double where + {-# INLINE wireSize #-} wireSize {- TYPE_DOUBLE -} 1 _ = 8 wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} wirePut {- TYPE_DOUBLE -} 1 x = putWord64le (castDoubleToWord64 x) wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} wireGet {- TYPE_DOUBLE -} 1 = fmap castWord64ToDouble getWord64le wireGet ft = wireGetErr ft + {-# INLINE wireGetPacked #-} wireGetPacked 1 = genericPacked 1 wireGetPacked ft = wireGetErr ft instance Wire Float where + {-# INLINE wireSize #-} wireSize {- TYPE_FLOAT -} 2 _ = 4 wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} wirePut {- TYPE_FLOAT -} 2 x = putWord32le (castFloatToWord32 x) wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} wireGet {- TYPE_FLOAT -} 2 = fmap castWord32ToFloat getWord32le wireGet ft = wireGetErr ft + {-# INLINE wireGetPacked #-} wireGetPacked 2 = genericPacked 2 wireGetPacked ft = wireGetErr ft instance Wire Int64 where + {-# INLINE wireSize #-} wireSize {- TYPE_INT64 -} 3 x = size'Int64 x wireSize {- TYPE_SINT64 -} 18 x = size'Word64 (zzEncode64 x) wireSize {- TYPE_SFIXED64 -} 16 _ = 8 wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} wirePut {- TYPE_INT64 -} 3 x = putVarSInt x wirePut {- TYPE_SINT64 -} 18 x = putVarUInt (zzEncode64 x) wirePut {- TYPE_SFIXED64 -} 16 x = putWord64le (fromIntegral x) wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} wireGet {- TYPE_INT64 -} 3 = getVarInt wireGet {- TYPE_SINT64 -} 18 = fmap zzDecode64 getVarInt wireGet {- TYPE_SFIXED64 -} 16 = fmap fromIntegral getWord64le wireGet ft = wireGetErr ft + {-# INLINE wireGetPacked #-} wireGetPacked 3 = genericPacked 3 wireGetPacked 18 = genericPacked 18 wireGetPacked 16 = genericPacked 16 wireGetPacked ft = wireGetErr ft instance Wire Int32 where + {-# INLINE wireSize #-} wireSize {- TYPE_INT32 -} 5 x = size'Int32 x wireSize {- TYPE_SINT32 -} 17 x = size'Word32 (zzEncode32 x) wireSize {- TYPE_SFIXED32 -} 15 _ = 4 wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} wirePut {- TYPE_INT32 -} 5 x = putVarSInt x wirePut {- TYPE_SINT32 -} 17 x = putVarUInt (zzEncode32 x) wirePut {- TYPE_SFIXED32 -} 15 x = putWord32le (fromIntegral x) wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} wireGet {- TYPE_INT32 -} 5 = getVarInt wireGet {- TYPE_SINT32 -} 17 = fmap zzDecode32 getVarInt wireGet {- TYPE_SFIXED32 -} 15 = fmap fromIntegral getWord32le wireGet ft = wireGetErr ft + {-# INLINE wireGetPacked #-} wireGetPacked 5 = genericPacked 5 wireGetPacked 17 = genericPacked 17 wireGetPacked 15 = genericPacked 15 wireGetPacked ft = wireGetErr ft instance Wire Word64 where + {-# INLINE wireSize #-} wireSize {- TYPE_UINT64 -} 4 x = size'Word64 x wireSize {- TYPE_FIXED64 -} 6 _ = 8 wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} wirePut {- TYPE_UINT64 -} 4 x = putVarUInt x wirePut {- TYPE_FIXED64 -} 6 x = putWord64le x wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} wireGet {- TYPE_FIXED64 -} 6 = getWord64le wireGet {- TYPE_UINT64 -} 4 = getVarInt wireGet ft = wireGetErr ft + {-# INLINE wireGetPacked #-} wireGetPacked 6 = genericPacked 6 wireGetPacked 4 = genericPacked 4 wireGetPacked ft = wireGetErr ft instance Wire Word32 where + {-# INLINE wireSize #-} wireSize {- TYPE_UINT32 -} 13 x = size'Word32 x wireSize {- TYPE_FIXED32 -} 7 _ = 4 wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} wirePut {- TYPE_UINT32 -} 13 x = putVarUInt x wirePut {- TYPE_FIXED32 -} 7 x = putWord32le x wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} wireGet {- TYPE_UINT32 -} 13 = getVarInt wireGet {- TYPE_FIXED32 -} 7 = getWord32le wireGet ft = wireGetErr ft + {-# INLINE wireGetPacked #-} wireGetPacked 13 = genericPacked 13 wireGetPacked 7 = genericPacked 7 wireGetPacked ft = wireGetErr ft instance Wire Bool where + {-# INLINE wireSize #-} wireSize {- TYPE_BOOL -} 8 _ = 1 wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} wirePut {- TYPE_BOOL -} 8 False = putWord8 0 wirePut {- TYPE_BOOL -} 8 True = putWord8 1 -- google's wire_format_lite_inl.h wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} wireGet {- TYPE_BOOL -} 8 = do x <- getVarInt :: Get Int32 -- google's wire_format_lit_inl.h line 155 case x of @@ -558,35 +583,46 @@ -- x' | x' < 128 -> return True -- _ -> throwError ("TYPE_BOOL read failure : " ++ show x) wireGet ft = wireGetErr ft + {-# INLINE wireGetPacked #-} wireGetPacked 8 = genericPacked 8 wireGetPacked ft = wireGetErr ft instance Wire Utf8 where -- items of TYPE_STRING is already in a UTF8 encoded Data.ByteString.Lazy + {-# INLINE wireSize #-} wireSize {- TYPE_STRING -} 9 x = prependMessageSize $ BS.length (utf8 x) wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} wirePut {- TYPE_STRING -} 9 x = putVarUInt (BS.length (utf8 x)) >> putLazyByteString (utf8 x) wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} wireGet {- TYPE_STRING -} 9 = getVarInt >>= getLazyByteString >>= verifyUtf8 wireGet ft = wireGetErr ft instance Wire ByteString where -- items of TYPE_BYTES is an untyped binary Data.ByteString.Lazy + {-# INLINE wireSize #-} wireSize {- TYPE_BYTES -} 12 x = prependMessageSize $ BS.length x wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} wirePut {- TYPE_BYTES -} 12 x = putVarUInt (BS.length x) >> putLazyByteString x wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} wireGet {- TYPE_BYTES -} 12 = getVarInt >>= getLazyByteString wireGet ft = wireGetErr ft -- Wrap a protocol-buffer Enum in fromEnum or toEnum and serialize the Int: instance Wire Int where + {-# INLINE wireSize #-} wireSize {- TYPE_ENUM -} 14 x = size'Int x wireSize ft x = wireSizeErr ft x + {-# INLINE wirePut #-} wirePut {- TYPE_ENUM -} 14 x = putVarSInt x wirePut ft x = wirePutErr ft x + {-# INLINE wireGet #-} wireGet {- TYPE_ENUM -} 14 = getVarInt wireGet ft = wireGetErr ft + {-# INLINE wireGetPacked #-} wireGetPacked 14 = genericPacked 14 -- Should not actually be used, see wireGetPackedEnum, though this ought to work if it were used (e.g. genericPacked) wireGetPacked ft = wireGetErr ft diff --git a/protocol-buffers.cabal b/protocol-buffers.cabal --- a/protocol-buffers.cabal +++ b/protocol-buffers.cabal @@ -1,5 +1,5 @@ name: protocol-buffers -version: 2.0.6 +version: 2.0.7 cabal-version: >= 1.6 build-type: Simple license: BSD3 @@ -13,7 +13,7 @@ synopsis: Parse Google Protocol Buffer specifications description: Parse proto files and generate Haskell code. category: Text -Tested-With: GHC == 7.0.3 +Tested-With: GHC == 7.4.1 extra-source-files: TODO README