Merge pull request #9527 from jasagredo/js/fix-extra-paths-propagation

Fix extra-prog-path propagation in the codebase.

Cabal/src/Distribution/Simple/Configure.hs

@@ -85,7 +85,7 @@ import Distribution.Simple.PackageIndex (InstalledPackageIndex, lookupUnitId)
 import qualified Distribution.Simple.PackageIndex as PackageIndex
 import Distribution.Simple.PreProcess
 import Distribution.Simple.Program
-import Distribution.Simple.Program.Db (lookupProgramByName)
+import Distribution.Simple.Program.Db (appendProgramSearchPath, lookupProgramByName)
 import Distribution.Simple.Setup.Common as Setup
 import Distribution.Simple.Setup.Config as Setup
 import Distribution.Simple.Utils
@@ -488,6 +488,7 @@ preConfigurePackage cfg g_pkg_descr = do
   checkDeprecatedFlags verbosity cfg
   checkExactConfiguration verbosity g_pkg_descr 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
@@ -500,7 +501,7 @@ preConfigurePackage cfg g_pkg_descr = do
       (flagToMaybe (configHcFlavor cfg))
       (flagToMaybe (configHcPath cfg))
       (flagToMaybe (configHcPkg cfg))
-      (mkProgramDb cfg (configPrograms cfg))
+      programDbPre
       (lessVerbose verbosity)
 
   -- Where to build the package
@@ -1230,19 +1231,18 @@ configureComponents
 mkPromisedDepsSet :: [GivenComponent] -> Map (PackageName, ComponentName) ComponentId
 mkPromisedDepsSet comps = Map.fromList [((pn, CLibName ln), cid) | GivenComponent pn ln cid <- comps]
 
-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 =
-      getProgramSearchPath initialProgramDb
-        ++ map
-          ProgramSearchPathDir
-          (fromNubList $ configProgramPathExtra cfg)
+    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
@@ -2253,15 +2253,14 @@ ccLdOptionsBuildInfo cflags ldflags ldflags_static =
 configCompilerAuxEx
   :: ConfigFlags
   -> IO (Compiler, Platform, ProgramDb)
-configCompilerAuxEx 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

Cabal/src/Distribution/Simple/ConfigureScript.hs

@@ -169,10 +169,7 @@ 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

Cabal/src/Distribution/Simple/GHC.hs

@@ -697,10 +697,12 @@ libAbiHash verbosity _pkg_descr lbi lib clbi = do
       | otherwise = error "libAbiHash: Can't find an enabled library way"
 
   (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)
 
 componentCcGhcOptions

Cabal/src/Distribution/Simple/GHCJS.hs

@@ -1769,7 +1769,7 @@ libAbiHash verbosity _pkg_descr lbi lib clbi = do
   hash <-
     getProgramInvocationOutput
       verbosity
-      (ghcInvocation ghcjsProg comp platform ghcArgs)
+      =<< ghcInvocation verbosity ghcjsProg comp platform ghcArgs
   return (takeWhile (not . isSpace) hash)
 
 componentGhcOptions

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
@@ -221,6 +222,21 @@ modifyProgramSearchPath
 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,7 +32,9 @@ module Distribution.Simple.Program.Find
   , defaultProgramSearchPath
   , findProgramOnSearchPath
   , programSearchPathAsPATHVar
+  , logExtraProgramSearchPath
   , getSystemSearchPath
+  , getExtraPathEnv
   , simpleProgram
   ) where
 
@@ -63,6 +65,15 @@ import qualified System.Win32 as Win32
 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
@@ -133,6 +144,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%@.

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

@@ -28,6 +28,7 @@ import Distribution.Pretty
 import Distribution.Simple.Compiler
 import Distribution.Simple.Flag
 import Distribution.Simple.GHC.ImplInfo
+import Distribution.Simple.Program.Find (getExtraPathEnv)
 import Distribution.Simple.Program.Run
 import Distribution.Simple.Program.Types
 import Distribution.System
@@ -554,8 +555,6 @@ data GhcOptions = GhcOptions
   , ghcOptExtraPath :: NubListR FilePath
   -- ^ Put the extra folders in the PATH environment variable we invoke
   -- GHC with
-  -- | Put the extra folders in the PATH environment variable we invoke
-  -- GHC with
   , ghcOptCabal :: Flag Bool
   -- ^ Let GHC know that it is Cabal that's calling it.
   -- Modifies some of the GHC error messages.
@@ -616,18 +615,24 @@ runGHC
   -> 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
-  :: ConfiguredProgram
+  :: Verbosity
+  -> ConfiguredProgram
   -> Compiler
   -> Platform
   -> GhcOptions
-  -> ProgramInvocation
-ghcInvocation prog comp platform opts =
-  (programInvocation prog (renderGhcOptions comp platform opts))
-    { progInvokePathEnv = fromNubListR (ghcOptExtraPath opts)
-    }
+  -> 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

@@ -36,7 +36,6 @@ import Distribution.Simple.Program.Types
 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
@@ -51,8 +50,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
@@ -75,7 +72,6 @@ emptyProgramInvocation =
     { progInvokePath = ""
     , progInvokeArgs = []
     , progInvokeEnv = []
-    , progInvokePathEnv = []
     , progInvokeCwd = Nothing
     , progInvokeInput = Nothing
     , progInvokeInputEncoding = IOEncodingText
@@ -107,7 +103,6 @@ runProgramInvocation
     { progInvokePath = path
     , progInvokeArgs = args
     , progInvokeEnv = []
-    , progInvokePathEnv = []
     , progInvokeCwd = Nothing
     , progInvokeInput = Nothing
     } =
@@ -118,12 +113,10 @@ runProgramInvocation
     { 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
@@ -140,13 +133,11 @@ runProgramInvocation
     { 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
@@ -202,30 +193,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.

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

@@ -93,6 +93,13 @@ type ProgArg = String
 -- 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