Skip to content

Commit

Permalink
Sumtype proto3 enums
Browse files Browse the repository at this point in the history 
Fixes #151.
  • Loading branch information
@judah
Paul Kinsky authored and judah committed Nov 1, 2017
1 parent 71025ad commit 7a6f900
Show file tree
Hide file tree
Showing 4 changed files with 191 additions and 60 deletions.
4 changes: 2 additions & 2 deletions proto-lens-protoc/package.yaml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -59,8 +59,8 @@ library:
- Data.Text as Data.ProtoLens.Reexport.Data.Text,
- Lens.Family2 as Data.ProtoLens.Reexport.Lens.Family2,
- Lens.Family2.Unchecked as Data.ProtoLens.Reexport.Lens.Family2.Unchecked,
- Lens.Labels as Data.ProtoLens.Reexport.Lens.Labels

- Lens.Labels as Data.ProtoLens.Reexport.Lens.Labels,
- Text.Read as Data.ProtoLens.Reexport.Text.Read

executables:
proto-lens-protoc:
Expand Down
4 changes: 4 additions & 0 deletions proto-lens-protoc/src/Data/ProtoLens/Compiler/Definitions.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -156,6 +156,8 @@ promoteSymbol (Symbol s) = tyPromotedString s
-- | All the information needed to define or use a proto enum type.
data EnumInfo n = EnumInfo
{ enumName :: n
, enumUnrecognizedName :: n
, enumUnrecognizedValueName :: n
, enumDescriptor :: EnumDescriptorProto
, enumValues :: [EnumValueInfo n]
} deriving Functor
Expand Down Expand Up @@ -365,6 +367,8 @@ enumDef protoPrefix hsPrefix d = let
in (mkText (d ^. name)
, Enum EnumInfo
{ enumName = mkHsName (d ^. name)
, enumUnrecognizedName = mkHsName (d ^. name <> "'Unrecognized")
, enumUnrecognizedValueName = mkHsName (d ^. name <> "'UnrecognizedValue")
, enumDescriptor = d
, enumValues = collectEnumValues mkHsName $ d ^. value
})
Expand Down
228 changes: 173 additions & 55 deletions proto-lens-protoc/src/Data/ProtoLens/Compiler/Generate.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -108,8 +108,8 @@ generateModule modName imports syntaxType modifyImport definitions importedEnv
[ "Prelude", "Data.Int", "Data.Word"
, "Data.ProtoLens", "Data.ProtoLens.Message.Enum"
, "Lens.Family2", "Lens.Family2.Unchecked", "Data.Default.Class"
, "Data.Text", "Data.Map" , "Data.ByteString"
, "Lens.Labels"
, "Data.Text", "Data.Map", "Data.ByteString"
, "Lens.Labels", "Text.Read"
]
++ map importSimple imports
env = Map.union (unqualifyEnv definitions) importedEnv
Expand Down Expand Up @@ -250,89 +250,207 @@ generateMessageDecls syntaxType env protoName info =
allFields = allMessageFields syntaxType env info

