proto-lens-protoc 0.2.2.3 → 0.3.0.0

raw patch · 9 files changed

+1015/−339 lines, 9 filesdep +deepseqdep +prettydep +proto-lens-protocdep −proto-lens-descriptorsdep ~haskell-src-extsdep ~lens-labelsdep ~proto-lensPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, pretty, proto-lens-protoc

Dependencies removed: proto-lens-descriptors

Dependency ranges changed: haskell-src-exts, lens-labels, proto-lens

API changes (from Hackage documentation)

Files

• Changelog.md +17/−1
• app/protoc-gen-haskell.hs +97/−0
• proto-lens-protoc.cabal +89/−87
• src/Data/ProtoLens/Compiler/Combinators.hs +125/−23
• src/Data/ProtoLens/Compiler/Definitions.hs +82/−8
• src/Data/ProtoLens/Compiler/Generate.hs +469/−97
• src/Data/ProtoLens/Compiler/Plugin.hs +13/−9
• src/Data/ProtoLens/Setup.hs +123/−25
• src/protoc-gen-haskell.hs +0/−89

@@ -1,6 +1,22 @@ # Changelog for `proto-lens-protoc` -## Unreleased changes+## v0.3.0.0+- Remove support for `ghc-7.10`. (#136)+- Use a `.cabal` file that's auto-generated from `hpack`. (#138)+- Separate types into their own module, apart from field lenses.+- Improve readability of `HasLens` instances. (#118)+- Add support for tracking unknown fields. (#129)+- Don't generate Haskell modules if they won't be used. (#126)+- Bundle enum pattern synonyms exports with their type. (#136)+- Split the `Message` class into separate methods. (#139)+- Refactor the `FieldDescriptorType. (#147)+- Add a case to proto3 enums for unknown values. (#137)+- Track consolidation of `proto-lens-descriptors` into `proto-lens`. (#140)+- Generate service definitions using promoted datatypes. (#154)+- Generate prisms for `oneof` message fields. (#160)+- Build with `haskell-src-exts-1.20.*`. (#170)+- Add Haddock comments to fields. (#172)+- Don't unnecessarily touch files. (#177)  ## v0.2.2.3 - Don't camel-case message names.  This reverts behavior which was added

@@ -0,0 +1,97 @@+-- Copyright 2016 Google Inc. All Rights Reserved.+--+-- Use of this source code is governed by a BSD-style+-- license that can be found in the LICENSE file or at+-- https://developers.google.com/open-source/licenses/bsd++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+module Main where++import qualified Data.ByteString as B+import Data.Map.Strict ((!))+import Data.Monoid ((<>))+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Text (Text, pack)+import Data.ProtoLens (decodeMessage, def, encodeMessage)+import Lens.Family2+import Proto.Google.Protobuf.Compiler.Plugin+    ( CodeGeneratorRequest+    , CodeGeneratorResponse+    )+import Proto.Google.Protobuf.Compiler.Plugin_Fields+    ( content+    , file+    , fileToGenerate+    , parameter+    , protoFile+    )+import Proto.Google.Protobuf.Descriptor (FileDescriptorProto)+import Proto.Google.Protobuf.Descriptor_Fields (name, dependency)+import System.Environment (getProgName)+import System.Exit (exitWith, ExitCode(..))+import System.IO as IO++import Data.ProtoLens.Compiler.Combinators+    ( prettyPrint+    , prettyPrintModule+    , getModuleName+    )+import Data.ProtoLens.Compiler.Generate+import Data.ProtoLens.Compiler.Plugin++main :: IO ()+main = do+    contents <- B.getContents+    progName <- getProgName+    case decodeMessage contents of+        Left e -> IO.hPutStrLn stderr e >> exitWith (ExitFailure 1)+        Right x -> B.putStr $ encodeMessage $ makeResponse progName x++makeResponse :: String -> CodeGeneratorRequest -> CodeGeneratorResponse+makeResponse prog request = let+    useReexport = case T.unpack $ request ^. parameter of+                    "" -> reexported+                    "no-reexports" -> id+                    p -> error $ "Error reading parameter: " ++ show p+    outputFiles = generateFiles useReexport header+                      (request ^. protoFile)+                      (request ^. fileToGenerate)+    header :: FileDescriptorProto -> Text+    header f = "{- This file was auto-generated from "+                <> (f ^. name)+                <> " by the " <> pack prog <> " program. -}\n"+    in def & file .~ [ def & name .~ outputName+                           & content .~ outputContent+                     | (outputName, outputContent) <- outputFiles+                     ]+++generateFiles :: ModifyImports -> (FileDescriptorProto -> Text)+              -> [FileDescriptorProto] -> [ProtoFileName] -> [(Text, Text)]+generateFiles modifyImports header files toGenerate = let+  modulePrefix = "Proto"+  filesByName = analyzeProtoFiles modulePrefix files+  -- The contents of the generated Haskell file for a given .proto file.+  modulesToBuild f = let+      deps = descriptor f ^. dependency+      imports = Set.toAscList $ Set.fromList+                  [ haskellModule (filesByName ! exportName)+                  | dep <- deps+                  , exportName <- exports (filesByName ! dep)+                  ]+      in generateModule (haskellModule f) imports+             (fileSyntaxType (descriptor f))+             modifyImports+             (definitions f)+             (collectEnvFromDeps deps filesByName)+             (services f)+  in [ ( outputFilePath $ prettyPrint $ getModuleName modul+       , header (descriptor f) <> pack (prettyPrintModule modul)+       )+     | fileName <- toGenerate+     , let f = filesByName ! fileName+     , modul <- modulesToBuild f+     ]+

