diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -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 diff --git a/Text/ProtocolBuffers.hs b/Text/ProtocolBuffers.hs --- a/Text/ProtocolBuffers.hs +++ b/Text/ProtocolBuffers.hs @@ -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 diff --git a/Text/ProtocolBuffers/Basic.hs b/Text/ProtocolBuffers/Basic.hs --- a/Text/ProtocolBuffers/Basic.hs +++ b/Text/ProtocolBuffers/Basic.hs @@ -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 diff --git a/Text/ProtocolBuffers/Extensions.hs b/Text/ProtocolBuffers/Extensions.hs --- a/Text/ProtocolBuffers/Extensions.hs +++ b/Text/ProtocolBuffers/Extensions.hs @@ -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 diff --git a/Text/ProtocolBuffers/Header.hs b/Text/ProtocolBuffers/Header.hs --- a/Text/ProtocolBuffers/Header.hs +++ b/Text/ProtocolBuffers/Header.hs @@ -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 diff --git a/Text/ProtocolBuffers/Identifiers.hs b/Text/ProtocolBuffers/Identifiers.hs new file mode 100644 --- /dev/null +++ b/Text/ProtocolBuffers/Identifiers.hs @@ -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" + ] diff --git a/Text/ProtocolBuffers/Reflections.hs b/Text/ProtocolBuffers/Reflections.hs --- a/Text/ProtocolBuffers/Reflections.hs +++ b/Text/ProtocolBuffers/Reflections.hs @@ -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 diff --git a/Text/ProtocolBuffers/Unknown.hs b/Text/ProtocolBuffers/Unknown.hs --- a/Text/ProtocolBuffers/Unknown.hs +++ b/Text/ProtocolBuffers/Unknown.hs @@ -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 diff --git a/Text/ProtocolBuffers/WireMessage.hs b/Text/ProtocolBuffers/WireMessage.hs --- a/Text/ProtocolBuffers/WireMessage.hs +++ b/Text/ProtocolBuffers/WireMessage.hs @@ -6,8 +6,11 @@ . 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 diff --git a/protocol-buffers.cabal b/protocol-buffers.cabal --- a/protocol-buffers.cabal +++ b/protocol-buffers.cabal @@ -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