/
Dependency.hs
234 lines (209 loc) · 9.5 KB
/
Dependency.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Dependency
-- Copyright : (c) David Himmelstrup 2005,
-- Bjorn Bringert 2007
-- Duncan Coutts 2008
-- License : BSD-like
--
-- Maintainer : cabal-devel@gmail.com
-- Stability : provisional
-- Portability : portable
--
-- Top level interface to dependency resolution.
-----------------------------------------------------------------------------
module Distribution.Client.Dependency (
module Distribution.Client.Dependency.Types,
resolveDependencies,
resolveDependenciesWithProgress,
dependencyConstraints,
dependencyTargets,
PackagesPreference(..),
PackagesPreferenceDefault(..),
PackagePreference(..),
upgradableDependencies,
) where
import Distribution.Client.Dependency.Bogus (bogusResolver)
import Distribution.Client.Dependency.TopDown (topDownResolver)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.Types
( UnresolvedDependency(..), AvailablePackage(..) )
import Distribution.Client.Dependency.Types
( DependencyResolver, PackageConstraint(..)
, PackagePreferences(..), InstalledPreference(..)
, Progress(..), foldProgress )
import Distribution.Package
( PackageIdentifier(..), PackageName(..), packageVersion, packageName
, Dependency(..), Package(..), PackageFixedDeps(..) )
import Distribution.Version
( VersionRange(AnyVersion), orLaterVersion, isAnyVersion )
import Distribution.Compiler
( CompilerId(..) )
import Distribution.System
( Platform )
import Distribution.Simple.Utils (comparing)
import Distribution.Client.Utils (mergeBy, MergeResult(..))
import Data.List (maximumBy)
import Data.Monoid (Monoid(mempty))
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Set (Set)
import Control.Exception (assert)
defaultResolver :: DependencyResolver
defaultResolver = topDownResolver
-- | Global policy for the versions of all packages.
--
data PackagesPreference = PackagesPreference
PackagesPreferenceDefault
[PackagePreference]
dependencyConstraints :: [UnresolvedDependency] -> [PackageConstraint]
dependencyConstraints deps =
[ PackageVersionConstraint name versionRange
| UnresolvedDependency (Dependency name versionRange) _ <- deps
, not (isAnyVersion versionRange) ]
++ [ PackageFlagsConstraint name flags
| UnresolvedDependency (Dependency name _) flags <- deps
, not (null flags) ]
dependencyTargets :: [UnresolvedDependency] -> [PackageName]
dependencyTargets deps =
[ name | UnresolvedDependency (Dependency name _) _ <- deps ]
-- | Global policy for all packages to say if we prefer package versions that
-- are already installed locally or if we just prefer the latest available.
--
data PackagesPreferenceDefault =
-- | Always prefer the latest version irrespective of any existing
-- installed version.
--
-- * This is the standard policy for upgrade.
--
PreferAllLatest
-- | Always prefer the installed versions over ones that would need to be
-- installed. Secondarily, prefer latest versions (eg the latest installed
-- version or if there are none then the latest available version).
| PreferAllInstalled
-- | Prefer the latest version for packages that are explicitly requested
-- but prefers the installed version for any other packages.
--
-- * This is the standard policy for install.
--
| PreferLatestForSelected
data PackagePreference
= PackageVersionPreference PackageName VersionRange
| PackageInstalledPreference PackageName InstalledPreference
resolveDependencies :: Platform
-> CompilerId
-> Maybe (PackageIndex InstalledPackageInfo)
-> PackageIndex AvailablePackage
-> PackagesPreference
-> [PackageConstraint]
-> [PackageName]
-> Either String InstallPlan
resolveDependencies platform comp installed available
preferences constraints targets =
foldProgress (flip const) Left Right $
resolveDependenciesWithProgress platform comp installed available
preferences constraints targets
resolveDependenciesWithProgress :: Platform
-> CompilerId
-> Maybe (PackageIndex InstalledPackageInfo)
-> PackageIndex AvailablePackage
-> PackagesPreference
-> [PackageConstraint]
-> [PackageName]
-> Progress String String InstallPlan
resolveDependenciesWithProgress platform comp (Just installed) =
dependencyResolver defaultResolver platform comp installed
resolveDependenciesWithProgress platform comp Nothing =
dependencyResolver bogusResolver platform comp mempty
hideBrokenPackages :: PackageFixedDeps p => PackageIndex p -> PackageIndex p
hideBrokenPackages index =
check (null . PackageIndex.brokenPackages)
. foldr (PackageIndex.deletePackageId . packageId) index
. PackageIndex.reverseDependencyClosure index
. map (packageId . fst)
$ PackageIndex.brokenPackages index
where
check p x = assert (p x) x
dependencyResolver
:: DependencyResolver
-> Platform -> CompilerId
-> PackageIndex InstalledPackageInfo
-> PackageIndex AvailablePackage
-> PackagesPreference
-> [PackageConstraint]
-> [PackageName]
-> Progress String String InstallPlan
dependencyResolver resolver platform comp installed available
pref constraints targets =
let installed' = hideBrokenPackages installed
-- If the user is not explicitly asking to upgrade base then lets
-- prevent that from happening accidentally since it is usually not what
-- you want and it probably does not work anyway. We do it by adding a
-- constraint to only pick an installed version of base and ghc-prim.
extraConstraints =
[ PackageInstalledConstraint pkgname
| all (/=PackageName "base") targets
, pkgname <- [ PackageName "base", PackageName "ghc-prim" ]
, not (null (PackageIndex.lookupPackageName installed pkgname)) ]
preferences = interpretPackagesPreference (Set.fromList targets) pref
in fmap toPlan
$ resolver platform comp installed' available
preferences (extraConstraints ++ constraints) targets
where
toPlan pkgs =
case InstallPlan.new platform comp (PackageIndex.fromList pkgs) of
Right plan -> plan
Left problems -> error $ unlines $
"internal error: could not construct a valid install plan."
: "The proposed (invalid) plan contained the following problems:"
: map InstallPlan.showPlanProblem problems
-- | Give an interpretation to the global 'PackagesPreference' as
-- specific per-package 'PackageVersionPreference'.
--
interpretPackagesPreference :: Set PackageName
-> PackagesPreference
-> (PackageName -> PackagePreferences)
interpretPackagesPreference selected (PackagesPreference defaultPref prefs) =
\pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname)
where
versionPref pkgname =
fromMaybe AnyVersion (Map.lookup pkgname versionPrefs)
versionPrefs = Map.fromList
[ (pkgname, pref)
| PackageVersionPreference pkgname pref <- prefs ]
installPref pkgname =
fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)
installPrefs = Map.fromList
[ (pkgname, pref)
| PackageInstalledPreference pkgname pref <- prefs ]
installPrefDefault = case defaultPref of
PreferAllLatest -> \_ -> PreferLatest
PreferAllInstalled -> \_ -> PreferInstalled
PreferLatestForSelected -> \pkgname ->
-- When you say cabal install foo, what you really mean is, prefer the
-- latest version of foo, but the installed version of everything else
if pkgname `Set.member` selected then PreferLatest
else PreferInstalled
-- | Given the list of installed packages and available packages, figure
-- out which packages can be upgraded.
--
upgradableDependencies :: PackageIndex InstalledPackageInfo
-> PackageIndex AvailablePackage
-> [Dependency]
upgradableDependencies installed available =
[ Dependency name (orLaterVersion latestVersion)
-- This is really quick (linear time). The trick is that we're doing a
-- merge join of two tables. We can do it as a merge because they're in
-- a comparable order because we're getting them from the package indexs.
| InBoth latestInstalled allAvailable
<- mergeBy (\a (b:_) -> packageName a `compare` packageName b)
[ maximumBy (comparing packageVersion) pkgs
| pkgs <- PackageIndex.allPackagesByName installed ]
(PackageIndex.allPackagesByName available)
, let (PackageIdentifier name latestVersion) = packageId latestInstalled
, any (\p -> packageVersion p > latestVersion) allAvailable ]