diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: Cabal -version: 3.10.2.1 +version: 3.10.3.0 copyright: 2003-2023, Cabal Development Team (see AUTHORS file) license: BSD-3-Clause license-file: LICENSE @@ -21,7 +21,7 @@ -- If we use a new Cabal feature, this needs to be changed to Custom so -- we can bootstrap. -extra-source-files: +extra-doc-files: README.md ChangeLog.md source-repository head @@ -38,16 +38,16 @@ array >= 0.4.0.1 && < 0.6, base >= 4.9 && < 5, bytestring >= 0.10.0.0 && < 0.13, - containers >= 0.5.0.0 && < 0.7, + containers >= 0.5.0.0 && < 0.8, deepseq >= 1.3.0.1 && < 1.6, directory >= 1.2 && < 1.4, - filepath >= 1.3.0.1 && < 1.5, + filepath >= 1.3.0.1 && < 1.6, pretty >= 1.1.1 && < 1.2, process >= 1.2.1.0 && < 1.7, time >= 1.4.0.1 && < 1.13 if os(windows) - build-depends: Win32 >= 2.3.0.0 && < 2.14 + build-depends: Win32 >= 2.3.0.0 && < 2.15 else build-depends: unix >= 2.6.0.0 && < 2.9 diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,4 +1,7 @@ -# 3.10.2.1 [Hécate] (mailto:hecate+github@glitchbra.in) October 2023 +# 3.10.3.0 [Hécate](mailto:hecate+github@glitchbra.in) January 2024 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.10.3.0.md + +# 3.10.2.1 [Hécate](mailto:hecate+github@glitchbra.in) October 2023 * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.10.2.1.md # 3.10.2.0 [Hécate](mailto:hecate+github@glitchbra.in) August 2023 diff --git a/src/Distribution/PackageDescription/Check.hs b/src/Distribution/PackageDescription/Check.hs --- a/src/Distribution/PackageDescription/Check.hs +++ b/src/Distribution/PackageDescription/Check.hs @@ -224,6 +224,7 @@ | CVExpliticDepsCustomSetup | CVAutogenPaths | CVAutogenPackageInfo + | CVAutogenPackageInfoGuard | GlobNoMatch String String | GlobExactMatch String String FilePath | GlobNoDir String String FilePath @@ -664,6 +665,11 @@ ++ "the module does not come with the package and is generated on " ++ "setup. Modules built with a custom Setup.hs script also go here " ++ "to ensure that commands like sdist don't fail." +ppExplanation CVAutogenPackageInfoGuard = + "To use the autogenerated module PackageInfo_* you need to specify " + ++ "`cabal-version: 3.12` or higher. This is not possible in `cabal " + ++ "3.10`. To use this feature and be able to upload your package to " + ++ "Hackage, download `cabal 3.12`!" ppExplanation (GlobNoMatch field glob) = "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not" ++ " match any files." @@ -1193,9 +1199,10 @@ unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ] unknownLanguages = [ name | bi <- allBuildInfo pkg , UnknownLanguage name <- allLanguages bi ] - unknownExtensions = [ name | bi <- allBuildInfo pkg - , UnknownExtension name <- allExtensions bi - , name `notElem` map prettyShow knownLanguages ] + unknownExtensions = filter (/= "TypeAbstractions") + [ name | bi <- allBuildInfo pkg + , UnknownExtension name <- allExtensions bi + , name `notElem` map prettyShow knownLanguages ] ourDeprecatedExtensions = nub $ catMaybes [ find ((==ext) . fst) deprecatedExtensions | bi <- allBuildInfo pkg @@ -1813,6 +1820,9 @@ && not (elem (autogenPackageInfoModuleName pkg) allModuleNamesAutogen) ) $ PackageDistInexcusable CVAutogenPackageInfo + , check + (elem (autogenPackageInfoModuleName pkg) allModuleNames) + (PackageDistInexcusable CVAutogenPackageInfoGuard) ] where -- Perform a check on packages that use a version of the spec less than diff --git a/src/Distribution/Simple.hs b/src/Distribution/Simple.hs --- a/src/Distribution/Simple.hs +++ b/src/Distribution/Simple.hs @@ -576,8 +576,7 @@ -- -- * 'postConf' runs @.\/configure@, if present. -- --- * the pre-hooks 'preBuild', 'preClean', 'preCopy', 'preInst', --- 'preReg' and 'preUnreg' read additional build information from +-- * the pre-hooks, except for pre-conf, read additional build information from -- /package/@.buildinfo@, if present. -- -- Thus @configure@ can use local system information to generate @@ -588,14 +587,17 @@ = simpleUserHooks { postConf = defaultPostConf, - preBuild = readHookWithArgs buildVerbosity buildDistPref, -- buildCabalFilePath, + preBuild = readHookWithArgs buildVerbosity buildDistPref, + preRepl = readHookWithArgs replVerbosity replDistPref, preCopy = readHookWithArgs copyVerbosity copyDistPref, preClean = readHook cleanVerbosity cleanDistPref, preInst = readHook installVerbosity installDistPref, preHscolour = readHook hscolourVerbosity hscolourDistPref, preHaddock = readHookWithArgs haddockVerbosity haddockDistPref, preReg = readHook regVerbosity regDistPref, - preUnreg = readHook regVerbosity regDistPref + preUnreg = readHook regVerbosity regDistPref, + preTest = readHookWithArgs testVerbosity testDistPref, + preBench = readHookWithArgs benchmarkVerbosity benchmarkDistPref } where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () diff --git a/src/Distribution/Simple/Configure.hs b/src/Distribution/Simple/Configure.hs --- a/src/Distribution/Simple/Configure.hs +++ b/src/Distribution/Simple/Configure.hs @@ -76,12 +76,13 @@ import Distribution.Simple.Setup as Setup import Distribution.Simple.BuildTarget import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program.Db (appendProgramSearchPath, modifyProgramSearchPath, lookupProgramByName) +import Distribution.Simple.Utils +import Distribution.System import Distribution.Types.PackageVersionConstraint import Distribution.Types.LocalBuildInfo import Distribution.Types.ComponentRequestedSpec import Distribution.Types.GivenComponent -import Distribution.Simple.Utils -import Distribution.System import Distribution.Version import Distribution.Verbosity import qualified Distribution.Compat.Graph as Graph @@ -101,7 +102,8 @@ import Control.Exception ( try ) import Distribution.Utils.Structured ( structuredDecodeOrFailIO, structuredEncode ) -import Distribution.Compat.Directory ( listDirectory ) +import Distribution.Compat.Directory + ( listDirectory, doesPathExist ) import Data.ByteString.Lazy ( ByteString ) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as BLC8 @@ -114,8 +116,6 @@ , getTemporaryDirectory, removeFile) import System.FilePath ( (), isAbsolute, takeDirectory ) -import Distribution.Compat.Directory - ( doesPathExist ) import qualified System.Info ( compilerName, compilerVersion ) import System.IO @@ -367,18 +367,19 @@ (fromFlag (configUserInstall cfg)) (configPackageDBs cfg) + programDbPre <- mkProgramDb cfg (configPrograms cfg) -- comp: the compiler we're building with -- compPlatform: the platform we're building for -- programDb: location and args of all programs we're -- building with - (comp :: Compiler, + (comp :: Compiler, compPlatform :: Platform, - programDb :: ProgramDb) + programDb :: ProgramDb) <- configCompilerEx (flagToMaybe (configHcFlavor cfg)) (flagToMaybe (configHcPath cfg)) (flagToMaybe (configHcPkg cfg)) - (mkProgramDb cfg (configPrograms cfg)) + programDbPre (lessVerbose verbosity) -- The InstalledPackageIndex of all installed packages @@ -637,21 +638,16 @@ "--enable-split-objs; ignoring") return False - let compilerSupportsGhciLibs :: Bool - compilerSupportsGhciLibs = - case compilerId comp of - CompilerId GHC version - | version > mkVersion [9,3] && windows -> - False - CompilerId GHC _ -> - True - CompilerId GHCJS _ -> - True - _ -> False - where - windows = case compPlatform of - Platform _ Windows -> True - Platform _ _ -> False + -- Basically yes/no/unknown. + let linkerSupportsRelocations :: Maybe Bool + linkerSupportsRelocations = + case lookupProgramByName "ld" programDb'' of + Nothing -> Nothing + Just ld -> + case Map.lookup "Supports relocatable output" $ programProperties ld of + Just "YES" -> Just True + Just "NO" -> Just False + _other -> Nothing let ghciLibByDefault = case compilerId comp of @@ -671,10 +667,12 @@ withGHCiLib_ <- case fromFlagOrDefault ghciLibByDefault (configGHCiLib cfg) of - True | not compilerSupportsGhciLibs -> do + -- NOTE: If linkerSupportsRelocations is Nothing this may still fail if the + -- linker does not support -r. + True | not (fromMaybe True linkerSupportsRelocations) -> do warn verbosity $ - "--enable-library-for-ghci is no longer supported on Windows with" - ++ " GHC 9.4 and later; ignoring..." + "--enable-library-for-ghci is not supported with the current" + ++ " linker; ignoring..." return False v -> return v @@ -843,17 +841,28 @@ where verbosity = fromFlag (configVerbosity cfg) -mkProgramDb :: ConfigFlags -> ProgramDb -> ProgramDb -mkProgramDb cfg initialProgramDb = programDb +-- | Adds the extra program paths from the flags provided to @configure@ as +-- well as specified locations for certain known programs and their default +-- arguments. +mkProgramDb :: ConfigFlags -> ProgramDb -> IO ProgramDb +mkProgramDb cfg initialProgramDb = do + programDb <- + modifyProgramSearchPath (getProgramSearchPath initialProgramDb ++) + <$> appendProgramSearchPath (fromFlagOrDefault normal (configVerbosity cfg)) searchpath initialProgramDb + pure + . userSpecifyArgss (configProgramArgs cfg) + . userSpecifyPaths (configProgramPaths cfg) + $ programDb where - programDb = userSpecifyArgss (configProgramArgs cfg) - . userSpecifyPaths (configProgramPaths cfg) - . setProgramSearchPath searchpath - $ initialProgramDb - searchpath = map ProgramSearchPathDir - (fromNubList $ configProgramPathExtra cfg) - ++ getProgramSearchPath initialProgramDb + searchpath = fromNubList $ configProgramPathExtra cfg +-- Note. We try as much as possible to _prepend_ rather than postpend the extra-prog-path +-- so that we can override the system path. However, in a v2-build, at this point, the "system" path +-- has already been extended by both the built-tools-depends paths, as well as the program-path-extra +-- so for v2 builds adding it again is entirely unnecessary. However, it needs to get added again _anyway_ +-- so as to take effect for v1 builds or standalone calls to Setup.hs +-- In this instance, the lesser evil is to not allow it to override the system path. + -- ----------------------------------------------------------------------------- -- Helper functions for configure @@ -938,11 +947,11 @@ then internalDepSatisfiable else -- Backward compatibility for the old sublibrary syntax - (sublibs == mainLibSet + sublibs == mainLibSet && Map.member (pn, CLibName $ LSubLibName $ packageNameToUnqualComponentName depName) - requiredDepsMap) + requiredDepsMap || all visible sublibs @@ -969,7 +978,7 @@ internalDepSatisfiable = Set.isSubsetOf (NES.toSet sublibs) packageLibraries internalDepSatisfiableExternally = - all (\ln -> not $ null $ PackageIndex.lookupInternalDependency installedPackageSet pn vr ln) sublibs + all (not . null . PackageIndex.lookupInternalDependency installedPackageSet pn vr) sublibs -- Check whether a library exists and is visible. -- We don't disambiguate between dependency on non-existent or private @@ -1438,8 +1447,7 @@ -- flag into a single package db stack. -- interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack -interpretPackageDbFlags userInstall specificDBs = - extra initialStack specificDBs +interpretPackageDbFlags userInstall = extra initialStack where initialStack | userInstall = [GlobalPackageDB, UserPackageDB] | otherwise = [GlobalPackageDB] @@ -1685,8 +1693,8 @@ let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' - (extraLibsStatic') = filter ("-l" `isPrefixOf`) ldflags_static - (extraLibDirsStatic') = filter ("-L" `isPrefixOf`) ldflags_static + extraLibsStatic' = filter ("-l" `isPrefixOf`) ldflags_static + extraLibDirsStatic' = filter ("-L" `isPrefixOf`) ldflags_static in mempty { includeDirs = map (drop 2) includeDirs', extraLibs = map (drop 2) extraLibs', @@ -1702,13 +1710,13 @@ configCompilerAuxEx :: ConfigFlags -> IO (Compiler, Platform, ProgramDb) -configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg) +configCompilerAuxEx cfg = do + programDb <- mkProgramDb cfg defaultProgramDb + configCompilerEx (flagToMaybe $ configHcFlavor cfg) (flagToMaybe $ configHcPath cfg) (flagToMaybe $ configHcPkg cfg) programDb (fromFlag (configVerbosity cfg)) - where - programDb = mkProgramDb cfg defaultProgramDb configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath -> ProgramDb -> Verbosity diff --git a/src/Distribution/Simple/ConfigureScript.hs b/src/Distribution/Simple/ConfigureScript.hs --- a/src/Distribution/Simple/ConfigureScript.hs +++ b/src/Distribution/Simple/ConfigureScript.hs @@ -137,10 +137,9 @@ maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)] args' = configureFile':args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag shProg = simpleProgram "sh" - progDb = modifyProgramSearchPath - (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb + progDb <- appendProgramSearchPath verbosity extraPath emptyProgramDb shConfiguredProg <- lookupProgram shProg - `fmap` configureProgram verbosity shProg progDb + `fmap` configureProgram verbosity shProg progDb case shConfiguredProg of Just sh -> runProgramInvocation verbosity $ (programInvocation (sh {programOverrideEnv = overEnv}) args') diff --git a/src/Distribution/Simple/GHC.hs b/src/Distribution/Simple/GHC.hs --- a/src/Distribution/Simple/GHC.hs +++ b/src/Distribution/Simple/GHC.hs @@ -935,7 +935,7 @@ ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs libBi, - ghcOptRPaths = rpaths + ghcOptRPaths = rpaths <> toNubListR (extraLibDirs libBi) } ghcStaticLinkArgs = mempty { @@ -1436,7 +1436,7 @@ [tmpDir x | x <- cLikeObjs ++ cxxObjs] } dynLinkerOpts = mempty { - ghcOptRPaths = rpaths, + ghcOptRPaths = rpaths <> toNubListR (extraLibDirs bnfo), ghcOptInputFiles = toNubListR [tmpDir x | x <- cLikeObjs ++ cxxObjs] } @@ -1861,18 +1861,12 @@ libBi = libBuildInfo lib comp = compiler lbi platform = hostPlatform lbi - vanillaArgs0 = + vanillaArgs = (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) `mappend` mempty { ghcOptMode = toFlag GhcModeAbiHash, ghcOptInputModules = toNubListR $ exposedModules lib } - vanillaArgs = - -- Package DBs unnecessary, and break ghc-cabal. See #3633 - -- BUT, put at least the global database so that 7.4 doesn't - -- break. - vanillaArgs0 { ghcOptPackageDBs = [GlobalPackageDB] - , ghcOptPackages = mempty } sharedArgs = vanillaArgs `mappend` mempty { ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptFPic = toFlag True, @@ -1896,7 +1890,7 @@ (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) hash <- getProgramInvocationOutput verbosity - (ghcInvocation ghcProg comp platform ghcArgs) + =<< ghcInvocation verbosity ghcProg comp platform ghcArgs return (takeWhile (not . isSpace) hash) componentGhcOptions :: Verbosity -> LocalBuildInfo diff --git a/src/Distribution/Simple/GHC/Internal.hs b/src/Distribution/Simple/GHC/Internal.hs --- a/src/Distribution/Simple/GHC/Internal.hs +++ b/src/Distribution/Simple/GHC/Internal.hs @@ -101,7 +101,9 @@ } . addKnownProgram ldProgram { programFindLocation = findProg ldProgramName extraLdPath, - programPostConf = configureLd + programPostConf = \v cp -> + -- Call any existing configuration first and then add any new configuration + configureLd v =<< programPostConf ldProgram v cp } . addKnownProgram arProgram { programFindLocation = findProg arProgramName extraArPath diff --git a/src/Distribution/Simple/GHCJS.hs b/src/Distribution/Simple/GHCJS.hs --- a/src/Distribution/Simple/GHCJS.hs +++ b/src/Distribution/Simple/GHCJS.hs @@ -1573,18 +1573,12 @@ libBi = libBuildInfo lib comp = compiler lbi platform = hostPlatform lbi - vanillaArgs0 = + vanillaArgs = (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) `mappend` mempty { ghcOptMode = toFlag GhcModeAbiHash, ghcOptInputModules = toNubListR $ exposedModules lib } - vanillaArgs = - -- Package DBs unnecessary, and break ghc-cabal. See #3633 - -- BUT, put at least the global database so that 7.4 doesn't - -- break. - vanillaArgs0 { ghcOptPackageDBs = [GlobalPackageDB] - , ghcOptPackages = mempty } sharedArgs = vanillaArgs `mappend` mempty { ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptFPic = toFlag True, @@ -1608,7 +1602,7 @@ (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) hash <- getProgramInvocationOutput verbosity - (ghcInvocation ghcjsProg comp platform ghcArgs) + =<< ghcInvocation verbose ghcjsProg comp platform ghcArgs return (takeWhile (not . isSpace) hash) componentGhcOptions :: Verbosity -> LocalBuildInfo diff --git a/src/Distribution/Simple/Program/Builtin.hs b/src/Distribution/Simple/Program/Builtin.hs --- a/src/Distribution/Simple/Program/Builtin.hs +++ b/src/Distribution/Simple/Program/Builtin.hs @@ -256,8 +256,7 @@ stripProgram :: Program stripProgram = (simpleProgram "strip") { - programFindVersion = \verbosity -> - findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity) + programFindVersion = findProgramVersion "--version" stripExtractVersion . lessVerbose } hsc2hsProgram :: Program @@ -322,8 +321,45 @@ greencardProgram = simpleProgram "greencard" ldProgram :: Program -ldProgram = simpleProgram "ld" +ldProgram = (simpleProgram "ld") + { programPostConf = \verbosity ldProg -> do + -- The `lld` linker cannot create merge (relocatable) objects so we + -- want to detect this. + -- If the linker does support relocatable objects, we want to use that + -- to create partially pre-linked objects for GHCi, so we get much + -- faster loading as we do not have to do the separate loading and + -- in-memory linking the static linker in GHC does, but can offload + -- parts of this process to a pre-linking step. + -- However this requires the linker to support this features. Not all + -- linkers do, and notably as of this writing `lld` which is a popular + -- choice for windows linking does not support this feature. However + -- if using binutils ld or another linker that supports --relocatable, + -- we should still be good to generate pre-linked objects. + ldHelpOutput <- + getProgramInvocationOutput + verbosity + (programInvocation ldProg ["--help"]) + -- In case the linker does not support '--help'. Eg the LLVM linker, + -- `lld` only accepts `-help`. + `catchIO` (\_ -> return "") + let k = "Supports relocatable output" + -- Standard GNU `ld` uses `--relocatable` while `ld.gold` uses + -- `-relocatable` (single `-`). + v + | "-relocatable" `isInfixOf` ldHelpOutput = "YES" + -- ld64 on macOS has this lovely response for "--help" + -- + -- ld64: For information on command line options please use 'man ld'. + -- + -- it does however support -r, if you read the manpage + -- (e.g. https://www.manpagez.com/man/1/ld64/) + | "ld64:" `isPrefixOf` ldHelpOutput = "YES" + | otherwise = "NO" + m = Map.insert k v (programProperties ldProg) + return $ ldProg{programProperties = m} + } + tarProgram :: Program tarProgram = (simpleProgram "tar") { -- See #1901. Some versions of 'tar' (OpenBSD, NetBSD, ...) don't support the @@ -334,7 +370,7 @@ -- Some versions of tar don't support '--help'. `catchIO` (\_ -> return "") let k = "Supports --format" - v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO" + v = if "--format" `isInfixOf` tarHelpOutput then "YES" else "NO" m = Map.insert k v (programProperties tarProg) return $ tarProg { programProperties = m } } @@ -343,6 +379,14 @@ cppProgram = simpleProgram "cpp" pkgConfigProgram :: Program -pkgConfigProgram = (simpleProgram "pkg-config") { - programFindVersion = findProgramVersion "--version" id - } +pkgConfigProgram = + (simpleProgram "pkg-config") + { programFindVersion = findProgramVersion "--version" id + , programPostConf = \_ pkgConfProg -> + let programOverrideEnv' = + programOverrideEnv pkgConfProg + ++ [ ("PKG_CONFIG_ALLOW_SYSTEM_CFLAGS", Just "1") + , ("PKG_CONFIG_ALLOW_SYSTEM_LIBS", Just "1") + ] + in pure $ pkgConfProg{programOverrideEnv = programOverrideEnv'} + } diff --git a/src/Distribution/Simple/Program/Db.hs b/src/Distribution/Simple/Program/Db.hs --- a/src/Distribution/Simple/Program/Db.hs +++ b/src/Distribution/Simple/Program/Db.hs @@ -34,6 +34,7 @@ -- ** Query and manipulate the program db addKnownProgram, addKnownPrograms, + appendProgramSearchPath, lookupKnownProgram, knownPrograms, getProgramSearchPath, @@ -46,6 +47,7 @@ userSpecifyArgss, userSpecifiedArgs, lookupProgram, + lookupProgramByName, updateProgram, configuredPrograms, @@ -222,6 +224,21 @@ modifyProgramSearchPath f db = setProgramSearchPath (f $ getProgramSearchPath db) db +-- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb' +-- by appending the provided extra paths. Also logs the added paths +-- in info verbosity. +appendProgramSearchPath + :: Verbosity + -> [FilePath] + -> ProgramDb + -> IO ProgramDb +appendProgramSearchPath verbosity extraPaths db = + if not $ null extraPaths + then do + logExtraProgramSearchPath verbosity extraPaths + pure $ modifyProgramSearchPath (map ProgramSearchPathDir extraPaths ++) db + else pure db + -- |User-specify this path. Basically override any path information -- for this program in the configuration. If it's not a known -- program ignore it. @@ -293,8 +310,11 @@ -- | Try to find a configured program lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram -lookupProgram prog = Map.lookup (programName prog) . configuredProgs +lookupProgram = lookupProgramByName . programName +-- | Try to find a configured program +lookupProgramByName :: String -> ProgramDb -> Maybe ConfiguredProgram +lookupProgramByName name = Map.lookup name . configuredProgs -- | Update a configured program in the database. updateProgram :: ConfiguredProgram -> ProgramDb diff --git a/src/Distribution/Simple/Program/Find.hs b/src/Distribution/Simple/Program/Find.hs --- a/src/Distribution/Simple/Program/Find.hs +++ b/src/Distribution/Simple/Program/Find.hs @@ -32,13 +32,17 @@ defaultProgramSearchPath, findProgramOnSearchPath, programSearchPathAsPATHVar, + logExtraProgramSearchPath, getSystemSearchPath, + getExtraPathEnv, + simpleProgram ) where import Prelude () import Distribution.Compat.Prelude import Distribution.Verbosity +import Distribution.Simple.Program.Types import Distribution.Simple.Utils import Distribution.System import Distribution.Compat.Environment @@ -52,30 +56,18 @@ import qualified System.Win32 as Win32 #endif --- | A search path to use when locating executables. This is analogous --- to the unix @$PATH@ or win32 @%PATH%@ but with the ability to use --- the system default method for finding executables ('findExecutable' which --- on unix is simply looking on the @$PATH@ but on win32 is a bit more --- complicated). --- --- The default to use is @[ProgSearchPathDefault]@ but you can add extra dirs --- either before, after or instead of the default, e.g. here we add an extra --- dir to search after the usual ones. --- --- > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir] --- -type ProgramSearchPath = [ProgramSearchPathEntry] -data ProgramSearchPathEntry = - ProgramSearchPathDir FilePath -- ^ A specific dir - | ProgramSearchPathDefault -- ^ The system default - deriving (Eq, Generic, Typeable) - -instance Binary ProgramSearchPathEntry -instance Structured ProgramSearchPathEntry - defaultProgramSearchPath :: ProgramSearchPath defaultProgramSearchPath = [ProgramSearchPathDefault] +logExtraProgramSearchPath + :: Verbosity + -> [FilePath] + -> IO () +logExtraProgramSearchPath verbosity extraPaths = + info verbosity . unlines $ + "Including the following directories in PATH:" + : map ("- " ++) extraPaths + findProgramOnSearchPath :: Verbosity -> ProgramSearchPath -> FilePath -> IO (Maybe (FilePath, [FilePath])) findProgramOnSearchPath verbosity searchpath prog = do @@ -141,6 +133,25 @@ Just _ -> return a Nothing -> firstJustM mas +-- | Adds some paths to the "PATH" entry in the key-value environment provided +-- or if there is none, looks up @$PATH@ in the real environment. +getExtraPathEnv + :: Verbosity + -> [(String, Maybe String)] + -> [FilePath] + -> IO [(String, Maybe String)] +getExtraPathEnv _ _ [] = return [] +getExtraPathEnv verbosity env extras = do + mb_path <- case lookup "PATH" env of + Just x -> return x + Nothing -> lookupEnv "PATH" + logExtraProgramSearchPath verbosity extras + let extra = intercalate [searchPathSeparator] extras + path' = case mb_path of + Nothing -> extra + Just path -> extra ++ searchPathSeparator : path + return [("PATH", Just path')] + -- | Interpret a 'ProgramSearchPath' to construct a new @$PATH@ env var. -- Note that this is close but not perfect because on Windows the search -- algorithm looks at more than just the @%PATH%@. @@ -196,3 +207,19 @@ _ -> return mExe #endif + +-- | Make a simple named program. +-- +-- By default we'll just search for it in the path and not try to find the +-- version name. You can override these behaviours if necessary, eg: +-- +-- > (simpleProgram "foo") { programFindLocation = ... , programFindVersion ... } +-- +simpleProgram :: String -> Program +simpleProgram name = Program { + programName = name, + programFindLocation = \v p -> findProgramOnSearchPath v p name, + programFindVersion = \_ _ -> return Nothing, + programPostConf = \_ p -> return p, + programNormaliseArgs = \_ _ -> id + } diff --git a/src/Distribution/Simple/Program/GHC.hs b/src/Distribution/Simple/Program/GHC.hs --- a/src/Distribution/Simple/Program/GHC.hs +++ b/src/Distribution/Simple/Program/GHC.hs @@ -31,8 +31,9 @@ import Distribution.ModuleName import Distribution.Simple.Compiler import Distribution.Simple.Flag -import Distribution.Simple.Program.Types +import Distribution.Simple.Program.Find (getExtraPathEnv) import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Types import Distribution.System import Distribution.Pretty import Distribution.Types.ComponentId @@ -569,15 +570,19 @@ runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> Platform -> GhcOptions -> IO () runGHC verbosity ghcProg comp platform opts = do - runProgramInvocation verbosity (ghcInvocation ghcProg comp platform opts) + runProgramInvocation verbosity =<< ghcInvocation verbosity ghcProg comp platform opts +ghcInvocation :: Verbosity -> ConfiguredProgram -> Compiler -> Platform -> GhcOptions + -> IO ProgramInvocation +ghcInvocation verbosity ghcProg comp platform opts = do + -- NOTE: GHC is the only program whose path we modify with more values than + -- the standard @extra-prog-path@, namely the folders of the executables in + -- the components, see @componentGhcOptions@. + let envOverrides = programOverrideEnv ghcProg + extraPath <- getExtraPathEnv verbosity envOverrides (fromNubListR (ghcOptExtraPath opts)) + let ghcProg' = ghcProg{programOverrideEnv = envOverrides ++ extraPath} -ghcInvocation :: ConfiguredProgram -> Compiler -> Platform -> GhcOptions - -> ProgramInvocation -ghcInvocation prog comp platform opts = - (programInvocation prog (renderGhcOptions comp platform opts)) { - progInvokePathEnv = fromNubListR (ghcOptExtraPath opts) - } + pure $ programInvocation ghcProg' (renderGhcOptions comp platform opts) renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String] renderGhcOptions comp _platform@(Platform _arch os) opts diff --git a/src/Distribution/Simple/Program/Run.hs b/src/Distribution/Simple/Program/Run.hs --- a/src/Distribution/Simple/Program/Run.hs +++ b/src/Distribution/Simple/Program/Run.hs @@ -13,20 +13,19 @@ -- This module provides a data type for program invocations and functions to -- run them. -module Distribution.Simple.Program.Run ( - ProgramInvocation(..), - IOEncoding(..), - emptyProgramInvocation, - simpleProgramInvocation, - programInvocation, - multiStageProgramInvocation, - - runProgramInvocation, - getProgramInvocationOutput, - getProgramInvocationLBS, - getProgramInvocationOutputAndErrors, - - getEffectiveEnvironment, +module Distribution.Simple.Program.Run + ( ProgramInvocation (..) + , IOEncoding (..) + , emptyProgramInvocation + , simpleProgramInvocation + , programInvocation + , multiStageProgramInvocation + , runProgramInvocation + , getProgramInvocationOutput + , getProgramInvocationLBS + , getProgramInvocationOutputAndErrors + , getProgramInvocationLBSAndErrors + , getEffectiveEnvironment ) where import Distribution.Compat.Prelude @@ -38,8 +37,6 @@ import Distribution.Utils.Generic import Distribution.Verbosity -import System.FilePath (searchPathSeparator) - import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map @@ -54,8 +51,6 @@ progInvokePath :: FilePath, progInvokeArgs :: [String], progInvokeEnv :: [(String, Maybe String)], - -- Extra paths to add to PATH - progInvokePathEnv :: [FilePath], progInvokeCwd :: Maybe FilePath, progInvokeInput :: Maybe IOData, progInvokeInputEncoding :: IOEncoding, -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. @@ -76,7 +71,6 @@ progInvokePath = "", progInvokeArgs = [], progInvokeEnv = [], - progInvokePathEnv = [], progInvokeCwd = Nothing, progInvokeInput = Nothing, progInvokeInputEncoding = IOEncodingText, @@ -107,7 +101,6 @@ progInvokePath = path, progInvokeArgs = args, progInvokeEnv = [], - progInvokePathEnv = [], progInvokeCwd = Nothing, progInvokeInput = Nothing } = @@ -118,12 +111,10 @@ progInvokePath = path, progInvokeArgs = args, progInvokeEnv = envOverrides, - progInvokePathEnv = extraPath, progInvokeCwd = mcwd, progInvokeInput = Nothing } = do - pathOverride <- getExtraPathEnv envOverrides extraPath - menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) + menv <- getEffectiveEnvironment envOverrides maybeExit $ rawSystemIOWithEnv verbosity path args mcwd menv @@ -134,13 +125,11 @@ progInvokePath = path, progInvokeArgs = args, progInvokeEnv = envOverrides, - progInvokePathEnv = extraPath, progInvokeCwd = mcwd, progInvokeInput = Just inputStr, progInvokeInputEncoding = encoding } = do - pathOverride <- getExtraPathEnv envOverrides extraPath - menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) + menv <- getEffectiveEnvironment envOverrides (_, errors, exitCode) <- rawSystemStdInOut verbosity path args mcwd menv @@ -174,6 +163,13 @@ (output', errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode) +getProgramInvocationLBSAndErrors + :: Verbosity + -> ProgramInvocation + -> IO (LBS.ByteString, String, ExitCode) +getProgramInvocationLBSAndErrors verbosity inv = + getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary + getProgramInvocationIODataAndErrors :: KnownIODataMode mode => Verbosity -> ProgramInvocation -> IODataMode mode -> IO (mode, String, ExitCode) @@ -183,29 +179,15 @@ { progInvokePath = path , progInvokeArgs = args , progInvokeEnv = envOverrides - , progInvokePathEnv = extraPath , progInvokeCwd = mcwd , progInvokeInput = minputStr , progInvokeInputEncoding = encoding } mode = do - pathOverride <- getExtraPathEnv envOverrides extraPath - menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) + menv <- getEffectiveEnvironment envOverrides rawSystemStdInOut verbosity path args mcwd menv input mode where input = encodeToIOData encoding <$> minputStr - -getExtraPathEnv :: [(String, Maybe String)] -> [FilePath] -> IO [(String, Maybe String)] -getExtraPathEnv _ [] = return [] -getExtraPathEnv env extras = do - mb_path <- case lookup "PATH" env of - Just x -> return x - Nothing -> lookupEnv "PATH" - let extra = intercalate [searchPathSeparator] extras - path' = case mb_path of - Nothing -> extra - Just path -> extra ++ searchPathSeparator : path - return [("PATH", Just path')] -- | Return the current environment extended with the given overrides. -- If an entry is specified twice in @overrides@, the second entry takes diff --git a/src/Distribution/Simple/Program/Types.hs b/src/Distribution/Simple/Program/Types.hs --- a/src/Distribution/Simple/Program/Types.hs +++ b/src/Distribution/Simple/Program/Types.hs @@ -25,7 +25,6 @@ Program(..), ProgramSearchPath, ProgramSearchPathEntry(..), - simpleProgram, -- * Configured program and related functions ConfiguredProgram(..), @@ -40,7 +39,6 @@ import Distribution.Compat.Prelude import Distribution.PackageDescription -import Distribution.Simple.Program.Find import Distribution.Version import Distribution.Verbosity @@ -87,6 +85,36 @@ type ProgArg = String +-- | A search path to use when locating executables. This is analogous +-- to the unix @$PATH@ or win32 @%PATH%@ but with the ability to use +-- the system default method for finding executables ('findExecutable' which +-- on unix is simply looking on the @$PATH@ but on win32 is a bit more +-- complicated). +-- +-- The default to use is @[ProgSearchPathDefault]@ but you can add extra dirs +-- either before, after or instead of the default, e.g. here we add an extra +-- dir to search after the usual ones. +-- +-- > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir] +-- +-- We also use this path to set the environment when running child processes. +-- +-- The @ProgramDb@ is created with a @ProgramSearchPath@ to which we +-- @appendProgramSearchPath@ to add the ones that come from cli flags and from +-- configurations. Then each of the programs that are configured in the db +-- inherits the same path as part of @configureProgram@. +type ProgramSearchPath = [ProgramSearchPathEntry] + +data ProgramSearchPathEntry + = -- | A specific dir + ProgramSearchPathDir FilePath + | -- | The system default + ProgramSearchPathDefault + deriving (Eq, Generic, Typeable) + +instance Binary ProgramSearchPathEntry +instance Structured ProgramSearchPathEntry + -- | Represents a program which has been configured and is thus ready to be run. -- -- These are usually made by configuring a 'Program', but if you have to @@ -156,22 +184,6 @@ -- | Suppress any extra arguments added by the user. suppressOverrideArgs :: ConfiguredProgram -> ConfiguredProgram suppressOverrideArgs prog = prog { programOverrideArgs = [] } - --- | Make a simple named program. --- --- By default we'll just search for it in the path and not try to find the --- version name. You can override these behaviours if necessary, eg: --- --- > (simpleProgram "foo") { programFindLocation = ... , programFindVersion ... } --- -simpleProgram :: String -> Program -simpleProgram name = Program { - programName = name, - programFindLocation = \v p -> findProgramOnSearchPath v p name, - programFindVersion = \_ _ -> return Nothing, - programPostConf = \_ p -> return p, - programNormaliseArgs = \_ _ -> id - } -- | Make a simple 'ConfiguredProgram'. --