proto-lens-protoc 0.2.1.0 → 0.2.2.0

raw patch · 6 files changed

+471/−166 lines, 6 filesdep ~Cabaldep ~basedep ~filepathPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: Cabal, base, filepath, haskell-src-exts, proto-lens, proto-lens-descriptors

API changes (from Hackage documentation)

Files

• Changelog.md +16/−0
• proto-lens-protoc.cabal +17/−14
• src/Data/ProtoLens/Compiler/Combinators.hs +11/−1
• src/Data/ProtoLens/Compiler/Definitions.hs +124/−35
• src/Data/ProtoLens/Compiler/Generate.hs +236/−100
• src/Data/ProtoLens/Setup.hs +67/−16

@@ -0,0 +1,16 @@+# Changelog for `proto-lens-protoc`++## Unreleased changes++## v0.2.2.0+- Bump the dependency on `base` to support `ghc-8.2.1` and `Cabal-2.0`.+- Bump the dependency for `haskell-src-exts-0.19`.+- Improve the semantics of oneof fields, and add a lens to access the+  underlying sum type.+- Generate Ord instances for all exported datatypes.+- Print a better error message when missing `protoc` or `proto-lens-protoc`.+- Expose message names to support `Data.ProtoLens.Any`.+- CamelCase the names of Haskell message types.++## v0.2.1.0 and older+See `Changelog.md` for `proto-lens`.

@@ -1,5 +1,5 @@ name:                proto-lens-protoc-version:             0.2.1.0+version:             0.2.2.0 synopsis:            Protocol buffer compiler for the proto-lens library. description:   Turn protocol buffer files (.proto) into Haskell files (.hs) which@@ -15,6 +15,7 @@ category:            Data build-type:          Simple cabal-version:       >=1.21+extra-source-files:  Changelog.md  -- Work around stack bug, since we don't want to build the library -- during bootstrapping:@@ -36,19 +37,21 @@     default-language:  Haskell2010     hs-source-dirs:    src     build-depends:-          Cabal >= 1.22 && < 1.25-        , base >= 4.8 && < 4.10+          Cabal >= 1.22 && < 2.1+        , base >= 4.8 && < 4.11         , bytestring == 0.10.*         , containers == 0.5.*         , data-default-class >= 0.0 && < 0.2         , directory >= 1.2 && < 1.4-        , filepath == 1.4.*-        , haskell-src-exts >= 1.17 && < 1.19+        , filepath >= 1.4 && < 1.6+        , haskell-src-exts >= 1.17 && < 1.20         , lens-family == 1.2.*         , lens-labels == 0.1.*         , process >= 1.2 && < 1.5-        , proto-lens == 0.2.1.0-        , proto-lens-descriptors == 0.2.1.0+        -- Specify a more precise version of `proto-lens`, since it depends on+        -- the exact definition of the Message class.+        , proto-lens == 0.2.2.*+        , proto-lens-descriptors == 0.2.2.*         , text == 1.2.*     reexported-modules:         -- Modules that are needed by the generated Haskell files.@@ -73,17 +76,17 @@   main-is:  protoc-gen-haskell.hs    build-depends:-        base >= 4.8 && < 4.10+        base >= 4.8 && < 4.11       , bytestring == 0.10.*       , containers == 0.5.*       , data-default-class >= 0.0 && < 0.2-      , filepath == 1.4.*-      , haskell-src-exts >= 1.17 && < 1.19+      , filepath >= 1.4 && < 1.6+      , haskell-src-exts >= 1.17 && < 1.20       , lens-family == 1.2.*-      -- Specify an exact version of `proto-lens`, since it's tied closely-      -- to the generated code.-      , proto-lens == 0.2.1.0-      , proto-lens-descriptors == 0.2.1.0+      -- Specify a more precise version of `proto-lens`, since it depends on+      -- the exact definition of the Message class.+      , proto-lens == 0.2.2.*+      , proto-lens-descriptors == 0.2.2.*       , text == 1.2.*   hs-source-dirs:      src   other-modules:

@@ -54,7 +54,9 @@ type ConDecl = Syntax.ConDecl ()  conDecl :: Name -> [Type] -> ConDecl-conDecl = Syntax.ConDecl ()+conDecl constructorName paramTypes+    = Syntax.ConDecl () constructorName $+        fmap tyBang paramTypes  recDecl :: Name -> [(Name, Type)] -> ConDecl recDecl dataName fields@@ -102,6 +104,14 @@  let' :: [Decl] -> Exp -> Exp let' ds e = Syntax.Let () (Syntax.BDecls () ds) e++type Alt = Syntax.Alt ()++case' :: Exp -> [Alt] -> Exp+case' = Syntax.Case ()++alt :: Pat -> Exp -> Alt+alt p e = Syntax.Alt () p (Syntax.UnGuardedRhs () e) Nothing  stringExp :: String -> Exp stringExp = Syntax.Lit () . string

