diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,9 +1,18 @@ # Changelog for `proto-lens-protoc` -## v0.3.1.3 +## v0.4 +- Split out `proto-lens-setup` and `proto-lens-runtime` into separate + packages. +- Hide the constructors and record fields of message types, and make `Show` + instances call `showMessageShort`. +- Generate explicit `NFData` instances for each type. +- Track the change to `proto-lens`: Don't use `data-default` for + defaul proto values (#194). +- Use simplified lens-labels instances. (#208) + +## v0.3.1.2 - Bump the upper bound to `temporary-1.3`. - Fix warnings. -- Add support for ghc-8.6. ## v0.3.1.1 - Fix management of generated files between Cabal components (#171). @@ -24,14 +33,11 @@ - 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) +- 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 diff --git a/app/protoc-gen-haskell.hs b/app/protoc-gen-haskell.hs --- a/app/protoc-gen-haskell.hs +++ b/app/protoc-gen-haskell.hs @@ -14,7 +14,7 @@ import qualified Data.Set as Set import qualified Data.Text as T import Data.Text (Text, pack) -import Data.ProtoLens (decodeMessage, def, encodeMessage) +import Data.ProtoLens (decodeMessage, defMessage, encodeMessage) import Lens.Family2 import Proto.Google.Protobuf.Compiler.Plugin ( CodeGeneratorRequest @@ -51,19 +51,21 @@ makeResponse :: String -> CodeGeneratorRequest -> CodeGeneratorResponse makeResponse prog request = let - useReexport = case T.unpack $ request ^. parameter of + useRuntime = case T.unpack $ request ^. parameter of "" -> reexported - "no-reexports" -> id + "no-runtime" -> id p -> error $ "Error reading parameter: " ++ show p - outputFiles = generateFiles useReexport header + outputFiles = generateFiles useRuntime 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 + in defMessage + & file .~ [ defMessage + & name .~ outputName + & content .~ outputContent | (outputName, outputContent) <- outputFiles ] diff --git a/proto-lens-protoc.cabal b/proto-lens-protoc.cabal --- a/proto-lens-protoc.cabal +++ b/proto-lens-protoc.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 67abce4e43117635551e092a847159fa0cd85ababdeba28c6bd694ab998bbc50 +-- hash: f70b96202ee9a7ec921d1b59d0317817c43f639d31fda260d34e2c74d90463df name: proto-lens-protoc -version: 0.3.1.3 +version: 0.4.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.' @@ -18,7 +18,7 @@ license: BSD3 license-file: LICENSE build-type: Simple -cabal-version: >= 1.22 +cabal-version: >= 1.10 extra-source-files: Changelog.md @@ -27,55 +27,24 @@ location: https://github.com/google/proto-lens subdir: proto-lens-protoc -flag only-executable - description: Only build the executable. Used for bootstrapping. - manual: False - default: False - library 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 hs-source-dirs: src build-depends: - Cabal >=1.22 && <2.5 - , base >=4.9 && <4.13 - , bytestring ==0.10.* - , containers >=0.5 && <0.7 - , data-default-class >=0.0 && <0.2 - , deepseq ==1.4.* - , directory >=1.2 && <1.4 + base >=4.9 && <4.12 + , containers ==0.5.* , 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.* - , temporary >=1.2 && <1.4 + , proto-lens ==0.4.* , text ==1.2.* default-language: Haskell2010 @@ -86,15 +55,11 @@ hs-source-dirs: app build-depends: - base >=4.9 && <4.13 + base >=4.9 && <4.12 , bytestring ==0.10.* - , containers >=0.5 && <0.7 - , data-default-class >=0.0 && <0.2 - , deepseq ==1.4.* - , filepath >=1.4 && <1.6 - , haskell-src-exts >=1.17 && <1.21 + , containers ==0.5.* , lens-family ==1.2.* - , proto-lens ==0.3.* + , proto-lens ==0.4.* , proto-lens-protoc , text ==1.2.* default-language: Haskell2010 diff --git a/src/Data/ProtoLens/Compiler/Combinators.hs b/src/Data/ProtoLens/Compiler/Combinators.hs --- a/src/Data/ProtoLens/Compiler/Combinators.hs +++ b/src/Data/ProtoLens/Compiler/Combinators.hs @@ -157,6 +157,9 @@ stringExp :: String -> Exp stringExp = Syntax.Lit () . string +charExp :: Char -> Exp +charExp = Syntax.Lit () . char + tuple :: [Exp] -> Exp tuple = Syntax.Tuple () Syntax.Boxed @@ -406,6 +409,9 @@ string :: String -> Syntax.Literal () string s = Syntax.String () s (show s) + +char :: Char -> Syntax.Literal () +char c = Syntax.Char () c [c] modifyModuleName :: (String -> String) -> ModuleName -> ModuleName modifyModuleName f (Syntax.ModuleName _ unpacked) = diff --git a/src/Data/ProtoLens/Compiler/Generate.hs b/src/Data/ProtoLens/Compiler/Generate.hs --- a/src/Data/ProtoLens/Compiler/Generate.hs +++ b/src/Data/ProtoLens/Compiler/Generate.hs @@ -65,9 +65,9 @@ "" -> Proto2 -- The proto compiler doesn't set syntax for proto2 files. s -> error $ "Unknown syntax type " ++ show s --- Whether to import the "Reexport" modules or the originals; --- e.g., Data.ProtoLens.Reexport.Data.Map vs Data.Map. -data UseReexport = UseReexport | UseOriginal +-- Whether to import the "Runtime" modules or the originals; +-- e.g., Data.ProtoLens.Runtime.Data.Map vs Data.Map. +data UseRuntime = UseRuntime | UseOriginal deriving (Eq, Read) -- | Generate a Haskell module for the given input file(s). @@ -84,7 +84,7 @@ = [ Module modName (Just $ (serviceExports ++) $ concatMap generateExports $ Map.elems definitions) pragmas - (prismImport:sharedImports) + (mainImports ++ sharedImports) $ (concatMap generateDecls $ Map.toList definitions) ++ map uncommented (concatMap (generateServiceDecls env) services) , Module fieldModName @@ -110,11 +110,12 @@ -- in a single entry, so we use two: `Foo(..)` and `Foo(A, B)`. , optionsGhcPragma "-fno-warn-duplicate-exports" ] - prismImport = modifyImport $ importSimple "Lens.Labels.Prism" + mainImports = map (modifyImport . importSimple) + [ "Control.DeepSeq", "Lens.Labels.Prism" ] sharedImports = map (modifyImport . importSimple) [ "Prelude", "Data.Int", "Data.Word" , "Data.ProtoLens", "Data.ProtoLens.Message.Enum", "Data.ProtoLens.Service.Types" - , "Lens.Family2", "Lens.Family2.Unchecked", "Data.Default.Class" + , "Lens.Family2", "Lens.Family2.Unchecked" , "Data.Text", "Data.Map", "Data.ByteString", "Data.ByteString.Char8" , "Lens.Labels", "Text.Read" ] @@ -165,7 +166,7 @@ reexported imp@ImportDecl {importModule = m} = imp { importAs = Just m, importModule = m' } where - m' = fromString $ "Data.ProtoLens.Reexport." ++ prettyPrint m + m' = fromString $ "Data.ProtoLens.Runtime." ++ prettyPrint m messageComment :: ModuleName -> Name -> [RecordField] -> String messageComment fieldModName n fields = unlines @@ -181,8 +182,10 @@ generateMessageExports :: MessageInfo Name -> [ExportSpec] generateMessageExports m = - map (exportAll . unQual) - $ messageName m : map oneofTypeName (messageOneofFields m) + -- Hide the message contructor, but expose "oneof" case constructors. + exportWith (unQual $ messageName m) [] + : map (exportAll . unQual . oneofTypeName) + (messageOneofFields m) generateServiceDecls :: Env QName -> ServiceInfo -> [Decl] generateServiceDecls env si = @@ -253,9 +256,16 @@ ] ++ [(messageUnknownFields info, "Data.ProtoLens.FieldSet")] ] - $ deriving' ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"] + $ deriving' ["Prelude.Eq", "Prelude.Ord"] + -- instance Show Bar where + -- showsPrec __x __s = showChar '{' (showString (showMessageShort __x) (showChar '}' s)) + , uncommented $ + instDecl [] ("Prelude.Show" `ihApp` [dataType]) + [[match "showsPrec" ["_", "__x", "__s"] + $ "Prelude.showChar" @@ charExp '{' + @@ ("Prelude.showString" @@ ("Data.ProtoLens.showMessageShort" @@ "__x") + @@ ("Prelude.showChar" @@ charExp '}' @@ "__s"))]] ] ++ - -- oneof field data type declarations -- proto: message Foo { -- oneof bar { @@ -274,24 +284,13 @@ $ deriving' ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"] | oneofInfo <- messageOneofFields info ] ++ - -- 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 + -- instance HasLens' Foo "foo" Bar -- lensOf _ = ... -- Note: for optional fields, this generates an instance both for "foo" and -- for "maybe'foo" (see plainRecordField below). - [ uncommented $ instDecl [classA "Prelude.Functor" ["f"]] + [ uncommented $ instDecl [] ("Lens.Labels.HasLens'" `ihApp` - ["f", dataType, sym, tyParen t]) + [dataType, sym, tyParen t]) [[match "lensOf'" [pWildCard] $ "Prelude.." @@ rawFieldAccessor (unQual $ recordFieldName li) @@ -302,27 +301,19 @@ , let sym = promoteSymbol $ lensSymbol i ] ++ - -- instance Data.Default.Class.Default Bar where - [ uncommented $ instDecl [] ("Data.Default.Class.Default" `ihApp` [dataType]) - -- def = Bar { _Bar_foo = 0 } - [ - [ match "def" [] - $ recConstr (unQual dataName) $ - [ fieldUpdate (unQual $ haskellRecordFieldName $ plainFieldName f) - (hsFieldDefault syntaxType env (fieldDescriptor f)) - | f <- messageFields info - ] ++ - [ fieldUpdate (unQual $ haskellRecordFieldName $ oneofFieldName o) - "Prelude.Nothing" - | o <- messageOneofFields info - ] ++ - [ fieldUpdate (unQual $ messageUnknownFields info) - "[]"] - ] - ] -- instance Message.Message Bar where - , uncommented $ instDecl [] ("Data.ProtoLens.Message" `ihApp` [dataType]) + [ uncommented $ instDecl [] ("Data.ProtoLens.Message" `ihApp` [dataType]) $ messageInstance syntaxType env protoName info + -- instance NFData Bar where + , uncommented $ instDecl [] ("Control.DeepSeq.NFData" `ihApp` [dataType]) + [[match "rnf" [] $ messageRnfExpr info]] + ] ++ + -- instance NFData Foo'Bar where + [ uncommented $ + instDecl [] ("Control.DeepSeq.NFData" `ihApp` + [tyCon $ unQual $ oneofTypeName o]) + [map oneofRnfMatch $ oneofCases o] + | o <- messageOneofFields info ] where dataType = tyCon $ unQual dataName @@ -523,14 +514,15 @@ "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]] + -- instance NFData Foo where + -- rnf x__ = seq x__ () + -- (Trivial since enum types are already strict) + , instDecl [] ("Control.DeepSeq.NFData" `ihApp` [dataType]) + [[ match "rnf" ["x__"] $ "Prelude.seq" @@ "x__" @@ "()" ]] ] ++ -- pattern Enum2a :: FooEnum -- pattern Enum2a = Enum2 @@ -601,10 +593,6 @@ [ dataDecl dataName [conDecl n [] | n <- constructorNames] $ deriving' ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"] - -- 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]) @@ -684,6 +672,11 @@ [[ match "minBound" [] $ con $ unQual minBoundName , match "maxBound" [] $ con $ unQual maxBoundName ]] + -- instance NFData Foo where + -- rnf x__ = seq x__ () + -- (Trivial since enum types are already strict) + , instDecl [] ("Control.DeepSeq.NFData" `ihApp` [dataType]) + [[ match "rnf" ["x__"] $ "Prelude.seq" @@ "x__" @@ "()" ]] ] ++ -- pattern FooAlias :: Foo @@ -738,14 +731,14 @@ generateFieldDecls :: Symbol -> [Decl] generateFieldDecls xStr = - -- foo :: forall x 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 :: forall f s a + -- . (Functor f, HasLens s x a) => LensLike' f s a -- foo = lensOf (Proxy# :: Proxy# x) [ typeSig [x] - $ tyForAll ["f", "s", "t", "a", "b"] - [classA "Lens.Labels.HasLens" ["f", "s", "t", xSym, "a", "b"]] - $ "Lens.Family2.LensLike" @@ "f" @@ "s" @@ "t" @@ "a" @@ "b" + $ tyForAll ["f", "s", "a"] + [classA "Prelude.Functor" ["f"], + classA "Lens.Labels.HasLens'" ["s", xSym, "a"]] + $ "Lens.Family2.LensLike'" @@ "f" @@ "s" @@ "a" , funBind [match x [] $ lensOfExp xStr] ] where @@ -763,7 +756,7 @@ -- ^ All of the (overloaded) lenses accessing this record field. } --- | An instance of HasLens for a particualr field. +-- | An instance of HasLens' for a particular field. data LensInstance = LensInstance { lensSymbol :: Symbol -- ^ The overloaded name for this lens. @@ -949,10 +942,10 @@ hsFieldValueDefault :: Env QName -> FieldDescriptorProto -> Exp hsFieldValueDefault env fd = case fd ^. type' of - FieldDescriptorProto'TYPE_MESSAGE -> "Data.Default.Class.def" - FieldDescriptorProto'TYPE_GROUP -> "Data.Default.Class.def" + FieldDescriptorProto'TYPE_MESSAGE -> "Data.ProtoLens.defMessage" + FieldDescriptorProto'TYPE_GROUP -> "Data.ProtoLens.defMessage" FieldDescriptorProto'TYPE_ENUM - | T.null def -> "Data.Default.Class.def" + | T.null def -> "Data.ProtoLens.fieldDefault" | Enum e <- definedFieldType fd env , Just v <- List.lookup def [ (enumValueDescriptor v ^. name, enumValueName v) | v <- enumValues e @@ -1047,6 +1040,19 @@ let' (map (fieldDescriptorVarBind $ messageName m) $ fields) $ "Data.Map.fromList" @@ list fieldsByTag ] , [ match "unknownFields" [] $ rawFieldAccessor (unQual $ messageUnknownFields m) ] + , [ match "defMessage" [] + $ recConstr (unQual $ messageName m) $ + [ fieldUpdate (unQual $ haskellRecordFieldName $ plainFieldName f) + (hsFieldDefault syntaxType env (fieldDescriptor f)) + | f <- messageFields m + ] ++ + [ fieldUpdate (unQual $ haskellRecordFieldName $ oneofFieldName o) + "Prelude.Nothing" + | o <- messageOneofFields m + ] ++ + [ fieldUpdate (unQual $ messageUnknownFields m) + "[]"] + ] ] where fieldsByTag = @@ -1129,7 +1135,7 @@ _ -> overloadedField f lensOfExp :: Symbol -> Exp -lensOfExp sym = ("Lens.Labels.lensOf" +lensOfExp sym = ("Lens.Labels.lensOf'" @@ ("Lens.Labels.proxy#" @::@ ("Lens.Labels.Proxy#" @@ promoteSymbol sym))) @@ -1181,3 +1187,25 @@ where mk x y = fromString ("Data.ProtoLens." ++ x) @@ fromString ("Data.ProtoLens." ++ y) + +-- | Generate the implementation of NFData.rnf for the given message. +-- +-- instance NFData Bar where +-- rnf = \x -> deepseq (_Bar'foo x) (deepseq (_Bar'bar x) ()) +messageRnfExpr :: MessageInfo Name -> Exp +messageRnfExpr msg = lambda ["x__"] $ foldr (@@) "()" (map seqField fieldNames) + where + fieldNames = messageUnknownFields msg + : map (haskellRecordFieldName . plainFieldName) + (messageFields msg) + ++ map (haskellRecordFieldName . oneofFieldName) + (messageOneofFields msg) + seqField :: Name -> Exp + seqField f = "Control.DeepSeq.deepseq" @@ (var (unQual f) @@ "x__") + +-- instance NFData Bar where +-- rnf (Foo'a x__) = rnf x__ +-- rnf (Bar'b x__) = rnf x__ +oneofRnfMatch :: OneofCase -> Match +oneofRnfMatch c = match "rnf" [unQual (caseConstructorName c) `pApp` ["x__"]] + $ "Control.DeepSeq.rnf" @@ "x__" diff --git a/src/Data/ProtoLens/Setup.hs b/src/Data/ProtoLens/Setup.hs deleted file mode 100644 --- a/src/Data/ProtoLens/Setup.hs +++ /dev/null @@ -1,479 +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 - --- | Helper functions to generate proto files as part of a @Setup.hs@ script. --- --- These functions assume that the @proto-lens-protoc@ executable is on the --- PATH, and throw an exception otherwise. That executable will be installed --- automatically as part of installing this package; in particular, it should --- be enough to just list `proto-lens-protoc` in a user package's --- `build-dependencies`. --- --- See @README.md@ for instructions on how to use proto-lens with Cabal. -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -module Data.ProtoLens.Setup - ( defaultMainGeneratingProtos - , defaultMainGeneratingSpecificProtos - , generatingProtos - , generatingSpecificProtos - , generateProtosWithImports - , generateProtos - ) where - -import Control.Monad (filterM, forM_, when) -import qualified Data.ByteString as BS -import qualified Data.Map as Map -import Data.Maybe (maybeToList) -import qualified Data.Set as Set -import qualified Data.Text as T -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 -#if !MIN_VERSION_Cabal(2,0,0) - , hsSourceDirs -#endif -#if MIN_VERSION_Cabal(2,4,0) - , specVersion -#endif - , libBuildInfo - , otherModules - , testBuildInfo - , testBuildInfo - , testName - ) -import qualified Distribution.Simple.BuildPaths as BuildPaths -import Distribution.Simple.InstallDirs (datadir) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..) - , absoluteInstallDirs - , ComponentName(..) - , ComponentLocalBuildInfo - , 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 - , installOrdinaryFile -#if MIN_VERSION_Cabal(2,4,0) -#else - , matchFileGlob -#endif - ) -#if MIN_VERSION_Cabal(2,4,0) -import Distribution.Simple.Glob (matchDirFileGlob) -#endif -import Distribution.Simple - ( defaultMainWithHooks - , simpleUserHooks - , UserHooks(..) - ) -import Distribution.Verbosity - ( Verbosity -#if MIN_VERSION_Cabal(2,4,0) - , normal -#endif - ) -import System.FilePath - ( () - , equalFilePath - , isRelative - , makeRelative - , takeDirectory - , takeExtension - ) -import System.Directory - ( copyFile - , createDirectoryIfMissing - , doesDirectoryExist - , doesFileExist - , findExecutable - , removeDirectoryRecursive - ) -import System.IO (hPutStrLn, stderr) -import System.IO.Temp (withSystemTempDirectory) -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 .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). --- --- Throws an exception if the @proto-lens-protoc@ executable is not on the PATH. -defaultMainGeneratingProtos - :: FilePath -- ^ The root directory under which .proto files can be found. - -> IO () -defaultMainGeneratingProtos root - = defaultMainWithHooks $ generatingProtos root simpleUserHooks - --- | This behaves the same as 'Distribution.Simple.defaultMain', but --- auto-generates Haskell files from the .proto files listed. The given .proto --- files should be under the given root directory. --- --- Writes the generated files to the autogen directory (@dist\/build\/autogen@ --- for Cabal, and @.stack-work\/dist\/...\/build\/autogen@ for stack). --- --- 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. - -> (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. - -> IO () -defaultMainGeneratingSpecificProtos root getProtos - = defaultMainWithHooks - $ generatingSpecificProtos root getProtos simpleUserHooks - --- | Augment the given 'UserHooks' to auto-generate Haskell files from the --- .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). --- --- Throws an exception if the @proto-lens-protoc@ executable is not on the PATH. -generatingProtos - :: FilePath -- ^ The root directory under which .proto files can be found. - -> UserHooks -> UserHooks -generatingProtos root = generatingSpecificProtos root getProtos - where - getProtos l = do - -- Replicate Cabal's own logic for parsing file globs. - files <- concat <$> mapM (match $ localPkgDescr l) - (extraSrcFiles $ localPkgDescr l) - pure - . filter (\f -> takeExtension f == ".proto") - . map (makeRelative root) - . filter (isSubdirectoryOf root) - $ files - -match :: PackageDescription -> FilePath -> IO [FilePath] -#if MIN_VERSION_Cabal(2,4,0) -match desc f = matchDirFileGlob normal (specVersion desc) "." f -#else -match _ f = matchFileGlob f -#endif - --- | Augment the given 'UserHooks' to auto-generate Haskell files from the --- .proto files returned by a function @getProtos@. --- --- Writes the generated files to the autogen directory (@dist\/build\/autogen@ --- for Cabal, and @.stack-work\/dist\/...\/build\/autogen@ for stack). --- --- 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. - -> (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 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 -#if !MIN_VERSION_Cabal(2,0,0) - -- Older versions of Cabal don't support the autogen-modules field. - -- Work around it by manually generating the modules and putting them - -- in a place where `cabal sdist` will pick them up. - , sDistHook = \p maybe_l h f -> case maybe_l of - Nothing -> error "Can't run protoc; run 'cabal configure' first." - Just l -> do - generate l - sDistHook hooks (fudgePackageDesc l p) maybe_l h f -#endif - , postCopy = \a flags pkg lbi -> do - let verb = fromFlag $ copyVerbosity flags - let destDir = datadir (absoluteInstallDirs pkg lbi - $ fromFlag $ copyDest flags) - protoLensImportsPrefix - getProtos lbi >>= copyProtosToDataDir verb root destDir - postCopy hooks a flags pkg lbi - } - where - generate l = getProtos l >>= generateSources root l - --- | Generate Haskell source files for the given input .proto files. --- --- Process all the proto files that are referenced in the exposed-modules --- or other-modules of some "active" component, and write them all to a --- single temporary directory. (For example, passing --no-enable-tests --- makes all test-suite components inactive.) --- --- Then, for each active component, copy the corresponding module files --- over to its specific autogen directory (if Cabal-2.*) or to the global --- autogen directory (if Cabal-1.*). However, don't actually do the copy --- if it's the same as 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). -generateSources :: FilePath -- ^ The root directory - -> LocalBuildInfo - -> [FilePath] -- ^ Proto files relative to the root directory. - -> IO () -generateSources root l files = withSystemTempDirectory "protoc-out" $ \tmpDir -> do - -- Collect import paths from build-depends of this package. - importDirs <- filterM doesDirectoryExist - [ InstalledPackageInfo.dataDir info protoLensImportsPrefix - | info <- collectDeps l - ] - -- Generate .hs files for all active components into a single temporary - -- directory. - let activeModules = collectActiveModules l - let allModules = Set.fromList . concat . map snd $ activeModules - let usedInComponent f = ModuleName.fromString (Plugin.moduleNameStr "Proto" f) - `Set.member` allModules - generateProtosWithImports (root : importDirs) tmpDir - -- Applying 'root ' does nothing if the path is already - -- absolute. - $ map (root ) $ filter usedInComponent files - -- Copy each active component's files over to its autogen directory, but - -- only if they've changed since last time. - forM_ activeModules $ \(compBI, mods) -> forM_ mods $ \m -> do - let f = T.unpack (Plugin.outputFilePath $ ModuleName.toFilePath m) - let sourcePath = tmpDir f - sourceExists <- doesFileExist sourcePath - when sourceExists $ do - let dest = autogenComponentModulesDir l compBI f - copyIfDifferent sourcePath dest - --- Note: we do a copy rather than a move since a given module may be used in --- more than one component. -copyIfDifferent :: FilePath -> FilePath -> IO () -copyIfDifferent sourcePath targetPath = do - targetExists <- doesFileExist targetPath - identical <- do - 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) - copyFile 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. -copyProtosToDataDir :: Verbosity - -> FilePath -- ^ The root for source .proto files in this - -- package. - -> FilePath -- ^ The final location where .proto files should - -- be installed. - -> [FilePath] -- ^ .proto files relative to the root - -> IO () -copyProtosToDataDir verb root destDir files = do - -- Make the build more hermetic by clearing the output - -- directory. - exists <- doesDirectoryExist destDir - when exists $ removeDirectoryRecursive destDir - forM_ files $ \f -> do - let srcFile = root f - let destFile = destDir f - createDirectoryIfMissingVerbose verb True - (takeDirectory destFile) - installOrdinaryFile verb srcFile destFile - --- | Imports are stored as $datadir/proto-lens-imports/**/*.proto. -protoLensImportsPrefix :: FilePath -protoLensImportsPrefix = "proto-lens-imports" - -#if !MIN_VERSION_Cabal(2,0,0) --- | Add the autogen directory to the hs-source-dirs of all the targets in the --- .cabal file. Used to fool 'sdist' by pointing it to the generated source --- files. -fudgePackageDesc :: LocalBuildInfo -> PackageDescription -> PackageDescription -fudgePackageDesc lbi p = p - { library = - (\lib -> lib { libBuildInfo = fudgeBuildInfo CLibName $ libBuildInfo lib }) - <$> library p - , executables = - (\exe -> exe { buildInfo = fudgeBuildInfo (CExeName $ exeName exe) - $ buildInfo exe }) - <$> executables p - , testSuites = - (\test -> test { testBuildInfo = fudgeBuildInfo (CTestName $ testName test) - $ testBuildInfo test }) - <$> testSuites p - , benchmarks = - (\bench -> bench { benchmarkBuildInfo = - fudgeBuildInfo (CBenchName $ benchmarkName bench) - $ benchmarkBuildInfo bench }) - <$> benchmarks p - } - where - comps = allComponents lbi - fudgeBuildInfo n bi - | Just compLBI <- Map.lookup n comps - = bi { hsSourceDirs = autogenComponentModulesDir lbi compLBI - : hsSourceDirs bi } - | otherwise = bi -- Could happen if a component isn't active; try - -- anyway and see whether Cabal complains later on. -#endif - --- | Returns whether the @root@ is a parent folder of @f@. -isSubdirectoryOf :: FilePath -> FilePath -> Bool -isSubdirectoryOf root f - = isRelative f - -- Note: `makeRelative root f` returns `f` when f doesn't live under the - -- root. - && equalFilePath f (root makeRelative root f) - --- | Run the proto compiler to generate Haskell files from the given .proto files. --- --- Writes the generated files to the autogen directory (@dist\/build\/autogen@ --- for Cabal, and @.stack-work\/dist\/...\/build\/autogen@ for stack). --- --- Throws an exception if the @proto-lens-protoc@ executable is not on the PATH. -generateProtos - :: FilePath -- ^ The root directory under which .proto files can be found. - -> FilePath -- ^ The output directory for the generated Haskell files. - -> [FilePath] -- ^ The .proto files to process. - -> IO () -generateProtos root = generateProtosWithImports [root] --- --- | Run the proto compiler to generate Haskell files from the given .proto files. --- --- Writes the generated files to the autogen directory (@dist\/build\/autogen@ --- for Cabal, and @.stack-work\/dist\/...\/build\/autogen@ for stack). --- --- Throws an exception if the @proto-lens-protoc@ executable is not on the PATH. -generateProtosWithImports - :: [FilePath] -- ^ Directories under which .proto files and/or files that - -- they import can be found. - -> FilePath -- ^ The output directory for the generated Haskell files. - -> [FilePath] -- ^ The .proto files to process. - -> IO () -generateProtosWithImports _ _ [] = return () -generateProtosWithImports imports output files = do - 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 - --- | 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 -> [(ComponentLocalBuildInfo, [ModuleName])] -collectActiveModules l = map (\(n, c) -> (c, f n)) $ Map.toList $ allComponents l - where - p = localPkgDescr l - f CLibName = maybeToList (library p) >>= - \lib -> exposedModules lib - ++ otherModules (libBuildInfo lib) - f (CExeName n) = otherModules . buildInfo $ exes Map.! n - f (CTestName n) = otherModules . testBuildInfo $ tests Map.! n - f (CBenchName n) = otherModules . benchmarkBuildInfo $ benchs Map.! n -#if MIN_VERSION_Cabal(2,0,0) - f _ = [] -- TODO: other lib kinds; for now just suppress the warning -#endif - exes = Map.fromList [(exeName e, e) | e <- executables p] - tests = Map.fromList [(testName e, e) | e <- testSuites p] - benchs = Map.fromList [(benchmarkName e, e) | e <- benchmarks p] - -------------------------------------------------------- --- 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 - --- | All the components that will be built by this Cabal command. -allComponents :: LocalBuildInfo -> Map.Map ComponentName ComponentLocalBuildInfo -#if MIN_VERSION_Cabal(2,0,0) -allComponents l = fmap requireOne $ componentNameMap l - where - -- TODO: this doesn't support Backpack, which can have more than one - -- ComponentLocalBuildInfo associated with a name. - requireOne [x] = x - requireOne xs = error $ "Data.ProtoLens.Setup.allComponents: expected one " - ++ "component per name, got " ++ show xs - -#else -allComponents l = Map.fromList [(c, b) | (c, b, _) <- componentsConfigs l] -#endif - --- | Get the component-level "autogen" directory where we're putting the --- generated .hs files. (For Cabal-1.0, use the shared 'BuildPaths.autogenModulesDir'.) -autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> FilePath -#if MIN_VERSION_Cabal(2,0,0) -autogenComponentModulesDir = BuildPaths.autogenComponentModulesDir -#else -autogenComponentModulesDir lbi _ = BuildPaths.autogenModulesDir lbi -#endif