packages feed

protocol-buffers 0.3.1 → 1.0.0

raw patch · 10 files changed

+466/−56 lines, 10 filesdep +sybdep ~base

Dependencies added: syb

Dependency ranges changed: base

Files

TODO view
@@ -1,7 +1,9 @@+Change Resolve to separate the conversion to fully qualified names from the name mangling.+  This should allow hprotoc to create FileDescriptorSet output that mimics protoc+ How does protoc parse enum options and enum value options??  In the new version!  Add even more of the documentation for the public API.-add check to getBareMessageWith for fieldId of stop group tag? delete commented out code add strictness annotations to internal data types. benchmark
Text/ProtocolBuffers.hs view
@@ -5,17 +5,18 @@  @ import Text.ProtocolBuffers.Basic-  ( Seq,Utf8(..),ByteString,Int32,Int64,Word32,Word64+  ( Seq,Utf8(utf8),Int32,Int64,Word32,Word64   , WireTag,FieldId,WireType,FieldType,EnumCode,WireSize-  , Mergeable(..),Default(..),Wire)+  , Mergeable(mergeEmpty,mergeAppend,mergeConcat),Default(defaultValue),Wire) import Text.ProtocolBuffers.Default() import Text.ProtocolBuffers.Extensions-  ( Key,ExtKey(getExt,putExt,clearExt),MessageAPI(..)+  ( Key,ExtKey(getExt,putExt,clearExt),MessageAPI(getVal,isSet)   , getKeyFieldId,getKeyFieldType,getKeyDefaultValue)+import Text.ProtocolBuffers.Identifiers import Text.ProtocolBuffers.Mergeable() import Text.ProtocolBuffers.Reflections   ( ReflectDescriptor(..),ReflectEnum(..),ProtoName(..),HsDefault(..),EnumInfoApp-  , KeyInfo,FieldInfo(..),DescriptorInfo(..),EnumInfo(..),ProtoInfo(..))+  , KeyInfo,FieldInfo(..),DescriptorInfo(..),EnumInfo(..),ProtoInfo(..),makePNF ) import Text.ProtocolBuffers.WireMessage   ( Put,Get,runPut,runGet,runGetOnLazy   , messageSize,messagePut,messageGet,messagePutM,messageGetM@@ -23,26 +24,38 @@   , messageAsFieldSize,messageAsFieldPutM,messageAsFieldGetM) @ +The message serialization is taken care of by "WireMessage"+operations, especially 'messagePut' and 'messageGet'.  The+'MessageAPI' provides the useful polymorphic 'getVal' and 'isSet'+where 'getVal' looks up default values and also works with extension+keys.  The 'Utf8' newtype is used to indicate the format in the+underlying lazy 'ByteString'.  Messages and values can be combined+with the right-biased 'Mergeable' operations.  The 'mergeEmpty' should+not be used as required values are filled in with undefined errors,+please use 'defaultValue' instead.+ -} module Text.ProtocolBuffers(     module Text.ProtocolBuffers.Basic   , module Text.ProtocolBuffers.Extensions+  , module Text.ProtocolBuffers.Identifiers   , module Text.ProtocolBuffers.Reflections   , module Text.ProtocolBuffers.WireMessage   ) where  import Text.ProtocolBuffers.Basic-  ( Seq,Utf8(..),ByteString,Int32,Int64,Word32,Word64+  ( Seq,Utf8(utf8),Int32,Int64,Word32,Word64   , WireTag,FieldId,WireType,FieldType,EnumCode,WireSize-  , Mergeable(..),Default(..),Wire)+  , Mergeable(mergeEmpty,mergeAppend,mergeConcat),Default(defaultValue),Wire) import Text.ProtocolBuffers.Default() import Text.ProtocolBuffers.Extensions-  ( Key,ExtKey(getExt,putExt,clearExt),MessageAPI(..)+  ( Key,ExtKey(getExt,putExt,clearExt),MessageAPI(getVal,isSet)   , getKeyFieldId,getKeyFieldType,getKeyDefaultValue)+import Text.ProtocolBuffers.Identifiers import Text.ProtocolBuffers.Mergeable() import Text.ProtocolBuffers.Reflections   ( ReflectDescriptor(..),ReflectEnum(..),ProtoName(..),HsDefault(..),EnumInfoApp-  , KeyInfo,FieldInfo(..),DescriptorInfo(..),EnumInfo(..),ProtoInfo(..))+  , KeyInfo,FieldInfo(..),DescriptorInfo(..),EnumInfo(..),ProtoInfo(..),makePNF ) import Text.ProtocolBuffers.WireMessage   ( Put,Get,runPut,runGet,runGetOnLazy   , messageSize,messagePut,messageGet,messagePutM,messageGetM
Text/ProtocolBuffers/Basic.hs view
@@ -18,19 +18,39 @@ import Data.Generics(Data(..)) import Data.Int(Int32,Int64) import Data.Ix(Ix)+import Data.Monoid(Monoid(..)) import Data.Sequence(Seq) import Data.Typeable(Typeable(..)) import Data.Word(Word32,Word64) import Text.ProtocolBuffers.Get(Get) +import Data.ByteString.Lazy.UTF8 as U (toString,fromString)+ -- Num instances are derived below for the purpose of getting fromInteger for case matching  -- | 'Utf8' is used to mark 'ByteString' values that (should) contain -- valud utf8 encoded strings.  This type is used to represent -- 'TYPE_STRING' values. newtype Utf8 = Utf8 {utf8 :: ByteString}-  deriving (Read,Show,Data,Typeable,Eq,Ord)+  deriving (Data,Typeable,Eq,Ord) +instance Read Utf8 where+  readsPrec d xs =+    let r :: Int -> ReadS String+        r = readsPrec+        f :: (String,String) -> (Utf8,String)+        f (a,b) = (Utf8 (U.fromString a),b)+    in map f . r d $ xs++instance Show Utf8 where+  showsPrec d (Utf8 bs) = let s :: Int -> String -> ShowS+                              s = showsPrec+                          in s d (U.toString bs)++instance Monoid Utf8 where+  mempty = Utf8 mempty+  mappend (Utf8 x) (Utf8 y) = Utf8 (mappend x y)+ -- | 'WireTag' is the 32 bit value with the upper 29 bits being the -- 'FieldId' and the lower 3 bits being the 'WireType' newtype WireTag = WireTag { getWireTag :: Word32 } -- bit concatenation of FieldId and WireType@@ -44,7 +64,7 @@  -- Note that values 19000-19999 are forbidden for FieldId instance Bounded FieldId where-  minBound = 0+  minBound = 1   maxBound = 536870911 -- 2^29-1  -- | 'WireType' is the 3 bit wire encoding value, and is currently in
Text/ProtocolBuffers/Extensions.hs view
@@ -23,7 +23,7 @@   , Key(..),ExtKey(..),MessageAPI(..)   -- * Internal types, functions, and classes   , wireSizeExtField,wirePutExtField,getMessageExt,getBareMessageExt,loadExtension-  , GPB,ExtField(..),ExtendMessage(..)+  , GPB,ExtField(..),ExtendMessage(..),ExtFieldValue(..)   ) where  import qualified Data.ByteString.Lazy as L
Text/ProtocolBuffers/Header.hs view
@@ -11,6 +11,7 @@     , module Data.Typeable     , module Text.ProtocolBuffers.Basic     , module Text.ProtocolBuffers.Extensions+    , module Text.ProtocolBuffers.Identifiers     , module Text.ProtocolBuffers.Reflections     , module Text.ProtocolBuffers.Unknown     , module Text.ProtocolBuffers.WireMessage@@ -28,9 +29,10 @@ import Text.ProtocolBuffers.Extensions   ( wireSizeExtField,wirePutExtField,loadExtension,getMessageExt,getBareMessageExt   , GPB,Key(..),ExtField,ExtendMessage(..),MessageAPI(..),ExtKey(wireGetKey) )+import Text.ProtocolBuffers.Identifiers(FIName(..),MName(..),FName(..)) import Text.ProtocolBuffers.Mergeable() import Text.ProtocolBuffers.Reflections-  ( ReflectDescriptor(..),ReflectEnum(..),EnumInfo(..),ProtoName(..),DescriptorInfo(extRanges) )+  ( ReflectDescriptor(..),ReflectEnum(..),EnumInfo(..),ProtoName(..),DescriptorInfo(extRanges),makePNF ) import Text.ProtocolBuffers.Unknown   ( UnknownField,UnknownMessage(..),wireSizeUnknownField,wirePutUnknownField,loadUnknown ) import Text.ProtocolBuffers.WireMessage
+ Text/ProtocolBuffers/Identifiers.hs view
@@ -0,0 +1,347 @@+-- | 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 gereneted DescriptorProto+-- data structures it is stored in 'Utf8' tagged lazy bytestrings.+--+-- An 'identifier' is a non-empty ASCII string made of [a-zA-Z0-9_]+-- where the first cahracter is never in [0-9].+--+-- A 'field' is a mangled identifer that is a valid Haskell name that+-- begins with lower case, and which may have a single quote at the+-- end if needed to avoid a reserved word.  These may also start with+-- '_', though just a "_" is mangled to "_'".+--+-- A 'module' is a mangled identifier that is a valid Haskell name+-- that begins with upper case.  These never have a single quote.  A+-- leading _ is replaced with a leading U'_ to make a valid+-- identifier.+module Text.ProtocolBuffers.Identifiers+  ( unull,toString,fromString+  , IName(..),DIName(..),FIName(..)+  , MName(..),FMName(..),PMName(..)+  , FName(..),FFName(..),PFName(..)+  , Dotted(..),Mangle(..)+  , joinPM,joinPF,difi,splitDI,splitFI,splitFM+  , checkDIString,checkDIUtf8+  , promoteDI,promoteFI,promoteFM,promoteFF,dotFM,dotFF,fqAppend+  ) where++import qualified Data.ByteString.Lazy.Char8 as LC+import qualified Data.ByteString.Lazy.UTF8 as U+import Data.Char+import Data.List+import Data.Monoid+import Data.Generics(Data)+import Data.Typeable(Typeable)+import Data.Set(Set)+import qualified Data.Set as S+import Text.ProtocolBuffers.Basic++-- basic utilities to export++unull :: Utf8 -> Bool+unull = LC.null . utf8++toString :: Utf8 -> String+toString = U.toString . utf8++fromString :: String -> Utf8+fromString = Utf8 . U.fromString++-- | Contains one identifier name+newtype IName a = IName {iName::a} deriving (Data,Typeable,Eq,Ord)+-- | Contains one module name, non-empty+newtype MName a = MName {mName::a} deriving (Data,Typeable,Eq,Ord)+-- | Contains one field name, non-empty+newtype FName a = FName {fName::a} deriving (Data,Typeable,Eq,Ord)+-- | '.' separated identifier which may or may start with a dot.  There+-- are never two or more '.'s in a row.  There is always at least one identifier.+newtype DIName a = DIName {diName :: a} deriving (Data,Typeable,Eq,Ord)+-- | Fully qualified identifier: repeated ('.' then identifier)+newtype FIName a = FIName {fiName::a} deriving (Data,Typeable,Eq,Ord)+-- | Full Haskell module name: MNames separated by '.', ending with a module+newtype FMName a = FMName {fmName::a} deriving (Data,Typeable,Eq,Ord)+-- | Full Haskell field name: MNames separated by '.', ending with a field+newtype FFName a = FFName {ffName::a} deriving (Data,Typeable,Eq,Ord)+-- | Parsed Haskell name ending with MName.  Good contructor to use.+data PMName a = PMName [MName a] (MName a) deriving (Show,Data,Typeable,Read,Eq,Ord)+-- | Parsed Haskell name ending with FName.  Good constructor to use.+data PFName a = PFName [MName a] (FName a) deriving (Show,Data,Typeable,Read,Eq,Ord)++app_prec,max_prec :: Int+app_prec = 10+max_prec = 11++{-# INLINE readIt #-}+readIt :: (Read a) => (a -> a1) -> String -> Int -> String -> [(a1, String)]+readIt con name d  = readParen (d > app_prec) (\r -> [(con m,t) | (name',s) <- lex r, name==name', (m,t) <- readsPrec (max_prec) s])++{-# INLINE showIt #-}+showIt :: (Show a) => Int -> [Char] -> a -> String -> String+showIt d name a = showParen (d > app_prec) $ (name++) . (' ':) . showsPrec max_prec a++instance Read a => Read (IName a) where readsPrec = readIt IName "IName"+instance Read a => Read (MName a) where readsPrec = readIt MName "MName"+instance Read a => Read (FName a) where readsPrec = readIt FName "FName"+instance Read a => Read (DIName a) where readsPrec = readIt DIName "DIName"+instance Read a => Read (FIName a) where readsPrec = readIt FIName "FIName"+instance Read a => Read (FFName a) where readsPrec = readIt FFName "FFName"+instance Read a => Read (FMName a) where readsPrec = readIt FMName "FMName"++instance Show a => Show (IName a) where showsPrec d (IName a) = showIt d "IName" a+instance Show a => Show (MName a) where showsPrec d (MName a) = showIt d "MName" a+instance Show a => Show (FName a) where showsPrec d (FName a) = showIt d "FName" a+instance Show a => Show (DIName a) where showsPrec d (DIName a) = showIt d "DIName" a+instance Show a => Show (FIName a) where showsPrec d (FIName a) = showIt d "FIName" a+instance Show a => Show (FMName a) where showsPrec d (FMName a) = showIt d "FMName" a+instance Show a => Show (FFName a) where showsPrec d (FFName a) = showIt d "FFName" a++-- | This is used to abstract over Utf8 and String.  The important+-- entry point is 'validDI'.+class (Monoid a) => Dotted a where+  uncons :: a -> Maybe (Char,a)+  cons :: Char -> a -> a+  dot :: a -> a -> a+  validI :: a -> Maybe (IName a)+  -- | '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]++-- These are also part of the external API, they are abstracted over+-- Dotted.++joinPM :: Dotted a => PMName a -> FMName a+joinPM (PMName xs (MName x)) = FMName (foldr dot x . map mName $ xs)++joinPF :: Dotted a => PFName a -> FFName a+joinPF (PFName xs (FName x)) = FFName (foldr dot x . map mName $ xs)++-- | 'difi' examines the 'DIName' and prepend a '.' if absent, promoting+-- it to a 'FIName'.+difi :: Dotted a => DIName a -> FIName a+difi (DIName a) = case uncons a of+                    Just ('.',_) -> FIName a+                    _ -> FIName (cons '.' a)++-- | Typed 'split'+splitDI :: Dotted a => DIName a -> [IName a]+splitDI = map IName . split . diName++-- | Typed 'split'+splitFI :: Dotted a => FIName a -> [IName a]+splitFI = map IName . split . fiName++-- | Typed 'split'+splitFM :: Dotted a => FMName a -> [MName a]+splitFM = map MName . split . fmName++promoteDI :: Dotted a => IName a -> DIName a +promoteDI = DIName . iName++promoteFI :: Dotted a => IName a -> FIName a +promoteFI = FIName . cons '.' . iName++promoteFM :: Dotted a => MName a -> FMName a+promoteFM = FMName . mName++promoteFF :: Dotted a => FName a -> FFName a+promoteFF = FFName . fName++dotFM :: Dotted a => FMName a -> FMName a -> FMName a+dotFM (FMName a) (FMName b) = FMName (a `dot` b)++dotFF :: Dotted a => FMName a -> FFName a -> FFName a+dotFF (FMName a) (FFName b) = FFName (a `dot` b)++fqAppend :: Dotted a => FIName a -> [IName a] -> FIName a+fqAppend (FIName base) xs = FIName (foldl' dot base . map iName $ xs)++-- The two checkDI* functions give better error messages than validDI++-- | Right (True,_) means the input is a FIName.+-- Right (False,_) means the input is a DIName (without leading '.')+--+-- This creates useful error messages for the user.+checkDIString :: String -> Either String (Bool,[IName String])+checkDIString "" = Left $ "Invalid empty identifier: "++show ""+checkDIString "." = Left $ "Invalid identifier of just a period: "++show "."+checkDIString xs | ('.':ys) <- xs = fmap ((,) True) $ parts id (span ('.'/=) ys)+                 | otherwise = fmap ((,) False) $ parts id (span ('.'/=) xs)+ where parts _f ("","") = Left $ "Invalid identifier because it ends with a period: "++show xs+       parts _f ("",_)  = Left $ "Invalid identifier because is contains two periods in a row: "++show xs+       parts f  (a,"")  = Right (f [IName a])+       parts f  (a,b)   = parts (f . (IName a:)) (span ('.'/=) (tail b))++-- | Right (True,_) means the input is a FIName.+-- Right (False,_) means the input is a DIName (without leading '.')+--+-- This creates useful error messages for the user.+checkDIUtf8 :: Utf8 -> Either String (Bool,[IName Utf8])+checkDIUtf8 s@(Utf8 xs) =+  case U.uncons xs of+    Nothing -> Left $ "Invalid empty identifier: "++show ""+    Just ('.',ys) | LC.null ys -> Left $ "Invalid identifier of just a period: "++show "."+                  | otherwise -> fmap ((,) True) $ parts id (U.span ('.'/=) ys)+    Just _ -> fmap ((,) False) $ parts id (U.span ('.'/=) xs)+ where parts f (a,b) = case (LC.null a,LC.null b) of+                         (True,True) -> Left $ "Invalid identifier because it ends with a period: "++show (toString s)+                         (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+-- types IName/DIName/FIName.  Currently, all the Haskell instances+-- are for the String base type.++class Mangle a b where mangle :: a -> b++instance Mangle (IName String) (MName String) where+  mangle (IName s) = MName (fixUp s)++instance Mangle (IName Utf8) (MName String) where+  mangle (IName s) = MName (fixUp . toString $ s)++instance Mangle (FName String) (MName String) where+  mangle (FName s) = MName (fixUp s)++instance Mangle (IName String) (FName String) where+  mangle (IName s) = FName (fixLow s)++instance Mangle (IName Utf8) (FName String) where+  mangle (IName s) = FName (fixLow . toString $ s)++instance Mangle (MName String) (FName String) where+  mangle (MName s) = FName (fixLow s)++instance Mangle (DIName Utf8) (PMName String) where+  mangle s = let ms = splitDI s in PMName (map mangle $ init ms) (mangle $ last ms)++instance Mangle (FIName Utf8) (PMName String) where+  mangle s = let ms = splitFI s in PMName (map mangle $ init ms) (mangle $ last ms)++instance Mangle (DIName Utf8) (PFName String) where+  mangle s = let ms = splitDI s in PFName (map mangle $ init ms) (mangle $ last ms)++instance Mangle (FIName Utf8) (PFName String) where+  mangle s = let ms =  splitFI s in PFName (map mangle $ init ms) (mangle $ last ms)++-- implementation details follow++dotUtf8 :: Utf8 -> Utf8 -> Utf8+dotUtf8 (Utf8 a) (Utf8 b) = Utf8 (LC.append a (LC.cons '.' b))++dotString :: String -> String -> String+dotString a b = a ++ ('.':b)++-- | Return list of nonempty Utf8, with all '.' removed+splitUtf8 :: Utf8 -> [Utf8]+splitUtf8 = unfoldr s . utf8 where+  s :: ByteString -> Maybe (Utf8,ByteString)+  s y = case LC.uncons y of+          Nothing -> Nothing+          Just ('.',xs) -> s xs -- delete all '.' in the input+          _ -> Just (let (a,b) = U.span ('.'/=) y in (Utf8 a,b))++-- | Return list of nonempty String, with all '.' removed+splitString :: String -> [String]+splitString = unfoldr s where+  s [] = Nothing+  s ('.':xs) = s xs -- delete all '.' in the input+  s xs = Just (span ('.'/=) xs)++validIUtf8 :: Utf8 -> Maybe (IName Utf8)+validIUtf8 xs | unull xs = Nothing+validIUtf8 xs@(Utf8 bs) = if LC.all (`S.member` validISet) bs+                            then Just (IName xs)+                            else Nothing++validIString :: String -> Maybe (IName String)+validIString [] = Nothing+validIString xs = if all (`S.member` validISet) xs+                    then Just (IName xs)+                    else Nothing++validDIUtf8 :: Utf8 -> Maybe (DIName Utf8)+validDIUtf8 xs | unull xs = Nothing+validDIUtf8 xs@(Utf8 bs) =+  if LC.all (`S.member` validDISet) bs && LC.any ('.'/=) bs && LC.last bs /= '.'+     && (all (\(x,y) -> '.'/=x || '.'/=y) . (\x -> zip (init x) (tail x)) . toString $ xs)+    then Just (DIName xs)+    else Nothing++validDIString :: String -> Maybe (DIName String)+validDIString []  = Nothing+validDIString xs =+  if all (`S.member` validDISet) xs && any ('.'/=) xs && last xs /= '.'+     && all (\(x,y) -> '.'/=x || '.'/=y) (zip (init xs) (tail xs))+    then Just (DIName xs)+    else Nothing++validISet :: Set Char+validISet = S.fromDistinctAscList "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"++validDISet :: Set Char+validDISet = S.fromDistinctAscList ".0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"++instance Dotted Utf8 where+  uncons x = case U.uncons (utf8 x) of+               Nothing -> Nothing+               Just (c,b) -> Just (c,Utf8 b)+  cons b (Utf8 bs) | fromEnum b < 128 = Utf8 (LC.cons b bs)+                   | otherwise = Utf8 ((U.fromString [b]) `mappend` bs)+  dot = dotUtf8+  split = splitUtf8+  validI = validIUtf8+  validDI = validDIUtf8++instance Dotted String where+  uncons [] = Nothing+  uncons (x:xs) = Just (x,xs)+  cons = (:)+  dot = dotString+  split = splitString+  validI = validIString+  validDI = validDIString++err :: String -> a+err s = error ("Text.ProtocolBuffers.ProtoCompile.Identifiers: "++s)++-- make leading upper case letter, and leanding "_" becomes "U'_"+fixUp :: String -> String+fixUp xs | last xs == '\'' = fixUp (init xs) -- in case this is mangling after "fixLow"+fixUp ('_':xs) = "U'"++xs+fixUp i@(x:xs) | isLower x =+  let x' = toUpper x+  in if isLower x' then err ("fixUp: stubborn lower case"++show i)+       else x': xs+fixUp xs = xs++-- make leading '_' or lower case letter, may end with added single quote.+fixLow :: String -> String+fixLow [] = []+fixLow ('U':'\'':xs@('_':_))= fixLow xs+fixLow i@(x:xs) | i `S.member` reserved = i ++ "'"+                | isUpper x = let x' = toLower x+                              in if isUpper x' then err ("fixLow: stubborn upper case: "++show i)+                                   else let i' = (x':xs)+                                        in if i' `S.member` reserved then i' ++ "'" else i'+                | otherwise = i++-- | 'reserved' is a set of strings which are Haskell keywords and+-- should not be valid field names.+--+-- I do not protect these values:+-- "mdo","foreign","rec","proc" ( GHC manual section 8.3.16 )+-- because I do not anticipate using these extensions in the generated+-- Haskell code.+reserved :: Set String+reserved = S.fromDistinctAscList+  ["_"+  ,"case","class","data","default","deriving","do","else"+  ,"forall" {- extension keyword -}+  ,"if","import","in","infix","infixl","infixr","instance"+  ,"let","module","newtype","of","then","type","where"+  ]
Text/ProtocolBuffers/Reflections.hs view
@@ -8,13 +8,17 @@ -- have yet to write much documentation.  Luckily the record field -- names are somewhat descriptive. --+-- The other reflection is using the 'fileDescriptorProto' which+-- is put into the top level module created by hprotoc. module Text.ProtocolBuffers.Reflections-  ( ProtoName(..),ProtoInfo(..),DescriptorInfo(..),FieldInfo(..),KeyInfo+  ( ProtoName(..),ProtoFName(..),ProtoInfo(..),DescriptorInfo(..),FieldInfo(..),KeyInfo   , HsDefault(..),EnumInfo(..),EnumInfoApp   , ReflectDescriptor(..),ReflectEnum(..),GetMessageInfo(..)+  , makePNF   ) where  import Text.ProtocolBuffers.Basic+import Text.ProtocolBuffers.Identifiers  import Data.List(sort) import qualified Data.Foldable as F(toList)@@ -24,6 +28,14 @@ import Data.Typeable(Typeable) import Data.Map(Map) +-- | 'makePNF' is used by the generated code to create a ProtoName with less newtype noise.+makePNF :: ByteString -> [String] -> [String] -> String -> ProtoName+makePNF a bs cs d =+  ProtoName (FIName (Utf8 a))+            (map MName bs)+            (map MName cs)+            (MName d)+ -- | This is fully qualified name data type for code generation.  The -- 'haskellPrefix' was possibly specified on the 'hprotoc' command -- line.  The 'parentModule' is a combination of the module prefix@@ -31,19 +43,27 @@ -- -- The name components are likely to have been mangled to ensure the -- 'baseName' started with an uppercase letter, in @ ['A'..'Z'] @.-data ProtoName = ProtoName { haskellPrefix :: String  -- ^ Haskell specific prefix to module hierarchy (e.g. Text.Foo)-                           , parentModule :: String   -- ^ Proto specified namespace (like Com.Google.Bar)-                           , baseName :: String       -- ^ unqualfied name of this thing (with no periods)+data ProtoName = ProtoName { protobufName :: FIName Utf8     -- ^ fully qualified name using "package" prefix (no mangling)+                           , haskellPrefix :: [MName String] -- ^ Haskell specific prefix to module hierarchy (e.g. Text.Foo)+                           , parentModule :: [MName String]  -- ^ .proto specified namespace (like Com.Google.Bar)+                           , baseName :: MName String                            }   deriving (Show,Read,Eq,Ord,Data,Typeable) -data ProtoInfo = ProtoInfo { protoMod :: ProtoName-                           , protoFilePath :: [FilePath]-                           , protoSource :: String-                           , extensionKeys :: Seq KeyInfo-                           , messages :: [DescriptorInfo]-                           , enums :: [EnumInfo]-                           , knownKeyMap :: Map ProtoName (Seq FieldInfo)+data ProtoFName = ProtoFName { protobufName' :: FIName Utf8     -- ^ fully qualified name using "package" prefix (no mangling)+                             , haskellPrefix' :: [MName String] -- ^ Haskell specific prefix to module hierarchy (e.g. Text.Foo)+                             , parentModule' :: [MName String]  -- ^ .proto specified namespace (like Com.Google.Bar)+                             , baseName' :: FName String+                             }+  deriving (Show,Read,Eq,Ord,Data,Typeable)++data ProtoInfo = ProtoInfo { protoMod :: ProtoName        -- ^ blank protobufName, maybe blank haskellPrefix and/or parentModule+                           , protoFilePath :: [FilePath]  -- ^ path to haskell module+                           , protoSource :: FilePath      -- ^ filename without path of .proto file+                           , extensionKeys :: Seq KeyInfo -- ^ top level keys+                           , messages :: [DescriptorInfo] -- ^ all messages and groups+                           , enums :: [EnumInfo]          -- ^ all enums+                           , knownKeyMap :: Map ProtoName (Seq FieldInfo) -- all keys in namespace                            }   deriving (Show,Read,Eq,Ord,Data,Typeable) @@ -70,9 +90,9 @@                                      }   deriving (Show,Read,Eq,Ord,Data,Typeable) -type KeyInfo = (ProtoName,FieldInfo)+type KeyInfo = (ProtoName,FieldInfo) -- Extendee and FieldInfo -data FieldInfo = FieldInfo { fieldName     :: ProtoName+data FieldInfo = FieldInfo { fieldName     :: ProtoFName                            , fieldNumber   :: FieldId                            , wireTag       :: WireTag                            , wireTagLength :: WireSize         -- ^ Bytes required in the Varint formatted wireTag
Text/ProtocolBuffers/Unknown.hs view
@@ -1,5 +1,6 @@--- | This module add unknown field supprt to the library---+-- | This module add unknown field support to the library.  There are+-- no user API things here.+ -- This should support --  1) Storing unknown bytestrings in messages --     a) Mergeable@@ -71,17 +72,6 @@ wirePutUnknownField (UnknownField m) = mapM_ aPut (M.assocs m) where   aPut (fi,(UFV wt raw)) = F.mapM_ (\bs -> putVarUInt (getWireTag $ mkWireTag fi wt) >> putLazyByteString bs) raw -{--getMessageUnknown :: (Mergeable message, ReflectDescriptor message,Typeable message,ExtendMessage message)-                  => (FieldId -> message -> Get message)-                  -> Get message-getMessageUnknown = getMessageWith loadUnknown--getBareMessageUnknown :: (Mergeable message, ReflectDescriptor message,Typeable message,ExtendMessage message)-                      => (FieldId -> message -> Get message)-                      -> Get message-getBareMessageUnknown = getBareMessageWith loadUnknown--} loadUnknown :: (Typeable a, UnknownMessage a) => FieldId -> WireType -> a -> Get a loadUnknown fieldId wireType msg = do   let (UnknownField uf) = getUnknownField msg
Text/ProtocolBuffers/WireMessage.hs view
@@ -6,8 +6,11 @@ <http://code.google.com/apis/protocolbuffers/docs/encoding.html>.  The user API functions are grouped into sections and documented.  The-rest are for internal use.- -}+rest are for internal use.  The main functions are 'messageGet' and+'messagePut' (and 'messageSize').  There are then several 'message*'+variants which allow for finer control and for making delimited+messages.+-} module Text.ProtocolBuffers.WireMessage     ( -- * User API functions       -- ** Main encoding and decoding operations (non-delimited message encoding)@@ -56,6 +59,8 @@ import Text.ProtocolBuffers.Reflections(ReflectDescriptor(reflectDescriptorInfo,getMessageInfo)                                        ,DescriptorInfo(..),GetMessageInfo(..)) +--import Debug.Trace(trace)+ -- External user API for writing and reading messages  -- | This computes the size of the message's fields with tags on the@@ -478,7 +483,7 @@ instance Wire Int where   wireSize {- TYPE_ENUM    -} 14      x = size'Varint x   wireSize ft x = wireSizeErr ft x-  wirePut  {- TYPE_ENUM    -} 14      x = putVarUInt x+  wirePut  {- TYPE_ENUM    -} 14      x = putVarSInt x   wirePut ft x = wirePutErr ft x   wireGet  {- TYPE_ENUM    -} 14        = getVarInt   wireGet ft = wireGetErr ft@@ -487,14 +492,16 @@ {-# INLINE size'Varint #-} size'Varint :: (Bits a,Integral a) => a -> Int64 size'Varint b = case compare b 0 of-                  LT -> fromIntegral (divBy (bitSize b) 7)+                  LT -> 10 -- fromIntegral (divBy (bitSize b) 7)                   EQ -> 1                   GT -> genericLength . takeWhile (0<) . iterate (`shiftR` 7) $ b +{- unused since I started casting all negative values to Int64 {-# INLINE divBy #-} divBy :: (Ord a, Integral a) => a -> a -> a divBy a b = let (q,r) = quotRem (abs a) b             in if r==0 then q else succ q+-}  -- Taken from google's code, but I had to explcitly add fromIntegral in the right places: zzEncode32 :: Int32 -> Word32@@ -539,18 +546,25 @@       else return (val .|. ((fromIntegral b) `shiftL` n))  -- This can be used on any Integral type and is needed for signed types; unsigned can use putVarUInt below.+-- This has been changed to handle only up to 64 bit integral values (to match documentation). {-# INLINE putVarSInt #-}-putVarSInt :: (Integral a, Bits a) => a -> Put-putVarSInt b =-  case compare b 0 of-    LT -> let len = divBy (bitSize b) 7               -- (pred len)*7 < bitSize b <= len*7-              last'Size = (bitSize b)-((pred len)*7)  -- at least 1 and at most 7-              last'Mask = pred (1 `shiftL` last'Size) -- at least 1 and at most 255-              go i 1 = putWord8 (fromIntegral i .&. last'Mask)+putVarSInt :: (Typeable a, Integral a, Bits a) => a -> Put+putVarSInt bIn =+  case compare bIn 0 of+    LT -> let b :: Int64 -- upcast to 64 bit to match documentation of 10 bytes for all negative values+              b = fromIntegral bIn+--               len = divBy (bitSize b) 7               -- (pred len)*7 < bitSize b <= len*7+--               last'Size = (bitSize b)-((pred len)*7)  -- at least 1 and at most 7+--               last'Mask = pred (1 `shiftL` last'Size) -- at least 1 and at most 255+              len :: Int+              len = 10                                -- (pred 10)*7 < 64 <= 10*7+--            last'Size = 1                           -- 64 - (pred 10)*7+              last'Mask = 1                           -- pred (1 `shiftL` 1)+              go i 1 = putWord8 (fromIntegral (i .&. last'Mask))               go i n = putWord8 (fromIntegral (i .&. 0x7F) .|. 0x80) >> go (i `shiftR` 7) (pred n)           in go b len     EQ -> putWord8 0-    GT -> putVarUInt b+    GT -> putVarUInt bIn  -- This should be used on unsigned Integral types only (not checked) {-# INLINE putVarUInt #-}@@ -642,6 +656,6 @@ toWireType 14 =  0 toWireType 15 =  5 toWireType 16 =  1-toWireType 17 =  5-toWireType 18 =  1+toWireType 17 =  0+toWireType 18 =  0 toWireType  x = error $ "Text.ProcolBuffers.Basic.toWireType: Bad FieldType: "++show x
protocol-buffers.cabal view
@@ -1,5 +1,5 @@ name:           protocol-buffers-version:        0.3.1+version:        1.0.0 cabal-version:  >= 1.2 build-type:     Simple license:        BSD3@@ -29,7 +29,6 @@     description: Choose the new smaller, split-up base package.  Library--- fvia-C is needed on OS X powerPC (G4) with WireMessage.hs to prevent a GHC crash   ghc-options:  -Wall -O2   exposed-modules: Text.ProtocolBuffers                    Text.ProtocolBuffers.Basic@@ -41,6 +40,7 @@                    Text.ProtocolBuffers.Reflections                    Text.ProtocolBuffers.Unknown                    Text.ProtocolBuffers.WireMessage+                   Text.ProtocolBuffers.Identifiers    if flag(small_base)         build-depends: base >= 3,@@ -50,7 +50,8 @@                        filepath,                        directory,                        mtl,-                       QuickCheck+                       QuickCheck,+                       syb   else         build-depends: base < 3 @@ -67,4 +68,5 @@                    ScopedTypeVariables,                    TypeSynonymInstances,                    MultiParamTypeClasses,+                   FlexibleContexts,                    FunctionalDependencies