Skip to content

GitLab

Commit 99d912d3 authored by etrepum's avatar etrepum Committed by tibbe
Browse files

Add cabal exec

parent fdf8afce
Hide whitespace changes
Inline Side-by-side
Showing with 107 additions and 35 deletions
Cabal/Distribution/Simple/GHC.hs
View file @ 99d912d3
......@@ -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
......
cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs
View file @ 99d912d3
......@@ -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
......
cabal-install/Distribution/Client/Setup.hs
View file @ 99d912d3
......@@ -34,6 +34,7 @@ module Distribution.Client.Setup
, sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
, win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
, sandboxCommand, defaultSandboxLocation, SandboxFlags(..)
, execCommand, ExecFlags(..)
, parsePackageArgs
--TODO: stop exporting these:
......@@ -1602,6 +1603,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
-- ------------------------------------------------------------
......
cabal-install/Main.hs
View file @ 99d912d3
......@@ -36,10 +36,11 @@ import Distribution.Client.Setup
, SDistFlags(..), SDistExFlags(..), sdistCommand
, Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand
, SandboxFlags(..), sandboxCommand
, ExecFlags(..), execCommand
, reportCommand
)
import Distribution.Simple.Setup
( HaddockFlags(..), haddockCommand, defaultHaddockFlags
( HaddockFlags(..), haddockCommand
, HscolourFlags(..), hscolourCommand
, ReplFlags(..), replCommand
, CopyFlags(..), copyCommand
......@@ -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
......@@ -214,9 +220,11 @@ mainWorker args = topHandler $
,replCommand defaultProgramConfiguration
`commandAddAction` replAction
,sandboxCommand `commandAddAction` sandboxAction
,haddockCommand `commandAddAction` haddockAction
,execCommand `commandAddAction` execAction
,wrapperAction copyCommand
copyVerbosity copyDistPref
,wrapperAction haddockCommand
haddockVerbosity haddockDistPref
,wrapperAction cleanCommand
cleanVerbosity cleanDistPref
,wrapperAction hscolourCommand
......@@ -630,14 +638,11 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
let sandboxDistPref = case useSandbox of
NoSandbox -> NoFlag
UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir
configFlags' = maybeForceTests installFlags' $
savedConfigureFlags config `mappend` configFlags
configFlags' = savedConfigureFlags config `mappend` configFlags
configExFlags' = defaultConfigExFlags `mappend`
savedConfigureExFlags config `mappend` configExFlags
installFlags' = defaultInstallFlags `mappend`
savedInstallFlags config `mappend` installFlags
haddockFlags' = defaultHaddockFlags `mappend`
savedHaddockFlags config `mappend` haddockFlags
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, platform, conf) <- configCompilerAux' configFlags'
......@@ -672,16 +677,9 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
comp platform conf
useSandbox mSandboxPkgInfo
globalFlags' configFlags'' configExFlags'
installFlags' haddockFlags'
installFlags' haddockFlags
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
-> IO ()
testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do
......@@ -744,20 +742,6 @@ benchmarkAction (benchmarkFlags, buildFlags, buildExFlags)
setupWrapper verbosity setupOptions Nothing
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 extraArgs globalFlags = do
let verbosity = fromFlag (listVerbosity listFlags)
......@@ -1010,6 +994,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