diff --git a/README.md b/README.md index ac9c73f4..9f12a4c8 100644 --- a/README.md +++ b/README.md @@ -96,7 +96,7 @@ will generate the haskell files `Proto/Project/{Foo,Bar}.hs`. - Services are not supported. - Extensions (proto2-only) are not supported. -- Unknown enum values cause a decoding error, instead of being preserved +- Unknown proto2 enum values cause a decoding error, instead of being preserved round-trip. - Messages with proto3 syntax preserve unknown fields, the same as for proto2. This behavior tracks a [recent change to the specification](google/protobuf#272). diff --git a/proto-lens-protoc/src/Data/ProtoLens/Compiler/Combinators.hs b/proto-lens-protoc/src/Data/ProtoLens/Compiler/Combinators.hs index f4d4a930..4055465d 100644 --- a/proto-lens-protoc/src/Data/ProtoLens/Compiler/Combinators.hs +++ b/proto-lens-protoc/src/Data/ProtoLens/Compiler/Combinators.hs @@ -72,15 +72,28 @@ patSynSig n t = Syntax.PatSynSig () n Nothing Nothing Nothing t patSyn :: Pat -> Pat -> Decl patSyn p1 p2 = Syntax.PatSyn () p1 p2 Syntax.ImplicitBidirectional -dataDecl :: Name -> [ConDecl] -> [QName] -> Decl +dataDecl :: Name -> [ConDecl] -> Deriving -> Decl dataDecl name conDecls derives = Syntax.DataDecl () (Syntax.DataType ()) Nothing (Syntax.DHead () name) [Syntax.QualConDecl () Nothing Nothing q | q <- conDecls] - $ Just $ Syntax.Deriving () - [ Syntax.IRule () Nothing Nothing (Syntax.IHCon () c) - | c <- derives - ] + $ Just derives + +newtypeDecl :: Name -> Type -> Deriving -> Decl +newtypeDecl name wrappedType derives + = Syntax.DataDecl () (Syntax.NewType ()) Nothing + (Syntax.DHead () name) + [Syntax.QualConDecl () Nothing Nothing + $ Syntax.ConDecl () name [wrappedType]] + $ Just derives + +type Deriving = Syntax.Deriving () + +deriving' :: [QName] -> Deriving +deriving' classes = Syntax.Deriving () + [ Syntax.IRule () Nothing Nothing (Syntax.IHCon () c) + | c <- classes + ] funBind :: [Match] -> Decl funBind = Syntax.FunBind () diff --git a/proto-lens-protoc/src/Data/ProtoLens/Compiler/Generate.hs b/proto-lens-protoc/src/Data/ProtoLens/Compiler/Generate.hs index c6263e74..12cea7ff 100644 --- a/proto-lens-protoc/src/Data/ProtoLens/Compiler/Generate.hs +++ b/proto-lens-protoc/src/Data/ProtoLens/Compiler/Generate.hs @@ -19,7 +19,7 @@ import Control.Arrow (second) import qualified Data.Foldable as F import qualified Data.List as List import qualified Data.Map as Map -import Data.Maybe (isNothing) +import Data.Maybe (isNothing, isJust) import Data.Monoid ((<>)) import Data.Ord (comparing) import qualified Data.Set as Set @@ -53,7 +53,7 @@ import Data.ProtoLens.Compiler.Combinators import Data.ProtoLens.Compiler.Definitions data SyntaxType = Proto2 | Proto3 - deriving Eq + deriving (Show, Eq) fileSyntaxType :: FileDescriptorProto -> SyntaxType fileSyntaxType f = case f ^. syntax of @@ -93,7 +93,7 @@ generateModule modName imports syntaxType modifyImport definitions importedEnv pragmas = [ languagePragma $ map fromString ["ScopedTypeVariables", "DataKinds", "TypeFamilies", - "UndecidableInstances", + "UndecidableInstances", "GeneralizedNewtypeDeriving", "MultiParamTypeClasses", "FlexibleContexts", "FlexibleInstances", "PatternSynonyms", "MagicHash", "NoImplicitPrelude"] -- Allow unused imports in case we don't import anything from @@ -114,9 +114,9 @@ generateModule modName imports syntaxType modifyImport definitions importedEnv env = Map.union (unqualifyEnv definitions) importedEnv generateDecls (protoName, Message m) = generateMessageDecls syntaxType env (stripDotPrefix protoName) m - generateDecls (_, Enum e) = generateEnumDecls e + generateDecls (_, Enum e) = generateEnumDecls syntaxType e generateExports (Message m) = generateMessageExports m - generateExports (Enum e) = generateEnumExports e + generateExports (Enum e) = generateEnumExports syntaxType e allLensNames = F.toList $ Set.fromList [ lensSymbol inst | Message m <- Map.elems definitions @@ -173,7 +173,7 @@ generateMessageDecls syntaxType env protoName info = ] ++ [(messageUnknownFields info, "Data.ProtoLens.FieldSet")] ] - ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"] + $ deriving' ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"] ] ++ -- oneof field data type declarations @@ -191,7 +191,7 @@ generateMessageDecls syntaxType env protoName info = , let f = caseField c , let consName = caseConstructorName c ] - ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"] + $ deriving' ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"] | oneofInfo <- messageOneofFields info ] ++ -- instance (HasLens' f Foo x a, HasLens' f Foo x b, a ~ b) @@ -248,18 +248,94 @@ generateMessageDecls syntaxType env protoName info = dataName = messageName info allFields = allMessageFields syntaxType env info -generateEnumExports :: EnumInfo Name -> [ExportSpec] -generateEnumExports e = [exportAll n, exportWith n aliases] +generateEnumExports :: SyntaxType -> EnumInfo Name -> [ExportSpec] +generateEnumExports syntaxType e = [exportAll n, exportWith n aliases] where n = unQual $ enumName e - aliases = [enumValueName v | v <- enumValues e, Just _ <- [enumAliasOf v]] + aliases = [enumValueName v | v <- enumValues e, needsManualExport v] + needsManualExport v = syntaxType == Proto3 + || isJust (enumAliasOf v) + +generateEnumDecls :: SyntaxType -> EnumInfo Name -> [Decl] +generateEnumDecls Proto3 info = + -- newtype Foo = Foo Int32 + [ newtypeDecl dataName "Data.Int.Int32" + $ deriving' ["Prelude.Eq", "Prelude.Ord", "Prelude.Enum", "Prelude.Bounded"] + + -- instance Show Foo where + -- showsPrec _ Value0 = "Value0" -- the Haskell name + -- showsPrec p (Foo k) = showParen (p > 10) + -- $ showString "toEnum " . shows k + , instDecl [] ("Prelude.Show" `ihApp` [dataType]) + [ [ match "showsPrec" [pWildCard, pApp (unQual n) []] + $ "Prelude.showString" @@ stringExp (prettyPrint n) + | n <- map enumValueName $ enumValues info + ] + ++ + [ match "showsPrec" ["p", pApp (unQual dataName) ["k"]] + $ "Prelude.showParen" @@ ("Prelude.>" @@ "p" @@ litInt 10) + @@ ("Prelude.." @@ ("Prelude.showString" + @@ stringExp "toEnum ") + @@ ("Prelude.shows" @@ "k")) + ] + ] + + -- instance MessageEnum Foo where + -- maybeToEnum k = Just $ toEnum k + -- showEnum (Foo 0) = "Value0" -- the proto name + -- showEnum (Foo k) = show k + -- readEnum "Value0" = Just (Foo 0) + -- readEnum _ = Nothing + , instDecl [] ("Data.ProtoLens.MessageEnum" `ihApp` [dataType]) + [ [match "maybeToEnum" ["k"] + $ "Prelude.Just" @@ ("Prelude.toEnum" @@ "k")] + , [ match "showEnum" [pVar n] $ stringExp pn + | v <- enumValues info + , isNothing (enumAliasOf v) + , let n = enumValueName v + , let pn = T.unpack $ enumValueDescriptor v ^. name + ] + , [ match "showEnum" [pApp (unQual dataName) ["k"]] + $ "Prelude.show" @@ "k" + ] + + , [ match "readEnum" [stringPat pn] + $ "Prelude.Just" @@ con (unQual n) + | v <- enumValues info + , let n = enumValueName v + , let pn = T.unpack $ enumValueDescriptor v ^. name + ] + ++ + [ match "readEnum" [pWildCard] "Prelude.Nothing" + ] + ] + -- proto3 enums always default to zero. + , instDecl [] ("Data.Default.Class.Default" `ihApp` [dataType]) + [[match "def" [] $ "Prelude.toEnum" @@ litInt 0]] + , instDecl [] ("Data.ProtoLens.FieldDefault" `ihApp` [dataType]) + [[match "fieldDefault" [] $ "Prelude.toEnum" @@ litInt 0]] + ] + ++ + -- pattern Value0 :: Foo + -- pattern Value0 = Foo 0 + concat + [ [ patSynSig n dataType + , patSyn (pVar n) + $ pApp (unQual dataName) [pLitInt k] + ] + | v <- enumValues info + , let n = enumValueName v + , let k = fromIntegral $ enumValueDescriptor v ^. number + ] + where + dataName = enumName info + dataType = tyCon $ unQual dataName -generateEnumDecls :: EnumInfo Name -> [Decl] -generateEnumDecls info = +generateEnumDecls Proto2 info = [ dataDecl dataName [conDecl n [] | n <- constructorNames] - ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"] + $ deriving' ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"] -- instance Data.Default.Class.Default Foo where -- def = FirstEnumValue , instDecl [] ("Data.Default.Class.Default" `ihApp` [dataType]) diff --git a/proto-lens-tests/tests/proto3.proto b/proto-lens-tests/tests/proto3.proto index f8a764b6..1e1c77a7 100644 --- a/proto-lens-tests/tests/proto3.proto +++ b/proto-lens-tests/tests/proto3.proto @@ -17,8 +17,10 @@ message Foo { Sub sub = 5; enum FooEnum { + option allow_alias = true; Enum1 = 0; - Enum2 = 1; + Enum2 = 3; + Enum2a = 3; } FooEnum enum = 6; diff --git a/proto-lens-tests/tests/proto3_test.hs b/proto-lens-tests/tests/proto3_test.hs index a9bacadc..1883f031 100644 --- a/proto-lens-tests/tests/proto3_test.hs +++ b/proto-lens-tests/tests/proto3_test.hs @@ -35,7 +35,7 @@ import Proto.Proto3'Fields ) import Test.Framework (testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?)) +import Test.HUnit ((@=?), assertBool) import Data.ProtoLens.TestUtil @@ -98,6 +98,26 @@ main = testMain , testCase "string" $ (def :: Strings) @=? (def & string .~ "") , testCase "enum" $ (def :: Foo) @=? (def & enum .~ Foo'Enum1) ] + -- Enums are all pattern aliases + , testGroup "enum" + [ testCase "aliases are exported" $ Foo'Enum2 @=? Foo'Enum2a + , testCase "enum values" $ do + map toEnum [0, 3, 3] @=? [Foo'Enum1, Foo'Enum2, Foo'Enum2a] + ["Foo'Enum1", "Foo'Enum2", "Foo'Enum2", "toEnum 5"] + @=? map show [Foo'Enum1, Foo'Enum2, Foo'Enum2a, toEnum 5] + ["Enum1", "Enum2", "Enum2", "6"] + @=? map showEnum [Foo'Enum1, Foo'Enum2, Foo'Enum2a, toEnum 6] + [Just Foo'Enum1, Just Foo'Enum2, Just Foo'Enum2, Nothing, Nothing] + @=? map readEnum ["Enum1", "Enum2", "Enum2a", "4", "5"] + , testCase "enum patterns" $ do + assertBool "enum value" $ case toEnum 3 of + Foo'Enum2 -> True + _ -> False + assertBool "enum alias" $ case toEnum 3 of + Foo'Enum2a -> True + _ -> False + + ] -- Unset proto3 messages are different than the default value. , testGroup "submessage" [ testCase "Nothing" $ Nothing @=? ((def :: Foo) ^. maybe'sub) diff --git a/proto-lens/src/Data/ProtoLens/Message.hs b/proto-lens/src/Data/ProtoLens/Message.hs index 6f4544ba..57c8c570 100644 --- a/proto-lens/src/Data/ProtoLens/Message.hs +++ b/proto-lens/src/Data/ProtoLens/Message.hs @@ -220,7 +220,8 @@ class (Enum a, Bounded a) => MessageEnum a where -- | Convert the given 'Int' to an enum value. Returns 'Nothing' if -- no corresponding value was defined in the .proto file. maybeToEnum :: Int -> Maybe a - -- | Get the name of this enum as defined in the .proto file. + -- | Get the name of this enum as defined in the .proto file. Used + -- for the human-readable output in @Data.ProtoLens.TextFormat@. showEnum :: a -> String -- | Convert the given 'String' to an enum value. Returns 'Nothing' if -- no corresponding value was defined in the .proto file.