Dependency.hs 32.7 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
26
27
    -- * Constructing resolver policies
    DepResolverParams(..),
    PackageConstraint(..),
28
29
    PackagesPreferenceDefault(..),
    PackagePreference(..),
30
31
32
33
34
35
    InstalledPreference(..),

    -- ** Standard policy
    standardInstallPolicy,
    PackageSpecifier(..),

36
    -- ** Sandbox policy
37
    applySandboxInstallPolicy,
38

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

    -- ** Policy utils
    addConstraints,
    addPreferences,
    setPreferenceDefault,
Andres Löh's avatar
Andres Löh committed
49
    setReorderGoals,
50
    setIndependentGoals,
51
    setAvoidReinstalls,
52
    setShadowPkgs,
Andres Löh's avatar
Andres Löh committed
53
    setStrongFlags,
Andres Löh's avatar
Andres Löh committed
54
    setMaxBackjumps,
55
    addSourcePackages,
56
    hideInstalledPackagesSpecificByUnitId,
57
    hideInstalledPackagesSpecificBySourcePackageId,
58
    hideInstalledPackagesAllVersions,
59
60
    removeUpperBounds,
    addDefaultSetupDependencies,
61
  ) where
62

63
64
import Distribution.Client.Dependency.TopDown
         ( topDownResolver )
Andres Löh's avatar
Andres Löh committed
65
66
import Distribution.Client.Dependency.Modular
         ( modularResolver, SolverConfig(..) )
67
import qualified Distribution.Client.PackageIndex as PackageIndex
68
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
69
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
70
71
72
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.Types
73
         ( SourcePackageDb(SourcePackageDb), SourcePackage(..)
74
75
         , ConfiguredPackage(..), ConfiguredId(..)
         , OptionalStanza(..), enableStanzas )
76
import Distribution.Client.Dependency.Types
77
         ( PreSolver(..), Solver(..), DependencyResolver, ResolverPackage(..)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
78
         , PackageConstraint(..), showPackageConstraint
79
         , LabeledPackageConstraint(..), unlabelPackageConstraint
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
80
         , ConstraintSource(..), showConstraintSource
81
         , PackagePreferences(..), InstalledPreference(..)
Andres Löh's avatar
Andres Löh committed
82
         , PackagesPreferenceDefault(..)
83
         , Progress(..), foldProgress )
84
85
import Distribution.Client.Sandbox.Types
         ( SandboxPackageInfo(..) )
86
import Distribution.Client.Targets
87
88
import Distribution.Client.ComponentDeps (ComponentDeps)
import qualified Distribution.Client.ComponentDeps as CD
89
import qualified Distribution.InstalledPackageInfo as Installed
90
import Distribution.Package
91
92
         ( PackageName(..), PackageIdentifier(PackageIdentifier), PackageId
         , Package(..), packageName, packageVersion
93
         , UnitId, Dependency(Dependency))
94
import qualified Distribution.PackageDescription as PD
95
96
         ( PackageDescription(..), SetupBuildInfo(..)
         , GenericPackageDescription(..)
97
98
         , Flag(flagName), FlagName(..) )
import Distribution.PackageDescription.Configuration
99
         ( finalizePackageDescription )
100
101
import Distribution.Client.PackageUtils
         ( externalBuildDepends )
102
import Distribution.Version
103
         ( VersionRange, anyVersion, thisVersion, withinRange
104
         , simplifyVersionRange )
105
import Distribution.Compiler
106
         ( CompilerInfo(..) )
107
import Distribution.System
108
         ( Platform )
109
110
import Distribution.Client.Utils
         ( duplicates, duplicatesBy, mergeBy, MergeResult(..) )
111
112
import Distribution.Simple.Utils
         ( comparing, warn, info )
113
114
import Distribution.Simple.Configure
         ( relaxPackageDeps )
115
116
import Distribution.Simple.Setup
         ( AllowNewer(..) )
117
118
import Distribution.Text
         ( display )
119
120
import Distribution.Verbosity
         ( Verbosity )
121

