Dependency.hs 41 KB
Newer Older
1
2
-----------------------------------------------------------------------------
-- |
3
-- Module      :  Distribution.Client.Dependency
4
5
6
-- Copyright   :  (c) David Himmelstrup 2005,
--                    Bjorn Bringert 2007
--                    Duncan Coutts 2008
7
8
-- License     :  BSD-like
--
9
-- Maintainer  :  cabal-devel@gmail.com
10
11
12
-- Stability   :  provisional
-- Portability :  portable
--
13
-- Top level interface to dependency resolution.
14
-----------------------------------------------------------------------------
15
module Distribution.Client.Dependency (
16
    -- * The main package dependency resolver
17
    chooseSolver,
18
    resolveDependencies,
19
20
    Progress(..),
    foldProgress,
21

22
23
    -- * Alternate, simple resolver that does not do dependencies recursively
    resolveWithoutDependencies,
24

25
    -- * Constructing resolver policies
26
    PackageProperty(..),
27
    PackageConstraint(..),
28
    scopeToplevel,
29
30
    PackagesPreferenceDefault(..),
    PackagePreference(..),
31
32

    -- ** Standard policy
33
    basicInstallPolicy,
34
35
36
    standardInstallPolicy,
    PackageSpecifier(..),

37
    -- ** Sandbox policy
38
    applySandboxInstallPolicy,
39

40
41
42
43
44
45
46
47
    -- ** Extra policy options
    upgradeDependencies,
    reinstallTargets,

    -- ** Policy utils
    addConstraints,
    addPreferences,
    setPreferenceDefault,
Andres Löh's avatar
Andres Löh committed
48
    setReorderGoals,
49
    setCountConflicts,
50
    setIndependentGoals,
51
    setAvoidReinstalls,
52
    setShadowPkgs,
Andres Löh's avatar
Andres Löh committed
53
    setStrongFlags,
54
    setAllowBootLibInstalls,
Andres Löh's avatar
Andres Löh committed
55
    setMaxBackjumps,
56
    setEnableBackjumping,
57
    setSolveExecutables,
58
    setGoalOrder,
59
    setSolverVerbosity,
60
    removeLowerBounds,
61
62
    removeUpperBounds,
    addDefaultSetupDependencies,
63
    addSetupCabalMinVersionConstraint,
64
  ) where
65

66
import Distribution.Solver.Modular
Andres Löh's avatar
Andres Löh committed
67
         ( modularResolver, SolverConfig(..) )
68
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
69
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
70
71
import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
72
import Distribution.Client.Types
73
         ( SourcePackageDb(SourcePackageDb)
74
         , PackageSpecifier(..), pkgSpecifierTarget, pkgSpecifierConstraints
75
76
         , UnresolvedPkgLoc, UnresolvedSourcePackage
         , AllowNewer(..), AllowOlder(..), RelaxDeps(..), RelaxedDep(..)
77
         , RelaxDepScope(..), RelaxDepMod(..), RelaxDepSubject(..), isRelaxDeps
78
         )
79
import Distribution.Client.Dependency.Types
80
         ( PreSolver(..), Solver(..)
81
         , PackagesPreferenceDefault(..) )
82
83
import Distribution.Client.Sandbox.Types
         ( SandboxPackageInfo(..) )
84
import Distribution.Package
85
         ( PackageName, mkPackageName, PackageIdentifier(PackageIdentifier), PackageId
86
87
         , Package(..), packageName, packageVersion )
import Distribution.Types.Dependency
88
import qualified Distribution.PackageDescription as PD
89
import qualified Distribution.PackageDescription.Configuration as PD
90
import Distribution.PackageDescription.Configuration
91
         ( finalizePD )
92
93
import Distribution.Client.PackageUtils
         ( externalBuildDepends )
94
import Distribution.Compiler
95
         ( CompilerInfo(..) )
96
import Distribution.System
97
         ( Platform )
98
99
import Distribution.Client.Utils
         ( duplicates, duplicatesBy, mergeBy, MergeResult(..) )
100
import Distribution.Simple.Utils
bardur.arantsson's avatar
bardur.arantsson committed
101
         ( comparing )
102
import Distribution.Simple.Setup
103
         ( asBool )
104
105
import Distribution.Text
         ( display )
106
import Distribution.Verbosity
107
         ( normal, Verbosity )
108
import Distribution.Version
109
import qualified Distribution.Compat.Graph as Graph
110

111
112
import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)
import qualified Distribution.Solver.Types.ComponentDeps as CD
113
import           Distribution.Solver.Types.ConstraintSource
114
import           Distribution.Solver.Types.DependencyResolver
115
import           Distribution.Solver.Types.InstalledPreference
116
import           Distribution.Solver.Types.LabeledPackageConstraint
117
import           Distribution.Solver.Types.OptionalStanza
118
import           Distribution.Solver.Types.PackageConstraint
119
import           Distribution.Solver.Types.PackagePath
120
import           Distribution.Solver.Types.PackagePreferences
121
122
123
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
import           Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
import           Distribution.Solver.Types.Progress
124
import           Distribution.Solver.Types.ResolverPackage
125
126
127
128
import           Distribution.Solver.Types.Settings
import           Distribution.Solver.Types.SolverId
import           Distribution.Solver.Types.SolverPackage
import           Distribution.Solver.Types.SourcePackage
129
import           Distribution.Solver.Types.Variable
130

