Add --no-field-prefix

src/Proto3/Suite/DotProto/Generate.hs

@@ -25,6 +25,7 @@ module Proto3.Suite.DotProto.Generate
   ( CompileError(..)
   , StringType(..)
   , RecordStyle (..)
+  , IsPrefixed(..)
   , parseStringType
   , TypeContext
   , CompileArgs(..)
@@ -83,6 +84,7 @@ data CompileArgs = CompileArgs
   , outputDir          :: FilePath
   , stringType         :: StringType
   , recordStyle        :: RecordStyle
+  , isPrefixed         :: IsPrefixed
   }
 
 data StringType = StringType String String
@@ -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
@@ -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
@@ -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"
@@ -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
@@ -264,6 +272,7 @@ hsModuleForDotProto
 hsModuleForDotProto
     stringType
     recordStyle
+    isPrefixed
     (extraImports, extraInstances)
     dotProto@DotProto{ protoMeta = DotProtoMeta { metaModulePath = modulePath }
                      , protoPackage
@@ -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
 
@@ -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
@@ -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 =
@@ -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
 
@@ -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) ]
@@ -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
@@ -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
 
@@ -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
@@ -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
@@ -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
 
@@ -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
@@ -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))
 
@@ -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

src/Proto3/Suite/DotProto/Internal.hs

@@ -498,6 +498,8 @@ prefixedConName msgName conName = do
   constructor <- typeLikeName conName
   return (msgName ++ constructor)
 
+newtype IsPrefixed = IsPrefixed Bool
+
 -- | @'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
@@ -508,13 +510,24 @@ 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)
+
 -- | @'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 fieldName
+
 dpIdentUnqualName :: MonadError CompileError m => DotProtoIdentifier -> m String
 dpIdentUnqualName (Single name)       = pure name
 dpIdentUnqualName (Dots (Path names)) = pure (NE.last names)
@@ -593,11 +606,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
@@ -610,7 +623,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

tests/TestCodeGen.hs

@@ -51,10 +51,11 @@ pythonInteroperation = testGroup "Python interoperation" $ do
 #else
   recStyle <- [RegularRecords]
 #endif
+  isPrefixedArg <- [IsPrefixed True, IsPrefixed False]
   tt <- ["Data.Text.Lazy.Text", "Data.Text.Text", "Data.Text.Short.ShortText"]
   format <- ["Binary", "Jsonpb"]
   direction <- [simpleEncodeDotProto, simpleDecodeDotProto]
-  pure @[] (direction recStyle tt format)
+  pure @[] (direction recStyle isPrefixedArg tt format)
 
 swaggerWrapperFormat :: TestTree
 swaggerWrapperFormat = testGroup "Swagger Wrapper Format"
@@ -164,15 +165,15 @@ setPythonPath :: IO ()
 setPythonPath = Turtle.export "PYTHONPATH" .
   maybe pyTmpDir (\p -> pyTmpDir <> ":" <> p) =<< Turtle.need "PYTHONPATH"
 
-simpleEncodeDotProto :: RecordStyle -> String -> T.Text -> TestTree
-simpleEncodeDotProto recStyle chosenStringType format =
+simpleEncodeDotProto :: RecordStyle -> IsPrefixed  ->  String -> T.Text -> TestTree
+simpleEncodeDotProto recStyle isPrefixedArg chosenStringType format =
     testCase ("generate code for a simple .proto and then use it to encode messages" ++
               " with string type " ++ chosenStringType ++ " in format " ++ show format ++
               ", record style " ++ show recStyle)
     $ do
          decodedStringType <- either die pure (parseStringType chosenStringType)
 
-         compileTestDotProtos recStyle decodedStringType
+         compileTestDotProtos recStyle isPrefixedArg decodedStringType
          -- Compile our generated encoder
          let args = [hsTmpDir]
 #if DHALL
@@ -190,15 +191,15 @@ simpleEncodeDotProto recStyle chosenStringType format =
          Turtle.rmtree hsTmpDir
          Turtle.rmtree pyTmpDir
 
-simpleDecodeDotProto :: RecordStyle -> String -> T.Text -> TestTree
-simpleDecodeDotProto recStyle chosenStringType format =
+simpleDecodeDotProto :: RecordStyle -> IsPrefixed ->  String -> T.Text -> TestTree
+simpleDecodeDotProto recStyle isPrefixedArg chosenStringType format =
     testCase ("generate code for a simple .proto and then use it to decode messages" ++
               " with string type " ++ chosenStringType ++ " in format " ++ show format ++
               ", record style " ++ show recStyle)
     $ do
          decodedStringType <- either die pure (parseStringType chosenStringType)
 
-         compileTestDotProtos recStyle decodedStringType
+         compileTestDotProtos recStyle isPrefixedArg decodedStringType
          -- Compile our generated decoder
          let args = [hsTmpDir]
 #if DHALL
@@ -223,8 +224,8 @@ pyTmpDir = "test-files/py-tmp"
 defaultStringType :: StringType
 defaultStringType = StringType "Data.Text.Lazy" "Text"
 
-compileTestDotProtos :: RecordStyle -> StringType -> IO ()
-compileTestDotProtos recStyle decodedStringType = do
+compileTestDotProtos :: RecordStyle -> IsPrefixed ->  StringType -> IO ()
+compileTestDotProtos recStyle isPrefixedArg decodedStringType = do
   Turtle.mktree hsTmpDir
   Turtle.mktree pyTmpDir
   let protoFiles =
@@ -248,6 +249,7 @@ compileTestDotProtos recStyle decodedStringType = do
                    , inputProto = protoFile
                    , stringType = decodedStringType
                    , recordStyle = recStyle
+                   , isPrefixed = isPrefixedArg
                    }
 
     let cmd = T.concat [ "protoc --python_out="