122
import Data.List
123
         ( foldl', sort, sortBy, nubBy, maximumBy, intercalate, nub )
124
import Data.Function (on)
125
import Data.Maybe (fromMaybe)
126
import qualified Data.Map as Map
127
128
import qualified Data.Set as Set
import Data.Set (Set)
129
130
131
import Control.Exception
         ( assert )

132

133
134
135
136
137
138
139
140
141
142
-- ------------------------------------------------------------
-- * 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 {
       depResolverTargets           :: [PackageName],
143
       depResolverConstraints       :: [LabeledPackageConstraint],
144
145
       depResolverPreferences       :: [PackagePreference],
       depResolverPreferenceDefault :: PackagesPreferenceDefault,
146
       depResolverInstalledPkgIndex :: InstalledPackageIndex,
147
       depResolverSourcePkgIndex    :: PackageIndex.PackageIndex SourcePackage,
Andres Löh's avatar
Andres Löh committed
148
       depResolverReorderGoals      :: Bool,
149
       depResolverIndependentGoals  :: Bool,
Andres Löh's avatar
Andres Löh committed
150
       depResolverAvoidReinstalls   :: Bool,
151
       depResolverShadowPkgs        :: Bool,
Andres Löh's avatar
Andres Löh committed
152
       depResolverStrongFlags       :: Bool,
Andres Löh's avatar
Andres Löh committed
153
       depResolverMaxBackjumps      :: Maybe Int
154
     }
155

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
156
157
showDepResolverParams :: DepResolverParams -> String
showDepResolverParams p =
tibbe's avatar
tibbe committed
158
     "targets: " ++ intercalate ", " (map display (depResolverTargets p))
Andres Löh's avatar
Andres Löh committed
159
  ++ "\nconstraints: "
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
160
  ++   concatMap (("\n  " ++) . showLabeledConstraint)
161
       (depResolverConstraints p)
Andres Löh's avatar
Andres Löh committed
162
  ++ "\npreferences: "
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
163
  ++   concatMap (("\n  " ++) . showPackagePreference)
164
       (depResolverPreferences p)
165
166
167
168
169
170
  ++ "\nstrategy: "          ++ show (depResolverPreferenceDefault p)
  ++ "\nreorder goals: "     ++ show (depResolverReorderGoals      p)
  ++ "\nindependent goals: " ++ show (depResolverIndependentGoals  p)
  ++ "\navoid reinstalls: "  ++ show (depResolverAvoidReinstalls   p)
  ++ "\nshadow packages: "   ++ show (depResolverShadowPkgs        p)
  ++ "\nstrong flags: "      ++ show (depResolverStrongFlags       p)
171
172
  ++ "\nmax backjumps: "     ++ maybe "infinite" show
                                     (depResolverMaxBackjumps      p)
173
  where
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
174
175
176
    showLabeledConstraint :: LabeledPackageConstraint -> String
    showLabeledConstraint (LabeledPackageConstraint pc src) =
        showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")"
177

178
179
180
181
182
183
184
185
186
187
188
189
-- | 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.
190
191
   | PackageInstalledPreference PackageName InstalledPreference

192
193
194
195
196
     -- | 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
197
198
199
-- | Provide a textual representation of a package preference
-- for debugging purposes.
--
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
200
201
showPackagePreference :: PackagePreference -> String
showPackagePreference (PackageVersionPreference   pn vr) =
Andres Löh's avatar
Andres Löh committed
202
  display pn ++ " " ++ display (simplifyVersionRange vr)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
203
showPackagePreference (PackageInstalledPreference pn ip) =
Andres Löh's avatar
Andres Löh committed
204
  display pn ++ " " ++ show ip
205
206
showPackagePreference (PackageStanzasPreference pn st) =
  display pn ++ " " ++ show st
Andres Löh's avatar
Andres Löh committed
207

208
basicDepResolverParams :: InstalledPackageIndex
209
                       -> PackageIndex.PackageIndex SourcePackage
210
                       -> DepResolverParams
211
basicDepResolverParams installedPkgIndex sourcePkgIndex =
212
213
214
215
216
    DepResolverParams {
       depResolverTargets           = [],
       depResolverConstraints       = [],
       depResolverPreferences       = [],
       depResolverPreferenceDefault = PreferLatestForSelected,
217
       depResolverInstalledPkgIndex = installedPkgIndex,
218
       depResolverSourcePkgIndex    = sourcePkgIndex,
Andres Löh's avatar
Andres Löh committed
219
       depResolverReorderGoals      = False,
220
       depResolverIndependentGoals  = False,
Andres Löh's avatar
Andres Löh committed
221
       depResolverAvoidReinstalls   = False,
222
       depResolverShadowPkgs        = False,
Andres Löh's avatar
Andres Löh committed
223
       depResolverStrongFlags       = False,
Andres Löh's avatar
Andres Löh committed
224
       depResolverMaxBackjumps      = Nothing
225
226
227
228
229
230
231
232
233
     }

addTargets :: [PackageName]
           -> DepResolverParams -> DepResolverParams
addTargets extraTargets params =
    params {
      depResolverTargets = extraTargets ++ depResolverTargets params
    }

234
addConstraints :: [LabeledPackageConstraint]
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
               -> 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
    }