131
import Data.List
132
         ( foldl', sort, sortBy, nubBy, maximumBy, intercalate, nub )
133
import Data.Function (on)
134
import Data.Maybe (fromMaybe, mapMaybe)
135
import qualified Data.Map as Map
136
137
import qualified Data.Set as Set
import Data.Set (Set)
138
139
140
import Control.Exception
         ( assert )

141

142
143
144
145
146
147
148
149
150
-- ------------------------------------------------------------
-- * High level planner policy
-- ------------------------------------------------------------

-- | The set of parameters to the dependency resolver. These parameters are
-- relatively low level but many kinds of high level policies can be
-- implemented in terms of adjustments to the parameters.
--
data DepResolverParams = DepResolverParams {
151
       depResolverTargets           :: Set PackageName,
152
       depResolverConstraints       :: [LabeledPackageConstraint],
153
154
       depResolverPreferences       :: [PackagePreference],
       depResolverPreferenceDefault :: PackagesPreferenceDefault,
155
       depResolverInstalledPkgIndex :: InstalledPackageIndex,
156
       depResolverSourcePkgIndex    :: PackageIndex.PackageIndex UnresolvedSourcePackage,
157
       depResolverReorderGoals      :: ReorderGoals,
158
       depResolverCountConflicts    :: CountConflicts,
159
160
161
162
       depResolverIndependentGoals  :: IndependentGoals,
       depResolverAvoidReinstalls   :: AvoidReinstalls,
       depResolverShadowPkgs        :: ShadowPkgs,
       depResolverStrongFlags       :: StrongFlags,
163
164

       -- | Whether to allow base and its dependencies to be installed.
165
       depResolverAllowBootLibInstalls :: AllowBootLibInstalls,
166

167
       depResolverMaxBackjumps      :: Maybe Int,
168
       depResolverEnableBackjumping :: EnableBackjumping,
169
170
171
172
173
       -- | Whether or not to solve for dependencies on executables.
       -- This should be true, except in the legacy code path where
       -- we can't tell if an executable has been installed or not,
       -- so we shouldn't solve for them.  See #3875.
       depResolverSolveExecutables  :: SolveExecutables,
174
175

       -- | Function to override the solver's goal-ordering heuristics.
176
177
       depResolverGoalOrder         :: Maybe (Variable QPN -> Variable QPN -> Ordering),
       depResolverVerbosity         :: Verbosity
178
     }
179

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
180
181
showDepResolverParams :: DepResolverParams -> String
showDepResolverParams p =
182
     "targets: " ++ intercalate ", " (map display $ Set.toList (depResolverTargets p))
Andres Löh's avatar
Andres Löh committed
183
  ++ "\nconstraints: "
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
184
  ++   concatMap (("\n  " ++) . showLabeledConstraint)
185
       (depResolverConstraints p)
Andres Löh's avatar
Andres Löh committed
186
  ++ "\npreferences: "
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
187
  ++   concatMap (("\n  " ++) . showPackagePreference)
188
       (depResolverPreferences p)
189
190
191
192
193
194
195
  ++ "\nstrategy: "          ++ show (depResolverPreferenceDefault        p)
  ++ "\nreorder goals: "     ++ show (asBool (depResolverReorderGoals     p))
  ++ "\ncount conflicts: "   ++ show (asBool (depResolverCountConflicts   p))
  ++ "\nindependent goals: " ++ show (asBool (depResolverIndependentGoals p))
  ++ "\navoid reinstalls: "  ++ show (asBool (depResolverAvoidReinstalls  p))
  ++ "\nshadow packages: "   ++ show (asBool (depResolverShadowPkgs       p))
  ++ "\nstrong flags: "      ++ show (asBool (depResolverStrongFlags      p))
196
  ++ "\nallow boot library installs: " ++ show (asBool (depResolverAllowBootLibInstalls p))
197
  ++ "\nmax backjumps: "     ++ maybe "infinite" show
198
                                     (depResolverMaxBackjumps             p)
199
  where
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
200
201
202
    showLabeledConstraint :: LabeledPackageConstraint -> String
    showLabeledConstraint (LabeledPackageConstraint pc src) =
        showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")"
203

204
205
206
207
208
209
210
211
212
213
214
215
-- | A package selection preference for a particular package.
--
-- Preferences are soft constraints that the dependency resolver should try to
-- respect where possible. It is not specified if preferences on some packages
-- are more important than others.
--
data PackagePreference =

     -- | A suggested constraint on the version number.
     PackageVersionPreference   PackageName VersionRange

     -- | If we prefer versions of packages that are already installed.
216
217
   | PackageInstalledPreference PackageName InstalledPreference

218
219
220
221
222
     -- | If we would prefer to enable these optional stanzas
     -- (i.e. test suites and/or benchmarks)
   | PackageStanzasPreference   PackageName [OptionalStanza]


Andres Löh's avatar
Andres Löh committed
223
224
225
-- | Provide a textual representation of a package preference
-- for debugging purposes.
--
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
226
227
showPackagePreference :: PackagePreference -> String
showPackagePreference (PackageVersionPreference   pn vr) =
Andres Löh's avatar
Andres Löh committed
228
  display pn ++ " " ++ display (simplifyVersionRange vr)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
229
showPackagePreference (PackageInstalledPreference pn ip) =
Andres Löh's avatar
Andres Löh committed
230
  display pn ++ " " ++ show ip
231
232
showPackagePreference (PackageStanzasPreference pn st) =
  display pn ++ " " ++ show st
Andres Löh's avatar
Andres Löh committed
233

234
basicDepResolverParams :: InstalledPackageIndex
235
                       -> PackageIndex.PackageIndex UnresolvedSourcePackage
236
                       -> DepResolverParams
237
basicDepResolverParams installedPkgIndex sourcePkgIndex =
238
    DepResolverParams {
239
       depResolverTargets           = Set.empty,
240
241
242
       depResolverConstraints       = [],
       depResolverPreferences       = [],
       depResolverPreferenceDefault = PreferLatestForSelected,
243
       depResolverInstalledPkgIndex = installedPkgIndex,
244
       depResolverSourcePkgIndex    = sourcePkgIndex,
245
       depResolverReorderGoals      = ReorderGoals False,
246
       depResolverCountConflicts    = CountConflicts True,
247
248
249
250
       depResolverIndependentGoals  = IndependentGoals False,
       depResolverAvoidReinstalls   = AvoidReinstalls False,
       depResolverShadowPkgs        = ShadowPkgs False,
       depResolverStrongFlags       = StrongFlags False,
251
       depResolverAllowBootLibInstalls = AllowBootLibInstalls False,
252
       depResolverMaxBackjumps      = Nothing,
253
       depResolverEnableBackjumping = EnableBackjumping True,
254
       depResolverSolveExecutables  = SolveExecutables True,
255
256
       depResolverGoalOrder         = Nothing,
       depResolverVerbosity         = normal
257
258
259
260
261
262
     }

addTargets :: [PackageName]
           -> DepResolverParams -> DepResolverParams
addTargets extraTargets params =
    params {
263
      depResolverTargets = Set.fromList extraTargets `Set.union` depResolverTargets params
264
265
    }

266
addConstraints :: [LabeledPackageConstraint]
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
               -> DepResolverParams -> DepResolverParams
addConstraints extraConstraints params =
    params {
      depResolverConstraints = extraConstraints
                            ++ depResolverConstraints params
    }

addPreferences :: [PackagePreference]
               -> DepResolverParams -> DepResolverParams
addPreferences extraPreferences params =
    params {
      depResolverPreferences = extraPreferences
                            ++ depResolverPreferences params
    }

setPreferenceDefault :: PackagesPreferenceDefault
                     -> DepResolverParams -> DepResolverParams
setPreferenceDefault preferenceDefault params =
    params {
      depResolverPreferenceDefault = preferenceDefault
    }

289
290
setReorderGoals :: ReorderGoals -> DepResolverParams -> DepResolverParams
setReorderGoals reorder params =
Andres Löh's avatar
Andres Löh committed
291
    params {
292
      depResolverReorderGoals = reorder
Andres Löh's avatar
Andres Löh committed
293
294
    }

295
296
297
298
299
300
setCountConflicts :: CountConflicts -> DepResolverParams -> DepResolverParams
setCountConflicts count params =
    params {
      depResolverCountConflicts = count
    }

301
302
setIndependentGoals :: IndependentGoals -> DepResolverParams -> DepResolverParams
setIndependentGoals indep params =
303
    params {
304
      depResolverIndependentGoals = indep
305
306
    }

307
308
setAvoidReinstalls :: AvoidReinstalls -> DepResolverParams -> DepResolverParams
setAvoidReinstalls avoid params =
309
    params {
310
      depResolverAvoidReinstalls = avoid
311
312
    }

313
314
setShadowPkgs :: ShadowPkgs -> DepResolverParams -> DepResolverParams
setShadowPkgs shadow params =
315
    params {
316
      depResolverShadowPkgs = shadow
317
318
    }

319
320
setStrongFlags :: StrongFlags -> DepResolverParams -> DepResolverParams
setStrongFlags sf params =
Andres Löh's avatar
Andres Löh committed
321
    params {
322
      depResolverStrongFlags = sf
Andres Löh's avatar
Andres Löh committed
323
324
    }

325
326
setAllowBootLibInstalls :: AllowBootLibInstalls -> DepResolverParams -> DepResolverParams
setAllowBootLibInstalls i params =
327
    params {
328
      depResolverAllowBootLibInstalls = i
329
330
    }

Andres Löh's avatar
Andres Löh committed
331
332
333
334
335
336
setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams
setMaxBackjumps n params =
    params {
      depResolverMaxBackjumps = n
    }

337
338
339
340
341
342
setEnableBackjumping :: EnableBackjumping -> DepResolverParams -> DepResolverParams
setEnableBackjumping b params =
    params {
      depResolverEnableBackjumping = b
    }

343
344
345
346
347
348
setSolveExecutables :: SolveExecutables -> DepResolverParams -> DepResolverParams
setSolveExecutables b params =
    params {
      depResolverSolveExecutables = b
    }

349
350
351
352
353
354
355
356
setGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
             -> DepResolverParams
             -> DepResolverParams
setGoalOrder order params =
    params {
      depResolverGoalOrder = order
    }

357
358
359
360
361
362
setSolverVerbosity :: Verbosity -> DepResolverParams -> DepResolverParams
setSolverVerbosity verbosity params =
    params {
      depResolverVerbosity = verbosity
    }

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
363
364
-- | Some packages are specific to a given compiler version and should never be
-- upgraded.
365
366
dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams
dontUpgradeNonUpgradeablePackages params =
367
368
369
    addConstraints extraConstraints params
  where
    extraConstraints =
370
      [ LabeledPackageConstraint
371
        (PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled)
372
        ConstraintSourceNonUpgradeablePackage
373
      | Set.notMember (mkPackageName "base") (depResolverTargets params)
374
375
376
377
378
379
380
381
      -- If you change this enumeration, make sure to update the list in
      -- "Distribution.Solver.Modular.Solver" as well
      , pkgname <- [ mkPackageName "base"
                   , mkPackageName "ghc-prim"
                   , mkPackageName "integer-gmp"
                   , mkPackageName "integer-simple"
                   , mkPackageName "template-haskell"
                   ]
382
      , isInstalled pkgname ]
383

384
    isInstalled = not . null
385
                . InstalledPackageIndex.lookupPackageName
386
                                 (depResolverInstalledPkgIndex params)
387

388
addSourcePackages :: [UnresolvedSourcePackage]
389
390
                  -> DepResolverParams -> DepResolverParams
addSourcePackages pkgs params =
391
    params {
392
393
394
      depResolverSourcePkgIndex =
        foldl (flip PackageIndex.insert)
              (depResolverSourcePkgIndex params) pkgs
395
396
    }

397
hideInstalledPackagesSpecificBySourcePackageId :: [PackageId]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
398
399
                                                  -> DepResolverParams
                                                  -> DepResolverParams
400
hideInstalledPackagesSpecificBySourcePackageId pkgids params =
401
402
    --TODO: this should work using exclude constraints instead
    params {
403
      depResolverInstalledPkgIndex =
404
        foldl' (flip InstalledPackageIndex.deleteSourcePackageId)
405
               (depResolverInstalledPkgIndex params) pkgids
406
407
408
409
410
411
412
    }

hideInstalledPackagesAllVersions :: [PackageName]
                                 -> DepResolverParams -> DepResolverParams
hideInstalledPackagesAllVersions pkgnames params =
    --TODO: this should work using exclude constraints instead
    params {
413
      depResolverInstalledPkgIndex =
414
        foldl' (flip InstalledPackageIndex.deletePackageName)
415
               (depResolverInstalledPkgIndex params) pkgnames
416
417
418
    }


419
-- | Remove upper bounds in dependencies using the policy specified by the
420
-- 'AllowNewer' argument (all/some/none).
421
422
423
424
425
--
-- Note: It's important to apply 'removeUpperBounds' after
-- 'addSourcePackages'. Otherwise, the packages inserted by
-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.
--
426
removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams
427
removeUpperBounds (AllowNewer relDeps) = removeBounds RelaxUpper relDeps
428
429
430

-- | Dual of 'removeUpperBounds'
removeLowerBounds :: AllowOlder -> DepResolverParams -> DepResolverParams
431
432
433
434
435
436
removeLowerBounds (AllowOlder relDeps) = removeBounds RelaxLower relDeps

data RelaxKind = RelaxLower | RelaxUpper

-- | Common internal implementation of 'removeLowerBounds'/'removeUpperBounds'
removeBounds :: RelaxKind -> RelaxDeps -> DepResolverParams -> DepResolverParams
437
438
removeBounds _ rd params | not (isRelaxDeps rd) = params -- no-op optimisation
removeBounds  relKind relDeps            params =
439
440
441
442
443
444
445
446
    params {
      depResolverSourcePkgIndex = sourcePkgIndex'
    }
  where
    sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params

    relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage
    relaxDeps srcPkg = srcPkg {
447
      packageDescription = relaxPackageDeps relKind relDeps
448
449
                           (packageDescription srcPkg)
      }
450

451
452
-- | Relax the dependencies of this package if needed.
--
453
454
-- Helper function used by 'removeBounds'
relaxPackageDeps :: RelaxKind
455
456
                 -> RelaxDeps
                 -> PD.GenericPackageDescription -> PD.GenericPackageDescription
457
relaxPackageDeps _ rd gpd | not (isRelaxDeps rd) = gpd -- subsumed by no-op case in 'removeBounds'
458
relaxPackageDeps relKind RelaxDepsAll  gpd = PD.transformAllBuildDepends relaxAll gpd
459
  where
460
    relaxAll :: Dependency -> Dependency
461
462
463
464
    relaxAll (Dependency pkgName verRange) =
        Dependency pkgName (removeBound relKind RelaxDepModNone verRange)

relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd =
465
466
467
  PD.transformAllBuildDepends relaxSome gpd
  where
    thisPkgName    = packageName gpd
468
469
470
    thisPkgId      = packageId   gpd
    depsToRelax    = Map.fromList $ mapMaybe f depsToRelax0

471
    f :: RelaxedDep -> Maybe (RelaxDepSubject,RelaxDepMod)
472
473
474
475
476
477
478
479
480
481
482
    f (RelaxedDep scope rdm p) = case scope of
      RelaxDepScopeAll        -> Just (p,rdm)
      RelaxDepScopePackage p0
          | p0 == thisPkgName -> Just (p,rdm)
          | otherwise         -> Nothing
      RelaxDepScopePackageId p0
          | p0 == thisPkgId   -> Just (p,rdm)
          | otherwise         -> Nothing

    relaxSome :: Dependency -> Dependency
    relaxSome d@(Dependency depName verRange)
483
484
485
486
487
        | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax =
            -- a '*'-subject acts absorbing, for consistency with
            -- the 'Semigroup RelaxDeps' instance
            Dependency depName (removeBound relKind relMod verRange)
        | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax =
488
489
490
491
492
493
494
            Dependency depName (removeBound relKind relMod verRange)
        | otherwise = d -- no-op

-- | Internal helper for 'relaxPackageDeps'
removeBound :: RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange
removeBound RelaxLower RelaxDepModNone = removeLowerBound
removeBound RelaxUpper RelaxDepModNone = removeUpperBound
495
removeBound relKind RelaxDepModCaret = hyloVersionRange embed projectVersionRange
496
  where
497
498
499
    embed (MajorBoundVersionF v) = caretTransformation v (majorUpperBound v)
    embed vr                     = embedVersionRange vr

500
501
502
503
504
    -- This function is the interesting part as it defines the meaning
    -- of 'RelaxDepModCaret', i.e. to transform only @^>=@ constraints;
    caretTransformation l u = case relKind of
      RelaxUpper -> orLaterVersion l -- rewrite @^>= x.y.z@ into @>= x.y.z@
      RelaxLower -> earlierVersion u -- rewrite @^>= x.y.z@ into @< x.(y+1)@
505

506
507
508
509
510
511
-- | Supply defaults for packages without explicit Setup dependencies
--
-- Note: It's important to apply 'addDefaultSetupDepends' after
-- 'addSourcePackages'. Otherwise, the packages inserted by
-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.
--
512
addDefaultSetupDependencies :: (UnresolvedSourcePackage -> Maybe [Dependency])
513
514
515
516
517
518
519
                            -> DepResolverParams -> DepResolverParams
addDefaultSetupDependencies defaultSetupDeps params =
    params {
      depResolverSourcePkgIndex =
        fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params)
    }
  where
