Commit 3bdb811c authored by Duncan Coutts's avatar Duncan Coutts

Add a install/upgrade --preference='foo < 2' flag

This behaves just like the preferred-versions file in the hackage index
but it can be specified on the command line or in a config file.
parent 5c854636
......@@ -21,7 +21,6 @@ module Distribution.Client.Dependency (
dependencyTargets,
PackagesPreference(..),
packagesPreference,
PackagesPreferenceDefault(..),
PackagePreference(..),
......@@ -57,7 +56,6 @@ import Data.List (maximumBy)
import Data.Monoid (Monoid(mempty))
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import Data.Set (Set)
import Control.Exception (assert)
......@@ -71,13 +69,6 @@ data PackagesPreference = PackagesPreference
PackagesPreferenceDefault
[PackagePreference]
packagesPreference :: PackagesPreferenceDefault
-> Map PackageName VersionRange
-> PackagesPreference
packagesPreference defaultPref versionPrefs =
PackagesPreference defaultPref [ PackageVersionPreference name ver
| (name, ver) <- Map.toList versionPrefs ]
dependencyConstraints :: [UnresolvedDependency] -> [PackageConstraint]
dependencyConstraints deps =
[ PackageVersionConstraint name versionRange
......
......@@ -28,7 +28,8 @@ import Distribution.Client.Types
import Distribution.Client.Dependency
( resolveDependenciesWithProgress
, dependencyConstraints, dependencyTargets
, packagesPreference, PackagesPreferenceDefault(..) )
, PackagesPreference(..), PackagesPreferenceDefault(..)
, PackagePreference(..) )
import Distribution.Client.Dependency.Types
( foldProgress )
import Distribution.Client.IndexUtils as IndexUtils
......@@ -55,6 +56,7 @@ import Distribution.Text
import Distribution.Verbosity
( Verbosity )
import qualified Data.Map as Map
import Control.Monad
( when, filterM )
import System.Directory
......@@ -150,7 +152,7 @@ fetch :: Verbosity
-> IO ()
fetch verbosity packageDB repos comp conf deps = do
installed <- getInstalledPackages verbosity comp packageDB conf
AvailablePackageDb available versionPref
AvailablePackageDb available availablePrefs
<- getAvailablePackages verbosity repos
deps' <- IndexUtils.disambiguateDependencies available deps
......@@ -166,7 +168,9 @@ fetch verbosity packageDB repos comp conf deps = do
let progress = resolveDependenciesWithProgress
buildPlatform (compilerId comp)
installed' available
(packagesPreference PreferLatestForSelected versionPref)
(PackagesPreference PreferLatestForSelected
[ PackageVersionPreference name ver
| (name, ver) <- Map.toList availablePrefs ])
(dependencyConstraints deps')
(dependencyTargets deps')
notice verbosity "Resolving dependencies..."
......
......@@ -19,6 +19,7 @@ import Data.List
( unfoldr, find, nub, sort )
import Data.Maybe
( isJust, fromMaybe )
import qualified Data.Map as Map
import Control.Exception as Exception
( handle, handleJust, Exception(IOException) )
import Control.Monad
......@@ -35,7 +36,8 @@ import System.IO.Error
import Distribution.Client.Dependency
( resolveDependenciesWithProgress
, PackageConstraint(..), dependencyConstraints, dependencyTargets
, packagesPreference, PackagesPreferenceDefault(..)
, PackagesPreference(..), PackagesPreferenceDefault(..)
, PackagePreference(..)
, upgradableDependencies
, Progress(..), foldProgress, )
import Distribution.Client.Fetch (fetchPackage)
......@@ -81,7 +83,7 @@ import Distribution.Simple.InstallDirs
( fromPathTemplate, toPathTemplate
, initialPathTemplateEnv, substPathTemplate )
import Distribution.Package
( PackageIdentifier, packageName, packageVersion
( PackageName, PackageIdentifier, packageName, packageVersion
, Package(..), PackageFixedDeps(..)
, Dependency(..), thisPackageVersion )
import qualified Distribution.PackageDescription as PackageDescription
......@@ -128,7 +130,8 @@ install verbosity packageDB repos comp conf configFlags installFlags deps =
verbosity packageDB repos comp conf configFlags installFlags
where
planner :: Planner
planner | null deps = planLocalPackage verbosity comp configFlags
planner | null deps = planLocalPackage verbosity
comp configFlags installFlags
| otherwise = planRepoPackages PreferLatestForSelected
comp configFlags installFlags deps
......@@ -137,7 +140,7 @@ upgrade verbosity packageDB repos comp conf configFlags installFlags deps =
verbosity packageDB repos comp conf configFlags installFlags
where
planner :: Planner
planner | null deps = planUpgradePackages comp configFlags
planner | null deps = planUpgradePackages comp configFlags installFlags
| otherwise = planRepoPackages PreferAllLatest
comp configFlags installFlags deps
......@@ -266,9 +269,10 @@ storeDetailedBuildReports verbosity logsDir reports = sequence_
-- | Make an 'InstallPlan' for the unpacked package in the current directory,
-- and all its dependencies.
--
planLocalPackage :: Verbosity -> Compiler -> Cabal.ConfigFlags -> Planner
planLocalPackage verbosity comp configFlags installed
(AvailablePackageDb available versionPrefs) = do
planLocalPackage :: Verbosity -> Compiler
-> Cabal.ConfigFlags -> InstallFlags -> Planner
planLocalPackage verbosity comp configFlags installFlags 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
......@@ -281,17 +285,18 @@ planLocalPackage verbosity comp configFlags installed
Available.packageDescription = pkg,
packageSource = LocalUnpackedPackage
}
targets = [packageName pkg]
constraints = [PackageVersionConstraint (packageName pkg)
(ThisVersion (packageVersion pkg))
,PackageFlagsConstraint (packageName pkg)
(Cabal.configConfigurationsFlags configFlags)]
++ [ PackageVersionConstraint name ver
| Dependency name ver <- Cabal.configConstraints configFlags ]
preferences = mergePackagePrefs PreferLatestForSelected
availablePrefs installFlags
return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)
installed' available'
(packagesPreference PreferLatestForSelected versionPrefs)
constraints [packageName pkg]
installed' available' preferences constraints targets
-- | Make an 'InstallPlan' for the given dependencies.
--
......@@ -299,7 +304,7 @@ planRepoPackages :: PackagesPreferenceDefault -> Compiler
-> Cabal.ConfigFlags -> InstallFlags
-> [UnresolvedDependency] -> Planner
planRepoPackages defaultPref comp configFlags installFlags deps installed
(AvailablePackageDb available versionPrefs) = do
(AvailablePackageDb available availablePrefs) = do
deps' <- IndexUtils.disambiguateDependencies available deps
let installed'
| Cabal.fromFlagOrDefault False (installReinstall installFlags)
......@@ -309,35 +314,46 @@ planRepoPackages defaultPref comp configFlags installFlags deps installed
constraints = dependencyConstraints deps'
++ [ PackageVersionConstraint name ver
| Dependency name ver <- Cabal.configConstraints configFlags ]
preferences = mergePackagePrefs defaultPref availablePrefs installFlags
return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)
installed' available
(packagesPreference defaultPref versionPrefs)
constraints targets
installed' available preferences constraints targets
where
hideGivenDeps pkgs index =
foldr PackageIndex.deletePackageName index
[ name | UnresolvedDependency (Dependency name _) _ <- pkgs ]
planUpgradePackages :: Compiler -> Cabal.ConfigFlags -> Planner
planUpgradePackages comp configFlags (Just installed)
(AvailablePackageDb available versionPrefs) = return $
planUpgradePackages :: Compiler -> Cabal.ConfigFlags -> InstallFlags -> Planner
planUpgradePackages comp configFlags installFlags (Just installed)
(AvailablePackageDb available availablePrefs) = return $
resolveDependenciesWithProgress buildPlatform (compilerId comp)
(Just installed) available
(packagesPreference PreferAllLatest versionPrefs)
constraints targets
(Just installed) available preferences constraints targets
where
deps = upgradableDependencies installed available
preferences = mergePackagePrefs PreferAllLatest availablePrefs installFlags
constraints = [ PackageVersionConstraint name ver
| Dependency name ver <- deps ]
++ [ PackageVersionConstraint name ver
| Dependency name ver <- Cabal.configConstraints configFlags ]
targets = [ name | Dependency name _ <- deps ]
planUpgradePackages comp _ _ _ =
planUpgradePackages comp _ _ _ _ =
die $ display (compilerId comp)
++ " does not track installed packages so cabal cannot figure out what"
++ " packages need to be upgraded."
mergePackagePrefs :: PackagesPreferenceDefault
-> Map.Map PackageName VersionRange
-> InstallFlags
-> PackagesPreference
mergePackagePrefs defaultPref availablePrefs installFlags =
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 <- installPreferences installFlags ]
printDryRun :: Verbosity -> Maybe (PackageIndex InstalledPackageInfo)
-> InstallPlan -> IO ()
printDryRun verbosity minstalled plan = case unfoldr next plan of
......
......@@ -377,7 +377,8 @@ data InstallFlags = InstallFlags {
installCabalVersion :: Flag Version,
installLogFile :: Flag FilePath,
installBuildReports :: Flag Bool,
installSymlinkBinDir:: Flag FilePath
installSymlinkBinDir:: Flag FilePath,
installPreferences :: [Dependency]
}
defaultInstallFlags :: InstallFlags
......@@ -390,7 +391,8 @@ defaultInstallFlags = InstallFlags {
installCabalVersion = mempty,
installLogFile = mempty,
installBuildReports = Flag False,
installSymlinkBinDir= mempty
installSymlinkBinDir= mempty,
installPreferences = mempty
}
installCommand :: CommandUI (Cabal.ConfigFlags, InstallFlags)
......@@ -449,6 +451,13 @@ installOptions showOrParseArgs =
installBuildReports (\v flags -> flags { installBuildReports = v })
trueArg
, option [] ["preference"]
"Specify preferences (soft constraints) on the version of a package"
installPreferences (\v flags -> flags { installPreferences = v })
(reqArg "DEPENDENCY"
(readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse))
(map (\x -> display x)))
] ++ case showOrParseArgs of -- TODO: remove when "cabal install" avoids
ParseArgs ->
option [] ["only"]
......@@ -468,7 +477,8 @@ instance Monoid InstallFlags where
installCabalVersion = mempty,
installLogFile = mempty,
installBuildReports = mempty,
installSymlinkBinDir= mempty
installSymlinkBinDir= mempty,
installPreferences = mempty
}
mappend a b = InstallFlags {
installDocumentation= combine installDocumentation,
......@@ -479,7 +489,8 @@ instance Monoid InstallFlags where
installCabalVersion = combine installCabalVersion,
installLogFile = combine installLogFile,
installBuildReports = combine installBuildReports,
installSymlinkBinDir= combine installSymlinkBinDir
installSymlinkBinDir= combine installSymlinkBinDir,
installPreferences = combine installPreferences
}
where combine field = field a `mappend` field b
......
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