@@ -1,98 +1,100 @@-name:                proto-lens-protoc-version:             0.2.2.3-synopsis:            Protocol buffer compiler for the proto-lens library.-description:-  Turn protocol buffer files (.proto) into Haskell files (.hs) which-  can be used with the proto-lens package.+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 4175638cf6efe9244007b8b4992689b765c2b68967bd4c36bdbc182a92e587c4 -  The library component of this package contains compiler code (namely-  Data.ProtoLens.Compiler.*) that is not guaranteed to have stable APIs.-license:             BSD3-license-file:        LICENSE-author:              Judah Jacobson-maintainer:          proto-lens@googlegroups.com-copyright:           Google Inc.-category:            Data-build-type:          Simple-cabal-version:       >=1.21-extra-source-files:  Changelog.md+name:           proto-lens-protoc+version:        0.3.0.0+synopsis:       Protocol buffer compiler for the proto-lens library.+description:    Turn protocol buffer files (.proto) into Haskell files (.hs) which can be used with the proto-lens package.+                The library component of this package contains compiler code (namely Data.ProtoLens.Compiler.*) is not guaranteed to have stable APIs.'+category:       Data+homepage:       https://github.com/google/proto-lens#readme+bug-reports:    https://github.com/google/proto-lens/issues+author:         Judah Jacobson+maintainer:     proto-lens@googlegroups.com+copyright:      Google Inc.+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.21 --- Work around stack bug, since we don't want to build the library--- during bootstrapping:--- https://github.com/commercialhaskell/stack/issues/1406-flag only-executable-    Description: Only build the executable.  Used for bootstrapping.-    Default: False+extra-source-files:+    Changelog.md -library-  if flag(only-executable) {-      buildable: False-  } else {-    exposed-modules:-        Data.ProtoLens.Compiler.Combinators-        Data.ProtoLens.Compiler.Definitions-        Data.ProtoLens.Compiler.Generate-        Data.ProtoLens.Compiler.Plugin-        Data.ProtoLens.Setup-    default-language:  Haskell2010-    hs-source-dirs:    src-    build-depends:-          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 && < 1.6-        , haskell-src-exts >= 1.17 && < 1.20-        , lens-family == 1.2.*-        , lens-labels == 0.1.*-        , process >= 1.2 && < 1.7-        -- 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.-        -- For forwards compatibility, reexport them as new module names so that-        -- other packages don't accidentally write non-generated code that-        -- relies on these modules being reexported by proto-lens-protoc.-          Prelude as Data.ProtoLens.Reexport.Prelude-        , Data.Int as Data.ProtoLens.Reexport.Data.Int-        , Data.Word as Data.ProtoLens.Reexport.Data.Word-        , Data.ByteString as Data.ProtoLens.Reexport.Data.ByteString-        , Data.Default.Class as Data.ProtoLens.Reexport.Data.Default.Class-        , Data.Map as Data.ProtoLens.Reexport.Data.Map-        , Data.ProtoLens as Data.ProtoLens.Reexport.Data.ProtoLens-        , Data.ProtoLens.Message.Enum as Data.ProtoLens.Reexport.Data.ProtoLens.Message.Enum-        , 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-    }+source-repository head+  type: git+  location: https://github.com/google/proto-lens+  subdir: proto-lens-protoc -executable proto-lens-protoc-  main-is:  protoc-gen-haskell.hs+flag only-executable+  description: Only build the executable.  Used for bootstrapping.+  manual: False+  default: False +library+  hs-source-dirs:+      src   build-depends:-        base >= 4.8 && < 4.11-      , bytestring == 0.10.*-      , containers == 0.5.*-      , data-default-class >= 0.0 && < 0.2-      , filepath >= 1.4 && < 1.6-      , haskell-src-exts >= 1.17 && < 1.20-      , lens-family == 1.2.*-      -- 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:+      Cabal >=1.22 && <2.1+    , base >=4.8 && <4.11+    , bytestring ==0.10.*+    , containers ==0.5.*+    , data-default-class >=0.0 && <0.2+    , deepseq ==1.4.*+    , directory >=1.2 && <1.4+    , filepath >=1.4 && <1.6+    , haskell-src-exts >=1.17 && <1.21+    , lens-family ==1.2.*+    , lens-labels ==0.2.*+    , pretty ==1.1.*+    , process >=1.2 && <1.7+    , proto-lens ==0.3.*+    , text ==1.2.*+  exposed-modules:       Data.ProtoLens.Compiler.Combinators       Data.ProtoLens.Compiler.Definitions       Data.ProtoLens.Compiler.Generate       Data.ProtoLens.Compiler.Plugin+      Data.ProtoLens.Setup+  other-modules:+      Paths_proto_lens_protoc+  reexported-modules:+      Prelude as Data.ProtoLens.Reexport.Prelude,+      Data.Int as Data.ProtoLens.Reexport.Data.Int,+      Data.Word as Data.ProtoLens.Reexport.Data.Word,+      Data.ByteString as Data.ProtoLens.Reexport.Data.ByteString,+      Data.ByteString.Char8 as Data.ProtoLens.Reexport.Data.ByteString.Char8,+      Data.Default.Class as Data.ProtoLens.Reexport.Data.Default.Class,+      Data.Map as Data.ProtoLens.Reexport.Data.Map,+      Data.ProtoLens as Data.ProtoLens.Reexport.Data.ProtoLens,+      Data.ProtoLens.Service.Types as Data.ProtoLens.Reexport.Data.ProtoLens.Service.Types,+      Data.ProtoLens.Message.Enum as Data.ProtoLens.Reexport.Data.ProtoLens.Message.Enum,+      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.Prism as Data.ProtoLens.Reexport.Lens.Labels.Prism,+      Text.Read as Data.ProtoLens.Reexport.Text.Read+  default-language: Haskell2010 -  default-language:    Haskell2010+executable proto-lens-protoc+  main-is: protoc-gen-haskell.hs+  hs-source-dirs:+      app+  build-depends:+      base >=4.8 && <4.11+    , bytestring ==0.10.*+    , containers ==0.5.*+    , data-default-class >=0.0 && <0.2+    , deepseq ==1.4.*+    , filepath >=1.4 && <1.6+    , haskell-src-exts >=1.17 && <1.21+    , lens-family ==1.2.*+    , proto-lens ==0.3.*+    , proto-lens-protoc+    , text ==1.2.*+  other-modules:+      Paths_proto_lens_protoc+  default-language: Haskell2010

@@ -7,6 +7,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-} -- | Some utility functions, classes and instances for nicer code generation. -- -- Re-exports simpler versions of the types and constructors from@@ -33,13 +34,20 @@ import qualified Language.Haskell.Exts.Pretty as Pretty import Language.Haskell.Exts.SrcLoc (SrcLoc, noLoc) #endif+import Text.PrettyPrint (($+$), (<+>), render, text, vcat, Doc)  #if MIN_VERSION_haskell_src_exts(1,18,0) prettyPrint :: Pretty.Pretty a => a -> String prettyPrint = Pretty.prettyPrint++prettyPrim :: Pretty.Pretty a => a -> Doc+prettyPrim = Pretty.prettyPrim #else prettyPrint :: (Functor m, Pretty.Pretty (m SrcLoc)) => m () -> String prettyPrint = Pretty.prettyPrint . fmap (const noLoc)++prettyPrim :: (Functor m, Pretty.Pretty (m SrcLoc)) => m () -> Doc+prettyPrim = Pretty.prettyPrim . fmap (const noLoc) #endif  type Asst = Syntax.Asst ()@@ -67,35 +75,68 @@ type Decl = Syntax.Decl ()  patSynSig :: Name -> Type -> Decl+#if MIN_VERSION_haskell_src_exts(1,20,0)+patSynSig n t = Syntax.PatSynSig () [n] Nothing Nothing Nothing t+#else patSynSig n t = Syntax.PatSynSig () n Nothing Nothing Nothing t+#endif  patSyn :: Pat -> Pat -> Decl patSyn p1 p2 = Syntax.PatSyn () p1 p2 Syntax.ImplicitBidirectional -dataDecl :: Name -> [ConDecl] -> [QName] -> Decl-dataDecl name conDecls derives-    = Syntax.DataDecl () (Syntax.DataType ()) Nothing+dataDecl :: Name -> [ConDecl] -> Deriving -> Decl+dataDecl = dataDeclHelper $ Syntax.DataType ()++newtypeDecl :: Name -> Type -> Deriving -> Decl+newtypeDecl name wrappedType+    = dataDeclHelper (Syntax.NewType ()) name+          [Syntax.ConDecl () name [wrappedType]]++dataDeclHelper :: Syntax.DataOrNew () -> Name -> [ConDecl] -> Deriving -> Decl+dataDeclHelper dataOrNew name conDecls derives+    = Syntax.DataDecl () dataOrNew Nothing         (Syntax.DHead () name)             [Syntax.QualConDecl () Nothing Nothing q | q <- conDecls]-        $ Just $ Syntax.Deriving ()-            [ Syntax.IRule () Nothing Nothing (Syntax.IHCon () c)-            | c <- derives-            ]+#if MIN_VERSION_haskell_src_exts(1,20,0)+        [derives]+#else+        $ Just derives+#endif +type Deriving = Syntax.Deriving ()++deriving' :: [QName] -> Deriving+deriving' classes = Syntax.Deriving ()+#if MIN_VERSION_haskell_src_exts(1,20,0)+                      Nothing+#endif+                      [ Syntax.IRule () Nothing Nothing (Syntax.IHCon () c)+                      | c <- classes+                      ]+ funBind :: [Match] -> Decl funBind = Syntax.FunBind () -instDecl :: [Asst] -> InstHead -> [[Match]] -> Decl-instDecl ctx instHead matches+instType :: Type -> Type -> Syntax.InstDecl ()+instType = Syntax.InsType ()++instMatch :: [Match] -> Syntax.InstDecl ()+instMatch m = Syntax.InsDecl () $ funBind m++instDeclWithTypes :: [Asst] -> InstHead -> [Syntax.InstDecl ()] -> Decl+instDeclWithTypes ctx instHead decls     = Syntax.InstDecl () Nothing         (Syntax.IRule () Nothing ctx' instHead)-        $ Just [Syntax.InsDecl () $ funBind m | m <- matches]+        $ Just decls   where     ctx' = case ctx of         [] -> Nothing         [c] -> Just $ Syntax.CxSingle () c         cs -> Just $ Syntax.CxTuple () cs +instDecl :: [Asst] -> InstHead -> [[Match]] -> Decl+instDecl ctx instHead = instDeclWithTypes ctx instHead . fmap instMatch+ typeSig :: [Name] -> Type -> Decl typeSig = Syntax.TypeSig () @@ -150,6 +191,8 @@ ihApp :: InstHead -> [Type] -> InstHead ihApp = foldl (Syntax.IHApp ()) +tyParen :: Type -> Type+tyParen = Syntax.TyParen ()  type Match = Syntax.Match () @@ -157,19 +200,42 @@ match :: Name -> [Pat] -> Exp -> Syntax.Match () match n ps e = Syntax.Match () n ps (Syntax.UnGuardedRhs () e) Nothing -type Module = Syntax.Module ()+-- | A hand-rolled type for modules, which allows comments on top-level+-- declarations.+data Module = Module ModuleName (Maybe [ExportSpec]) [ModulePragma]+                [Syntax.ImportDecl ()]+                [CommentedDecl] -module' :: ModuleName -> [ModulePragma] -> [Syntax.ImportDecl ()] -> [Decl] -> Module-module' modName-    = 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)+-- | A declaration, along with an optional comment.+data CommentedDecl = CommentedDecl (Maybe String) Decl +uncommented :: Decl -> CommentedDecl+uncommented = CommentedDecl Nothing++commented :: String -> Decl -> CommentedDecl+commented = CommentedDecl . Just++prettyPrintModule :: Module -> String+prettyPrintModule (Module modName exports pragmas imports decls) =+    render $+        vcat (map prettyPrim pragmas)+        $+$ prettyPrim (Syntax.ModuleHead () modName+                           -- no warning text+                           Nothing+                           (Syntax.ExportSpecList () <$> exports))+        $+$ vcat (map prettyPrim imports)+        $+$ ""+        $+$ vcat (map pprintDecl decls)+  where+    pprintDecl (CommentedDecl Nothing d) = prettyPrim d+    pprintDecl (CommentedDecl (Just c) d)+        = "{- |" <+> text c <+> "-}" $+$ prettyPrim d++type ExportSpec = Syntax.ExportSpec ()++getModuleName :: Module -> ModuleName+getModuleName (Module name _ _ _ _) = name+ type ModuleName = Syntax.ModuleName () type ModulePragma = Syntax.ModulePragma () @@ -179,6 +245,26 @@ 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 ()@@ -214,9 +300,20 @@ tyList :: Type -> Type tyList = Syntax.TyList () +tyPromotedList :: [Type] -> Type+tyPromotedList ts = Syntax.TyPromoted () $ Syntax.PromotedList () True ts+ tyPromotedString :: String -> Type tyPromotedString s = Syntax.TyPromoted () $ Syntax.PromotedString () s s +type Promoted = Syntax.Promoted ()++tyPromotedCon :: Promoted -> Type+tyPromotedCon = Syntax.TyPromoted ()++instance IsString Promoted where+    fromString = Syntax.PromotedCon () True . fromString+ tyForAll :: [TyVarBind] -> [Asst] -> Type -> Type tyForAll vars ctx t = Syntax.TyForall () (Just vars)                             (Just $ Syntax.CxTuple () ctx)@@ -228,7 +325,7 @@ #else tyBang = Syntax.TyBang () (Syntax.BangedTy ()) #endif- + -- | Application of a Haskell type or expression to an argument. -- For example, to represent @f x y@, you can write --@@ -252,7 +349,7 @@ -- | Whether this character belongs to an Ident (e.g., "foo") or a symbol -- (e.g., "<$>"). isIdentChar :: Char -> Bool-isIdentChar c = isAlphaNum c || c `elem` "_'"+isIdentChar c = isAlphaNum c || c `elem` ("_'" :: String)  instance IsString ModuleName where     fromString = Syntax.ModuleName ()@@ -309,3 +406,8 @@  string :: String -> Syntax.Literal () string s = Syntax.String () s (show s)++modifyModuleName :: (String -> String) -> ModuleName -> ModuleName+modifyModuleName f (Syntax.ModuleName _ unpacked) =+  Syntax.ModuleName () $ f unpacked+