520
    applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage
521
522
523
524
525
526
527
    applyDefaultSetupDeps srcpkg =
        srcpkg {
          packageDescription = gpkgdesc {
            PD.packageDescription = pkgdesc {
              PD.setupBuildInfo =
                case PD.setupBuildInfo pkgdesc of
                  Just sbi -> Just sbi
528
                  Nothing -> case defaultSetupDeps srcpkg of
529
                    Nothing -> Nothing
530
531
532
533
534
                    Just deps | isCustom -> Just PD.SetupBuildInfo {
                                                PD.defaultSetupDepends = True,
                                                PD.setupDepends        = deps
                                            }
                              | otherwise -> Nothing
535
536
537
538
            }
          }
        }
      where
539
        isCustom = PD.buildType pkgdesc == PD.Custom
540
541
542
        gpkgdesc = packageDescription srcpkg
        pkgdesc  = PD.packageDescription gpkgdesc

Mikhail Glushenkov's avatar
Typos.    
Mikhail Glushenkov committed
543
-- | If a package has a custom setup then we need to add a setup-depends
544
-- on Cabal.
545
546
547
548
549
550
--
addSetupCabalMinVersionConstraint :: Version
                                  -> DepResolverParams -> DepResolverParams
addSetupCabalMinVersionConstraint minVersion =
    addConstraints
      [ LabeledPackageConstraint
551
          (PackageConstraint (ScopeAnySetupQualifier cabalPkgname)
552
                             (PackagePropertyVersion $ orLaterVersion minVersion))
553
554
555
556
557
          ConstraintSetupCabalMinVersion
      ]
  where
    cabalPkgname = mkPackageName "Cabal"

