Commit a04d4930 authored by etrepum's avatar etrepum Committed by tibbe
Browse files

Re-add cabal exec after failed rebase

Conflicts:
	cabal-install/Main.hs
parent e24bffb8
......@@ -44,6 +44,7 @@ module Distribution.Simple.GHC (
componentGhcOptions,
ghcLibDir,
ghcDynamic,
ghcGlobalPackageDB,
) where
import qualified Distribution.Simple.GHC.IPI641 as IPI641
......@@ -549,6 +550,13 @@ ghcLibDir' verbosity ghcProg =
(reverse . dropWhile isSpace . reverse) `fmap`
rawSystemProgramStdout verbosity ghcProg ["--print-libdir"]
-- | Return the 'FilePath' to the global GHC package database.
ghcGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath
ghcGlobalPackageDB verbosity ghcProg =
(reverse . dropWhile isSpace . reverse) `fmap`
rawSystemProgramStdout verbosity ghcProg ["--print-global-package-db"]
-- Cabal does not use the environment variable GHC_PACKAGE_PATH; let users
-- know that this is the case. See ticket #335. Simply ignoring it is not a
-- good idea, since then ghc and cabal are looking at different sets of
......
......@@ -19,6 +19,7 @@ module Distribution.Client.Sandbox.PackageEnvironment (
, showPackageEnvironment
, showPackageEnvironmentWithComments
, setPackageDB
, sandboxPackageDBPath
, loadUserConfig
, basePackageEnvironment
......@@ -210,14 +211,23 @@ initialPackageEnvironment sandboxDir compiler platform = do
}
}
-- | Return the path to the sandbox package database.
sandboxPackageDBPath :: FilePath -> Compiler -> Platform -> String
sandboxPackageDBPath sandboxDir compiler platform =
sandboxDir
</> (Text.display platform ++ "-"
++ showCompilerId compiler
++ "-packages.conf.d")
-- | Use the package DB location specific for this compiler.
setPackageDB :: FilePath -> Compiler -> Platform -> ConfigFlags -> ConfigFlags
setPackageDB sandboxDir compiler platform configFlags =
configFlags {
configPackageDBs = [Just (SpecificPackageDB $ sandboxDir
</> (Text.display platform ++ "-"
++ showCompilerId compiler
++ "-packages.conf.d"))]
configPackageDBs = [Just (SpecificPackageDB $ sandboxPackageDBPath
sandboxDir
compiler
platform)]
}
-- | Almost the same as 'savedConf `mappend` pkgEnv', but some settings are
......
......@@ -34,6 +34,7 @@ module Distribution.Client.Setup
, sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
, win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
, sandboxCommand, defaultSandboxLocation, SandboxFlags(..)
, execCommand, ExecFlags(..)
, parsePackageArgs
--TODO: stop exporting these:
......@@ -1608,6 +1609,44 @@ instance Monoid SandboxFlags where
}
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
-- * Exec Flags
-- ------------------------------------------------------------
data ExecFlags = ExecFlags {
execVerbosity :: Flag Verbosity
}
defaultExecFlags :: ExecFlags
defaultExecFlags = ExecFlags {
execVerbosity = toFlag normal
}
execCommand :: CommandUI ExecFlags
execCommand = CommandUI {
commandName = "exec",
commandSynopsis = "Run a command with the cabal environment",
commandDescription = Nothing,
commandUsage = \pname ->
"Usage: " ++ pname ++ " exec [FLAGS] COMMAND [-- [ARGS...]]\n\n"
++ "Flags for exec:",
commandDefaultFlags = defaultExecFlags,
commandOptions = \_ ->
[ optionVerbosity execVerbosity
(\v flags -> flags { execVerbosity = v })
]
}
instance Monoid ExecFlags where
mempty = ExecFlags {
execVerbosity = mempty
}
mappend a b = ExecFlags {
execVerbosity = combine execVerbosity
}
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
-- * GetOpt Utils
-- ------------------------------------------------------------
......
......@@ -36,6 +36,7 @@ import Distribution.Client.Setup
, SDistFlags(..), SDistExFlags(..), sdistCommand
, Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand
, SandboxFlags(..), sandboxCommand
, ExecFlags(..), execCommand
, reportCommand
)
import Distribution.Simple.Setup
......@@ -77,6 +78,7 @@ import Distribution.Client.Sandbox (sandboxInit
,sandboxListSources
,sandboxHcPkg
,dumpPackageEnvironment
,withSandboxBinDirOnSearchPath
,getSandboxConfigFilePath
,loadConfigOrSandboxConfig
......@@ -93,6 +95,7 @@ import Distribution.Client.Sandbox (sandboxInit
,configPackageDB')
import Distribution.Client.Sandbox.PackageEnvironment
(setPackageDB
,sandboxPackageDBPath
,userPackageEnvironmentFile)
import Distribution.Client.Sandbox.Timestamp (maybeAddCompilerTimestampRecord)
import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox)
......@@ -119,11 +122,14 @@ import Distribution.Simple.Configure
, ConfigStateFileErrorType(..), localBuildInfoFile
, getPersistBuildConfig, tryGetPersistBuildConfig )
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.Program (defaultProgramConfiguration)
import Distribution.Simple.GHC (ghcGlobalPackageDB)
import Distribution.Simple.Program (defaultProgramConfiguration, lookupProgram, ghcProgram)
import Distribution.Simple.Program.Run (getEffectiveEnvironment)
import qualified Distribution.Simple.Setup as Cabal
import Distribution.Simple.Utils
( cabalVersion, die, notice, info, topHandler
, findPackageDesc, tryFindPackageDesc )
( cabalVersion, debug, die, notice, info, topHandler
, findPackageDesc, tryFindPackageDesc , rawSystemExit
, rawSystemExitWithEnv )
import Distribution.Text
( display )
import Distribution.Verbosity as Verbosity
......@@ -215,6 +221,7 @@ mainWorker args = topHandler $
`commandAddAction` replAction
,sandboxCommand `commandAddAction` sandboxAction
,haddockCommand `commandAddAction` haddockAction
,execCommand `commandAddAction` execAction
,wrapperAction copyCommand
copyVerbosity copyDistPref
,wrapperAction cleanCommand
......@@ -1010,6 +1017,37 @@ sandboxAction sandboxFlags extraArgs globalFlags = do
where
noExtraArgs = (<1) . length
execAction :: ExecFlags -> [String] -> GlobalFlags -> IO ()
execAction execFlags extraArgs globalFlags = do
let verbosity = fromFlag (execVerbosity execFlags)
(useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags
mempty
case extraArgs of
(exec:args) -> do
case useSandbox of
NoSandbox ->
rawSystemExit verbosity exec args
(UseSandbox sandboxDir) -> do
let configFlags = savedConfigureFlags config
(comp, platform, conf) <- configCompilerAux' configFlags
withSandboxBinDirOnSearchPath sandboxDir $ do
menv <- newEnv sandboxDir comp platform conf verbosity
case menv of
Just env -> rawSystemExitWithEnv verbosity exec args env
Nothing -> rawSystemExit verbosity exec args
-- Error handling.
[] -> die $ "Please specify an executable to run"
where
newEnv sandboxDir comp platform conf verbosity = do
let s = sandboxPackageDBPath sandboxDir comp platform
case lookupProgram ghcProgram conf of
Nothing -> do
debug verbosity "sandbox exec only works with GHC"
exitFailure
Just ghcProg -> do
g <- ghcGlobalPackageDB verbosity ghcProg
getEffectiveEnvironment [("GHC_PACKAGE_PATH", Just $ s ++ ":" ++ g)]
-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.
--
win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> GlobalFlags
......
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