@@ -14,6 +14,8 @@     ( Env     , Definition(..)     , MessageInfo(..)+    , ServiceInfo(..)+    , MethodInfo(..)     , FieldInfo(..)     , OneofInfo(..)     , OneofCase(..)@@ -26,7 +28,10 @@     , qualifyEnv     , unqualifyEnv     , collectDefinitions+    , collectServices     , definedFieldType+    , definedType+    , camelCase     ) where  import Data.Char (isUpper, toUpper)@@ -46,15 +51,25 @@     , EnumValueDescriptorProto     , FieldDescriptorProto     , FileDescriptorProto+    , MethodDescriptorProto+    , ServiceDescriptorProto+    )+import Proto.Google.Protobuf.Descriptor_Fields+    ( clientStreaming     , enumType     , field+    , inputType     , maybe'oneofIndex     , messageType+    , method     , name     , nestedType     , number     , oneofDecl+    , outputType     , package+    , serverStreaming+    , service     , typeName     , value     )@@ -90,8 +105,26 @@     , messageOneofFields :: [OneofInfo]       -- ^ The oneofs in this message, associated with the fields that       --   belong to them.+    , messageUnknownFields :: Name+      -- ^ The name of the Haskell field in this message that holds the+      -- unknown fields.     } deriving Functor +data ServiceInfo = ServiceInfo+    { serviceName    :: Text+    , servicePackage :: Text+    , serviceMethods :: [MethodInfo]+    }++data MethodInfo = MethodInfo+    { methodName   :: Text+    , methodIdent  :: Text+    , methodInput  :: Text+    , methodOutput :: Text+    , methodClientStreaming :: Bool+    , methodServerStreaming :: Bool+    }+ -- | Information about a single field of a proto message. data FieldInfo = FieldInfo     { fieldDescriptor  :: FieldDescriptorProto@@ -111,6 +144,8 @@     , caseConstructorName :: Name         -- ^ The constructor for building a 'oneofTypeName' from the         -- value in this field.+    , casePrismName :: Name+        -- ^ The name for building 'Prism' definition.     }  data FieldName = FieldName@@ -151,6 +186,8 @@ -- | 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@@ -184,6 +221,13 @@     err = error $ "definedFieldType: Field type " ++ unpack (fd ^. typeName)                   ++ " not found in environment." +-- | Look up the Haskell name for the type of a given type.+definedType :: Text -> Env QName -> Definition QName+definedType ty = fromMaybe err . Map.lookup ty+  where+    err = error $ "definedType: Type " ++ unpack ty+                  ++ " not found in environment."+ -- | Collect all the definitions in the given file (including definitions -- nested in other messages), and assign Haskell names to them. collectDefinitions :: FileDescriptorProto -> Env Name@@ -195,6 +239,28 @@     in Map.fromList $ messageAndEnumDefs protoPrefix hsPrefix                           (fd ^. messageType) (fd ^. enumType) +collectServices :: FileDescriptorProto -> [ServiceInfo]+collectServices fd = fmap (toServiceInfo $ fd ^. package) $ fd ^. service+  where+    toServiceInfo :: Text -> ServiceDescriptorProto -> ServiceInfo+    toServiceInfo pkg sd =+        ServiceInfo+            { serviceName    = sd ^. name+            , servicePackage = pkg+            , serviceMethods = fmap toMethodInfo $ sd ^. method+            }++    toMethodInfo :: MethodDescriptorProto -> MethodInfo+    toMethodInfo md =+        MethodInfo+            { methodName   = md ^. name+            , methodIdent  = camelCase $ md ^. name+            , methodInput  = fromString . T.unpack $ md ^. inputType+            , methodOutput = fromString . T.unpack $ md ^. outputType+            , methodClientStreaming = md ^. clientStreaming+            , methodServerStreaming = md ^. serverStreaming+            }+ messageAndEnumDefs :: Text -> String -> [DescriptorProto]                    -> [EnumDescriptorProto] -> [(Text, Definition Name)] messageAndEnumDefs protoPrefix hsPrefix messages enums@@ -223,6 +289,8 @@                   map (fieldInfo hsPrefix')                       $ Map.findWithDefault [] Nothing allFields             , messageOneofFields = collectOneofFields hsPrefix' d allFields+            , messageUnknownFields =+                  fromString $ "_" ++ hsPrefix' ++ "_unknownFields"             }  fieldInfo :: String -> FieldDescriptorProto -> FieldInfo@@ -241,14 +309,18 @@                           $ Map.findWithDefault [] (Just idx)                               allFields         }-    oneofCase f = OneofCase-        { caseField = fieldInfo hsPrefix 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 ++ hsNameUnique subdefCons (f ^. name)-        }+    oneofCase f =+        let consName = hsPrefix ++ hsNameUnique subdefCons (f ^. name)+        in OneofCase+            { caseField = fieldInfo hsPrefix 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 consName+            , casePrismName =+                  fromString $ "_" ++ consName+            }     -- Make a name that doesn't overlap with those already defined by submessages     -- or subenums.     hsNameUnique ns n@@ -358,6 +430,8 @@     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             })

@@ -6,6 +6,7 @@  -- | This module builds the actual, generated Haskell file -- for a given input .proto file.+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Data.ProtoLens.Compiler.Generate(     generateModule,@@ -19,7 +20,7 @@ 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@@ -28,13 +29,17 @@ import qualified Data.Text as T import Data.Tuple (swap) import Lens.Family2 ((^.))+import Text.Printf (printf)+ import Proto.Google.Protobuf.Descriptor     ( EnumValueDescriptorProto     , FieldDescriptorProto     , FieldDescriptorProto'Label(..)     , FieldDescriptorProto'Type(..)     , FileDescriptorProto-    , defaultValue+    )+import Proto.Google.Protobuf.Descriptor_Fields+    ( defaultValue     , label     , mapEntry     , maybe'oneofIndex@@ -51,7 +56,7 @@ import Data.ProtoLens.Compiler.Definitions  data SyntaxType = Proto2 | Proto3-    deriving Eq+    deriving (Show, Eq)  fileSyntaxType :: FileDescriptorProto -> SyntaxType fileSyntaxType f = case f ^. syntax of@@ -73,33 +78,56 @@                -> ModifyImports                -> Env Name      -- ^ Definitions in this file                -> Env QName     -- ^ Definitions in the imported modules-               -> Module-generateModule modName imports syntaxType modifyImport definitions importedEnv-    = module' modName+               -> [ServiceInfo]+               -> [Module]+generateModule modName imports syntaxType modifyImport definitions importedEnv services+    = [ Module modName+                (Just $ (serviceExports ++) $ concatMap generateExports $ Map.elems definitions)+                pragmas+                (prismImport:sharedImports)+          $ (concatMap generateDecls $ Map.toList definitions)+         ++ map uncommented (concatMap (generateServiceDecls env) services)+      , Module fieldModName+                Nothing+                pragmas+                sharedImports+          . map uncommented+          $ concatMap generateFieldDecls allLensNames+      ]+  where+    fieldModName = modifyModuleName (++ "_Fields") modName+    pragmas =           [ languagePragma $ map fromString               ["ScopedTypeVariables", "DataKinds", "TypeFamilies",-               "UndecidableInstances",+               "UndecidableInstances", "GeneralizedNewtypeDeriving",                "MultiParamTypeClasses", "FlexibleContexts", "FlexibleInstances",-               "PatternSynonyms", "MagicHash", "NoImplicitPrelude"]+               "PatternSynonyms", "MagicHash", "NoImplicitPrelude",+               "DataKinds"]               -- 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"           ]-          (map (modifyImport . importSimple)+    prismImport = modifyImport $ importSimple "Lens.Labels.Prism"+    sharedImports = map (modifyImport . importSimple)               [ "Prelude", "Data.Int", "Data.Word"-              , "Data.ProtoLens", "Data.ProtoLens.Message.Enum"+              , "Data.ProtoLens", "Data.ProtoLens.Message.Enum", "Data.ProtoLens.Service.Types"               , "Lens.Family2", "Lens.Family2.Unchecked", "Data.Default.Class"-              , "Data.Text",  "Data.Map" , "Data.ByteString"-              , "Lens.Labels"+              , "Data.Text",  "Data.Map", "Data.ByteString", "Data.ByteString.Char8"+              , "Lens.Labels", "Text.Read"               ]-            ++ map importSimple imports)-          (concatMap generateDecls (Map.toList definitions)-           ++ concatMap generateFieldDecls allLensNames)-  where+            ++ map importSimple imports     env = Map.union (unqualifyEnv definitions) importedEnv     generateDecls (protoName, Message m)-        = generateMessageDecls syntaxType env (stripDotPrefix protoName) m-    generateDecls (_, Enum e) = generateEnumDecls e+        = generateMessageDecls fieldModName syntaxType env (stripDotPrefix protoName) m+       ++ map uncommented (concatMap (generatePrisms env) (messageOneofFields m))+    generateDecls (_, Enum e) = map uncommented $ generateEnumDecls syntaxType e+    generateExports (Message m) = generateMessageExports m+                               ++ concatMap generatePrismExports (messageOneofFields m)+    generateExports (Enum e) = generateEnumExports syntaxType e+    serviceExports = fmap generateServiceExports services     allLensNames = F.toList $ Set.fromList         [ lensSymbol inst         | Message m <- Map.elems definitions@@ -139,18 +167,93 @@   where     m' = fromString $ "Data.ProtoLens.Reexport." ++ prettyPrint m -generateMessageDecls :: SyntaxType -> Env QName -> T.Text -> MessageInfo Name -> [Decl]-generateMessageDecls syntaxType env protoName info =+messageComment :: ModuleName -> Name -> [RecordField] -> String+messageComment fieldModName n fields = unlines+    $ ["Fields :", ""]+        ++ map item (concatMap recordFieldLenses fields)+  where+    item :: LensInstance -> String+    item l = (printf "    * '%s.%s' @:: %s@"+                 (prettyPrint fieldModName)+                 (prettyPrint $ nameFromSymbol $ lensSymbol l)+                 (prettyPrint $ "Lens'" @@ t @@ (lensFieldType l)))+    t = tyCon (unQual n)++generateMessageExports :: MessageInfo Name -> [ExportSpec]+generateMessageExports m =+    map (exportAll . unQual)+        $ messageName m : map oneofTypeName (messageOneofFields m)++generateServiceDecls :: Env QName -> ServiceInfo -> [Decl]+generateServiceDecls env si =+    -- data MyService = MyService+    [ dataDecl serverDataName+      [ recDecl serverDataName []+      ]+      $ deriving' []+    ] +++    -- instance Data.ProtoLens.Service.Types.Service MyService where+    --     type ServiceName    MyService = "myService"+    --     type ServicePackage MyService = "some.package"+    --     type ServiceMethods MyService = '["normalMethod", "streamingMethod"]+    [ instDeclWithTypes [] ("Data.ProtoLens.Service.Types.Service" `ihApp` [serverRecordType])+        [ instType ("ServiceName" @@ serverRecordType)+                 . tyPromotedString . T.unpack $ serviceName si+        , instType ("ServicePackage" @@ serverRecordType)+                 . tyPromotedString . T.unpack $ servicePackage si+        , instType ("ServiceMethods" @@ serverRecordType)+                 $ tyPromotedList+                      [ tyPromotedString . T.unpack $ methodIdent m+                      | m <- List.sortBy (comparing methodIdent) $ serviceMethods si+                      ]+        ]+    ] +++    -- instance Data.ProtoLens.Service.Types.HasMethodImpl MyService "normalMethod" where+    --     type MethodInput       MyService "normalMethod" = Foo+    --     type MethodOutput      MyService "normalMethod" = Bar+    --     type IsClientStreaming MyService "normalMethod" = 'False+    --     type IsServerStreaming MyService "normalMethod" = 'False+    [ instDeclWithTypes [] ("Data.ProtoLens.Service.Types.HasMethodImpl" `ihApp` [serverRecordType, instanceHead])+        [ instType ("MethodName" @@ serverRecordType @@ instanceHead)+                 . tyPromotedString . T.unpack $ methodName m+        , instType ("MethodInput" @@ serverRecordType @@ instanceHead)+                 . lookupType $ methodInput m+        , instType ("MethodOutput" @@ serverRecordType @@ instanceHead)+                 . lookupType $ methodOutput m+        , instType ("MethodStreamingType" @@ serverRecordType @@ instanceHead)+                 . tyPromotedCon+                 $ case (methodClientStreaming m, methodServerStreaming m) of+                     (False, False) -> "Data.ProtoLens.Service.Types.NonStreaming"+                     (True,  False) -> "Data.ProtoLens.Service.Types.ClientStreaming"+                     (False, True)  -> "Data.ProtoLens.Service.Types.ServerStreaming"+                     (True,  True)  -> "Data.ProtoLens.Service.Types.BiDiStreaming"+        ]+    | m <- serviceMethods si+    , let instanceHead = tyPromotedString (T.unpack $ methodIdent m)+    ]+  where+    serverDataName = fromString . T.unpack $ serviceName si+    serverRecordType = tyCon $ unQual serverDataName++    lookupType t = case definedType t env of+                       Message msg -> tyCon $ messageName msg+                       Enum _ -> error "Service must have a message type"+++generateMessageDecls :: ModuleName -> SyntaxType -> Env QName -> T.Text -> MessageInfo Name -> [CommentedDecl]+generateMessageDecls fieldModName syntaxType env protoName info =     -- data Bar = Bar {     --    foo :: Baz     -- }-    [ dataDecl dataName-        [recDecl dataName $-                  [ (recordFieldName f, recordFieldType f)-                  | f <- allFields-                  ]-        ]-        ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"]+    [ commented (messageComment fieldModName (messageName info) allFields)+        $ dataDecl dataName+            [recDecl dataName $+                      [ (recordFieldName f, recordFieldType f)+                      | f <- allFields+                      ]+                      ++ [(messageUnknownFields info, "Data.ProtoLens.FieldSet")]+            ]+            $ deriving' ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"]     ] ++      -- oneof field data type declarations@@ -162,25 +265,34 @@     --        }     -- haskell: data Foo'Bar = Foo'Bar'c !Prelude.Float     --                       | Foo'Bar's !Sub-    [ dataDecl (oneofTypeName oneofInfo)+    [ uncommented $ 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"]+      $ deriving' ["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+    -- instance (HasLens' f Foo x a, HasLens' f Foo x b, a ~ b)+    --    => HasLens f Foo Foo x a b+    [ uncommented $+          instDecl [classA "Lens.Labels.HasLens'" ["f", dataType, "x", "a"],+                    equalP "a" "b"]+              ("Lens.Labels.HasLens" `ihApp`+                  ["f", dataType, dataType, "x", "a", "b"])+              [[match "lensOf" [] "Lens.Labels.lensOf'"]]+    ]+    +++    -- instance Functor f+    --     => HasLens' f Foo "foo" Bar     --   lensOf _ = ...     -- Note: for optional fields, this generates an instance both for "foo" and-    -- for "maybe'foo" (see lensInfo below).-    [ instDecl [equalP "a" t, equalP "b" t, classA "Prelude.Functor" ["f"]]-        ("Lens.Labels.HasLens" `ihApp`-            [sym, "f", dataType, dataType, "a", "b"])-            [[match "lensOf" [pWildCard] $+    -- for "maybe'foo" (see plainRecordField below).+    [ uncommented $ instDecl [classA "Prelude.Functor" ["f"]]+        ("Lens.Labels.HasLens'" `ihApp`+            ["f", dataType, sym, tyParen t])+            [[match "lensOf'" [pWildCard] $                 "Prelude.."                     @@ rawFieldAccessor (unQual $ recordFieldName li)                     @@ lensExp i]]@@ -191,7 +303,7 @@     ]     ++     -- instance Data.Default.Class.Default Bar where-    [ instDecl [] ("Data.Default.Class.Default" `ihApp` [dataType])+    [ uncommented $ instDecl [] ("Data.Default.Class.Default" `ihApp` [dataType])         -- def = Bar { _Bar_foo = 0 }         [             [ match "def" []@@ -203,23 +315,292 @@                       [ fieldUpdate (unQual $ haskellRecordFieldName $ oneofFieldName o)                             "Prelude.Nothing"                       | o <- messageOneofFields info-                      ]+                      ] +++                      [ fieldUpdate (unQual $ messageUnknownFields info)+                            "[]"]             ]         ]     -- instance Message.Message Bar where-    , instDecl [] ("Data.ProtoLens.Message" `ihApp` [dataType])-        [[match "descriptor" [] $ descriptorExpr syntaxType env protoName info]]+    , uncommented $ instDecl [] ("Data.ProtoLens.Message" `ihApp` [dataType])+        $ messageInstance syntaxType env protoName info     ]   where     dataType = tyCon $ unQual dataName     dataName = messageName info     allFields = allMessageFields syntaxType env info -generateEnumDecls :: EnumInfo Name -> [Decl]-generateEnumDecls info =+-- oneof Prism declarations+-- proto: message Foo {+--          oneof bar {+--            float c = 1;+--            Sub s = 2;+--          }+--        }+-- haskell: _Foo'C :: Prism' Bar'C Float+--          _Foo'S :: Prism' Bar'S Sub+--+--  example of the function definition for _Foo'C:+-- _Foo'C :: Lens.Prism.Prism' Bar'C Float+-- _Foo'C+--   = Lens.Prism.prism' Bar'C+--       (\ p__ ->+--          case p__ of+--              Bar'C p__val -> Prelude.Just p__val+--              _otherwise -> Prelude.Nothing)+generatePrisms :: Env QName -> OneofInfo -> [Decl]+generatePrisms env oneofInfo =+    if length cases > 1+       then concatMap (generatePrism altOtherwise) cases+       else concatMap (generatePrism mempty) cases+    where+        cases = oneofCases oneofInfo+        altOtherwise = [ alt "_otherwise" "Prelude.Nothing" ]++        -- Generate type signature+        -- e.g. Prism' Bar'C Float+        generateTypeSig f funName =+            typeSig [funName] $ "Lens.Labels.Prism.Prism'"+                                -- The oneof sum type name+                             @@ (tyCon . unQual $ oneofTypeName oneofInfo)+                                -- The field contained in the sum+                             @@ (hsFieldType env $ fieldDescriptor f)+        -- Generate function definition+        -- Prism' is constructed with Constructor for building value+        -- and Deconstructor and wrapping in Just for getting value+        generateFunDef otherwiseCase consName =+               "Lens.Labels.Prism.prism'"+               -- Sum type constructor+            @@ con (unQual consName)+               -- Case deconstruction+            @@ (lambda ["p__"] $+                    case' "p__" $+                        [ alt (pApp (unQual consName) ["p__val"])+                              ("Prelude.Just" @@ "p__val")+                        ]+                       -- We want to generate the otherwise case+                       -- depending on the amount of sum type cases there are+                       ++ otherwiseCase+               )+        generatePrism :: [Alt] -> OneofCase -> [Decl]+        generatePrism otherwiseCase oneofCase =+            let consName = caseConstructorName oneofCase+                prismName = casePrismName oneofCase+            in [ generateTypeSig (caseField oneofCase) prismName+               , funBind [ match prismName [] $ generateFunDef otherwiseCase consName ]+               ]++generatePrismExports :: OneofInfo -> [ExportSpec]+generatePrismExports = map (exportVar . unQual . casePrismName) . oneofCases++generateEnumExports :: SyntaxType -> EnumInfo Name -> [ExportSpec]+generateEnumExports syntaxType e = [exportAll n, exportWith n aliases] ++ proto3NewType+  where+    n = unQual $ enumName e+    aliases = [enumValueName v | v <- enumValues e, needsManualExport v]+    needsManualExport v = isJust (enumAliasOf v)+    proto3NewType = if syntaxType == Proto3+      then [exportVar . unQual $ enumUnrecognizedValueName e]+      else []++generateServiceExports :: ServiceInfo -> ExportSpec+generateServiceExports si = exportAll $ unQual $ fromString $ T.unpack $ serviceName si++generateEnumDecls :: SyntaxType -> EnumInfo Name -> [Decl]+generateEnumDecls Proto3 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 "maybeToEnum" ["k"]+                  $ "Prelude.Just" @@+                    (con (unQual unrecognizedName)+                      @@ (con (unQual unrecognizedValueName)+                          @@ ("Prelude.fromIntegral" @@ "k")+                         )+                    )+          ]+        , [ 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 "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 "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"+        ]++    -- instance Data.Default.Class.Default Foo where+    --   def = FirstEnumValue+    , instDecl [] ("Data.Default.Class.Default" `ihApp` [dataType])+        [[match "def" [] defaultCon]]+    -- instance Data.ProtoLens.FieldDefault Foo where+    --   fieldDefault = FirstEnumValue+    , instDecl [] ("Data.ProtoLens.FieldDefault" `ihApp` [dataType])+        [[match "fieldDefault" [] defaultCon]]+    ] +++    -- pattern Enum2a :: FooEnum+    -- pattern Enum2a = Enum2+    concat+        [ [ patSynSig aliasName dataType+          , patSyn (pVar aliasName) (pVar originalName)+          ]+        | EnumValueInfo+            { enumValueName = aliasName+            , enumAliasOf = Just originalName+            } <- enumValues info+        ]++  where+    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]-        ["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])@@ -358,18 +739,14 @@ 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+    --        . HasLens f s t x a b => LensLike f s t a b     -- -- Note: `Lens.Family2.LensLike f` implies Functor f.     -- foo = lensOf (Proxy# :: Proxy# x)     [ typeSig [x]           $ tyForAll ["f", "s", "t", "a", "b"]-                  [classA "Lens.Labels.HasLens" [xSym, "f", "s", "t", "a", "b"]]+                  [classA "Lens.Labels.HasLens" ["f", "s", "t", xSym, "a", "b"]]                     $ "Lens.Family2.LensLike" @@ "f" @@ "s" @@ "t" @@ "a" @@ "b"-    , funBind [match x []-                  $ "Lens.Labels.lensOf"-                      @@ ("Lens.Labels.proxy#" @::@-                          ("Lens.Labels.Proxy#" @@ xSym))-              ]+    , funBind [match x [] $ lensOfExp xStr]     ]   where     x = nameFromSymbol xStr@@ -662,21 +1039,15 @@     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-    --      (Data.Map.fromList [(Tag 1, foo__field_descriptor),...])-    --      (Data.Map.fromList [("foo", foo__field_descriptor),...])-    ---    -- (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) $ fields)-        $ "Data.ProtoLens.MessageDescriptor"-          @@ ("Data.Text.pack" @@ stringExp (T.unpack protoName))-          @@ ("Data.Map.fromList" @@ list fieldsByTag)-          @@ ("Data.Map.fromList" @@ list fieldsByTextFormatName)+messageInstance :: SyntaxType -> Env QName -> T.Text -> MessageInfo Name -> [[Match]]+messageInstance syntaxType env protoName m =+    [ [ match "messageName" [pWildCard] $+          "Data.Text.pack" @@ stringExp (T.unpack protoName)]+    , [ match "fieldsByTag" [] $+          let' (map (fieldDescriptorVarBind $ messageName m) $ fields)+              $ "Data.Map.fromList" @@ list fieldsByTag ]+    , [ match "unknownFields" [] $ rawFieldAccessor (unQual $ messageUnknownFields m) ]+    ]   where     fieldsByTag =         [tuple@@ -686,13 +1057,6 @@                           @@ litInt (fromIntegral                                       $ fieldDescriptor f ^. number)               ]-    fieldsByTextFormatName =-        [tuple-              [ t, fieldDescriptorVar f ]-              | f <- fields-              , let t = stringExp $ T.unpack $ textFormatFieldName env-                                                    (fieldDescriptor f)-              ]     fieldDescriptorVar = var . unQual . fieldDescriptorName     fieldDescriptorName f         = nameFromSymbol $ overloadedName (plainFieldName f) <> "__field_descriptor"@@ -737,7 +1101,8 @@  fieldAccessorExpr :: SyntaxType -> Env QName -> FieldInfo -> Exp -- (PlainField Required foo), (OptionalField foo), etc...-fieldAccessorExpr syntaxType env f = accessorCon @@ var (unQual hsFieldName)+fieldAccessorExpr syntaxType env f = accessorCon @@ lensOfExp hsFieldName+   where     fd = fieldDescriptor f     accessorCon = case fd ^. label of@@ -750,19 +1115,24 @@           FieldDescriptorProto'LABEL_REPEATED               | Just (k, v) <- getMapFields env fd                   -> "Data.ProtoLens.MapField"-                         @@ con (unQual $ nameFromSymbol $ overloadedField k)-                         @@ con (unQual $ nameFromSymbol $ overloadedField v)+                         @@ lensOfExp (overloadedField k)+                         @@ lensOfExp (overloadedField v)               | otherwise -> "Data.ProtoLens.RepeatedField"                   @@ if isPackedField syntaxType fd                         then "Data.ProtoLens.Packed"                         else "Data.ProtoLens.Unpacked"     hsFieldName-        = nameFromSymbol $ case fd ^. label of+        = case fd ^. label of               FieldDescriptorProto'LABEL_OPTIONAL                   | not (isDefaultingOptional syntaxType fd)                       -> "maybe'" <> overloadedField f               _ -> overloadedField f +lensOfExp :: Symbol -> Exp+lensOfExp sym = ("Lens.Labels.lensOf"+                  @@ ("Lens.Labels.proxy#" @::@+                      ("Lens.Labels.Proxy#" @@ promoteSymbol sym)))+ overloadedField :: FieldInfo -> Symbol overloadedField = overloadedName . plainFieldName @@ -789,23 +1159,25 @@                       ]  fieldTypeDescriptorExpr :: FieldDescriptorProto'Type -> Exp-fieldTypeDescriptorExpr =-    (\n -> fromString $ "Data.ProtoLens." ++ n ++ "Field") . \t -> case t of-    FieldDescriptorProto'TYPE_DOUBLE -> "Double"-    FieldDescriptorProto'TYPE_FLOAT -> "Float"-    FieldDescriptorProto'TYPE_INT64 -> "Int64"-    FieldDescriptorProto'TYPE_UINT64 -> "UInt64"-    FieldDescriptorProto'TYPE_INT32 -> "Int32"-    FieldDescriptorProto'TYPE_FIXED64 -> "Fixed64"-    FieldDescriptorProto'TYPE_FIXED32 -> "Fixed32"-    FieldDescriptorProto'TYPE_BOOL -> "Bool"-    FieldDescriptorProto'TYPE_STRING -> "String"-    FieldDescriptorProto'TYPE_GROUP -> "Group"-    FieldDescriptorProto'TYPE_MESSAGE -> "Message"-    FieldDescriptorProto'TYPE_BYTES -> "Bytes"-    FieldDescriptorProto'TYPE_UINT32 -> "UInt32"-    FieldDescriptorProto'TYPE_ENUM -> "Enum"-    FieldDescriptorProto'TYPE_SFIXED32 -> "SFixed32"-    FieldDescriptorProto'TYPE_SFIXED64 -> "SFixed64"-    FieldDescriptorProto'TYPE_SINT32 -> "SInt32"-    FieldDescriptorProto'TYPE_SINT64 -> "SInt64"+fieldTypeDescriptorExpr = \case+    FieldDescriptorProto'TYPE_DOUBLE -> mk "ScalarField" "DoubleField"+    FieldDescriptorProto'TYPE_FLOAT -> mk "ScalarField" "FloatField"+    FieldDescriptorProto'TYPE_INT64 -> mk "ScalarField" "Int64Field"+    FieldDescriptorProto'TYPE_UINT64 -> mk "ScalarField" "UInt64Field"+    FieldDescriptorProto'TYPE_INT32 -> mk "ScalarField" "Int32Field"+    FieldDescriptorProto'TYPE_FIXED64 -> mk "ScalarField" "Fixed64Field"+    FieldDescriptorProto'TYPE_FIXED32 -> mk "ScalarField" "Fixed32Field"+    FieldDescriptorProto'TYPE_BOOL -> mk "ScalarField" "BoolField"+    FieldDescriptorProto'TYPE_STRING -> mk "ScalarField" "StringField"+    FieldDescriptorProto'TYPE_GROUP -> mk "MessageField" "GroupType"+    FieldDescriptorProto'TYPE_MESSAGE -> mk "MessageField" "MessageType"+    FieldDescriptorProto'TYPE_BYTES -> mk "ScalarField" "BytesField"+    FieldDescriptorProto'TYPE_UINT32 -> mk "ScalarField" "UInt32Field"+    FieldDescriptorProto'TYPE_ENUM -> mk "ScalarField" "EnumField"+    FieldDescriptorProto'TYPE_SFIXED32 -> mk "ScalarField" "SFixed32Field"+    FieldDescriptorProto'TYPE_SFIXED64 -> mk "ScalarField" "SFixed64Field"+    FieldDescriptorProto'TYPE_SINT32 -> mk "ScalarField" "SInt32Field"+    FieldDescriptorProto'TYPE_SINT64 -> mk "ScalarField" "SInt64Field"+  where+    mk x y = fromString ("Data.ProtoLens." ++ x)+              @@ fromString ("Data.ProtoLens." ++ y)

@@ -26,8 +26,8 @@ import qualified Data.Text as T import Data.Text (Text) import Lens.Family2-import Proto.Google.Protobuf.Descriptor-    (FileDescriptorProto, name, dependency, publicDependency)+import Proto.Google.Protobuf.Descriptor (FileDescriptorProto)+import Proto.Google.Protobuf.Descriptor_Fields (name, dependency, publicDependency) import System.FilePath (dropExtension, splitDirectories)  @@ -41,6 +41,7 @@     { descriptor :: FileDescriptorProto     , haskellModule :: ModuleName     , definitions :: Env Name+    , services :: [ServiceInfo]     -- | The names of proto files exported (transitively, via "import public"     -- decl) by this file.     , exports :: [ProtoFileName]@@ -57,6 +58,7 @@     moduleNames = fmap (moduleName modulePrefix) filesByName     -- The definitions in each input proto file, indexed by filename.     definitionsByName = fmap collectDefinitions filesByName+    servicesByName = fmap collectServices filesByName     -- The exports from each .proto file (including any "public import"     -- dependencies), as they appear to other modules that are importing them;     -- i.e., qualified by module name.@@ -68,6 +70,7 @@         { descriptor = f         , haskellModule = moduleNames ! n         , definitions = definitionsByName ! n+        , services = servicesByName ! n         , exports = exportsByName ! n         , exportedEnv = exportedEnvs ! n         }@@ -85,22 +88,23 @@  -- | Get the Haskell 'ModuleName' corresponding to a given .proto file. moduleName :: Text -> FileDescriptorProto -> ModuleName-moduleName modulePrefix fd = fromString (moduleNameStr modulePrefix fd)+moduleName modulePrefix fd+      = fromString $ moduleNameStr (T.unpack modulePrefix) (T.unpack $ fd ^. name)  -- | Get the Haskell module name corresponding to a given .proto file.-moduleNameStr :: Text -> FileDescriptorProto -> String-moduleNameStr prefix fd = fixModuleName rawModuleName+moduleNameStr :: String -> FilePath -> String+moduleNameStr prefix path = fixModuleName rawModuleName   where-    path = fd ^. name     fixModuleName "" = ""     -- Characters allowed in Bazel filenames but not in module names:     fixModuleName ('.':c:cs) = '.' : toUpper c : fixModuleName cs     fixModuleName ('_':c:cs) = toUpper c : fixModuleName cs     fixModuleName ('-':c:cs) = toUpper c : fixModuleName cs     fixModuleName (c:cs) = c : fixModuleName cs-    rawModuleName = intercalate "." $ (T.unpack prefix :)-                        $ splitDirectories $ dropExtension-                        $ T.unpack path+    rawModuleName = intercalate "."+                        . (prefix :)+                        . splitDirectories $ dropExtension+                        $ path  -- | Given a list of .proto files (topologically sorted), determine which -- files' definitions are exported by which files.

@@ -14,6 +14,7 @@ -- -- See @README.md@ for instructions on how to use proto-lens with Cabal. {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-} module Data.ProtoLens.Setup     ( defaultMainGeneratingProtos     , defaultMainGeneratingSpecificProtos@@ -23,35 +24,49 @@     , generateProtos     ) where -#if __GLASGOW_HASKELL__ < 709-import Data.Functor ((<$>))+import Control.DeepSeq (force)+import Control.Monad (filterM, forM_, guard, when)+#if MIN_VERSION_Cabal(2,0,0)+import qualified Data.Map as Map #endif--import Control.Monad (filterM, forM_, when)+import qualified Data.ByteString as BS+import Data.Maybe (maybeToList)+import qualified Data.Set as Set+import Distribution.ModuleName (ModuleName)+import qualified Distribution.ModuleName as ModuleName import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import Distribution.PackageDescription     ( PackageDescription(..)     , benchmarkBuildInfo+    , benchmarkName     , buildInfo+    , exeName+    , exposedModules     , extraSrcFiles     , hsSourceDirs     , libBuildInfo+    , otherModules     , testBuildInfo+    , testBuildInfo+    , testName     ) import qualified Distribution.Simple.BuildPaths as BuildPaths import Distribution.Simple.InstallDirs (datadir) import Distribution.Simple.LocalBuildInfo     ( LocalBuildInfo(..)     , absoluteInstallDirs+    , ComponentName(..)     , componentPackageDeps #if MIN_VERSION_Cabal(2,0,0)     , allComponentsInBuildOrder+    , componentNameMap #endif     ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.Setup (fromFlag, copyDest, copyVerbosity) import Distribution.Simple.Utils     ( createDirectoryIfMissingVerbose+    , getDirectoryContentsRecursive     , installOrdinaryFile     , matchFileGlob     )@@ -66,23 +81,32 @@     , equalFilePath     , isRelative     , makeRelative-    , takeExtension     , takeDirectory+    , takeExtension     ) import System.Directory     ( createDirectoryIfMissing     , doesDirectoryExist+    , doesFileExist     , findExecutable     , removeDirectoryRecursive+    , renameFile     ) import System.IO (hPutStrLn, stderr) import System.Process (callProcess) +import qualified Data.ProtoLens.Compiler.Plugin as Plugin+ -- | This behaves the same as 'Distribution.Simple.defaultMain', but--- auto-generates Haskell files from the .proto files listed in--- the @.cabal@ file under @extra-source-files@ which are located under the--- given root directory.+-- auto-generates Haskell files from .proto files which are: --+-- * Listed in the @.cabal@ file under @extra-source-files@,+--+-- * Located under the given root directory, and+--+-- * Correspond to a module (@"Proto.*"@) in `exposed-modules` or+-- `other-modules` of some component in the @.cabal@ file.+-- -- Writes the generated files to the autogen directory (@dist\/build\/autogen@ -- for Cabal, and @.stack-work\/dist\/...\/build\/autogen@ for stack). --@@ -103,7 +127,7 @@ -- Throws an exception if the @proto-lens-protoc@ executable is not on the PATH. defaultMainGeneratingSpecificProtos     :: FilePath -- ^ The root directory under which .proto files can be found.-    -> (PackageDescription -> IO [FilePath])+    -> (LocalBuildInfo -> IO [FilePath])     -- ^ A function to return a list of .proto files. Takes the Cabal package     -- description as input. Non-absolute paths are treated as relative to the     -- provided root directory.@@ -113,9 +137,15 @@     $ generatingSpecificProtos root getProtos simpleUserHooks  -- | Augment the given 'UserHooks' to auto-generate Haskell files from the--- .proto files listed in the @.cabal@ file under @extra-source-files@ which--- are located under the given root directory.+-- .proto files which are: --+-- * Listed in the @.cabal@ file under @extra-source-files@,+--+-- * Located under the given root directory, and+--+-- * Correspond to a module (@"Proto.*"@) in `exposed-modules` or+-- `other-modules` of some component in the @.cabal@ file.+-- -- Writes the generated files to the autogen directory (@dist\/build\/autogen@ -- for Cabal, and @.stack-work\/dist\/...\/build\/autogen@ for stack). --@@ -125,14 +155,20 @@     -> UserHooks -> UserHooks generatingProtos root = generatingSpecificProtos root getProtos   where-    getProtos p = do+    getProtos l = do       -- Replicate Cabal's own logic for parsing file globs.-      files <- concat <$> mapM matchFileGlob (extraSrcFiles p)-      pure $ map (makeRelative root)-           $ filter (isSubdirectoryOf root)-           $ filter (\f -> takeExtension f == ".proto")-               files+      files <- concat <$> mapM matchFileGlob (extraSrcFiles $ localPkgDescr l)+      let activeModules = Set.fromList $ collectActiveModules l+      pure . filter (\f -> relativeFileToProtoModule f+                            `Set.member` activeModules)+           . filter (\f -> takeExtension f == ".proto")+           . map (makeRelative root)+           . filter (isSubdirectoryOf root)+           $ files+    relativeFileToProtoModule+        = ModuleName.fromString . Plugin.moduleNameStr "Proto" + -- | Augment the given 'UserHooks' to auto-generate Haskell files from the -- .proto files returned by a function @getProtos@. --@@ -142,46 +178,77 @@ -- Throws an exception if the @proto-lens-protoc@ executable is not on the PATH. generatingSpecificProtos     :: FilePath -- ^ The root directory under which .proto files can be found.-    -> (PackageDescription -> IO [FilePath])+    -> (LocalBuildInfo -> IO [FilePath])     -- ^ A function to return a list of .proto files. Takes the Cabal package     -- description as input. Non-absolute paths are treated as relative to the     -- provided root directory.     -> UserHooks -> UserHooks generatingSpecificProtos root getProtos hooks = hooks-    { buildHook = \p l h f -> generate p l >> buildHook hooks p l h f-    , haddockHook = \p l h f -> generate p l >> haddockHook hooks p l h f-    , replHook = \p l h f args -> generate p l >> replHook hooks p l h f args+    { buildHook = \p l h f -> generate l >> buildHook hooks p l h f+    , haddockHook = \p l h f -> generate l >> haddockHook hooks p l h f+    , replHook = \p l h f args -> generate l >> replHook hooks p l h f args     , sDistHook = \p maybe_l h f -> case maybe_l of             Nothing -> error "Can't run protoc; run 'cabal configure' first."             Just l -> do-                        generate p l+                        generate l                         sDistHook hooks (fudgePackageDesc l p) maybe_l h f     , postCopy = \a flags pkg lbi -> do                   let verb = fromFlag $ copyVerbosity flags                   let destDir = datadir (absoluteInstallDirs pkg lbi                                              $ fromFlag $ copyDest flags)                               </> protoLensImportsPrefix-                  getProtos pkg >>= copyProtosToDataDir verb root destDir+                  getProtos lbi >>= copyProtosToDataDir verb root destDir                   postCopy hooks a flags pkg lbi     }   where-    generate p l = getProtos p >>= generateSources root l+    generate l = getProtos l >>= generateSources root l  -- | Generate Haskell source files for the given input .proto files. generateSources :: FilePath -- ^ The root directory                 -> LocalBuildInfo                 -> [FilePath] -- ^ Proto files relative to the root directory.                 -> IO ()+generateSources _ _ [] = return () generateSources root l files = do     -- Collect import paths from build-depends of this package.     importDirs <- filterM doesDirectoryExist                      [ InstalledPackageInfo.dataDir info </> protoLensImportsPrefix                      | info <- collectDeps l                      ]-    generateProtosWithImports (root : importDirs) (autogenModulesDir l)+    -- Generate .hs files into a temporary directory, then move them over+    -- to the target (autogen) directory only if they are different from+    -- what's already there. This way, we don't needlessly touch the generated+    -- .hs files when nothing changes, and thus don't needlessly make GHC+    -- recompile them (as it considers their modification times for that).+    let tmpAutogenModulesDir = autogenModulesDir l ++ "-protoc-tmpOutDir"+    -- Generate .hs files into temp dir.+    generateProtosWithImports (root : importDirs) tmpAutogenModulesDir                               -- Applying 'root </>' does nothing if the path is already                               -- absolute.                               (map (root </>) files)+    -- Discover generated files.+    -- `getDirectoryContentsRecursive` is lazy IO, so we `force` through+    -- the list to make it strict hereinafter.+    !generatedFiles <- force <$> getDirectoryContentsRecursive tmpAutogenModulesDir+    -- Move files to autogen dir only if file contents are different.+    forM_ generatedFiles $ \pathRelativeToTmpDir -> do+        let sourcePath = tmpAutogenModulesDir </> pathRelativeToTmpDir+        let targetPath = autogenModulesDir l </> pathRelativeToTmpDir+        identical <- do+            targetExists <- doesFileExist targetPath+            if not targetExists+                then return False+                else do+                    -- This could be done in a streaming fashion,+                    -- but since the .hs files usually easily fit+                    -- into RAM, this is OK.+                    sourceContents <- BS.readFile sourcePath+                    targetContents <- BS.readFile targetPath+                    return (sourceContents == targetContents)+        -- Do the move if necessary.+        when (not identical) $ do+            createDirectoryIfMissing True (takeDirectory targetPath)+            renameFile sourcePath targetPath  -- | Copy each .proto file into the installed "data-dir" path, -- so that it can be included by other packages that depend on this one.@@ -296,6 +363,29 @@             hPutStrLn stderr sep             error $ "Missing executable " ++ show name +-- | Collect all the module names that we need to build.+-- For example: only include test-suites if we're building with tests enabled+-- (e.g., `stack test` vs `stack build`).+collectActiveModules :: LocalBuildInfo -> [ModuleName]+collectActiveModules l = let+    in (activeLib >>= exposedModules)+        ++ concatMap otherModules+            (concat+                [ libBuildInfo <$> activeLib+                , buildInfo <$> activeExes+                , testBuildInfo <$> activeTests+                , benchmarkBuildInfo <$> activeBenchmarks+                ])+  where+    p = localPkgDescr l+    activeLib = guard (active CLibName) >> maybeToList (library p)+    activeExes = filter (active . CExeName . exeName) $ executables p+    activeTests = filter (active . CTestName . testName) $ testSuites p+    activeBenchmarks = filter (active . CBenchName . benchmarkName)+                          $ benchmarks p+    comps = Set.fromList $ allComponentNames l+    active = (`Set.member` comps)+ ------------------------------------------------------- -- Compatibility layer between Cabal-1.* and Cabal-2.* @@ -312,6 +402,14 @@     (_, c ,_) <- componentsConfigs l     (_, i) <- componentPackageDeps c     PackageIndex.lookupSourcePackageId (installedPkgs l) i+#endif++-- | All the components that will be built by this Cabal command.+allComponentNames :: LocalBuildInfo -> [ComponentName]+#if MIN_VERSION_Cabal(2,0,0)+allComponentNames l = Map.keys $ componentNameMap l+#else+allComponentNames l = [c | (c, _, _) <- componentsConfigs l] #endif  -- | Get the package-level "autogen" directory where we're putting the

@@ -1,89 +0,0 @@--- Copyright 2016 Google Inc. All Rights Reserved.------ Use of this source code is governed by a BSD-style--- license that can be found in the LICENSE file or at--- https://developers.google.com/open-source/licenses/bsd--{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-module Main where--import qualified Data.ByteString as B-import Data.Map.Strict ((!))-import Data.Monoid ((<>))-import qualified Data.Set as Set-import qualified Data.Text as T-import Data.Text (Text, pack)-import Data.ProtoLens (decodeMessage, def, encodeMessage)-import Lens.Family2-import Proto.Google.Protobuf.Compiler.Plugin-    ( CodeGeneratorRequest-    , CodeGeneratorResponse-    , content-    , file-    , fileToGenerate-    , parameter-    , protoFile-    )-import Proto.Google.Protobuf.Descriptor-    (FileDescriptorProto, name, dependency)-import System.Environment (getProgName)-import System.Exit (exitWith, ExitCode(..))-import System.IO as IO--import Data.ProtoLens.Compiler.Combinators (prettyPrint)-import Data.ProtoLens.Compiler.Generate-import Data.ProtoLens.Compiler.Plugin--main :: IO ()-main = do-    contents <- B.getContents-    progName <- getProgName-    case decodeMessage contents of-        Left e -> IO.hPutStrLn stderr e >> exitWith (ExitFailure 1)-        Right x -> B.putStr $ encodeMessage $ makeResponse progName x--makeResponse :: String -> CodeGeneratorRequest -> CodeGeneratorResponse-makeResponse prog request = let-    useReexport = case T.unpack $ request ^. parameter of-                    "" -> reexported-                    "no-reexports" -> id-                    p -> error $ "Error reading parameter: " ++ show p-    outputFiles = generateFiles useReexport header-                      (request ^. protoFile)-                      (request ^. fileToGenerate)-    header :: FileDescriptorProto -> Text-    header f = "{- This file was auto-generated from "-                <> (f ^. name)-                <> " by the " <> pack prog <> " program. -}\n"-    in def & file .~ [ def & name .~ outputName-                           & content .~ outputContent-                     | (outputName, outputContent) <- outputFiles-                     ]---generateFiles :: ModifyImports -> (FileDescriptorProto -> Text)-              -> [FileDescriptorProto] -> [ProtoFileName] -> [(Text, Text)]-generateFiles modifyImports header files toGenerate = let-  modulePrefix = "Proto"-  filesByName = analyzeProtoFiles modulePrefix files-  -- The contents of the generated Haskell file for a given .proto file.-  buildFile f = let-      deps = descriptor f ^. dependency-      imports = Set.toAscList $ Set.fromList-                  [ haskellModule (filesByName ! exportName)-                  | dep <- deps-                  , exportName <- exports (filesByName ! dep)-                  ]-      in generateModule (haskellModule f) imports-             (fileSyntaxType (descriptor f))-             modifyImports-             (definitions f)-             (collectEnvFromDeps deps filesByName)-  in [ ( outputFilePath . prettyPrint . haskellModule $ f-       , header (descriptor f) <> pack (prettyPrint $ buildFile f)-       )-     | fileName <- toGenerate-     , let f = filesByName ! fileName-     ]-