558

559
560
561
562
563
564
upgradeDependencies :: DepResolverParams -> DepResolverParams
upgradeDependencies = setPreferenceDefault PreferAllLatest


reinstallTargets :: DepResolverParams -> DepResolverParams
reinstallTargets params =
565
    hideInstalledPackagesAllVersions (Set.toList $ depResolverTargets params) params
566
567


568
569
570
571
572
573
574
-- | A basic solver policy on which all others are built.
--
basicInstallPolicy :: InstalledPackageIndex
                   -> SourcePackageDb
                   -> [PackageSpecifier UnresolvedSourcePackage]
                   -> DepResolverParams
basicInstallPolicy
575
576
    installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs)
    pkgSpecifiers
577
578
579

  = addPreferences
      [ PackageVersionPreference name ver
580
      | (name, ver) <- Map.toList sourcePkgPrefs ]
581
582
583
584
585
586
587

  . addConstraints
      (concatMap pkgSpecifierConstraints pkgSpecifiers)

  . addTargets
      (map pkgSpecifierTarget pkgSpecifiers)

588
  . hideInstalledPackagesSpecificBySourcePackageId
589
590
      [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]

591
  . addSourcePackages
592
593
594
      [ pkg  | SpecificSourcePackage pkg <- pkgSpecifiers ]

  $ basicDepResolverParams