generateEnumExports :: SyntaxType -> EnumInfo Name -> [ExportSpec]
generateEnumExports syntaxType e = [exportAll n, exportWith n aliases]
generateEnumExports syntaxType e = [exportAll n, exportWith n aliases] ++ proto3NewType
where
n = unQual $ enumName e
aliases = [enumValueName v | v <- enumValues e, needsManualExport v]
needsManualExport v = syntaxType == Proto3
|| isJust (enumAliasOf v)
needsManualExport v = isJust (enumAliasOf v)
proto3NewType = if syntaxType == Proto3
then [exportVar . unQual $ enumUnrecognizedValueName e]
else []

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
-- data FooEnum
-- = Enum1
-- | Enum2
-- | FooEnum'Unrecognized !FooEnum'UnrecognizedValue
-- deriving (Prelude.Show, Prelude.Eq, Prelude.Ord, Prelude.Read)
[ dataDecl dataName
( (flip conDecl [] <$> constructorNames)
++ [conDecl unrecognizedName [tyCon $ unQual unrecognizedValueName]]
)
$ deriving' ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"]

-- newtype FooEnum'UnrecognizedValue = FooEnum'UnrecognizedValue Data.Int.Int32
-- deriving (Prelude.Eq, Prelude.Ord, Prelude.Show, Prelude.Read)
, newtypeDecl unrecognizedValueName
"Data.Int.Int32"
$ deriving' ["Prelude.Eq", "Prelude.Ord", "Prelude.Show"]

-- instance Data.ProtoLens.MessageEnum FooEnum where
-- maybeToEnum 0 = Prelude.Just Enum1
-- maybeToEnum 3 = Prelude.Just Enum2
-- maybeToEnum k
-- = Prelude.Just
-- (FooEnum'Unrecognized
-- (FooEnum'UnrecognizedValue (Prelude.fromIntegral k)))
-- showEnum (FooEnum'Unrecognized (FooEnum'UnrecognizedValue k))
-- = Prelude.show k
-- showEnum Foo'Enum2 = "Enum2"
-- showEnum Foo'Enum1 = "Enum1"
-- readEnum "Enum2a" = Prelude.Just Enum2a -- alias
-- readEnum "Enum2" = Prelude.Just Enum2
-- readEnum "Enum1" = Prelude.Just Enum1
-- readEnum k = Text.Read.readMaybe k >>= maybeToEnum
, instDecl [] ("Data.ProtoLens.MessageEnum" `ihApp` [dataType])
[ [ match "maybeToEnum" [pLitInt k] $ "Prelude.Just" @@ con (unQual c)
| (c, k) <- constructorNumbers
]
++
[ match "showsPrec" ["p", pApp (unQual dataName) ["k"]]
$ "Prelude.showParen" @@ ("Prelude.>" @@ "p" @@ litInt 10)
@@ ("Prelude.." @@ ("Prelude.showString"
@@ stringExp "toEnum ")
@@ ("Prelude.shows" @@ "k"))
[match "maybeToEnum" ["k"]
$ "Prelude.Just" @@
(con (unQual unrecognizedName)
@@ (con (unQual unrecognizedValueName)
@@ ("Prelude.fromIntegral" @@ "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)
, [ match "showEnum" [pApp (unQual n) []]
$ stringExp pn
| v <- filter (null . enumAliasOf) $ enumValues info
, let n = enumValueName v
, let pn = T.unpack $ enumValueDescriptor v ^. name
] ++
[match "showEnum" [pApp (unQual unrecognizedName)
[pApp (unQual unrecognizedValueName) [pVar "k"]]
]
$ "Prelude.show" @@ "k"
]
, [ 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" [pVar "k"] $ "Prelude.>>="
@@ ("Text.Read.readMaybe" @@ "k")
@@ "Data.ProtoLens.maybeToEnum"]
]

-- instance Bounded Foo where
-- minBound = Foo1
-- maxBound = FooN
, instDecl [] ("Prelude.Bounded" `ihApp` [dataType])
[[ match "minBound" [] $ con $ unQual minBoundName
, match "maxBound" [] $ con $ unQual maxBoundName
]]

-- instance Enum Foo where
-- toEnum k = maybe (error ("Foo.toEnum: unknown argument for enum Foo: "
-- ++ show k))
-- id (maybeToEnum k)
-- fromEnum Foo1 = 1
-- fromEnum Foo2 = 2
-- ..
-- succ FooN = error "Foo.succ: bad argument FooN."
-- succ Foo1 = Foo2
-- succ Foo2 = Foo3
-- ..
-- pred Foo1 = error "Foo.succ: bad argument Foo1."
-- pred Foo2 = Foo1
-- pred Foo3 = Foo2
-- ..
-- enumFrom = messageEnumFrom
-- enumFromTo = messageEnumFromTo
-- enumFromThen = messageEnumFromThen
-- enumFromThenTo = messageEnumFromThenTo
, instDecl [] ("Prelude.Enum" `ihApp` [dataType])
[[match "toEnum" ["k__"]
$ "Prelude.maybe" @@ errorMessageExpr @@ "Prelude.id"
@@ ("Data.ProtoLens.maybeToEnum" @@ "k__")]
, [ match "fromEnum" [pApp (unQual c) []] $ litInt k
| (c, k) <- constructorNumbers
]
++
[ match "readEnum" [pWildCard] "Prelude.Nothing"
[match "fromEnum" [pApp (unQual unrecognizedName)
[pApp (unQual unrecognizedValueName) [pVar "k"]]
]
$ "Prelude.fromIntegral" @@ "k"
]
, succDecl "succ" maxBoundName succPairs
, succDecl "pred" minBoundName $ map swap succPairs
, alias "enumFrom" "Data.ProtoLens.Message.Enum.messageEnumFrom"
, alias "enumFromTo" "Data.ProtoLens.Message.Enum.messageEnumFromTo"
, alias "enumFromThen" "Data.ProtoLens.Message.Enum.messageEnumFromThen"
, alias "enumFromThenTo"
"Data.ProtoLens.Message.Enum.messageEnumFromThenTo"
]

-- proto3 enums always default to zero.
-- instance Data.Default.Class.Default Foo where
-- def = FirstEnumValue
, instDecl [] ("Data.Default.Class.Default" `ihApp` [dataType])
[[match "def" [] $ "Prelude.toEnum" @@ litInt 0]]
[[match "def" [] defaultCon]]
-- instance Data.ProtoLens.FieldDefault Foo where
-- fieldDefault = FirstEnumValue
, instDecl [] ("Data.ProtoLens.FieldDefault" `ihApp` [dataType])
[[match "fieldDefault" [] $ "Prelude.toEnum" @@ litInt 0]]
]
++
-- pattern Value0 :: Foo
-- pattern Value0 = Foo 0
[[match "fieldDefault" [] defaultCon]]
] ++
-- pattern Enum2a :: FooEnum
-- pattern Enum2a = Enum2
concat
[ [ patSynSig n dataType
, patSyn (pVar n)
$ pApp (unQual dataName) [pLitInt k]
[ [ patSynSig aliasName dataType
, patSyn (pVar aliasName) (pVar originalName)
]
| v <- enumValues info
, let n = enumValueName v
, let k = fromIntegral $ enumValueDescriptor v ^. number
| EnumValueInfo
{ enumValueName = aliasName
, enumAliasOf = Just originalName
} <- enumValues info
]

where
dataName = enumName info
EnumInfo { enumName = dataName
, enumUnrecognizedName = unrecognizedName
, enumUnrecognizedValueName = unrecognizedValueName
, enumDescriptor = ed
} = info
errorMessage = "toEnum: unknown value for enum " ++ unpack (ed ^. name)
++ ": "

errorMessageExpr = "Prelude.error"
@@ ("Prelude.++" @@ stringExp errorMessage
@@ ("Prelude.show" @@ "k__"))
alias funName implName = [match funName [] implName]

dataType = tyCon $ unQual dataName



constructors :: [(Name, EnumValueDescriptorProto)]
constructors = List.sortBy (comparing ((^. number) . snd))
[(n, d) | EnumValueInfo
{ enumValueName = n
, enumValueDescriptor = d
, enumAliasOf = Nothing
} <- enumValues info
]
constructorNames = map fst constructors

defaultCon = con $ unQual $ head constructorNames

minBoundName = head constructorNames
maxBoundName = last constructorNames

constructorNumbers = map (second (fromIntegral . (^. number))) constructors

succPairs = zip constructorNames $ tail constructorNames
succDecl funName boundName thePairs =
match funName [pApp (unQual boundName) []]
("Prelude.error" @@ stringExp (concat
[ prettyPrint dataName, ".", prettyPrint funName, ": bad argument "
, prettyPrint boundName, ". This value would be out of bounds."
]))
:
[ match funName [pApp (unQual from) []] $ con $ unQual to
| (from, to) <- thePairs
]
++
[match funName [pWildCard]
("Prelude.error" @@ stringExp (concat
[ prettyPrint dataName, ".", prettyPrint funName, ": bad argument: unrecognized value"
]))
]

generateEnumDecls Proto2 info =
[ dataDecl dataName
[conDecl n [] | n <- constructorNames]
Expand Down
15 changes: 12 additions & 3 deletions proto-lens-tests/tests/proto3_test.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -98,16 +98,25 @@ main = testMain
, testCase "string" $ (def :: Strings) @=? (def & string .~ "")
, testCase "enum" $ (def :: Foo) @=? (def & enum .~ Foo'Enum1)
]
-- Enums are all pattern aliases
-- Enums are sum types, except for aliases
, testGroup "enum"
[ testCase "aliases are exported" $ Foo'Enum2 @=? Foo'Enum2a
, serializeTo "serializeTo enum"
(def & enum .~ Foo'Enum2 :: Foo)
"enum: Enum2"
$ tagged 6 $ VarInt 3
, serializeTo "serializeTo unrecognized"
(def & enum .~ toEnum 9 :: Foo)
"enum: 9"
$ tagged 6 $ VarInt 9
, testCase "enum values" $ do
map toEnum [0, 3, 3] @=? [Foo'Enum1, Foo'Enum2, Foo'Enum2a]
["Foo'Enum1", "Foo'Enum2", "Foo'Enum2", "toEnum 5"]
fromEnum <$> (maybeToEnum 4 :: Maybe Foo'FooEnum) @=? Just 4
["Foo'Enum1", "Foo'Enum2", "Foo'Enum2", "Foo'FooEnum'Unrecognized (Foo'FooEnum'UnrecognizedValue 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]
[Just Foo'Enum1, Just Foo'Enum2, Just Foo'Enum2, maybeToEnum 4, maybeToEnum 5]
@=? map readEnum ["Enum1", "Enum2", "Enum2a", "4", "5"]
, testCase "enum patterns" $ do
assertBool "enum value" $ case toEnum 3 of
Expand Down

0 comments on commit 7a6f900

Please sign in to comment.