Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add --no-field-prefix option #228

Open
wants to merge 6 commits into
base: master
Choose a base branch
from
+283 −228
Open

Add --no-field-prefix option #228

Show file tree
Hide file tree
Changes from 2 commits
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
8ee46de
Add `--no-field-prefix`
ccycle Feb 20, 2023
9197b19
Remove field selectors in tests
ccycle Feb 8, 2023
70cead3
Use `Set` in keywords list
ccycle Apr 21, 2023
3e7b7ed
Add keyword check
ccycle Apr 27, 2023
4fc88a7
Merge commit 'b0a3308d9d1b1b070c371f90de984ff192020537' into no-field…
ccycle Jun 26, 2023
58acd42
Fix help message
ccycle Jun 26, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
68 changes: 42 additions & 26 deletions src/Proto3/Suite/DotProto/Generate.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -25,6 +25,7 @@ module Proto3.Suite.DotProto.Generate
( CompileError(..)
, StringType(..)
, RecordStyle (..)
, IsPrefixed(..)
, parseStringType
, TypeContext
, CompileArgs(..)
Expand Down Expand Up @@ -83,6 +84,7 @@ data CompileArgs = CompileArgs
, outputDir :: FilePath
, stringType :: StringType
, recordStyle :: RecordStyle
, isPrefixed :: IsPrefixed
}

data StringType = StringType String String
Expand Down Expand Up @@ -110,7 +112,7 @@ compileDotProtoFile CompileArgs{..} = runExceptT $ do
Turtle.mktree (Turtle.directory modulePath)

extraInstances <- foldMapM getExtraInstances extraInstanceFiles
haskellModule <- renderHsModuleForDotProto stringType recordStyle extraInstances dotProto importTypeContext
haskellModule <- renderHsModuleForDotProto stringType recordStyle isPrefixed extraInstances dotProto importTypeContext

liftIO (writeFile (Turtle.encodeString modulePath) haskellModule)
where
Expand Down Expand Up @@ -182,9 +184,10 @@ renderHsModuleForDotProto
:: MonadError CompileError m
=> StringType
-> RecordStyle
-> IsPrefixed
-> ([HsImportDecl],[HsDecl]) -> DotProto -> TypeContext -> m String
renderHsModuleForDotProto stringType recordStyle extraInstanceFiles dotProto importCtxt = do
haskellModule <- hsModuleForDotProto stringType recordStyle extraInstanceFiles dotProto importCtxt
renderHsModuleForDotProto stringType recordStyle isPrefixed extraInstanceFiles dotProto importCtxt = do
haskellModule <- hsModuleForDotProto stringType recordStyle isPrefixed extraInstanceFiles dotProto importCtxt

let languagePragmas = textUnlines $ map (\extn -> "{-# LANGUAGE " <> extn <> " #-}") $ sort extensions
ghcOptionPragmas = textUnlines $ map (\opt -> "{-# OPTIONS_GHC " <> opt <> " #-}") $ sort options
Expand All @@ -207,6 +210,9 @@ renderHsModuleForDotProto stringType recordStyle extraInstanceFiles dotProto imp
, "TypeFamilies"
, "UndecidableInstances"
]
++ case isPrefixed of
IsPrefixed True -> []
IsPrefixed False -> ["DuplicateRecordFields"]

