protocol-buffers 2.0.14 → 2.0.17
raw patch · 8 files changed
+318/−206 lines, 8 filesdep +parsecdep ~base
Dependencies added: parsec
Dependency ranges changed: base
Files
- Text/ProtocolBuffers.hs +5/−0
- Text/ProtocolBuffers/Basic.hs +1/−1
- Text/ProtocolBuffers/Extensions.hs +119/−201
- Text/ProtocolBuffers/Get.hs +2/−2
- Text/ProtocolBuffers/Header.hs +4/−0
- Text/ProtocolBuffers/TextMessage.hs +182/−0
- Text/ProtocolBuffers/WireMessage.hs +1/−1
- protocol-buffers.cabal +4/−1
Text/ProtocolBuffers.hs view
@@ -15,6 +15,8 @@ import Text.ProtocolBuffers.Reflections ( ReflectDescriptor(..),ReflectEnum(..),ProtoName(..),HsDefault(..),EnumInfoApp , KeyInfo,FieldInfo(..),DescriptorInfo(..),EnumInfo(..),ProtoInfo(..),makePNF )+import Text.ProtocolBuffers.TextMessage+ ( messagePutText, messageGetText ) import Text.ProtocolBuffers.WireMessage ( Wire,Put,Get,runPut,runGet,runGetOnLazy , messageSize,messagePut,messageGet,messagePutM,messageGetM@@ -43,6 +45,7 @@ , module Text.ProtocolBuffers.Extensions , module Text.ProtocolBuffers.Identifiers , module Text.ProtocolBuffers.Reflections+ , module Text.ProtocolBuffers.TextMessage , module Text.ProtocolBuffers.WireMessage ) where @@ -57,6 +60,8 @@ import Text.ProtocolBuffers.Reflections ( ReflectDescriptor(..),ReflectEnum(..),ProtoName(..),HsDefault(..),EnumInfoApp , KeyInfo,FieldInfo(..),DescriptorInfo(..),EnumInfo(..),ProtoInfo(..),makePNF )+import Text.ProtocolBuffers.TextMessage+ ( messagePutText, messageGetText ) import Text.ProtocolBuffers.WireMessage ( Wire,Put,Get,runPut,runGet,runGetOnLazy , messageSize,messagePut,messageGet,messagePutM,messageGetM
Text/ProtocolBuffers/Basic.hs view
@@ -21,7 +21,7 @@ import Data.Ix(Ix) import Data.Monoid(Monoid(..)) import Data.Sequence(Seq,(><))-import Data.Typeable(Typeable(..))+import Data.Typeable(Typeable) import Data.Word(Word8,Word32,Word64) import qualified Data.ByteString.Lazy as L(unpack)
Text/ProtocolBuffers/Extensions.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs,MultiParamTypeClasses,FunctionalDependencies,FlexibleInstances,DeriveDataTypeable,ScopedTypeVariables #-}+{-# LANGUAGE GADTs,MultiParamTypeClasses,FunctionalDependencies,FlexibleInstances,DeriveDataTypeable,ScopedTypeVariables,StandaloneDeriving #-} -- | 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@@ -38,7 +38,7 @@ import Data.Monoid(mappend,mconcat) import Data.Sequence((|>),(><),viewl,ViewL(..)) import qualified Data.Sequence as Seq(singleton,null,empty)-import Data.Typeable(Typeable(typeOf),Typeable1(typeOf1),Typeable2(typeOf2),TypeRep,mkTyConApp,mkTyCon3,cast)+import Data.Typeable(Typeable,typeOf,cast) import Data.Data(Data(gfoldl,gunfold,toConstr),Constr,DataType,Fixity(Prefix),mkDataType,mkConstr,constrIndex,dataTypeOf) import Text.ProtocolBuffers.Basic@@ -78,7 +78,9 @@ -- data Key c msg v where Key :: (ExtKey c,ExtendMessage msg,GPB v) => FieldId -> FieldType -> (Maybe v) -> Key c msg v+ deriving (Typeable) + -- | 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).@@ -97,10 +99,7 @@ getKeyDefaultValue :: Key c msg v -> v getKeyDefaultValue (Key _ _ md) = fromMaybe defaultValue md -instance Typeable1 c => Typeable2 (Key c) where- typeOf2 _ = mkTyConApp (mkTyCon3 "protocol-buffers" "Text.ProtocolBuffers.Extensions" "Key") [typeOf1 (undefined :: c ())]--instance (Typeable1 c, Typeable msg, Typeable v) => Show (Key c msg v) where+instance (Typeable c, ExtendMessage msg, GPB v) => Show (Key c msg v) where show key@(Key fieldId fieldType maybeDefaultValue) = concat ["(Key (",show fieldId ,") (",show fieldType@@ -108,20 +107,16 @@ ,") :: ",show (typeOf key) ,")"] --- | 'GPWitness' is an instance witness for the 'GPB' classes. This--- exists mainly to be a part of 'GPDyn' or 'GPDynSeq'.-data GPWitness a where GPWitness :: (GPB a) => GPWitness a- deriving (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.-data GPDyn = forall a . GPDyn !(GPWitness a) !a+-- with an existential. This is used in 'ExtOptional' for optional fields.+data GPDyn where+ GPDyn :: (GPB a) => !a -> GPDyn deriving (Typeable) -- | The 'GPDynSeq' is another specialization of 'Dynamic' and is used -- in 'ExtRepeated' for repeated fields.-data GPDynSeq = forall a . GPDynSeq !(GPWitness a) !(Seq a)+data GPDynSeq where+ GPDynSeq :: GPB a => !(Seq a) -> GPDynSeq deriving (Typeable) -- | The 'PackedSeq' is needed to distinguish the packed repeated format from the repeated format.@@ -137,11 +132,11 @@ | ExtPacked !FieldType !GPDynSeq deriving (Typeable,Ord,Show) --- For making a Data instance for ExtField+-- | For making a Data instance for ExtField data ExtDataPair = ExtDataPair FieldId (Seq EP) deriving (Typeable,Data,Show) -data EP = EP {-# UNPACK #-} !WireType !ByteString+data EP = EP {-# UNPACK #-} !WireType !ByteString deriving (Typeable,Data,Eq,Ord,Show) data DummyMessageType deriving (Typeable)@@ -149,38 +144,35 @@ -- | ExtField is a newtype'd map from the numeric FieldId key to the -- ExtFieldValue. This allows for the needed class instances. newtype ExtField = ExtField (Map FieldId ExtFieldValue)- deriving (Eq,Ord,Show)+ deriving (Typeable,Eq,Ord,Show) --- Used only in gfoldl for Data instance of ExtField+-- | Used only in gfoldl for Data instance of ExtField dataToList :: ExtField -> [ExtDataPair] dataToList (ExtField ef) = map toEDP . M.toList $ ef where toEDP (fi,ExtFromWire eps) = ExtDataPair fi eps- toEDP (fi,ExtOptional ft (GPDyn GPWitness d)) =+ toEDP (fi,ExtOptional ft (GPDyn d)) = let p = wirePutOpt (toWireTag fi ft) ft (Just d) ep = EP (toWireType ft) (runPut p) in ExtDataPair fi (Seq.singleton ep)- toEDP (fi,ExtRepeated ft (GPDynSeq GPWitness s)) =+ toEDP (fi,ExtRepeated ft (GPDynSeq s)) = let f :: forall w. Wire w => w -> EP f = EP (toWireType ft) . runPut . wirePutReq (toWireTag fi ft) ft in ExtDataPair fi (fmap f s)- toEDP (fi,ExtPacked ft (GPDynSeq GPWitness s)) =+ toEDP (fi,ExtPacked ft (GPDynSeq s)) = let p = wirePutPacked (toPackedWireTag fi) ft s ep = EP (snd. splitWireTag $ toPackedWireTag fi) (runPut p) in ExtDataPair fi (Seq.singleton ep) --- Used only in gfoldl and gunfold for Data instance of ExtField+-- | Used only in gfoldl and gunfold for Data instance of ExtField dataFromList :: [ExtDataPair] -> ExtField dataFromList = ExtField . M.fromList . map fromEDP where fromEDP (ExtDataPair fid eps) = (fid,ExtFromWire eps) -instance Typeable ExtField where- typeOf _ = tr_ExtField--tr_ExtField :: TypeRep-tr_ExtField = mkTyConApp (mkTyCon3 "protocol-buffers" "Text.ProtocolBuffers.Extensions" "ExtField") []-+-- | Used only in gfoldl and gunfold for Data instance of ExtField ty_ExtField :: DataType ty_ExtField = mkDataType "Text.ProtocolBuffers.Extensions.ExtField" [con_ExtField]++-- | Used only in gfoldl and gunfold for Data instance of ExtField con_ExtField :: Constr con_ExtField = mkConstr ty_ExtField "ExtField" [] Prefix @@ -190,6 +182,7 @@ _ -> k (z dataFromList) toConstr (ExtField _) = con_ExtField dataTypeOf _ = ty_ExtField+ instance ExtendMessage DummyMessageType where getExtField = undefined@@ -209,28 +202,28 @@ (==) (ExtOptional a b) (ExtOptional a' b') = a==a' && b==b' (==) (ExtRepeated a b) (ExtRepeated a' b') = a==a' && b==b' (==) (ExtPacked a b) (ExtPacked a' b') = a==a' && b==b'- (==) x@(ExtOptional ft (GPDyn w@GPWitness _)) (ExtFromWire s') =+ (==) x@(ExtOptional ft (GPDyn w)) (ExtFromWire s') = let wt = toWireType ft- makeKeyType :: GPWitness a -> Key Maybe DummyMessageType a- makeKeyType = undefined+ makeKeyType :: a -> Key Maybe DummyMessageType a+ makeKeyType _ = undefined key = Key 0 ft Nothing `asTypeOf` makeKeyType w in case parseWireExtMaybe key wt s' of Right (_,y) -> x==y _ -> False (==) y@(ExtFromWire {}) x@(ExtOptional {}) = x == y- (==) x@(ExtRepeated ft (GPDynSeq w@GPWitness _)) (ExtFromWire s') =+ (==) x@(ExtRepeated ft (GPDynSeq w)) (ExtFromWire s') = let wt = toWireType ft- makeKeyType :: GPWitness a -> Key Seq DummyMessageType a- makeKeyType = undefined+ makeKeyType :: Seq a -> Key Seq DummyMessageType a+ makeKeyType _ = undefined key = Key 0 ft Nothing `asTypeOf` makeKeyType w in case parseWireExtSeq key wt s' of Right (_,y) -> x==y _ -> False (==) y@(ExtFromWire {}) x@(ExtRepeated {}) = x == y- (==) x@(ExtPacked ft (GPDynSeq w@GPWitness _)) (ExtFromWire s') =+ (==) x@(ExtPacked ft (GPDynSeq w)) (ExtFromWire s') = let wt = 2 -- all packed types have wire type 2, length delimited- makeKeyType :: GPWitness a -> Key PackedSeq DummyMessageType a- makeKeyType = undefined+ makeKeyType :: Seq a -> Key PackedSeq DummyMessageType a+ makeKeyType _ = undefined key = Key 0 ft Nothing `asTypeOf` makeKeyType w in case parseWireExtPackedSeq key wt s' of Right (_,y) -> x==y@@ -248,8 +241,7 @@ putExtField :: ExtField -> msg -> msg validExtRanges :: msg -> [(FieldId,FieldId)] --- wireKeyToUnPacked is used to load a repeated packed format into a repeated non-packed extension key--- wireKeyToPacked is used to load a repeated unpacked format into a repeated packed extension key+-- | wireKeyToUnPacked is used to load a repeated packed format into a repeated non-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)@@ -257,28 +249,29 @@ vv <- wireGetPacked t `asTypeOf` (myCast mv) let (ExtField ef) = getExtField msg v' <- case M.lookup i ef of- Nothing -> return $ ExtRepeated t (GPDynSeq GPWitness vv)- Just (ExtRepeated t' (GPDynSeq GPWitness s)) | t/=t' ->+ Nothing -> return $ ExtRepeated t (GPDynSeq vv)+ Just (ExtRepeated t' (GPDynSeq s)) | t/=t' -> fail $ "wireGetKeyToUnPacked: Key mismatch! found wrong field type: "++show (k,t,t') | otherwise -> case cast s of Nothing -> fail $ "wireGetKeyToUnPacked: previous Seq value cast failed: "++show (k,typeOf s)- Just s' -> return $ ExtRepeated t (GPDynSeq GPWitness (s' >< vv))+ Just s' -> return $ ExtRepeated t (GPDynSeq (s' >< vv)) Just (ExtFromWire raw) -> case parseWireExtSeq k (toWireType t) raw of -- was wt from ExtFromWire Left errMsg -> fail $ "wireGetKeyToUnPacked: Could not parseWireExtSeq: "++show k++"\n"++errMsg- Right (_,ExtRepeated t' (GPDynSeq GPWitness s)) | t/=t' ->+ Right (_,ExtRepeated t' (GPDynSeq s)) | t/=t' -> fail $ "wireGetKeyToUnPacked:: Key mismatch! parseWireExtSeq returned wrong field type: "++show (k,t,t') | 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' >< vv))+ Just s' -> return $ ExtRepeated t (GPDynSeq (s' >< vv)) wtf -> fail $ "wireGetKeyToUnPacked: Weird parseWireExtSeq return value: "++show (k,wtf) Just wtf@(ExtOptional {}) -> fail $ "wireGetKeyToUnPacked: ExtOptional found when ExtRepeated expected: "++show (k,wtf) Just wtf@(ExtPacked {}) -> fail $ "wireGetKeyToUnPacked: ExtPacked found when ExtRepeated expected: "++show (k,wtf) let ef' = M.insert i v' ef seq v' $ seq ef' $ return (putExtField (ExtField ef') msg) +-- | wireKeyToPacked is used to load a repeated unpacked format into a repeated packed extension key wireGetKeyToPacked :: (ExtendMessage msg,GPB v) => Key PackedSeq msg v -> msg -> Get msg wireGetKeyToPacked k@(Key i t mv) msg = do let wt = toWireType t@@ -287,22 +280,22 @@ v <- wireGet t `asTypeOf` (myCast mv) let (ExtField ef) = getExtField msg v' <- case M.lookup i ef of- Nothing -> return $ ExtPacked t (GPDynSeq GPWitness (Seq.singleton v))- Just (ExtPacked t' (GPDynSeq GPWitness s)) | t/=t' ->+ Nothing -> return $ ExtPacked t (GPDynSeq (Seq.singleton v))+ Just (ExtPacked t' (GPDynSeq s)) | t/=t' -> fail $ "wireGetKeyToPacked: Key mismatch! found wrong field type: "++show (k,t,t') | otherwise -> case cast s of Nothing -> fail $ "wireGetKeyToPacked: previous Seq value cast failed: "++show (k,typeOf s)- Just s' -> seq v $ return $ ExtRepeated t (GPDynSeq GPWitness (s' |> v))+ Just s' -> seq v $ return $ ExtRepeated t (GPDynSeq (s' |> v)) Just (ExtFromWire raw) -> case parseWireExtPackedSeq k wt raw of Left errMsg -> fail $ "wireGetKeyToPacked: Could not parseWireExtPackedSeq: "++show k++"\n"++errMsg- Right (_,ExtPacked t' (GPDynSeq GPWitness s)) | t/=t' ->+ Right (_,ExtPacked t' (GPDynSeq s)) | t/=t' -> fail $ "wireGetKeyToPacked: Key mismatch! parseWireExtPackedSeq returned wrong field type: "++show (k,t,t') | otherwise -> case cast s of Nothing -> fail $ "wireGetKeyToPacked: previous Seq value cast failed: "++show (k,typeOf s)- Just s' -> seq v $ return $ ExtRepeated t (GPDynSeq GPWitness (s' |> v))+ Just s' -> seq v $ return $ ExtRepeated t (GPDynSeq (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)@@ -373,76 +366,32 @@ mergeExtFieldValue :: ExtFieldValue -> ExtFieldValue -> ExtFieldValue mergeExtFieldValue (ExtFromWire s1) (ExtFromWire s2) = ExtFromWire (mappend s1 s2) -mergeExtFieldValue (ExtOptional ft1 (GPDyn GPWitness d1))- (ExtOptional ft2 (GPDyn GPWitness d2)) =+mergeExtFieldValue (ExtOptional ft1 (GPDyn d1))+ (ExtOptional ft2 (GPDyn d2)) = if ft1 /= ft2 then err $ "mergeExtFieldValue : ExtOptional FieldType mismatch "++show (ft1,ft2) else case cast d2 of Nothing -> err $ "mergeExtFieldValue : ExtOptional cast failed, FieldType "++show (ft2,typeOf d1,typeOf d2)- Just d2' -> ExtOptional ft2 (GPDyn GPWitness (mergeAppend d1 d2'))+ Just d2' -> ExtOptional ft2 (GPDyn (mergeAppend d1 d2')) -mergeExtFieldValue (ExtRepeated ft1 (GPDynSeq GPWitness s1))- (ExtRepeated ft2 (GPDynSeq GPWitness s2)) =+mergeExtFieldValue (ExtRepeated ft1 (GPDynSeq s1))+ (ExtRepeated ft2 (GPDynSeq s2)) = if ft1 /= ft2 then err $ "mergeExtFieldValue : ExtRepeated FieldType mismatch "++show (ft1,ft2) else case cast s2 of Nothing -> err $ "mergeExtFieldValue : ExtRepeated cast failed, FieldType "++show (ft2,typeOf s1,typeOf s2)- Just s2' -> ExtRepeated ft2 (GPDynSeq GPWitness (mappend s1 s2'))+ Just s2' -> ExtRepeated ft2 (GPDynSeq (mappend s1 s2')) -mergeExtFieldValue (ExtPacked ft1 (GPDynSeq GPWitness s1))- (ExtPacked ft2 (GPDynSeq GPWitness s2)) =+mergeExtFieldValue (ExtPacked ft1 (GPDynSeq s1))+ (ExtPacked ft2 (GPDynSeq s2)) = if ft1 /= ft2 then err $ "mergeExtFieldValue : ExtPacked FieldType mismatch "++show (ft1,ft2) else case cast s2 of Nothing -> err $ "mergeExtFieldValue : ExtPacked cast failed, FieldType "++show (ft2,typeOf s1,typeOf s2)- Just s2' -> ExtPacked ft2 (GPDynSeq GPWitness (mappend s1 s2'))+ Just s2' -> ExtPacked ft2 (GPDynSeq (mappend s1 s2')) mergeExtFieldValue a b = err $ "mergeExtFieldValue : mismatch of constructors "++show (a,b) instance Default ExtField where defaultValue = ExtField M.empty -instance Show (GPWitness a) where- showsPrec _n GPWitness = ("(GPWitness :: GPWitness ("++) . shows (typeOf (undefined :: a)) . (')':) . (')':)--instance Eq (GPWitness a) where- (==) GPWitness GPWitness = True- (/=) GPWitness GPWitness = False--instance Ord (GPWitness a) where- compare GPWitness GPWitness = EQ--instance (GPB a) => Data (GPWitness a) where- gunfold _k z c = case constrIndex c of- 1 -> z GPWitness- _ -> err "gunfold of GPWitness error"- toConstr GPWitness = gpWitnessC- dataTypeOf _ = gpWitnessDT--gpWitnessC :: Constr-gpWitnessC = mkConstr gpWitnessDT "GPWitness" [] Prefix -gpWitnessDT :: DataType-gpWitnessDT = 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)--}- instance Eq GPDyn where (==) a b = fromMaybe False (eqGPDyn a b) @@ -450,7 +399,7 @@ compare a b = fromMaybe (compare (show a) (show b)) (ordGPDyn a b) instance Show GPDyn where- showsPrec _n (GPDyn x@GPWitness a) = ("(GPDyn "++) . shows x . (" ("++) . shows a . ("))"++)+ showsPrec _n (GPDyn a) = ("(GPDyn "++) . (" ("++) . shows a . ("))"++) instance Eq GPDynSeq where (==) a b = fromMaybe False (eqGPDynSeq a b)@@ -459,48 +408,25 @@ compare a b = fromMaybe (compare (show a) (show b)) (ordGPDynSeq a b) instance Show GPDynSeq where- showsPrec _n (GPDynSeq x@GPWitness s) = ("(GPDynSeq "++) . shows x . (" ("++) . shows s . ("))"++)+ showsPrec _n (GPDynSeq s) = ("(GPDynSeq "++) . (" ("++) . shows s . ("))"++) ordGPDyn :: GPDyn -> GPDyn -> Maybe Ordering-ordGPDyn (GPDyn GPWitness a1) (GPDyn GPWitness a2) = fmap (compare a1) (cast a2)+ordGPDyn (GPDyn a1) (GPDyn a2) = fmap (compare a1) (cast a2) eqGPDyn :: GPDyn -> GPDyn -> Maybe Bool-eqGPDyn (GPDyn GPWitness a1) (GPDyn GPWitness a2) = fmap (a1==) (cast a2)---- showGPDyn :: GPDyn -> String--- showGPDyn (GPDyn GPWitness s) = show s+eqGPDyn (GPDyn a1) (GPDyn a2) = fmap (a1==) (cast a2) ordGPDynSeq :: GPDynSeq -> GPDynSeq -> Maybe Ordering-ordGPDynSeq (GPDynSeq GPWitness a1) (GPDynSeq GPWitness a2) = fmap (compare a1) (cast a2)+ordGPDynSeq (GPDynSeq a1) (GPDynSeq a2) = fmap (compare a1) (cast a2) eqGPDynSeq :: GPDynSeq -> GPDynSeq -> Maybe Bool-eqGPDynSeq (GPDynSeq GPWitness a1) (GPDynSeq GPWitness a2) = fmap (a1==) (cast a2)---- 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 t+eqGPDynSeq (GPDynSeq a1) (GPDynSeq a2) = fmap (a1==) (cast a2) instance ExtKey Maybe where putExt key Nothing msg = clearExt key msg putExt (Key i t _) (Just v) msg = let (ExtField ef) = getExtField msg- v' = ExtOptional t (GPDyn GPWitness v)+ v' = ExtOptional t (GPDyn v) ef' = M.insert i v' ef in seq v' $ seq ef' (putExtField (ExtField ef') msg) @@ -518,7 +444,7 @@ Just x -> getExt' x where getExt' (ExtRepeated t' _) = Left $ "getExt Maybe: ExtField has repeated type: "++show (k,t') getExt' (ExtPacked t' _) = Left $ "getExt Maybe: ExtField has packed type: "++show (k,t')- getExt' (ExtOptional t' (GPDyn GPWitness d)) | t/=t' =+ getExt' (ExtOptional t' (GPDyn d)) | t/=t' = Left $ "getExt Maybe: Key's FieldType does not match ExtField's: "++show (k,t') | otherwise = case cast d of@@ -533,22 +459,22 @@ v <- wireGet t `asTypeOf` (myCast mv) let (ExtField ef) = getExtField msg v' <- case M.lookup i ef of- Nothing -> return $ ExtOptional t (GPDyn GPWitness v)- Just (ExtOptional t' (GPDyn GPWitness vOld)) | t /= t' ->+ Nothing -> return $ ExtOptional t (GPDyn v)+ Just (ExtOptional t' (GPDyn vOld)) | t /= t' -> fail $ "wireGetKey Maybe: Key mismatch! found wrong field type: "++show (k,t,t') | otherwise -> case cast vOld of Nothing -> fail $ "wireGetKey Maybe: previous Maybe value case failed: "++show (k,typeOf vOld)- Just vOld' -> return $ ExtOptional t (GPDyn GPWitness (mergeAppend vOld' v))+ Just vOld' -> return $ ExtOptional t (GPDyn (mergeAppend vOld' v)) Just (ExtFromWire raw) -> case parseWireExtMaybe k wt raw of Left errMsg -> fail $ "wireGetKey Maybe: Could not parseWireExtMaybe: "++show k++"\n"++errMsg- Right (_,ExtOptional t' (GPDyn GPWitness vOld)) | t/=t' ->+ Right (_,ExtOptional t' (GPDyn vOld)) | t/=t' -> fail $ "wireGetKey Maybe: Key mismatch! found wrong field type: "++show (k,t,t') | otherwise -> case cast vOld of Nothing -> fail $ "wireGetKey Maybe: previous Maybe value case failed: "++show (k,typeOf vOld)- Just vOld' -> return $ ExtOptional t (GPDyn GPWitness (mergeAppend vOld' v))+ Just vOld' -> return $ ExtOptional t (GPDyn (mergeAppend vOld' v)) wtf -> fail $ "wireGetKey Maybe: Weird parseGetWireMaybe return value: "++show (k,wtf) Just wtf@(ExtRepeated {}) -> fail $ "wireGetKey Maybe: ExtRepeated found with ExtOptional expected: "++show (k,wtf) Just wtf@(ExtPacked {}) -> fail $ "wireGetKey Maybe: ExtPacked found with ExtOptional expected: "++show (k,wtf)@@ -560,19 +486,18 @@ 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- let mkWitType :: Maybe a -> GPWitness a+ let mkWitType :: Maybe a -> FieldType -> EP -> Either String (Seq a) mkWitType = undefined- witness = GPWitness `asTypeOf` (mkWitType mv)--- parsed = map (applyGet (wireGet ft)) . F.toList $ raw- parsed = map (chooseGet ft) . F.toList $ raw+ chooseGet' = chooseGet `asTypeOf` (mkWitType mv)+ let parsed = map (chooseGet' ft) . F.toList $ raw errs = [ m | Left m <- 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))))+ x :< xs -> Right (fi,(ExtOptional ft (GPDyn (F.foldl' mergeAppend x xs)))) else Left (unlines errs) --- 'chooseGet' is an intermediate handler between parseWireExt* and applyGet. This does not know+-- | '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 desired FieldType and the WireType chooseGet :: (Wire r) => FieldType -> EP -> Either String (Seq r)@@ -599,7 +524,7 @@ putExt key@(Key i t _) s msg | Seq.null s = clearExt key msg | otherwise = let (ExtField ef) = getExtField msg- v' = ExtRepeated t (GPDynSeq GPWitness s)+ v' = ExtRepeated t (GPDynSeq s) ef' = M.insert i v' ef in seq v' $ seq ef' (putExtField (ExtField ef') msg) @@ -617,7 +542,7 @@ Just x -> getExt' x where getExt' (ExtOptional t' _) = Left $ "getExt Seq: ExtField has optional type: "++show (k,t') getExt' (ExtPacked t' _) = Left $ "getExt Seq: ExtField has packed type: "++show (k,t')- getExt' (ExtRepeated t' (GPDynSeq GPWitness s)) | t'/=t =+ getExt' (ExtRepeated t' (GPDynSeq s)) | t'/=t = Left $ "getExt Seq: Key's FieldType does not match ExtField's: "++show (k,t') | otherwise = case cast s of@@ -636,22 +561,22 @@ v <- wireGet t `asTypeOf` (myCast mv) let (ExtField ef) = getExtField msg v' <- case M.lookup i ef of- Nothing -> return $ ExtRepeated t (GPDynSeq GPWitness (Seq.singleton v))- Just (ExtRepeated t' (GPDynSeq GPWitness s)) | t/=t' ->+ Nothing -> return $ ExtRepeated t (GPDynSeq (Seq.singleton v))+ Just (ExtRepeated t' (GPDynSeq s)) | t/=t' -> fail $ "wireGetKey Seq: Key mismatch! found wrong field type: "++show (k,t,t') | otherwise -> case cast s of Nothing -> fail $ "wireGetKey Seq: previous Seq value cast failed: "++show (k,typeOf s)- Just s' -> seq v $ return $ ExtRepeated t (GPDynSeq GPWitness (s' |> v))+ Just s' -> seq v $ return $ ExtRepeated t (GPDynSeq (s' |> v)) Just (ExtFromWire raw) -> case parseWireExtSeq k wt raw of Left errMsg -> fail $ "wireGetKey Seq: Could not parseWireExtSeq: "++show k++"\n"++errMsg- Right (_,ExtRepeated t' (GPDynSeq GPWitness s)) | t/=t' ->+ Right (_,ExtRepeated t' (GPDynSeq s)) | t/=t' -> fail $ "wireGetKey Seq: Key mismatch! parseWireExtSeq returned wrong field type: "++show (k,t,t') | otherwise -> case cast s of Nothing -> fail $ "wireGetKey Seq: previous Seq value cast failed: "++show (k,typeOf s)- Just s' -> seq v $ return $ ExtRepeated t (GPDynSeq GPWitness (s' |> v))+ Just s' -> seq v $ return $ ExtRepeated t (GPDynSeq (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)@@ -663,20 +588,19 @@ 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- let mkWitType :: Maybe a -> GPWitness a+ let mkWitType :: Maybe a -> FieldType -> EP -> Either String (Seq a) mkWitType = undefined- witness = GPWitness `asTypeOf` (mkWitType mv)--- parsed = map (applyGet (wireGet t)) . F.toList $ raw- parsed = map (chooseGet t) . F.toList $ raw+ chooseGet' = chooseGet `asTypeOf` (mkWitType mv)+ let parsed = map (chooseGet' t) . F.toList $ raw errs = [ m | Left m <- parsed ]- if null errs then Right (i,(ExtRepeated t (GPDynSeq witness (mconcat [ a | Right a <- parsed ]))))+ if null errs then Right (i,(ExtRepeated t (GPDynSeq (mconcat [ a | Right a <- parsed ])))) else Left (unlines errs) instance ExtKey PackedSeq where putExt key@(Key i t _) (PackedSeq s) msg | Seq.null s = clearExt key msg | otherwise = let (ExtField ef) = getExtField msg- v' = ExtPacked t (GPDynSeq GPWitness s)+ v' = ExtPacked t (GPDynSeq s) ef' = M.insert i v' ef in seq v' $ seq ef' (putExtField (ExtField ef') msg) @@ -694,7 +618,7 @@ Just x -> getExt' x where getExt' (ExtOptional t' _) = Left $ "getExt PackedSeq: ExtField has optional type: "++show (k,t') getExt' (ExtRepeated t' _) = Left $ "getExt PackedSeq: ExtField has repeated type: "++show (k,t')- getExt' (ExtPacked t' (GPDynSeq GPWitness s)) | t'/=t =+ getExt' (ExtPacked t' (GPDynSeq s)) | t'/=t = Left $ "getExt PackedSeq: Key's FieldType does not match ExtField's: "++show (k,t') | otherwise = case cast s of@@ -709,22 +633,22 @@ vv <- wireGetPacked t `asTypeOf` (myCast mv) let (ExtField ef) = getExtField msg v' <- case M.lookup i ef of- Nothing -> return $ ExtPacked t (GPDynSeq GPWitness vv)- Just (ExtPacked t' (GPDynSeq GPWitness s)) | t/=t' ->+ Nothing -> return $ ExtPacked t (GPDynSeq vv)+ Just (ExtPacked t' (GPDynSeq s)) | t/=t' -> fail $ "wireGetKey PackedSeq: Key mismatch! found wrong field type: "++show (k,t,t') | otherwise -> case cast s of Nothing -> fail $ "wireGetKey PackedSeq: previous Seq value cast failed: "++show (k,typeOf s)- Just s' -> return $ ExtRepeated t (GPDynSeq GPWitness (s' >< vv))+ Just s' -> return $ ExtRepeated t (GPDynSeq (s' >< vv)) Just (ExtFromWire raw) -> case parseWireExtPackedSeq k wt raw of Left errMsg -> fail $ "wireGetKey PackedSeq: Could not parseWireExtPackedSeq: "++show k++"\n"++errMsg- Right (_,ExtPacked t' (GPDynSeq GPWitness s)) | t/=t' ->+ Right (_,ExtPacked t' (GPDynSeq s)) | t/=t' -> fail $ "wireGetKey PackedSeq: Key mismatch! parseWireExtPackedSeq returned wrong field type: "++show (k,t,t') | otherwise -> case cast s of Nothing -> fail $ "wireGetKey PackedSeq: previous Seq value cast failed: "++show (k,typeOf s)- Just s' -> return $ ExtRepeated t (GPDynSeq GPWitness (s' >< vv))+ Just s' -> return $ ExtRepeated t (GPDynSeq (s' >< vv)) wtf -> fail $ "wireGetKey PackedSeq: Weird parseWireExtPackedSeq return value: "++show (k,wtf) Just wtf@(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?@@ -736,13 +660,12 @@ parseWireExtPackedSeq k@(Key i t mv) wt raw | 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,toWireType t,wt) | otherwise = do- let mkWitType :: Maybe a -> GPWitness a+ let mkWitType :: Maybe a -> FieldType -> EP -> Either String (Seq a) mkWitType = undefined- witness = GPWitness `asTypeOf` (mkWitType mv)--- parsed = map (applyGet (wireGetPacked t)) . F.toList $ raw- parsed = map (chooseGet t) . F.toList $ raw+ chooseGet' = chooseGet `asTypeOf` (mkWitType mv)+ let parsed = map (chooseGet' t) . F.toList $ raw errs = [ m | Left m <- parsed ]- if null errs then Right (i,(ExtPacked t (GPDynSeq witness (mconcat [ a | Right a <- parsed ]))))+ if null errs then Right (i,(ExtPacked t (GPDynSeq (mconcat [ a | Right a <- parsed ])))) else Left (unlines errs) -- | This is used by the generated code@@ -751,18 +674,13 @@ aSize old (fi,(ExtFromWire raw)) = let toSize (EP wt bs) = size'WireTag (mkWireTag fi wt) + L.length bs in F.foldl' (\oldVal new -> oldVal + toSize new) old raw-{-- aSize old (fi,(ExtFromWire raw)) = old +- let tagSize = size'WireTag (mkWireTag fi wt)- in F.foldl' (\oldVal new -> oldVal + L.length new) (fromIntegral (Seq.length raw) * tagSize) raw--}- aSize old (fi,(ExtOptional ft (GPDyn GPWitness d))) = old ++ aSize old (fi,(ExtOptional ft (GPDyn d))) = old + let tagSize = size'WireTag (toWireTag fi ft) in wireSizeReq tagSize ft d- aSize old (fi,(ExtRepeated ft (GPDynSeq GPWitness s))) = old ++ aSize old (fi,(ExtRepeated ft (GPDynSeq s))) = old + let tagSize = size'WireTag (toWireTag fi ft) in wireSizeRep tagSize ft s- aSize old (fi,(ExtPacked ft (GPDynSeq GPWitness s))) = old ++ aSize old (fi,(ExtPacked ft (GPDynSeq s))) = old + let tagSize = size'WireTag (toPackedWireTag fi) in wireSizePacked tagSize ft s @@ -771,9 +689,9 @@ wirePutExtField :: ExtField -> Put wirePutExtField (ExtField m) = mapM_ aPut (M.assocs m) where aPut (fi,(ExtFromWire raw)) = F.mapM_ (\(EP wt bs) -> putVarUInt (getWireTag $ mkWireTag fi wt) >> putLazyByteString bs) raw- aPut (fi,(ExtOptional ft (GPDyn GPWitness d))) = wirePutOpt (toWireTag fi ft) ft (Just d)- aPut (fi,(ExtRepeated ft (GPDynSeq GPWitness s))) = wirePutRep (toWireTag fi ft) ft s- aPut (fi,(ExtPacked ft (GPDynSeq GPWitness s))) = wirePutPacked (toPackedWireTag fi) ft s+ aPut (fi,(ExtOptional ft (GPDyn d))) = wirePutOpt (toWireTag fi ft) ft (Just d)+ aPut (fi,(ExtRepeated ft (GPDynSeq s))) = wirePutRep (toWireTag fi ft) ft s+ aPut (fi,(ExtPacked ft (GPDynSeq s))) = wirePutPacked (toPackedWireTag fi) ft s notExtension :: (ReflectDescriptor a, ExtendMessage a,Typeable a) => FieldId -> WireType -> a -> Get a notExtension fieldId _wireType msg = throwError ("Field id "++show fieldId++" is not a valid extension field id for "++show (typeOf (undefined `asTypeOf` msg)))@@ -799,36 +717,36 @@ 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)- | otherwise -> do+ Just (ExtOptional ft (GPDyn a)) | toWireType ft /= wireType -> badwt (toWireType ft)+ | otherwise -> do b <- wireGet ft- let v' = ExtOptional ft (GPDyn x (mergeAppend a b))+ let v' = ExtOptional ft (GPDyn (mergeAppend a b)) ef' = M.insert fieldId v' ef seq v' $ seq ef' $ return (putExtField (ExtField ef') msg) -- handle wireType of "2" when toWireType ft is not "2" but ft could be packed by using wireGetPacked ft- Just (ExtRepeated ft (GPDynSeq x@GPWitness s)) | toWireType ft /= wireType -> if (wireType==2) && (isValidPacked ft) - then do- aa <- wireGetPacked ft- let v' = ExtRepeated ft (GPDynSeq x (s >< aa))- ef' = M.insert fieldId v' ef- seq v' $ seq ef' $ return (putExtField (ExtField ef') msg)- else badwt (toWireType ft)- | otherwise -> do+ Just (ExtRepeated ft (GPDynSeq s)) | toWireType ft /= wireType -> if (wireType==2) && (isValidPacked ft) + then do+ aa <- wireGetPacked ft+ let v' = ExtRepeated ft (GPDynSeq (s >< aa))+ ef' = M.insert fieldId v' ef+ seq v' $ seq ef' $ return (putExtField (ExtField ef') msg)+ else badwt (toWireType ft)+ | otherwise -> do a <- wireGet ft- let v' = seq a $ ExtRepeated ft (GPDynSeq x (s |> a))+ let v' = seq a $ ExtRepeated ft (GPDynSeq (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' = 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 -}- | otherwise -> do+ Just (ExtPacked ft (GPDynSeq s)) | 2 /= wireType -> if (toWireType ft) == wireType+ then do+ a <- wireGet ft+ let v' = seq a $ ExtPacked ft (GPDynSeq (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 -}+ | otherwise -> do aa <- wireGetPacked ft- let v' = ExtPacked ft (GPDynSeq x (s >< aa))+ let v' = ExtPacked ft (GPDynSeq (s >< aa)) ef' = M.insert fieldId v' ef seq v' $ seq ef' $ return (putExtField (ExtField ef') msg)
Text/ProtocolBuffers/Get.hs view
@@ -122,7 +122,7 @@ {-# SPECIALIZE decode7unrolled :: Get Int #-} {-# SPECIALIZE decode7unrolled :: Get Integer #-} decode7unrolled :: forall s. (Num s,Integral s, Bits s) => Get s-{-# NOINLINE decode7unrolled #-}+-- NOINLINE decode7unrolled removed to allow SPECIALIZE to work decode7unrolled = Get $ \ sc sIn@(S ss@(S.PS fp off len) bs n) pc -> trace ("decode7unrolled: "++show (len,n)) $ if S.null ss then trace ("decode7unrolled: S.null ss") $ unGet decode7 sc sIn pc -- decode7 will try suspend then will fail if still bad@@ -217,7 +217,7 @@ {-# SPECIALIZE decode7 :: Get Int #-} {-# SPECIALIZE decode7 :: Get Integer #-} decode7 :: forall s. (Integral s, Bits s) => Get s-{-# NOINLINE decode7 #-}+-- NOINLINE decode7 removed to allow SPECIALIZE to work decode7 = go 0 0 where go !s1 !shift1 = trace ("decode7.go: "++show (toInteger s1, shift1)) $ do
Text/ProtocolBuffers/Header.hs view
@@ -6,11 +6,13 @@ , pack, fromMaybe, ap , fromDistinctAscList, member , throwError,catchError+ , choice, sepEndBy, spaces, try , module Data.Generics , module Text.ProtocolBuffers.Basic , module Text.ProtocolBuffers.Extensions , module Text.ProtocolBuffers.Identifiers , module Text.ProtocolBuffers.Reflections+ , module Text.ProtocolBuffers.TextMessage , module Text.ProtocolBuffers.Unknown , module Text.ProtocolBuffers.WireMessage ) where@@ -23,6 +25,7 @@ import Data.Maybe(fromMaybe) import Data.Sequence((|>)) -- for append, see below import Data.Set(fromDistinctAscList,member)+import Text.Parsec(choice, sepEndBy, spaces, try) import Text.ProtocolBuffers.Basic -- all import Text.ProtocolBuffers.Extensions@@ -33,6 +36,7 @@ import Text.ProtocolBuffers.Reflections ( ReflectDescriptor(..),ReflectEnum(..),EnumInfo(..),ProtoName(..) , GetMessageInfo(GetMessageInfo),DescriptorInfo(extRanges),makePNF )+import Text.ProtocolBuffers.TextMessage -- all import Text.ProtocolBuffers.Unknown ( UnknownField,UnknownMessage(..),wireSizeUnknownField,wirePutUnknownField,catch'Unknown ) import Text.ProtocolBuffers.WireMessage
+ Text/ProtocolBuffers/TextMessage.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE BangPatterns, FlexibleContexts, ScopedTypeVariables #-}+module Text.ProtocolBuffers.TextMessage (+-- * User API functions+-- ** Main encoding and decoding operations+ messagePutText,+ messageGetText,+-- * Internal API functions+ TextMsg(..),+ TextType(..),+ tellShow,+ tellSubMessage,+ getRead,+ getSubMessage,+ ) where++import Control.Applicative ((<$>), (<*), (*>))+import Control.Monad.Identity (Identity)+import Control.Monad (void)+import Control.Monad.Writer (Writer, execWriter, tell, censor)+import Data.Char+import Data.Foldable (toList)+import Data.Int+import Data.List (intercalate)+import Data.Sequence (singleton)+import Data.Traversable+import Data.Word+import Text.Parsec+import Text.Printf+import Text.ProtocolBuffers.Basic+import Text.Read++import qualified Data.ByteString.Lazy.Char8 as C8+import qualified Data.ByteString.Lazy.UTF8 as U8+import qualified Text.Parsec.Token as T++type Log = Seq (Int, String)+type Output = Writer Log ()++-- | Printable and readable messages+class TextMsg a where+ textPut :: a -> Output+ textGet :: Stream s Identity Char => Parsec s () a++-- | Printable and readable field types+class TextType a where+ tellT :: String -> a -> Output+ getT :: Stream s Identity Char => String -> Parsec s () a++tells :: String -> Output+tells s = tell $ singleton (0, s)++tellShow :: Show a => String -> a -> Output+tellShow name v = tells $ name ++ ": " ++ show v++tellStr :: String -> ByteString -> Output+tellStr name s = tells $ name ++ ": \"" ++ dumpOctal s ++ "\""++tellSubMessage :: TextMsg a => String -> a -> Output+tellSubMessage name m = do+ tells $ name ++ " {"+ indent $ textPut m+ tells "}"+ where+ indent = censor (fmap (\(!n, s) -> (n + 1, s)))++dumpOctal :: ByteString -> String+dumpOctal = C8.foldr escape []+ where+ escape '\n' str = "\\n" ++ str+ escape '\"' str = "\\\"" ++ str+ escape c str | isAscii c && isPrint c = c : str+ escape c str = printf "\\%03o" c ++ str++instance TextType Int32 where+ tellT = tellShow+ getT = getScalar integer++instance TextType Int64 where+ tellT = tellShow+ getT = getScalar integer++instance TextType Word32 where+ tellT = tellShow+ getT = getScalar natural++instance TextType Word64 where+ tellT = tellShow+ getT = getScalar natural++instance TextType Bool where+ tellT name True = tells $ name ++ ": true"+ tellT name False = tells $ name ++ ": false"+ getT name = do+ v <- getScalar (string "true" <|> string "false") name+ return (v == "true")++instance TextType Double where+ tellT = tellShow+ getT = getScalar float++instance TextType Float where+ tellT = tellShow+ getT name = realToFrac <$> getScalar float name++instance TextType Utf8 where+ tellT name (Utf8 s) = tellStr name s+ getT name = uFromString <$> getScalar stringLiteral name++instance TextType ByteString where+ tellT = tellStr+ getT name = U8.fromString <$> getScalar stringLiteral name++instance TextType a => TextType (Maybe a) where+ tellT _ Nothing = return ()+ tellT name (Just v) = tellT name v+ getT name = Just <$> getT name++instance TextType a => TextType (Seq a) where+ tellT name xs = void $ forM xs $ tellT name+ getT = error "should not take sequence directly"++-- | This writes message as text-format protobuf to 'String'+messagePutText :: TextMsg a => a -> String+messagePutText = intercalate "\n" . toList . fmap setIndent . execWriter . textPut+ where+ setIndent (n, s) = replicate (n * 2) ' ' ++ s++lexer :: Stream s Identity Char => T.GenTokenParser s () Identity+lexer = T.makeTokenParser T.LanguageDef {+ T.identStart = letter <|> char '_'+ , T.identLetter = alphaNum <|> char '_'+ , T.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"+ , T.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"+ , T.caseSensitive = True+ , T.commentStart = "/*"+ , T.commentEnd = "*/"+ , T.commentLine = "//"+ , T.nestedComments = True+ , T.reservedNames = []+ , T.reservedOpNames= []+ }++symbol :: Stream s Identity Char => String -> Parsec s () ()+symbol sym = void $ T.symbol lexer sym++colon :: Stream s Identity Char => Parsec s () ()+colon = void $ T.colon lexer++braces :: Stream s Identity Char => Parsec s () a -> Parsec s () a+braces = T.braces lexer++natural :: (Integral a, Stream s Identity Char) => Parsec s () a+natural = fromIntegral <$> T.natural lexer++integer :: (Integral a, Stream s Identity Char) => Parsec s () a+integer = fromIntegral <$> T.integer lexer++float :: Stream s Identity Char => Parsec s () Double+float = T.float lexer++stringLiteral :: Stream s Identity Char => Parsec s () String+stringLiteral = T.stringLiteral lexer++getRead :: forall a s . (Read a, Stream s Identity Char) => String -> Parsec s () a+getRead name = try $ do+ v <- getScalar (T.identifier lexer) name+ case readMaybe v of+ Just r -> return r+ Nothing -> fail $ "can't parse " ++ v++getScalar :: Stream s Identity Char => Parsec s () a -> String -> Parsec s () a+getScalar parser name = symbol name *> colon *> parser++getSubMessage :: (Stream s Identity Char, TextMsg a) => String -> Parsec s () a+getSubMessage name = symbol name *> braces textGet++-- | This reads message as text-format protobuf from any Parsec-compatible source.+-- Input must be completely consumed.+messageGetText :: (TextMsg a, Stream s Identity Char) => s -> Either String a+messageGetText s = case parse (textGet <* eof) "<protobuf>" s of+ Left e -> Left (show e)+ Right m -> Right m
Text/ProtocolBuffers/WireMessage.hs view
@@ -51,7 +51,7 @@ import Data.Sequence ((|>)) import qualified Data.Sequence as Seq(length,empty) import qualified Data.Set as Set(delete,null)-import Data.Typeable (Typeable(..))+import Data.Typeable (Typeable,typeOf) -- GHC internals for getting at Double and Float representation as Word64 and Word32 -- This has been superceded by the ST array trick (ugly, but promised to work) --import GHC.Exts (Double(D#),Float(F#),unsafeCoerce#)
protocol-buffers.cabal view
@@ -1,5 +1,5 @@ name: protocol-buffers-version: 2.0.14+version: 2.0.17 cabal-version: >= 1.6 build-type: Simple license: BSD3@@ -31,6 +31,7 @@ Text.ProtocolBuffers.Header Text.ProtocolBuffers.Identifiers Text.ProtocolBuffers.Reflections+ Text.ProtocolBuffers.TextMessage Text.ProtocolBuffers.Unknown Text.ProtocolBuffers.WireMessage @@ -41,6 +42,7 @@ directory, filepath, mtl,+ parsec, utf8-string if flag(small_base)@@ -64,6 +66,7 @@ RankNTypes, RecordWildCards ScopedTypeVariables,+ StandaloneDeriving, TypeSynonymInstances -- {-