595
      installedPkgIndex sourcePkgIndex
596

597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613

-- | The policy used by all the standard commands, install, fetch, freeze etc
-- (but not the new-build and related commands).
--
-- It extends the 'basicInstallPolicy' with a policy on setup deps.
--
standardInstallPolicy :: InstalledPackageIndex
                      -> SourcePackageDb
                      -> [PackageSpecifier UnresolvedSourcePackage]
                      -> DepResolverParams
standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers

  = addDefaultSetupDependencies mkDefaultSetupDeps

  $ basicInstallPolicy
      installedPkgIndex sourcePkgDb pkgSpecifiers

614
615
616
617
    where
      -- Force Cabal >= 1.24 dep when the package is affected by #3199.
      mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency]
      mkDefaultSetupDeps srcpkg | affected        =
618
        Just [Dependency (mkPackageName "Cabal")
619
              (orLaterVersion $ mkVersion [1,24])]
620
621
622
623
                                | otherwise       = Nothing
        where
          gpkgdesc = packageDescription srcpkg
          pkgdesc  = PD.packageDescription gpkgdesc
624
          bt       = PD.buildType pkgdesc
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
          affected = bt == PD.Custom && hasBuildableFalse gpkgdesc

      -- Does this package contain any components with non-empty 'build-depends'
      -- and a 'buildable' field that could potentially be set to 'False'? False
      -- positives are possible.
      hasBuildableFalse :: PD.GenericPackageDescription -> Bool
      hasBuildableFalse gpkg =
        not (all alwaysTrue (zipWith PD.cOr buildableConditions noDepConditions))
        where
          buildableConditions      = PD.extractConditions PD.buildable gpkg
          noDepConditions          = PD.extractConditions
                                     (null . PD.targetBuildDepends)    gpkg
          alwaysTrue (PD.Lit True) = True
          alwaysTrue _             = False


