-- | 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-- its constructor is (in an ideal world) hidden.---- This first part also includes the keys for the extension fields:-- the 'Key' data type. These are typically defined in code generated-- by 'hprotoc' from '.proto' file definitions.---- The second main part is the 'MessageAPI' class which defines-- 'getVal' and 'isSet'. These allow uniform access to normal and-- extension fields for users.---- Access to extension fields is strictly though keys. There is not-- currently any way to query or change or clear any other extension-- field data.---- This module is likely to get broken up into pieces.moduleText.ProtocolBuffers.Extensions(-- * Query functions for 'Key'getKeyFieldId,getKeyFieldType,getKeyDefaultValue-- * External types and classes,Key(..),ExtKey(..),MessageAPI(..),PackedSeq(..),EP(..)-- * Internal types, functions, and classes,wireSizeExtField,wirePutExtField,loadExtension,notExtension,wireGetKeyToUnPacked,wireGetKeyToPacked,GPB,ExtField(..),ExtendMessage(..),ExtFieldValue(..),)whereimportControl.Monad.Error.Class(throwError)importqualifiedData.ByteString.LazyasLimportqualifiedData.FoldableasFimportData.GenericsimportData.Map(Map)importqualifiedData.MapasMimportData.Maybe(fromMaybe,isJust)importData.Monoid(mappend,mconcat)importData.Sequence((|>),(><))importqualifiedData.SequenceasSeq(singleton,null,empty)importData.Typeable()importText.ProtocolBuffers.BasicimportText.ProtocolBuffers.Default()importText.ProtocolBuffers.WireMessageimportText.ProtocolBuffers.ReflectionsimportText.ProtocolBuffers.GetasGet(Result(..),bytesRead)err::String->berrmsg=error$"Text.ProtocolBuffers.Extensions error\n"++msg-- | The 'Key' data type is used with the 'ExtKey' class to put, get,-- and clear external fields of messages. The 'Key' can also be used-- with the 'MessagesAPI' to get a possibly default value and to check-- whether a key has been set in a message.---- The 'Key' type (opaque to the user) has a phantom type of Maybe-- or Seq that corresponds to Optional or Repeated fields. And a-- second phantom type that matches the message type it must be used-- with. The third type parameter corresonds to the Haskell value-- type.---- The 'Key' is a GADT that puts all the needed class instances into-- scope. The actual content is the 'FieldId' ( numeric key), the-- 'FieldType' (for sanity checks), and @Maybe v@ (a non-standard-- default value).---- When code is generated all of the known keys are taken into account-- in the deserialization from the wire. Unknown extension fields are-- read as a collection of raw byte sequences. If a key is then-- presented it will be used to parse the bytes.-- -- There is no guarantee for what happens if two Keys disagree about-- the type of a field; in particular there may be undefined values-- and runtime errors. The data constructor for 'Key' has to be-- exported to the generated code, but is not exposed to the user by-- "Text.ProtocolBuffers".--dataKeycmsgvwhereKey::(ExtKeyc,ExtendMessagemsg,GPBv)=>FieldId->FieldType->(Maybev)->Keycmsgv-- | This allows reflection, in this case it gives the numerical-- 'FieldId' of the key, from 1 to 2^29-1 (excluding 19,000 through-- 19,999).getKeyFieldId::Keycmsgv->FieldIdgetKeyFieldId(Keyfi__)=fi-- | This allows reflection, in this case it gives the 'FieldType'-- enumeration value (1 to 18) of the-- "Text.DescriptorProtos.FieldDescriptorProto.Type" of the field.getKeyFieldType::Keycmsgv->FieldTypegetKeyFieldType(Key_ft_)=ft-- | This will return the default value for a given 'Key', which is-- set in the '.proto' file, or if unset it is the 'defaultValue' of-- that type.getKeyDefaultValue::Keycmsgv->vgetKeyDefaultValue(Key__md)=fromMaybedefaultValuemdinstanceTypeable1c=>Typeable2(Keyc)wheretypeOf2_=mkTyConApp(mkTyCon"Text.ProtocolBuffers.Extensions.Key")[typeOf1(undefined::c())]instance(Typeable1c,Typeablemsg,Typeablev)=>Show(Keycmsgv)whereshowkey@(KeyfieldIdfieldTypemaybeDefaultValue)=concat["(Key (",showfieldId,") (",showfieldType,") (",showmaybeDefaultValue,") :: ",show(typeOfkey),")"]-- | 'GPWitness' is an instance witness for the 'GPB' classes. This-- exists mainly to be a part of 'GPDyn' or 'GPDynSeq'.dataGPWitnessawhereGPWitness::(GPBa)=>GPWitnessaderiving(Typeable)-- | 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.dataGPDyn=foralla.GPDyn!(GPWitnessa)aderiving(Typeable)-- | The 'GPDynSeq' is another specialization of 'Dynamic' and is used-- in 'ExtRepeated' for repeated fields.dataGPDynSeq=foralla.GPDynSeq!(GPWitnessa)!(Seqa)deriving(Typeable)-- | The 'PackedSeq' is needed to distinguish the packed repeated format from the repeated format.-- This is only used in the phantom type of Key.newtypePackedSeqa=PackedSeq{unPackedSeq::(Seqa)}deriving(Typeable)-- | The WireType is used to ensure the Seq is homogenous.-- The ByteString is the unparsed input after the tag.dataExtFieldValue=ExtFromWire!(SeqEP)-- XXX must store wiretype with ByteString|ExtOptional!FieldType!GPDyn|ExtRepeated!FieldType!GPDynSeq|ExtPacked!FieldType!GPDynSeqderiving(Typeable,Ord,Show)dataEP=EP{-# UNPACK #-}!WireType!ByteStringderiving(Typeable,Eq,Ord,Show)dataDummyMessageTypederiving(Typeable)instanceExtendMessageDummyMessageTypewheregetExtField=undefinedputExtField=undefinedvalidExtRanges=undefined-- I want a complicated comparison here to at least allow testing of-- setting a field, writing to wire, reading back from wire, and-- comparing.---- The comparison of ExtFromWire with ExtFromWire is conservative-- about returning True. It is entirely possible that if both value-- were interpreted by the same Key that their resulting values would-- compare True.instanceEqExtFieldValuewhere(==)(ExtFromWireb)(ExtFromWireb')=b==b'(==)(ExtOptionalab)(ExtOptionala'b')=a==a'&&b==b'(==)(ExtRepeatedab)(ExtRepeateda'b')=a==a'&&b==b'(==)(ExtPackedab)(ExtPackeda'b')=a==a'&&b==b'(==)x@(ExtOptionalft(GPDynw@GPWitness_))(ExtFromWires')=letwt=toWireTypeftmakeKeyType::GPWitnessa->KeyMaybeDummyMessageTypeamakeKeyType=undefinedkey=Key0ftNothing`asTypeOf`makeKeyTypewincaseparseWireExtMaybekeywts'ofRight(_,y)->x==y_->False(==)y@(ExtFromWire{})x@(ExtOptional{})=x==y(==)x@(ExtRepeatedft(GPDynSeqw@GPWitness_))(ExtFromWires')=letwt=toWireTypeftmakeKeyType::GPWitnessa->KeySeqDummyMessageTypeamakeKeyType=undefinedkey=Key0ftNothing`asTypeOf`makeKeyTypewincaseparseWireExtSeqkeywts'ofRight(_,y)->x==y_->False(==)y@(ExtFromWire{})x@(ExtRepeated{})=x==y(==)x@(ExtPackedft(GPDynSeqw@GPWitness_))(ExtFromWires')=letwt=2-- all packed types have wire type 2, length delimitedmakeKeyType::GPWitnessa->KeyPackedSeqDummyMessageTypeamakeKeyType=undefinedkey=Key0ftNothing`asTypeOf`makeKeyTypewincaseparseWireExtPackedSeqkeywts'ofRight(_,y)->x==y_->False(==)y@(ExtFromWire{})x@(ExtPacked{})=x==y(==)__=False-- | ExtField is a newtype'd map from the numeric FieldId key to the-- ExtFieldValue. This allows for the needed class instances.newtypeExtField=ExtField(MapFieldIdExtFieldValue)deriving(Typeable,Eq,Ord,Show)-- | 'ExtendMessage' abstracts the operations of storing and-- retrieving the 'ExtField' from the message, and provides the-- reflection needed to know the valid field numbers.---- This only used internally.classTypeablemsg=>ExtendMessagemsgwheregetExtField::msg->ExtFieldputExtField::ExtField->msg->msgvalidExtRanges::msg->[(FieldId,FieldId)]-- 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 keywireGetKeyToUnPacked::(ExtendMessagemsg,GPBv)=>KeySeqmsgv->msg->GetmsgwireGetKeyToUnPackedk@(Keyitmv)msg=doletmyCast::Maybea->Get(Seqa)myCast=undefinedvv<-wireGetPackedt`asTypeOf`(myCastmv)let(ExtFieldef)=getExtFieldmsgv'<-caseM.lookupiefofNothing->return$ExtRepeatedt(GPDynSeqGPWitnessvv)Just(ExtRepeatedt'(GPDynSeqGPWitnesss))|t/=t'->fail$"wireGetKeyToUnPacked: Key mismatch! found wrong field type: "++show(k,t,t')|otherwise->casecastsofNothing->fail$"wireGetKeyToUnPacked: previous Seq value cast failed: "++show(k,typeOfs)Justs'->return$ExtRepeatedt(GPDynSeqGPWitness(s'><vv))Just(ExtFromWireraw)->caseparseWireExtSeqk(toWireTypet)rawof-- was wt from ExtFromWireLefterrMsg->fail$"wireGetKeyToUnPacked: Could not parseWireExtSeq: "++showk++"\n"++errMsgRight(_,ExtRepeatedt'(GPDynSeqGPWitnesss))|t/=t'->fail$"wireGetKeyToUnPacked:: Key mismatch! parseWireExtSeq returned wrong field type: "++show(k,t,t')|otherwise->casecastsofNothing->fail$"wireGetKey Seq: previous Seq value cast failed: "++show(k,typeOfs)Justs'->return$ExtRepeatedt(GPDynSeqGPWitness(s'><vv))wtf->fail$"wireGetKeyToUnPacked: Weird parseWireExtSeq return value: "++show(k,wtf)Justwtf@(ExtOptional{})->fail$"wireGetKeyToUnPacked: ExtOptional found when ExtRepeated expected: "++show(k,wtf)Justwtf@(ExtPacked{})->fail$"wireGetKeyToUnPacked: ExtPacked found when ExtRepeated expected: "++show(k,wtf)letef'=M.insertiv'efseqv'$seqef'$return(putExtField(ExtFieldef')msg)wireGetKeyToPacked::(ExtendMessagemsg,GPBv)=>KeyPackedSeqmsgv->msg->GetmsgwireGetKeyToPackedk@(Keyitmv)msg=doletwt=toWireTypetmyCast::Maybea->GetamyCast=undefinedv<-wireGett`asTypeOf`(myCastmv)let(ExtFieldef)=getExtFieldmsgv'<-caseM.lookupiefofNothing->return$ExtPackedt(GPDynSeqGPWitness(Seq.singletonv))Just(ExtPackedt'(GPDynSeqGPWitnesss))|t/=t'->fail$"wireGetKeyToPacked: Key mismatch! found wrong field type: "++show(k,t,t')|otherwise->casecastsofNothing->fail$"wireGetKeyToPacked: previous Seq value cast failed: "++show(k,typeOfs)Justs'->return$ExtRepeatedt(GPDynSeqGPWitness(s'|>v))Just(ExtFromWireraw)->caseparseWireExtPackedSeqkwtrawofLefterrMsg->fail$"wireGetKeyToPacked: Could not parseWireExtPackedSeq: "++showk++"\n"++errMsgRight(_,ExtPackedt'(GPDynSeqGPWitnesss))|t/=t'->fail$"wireGetKeyToPacked: Key mismatch! parseWireExtPackedSeq returned wrong field type: "++show(k,t,t')|otherwise->casecastsofNothing->fail$"wireGetKeyToPacked: previous Seq value cast failed: "++show(k,typeOfs)Justs'->return$ExtRepeatedt(GPDynSeqGPWitness(s'|>v))wtf->fail$"wireGetKeyToPacked: Weird parseWireExtPackedSeq return value: "++show(k,wtf)Justwtf@(ExtOptional{})->fail$"wireGetKeyToPacked: ExtOptional found when ExtPacked expected: "++show(k,wtf)Justwtf@(ExtRepeated{})->fail$"wireGetKeyToPacked: ExtRepeated found when ExtPacked expected: "++show(k,wtf)letef'=M.insertiv'efseqv'$seqef'$return(putExtField(ExtFieldef')msg)-- | The 'ExtKey' class has three functions for user of the API:-- 'putExt', 'getExt', and 'clearExt'. The 'wireGetKey' is used in-- generated code.---- There are two instances of this class, 'Maybe' for optional message-- fields and 'Seq' for repeated message fields. This class allows-- for uniform treatment of these two kinds of extension fields.classExtKeycwhere-- | Change or clear the value of a key in a message. Passing-- 'Nothing' with an optional key or an empty 'Seq' with a repeated-- key clears the value. This function thus maintains the invariant-- that having a field number in the 'ExtField' map means that the-- field is set and not empty.---- This should be only way to set the contents of a extension field.putExt::Keycmsgv->cv->msg->msg-- | Access the key in the message. Optional have type @(Key Maybe-- msg v)@ and return type @(Maybe v)@ while repeated fields have-- type @(Key Seq msg v)@ and return type @(Seq v)@.---- There are a few sources of errors with the lookup of the key:---- * It may find unparsed bytes from loading the message. 'getExt'-- will attempt to parse the bytes as the key\'s value type, and-- may fail. The parsing is done with the 'parseWireExt' method-- (which is not exported to user API).---- * The wrong optional-key versus repeated-key type is a failure-- -- * The wrong type of the value might be found in the map and-- * cause a failure---- The failures above should only happen if two different keys are-- used with the same field number.getExt::Keycmsgv->msg->EitherString(cv)-- 'clearExt' unsets the field of the 'Key' if it is present.clearExt::Keycmsgv->msg->msg-- 'wireGetKey' is used in generated code to load extension fields-- which are defined in the same '.proto' file as the message. This-- results in the storing the parsed type instead of the raw bytes-- inside the message.wireGetKey::Keycmsgv->msg->Getmsg-- | The 'Key' and 'GPWitness' GADTs use 'GPB' as a shorthand for many-- classes.class(Mergeablea,Defaulta,Wirea,Showa,Typeablea,Eqa,Orda)=>GPBainstanceGPBBoolinstanceGPBByteStringinstanceGPBUtf8instanceGPBDoubleinstanceGPBFloatinstanceGPBInt32instanceGPBInt64instanceGPBWord32instanceGPBWord64instanceMergeableExtFieldwheremergeEmpty=ExtFieldM.emptymergeAppend(ExtFieldm1)(ExtFieldm2)=ExtField(M.unionWithmergeExtFieldValuem1m2)mergeExtFieldValue::ExtFieldValue->ExtFieldValue->ExtFieldValuemergeExtFieldValue(ExtFromWires1)(ExtFromWires2)=ExtFromWire(mappends1s2)mergeExtFieldValue(ExtOptionalft1(GPDynGPWitnessd1))(ExtOptionalft2(GPDynGPWitnessd2))=ifft1/=ft2thenerr$"mergeExtFieldValue : ExtOptional FieldType mismatch "++show(ft1,ft2)elsecasecastd2ofNothing->err$"mergeExtFieldValue : ExtOptional cast failed, FieldType "++show(ft2,typeOfd1,typeOfd2)Justd2'->ExtOptionalft2(GPDynGPWitness(mergeAppendd1d2'))mergeExtFieldValue(ExtRepeatedft1(GPDynSeqGPWitnesss1))(ExtRepeatedft2(GPDynSeqGPWitnesss2))=ifft1/=ft2thenerr$"mergeExtFieldValue : ExtRepeated FieldType mismatch "++show(ft1,ft2)elsecasecasts2ofNothing->err$"mergeExtFieldValue : ExtRepeated cast failed, FieldType "++show(ft2,typeOfs1,typeOfs2)Justs2'->ExtRepeatedft2(GPDynSeqGPWitness(mappends1s2'))mergeExtFieldValue(ExtPackedft1(GPDynSeqGPWitnesss1))(ExtPackedft2(GPDynSeqGPWitnesss2))=ifft1/=ft2thenerr$"mergeExtFieldValue : ExtPacked FieldType mismatch "++show(ft1,ft2)elsecasecasts2ofNothing->err$"mergeExtFieldValue : ExtPacked cast failed, FieldType "++show(ft2,typeOfs1,typeOfs2)Justs2'->ExtPackedft2(GPDynSeqGPWitness(mappends1s2'))mergeExtFieldValueab=err$"mergeExtFieldValue : mismatch of constructors "++show(a,b)instanceDefaultExtFieldwheredefaultValue=ExtFieldM.emptyinstanceShow(GPWitnessa)whereshowsPrec_nGPWitness=("(GPWitness :: GPWitness ("++).shows(typeOf(undefined::a)).(')':).(')':)instanceEq(GPWitnessa)where(==)GPWitnessGPWitness=True(/=)GPWitnessGPWitness=FalseinstanceOrd(GPWitnessa)wherecompareGPWitnessGPWitness=EQinstance(GPBa)=>Data(GPWitnessa)wheregunfold_kzc=caseconstrIndexcof1->zGPWitness_->err"gunfold of GPWitness error"toConstrGPWitness=gpWitnessCdataTypeOf_=gpWitnessDTgpWitnessC::ConstrgpWitnessC=mkConstrgpWitnessDT"GPWitness"[]PrefixgpWitnessDT::DataTypegpWitnessDT=mkDataType"GPWitness"[gpWitnessC]{-
gpDynC :: Constr
gpDynC = mkConstr gpDynDT "GPDyn" ["a"] Prefix
gpDynDT :: DataType
gpDynDT = mkDataType "GPDyn" [gpDynC]
fromGPDyn :: (GPB a) => GPDyn -> Maybe a
fromGPDyn (GPDyn GPWitness a) = cast a
typeOfGPDyn :: GPDyn -> TypeRep
typeOfGPDyn (GPDyn GPWitness a) = typeOf a
defaultValueGPDyn :: GPWitness a -> GPDyn
defaultValueGPDyn x@GPWitness = GPDyn x defaultValue
mergeEmptyGPDyn :: GPWitness a -> GPDyn
mergeEmptyGPDyn x@GPWitness = GPDyn x mergeEmpty
mergeAppendGPDyn :: GPDyn -> GPDyn -> Maybe GPDyn
mergeAppendGPDyn (GPDyn GPWitness a1) (GPDyn GPWitness a2) = fmap (GPDyn GPWitness . mergeAppend a1) (cast a2)
-}instanceEqGPDynwhere(==)ab=fromMaybeFalse(eqGPDynab)instanceOrdGPDynwherecompareab=fromMaybe(compare(showa)(showb))(ordGPDynab)instanceShowGPDynwhereshowsPrec_n(GPDynx@GPWitnessa)=("(GPDyn "++).showsx.(" ("++).showsa.("))"++)instanceEqGPDynSeqwhere(==)ab=fromMaybeFalse(eqGPDynSeqab)instanceOrdGPDynSeqwherecompareab=fromMaybe(compare(showa)(showb))(ordGPDynSeqab)instanceShowGPDynSeqwhereshowsPrec_n(GPDynSeqx@GPWitnesss)=("(GPDynSeq "++).showsx.(" ("++).showss.("))"++)ordGPDyn::GPDyn->GPDyn->MaybeOrderingordGPDyn(GPDynGPWitnessa1)(GPDynGPWitnessa2)=fmap(comparea1)(casta2)eqGPDyn::GPDyn->GPDyn->MaybeBooleqGPDyn(GPDynGPWitnessa1)(GPDynGPWitnessa2)=fmap(a1==)(casta2)-- showGPDyn :: GPDyn -> String-- showGPDyn (GPDyn GPWitness s) = show sordGPDynSeq::GPDynSeq->GPDynSeq->MaybeOrderingordGPDynSeq(GPDynSeqGPWitnessa1)(GPDynSeqGPWitnessa2)=fmap(comparea1)(casta2)eqGPDynSeq::GPDynSeq->GPDynSeq->MaybeBooleqGPDynSeq(GPDynSeqGPWitnessa1)(GPDynSeqGPWitnessa2)=fmap(a1==)(casta2)-- showGPDynSeq :: GPDynSeq -> String-- showGPDynSeq (GPDynSeq GPWitness s) = show s-- wireSizeGPDyn :: FieldType -> GPDyn -> WireSize-- wireSizeGPDyn ft (GPDyn GPWitness a) = wireSize ft a -- wirePutGPDyn :: FieldType -> GPDyn -> Put-- wirePutGPDyn ft (GPDyn GPWitness a) = wirePut ft a -- wireGetGPDyn :: forall a. GPWitness a -> FieldType -> Get GPDyn-- wireGetGPDyn GPWitness ft = fmap (GPDyn GPWitness) (wireGet ft :: Get a)-- getWitness :: (GPB a) => GPDyn -> Maybe (GPWitness a)-- getWitness (GPDyn x@GPWitness _) = cast x-- readGPDyn :: forall a . Read a => GPWitness a -> String -> GPDyn-- readGPDyn x@(GPWitness) s =-- let t :: a; t = read s-- in GPDyn x tinstanceExtKeyMaybewhereputExtkeyNothingmsg=clearExtkeymsgputExt(Keyit_)(Justv)msg=let(ExtFieldef)=getExtFieldmsgv'=ExtOptionalt(GPDynGPWitnessv)ef'=M.insertiv'efinseqv'$seqef'(putExtField(ExtFieldef')msg)clearExt(Keyi__)msg=let(ExtFieldef)=getExtFieldmsgef'=M.deleteiefinseqef'(putExtField(ExtFieldef')msg)getExtk@(Keyit_)msg=letwt=toWireTypet(ExtFieldef)=getExtFieldmsgincaseM.lookupiefofNothing->RightNothingJust(ExtFromWireraw)->eitherLeft(getExt'.snd)(parseWireExtMaybekwtraw)Justx->getExt'xwheregetExt'(ExtRepeatedt'_)=Left$"getExt Maybe: ExtField has repeated type: "++show(k,t')getExt'(ExtPackedt'_)=Left$"getExt Maybe: ExtField has packed type: "++show(k,t')getExt'(ExtOptionalt'(GPDynGPWitnessd))|t/=t'=Left$"getExt Maybe: Key's FieldType does not match ExtField's: "++show(k,t')|otherwise=casecastdofNothing->Left$"getExt Maybe: Key's value cast failed: "++show(k,typeOfd)Justd'->Right(Justd')getExt'(ExtFromWire{})=err$"Impossible? getExt.getExt' Maybe should not have ExtFromWire case (after parseWireExt)!"wireGetKeyk@(Keyitmv)msg=doletwt=toWireTypetmyCast::Maybea->GetamyCast=undefinedv<-wireGett`asTypeOf`(myCastmv)let(ExtFieldef)=getExtFieldmsgv'<-caseM.lookupiefofNothing->return$ExtOptionalt(GPDynGPWitnessv)Just(ExtOptionalt'(GPDynGPWitnessvOld))|t/=t'->fail$"wireGetKey Maybe: Key mismatch! found wrong field type: "++show(k,t,t')|otherwise->casecastvOldofNothing->fail$"wireGetKey Maybe: previous Maybe value case failed: "++show(k,typeOfvOld)JustvOld'->return$ExtOptionalt(GPDynGPWitness(mergeAppendvOld'v))Just(ExtFromWireraw)->caseparseWireExtMaybekwtrawofLefterrMsg->fail$"wireGetKey Maybe: Could not parseWireExtMaybe: "++showk++"\n"++errMsgRight(_,ExtOptionalt'(GPDynGPWitnessvOld))|t/=t'->fail$"wireGetKey Maybe: Key mismatch! found wrong field type: "++show(k,t,t')|otherwise->casecastvOldofNothing->fail$"wireGetKey Maybe: previous Maybe value case failed: "++show(k,typeOfvOld)JustvOld'->return$ExtOptionalt(GPDynGPWitness(mergeAppendvOld'v))wtf->fail$"wireGetKey Maybe: Weird parseGetWireMaybe return value: "++show(k,wtf)Justwtf@(ExtRepeated{})->fail$"wireGetKey Maybe: ExtRepeated found with ExtOptional expected: "++show(k,wtf)Justwtf@(ExtPacked{})->fail$"wireGetKey Maybe: ExtPacked found with ExtOptional expected: "++show(k,wtf)letef'=M.insertiv'efseqv'$seqef'$return(putExtField(ExtFieldef')msg)-- | used by 'getVal' and 'wireGetKey' for the 'Maybe' instanceparseWireExtMaybe::KeyMaybemsgv->WireType->SeqEP->EitherString(FieldId,ExtFieldValue)parseWireExtMaybek@(Keyfiftmv)wtraw|wt/=toWireTypeft=Left$"parseWireExt Maybe: Key's FieldType does not match ExtField's wire type: "++show(k,toWireTypeft,wt)|otherwise=doletmkWitType::Maybea->GPWitnessamkWitType=undefinedwitness=GPWitness`asTypeOf`(mkWitTypemv)-- parsed = map (applyGet (wireGet ft)) . F.toList $ rawparsed=map(chooseGetft).F.toList$rawerrs=[m|Leftm<-parsed]ifnullerrsthenRight(fi,(ExtOptionalft(GPDynwitness(mergeConcat.mconcat$[a|Righta<-parsed]))))elseLeft(unlineserrs)-- '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 WireTypechooseGet::(Wirer)=>FieldType->EP->EitherString(Seqr)chooseGetft(EPwtbsIn)=if(2==wt)&&(isValidPackedft)thenapplyGet(wireGetPackedft)bsInelseif(wt==toWireTypeft)thenapplyGet(fmapSeq.singleton$wireGetft)bsInelseLeft$"Text.ProtocolBuffers.Extensions.chooseGet: wireType mismatch "++show(wt,ft)-- | Converts the the 'Result' into an 'Either' type and enforces-- consumption of entire 'ByteString'. Used by 'parseWireExtMaybe'-- and 'parseWireExtSeq' to process raw wire input that has been-- stored in an 'ExtField'.applyGet::Getr->ByteString->EitherStringrapplyGetgbsIn=resolveEOF(runGetgbsIn)whereresolveEOF::Resultr->EitherStringrresolveEOF(Failedis)=Left("Failed at "++showi++" : "++s)resolveEOF(Finishedbs_ir)|L.nullbs=Rightr|otherwise=Left"Not all input consumed"resolveEOF(Partial{})=Left"Not enough input"instanceExtKeySeqwhereputExtkey@(Keyit_)smsg|Seq.nulls=clearExtkeymsg|otherwise=let(ExtFieldef)=getExtFieldmsgv'=ExtRepeatedt(GPDynSeqGPWitnesss)ef'=M.insertiv'efinseqv'$seqef'(putExtField(ExtFieldef')msg)clearExt(Keyi__)msg=let(ExtFieldef)=getExtFieldmsgef'=M.deleteiefinseqef'(putExtField(ExtFieldef')msg)getExtk@(Keyit_)msg=letwt=toWireTypet(ExtFieldef)=getExtFieldmsgincaseM.lookupiefofNothing->RightSeq.emptyJust(ExtFromWireraw)->eitherLeft(getExt'.snd)(parseWireExtSeqkwtraw)Justx->getExt'xwheregetExt'(ExtOptionalt'_)=Left$"getExt Seq: ExtField has optional type: "++show(k,t')getExt'(ExtPackedt'_)=Left$"getExt Seq: ExtField has packed type: "++show(k,t')getExt'(ExtRepeatedt'(GPDynSeqGPWitnesss))|t'/=t=Left$"getExt Seq: Key's FieldType does not match ExtField's: "++show(k,t')|otherwise=casecastsofNothing->Left$"getExt Seq: Key's Seq value cast failed: "++show(k,typeOfs)Justs'->Rights'getExt'(ExtFromWire{})=err$"Impossible? getExt.getExt' Seq should not have ExtFromWire case (after parseWireExtSeq)!"-- This is more complicated than the Maybe instance because the old-- Seq needs to be retrieved and perhaps parsed and then appended-- to. All sanity checks are included below. TODO: do enough-- testing to be confident in removing some checks.wireGetKeyk@(Keyitmv)msg=doletwt=toWireTypetmyCast::Maybea->GetamyCast=undefinedv<-wireGett`asTypeOf`(myCastmv)let(ExtFieldef)=getExtFieldmsgv'<-caseM.lookupiefofNothing->return$ExtRepeatedt(GPDynSeqGPWitness(Seq.singletonv))Just(ExtRepeatedt'(GPDynSeqGPWitnesss))|t/=t'->fail$"wireGetKey Seq: Key mismatch! found wrong field type: "++show(k,t,t')|otherwise->casecastsofNothing->fail$"wireGetKey Seq: previous Seq value cast failed: "++show(k,typeOfs)Justs'->return$ExtRepeatedt(GPDynSeqGPWitness(s'|>v))Just(ExtFromWireraw)->caseparseWireExtSeqkwtrawofLefterrMsg->fail$"wireGetKey Seq: Could not parseWireExtSeq: "++showk++"\n"++errMsgRight(_,ExtRepeatedt'(GPDynSeqGPWitnesss))|t/=t'->fail$"wireGetKey Seq: Key mismatch! parseWireExtSeq returned wrong field type: "++show(k,t,t')|otherwise->casecastsofNothing->fail$"wireGetKey Seq: previous Seq value cast failed: "++show(k,typeOfs)Justs'->return$ExtRepeatedt(GPDynSeqGPWitness(s'|>v))wtf->fail$"wireGetKey Seq: Weird parseWireExtSeq return value: "++show(k,wtf)Justwtf@(ExtOptional{})->fail$"wireGetKey Seq: ExtOptional found when ExtRepeated expected: "++show(k,wtf)Justwtf@(ExtPacked{})->fail$"wireGetKey Seq: ExtPacked found when ExtRepeated expected: "++show(k,wtf)letef'=M.insertiv'efseqv'$seqef'$return(putExtField(ExtFieldef')msg)-- | used by 'getVal' and 'wireGetKey' for the 'Seq' instanceparseWireExtSeq::KeySeqmsgv->WireType->SeqEP->EitherString(FieldId,ExtFieldValue)parseWireExtSeqk@(Keyitmv)wtraw|wt/=toWireTypet=Left$"parseWireExtSeq: Key mismatch! Key's FieldType does not match ExtField's wire type: "++show(k,toWireTypet,wt)|otherwise=doletmkWitType::Maybea->GPWitnessamkWitType=undefinedwitness=GPWitness`asTypeOf`(mkWitTypemv)-- parsed = map (applyGet (wireGet t)) . F.toList $ rawparsed=map(chooseGett).F.toList$rawerrs=[m|Leftm<-parsed]ifnullerrsthenRight(i,(ExtRepeatedt(GPDynSeqwitness(mconcat[a|Righta<-parsed]))))elseLeft(unlineserrs)instanceExtKeyPackedSeqwhereputExtkey@(Keyit_)(PackedSeqs)msg|Seq.nulls=clearExtkeymsg|otherwise=let(ExtFieldef)=getExtFieldmsgv'=ExtPackedt(GPDynSeqGPWitnesss)ef'=M.insertiv'efinseqv'$seqef'(putExtField(ExtFieldef')msg)clearExt(Keyi__)msg=let(ExtFieldef)=getExtFieldmsgef'=M.deleteiefinseqef'(putExtField(ExtFieldef')msg)getExtk@(Keyit_)msg=letwt=toWireTypet(ExtFieldef)=getExtFieldmsgincaseM.lookupiefofNothing->Right(PackedSeqSeq.empty)Just(ExtFromWireraw)->eitherLeft(getExt'.snd)(parseWireExtPackedSeqkwtraw)Justx->getExt'xwheregetExt'(ExtOptionalt'_)=Left$"getExt PackedSeq: ExtField has optional type: "++show(k,t')getExt'(ExtRepeatedt'_)=Left$"getExt PackedSeq: ExtField has repeated type: "++show(k,t')getExt'(ExtPackedt'(GPDynSeqGPWitnesss))|t'/=t=Left$"getExt PackedSeq: Key's FieldType does not match ExtField's: "++show(k,t')|otherwise=casecastsofNothing->Left$"getExt PackedSeq: Key's Seq value cast failed: "++show(k,typeOfs)Justs'->Right(PackedSeqs')getExt'(ExtFromWire{})=err$"Impossible? getExt.getExt' PackedSeq should not have ExtFromWire case (after parseWireExtSeq)!"wireGetKeyk@(Keyitmv)msg=doletwt=toWireTypetmyCast::Maybea->Get(Seqa)myCast=undefinedvv<-wireGetPackedt`asTypeOf`(myCastmv)let(ExtFieldef)=getExtFieldmsgv'<-caseM.lookupiefofNothing->return$ExtPackedt(GPDynSeqGPWitnessvv)Just(ExtPackedt'(GPDynSeqGPWitnesss))|t/=t'->fail$"wireGetKey PackedSeq: Key mismatch! found wrong field type: "++show(k,t,t')|otherwise->casecastsofNothing->fail$"wireGetKey PackedSeq: previous Seq value cast failed: "++show(k,typeOfs)Justs'->return$ExtRepeatedt(GPDynSeqGPWitness(s'><vv))Just(ExtFromWireraw)->caseparseWireExtPackedSeqkwtrawofLefterrMsg->fail$"wireGetKey PackedSeq: Could not parseWireExtPackedSeq: "++showk++"\n"++errMsgRight(_,ExtPackedt'(GPDynSeqGPWitnesss))|t/=t'->fail$"wireGetKey PackedSeq: Key mismatch! parseWireExtPackedSeq returned wrong field type: "++show(k,t,t')|otherwise->casecastsofNothing->fail$"wireGetKey PackedSeq: previous Seq value cast failed: "++show(k,typeOfs)Justs'->return$ExtRepeatedt(GPDynSeqGPWitness(s'><vv))wtf->fail$"wireGetKey PackedSeq: Weird parseWireExtPackedSeq return value: "++show(k,wtf)Justwtf@(ExtOptional{})->fail$"wireGetKey PackedSeq: ExtOptional found when ExtPacked expected: "++show(k,wtf)-- XXX XXX XXX 2.3.0 need to add handling to the next line?Justwtf@(ExtRepeated{})->fail$"wireGetKey PackedSeq: ExtRepeated found when ExtPacked expected: "++show(k,wtf)letef'=M.insertiv'efseqv'$seqef'$return(putExtField(ExtFieldef')msg)parseWireExtPackedSeq::KeyPackedSeqmsgv->WireType->SeqEP->EitherString(FieldId,ExtFieldValue)parseWireExtPackedSeqk@(Keyitmv)wtraw|wt/=2{- packed wire type is 2, length delimited -}=Left$"parseWireExtPackedSeq: Key mismatch! Key's FieldType does not match ExtField's wire type: "++show(k,toWireTypet,wt)|otherwise=doletmkWitType::Maybea->GPWitnessamkWitType=undefinedwitness=GPWitness`asTypeOf`(mkWitTypemv)-- parsed = map (applyGet (wireGetPacked t)) . F.toList $ rawparsed=map(chooseGett).F.toList$rawerrs=[m|Leftm<-parsed]ifnullerrsthenRight(i,(ExtPackedt(GPDynSeqwitness(mconcat[a|Righta<-parsed]))))elseLeft(unlineserrs)-- | This is used by the generated codewireSizeExtField::ExtField->WireSizewireSizeExtField(ExtFieldm)=F.foldl'aSize0(M.assocsm)whereaSizeold(fi,(ExtFromWireraw))=lettoSize(EPwtbs)=(size'Varint(getWireTag(mkWireTagfiwt)))+L.lengthbsinF.foldl'(\oldValnew->oldVal+toSizenew)oldraw{-
aSize old (fi,(ExtFromWire raw)) = old +
let tagSize = size'Varint (getWireTag (mkWireTag fi wt))
in F.foldl' (\oldVal new -> oldVal + L.length new) (fromIntegral (Seq.length raw) * tagSize) raw
-}aSizeold(fi,(ExtOptionalft(GPDynGPWitnessd)))=old+lettagSize=size'Varint(getWireTag(toWireTagfift))inwireSizeReqtagSizeftdaSizeold(fi,(ExtRepeatedft(GPDynSeqGPWitnesss)))=old+lettagSize=size'Varint(getWireTag(toWireTagfift))inwireSizeReptagSizeftsaSizeold(fi,(ExtPackedft(GPDynSeqGPWitnesss)))=old+lettagSize=size'Varint(getWireTag(toPackedWireTagfi))inwireSizePackedtagSizefts-- | This is used by the generated code. The data is serialized in-- order of increasing field number.wirePutExtField::ExtField->PutwirePutExtField(ExtFieldm)=mapM_aPut(M.assocsm)whereaPut(fi,(ExtFromWireraw))=F.mapM_(\(EPwtbs)->putVarUInt(getWireTag$mkWireTagfiwt)>>putLazyByteStringbs)rawaPut(fi,(ExtOptionalft(GPDynGPWitnessd)))=wirePutOpt(toWireTagfift)ft(Justd)aPut(fi,(ExtRepeatedft(GPDynSeqGPWitnesss)))=wirePutRep(toWireTagfift)ftsaPut(fi,(ExtPackedft(GPDynSeqGPWitnesss)))=wirePutPacked(toPackedWireTagfi)ftsnotExtension::(ReflectDescriptora,ExtendMessagea,Typeablea)=>FieldId->WireType->a->GetanotExtensionfieldId_wireTypemsg=throwError("Field id "++showfieldId++" is not a valid extension field id for "++show(typeOf(undefined`asTypeOf`msg)))-- | get a value from the wire into the message's ExtField. This is used by generated code for-- extensions that were not known at compile time.loadExtension::(ReflectDescriptora,ExtendMessagea)=>FieldId->WireType->a->Geta--loadExtension fieldId wireType msg | isValidExt fieldId msg = do -- XXX check moved to generated code--loadExtension fieldId wireType msg = unknown fieldId wireType msg -- XXXloadExtensionfieldIdwireTypemsg=dolet(ExtFieldef)=getExtFieldmsgbadwt::WireType->Getabadwtwt=dohere<-bytesReadfail$"Conflicting wire types at byte position "++showhere++" for extension to message: "++show(typeOfmsg,fieldId,wireType,wt)caseM.lookupfieldIdefofNothing->dobs<-wireGetFromWirefieldIdwireTypeletv'=ExtFromWire(Seq.singleton(EPwireTypebs))ef'=M.insertfieldIdv'efseqv'$seqef'$return$putExtField(ExtFieldef')msgJust(ExtFromWireraw)->dobs<-wireGetFromWirefieldIdwireTypeletv'=ExtFromWire(raw|>(EPwireTypebs))ef'=M.insertfieldIdv'efseqv'$seqef'$return(putExtField(ExtFieldef')msg)Just(ExtOptionalft(GPDynx@GPWitnessa))|toWireTypeft/=wireType->badwt(toWireTypeft)|otherwise->dob<-wireGetftletv'=ExtOptionalft(GPDynx(mergeAppendab))ef'=M.insertfieldIdv'efseqv'$seqef'$return(putExtField(ExtFieldef')msg)-- handle wireType of "2" when toWireType ft is not "2" but ft could be packed by using wireGetPacked ftJust(ExtRepeatedft(GPDynSeqx@GPWitnesss))|toWireTypeft/=wireType->if(wireType==2)&&(isValidPackedft)thendoaa<-wireGetPackedftletv'=ExtRepeatedft(GPDynSeqx(s><aa))ef'=M.insertfieldIdv'efseqv'$seqef'$return(putExtField(ExtFieldef')msg)elsebadwt(toWireTypeft)|otherwise->doa<-wireGetftletv'=ExtRepeatedft(GPDynSeqx(s|>a))ef'=M.insertfieldIdv'efseqv'$seqef'$return(putExtField(ExtFieldef')msg)-- handle wireType of NOT "2" when wireType is good match for ft by using wireGet ftJust(ExtPackedft(GPDynSeqx@GPWitnesss))|2/=wireType->if(toWireTypeft)==wireTypethendoa<-wireGetftletv'=ExtPackedft(GPDynSeqx(s|>a))ef'=M.insertfieldIdv'efseqv'$seqef'$return(putExtField(ExtFieldef')msg)elsebadwt2{- packed uses length delimited: 2 -}|otherwise->doaa<-wireGetPackedftletv'=ExtPackedft(GPDynSeqx(s><aa))ef'=M.insertfieldIdv'efseqv'$seqef'$return(putExtField(ExtFieldef')msg)classMessageAPImsgab|msga->bwhere-- | Access data in a message. The first argument is always the-- message. The second argument can be one of 4 categories.---- * The field name of a required field acts a simple retrieval of-- the data from the message.---- * The field name of an optional field will retreive the data if-- it is set or lookup the default value if it is not set.---- * The field name of a repeated field always retrieves the-- (possibly empty) 'Seq' of values.---- * A Key for an optional or repeated value will act as the field-- name does above, but if there is a type mismatch or parse error-- it will use the defaultValue for optional types and an empty-- sequence for repeated types.getVal::msg->a->b-- | Check whether data is present in the message.---- * Required fields always return 'True'.---- * Optional fields return whether a value is present.---- * Repeated field return 'False' if there are no values, otherwise-- they return 'True'.---- * Keys return as optional or repeated, but checks only if the-- field # is present. This assumes that there are no collisions-- where more that one key refers to the same field number of this-- message type.isSet::msg->a->BoolisSet__=Trueinstance(Defaultmsg,Defaulta)=>MessageAPImsg(msg->Maybea)awheregetValmf=fromMaybe(fromMaybedefaultValue(fdefaultValue))(fm)isSetmf=isJust(fm)instanceMessageAPImsg(msg->(Seqa))(Seqa)wheregetValmf=fmisSetmf=not(Seq.null(fm))instance(Defaultv)=>MessageAPImsg(KeyMaybemsgv)vwheregetValmk@(Key__md)=casegetExtkmofRight(Justv)->v_->fromMaybedefaultValuemdisSetm(Keyfid__)=let(ExtFieldx)=getExtFieldminM.memberfidxinstance(Defaultv)=>MessageAPImsg(KeySeqmsgv)(Seqv)wheregetValmk@(Key___)=casegetExtkmofRights->s_->Seq.emptyisSetm(Keyfid__)=let(ExtFieldx)=getExtFieldminM.memberfidxinstanceMessageAPImsg(msg->ByteString)ByteStringwheregetValmf=fminstanceMessageAPImsg(msg->Utf8)Utf8wheregetValmf=fminstanceMessageAPImsg(msg->Double)DoublewheregetValmf=fminstanceMessageAPImsg(msg->Float)FloatwheregetValmf=fminstanceMessageAPImsg(msg->Int32)Int32wheregetValmf=fminstanceMessageAPImsg(msg->Int64)Int64wheregetValmf=fminstanceMessageAPImsg(msg->Word32)Word32wheregetValmf=fminstanceMessageAPImsg(msg->Word64)Word64wheregetValmf=fm-- Must keep synchronized with Parser.isValidPackedisValidPacked::FieldType->BoolisValidPackedfieldType=casefieldTypeof9->False10->False11->False-- Impossible value for typeCode from parseType, but here for completeness12->False_->True