diff --git a/Text/ProtocolBuffers/ProtoCompile.hs b/Text/ProtocolBuffers/ProtoCompile.hs --- a/Text/ProtocolBuffers/ProtoCompile.hs +++ b/Text/ProtocolBuffers/ProtoCompile.hs @@ -19,7 +19,7 @@ import Text.ProtocolBuffers.Basic(defaultValue, Utf8(..), utf8) import Text.ProtocolBuffers.Identifiers(MName,checkDIString,mangle) -import Text.ProtocolBuffers.Reflections(ProtoInfo(..),EnumInfo(..)) +import Text.ProtocolBuffers.Reflections(ProtoInfo(..),EnumInfo(..),OneofInfo(..)) import Text.ProtocolBuffers.WireMessage (messagePut, messageGet) import qualified Text.DescriptorProtos.FileDescriptorProto as D(FileDescriptorProto) @@ -27,11 +27,13 @@ -- import qualified Text.DescriptorProtos.FileDescriptorSet as D(FileDescriptorSet) import qualified Text.DescriptorProtos.FileDescriptorSet as D.FileDescriptorSet(FileDescriptorSet(..)) -import Text.ProtocolBuffers.ProtoCompile.BreakRecursion(makeResult) -import Text.ProtocolBuffers.ProtoCompile.Gen(protoModule,descriptorModules,enumModule) +import Text.ProtocolBuffers.ProtoCompile.BreakRecursion(makeResult,displayResult) +import Text.ProtocolBuffers.ProtoCompile.Gen(protoModule,descriptorModules,enumModule,oneofModule) import Text.ProtocolBuffers.ProtoCompile.MakeReflections(makeProtoInfo,serializeFDP) import Text.ProtocolBuffers.ProtoCompile.Resolve(loadProto,loadCodeGenRequest,makeNameMaps,getTLS - ,Env,LocalFP(..),CanonFP(..),TopLevel(..)) + ,Env,LocalFP(..),CanonFP(..),TopLevel(..) + ,NameMap(..) + ) import Text.Google.Protobuf.Compiler.CodeGeneratorRequest import Text.Google.Protobuf.Compiler.CodeGeneratorResponse hiding (error, file) @@ -41,6 +43,7 @@ -- The Paths_hprotoc module is produced by cabal import Paths_hprotoc(version) + data Options = Options { optPrefix :: [MName String] , optAs :: [(CanonFP,[MName String])] , optTarget :: LocalFP @@ -252,6 +255,7 @@ -- Compute the nameMap that determine how to translate from proto names to haskell names -- This is the part that uses the (optional) package name nameMap <- either error return $ makeNameMaps (optPrefix options) (optAs options) env + let NameMap _ rm = nameMap -- DEBUG print' "Haskell name mangling done" let protoInfo = makeProtoInfo (optUnknownFields options,optLazy options,optLenses options) nameMap fdp result = makeResult protoInfo @@ -265,7 +269,11 @@ produceENM ei = do let file = joinPath . enumFilePath $ ei writeFile' file (prettyPrintStyleMode style myMode (enumModule ei)) + produceONO oi = do + let file = joinPath . oneofFilePath $ oi + writeFile' file (prettyPrintStyleMode style myMode (oneofModule result oi)) mapM_ produceMSG (messages protoInfo) mapM_ produceENM (enums protoInfo) + mapM_ produceONO (oneofs protoInfo) let file = joinPath . protoFilePath $ protoInfo writeFile' file (prettyPrintStyleMode style myMode (protoModule result protoInfo (serializeFDP fdp))) diff --git a/Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs b/Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs --- a/Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs +++ b/Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs @@ -177,7 +177,7 @@ data Result = Result { rKind :: Map MKey VertexKind , rIBoot :: Set (MKey,Part,MKey) , rIKey :: Set (MKey,MKey) } - deriving Eq + deriving (Eq,Show) displayResult :: Result -> String displayResult (Result {rKind = kv, rIBoot = ab, rIKey=ab'keys }) = unlines $ @@ -237,7 +237,7 @@ , "! The failed subset is:" ] ++ showSCCs remainingProblems ++ "\n" in if null remainingProblems then ecart (showG finalGraph) answer - else trace msg answer + else trace msg answer -- Build the graph using the vertices and the Result so far. makeG :: [V] -> Result -> G @@ -247,7 +247,7 @@ -- the snd [V] is from the DescriptorInfo. makeVertices :: ProtoInfo -> (V,[V]) makeVertices pi = answer where - answer = ( protoInfoV , map makeV (messages pi) ) + answer = ( protoInfoV , map makeV (messages pi) ++ map makeVoneof (oneofs pi) ) protoInfoV = V { vMKey = pKey (protoMod pi) , vNeedsKeys = mempty @@ -257,13 +257,22 @@ makeV di = V { vMKey = pKey (descName di) , vNeedsKeys = nk (knownKeys di) , vKeysNeedsTypes = knt (keys di) - , vTypeNeedsTypes = tnt (fields di) } + , vTypeNeedsTypes = Set.union (tnt (fields di)) (ont (descOneofs di)) } + makeVoneof oi = V { vMKey = pKey (oneofName oi) + , vNeedsKeys = mempty + , vKeysNeedsTypes = mempty + , vTypeNeedsTypes = (tnt . fmap snd . oneofFields) oi + } + allK = Set.fromList (pKey (protoMod pi) : map (pKey . descName) (messages pi)) - allT = Set.fromList (map (pKey . descName) (messages pi)) + allT = Set.fromList $ (map (pKey . descName) (messages pi)) ++ (map (pKey . oneofName) (oneofs pi)) tnt :: Seq FieldInfo -> Set MKey tnt fs = Set.intersection allT $ Set.fromList $ map pKey . mapMaybe typeName . F.toList $ fs + + ont :: Seq OneofInfo -> Set MKey + ont os = Set.intersection allT $ Set.fromList $ map (pKey . oneofName) . F.toList $ os knt :: Seq KeyInfo -> Set MKey knt ks = diff --git a/Text/ProtocolBuffers/ProtoCompile/Gen.hs b/Text/ProtocolBuffers/ProtoCompile/Gen.hs --- a/Text/ProtocolBuffers/ProtoCompile/Gen.hs +++ b/Text/ProtocolBuffers/ProtoCompile/Gen.hs @@ -14,11 +14,11 @@ -- The names are also assumed to have become fully-qualified, and all -- the optional type codes have been set. -- -module Text.ProtocolBuffers.ProtoCompile.Gen(protoModule,descriptorModules,enumModule,prettyPrint) where +module Text.ProtocolBuffers.ProtoCompile.Gen(protoModule,descriptorModules,enumModule,oneofModule,prettyPrint) where import Text.ProtocolBuffers.Basic import Text.ProtocolBuffers.Identifiers -import Text.ProtocolBuffers.Reflections(KeyInfo,HsDefault(..),SomeRealFloat(..),DescriptorInfo(..),ProtoInfo(..),EnumInfo(..),ProtoName(..),ProtoFName(..),FieldInfo(..)) +import Text.ProtocolBuffers.Reflections(KeyInfo,HsDefault(..),SomeRealFloat(..),DescriptorInfo(..),ProtoInfo(..),OneofInfo(..),EnumInfo(..),ProtoName(..),ProtoFName(..),FieldInfo(..)) import Text.ProtocolBuffers.ProtoCompile.BreakRecursion(Result(..),VertexKind(..),pKey,pfKey,getKind,Part(..)) @@ -34,12 +34,11 @@ import Data.Char(isLower,isUpper) import qualified Data.Map as M import Data.Maybe(mapMaybe) -import qualified Data.Sequence as Seq(null,length) +import Data.Sequence (ViewL(..),(><)) +import qualified Data.Sequence as Seq(null,length,empty,viewl) import qualified Data.Set as S import System.FilePath(joinPath) ---import Debug.Trace(trace) - ecart :: String -> a -> a ecart _ x = x @@ -61,6 +60,15 @@ noWhere = BDecls [] #endif +#if MIN_VERSION_haskell_src_exts(1, 17, 0) +whereBinds :: Binds -> Maybe Binds +whereBinds = Just +#else +whereBinds :: Binds -> Binds +whereBinds = id +#endif + + ($$) :: Exp -> Exp -> Exp ($$) = App @@ -220,6 +228,32 @@ ,("ans",show ans)]) $ ans + +importO :: Result -> ModuleName -> Part -> OneofInfo -> Maybe [ImportDecl] +importO r selfMod@(ModuleName self) part oi = + let pn = oneofName oi + o = pKey pn + m1 = ModuleName (joinMod (haskellPrefix pn ++ parentModule pn ++ [baseName pn])) + m2 = ModuleName (joinMod (parentModule pn)) + m3 = ModuleName (joinMod (parentModule pn ++ [baseName pn])) + fromSource = S.member (FMName self,part,o) (rIBoot r) +#if MIN_VERSION_haskell_src_exts(1, 17, 0) + iabs1 = IAbs NoNamespace (Ident (mName (baseName pn))) + iabsget = map (IAbs NoNamespace . Ident . fst . oneofGet) . F.toList . oneofFields $ oi +#else + iabs1 = IAbs (Ident (mName (baseName pn))) + iabsget = map (IAbs . Ident . fst . oneofGet) . F.toList . oneofFields $ oi +#endif + ithall = IThingAll (Ident (mName (baseName pn))) + + ans1 = ImportDecl src m1 True fromSource False Nothing (Just m2) + (Just (False,[iabs1])) + ans2 = ImportDecl src m1 True fromSource False Nothing (Just m3) + (Just (False,ithall:iabsget)) + in if m1 == selfMod && part /= KeyFile + then Nothing + else Just [ans1,ans2] + -- Several items might be taken from the same module, combine these statements mergeImports :: [ImportDecl] -> [ImportDecl] mergeImports importsIn = @@ -266,7 +300,32 @@ then UnQual (baseIdent' name) -- name is local, make UnQual else qualFName name -- name is imported, make Qual + -------------------------------------------- +-- utility for OneofInfo +-------------------------------------------- + +oneofCon :: (ProtoName,FieldInfo) -> Exp +oneofCon (name,_) = Con (qualName name) + +oneofPat :: (ProtoName,FieldInfo) -> (Pat,Pat) +oneofPat (name,fi) = + let fName@(Ident fname) = baseIdent' (fieldName fi) + in (PApp (qualName name) [PVar fName],PApp (unqualName name) [PVar fName]) + +oneofRec :: (ProtoName,FieldInfo) -> (Exp,Exp) +oneofRec (_,fi) = + let fName@(Ident fname) = baseIdent' (fieldName fi) + in (litStr fname,lvar fname) + +oneofGet :: (ProtoName,FieldInfo) -> (String,ProtoName) +oneofGet (p,fi) = + let Ident fname = baseIdent' (fieldName fi) + unqual = "get'" ++ fname + p' = p { baseName = MName unqual } + in (unqual,p') + +-------------------------------------------- -- Define LANGUAGE options as [ModulePramga] -------------------------------------------- modulePragmas :: Bool -> [ModulePragma] @@ -278,6 +337,70 @@ | otherwise = [] -------------------------------------------- +-- OneofDescriptorProto module creation +-------------------------------------------- +oneofModule :: Result -> OneofInfo -> Module +oneofModule result oi + = Module src (ModuleName (fqMod protoName)) (modulePragmas False) Nothing + Nothing imports (oneofDecls oi) + where protoName = oneofName oi + typs = mapMaybe typeName . F.toList . fmap snd . oneofFields $ oi + imports = (standardImports False False (oneofMakeLenses oi)) + ++ (mergeImports (mapMaybe (importPN result (ModuleName (fqMod protoName)) Normal) typs)) + + +oneofDecls :: OneofInfo -> [Decl] +oneofDecls oi = (oneofX oi : oneofFuncs oi) ++ + [ instanceDefaultOneof oi + , instanceMergeableOneof oi + ] + +oneofX :: OneofInfo -> Decl +oneofX oi = DataDecl src DataType [] (baseIdent (oneofName oi)) [] + (map oneofValueX (F.toList (oneofFields oi) )) + derives + where oneofValueX (pname,fi) = QualConDecl src [] [] con + where con = RecDecl (baseIdent pname) [fieldX] + fieldX = ([baseIdent' . fieldName $ fi], TyParen (TyCon typed )) + typed = case useType (getFieldType (typeCode fi)) of + Just s -> private s + Nothing -> case typeName fi of + Just s -> qualName s + Nothing -> imp $ "No Name for Field!\n" ++ show fi + +oneofFuncs :: OneofInfo -> [Decl] +oneofFuncs oi = map mkfuns (F.toList (oneofFields oi)) + where mkfuns f = defun (fst (oneofGet f)) [patvar "x"] $ + Case (lvar "x") + [ Alt src (snd (oneofPat f)) + (UnGuardedRhs (preludecon "Just" $$ snd (oneofRec f))) noWhere + , Alt src PWildCard + (UnGuardedRhs (preludecon "Nothing")) noWhere + ] + + + +{- oneof field does not have to have a default value, but for convenience + (to make all messages an instance of Default and Mergeable), we make + the first case as default like enum. -} + +instanceDefaultOneof :: OneofInfo -> Decl +instanceDefaultOneof oi + = InstDecl src Nothing [] [] (private "Default") [TyCon (unqualName (oneofName oi))] + [ inst "defaultValue" [] firstValue ] + where firstValue :: Exp + firstValue = case Seq.viewl (oneofFields oi) of + EmptyL -> imp ("instanceDefaultOneof: empty in " ++ show oi) + (n,_) :< _ -> case (baseIdent n) of + Ident str -> App (lcon str) (pvar "defaultValue") + Symbol _ -> imp ("instanceDefaultOneof: " ++ show n) + +instanceMergeableOneof :: OneofInfo -> Decl +instanceMergeableOneof oi + = InstDecl src Nothing [] [] (private "Mergeable") [TyCon (unqualName (oneofName oi))] [] + + +-------------------------------------------- -- EnumDescriptorProto module creation -------------------------------------------- enumModule :: EnumInfo -> Module @@ -490,7 +613,10 @@ = let protoName = descName di un = unqualName protoName classes = [prelude "Show",prelude "Eq",prelude "Ord",prelude "Typeable",prelude "Data" - ,private "Mergeable",private "Default",private "Wire",private "GPB",private "ReflectDescriptor", private "TextType", private "TextMsg"] + ,private "Mergeable",private "Default" + ,private "Wire",private "GPB",private "ReflectDescriptor" + , private "TextType", private "TextMsg" + ] ++ if hasExt di then [private "ExtendMessage"] else [] ++ if storeUnknown di then [private "UnknownMessage"] else [] instMesAPI = InstDecl src Nothing [] [] (private "MessageAPI") @@ -557,6 +683,7 @@ imports = (standardImports False (hasExt di) (makeLenses di) ++) . mergeImports . concat $ [ mapMaybe (importPN result m Normal) $ extendees' ++ mapMaybe typeName (myKeys' ++ (F.toList (fields di))) + , concat . mapMaybe (importO result m Normal) $ F.toList (descOneofs di) , mapMaybe (importPFN result m) (map fieldName (myKeys ++ F.toList (knownKeys di))) ] mkLenses = Var (Qual (ModuleName "Control.Lens.TH") (Ident "makeLenses")) lenses | makeLenses di = [SpliceDecl src (mkLenses $$ TypQuote (unqualName protoName))] @@ -662,7 +789,10 @@ con = RecDecl name eFields where eFields = F.foldr ((:) . fieldX) end (fields di) end = (if hasExt di then (extfield:) else id) - $ (if storeUnknown di then [unknownField] else []) + . (if storeUnknown di then (unknownField:) else id) + $ eOneof + eOneof = F.foldr ((:) . fieldOneofX) [] (descOneofs di) + bangType = if lazyFields di then TyParen {- UnBangedTy -} else TyBang BangedTy . TyParen -- extfield :: ([Name],BangType) extfield = ([fieldIdent di "ext'field"], bangType (TyCon (private "ExtField"))) @@ -680,6 +810,9 @@ Just s | self /= s -> qualName s | otherwise -> unqualName s Nothing -> error $ "No Name for Field!\n" ++ show fi + fieldOneofX :: OneofInfo -> ([Name],Type) + fieldOneofX oi = ([baseIdent' . oneofFName $ oi], typeApp "Maybe" (TyParen (TyCon typed))) + where typed = qualName (oneofName oi) instancesDescriptor :: DescriptorInfo -> [Decl] instancesDescriptor di = map ($ di) $ @@ -723,32 +856,32 @@ instanceTextMsg :: DescriptorInfo -> Decl instanceTextMsg di = InstDecl src Nothing [] [] (private "TextMsg") [TyCon (unqualName (descName di))] [ - inst "textPut" [patvar msgVar] genPrintFields + inst "textPut" [patvar msgVar] genPrint , InsDecl $ FunBind [Match src (Ident "textGet") [] Nothing (UnGuardedRhs parser) bdecls] ] where #if MIN_VERSION_haskell_src_exts(1, 17, 0) - bdecls = Just (BDecls subparsers) + bdecls = Just (BDecls (subparsers ++ subparsersO)) #else - bdecls = BDecls subparsers + bdecls = BDecls (subparsers ++ subparsersO) #endif flds = F.toList (fields di) + os = F.toList (descOneofs di) msgVar = distinctVar "msg" distinctVar var = if var `elem` reservedVars then distinctVar (var ++ "'") else var reservedVars = map toPrintName flds - toPrintName fi = let IName uname = last $ splitFI $ protobufName' (fieldName fi) in uToString uname - printField fi = let Ident funcname = baseIdent' (fieldName fi) - printname = toPrintName fi - in Qualifier $ pvar "tellT" $$ litStr printname $$ Paren (lvar funcname $$ lvar msgVar) - genPrintFields = if null flds - then preludevar "return" $$ Hse.Tuple Boxed [] - else Do $ map printField flds + genPrintFields = map (Qualifier . printField msgVar) flds + genPrintOneofs = map (Qualifier . printOneof msgVar) os + genPrint = if null flds && null os + then preludevar "return" $$ Hse.Tuple Boxed [] + else Do $ genPrintFields ++ genPrintOneofs + parser - | Seq.null (fields di) = preludevar "return" $$ pvar "defaultValue" + | null flds && null os = preludevar "return" $$ pvar "defaultValue" | otherwise = Do [ Generator src (patvar "mods") $ pvar "sepEndBy" - $$ Paren (pvar "choice" $$ List (map (lvar . parserName) flds)) + $$ Paren (pvar "choice" $$ List (map (lvar . parserName) flds ++ map (lvar . parserNameO) os)) $$ pvar "spaces", Qualifier $ (preludevar "return") $$ Paren (preludevar "foldl" @@ -757,6 +890,7 @@ $$ lvar "mods") ] parserName f = let Ident fname = baseIdent' (fieldName f) in "parse'" ++ fname + parserNameO o = let Ident oname = baseIdent' (oneofFName o) in "parse'" ++ oname subparsers = map (\f -> defun (parserName f) [] (getField f)) flds getField fi = let printname = toPrintName fi Ident funcname = baseIdent' (fieldName fi) @@ -767,7 +901,53 @@ $$ Paren (Lambda src [patvar "o"] (RecUpdate (lvar "o") [ FieldUpdate (local funcname) update])) ] + + subparsersO = map funbind os + funbind o = FunBind [Match src (Ident (parserNameO o)) [] Nothing (UnGuardedRhs (getOneof)) whereParse] + where getOneof = pvar "try" $$ + (pvar "choice" $$ List (map (Var . UnQual . Ident) parsefs)) + oflds = F.toList (oneofFields o) + flds = map snd oflds + parsefs = map parserName flds + whereParse = whereBinds $ BDecls (map decl oflds) + where decl (n,f) = defun (parserName f) [] (getOneofField (n,f)) + getOneofField p@(n,f) = + let Ident oname = baseIdent' (oneofFName o) + printname = toPrintName f + update = preludecon "Just" $$ Paren (oneofCon p $$ lvar "v") + in pvar "try" $$ Do [ + Generator src (patvar "v") $ pvar "getT" $$ litStr printname, + Qualifier $ (preludevar "return") + $$ Paren (Lambda src [patvar "s"] + (RecUpdate (lvar "s") [ FieldUpdate (local oname) update])) + ] + +printField :: String -> FieldInfo -> Exp +printField msgVar fi + = let Ident funcname = baseIdent' (fieldName fi) + printname = toPrintName fi + in pvar "tellT" $$ litStr printname $$ Paren (lvar funcname $$ lvar msgVar) + +toPrintName :: FieldInfo -> String +toPrintName fi = let IName uname = last $ splitFI $ protobufName' (fieldName fi) in uToString uname + +printOneof :: String -> OneofInfo -> Exp +printOneof msgVar oi + = Case (Paren (lvar funcname $$ lvar msgVar)) (map caseAlt flds ++ [caseAltNothing]) + where Ident funcname = baseIdent' (oneofFName oi) + IName uname = last $ splitFI $ protobufName' (oneofFName oi) + printname = uToString uname + flds = F.toList (oneofFields oi) + caseAlt :: (ProtoName,FieldInfo) -> Alt + caseAlt f = Alt src patt (UnGuardedRhs rhs) noWhere + where patt = PApp (prelude "Just") [fst (oneofPat f)] + (rstr,rvar) = oneofRec f + rhs = pvar "tellT" $$ rstr $$ rvar -- litStr fname $$ (lvar fname) + caseAltNothing :: Alt + caseAltNothing = Alt src (PApp (prelude "Nothing") []) (UnGuardedRhs rhs) noWhere + where rhs = preludevar "return" $$ unit_con + instanceMergeable :: DescriptorInfo -> Decl instanceMergeable di = InstDecl src Nothing [] [] (private "Mergeable") [TyCon un] @@ -778,7 +958,7 @@ where un = unqualName (descName di) len = (if hasExt di then succ else id) $ (if storeUnknown di then succ else id) - $ Seq.length (fields di) + $ Seq.length (fields di) + Seq.length (descOneofs di) patternVars1,patternVars2 :: [Pat] patternVars1 = take len inf where inf = map (\ n -> patvar ("x'" ++ show n)) [(1::Int)..] @@ -798,7 +978,8 @@ where un = unqualName (descName di) deflistExt = F.foldr ((:) . defX) end (fields di) end = (if hasExt di then (pvar "defaultValue":) else id) - $ (if storeUnknown di then [pvar "defaultValue"] else []) + . (if storeUnknown di then (pvar "defaultValue":) else id) + $ F.foldr ((:) . defOneof) [] (descOneofs di) defX :: FieldInfo -> Exp defX fi | isRequired fi = dv1 @@ -809,7 +990,10 @@ dv2 = case hsDefault fi of Nothing -> pvar "defaultValue" Just hsdef -> Paren $ preludecon "Just" $$ defToSyntax (typeCode fi) hsdef + defOneof :: OneofInfo -> Exp + defOneof oi= pvar "defaultValue" + instanceMessageAPI :: ProtoName -> Decl instanceMessageAPI protoName = InstDecl src Nothing [] [] (private "MessageAPI") @@ -820,13 +1004,14 @@ instanceWireDescriptor :: DescriptorInfo -> Decl instanceWireDescriptor di@(DescriptorInfo { descName = protoName , fields = fieldInfos + , descOneofs = oneofInfos , extRanges = allowedExts , knownKeys = fieldExts }) = let me = unqualName protoName extensible = not (null allowedExts) len = (if extensible then succ else id) $ (if storeUnknown di then succ else id) - $ Seq.length fieldInfos + $ Seq.length fieldInfos + Seq.length oneofInfos mine = PApp me . take len . map (\ n -> patvar ("x'" ++ show n)) $ [(1::Int)..] vars = take len . map (\ n -> lvar ("x'" ++ show n)) $ [(1::Int)..] mExt | extensible = Just (vars !! Seq.length fieldInfos) @@ -857,15 +1042,25 @@ | otherwise = sizesListExt sizesListExt | Just v <- mExt = sizesListFields ++ [ pvar "wireSizeExtField" $$ v ] | otherwise = sizesListFields - sizesListFields = zipWith toSize vars . F.toList $ fieldInfos - toSize var fi = let f = if isPacked fi then "wireSizePacked" - else if isRequired fi then "wireSizeReq" - else if canRepeat fi then "wireSizeRep" - else "wireSizeOpt" - in foldl' App (pvar f) [ litInt (wireTagLength fi) - , litInt (getFieldType (typeCode fi)) - , var] + sizesListFields = concat . zipWith toSize vars . F.toList $ + fmap Left fieldInfos >< fmap Right oneofInfos + toSize var (Left fi) + = let f = if isPacked fi then "wireSizePacked" + else if isRequired fi then "wireSizeReq" + else if canRepeat fi then "wireSizeRep" + else "wireSizeOpt" + in [foldl' App (pvar f) [ litInt (wireTagLength fi) + , litInt (getFieldType (typeCode fi)) + , var]] + toSize var (Right oi) = map (toSize' var) . F.toList . oneofFields $ oi + where toSize' var r@(n,fi) + = let f = "wireSizeOpt" + var' = mkOp "Prelude'.=<<" (Var (qualName (snd (oneofGet r)))) var + in foldl' App (pvar f) [ litInt (wireTagLength fi) + , litInt (getFieldType (typeCode fi)) + , var'] + -- wirePut generation putCases = UnGuardedRhs $ cases (lvar "put'Fields") @@ -887,17 +1082,31 @@ | otherwise = sortedPutStmtsList sortedPutStmtsList = map snd -- remove number . sortBy (compare `on` fst) -- sort by number - . zip (map fieldNumber . F.toList $ fieldInfos) -- add number as fst $ putStmtsList - putStmtsList = zipWith toPut vars . F.toList $ fieldInfos - toPut var fi = let f = if isPacked fi then "wirePutPacked" - else if isRequired fi then "wirePutReq" - else if canRepeat fi then "wirePutRep" - else "wirePutOpt" - in Qualifier $ + putStmtsList = concat . zipWith toPut vars . F.toList $ + fmap Left fieldInfos >< fmap Right oneofInfos + toPut var (Left fi) + = let f = if isPacked fi then "wirePutPacked" + else if isRequired fi then "wirePutReq" + else if canRepeat fi then "wirePutRep" + else "wirePutOpt" + in [(fieldNumber fi, + Qualifier $ + foldl' App (pvar f) [ litInt (getWireTag (wireTag fi)) + , litInt (getFieldType (typeCode fi)) + , var] + )] + toPut var (Right oi) = map (toPut' var) . F.toList . oneofFields $ oi + where toPut' var r@(n,fi) + = let f = "wirePutOpt" + var' = mkOp "Prelude'.=<<" (Var (qualName (snd (oneofGet r)))) var + in (fieldNumber fi + ,Qualifier $ foldl' App (pvar f) [ litInt (getWireTag (wireTag fi)) - , litInt (getFieldType (typeCode fi)) - , var] + , litInt (getFieldType (typeCode fi)) + , var'] + ) + -- wireGet generation -- new for 1.5.7, rewriting this a great deal! getCases = let param = if storeUnknown di @@ -915,6 +1124,10 @@ (Case (lvar "wire'Tag") updateAlts) -- update cases are all normal fields then all known extensions then wildcard updateAlts = concatMap toUpdate (F.toList fieldInfos) + ++ (do -- in list monad + o <- F.toList oneofInfos + f <- F.toList (oneofFields o) + toUpdateO o f) ++ (if extensible then concatMap toUpdateExt (F.toList fieldExts) else []) ++ [Alt src PWildCard (UnGuardedRhs wildcardAlt) noWhere] -- the wildcard alternative handles new extensions and @@ -960,6 +1173,9 @@ -- wireGet without extensions toUpdate fi | Just (wt1,wt2) <- packedTag fi = [toUpdateUnpacked wt1 fi, toUpdatePacked wt2 fi] | otherwise = [toUpdateUnpacked (wireTag fi) fi] + + + toUpdateUnpacked wt1 fi = Alt src (litIntP . getWireTag $ wt1) (UnGuardedRhs $ preludevar "fmap" $$ (Paren $ Lambda src [PBangPat (patvar "new'Field")] $ @@ -992,6 +1208,42 @@ -- knowledge that only TYPE_MESSAGE and TYPE_GROUP have merges -- that are not right-biased replacements. The "mergeAppend" uses -- knowledge of how all repeated fields get merged. + + + -- for fields in OneofInfo + toUpdateO oi f@(_n,fi) + | Just (wt1,wt2) <- packedTag fi = [toUpdateUnpackedO oi wt1 f, toUpdatePackedO oi wt2 f] + | otherwise = [toUpdateUnpackedO oi (wireTag fi) f] + + toUpdateUnpackedO oi wt1 f@(_,fi) = + Alt src (litIntP . getWireTag $ wt1) (UnGuardedRhs $ + preludevar "fmap" $$ (Paren $ Lambda src [PBangPat (patvar "new'Field")] $ + RecUpdate (lvar "old'Self") + [FieldUpdate (unqualFName . oneofFName $ oi) + (labelUpdateUnpackedO oi f)]) + $$ (Paren (pvar "wireGet" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere + labelUpdateUnpackedO oi f@(_,fi) = qMerge (preludecon "Just" $$ + (oneofCon f $$ lvar "new'Field") + ) + where qMerge x | fromIntegral (getFieldType (typeCode fi)) `elem` [10,(11::Int)] = + pvar "mergeAppend" $$ Paren ( (Var . unqualFName . oneofFName $ oi) + $$ lvar "old'Self" ) + $$ Paren x + | otherwise = x + toUpdatePackedO oi wt2 f@(_,fi) = + Alt src (litIntP . getWireTag $ wt2) (UnGuardedRhs $ + preludevar "fmap" $$ (Paren $ Lambda src [PBangPat (patvar "new'Field")] $ + RecUpdate (lvar "old'Self") + [FieldUpdate (unqualFName . oneofFName $ oi) + (labelUpdatePackedO oi f)]) + $$ (Paren (pvar "wireGetPacked" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere + labelUpdatePackedO oi f@(_,fi) = pvar "mergeAppend" $$ Paren ((Var . unqualFName . oneofFName $ oi) + $$ lvar "old'Self") + $$ Paren (preludecon "Just" $$ + (oneofCon f $$ lvar "new'Field")) + + + in InstDecl src Nothing [] [] (private "Wire") [TyCon me] . map InsDecl $ [ FunBind [Match src (Ident "wireSize") [patvar "ft'",PAsPat (Ident "self'") (PParen mine)] Nothing sizeCases whereCalcSize] diff --git a/Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs b/Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs --- a/Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs +++ b/Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs @@ -35,6 +35,8 @@ import qualified Text.DescriptorProtos.FieldOptions as D.FieldOptions(FieldOptions(..)) import qualified Text.DescriptorProtos.FileDescriptorProto as D(FileDescriptorProto(FileDescriptorProto)) import qualified Text.DescriptorProtos.FileDescriptorProto as D.FileDescriptorProto(FileDescriptorProto(..)) +import qualified Text.DescriptorProtos.OneofDescriptorProto as D(OneofDescriptorProto) +import qualified Text.DescriptorProtos.OneofDescriptorProto as D.OneofDescriptorProto(OneofDescriptorProto(..)) import Text.ProtocolBuffers.Basic import Text.ProtocolBuffers.Identifiers @@ -42,8 +44,11 @@ import Text.ProtocolBuffers.WireMessage(size'WireTag,toWireTag,toPackedWireTag,runPut,Wire(..)) import Text.ProtocolBuffers.ProtoCompile.Resolve(ReMap,NameMap(..),getPackageID) +-- import Text.ProtocolBuffers.Reflections + import qualified Data.Foldable as F(foldr,toList) -import qualified Data.Sequence as Seq(fromList,empty,singleton,null) +import Data.Sequence ((<|)) +import qualified Data.Sequence as Seq(fromList,empty,singleton,null,filter) import Numeric(readHex,readOct,readDec) import Data.Monoid(mconcat,mappend) import qualified Data.Map as M(fromListWith,lookup,keys) @@ -72,7 +77,7 @@ -> ProtoInfo makeProtoInfo (unknownField,lazyFieldsOpt,lenses) (NameMap (packageID,hPrefix,hParent) reMap) fdp@(D.FileDescriptorProto { D.FileDescriptorProto.name = Just rawName }) - = ProtoInfo protoName (pnPath protoName) (toString rawName) keyInfos allMessages allEnums allKeys where + = ProtoInfo protoName (pnPath protoName) (toString rawName) keyInfos allMessages allEnums allOneofs allKeys where packageName = getPackageID packageID :: FIName (Utf8) protoName = case hParent of [] -> case hPrefix of @@ -84,6 +89,7 @@ allMessages = concatMap (processMSG packageName False) (F.toList $ D.FileDescriptorProto.message_type fdp) allEnums = map (makeEnumInfo' reMap packageName) (F.toList $ D.FileDescriptorProto.enum_type fdp) ++ concatMap (processENM packageName) (F.toList $ D.FileDescriptorProto.message_type fdp) + allOneofs = concatMap (processONO packageName) (F.toList $ D.FileDescriptorProto.message_type fdp) allKeys = M.fromListWith mappend . map (\(k,a) -> (k,Seq.singleton a)) . F.toList . mconcat $ keyInfos : map keys allMessages processMSG parent msgIsGroup msg = @@ -100,6 +106,10 @@ (F.toList (D.DescriptorProto.enum_type msg)) where parent' = fqAppend parent [IName (fromJust (D.DescriptorProto.name msg))] nested = concatMap (processENM parent') (F.toList (D.DescriptorProto.nested_type msg)) + processONO parent msg = foldr ((:) . makeOneofInfo' reMap parent' lenses msg) nested + (zip [0..] (F.toList (D.DescriptorProto.oneof_decl msg))) + where parent' = fqAppend parent [IName (fromJust (D.DescriptorProto.name msg))] + nested = concatMap (processONO parent') (F.toList (D.DescriptorProto.nested_type msg)) makeProtoInfo _ _ _ = imp $ "makeProtoInfo: missing name or package" makeEnumInfo' :: ReMap -> FIName Utf8 -> D.EnumDescriptorProto -> EnumInfo @@ -120,6 +130,26 @@ oneValue evdp = imp $ "no name or number for evdp passed to makeEnumInfo.oneValue: "++show evdp makeEnumInfo' _ _ _ = imp "makeEnumInfo: missing name" +makeOneofInfo' :: ReMap -> FIName Utf8 + -> Bool -- ^ makeLenses + -> D.DescriptorProto -> (Int32,D.OneofDescriptorProto) -> OneofInfo +makeOneofInfo' reMap parent lenses parentProto + (n, e@(D.OneofDescriptorProto.OneofDescriptorProto + { D.OneofDescriptorProto.name = Just rawName })) + = OneofInfo protoName protoFName (pnPath protoName) fieldInfos lenses + where protoName@(ProtoName x a b c) = toHaskell reMap $ fqAppend parent [IName rawName] + protoFName = ProtoFName x a b (mangle c) (if lenses then "_" else "") + rawFields = D.DescriptorProto.field parentProto + rawFieldsOneof = Seq.filter ((== Just n) . D.FieldDescriptorProto.oneof_index) rawFields + getFieldProtoName fdp + = case D.FieldDescriptorProto.name fdp of + Just name -> toHaskell reMap $ fqAppend (protobufName protoName) [IName name] + Nothing -> imp $ "getFieldProtoName: missing info in " ++ show fdp + getFieldInfo = toFieldInfo' reMap (protobufName protoName) lenses + fieldInfos = fmap (\x->(getFieldProtoName x,getFieldInfo x)) rawFieldsOneof +makeOneofInfo' _ _ _ _ _ = imp "makeOneofInfo: missing name" + + keyExtendee' :: ReMap -> D.FieldDescriptorProto.FieldDescriptorProto -> ProtoName keyExtendee' reMap f = case D.FieldDescriptorProto.extendee f of Nothing -> imp $ "keyExtendee expected Just but found Nothing: "++show f @@ -135,17 +165,23 @@ -> (Bool,Bool,Bool) -- unknownField, lazyFields and lenses -> D.DescriptorProto -> DescriptorInfo makeDescriptorInfo' reMap parent getKnownKeys msgIsGroup (unknownField,lazyFieldsOpt,lenses) - (D.DescriptorProto.DescriptorProto + msg@(D.DescriptorProto.DescriptorProto { D.DescriptorProto.name = Just rawName , D.DescriptorProto.field = rawFields + , D.DescriptorProto.oneof_decl = rawOneofs , D.DescriptorProto.extension = rawKeys , D.DescriptorProto.extension_range = extension_range }) - = let di = DescriptorInfo protoName (pnPath protoName) msgIsGroup - fieldInfos keyInfos extRangeList (getKnownKeys protoName) + = let di = DescriptorInfo protoName (pnPath protoName) msgIsGroup + fieldInfos oneofInfos keyInfos extRangeList + (getKnownKeys protoName) unknownField lazyFieldsOpt lenses in di -- trace (toString rawName ++ "\n" ++ show di ++ "\n\n") $ di where protoName = toHaskell reMap $ fqAppend parent [IName rawName] - fieldInfos = fmap (toFieldInfo' reMap (protobufName protoName) lenses) rawFields + rawFieldsNotOneof = Seq.filter (\x -> D.FieldDescriptorProto.oneof_index x == Nothing) rawFields + fieldInfos = fmap (toFieldInfo' reMap (protobufName protoName) lenses) rawFieldsNotOneof + oneofInfos = F.foldr ((<|) . makeOneofInfo' reMap (protobufName protoName) lenses msg) Seq.empty + (zip [0..] (F.toList rawOneofs)) + keyInfos = fmap (\f -> (keyExtendee' reMap f,toFieldInfo' reMap (protobufName protoName) lenses f)) rawKeys extRangeList = concatMap check unchecked where check x@(lo,hi) | hi < lo = [] diff --git a/Text/ProtocolBuffers/ProtoCompile/Parser.hs b/Text/ProtocolBuffers/ProtoCompile/Parser.hs --- a/Text/ProtocolBuffers/ProtoCompile/Parser.hs +++ b/Text/ProtocolBuffers/ProtoCompile/Parser.hs @@ -38,6 +38,8 @@ import qualified Text.DescriptorProtos.MethodDescriptorProto as D.MethodDescriptorProto(MethodDescriptorProto(..)) -- import qualified Text.DescriptorProtos.MethodOptions as D(MethodOptions) import qualified Text.DescriptorProtos.MethodOptions as D.MethodOptions(MethodOptions(..)) +import qualified Text.DescriptorProtos.OneofDescriptorProto as D(OneofDescriptorProto) +import qualified Text.DescriptorProtos.OneofDescriptorProto as D.OneofDescriptorProto(OneofDescriptorProto(..)) import qualified Text.DescriptorProtos.ServiceDescriptorProto as D(ServiceDescriptorProto) import qualified Text.DescriptorProtos.ServiceDescriptorProto as D.ServiceDescriptorProto(ServiceDescriptorProto(..)) -- import qualified Text.DescriptorProtos.ServiceOptions as D(ServiceOptions) @@ -62,8 +64,8 @@ import Data.Ix(inRange) import Data.Maybe(fromMaybe) import Data.Monoid(mconcat) -import Data.Sequence((|>)) -import qualified Data.Sequence as Seq(fromList) +import Data.Sequence((|>),(><)) +import qualified Data.Sequence as Seq(fromList,length,empty) import Data.Word(Word8) import Numeric(showOct) --import System.FilePath(takeFileName) @@ -250,7 +252,9 @@ , message upTopMsg , enum upTopEnum , extend upTopMsg upTopExt - , service] >> proto) + , service + , syntax + ] >> proto) upTopMsg msg = update' (\s -> s {D.FileDescriptorProto.message_type=D.FileDescriptorProto.message_type s |> msg}) upTopEnum e = update' (\s -> s {D.FileDescriptorProto.enum_type=D.FileDescriptorProto.enum_type s |> e}) upTopExt f = update' (\s -> s {D.FileDescriptorProto.extension=D.FileDescriptorProto.extension s |> f}) @@ -318,12 +322,48 @@ "java_outer_classname" -> strLit >>= \p -> return' (old {D.FileOptions.java_outer_classname=Just p}) "java_multiple_files" -> boolLit >>= \p -> return' (old {D.FileOptions.java_multiple_files =Just p}) "java_generate_equals_and_hash" -> boolLit >>= \p -> return' (old {D.FileOptions.java_generate_equals_and_hash =Just p}) + "java_string_check_utf8"-> boolLit >>= \p -> return' (old {D.FileOptions.java_string_check_utf8 = Just p}) "optimize_for" -> enumLit >>= \p -> return' (old {D.FileOptions.optimize_for =Just p}) + "go_package" -> strLit >>= \p -> return' (old {D.FileOptions.go_package =Just p}) "cc_generic_services" -> boolLit >>= \p -> return' (old {D.FileOptions.cc_generic_services =Just p}) "java_generic_services" -> boolLit >>= \p -> return' (old {D.FileOptions.java_generic_services =Just p}) "py_generic_services" -> boolLit >>= \p -> return' (old {D.FileOptions.py_generic_services =Just p}) + "deprecated" -> boolLit >>= \p -> return' (old {D.FileOptions.deprecated =Just p}) + "cc_enable_arenas" -> boolLit >>= \p -> return' (old {D.FileOptions.cc_enable_arenas =Just p}) + "objc_class_prefix" -> strLit >>= \p -> return' (old {D.FileOptions.objc_class_prefix =Just p}) + "csharp_namespace" -> strLit >>= \p -> return' (old {D.FileOptions.csharp_namespace =Just p}) + "javanano_use_deprecated_package" -> boolLit >>= \p -> return' (old {D.FileOptions.javanano_use_deprecated_package =Just p}) _ -> unexpected $ "FileOptions has no option named " ++ optName +oneof :: (D.OneofDescriptorProto -> Seq D.FieldDescriptorProto -> P s ()) -> P s () +oneof up = pName (U.fromString "oneof") >> do + self <- ident1 + (o,fs) <- subParser (pChar '{' >> subOneof) (defaultValue {D.OneofDescriptorProto.name=Just self}, Seq.empty) + up o fs + +subOneof :: P (D.OneofDescriptorProto,Seq D.FieldDescriptorProto) () +subOneof = pChar '}' <|> (choice [ eof + , fieldOneof >>= upMsgField] >> subOneof) + where upMsgField f = update' (\(o,fs) -> (o,fs |> f)) + + +fieldOneof :: P s D.FieldDescriptorProto +fieldOneof = do + sType <- ident + -- parseType may return Nothing, this is fixed up in Text.ProtocolBuffers.ProtoCompile.Resolve.fqField + let (maybeTypeCode,maybeTypeName) = case parseType (uToString sType) of + Just t -> (Just t,Nothing) + Nothing -> (Nothing, Just sType) + name <- ident1 + number <- pChar '=' >> fieldInt + let v1 = defaultValue { D.FieldDescriptorProto.name = Just name + , D.FieldDescriptorProto.number = Just number + , D.FieldDescriptorProto.label = Just LABEL_OPTIONAL + , D.FieldDescriptorProto.type' = maybeTypeCode + , D.FieldDescriptorProto.type_name = maybeTypeName + } + eol >> return v1 + message :: (D.DescriptorProto -> P s ()) -> P s () message up = pName (U.fromString "message") >> do self <- ident1 @@ -335,12 +375,21 @@ , field upNestedMsg Nothing >>= upMsgField , message upNestedMsg , enum upNestedEnum + , oneof upMsgOneof , extensions , extend upNestedMsg upExtField - , messageOption] >> subMessage) + , messageOption] >> subMessage + ) where upNestedMsg msg = update' (\s -> s {D.DescriptorProto.nested_type=D.DescriptorProto.nested_type s |> msg}) upNestedEnum e = update' (\s -> s {D.DescriptorProto.enum_type=D.DescriptorProto.enum_type s |> e}) upMsgField f = update' (\s -> s {D.DescriptorProto.field=D.DescriptorProto.field s |> f}) + upMsgOneof o xs = update' $ \s -> + let n = Seq.length (D.DescriptorProto.oneof_decl s) + xs' = fmap (\s -> s { D.FieldDescriptorProto.oneof_index = Just (fromIntegral n) }) xs + in s {D.DescriptorProto.oneof_decl=D.DescriptorProto.oneof_decl s |> o + ,D.DescriptorProto.field=D.DescriptorProto.field s >< xs' + } + upExtField f = update' (\s -> s {D.DescriptorProto.extension=D.DescriptorProto.extension s |> f}) messageOption = pOptionWith getOld >>= setOption >>= setNew >> eol where @@ -365,7 +414,7 @@ field upGroup maybeExtendee = do let allowedLabels = case maybeExtendee of Nothing -> ["optional","repeated","required"] - Just {} -> ["optional","repeated"] -- cannot declare a required extension + Just {} -> ["optional","repeated"] -- cannot declare a required extension and an oneof extension. sLabel <- choice . map (pName . U.fromString) $ allowedLabels theLabel <- maybe (fail ("not a valid Label :"++show sLabel)) return (parseLabel (uToString sLabel)) sType <- ident @@ -464,9 +513,9 @@ "ctype" | (Just TYPE_STRING) == mt -> do enumLit >>= \p -> return' (old {D.FieldOptions.ctype=Just p}) | otherwise -> unexpected $ "field option cyte is only defined for string fields" - "experimental_map_key" | Nothing == mt -> do - strLit >>= \p -> return' (old {D.FieldOptions.experimental_map_key=Just p}) - | otherwise -> unexpected $ "field option experimental_map_key is only defined for messages" + -- "experimental_map_key" | Nothing == mt -> do + -- strLit >>= \p -> return' (old {D.FieldOptions.experimental_map_key=Just p}) + -- | otherwise -> unexpected $ "field option experimental_map_key is only defined for messages" "packed" | isValidPacked label mt -> do boolLit >>= \p -> return' (old {D.FieldOptions.packed=Just p}) | otherwise -> unexpected $ "field option packed is not defined for this kind of field" @@ -539,6 +588,11 @@ update' (\s -> s {D.FileDescriptorProto.service=D.FileDescriptorProto.service s |> f}) where subService = pChar '}' <|> (choice [ eol, rpc, serviceOption ] >> subService) + +syntax = pName (U.fromString "syntax") >> do + pChar '=' + p <- strLit + update' (\s -> s {D.FileDescriptorProto.syntax=Just p}) serviceOption,rpc :: P D.ServiceDescriptorProto () serviceOption = pOptionWith getOld >>= setOption >>= setNew >> eol where diff --git a/Text/ProtocolBuffers/ProtoCompile/Resolve.hs b/Text/ProtocolBuffers/ProtoCompile/Resolve.hs --- a/Text/ProtocolBuffers/ProtoCompile/Resolve.hs +++ b/Text/ProtocolBuffers/ProtoCompile/Resolve.hs @@ -115,6 +115,8 @@ import qualified Text.DescriptorProtos.FileDescriptorProto as D.FileDescriptorProto(FileDescriptorProto(..)) import qualified Text.DescriptorProtos.MethodDescriptorProto as D(MethodDescriptorProto) import qualified Text.DescriptorProtos.MethodDescriptorProto as D.MethodDescriptorProto(MethodDescriptorProto(..)) +import qualified Text.DescriptorProtos.OneofDescriptorProto as D(OneofDescriptorProto) +import qualified Text.DescriptorProtos.OneofDescriptorProto as D.OneofDescriptorProto(OneofDescriptorProto(..)) import qualified Text.DescriptorProtos.ServiceDescriptorProto as D(ServiceDescriptorProto) import qualified Text.DescriptorProtos.ServiceDescriptorProto as D.ServiceDescriptorProto(ServiceDescriptorProto(..)) import qualified Text.DescriptorProtos.UninterpretedOption as D(UninterpretedOption) @@ -156,7 +158,7 @@ import Data.Ix(inRange) import Data.List(foldl',stripPrefix,isPrefixOf,isSuffixOf) import Data.Map(Map) -import Data.Maybe(mapMaybe) +import Data.Maybe(mapMaybe,isNothing) import Data.Typeable -- import Data.Monoid() import System.Directory(doesFileExist,canonicalizePath) @@ -631,6 +633,16 @@ runMRM'Reader (mrmFile fdp) template return (packageName,hPrefix,hParent) -- Traversal of the named DescriptorProto types + fieldNotOneof :: D.DescriptorProto -> Seq D.FieldDescriptorProto + fieldNotOneof = Seq.filter (isNothing . D.FieldDescriptorProto.oneof_index) . D.DescriptorProto.field + + oneofFieldMap :: D.DescriptorProto -> [(D.OneofDescriptorProto,Seq D.FieldDescriptorProto)] + oneofFieldMap dp = zip odps fdpss + where odps = F.toList (D.DescriptorProto.oneof_decl dp) + fdps = D.DescriptorProto.field dp + fdpss = map (\i->Seq.filter ((== Just i) . D.FieldDescriptorProto.oneof_index) fdps) [0..] + + mrmFile :: D.FileDescriptorProto -> MRM () mrmFile fdp = do F.mapM_ mrmMsg (D.FileDescriptorProto.message_type fdp) @@ -642,9 +654,14 @@ local (const template) $ do F.mapM_ mrmEnum (D.DescriptorProto.enum_type dp) F.mapM_ mrmField (D.DescriptorProto.extension dp) - F.mapM_ mrmField (D.DescriptorProto.field dp) + F.mapM_ mrmField (fieldNotOneof dp) + F.mapM_ mrmOneof (oneofFieldMap dp) F.mapM_ mrmMsg (D.DescriptorProto.nested_type dp) mrmField fdp = mrmName "mrmField.name" D.FieldDescriptorProto.name fdp + mrmOneof (odp,fdps) = do + template <- mrmName "mrmOneof.name" D.OneofDescriptorProto.name odp + local (const template) $ + F.mapM_ mrmField fdps mrmEnum edp = do template <- mrmName "mrmEnum.name" D.EnumDescriptorProto.name edp local (const template) $ F.mapM_ mrmEnumValue (D.EnumDescriptorProto.value edp) diff --git a/hprotoc.cabal b/hprotoc.cabal --- a/hprotoc.cabal +++ b/hprotoc.cabal @@ -1,5 +1,5 @@ name: hprotoc -version: 2.1.12 +version: 2.2.0 cabal-version: >= 1.6 build-type: Simple license: BSD3 @@ -20,8 +20,8 @@ location: git://github.com/k-bx/protocol-buffers.git Executable hprotoc - build-depends: protocol-buffers == 2.1.12, - protocol-buffers-descriptor == 2.1.12 + build-depends: protocol-buffers == 2.2.0, + protocol-buffers-descriptor == 2.2.0 Main-Is: Text/ProtocolBuffers/ProtoCompile.hs Hs-Source-Dirs: ., protoc-gen-haskell @@ -69,8 +69,8 @@ TypeSynonymInstances Library - build-depends: protocol-buffers == 2.1.12, - protocol-buffers-descriptor == 2.1.12 + build-depends: protocol-buffers == 2.2.0, + protocol-buffers-descriptor == 2.2.0 Hs-Source-Dirs: ., protoc-gen-haskell build-tools: alex