Andres Löh's avatar
Andres Löh committed
257
258
259
260
261
262
setReorderGoals :: Bool -> DepResolverParams -> DepResolverParams
setReorderGoals b params =
    params {
      depResolverReorderGoals = b
    }

263
264
265
266
267
268
setIndependentGoals :: Bool -> DepResolverParams -> DepResolverParams
setIndependentGoals b params =
    params {
      depResolverIndependentGoals = b
    }

269
270
271
272
273
274
setAvoidReinstalls :: Bool -> DepResolverParams -> DepResolverParams
setAvoidReinstalls b params =
    params {
      depResolverAvoidReinstalls = b
    }

275
276
277
278
279
280
setShadowPkgs :: Bool -> DepResolverParams -> DepResolverParams
setShadowPkgs b params =
    params {
      depResolverShadowPkgs = b
    }

Andres Löh's avatar
Andres Löh committed
281
282
283
284
285
286
setStrongFlags :: Bool -> DepResolverParams -> DepResolverParams
setStrongFlags b params =
    params {
      depResolverStrongFlags = b
    }

Andres Löh's avatar
Andres Löh committed
287
288
289
290
291
292
setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams
setMaxBackjumps n params =
    params {
      depResolverMaxBackjumps = n
    }

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
293
294
-- | Some packages are specific to a given compiler version and should never be
-- upgraded.
295
296
dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams
dontUpgradeNonUpgradeablePackages params =
297
298
299
    addConstraints extraConstraints params
  where
    extraConstraints =
300
301
      [ LabeledPackageConstraint
        (PackageConstraintInstalled pkgname)
302
        ConstraintSourceNonUpgradeablePackage
303
      | notElem (PackageName "base") (depResolverTargets params)
304
      , pkgname <- map PackageName [ "base", "ghc-prim", "integer-gmp"
305
                                   , "integer-simple" ]
306
307
308
      , isInstalled pkgname ]
    -- TODO: the top down resolver chokes on the base constraints
    -- below when there are no targets and thus no dep on base.
Ian D. Bollinger's avatar
Ian D. Bollinger committed
309
    -- Need to refactor constraints separate from needing packages.
310
    isInstalled = not . null
311
                . InstalledPackageIndex.lookupPackageName
312
                                 (depResolverInstalledPkgIndex params)
313

314
315
316
addSourcePackages :: [SourcePackage]
                  -> DepResolverParams -> DepResolverParams
addSourcePackages pkgs params =
317
    params {
318
319
320
      depResolverSourcePkgIndex =
        foldl (flip PackageIndex.insert)
              (depResolverSourcePkgIndex params) pkgs
321
322
    }

323
hideInstalledPackagesSpecificByUnitId :: [UnitId]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
324
325
                                                     -> DepResolverParams
                                                     -> DepResolverParams
326
hideInstalledPackagesSpecificByUnitId pkgids params =
327
328
329
    --TODO: this should work using exclude constraints instead
    params {
      depResolverInstalledPkgIndex =
330
        foldl' (flip InstalledPackageIndex.deleteUnitId)
331
332
333
334
               (depResolverInstalledPkgIndex params) pkgids
    }

hideInstalledPackagesSpecificBySourcePackageId :: [PackageId]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
335
336
                                                  -> DepResolverParams
                                                  -> DepResolverParams
337
hideInstalledPackagesSpecificBySourcePackageId pkgids params =
338
339
    --TODO: this should work using exclude constraints instead
    params {
340
      depResolverInstalledPkgIndex =
341
        foldl' (flip InstalledPackageIndex.deleteSourcePackageId)
342
               (depResolverInstalledPkgIndex params) pkgids
343
344
345
346
347
348
349
    }

hideInstalledPackagesAllVersions :: [PackageName]
                                 -> DepResolverParams -> DepResolverParams
