hprotoc 2.4.11 → 2.4.12
raw patch · 7 files changed
+245/−95 lines, 7 filesdep ~basedep ~protocol-buffersdep ~protocol-buffers-descriptorPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: base, protocol-buffers, protocol-buffers-descriptor
API changes (from Hackage documentation)
- Text.ProtocolBuffers.ProtoCompile.MakeReflections: makeProtoInfo :: (Bool, Bool, Bool) -> NameMap -> FileDescriptorProto -> ProtoInfo
+ Text.ProtocolBuffers.ProtoCompile.MakeReflections: makeProtoInfo :: (Bool, Bool, Bool, Bool) -> NameMap -> FileDescriptorProto -> ProtoInfo
Files
- Text/ProtocolBuffers/ProtoCompile.hs +23/−9
- Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs +0/−3
- Text/ProtocolBuffers/ProtoCompile/Gen.hs +172/−33
- Text/ProtocolBuffers/ProtoCompile/Identifiers.hs +0/−3
- Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs +30/−30
- Text/ProtocolBuffers/ProtoCompile/Resolve.hs +12/−10
- hprotoc.cabal +8/−7
Text/ProtocolBuffers/ProtoCompile.hs view
@@ -44,13 +44,22 @@ import Paths_hprotoc(version) -data Options = Options { optPrefix :: [MName String]- , optAs :: [(CanonFP,[MName String])]- , optTarget :: LocalFP- , optInclude :: [LocalFP]- , optProto :: LocalFP- , optDesc :: Maybe (LocalFP)- , optImports,optVerbose,optUnknownFields,optLazy,optLenses,optDryRun :: Bool }+data Options =+ Options+ { optPrefix :: [MName String]+ , optAs :: [(CanonFP,[MName String])]+ , optTarget :: LocalFP+ , optInclude :: [LocalFP]+ , optProto :: LocalFP+ , optDesc :: Maybe (LocalFP)+ , optImports :: Bool+ , optVerbose :: Bool+ , optUnknownFields :: Bool+ , optLazy :: Bool+ , optLenses :: Bool+ , optJson :: Bool+ , optDryRun :: Bool+ } deriving Show setPrefix,setTarget,setInclude,setProto,setDesc :: String -> Options -> Options@@ -65,6 +74,7 @@ setUnknown o = o { optUnknownFields = True } setLazy o = o { optLazy = True } setLenses o = o { optLenses = True }+setJson o = o { optJson = True } setDryRun o = o { optDryRun = True } toPrefix :: String -> [MName String]@@ -113,6 +123,8 @@ "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 [] ["json"] (NoArg (Mutate setJson))+ "generate json instances" , Option ['v'] ["verbose"] (NoArg (Mutate setVerbose)) "increase amount of printed information" , Option [] ["version"] (NoArg (Switch VersionInfo))@@ -155,7 +167,9 @@ , optUnknownFields = False , optLazy = False , optLenses = False- , optDryRun = False }+ , optJson = False+ , optDryRun = False+ } main :: IO () main = do@@ -257,7 +271,7 @@ 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+ let protoInfo = makeProtoInfo (optUnknownFields options,optLazy options,optLenses options, optJson options) nameMap fdp result = makeResult protoInfo seq result (print' "Recursive modules resolved") let produceMSG di = do
Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs view
@@ -116,9 +116,6 @@ import Text.ProtocolBuffers.Basic import Text.ProtocolBuffers.Identifiers import Text.ProtocolBuffers.Reflections-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-#endif import Debug.Trace(trace)
Text/ProtocolBuffers/ProtoCompile/Gen.hs view
@@ -16,13 +16,15 @@ -- module Text.ProtocolBuffers.ProtoCompile.Gen(protoModule,descriptorModules,enumModule,oneofModule,prettyPrint) where +import Text.DescriptorProtos.FieldDescriptorProto.Type hiding (Type)+ import Text.ProtocolBuffers.Basic import Text.ProtocolBuffers.Identifiers 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(..)) -import Control.Monad(mzero)+import Data.Monoid ((<>)) import qualified Data.ByteString.Lazy.Char8 as LC(unpack) import qualified Data.Foldable as F(foldr,toList) import Data.List(sortBy,foldl',foldl1',group,sort,union)@@ -33,8 +35,9 @@ import Data.Char(isLower,isUpper) import qualified Data.Map as M import Data.Maybe(mapMaybe)+import Data.List (dropWhileEnd) import Data.Sequence (ViewL(..),(><))-import qualified Data.Sequence as Seq(null,length,empty,viewl)+import qualified Data.Sequence as Seq(null,length,viewl) import qualified Data.Set as S import System.FilePath(joinPath) @@ -101,7 +104,7 @@ -- pvar and preludevar and lvar are for lower-case identifiers isVar :: String -> Bool-isVar (x:_) = isLower x || x == '_'+isVar (x:_) = isLower x || x == '_' || x == '<' || x == '+' isVar _ = False isCon :: String -> Bool@@ -285,12 +288,12 @@ oneofPat :: (ProtoName,FieldInfo) -> (Pat (),Pat ()) oneofPat (name,fi) =- let fName@(Ident () fname) = baseIdent' (fieldName 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)+ let (Ident () fname) = baseIdent' (fieldName fi) in (litStr fname,lvar fname) oneofGet :: (ProtoName,FieldInfo) -> (String,ProtoName)@@ -306,7 +309,7 @@ modulePragmas :: Bool -> [ModulePragma ()] modulePragmas templateHaskell = [ LanguagePragma () (map (Ident ()) $- thPragma ++ ["BangPatterns","DeriveDataTypeable","DeriveGeneric","FlexibleInstances","MultiParamTypeClasses"]+ thPragma ++ ["BangPatterns","DeriveDataTypeable","DeriveGeneric","FlexibleInstances","MultiParamTypeClasses","OverloadedStrings"] ) , OptionsPragma () (Just GHC) " -fno-warn-unused-imports " ]@@ -394,7 +397,7 @@ (standardImports True False False) (enumDecls ei) enumDecls :: EnumInfo -> [Decl ()]-enumDecls ei = map ($ ei) [ enumX+enumDecls ei = map ($ ei) [ enumX , instanceMergeableEnum , instanceBounded , instanceDefaultEnum ]@@ -405,12 +408,40 @@ , instanceMessageAPI . enumName , instanceReflectEnum , instanceTextTypeEnum+ ] +++ filter (const (enumJsonInstances ei))+ [ instanceToJSONEnum ei+ , instanceFromJSONEnum ei ] enumX :: EnumInfo -> Decl () enumX ei = DataDecl () (DataType ()) Nothing (DHead () (baseIdent (enumName ei))) (map enumValueX (enumValues ei)) (return derivesEnum) where enumValueX (_,name) = QualConDecl () Nothing Nothing (ConDecl () (Ident () name) []) +instanceToJSONEnum :: EnumInfo -> Decl ()+instanceToJSONEnum ei+ = InstDecl () Nothing (mkSimpleIRule (private "ToJSON") [TyCon () (unqualName (enumName ei))]) . Just $+ [ inst "toJSON" [patvar "msg'"] (pcon "String" $$ Paren () (Case () (lvar "msg'") alts))+ ]+ where+ mkAlt :: String -> Alt ()+ mkAlt alt = Alt () (PApp () (UnQual () (Ident () alt)) []) (UnGuardedRhs () $ litStr alt) Nothing+ alts = map (mkAlt . snd) (enumValues ei)++instanceFromJSONEnum :: EnumInfo -> Decl ()+instanceFromJSONEnum ei+ = InstDecl () Nothing (mkSimpleIRule (private "FromJSON") [TyCon () (unqualName name)]) . Just $+ [ inst "parseJSON" [] (pvar "withText" $$ litStr name' $$ Paren () (Lambda () [patvar "msg'"] body))+ ]+ where+ name = enumName $ ei+ name' = joinMod (haskellPrefix name ++ parentModule name ++ [baseName name, baseName name])+ body = Case () (lvar "msg'") alts+ mkAlt (_, alt) = Alt () (PLit () (Signless ()) (String () alt alt)) (UnGuardedRhs () (preludevar "return" $$ lcon alt)) Nothing+ alts =+ map mkAlt (enumValues ei) +++ [ Alt () (PWildCard ()) (UnGuardedRhs () $ preludevar "fail" $$ Paren () (litStr "Invalid value " $$ preludevar "++" $$ preludevar "show" $$ lvar "msg'" $$ preludevar "++" $$ litStr (" for enum "++name'))) Nothing ]+ instanceTextTypeEnum :: EnumInfo -> Decl () instanceTextTypeEnum ei = InstDecl () Nothing (mkSimpleIRule (private "TextType") [TyCon () (unqualName (enumName ei))]) . Just $@@ -507,7 +538,9 @@ where one (v,ns) = Tuple () Boxed [litInt (getEnumCode v),litStr ns,lcon ns] ei' = foldl' (App ()) (pcon "EnumInfo") [protoNameExp ,List () $ map litStr (enumFilePath ei)- ,List () (map two values)]+ ,List () (map two values)+ ,preludecon (show (enumJsonInstances ei))+ ] where two (v,ns) = Tuple () Boxed [litInt (getEnumCode v),litStr ns] protoNameExp = Paren () $ foldl' (App ()) (pvar "makePNF") [ xxx'Exp, mList a, mList b, litStr (mName c) ]@@ -578,23 +611,17 @@ = let protoName = descName di un = unqualName protoName classes = [prelude "Show",prelude "Eq",prelude "Ord",prelude "Data", prelude "Generic"-#if __GLASGOW_HASKELL__ < 780- ,prelude "Typeable"-#endif ,private "Mergeable",private "Default" ,private "Wire",private "GPB",private "ReflectDescriptor"- , private "TextType", private "TextMsg"+ ,private "TextType", private "TextMsg" ]- ++ if hasExt di then [private "ExtendMessage"] else []- ++ if storeUnknown di then [private "UnknownMessage"] else []+ ++ (if hasExt di then [private "ExtendMessage"] else [])+ ++ (if storeUnknown di then [private "UnknownMessage"] else [])+ ++ (if jsonInstances di then [private "FromJSON", private "ToJSON"] else []) instMesAPI = InstDecl () Nothing (mkSimpleIRule (private "MessageAPI") [TyVar () (Ident () "msg'"), TyParen () (TyFun () (TyVar () (Ident () "msg'")) (TyCon () un)), (TyCon () un)]) Nothing dataDecl = DataDecl () (DataType ()) Nothing (DHead () (baseIdent protoName)) [] $-#if __GLASGOW_HASKELL__ >= 780 pure derivesTypeable-#else- mzero-#endif mkInst s = InstDecl () Nothing (mkSimpleIRule s [TyCon () un]) Nothing eabs = EAbs () (NoNamespace ()) un in Module () (Just (ModuleHead () (ModuleName () (fqMod protoName)) Nothing (Just (ExportSpecList () [eabs])))) (modulePragmas $ makeLenses di) minimalImports@@ -647,8 +674,11 @@ | otherwise = [] declKeys | sepKey = [] | otherwise = keysXTypeVal (descName di) (keys di)- in Module () (Just (ModuleHead () m Nothing (Just (ExportSpecList () ((EThingWith () (EWildcard () 0) un [] : exportLenses di ++ exportKeys)))))) (modulePragmas $ makeLenses di) imports- (descriptorX di : lenses ++ declKeys ++ instancesDescriptor di)+ in Module ()+ (Just (ModuleHead () m Nothing (Just (ExportSpecList () ((EThingWith () (EWildcard () 0) un [] : exportLenses di ++ exportKeys))))))+ (modulePragmas $ makeLenses di)+ imports+ (descriptorX di : lenses ++ declKeys ++ instancesDescriptor di) mkLenses :: Exp () mkLenses = Var () (Qual () (ModuleName () "Control.Lens.TH") (Ident () "makeLenses"))@@ -656,12 +686,11 @@ exportLenses :: DescriptorInfo -> [ExportSpec ()] exportLenses di = if makeLenses di- then- map (EVar () . unqualFName . stripPrefix) (lensFieldNames di)+ then map (EVar () . unqualFName . stripPrefix) lensFieldNames else [] where stripPrefix pfn = pfn { baseNamePrefix' = "" }- lensFieldNames di = map fieldName (F.toList (fields di))- ++ map oneofFName (F.toList (descOneofs di))+ lensFieldNames = map fieldName (F.toList (fields di))+ ++ map oneofFName (F.toList (descOneofs di)) minimalImports :: [ImportDecl ()] minimalImports =@@ -683,7 +712,7 @@ ops | ext = map (IVar () . Symbol ()) $ base ++ ["==","<=","&&"] | otherwise = map (IVar () . Symbol ()) base base | isEnumMod = ["+","/","."]- | otherwise = ["+","/"]+ | otherwise = ["+","/","++","."] lensTH | lenses = [ImportDecl () (ModuleName () "Control.Lens.TH") True False False Nothing Nothing Nothing] | otherwise = [] @@ -743,9 +772,9 @@ name = baseIdent self con = RecDecl () name eFields where eFields = map (\(ns, t) -> FieldDecl () ns t) $ F.foldr ((:) . fieldX) end (fields di)- end = (if hasExt di then (extfield:) else id)- . (if storeUnknown di then (unknownField:) else id)- $ eOneof+ end = (if hasExt di then pure extfield else mempty) <>+ eOneof <>+ (if storeUnknown di then pure unknownField else mempty) eOneof = F.foldr ((:) . fieldOneofX) [] (descOneofs di) bangType = if lazyFields di then TyParen () {- UnBangedTy -} else TyBang () (BangedTy ()) (NoUnpackPragma ()) . TyParen ()@@ -773,6 +802,7 @@ instancesDescriptor di = map ($ di) $ (if hasExt di then (instanceExtendMessage:) else id) $ (if storeUnknown di then (instanceUnknownMessage:) else id) $+ (if jsonInstances di then ([instanceToJSON,instanceFromJSON]++) else id) $ [ instanceMergeable , instanceDefault , instanceWireDescriptor@@ -800,6 +830,116 @@ ] where putunknownfield = RecUpdate () (lvar "msg") [ FieldUpdate () (localField di "unknown'field") (lvar "u'f") ] +instanceToJSON :: DescriptorInfo -> Decl ()+instanceToJSON di+ = InstDecl () Nothing (mkSimpleIRule (private "ToJSON") [TyCon () (unqualName (descName di))]) . Just $+ [ inst "toJSON" [patvar msgVar] serializeFun+ ]+ where+ flds = F.toList (fields di)+ os = F.toList (descOneofs di)+ msgVar = distinctVar "msg"+ reservedVars = map toPrintName flds+ distinctVar var = if var `elem` reservedVars then distinctVar (var ++ "'") else var+ getFname fld = fName $ baseName' $ fieldName fld+ toJSONFun fld = case toEnum (getFieldType (typeCode fld)) of+ TYPE_INT64 -> pvar "toJSONShowWithPayload"+ TYPE_UINT64 -> pvar "toJSONShowWithPayload"+ TYPE_BYTES -> pvar "toJSONByteString"+ _ -> pvar "toJSON"+ makeOneOfPair oi =+ let Ident () funcname = baseIdent' (oneofFName oi)+ oneOfFlds = F.toList (oneofFields oi)+ caseAlt :: (ProtoName,FieldInfo) -> Alt ()+ caseAlt f = Alt () patt (UnGuardedRhs () rhs) noWhere+ where patt = PApp () (prelude "Just") [fst (oneofPat f)]+ (rstr,rvar) = oneofRec f+ rhs = List () [Tuple () Boxed [ rstr, toJSONFun (snd f) $$ rvar ] ]+ caseAltNothing :: Alt ()+ caseAltNothing = Alt () (PApp () (prelude "Nothing") []) (UnGuardedRhs () rhs) noWhere+ where rhs = List () []+ in Case () (Paren () (lvar funcname $$ lvar msgVar)) (map caseAlt oneOfFlds ++ [caseAltNothing])+ makePair fld =+ let fldName = getFname fld+ fldName' = dropWhileEnd (== '\'') fldName+ arg = Paren () (lvar fldName $$ lvar msgVar)+ toJSONCall = case (isRequired fld, canRepeat fld) of+ (True, False) -> toJSONFun fld $$ arg+ (_, _) -> pvar "toJSON" $$ Paren () (preludevar "fmap" $$ toJSONFun fld $$ arg)+ in Tuple () Boxed+ [ Lit () (String () fldName' (show fldName'))+ , toJSONCall+ ]+ serializeFun =+ pvar "objectNoEmpty" $$ Paren () (mkOp "++" (List () (map makePair flds)) (preludevar "concat" $$ List () (map makeOneOfPair os)))++instanceFromJSON :: DescriptorInfo -> Decl ()+instanceFromJSON di+ = InstDecl () Nothing (mkSimpleIRule (private "FromJSON") [TyCon () (unqualName (descName di))]) . Just $+ [ inst "parseJSON" [] (pvar "withObject" $$ Lit () (String () name (show name)) $$ Paren () parseFun)+ ]+ where+ name = mName $ baseName $ descName di+ flds = F.toList (fields di)+ os = F.toList (descOneofs di)+ reservedVars = map toPrintName flds+ distinctVar var = if var `elem` reservedVars then distinctVar (var ++ "'") else var+ objVar = distinctVar "o"+ getFname fld = fName $ baseName' $ fieldName fld+ getOneofFname oi = fName $ baseName' $ oneofFName oi+ parseJSONFun fld = case toEnum (getFieldType (typeCode fld)) of+ TYPE_INT64 -> pvar "parseJSONReadWithPayload" $$ Lit () (String () "int64" (show "int64"))+ TYPE_UINT64 -> pvar "parseJSONReadWithPayload" $$ Lit () (String () "uint64" (show "uint64"))+ TYPE_BOOL -> pvar "parseJSONBool"+ TYPE_BYTES -> pvar "parseJSONByteString"+ _ -> pvar "parseJSON"+ getOption r@(_, fi) =+ let fldName = getFname fi+ in preludevar "fmap" $$ Paren () (preludevar "fmap" $$ oneofCon r) $$+ Paren () (pvar "explicitParseFieldMaybe" $$ parseJSONFun fi $$ lvar objVar $$ litStr fldName)+ getOneofValue oi =+ let fldName = getOneofFname oi+ in Generator () (patvar fldName) (preludevar "fmap" $$ pvar "msum" $$ Paren () (preludevar "sequence" $$ List () ((map getOption (F.toList (oneofFields oi)) ++ [preludevar "return" $$ preludecon "Nothing"]))))+ getFieldValue fld =+ let fldName = getFname fld+ fldName' = dropWhileEnd (== '\'') fldName+ parseFieldFun = case (hsDefault fld, isRequired fld) of+ (Nothing, True) -> pvar "explicitParseField"+ _ -> pvar "explicitParseFieldMaybe"+ parseJSONFun' = case canRepeat fld of+ False -> parseJSONFun fld+ True -> Paren () (preludevar "mapM" $$ parseJSONFun fld $$ pvar "<=<" $$ pvar "parseJSON")+ parseFieldCall = parseFieldFun $$ parseJSONFun' $$ lvar objVar $$ Lit () (String () fldName' (show fldName'))+ parseFieldCall' = case canRepeat fld of+ False -> parseFieldCall+ True -> preludevar "fmap" $$ Paren () (preludevar "maybe" $$ preludevar "mempty" $$ preludevar "id") $$ parseFieldCall+ parseFieldCall'' = case (hsDefault fld, canRepeat fld) of+ (_ , True) -> parseFieldCall'+ (Nothing, False) -> parseFieldCall'+ (Just d, False) ->+ let defLit = defToSyntax (typeCode fld) d+ defParse = case isRequired fld of+ True -> Paren () defLit+ False -> Paren () (preludecon "Just" $$ Paren () defLit)+ tmpVar = distinctVar "tmp"+ modfun = if isRequired fld then preludevar "id" else preludecon "Just"+ in Do ()+ [ Generator () (patvar tmpVar) parseFieldCall'+ , Qualifier () $ preludevar "return" $$ Paren () (preludevar "maybe" $$ defParse $$ modfun $$ lvar tmpVar)+ ]+ in Generator () (patvar fldName) parseFieldCall''+ updates =+ (map (\fld -> FieldUpdate () (local (getFname fld)) (lvar (getFname fld))) flds) +++ (map (\oi -> FieldUpdate () (local (getOneofFname oi)) (lvar (getOneofFname oi))) os)+ retVal =+ case updates of+ [] -> pvar "defaultValue"+ (_:_) -> RecUpdate () (pvar "defaultValue") updates+ parseFun = Lambda () [patvar objVar] $ Do () $+ map getFieldValue flds +++ map getOneofValue os +++ [ Qualifier () $ preludevar "return" $$ retVal ]+ instanceTextType :: DescriptorInfo -> Decl () instanceTextType di = InstDecl () Nothing (mkSimpleIRule (private "TextType") [TyCon () (unqualName (descName di))]) . Just $@@ -887,8 +1027,6 @@ 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 () patt (UnGuardedRhs () rhs) noWhere@@ -1057,9 +1195,10 @@ -- wireGet generation -- new for 1.5.7, rewriting this a great deal!- getCases = let param = if storeUnknown di- then Paren () (pvar "catch'Unknown" $$ lvar "update'Self")- else lvar "update'Self"+ getCases = let handleUnknown = if storeUnknown di+ then pvar "loadUnknown"+ else pvar "discardUnknown"+ param = Paren () (pvar "catch'Unknown'" $$ handleUnknown $$ lvar "update'Self") in UnGuardedRhs () $ cases (pvar "getBareMessageWith" $$ param) (pvar "getMessageWith" $$ param) (pvar "wireGetErr" $$ lvar "ft'")
Text/ProtocolBuffers/ProtoCompile/Identifiers.hs view
@@ -25,9 +25,6 @@ import Data.Set(Set) import qualified Data.Set as S import Text.ProtocolBuffers.Basic-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-#endif -- | Contains one identifier name newtype IName a = IName {iName::a} deriving (Show,Read,Eq,Ord)
Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs view
@@ -9,7 +9,7 @@ -- parent Descriptor to the actual Descriptor. It moves the data out -- of Maybe types. It converts Utf8 to String. Keys known to extend -- a Descriptor are listed in that Descriptor.--- +-- -- In building the reflection info new things are computed. It changes -- dotted names to ProtoName using the translator from -- 'makeNameMaps'. It parses the default value from the ByteString to@@ -21,20 +21,20 @@ import qualified Text.DescriptorProtos.DescriptorProto as D.DescriptorProto(DescriptorProto(..)) import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D.DescriptorProto(ExtensionRange(ExtensionRange)) import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D.DescriptorProto.ExtensionRange(ExtensionRange(..))-import qualified Text.DescriptorProtos.EnumDescriptorProto as D(EnumDescriptorProto) -import qualified Text.DescriptorProtos.EnumDescriptorProto as D.EnumDescriptorProto(EnumDescriptorProto(..)) +import qualified Text.DescriptorProtos.EnumDescriptorProto as D(EnumDescriptorProto)+import qualified Text.DescriptorProtos.EnumDescriptorProto as D.EnumDescriptorProto(EnumDescriptorProto(..)) import qualified Text.DescriptorProtos.EnumValueDescriptorProto as D(EnumValueDescriptorProto) import qualified Text.DescriptorProtos.EnumValueDescriptorProto as D.EnumValueDescriptorProto(EnumValueDescriptorProto(..))-import qualified Text.DescriptorProtos.FieldDescriptorProto as D(FieldDescriptorProto) -import qualified Text.DescriptorProtos.FieldDescriptorProto as D.FieldDescriptorProto(FieldDescriptorProto(..)) +import qualified Text.DescriptorProtos.FieldDescriptorProto as D(FieldDescriptorProto)+import qualified Text.DescriptorProtos.FieldDescriptorProto as D.FieldDescriptorProto(FieldDescriptorProto(..)) -- import qualified Text.DescriptorProtos.FieldDescriptorProto.Label as D.FieldDescriptorProto(Label) import Text.DescriptorProtos.FieldDescriptorProto.Label as D.FieldDescriptorProto.Label(Label(..)) -- import qualified Text.DescriptorProtos.FieldDescriptorProto.Type as D.FieldDescriptorProto(Type) import Text.DescriptorProtos.FieldDescriptorProto.Type as D.FieldDescriptorProto.Type(Type(..)) import qualified Text.DescriptorProtos.FieldOptions as D(FieldOptions(FieldOptions)) 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.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(..)) @@ -71,11 +71,11 @@ Nothing -> imp $ "toHaskell failed to find "++show k++" among "++show (M.keys reMap) Just pn -> pn -makeProtoInfo :: (Bool,Bool,Bool) -- unknownField, lazyFields and lenses for makeDescriptorInfo'+makeProtoInfo :: (Bool,Bool,Bool,Bool) -- unknownField, lazyFields, lenses and json for makeDescriptorInfo' -> NameMap- -> D.FileDescriptorProto + -> D.FileDescriptorProto -> ProtoInfo-makeProtoInfo (unknownField,lazyFieldsOpt,lenses) (NameMap (packageID,hPrefix,hParent) reMap)+makeProtoInfo (unknownField,lazyFieldsOpt,lenses,json) (NameMap (packageID,hPrefix,hParent) reMap) fdp@(D.FileDescriptorProto { D.FileDescriptorProto.name = Just rawName }) = ProtoInfo protoName (pnPath protoName) (toString rawName) keyInfos allMessages allEnums allOneofs allKeys where packageName = getPackageID packageID :: FIName (Utf8)@@ -87,38 +87,38 @@ 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) + allEnums = map (makeEnumInfo' reMap packageName json) (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 = + processMSG parent msgIsGroup msg = let getKnownKeys protoName' = fromMaybe Seq.empty (M.lookup protoName' allKeys) groups = collectedGroups msg checkGroup x = elem (fromMaybe (imp $ "no message name in makeProtoInfo.processMSG.checkGroup:\n"++show msg) (D.DescriptorProto.name x)) groups parent' = fqAppend parent [IName (fromJust (D.DescriptorProto.name msg))]- in makeDescriptorInfo' reMap parent getKnownKeys msgIsGroup (unknownField,lazyFieldsOpt,lenses) msg+ in makeDescriptorInfo' reMap parent getKnownKeys msgIsGroup (unknownField,lazyFieldsOpt,lenses,json) msg : concatMap (\x -> processMSG parent' (checkGroup x) x) (F.toList (D.DescriptorProto.nested_type msg))- processENM parent msg = foldr ((:) . makeEnumInfo' reMap parent') nested+ processENM parent msg = foldr ((:) . makeEnumInfo' reMap parent' json) nested (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)) + 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-makeEnumInfo' reMap parent+makeEnumInfo' :: ReMap -> FIName Utf8 -> Bool -> D.EnumDescriptorProto -> EnumInfo+makeEnumInfo' reMap parent json e@(D.EnumDescriptorProto.EnumDescriptorProto { D.EnumDescriptorProto.name = Just rawName , D.EnumDescriptorProto.value = value }) = if Seq.null value then imp $ "enum has no values: "++show e- else EnumInfo protoName (pnPath protoName) enumVals+ else EnumInfo protoName (pnPath protoName) enumVals json where protoName = toHaskell reMap $ fqAppend parent [IName rawName] enumVals ::[(EnumCode,String)] enumVals = F.foldr ((:) . oneValue) [] value@@ -128,7 +128,7 @@ , D.EnumValueDescriptorProto.number = Just number }) = (EnumCode number,mName . baseName . toHaskell reMap $ fqAppend (protobufName protoName) [IName name]) oneValue evdp = imp $ "no name or number for evdp passed to makeEnumInfo.oneValue: "++show evdp-makeEnumInfo' _ _ _ = imp "makeEnumInfo: missing name"+makeEnumInfo' _ _ _ _ = imp "makeEnumInfo: missing name" makeOneofInfo' :: ReMap -> FIName Utf8 -> Bool -- ^ makeLenses@@ -162,26 +162,26 @@ makeDescriptorInfo' :: ReMap -> FIName Utf8 -> (ProtoName -> Seq FieldInfo) -> Bool -- msgIsGroup- -> (Bool,Bool,Bool) -- unknownField, lazyFields and lenses+ -> (Bool,Bool,Bool,Bool) -- unknownField, lazyFields, lenses, json -> D.DescriptorProto -> DescriptorInfo-makeDescriptorInfo' reMap parent getKnownKeys msgIsGroup (unknownField,lazyFieldsOpt,lenses)+makeDescriptorInfo' reMap parent getKnownKeys msgIsGroup (unknownField,lazyFieldsOpt,lenses,json) 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 + = let di = DescriptorInfo protoName (pnPath protoName) msgIsGroup fieldInfos oneofInfos keyInfos extRangeList (getKnownKeys protoName)- unknownField lazyFieldsOpt lenses+ unknownField lazyFieldsOpt lenses json in di -- trace (toString rawName ++ "\n" ++ show di ++ "\n\n") $ di where protoName = toHaskell reMap $ fqAppend parent [IName rawName] 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 = []@@ -221,7 +221,7 @@ -} wt | packedOption = toPackedWireTag fieldId -- write packed | otherwise = toWireTag fieldId fieldType -- write unpacked- + wt2 | validPacked = Just (toWireTag fieldId fieldType -- read unpacked ,toPackedWireTag fieldId) -- read packed | otherwise = Nothing@@ -245,10 +245,10 @@ mayDef toFieldInfo' _ _ _ f = imp $ "toFieldInfo: missing info in "++show f -collectedGroups :: D.DescriptorProto -> [Utf8] +collectedGroups :: D.DescriptorProto -> [Utf8] collectedGroups = catMaybes . map D.FieldDescriptorProto.type_name- . filter (\f -> D.FieldDescriptorProto.type' f == Just TYPE_GROUP) + . filter (\f -> D.FieldDescriptorProto.type' f == Just TYPE_GROUP) . F.toList . D.DescriptorProto.field @@ -297,8 +297,8 @@ {- parseDefDouble :: Utf8 -> Maybe HsDefault-parseDefDouble bs | - | otherwise = fmap (HsDef'Rational . toRational) +parseDefDouble bs |+ | otherwise = fmap (HsDef'Rational . toRational) . mayRead reads' . uToString $ bs -} @@ -314,7 +314,7 @@ {- parseDefFloat :: Utf8 -> Maybe HsDefault-parseDefFloat bs = fmap (HsDef'Rational . toRational) +parseDefFloat bs = fmap (HsDef'Rational . toRational) . mayRead reads' . uToString $ bs where reads' :: ReadS Float reads' = readSigned' reads
Text/ProtocolBuffers/ProtoCompile/Resolve.hs view
@@ -581,7 +581,7 @@ tell [(fqSelf,self)] return template' --- Compute the nameMap that determine how to translate from proto names to haskell names+-- | Compute the nameMap that determine how to translate from proto names to haskell names -- The loop oever makeNameMap uses the (optional) package name -- makeNameMaps is called from the run' routine in ProtoCompile.hs for both standalone and plugin use. -- hPrefix and hAs are command line controlled options.@@ -600,12 +600,12 @@ Just p -> p Nothing -> hPrefix -- this is the usual branch unless overridden on command line let (tl,tls) = getTLS env- (fdp:fdps) <- mapM top'FDP (tl:tls)+ fdp <- top'FDP tl+ fdps <- mapM top'FDP tls (NameMap tuple m) <- makeNameMap (getPrefix fdp) fdp let f (NameMap _ x) = x ms <- fmap (map f) . mapM (\y -> makeNameMap (getPrefix y) y) $ fdps let nameMap = (NameMap tuple (M.unions (m:ms)))--- trace (show nameMap) $ return nameMap -- | 'makeNameMap' conservatively checks its input.@@ -1122,7 +1122,7 @@ msg' = seq ef' (putExtField (ExtField ef') msg) return msg' --- 'interpretOption' is called by 'interpretOptions'+-- | 'interpretOption' is called by 'interpretOptions' -- The 'interpretOption' function is quite long because there are two things going on. -- The first is the actual type must be retrieved from the UninterpretedOption and encoded. -- The second is that messages/groups holding messages/groups ... holding the above must wrap this.@@ -1133,7 +1133,9 @@ interpretOption :: [IName String] -> D.UninterpretedOption -> RE (FieldId,ExtFieldValue) interpretOption optName uno = case F.toList (D.UninterpretedOption.name uno) of [] -> iFail $ "Empty name_part"- (part:parts) -> go Nothing optName part parts+ (part:parts) -> do+ (fieldId, raw) <- go Nothing optName part parts+ return (fieldId, ExtFromWire raw) where iFail :: String -> RE a -- needed by ghc-7.0.2 iFail msg = do env <- ask@@ -1143,7 +1145,7 @@ , " message: "++msg ] -- This takes care of an intermediate message or group type- go :: Maybe Entity {- E'Message E'Group -} -> [IName String] -> D.NamePart -> [D.NamePart] -> RE (FieldId,ExtFieldValue)+ go :: Maybe Entity {- E'Message E'Group -} -> [IName String] -> D.NamePart -> [D.NamePart] -> RE (FieldId,Seq EP) go mParent names (D.NamePart { D.NamePart.name_part = name , D.NamePart.is_extension = isKey }) (next:rest) = do -- get entity (Field or Key) and the TYPE_*@@ -1175,7 +1177,7 @@ E'Group {} -> return TYPE_GROUP _ -> iFail $ "Intermediate entry is not an E'Message or E'Group: "++show (eName entity) -- recursive call to get inner result- (fid',ExtFromWire raw') <- go (Just entity) (eName entity) next rest+ (fid', raw') <- go (Just entity) (eName entity) next rest -- wrap old tag + inner result with outer info let tag@(WireTag tag') = mkWireTag fid' wt' (EP wt' bs') = Seq.index raw' 0@@ -1189,7 +1191,7 @@ putLazyByteString bs' putVarUInt (succ (getWireTag (mkWireTag fid wt))) _ -> fail $ "bug! raw with type "++show t++" should be impossible"- return (fid,ExtFromWire (Seq.singleton (EP wt bs)))+ return (fid, Seq.singleton (EP wt bs)) -- This takes care of the acutal value of the option, which must be a basic type go mParent names (D.NamePart { D.NamePart.name_part = name@@ -1211,11 +1213,11 @@ Just TYPE_MESSAGE -> {- impossible -} iFail $ "Last entry was a TYPE_MESSAGE instead of concrete value type" -- impossible Just typeCode -> return typeCode -- Need to define a polymorphic 'done' to convert actual data type to its wire encoding- let done :: Wire v => v -> RE (FieldId,ExtFieldValue)+ let done :: Wire v => v -> RE (FieldId,Seq EP) done v = let ft = FieldType (fromEnum t) wt = toWireType ft fid = fNumber fk- in return (fid,ExtFromWire (Seq.singleton (EP wt (runPut (wirePut ft v)))))+ in return (fid, Seq.singleton (EP wt (runPut (wirePut ft v)))) -- The actual type and value fed to 'done' depends on the values 't' and 'uno': case t of TYPE_ENUM -> -- Now must also also handle Message and Group
hprotoc.cabal view
@@ -1,5 +1,5 @@ name: hprotoc-version: 2.4.11+version: 2.4.12 cabal-version: >= 1.6 build-type: Simple license: BSD3@@ -15,20 +15,21 @@ extra-source-files: README, google-proto-files/google/protobuf/descriptor.proto, google-proto-files/google/protobuf/plugin.proto+Tested-With: GHC == 8.0.2, GHC == 8.2.1, GHC == 8.4.2, GHC == 8.6.2 source-repository head type: git location: git://github.com/k-bx/protocol-buffers.git Executable hprotoc- build-depends: protocol-buffers == 2.4.11,- protocol-buffers-descriptor == 2.4.11+ build-depends: protocol-buffers == 2.4.12,+ protocol-buffers-descriptor == 2.4.12 Main-Is: Text/ProtocolBuffers/ProtoCompile.hs Hs-Source-Dirs: ., protoc-gen-haskell build-tools: alex ghc-options: -O2 -Wall -fspec-constr-count=10 -- ghc-prof-options: -O2 -auto-all -prof- build-depends: base >= 4.7.0 && < 5,+ build-depends: base >= 4.9.0 && < 5, array, binary, bytestring,@@ -69,14 +70,14 @@ TypeSynonymInstances Library- build-depends: protocol-buffers == 2.4.11,- protocol-buffers-descriptor == 2.4.11+ build-depends: protocol-buffers == 2.4.12,+ protocol-buffers-descriptor == 2.4.12 Hs-Source-Dirs: ., protoc-gen-haskell build-tools: alex ghc-options: -O2 -Wall -fspec-constr-count=10 -- ghc-prof-options: -O2 -auto-all -prof- build-depends: base >= 4.7.0 && < 5,+ build-depends: base >= 4.9.0 && < 5, array, binary, bytestring,