Proto3 enums

.travis.yml

@@ -13,14 +13,10 @@ cache:
 
 matrix:
   include:
-  - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22
-    addons: {apt: {packages: [cabal-install-1.22, ghc-7.10.3], sources: [hvr-ghc]}}
   - env: BUILD=cabal GHCVER=8.0.1 CABALVER=1.24
     addons: {apt: {packages: [cabal-install-1.24, ghc-8.0.1], sources: [hvr-ghc]}}
   - env: BUILD=cabal GHCVER=8.2.1 CABALVER=2.0
     addons: {apt: {packages: [cabal-install-2.0, ghc-8.2.1], sources: [hvr-ghc]}}
-  - env: BUILD=stack STACK='stack --resolver=lts-6.22'
-    addons: {apt: {packages: [libgmp-dev]}}
   - env: BUILD=stack STACK='stack --resolver=lts-7.4'
     addons: {apt: {packages: [libgmp-dev]}}
   - env: BUILD=stack STACK='stack --resolver=lts-8.24'

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).

lens-labels/src/Lens/Labels.hs

@@ -53,17 +53,11 @@ module Lens.Labels (
 
 import qualified Control.Category as Category
 import GHC.Prim (Proxy#, proxy#)
-#if __GLASGOW_HASKELL__ >= 800
 import GHC.OverloadedLabels (IsLabel(..))
-#endif
 import GHC.TypeLits (Symbol)
 
 import Data.Function ((&))
-#if __GLASGOW_HASKELL__ >= 800
 import Data.Functor.Const (Const(..))
-#else
-import Control.Applicative (Const(..))
-#endif
 import Data.Functor.Identity(Identity(..))
 
 
@@ -81,7 +75,6 @@ class HasLens f s t (x :: Symbol) a b
         | x s -> a, x t -> b, x s b -> t, x t a -> s where
     lensOf :: Proxy# x -> (a -> f b) -> s -> f t
 
-#if __GLASGOW_HASKELL__ >= 800
 instance
     (p ~ (a -> f b), q ~ (s -> f t), HasLens f s t x a b)
     => IsLabel x (LensFn p q) where
@@ -90,7 +83,6 @@ instance
 #else
     fromLabel p = LensFn $ lensOf p
 #endif
-#endif
 
 -- | A type class for lens fields of monomorphic types (i.e., where the lens
 -- doesn't change the outer type).

proto-lens-descriptors/src/Proto/Google/Protobuf/Compiler/Plugin'Fields.hs

@@ -4,6 +4,7 @@
   FlexibleInstances, PatternSynonyms, MagicHash, NoImplicitPrelude
   #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}
 module Proto.Google.Protobuf.Compiler.Plugin'Fields where
 import qualified Prelude
 import qualified Data.Int

proto-lens-descriptors/src/Proto/Google/Protobuf/Compiler/Plugin.hs

@@ -4,7 +4,11 @@
   FlexibleInstances, PatternSynonyms, MagicHash, NoImplicitPrelude
   #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
-module Proto.Google.Protobuf.Compiler.Plugin where
+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}
+module Proto.Google.Protobuf.Compiler.Plugin
+       (CodeGeneratorRequest(..), CodeGeneratorResponse(..),
+        CodeGeneratorResponse'File(..))
+       where
 import qualified Prelude
 import qualified Data.Int
 import qualified Data.Word

proto-lens-descriptors/src/Proto/Google/Protobuf/Descriptor'Fields.hs

@@ -4,6 +4,7 @@
   FlexibleInstances, PatternSynonyms, MagicHash, NoImplicitPrelude
   #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}
 module Proto.Google.Protobuf.Descriptor'Fields where
 import qualified Prelude
 import qualified Data.Int

proto-lens-descriptors/src/Proto/Google/Protobuf/Descriptor.hs

@@ -4,7 +4,25 @@
   FlexibleInstances, PatternSynonyms, MagicHash, NoImplicitPrelude
   #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
-module Proto.Google.Protobuf.Descriptor where
+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}
+module Proto.Google.Protobuf.Descriptor
+       (DescriptorProto(..), DescriptorProto'ExtensionRange(..),
+        DescriptorProto'ReservedRange(..), EnumDescriptorProto(..),
+        EnumOptions(..), EnumValueDescriptorProto(..),
+        EnumValueOptions(..), FieldDescriptorProto(..),
+        FieldDescriptorProto'Label(..), FieldDescriptorProto'Label(),
+        FieldDescriptorProto'Type(..), FieldDescriptorProto'Type(),
+        FieldOptions(..), FieldOptions'CType(..), FieldOptions'CType(),
+        FieldOptions'JSType(..), FieldOptions'JSType(),
+        FileDescriptorProto(..), FileDescriptorSet(..), FileOptions(..),
+        FileOptions'OptimizeMode(..), FileOptions'OptimizeMode(),
+        GeneratedCodeInfo(..), GeneratedCodeInfo'Annotation(..),
+        MessageOptions(..), MethodDescriptorProto(..), MethodOptions(..),
+        OneofDescriptorProto(..), ServiceDescriptorProto(..),
+        ServiceOptions(..), SourceCodeInfo(..),
+        SourceCodeInfo'Location(..), UninterpretedOption(..),
+        UninterpretedOption'NamePart(..))
+       where
 import qualified Prelude
 import qualified Data.Int
 import qualified Data.Word

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 ()
@@ -161,16 +174,21 @@ match n ps e = Syntax.Match () n ps (Syntax.UnGuardedRhs () e) Nothing
 
 type Module = Syntax.Module ()
 
-module' :: ModuleName -> [ModulePragma] -> [Syntax.ImportDecl ()] -> [Decl] -> Module
-module' modName
+type ExportSpec = Syntax.ExportSpec ()
+
+module'
+    :: ModuleName
+    -> Maybe [ExportSpec]
+    -> [ModulePragma]
+    -> [Syntax.ImportDecl ()]
+    -> [Decl]
+    -> Module
+module' modName exports
     = Syntax.Module ()
         (Just $ Syntax.ModuleHead () modName
                     -- no warning text
                     Nothing
-                    -- no explicit exports; we export everything.
-                    -- TODO: Also export public imports, taking care not to
-                    -- cause a name conflict between field accessors.
-                    Nothing)
+                    (Syntax.ExportSpecList () <$> exports))
 
 getModuleName :: Module -> Maybe ModuleName
 getModuleName (Syntax.Module _ (Just (Syntax.ModuleHead _ name _ _)) _ _ _)
@@ -186,6 +204,26 @@ languagePragma = Syntax.LanguagePragma ()
 optionsGhcPragma :: String -> ModulePragma
 optionsGhcPragma = Syntax.OptionsPragma () (Just Syntax.GHC)
 
+exportVar :: QName -> ExportSpec
+exportVar = Syntax.EVar ()
+
+exportAll :: QName -> ExportSpec
+#if MIN_VERSION_haskell_src_exts(1,18,0)
+exportAll q = Syntax.EThingWith () (Syntax.EWildcard () 0) q []
+#else
+exportAll = Syntax.EThingAll ()
+#endif
+
+exportWith :: QName -> [Name] -> ExportSpec
+#if MIN_VERSION_haskell_src_exts(1,18,0)
+exportWith q = Syntax.EThingWith ()
+                    (Syntax.NoWildcard ())
+                    q
+                    . map (Syntax.ConName ())
+#else
+exportWith q = Syntax.EThingWith () q . map (Syntax.ConName ())
+#endif
+
 type Name = Syntax.Name ()
 
 type Pat = Syntax.Pat ()

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
@@ -78,10 +78,12 @@ generateModule :: ModuleName
                -> [Module]
 generateModule modName imports syntaxType modifyImport definitions importedEnv
     = [ module' modName
+                (Just $ concatMap generateExports $ Map.elems definitions)
                 pragmas
                 sharedImports
           . concatMap generateDecls $ Map.toList definitions
       , module' fieldModName
+                Nothing
                 pragmas
                 sharedImports
                 (concatMap generateFieldDecls allLensNames)
@@ -91,12 +93,15 @@ 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
               -- Data.Text, Data.Int, etc.
           , optionsGhcPragma "-fno-warn-unused-imports"
+          -- haskell-src-exts doesn't support exporting `Foo(..., A, B)`
+          -- in a single entry, so we use two: `Foo(..)` and `Foo(A, B)`.
+          , optionsGhcPragma "-fno-warn-duplicate-exports"
           ]
     sharedImports = map (modifyImport . importSimple)
               [ "Prelude", "Data.Int", "Data.Word"
@@ -109,7 +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 syntaxType e
     allLensNames = F.toList $ Set.fromList
         [ lensSymbol inst
         | Message m <- Map.elems definitions
@@ -149,6 +156,11 @@ reexported imp@ImportDecl {importModule = m}
   where
     m' = fromString $ "Data.ProtoLens.Reexport." ++ prettyPrint m
 
+generateMessageExports :: MessageInfo Name -> [ExportSpec]
+generateMessageExports m =
+    map (exportAll . unQual)
+        $ messageName m : map oneofTypeName (messageOneofFields m)
+
 generateMessageDecls :: SyntaxType -> Env QName -> T.Text -> MessageInfo Name -> [Decl]
 generateMessageDecls syntaxType env protoName info =
     -- data Bar = Bar {
@@ -161,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
@@ -179,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)
@@ -236,11 +248,94 @@ generateMessageDecls syntaxType env protoName info =
     dataName = messageName info
     allFields = allMessageFields syntaxType env info
 
-generateEnumDecls :: EnumInfo Name -> [Decl]
-generateEnumDecls info =
+generateEnumExports :: SyntaxType -> EnumInfo Name -> [ExportSpec]
+generateEnumExports syntaxType e = [exportAll n, exportWith n aliases]
+  where
+    n = unQual $ enumName e
+    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 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])