Temporary hacks for data-dirs in tests etc

Author: sheaf

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

@@ -67,6 +67,9 @@ module Distribution.Simple.Program.Db
   , ConfiguredProgs
   , updateUnconfiguredProgs
   , updateConfiguredProgs
+
+    -- SetupHooks TODO: hack
+  , updatePathProgDb
   ) where
 
 import Distribution.Compat.Prelude
@@ -466,6 +469,24 @@ reconfigurePrograms verbosity paths argss progdb = do
   where
     progs = catMaybes [lookupKnownProgram name progdb | (name, _) <- paths]
 
+-- SetupHooks TODO: hack
+updatePathProgDb :: Verbosity -> [(String, Maybe String)] -> ProgramDb -> IO ProgramDb
+updatePathProgDb verbosity envOverrides progdb =
+  updatePathProgs verbosity envOverrides progs progdb
+  where
+    progs = Map.elems $ configuredProgs progdb
+
+updatePathProgs :: Verbosity -> [(String, Maybe String)] -> [ConfiguredProgram] -> ProgramDb -> IO ProgramDb
+updatePathProgs verbosity envOverrides progs progdb =
+  foldM (flip (updatePathProg verbosity envOverrides)) progdb progs
+
+updatePathProg :: Verbosity -> [(String, Maybe String)] ->  ConfiguredProgram -> ProgramDb -> IO ProgramDb
+updatePathProg _verbosity envOverrides prog progdb = do
+  newPath <- programSearchPathAsPATHVar (progSearchPath progdb)
+  let prog' = prog { programOverrideEnv = [("PATH", Just newPath)] ++ envOverrides }
+    -- SetupHooks TODO: don't just replace the old but augment it?
+  return $ updateProgram prog' progdb
+
 -- | Check that a program is configured and available to be run.
 --
 -- It raises an exception if the program could not be configured, otherwise

Cabal/src/Distribution/Simple/Test/ExeV10.hs

@@ -22,11 +22,15 @@ import qualified Distribution.Simple.LocalBuildInfo as LBI
   , buildDir
   , depLibraryPaths
   )
+import Distribution.Simple.Program
+import Distribution.Simple.Program.Db
+import Distribution.Simple.Program.Find
+import Distribution.Simple.Program.Run
 import Distribution.Simple.Setup.Common
 import Distribution.Simple.Setup.Test
 import Distribution.Simple.Test.Log
 import Distribution.Simple.Utils
