Commit e24bffb8 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov Committed by tibbe
Browse files

Revert "Add cabal exec"

This reverts commit 99d912d3.

Looks like Johan managed to botch a merge somehow, see #1786. Or maybe that was
a bug on the GitHub side.

(cherry picked from commit d10d67cc)
parent 04b545f0
...@@ -44,7 +44,6 @@ module Distribution.Simple.GHC ( ...@@ -44,7 +44,6 @@ module Distribution.Simple.GHC (
componentGhcOptions, componentGhcOptions,
ghcLibDir, ghcLibDir,
ghcDynamic, ghcDynamic,
ghcGlobalPackageDB,
) where ) where
import qualified Distribution.Simple.GHC.IPI641 as IPI641 import qualified Distribution.Simple.GHC.IPI641 as IPI641
...@@ -550,13 +549,6 @@ ghcLibDir' verbosity ghcProg = ...@@ -550,13 +549,6 @@ ghcLibDir' verbosity ghcProg =
(reverse . dropWhile isSpace . reverse) `fmap` (reverse . dropWhile isSpace . reverse) `fmap`
rawSystemProgramStdout verbosity ghcProg ["--print-libdir"] 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 -- 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 -- 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 -- good idea, since then ghc and cabal are looking at different sets of
......
...@@ -19,7 +19,6 @@ module Distribution.Client.Sandbox.PackageEnvironment ( ...@@ -19,7 +19,6 @@ module Distribution.Client.Sandbox.PackageEnvironment (
, showPackageEnvironment , showPackageEnvironment
, showPackageEnvironmentWithComments , showPackageEnvironmentWithComments
, setPackageDB , setPackageDB
, sandboxPackageDBPath
, loadUserConfig , loadUserConfig
, basePackageEnvironment , basePackageEnvironment
...@@ -211,23 +210,14 @@ initialPackageEnvironment sandboxDir compiler platform = do ...@@ -211,23 +210,14 @@ 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. -- | Use the package DB location specific for this compiler.
setPackageDB :: FilePath -> Compiler -> Platform -> ConfigFlags -> ConfigFlags setPackageDB :: FilePath -> Compiler -> Platform -> ConfigFlags -> ConfigFlags
setPackageDB sandboxDir compiler platform configFlags = setPackageDB sandboxDir compiler platform configFlags =
configFlags { configFlags {
configPackageDBs = [Just (SpecificPackageDB $ sandboxPackageDBPath configPackageDBs = [Just (SpecificPackageDB $ sandboxDir
sandboxDir </> (Text.display platform ++ "-"
compiler ++ showCompilerId compiler
platform)] ++ "-packages.conf.d"))]
} }
-- | Almost the same as 'savedConf `mappend` pkgEnv', but some settings are -- | Almost the same as 'savedConf `mappend` pkgEnv', but some settings are
......
...@@ -34,7 +34,6 @@ module Distribution.Client.Setup ...@@ -34,7 +34,6 @@ module Distribution.Client.Setup
, sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
, win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..) , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
, sandboxCommand, defaultSandboxLocation, SandboxFlags(..) , sandboxCommand, defaultSandboxLocation, SandboxFlags(..)
, execCommand, ExecFlags(..)
, parsePackageArgs , parsePackageArgs
--TODO: stop exporting these: --TODO: stop exporting these:
...@@ -1609,44 +1608,6 @@ instance Monoid SandboxFlags where ...@@ -1609,44 +1608,6 @@ instance Monoid SandboxFlags where
} }
where combine field = field a `mappend` field b 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 -- * GetOpt Utils
-- ------------------------------------------------------------ -- ------------------------------------------------------------
......
...@@ -36,11 +36,10 @@ import Distribution.Client.Setup ...@@ -36,11 +36,10 @@ import Distribution.Client.Setup
, SDistFlags(..), SDistExFlags(..), sdistCommand , SDistFlags(..), SDistExFlags(..), sdistCommand
, Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand
, SandboxFlags(..), sandboxCommand , SandboxFlags(..), sandboxCommand
, ExecFlags(..), execCommand
, reportCommand , reportCommand
) )
import Distribution.Simple.Setup import Distribution.Simple.Setup
( HaddockFlags(..), haddockCommand ( HaddockFlags(..), haddockCommand, defaultHaddockFlags
, HscolourFlags(..), hscolourCommand , HscolourFlags(..), hscolourCommand
, ReplFlags(..), replCommand , ReplFlags(..), replCommand
, CopyFlags(..), copyCommand , CopyFlags(..), copyCommand
...@@ -78,7 +77,6 @@ import Distribution.Client.Sandbox (sandboxInit ...@@ -78,7 +77,6 @@ import Distribution.Client.Sandbox (sandboxInit
,sandboxListSources ,sandboxListSources
,sandboxHcPkg ,sandboxHcPkg
,dumpPackageEnvironment ,dumpPackageEnvironment
,withSandboxBinDirOnSearchPath
,getSandboxConfigFilePath ,getSandboxConfigFilePath
,loadConfigOrSandboxConfig ,loadConfigOrSandboxConfig
...@@ -95,7 +93,6 @@ import Distribution.Client.Sandbox (sandboxInit ...@@ -95,7 +93,6 @@ import Distribution.Client.Sandbox (sandboxInit
,configPackageDB') ,configPackageDB')
import Distribution.Client.Sandbox.PackageEnvironment import Distribution.Client.Sandbox.PackageEnvironment
(setPackageDB (setPackageDB
,sandboxPackageDBPath
,userPackageEnvironmentFile) ,userPackageEnvironmentFile)
import Distribution.Client.Sandbox.Timestamp (maybeAddCompilerTimestampRecord) import Distribution.Client.Sandbox.Timestamp (maybeAddCompilerTimestampRecord)
import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox) import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox)
...@@ -122,14 +119,11 @@ import Distribution.Simple.Configure ...@@ -122,14 +119,11 @@ import Distribution.Simple.Configure
, ConfigStateFileErrorType(..), localBuildInfoFile , ConfigStateFileErrorType(..), localBuildInfoFile
, getPersistBuildConfig, tryGetPersistBuildConfig ) , getPersistBuildConfig, tryGetPersistBuildConfig )
import qualified Distribution.Simple.LocalBuildInfo as LBI import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.GHC (ghcGlobalPackageDB) import Distribution.Simple.Program (defaultProgramConfiguration)
import Distribution.Simple.Program (defaultProgramConfiguration, lookupProgram, ghcProgram)
import Distribution.Simple.Program.Run (getEffectiveEnvironment)
import qualified Distribution.Simple.Setup as Cabal import qualified Distribution.Simple.Setup as Cabal
import Distribution.Simple.Utils import Distribution.Simple.Utils
( cabalVersion, debug, die, notice, info, topHandler ( cabalVersion, die, notice, info, topHandler
, findPackageDesc, tryFindPackageDesc , rawSystemExit , findPackageDesc, tryFindPackageDesc )
, rawSystemExitWithEnv )
import Distribution.Text import Distribution.Text
( display ) ( display )
import Distribution.Verbosity as Verbosity import Distribution.Verbosity as Verbosity
...@@ -220,11 +214,9 @@ mainWorker args = topHandler $ ...@@ -220,11 +214,9 @@ mainWorker args = topHandler $
,replCommand defaultProgramConfiguration ,replCommand defaultProgramConfiguration
`commandAddAction` replAction `commandAddAction` replAction
,sandboxCommand `commandAddAction` sandboxAction ,sandboxCommand `commandAddAction` sandboxAction
,execCommand `commandAddAction` execAction ,haddockCommand `commandAddAction` haddockAction
,wrapperAction copyCommand ,wrapperAction copyCommand
copyVerbosity copyDistPref copyVerbosity copyDistPref
,wrapperAction haddockCommand
haddockVerbosity haddockDistPref
,wrapperAction cleanCommand ,wrapperAction cleanCommand
cleanVerbosity cleanDistPref cleanVerbosity cleanDistPref
,wrapperAction hscolourCommand ,wrapperAction hscolourCommand
...@@ -638,11 +630,14 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags) ...@@ -638,11 +630,14 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
let sandboxDistPref = case useSandbox of let sandboxDistPref = case useSandbox of
NoSandbox -> NoFlag NoSandbox -> NoFlag
UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir
configFlags' = savedConfigureFlags config `mappend` configFlags configFlags' = maybeForceTests installFlags' $
savedConfigureFlags config `mappend` configFlags
configExFlags' = defaultConfigExFlags `mappend` configExFlags' = defaultConfigExFlags `mappend`
savedConfigureExFlags config `mappend` configExFlags savedConfigureExFlags config `mappend` configExFlags
installFlags' = defaultInstallFlags `mappend` installFlags' = defaultInstallFlags `mappend`
savedInstallFlags config `mappend` installFlags savedInstallFlags config `mappend` installFlags
haddockFlags' = defaultHaddockFlags `mappend`
savedHaddockFlags config `mappend` haddockFlags
globalFlags' = savedGlobalFlags config `mappend` globalFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, platform, conf) <- configCompilerAux' configFlags' (comp, platform, conf) <- configCompilerAux' configFlags'
...@@ -677,9 +672,16 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags) ...@@ -677,9 +672,16 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
comp platform conf comp platform conf
useSandbox mSandboxPkgInfo useSandbox mSandboxPkgInfo
globalFlags' configFlags'' configExFlags' globalFlags' configFlags'' configExFlags'
installFlags' haddockFlags installFlags' haddockFlags'
targets targets
where
-- '--run-tests' implies '--enable-tests'.
maybeForceTests installFlags' configFlags' =
if fromFlagOrDefault False (installRunTests installFlags')
then configFlags' { configTests = toFlag True }
else configFlags'
testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags
-> IO () -> IO ()
testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do
...@@ -742,6 +744,20 @@ benchmarkAction (benchmarkFlags, buildFlags, buildExFlags) ...@@ -742,6 +744,20 @@ benchmarkAction (benchmarkFlags, buildFlags, buildExFlags)
setupWrapper verbosity setupOptions Nothing setupWrapper verbosity setupOptions Nothing
Cabal.benchmarkCommand (const benchmarkFlags) extraArgs Cabal.benchmarkCommand (const benchmarkFlags) extraArgs
haddockAction :: HaddockFlags -> [String] -> GlobalFlags -> IO ()
haddockAction haddockFlags extraArgs globalFlags = do
let verbosity = fromFlag (haddockVerbosity haddockFlags)
(_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty
let haddockFlags' = defaultHaddockFlags `mappend`
savedHaddockFlags config `mappend` haddockFlags
setupScriptOptions = defaultSetupScriptOptions {
useDistPref = fromFlagOrDefault
(useDistPref defaultSetupScriptOptions)
(haddockDistPref haddockFlags')
}
setupWrapper verbosity setupScriptOptions Nothing
haddockCommand (const haddockFlags') extraArgs
listAction :: ListFlags -> [String] -> GlobalFlags -> IO () listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()
listAction listFlags extraArgs globalFlags = do listAction listFlags extraArgs globalFlags = do
let verbosity = fromFlag (listVerbosity listFlags) let verbosity = fromFlag (listVerbosity listFlags)
...@@ -994,37 +1010,6 @@ sandboxAction sandboxFlags extraArgs globalFlags = do ...@@ -994,37 +1010,6 @@ sandboxAction sandboxFlags extraArgs globalFlags = do
where where
noExtraArgs = (<1) . length 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. -- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.
-- --
win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> GlobalFlags 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