hideInstalledPackagesAllVersions pkgnames params =
    --TODO: this should work using exclude constraints instead
    params {
350
      depResolverInstalledPkgIndex =
351
        foldl' (flip InstalledPackageIndex.deletePackageName)
352
               (depResolverInstalledPkgIndex params) pkgnames
353
354
355
356
357
    }


hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams
hideBrokenInstalledPackages params =
358
    hideInstalledPackagesSpecificByUnitId pkgids params
359
  where
360
    pkgids = map Installed.installedUnitId
361
           . InstalledPackageIndex.reverseDependencyClosure
362
                            (depResolverInstalledPkgIndex params)
363
           . map (Installed.installedUnitId . fst)
364
           . InstalledPackageIndex.brokenPackages
365
           $ depResolverInstalledPkgIndex params
366

367
-- | Remove upper bounds in dependencies using the policy specified by the
368
-- 'AllowNewer' argument (all/some/none).
369
370
371
372
373
--
-- Note: It's important to apply 'removeUpperBounds' after
-- 'addSourcePackages'. Otherwise, the packages inserted by
-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.
--
374
removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams
375
376
removeUpperBounds AllowNewerNone params = params
removeUpperBounds allowNewer     params =
377
378
379
380
    params {
      depResolverSourcePkgIndex = sourcePkgIndex'
    }
  where
381
382
383
384
385
    sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params

    relaxDeps :: SourcePackage -> SourcePackage
    relaxDeps srcPkg = srcPkg {
      packageDescription = relaxPackageDeps allowNewer
386
387
                           (packageDescription srcPkg)
      }
388

389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
-- | 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.
--
addDefaultSetupDependencies :: (SourcePackage -> [Dependency])
                            -> DepResolverParams -> DepResolverParams
addDefaultSetupDependencies defaultSetupDeps params =
    params {
      depResolverSourcePkgIndex =
        fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params)
    }
  where
    applyDefaultSetupDeps :: SourcePackage -> SourcePackage
    applyDefaultSetupDeps srcpkg =
        srcpkg {
          packageDescription = gpkgdesc {
            PD.packageDescription = pkgdesc {
              PD.setupBuildInfo =
                case PD.setupBuildInfo pkgdesc of
                  Just sbi -> Just sbi
                  Nothing  -> Just PD.SetupBuildInfo {
                                PD.setupDepends = defaultSetupDeps srcpkg
                              }
            }
          }
        }
      where
        gpkgdesc = packageDescription srcpkg
        pkgdesc  = PD.packageDescription gpkgdesc


422
423
424
425
426
427
428
429
430
upgradeDependencies :: DepResolverParams -> DepResolverParams
upgradeDependencies = setPreferenceDefault PreferAllLatest


reinstallTargets :: DepResolverParams -> DepResolverParams
reinstallTargets params =
    hideInstalledPackagesAllVersions (depResolverTargets params) params


431
standardInstallPolicy :: InstalledPackageIndex
432
433
                      -> SourcePackageDb
                      -> [PackageSpecifier SourcePackage]
434
435
                      -> DepResolverParams
standardInstallPolicy
436
437
    installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs)
    pkgSpecifiers
438
439
440

  = addPreferences
      [ PackageVersionPreference name ver
441
      | (name, ver) <- Map.toList sourcePkgPrefs ]
442
443
444
445
446
447
448

  . addConstraints
      (concatMap pkgSpecifierConstraints pkgSpecifiers)

  . addTargets
      (map pkgSpecifierTarget pkgSpecifiers)

449
  . hideInstalledPackagesSpecificBySourcePackageId
450
451
      [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]

452
  . addSourcePackages
453
454
455
      [ pkg  | SpecificSourcePackage pkg <- pkgSpecifiers ]

  $ basicDepResolverParams
456
      installedPkgIndex sourcePkgIndex
457

458
459
460
461
applySandboxInstallPolicy :: SandboxPackageInfo
                             -> DepResolverParams
                             -> DepResolverParams
applySandboxInstallPolicy
462
  (SandboxPackageInfo modifiedDeps otherDeps allSandboxPkgs _allDeps)
463
  params
464
465
466
467
468
469

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

  . addTargets installedNotModified

