Commit 146d736d authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

Merge pull request #2859 from adamgundry/fix-sandbox-hcpkg

Use configured compiler for cabal sandbox hc-pkg
parents 63a2c9c7 833da5e2
...@@ -14,8 +14,6 @@ module Distribution.Client.Exec ( exec ...@@ -14,8 +14,6 @@ module Distribution.Client.Exec ( exec
import Control.Monad (unless) import Control.Monad (unless)
import Data.Foldable (forM_)
import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.GHCJS as GHCJS
...@@ -91,22 +89,19 @@ sandboxEnvironment verbosity sandboxDir comp platform programDb = ...@@ -91,22 +89,19 @@ sandboxEnvironment verbosity sandboxDir comp platform programDb =
let Just program = lookupProgram hcProgram programDb let Just program = lookupProgram hcProgram programDb
gDb <- getGlobalPackageDB verbosity program gDb <- getGlobalPackageDB verbosity program
sandboxConfigFilePath <- getSandboxConfigFilePath mempty sandboxConfigFilePath <- getSandboxConfigFilePath mempty
let compilerPackagePath = hcPackagePath gDb let sandboxPackagePath = sandboxPackageDBPath sandboxDir comp platform
compilerPackagePaths = prependToSearchPath gDb sandboxPackagePath
-- Packages database must exist, otherwise things will start -- Packages database must exist, otherwise things will start
-- failing in mysterious ways. -- failing in mysterious ways.
forM_ compilerPackagePath $ \fp -> do exists <- doesDirectoryExist sandboxPackagePath
exists <- doesDirectoryExist fp unless exists $ warn verbosity $ "Package database is not a directory: "
unless exists $ warn verbosity $ "Package database is not a directory: " ++ fp ++ sandboxPackagePath
-- Build the environment -- Build the environment
return [ (packagePathEnvVar, compilerPackagePath) return [ (packagePathEnvVar, Just compilerPackagePaths)
, ("CABAL_SANDBOX_PACKAGE_PATH", compilerPackagePath) , ("CABAL_SANDBOX_PACKAGE_PATH", Just compilerPackagePaths)
, ("CABAL_SANDBOX_CONFIG", Just sandboxConfigFilePath) , ("CABAL_SANDBOX_CONFIG", Just sandboxConfigFilePath)
] ]
hcPackagePath gDb =
let s = sandboxPackageDBPath sandboxDir comp platform
in Just $ prependToSearchPath gDb s
prependToSearchPath path newValue = prependToSearchPath path newValue =
newValue ++ [searchPathSeparator] ++ path newValue ++ [searchPathSeparator] ++ path
......
...@@ -39,7 +39,7 @@ module Distribution.Client.Sandbox ( ...@@ -39,7 +39,7 @@ module Distribution.Client.Sandbox (
updateInstallDirs, updateInstallDirs,
-- FIXME: move somewhere else -- FIXME: move somewhere else
configPackageDB', configCompilerAux' configPackageDB', configCompilerAux', getPersistOrConfigCompiler
) where ) where
import Distribution.Client.Setup import Distribution.Client.Setup
...@@ -65,7 +65,8 @@ import Distribution.Client.Sandbox.PackageEnvironment ...@@ -65,7 +65,8 @@ import Distribution.Client.Sandbox.PackageEnvironment
, createPackageEnvironmentFile, classifyPackageEnvironment , createPackageEnvironmentFile, classifyPackageEnvironment
, tryLoadSandboxPackageEnvironmentFile, loadUserConfig , tryLoadSandboxPackageEnvironmentFile, loadUserConfig
, commentPackageEnvironment, showPackageEnvironmentWithComments , commentPackageEnvironment, showPackageEnvironmentWithComments
, sandboxPackageEnvironmentFile, userPackageEnvironmentFile ) , sandboxPackageEnvironmentFile, userPackageEnvironmentFile
, sandboxPackageDBPath )
import Distribution.Client.Sandbox.Types ( SandboxPackageInfo(..) import Distribution.Client.Sandbox.Types ( SandboxPackageInfo(..)
, UseSandbox(..) ) , UseSandbox(..) )
import Distribution.Client.SetupWrapper import Distribution.Client.SetupWrapper
...@@ -82,7 +83,10 @@ import Distribution.Simple.Compiler ( Compiler(..), PackageDB(..) ...@@ -82,7 +83,10 @@ import Distribution.Simple.Compiler ( Compiler(..), PackageDB(..)
import Distribution.Simple.Configure ( configCompilerAuxEx import Distribution.Simple.Configure ( configCompilerAuxEx
, interpretPackageDbFlags , interpretPackageDbFlags
, getPackageDBContents , getPackageDBContents
, maybeGetPersistBuildConfig
, findDistPrefOrDefault
, findDistPref ) , findDistPref )
import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo
import Distribution.Simple.PreProcess ( knownSuffixHandlers ) import Distribution.Simple.PreProcess ( knownSuffixHandlers )
import Distribution.Simple.Program ( ProgramConfiguration ) import Distribution.Simple.Program ( ProgramConfiguration )
import Distribution.Simple.Setup ( Flag(..), HaddockFlags(..) import Distribution.Simple.Setup ( Flag(..), HaddockFlags(..)
...@@ -479,11 +483,13 @@ sandboxListSources verbosity _sandboxFlags globalFlags = do ...@@ -479,11 +483,13 @@ sandboxListSources verbosity _sandboxFlags globalFlags = do
-- tool with provided arguments, restricted to the sandbox. -- tool with provided arguments, restricted to the sandbox.
sandboxHcPkg :: Verbosity -> SandboxFlags -> GlobalFlags -> [String] -> IO () sandboxHcPkg :: Verbosity -> SandboxFlags -> GlobalFlags -> [String] -> IO ()
sandboxHcPkg verbosity _sandboxFlags globalFlags extraArgs = do sandboxHcPkg verbosity _sandboxFlags globalFlags extraArgs = do
(_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv
dbStack = configPackageDB' configFlags -- Invoke hc-pkg for the most recently configured compiler (if any),
(comp, _platform, conf) <- configCompilerAux' configFlags -- using the right package-db for the compiler (see #1935).
(comp, platform, conf) <- getPersistOrConfigCompiler configFlags
let dir = sandboxPackageDBPath sandboxDir comp platform
dbStack = [GlobalPackageDB, SpecificPackageDB dir]
Register.invokeHcPkg verbosity comp conf dbStack extraArgs Register.invokeHcPkg verbosity comp conf dbStack extraArgs
updateInstallDirs :: Flag Bool updateInstallDirs :: Flag Bool
...@@ -791,3 +797,18 @@ configCompilerAux' configFlags = ...@@ -791,3 +797,18 @@ configCompilerAux' configFlags =
configCompilerAuxEx configFlags configCompilerAuxEx configFlags
--FIXME: make configCompilerAux use a sensible verbosity --FIXME: make configCompilerAux use a sensible verbosity
{ configVerbosity = fmap lessVerbose (configVerbosity configFlags) } { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }
-- | Try to read the most recently configured compiler from the
-- 'localBuildInfoFile', falling back on 'configCompilerAuxEx' if it
-- cannot be read.
getPersistOrConfigCompiler :: ConfigFlags
-> IO (Compiler, Platform, ProgramConfiguration)
getPersistOrConfigCompiler configFlags = do
distPref <- findDistPrefOrDefault (configDistPref configFlags)
mlbi <- maybeGetPersistBuildConfig distPref
case mlbi of
Nothing -> do configCompilerAux' configFlags
Just lbi -> return ( LocalBuildInfo.compiler lbi
, LocalBuildInfo.hostPlatform lbi
, LocalBuildInfo.withPrograms lbi
)
...@@ -100,6 +100,7 @@ import Distribution.Client.Sandbox (sandboxInit ...@@ -100,6 +100,7 @@ import Distribution.Client.Sandbox (sandboxInit
,updateInstallDirs ,updateInstallDirs
,configCompilerAux' ,configCompilerAux'
,getPersistOrConfigCompiler
,configPackageDB') ,configPackageDB')
import Distribution.Client.Sandbox.PackageEnvironment import Distribution.Client.Sandbox.PackageEnvironment
(setPackageDB (setPackageDB
...@@ -1158,7 +1159,7 @@ execAction execFlags extraArgs globalFlags = do ...@@ -1158,7 +1159,7 @@ execAction execFlags extraArgs globalFlags = do
let verbosity = fromFlag (execVerbosity execFlags) let verbosity = fromFlag (execVerbosity execFlags)
(useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags
let configFlags = savedConfigureFlags config let configFlags = savedConfigureFlags config
(comp, platform, conf) <- configCompilerAux' configFlags (comp, platform, conf) <- getPersistOrConfigCompiler configFlags
exec verbosity useSandbox comp platform conf extraArgs exec verbosity useSandbox comp platform conf extraArgs
userConfigAction :: UserConfigFlags -> [String] -> GlobalFlags -> IO () userConfigAction :: UserConfigFlags -> [String] -> GlobalFlags -> IO ()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment