Fix extra-prog-path propagation in the codebase.

Extra prog paths were being handled in many different ways all thorugh
the codebase. This PR introduces a unified way to look at them.

Aiming for traceability, the addition of extra paths is now traced via
`logExtraProgramSearchPath`. All appearances of
`modifyProgramSearchPath` are replaced with `appendProgramSearchPath`
which traces the added paths.

`progInvokePathEnv` was only being set by GHC for some paths to
executables in components and only under certain circumstances. Now
every `ghcInvocation` sets the extra paths directly into `pkgInvokeEnv`.

In particular this fixes PATH issues when running MinGW cabal in
PowerShell, as usually for other OSes the system path contains most of
the expected directories.

Author: jasagredo

Cabal/src/Distribution/Simple/Configure.hs

@@ -86,7 +86,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
@@ -462,6 +462,7 @@ 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
@@ -474,7 +475,7 @@ configure (pkg_descr0, pbi) cfg = do
       (flagToMaybe (configHcFlavor cfg))
       (flagToMaybe (configHcPath cfg))
       (flagToMaybe (configHcPkg cfg))
-      (mkProgramDb cfg (configPrograms cfg))
+      programDbPre
       (lessVerbose verbosity)
 
   -- The InstalledPackageIndex of all installed packages
@@ -1008,19 +1009,18 @@ configure (pkg_descr0, pbi) cfg = do
 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
@@ -2083,15 +2083,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 ghcProg comp platform ghcArgs
+
   return (takeWhile (not . isSpace) hash)
 
 componentCcGhcOptions
@@ -853,47 +855,47 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do
       whenGHCi $ installOrdinary builtDir targetDir ghciProfLibName
     whenShared $
       if
-          -- The behavior for "extra-bundled-libraries" changed in version 2.5.0.
-          -- See ghc issue #15837 and Cabal PR #5855.
-          | specVersion pkg < CabalSpecV3_0 -> do
-              sequence_
-                [ installShared
-                  builtDir
-                  dynlibTargetDir
-                  (mkGenericSharedLibName platform compiler_id (l ++ f))
-                | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib)
-                , f <- "" : extraDynLibFlavours (libBuildInfo lib)
-                ]
-          | otherwise -> do
-              sequence_
-                [ installShared
-                  builtDir
-                  dynlibTargetDir
-                  ( mkGenericSharedLibName
-                      platform
-                      compiler_id
-                      (getHSLibraryName uid ++ f)
-                  )
-                | f <- "" : extraDynLibFlavours (libBuildInfo lib)
-                ]
-              sequence_
-                [ do
-                  files <- getDirectoryContents builtDir
-                  let l' =
-                        mkGenericSharedBundledLibName
-                          platform
-                          compiler_id
-                          l
-                  forM_ files $ \file ->
-                    when (l' `isPrefixOf` file) $ do
-                      isFile <- doesFileExist (builtDir </> file)
-                      when isFile $ do
-                        installShared
-                          builtDir
-                          dynlibTargetDir
-                          file
-                | l <- extraBundledLibs (libBuildInfo lib)
-                ]
+        -- The behavior for "extra-bundled-libraries" changed in version 2.5.0.
+        -- See ghc issue #15837 and Cabal PR #5855.
+        | specVersion pkg < CabalSpecV3_0 -> do
+            sequence_
+              [ installShared
+                builtDir
+                dynlibTargetDir
+                (mkGenericSharedLibName platform compiler_id (l ++ f))
+              | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib)
+              , f <- "" : extraDynLibFlavours (libBuildInfo lib)
+              ]
+        | otherwise -> do
+            sequence_
+              [ installShared
+                builtDir
+                dynlibTargetDir
+                ( mkGenericSharedLibName
+                    platform
+                    compiler_id
+                    (getHSLibraryName uid ++ f)
+                )
+              | f <- "" : extraDynLibFlavours (libBuildInfo lib)
+              ]
+            sequence_
+              [ do
+                files <- getDirectoryContents builtDir
+                let l' =
+                      mkGenericSharedBundledLibName
+                        platform
+                        compiler_id
+                        l
+                forM_ files $ \file ->
+                  when (l' `isPrefixOf` file) $ do
+                    isFile <- doesFileExist (builtDir </> file)
+                    when isFile $ do
+                      installShared
+                        builtDir
+                        dynlibTargetDir
+                        file
+              | l <- extraBundledLibs (libBuildInfo lib)
+              ]
   where
     builtDir = componentBuildDir lbi clbi
 

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 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,18 @@ 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 = do
+  logExtraProgramSearchPath verbosity extraPaths
+  pure $ modifyProgramSearchPath (map ProgramSearchPathDir extraPaths ++) 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
   ) where
 
 import Distribution.Compat.Prelude
@@ -69,6 +71,14 @@ import qualified System.Win32 as Win32
 -- 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@. It is only GHC that get
+-- some more paths added
 type ProgramSearchPath = [ProgramSearchPathEntry]
 
 data ProgramSearchPathEntry
@@ -84,6 +94,15 @@ 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
@@ -154,6 +173,23 @@ 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
+  :: [(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')]
+
 -- | 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,23 @@ runGHC
   -> GhcOptions
   -> IO ()
 runGHC verbosity ghcProg comp platform opts = do
-  runProgramInvocation verbosity (ghcInvocation ghcProg comp platform opts)
+  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)
-    }
+  -> IO ProgramInvocation
+ghcInvocation 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 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