470
471
472
473
  . addPreferences
      [ PackageVersionPreference (packageName pkg)
        (thisVersion (packageVersion pkg)) | pkg <- otherDeps ]

474
  . addConstraints
475
476
      [ let pc = PackageConstraintVersion (packageName pkg)
                 (thisVersion (packageVersion pkg))
477
        in LabeledPackageConstraint pc ConstraintSourceModifiedAddSourceDep
478
      | pkg <- modifiedDeps ]
479
480
481
482
483
484
485
486
487

  . 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.

488
  $ params
489
490
491
492
493
494
495
496

  where
    installedPkgIds =
      map fst . InstalledPackageIndex.allPackagesBySourcePackageId
      $ allSandboxPkgs
    modifiedPkgIds       = map packageId modifiedDeps
    installedNotModified = [ packageName pkg | pkg <- installedPkgIds,
                             pkg `notElem` modifiedPkgIds ]
497
498
499
500
501

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

502
chooseSolver :: Verbosity -> PreSolver -> CompilerInfo -> IO Solver
503
504
505
506
507
508
509
510
511
512
chooseSolver verbosity preSolver _cinfo =
    case preSolver of
      AlwaysTopDown -> do
        warn verbosity "Topdown solver is deprecated"
        return TopDown
      AlwaysModular -> do
        return Modular
      Choose -> do
        info verbosity "Choosing modular solver."
        return Modular
513

514
runSolver :: Solver -> SolverConfig -> DependencyResolver
Ian D. Bollinger's avatar
Ian D. Bollinger committed
515
runSolver TopDown = const topDownResolver -- TODO: warn about unsupported options
516
runSolver Modular = modularResolver
517

518
519
520
521
522
523
524
-- | 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
525
                    -> CompilerInfo
526
                    -> Solver
527
                    -> DepResolverParams
528
                    -> Progress String String InstallPlan
529

530
    --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages
531
resolveDependencies platform comp _solver params
532
  | null (depResolverTargets params)
533
534
535
  = return (validateSolverResult platform comp indGoals [])
  where
    indGoals = depResolverIndependentGoals params
536

537
resolveDependencies platform comp  solver params =
538

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
539
    Step (showDepResolverParams finalparams)
540
  $ fmap (validateSolverResult platform comp indGoals)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
541
  $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls
Andres Löh's avatar
Andres Löh committed
542
                      shadowing strFlags maxBkjumps)
543
544
                     platform comp installedPkgIndex sourcePkgIndex
                     preferences constraints targets
545
  where
Andres Löh's avatar
Andres Löh committed
546
547

    finalparams @ (DepResolverParams
548
549
      targets constraints
      prefs defpref
550
      installedPkgIndex
551
      sourcePkgIndex
Andres Löh's avatar
Andres Löh committed
552
      reorderGoals
553
      indGoals
Andres Löh's avatar
Andres Löh committed
554
      noReinstalls
555
      shadowing
Andres Löh's avatar
Andres Löh committed
556
      strFlags
Andres Löh's avatar
Andres Löh committed
557
      maxBkjumps)     = dontUpgradeNonUpgradeablePackages
558
                      -- TODO:
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
559
560
561
                      -- The modular solver can properly deal with broken
                      -- packages and won't select them. So the
                      -- 'hideBrokenInstalledPackages' function should be moved
Ian D. Bollinger's avatar
Ian D. Bollinger committed
562
                      -- into a module that is specific to the top-down solver.
563
564
                      . (if solver /= Modular then hideBrokenInstalledPackages
                                              else id)
565
                      $ params
566
567
568
569

    preferences = interpretPackagesPreference
                    (Set.fromList targets) defpref prefs

570

571
-- | Give an interpretation to the global 'PackagesPreference' as
572
573
--  specific per-package 'PackageVersionPreference'.
--
574
interpretPackagesPreference :: Set PackageName
575
576
                            -> PackagesPreferenceDefault
                            -> [PackagePreference]
577
                            -> (PackageName -> PackagePreferences)
578
interpretPackagesPreference selected defaultPref prefs =
579
580
581
  \pkgname -> PackagePreferences (versionPref pkgname)
                                 (installPref pkgname)
                                 (stanzasPref pkgname)
582
583
  where
    versionPref pkgname =
584
585
586
587
      fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs)
    versionPrefs = Map.fromListWith (++)
                   [(pkgname, [pref])
                   | PackageVersionPreference pkgname pref <- prefs]