641
642
643
644
applySandboxInstallPolicy :: SandboxPackageInfo
                             -> DepResolverParams
                             -> DepResolverParams
applySandboxInstallPolicy
645
  (SandboxPackageInfo modifiedDeps otherDeps allSandboxPkgs _allDeps)
646
  params
647
648
649
650
651
652

  = addPreferences [ PackageInstalledPreference n PreferInstalled
                   | n <- installedNotModified ]

  . addTargets installedNotModified

653
654
655
656
  . addPreferences
      [ PackageVersionPreference (packageName pkg)
        (thisVersion (packageVersion pkg)) | pkg <- otherDeps ]

657
  . addConstraints
658
      [ let pc = PackageConstraint
659
                 (scopeToplevel $ packageName pkg)
660
                 (PackagePropertyVersion $ thisVersion (packageVersion pkg))
661
        in LabeledPackageConstraint pc ConstraintSourceModifiedAddSourceDep
662
      | pkg <- modifiedDeps ]
663
664
665
666
667
668
669
670
671

  . addTargets [ packageName pkg | pkg <- modifiedDeps ]

  . hideInstalledPackagesSpecificBySourcePackageId
      [ packageId pkg | pkg <- modifiedDeps ]

  -- We don't need to add source packages for add-source deps to the
  -- 'installedPkgIndex' since 'getSourcePackages' did that for us.

672
  $ params
673
674
675
676
677
678
679
680

  where
    installedPkgIds =
      map fst . InstalledPackageIndex.allPackagesBySourcePackageId
      $ allSandboxPkgs
    modifiedPkgIds       = map packageId modifiedDeps
    installedNotModified = [ packageName pkg | pkg <- installedPkgIds,
                             pkg `notElem` modifiedPkgIds ]
681
682
683
684
685

-- ------------------------------------------------------------
-- * Interface to the standard resolver
-- ------------------------------------------------------------

686
chooseSolver :: Verbosity -> PreSolver -> CompilerInfo -> IO Solver
bardur.arantsson's avatar
bardur.arantsson committed
687
chooseSolver _verbosity preSolver _cinfo =
688
689
690
    case preSolver of
      AlwaysModular -> do
        return Modular
691

692
runSolver :: Solver -> SolverConfig -> DependencyResolver UnresolvedPkgLoc
693
runSolver Modular = modularResolver
694

695
696
697
698
699
700
701
-- | Run the dependency solver.
--
-- Since this is potentially an expensive operation, the result is wrapped in a
-- a 'Progress' structure that can be unfolded to provide progress information,
-- logging messages and the final result or an error.
--
resolveDependencies :: Platform
702
                    -> CompilerInfo
703
                    -> PkgConfigDb
704
                    -> Solver
705
                    -> DepResolverParams
706
                    -> Progress String String SolverInstallPlan
707

708
    --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages
709
resolveDependencies platform comp _pkgConfigDB _solver params
710
  | Set.null (depResolverTargets params)
711
712
713
  = return (validateSolverResult platform comp indGoals [])
  where
    indGoals = depResolverIndependentGoals params
714