@@ -7,12 +7,20 @@ -- | This module takes care of collecting all the definitions in a .proto file -- and assigning Haskell names to all of the defined things (messages, enums -- and field names).-{-# LANGUAGE DeriveFunctor, OverloadedStrings #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-} module Data.ProtoLens.Compiler.Definitions     ( Env     , Definition(..)     , MessageInfo(..)     , FieldInfo(..)+    , OneofInfo(..)+    , OneofCase(..)+    , FieldName(..)+    , Symbol+    , nameFromSymbol+    , promoteSymbol     , EnumInfo(..)     , EnumValueInfo(..)     , qualifyEnv@@ -28,10 +36,10 @@ import Data.Maybe (fromMaybe) import Data.Monoid import qualified Data.Set as Set-import Data.String (fromString)+import Data.String (IsString(..)) import Data.Text (Text, cons, splitOn, toLower, uncons, unpack) import qualified Data.Text as T-import Lens.Family2 ((^.))+import Lens.Family2 ((^.), (^..)) import Proto.Google.Protobuf.Descriptor     ( DescriptorProto     , EnumDescriptorProto@@ -40,10 +48,12 @@     , FileDescriptorProto     , enumType     , field+    , maybe'oneofIndex     , messageType     , name     , nestedType     , number+    , oneofDecl     , package     , typeName     , value@@ -53,7 +63,9 @@     ( Name     , QName     , ModuleName+    , Type     , qual+    , tyPromotedString     , unQual     ) @@ -74,22 +86,68 @@ data MessageInfo n = MessageInfo     { messageName :: n  -- ^ Haskell type name     , messageDescriptor :: DescriptorProto-    , messageFields :: [FieldInfo]-      -- ^ The Haskell names for each field.-      -- This list corresponds 1-1 with "field" in messageDescriptor.+    , messageFields :: [FieldInfo] -- ^ Fields not belonging to a oneof.+    , messageOneofFields :: [OneofInfo]+      -- ^ The oneofs in this message, associated with the fields that+      --   belong to them.     } deriving Functor  -- | Information about a single field of a proto message. data FieldInfo = FieldInfo-    { overloadedField :: String-      -- ^ The Haskell overloaded name of this field; may be shared between two-      -- different message data types.-    , recordFieldName :: Name-      -- ^ The Haskell name of this internal record field.  Unique within each+    { fieldDescriptor  :: FieldDescriptorProto+    , plainFieldName :: FieldName+    }++data OneofInfo = OneofInfo+    { oneofFieldName :: FieldName+    , oneofTypeName :: Name+      -- ^ The name of the sum type corresponding to this oneof.+    , oneofCases :: [OneofCase]+      -- ^ The individual fields that make up this oneof.+    }++data OneofCase = OneofCase+    { caseField :: FieldInfo+    , caseConstructorName :: Name+        -- ^ The constructor for building a 'oneofTypeName' from the+        -- value in this field.+    }++data FieldName = FieldName+    { overloadedName :: Symbol+      -- ^ The overloaded name of lenses that access this field.+      -- For example, if the field is called "foo_bar" in the .proto+      -- then @overloadedName == "fooBar"@ and we might generate+      -- @fooBar@ and/or @maybe'fooBar@ lenses to access the data.+      --+      -- May be shared between two different message data types in the same       -- module.-    , fieldDescriptor :: FieldDescriptorProto+    , haskellRecordFieldName :: Name+      -- ^ The Haskell name of this internal record field; for example,+      -- "_Foo'Bar'baz.  Unique within each module.     } +-- | A string that refers to the name (in Haskell) of a lens that accesses a+-- field.+--+-- For example, in the signature of the overloaded lens+--+-- @+--     foo :: HasLens "foo" ... => Lens ...+-- @+--+-- a 'Symbol' is used to construct both the type-level argument to+-- @HasLens@ and the name of the function @foo@.+newtype Symbol = Symbol String+    deriving (Eq, Ord, IsString, Monoid)++nameFromSymbol :: Symbol -> Name+nameFromSymbol (Symbol s) = fromString s++-- | Construct a promoted, type-level string.+promoteSymbol :: Symbol -> Type+promoteSymbol (Symbol s) = tyPromotedString s+ -- | All the information needed to define or use a proto enum type. data EnumInfo n = EnumInfo     { enumName :: n@@ -119,7 +177,7 @@ unqualifyEnv :: Env Name -> Env QName unqualifyEnv = mapEnv unQual --- | Look up the type definition for a given field.+-- | Look up the Haskell name for the type of a given field (message or enum). definedFieldType :: FieldDescriptorProto -> Env QName -> Definition QName definedFieldType fd env = fromMaybe err $ Map.lookup (fd ^. typeName) env   where@@ -147,36 +205,67 @@ messageDefs :: Text -> String -> DescriptorProto             -> [(Text, Definition Name)] messageDefs protoPrefix hsPrefix d-    = thisDef : subDefs+    = (protoName, thisDef)+          : messageAndEnumDefs+                (protoName <> ".")+                hsPrefix'+                (d ^. nestedType)+                (d ^. enumType)   where-    protoName = d ^. name-    hsName = unpack $ capitalize $ d ^. name-    thisDef = (protoPrefix <> protoName-              , Message MessageInfo-                  { messageName = fromString $ hsPrefix ++ hsName-                  , messageDescriptor = d-                  , messageFields =-                      [ FieldInfo-                          { overloadedField = n-                          , recordFieldName = fromString $ "_" ++ hsPrefix' ++ n-                          , fieldDescriptor = f-                          }-                      | f <- d ^. field-                      , let n = fieldName (f ^. name)-                      ]-                  })-    subDefs = messageAndEnumDefs protoPrefix' hsPrefix'-                  (d ^. nestedType) (d ^. enumType)-    protoPrefix' = protoPrefix <> protoName <> "."-    hsPrefix' = hsPrefix ++ hsName ++ "'"+    protoName = protoPrefix <> d ^. name+    hsPrefix' = hsPrefix ++ hsName (d ^. name) ++ "'"+    hsName = unpack . capitalize . camelCase+    allFields = collectFieldsByOneofIndex (d ^. field)+    thisDef =+        Message MessageInfo+            { messageName = fromString $ hsPrefix ++ hsName (d ^. name)+            , messageDescriptor = d+            , messageFields =+                  map fieldInfo $ Map.findWithDefault [] Nothing allFields+            , messageOneofFields =+                  zipWith oneofInfo [0..]+                      $ d ^.. oneofDecl . traverse . name+            }+    fieldInfo f = FieldInfo f $ mkFieldName $ f ^. name+    mkFieldName n = FieldName+                    { overloadedName = fromString n'+                    , haskellRecordFieldName = fromString $ "_" ++ hsPrefix' ++ n'+                    }+      where+        n' = fieldName n+    oneofInfo :: Int32 -> Text -> OneofInfo+    oneofInfo idx n = OneofInfo+                        { oneofFieldName = mkFieldName n+                        , oneofTypeName = fromString $ hsPrefix' ++ hsName n+                        , oneofCases = map oneofCase+                                          $ Map.findWithDefault [] (Just idx)+                                              allFields+                        }+    oneofCase f = OneofCase+                        { caseField = fieldInfo f+                        , caseConstructorName =+                              -- Note: oneof case constructors aren't prefixed+                              -- by the oneof name; field names (even inside+                              -- of a oneof) are unique within a message.+                              fromString $ hsPrefix' ++ hsName (f ^. name)+                        } ++-- | Group fields by the index of the oneof field that they belong to.+-- (Or 'Nothing' if they don't belong to a oneof.)+collectFieldsByOneofIndex+    :: [FieldDescriptorProto] -> Map.Map (Maybe Int32) [FieldDescriptorProto]+collectFieldsByOneofIndex =+    fmap reverse+    . Map.fromListWith (++)+    . fmap (\f -> (f ^. maybe'oneofIndex, [f]))+ -- | Get the name in Haskell of a proto field, taking care of camel casing and -- clashes with language keywords. fieldName :: Text -> String fieldName = unpack . disambiguate . camelCase   where     disambiguate s-        -- TODO: use a more comprehensive blacklist of Haskell keywords.         | s `Set.member` reservedKeywords = s <> "'"         | otherwise = s 

@@ -20,6 +20,7 @@ import qualified Data.List as List import qualified Data.Map as Map import Data.Maybe (isNothing)+import Data.Monoid ((<>)) import Data.Ord (comparing) import qualified Data.Set as Set import Data.String (fromString)@@ -92,19 +93,31 @@               , "Lens.Labels"               ]             ++ map importSimple imports)-          (concatMap generateDecls (Map.elems definitions)-           ++ concatMap generateFieldDecls allFieldNames)+          (concatMap generateDecls (Map.toList definitions)+           ++ concatMap generateFieldDecls allLensNames)   where     env = Map.union (unqualifyEnv definitions) importedEnv-    generateDecls (Message m) = generateMessageDecls syntaxType env m-    generateDecls (Enum e) = generateEnumDecls e-    allFieldNames = F.toList $ Set.fromList-        [ fieldSymbol i+    generateDecls (protoName, Message m)+        = generateMessageDecls syntaxType env (stripDotPrefix protoName) m+    generateDecls (_, Enum e) = generateEnumDecls e+    allLensNames = F.toList $ Set.fromList+        [ lensSymbol inst         | Message m <- Map.elems definitions-        , f <- messageFields m-        , i <- fieldInstances (lensInfo syntaxType env f)+        , info <- allMessageFields syntaxType env m+        , inst <- recordFieldLenses info         ]+    -- The Env uses the convention that Message names are prefixed with '.'+    -- (since that's how the FileDescriptorProto refers to them).+    -- Strip that off when defining MessageDescriptor.messageName.+    stripDotPrefix s+        | Just ('.', s') <- T.uncons s = s'+        | otherwise = s +allMessageFields :: SyntaxType -> Env QName -> MessageInfo Name -> [RecordField]+allMessageFields syntaxType env info =+    map (plainRecordField syntaxType env) (messageFields info)+        ++ map (oneofRecordField env) (messageOneofFields info)+ importSimple :: ModuleName -> ImportDecl () importSimple m = ImportDecl     { importAnn = ()@@ -126,19 +139,39 @@   where     m' = fromString $ "Data.ProtoLens.Reexport." ++ prettyPrint m -generateMessageDecls :: SyntaxType -> Env QName -> MessageInfo Name -> [Decl]-generateMessageDecls syntaxType env info =+generateMessageDecls :: SyntaxType -> Env QName -> T.Text -> MessageInfo Name -> [Decl]+generateMessageDecls syntaxType env protoName info =     -- data Bar = Bar {     --    foo :: Baz     -- }     [ dataDecl dataName-        [recDecl dataName-                  [ (recordFieldName f, internalType (lensInfo syntaxType env f))-                  | f <- fields+        [recDecl dataName $+                  [ (recordFieldName f, recordFieldType f)+                  | f <- allFields                   ]         ]-        ["Prelude.Show", "Prelude.Eq"]+        ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"]     ] ++++    -- oneof field data type declarations+    -- proto: message Foo {+    --          oneof bar {+    --            float c = 1;+    --            Sub s = 2;+    --          }+    --        }+    -- haskell: data Foo'Bar = Foo'Bar'c !Prelude.Float+    --                       | Foo'Bar's !Sub+    [ dataDecl (oneofTypeName oneofInfo)+      [ conDecl consName [hsFieldType env $ fieldDescriptor f]+      | c <- oneofCases oneofInfo+      , let f = caseField c+      , let consName = caseConstructorName c+      ]+      ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"]+    | oneofInfo <- messageOneofFields info+    ] +++     -- type instance (Functor f, a ~ Baz, b ~ Baz)     --     => HasLens "foo" f Bar Bar a b where     --   lensOf _ = ...@@ -147,38 +180,46 @@     [ instDecl [equalP "a" t, equalP "b" t, classA "Prelude.Functor" ["f"]]         ("Lens.Labels.HasLens" `ihApp`             [sym, "f", dataType, dataType, "a", "b"])-            [[match "lensOf" [pWildCard] $ fieldAccessor i]]-    | f <- fields-    , i <- fieldInstances (lensInfo syntaxType env f)-    , let t = fieldTypeInstance i-    , let sym = tyPromotedString $ fieldSymbol i+            [[match "lensOf" [pWildCard] $+                "Prelude.."+                    @@ rawFieldAccessor (unQual $ recordFieldName li)+                    @@ lensExp i]]+    | li <- allFields+    , i <- recordFieldLenses li+    , let t = lensFieldType i+    , let sym = promoteSymbol $ lensSymbol i     ]     ++     -- instance Data.Default.Class.Default Bar where     [ instDecl [] ("Data.Default.Class.Default" `ihApp` [dataType])         -- def = Bar { _Bar_foo = 0 }-        [ +        [             [ match "def" []-                $ recConstr (unQual dataName)-                      [ fieldUpdate (unQual $ recordFieldName f)+                $ recConstr (unQual dataName) $+                      [ fieldUpdate (unQual $ haskellRecordFieldName $ plainFieldName f)                             (hsFieldDefault syntaxType env (fieldDescriptor f))-                      | f <- fields+                      | f <- messageFields info+                      ] +++                      [ fieldUpdate (unQual $ haskellRecordFieldName $ oneofFieldName o)+                            "Prelude.Nothing"+                      | o <- messageOneofFields info                       ]             ]         ]     -- instance Message.Message Bar where     , instDecl [] ("Data.ProtoLens.Message" `ihApp` [dataType])-        [[match "descriptor" [] $ descriptorExpr syntaxType env info]]+        [[match "descriptor" [] $ descriptorExpr syntaxType env protoName info]]     ]   where     dataType = tyCon $ unQual dataName-    MessageInfo { messageName = dataName, messageFields = fields} = info+    dataName = messageName info+    allFields = allMessageFields syntaxType env info  generateEnumDecls :: EnumInfo Name -> [Decl] generateEnumDecls info =     [ dataDecl dataName         [conDecl n [] | n <- constructorNames]-        ["Prelude.Show", "Prelude.Eq"]+        ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"]     -- instance Data.Default.Class.Default Foo where     --   def = FirstEnumValue     , instDecl [] ("Data.Default.Class.Default" `ihApp` [dataType])@@ -314,7 +355,7 @@     errorMessage = "toEnum: unknown value for enum " ++ unpack (ed ^. name)                       ++ ": " -generateFieldDecls :: String -> [Decl]+generateFieldDecls :: Symbol -> [Decl] generateFieldDecls xStr =     -- foo :: forall x f s t a b     --        . HasLens x f s t a b => LensLike f s t a b@@ -331,96 +372,152 @@               ]     ]   where-    x = fromString xStr-    xSym = tyPromotedString xStr+    x = nameFromSymbol xStr+    xSym = promoteSymbol xStr  ------------------------------------------ --- | The Haskell types and lenses for an individual field of a message.--- This is used to generate both the data record Decl and the instances of--- HasField.-data LensInfo = LensInfo-    { internalType :: Type  -- ^ Internal type in the record-    , fieldInstances :: [FieldInstanceInfo]  -- ^ All instances of Field/HasField+-- | An individual field of the Haskell type corresponding to a proto message.+data RecordField = RecordField+    { recordFieldName :: Name  -- ^ The Haskell name of this field (unique+                               --   within the module).+    , recordFieldType :: Type  -- ^ Internal type in the record+    , recordFieldLenses :: [LensInstance]+        -- ^ All of the (overloaded) lenses accessing this record field.     } -data FieldInstanceInfo = FieldInstanceInfo-    { fieldSymbol :: String      -- ^ The name of the Symbol corresponding to-                                 --   this field.-    , fieldTypeInstance :: Type  -- ^ The type instance for Field, i.e.,-                                 --     type instance Field "foo" Bar = ...-    , fieldAccessor :: Exp       -- ^ The value of the "field" lens for this-                                 --   field, i.e.,-                                 --     field _ = ...+-- | An instance of HasLens for a particualr field.+data LensInstance = LensInstance+    { lensSymbol :: Symbol+          -- ^ The overloaded name for this lens.+    , lensFieldType :: Type+          -- ^ The type pointed to from this lens.+    , lensExp :: Exp+        -- ^ A lens from the recordFieldType to the lensFieldType; i.e.,+        -- from how it's actually stored in the Haskell record to how the+        -- lens views it.     }  -- | Compile information about the record field type and type/class instances -- for this particular field.-lensInfo :: SyntaxType -> Env QName -> FieldInfo -> LensInfo-lensInfo syntaxType env f = case fd ^. label of+--+-- Used for "plain" record fields that are not part of a oneof.+plainRecordField :: SyntaxType -> Env QName -> FieldInfo -> RecordField+plainRecordField syntaxType env f = case fd ^. label of     -- data Foo = Foo { _Foo_bar :: Bar }     -- type instance Field "bar" Foo = Bar-    FieldDescriptorProto'LABEL_REQUIRED -> LensInfo baseType-                  [FieldInstanceInfo-                      { fieldSymbol = baseName-                      , fieldTypeInstance = baseType-                      , fieldAccessor = rawAccessor+    FieldDescriptorProto'LABEL_REQUIRED+        -> recordField baseType+                  [LensInstance+                      { lensSymbol = baseName+                      , lensFieldType = baseType+                      , lensExp = rawAccessor                       }]     FieldDescriptorProto'LABEL_OPTIONAL         | isDefaultingOptional syntaxType fd-              -> LensInfo baseType-                    [FieldInstanceInfo-                      { fieldSymbol = baseName-                      , fieldTypeInstance = baseType-                      , fieldAccessor = rawAccessor+              -> recordField baseType+                    [LensInstance+                      { lensSymbol = baseName+                      , lensFieldType = baseType+                      , lensExp = rawAccessor                       }]+    -- data Foo = Foo { _Foo_bar :: Maybe Bar }+    -- type instance Field "bar" Foo = Bar+    -- type instance Field "maybe'bar" Foo = Maybe Bar+        | otherwise ->+              recordField maybeType+                  [LensInstance+                      { lensSymbol = baseName+                      , lensFieldType = baseType+                      , lensExp = maybeAccessor+                      }+                  , LensInstance+                      { lensSymbol = "maybe'" <> baseName+                      , lensFieldType = maybeType+                      , lensExp = rawAccessor+                      }+                  ]     FieldDescriptorProto'LABEL_REPEATED         -- data Foo = Foo { _Foo_bar :: Map Bar Baz }         -- type instance Field "foo" Foo = Map Bar Baz         | Just (k,v) <- getMapFields env fd -> let             mapType = "Data.Map.Map" @@ hsFieldType env (fieldDescriptor k)                                      @@ hsFieldType env (fieldDescriptor v)-            in LensInfo mapType-                  [FieldInstanceInfo-                       { fieldSymbol = baseName-                       , fieldTypeInstance = mapType-                       , fieldAccessor = rawAccessor+            in recordField mapType+                  [LensInstance+                       { lensSymbol = baseName+                       , lensFieldType = mapType+                       , lensExp = rawAccessor                        }]         -- data Foo = Foo { _Foo_bar :: [Bar] }         -- type instance Field "bar" Foo = [Bar]-        | otherwise -> LensInfo listType-                  [FieldInstanceInfo-                      { fieldSymbol = baseName-                      , fieldTypeInstance = listType-                      , fieldAccessor = rawAccessor+        | otherwise -> recordField listType+                  [LensInstance+                      { lensSymbol = baseName+                      , lensFieldType = listType+                      , lensExp = rawAccessor                       }]-    -- data Foo = Foo { _Foo_bar :: Maybe Bar }-    -- type instance Field "bar" Foo = Bar-    -- type instance Field "maybe'bar" Foo = Maybe Bar-    FieldDescriptorProto'LABEL_OPTIONAL -> LensInfo maybeType-                  [FieldInstanceInfo-                      { fieldSymbol = baseName-                      , fieldTypeInstance = baseType-                      , fieldAccessor = maybeAccessor-                      }-                  , FieldInstanceInfo-                      { fieldSymbol = maybeName-                      , fieldTypeInstance = "Prelude.Maybe" @@ baseType-                      , fieldAccessor = rawAccessor-                      }-                  ]   where-    baseName = overloadedField f+    recordField = RecordField (haskellRecordFieldName $ plainFieldName f)+    baseName = overloadedName $ plainFieldName f     fd = fieldDescriptor f     baseType = hsFieldType env fd-    listType = tyList baseType     maybeType = "Prelude.Maybe" @@ baseType-    maybeName = "maybe'" ++ baseName-    maybeAccessor = "Prelude.." @@ fromString maybeName-                        @@ ("Data.ProtoLens.maybeLens"-                                @@ hsFieldValueDefault env fd)-    rawAccessor = rawFieldAccessor $ unQual $ recordFieldName f+    listType = tyList baseType+    rawAccessor = "Prelude.id"+    maybeAccessor = "Data.ProtoLens.maybeLens"+                          @@ hsFieldValueDefault env fd ++oneofRecordField :: Env QName -> OneofInfo -> RecordField+oneofRecordField env oneofInfo+    = RecordField+        { recordFieldName = haskellRecordFieldName $ oneofFieldName oneofInfo+        , recordFieldType =+              "Prelude.Maybe" @@ tyCon (unQual $ oneofTypeName oneofInfo)+        , recordFieldLenses = lenses+        }+  where+    lenses =+        -- Only generate a "maybe" version of this lens,+        -- since oneofs don't have a notion of a "default" case.+        -- data Foo = Foo { _Foo'bar = Maybe Foo'Bar }+        -- type instance Field "maybe'bar" Foo = Maybe Foo'Bar+        [LensInstance+          { lensSymbol = "maybe'" <> overloadedName+                                        (oneofFieldName oneofInfo)+          , lensFieldType =+                "Prelude.Maybe" @@ tyCon (unQual $ oneofTypeName oneofInfo)+          , lensExp = "Prelude.id"+          }+         ]+         ++ concat+          -- Generate the same lenses for each sub-field of the oneof+          -- as if they were proto2 optional fields.+          -- type instance Field "bar" Foo = Bar+          -- type instance Field "maybe'bar" Foo = Maybe Bar+            [ [ LensInstance+                { lensSymbol = maybeName+                , lensFieldType = "Prelude.Maybe" @@ baseType+                , lensExp = oneofFieldAccessor c+                }+              , LensInstance+                { lensSymbol = baseName+                , lensFieldType = baseType+                , lensExp = "Prelude.."+                                @@ oneofFieldAccessor c+                                @@ ("Data.ProtoLens.maybeLens"+                                              @@ hsFieldValueDefault env+                                                    (fieldDescriptor f))+                }+              ]+            | c <- oneofCases oneofInfo+            , let f = caseField c+            , let baseName = overloadedName $ plainFieldName f+            , let baseType = hsFieldType env $ fieldDescriptor f+            , let maybeName = "maybe'" <> baseName+            ]+ -- Get the key/value types of this type, if it is really a map. getMapFields :: Env QName -> FieldDescriptorProto              -> Maybe (FieldInfo, FieldInfo)@@ -533,8 +630,40 @@     setter = lambda ["x__", "y__"]                     $ recUpdate "x__" [fieldUpdate f "y__"] -descriptorExpr :: SyntaxType -> Env QName -> MessageInfo Name -> Exp-descriptorExpr syntaxType env m+-- | A lens that maps from a oneof sum type to one of its individual cases.+--+-- For example, with+--     data Foo = Bar Int32 | Baz Int64+--+-- this will generate a lens of type @Lens' (Maybe Foo) (Maybe Int32)@.+--+-- (Recall that oneofs are stored in a proto message as @Maybe Foo@, where+-- 'Nothing' means that it's either set to an unknown value or unset.)+--+-- lens+--   (\ x__ -> case x__ of+--       Prelude.Just (Foo'c x__val) -> Prelude.Just x__val+--       otherwise -> Prelude.Nothing)+--   (\ _ y__ -> fmap Foo'c y__+oneofFieldAccessor :: OneofCase -> Exp+oneofFieldAccessor o+        = "Lens.Family2.Unchecked.lens" @@ getter @@ setter+  where+    consName = caseConstructorName o+    getter = lambda ["x__"] $+        case' "x__"+            [ alt+                (pApp "Prelude.Just" [pApp (unQual consName) ["x__val"]])+                ("Prelude.Just" @@ "x__val")+            , alt+                "_otherwise"+                "Prelude.Nothing"+            ]+    setter = lambda ["_", "y__"]+                $ "Prelude.fmap" @@ con (unQual consName) @@ "y__"++descriptorExpr :: SyntaxType -> Env QName -> T.Text -> MessageInfo Name -> Exp+descriptorExpr syntaxType env protoName m     -- let foo__field_descriptor = ...     --     ...     -- in Message.MessageDescriptor@@ -543,15 +672,16 @@     --     -- (Note that the two maps have the same elements but different keys.  We     -- use the "let" expression to share elements between the two maps.)-    = let' (map (fieldDescriptorVarBind $ messageName m) $ messageFields m)+    = let' (map (fieldDescriptorVarBind $ messageName m) $ fields)         $ "Data.ProtoLens.MessageDescriptor"+          @@ ("Data.Text.pack" @@ stringExp (T.unpack protoName))           @@ ("Data.Map.fromList" @@ list fieldsByTag)           @@ ("Data.Map.fromList" @@ list fieldsByTextFormatName)   where     fieldsByTag =         [tuple               [ t, fieldDescriptorVar f ]-              | f <- messageFields m+              | f <- fields               , let t = "Data.ProtoLens.Tag"                           @@ litInt (fromIntegral                                       $ fieldDescriptor f ^. number)@@ -559,18 +689,20 @@     fieldsByTextFormatName =         [tuple               [ t, fieldDescriptorVar f ]-              | f <- messageFields m+              | f <- fields               , let t = stringExp $ T.unpack $ textFormatFieldName env                                                     (fieldDescriptor f)               ]-    fieldDescriptorVar = fromString . fieldDescriptorName+    fieldDescriptorVar = var . unQual . fieldDescriptorName     fieldDescriptorName f-        = fromString $ overloadedField f ++ "__field_descriptor"+        = nameFromSymbol $ overloadedName (plainFieldName f) <> "__field_descriptor"     fieldDescriptorVarBind n f         = funBind-              [match (fromString $ fieldDescriptorName f) []+              [match (fieldDescriptorName f) []                   $ fieldDescriptorExpr syntaxType env n f               ]+    fields = messageFields m+                ++ (messageOneofFields m >>= fmap caseField . oneofCases)  -- | Get the name of the field when used in a text format proto. Groups are -- special because their text format field name is the name of their type,@@ -618,25 +750,29 @@           FieldDescriptorProto'LABEL_REPEATED               | Just (k, v) <- getMapFields env fd                   -> "Data.ProtoLens.MapField"-                         @@ fromString (overloadedField k)-                         @@ fromString (overloadedField v)+                         @@ con (unQual $ nameFromSymbol $ overloadedField k)+                         @@ con (unQual $ nameFromSymbol $ overloadedField v)               | otherwise -> "Data.ProtoLens.RepeatedField"                   @@ if isPackedField syntaxType fd                         then "Data.ProtoLens.Packed"                         else "Data.ProtoLens.Unpacked"     hsFieldName-        = fromString $ case fd ^. label of+        = nameFromSymbol $ case fd ^. label of               FieldDescriptorProto'LABEL_OPTIONAL                   | not (isDefaultingOptional syntaxType fd)-                      -> "maybe'" ++ overloadedField f+                      -> "maybe'" <> overloadedField f               _ -> overloadedField f +overloadedField :: FieldInfo -> Symbol+overloadedField = overloadedName . plainFieldName+ isDefaultingOptional :: SyntaxType -> FieldDescriptorProto -> Bool isDefaultingOptional syntaxType f     = f ^. label == FieldDescriptorProto'LABEL_OPTIONAL           && syntaxType == Proto3           && f ^. type' /= FieldDescriptorProto'TYPE_MESSAGE-          -- For now, we treat oneof's like proto2 optional fields.+          -- oneof fields have the same API as proto2 optional fields,+          -- but setting one field will automatically clear the others.           && isNothing (f ^. maybe'oneofIndex)  isPackedField :: SyntaxType -> FieldDescriptorProto -> Bool

@@ -38,14 +38,17 @@     , libBuildInfo     , testBuildInfo     )-import Distribution.Simple.BuildPaths (autogenModulesDir)+import qualified Distribution.Simple.BuildPaths as BuildPaths import Distribution.Simple.InstallDirs (datadir) import Distribution.Simple.LocalBuildInfo     ( LocalBuildInfo(..)     , absoluteInstallDirs     , componentPackageDeps+#if MIN_VERSION_Cabal(2,0,0)+    , allComponentsInBuildOrder+#endif     )-import Distribution.Simple.PackageIndex (lookupSourcePackageId)+import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.Setup (fromFlag, copyDest, copyVerbosity) import Distribution.Simple.Utils     ( createDirectoryIfMissingVerbose@@ -72,6 +75,7 @@     , findExecutable     , removeDirectoryRecursive     )+import System.IO (hPutStrLn, stderr) import System.Process (callProcess)  -- | This behaves the same as 'Distribution.Simple.defaultMain', but@@ -172,9 +176,7 @@     -- Collect import paths from build-depends of this package.     importDirs <- filterM doesDirectoryExist                      [ InstalledPackageInfo.dataDir info </> protoLensImportsPrefix-                     | (_, c, _) <- componentsConfigs l-                     , (_, i) <- componentPackageDeps c-                     , info <- lookupSourcePackageId (installedPkgs l) i+                     | info <- collectDeps l                      ]     generateProtosWithImports (root : importDirs) (autogenModulesDir l)                               -- Applying 'root </>' does nothing if the path is already@@ -263,14 +265,63 @@     -> [FilePath] -- ^ The .proto files to process.     -> IO () generateProtosWithImports imports output files = do-    maybeProtoLensProtoc <- findExecutable "proto-lens-protoc"-    case maybeProtoLensProtoc of-        Nothing -> error "Couldn't find executable proto-lens-protoc."-        Just protoLensProtoc -> do-            createDirectoryIfMissing True output-            callProcess "protoc" $-                [ "--plugin=protoc-gen-haskell=" ++ protoLensProtoc-                , "--haskell_out=" ++ output-                ]-                ++ ["--proto_path=" ++ p | p <- imports]-                ++ files+    protoLensProtoc+        <- findExecutableOrDie "proto-lens-protoc"+              $ "Please file a bug at "+                  ++ "https://github.com/google/proto-lens/issues ."+    protoc <- findExecutableOrDie "protoc"+                $ "Follow the installation instructions at "+                    ++ "https://google.github.io/proto-lens/installing-protoc.html ."+    createDirectoryIfMissing True output+    callProcess protoc $+        [ "--plugin=protoc-gen-haskell=" ++ protoLensProtoc+        , "--haskell_out=" ++ output+        ]+        ++ ["--proto_path=" ++ p | p <- imports]+        ++ files++-- | Search the PATH for an executable, printing an error message if it's not+-- found.+findExecutableOrDie :: String -> String -> IO FilePath+findExecutableOrDie name debugMsg = do+    maybePath <- findExecutable name+    case maybePath of+        Just path -> return path+        Nothing -> do+            let sep = "=========="+            hPutStrLn stderr sep+            hPutStrLn stderr $ "Error: couldn't find the executable " ++ show name+                            ++ " in your $PATH."+                            ++ "\n    " ++ debugMsg+            hPutStrLn stderr sep+            error $ "Missing executable " ++ show name++-------------------------------------------------------+-- Compatibility layer between Cabal-1.* and Cabal-2.*++-- | List all the packages that this one depends on.+collectDeps :: LocalBuildInfo -> [InstalledPackageInfo.InstalledPackageInfo]+#if MIN_VERSION_Cabal(2,0,0)+collectDeps l = do+    c <- allComponentsInBuildOrder l+    (i,_) <- componentPackageDeps c+    Just p <- [PackageIndex.lookupUnitId (installedPkgs l) i]+    return p+#else+collectDeps l = do+    (_, c ,_) <- componentsConfigs l+    (_, i) <- componentPackageDeps c+    PackageIndex.lookupSourcePackageId (installedPkgs l) i+#endif++-- | Get the package-level "autogen" directory where we're putting the+-- generated .hs files.  (The 'BuildPaths.autogenModulesDir' file was+-- deprecated in Cabal-2.0 in favor of module-specific directories+-- (@autogenComponentModulesDir@), but our setup currently needs the more+-- global location.)+autogenModulesDir :: LocalBuildInfo -> FilePath+#if MIN_VERSION_Cabal(2,0,0)+autogenModulesDir = BuildPaths.autogenPackageModulesDir+#else+autogenModulesDir = BuildPaths.autogenModulesDir+#endif