diff --git a/src/Proto3/Suite/DotProto/Generate.hs b/src/Proto3/Suite/DotProto/Generate.hs index eaf80104..adc5ec25 100644 --- a/src/Proto3/Suite/DotProto/Generate.hs +++ b/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 @@ -289,7 +298,7 @@ hsModuleForDotProto typeContext <- dotProtoTypeContext dotProto let toDotProtoDeclaration = - dotProtoDefinitionD stringType recordStyle protoPackage (typeContext <> importTypeContext) + dotProtoDefinitionD stringType recordStyle isPrefixed protoPackage (typeContext <> importTypeContext) let extraInstances' = instancesForModule moduleName extraInstances @@ -733,19 +742,20 @@ validMapKey = (`elem` [ Int32, Int64, SInt32, SInt64, UInt32, UInt64 dotProtoDefinitionD :: MonadError CompileError m => StringType -> RecordStyle + -> IsPrefixed -> DotProtoPackageSpec -> TypeContext -> DotProtoDefinition -> m [HsDecl] -dotProtoDefinitionD stringType recordStyle pkgSpec ctxt = \case +dotProtoDefinitionD stringType recordStyle isPrefixed pkgSpec 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 pkgSpec ctxt serviceName serviceParts + dotProtoServiceD stringType isPrefixed pkgSpec ctxt serviceName serviceParts -- | Generate 'Named' instance for a type in this package namedInstD :: String -> HsDecl @@ -774,12 +784,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 = @@ -800,10 +811,10 @@ 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) @@ -811,7 +822,7 @@ dotProtoMessageD stringType recordStyle ctxt parentIdent messageIdent messagePar #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 @@ -843,12 +854,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) ] @@ -858,7 +869,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 @@ -873,7 +884,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 @@ -906,14 +917,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 @@ -1041,14 +1053,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 @@ -1162,14 +1175,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 @@ -1306,6 +1320,7 @@ getFieldNameForSchemaInstanceDeclaration fld = do toSchemaInstanceDeclaration :: MonadError CompileError m => StringType + -> IsPrefixed -> TypeContext -> String -- ^ Name of the message type to create an instance for @@ -1315,10 +1330,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)) @@ -1651,12 +1666,13 @@ dotProtoEnumD parentIdent enumIdent enumParts = do dotProtoServiceD :: MonadError CompileError m => StringType + -> IsPrefixed -> DotProtoPackageSpec -> TypeContext -> DotProtoIdentifier -> [DotProtoServicePart] -> m [HsDecl] -dotProtoServiceD stringType pkgSpec ctxt serviceIdent service = do +dotProtoServiceD stringType isPrefixed pkgSpec ctxt serviceIdent service = do serviceName <- typeLikeName =<< dpIdentUnqualName serviceIdent endpointPrefix <- @@ -1667,7 +1683,7 @@ dotProtoServiceD stringType pkgSpec ctxt serviceIdent service = do DotProtoNoPackage -> pure $ "/" ++ 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 diff --git a/src/Proto3/Suite/DotProto/Internal.hs b/src/Proto3/Suite/DotProto/Internal.hs index a96c07a3..afd441a3 100644 --- a/src/Proto3/Suite/DotProto/Internal.hs +++ b/src/Proto3/Suite/DotProto/Internal.hs @@ -33,6 +33,7 @@ import Data.List (intercalate) import qualified Data.List.NonEmpty as NE import qualified Data.Map as M import Data.Maybe (fromMaybe) +import qualified Data.Set as S import qualified Data.Text as T import Data.Tuple (swap) import qualified NeatInterpolation as Neat @@ -499,6 +500,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 @@ -509,6 +514,15 @@ prefixedMethodName serviceName (x : xs) method <- typeLikeName (x : xs) return (fieldLikeName serviceName ++ method) +prefixedMethodNameWithFlag :: MonadError CompileError m => IsPrefixed -> String -> String -> m String +prefixedMethodNameWithFlag _ _ "" = invalidTypeNameError "" +prefixedMethodNameWithFlag (IsPrefixed flag) serviceName (x : xs) + | flag = prefixedMethodName serviceName (x : xs) + | name `S.member` haskellKeywords = return (name ++ "_") + | otherwise = return name + where + name = (toCamelCase . fieldLikeName) (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 @@ -516,6 +530,22 @@ 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 $ + -- Avoid parse error occurring when the field name matches any of Haskell keywords + if name `S.member` haskellKeywords then name ++ "_" else name + where + name = (toCamelCase . fieldLikeName) fieldName + +haskellKeywords :: S.Set String +haskellKeywords = S.fromList + ["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) @@ -594,11 +624,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 @@ -611,7 +641,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 diff --git a/tests/SimpleDecodeDotProto.hs b/tests/SimpleDecodeDotProto.hs index e07de814..e9074e5e 100644 --- a/tests/SimpleDecodeDotProto.hs +++ b/tests/SimpleDecodeDotProto.hs @@ -2,7 +2,6 @@ {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE RecordWildCards #-} module Main where @@ -98,18 +97,25 @@ testCaseInFormat :: (?format :: Format) => String -> Assertion -> TestTree testCaseInFormat = testCase . (++ ": format " ++ show ?format) testCase1 = testCaseInFormat "Trivial message" $ - do Trivial { .. } <- readProto - trivialTrivialField @?= 0x7BADBEEF + do Trivial trivialField <- readProto + trivialField @?= 0x7BADBEEF testCase2 = testCaseInFormat "Multi-field message" $ - do MultipleFields { .. } <- readProto - - multipleFieldsMultiFieldDouble @?= 1.125 - multipleFieldsMultiFieldFloat @?= 1e9 - multipleFieldsMultiFieldInt32 @?= 0x1135 - multipleFieldsMultiFieldInt64 @?= 0x7FFAFABADDEAFFA0 - multipleFieldsMultiFieldString @?= "Goodnight moon" - multipleFieldsMultiFieldBool @?= False + do MultipleFields + multiFieldDouble + multiFieldFloat + multiFieldInt32 + multiFieldInt64 + multiFieldString + multiFieldBool + <- readProto + + multiFieldDouble @?= 1.125 + multiFieldFloat @?= 1e9 + multiFieldInt32 @?= 0x1135 + multiFieldInt64 @?= 0x7FFAFABADDEAFFA0 + multiFieldString @?= "Goodnight moon" + multiFieldBool @?= False testCaseSignedInts = testCaseInFormat "Signed integer types" $ do expect (SignedInts 0 0) @@ -119,27 +125,27 @@ testCaseSignedInts = testCaseInFormat "Signed integer types" $ expect (SignedInts maxBound maxBound) testCase3 = testCaseInFormat "Nested enumeration" $ - do WithEnum { withEnumEnumField = Enumerated a } <- readProto + do WithEnum (Enumerated a) <- readProto a @?= Right WithEnum_TestEnumENUM1 - WithEnum { withEnumEnumField = Enumerated b } <- readProto + WithEnum (Enumerated b) <- readProto b @?= Right WithEnum_TestEnumENUM2 - WithEnum { withEnumEnumField = Enumerated c } <- readProto + WithEnum (Enumerated c) <- readProto c @?= Right WithEnum_TestEnumENUM3 - WithEnum { withEnumEnumField = Enumerated d } <- readProto + WithEnum (Enumerated d) <- readProto d @?= Left 0xBEEF testCase4 = testCaseInFormat "Nested message" $ - do WithNesting { withNestingNestedMessage = a } <- readProto + do WithNesting a <- readProto a @?= Just (WithNesting_Nested "testCase4 nestedField1" 0xABCD [] []) - WithNesting { withNestingNestedMessage = b } <- readProto + WithNesting b <- readProto b @?= Nothing testCase5 = testCaseInFormat "Nested repeated message" $ - do WithNestingRepeated { withNestingRepeatedNestedMessages = a } <- readProto + do WithNestingRepeated a <- readProto length a @?= 3 let [a1, a2, a3] = a @@ -147,81 +153,81 @@ testCase5 = testCaseInFormat "Nested repeated message" $ a2 @?= WithNestingRepeated_Nested "Hello world" 0x7FFFFFFF [0, 0, 0] [] a3 @?= WithNestingRepeated_Nested "" 0 [] [] - WithNestingRepeated { withNestingRepeatedNestedMessages = b } <- readProto + WithNestingRepeated b <- readProto b @?= [] testCase6 = testCaseInFormat "Nested repeated int message" $ - do WithNestingRepeatedInts { withNestingRepeatedIntsNestedInts = a } <- readProto + do WithNestingRepeatedInts a <- readProto a @?= [ NestedInts 636513 619021 ] - WithNestingRepeatedInts { withNestingRepeatedIntsNestedInts = b } <- readProto + WithNestingRepeatedInts b <- readProto b @?= [] - WithNestingRepeatedInts { withNestingRepeatedIntsNestedInts = c } <- readProto + WithNestingRepeatedInts c <- readProto c @?= [ NestedInts 636513 619021 , NestedInts 423549 687069 , NestedInts 545506 143731 , NestedInts 193605 385360 ] testCase7 = testCaseInFormat "Repeated int32 field" $ - do WithRepetition { withRepetitionRepeatedField1 = a } <- readProto + do WithRepetition a <- readProto a @?= [] - WithRepetition { withRepetitionRepeatedField1 = b } <- readProto + WithRepetition b <- readProto b @?= [1..10000] testCase8 = testCaseInFormat "Fixed-width integer types" $ - do WithFixed { .. } <- readProto - withFixedFixed1 @?= 0 - withFixedFixed2 @?= 0 - withFixedFixed3 @?= 0 - withFixedFixed4 @?= 0 - - WithFixed { .. } <- readProto - withFixedFixed1 @?= maxBound - withFixedFixed2 @?= maxBound - withFixedFixed3 @?= maxBound - withFixedFixed4 @?= maxBound - - WithFixed { .. } <- readProto - withFixedFixed1 @?= minBound - withFixedFixed2 @?= minBound - withFixedFixed3 @?= minBound - withFixedFixed4 @?= minBound + do WithFixed fixed1 fixed2 fixed3 fixed4 <- readProto + fixed1 @?= 0 + fixed2 @?= 0 + fixed3 @?= 0 + fixed4 @?= 0 + + WithFixed fixed1 fixed2 fixed3 fixed4 <- readProto + fixed1 @?= maxBound + fixed2 @?= maxBound + fixed3 @?= maxBound + fixed4 @?= maxBound + + WithFixed fixed1 fixed2 fixed3 fixed4 <- readProto + fixed1 @?= minBound + fixed2 @?= minBound + fixed3 @?= minBound + fixed4 @?= minBound testCase9 = testCaseInFormat "Bytes fields" $ - do WithBytes { .. } <- readProto - withBytesBytes1 @?= "\x00\x00\x00\x01\x02\x03\xFF\xFF\x00\x01" - withBytesBytes2 @?= ["", "\x01", "\xAB\xBAhello", "\xBB"] + do WithBytes bytes1 bytes2 <- readProto + bytes1 @?= "\x00\x00\x00\x01\x02\x03\xFF\xFF\x00\x01" + bytes2 @?= ["", "\x01", "\xAB\xBAhello", "\xBB"] - WithBytes { .. } <- readProto - withBytesBytes1 @?= "Hello world" - withBytesBytes2 @?= [] + WithBytes bytes1 bytes2 <- readProto + bytes1 @?= "Hello world" + bytes2 @?= [] - WithBytes { .. } <- readProto - withBytesBytes1 @?= "" - withBytesBytes2 @?= ["Hello", "\x00world", "\x00\x00"] + WithBytes bytes1 bytes2 <- readProto + bytes1 @?= "" + bytes2 @?= ["Hello", "\x00world", "\x00\x00"] - WithBytes { .. } <- readProto - withBytesBytes1 @?= "" - withBytesBytes2 @?= [] + WithBytes bytes1 bytes2 <- readProto + bytes1 @?= "" + bytes2 @?= [] testCase10 = testCaseInFormat "Packed and unpacked repeated types" $ - do WithPacking { .. } <- readProto - withPackingPacking1 @?= [] - withPackingPacking2 @?= [] + do WithPacking packing1 packing2 <- readProto + packing1 @?= [] + packing2 @?= [] - WithPacking { .. } <- readProto - withPackingPacking1 @?= [100, 2000, 300, 4000, 500, 60000, 7000] - withPackingPacking2 @?= [] + WithPacking packing1 packing2 <- readProto + packing1 @?= [100, 2000, 300, 4000, 500, 60000, 7000] + packing2 @?= [] - WithPacking { .. } <- readProto - withPackingPacking1 @?= [] - withPackingPacking2 @?= [100, 2000, 300, 4000, 500, 60000, 7000] + WithPacking packing1 packing2 <- readProto + packing1 @?= [] + packing2 @?= [100, 2000, 300, 4000, 500, 60000, 7000] - WithPacking { .. } <- readProto - withPackingPacking1 @?= [1, 2, 3, 4, 5] - withPackingPacking2 @?= [5, 4, 3, 2, 1] + WithPacking packing1 packing2 <- readProto + packing1 @?= [1, 2, 3, 4, 5] + packing2 @?= [5, 4, 3, 2, 1] testCase11 = testCaseInFormat "All possible packed types" $ do a <- readProto @@ -249,149 +255,149 @@ testCase11 = testCaseInFormat "All possible packed types" $ testCase12 = testCaseInFormat "Message with out of order field numbers" $ - do OutOfOrderFields { .. } <- readProto - outOfOrderFieldsField1 @?= [] - outOfOrderFieldsField2 @?= "" - outOfOrderFieldsField3 @?= maxBound - outOfOrderFieldsField4 @?= [] - - OutOfOrderFields { .. } <- readProto - outOfOrderFieldsField1 @?= [1,7..100] - outOfOrderFieldsField2 @?= "This is a test" - outOfOrderFieldsField3 @?= minBound - outOfOrderFieldsField4 @?= ["This", "is", "a", "test"] + do OutOfOrderFields field1 field2 field3 field4 <- readProto + field1 @?= [] + field2 @?= "" + field3 @?= maxBound + field4 @?= [] + + OutOfOrderFields field1 field2 field3 field4 <- readProto + field1 @?= [1,7..100] + field2 @?= "This is a test" + field3 @?= minBound + field4 @?= ["This", "is", "a", "test"] testCase13 = testCaseInFormat "Nested message with the same name as another package-level message" $ - do ShadowedMessage { .. } <- readProto - shadowedMessageName @?= "name" - shadowedMessageValue @?= 0x7DADBEEF + do ShadowedMessage name value <- readProto + name @?= "name" + value @?= 0x7DADBEEF - MessageShadower { .. } <- readProto - messageShadowerName @?= "another name" + MessageShadower shadowedMessage name <- readProto + name @?= "another name" -- Until -- is fixed, the Haskell JSONPB parser will fail to find the this -- field under its lowerCamelCase name. Once the fix is available -- we can make the following verification unconditional: when (?format /= Jsonpb) $ - messageShadowerShadowedMessage @?= Just (MessageShadower_ShadowedMessage "name" "string value") + shadowedMessage @?= Just (MessageShadower_ShadowedMessage "name" "string value") - MessageShadower_ShadowedMessage { .. } <- readProto - messageShadower_ShadowedMessageName @?= "another name" - messageShadower_ShadowedMessageValue @?= "another string" + MessageShadower_ShadowedMessage name value <- readProto + name @?= "another name" + value @?= "another string" testCase14 = testCaseInFormat "Qualified name resolution" $ - do WithQualifiedName { .. } <- readProto - withQualifiedNameQname1 @?= Just (ShadowedMessage "int value" 42) - withQualifiedNameQname2 @?= Just (MessageShadower_ShadowedMessage "string value" "hello world") + do WithQualifiedName qname1 qname2 <- readProto + qname1 @?= Just (ShadowedMessage "int value" 42) + qname2 @?= Just (MessageShadower_ShadowedMessage "string value" "hello world") testCase15 = testCaseInFormat "Imported message resolution" $ - do TestProtoImport.WithNesting { .. } <- readProto - withNestingNestedMessage1 @?= Just (TestProtoImport.WithNesting_Nested 1 2) - withNestingNestedMessage2 @?= Nothing + do TestProtoImport.WithNesting message1 message2 <- readProto + message1 @?= Just (TestProtoImport.WithNesting_Nested 1 2) + message2 @?= Nothing testCase16 = testCaseInFormat "Proper resolution of shadowed message names" $ - do UsingImported { .. } <- readProto - usingImportedImportedNesting @?= + do UsingImported importedNesting localNesting <- readProto + importedNesting @?= Just (TestProtoImport.WithNesting (Just (TestProtoImport.WithNesting_Nested 1 2)) (Just (TestProtoImport.WithNesting_Nested 3 4))) - usingImportedLocalNesting @?= Just (WithNesting (Just (WithNesting_Nested "field" 0xBEEF [] []))) + localNesting @?= Just (WithNesting (Just (WithNesting_Nested "field" 0xBEEF [] []))) testCase17 = testCaseInFormat "Oneof" $ do -- Read default values for oneof subfields - do TestProtoOneof.Something{ .. } <- readProto - somethingValue @?= 1 - somethingAnother @?= 2 - somethingPickOne @?= Just (TestProtoOneof.SomethingPickOneName "") - do TestProtoOneof.Something { .. } <- readProto - somethingValue @?= 3 - somethingAnother @?= 4 - somethingPickOne @?= Just (TestProtoOneof.SomethingPickOneSomeid 0) - do TestProtoOneof.Something { .. } <- readProto - somethingValue @?= 5 - somethingAnother @?= 6 - somethingPickOne @?= Just (TestProtoOneof.SomethingPickOneDummyMsg1 + do TestProtoOneof.Something value another pickOne <- readProto + value @?= 1 + another @?= 2 + pickOne @?= Just (TestProtoOneof.SomethingPickOneName "") + do TestProtoOneof.Something value another pickOne <- readProto + value @?= 3 + another @?= 4 + pickOne @?= Just (TestProtoOneof.SomethingPickOneSomeid 0) + do TestProtoOneof.Something value another pickOne <- readProto + value @?= 5 + another @?= 6 + pickOne @?= Just (TestProtoOneof.SomethingPickOneDummyMsg1 (TestProtoOneof.DummyMsg 0)) - do TestProtoOneof.Something { .. } <- readProto - somethingValue @?= 7 - somethingAnother @?= 8 - somethingPickOne @?= Just (TestProtoOneof.SomethingPickOneDummyMsg2 + do TestProtoOneof.Something value another pickOne <- readProto + value @?= 7 + another @?= 8 + pickOne @?= Just (TestProtoOneof.SomethingPickOneDummyMsg2 (TestProtoOneof.DummyMsg 0)) - do TestProtoOneof.Something { .. } <- readProto - somethingValue @?= 9 - somethingAnother @?= 10 - somethingPickOne @?= Just (TestProtoOneof.SomethingPickOneDummyEnum + do TestProtoOneof.Something value another pickOne <- readProto + value @?= 9 + another @?= 10 + pickOne @?= Just (TestProtoOneof.SomethingPickOneDummyEnum (Enumerated (Right TestProtoOneof.DummyEnumDUMMY0))) -- Read non-default values for oneof subfields - do TestProtoOneof.Something{ .. } <- readProto - somethingValue @?= 1 - somethingAnother @?= 2 - somethingPickOne @?= Just (TestProtoOneof.SomethingPickOneName "hello world") - do TestProtoOneof.Something { .. } <- readProto - somethingValue @?= 3 - somethingAnother @?= 4 - somethingPickOne @?= Just (TestProtoOneof.SomethingPickOneSomeid 42) - do TestProtoOneof.Something { .. } <- readProto - somethingValue @?= 5 - somethingAnother @?= 6 - somethingPickOne @?= Just (TestProtoOneof.SomethingPickOneDummyMsg1 + do TestProtoOneof.Something value another pickOne <- readProto + value @?= 1 + another @?= 2 + pickOne @?= Just (TestProtoOneof.SomethingPickOneName "hello world") + do TestProtoOneof.Something value another pickOne <- readProto + value @?= 3 + another @?= 4 + pickOne @?= Just (TestProtoOneof.SomethingPickOneSomeid 42) + do TestProtoOneof.Something value another pickOne <- readProto + value @?= 5 + another @?= 6 + pickOne @?= Just (TestProtoOneof.SomethingPickOneDummyMsg1 (TestProtoOneof.DummyMsg 66)) - do TestProtoOneof.Something { .. } <- readProto - somethingValue @?= 7 - somethingAnother @?= 8 - somethingPickOne @?= Just (TestProtoOneof.SomethingPickOneDummyMsg2 + do TestProtoOneof.Something value another pickOne <- readProto + value @?= 7 + another @?= 8 + pickOne @?= Just (TestProtoOneof.SomethingPickOneDummyMsg2 (TestProtoOneof.DummyMsg 67)) - do TestProtoOneof.Something { .. } <- readProto - somethingValue @?= 9 - somethingAnother @?= 10 - somethingPickOne @?= Just (TestProtoOneof.SomethingPickOneDummyEnum + do TestProtoOneof.Something value another pickOne <- readProto + value @?= 9 + another @?= 10 + pickOne @?= Just (TestProtoOneof.SomethingPickOneDummyEnum (Enumerated (Right TestProtoOneof.DummyEnumDUMMY1))) -- Read with oneof not set - do TestProtoOneof.Something { .. } <- readProto - somethingValue @?= 11 - somethingAnother @?= 12 - somethingPickOne @?= Nothing + do TestProtoOneof.Something value another pickOne <- readProto + value @?= 11 + another @?= 12 + pickOne @?= Nothing testCase18 = testCaseInFormat "Imported Oneof" $ do - do TestProtoOneof.WithImported{ .. } <- readProto - withImportedPickOne @?= Just (TestProtoOneof.WithImportedPickOneDummyMsg1 + do TestProtoOneof.WithImported pickOne <- readProto + pickOne @?= Just (TestProtoOneof.WithImportedPickOneDummyMsg1 (TestProtoOneof.DummyMsg 0)) - do TestProtoOneof.WithImported{ .. } <- readProto - withImportedPickOne @?= Just (TestProtoOneof.WithImportedPickOneDummyMsg1 + do TestProtoOneof.WithImported pickOne <- readProto + pickOne @?= Just (TestProtoOneof.WithImportedPickOneDummyMsg1 (TestProtoOneof.DummyMsg 68)) - do TestProtoOneof.WithImported{ .. } <- readProto - withImportedPickOne @?= Just (TestProtoOneof.WithImportedPickOneWithOneof + do TestProtoOneof.WithImported pickOne <- readProto + pickOne @?= Just (TestProtoOneof.WithImportedPickOneWithOneof (TestProtoOneofImport.WithOneof Nothing)) - do TestProtoOneof.WithImported{ .. } <- readProto - withImportedPickOne @?= Just (TestProtoOneof.WithImportedPickOneWithOneof + do TestProtoOneof.WithImported pickOne <- readProto + pickOne @?= Just (TestProtoOneof.WithImportedPickOneWithOneof (TestProtoOneofImport.WithOneof (Just (TestProtoOneofImport.WithOneofPickOneA "")))) - do TestProtoOneof.WithImported{ .. } <- readProto - withImportedPickOne @?= Just (TestProtoOneof.WithImportedPickOneWithOneof + do TestProtoOneof.WithImported pickOne <- readProto + pickOne @?= Just (TestProtoOneof.WithImportedPickOneWithOneof (TestProtoOneofImport.WithOneof (Just (TestProtoOneofImport.WithOneofPickOneB 0)))) - do TestProtoOneof.WithImported{ .. } <- readProto - withImportedPickOne @?= Just (TestProtoOneof.WithImportedPickOneWithOneof + do TestProtoOneof.WithImported pickOne <- readProto + pickOne @?= Just (TestProtoOneof.WithImportedPickOneWithOneof (TestProtoOneofImport.WithOneof (Just (TestProtoOneofImport.WithOneofPickOneA "foo")))) - do TestProtoOneof.WithImported{ .. } <- readProto - withImportedPickOne @?= Just (TestProtoOneof.WithImportedPickOneWithOneof + do TestProtoOneof.WithImported pickOne <- readProto + pickOne @?= Just (TestProtoOneof.WithImportedPickOneWithOneof (TestProtoOneofImport.WithOneof (Just (TestProtoOneofImport.WithOneofPickOneB 19)))) - do TestProtoOneof.WithImported{ .. } <- readProto - withImportedPickOne @?= Nothing + do TestProtoOneof.WithImported pickOne <- readProto + pickOne @?= Nothing testCase19 = testCaseInFormat "Maps" $ do result <- readProto let wt = Just . WrappedTrivial . Just . Trivial - let expected = MapTest{ mapTestPrim = M.fromList [("foo", 1),("bar", 42),("baz", 1234567)] - -- The python implementation forbids serialising map entries - -- with 'None' as the value (dynamic type error). - , mapTestTrivial = M.fromList [(1, wt 1),(2, wt 42),(101, wt 1234567), (79, Just (WrappedTrivial Nothing))] - , mapTestSigned = M.fromList [(1,2),(3,4),(5,6)] - } + -- The python implementation forbids serialising map entries + -- with 'None' as the value (dynamic type error). + let prim = M.fromList [("foo", 1),("bar", 42),("baz", 1234567)] + trivial = M.fromList [(1, wt 1),(2, wt 42),(101, wt 1234567), (79, Just (WrappedTrivial Nothing))] + signed = M.fromList [(1,2),(3,4),(5,6)] + let expected = MapTest prim trivial signed result @?= expected testCase_DoubleValue = testCaseInFormat "DoubleValue" $ do @@ -452,5 +458,5 @@ testCase_BytesValue = testCaseInFormat "BytesValue" $ do allTestsDone = testCaseInFormat "Receive end of test suite sentinel message" $ - do MultipleFields{..} <- readProto - multipleFieldsMultiFieldString @?= "All tests complete" + do MultipleFields _ _ _ _ multiFieldString _ <- readProto + multiFieldString @?= "All tests complete" diff --git a/tests/SimpleEncodeDotProto.hs b/tests/SimpleEncodeDotProto.hs index 97c36a99..27ed54a5 100644 --- a/tests/SimpleEncodeDotProto.hs +++ b/tests/SimpleEncodeDotProto.hs @@ -142,33 +142,29 @@ testCase14 = testCase15 :: (?format :: Format) => IO () testCase15 = - outputMessage + outputMessage $ TestProtoImport.WithNesting - { TestProtoImport.withNestingNestedMessage1 = - Just TestProtoImport.WithNesting_Nested - { TestProtoImport.withNesting_NestedNestedField1 = 1 - , TestProtoImport.withNesting_NestedNestedField2 = 2 - } - , TestProtoImport.withNestingNestedMessage2 = Nothing - } + (Just $ TestProtoImport.WithNesting_Nested nestedField1 nestedField2) + nestedMessage2 + where + nestedField1 = 1 + nestedField2 = 2 + nestedMessage2 = Nothing testCase16 :: (?format :: Format) => IO () testCase16 = - outputMessage (UsingImported { usingImportedImportedNesting = - Just (TestProtoImport.WithNesting - (Just (TestProtoImport.WithNesting_Nested 1 2)) - (Just (TestProtoImport.WithNesting_Nested 3 4))) - , usingImportedLocalNesting = - Just (WithNesting (Just (WithNesting_Nested "field" 0xBEEF [] []))) }) + outputMessage (UsingImported importedNesting localNesting) + where + importedNesting = Just (TestProtoImport.WithNesting + (Just (TestProtoImport.WithNesting_Nested 1 2)) + (Just (TestProtoImport.WithNesting_Nested 3 4))) + localNesting = Just (WithNesting (Just (WithNesting_Nested "field" 0xBEEF [] []))) testCase17 :: (?format :: Format) => IO () testCase17 = do - let emit v a p = outputMessage - TestProtoOneof.Something - { TestProtoOneof.somethingValue = v - , TestProtoOneof.somethingAnother = a - , TestProtoOneof.somethingPickOne = p - } + let emit v a p = outputMessage $ + TestProtoOneof.Something v a p + -- Send default values for oneof subfields emit 1 2 $ Just $ TestProtoOneof.SomethingPickOneName "" emit 3 4 $ Just $ TestProtoOneof.SomethingPickOneSomeid 0 @@ -204,10 +200,10 @@ testCase18 = do testCase19 :: (?format :: Format) => IO () testCase19 = do let wt = Just . WrappedTrivial . Just . Trivial - outputMessage MapTest{ mapTestPrim = M.fromList [("foo", 1),("bar", 42),("baz", 1234567)] - , mapTestTrivial = M.fromList $ [(1, wt 1),(2, wt 42),(101, wt 1234567)] ++ (if ?format == Jsonpb then [] else [(79, Nothing)]) - , mapTestSigned = M.fromList [(1,2),(3,4),(5,6)] - } + let prim = M.fromList [("foo", 1),("bar", 42),("baz", 1234567)] + trivial = M.fromList $ [(1, wt 1),(2, wt 42),(101, wt 1234567)] ++ (if ?format == Jsonpb then [] else [(79, Nothing)]) + signed = M.fromList [(1,2),(3,4),(5,6)] + outputMessage $ MapTest prim trivial signed testCase_DoubleValue :: (?format :: Format) => IO () testCase_DoubleValue = do diff --git a/tests/TestCodeGen.hs b/tests/TestCodeGen.hs index 1fa5eb7e..1e59b0d4 100644 --- a/tests/TestCodeGen.hs +++ b/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) + ", record style " ++ show recStyle ++ ", prefix flag is " ++ show isPrefixedArg) $ 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) + ", record style " ++ show recStyle ++ ", prefix flag is " ++ show isPrefixedArg) $ 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=" diff --git a/tools/compile-proto-file/Main.hs b/tools/compile-proto-file/Main.hs index 5007b1e0..1010e256 100644 --- a/tools/compile-proto-file/Main.hs +++ b/tools/compile-proto-file/Main.hs @@ -15,7 +15,7 @@ import Proto3.Suite.DotProto.Generate parseArgs :: ParserInfo CompileArgs parseArgs = info (helper <*> parser) (fullDesc <> progDesc "Compiles a .proto file to a Haskell module") where - parser = CompileArgs <$> includes <*> extraInstances <*> proto <*> out <*> stringType <*> recordStyle + parser = CompileArgs <$> includes <*> extraInstances <*> proto <*> out <*> stringType <*> recordStyle <*> isPrefixed includes = many $ strOption $ long "includeDir" @@ -47,5 +47,10 @@ parseArgs = info (helper <*> parser) (fullDesc <> progDesc "Compiles a .proto fi $ long "largeRecords" <> help "Use large-records library to optimize the core code size of generated records" + isPrefixed = IsPrefixed . not <$> switch ( + long "no-field-prefix" + <> help "Do not prefix type names to record field names" + ) + main :: IO () main = execParser parseArgs >>= compileDotProtoFileOrDie