hprotoc 2.1.12 → 2.2.0
raw patch · 7 files changed
+445/−69 lines, 7 filesdep ~protocol-buffersdep ~protocol-buffers-descriptor
Dependency ranges changed: protocol-buffers, protocol-buffers-descriptor
Files
- Text/ProtocolBuffers/ProtoCompile.hs +12/−4
- Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs +14/−5
- Text/ProtocolBuffers/ProtoCompile/Gen.hs +291/−39
- Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs +42/−6
- Text/ProtocolBuffers/ProtoCompile/Parser.hs +62/−8
- Text/ProtocolBuffers/ProtoCompile/Resolve.hs +19/−2
- hprotoc.cabal +5/−5
Text/ProtocolBuffers/ProtoCompile.hs view
@@ -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)))
Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs view
@@ -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 =
Text/ProtocolBuffers/ProtoCompile/Gen.hs view
@@ -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]
Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs view
@@ -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 = []
Text/ProtocolBuffers/ProtoCompile/Parser.hs view
@@ -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
Text/ProtocolBuffers/ProtoCompile/Resolve.hs view
@@ -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)
hprotoc.cabal view
@@ -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