diff --git a/Text/ProtocolBuffers/ProtoCompile.hs b/Text/ProtocolBuffers/ProtoCompile.hs --- a/Text/ProtocolBuffers/ProtoCompile.hs +++ b/Text/ProtocolBuffers/ProtoCompile.hs @@ -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 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 @@ -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 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 @@ -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 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 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 @@ -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 } diff --git a/hprotoc.cabal b/hprotoc.cabal --- a/hprotoc.cabal +++ b/hprotoc.cabal @@ -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