Merge pull request haskell#9912 from mpickering/wip/program-db-paths

Correctly provision build tools in all situations

Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs

@@ -41,7 +41,7 @@ md5CheckGenericPackageDescription proxy = md5Check proxy
 md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion
 md5CheckLocalBuildInfo proxy = md5Check proxy
 #if MIN_VERSION_base(4,19,0)
-    0x5f774efdb0aedcbf5263d3d99e38d50b
+    0x552eca9ce2e4a34e74deff571f279fc4
 #else
-    0x0f53d756836a410f72b31feb7d9f7b09
+    0x48497d6b3f15df06f1107b81b98febe1
 #endif

Cabal/src/Distribution/Simple/Bench.hs

@@ -23,21 +23,27 @@ module Distribution.Simple.Bench
 import Distribution.Compat.Prelude
 import Prelude ()
 
+import Distribution.Compat.Environment
 import qualified Distribution.PackageDescription as PD
 import Distribution.Pretty
+import Distribution.Simple.Build (addInternalBuildTools)
 import Distribution.Simple.BuildPaths
 import Distribution.Simple.Compiler
+import Distribution.Simple.Errors
 import Distribution.Simple.InstallDirs
 import qualified Distribution.Simple.LocalBuildInfo as LBI
+import Distribution.Simple.Program.Db
+import Distribution.Simple.Program.Find
+import Distribution.Simple.Program.Run
 import Distribution.Simple.Setup.Benchmark
 import Distribution.Simple.Setup.Common
 import Distribution.Simple.UserHooks
 import Distribution.Simple.Utils
-import Distribution.Utils.Path
-
+import Distribution.System (Platform (Platform))
+import Distribution.Types.Benchmark (Benchmark (benchmarkBuildInfo))
 import Distribution.Types.UnqualComponentName
+import Distribution.Utils.Path
 
-import Distribution.Simple.Errors
 import System.Directory (doesFileExist)
 
 -- | Perform the \"@.\/setup bench@\" action.
@@ -61,23 +67,52 @@ bench args pkg_descr lbi flags = do
 
       -- Run the benchmark
       doBench :: (PD.Benchmark, LBI.ComponentLocalBuildInfo) -> IO ExitCode
-      doBench (bm, _clbi) =
+      doBench (bm, clbi) = do
+        let lbiForBench =
+              lbi
+                { -- Include any build-tool-depends on build tools internal to the current package.
+                  LBI.withPrograms =
+                    addInternalBuildTools
+                      pkg_descr
+                      lbi
+                      (benchmarkBuildInfo bm)
+                      (LBI.withPrograms lbi)
+                }
         case PD.benchmarkInterface bm of
           PD.BenchmarkExeV10 _ _ -> do
-            let cmd = i $ LBI.buildDir lbi </> makeRelativePathEx (name </> name <.> exeExtension (LBI.hostPlatform lbi))
+            let cmd = i $ LBI.buildDir lbiForBench </> makeRelativePathEx (name </> name <.> exeExtension (LBI.hostPlatform lbi))
                 options =
-                  map (benchOption pkg_descr lbi bm) $
+                  map (benchOption pkg_descr lbiForBench bm) $
                     benchmarkOptions flags
             -- Check that the benchmark executable exists.
             exists <- doesFileExist cmd
             unless exists $
               dieWithException verbosity $
                 NoBenchMarkProgram cmd
 
+            existingEnv <- getEnvironment
+
+            -- Compute the appropriate environment for running the benchmark
+            let progDb = LBI.withPrograms lbiForBench
+                pathVar = progSearchPath progDb
+                envOverrides = progOverrideEnv progDb
+            newPath <- programSearchPathAsPATHVar pathVar
+            overrideEnv <- fromMaybe [] <$> getEffectiveEnvironment ([("PATH", Just newPath)] ++ envOverrides)
+            let shellEnv = overrideEnv ++ existingEnv
+
+            -- Add (DY)LD_LIBRARY_PATH if needed
+            shellEnv' <-
+              if LBI.withDynExe lbiForBench
+                then do
+                  let (Platform _ os) = LBI.hostPlatform lbiForBench
+                  paths <- LBI.depLibraryPaths True False lbiForBench clbi
+                  return (addLibraryPath os paths shellEnv)
+                else return shellEnv
+
             notice verbosity $ startMessage name
             -- This will redirect the child process
             -- stdout/stderr to the parent process.
