Commit bd3c9b68 authored by refold's avatar refold
Browse files

Implement 'cabal sandbox hc-pkg'.

See #1200 (for which this is a partial fix).
parent 21abe3cd
......@@ -67,6 +67,7 @@ module Distribution.Simple.GHC (
installLib, installExe,
libAbiHash,
initPackageDB,
invokeHcPkg,
registerPackage,
componentGhcOptions,
ghcLibDir,
......@@ -1155,6 +1156,15 @@ initPackageDB verbosity conf dbPath = HcPkg.init verbosity ghcPkgProg dbPath
where
Just ghcPkgProg = lookupProgram ghcPkgProgram conf
-- | Run 'ghc-pkg' using a given package DB stack, directly forwarding the
-- provided command-line arguments to it.
invokeHcPkg :: Verbosity -> ProgramConfiguration -> PackageDBStack -> [String]
-> IO ()
invokeHcPkg verbosity conf dbStack extraArgs =
HcPkg.invoke verbosity ghcPkgProg dbStack extraArgs
where
Just ghcPkgProg = lookupProgram ghcPkgProgram conf
registerPackage
:: Verbosity
-> InstalledPackageInfo
......
......@@ -11,6 +11,7 @@
module Distribution.Simple.Program.HcPkg (
init,
invoke,
register,
reregister,
unregister,
......@@ -74,6 +75,15 @@ init verbosity hcPkg path =
runProgramInvocation verbosity
(initInvocation hcPkg verbosity path)
-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
-- provided command-line arguments to it.
invoke :: Verbosity -> ConfiguredProgram -> PackageDBStack -> [String] -> IO ()
invoke verbosity hcPkg dbStack extraArgs =
runProgramInvocation verbosity invocation
where
args = packageDbStackOpts hcPkg dbStack ++ extraArgs
invocation = programInvocation hcPkg args
-- | Call @hc-pkg@ to register a package.
--
-- > hc-pkg register {filename | -} [--user | --global | --package-db]
......
......@@ -58,6 +58,7 @@ module Distribution.Simple.Register (
unregister,
initPackageDB,
invokeHcPkg,
registerPackage,
generateRegistrationInfo,
inplaceInstalledPackageInfo,
......@@ -213,7 +214,18 @@ initPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> FilePath
initPackageDB verbosity comp conf dbPath =
case (compilerFlavor comp) of
GHC -> GHC.initPackageDB verbosity conf dbPath
_ -> die "initPackageDB is not implemented for this compiler"
_ -> die "Distribution.Simple.Register.initPackageDB: \
\not implemented for this compiler"
-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
-- provided command-line arguments to it.
invokeHcPkg :: Verbosity -> Compiler -> ProgramConfiguration -> PackageDBStack
-> [String] -> IO ()
invokeHcPkg verbosity comp conf dbStack extraArgs =
case (compilerFlavor comp) of
GHC -> GHC.invokeHcPkg verbosity conf dbStack extraArgs
_ -> die "Distribution.Simple.Register.invokeHcPkg: \
\not implemented for this compiler"
registerPackage :: Verbosity
-> InstalledPackageInfo
......
......@@ -11,16 +11,21 @@ module Distribution.Client.Sandbox (
sandboxInit,
sandboxDelete,
sandboxAddSource,
sandboxHcPkg,
dumpPackageEnvironment,
withSandboxBinDirOnSearchPath,
UseSandbox(..), isUseSandbox,
ForceGlobalInstall(UseDefaultPackageDBStack), maybeForceGlobalInstall,
loadConfigOrSandboxConfig,
initPackageDBIfNeeded,
maybeWithSandboxDirOnSearchPath,
installAddSourceDeps,
maybeInstallAddSourceDeps,
-- FIXME: move somewhere else
configPackageDB', configCompilerAux'
) where
import Distribution.Client.Setup
......@@ -44,7 +49,8 @@ import Distribution.Client.Targets ( UserTarget(..)
, readUserTargets
, resolveUserTargets )
import Distribution.Client.Types ( SourcePackageDb(..) )
import Distribution.Simple.Compiler ( Compiler, PackageDB(..) )
import Distribution.Simple.Compiler ( Compiler, PackageDB(..)
, PackageDBStack )
import Distribution.Simple.Configure ( configCompilerAux
, interpretPackageDbFlags )
import Distribution.Simple.Program ( ProgramConfiguration )
......@@ -205,6 +211,18 @@ sandboxAddSource verbosity buildTreeRefs _sandboxFlags globalFlags = do
Index.addBuildTreeRefs verbosity indexFile buildTreeRefs
-- | Invoke the @hc-pkg@ tool with provided arguments, restricted to the
-- sandbox.
sandboxHcPkg :: Verbosity -> SandboxFlags -> GlobalFlags -> [String] -> IO ()
sandboxHcPkg verbosity _sandboxFlags globalFlags extraArgs = do
(_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity
(globalConfigFile globalFlags)
let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv
dbStack = configPackageDB' configFlags ForceGlobalInstall
(comp, _platform, conf) <- configCompilerAux' configFlags
Register.invokeHcPkg verbosity comp conf dbStack extraArgs
--
-- * Helpers for writing code that works both inside and outside a sandbox.
--
......@@ -271,8 +289,7 @@ installAddSourceDeps verbosity config sandboxDir globalFlags = do
targets <- readUserTargets verbosity targetNames
let args :: InstallArgs
args = ((interpretPackageDbFlags {- userInstall = -} False
(configPackageDBs configFlags))
args = ((configPackageDB' configFlags ForceGlobalInstall)
,(globalRepos globalFlags')
,comp, platform, conf
,globalFlags', configFlags, configExFlags, installFlags
......@@ -301,15 +318,6 @@ installAddSourceDeps verbosity config sandboxDir globalFlags = do
processInstallPlan verbosity args installContext installPlan
where
-- Copied from Main.hs. FIXME: Remove duplication.
configCompilerAux' :: ConfigFlags
-> IO (Compiler, Platform, ProgramConfiguration)
configCompilerAux' configFlags =
configCompilerAux configFlags
--FIXME: make configCompilerAux use a sensible verbosity
{ configVerbosity = fmap lessVerbose (configVerbosity configFlags) }
-- | Check if a sandbox is present and call @installAddSourceDeps@ in that case.
maybeInstallAddSourceDeps :: Verbosity -> GlobalFlags -> IO UseSandbox
maybeInstallAddSourceDeps verbosity globalFlags = do
......@@ -327,3 +335,47 @@ maybeInstallAddSourceDeps verbosity globalFlags = do
\maybeInstallAddSourceDeps: can't happen"
installAddSourceDeps verbosity config sandboxDir globalFlags
return useSandbox
--
-- Utils (transitionary)
--
-- FIXME: configPackageDB' and configCompilerAux' don't really belong in this
-- module
--
-- | Force the usage of the global package DB even though @configUserInstall@
-- may be @True@.
--
-- We use @userInstallDirs@ in sandbox mode to prevent @cabal-install@ from
-- doing unnecessary things like invoking itself via @sudo@ (see commit
-- 7b2e3630f2ada8a56bf9100144e1bb9acbe6dc6a and 'rootCmd' in
-- "Distribution.Client.Install"), but in this particular case we want
-- @configUserInstall@ to be @False@ to prevent @UserPackageDB@ from being added
-- to the package DB stack (see #1183 and @interpretPackageDbFlags@ in
-- "Distribution.Simple.Configure").
--
-- In the future we may want to distinguish between global, user and sandbox
-- install types.
data ForceGlobalInstall = ForceGlobalInstall
| UseDefaultPackageDBStack
-- | If we're in a sandbox, add only the global package db to the package db
-- stack, otherwise use the default behaviour.
maybeForceGlobalInstall :: UseSandbox -> ForceGlobalInstall
maybeForceGlobalInstall NoSandbox = UseDefaultPackageDBStack
maybeForceGlobalInstall (UseSandbox _) = ForceGlobalInstall
configPackageDB' :: ConfigFlags -> ForceGlobalInstall -> PackageDBStack
configPackageDB' cfg force =
interpretPackageDbFlags userInstall (configPackageDBs cfg)
where
userInstall = case force of
ForceGlobalInstall -> False
UseDefaultPackageDBStack -> fromFlagOrDefault True (configUserInstall cfg)
configCompilerAux' :: ConfigFlags
-> IO (Compiler, Platform, ProgramConfiguration)
configCompilerAux' configFlags =
configCompilerAux configFlags
--FIXME: make configCompilerAux use a sensible verbosity
{ configVerbosity = fmap lessVerbose (configVerbosity configFlags) }
......@@ -67,35 +67,36 @@ import Distribution.Client.PackageEnvironment (setPackageDB)
import Distribution.Client.Sandbox (sandboxInit
,sandboxAddSource
,sandboxDelete
,sandboxHcPkg
,dumpPackageEnvironment
,UseSandbox(..), isUseSandbox
,ForceGlobalInstall(..)
,maybeForceGlobalInstall
,loadConfigOrSandboxConfig
,initPackageDBIfNeeded
,maybeWithSandboxDirOnSearchPath
,maybeInstallAddSourceDeps)
,maybeInstallAddSourceDeps
,configCompilerAux'
,configPackageDB')
import Distribution.Client.Init (initCabal)
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import Distribution.Simple.Compiler
( Compiler, PackageDBStack )
import Distribution.Simple.Program
( ProgramConfiguration )
import Distribution.Simple.Command
( CommandParse(..), CommandUI(..), Command
, commandsRun, commandAddAction, hiddenCommand )
import Distribution.Simple.Configure
( checkPersistBuildConfigOutdated, configCompilerAux
, interpretPackageDbFlags, maybeGetPersistBuildConfig )
, maybeGetPersistBuildConfig )
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.System ( Platform )
import Distribution.Simple.Utils
( cabalVersion, die, notice, topHandler )
import Distribution.Text
( display )
import Distribution.Verbosity as Verbosity
( Verbosity, normal, lessVerbose )
( Verbosity, normal )
import qualified Paths_cabal_install (version)
import System.Environment (getArgs, getProgName)
......@@ -658,12 +659,15 @@ sandboxAction sandboxFlags extraArgs globalFlags = do
["init"] -> sandboxInit verbosity sandboxFlags globalFlags
["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags
("add-source":extra) -> do
when ((<1) . length $ extra) $
die $ "The 'sandbox add-source' command expects at least one argument"
sandboxAddSource verbosity extra sandboxFlags globalFlags
when (noExtraArgs extra) $
die $ "The 'sandbox add-source' command expects at least one argument"
sandboxAddSource verbosity extra sandboxFlags globalFlags
-- More advanced commands.
["hc-pkg"] -> die "Not implemented!"
("hc-pkg":extra) -> do
when (noExtraArgs extra) $
die $ "The 'sandbox hc-pkg' command expects at least one argument"
sandboxHcPkg verbosity sandboxFlags globalFlags extra
["buildopts"] -> die "Not implemented!"
-- Hidden commands.
......@@ -673,6 +677,9 @@ sandboxAction sandboxFlags extraArgs globalFlags = do
[] -> die $ "Please specify a subcommand (see 'help sandbox')"
_ -> die $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs
where
noExtraArgs = (<1) . length
-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.
--
win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> GlobalFlags
......@@ -681,32 +688,3 @@ win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do
let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags)
Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path
win32SelfUpgradeAction _ _ _ = return ()
--
-- Utils (transitionary)
--
-- | Helper type used by configPackageDb'.
data ForceGlobalInstall = ForceGlobalInstall
| UseDefaultPackageDBStack
-- | If we're in a sandbox, add only the global package db to the package db
-- stack, otherwise use the default behaviour.
maybeForceGlobalInstall :: UseSandbox -> ForceGlobalInstall
maybeForceGlobalInstall NoSandbox = UseDefaultPackageDBStack
maybeForceGlobalInstall (UseSandbox _) = ForceGlobalInstall
configPackageDB' :: ConfigFlags -> ForceGlobalInstall -> PackageDBStack
configPackageDB' cfg force =
interpretPackageDbFlags userInstall (configPackageDBs cfg)
where
userInstall = case force of
ForceGlobalInstall -> False
UseDefaultPackageDBStack -> fromFlagOrDefault True (configUserInstall cfg)
configCompilerAux' :: ConfigFlags
-> IO (Compiler, Platform, ProgramConfiguration)
configCompilerAux' configFlags =
configCompilerAux configFlags
--FIXME: make configCompilerAux use a sensible verbosity
{ configVerbosity = fmap lessVerbose (configVerbosity configFlags) }
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