protocol-buffers 2.2.0 → 2.3.0
raw patch · 8 files changed
+71/−45 lines, 8 files
Files
- README.md +12/−5
- Text/ProtocolBuffers/Basic.hs +3/−2
- Text/ProtocolBuffers/Extensions.hs +14/−12
- Text/ProtocolBuffers/Get.hs +22/−13
- Text/ProtocolBuffers/Identifiers.hs +10/−6
- Text/ProtocolBuffers/TextMessage.hs +6/−4
- Text/ProtocolBuffers/Unknown.hs +3/−2
- protocol-buffers.cabal +1/−1
README.md view
@@ -333,16 +333,23 @@ is smoothly matched with Haskell sum types. Note that `Maybe` will be always present for a `oneof` field in the owner data type definition (Here, `Maybe Property` in the definition of `Member`). This is because of compatibility with other language-implementationn that treats `oneof` as a collection of `optional` fields. +implementations that treat `oneof` as a collection of `optional` fields. -In the `oneoftest` directory, we provides a Haskell example in `hprotoc/oneoftest/hs`+In the `oneoftest` directory, we provides a Haskell example in `hprotoc/oneoftest/hs`,+modification of the previous example using lenses in `hprotoc/oneoftest/hs-lens` and a C++ example in `hprotoc/oneoftest/cpp` to demonstrate how to use. Each example-has `encode` and `decode`.With `encode`, we start from data in memory and generate+has `encode` and `decode`. With `encode`, we start from data in memory and generate a serialized binary file in wire format. Then,`decode` takes the file and present some information to prove it successfully decoded the binary. One can encode from Haskell side and decode on C++ side, or vice versa. For building, simply run-`build.sh` in each directory. For C++, one must previously install C++ `protobuf`-library and `pkg-config`. We assume that `hprotoc` was already executed as shown above. +`build.sh` in each of `hs` or `cpp` directories. Example with lenses has a `stack.yml`+in it so it could be easily built with `stack build`. For C++, one must previously+install C++ `protobuf` library and `pkg-config`. We assume that `hprotoc` was already+executed as shown above. The version with lenses requires slightly different command:++```+oneoftest> hprotoc --proto_path=. --haskell_out=hs-lens/src school.proto+``` Here are examples. ```
Text/ProtocolBuffers/Basic.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable,GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable,GeneralizedNewtypeDeriving,CPP #-} -- | "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 defines the 'Mergeable' and@@ -19,7 +19,9 @@ import Data.Generics(Data(..)) import Data.Int(Int32,Int64) import Data.Ix(Ix)+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid(Monoid(..))+#endif import Data.Sequence(Seq,(><)) import Data.Typeable(Typeable) import Data.Word(Word8,Word32,Word64)@@ -257,4 +259,3 @@ instance Default (Seq a) where defaultValue = mempty instance Default ByteString where defaultValue = mempty instance Default Utf8 where defaultValue = mempty-
Text/ProtocolBuffers/Extensions.hs view
@@ -35,11 +35,13 @@ import Data.Map(Map) import qualified Data.Map as M import Data.Maybe(fromMaybe,isJust)+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid(mappend,mconcat)+#endif import Data.Sequence((|>),(><),viewl,ViewL(..)) import qualified Data.Sequence as Seq(singleton,null,empty) import Data.Typeable(Typeable,typeOf,cast)-import Data.Data(Data(gfoldl,gunfold,toConstr),Constr,DataType,Fixity(Prefix),mkDataType,mkConstr,constrIndex,dataTypeOf)+import Data.Data(Data(gfoldl,gunfold,toConstr),Constr,DataType,Fixity(Prefix),mkDataType,mkConstr,dataTypeOf) import Text.ProtocolBuffers.Basic import Text.ProtocolBuffers.WireMessage@@ -69,7 +71,7 @@ -- 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@@ -178,7 +180,7 @@ instance Data ExtField where gfoldl f z m = z dataFromList `f` dataToList m- gunfold k z c = k (z dataFromList)+ gunfold k z _ = k (z dataFromList) toConstr (ExtField _) = con_ExtField dataTypeOf _ = ty_ExtField @@ -329,7 +331,7 @@ -- (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 --@@ -346,7 +348,7 @@ -- | The 'Key' and 'GPWitness' GADTs use 'GPB' as a shorthand for many -- classes.-class (Mergeable a,Default a,Wire a,Show a,Typeable a,Eq a,Ord a) => GPB a +class (Mergeable a,Default a,Wire a,Show a,Typeable a,Eq a,Ord a) => GPB a instance GPB Bool instance GPB ByteString@@ -485,12 +487,12 @@ 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 -> FieldType -> EP -> Either String (Seq a) + let mkWitType :: Maybe a -> FieldType -> EP -> Either String (Seq a) mkWitType = undefined chooseGet' = chooseGet `asTypeOf` (mkWitType mv) let parsed = map (chooseGet' ft) . F.toList $ raw errs = [ m | Left m <- parsed ]- if null errs + 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 (F.foldl' mergeAppend x xs))))@@ -548,7 +550,7 @@ Nothing -> Left $ "getExt Seq: Key's Seq value cast failed: "++show (k,typeOf s) Just s' -> Right s' 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@@ -587,7 +589,7 @@ 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 -> FieldType -> EP -> Either String (Seq a) + let mkWitType :: Maybe a -> FieldType -> EP -> Either String (Seq a) mkWitType = undefined chooseGet' = chooseGet `asTypeOf` (mkWitType mv) let parsed = map (chooseGet' t) . F.toList $ raw@@ -602,7 +604,7 @@ v' = ExtPacked t (GPDynSeq s) ef' = M.insert i v' ef in seq v' $ seq ef' (putExtField (ExtField ef') msg)- + clearExt (Key i _ _) msg = let (ExtField ef) = getExtField msg ef' = M.delete i ef@@ -659,7 +661,7 @@ 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 -> FieldType -> EP -> Either String (Seq a) + let mkWitType :: Maybe a -> FieldType -> EP -> Either String (Seq a) mkWitType = undefined chooseGet' = chooseGet `asTypeOf` (mkWitType mv) let parsed = map (chooseGet' t) . F.toList $ raw@@ -723,7 +725,7 @@ 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 s)) | toWireType ft /= wireType -> if (wireType==2) && (isValidPacked ft) + 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))
Text/ProtocolBuffers/Get.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP,MagicHash,ScopedTypeVariables,FlexibleInstances,RankNTypes,TypeSynonymInstances,MultiParamTypeClasses,BangPatterns #-}+{-# LANGUAGE CPP,MagicHash,ScopedTypeVariables,FlexibleInstances,RankNTypes,TypeSynonymInstances,MultiParamTypeClasses,BangPatterns,CPP #-}+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- | By Chris Kuklewicz, drawing heavily from binary and binary-strict, -- but all the bugs are my own. --@@ -64,7 +65,11 @@ -- The Get monad is an instance of binary-strict's BinaryParser: -- import qualified Data.Binary.Strict.Class as P(BinaryParser(..)) -- The Get monad is an instance of all of these library classes:+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative(Applicative(pure,(<*>)),Alternative(empty,(<|>)))+#else+import Control.Applicative(Alternative(empty,(<|>)))+#endif import Control.Monad(MonadPlus(mzero,mplus),when) import Control.Monad.Error.Class(MonadError(throwError,catchError),Error(strMsg)) -- It can be a MonadCont, but the semantics are too broken without a ton of work.@@ -82,9 +87,13 @@ import qualified Data.ByteString.Lazy.Internal as L(ByteString(..),chunk) import qualified Data.Foldable as F(foldr,foldr1) -- used with Seq import Data.Int(Int32,Int64) -- index type for L.ByteString+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid(Monoid(mempty,mappend)) -- Writer has a Monoid contraint-import Data.Sequence(Seq,null,(|>)) -- used for future queue in handler state import Data.Word(Word,Word8,Word16,Word32,Word64)+#else+import Data.Word(Word8,Word16,Word32,Word64)+#endif+import Data.Sequence(Seq,null,(|>)) -- used for future queue in handler state import Foreign.ForeignPtr(withForeignPtr) import Foreign.Ptr(Ptr,castPtr,plusPtr,minusPtr,nullPtr) import Foreign.Storable(Storable(peek,sizeOf))@@ -127,7 +136,7 @@ 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 else- let (TU'OK x i) = + let (TU'OK x i) = unsafePerformIO $ withForeignPtr fp $ \ptr0 -> do if ptr0 == nullPtr || len < 1 then error "Get.decode7unrolled: ByteString invariant failed" else do let ok :: s -> Int -> IO (TU s)@@ -173,25 +182,25 @@ let !val'5 = (val'4 .|. (fromIntegral (b'5 .&. 0x7F) `shiftL` 28)) !ptr6 = ptr5 `plusPtr` 1 if ptr6 >= end then more else do- + b'6 <- peek ptr6 if b'6 < 128 then ok (val'5 .|. (fromIntegral b'6 `shiftL` 35)) 6 else do let !val'6 = (val'5 .|. (fromIntegral (b'6 .&. 0x7F) `shiftL` 35)) !ptr7 = ptr6 `plusPtr` 1 if ptr7 >= end then more else do- + b'7 <- peek ptr7 if b'7 < 128 then ok (val'6 .|. (fromIntegral b'7 `shiftL` 42)) 7 else do let !val'7 = (val'6 .|. (fromIntegral (b'7 .&. 0x7F) `shiftL` 42)) !ptr8 = ptr7 `plusPtr` 1 if ptr8 >= end then more else do- + b'8 <- peek ptr8 if b'8 < 128 then ok (val'7 .|. (fromIntegral b'8 `shiftL` 49)) 8 else do let !val'8 = (val'7 .|. (fromIntegral (b'8 .&. 0x7F) `shiftL` 49)) !ptr9 = ptr8 `plusPtr` 1 if ptr9 >= end then more else do- + b'9 <- peek ptr9 if b'9 < 128 then ok (val'8 .|. (fromIntegral b'9 `shiftL` 56)) 9 else do let !val'9 = (val'8 .|. (fromIntegral (b'9 .&. 0x7F) `shiftL` 56))@@ -380,7 +389,7 @@ useCheckpoint return a --- | 'lookAheadM' runs the @todo@ action. If the action returns 'Nothing' then the +-- | 'lookAheadM' runs the @todo@ action. If the action returns 'Nothing' then the -- BinaryParser state is rewound (as in 'lookAhead'). If the action return 'Just' then -- the BinaryParser is not rewound, and lookAheadM acts as an identity. --@@ -393,7 +402,7 @@ maybe useCheckpoint (const clearCheckpoint) a return a --- | 'lookAheadE' runs the @todo@ action. If the action returns 'Left' then the +-- | 'lookAheadE' runs the @todo@ action. If the action returns 'Left' then the -- BinaryParser state is rewound (as in 'lookAhead'). If the action return 'Right' then -- the BinaryParser is not rewound, and lookAheadE acts as an identity. --@@ -416,9 +425,9 @@ instance (Show a) => Show (Result a) where showsPrec _ (Failed n msg) = ("(Failed "++) . shows n . (' ':) . shows msg . (")"++) showsPrec _ (Finished bs n a) =- ("(CFinished ("++) + ("(CFinished ("++) . shows bs . (") ("++)- . shows n . (") ("++) + . shows n . (") ("++) . shows a . ("))"++) showsPrec _ (Partial {}) = ("(Partial <Maybe Data.ByteString.Lazy.ByteString-> Result a)"++) @@ -465,7 +474,7 @@ | otherwise = make_state (mappend whole bsNew) n1 rebuild x@(ErrorFrame {}) = x in sc () s' (rebuild pc)- + -- Internal access to full internal state, as helper functions getFull :: Get S getFull = Get $ \ sc s pc -> sc s s pc@@ -774,7 +783,7 @@ {-# INLINE getWord64host #-} -- Below here are the class instances- + instance Functor Get where fmap f m = Get (\sc -> unGet m (sc . f)) {-# INLINE fmap #-}
Text/ProtocolBuffers/Identifiers.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses,TypeSynonymInstances,FlexibleInstances,DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses,TypeSynonymInstances,FlexibleInstances,DeriveDataTypeable,CPP #-} -- | 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@@ -30,8 +30,12 @@ import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.UTF8 as U import Data.Char-import Data.List hiding (uncons)+#if __GLASGOW_HASKELL__ < 710+import Data.List import Data.Monoid+#else+import Data.List hiding (uncons)+#endif import Data.Generics(Data) import Data.Typeable(Typeable) import Data.Set(Set)@@ -104,7 +108,7 @@ cons :: Char -> a -> a dot :: a -> a -> a validI :: a -> Maybe (IName a)- -- | 'validDI' ensures the DIName is + -- | 'validDI' ensures the DIName is validDI :: a -> Maybe (DIName a) -- | 'split' returns a list of non-empty 'a' with all '.' characters removed split :: a -> [a]@@ -137,10 +141,10 @@ splitFM :: Dotted a => FMName a -> [MName a] splitFM = map MName . split . fmName -promoteDI :: Dotted a => IName a -> DIName a +promoteDI :: Dotted a => IName a -> DIName a promoteDI = DIName . iName -promoteFI :: Dotted a => IName a -> FIName a +promoteFI :: Dotted a => IName a -> FIName a promoteFI = FIName . cons '.' . iName promoteFM :: Dotted a => MName a -> FMName a@@ -190,7 +194,7 @@ (True,_) -> Left $ "Invalid identifier because is contains two periods in a row: "++show (toString s) (_,True) -> Right (f [IName (Utf8 a)]) _ -> parts (f . (IName (Utf8 a):)) (U.span ('.'/=) (U.drop 1 b))- + -- | The 'mangle' transformation has instances for several combiantions -- of input and output. These allow one to construct the Haskell types -- of MName/FMName/PMName and FName/FFName/PFName out of the protobuf
Text/ProtocolBuffers/TextMessage.hs view
@@ -13,7 +13,9 @@ getSubMessage, ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*), (*>))+#endif import Control.Monad.Identity (Identity) import Control.Monad (void) import Control.Monad.Writer (Writer, execWriter, tell, censor)@@ -53,7 +55,7 @@ tellShow name v = tells $ name ++ ": " ++ show v tellStr :: String -> ByteString -> Output-tellStr name s = tells $ name ++ ": \"" ++ dumpOctal s ++ "\""+tellStr name s = tells $ name ++ ": \"" ++ dumpDecimal s ++ "\"" tellSubMessage :: TextMsg a => String -> a -> Output tellSubMessage name m = do@@ -63,13 +65,13 @@ where indent = censor (fmap (\(!n, s) -> (n + 1, s))) -dumpOctal :: ByteString -> String-dumpOctal = C8.foldr escape []+dumpDecimal :: ByteString -> String+dumpDecimal = 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+ escape c str = printf "\\%03d" c ++ str instance TextType Int32 where tellT = tellShow
Text/ProtocolBuffers/Unknown.hs view
@@ -10,7 +10,9 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Foldable as F import Data.Generics+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid(mempty,mappend)+#endif import Data.Sequence((|>)) import Data.Typeable() import Control.Monad.Error.Class(catchError)@@ -54,7 +56,7 @@ {-# INLINE catch'Unknown #-} -- | This is used by the generated code catch'Unknown :: (Typeable a, UnknownMessage a) => (WireTag -> a -> Get a) -> (WireTag -> a -> Get a)-catch'Unknown update'Self = \wire'Tag old'Self -> catchError (update'Self wire'Tag old'Self) (\_ -> loadUnknown wire'Tag old'Self) +catch'Unknown update'Self = \wire'Tag old'Self -> catchError (update'Self wire'Tag old'Self) (\_ -> loadUnknown wire'Tag old'Self) where loadUnknown :: (Typeable a, UnknownMessage a) => WireTag -> a -> Get a loadUnknown tag msg = do let (fieldId,wireType) = splitWireTag tag@@ -63,4 +65,3 @@ let v' = seq bs $ UFV tag bs uf' = seq v' $ uf |> v' seq uf' $ return $ putUnknownField (UnknownField uf') msg-
protocol-buffers.cabal view
@@ -1,5 +1,5 @@ name: protocol-buffers-version: 2.2.0+version: 2.3.0 cabal-version: >= 1.6 build-type: Simple license: BSD3