protocol-buffers 1.8.3 → 2.0.0
raw patch · 12 files changed
+254/−390 lines, 12 filesdep −QuickCheckdep −haskell-srcdep −parsec
Dependencies removed: QuickCheck, haskell-src, parsec
Files
- Text/ProtocolBuffers.hs +4/−8
- Text/ProtocolBuffers/Basic.hs +59/−36
- Text/ProtocolBuffers/Default.hs +0/−18
- Text/ProtocolBuffers/Extensions.hs +20/−17
- Text/ProtocolBuffers/Get.hs +57/−20
- Text/ProtocolBuffers/Header.hs +2/−3
- Text/ProtocolBuffers/Identifiers.hs +1/−0
- Text/ProtocolBuffers/Mergeable.hs +0/−32
- Text/ProtocolBuffers/Reflections.hs +2/−0
- Text/ProtocolBuffers/Unknown.hs +5/−4
- Text/ProtocolBuffers/WireMessage.hs +67/−232
- protocol-buffers.cabal +37/−20
Text/ProtocolBuffers.hs view
@@ -7,18 +7,16 @@ import Text.ProtocolBuffers.Basic ( Seq,isValidUTF8,toUtf8,utf8,Utf8(Utf8),Int32,Int64,Word32,Word64 , WireTag,FieldId,WireType,FieldType,EnumCode,WireSize- , Mergeable(mergeEmpty,mergeAppend,mergeConcat),Default(defaultValue),Wire)-import Text.ProtocolBuffers.Default()+ , Mergeable(mergeAppend,mergeConcat),Default(defaultValue)) import Text.ProtocolBuffers.Extensions ( Key,ExtKey(getExt,putExt,clearExt),MessageAPI(getVal,isSet) , getKeyFieldId,getKeyFieldType,getKeyDefaultValue) import Text.ProtocolBuffers.Identifiers-import Text.ProtocolBuffers.Mergeable() import Text.ProtocolBuffers.Reflections ( ReflectDescriptor(..),ReflectEnum(..),ProtoName(..),HsDefault(..),EnumInfoApp , KeyInfo,FieldInfo(..),DescriptorInfo(..),EnumInfo(..),ProtoInfo(..),makePNF ) import Text.ProtocolBuffers.WireMessage- ( Put,Get,runPut,runGet,runGetOnLazy+ ( Wire,Put,Get,runPut,runGet,runGetOnLazy , messageSize,messagePut,messageGet,messagePutM,messageGetM , messageWithLengthSize,messageWithLengthPut,messageWithLengthGet,messageWithLengthPutM,messageWithLengthGetM , messageAsFieldSize,messageAsFieldPutM,messageAsFieldGetM)@@ -51,18 +49,16 @@ import Text.ProtocolBuffers.Basic ( Seq,isValidUTF8,toUtf8,utf8,Utf8(Utf8),Int32,Int64,Word32,Word64 , WireTag,FieldId,WireType,FieldType,EnumCode,WireSize- , Mergeable(mergeEmpty,mergeAppend,mergeConcat),Default(defaultValue),Wire)-import Text.ProtocolBuffers.Default()+ , Mergeable(mergeAppend,mergeConcat),Default(defaultValue)) import Text.ProtocolBuffers.Extensions ( Key,ExtKey(getExt,putExt,clearExt),MessageAPI(getVal,isSet) , getKeyFieldId,getKeyFieldType,getKeyDefaultValue) import Text.ProtocolBuffers.Identifiers-import Text.ProtocolBuffers.Mergeable() import Text.ProtocolBuffers.Reflections ( ReflectDescriptor(..),ReflectEnum(..),ProtoName(..),HsDefault(..),EnumInfoApp , KeyInfo,FieldInfo(..),DescriptorInfo(..),EnumInfo(..),ProtoInfo(..),makePNF ) import Text.ProtocolBuffers.WireMessage- ( Put,Get,runPut,runGet,runGetOnLazy+ ( Wire,Put,Get,runPut,runGet,runGetOnLazy , messageSize,messagePut,messageGet,messagePutM,messageGetM , messageWithLengthSize,messageWithLengthPut,messageWithLengthGet,messageWithLengthPutM,messageWithLengthGetM , messageAsFieldSize,messageAsFieldPutM,messageAsFieldGetM)
Text/ProtocolBuffers/Basic.hs view
@@ -1,19 +1,18 @@+{-# LANGUAGE DeriveDataTypeable,GeneralizedNewtypeDeriving #-} -- | "Text.ProtocolBuffers.Basic" defines or re-exports most of the -- basic field types; 'Maybe','Bool', 'Double', and 'Float' come from--- the Prelude instead. This module also defined the 'Mergeable',--- 'Default', and 'Wire' classes.+-- the Prelude instead. This module also defined the 'Mergeable' and+-- 'Default' classes. The 'Wire' class is not defined here to avoid orphans. module Text.ProtocolBuffers.Basic ( -- * Basic types for protocol buffer fields in Haskell Double,Float,Bool,Maybe,Seq,Utf8(Utf8),ByteString,Int32,Int64,Word32,Word64 -- * Haskell types that act in the place of DescritorProto values , WireTag(..),FieldId(..),WireType(..),FieldType(..),EnumCode(..),WireSize -- * Some of the type classes implemented messages and fields- , Mergeable(..),Default(..),Wire(..)+ , Mergeable(..),Default(..) -- ,Wire(..) , isValidUTF8, toUtf8, utf8, uToString, uFromString ) where -import Control.Monad.Error.Class(throwError)-import Data.Binary.Put(Put) import Data.Bits(Bits) import Data.ByteString.Lazy(ByteString) import Data.Foldable as F(Foldable(foldl))@@ -21,10 +20,9 @@ import Data.Int(Int32,Int64) import Data.Ix(Ix) import Data.Monoid(Monoid(..))-import Data.Sequence(Seq)+import Data.Sequence(Seq,(><)) import Data.Typeable(Typeable(..)) import Data.Word(Word8,Word32,Word64)-import Text.ProtocolBuffers.Get(Get) import qualified Data.ByteString.Lazy as L(unpack) import Data.ByteString.Lazy.UTF8 as U (toString,fromString)@@ -58,13 +56,13 @@ -- | 'WireTag' is the 32 bit value with the upper 29 bits being the -- 'FieldId' and the lower 3 bits being the 'WireType' newtype WireTag = WireTag { getWireTag :: Word32 } -- bit concatenation of FieldId and WireType- deriving (Eq,Ord,Read,Show,Num,Bits,Bounded,Data,Typeable)+ deriving (Eq,Ord,Enum,Read,Show,Num,Bits,Bounded,Data,Typeable) -- | 'FieldId' is the field number which can be in the range 1 to -- 2^29-1 but the value from 19000 to 19999 are forbidden (so sayeth -- Google). newtype FieldId = FieldId { getFieldId :: Int32 } -- really 29 bits- deriving (Eq,Ord,Read,Show,Num,Data,Typeable,Ix)+ deriving (Eq,Ord,Enum,Read,Show,Num,Data,Typeable,Ix) -- Note that values 19000-19999 are forbidden for FieldId instance Bounded FieldId where@@ -87,7 +85,7 @@ -- * 5 /32-bit/ : fixed32, sfixed32, float -- newtype WireType = WireType { getWireType :: Word32 } -- really 3 bits- deriving (Eq,Ord,Read,Show,Num,Data,Typeable)+ deriving (Eq,Ord,Enum,Read,Show,Num,Data,Typeable) instance Bounded WireType where minBound = 0@@ -127,7 +125,7 @@ -} newtype FieldType = FieldType { getFieldType :: Int } -- really [1..18] as fromEnum of Type from Type.hs- deriving (Eq,Ord,Read,Show,Num,Data,Typeable)+ deriving (Eq,Ord,Enum,Read,Show,Num,Data,Typeable) instance Bounded FieldType where minBound = 1@@ -150,28 +148,33 @@ -- left or right unit like 'mempty'. The default 'mergeAppend' is to -- take the second parameter and discard the first one. The -- 'mergeConcat' defaults to @foldl@ associativity.-class Mergeable a where+--+-- NOTE: 'mergeEmpty' has been removed in protocol buffers version 2.+-- Use defaultValue instead. New strict fields would mean that required+-- fields in messages will be automatic errors with 'mergeEmpty'.+class Default a => Mergeable a where+{- -- | The 'mergeEmpty' value of a basic type or a message with -- required fields will be undefined and a runtime error to -- evaluate. These are only handy for reading the wire encoding and -- users should employ 'defaultValue' instead. mergeEmpty :: a mergeEmpty = error "You did not define Mergeable.mergeEmpty!"-+-} -- | 'mergeAppend' is the right-biased merge of two values. A -- message (or group) is merged recursively. Required field are -- always taken from the second message. Optional field values are- -- taken from the most defined message or the message message if+ -- taken from the most defined message or the second message if -- both are set. Repeated fields have the sequences concatenated. -- Note that strings and bytes are NOT concatenated. mergeAppend :: a -> a -> a mergeAppend _a b = b - -- | 'mergeConcat' is @ F.foldl mergeAppend mergeEmpty @ and this+ -- | 'mergeConcat' is @ F.foldl mergeAppend defaultValue @ and this -- default definition is not overridden in any of the code except -- for the (Seq a) instance. mergeConcat :: F.Foldable t => t a -> a- mergeConcat = F.foldl mergeAppend mergeEmpty+ mergeConcat = F.foldl mergeAppend defaultValue -- | The Default class has the default-default values of types. See -- <http://code.google.com/apis/protocolbuffers/docs/proto.html#optional>@@ -188,26 +191,6 @@ -- and Repeated field values are empty. defaultValue :: a --- | The 'Wire' class is for internal use, and may change. If there--- is a mis-match between the 'FieldType' and the type of @b@ then you--- will get a failure at runtime.------ Users should stick to the message functions defined in--- "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)- wireGetPacked ft = throwError ("Text.ProtocolBuffers.ProtoCompile.Basic: wireGetPacked default:"- ++ "\n There is no way to get a packed FieldType of "++show ft- ++ ".\n Either there is a bug in this library or the wire format is has been updated.")- -- Returns Nothing if valid, and the position of the error if invalid isValidUTF8 :: ByteString -> Maybe Int isValidUTF8 bs = go 0 (L.unpack bs) 0 where@@ -235,3 +218,43 @@ uFromString :: String -> Utf8 uFromString s = Utf8 (U.fromString s)+++-- Base types are not very mergeable, but their Maybe and Seq versions are:+instance Mergeable a => Mergeable (Maybe a) where+-- mergeEmpty = Nothing+ mergeAppend = mayMerge++{-# INLINE mayMerge #-}+mayMerge :: (Mergeable b) => Maybe b -> Maybe b -> Maybe b+mayMerge Nothing y = y+mayMerge x Nothing = x+mayMerge (Just x) (Just y) = Just (mergeAppend x y)++instance Mergeable (Seq a) where+-- mergeEmpty = empty+ mergeAppend = (><)++-- These all have errors as mergeEmpty and use the second paramater for mergeAppend+instance Mergeable Bool+instance Mergeable Utf8+instance Mergeable ByteString+instance Mergeable Double+instance Mergeable Float+instance Mergeable Int32+instance Mergeable Int64+instance Mergeable Word32+instance Mergeable Word64++instance Default Word64 where defaultValue = 0+instance Default Word32 where defaultValue = 0+instance Default Int64 where defaultValue = 0+instance Default Int32 where defaultValue = 0+instance Default Float where defaultValue = 0+instance Default Double where defaultValue = 0+instance Default Bool where defaultValue = False+instance Default (Maybe a) where defaultValue = Nothing+instance Default (Seq a) where defaultValue = mempty+instance Default ByteString where defaultValue = mempty+instance Default Utf8 where defaultValue = mempty+
− Text/ProtocolBuffers/Default.hs
@@ -1,18 +0,0 @@--- | This only defined instances now. The class definition was moved to Basic.hs-module Text.ProtocolBuffers.Default() where--import Text.ProtocolBuffers.Basic-import Data.Monoid(mempty)----instance Default a => Default (Maybe a) where defaultValue = Just defaultValue-instance Default a => Default (Maybe a) where defaultValue = Nothing-instance Default (Seq a) where defaultValue = mempty-instance Default Bool where defaultValue = False-instance Default ByteString where defaultValue = mempty-instance Default Utf8 where defaultValue = Utf8 mempty-instance Default Double where defaultValue = 0-instance Default Float where defaultValue = 0-instance Default Int32 where defaultValue = 0-instance Default Int64 where defaultValue = 0-instance Default Word32 where defaultValue = 0-instance Default Word64 where defaultValue = 0
Text/ProtocolBuffers/Extensions.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE GADTs,MultiParamTypeClasses,FunctionalDependencies,FlexibleInstances,DeriveDataTypeable,ScopedTypeVariables #-} -- | The "Extensions" module contributes two main things. The first -- is the definition and implementation of extensible message -- features. This means that the 'ExtField' data type is exported but@@ -25,7 +26,7 @@ -- * Internal types, functions, and classes , wireSizeExtField,wirePutExtField,loadExtension,notExtension , wireGetKeyToUnPacked, wireGetKeyToPacked- , GPB,ExtField(..),ExtendMessage(..),ExtFieldValue(..),+ , GPB,ExtField(..),ExtendMessage(..),ExtFieldValue(..) ) where import Control.Monad.Error.Class(throwError)@@ -36,12 +37,11 @@ import qualified Data.Map as M import Data.Maybe(fromMaybe,isJust) import Data.Monoid(mappend,mconcat)-import Data.Sequence((|>),(><))+import Data.Sequence((|>),(><),viewl,ViewL(..)) import qualified Data.Sequence as Seq(singleton,null,empty) import Data.Typeable() import Text.ProtocolBuffers.Basic-import Text.ProtocolBuffers.Default() import Text.ProtocolBuffers.WireMessage import Text.ProtocolBuffers.Reflections import Text.ProtocolBuffers.Get as Get (Result(..),bytesRead)@@ -116,7 +116,7 @@ -- | The 'GPDyn' is my specialization of 'Dynamic'. It hides the type -- with an existential but the 'GPWitness' brings the class instances -- into scope. This is used in 'ExtOptional' for optional fields.-data GPDyn = forall a . GPDyn !(GPWitness a) a+data GPDyn = forall a . GPDyn !(GPWitness a) !a deriving (Typeable) -- | The 'GPDynSeq' is another specialization of 'Dynamic' and is used@@ -206,7 +206,7 @@ -- wireKeyToUnPacked is used to load a repeated packed format into a repeated non-packed extension key--- wireKetToPacked is used to load a repeated unpacked format into a repeated packed extension key+-- wireKeyToPacked is used to load a repeated unpacked format into a repeated packed extension key wireGetKeyToUnPacked :: (ExtendMessage msg,GPB v) => Key Seq msg v -> msg -> Get msg wireGetKeyToUnPacked k@(Key i t mv) msg = do let myCast :: Maybe a -> Get (Seq a)@@ -250,7 +250,7 @@ | otherwise -> case cast s of Nothing -> fail $ "wireGetKeyToPacked: previous Seq value cast failed: "++show (k,typeOf s)- Just s' -> return $ ExtRepeated t (GPDynSeq GPWitness (s' |> v))+ Just s' -> seq v $ return $ ExtRepeated t (GPDynSeq GPWitness (s' |> v)) Just (ExtFromWire raw) -> case parseWireExtPackedSeq k wt raw of Left errMsg -> fail $ "wireGetKeyToPacked: Could not parseWireExtPackedSeq: "++show k++"\n"++errMsg@@ -259,7 +259,7 @@ | otherwise -> case cast s of Nothing -> fail $ "wireGetKeyToPacked: previous Seq value cast failed: "++show (k,typeOf s)- Just s' -> return $ ExtRepeated t (GPDynSeq GPWitness (s' |> v))+ Just s' -> seq v $ return $ ExtRepeated t (GPDynSeq GPWitness (s' |> v)) wtf -> fail $ "wireGetKeyToPacked: Weird parseWireExtPackedSeq return value: "++show (k,wtf) Just wtf@(ExtOptional {}) -> fail $ "wireGetKeyToPacked: ExtOptional found when ExtPacked expected: "++show (k,wtf) Just wtf@(ExtRepeated {}) -> fail $ "wireGetKeyToPacked: ExtRepeated found when ExtPacked expected: "++show (k,wtf)@@ -324,7 +324,7 @@ instance GPB Word64 instance Mergeable ExtField where- mergeEmpty = ExtField M.empty+-- mergeEmpty = ExtField M.empty mergeAppend (ExtField m1) (ExtField m2) = ExtField (M.unionWith mergeExtFieldValue m1 m2) mergeExtFieldValue :: ExtFieldValue -> ExtFieldValue -> ExtFieldValue@@ -516,19 +516,22 @@ parseWireExtMaybe :: Key Maybe msg v -> WireType -> Seq EP -> Either String (FieldId,ExtFieldValue) parseWireExtMaybe k@(Key fi ft mv) wt raw | wt /= toWireType ft = Left $ "parseWireExt Maybe: Key's FieldType does not match ExtField's wire type: "++show (k,toWireType ft,wt)- | otherwise = do+ | otherwise = do let mkWitType :: Maybe a -> GPWitness a mkWitType = undefined witness = GPWitness `asTypeOf` (mkWitType mv) -- parsed = map (applyGet (wireGet ft)) . F.toList $ raw parsed = map (chooseGet ft) . F.toList $ raw errs = [ m | Left m <- parsed ]- if null errs then Right (fi,(ExtOptional ft (GPDyn witness (mergeConcat . mconcat $ [ a | Right a <- parsed ]))))+ if null errs + then case viewl (mconcat [ a | Right a <- parsed ]) of+ EmptyL -> Left "Text.ProtocolBuffers.Extensions.parseWireExtMaybe: impossible empty parsed list"+ x :< xs -> Right (fi,(ExtOptional ft (GPDyn witness (F.foldl' mergeAppend x xs)))) else Left (unlines errs) -- 'chooseGet' is an intermediate handler between parseWireExt* and applyGet. This does not know -- whether the EP will result in a single r or repeat r, so it always returns a Seq. It may also--- realize that there is a mismatch between the derired FieldType and the WireType+-- realize that there is a mismatch between the desired FieldType and the WireType chooseGet :: (Wire r) => FieldType -> EP -> Either String (Seq r) chooseGet ft (EP wt bsIn) = if (2==wt) && (isValidPacked ft)@@ -596,7 +599,7 @@ | otherwise -> case cast s of Nothing -> fail $ "wireGetKey Seq: previous Seq value cast failed: "++show (k,typeOf s)- Just s' -> return $ ExtRepeated t (GPDynSeq GPWitness (s' |> v))+ Just s' -> seq v $ return $ ExtRepeated t (GPDynSeq GPWitness (s' |> v)) Just (ExtFromWire raw) -> case parseWireExtSeq k wt raw of Left errMsg -> fail $ "wireGetKey Seq: Could not parseWireExtSeq: "++show k++"\n"++errMsg@@ -605,7 +608,7 @@ | otherwise -> case cast s of Nothing -> fail $ "wireGetKey Seq: previous Seq value cast failed: "++show (k,typeOf s)- Just s' -> return $ ExtRepeated t (GPDynSeq GPWitness (s' |> v))+ Just s' -> seq v $ return $ ExtRepeated t (GPDynSeq GPWitness (s' |> v)) wtf -> fail $ "wireGetKey Seq: Weird parseWireExtSeq return value: "++show (k,wtf) Just wtf@(ExtOptional {}) -> fail $ "wireGetKey Seq: ExtOptional found when ExtRepeated expected: "++show (k,wtf) Just wtf@(ExtPacked {}) -> fail $ "wireGetKey Seq: ExtPacked found when ExtRepeated expected: "++show (k,wtf)@@ -616,7 +619,7 @@ parseWireExtSeq :: Key Seq msg v -> WireType -> Seq EP -> Either String (FieldId,ExtFieldValue) parseWireExtSeq k@(Key i t mv) wt raw | wt /= toWireType t = Left $ "parseWireExtSeq: Key mismatch! Key's FieldType does not match ExtField's wire type: "++show (k,toWireType t,wt)- | otherwise = do+ | otherwise = do let mkWitType :: Maybe a -> GPWitness a mkWitType = undefined witness = GPWitness `asTypeOf` (mkWitType mv)@@ -750,7 +753,7 @@ seq v' $ seq ef' $ return $ putExtField (ExtField ef') msg Just (ExtFromWire raw) -> do bs <- wireGetFromWire fieldId wireType- let v' = ExtFromWire (raw |> (EP wireType bs))+ let v' = seq bs $ ExtFromWire (raw |> (EP wireType bs)) ef' = M.insert fieldId v' ef seq v' $ seq ef' $ return (putExtField (ExtField ef') msg) Just (ExtOptional ft (GPDyn x@GPWitness a)) | toWireType ft /= wireType -> badwt (toWireType ft)@@ -769,14 +772,14 @@ else badwt (toWireType ft) | otherwise -> do a <- wireGet ft- let v' = ExtRepeated ft (GPDynSeq x (s |> a))+ let v' = seq a $ ExtRepeated ft (GPDynSeq x (s |> a)) ef' = M.insert fieldId v' ef seq v' $ seq ef' $ return (putExtField (ExtField ef') msg) -- handle wireType of NOT "2" when wireType is good match for ft by using wireGet ft Just (ExtPacked ft (GPDynSeq x@GPWitness s)) | 2 /= wireType -> if (toWireType ft) == wireType then do a <- wireGet ft- let v' = ExtPacked ft (GPDynSeq x (s |> a))+ let v' = seq a $ ExtPacked ft (GPDynSeq x (s |> a)) ef' = M.insert fieldId v' ef seq v' $ seq ef' $ return (putExtField (ExtField ef') msg) else badwt 2 {- packed uses length delimited: 2 -}
Text/ProtocolBuffers/Get.hs view
@@ -1,9 +1,11 @@-{-# LANGUAGE CPP,MagicHash,ScopedTypeVariables,FlexibleInstances,RankNTypes #-}+{-# LANGUAGE CPP,MagicHash,ScopedTypeVariables,FlexibleInstances,RankNTypes,TypeSynonymInstances,MultiParamTypeClasses,BangPatterns #-} -- | By Chris Kuklewicz, drawing heavily from binary and binary-strict, -- but all the bugs are my own. -- -- This file is under the usual BSD3 licence, copyright 2008. --+-- Modified the monad to be strict for version 2.0.0+-- -- This started out as an improvement to -- "Data.Binary.Strict.IncrementalGet" with slightly better internals. -- The simplified 'Get', 'runGet', 'Result' trio with the@@ -38,8 +40,10 @@ -- The three 'lookAhead' and 'lookAheadM' and 'lookAheadE' functions are -- very similar to the ones in binary's Data.Binary.Get. --+--+-- Add specialized high-bit-run module Text.ProtocolBuffers.Get- (Get,runGet,Result(..)+ (Get,runGet,runGetAll,Result(..) -- main primitives ,ensureBytes,getStorable,getLazyByteString,suspendUntilComplete -- parser state manipulation@@ -47,7 +51,7 @@ -- lookAhead capabilities ,lookAhead,lookAheadM,lookAheadE -- below is for implementation of BinaryParser (for Int64 and Lazy bytestrings)- ,skip,bytesRead,isEmpty,isReallyEmpty,remaining,spanOf+ ,skip,bytesRead,isEmpty,isReallyEmpty,remaining,spanOf,highBitRun ,getWord8,getByteString ,getWord16be,getWord32be,getWord64be ,getWord16le,getWord32le,getWord64le@@ -66,11 +70,11 @@ import Control.Monad(ap) -- instead of Functor.fmap; ap for Applicative --import Control.Monad(replicateM,(>=>)) -- XXX testing import Data.Bits(Bits((.|.)))-import qualified Data.ByteString as S(concat,length,null,splitAt)+import qualified Data.ByteString as S(concat,length,null,splitAt,findIndex) --import qualified Data.ByteString as S(unpack) -- XXX testing import qualified Data.ByteString.Internal as S(ByteString,toForeignPtr,inlinePerformIO) import qualified Data.ByteString.Unsafe as S(unsafeIndex)-import qualified Data.ByteString.Lazy as L(take,drop,length,span,toChunks,fromChunks,null)+import qualified Data.ByteString.Lazy as L(take,drop,length,span,toChunks,fromChunks,null,findIndex) --import qualified Data.ByteString.Lazy as L(pack) -- XXX testing import qualified Data.ByteString.Lazy.Internal as L(ByteString(..),chunk) import qualified Data.Foldable as F(foldr,foldr1) -- used with Seq@@ -134,11 +138,13 @@ -- IMPORTANT: Any FutureFrame at the top level(s) is discarded by throwError. setCheckpoint,useCheckpoint,clearCheckpoint :: Get () setCheckpoint = Get $ \ sc s pc -> sc () s (HandlerFrame Nothing s mempty pc)+ useCheckpoint = Get $ \ sc (S _ _ _) frame -> case frame of (HandlerFrame Nothing s future pc) -> let (S {top=ss, current=bs, consumed=n}) = collect s future in sc () (S ss bs n) pc _ -> error "Text.ProtocolBuffers.Get: Impossible useCheckpoint frame!"+ clearCheckpoint = Get $ \ sc s frame -> case frame of (HandlerFrame Nothing _s _future pc) -> sc () s pc@@ -214,6 +220,14 @@ L.Chunk ss bs -> S ss bs 0 ec msg sOut = Failed (consumed sOut) msg +-- | 'runGetAll' is the simple executor, and will not ask for any continuation because this lazy bytestring is all the input+runGetAll :: Get a -> L.ByteString -> Result a+runGetAll (Get f) bsIn = f scIn sIn (ErrorFrame ec False)+ where scIn a (S ss bs n) _pc = Finished (L.chunk ss bs) n a+ sIn = case bsIn of L.Empty -> S mempty mempty 0+ L.Chunk ss bs -> S ss bs 0+ ec msg sOut = Failed (consumed sOut) msg+ -- | Get the input currently available to the parser. getAvailable :: Get L.ByteString getAvailable = Get $ \ sc s@(S ss bs _) pc -> sc (L.chunk ss bs) s pc@@ -226,8 +240,8 @@ -- -- WARNING : 'putAvailable' is still untested. putAvailable :: L.ByteString -> Get ()-putAvailable bsNew = Get $ \ sc (S _ss _bs n) pc ->- let s' = case bsNew of+putAvailable !bsNew = Get $ \ sc (S _ss _bs n) pc ->+ let !s' = case bsNew of L.Empty -> S mempty mempty n L.Chunk ss' bs' -> S ss' bs' n rebuild (HandlerFrame catcher (S ss1 bs1 n1) future pc') =@@ -241,12 +255,12 @@ L.Chunk ss2 bs2 -> S ss2 bs2 n1 rebuild x@(ErrorFrame {}) = x in sc () s' (rebuild pc)---- Internal access to full internal state, as helepr functions+ +-- Internal access to full internal state, as helper functions getFull :: Get S getFull = Get $ \ sc s pc -> sc s s pc putFull :: S -> Get ()-putFull s = Get $ \ sc _s pc -> sc () s pc+putFull !s = Get $ \ sc _s pc -> sc () s pc -- | Keep calling 'suspend' until Nothing is passed to the 'Partial' -- continuation. This ensures all the data has been loaded into the@@ -287,8 +301,8 @@ case rest of L.Empty -> putFull (S mempty mempty (offset + n)) L.Chunk ss' bs' -> putFull (S ss' bs' (offset + n))- return consume- Nothing -> suspendMsg "getLazyByteString failed" >> getLazyByteString n+ return $! consume+ Nothing -> suspendMsg ("getLazyByteString failed with "++show (n,(S.length ss,L.length bs,offset))) >> getLazyByteString n {-# INLINE getLazyByteString #-} -- important -- | 'suspend' is supposed to allow the execution of the monad to be@@ -423,6 +437,29 @@ else return b else return True ++-- | get the longest prefix of the input where the high bit is set as well as following byte.+-- This made getVarInt slower.+highBitRun :: Get Int64+{-# INLINE highBitRun #-}+highBitRun = loop where+ loop :: Get Int64+ {-# INLINE loop #-}+ loop = do+ (S ss bs _n) <- getFull+ let mi = S.findIndex (128>) ss+ case mi of+ Just i -> return (succ $ fromIntegral i)+ Nothing -> do+ let mj = L.findIndex (128>) bs+ case mj of+ Just j -> return (fromIntegral (S.length ss) + succ j)+ Nothing -> do+ continue <- suspend+ if continue then loop+ else throwError "highBitRun has failed"++-- | get the longest prefix of the input where all the bytes satisfy the predicate. spanOf :: (Word8 -> Bool) -> Get (L.ByteString) spanOf f = do let loop = do (S ss bs n) <- getFull let (pre,post) = L.span f (L.chunk ss bs)@@ -430,10 +467,9 @@ L.Empty -> putFull (S mempty mempty (n + L.length pre)) L.Chunk ss' bs' -> putFull (S ss' bs' (n + L.length pre)) if L.null post- then fmap ((L.toChunks pre)++) $ do- continue <- suspend- if continue then loop- else return (L.toChunks pre)+ then do continue <- suspend+ if continue then fmap ((L.toChunks pre)++) loop+ else return (L.toChunks pre) else return (L.toChunks pre) fmap L.fromChunks loop {-# INLINE spanOf #-}@@ -450,10 +486,11 @@ if nIn < S.length ss then do let (pre,post) = S.splitAt nIn ss putFull (S post bs (n+fromIntegral nIn))- return pre+ return $! pre -- Expect nIn to be less than S.length ss the vast majority of times -- so do not worry about doing anything fancy here.- else fmap (S.concat . L.toChunks) (getLazyByteString (fromIntegral nIn))+ else do now <- fmap (S.concat . L.toChunks) (getLazyByteString (fromIntegral nIn))+ return $! now {-# INLINE getByteString #-} -- important getWordhost :: Get Word@@ -559,9 +596,9 @@ {-# INLINE fmap #-} instance Monad Get where- return a = Get (\sc -> sc a)+ return a = seq a $ Get (\sc -> sc a) {-# INLINE return #-}- m >>= k = Get (\sc -> unGet m (\a -> unGet (k a) sc))+ m >>= k = Get (\sc -> unGet m (\ a -> seq a $ unGet (k a) sc)) {-# INLINE (>>=) #-} fail = throwError . strMsg
Text/ProtocolBuffers/Header.hs view
@@ -27,20 +27,19 @@ import Data.Typeable(Typeable(..)) import Text.ProtocolBuffers.Basic -- all-import Text.ProtocolBuffers.Default() import Text.ProtocolBuffers.Extensions ( wireSizeExtField,wirePutExtField,loadExtension,notExtension , wireGetKeyToUnPacked, wireGetKeyToPacked , GPB,Key(..),ExtField,ExtendMessage(..),MessageAPI(..),ExtKey(wireGetKey),PackedSeq ) import Text.ProtocolBuffers.Identifiers(FIName(..),MName(..),FName(..))-import Text.ProtocolBuffers.Mergeable() import Text.ProtocolBuffers.Reflections ( ReflectDescriptor(..),ReflectEnum(..),EnumInfo(..),ProtoName(..) , GetMessageInfo(GetMessageInfo),DescriptorInfo(extRanges),makePNF ) import Text.ProtocolBuffers.Unknown ( UnknownField,UnknownMessage(..),wireSizeUnknownField,wirePutUnknownField,catch'Unknown ) import Text.ProtocolBuffers.WireMessage- ( prependMessageSize,putSize,splitWireTag+ ( Wire(..)+ , prependMessageSize,putSize,splitWireTag , wireSizeReq,wireSizeOpt,wireSizeRep , wirePutReq,wirePutOpt,wirePutRep , wirePutPacked,wireSizePacked
Text/ProtocolBuffers/Identifiers.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE MultiParamTypeClasses,TypeSynonymInstances,FlexibleInstances,DeriveDataTypeable #-} -- | This modules colelct utility routines related to the different -- incarnations of identifiers in the code. The basic identifier is -- always ASCII, but because of the self generated DescriptorProto
− Text/ProtocolBuffers/Mergeable.hs
@@ -1,32 +0,0 @@--- | This provides instance of 'Mergeable' for the basic field types.-module Text.ProtocolBuffers.Mergeable() where--import Text.ProtocolBuffers.Basic--- import Data.Monoid(mempty,mappend)-import Data.Sequence(empty,(><))---- Base types are not very mergeable, but their Maybe and Seq versions are:-instance Mergeable a => Mergeable (Maybe a) where- mergeEmpty = Nothing- mergeAppend = mayMerge--instance Mergeable (Seq a) where- mergeEmpty = empty- mergeAppend = (><)---- These all have errors as mergeEmpty and use the second paramater for mergeAppend-instance Mergeable Bool-instance Mergeable Utf8-instance Mergeable ByteString-instance Mergeable Double-instance Mergeable Float-instance Mergeable Int32-instance Mergeable Int64-instance Mergeable Word32-instance Mergeable Word64--{-# INLINE mayMerge #-}-mayMerge :: (Mergeable b) => Maybe b -> Maybe b -> Maybe b-mayMerge Nothing y = y-mayMerge x Nothing = x-mayMerge (Just x) (Just y) = Just (mergeAppend x y)
Text/ProtocolBuffers/Reflections.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} -- | A strong feature of the protocol-buffers package is that it does -- not contain any structures defined by descriptor.proto! This -- prevents me hitting any annoying circular dependencies. The@@ -75,6 +76,7 @@ , extRanges :: [(FieldId,FieldId)] , knownKeys :: Seq FieldInfo , storeUnknown :: Bool+ , lazyFields :: Bool } deriving (Show,Read,Eq,Ord,Data,Typeable)
Text/ProtocolBuffers/Unknown.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable,RankNTypes #-} -- | This module add unknown field support to the library. There are no user API things here, -- except for advanced spelunking into the data structures which can and have changed with no -- notice. Importer beware.@@ -34,7 +35,7 @@ deriving (Eq,Ord,Show,Read,Data,Typeable) instance Mergeable UnknownField where- mergeEmpty = UnknownField mempty+-- mergeEmpty = UnknownField mempty mergeAppend (UnknownField m1) (UnknownField m2) = UnknownField (mappend m1 m2) instance Default UnknownField where@@ -59,7 +60,7 @@ let (fieldId,wireType) = splitWireTag tag (UnknownField uf) = getUnknownField msg bs <- wireGetFromWire fieldId wireType- let v' = UFV tag bs- uf' = uf |> v'- seq v' $ seq uf' $ return $ putUnknownField (UnknownField uf') msg+ let v' = seq bs $ UFV tag bs+ uf' = seq v' $ uf |> v'+ seq uf' $ return $ putUnknownField (UnknownField uf') msg
Text/ProtocolBuffers/WireMessage.hs view
@@ -1,3 +1,4 @@+{-# Language BangPatterns #-} {- | Here are the serialization and deserialization functions. @@ -40,6 +41,8 @@ import Control.Monad.ST import Data.Array.ST import Data.Bits (Bits(..))+--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 Data.List (genericLength)@@ -52,18 +55,21 @@ -- This has been superceded by the ST array trick (ugly, but promised to work) --import GHC.Exts (Double(D#),Float(F#),unsafeCoerce#) --import GHC.Word (Word64(W64#)) -- ,Word32(W32#))+--import Debug.Trace -- binary package import Data.Binary.Put (Put,runPut,putWord8,putWord32le,putWord64le,putLazyByteString) import Text.ProtocolBuffers.Basic-import Text.ProtocolBuffers.Get as Get (Result(..),Get,runGet,bytesRead,isReallyEmpty- ,spanOf,skip,lookAhead+import Text.ProtocolBuffers.Get as Get (Result(..),Get,runGet,runGetAll,bytesRead,isReallyEmpty+ ,spanOf,skip,lookAhead,highBitRun -- ,getByteString ,getWord8,getWord32le,getWord64le,getLazyByteString)-import Text.ProtocolBuffers.Mergeable() import Text.ProtocolBuffers.Reflections(ReflectDescriptor(reflectDescriptorInfo,getMessageInfo) ,DescriptorInfo(..),GetMessageInfo(..)) +trace :: a -> b -> b+trace _ s = s+ -- External user API for writing and reading messages -- | This computes the size of the message's fields with tags on the@@ -178,11 +184,11 @@ -- more input you should use 'runGet' and respond to 'Partial' -- differently. runGetOnLazy :: Get r -> ByteString -> Either String (r,ByteString)-runGetOnLazy parser bs = resolve (runGet parser bs)+runGetOnLazy parser bs = resolve (runGetAll parser bs) where resolve :: Result r -> Either String (r,ByteString) resolve (Failed i s) = Left ("Failed at "++show i++" : "++s) resolve (Finished bsOut _i r) = Right (r,bsOut)- resolve (Partial op) = resolve (op Nothing)+ resolve (Partial op) = resolve (op Nothing) -- should be impossible -- | Used in generated code. prependMessageSize :: WireSize -> WireSize@@ -266,14 +272,14 @@ packedLength <- getVarInt start <- bytesRead let stop = packedLength+start- next soFar = do+ next !soFar = do here <- bytesRead case compare stop here of EQ -> return soFar LT -> tooMuchData packedLength soFar start here GT -> do value <- wireGetEnum toMaybe'Enum- next $! soFar |> value+ seq value $ next (soFar |> value) next Seq.empty where Just e = undefined `asTypeOf` (toMaybe'Enum undefined)@@ -288,14 +294,14 @@ packedLength <- getVarInt start <- bytesRead let stop = packedLength+start- next soFar = do+ next !soFar = do here <- bytesRead case compare stop here of EQ -> return soFar LT -> tooMuchData packedLength soFar start here GT -> do value <- wireGet ft- next $! soFar |> value+ seq value $! next $! soFar |> value next Seq.empty where tooMuchData packedLength soFar start here =@@ -305,17 +311,18 @@ -- getMessageWith assumes the wireTag for the message, if it existed, has already been read. -- getMessageWith assumes that it still needs to read the Varint encoded length of the message.-getMessageWith :: (Mergeable message, ReflectDescriptor message)+getMessageWith :: (Default message, ReflectDescriptor message) -- => (WireTag -> FieldId -> WireType -> message -> Get message) => (WireTag -> message -> Get message) -> Get message+{- manyTAT.bin testing INLINE getMessageWith but made slower -} getMessageWith updater = do messageLength <- getVarInt start <- bytesRead let stop = messageLength+start -- switch from go to go' once all the required fields have been found- go reqs message | Set.null reqs = go' message- | otherwise = do+ go reqs !message | Set.null reqs = go' message+ | otherwise = do here <- bytesRead case compare stop here of EQ -> notEnoughData messageLength start@@ -325,7 +332,7 @@ let -- (fieldId,wireType) = splitWireTag wireTag reqs' = Set.delete wireTag reqs updater wireTag {- fieldId wireType -} message >>= go reqs'- go' message = do+ go' !message = do here <- bytesRead case compare stop here of EQ -> return message@@ -336,7 +343,7 @@ updater wireTag {- fieldId wireType -} message >>= go' go required initialMessage where- initialMessage = mergeEmpty+ initialMessage = defaultValue (GetMessageInfo {requiredTags=required}) = getMessageInfo initialMessage notEnoughData messageLength start = throwError ("Text.ProtocolBuffers.WireMessage.getMessageWith: Required fields missing when processing "@@ -352,14 +359,15 @@ -- getBareMessageWith assumes that it does needs to read the Varint encoded length of the message. -- getBareMessageWith will consume the entire ByteString it is operating on, or until it -- finds any STOP_GROUP tag (wireType == 4)-getBareMessageWith :: (Mergeable message, ReflectDescriptor message)+getBareMessageWith :: (Default message, ReflectDescriptor message) -- => (WireTag -> FieldId -> WireType -> message -> Get message) -- handle wireTags that are unknown or produce errors => (WireTag -> message -> Get message) -- handle wireTags that are unknown or produce errors -> Get message+{- manyTAT.bin testing INLINE getBareMessageWith but made slower -} getBareMessageWith updater = go required initialMessage where- go reqs message | Set.null reqs = go' message- | otherwise = do+ go reqs !message | Set.null reqs = go' message+ | otherwise = do done <- isReallyEmpty if done then notEnoughData else do@@ -368,7 +376,7 @@ if wireType == 4 then notEnoughData -- END_GROUP too soon else let reqs' = Set.delete wireTag reqs in updater wireTag {- fieldId wireType -} message >>= go reqs'- go' message = do+ go' !message = do done <- isReallyEmpty if done then return message else do@@ -376,7 +384,7 @@ let (_fieldId,wireType) = splitWireTag wireTag if wireType == 4 then return message else updater wireTag {- fieldId wireType -} message >>= go'- initialMessage = mergeEmpty+ initialMessage = defaultValue (GetMessageInfo {requiredTags=required}) = getMessageInfo initialMessage notEnoughData = throwError ("Text.ProtocolBuffers.WireMessage.getBareMessageWith: Required fields missing when processing " ++ (show . descName . reflectDescriptorInfo $ initialMessage))@@ -431,6 +439,26 @@ typeHack :: Get a -> a typeHack = undefined +-- | The 'Wire' class is for internal use, and may change. If there+-- is a mis-match between the 'FieldType' and the type of @b@ then you+-- will get a failure at runtime.+--+-- Users should stick to the message functions defined in+-- "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)+ wireGetPacked ft = throwError ("Text.ProtocolBuffers.ProtoCompile.Basic: wireGetPacked default:"+ ++ "\n There is no way to get a packed FieldType of "++show ft+ ++ ".\n Either there is a bug in this library or the wire format is has been updated.")+ instance Wire Double where wireSize {- TYPE_DOUBLE -} 1 _ = 8 wireSize ft x = wireSizeErr ft x@@ -557,7 +585,7 @@ wirePut ft x = wirePutErr ft x wireGet {- TYPE_ENUM -} 14 = getVarInt wireGet ft = wireGetErr ft- wireGetPacked 14 = genericPacked 14 -- Should actually be used, see wireGetPackedEnum+ 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 {-# INLINE verifyUtf8 #-}@@ -571,7 +599,7 @@ wireGetEnum toMaybe'Enum = do int <- wireGet 14 -- uses the "instance Wire Int" defined above case toMaybe'Enum int of- Just v -> return v+ Just !v -> return v Nothing -> throwError (msg ++ show int) where msg = "Bad wireGet of Enum "++show (typeOf (undefined `asTypeOf` typeHack toMaybe'Enum))++", unrecognized Int value is " typeHack :: (Int -> Maybe e) -> e@@ -667,7 +695,7 @@ wireGetFromWire :: FieldId -> WireType -> Get ByteString wireGetFromWire fi wt = getLazyByteString =<< calcLen where calcLen = case wt of- 0 -> lenOf (spanOf (>=128) >> skip 1)+ 0 -> highBitRun -- lenOf (spanOf (>=128) >> skip 1) 1 -> return 8 2 -> lookAhead $ do here <- bytesRead@@ -680,8 +708,8 @@ wtf -> throwError $ "Invalid wire type (expected 0,1,2,3,or 5) found: "++show (fi,wtf) lenOf g = do here <- bytesRead there <- lookAhead (g >> bytesRead)- return (there-here)- + trace (":wireGetFromWire.lenOf: "++show ((fi,wt),(here,there,there-here))) $ return (there-here)+ -- | After a group start tag with the given 'FieldId' this will skip -- ahead in the stream past the end tag of that group. Used by -- 'wireGetFromWire' to help compule the length of an unknown field@@ -750,214 +778,21 @@ toWireType x = error $ "Text.ProcolBuffers.Basic.toWireType: Bad FieldType: "++show x {----- getMessageWith assumes the wireTag for the message, if it existed, has already been read.--- getMessageWith assumes that it still needs to read the Varint encoded length of the message.-getMessageWith :: (Mergeable message, ReflectDescriptor message)- => (FieldId -> WireType -> message -> Get message) -- handle wireTags that updater cannot- -> (FieldId -> message -> Get message) -- handles "allowed" wireTags- -> Get message-getMessageWith punt updater = do- messageLength <- getVarInt- start <- bytesRead- let stop = messageLength+start- -- switch from go to go' once all the required fields have been found- go reqs message | Set.null reqs = go' message- | otherwise = do- here <- bytesRead- case compare stop here of- EQ -> notEnoughData messageLength start- LT -> tooMuchData messageLength start here- GT -> do- wireTag <- fmap WireTag getVarInt -- get tag off wire- let (fieldId,wireType) = splitWireTag wireTag- if Set.notMember wireTag allowed- then punt fieldId wireType message >>= go reqs- else let reqs' = Set.delete wireTag reqs- in catchError (updater fieldId message) - (\_ -> punt fieldId wireType message)- >>= go reqs'- go' message = do- here <- bytesRead- case compare stop here of- EQ -> return message- LT -> tooMuchData messageLength start here- GT -> do- wireTag <- fmap WireTag getVarInt -- get tag off wire- let (fieldId,wireType) = splitWireTag wireTag- if Set.notMember wireTag allowed- then punt fieldId wireType message >>= go'- else catchError (updater fieldId message)- (\_ -> punt fieldId wireType message)- >>= go'- go required initialMessage- where- initialMessage = mergeEmpty- (GetMessageInfo {requiredTags=required,allowedTags=allowed}) = getMessageInfo initialMessage- notEnoughData messageLength start =- fail ("Text.ProtocolBuffers.WireMessage.getMessageWith: Required fields missing when processing "- ++ (show . descName . reflectDescriptorInfo $ initialMessage)- ++ " at (messageLength,start) == " ++ show (messageLength,start))- tooMuchData messageLength start here =- fail ("Text.ProtocolBuffers.WireMessage.getMessageWith: overran expected length when processing"- ++ (show . descName . reflectDescriptorInfo $ initialMessage)- ++ " at (messageLength,start,here) == " ++ show (messageLength,start,here))---- | Used by generated code--- getBareMessageWith assumes the wireTag for the message, if it existed, has already been read.--- getBareMessageWith assumes that it does needs to read the Varint encoded length of the message.--- getBareMessageWith will consume the entire ByteString it is operating on, or until it--- finds any STOP_GROUP tag-getBareMessageWith :: (Mergeable message, ReflectDescriptor message)- => (FieldId -> WireType -> message -> Get message) -- handle wireTags that updater cannot- -> (FieldId -> message -> Get message) -- handles "allowed" wireTags- -> Get message-getBareMessageWith punt updater = go required initialMessage- where- go reqs message | Set.null reqs = go' message- | otherwise = do- done <- isReallyEmpty- if done then notEnoughData- else do- wireTag <- fmap WireTag getVarInt -- get tag off wire- let (fieldId,wireType) = splitWireTag wireTag- if wireType == 4 then notEnoughData -- END_GROUP too soon- else if Set.notMember wireTag allowed- then punt fieldId wireType message >>= go reqs- else let reqs' = Set.delete wireTag reqs- in catchError (updater fieldId message)- (\_ -> punt fieldId wireType message)- >>= go reqs'- go' message = do- done <- isReallyEmpty- if done then return message- else do- wireTag <- fmap WireTag getVarInt -- get tag off wire- let (fieldId,wireType) = splitWireTag wireTag -- WIRETYPE_END_GROUP- if wireType == 4 then return message- else if Set.notMember wireTag allowed- then punt fieldId wireType message >>= go'- else catchError (updater fieldId message)- (\_ -> punt fieldId wireType message)- >>= go'- initialMessage = mergeEmpty- (GetMessageInfo {requiredTags=required,allowedTags=allowed}) = getMessageInfo initialMessage- notEnoughData = fail ("Text.ProtocolBuffers.WireMessage.getBareMessageWith: Required fields missing when processing "- ++ (show . descName . reflectDescriptorInfo $ initialMessage))--+-- OPTIMIZE attempt:+-- Used in bench-003-highBitrun-and-new-getVarInt and much slower+-- This is a much slower variant than supplied by default in version 1.8.4+getVarInt :: (Integral a, Bits a) => Get a+getVarInt = do+ n <- highBitRun -- n is at least 0, or an error is thrown by highBitRun+ s <- getByteString (succ n) -- length of s is at least 1+ let go 0 val = return val+ go m val = let m' = pred m -- m' will be [(n-2) .. 0]+ val' = (val `shiftL` 7) .|. (fromIntegral (0x7F .&. S.unsafeIndex s m'))+ in go m' $! val'+ go n (fromIntegral (S.last s)) -}-{---- getMessageWith assumes the wireTag for the message, if it existed, has already been read.--- getMessageWith assumes that it still needs to read the Varint encoded length of the message.-getMessageWith :: (Mergeable message, ReflectDescriptor message)- => (FieldId -> message -> Get message) -- handles "allowed" wireTags including known extensions- -> Maybe (FieldId -> WireType -> message -> Get message) -- handle extension wireTags that updater does not- -> (FieldId -> WireType -> message -> Get message) -- handle wireTags that are unknown or produce errors- -> Get message-getMessageWith updater mayExt punt = do- messageLength <- getVarInt- start <- bytesRead- let stop = messageLength+start- getExt = case mayExt of- Nothing -> punt- Just loadExt -> - (\fieldId wireType msg -> catchError (loadExt fieldId wireType msg)- (\_ -> punt fieldId wireType msg))- -- switch from go to go' once all the required fields have been found- go reqs message | Set.null reqs = go' message- | otherwise = do- here <- bytesRead- case compare stop here of- EQ -> notEnoughData messageLength start- LT -> tooMuchData messageLength start here- GT -> do- wireTag <- fmap WireTag getVarInt -- get tag off wire- let (fieldId,wireType) = splitWireTag wireTag- if Set.notMember wireTag allowed- then getExt fieldId wireType message >>= go reqs- else let reqs' = Set.delete wireTag reqs- in catchError (updater fieldId message)- (\_ -> punt fieldId wireType message)- >>= go reqs'- go' message = do- here <- bytesRead- case compare stop here of- EQ -> return message- LT -> tooMuchData messageLength start here- GT -> do- wireTag <- fmap WireTag getVarInt -- get tag off wire- let (fieldId,wireType) = splitWireTag wireTag- if Set.notMember wireTag allowed- then getExt fieldId wireType message >>= go'- else catchError (updater fieldId message)- (\_ -> punt fieldId wireType message)- >>= go'- go required initialMessage- where- initialMessage = mergeEmpty- (GetMessageInfo {requiredTags=required,allowedTags=allowed}) = getMessageInfo initialMessage- notEnoughData messageLength start =- throwError ("Text.ProtocolBuffers.WireMessage.getMessageWith: Required fields missing when processing "- ++ (show . descName . reflectDescriptorInfo $ initialMessage)- ++ " at (messageLength,start) == " ++ show (messageLength,start))- tooMuchData messageLength start here =- throwError ("Text.ProtocolBuffers.WireMessage.getMessageWith: overran expected length when processing"- ++ (show . descName . reflectDescriptorInfo $ initialMessage)- ++ " at (messageLength,start,here) == " ++ show (messageLength,start,here)) --- | Used by generated code--- getBareMessageWith assumes the wireTag for the message, if it existed, has already been read.--- getBareMessageWith assumes that it does needs to read the Varint encoded length of the message.--- getBareMessageWith will consume the entire ByteString it is operating on, or until it--- finds any STOP_GROUP tag-getBareMessageWith :: (Mergeable message, ReflectDescriptor message)- => (FieldId -> message -> Get message) -- handles "allowed" wireTags including known extensions- -> Maybe (FieldId -> WireType -> message -> Get message) -- handle extension wireTags that updater does not- -> (FieldId -> WireType -> message -> Get message) -- handle wireTags that are unknown or produce errors- -> Get message-getBareMessageWith updater mayExt punt = go required initialMessage- where- getExt = case mayExt of- Nothing -> punt- Just loadExt -> - (\fieldId wireType msg -> catchError (loadExt fieldId wireType msg)- (\_ -> punt fieldId wireType msg))- go reqs message | Set.null reqs = go' message- | otherwise = do- done <- isReallyEmpty- if done then notEnoughData- else do- wireTag <- fmap WireTag getVarInt -- get tag off wire- let (fieldId,wireType) = splitWireTag wireTag- if wireType == 4 then notEnoughData -- END_GROUP too soon- else if Set.notMember wireTag allowed- then getExt fieldId wireType message >>= go reqs- else let reqs' = Set.delete wireTag reqs- in catchError (updater fieldId message)- (\_ -> punt fieldId wireType message)- >>= go reqs'- go' message = do- done <- isReallyEmpty- if done then return message- else do- wireTag <- fmap WireTag getVarInt -- get tag off wire- let (fieldId,wireType) = splitWireTag wireTag -- WIRETYPE_END_GROUP- if wireType == 4 then return message- else if Set.notMember wireTag allowed- then getExt fieldId wireType message >>= go'- else catchError (updater fieldId message)- (\_ -> punt fieldId wireType message)- >>= go'- initialMessage = mergeEmpty- (GetMessageInfo {requiredTags=required,allowedTags=allowed}) = getMessageInfo initialMessage- notEnoughData = throwError ("Text.ProtocolBuffers.WireMessage.getBareMessageWith: Required fields missing when processing "- ++ (show . descName . reflectDescriptorInfo $ initialMessage))+-- OPTIMIZE try inlinining getMessageWith and getBareMessageWith: bench-005, slower -unknownField :: FieldId -> Get a-unknownField fieldId = do - here <- bytesRead- throwError ("Impossible? Text.ProtocolBuffers.WireMessage.unknownField"- ++"\n Updater claims there is an unknown field id on wire: "++show fieldId- ++"\n at a position just before byte location "++show here)--}++-- OPTIMIZE try NO-inlining getMessageWith and getBareMessageWith
protocol-buffers.cabal view
@@ -1,10 +1,10 @@ name: protocol-buffers-version: 1.8.3+version: 2.0.0 cabal-version: >= 1.6 build-type: Simple license: BSD3 license-file: LICENSE-copyright: (c) 2008-2010 Christopher Edward Kuklewicz+copyright: (c) 2008-2011 Christopher Edward Kuklewicz author: Christopher Edward Kuklewicz maintainer: Chris Kuklewicz <protobuf@personal.mightyreason.com> stability: Good@@ -13,38 +13,35 @@ synopsis: Parse Google Protocol Buffer specifications description: Parse proto files and generate Haskell code. category: Text-Tested-With: GHC == 7.0.2---data-files: +Tested-With: GHC == 7.0.3 extra-source-files: TODO README--- extra-tmp-files: flag small_base description: Choose the new smaller, split-up base package. Library- -- Added -fspec-constr-count=10 to quiet ghc-7.0.2- ghc-options: -Wall -O2 -fspec-constr-count=10 -fno-warn-orphans+ -- Added -fspec-constr-count=10 to quiet ghc-7.0.2.+ ghc-options: -Wall -O2 -fspec-constr-count=10 + ghc-prof-options: -auto-all -prof exposed-modules: Text.ProtocolBuffers Text.ProtocolBuffers.Basic- Text.ProtocolBuffers.Default Text.ProtocolBuffers.Extensions Text.ProtocolBuffers.Get Text.ProtocolBuffers.Header- Text.ProtocolBuffers.Mergeable+ Text.ProtocolBuffers.Identifiers Text.ProtocolBuffers.Reflections Text.ProtocolBuffers.Unknown Text.ProtocolBuffers.WireMessage- Text.ProtocolBuffers.Identifiers - build-depends: containers,+ build-depends: array,+ binary, bytestring,- array,- filepath,+ containers, directory,+ filepath, mtl,- binary, parsec, utf8-string, haskell-src,- QuickCheck+ utf8-string if flag(small_base) build-depends: base == 4.*, syb@@ -52,16 +49,36 @@ build-depends: base == 3.* -- Most of these are needed for protocol-buffers (Get and WireMessage.hs)- extensions: DeriveDataTypeable,+-- Nothing especially hazardous in this list+ extensions: BangPatterns,+ CPP,+ DeriveDataTypeable, EmptyDataDecls, FlexibleInstances,+ FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, MagicHash,+ MultiParamTypeClasses, PatternGuards, RankNTypes,+ RecordWildCards ScopedTypeVariables,- TypeSynonymInstances,- MultiParamTypeClasses,- FlexibleContexts,- FunctionalDependencies+ TypeSynonymInstances++-- {-+-- FlexibleContexts,+-- NamedFieldPuns,+-- PatternGuards,+-- BangPatterns+-- CPP+-- DeriveDataTypeable+-- FlexibleInstances+-- FunctionalDependencies+-- GADTs+-- GeneralizedNewtypeDeriving+-- MagicHash+-- MultiParamTypeClasses+-- RankNTypes+-- ScopedTypeVariables+-- TypeSynonymInstances-}