Commit 98384d43 authored by barmston's avatar barmston

Pull exec into its own module

Some stylistic changes have been made but otherwise this works in the same
manner as the original implementation.
parent 29d5c92f
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Exec
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- Implementation of the 'exec' command. Runs an arbitrary executable in an
-- environment suitable for making use of the sandbox.
-----------------------------------------------------------------------------
module Distribution.Client.Exec ( exec
) where
import Distribution.Client.Sandbox.PackageEnvironment (sandboxPackageDBPath)
import Distribution.Client.Sandbox.Types (UseSandbox (..))
import Distribution.Client.Sandbox (withSandboxBinDirOnSearchPath)
import Distribution.Simple.Compiler (Compiler)
import Distribution.Simple.GHC (ghcGlobalPackageDB)
import Distribution.Simple.Program (ghcProgram, lookupProgram)
import Distribution.Simple.Program.Db (ProgramDb)
import Distribution.Simple.Program.Run (getEffectiveEnvironment)
import Distribution.Simple.Utils (debug, die, rawSystemExit,
rawSystemExitWithEnv)
import Distribution.System (Platform)
import Distribution.Verbosity (Verbosity)
import System.Exit (exitFailure)
import System.FilePath (searchPathSeparator)
import Control.Applicative ((<$>))
import Data.Traversable as T
-- | Execute the given command in the package's environment.
--
-- The given command is executed with GHC configured to use the correct
-- package database and with the sandbox bin directory added to the PATH.
exec :: Verbosity
-> UseSandbox
-> Compiler
-> Platform
-> ProgramDb
-> [String]
-> IO ()
exec verbosity useSandbox comp platform programDb extraArgs =
case extraArgs of
(exe:args) -> do
case useSandbox of
NoSandbox ->
rawSystemExit verbosity exe args
(UseSandbox sandboxDir) -> do
withSandboxBinDirOnSearchPath sandboxDir $ do
menv <- sandboxEnvironment
verbosity sandboxDir comp platform programDb
case menv of
Just env ->
rawSystemExitWithEnv verbosity exe args env
Nothing ->
rawSystemExit verbosity exe args
[] -> die $ "Please specify an executable to run"
-- | Return the package's sandbox environment.
--
-- The environment sets GHC_PACKAGE_PATH so that GHC will use the sandbox.
sandboxEnvironment :: Verbosity
-> FilePath
-> Compiler
-> Platform
-> ProgramDb
-> IO (Maybe [(String, String)])
sandboxEnvironment verbosity sandboxDir comp platform programDb = do
mGlobalPackageDb <- T.sequence $ ghcGlobalPackageDB verbosity
<$> lookupProgram ghcProgram programDb
case mGlobalPackageDb of
Nothing -> do
debug verbosity "exec only works with GHC"
exitFailure
Just gDb ->
getEffectiveEnvironment $ overrides gDb
where
overrides gDb = [ ("GHC_PACKAGE_PATH", ghcPackagePath gDb) ]
ghcPackagePath gDb =
let s = sandboxPackageDBPath sandboxDir comp platform
in Just $ prependToSearchPath gDb s
prependToSearchPath path newValue =
newValue ++ [searchPathSeparator] ++ path
......@@ -65,6 +65,7 @@ import qualified Distribution.Client.List as List
import Distribution.Client.Install (install)
import Distribution.Client.Configure (configure)
import Distribution.Client.Update (update)
import Distribution.Client.Exec (exec)
import Distribution.Client.Fetch (fetch)
import Distribution.Client.Freeze (freeze)
import Distribution.Client.Check as Check (check)
......@@ -80,7 +81,6 @@ import Distribution.Client.Sandbox (sandboxInit
,sandboxListSources
,sandboxHcPkg
,dumpPackageEnvironment
,withSandboxBinDirOnSearchPath
,getSandboxConfigFilePath
,loadConfigOrSandboxConfig
......@@ -97,7 +97,6 @@ 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)
......@@ -127,14 +126,11 @@ import Distribution.Simple.Configure
, ConfigStateFileErrorType(..), localBuildInfoFile
, getPersistBuildConfig, tryGetPersistBuildConfig )
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.GHC (ghcGlobalPackageDB)
import Distribution.Simple.Program (defaultProgramConfiguration, lookupProgram, ghcProgram)
import Distribution.Simple.Program.Run (getEffectiveEnvironment)
import Distribution.Simple.Program (defaultProgramConfiguration)
import qualified Distribution.Simple.Setup as Cabal
import Distribution.Simple.Utils
( cabalVersion, debug, die, notice, info, topHandler
, findPackageDesc, tryFindPackageDesc , rawSystemExit
, rawSystemExitWithEnv )
( cabalVersion, die, notice, info, topHandler
, findPackageDesc, tryFindPackageDesc )
import Distribution.Text
( display )
import Distribution.Verbosity as Verbosity
......@@ -145,7 +141,7 @@ import qualified Paths_cabal_install (version)
import System.Environment (getArgs, getProgName)
import System.Exit (exitFailure)
import System.FilePath (splitExtension, takeExtension, searchPathSeparator)
import System.FilePath (splitExtension, takeExtension)
import System.IO ( BufferMode(LineBuffering), hSetBuffering
#ifdef mingw32_HOST_OS
, stderr
......@@ -1062,32 +1058,9 @@ 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 ++ [searchPathSeparator] ++ g)]
let configFlags = savedConfigureFlags config
(comp, platform, conf) <- configCompilerAux' configFlags
exec verbosity useSandbox comp platform conf extraArgs
-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.
--
......
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