-            exitcode <- rawSystemExitCode verbosity mbWorkDir cmd options
+            exitcode <- rawSystemExitCode verbosity mbWorkDir cmd options (Just shellEnv')
             notice verbosity $ finishMessage name exitcode
             return exitcode
           _ -> do

Cabal/src/Distribution/Simple/Build.hs

@@ -45,6 +45,9 @@ module Distribution.Simple.Build
 
     -- * Internal package database creation
   , createInternalPackageDB
+
+    -- * Handling of internal build tools
+  , addInternalBuildTools
   ) where
 
 import Distribution.Compat.Prelude
@@ -76,7 +79,7 @@ import qualified Distribution.Simple.UHC as UHC
 
 import Distribution.Simple.Build.Macros (generateCabalMacrosHeader)
 import Distribution.Simple.Build.PackageInfoModule (generatePackageInfoModule)
-import Distribution.Simple.Build.PathsModule (generatePathsModule)
+import Distribution.Simple.Build.PathsModule (generatePathsModule, pkgPathEnvVar)
 import qualified Distribution.Simple.Program.HcPkg as HcPkg
 
 import Distribution.InstalledPackageInfo (InstalledPackageInfo)
@@ -95,6 +98,7 @@ import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.PreProcess
 import Distribution.Simple.Program
 import Distribution.Simple.Program.Builtin (haskellSuiteProgram)
+import Distribution.Simple.Program.Db
 import qualified Distribution.Simple.Program.GHC as GHC
 import Distribution.Simple.Program.Types
 import Distribution.Simple.Register
@@ -189,6 +193,7 @@ build_setupHooks
       let comp = targetComponent target
           clbi = targetCLBI target
           bi = componentBuildInfo comp
+          -- Include any build-tool-depends on build tools internal to the current package.
           progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)
           lbi' =
             lbi