588
589
590
591
592
593
594

    installPref pkgname =
      fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)
    installPrefs = Map.fromList
      [ (pkgname, pref)
      | PackageInstalledPreference pkgname pref <- prefs ]
    installPrefDefault = case defaultPref of
595
596
      PreferAllLatest         -> const PreferLatest
      PreferAllInstalled      -> const PreferInstalled
597
598
599
600
601
      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
602

603
604
605
606
607
608
609
    stanzasPref pkgname =
      fromMaybe [] (Map.lookup pkgname stanzasPrefs)
    stanzasPrefs = Map.fromListWith (\a b -> nub (a ++ b))
      [ (pkgname, pref)
      | PackageStanzasPreference pkgname pref <- prefs ]


610
611
612
613
614
615
616
617
618
619
-- ------------------------------------------------------------
-- * 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
                     -> Bool
620
                     -> [ResolverPackage]
621
                     -> InstallPlan
622
623
validateSolverResult platform comp indepGoals pkgs =
    case planPackagesProblems platform comp pkgs of
624
      [] -> case InstallPlan.new indepGoals index of
625
626
627
628
629
              Right plan     -> plan
              Left  problems -> error (formatPlanProblems problems)
      problems               -> error (formatPkgProblems problems)

  where
630
631
632
633
    index = InstalledPackageIndex.fromList (map toPlanPackage pkgs)

    toPlanPackage (PreExisting pkg) = InstallPlan.PreExisting pkg
    toPlanPackage (Configured  pkg) = InstallPlan.Configured  pkg
634
635
636
637

    formatPkgProblems  = formatProblemMessage . map showPlanPackageProblem
    formatPlanProblems = formatProblemMessage . map InstallPlan.showPlanProblem

638
    formatProblemMessage problems =
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
      unlines $
        "internal error: could not construct a valid install plan."
      : "The proposed (invalid) plan contained the following problems:"
      : problems
      ++ "Proposed plan:"
      : [InstallPlan.showPlanIndex index]


data PlanPackageProblem =
       InvalidConfiguredPackage ConfiguredPackage [PackageProblem]

showPlanPackageProblem :: PlanPackageProblem -> String
showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) =
     "Package " ++ display (packageId pkg)
  ++ " has an invalid configuration, in particular:\n"
  ++ unlines [ "  " ++ showPackageProblem problem
             | problem <- packageProblems ]

planPackagesProblems :: Platform -> CompilerInfo
658
                     -> [ResolverPackage]
659
660
661
                     -> [PlanPackageProblem]
planPackagesProblems platform cinfo pkgs =
     [ InvalidConfiguredPackage pkg packageProblems
662
     | Configured pkg <- pkgs
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
     , let packageProblems = configuredPackageProblems platform cinfo pkg
     , not (null packageProblems) ]

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

showPackageProblem :: PackageProblem -> String
showPackageProblem (DuplicateFlag (PD.FlagName flag)) =
  "duplicate flag in the flag assignment: " ++ flag

showPackageProblem (MissingFlag (PD.FlagName flag)) =
  "missing an assignment for the flag: " ++ flag

showPackageProblem (ExtraFlag (PD.FlagName flag)) =
  "extra flag given that is not used by the package: " ++ flag

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
                          -> ConfiguredPackage -> [PackageProblem]
configuredPackageProblems platform cinfo
  (ConfiguredPackage pkg specifiedFlags stanzas specifiedDeps') =
     [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]
  ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]
  ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]
  ++ [ DuplicateDeps pkgs
714
715
     | pkgs <- CD.nonSetupDeps (fmap (duplicatesBy (comparing packageName))
                                specifiedDeps) ]
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
  ++ [ MissingDep dep       | OnlyInLeft  dep       <- mergedDeps ]
  ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]
  ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps
                            , not (packageSatisfiesDependency pkgid dep) ]
  where
    specifiedDeps :: ComponentDeps [PackageId]
    specifiedDeps = fmap (map confSrcId) specifiedDeps'

    mergedFlags = mergeBy compare
      (sort $ map PD.flagName (PD.genPackageFlags (packageDescription pkg)))
      (sort $ map fst specifiedFlags)

    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)

738
739
    mergeDeps :: [Dependency] -> [PackageId]
              -> [MergeResult Dependency PackageId]
740
741
742
743
744
745
746
    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)