715
resolveDependencies platform comp pkgConfigDB solver params =
716

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
717
    Step (showDepResolverParams finalparams)
718
  $ fmap (validateSolverResult platform comp indGoals)
719
720
  $ runSolver solver (SolverConfig reordGoals cntConflicts
                      indGoals noReinstalls
721
                      shadowing strFlags allowBootLibs maxBkjumps enableBj
722
                      solveExes order verbosity)
723
                     platform comp installedPkgIndex sourcePkgIndex
724
                     pkgConfigDB preferences constraints targets
725
  where
Andres Löh's avatar
Andres Löh committed
726
727

    finalparams @ (DepResolverParams
728
729
      targets constraints
      prefs defpref
730
      installedPkgIndex
731
      sourcePkgIndex
732
733
      reordGoals
      cntConflicts
734
      indGoals
Andres Löh's avatar
Andres Löh committed
735
      noReinstalls
736
      shadowing
Andres Löh's avatar
Andres Löh committed
737
      strFlags
738
      allowBootLibs
739
      maxBkjumps
740
      enableBj
741
      solveExes
742
743
744
745
746
      order
      verbosity) =
        if asBool (depResolverAllowBootLibInstalls params)
        then params
        else dontUpgradeNonUpgradeablePackages params
747

748
    preferences = interpretPackagesPreference targets defpref prefs
749

750

751
-- | Give an interpretation to the global 'PackagesPreference' as
752
753
--  specific per-package 'PackageVersionPreference'.
--
754
interpretPackagesPreference :: Set PackageName
755
756
                            -> PackagesPreferenceDefault
                            -> [PackagePreference]
757
                            -> (PackageName -> PackagePreferences)
758
interpretPackagesPreference selected defaultPref prefs =
759
760
761
  \pkgname -> PackagePreferences (versionPref pkgname)
                                 (installPref pkgname)
                                 (stanzasPref pkgname)
762
763
  where
    versionPref pkgname =
764
765
766
767
      fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs)
    versionPrefs = Map.fromListWith (++)
                   [(pkgname, [pref])
                   | PackageVersionPreference pkgname pref <- prefs]
768
769
770
771
772
773
774

    installPref pkgname =
      fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)
    installPrefs = Map.fromList
      [ (pkgname, pref)
      | PackageInstalledPreference pkgname pref <- prefs ]
    installPrefDefault = case defaultPref of
775
776
      PreferAllLatest         -> const PreferLatest
      PreferAllInstalled      -> const PreferInstalled
777
778
779
780
781
      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
782

783
784
785
786
787
788
789
    stanzasPref pkgname =
      fromMaybe [] (Map.lookup pkgname stanzasPrefs)
    stanzasPrefs = Map.fromListWith (\a b -> nub (a ++ b))
      [ (pkgname, pref)
      | PackageStanzasPreference pkgname pref <- prefs ]


790
791
792
793
794
795
796
797
798
-- ------------------------------------------------------------
-- * Checking the result of the solver
-- ------------------------------------------------------------

-- | Make an install plan from the output of the dep resolver.
-- It checks that the plan is valid, or it's an error in the dep resolver.
--
validateSolverResult :: Platform
                     -> CompilerInfo
799
                     -> IndependentGoals
800
                     -> [ResolverPackage UnresolvedPkgLoc]
801
                     -> SolverInstallPlan
802
803
validateSolverResult platform comp indepGoals pkgs =
    case planPackagesProblems platform comp pkgs of
804
      [] -> case SolverInstallPlan.new indepGoals graph of
805
806
807
808
809
              Right plan     -> plan
              Left  problems -> error (formatPlanProblems problems)
      problems               -> error (formatPkgProblems problems)

  where
810
    graph = Graph.fromDistinctList pkgs
811
812

    formatPkgProblems  = formatProblemMessage . map showPlanPackageProblem
813
    formatPlanProblems = formatProblemMessage . map SolverInstallPlan.showPlanProblem
814

815
    formatProblemMessage problems =
816
817
818
819
820
      unlines $
        "internal error: could not construct a valid install plan."
      : "The proposed (invalid) plan contained the following problems:"
      : problems
      ++ "Proposed plan:"
821
      : [SolverInstallPlan.showPlanIndex pkgs]
822
823
824


data PlanPackageProblem =
825
826
827
       InvalidConfiguredPackage (SolverPackage UnresolvedPkgLoc)
                                [PackageProblem]
     | DuplicatePackageSolverId SolverId [ResolverPackage UnresolvedPkgLoc]
828
829
830
831
832
833
834

showPlanPackageProblem :: PlanPackageProblem -> String
showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) =
     "Package " ++ display (packageId pkg)
  ++ " has an invalid configuration, in particular:\n"
  ++ unlines [ "  " ++ showPackageProblem problem
             | problem <- packageProblems ]
835
836
837
showPlanPackageProblem (DuplicatePackageSolverId pid dups) =
     "Package " ++ display (packageId pid) ++ " has "
  ++ show (length dups) ++ " duplicate instances."
838
839

planPackagesProblems :: Platform -> CompilerInfo
840
                     -> [ResolverPackage UnresolvedPkgLoc]
841
842
843
                     -> [PlanPackageProblem]
