Commit 44d49765 authored by barmston's avatar barmston

Use the ConfiguredProgram abstraction in exec

parent 98384d43
......@@ -34,6 +34,7 @@ module Distribution.Simple.Program.Db (
knownPrograms,
getProgramSearchPath,
setProgramSearchPath,
modifyProgramSearchPath,
userSpecifyPath,
userSpecifyPaths,
userMaybeSpecifyPath,
......@@ -185,6 +186,16 @@ getProgramSearchPath = progSearchPath
setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb
setProgramSearchPath searchpath db = db { progSearchPath = searchpath }
-- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'.
-- This will affect programs that are configured from here on, so you
-- should usually modify it before configuring any programs.
--
modifyProgramSearchPath :: (ProgramSearchPath -> ProgramSearchPath)
-> ProgramDb
-> ProgramDb
modifyProgramSearchPath f db =
setProgramSearchPath (f $ getProgramSearchPath db) db
-- |User-specify this path. Basically override any path information
-- for this program in the configuration. If it's not a known
-- program ignore it.
......
......@@ -13,21 +13,21 @@ module Distribution.Client.Exec ( exec
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.Simple.Program.Db (ProgramDb, requireProgram, modifyProgramSearchPath)
import Distribution.Simple.Program.Find (ProgramSearchPathEntry(..))
import Distribution.Simple.Program.Run (programInvocation, runProgramInvocation)
import Distribution.Simple.Program.Types ( simpleProgram, ConfiguredProgram(..) )
import Distribution.Simple.Utils (debug, die)
import Distribution.System (Platform)
import Distribution.Verbosity (Verbosity)
import System.Exit (exitFailure)
import System.FilePath (searchPathSeparator)
import System.FilePath (searchPathSeparator, (</>))
import Control.Applicative ((<$>))
import Data.Traversable as T
......@@ -46,21 +46,20 @@ exec :: Verbosity
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
program <- requireProgram' verbosity useSandbox programDb exe
env <- ((++) (programOverrideEnv program)) <$> environmentOverrides
let invocation = programInvocation
program { programOverrideEnv = env }
args
runProgramInvocation verbosity invocation
[] -> die $ "Please specify an executable to run"
where
environmentOverrides =
case useSandbox of
NoSandbox -> return []
(UseSandbox sandboxDir) ->
sandboxEnvironment verbosity sandboxDir comp platform programDb
-- | Return the package's sandbox environment.
......@@ -71,7 +70,7 @@ sandboxEnvironment :: Verbosity
-> Compiler
-> Platform
-> ProgramDb
-> IO (Maybe [(String, String)])
-> IO [(String, Maybe String)]
sandboxEnvironment verbosity sandboxDir comp platform programDb = do
mGlobalPackageDb <- T.sequence $ ghcGlobalPackageDB verbosity
<$> lookupProgram ghcProgram programDb
......@@ -80,7 +79,7 @@ sandboxEnvironment verbosity sandboxDir comp platform programDb = do
debug verbosity "exec only works with GHC"
exitFailure
Just gDb ->
getEffectiveEnvironment $ overrides gDb
return $ overrides gDb
where
overrides gDb = [ ("GHC_PACKAGE_PATH", ghcPackagePath gDb) ]
......@@ -90,3 +89,25 @@ sandboxEnvironment verbosity sandboxDir comp platform programDb = do
prependToSearchPath path newValue =
newValue ++ [searchPathSeparator] ++ path
-- | Check that a program is configured and available to be run. If
-- a sandbox is available check in the sandbox's directory.
requireProgram' :: Verbosity
-> UseSandbox
-> ProgramDb
-> String
-> IO ConfiguredProgram
requireProgram' verbosity useSandbox programDb exe = do
(program, _) <- requireProgram
verbosity
(simpleProgram exe)
updateSearchPath
return program
where
updateSearchPath =
flip modifyProgramSearchPath programDb $ \searchPath ->
case useSandbox of
NoSandbox -> searchPath
UseSandbox sandboxDir ->
ProgramSearchPathDir (sandboxDir </> "bin") : searchPath
......@@ -49,7 +49,7 @@ tests cabalPath ghcPkgPath =
_ <- assertCleanSucceeded <$> cabal_clean dir [] cabalPath
_ <- assertSandboxSucceeded <$> cabal_sandbox dir ["delete"] cabalPath
assertMyExecutableDoesNotExist cabalPath
assertMyExecutableNotFound cabalPath
_ <- assertSandboxSucceeded <$> cabal_sandbox dir ["init"] cabalPath
_ <- assertInstallSucceeded <$> cabal_install dir [] cabalPath
......@@ -64,7 +64,7 @@ tests cabalPath ghcPkgPath =
, testCase "adds the sandbox bin directory to the PATH" $ do
_ <- assertCleanSucceeded <$> cabal_clean dir [] cabalPath
_ <- assertSandboxSucceeded <$> cabal_sandbox dir ["delete"] cabalPath
assertMyExecutableDoesNotExist cabalPath
assertMyExecutableNotFound cabalPath
_ <- assertSandboxSucceeded <$> cabal_sandbox dir ["init"] cabalPath
_ <- assertInstallSucceeded <$> cabal_install dir [] cabalPath
......@@ -100,12 +100,13 @@ tests cabalPath ghcPkgPath =
assertMyExecutableDoesNotExist :: FilePath -> IO ()
assertMyExecutableDoesNotExist cabalPath = do
assertMyExecutableNotFound :: FilePath -> IO ()
assertMyExecutableNotFound cabalPath = do
result <- cabal_exec dir ["my-executable"] cabalPath
assertExecFailed result
let output = outputText result
expected = "cabal: my-executable: does not exist"
expected = "cabal: The program 'my-executable' is required but it " ++
"could not be found"
errMsg = "should not have found a my-executable\n" ++ output
assertBool errMsg $
expected `isInfixOf` (intercalate " " . lines $ output)
......
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