Commit 7772ce9c authored by refold's avatar refold
Browse files

Add an alternative interface for 'D.C.Install.install'.

Splits 'D.C.Install.install' into three parts:

    * makeInstallContext - load common data
    * makeInstallPlan    - produce the install plan
    * processInstallPlan - actually perform the installations

This allows to manipulate the install plan produced with 'makeInstallPlan'
before performing the installations with 'processInstallPlan'. The high-level
'install' action is still present; most clients should use it instead.
parent b33260df
......@@ -14,7 +14,18 @@
-- High level interface to package installation.
-----------------------------------------------------------------------------
module Distribution.Client.Install (
install
-- * High-level interface
install,
-- * Lower-level interface that allows to manipulate the install plan
makeInstallContext,
makeInstallPlan,
processInstallPlan,
InstallArgs,
InstallContext,
-- * Prune certain packages from the install plan
pruneInstallPlan
) where
import Data.List
......@@ -158,55 +169,89 @@ install verbosity packageDBs repos comp conf
globalFlags configFlags configExFlags installFlags haddockFlags
userTargets0 = do
installContext <- makeInstallContext verbosity args userTargets0
installPlan <- foldProgress logMsg die return =<<
makeInstallPlan verbosity args installContext
processInstallPlan verbosity args installContext installPlan
where
args :: InstallArgs
args = (packageDBs, repos, comp, conf,
globalFlags, configFlags, configExFlags, installFlags,
haddockFlags)
logMsg message rest = debugNoWrap verbosity message >> rest
-- | Common context for makeInstallPlan and processInstallPlan.
type InstallContext = ( PackageIndex, SourcePackageDb
, [UserTarget], [PackageSpecifier SourcePackage] )
-- | Initial arguments given to 'install' or 'makeInstallContext'.
type InstallArgs = ( PackageDBStack
, [Repo]
, Compiler
, ProgramConfiguration
, GlobalFlags
, ConfigFlags
, ConfigExFlags
, InstallFlags
, HaddockFlags )
-- | Make an install context given install arguments.
makeInstallContext :: Verbosity -> InstallArgs -> [UserTarget]
-> IO InstallContext
makeInstallContext verbosity
(packageDBs, repos, comp, conf,
globalFlags, _, _, _, _) userTargets0 = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repos
solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))
(compilerId comp)
let -- For install, if no target is given it means we use the
-- current directory as the single target
userTargets | null userTargets0 = [UserTargetLocalDir "."]
| otherwise = userTargets0
pkgSpecifiers <- resolveUserTargets verbosity
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets
return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers)
-- | Make an install plan given install context and install arguments.
makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext
-> IO (Progress String String InstallPlan)
makeInstallPlan verbosity
(_, _, comp, _,
_, configFlags, configExFlags, installFlags,
_)
(installedPkgIndex, sourcePkgDb,
_, pkgSpecifiers) = do
solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))
(compilerId comp)
notice verbosity "Resolving dependencies..."
installPlan <- foldProgress logMsg die return $
planPackages
comp solver configFlags configExFlags installFlags
installedPkgIndex sourcePkgDb pkgSpecifiers
return $ planPackages comp solver configFlags configExFlags installFlags
installedPkgIndex sourcePkgDb pkgSpecifiers
-- | Given an install plan, perform the actual installations.
processInstallPlan :: Verbosity -> InstallArgs -> InstallContext
-> InstallPlan
-> IO ()
processInstallPlan verbosity
args@(_, _, _, _, _, _, _, installFlags, _)
(installedPkgIndex, sourcePkgDb,
userTargets, pkgSpecifiers) installPlan = do
checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb
installFlags pkgSpecifiers
unless dryRun $ do
installPlan' <- performInstallations verbosity
context installedPkgIndex installPlan
postInstallActions verbosity context userTargets installPlan'
args installedPkgIndex installPlan
postInstallActions verbosity args userTargets installPlan'
where
context :: InstallArgs
context = (packageDBs, repos, comp, conf,
globalFlags, configFlags, configExFlags, installFlags,
haddockFlags)
dryRun = fromFlag (installDryRun installFlags)
logMsg message rest = debugNoWrap verbosity message >> rest
type InstallArgs = ( PackageDBStack
, [Repo]
, Compiler
, ProgramConfiguration
, GlobalFlags
, ConfigFlags
, ConfigExFlags
, InstallFlags
, HaddockFlags )
dryRun = fromFlag (installDryRun installFlags)
-- ------------------------------------------------------------
-- * Installation planning
......
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