Commit c0f947c4 authored by Duncan Coutts's avatar Duncan Coutts

Use the new modular dep resolver interface in the various commands

Also minor tweak to InstallPlan.remove
parent 2af56476
......@@ -14,16 +14,7 @@ module Distribution.Client.Configure (
configure,
) where
import Data.Monoid
( Monoid(mempty) )
import qualified Data.Map as Map
import Distribution.Client.Dependency
( resolveDependenciesWithProgress
, PackageConstraint(..)
, PackagesPreference(..), PackagesPreferenceDefault(..)
, PackagePreference(..)
, Progress(..), foldProgress, )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.IndexUtils as IndexUtils
......@@ -40,19 +31,17 @@ import Distribution.Simple.Compiler
import Distribution.Simple.Program (ProgramConfiguration )
import Distribution.Simple.Setup
( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault )
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Client.PackageIndex (PackageIndex)
import Distribution.Simple.Utils
( defaultPackageDesc )
import Distribution.Package
( PackageName, packageName, packageVersion
, Package(..), Dependency(..), thisPackageVersion )
( Package(..), packageName, Dependency(..), thisPackageVersion )
import Distribution.PackageDescription.Parse
( readPackageDescription )
import Distribution.PackageDescription.Configuration
( finalizePackageDescription )
import Distribution.Version
( VersionRange, anyVersion, thisVersion )
( anyVersion, thisVersion )
import Distribution.Simple.Utils as Utils
( notice, info, die )
import Distribution.System
......@@ -130,45 +119,38 @@ planLocalPackage :: Verbosity -> Compiler
-> AvailablePackageDb
-> IO (Progress String String InstallPlan)
planLocalPackage verbosity comp configFlags configExFlags installed
(AvailablePackageDb _ availablePrefs) = do
availabledb = do
pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity
let -- The trick is, we add the local package to the available index and
-- remove it from the installed index. Then we ask to resolve a
-- dependency on exactly that package. So the resolver ends up having
-- to pick the local package.
available' = PackageIndex.insert localPkg mempty
installed' = PackageIndex.deletePackageId (packageId localPkg) installed
let -- We create a local package and ask to resolve a dependency on it
localPkg = AvailablePackage {
packageInfoId = packageId pkg,
Available.packageDescription = pkg,
packageSource = LocalUnpackedPackage "."
}
targets = [packageName pkg]
constraints = [PackageVersionConstraint (packageName pkg)
(thisVersion (packageVersion pkg))
,PackageFlagsConstraint (packageName pkg)
(configConfigurationsFlags configFlags)]
++ [ PackageVersionConstraint name ver
| Dependency name ver <- configConstraints configFlags ]
preferences = mergePackagePrefs PreferLatestForSelected
availablePrefs configExFlags
return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)
installed' available' preferences constraints targets
mergePackagePrefs :: PackagesPreferenceDefault
-> Map.Map PackageName VersionRange
-> ConfigExFlags
-> PackagesPreference
mergePackagePrefs defaultPref availablePrefs configExFlags =
PackagesPreference defaultPref $
-- The preferences that come from the hackage index
[ PackageVersionPreference name ver
| (name, ver) <- Map.toList availablePrefs ]
-- additional preferences from the config file or command line
++ [ PackageVersionPreference name ver
| Dependency name ver <- configPreferences configExFlags ]
resolverParams =
addPreferences
-- preferences from the config file or command line
[ PackageVersionPreference name ver
| Dependency name ver <- configPreferences configExFlags ]
. addConstraints
-- version constraints from the config file or command line
[ PackageVersionConstraint name ver
| Dependency name ver <- configConstraints configFlags ]
. addConstraints
-- package flags from the config file or command line
[ PackageFlagsConstraint (packageName pkg)
(configConfigurationsFlags configFlags) ]
$ standardInstallPolicy installed availabledb
[SpecificSourcePackage localPkg]
return (resolveDependencies buildPlatform (compilerId comp) resolverParams)
-- | Call an installer for an 'AvailablePackage' but override the configure
-- flags with the ones given by the 'ConfiguredPackage'. In particular the
......
......@@ -16,26 +16,18 @@ module Distribution.Client.Fetch (
) where
import Distribution.Client.Types
import Distribution.Client.FetchUtils
import Distribution.Client.Targets
import Distribution.Client.FetchUtils hiding (fetchPackage)
import Distribution.Client.Dependency
import Distribution.Client.PackageIndex (PackageIndex)
import Distribution.Client.Dependency as Dependency
( resolveDependenciesWithProgress
, resolveAvailablePackages
, dependencyConstraints, dependencyTargets
, PackagesPreference(..), PackagesPreferenceDefault(..)
, PackagePreference(..) )
import Distribution.Client.Dependency.Types
( foldProgress )
import Distribution.Client.IndexUtils as IndexUtils
( getAvailablePackages, disambiguateDependencies
, getInstalledPackages )
( getAvailablePackages, getInstalledPackages )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.Setup
( FetchFlags(..) )
( GlobalFlags(..), FetchFlags(..) )
import Distribution.Package
( packageId, Dependency(..) )
import qualified Distribution.Client.PackageIndex as PackageIndex
( packageId )
import Distribution.Simple.Compiler
( Compiler(compilerId), PackageDBStack )
import Distribution.Simple.Program
......@@ -51,14 +43,23 @@ import Distribution.Text
import Distribution.Verbosity
( Verbosity )
import qualified Data.Map as Map
import Control.Monad
( when, filterM )
( filterM )
-- ------------------------------------------------------------
-- * The fetch command
-- ------------------------------------------------------------
--TODO:
-- * add fetch -o support
-- * support tarball URLs via ad-hoc download cache (or in -o mode?)
-- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied
-- * Port various flags from install:
-- * --updage-dependencies
-- * --constraint and --preference
-- * --only-dependencies, but note it conflicts with --no-deps
-- | Fetch a list of packages and their dependencies.
--
fetch :: Verbosity
......@@ -66,101 +67,105 @@ fetch :: Verbosity
-> [Repo]
-> Compiler
-> ProgramConfiguration
-> GlobalFlags
-> FetchFlags
-> [UnresolvedDependency]
-> [UserTarget]
-> IO ()
fetch verbosity _ _ _ _ _ [] =
notice verbosity "No packages requested. Nothing to do."
fetch verbosity packageDBs repos comp conf flags deps = do
installed <- getInstalledPackages verbosity comp packageDBs conf
availableDb@(AvailablePackageDb available _)
<- getAvailablePackages verbosity repos
deps' <- IndexUtils.disambiguateDependencies available deps
pkgs <- resolvePackages verbosity
includeDeps comp
installed availableDb deps'
pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs
when (null pkgs') $
notice verbosity $ "No packages need to be fetched. "
++ "All the requested packages are already cached."
if dryRun
then notice verbosity $ unlines $
"The following packages would be fetched:"
: map (display . packageId) pkgs'
else sequence_
[ fetchRepoTarball verbosity repo pkgid
| (AvailablePackage pkgid _ (RepoTarballPackage repo _ _)) <- pkgs' ]
where
includeDeps = fromFlag (fetchDeps flags)
dryRun = fromFlag (fetchDryRun flags)
fetch verbosity _ _ _ _ _ _ [] =
notice verbosity "No packages requested. Nothing to do."
fetch verbosity packageDBs repos comp conf
globalFlags fetchFlags userTargets = do
resolvePackages
:: Verbosity
-> Bool
-> Compiler
-> PackageIndex InstalledPackage
-> AvailablePackageDb
-> [UnresolvedDependency]
-> IO [AvailablePackage]
resolvePackages verbosity includeDependencies comp
installed (AvailablePackageDb available availablePrefs) deps
mapM_ checkTarget userTargets
| includeDependencies = do
installed <- getInstalledPackages verbosity comp packageDBs conf
availableDb <- getAvailablePackages verbosity repos
pkgSpecifiers <- resolveUserTargets verbosity
globalFlags (packageIndex availableDb) userTargets
pkgs <- planPackages
verbosity comp fetchFlags
installed availableDb pkgSpecifiers
pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs
if null pkgs'
--TODO: when we add support for remote tarballs then this message
-- will need to be changed because for remote tarballs we fetch them
-- at the earlier phase.
then notice verbosity $ "No packages need to be fetched. "
++ "All the requested packages are already local "
++ "or cached locally."
else if dryRun
then notice verbosity $ unlines $
"The following packages would be fetched:"
: map (display . packageId) pkgs'
else mapM_ (fetchPackage verbosity . packageSource) pkgs'
where
dryRun = fromFlag (fetchDryRun fetchFlags)
planPackages :: Verbosity
-> Compiler
-> FetchFlags
-> PackageIndex InstalledPackage
-> AvailablePackageDb
-> [PackageSpecifier AvailablePackage]
-> IO [AvailablePackage]
planPackages verbosity comp fetchFlags
installed availableDb pkgSpecifiers
| includeDependencies = do
notice verbosity "Resolving dependencies..."
plan <- foldProgress logMsg die return $
resolveDependenciesWithProgress
buildPlatform (compilerId comp)
installed' available
preferences constraints
targets
--TODO: suggest using --no-deps, unpack or fetch -o
-- if cannot satisfy deps
--TODO: add commandline constraint and preference args for fetch
return (selectPackagesToFetch plan)
| otherwise = do
either (die . unlines . map show) return $
resolveAvailablePackages
installed available
preferences constraints
targets
installPlan <- foldProgress logMsg die return $
resolveDependencies
buildPlatform (compilerId comp)
resolverParams
-- The packages we want to fetch are those packages the 'InstallPlan'
-- that are in the 'InstallPlan.Configured' state.
return
[ pkg
| (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _))
<- InstallPlan.toList installPlan ]
| otherwise =
either (die . unlines . map show) return $
resolveWithoutDependencies resolverParams
where
targets = dependencyTargets deps
constraints = dependencyConstraints deps
preferences = PackagesPreference
PreferLatestForSelected
[ PackageVersionPreference name ver
| (name, ver) <- Map.toList availablePrefs ]
installed' = hideGivenDeps deps installed
-- Hide the packages given on the command line so that the dep resolver
-- will decide that they need fetching, even if they're already
-- installed. Sicne we want to get the source packages of things we might
-- have installed (but not have the sources for).
-- TODO: to allow for preferences on selecting an available version
-- corresponding to a package we've got installed, instead of hiding the
-- installed instances, we should add a constraint on using an installed
-- instance.
hideGivenDeps pkgs index =
foldr PackageIndex.deletePackageName index
[ name | UnresolvedDependency (Dependency name _) _ <- pkgs ]
-- The packages we want to fetch are those packages the 'InstallPlan' that
-- are in the 'InstallPlan.Configured' state.
selectPackagesToFetch :: InstallPlan.InstallPlan -> [AvailablePackage]
selectPackagesToFetch plan =
[ pkg | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _))
<- InstallPlan.toList plan ]
resolverParams =
-- Reinstall the targets given on the command line so that the dep
-- resolver will decide that they need fetching, even if they're
-- already installed. Sicne we want to get the source packages of
-- things we might have installed (but not have the sources for).
reinstallTargets
$ standardInstallPolicy installed availableDb pkgSpecifiers
includeDependencies = fromFlag (fetchDeps fetchFlags)
logMsg message rest = info verbosity message >> rest
checkTarget :: UserTarget -> IO ()
checkTarget target = case target of
UserTargetRemoteTarball _uri
-> die $ "The 'fetch' command does not yet support remote tarballs. "
++ "In the meantime you can use the 'unpack' commands."
_ -> return ()
fetchPackage :: Verbosity -> PackageLocation a -> IO ()
fetchPackage verbosity pkgsrc = case pkgsrc of
LocalUnpackedPackage _dir -> return ()
LocalTarballPackage _file -> return ()
RemoteTarballPackage _uri _ ->
die $ "The 'fetch' command does not yet support remote tarballs. "
++ "In the meantime you can use the 'unpack' commands."
RepoTarballPackage repo pkgid _ -> do
_ <- fetchRepoTarball verbosity repo pkgid
return ()
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Install
......@@ -18,10 +19,9 @@ module Distribution.Client.Install (
) where
import Data.List
( unfoldr, find, nub, sort, partition )
( unfoldr, find, nub, sort )
import Data.Maybe
( isJust, fromMaybe )
import qualified Data.Map as Map
import Control.Exception as Exception
( handleJust )
#if MIN_VERSION_base(4,0,0)
......@@ -46,18 +46,13 @@ import System.IO
import System.IO.Error
( isDoesNotExistError, ioeGetFileName )
import Distribution.Client.Targets
import Distribution.Client.Dependency
( resolveDependenciesWithProgress
, PackageConstraint(..), dependencyConstraints, dependencyTargets
, PackagesPreference(..), PackagesPreferenceDefault(..)
, PackagePreference(..)
, Progress(..), foldProgress, )
import Distribution.Client.FetchUtils
import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)
-- import qualified Distribution.Client.Info as Info
import Distribution.Client.IndexUtils as IndexUtils
( getAvailablePackages, disambiguateDependencies
, getInstalledPackages )
( getAvailablePackages, getInstalledPackages )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.Setup
......@@ -95,23 +90,21 @@ import Distribution.Simple.Setup
import qualified Distribution.Simple.Setup as Cabal
( installCommand, InstallFlags(..), emptyInstallFlags )
import Distribution.Simple.Utils
( defaultPackageDesc, rawSystemExit, comparing )
( rawSystemExit, comparing )
import Distribution.Simple.InstallDirs as InstallDirs
( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate
, initialPathTemplateEnv, installDirsTemplateEnv )
import Distribution.Package
( PackageName(..), PackageIdentifier, packageName, packageVersion
( PackageIdentifier, packageName, packageVersion
, Package(..), PackageFixedDeps(..)
, Dependency(..), thisPackageVersion )
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription
( PackageDescription )
import Distribution.PackageDescription.Parse
( readPackageDescription )
import Distribution.PackageDescription.Configuration
( finalizePackageDescription )
import Distribution.Version
( Version, VersionRange, anyVersion, thisVersion )
( Version, anyVersion, thisVersion )
import Distribution.Simple.Utils as Utils
( notice, info, warn, die, intercalate, withTempDirectory )
import Distribution.Client.Utils
......@@ -125,8 +118,6 @@ import Distribution.Verbosity as Verbosity
import Distribution.Simple.BuildPaths ( exeExtension )
--TODO:
-- * add --upgrade-deps flag
-- * eliminate upgrade, replaced by --upgrade-deps and world target
-- * assign flags to packages individually
-- * complain about flags that do not apply to any package given as target
-- so flags do not apply to dependencies, only listed, can use flag
......@@ -142,12 +133,6 @@ import Distribution.Simple.BuildPaths ( exeExtension )
-- * Top level user actions
-- ------------------------------------------------------------
-- | An installation target given by the user. At the moment this
-- is just a named package, possibly with a version constraint.
-- It should be generalised to handle other targets like http or dirs.
--
type InstallTarget = UnresolvedDependency
-- | Installs the packages needed to satisfy a list of dependencies.
--
install, upgrade
......@@ -160,32 +145,42 @@ install, upgrade
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> [InstallTarget]
-> [UserTarget]
-> IO ()
install verbosity packageDB repos comp conf
globalFlags configFlags configExFlags installFlags targets =
install verbosity packageDBs repos comp conf
globalFlags configFlags configExFlags installFlags userTargets0 = do
installWithPlanner verbosity context (planner onlyDeps) targets
installed <- getInstalledPackages verbosity comp packageDBs conf
availableDb <- getAvailablePackages verbosity repos
where
context :: InstallContext
context = (packageDB, repos, comp, conf,
globalFlags, configFlags, configExFlags, installFlags)
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
globalFlags (packageIndex availableDb) userTargets
onlyDeps = fromFlag (installOnlyDeps installFlags)
notice verbosity "Resolving dependencies..."
installPlan <- foldProgress logMsg die return $
planPackages
comp configFlags configExFlags installFlags
installed availableDb pkgSpecifiers
planner :: Bool -> Planner
planner
| null targets = planLocalPackage verbosity
comp configFlags configExFlags
printPlanMessages verbosity installed installPlan dryRun
| otherwise = planRepoPackages defaultPref
comp globalFlags configFlags configExFlags
installFlags targets
unless dryRun $ do
installPlan' <- performInstallations verbosity
context installed installPlan
postInstallActions verbosity context userTargets installPlan'
where
context :: InstallContext
context = (packageDBs, repos, comp, conf,
globalFlags, configFlags, configExFlags, installFlags)
defaultPref
| fromFlag (installUpgradeDeps installFlags) = PreferAllLatest
| otherwise = PreferLatestForSelected
dryRun = fromFlag (installDryRun installFlags)
logMsg message rest = info verbosity message >> rest
upgrade _ _ _ _ _ _ _ _ _ _ = die $
......@@ -201,11 +196,6 @@ upgrade _ _ _ _ _ _ _ _ _ _ = die $
++ "--upgrade-dependencies, it is recommended that you do not upgrade core "
++ "packages (e.g. by using appropriate --constraint= flags)."
type Planner = PackageIndex InstalledPackage
-> AvailablePackageDb
-> IO (Progress String String InstallPlan)
type InstallContext = ( PackageDBStack
, [Repo]
, Compiler
......@@ -215,162 +205,85 @@ type InstallContext = ( PackageDBStack
, ConfigExFlags
, InstallFlags )
-- | Top-level orchestration. Installs the packages generated by a planner.
--
installWithPlanner :: Verbosity
-> InstallContext
-> Planner
-> [UnresolvedDependency]
-> IO ()
installWithPlanner verbosity
context@(packageDBs, repos, comp, conf, _, _, _, installFlags)
planner targets = do
installed <- getInstalledPackages verbosity comp packageDBs conf
available <- getAvailablePackages verbosity repos
notice verbosity "Resolving dependencies..."
installPlan <- foldProgress logMsg die return =<< planner installed available
printPlanMessages verbosity installed installPlan dryRun
unless dryRun $
performInstallations verbosity context installed installPlan
>>= postInstallActions verbosity context targets
where
dryRun = fromFlag (installDryRun installFlags)
logMsg message rest = info verbosity message >> rest
-- ------------------------------------------------------------
-- * Installation planning
-- ------------------------------------------------------------
-- | Make an 'InstallPlan' for the unpacked package in the current directory,
-- and all its dependencies.
--
planLocalPackage :: Verbosity
-> Compiler
-> ConfigFlags
-> ConfigExFlags
-> Bool
-> Planner
planLocalPackage verbosity comp configFlags configExFlags onlyDeps installed
(AvailablePackageDb available availablePrefs) = do
pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity
let -- The trick is, we add the local package to the available index and
-- remove it from the installed index. Then we ask to resolve a
-- dependency on exactly that package. So the resolver ends up having
-- to pick the local package.
available' = PackageIndex.insert localPkg available
installed' = PackageIndex.deletePackageId (packageId localPkg) installed
localPkg = AvailablePackage {
packageInfoId = packageId pkg,
Available.packageDescription = pkg,
packageSource = LocalUnpackedPackage "."
}
targets = [packageName pkg]
constraints = [PackageVersionConstraint (packageName pkg)
(thisVersion (packageVersion pkg))
,PackageFlagsConstraint (packageName pkg)
(configConfigurationsFlags configFlags)]
++ [ PackageVersionConstraint name ver
| Dependency name ver <- configConstraints configFlags ]
preferences = mergePackagePrefs PreferLatestForSelected
availablePrefs configExFlags
plan = resolveDependenciesWithProgress buildPlatform
(compilerId comp)
installed' available' preferences constraints targets
isLocalPackage = (== localPackageName) . packageName
localPackageName = packageName pkg
-- If we only want dependencies, then remove the local package from
-- the install plan after we have built it.
return $ if onlyDeps then removeFromPlan isLocalPackage plan else plan
-- | Make an 'InstallPlan' for the given dependencies.
--
planRepoPackages :: PackagesPreferenceDefault
-> Compiler
-> GlobalFlags
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> [UnresolvedDependency]
-> Bool
-> Planner
planRepoPackages defaultPref comp