@@ -208,7 +213,6 @@ build_setupHooks
                   (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules
                   SetupHooks.executeRules verbosity lbi2 tgt ruleFromId
       preBuildComponent runPreBuildHooks verbosity lbi' target
-
       let numJobs = buildNumJobs flags
       par_strat <-
         toFlag <$> case buildUseSemaphore flags of
@@ -378,6 +382,7 @@ repl_setupHooks
           lbi'
             { withPackageDB = withPackageDB lbi ++ [internalPackageDB]
             , withPrograms =
+                -- Include any build-tool-depends on build tools internal to the current package.
                 addInternalBuildTools
                   pkg_descr
                   lbi'
@@ -911,24 +916,49 @@ createInternalPackageDB verbosity lbi distPref = do
     dbRelPath = internalPackageDBPath lbi distPref
     dbPath = interpretSymbolicPathLBI lbi dbRelPath
 
+-- | Update the program database to include any build-tool-depends specified
+-- in the given 'BuildInfo' on build tools internal to the current package.
+--
+-- This function:
+--
+--  - adds these internal build tools to the 'ProgramDb', including
+--    paths to their respective data directories,
+--  - adds their paths to the current 'progSearchPath', and adds the data
+--    directory environment variable for the current package to the current
+--    'progOverrideEnv', so that any programs configured from now on will be
+--    able to invoke these build tools.
 addInternalBuildTools
   :: PackageDescription
   -> LocalBuildInfo
   -> BuildInfo
   -> ProgramDb
   -> ProgramDb
 addInternalBuildTools pkg lbi bi progs =
-  foldr updateProgram progs internalBuildTools
+  prependProgramSearchPathNoLogging
+    internalToolPaths
+    [pkgDataDirVar]
+    $ foldr updateProgram progs internalBuildTools
   where
+    internalToolPaths = map (takeDirectory . programPath) internalBuildTools
+    pkgDataDirVar = (pkgPathEnvVar pkg "datadir", Just dataDirPath)
     internalBuildTools =
-      [ simpleConfiguredProgram toolName' (FoundOnSystem toolLocation)
+      [ (simpleConfiguredProgram toolName' (FoundOnSystem toolLocation))
+        { programOverrideEnv = [pkgDataDirVar]
+        }
       | toolName <- getAllInternalToolDependencies pkg bi
       , let toolName' = unUnqualComponentName toolName
       , let toolLocation =
               interpretSymbolicPathLBI lbi $
                 buildDir lbi
                   </> makeRelativePathEx (toolName' </> toolName' <.> exeExtension (hostPlatform lbi))
       ]
+    mbWorkDir = mbWorkDirLBI lbi
+    rawDataDir = dataDir pkg
+    dataDirPath
+      | null $ getSymbolicPath rawDataDir =
+          interpretSymbolicPath mbWorkDir sameDirectory
+      | otherwise =
+          interpretSymbolicPath mbWorkDir rawDataDir
 
 -- TODO: build separate libs in separate dirs so that we can build
 -- multiple libs, e.g. for 'LibTest' library-style test suites

Cabal/src/Distribution/Simple/Configure.hs

@@ -1364,7 +1364,7 @@ mkProgramDb :: ConfigFlags -> ProgramDb -> IO ProgramDb
 mkProgramDb cfg initialProgramDb = do
   programDb <-
     modifyProgramSearchPath (getProgramSearchPath initialProgramDb ++) -- We need to have the paths to programs installed by build-tool-depends before all other paths
-      <$> prependProgramSearchPath (fromFlagOrDefault normal (configVerbosity cfg)) searchpath initialProgramDb
+      <$> prependProgramSearchPath (fromFlagOrDefault normal (configVerbosity cfg)) searchpath [] initialProgramDb
   pure
     . userSpecifyArgss (configProgramArgs cfg)
     . userSpecifyPaths (configProgramPaths cfg)

Cabal/src/Distribution/Simple/ConfigureScript.hs

@@ -164,7 +164,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 <- prependProgramSearchPath verbosity extraPath emptyProgramDb
+  progDb <- prependProgramSearchPath verbosity extraPath [] emptyProgramDb
   shConfiguredProg <-
     lookupProgram shProg
       `fmap` configureProgram verbosity shProg progDb

Cabal/src/Distribution/Simple/Haddock.hs

@@ -336,6 +336,15 @@ haddock_setupHooks
       let
         component = targetComponent target
         clbi = targetCLBI target
+        bi = componentBuildInfo component
+        -- Include any build-tool-depends on build tools internal to the current package.
+        progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)
+        lbi' =
+          lbi
+            { withPrograms = progs'
+            , withPackageDB = withPackageDB lbi ++ [internalPackageDB]
+            , installedPkgs = index
+            }
 
         runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO ()
         runPreBuildHooks lbi2 tgt =
@@ -348,15 +357,7 @@ haddock_setupHooks
            in for_ mbPbcRules $ \pbcRules -> do
                 (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules
                 SetupHooks.executeRules verbosity lbi2 tgt ruleFromId
-      preBuildComponent runPreBuildHooks verbosity lbi target
-
-      let
-        lbi' =
-          lbi
-            { withPackageDB = withPackageDB lbi ++ [internalPackageDB]
-            , installedPkgs = index
-            }
-
+      preBuildComponent runPreBuildHooks verbosity lbi' target
       preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes
       let
         doExe com = case (compToExe com) of

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

@@ -35,6 +35,7 @@ module Distribution.Simple.Program.Db
   , addKnownProgram
   , addKnownPrograms
   , prependProgramSearchPath
+  , prependProgramSearchPathNoLogging
   , lookupKnownProgram
   , knownPrograms
   , getProgramSearchPath
@@ -102,6 +103,7 @@ import Distribution.Simple.Errors
 data ProgramDb = ProgramDb
   { unconfiguredProgs :: UnconfiguredProgs
   , progSearchPath :: ProgramSearchPath
+  , progOverrideEnv :: [(String, Maybe String)]
   , configuredProgs :: ConfiguredProgs
   }
   deriving (Typeable)
@@ -111,7 +113,7 @@ type UnconfiguredProgs = Map.Map String UnconfiguredProgram
 type ConfiguredProgs = Map.Map String ConfiguredProgram
 
 emptyProgramDb :: ProgramDb
-emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath Map.empty
+emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath [] Map.empty
 
 defaultProgramDb :: ProgramDb
 defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb
@@ -151,14 +153,17 @@ instance Read ProgramDb where
 instance Binary ProgramDb where
   put db = do
     put (progSearchPath db)
+    put (progOverrideEnv db)
     put (configuredProgs db)
 
   get = do
     searchpath <- get
+    overrides <- get
     progs <- get
     return $!
       emptyProgramDb
         { progSearchPath = searchpath
+        , progOverrideEnv = overrides
         , configuredProgs = progs
         }
 
@@ -169,6 +174,7 @@ instance Structured ProgramDb where
       0
       "ProgramDb"
       [ structure (Proxy :: Proxy ProgramSearchPath)
+      , structure (Proxy :: Proxy [(String, Maybe String)])
       , structure (Proxy :: Proxy ConfiguredProgs)
       ]
 
@@ -230,19 +236,32 @@ modifyProgramSearchPath f db =
   setProgramSearchPath (f $ getProgramSearchPath db) db
 
 -- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'
--- by prepending the provided extra paths. Also logs the added paths
--- in info verbosity.
+-- by prepending the provided extra paths.
+--
+--  - Logs the added paths in info verbosity.
+--  - Prepends environment variable overrides.
 prependProgramSearchPath
   :: Verbosity
   -> [FilePath]
+  -> [(String, Maybe FilePath)]
   -> ProgramDb
   -> IO ProgramDb
-prependProgramSearchPath verbosity extraPaths db =
-  if not $ null extraPaths
-    then do
-      logExtraProgramSearchPath verbosity extraPaths
-      pure $ modifyProgramSearchPath (map ProgramSearchPathDir extraPaths ++) db
-    else pure db
+prependProgramSearchPath verbosity extraPaths extraEnv db = do
+  unless (null extraPaths) $
+    logExtraProgramSearchPath verbosity extraPaths
+  unless (null extraEnv) $
+    logExtraProgramOverrideEnv verbosity extraEnv
+  return $ prependProgramSearchPathNoLogging extraPaths extraEnv db
+
+prependProgramSearchPathNoLogging
+  :: [FilePath]
+  -> [(String, Maybe String)]
+  -> ProgramDb
+  -> ProgramDb
+prependProgramSearchPathNoLogging extraPaths extraEnv db =
+  let db' = modifyProgramSearchPath (nub . (map ProgramSearchPathDir extraPaths ++)) db
+      db'' = db'{progOverrideEnv = extraEnv ++ progOverrideEnv db'}
+   in db''
 
 -- | User-specify this path.  Basically override any path information
 --  for this program in the configuration. If it's not a known
@@ -410,7 +429,7 @@ configureUnconfiguredProgram verbosity prog progdb = do
               , programVersion = version
               , programDefaultArgs = []
               , programOverrideArgs = userSpecifiedArgs prog progdb
-              , programOverrideEnv = [("PATH", Just newPath)]
+              , programOverrideEnv = [("PATH", Just newPath)] ++ progOverrideEnv progdb
               , programProperties = Map.empty
               , programLocation = location
               , programMonitorFiles = triedLocations

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

@@ -33,6 +33,7 @@ module Distribution.Simple.Program.Find
   , findProgramOnSearchPath
   , programSearchPathAsPATHVar
   , logExtraProgramSearchPath
+  , logExtraProgramOverrideEnv
   , getSystemSearchPath
   , getExtraPathEnv
   , simpleProgram
@@ -74,6 +75,19 @@ logExtraProgramSearchPath verbosity extraPaths =
     "Including the following directories in PATH:"
       : map ("- " ++) extraPaths
 
+logExtraProgramOverrideEnv
+  :: Verbosity
+  -> [(String, Maybe String)]
+  -> IO ()
+logExtraProgramOverrideEnv verbosity extraEnv =
+  info verbosity . unlines $
+    "Including the following environment variable overrides:"
+      : [ "- " ++ case mbVal of
+          Nothing -> "unset " ++ var
+          Just val -> var ++ "=" ++ val
+        | (var, mbVal) <- extraEnv
+        ]
+
 findProgramOnSearchPath
   :: Verbosity
   -> ProgramSearchPath

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

@@ -107,7 +107,7 @@ data ProgramSearchPathEntry
     ProgramSearchPathDir FilePath
   | -- | The system default
     ProgramSearchPathDefault
-  deriving (Eq, Generic, Typeable)
+  deriving (Show, Eq, Generic, Typeable)
 
 instance Binary ProgramSearchPathEntry
 instance Structured ProgramSearchPathEntry