hprotoc 2.1.6 → 2.1.7
raw patch · 5 files changed
+73/−44 lines, 5 filesdep ~protocol-buffersdep ~protocol-buffers-descriptorPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: protocol-buffers, protocol-buffers-descriptor
API changes (from Hackage documentation)
- Text.ProtocolBuffers.ProtoCompile.MakeReflections: makeProtoInfo :: (Bool, Bool) -> NameMap -> FileDescriptorProto -> ProtoInfo
+ Text.ProtocolBuffers.ProtoCompile.MakeReflections: makeProtoInfo :: (Bool, Bool, Bool) -> NameMap -> FileDescriptorProto -> ProtoInfo
Files
- Text/ProtocolBuffers/ProtoCompile.hs +7/−3
- Text/ProtocolBuffers/ProtoCompile/Gen.hs +40/−20
- Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs +18/−13
- Text/ProtocolBuffers/ProtoCompile/Parser.hs +3/−3
- hprotoc.cabal +5/−5
Text/ProtocolBuffers/ProtoCompile.hs view
@@ -47,11 +47,11 @@ , optInclude :: [LocalFP] , optProto :: LocalFP , optDesc :: Maybe (LocalFP)- , optImports,optVerbose,optUnknownFields,optLazy,optDryRun :: Bool }+ , optImports,optVerbose,optUnknownFields,optLazy,optLenses,optDryRun :: Bool } deriving Show setPrefix,setTarget,setInclude,setProto,setDesc :: String -> Options -> Options-setImports,setVerbose,setUnknown,setLazy,setDryRun :: Options -> Options+setImports,setVerbose,setUnknown,setLazy,setLenses,setDryRun :: Options -> Options setPrefix s o = o { optPrefix = toPrefix s } setTarget s o = o { optTarget = (LocalFP s) } setInclude s o = o { optInclude = LocalFP s : optInclude o }@@ -61,6 +61,7 @@ setVerbose o = o { optVerbose = True } setUnknown o = o { optUnknownFields = True } setLazy o = o { optLazy = True }+setLenses o = o { optLenses = True } setDryRun o = o { optDryRun = True } toPrefix :: String -> [MName String]@@ -107,6 +108,8 @@ "generated messages and groups all support unknown fields" , Option ['l'] ["lazy_fields"] (NoArg (Mutate setLazy)) "new default is now messages with strict fields, this reverts to generating lazy fields"+ , Option [] ["lenses"] (NoArg (Mutate setLenses))+ "generate lenses for accessing fields" , Option ['v'] ["verbose"] (NoArg (Mutate setVerbose)) "increase amount of printed information" , Option [] ["version"] (NoArg (Switch VersionInfo))@@ -148,6 +151,7 @@ , optVerbose = False , optUnknownFields = False , optLazy = False+ , optLenses = False , optDryRun = False } main :: IO ()@@ -249,7 +253,7 @@ -- This is the part that uses the (optional) package name nameMap <- either error return $ makeNameMaps (optPrefix options) (optAs options) env print' "Haskell name mangling done"- let protoInfo = makeProtoInfo (optUnknownFields options,optLazy options) nameMap fdp+ let protoInfo = makeProtoInfo (optUnknownFields options,optLazy options,optLenses options) nameMap fdp result = makeResult protoInfo seq result (print' "Recursive modules resolved") let produceMSG di = do
Text/ProtocolBuffers/ProtoCompile/Gen.hs view
@@ -95,9 +95,12 @@ local :: String -> QName local t = UnQual (Ident t) +localField :: DescriptorInfo -> String -> QName+localField di t = UnQual (fieldIdent di t)+ -- pvar and preludevar and lvar are for lower-case identifiers isVar :: String -> Bool-isVar (x:_) = isLower x+isVar (x:_) = isLower x || x == '_' isVar _ = False isCon :: String -> Bool@@ -223,15 +226,19 @@ baseIdent :: ProtoName -> Name baseIdent = Ident . mName . baseName baseIdent' :: ProtoFName -> Name-baseIdent' = Ident . fName . baseName'+baseIdent' pfn = Ident $ baseNamePrefix' pfn ++ fName (baseName' pfn) +fieldIdent :: DescriptorInfo -> String -> Name+fieldIdent di str | makeLenses di = Ident ('_':str)+ | otherwise = Ident str+ qualName :: ProtoName -> QName qualName p@(ProtoName _ _prefix [] _base) = UnQual (baseIdent p) qualName p@(ProtoName _ _prefix (parents) _base) = Qual (ModuleName (joinMod parents)) (baseIdent p) qualFName :: ProtoFName -> QName-qualFName p@(ProtoFName _ _prefix [] _base) = UnQual (baseIdent' p)-qualFName p@(ProtoFName _ _prefix parents _base) = Qual (ModuleName (joinMod parents)) (baseIdent' p)+qualFName p@(ProtoFName _ _prefix [] _base _basePrefix) = UnQual (baseIdent' p)+qualFName p@(ProtoFName _ _prefix parents _base _basePrefix) = Qual (ModuleName (joinMod parents)) (baseIdent' p) unqualName :: ProtoName -> QName unqualName p = UnQual (baseIdent p)@@ -240,7 +247,7 @@ unqualFName p = UnQual (baseIdent' p) mayQualName :: ProtoName -> ProtoFName -> QName-mayQualName (ProtoName _ c'prefix c'parents c'base) name@(ProtoFName _ prefix parents _base) =+mayQualName (ProtoName _ c'prefix c'parents c'base) name@(ProtoFName _ prefix parents _base _basePrefix) = if joinMod (c'prefix++c'parents++[c'base]) == joinMod (prefix++parents) then UnQual (baseIdent' name) -- name is local, make UnQual else qualFName name -- name is imported, make Qual@@ -249,7 +256,7 @@ -- Define LANGUAGE options as [ModulePramga] -------------------------------------------- modulePragmas :: [ModulePragma]-modulePragmas = [ LanguagePragma src (map Ident ["BangPatterns","DeriveDataTypeable","FlexibleInstances","MultiParamTypeClasses"]) +modulePragmas = [ LanguagePragma src (map Ident ["BangPatterns","DeriveDataTypeable","FlexibleInstances","MultiParamTypeClasses","TemplateHaskell"]) , OptionsPragma src (Just GHC) " -fno-warn-unused-imports " ] @@ -261,7 +268,7 @@ = let protoName = enumName ei in Module src (ModuleName (fqMod protoName)) modulePragmas Nothing (Just [EThingAll (unqualName protoName)])- (standardImports True False) (enumDecls ei)+ (standardImports True False False) (enumDecls ei) enumDecls :: EnumInfo -> [Decl] enumDecls ei = map ($ ei) [ enumX@@ -403,7 +410,7 @@ extendees ++ mapMaybe typeName myKeys in Module src m modulePragmas Nothing (Just (exportKeys++exportNames)) imports (keysXTypeVal protoName (extensionKeys pri) ++ embed'ProtoInfo pri ++ embed'fdpBS fdpBS)- where protoImports = standardImports False (not . Seq.null . extensionKeys $ pri) +++ where protoImports = standardImports False (not . Seq.null . extensionKeys $ pri) False ++ [ ImportDecl src (ModuleName "Text.DescriptorProtos.FileDescriptorProto") False False False Nothing Nothing (Just (False,[IAbs (Ident "FileDescriptorProto")])) , ImportDecl src (ModuleName "Text.ProtocolBuffers.Reflections") False False False Nothing Nothing@@ -495,15 +502,26 @@ myKeys' = if sepKey then [] else myKeys m = ModuleName (fqMod protoName) exportKeys = map (EVar NoNamespace . unqualFName . fieldName) myKeys- imports = (standardImports False (hasExt di) ++) . mergeImports . concat $+ imports = (standardImports False (hasExt di) (makeLenses di) ++) . mergeImports . concat $ [ mapMaybe (importPN result m Normal) $ extendees' ++ mapMaybe typeName (myKeys' ++ (F.toList (fields 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))]+ | otherwise = [] declKeys | sepKey = [] | otherwise = keysXTypeVal (descName di) (keys di)- in Module src m modulePragmas Nothing (Just (EThingAll un : exportKeys)) imports- (descriptorX di : declKeys ++ instancesDescriptor di)+ in Module src m modulePragmas Nothing (Just (EThingAll un : exportLenses di ++ exportKeys)) imports+ (descriptorX di : lenses ++ declKeys ++ instancesDescriptor di) +exportLenses :: DescriptorInfo -> [ExportSpec]+exportLenses di =+ if makeLenses di+ then map (EVar NoNamespace . unqualFName . stripPrefix . fieldName)+ (F.toList (fields di))+ else []+ where stripPrefix pfn = pfn { baseNamePrefix' = "" }+ minimalImports :: [ImportDecl] minimalImports = [ ImportDecl src (ModuleName "Prelude") True False False Nothing (Just (ModuleName "Prelude'")) Nothing@@ -511,17 +529,19 @@ , ImportDecl src (ModuleName "Data.Data") True False False Nothing (Just (ModuleName "Prelude'")) Nothing , ImportDecl src (ModuleName "Text.ProtocolBuffers.Header") True False False Nothing (Just (ModuleName "P'")) Nothing ] -standardImports :: Bool -> Bool -> [ImportDecl]-standardImports isEnumMod ext =+standardImports :: Bool -> Bool -> Bool -> [ImportDecl]+standardImports isEnumMod ext lenses = [ ImportDecl src (ModuleName "Prelude") False False False Nothing Nothing (Just (False,ops)) , ImportDecl src (ModuleName "Prelude") True False False Nothing (Just (ModuleName "Prelude'")) Nothing , ImportDecl src (ModuleName "Data.Typeable") True False False Nothing (Just (ModuleName "Prelude'")) Nothing , ImportDecl src (ModuleName "Data.Data") True False False Nothing (Just (ModuleName "Prelude'")) Nothing- , ImportDecl src (ModuleName "Text.ProtocolBuffers.Header") True False False Nothing (Just (ModuleName "P'")) Nothing ]+ , ImportDecl src (ModuleName "Text.ProtocolBuffers.Header") True False False Nothing (Just (ModuleName "P'")) Nothing ] ++ lensTH where ops | ext = map (IVar NoNamespace . Symbol) $ base ++ ["==","<=","&&"] | otherwise = map (IVar NoNamespace . Symbol) base base | isEnumMod = ["+","/","."] | otherwise = ["+","/"]+ lensTH | lenses = [ImportDecl src (ModuleName "Control.Lens.TH") True False False Nothing Nothing Nothing]+ | otherwise = [] keysXType :: ProtoName -> Seq KeyInfo -> [Decl] keysXType self ks = map (makeKeyType self) . F.toList $ ks@@ -583,9 +603,9 @@ $ (if storeUnknown di then [unknownField] else []) bangType = if lazyFields di then TyParen {- UnBangedTy -} else TyBang BangedTy . TyParen -- extfield :: ([Name],BangType)- extfield = ([Ident "ext'field"], bangType (TyCon (private "ExtField")))+ extfield = ([fieldIdent di "ext'field"], bangType (TyCon (private "ExtField"))) -- unknownField :: ([Name],BangType)- unknownField = ([Ident "unknown'field"], bangType (TyCon (private "UnknownField")))+ unknownField = ([fieldIdent di "unknown'field"], bangType (TyCon (private "UnknownField"))) -- fieldX :: FieldInfo -> ([Name],BangType) fieldX fi = ([baseIdent' . fieldName $ fi], bangType (labeled (TyCon typed))) where labeled | canRepeat fi = typeApp "Seq"@@ -616,19 +636,19 @@ instanceExtendMessage :: DescriptorInfo -> Decl instanceExtendMessage di = InstDecl src Nothing [] [] (private "ExtendMessage") [TyCon (unqualName (descName di))]- [ inst "getExtField" [] (lvar "ext'field")+ [ inst "getExtField" [] (Var (localField di "ext'field")) , inst "putExtField" [patvar "e'f", patvar "msg"] putextfield , inst "validExtRanges" [patvar "msg"] (pvar "extRanges" $$ (Paren $ pvar "reflectDescriptorInfo" $$ lvar "msg")) ]- where putextfield = RecUpdate (lvar "msg") [ FieldUpdate (local "ext'field") (lvar "e'f") ]+ where putextfield = RecUpdate (lvar "msg") [ FieldUpdate (localField di "ext'field") (lvar "e'f") ] instanceUnknownMessage :: DescriptorInfo -> Decl instanceUnknownMessage di = InstDecl src Nothing [] [] (private "UnknownMessage") [TyCon (unqualName (descName di))]- [ inst "getUnknownField" [] (lvar "unknown'field")+ [ inst "getUnknownField" [] (Var (localField di "unknown'field")) , inst "putUnknownField" [patvar "u'f",patvar "msg"] putunknownfield ]- where putunknownfield = RecUpdate (lvar "msg") [ FieldUpdate (local "unknown'field") (lvar "u'f") ]+ where putunknownfield = RecUpdate (lvar "msg") [ FieldUpdate (localField di "unknown'field") (lvar "u'f") ] instanceTextType :: DescriptorInfo -> Decl instanceTextType di
Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs view
@@ -66,11 +66,11 @@ Nothing -> imp $ "toHaskell failed to find "++show k++" among "++show (M.keys reMap) Just pn -> pn -makeProtoInfo :: (Bool,Bool) -- unknownField and lazyFields for makeDescriptorInfo'+makeProtoInfo :: (Bool,Bool,Bool) -- unknownField, lazyFields and lenses for makeDescriptorInfo' -> NameMap -> D.FileDescriptorProto -> ProtoInfo-makeProtoInfo (unknownField,lazyFieldsOpt) (NameMap (packageID,hPrefix,hParent) reMap)+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 packageName = getPackageID packageID :: FIName (Utf8)@@ -79,7 +79,7 @@ [] -> imp $ "makeProtoInfo: no hPrefix or hParent in NameMap for: "++show fdp _ -> ProtoName packageName (init hPrefix) [] (last hPrefix) _ -> ProtoName packageName hPrefix (init hParent) (last hParent)- keyInfos = Seq.fromList . map (\f -> (keyExtendee' reMap f,toFieldInfo' reMap packageName f))+ keyInfos = Seq.fromList . map (\f -> (keyExtendee' reMap f,toFieldInfo' reMap packageName lenses f)) . F.toList . D.FileDescriptorProto.extension $ fdp allMessages = concatMap (processMSG packageName False) (F.toList $ D.FileDescriptorProto.message_type fdp) allEnums = map (makeEnumInfo' reMap packageName) (F.toList $ D.FileDescriptorProto.enum_type fdp) @@ -93,7 +93,7 @@ (D.DescriptorProto.name x)) groups parent' = fqAppend parent [IName (fromJust (D.DescriptorProto.name msg))]- in makeDescriptorInfo' reMap parent getKnownKeys msgIsGroup (unknownField,lazyFieldsOpt) msg+ in makeDescriptorInfo' reMap parent getKnownKeys msgIsGroup (unknownField,lazyFieldsOpt,lenses) msg : concatMap (\x -> processMSG parent' (checkGroup x) x) (F.toList (D.DescriptorProto.nested_type msg)) processENM parent msg = foldr ((:) . makeEnumInfo' reMap parent') nested@@ -132,9 +132,9 @@ makeDescriptorInfo' :: ReMap -> FIName Utf8 -> (ProtoName -> Seq FieldInfo) -> Bool -- msgIsGroup- -> (Bool,Bool) -- unknownField and lazyFields+ -> (Bool,Bool,Bool) -- unknownField, lazyFields and lenses -> D.DescriptorProto -> DescriptorInfo-makeDescriptorInfo' reMap parent getKnownKeys msgIsGroup (unknownField,lazyFieldsOpt)+makeDescriptorInfo' reMap parent getKnownKeys msgIsGroup (unknownField,lazyFieldsOpt,lenses) (D.DescriptorProto.DescriptorProto { D.DescriptorProto.name = Just rawName , D.DescriptorProto.field = rawFields@@ -142,11 +142,11 @@ , D.DescriptorProto.extension_range = extension_range }) = let di = DescriptorInfo protoName (pnPath protoName) msgIsGroup fieldInfos keyInfos extRangeList (getKnownKeys protoName)- unknownField lazyFieldsOpt+ 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)) rawFields- keyInfos = fmap (\f -> (keyExtendee' reMap f,toFieldInfo' reMap (protobufName protoName) f)) rawKeys+ fieldInfos = fmap (toFieldInfo' reMap (protobufName protoName) lenses) rawFields+ keyInfos = fmap (\f -> (keyExtendee' reMap f,toFieldInfo' reMap (protobufName protoName) lenses f)) rawKeys extRangeList = concatMap check unchecked where check x@(lo,hi) | hi < lo = [] | hi<19000 || 19999<lo = [x]@@ -158,8 +158,13 @@ (maybe minBound FieldId mStart, maybe maxBound (FieldId . pred) mEnd) makeDescriptorInfo' _ _ _ _ _ _ = imp $ "makeDescriptorInfo: missing name" -toFieldInfo' :: ReMap -> FIName Utf8 -> D.FieldDescriptorProto -> FieldInfo-toFieldInfo' reMap parent+toFieldInfo'+ :: ReMap+ -> FIName Utf8+ -> Bool -- ^ whether to use lences (if True, an underscore prefix is used)+ -> D.FieldDescriptorProto+ -> FieldInfo+toFieldInfo' reMap parent lenses f@(D.FieldDescriptorProto.FieldDescriptorProto { D.FieldDescriptorProto.name = Just name , D.FieldDescriptorProto.number = Just number@@ -171,7 +176,7 @@ = fieldInfo where mayDef = parseDefaultValue f fieldInfo = let (ProtoName x a b c) = toHaskell reMap $ fqAppend parent [IName name]- protoFName = ProtoFName x a b (mangle c)+ protoFName = ProtoFName x a b (mangle c) (if lenses then "_" else "") fieldId = (FieldId (fromIntegral number)) fieldType = (FieldType (fromEnum type')) {- removed to update 1.5.5 to be compatible with protobuf-2.3.0@@ -202,7 +207,7 @@ (fmap (toHaskell reMap . FIName) mayTypeName) (fmap utf8 mayRawDef) mayDef-toFieldInfo' _ _ f = imp $ "toFieldInfo: missing info in "++show f+toFieldInfo' _ _ _ f = imp $ "toFieldInfo: missing info in "++show f collectedGroups :: D.DescriptorProto -> [Utf8] collectedGroups = catMaybes
Text/ProtocolBuffers/ProtoCompile/Parser.hs view
@@ -127,7 +127,7 @@ -- This assumes the initial (L _ '{' ) has already been parsed. getAggregate :: P s [Lexed] getAggregate = do- input <- getInput + input <- getInput let count :: Int -> Int -> P s [Lexed] count !n !depth = do -- Not using getNextToken so that the value of 'n' in count is correct.@@ -552,9 +552,9 @@ rpc = pName (U.fromString "rpc") >> do name <- ident1- input <- between (pChar '(') (pChar ')') ident1+ input <- between (pChar '(') (pChar ')') ident _ <- pName (U.fromString "returns")- output <- between (pChar '(') (pChar ')') ident1+ output <- between (pChar '(') (pChar ')') ident let m1 = defaultValue { D.MethodDescriptorProto.name=Just name , D.MethodDescriptorProto.input_type=Just input , D.MethodDescriptorProto.output_type=Just output }
hprotoc.cabal view
@@ -1,5 +1,5 @@ name: hprotoc-version: 2.1.6+version: 2.1.7 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.6,- protocol-buffers-descriptor == 2.1.6+ build-depends: protocol-buffers == 2.1.7,+ protocol-buffers-descriptor == 2.1.7 Main-Is: Text/ProtocolBuffers/ProtoCompile.hs Hs-Source-Dirs: ., protoc-gen-haskell@@ -69,8 +69,8 @@ TypeSynonymInstances Library- build-depends: protocol-buffers == 2.1.6,- protocol-buffers-descriptor == 2.1.6+ build-depends: protocol-buffers == 2.1.7,+ protocol-buffers-descriptor == 2.1.7 Hs-Source-Dirs: ., protoc-gen-haskell build-tools: alex