diff --git a/Text/ProtocolBuffers.hs b/Text/ProtocolBuffers.hs --- a/Text/ProtocolBuffers.hs +++ b/Text/ProtocolBuffers.hs @@ -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) diff --git a/Text/ProtocolBuffers/Basic.hs b/Text/ProtocolBuffers/Basic.hs --- a/Text/ProtocolBuffers/Basic.hs +++ b/Text/ProtocolBuffers/Basic.hs @@ -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 -- @@ -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 + diff --git a/Text/ProtocolBuffers/Default.hs b/Text/ProtocolBuffers/Default.hs deleted file mode 100644 --- a/Text/ProtocolBuffers/Default.hs +++ /dev/null @@ -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 diff --git a/Text/ProtocolBuffers/Extensions.hs b/Text/ProtocolBuffers/Extensions.hs --- a/Text/ProtocolBuffers/Extensions.hs +++ b/Text/ProtocolBuffers/Extensions.hs @@ -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 -} diff --git a/Text/ProtocolBuffers/Get.hs b/Text/ProtocolBuffers/Get.hs --- a/Text/ProtocolBuffers/Get.hs +++ b/Text/ProtocolBuffers/Get.hs @@ -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 diff --git a/Text/ProtocolBuffers/Header.hs b/Text/ProtocolBuffers/Header.hs --- a/Text/ProtocolBuffers/Header.hs +++ b/Text/ProtocolBuffers/Header.hs @@ -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 diff --git a/Text/ProtocolBuffers/Identifiers.hs b/Text/ProtocolBuffers/Identifiers.hs --- a/Text/ProtocolBuffers/Identifiers.hs +++ b/Text/ProtocolBuffers/Identifiers.hs @@ -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 diff --git a/Text/ProtocolBuffers/Mergeable.hs b/Text/ProtocolBuffers/Mergeable.hs deleted file mode 100644 --- a/Text/ProtocolBuffers/Mergeable.hs +++ /dev/null @@ -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) diff --git a/Text/ProtocolBuffers/Reflections.hs b/Text/ProtocolBuffers/Reflections.hs --- a/Text/ProtocolBuffers/Reflections.hs +++ b/Text/ProtocolBuffers/Reflections.hs @@ -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) diff --git a/Text/ProtocolBuffers/Unknown.hs b/Text/ProtocolBuffers/Unknown.hs --- a/Text/ProtocolBuffers/Unknown.hs +++ b/Text/ProtocolBuffers/Unknown.hs @@ -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 diff --git a/Text/ProtocolBuffers/WireMessage.hs b/Text/ProtocolBuffers/WireMessage.hs --- a/Text/ProtocolBuffers/WireMessage.hs +++ b/Text/ProtocolBuffers/WireMessage.hs @@ -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 diff --git a/protocol-buffers.cabal b/protocol-buffers.cabal --- a/protocol-buffers.cabal +++ b/protocol-buffers.cabal @@ -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 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-}