Merge pull request #9629 from haskell/mergify/bp/3.10/pr-9527

Fix extra-prog-path propagation in the codebase. (backport #9527)

Cabal/src/Distribution/Simple/Configure.hs

@@ -76,12 +76,13 @@ import Distribution.Simple.Program
 import Distribution.Simple.Setup as Setup
 import Distribution.Simple.BuildTarget
 import Distribution.Simple.LocalBuildInfo
+import Distribution.Simple.Program.Db (appendProgramSearchPath)
+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
@@ -367,18 +368,19 @@ configure (pkg_descr0, pbi) cfg = do
             (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
@@ -843,16 +845,25 @@ configure (pkg_descr0, pbi) cfg = do
     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 <- 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
@@ -1702,13 +1713,13 @@ ccLdOptionsBuildInfo cflags ldflags ldflags_static =
 
 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

Cabal/src/Distribution/Simple/ConfigureScript.hs

@@ -137,10 +137,9 @@ runConfigureScript verbosity flags lbi = do
       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')

Cabal/src/Distribution/Simple/GHC.hs

@@ -1890,7 +1890,7 @@ libAbiHash verbosity _pkg_descr lbi lib clbi = do
 
   (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

Cabal/src/Distribution/Simple/GHCJS.hs

@@ -1602,7 +1602,7 @@ libAbiHash verbosity _pkg_descr lbi lib clbi = do
 
   (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

Cabal/src/Distribution/Simple/Program/Db.hs

@@ -34,6 +34,7 @@ module Distribution.Simple.Program.Db (
     -- ** Query and manipulate the program db
     addKnownProgram,
     addKnownPrograms,
+    appendProgramSearchPath,
     lookupKnownProgram,
     knownPrograms,
     getProgramSearchPath,
@@ -222,6 +223,21 @@ modifyProgramSearchPath :: (ProgramSearchPath -> ProgramSearchPath)
 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.

Cabal/src/Distribution/Simple/Program/Find.hs

@@ -32,13 +32,17 @@ module Distribution.Simple.Program.Find (
     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 System.FilePath as FilePath
 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 @@ findProgramOnSearchPath verbosity searchpath prog = do
         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 @@ findExecutable prog = do
         _     -> 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
+  }

Cabal/src/Distribution/Simple/Program/GHC.hs

@@ -31,8 +31,9 @@ import Distribution.PackageDescription
 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 @@ data GhcProfAuto = GhcProfAutoAll       -- ^ @-fprof-auto@
 runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> Platform  -> GhcOptions
        -> IO ()
 runGHC verbosity ghcProg comp platform opts = do
-  runProgramInvocation verbosity (ghcInvocation ghcProg comp platform opts)
-
-
-ghcInvocation :: ConfiguredProgram -> Compiler -> Platform -> GhcOptions
-              -> ProgramInvocation
-ghcInvocation prog comp platform opts =
-    (programInvocation prog (renderGhcOptions comp platform opts)) {
-        progInvokePathEnv = fromNubListR (ghcOptExtraPath 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}
+
+  pure $ programInvocation ghcProg' (renderGhcOptions comp platform opts)
 
 renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String]
 renderGhcOptions comp _platform@(Platform _arch os) opts

Cabal/src/Distribution/Simple/Program/Run.hs

@@ -38,8 +38,6 @@ import Distribution.Simple.Utils
 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 +52,6 @@ data ProgramInvocation = ProgramInvocation {
        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 +72,6 @@ emptyProgramInvocation =
     progInvokePath  = "",
     progInvokeArgs  = [],
     progInvokeEnv   = [],
-    progInvokePathEnv = [],
     progInvokeCwd   = Nothing,
     progInvokeInput = Nothing,
     progInvokeInputEncoding  = IOEncodingText,
@@ -107,7 +102,6 @@ runProgramInvocation verbosity
     progInvokePath  = path,
     progInvokeArgs  = args,
     progInvokeEnv   = [],
-    progInvokePathEnv = [],
     progInvokeCwd   = Nothing,
     progInvokeInput = Nothing
   } =
@@ -118,12 +112,10 @@ runProgramInvocation verbosity
     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 +126,11 @@ runProgramInvocation verbosity
     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
@@ -183,30 +173,16 @@ getProgramInvocationIODataAndErrors
     { 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
 -- precedence.