747
748
749
750
751
752
753
    -- 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`.
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
    requiredDeps :: [Dependency]
    requiredDeps =
      --TODO: use something lower level than finalizePackageDescription
      case finalizePackageDescription specifiedFlags
         (const True)
         platform cinfo
         []
         (enableStanzas stanzas $ packageDescription pkg) of
        Right (resolvedPkg, _) ->
             externalBuildDepends resolvedPkg
          ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg)
        Left  _ ->
          error "configuredPackageInvalidDeps internal error"


769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
-- ------------------------------------------------------------
-- * Simple resolver that ignores dependencies
-- ------------------------------------------------------------

-- | A simplistic method of resolving a list of target package names to
-- available packages.
--
-- Specifically, it does not consider package dependencies at all. Unlike
-- 'resolveDependencies', no attempt is made to ensure that the selected
-- packages have dependencies that are satisfiable or consistent with
-- each other.
--
-- It is suitable for tasks such as selecting packages to download for user
-- inspection. It is not suitable for selecting packages to install.
--
Ian D. Bollinger's avatar
Ian D. Bollinger committed
784
-- Note: if no installed package index is available, it is OK to pass 'mempty'.
785
786
-- It simply means preferences for installed packages will be ignored.
--
787
resolveWithoutDependencies :: DepResolverParams
788
                           -> Either [ResolveNoDepsError] [SourcePackage]
789
resolveWithoutDependencies (DepResolverParams targets constraints
790
                              prefs defpref installedPkgIndex sourcePkgIndex
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
791
                              _reorderGoals _indGoals _avoidReinstalls
Andres Löh's avatar
Andres Löh committed
792
                              _shadowing _strFlags _maxBjumps) =
793
794
    collectEithers (map selectPackage targets)
  where
795
    selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage
796
797
798
799
800
801
802
803
    selectPackage pkgname
      | null choices = Left  $! ResolveUnsatisfiable pkgname requiredVersions
      | otherwise    = Right $! maximumBy bestByPrefs choices

      where
        -- Constraints
        requiredVersions = packageConstraints pkgname
        pkgDependency    = Dependency pkgname requiredVersions
804
805
        choices          = PackageIndex.lookupDependency sourcePkgIndex
                                                         pkgDependency
806
807

        -- Preferences
808
        PackagePreferences preferredVersions preferInstalled _
809
810
811
812
813
814
          = packagePreferences pkgname

        bestByPrefs   = comparing $ \pkg ->
                          (installPref pkg, versionPref pkg, packageVersion pkg)
        installPref   = case preferInstalled of
          PreferLatest    -> const False
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
815
816
          PreferInstalled -> not . null
                           . InstalledPackageIndex.lookupSourcePackageId
817
                                                     installedPkgIndex
818
                           . packageId
819
820
        versionPref pkg = length . filter (packageVersion pkg `withinRange`) $
                          preferredVersions
821
822
823
824
825

    packageConstraints :: PackageName -> VersionRange
    packageConstraints pkgname =
      Map.findWithDefault anyVersion pkgname packageVersionConstraintMap
    packageVersionConstraintMap =
826
827
828
      let pcs = map unlabelPackageConstraint constraints
      in Map.fromList [ (name, range)
                      | PackageConstraintVersion name range <- pcs ]
829
830

    packagePreferences :: PackageName -> PackagePreferences
831
832
    packagePreferences = interpretPackagesPreference
                           (Set.fromList targets) defpref prefs
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858


collectEithers :: [Either a b] -> Either [a] [b]
collectEithers = collect . partitionEithers
  where
    collect ([], xs) = Right xs
    collect (errs,_) = Left errs
    partitionEithers :: [Either a b] -> ([a],[b])
    partitionEithers = foldr (either left right) ([],[])
     where
       left  a (l, r) = (a:l, r)
       right a (l, r) = (l, a:r)

-- | Errors for 'resolveWithoutDependencies'.
--
data ResolveNoDepsError =

     -- | A package name which cannot be resolved to a specific package.
     -- Also gives the constraint on the version and whether there was
     -- a constraint on the package being installed.
     ResolveUnsatisfiable PackageName VersionRange

instance Show ResolveNoDepsError where
  show (ResolveUnsatisfiable name ver) =
       "There is no available version of " ++ display name
    ++ " that satisfies " ++ display (simplifyVersionRange ver)