planPackagesProblems platform cinfo pkgs =
     [ InvalidConfiguredPackage pkg packageProblems
844
     | Configured pkg <- pkgs
845
846
     , let packageProblems = configuredPackageProblems platform cinfo pkg
     , not (null packageProblems) ]
847
848
  ++ [ DuplicatePackageSolverId (Graph.nodeKey (head dups)) dups
     | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs ]
849
850
851
852
853
854
855
856
857
858

data PackageProblem = DuplicateFlag PD.FlagName
                    | MissingFlag   PD.FlagName
                    | ExtraFlag     PD.FlagName
                    | DuplicateDeps [PackageId]
                    | MissingDep    Dependency
                    | ExtraDep      PackageId
                    | InvalidDep    Dependency PackageId

showPackageProblem :: PackageProblem -> String
859
860
showPackageProblem (DuplicateFlag flag) =
  "duplicate flag in the flag assignment: " ++ PD.unFlagName flag
861

862
863
showPackageProblem (MissingFlag flag) =
  "missing an assignment for the flag: " ++ PD.unFlagName flag
864

865
866
showPackageProblem (ExtraFlag flag) =
  "extra flag given that is not used by the package: " ++ PD.unFlagName flag
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890

showPackageProblem (DuplicateDeps pkgids) =
     "duplicate packages specified as selected dependencies: "
  ++ intercalate ", " (map display pkgids)

showPackageProblem (MissingDep dep) =
     "the package has a dependency " ++ display dep
  ++ " but no package has been selected to satisfy it."

showPackageProblem (ExtraDep pkgid) =
     "the package configuration specifies " ++ display pkgid
  ++ " but (with the given flag assignment) the package does not actually"
  ++ " depend on any version of that package."

showPackageProblem (InvalidDep dep pkgid) =
     "the package depends on " ++ display dep
  ++ " but the configuration specifies " ++ display pkgid
  ++ " which does not satisfy the dependency."

-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if
-- in the configuration given by the flag assignment, all the package
-- dependencies are satisfied by the specified packages.
--
configuredPackageProblems :: Platform -> CompilerInfo
891
                          -> SolverPackage UnresolvedPkgLoc -> [PackageProblem]
892
configuredPackageProblems platform cinfo
893
  (SolverPackage pkg specifiedFlags stanzas specifiedDeps' _specifiedExeDeps') =
894
895
     -- FIXME/TODO: FlagAssignment ought to be duplicate-free as internal invariant
     [ DuplicateFlag flag | ((flag,_):_) <- duplicates (PD.unFlagAssignment specifiedFlags) ]
896
897
898
  ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]
  ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]
  ++ [ DuplicateDeps pkgs
899
900
     | pkgs <- CD.nonSetupDeps (fmap (duplicatesBy (comparing packageName))
                                specifiedDeps) ]
901
902
903
904
  ++ [ MissingDep dep       | OnlyInLeft  dep       <- mergedDeps ]
  ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]
  ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps
                            , not (packageSatisfiesDependency pkgid dep) ]
905
  -- TODO: sanity tests on executable deps
906
907
  where
    specifiedDeps :: ComponentDeps [PackageId]
908
    specifiedDeps = fmap (map solverSrcId) specifiedDeps'
909
910
911

    mergedFlags = mergeBy compare
      (sort $ map PD.flagName (PD.genPackageFlags (packageDescription pkg)))
912
      (sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO
913
914
915
916
917
918
919
920
921
922
923

    packageSatisfiesDependency
      (PackageIdentifier name  version)
      (Dependency        name' versionRange) = assert (name == name') $
        version `withinRange` versionRange

    dependencyName (Dependency name _) = name

    mergedDeps :: [MergeResult Dependency PackageId]
    mergedDeps = mergeDeps requiredDeps (CD.flatDeps specifiedDeps)

924
925
    mergeDeps :: [Dependency] -> [PackageId]
              -> [MergeResult Dependency PackageId]
926
927
928
929
930
931
932
    mergeDeps required specified =
      let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f) in
      mergeBy
        (\dep pkgid -> dependencyName dep `compare` packageName pkgid)
        (sortNubOn dependencyName required)
        (sortNubOn packageName    specified)

933
934
935
936
937
938
939
    -- TODO: It would be nicer to use ComponentDeps here so we can be more
    -- precise in our checks. That's a bit tricky though, as this currently
    -- relies on the 'buildDepends' field of 'PackageDescription'. (OTOH, that
    -- field is deprecated and should be removed anyway.)  As long as we _do_
    -- use a flat list here, we have to allow for duplicates when we fold
    -- specifiedDeps; once we have proper ComponentDeps here we should get rid
    -- of the `nubOn` in `mergeDeps`.
940
941
    requiredDeps :: [Dependency]
    requiredDeps =
942
943
      --TODO: use something lower level than finalizePD
      case finalizePD specifiedFlags
944
         (enableStanzas stanzas)
945
946
947
         (const True)
         platform cinfo
         []
948
         (packageDescription pkg) of
949
950
951
952
953
954
955
        Right (resolvedPkg, _) ->
             externalBuildDepends resolvedPkg
          ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg)
        Left  _ ->
          error "configuredPackageInvalidDeps internal error"


956
957
958
959
960
961