options :: [T.Text]
options = [ "-fno-warn-unused-imports"
Expand Down Expand Up @@ -254,6 +260,8 @@ hsModuleForDotProto
-- ^ the module and the type for string
-> RecordStyle
-- ^ kind of records to generate
-> IsPrefixed
-- ^ flag for prefix of field names
-> ([HsImportDecl], [HsDecl])
-- ^ Extra user-define instances that override default generated instances
-> DotProto
Expand All @@ -264,6 +272,7 @@ hsModuleForDotProto
hsModuleForDotProto
stringType
recordStyle
isPrefixed
(extraImports, extraInstances)
dotProto@DotProto{ protoMeta = DotProtoMeta { metaModulePath = modulePath }
, protoPackage
Expand All @@ -290,7 +299,7 @@ hsModuleForDotProto
typeContext <- dotProtoTypeContext dotProto

let toDotProtoDeclaration =
dotProtoDefinitionD stringType recordStyle packageIdentifier (typeContext <> importTypeContext)
dotProtoDefinitionD stringType recordStyle isPrefixed packageIdentifier (typeContext <> importTypeContext)

let extraInstances' = instancesForModule moduleName extraInstances

Expand Down Expand Up @@ -729,16 +738,17 @@ validMapKey = (`elem` [ Int32, Int64, SInt32, SInt64, UInt32, UInt64
dotProtoDefinitionD :: MonadError CompileError m
=> StringType
-> RecordStyle
-> IsPrefixed
-> DotProtoIdentifier -> TypeContext -> DotProtoDefinition -> m [HsDecl]
dotProtoDefinitionD stringType recordStyle pkgIdent ctxt = \case
dotProtoDefinitionD stringType recordStyle isPrefixed pkgIdent ctxt = \case
DotProtoMessage _ messageName messageParts ->
dotProtoMessageD stringType recordStyle ctxt Anonymous messageName messageParts
dotProtoMessageD stringType recordStyle isPrefixed ctxt Anonymous messageName messageParts

DotProtoEnum _ enumName enumParts ->
dotProtoEnumD Anonymous enumName enumParts

DotProtoService _ serviceName serviceParts ->
dotProtoServiceD stringType pkgIdent ctxt serviceName serviceParts
dotProtoServiceD stringType isPrefixed pkgIdent ctxt serviceName serviceParts

-- | Generate 'Named' instance for a type in this package
namedInstD :: String -> HsDecl
Expand Down Expand Up @@ -767,12 +777,13 @@ dotProtoMessageD
. MonadError CompileError m
=> StringType
-> RecordStyle
-> IsPrefixed
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m [HsDecl]
dotProtoMessageD stringType recordStyle ctxt parentIdent messageIdent messageParts = do
dotProtoMessageD stringType recordStyle isPrefixed ctxt parentIdent messageIdent messageParts = do
messageName <- qualifiedMessageName parentIdent messageIdent

let mkDataDecl flds =
Expand All @@ -793,18 +804,18 @@ dotProtoMessageD stringType recordStyle ctxt parentIdent messageIdent messagePar
, pure (nfDataInstD messageDataDecl messageName)
, pure (namedInstD messageName)
, pure (hasDefaultInstD messageName)
, messageInstD stringType ctxt' parentIdent messageIdent messageParts
, messageInstD stringType isPrefixed ctxt' parentIdent messageIdent messageParts

, toJSONPBMessageInstD stringType ctxt' parentIdent messageIdent messageParts
, fromJSONPBMessageInstD stringType ctxt' parentIdent messageIdent messageParts
, toJSONPBMessageInstD stringType isPrefixed ctxt' parentIdent messageIdent messageParts
, fromJSONPBMessageInstD stringType isPrefixed ctxt' parentIdent messageIdent messageParts

-- Generate Aeson instances in terms of JSONPB instances
, pure (toJSONInstDecl messageName)
, pure (fromJSONInstDecl messageName)

#ifdef SWAGGER
-- And the Swagger ToSchema instance corresponding to JSONPB encodings
, toSchemaInstanceDeclaration stringType ctxt' messageName Nothing
, toSchemaInstanceDeclaration stringType isPrefixed ctxt' messageName Nothing
=<< foldMapM getName messageParts
#endif

Expand Down Expand Up @@ -836,12 +847,12 @@ dotProtoMessageD stringType recordStyle ctxt parentIdent messageIdent messagePar

messagePartFieldD :: String -> DotProtoMessagePart -> m [([HsName], HsBangType)]
messagePartFieldD messageName (DotProtoMessageField DotProtoField{..}) = do
fullName <- prefixedFieldName messageName =<< dpIdentUnqualName dotProtoFieldName
fullName <- prefixedFieldNameWithFlag isPrefixed messageName =<< dpIdentUnqualName dotProtoFieldName
fullTy <- dptToHsType WithinMessage stringType ctxt' dotProtoFieldType
pure [ ([HsIdent fullName], HsUnBangedTy fullTy ) ]

messagePartFieldD messageName (DotProtoMessageOneOf fieldName _) = do
fullName <- prefixedFieldName messageName =<< dpIdentUnqualName fieldName
fullName <- prefixedFieldNameWithFlag isPrefixed messageName =<< dpIdentUnqualName fieldName
qualTyName <- prefixedConName messageName =<< dpIdentUnqualName fieldName
let fullTy = HsTyApp (HsTyCon (haskellName "Maybe")) . type_ $ qualTyName
pure [ ([HsIdent fullName], HsUnBangedTy fullTy) ]
Expand All @@ -851,7 +862,7 @@ dotProtoMessageD stringType recordStyle ctxt parentIdent messageIdent messagePar
nestedDecls :: DotProtoDefinition -> m [HsDecl]
nestedDecls (DotProtoMessage _ subMsgName subMessageDef) = do
parentIdent' <- concatDotProtoIdentifier parentIdent messageIdent
dotProtoMessageD stringType recordStyle ctxt' parentIdent' subMsgName subMessageDef
dotProtoMessageD stringType recordStyle isPrefixed ctxt' parentIdent' subMsgName subMessageDef

nestedDecls (DotProtoEnum _ subEnumName subEnumDef) = do
parentIdent' <- concatDotProtoIdentifier parentIdent messageIdent
Expand All @@ -866,7 +877,7 @@ dotProtoMessageD stringType recordStyle ctxt parentIdent messageIdent messagePar
(cons, idents) <- fmap unzip (mapM (oneOfCons fullName) fields)

#ifdef SWAGGER
toSchemaInstance <- toSchemaInstanceDeclaration stringType ctxt' fullName (Just idents)
toSchemaInstance <- toSchemaInstanceDeclaration stringType isPrefixed ctxt' fullName (Just idents)
=<< mapM getFieldNameForSchemaInstanceDeclaration fields
#endif

Expand Down Expand Up @@ -899,14 +910,15 @@ messageInstD
:: forall m
. MonadError CompileError m
=> StringType
-> IsPrefixed
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
messageInstD stringType ctxt parentIdent msgIdent messageParts = do
messageInstD stringType isPrefixed ctxt parentIdent msgIdent messageParts = do
msgName <- qualifiedMessageName parentIdent msgIdent
qualifiedFields <- getQualifiedFields msgName messageParts
qualifiedFields <- getQualifiedFields isPrefixed msgName messageParts

encodedFields <- mapM encodeMessageField qualifiedFields
decodedFields <- mapM decodeMessageField qualifiedFields
Expand Down Expand Up @@ -1034,14 +1046,15 @@ toJSONPBMessageInstD
:: forall m
. MonadError CompileError m
=> StringType
-> IsPrefixed
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
toJSONPBMessageInstD stringType ctxt parentIdent msgIdent messageParts = do
toJSONPBMessageInstD stringType isPrefixed ctxt parentIdent msgIdent messageParts = do
msgName <- qualifiedMessageName parentIdent msgIdent
qualFields <- getQualifiedFields msgName messageParts
qualFields <- getQualifiedFields isPrefixed msgName messageParts

let applyE nm oneofNm = do
fs <- traverse (encodeMessageField oneofNm) qualFields
Expand Down Expand Up @@ -1155,14 +1168,15 @@ fromJSONPBMessageInstD
:: forall m
. MonadError CompileError m
=> StringType
-> IsPrefixed
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
fromJSONPBMessageInstD stringType ctxt parentIdent msgIdent messageParts = do
fromJSONPBMessageInstD stringType isPrefixed ctxt parentIdent msgIdent messageParts = do
msgName <- qualifiedMessageName parentIdent msgIdent
qualFields <- getQualifiedFields msgName messageParts
qualFields <- getQualifiedFields isPrefixed msgName messageParts

fieldParsers <- traverse parseField qualFields

Expand Down Expand Up @@ -1299,6 +1313,7 @@ getFieldNameForSchemaInstanceDeclaration fld = do
toSchemaInstanceDeclaration
:: MonadError CompileError m
=> StringType
-> IsPrefixed
-> TypeContext
-> String
-- ^ Name of the message type to create an instance for
Expand All @@ -1308,10 +1323,10 @@ toSchemaInstanceDeclaration
-- ^ Field names, with every field that is not actually a oneof
-- combining fields paired with its options and protobuf type
-> m HsDecl
toSchemaInstanceDeclaration stringType ctxt messageName maybeConstructors fieldNamesEtc = do
toSchemaInstanceDeclaration stringType isPrefixed ctxt messageName maybeConstructors fieldNamesEtc = do
let fieldNames = map snd fieldNamesEtc

qualifiedFieldNames <- mapM (prefixedFieldName messageName) fieldNames
qualifiedFieldNames <- mapM (prefixedFieldNameWithFlag isPrefixed messageName) fieldNames

let messageConstructor = HsCon (UnQual (HsIdent messageName))

Expand Down Expand Up @@ -1644,19 +1659,20 @@ dotProtoEnumD parentIdent enumIdent enumParts = do
dotProtoServiceD
:: MonadError CompileError m
=> StringType
-> IsPrefixed
-> DotProtoIdentifier
-> TypeContext
-> DotProtoIdentifier
-> [DotProtoServicePart]
-> m [HsDecl]
dotProtoServiceD stringType pkgIdent ctxt serviceIdent service = do
dotProtoServiceD stringType isPrefixed pkgIdent ctxt serviceIdent service = do
serviceName <- typeLikeName =<< dpIdentUnqualName serviceIdent
packageName <- dpIdentQualName pkgIdent

let endpointPrefix = "/" ++ packageName ++ "." ++ serviceName ++ "/"

let serviceFieldD (DotProtoServiceRPCMethod RPCMethod{..}) = do
fullName <- prefixedMethodName serviceName =<< dpIdentUnqualName rpcMethodName
fullName <- prefixedMethodNameWithFlag isPrefixed serviceName =<< dpIdentUnqualName rpcMethodName

methodName <- case rpcMethodName of
Single nm -> pure nm
Expand Down
33 changes: 29 additions & 4 deletions src/Proto3/Suite/DotProto/Internal.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -498,6 +498,10 @@ prefixedConName msgName conName = do
constructor <- typeLikeName conName
return (msgName ++ constructor)

newtype IsPrefixed = IsPrefixed Bool
instance Show IsPrefixed where
show (IsPrefixed b) = show b

-- | @'prefixedMethodName' service method@ produces a Haskell record selector name for the service method @method@ by
-- joining the names @service@, @method@ under concatenation on a camel-casing transformation.
prefixedMethodName :: MonadError CompileError m => String -> String -> m String
Expand All @@ -508,13 +512,34 @@ prefixedMethodName serviceName (x : xs)
method <- typeLikeName (x : xs)
return (fieldLikeName serviceName ++ method)

prefixedMethodNameWithFlag :: MonadError CompileError m => IsPrefixed -> String -> String -> m String
prefixedMethodNameWithFlag _ _ "" = invalidTypeNameError "<empty name>"
prefixedMethodNameWithFlag (IsPrefixed flag) serviceName (x : xs)
| flag = prefixedMethodName serviceName (x : xs)
| isLower x = return (fieldLikeName (x : xs))
| otherwise = fieldLikeName <$> typeLikeName (x : xs)

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Do you need a keyword check in this function too?

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is needed for the same reason in this comment (#228 (comment)), since the function is used in generating service field name and needed to avoid parse error.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

OK, so if it is needed, then could you add it?

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Thank you for your comment, I added a commit including changes you requested. Could you please review for that?

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Does prefixedMethodNameWithFlag also need a keyword check?

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@j6carey Sorry I forgot including the commit, I'll add it.

@riz0id Thank you for the review. I'm not sure I follow your opinion correctly, but I also agree adding hs_name option and removing the part of my changes to avoid colliding with keywords.

I strongly suggest not trying to do any case convention changes and just use the name of service methods and message fields that are provided in the protobuf source. I can't think of any situations where there is a benefit to modifying the lexical content names. Also, theres no function that exists that can convert snake case to camel case without opening up the potential for unintended name shadowing in the code generator.

I have a question about this part. In this PR, should the use of toCamelCase be avoided, or allowed temporally to consider that it will be removed in the future?

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

In this PR and until we have a hs_name option, we should stick to the naming convention rules that the rest of proto3-suite uses for record selector names which is what you do here with toCamelCase. In the future though, when we have facilities to override names in generated Haskell code, we will probably make breaking changes to instead use snake case for records. Currently the number of edge cases that need to be considered in order to rename protobuf names to camel case Haskell identifiers is getting out of hand. Using snake case record selectors makes a lot more sense (imo) since:

  1. Protobuf suggests snake case for message field names by convention.
  2. Snake case would not require specific rules to avoid collisions with keywords or double underscores (i.e. "__").
  3. Many people (myself included) already use snake case by convention to distinguish record selectors from ordinary functions.

tldr; Yes use toCamelCase for now, but once proto3-suite supports a hs_name option expect breaking changes that use snake case for message field names.

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@riz0id OK, thanks. I also think that it is nice to control field selector names with the hs_name option and use snake case record selectors.

@j6carey I added some changes, could you take a look at this?

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

My concerns have been addressed, but @riz0id , did you want the keyword checks eliminated, or are they OK until hs_name is available?

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@riz0id Do you have any remaining concerns?

-- | @'prefixedFieldName' prefix field@ constructs a Haskell record selector name by prepending @prefix@ in camel-case
-- to the message field/service method name @field@.
prefixedFieldName :: MonadError CompileError m => String -> String -> m String
prefixedFieldName msgName fieldName = do
field <- typeLikeName fieldName
return (fieldLikeName msgName ++ field)

prefixedFieldNameWithFlag :: MonadError CompileError m => IsPrefixed -> String -> String -> m String
prefixedFieldNameWithFlag (IsPrefixed flag) msgName fieldName = do
if flag then prefixedFieldName msgName fieldName else return $ if name `elem` keywords then name ++ "_" else toCamelCase fieldName
where
name = fieldLikeName fieldName
-- copy from https://hackage.haskell.org/package/hscolour-1.20.3/docs/src/Language-Haskell-HsColour-Classify.html#keywords
-- and remove "forall", "qualified", "ccall", "as", "safe", "unsafe"
j6carey marked this conversation as resolved.
Show resolved Hide resolved
keywords =
["case","class","data","default","deriving","do","else"
,"if","import","in","infix","infixl","infixr","instance","let","module"
,"newtype","of","then","type","where","_"
,"foreign"
]

dpIdentUnqualName :: MonadError CompileError m => DotProtoIdentifier -> m String
dpIdentUnqualName (Single name) = pure name
dpIdentUnqualName (Dots (Path names)) = pure (NE.last names)
Expand Down Expand Up @@ -593,11 +618,11 @@ data OneofSubfield = OneofSubfield
} deriving Show

getQualifiedFields :: MonadError CompileError m
=> String -> [DotProtoMessagePart] -> m [QualifiedField]
getQualifiedFields msgName msgParts = flip foldMapM msgParts $ \case
=> IsPrefixed -> String -> [DotProtoMessagePart] -> m [QualifiedField]
getQualifiedFields isPrefixed msgName msgParts = flip foldMapM msgParts $ \case
DotProtoMessageField DotProtoField{..} -> do
fieldName <- dpIdentUnqualName dotProtoFieldName
qualName <- prefixedFieldName msgName fieldName
qualName <- prefixedFieldNameWithFlag isPrefixed msgName fieldName
pure . (:[]) $ QualifiedField { recordFieldName = coerce qualName
, fieldInfo = FieldNormal (coerce fieldName)
dotProtoFieldNumber
Expand All @@ -610,7 +635,7 @@ getQualifiedFields msgName msgParts = flip foldMapM msgParts $ \case

DotProtoMessageOneOf oneofIdent fields -> do
ident <- dpIdentUnqualName oneofIdent
oneofName <- prefixedFieldName msgName ident
oneofName <- prefixedFieldNameWithFlag isPrefixed msgName ident
oneofTypeName <- prefixedConName msgName ident

let mkSubfield DotProtoField{..} = do
Expand Down
Loading