-import Distribution.System
+import Distribution.System ( Platform(Platform) )
 import Distribution.TestSuite
 import qualified Distribution.Types.LocalBuildInfo as LBI
   ( LocalBuildInfo (..)
@@ -86,6 +90,16 @@ runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do
   notice verbosity $ summarizeSuiteStart $ testName'
 
   -- Run the test executable
+  newPath <- programSearchPathAsPATHVar (progSearchPath $ LBI.withPrograms lbi)
+
+  -- SetupHooks TODO: giant hack to propagate the data directories of
+  -- any build-tool-depends executables: these overrides are not stored in
+  -- the program database, but "ghc" has the right overrides, so use those.
+  -- This is just temporary before we rework ProgramDb a bit.
+  let otherStuff = case lookupProgramByName "ghc" (LBI.withPrograms lbi) of
+        Just (ConfiguredProgram { programOverrideEnv = overrides }) -> overrides
+        Nothing -> []
+  blah <- fromMaybe [] <$> getEffectiveEnvironment otherStuff
   let opts =
         map
           (testOption pkg_descr lbi suite)
@@ -100,7 +114,7 @@ runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do
       pkgPathEnv =
         (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
           : existingEnv
-      shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv
+      shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ blah ++ [("PATH", newPath)] ++ pkgPathEnv
 
   -- Add (DY)LD_LIBRARY_PATH if needed
   shellEnv' <-

cabal-install/src/Distribution/Client/SetupWrapper.hs

@@ -83,7 +83,7 @@ import Distribution.Simple.Compiler
   , compilerFlavor
   )
 import Distribution.Simple.Configure
-  ( configCompilerEx
+  ( configCompilerEx, localBuildInfoFile, getPersistBuildConfig, writePersistBuildConfig
   )
 import Distribution.Simple.PackageDescription
   ( readGenericPackageDescription
@@ -99,10 +99,10 @@ import Distribution.Simple.Program
   , getProgramSearchPath
   , ghcProgram
   , ghcjsProgram
-  , runDbProgramCwd
+  , runDbProgramCwd, programOverrideEnv, updateProgram
   )
 import Distribution.Simple.Program.Db
-  ( prependProgramSearchPath
+  ( prependProgramSearchPath, lookupProgramByName, updatePathProgDb
   )
 import Distribution.Simple.Program.Find
   ( programSearchPathAsPATHVar
@@ -193,6 +193,7 @@ import Distribution.Utils.NubList
   ( toNubListR
   )
 import Distribution.Types.LocalBuildInfo ( LocalBuildInfo )
+import qualified Distribution.Types.LocalBuildInfo as LBI
 import Distribution.Verbosity
 import Distribution.Client.Errors
 import qualified Distribution.Client.InLibrary as InLibrary
@@ -204,7 +205,7 @@ import Distribution.Client.SetupHooks.CallHooksExe
 
 import Data.List (foldl1')
 import Data.Kind ( Type, Constraint )
-import System.Directory (doesFileExist)
+import System.Directory (doesFileExist, removeFile)
 import System.FilePath ((<.>), (</>), takeFileName)
 import System.IO (Handle, hPutStr)
 import System.Process (StdStream (..))
@@ -634,6 +635,7 @@ setupWrapper verbosity options mpkg cmd getCommonFlags getFlags getExtraArgs wra
         NotInLibrary -> Don'tAllowInLibrary
         InLibraryArgs {} -> AllowInLibrary
   ASetup (setup :: Setup kind) <- getSetup verbosity options mpkg allowInLibrary
+  ASetup (setup' :: Setup kind') <- getSetup verbosity options mpkg Don'tAllowInLibrary
   let version = setupVersion setup
       flags = getFlags version
       extraArgs = getExtraArgs version
@@ -666,7 +668,48 @@ setupWrapper verbosity options mpkg cmd getCommonFlags getFlags getExtraArgs wra
                 InLibrary.configure
                   (InLibrary.libraryConfigureInputsFromElabPackage progDb' elabSharedConfig elabReadyPkg)
                   flags
-              return $ InLibraryLBI lbi
+              let mbWorkDir = useWorkingDir options
+                  distPref = useDistPref options
+{-
+                  lbiPath = interpretSymbolicPath mbWorkDir $ localBuildInfoFile distPref
+              removeFile lbiPath
+              let
+                notInLibraryMethod' :: kind' ~ GeneralSetup => IO ()
+                notInLibraryMethod' = runSetupCommand verbosity setup' cmd getCommonFlags flags extraArgs NotInLibrary
+                runSetup' :: IO ()
+                runSetup' =
+                  case setupMethod setup' of
+                    InternalMethod -> notInLibraryMethod'
+                    ExternalMethod {} -> notInLibraryMethod'
+                    SelfExecMethod -> notInLibraryMethod'
+                    LibraryMethod -> error "internal error: NotInLibrary argument but getSetup chose InLibrary"
+              runSetup'
+              --setupLBI <- getPersistBuildConfig mbWorkDir distPref
+              --when True $ do
+              --  putStrLn "SetupWrapper: InLibrary LBI comparison"
+              --  putStrLn $ unlines
+              --    [ "extraPathEnv: " ++ show (useExtraPathEnv options)
+              --    , "extraEnvOverrides: " ++ show (useExtraEnvOverrides options) ]
+              --  putStrLn $ replicate 80 '='
+              --  putStrLn "In-library GHC"
+              --  putStrLn $ show $ lookupProgramByName "ghc" $ LBI.withPrograms lbi
+              --  putStrLn $ replicate 80 '-'
+              --  putStrLn "Setup GHC"
+              --  putStrLn $ show $ lookupProgramByName "ghc" $ LBI.withPrograms setupLBI
+              --  putStrLn $ replicate 80 '='
+-}
+
+              let progs0 = LBI.withPrograms lbi
+              progs1 <- updatePathProgDb verbosity (useExtraEnvOverrides options) progs0
+              let
+                  lbi' =
+                    lbi
+                      { LBI.withPrograms = progs1
+                      }
+              -- (When we're comparing in-library and Setup, make sure that
+              -- the final LBI is the one from in-library.)
+              writePersistBuildConfig mbWorkDir distPref lbi'
+              return $ InLibraryLBI lbi'
             InLibraryPostConfigureArgs sPhase mbLBI ->
               case mbLBI of
                 NotInLibraryNoLBI ->
@@ -676,6 +719,8 @@ setupWrapper verbosity options mpkg cmd getCommonFlags getFlags getExtraArgs wra
                   -- LocalBuildInfo (see "whenReconfigure"
                   --   in Distribution.Client.ProjectBuilding.UnpackedPackage).
                 InLibraryLBI lbi ->
+                  --withExtraPathEnv (useExtraPathEnv options) $
+                  --  withEnvOverrides (useExtraEnvOverrides options) $
                   case sPhase of
                     SBuildPhase    -> InLibrary.build    flags lbi
                     SHaddockPhase  -> InLibrary.haddock  flags lbi