TopDown.hs 33.8 KB
Newer Older
1
2
-----------------------------------------------------------------------------
-- |
3
-- Module      :  Distribution.Client.Dependency.Types
4
5
6
7
8
9
10
11
12
-- Copyright   :  (c) Duncan Coutts 2008
-- License     :  BSD-like
--
-- Maintainer  :  cabal-devel@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Common types for dependency resolution.
-----------------------------------------------------------------------------
13
module Distribution.Client.Dependency.TopDown (
14
15
16
    topDownResolver
  ) where

17
18
19
import Distribution.Client.Dependency.TopDown.Types
import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints
import Distribution.Client.Dependency.TopDown.Constraints
20
         ( Satisfiable(..) )
21
22
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan
Duncan Coutts's avatar
Duncan Coutts committed
23
         ( PlanPackage(..) )
24
import Distribution.Client.Types
25
         ( AvailablePackage(..), ConfiguredPackage(..), InstalledPackage(..) )
26
import Distribution.Client.Dependency.Types
27
         ( DependencyResolver, PackageConstraint(..)
28
         , PackagePreferences(..), InstalledPreference(..)
29
         , Progress(..), foldProgress )
30

31
32
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Client.PackageIndex (PackageIndex)
33
import Distribution.Package
34
         ( PackageName(..), PackageIdentifier, Package(packageId), packageVersion, packageName
Duncan Coutts's avatar
Duncan Coutts committed
35
36
         , Dependency(Dependency), thisPackageVersion, notThisPackageVersion
         , PackageFixedDeps(depends) )
37
38
import Distribution.PackageDescription
         ( PackageDescription(buildDepends) )
39
40
import Distribution.Client.PackageUtils
         ( externalBuildDepends )
41
import Distribution.PackageDescription.Configuration
42
         ( finalizePackageDescription, flattenPackageDescription )
43
import Distribution.Version
44
45
         ( VersionRange, anyVersion, withinRange, simplifyVersionRange
         , UpperBound(..), asVersionIntervals )
46
47
48
import Distribution.Compiler
         ( CompilerId )
import Distribution.System
49
         ( Platform )
50
51
52
53
54
55
import Distribution.Simple.Utils
         ( equating, comparing )
import Distribution.Text
         ( display )

import Data.List
56
         ( foldl', maximumBy, minimumBy, nub, sort, groupBy )
57
import Data.Maybe
58
         ( fromJust, fromMaybe, catMaybes )
59
60
import Data.Monoid
         ( Monoid(mempty) )
Duncan Coutts's avatar
Duncan Coutts committed
61
62
import Control.Monad
         ( guard )
63
64
import qualified Data.Set as Set
import Data.Set (Set)
65
import qualified Data.Map as Map
66
import qualified Data.Graph as Graph
67
import qualified Data.Array as Array
68
69
import Control.Exception
         ( assert )
70
71
72
73
74
75

-- ------------------------------------------------------------
-- * Search state types
-- ------------------------------------------------------------

type Constraints  = Constraints.Constraints
76
                      InstalledPackageEx UnconfiguredPackage ExclusionReason
77
78
79
80
81
82
83
84
85
86
87
88
89
90
type SelectedPackages = PackageIndex SelectedPackage

-- ------------------------------------------------------------
-- * The search tree type
-- ------------------------------------------------------------

data SearchSpace inherited pkg
   = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]]
   | Failure Failure

-- ------------------------------------------------------------
-- * Traverse a search tree
-- ------------------------------------------------------------

91
explore :: (PackageName -> PackagePreferences)
92
93
94
        -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)
                       SelectablePackage
        -> Progress Log Failure (SelectedPackages, Constraints)
95

96
97
98
explore _    (Failure failure)       = Fail failure
explore _    (ChoiceNode (s,c,_) []) = Done (s,c)
explore pref (ChoiceNode _ choices)  =
99
  case [ choice | [choice] <- choices ] of
100
101
    ((_, node'):_) -> Step (logInfo node') (explore pref node')
    []             -> Step (logInfo node') (explore pref node')
102
      where
103
104
105
        choice     = minimumBy (comparing topSortNumber) choices
        pkgname    = packageName . fst . head $ choice
        (_, node') = maximumBy (bestByPref pkgname) choice
106
107
  where
    topSortNumber choice = case fst (head choice) of
108
      InstalledOnly           (InstalledPackageEx  _ i _) -> i
109
110
      AvailableOnly           (UnconfiguredPackage _ i _) -> i
      InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i
111

112
    bestByPref pkgname = case packageInstalledPreference of
113
114
115
116
        PreferLatest    ->
          comparing (\(p,_) -> (               isPreferred p, packageId p))
        PreferInstalled ->
          comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p))
117
118
119
      where
        isInstalled (AvailableOnly _) = False
        isInstalled _                 = True
120
        isPreferred p = packageVersion p `withinRange` preferredVersions
121
        (PackagePreferences preferredVersions packageInstalledPreference)
122
          = pref pkgname
123

124
125
126
127
128
    logInfo node = Select selected discarded
      where (selected, discarded) = case node of
              Failure    _               -> ([], [])
              ChoiceNode (_,_,changes) _ -> changes

129
130
131
132
133
134
135
136
-- ------------------------------------------------------------
-- * Generate a search tree
-- ------------------------------------------------------------

type ConfigurePackage = PackageIndex SelectablePackage
                     -> SelectablePackage
                     -> Either [Dependency] SelectedPackage

137
138
139
-- | (packages selected, packages discarded)
type SelectionChanges = ([SelectedPackage], [PackageIdentifier])

140
141
142
searchSpace :: ConfigurePackage
            -> Constraints
            -> SelectedPackages
143
            -> SelectionChanges
144
            -> Set PackageName
145
146
147
148
            -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)
                           SelectablePackage
searchSpace configure constraints selected changes next =
  ChoiceNode (selected, constraints, changes)
149
150
151
152
153
154
155
156
157
158
    [ [ (pkg, select name pkg)
      | pkg <- PackageIndex.lookupPackageName available name ]
    | name <- Set.elems next ]
  where
    available = Constraints.choices constraints

    select name pkg = case configure available pkg of
      Left missing -> Failure $ ConfigureFailed pkg
                        [ (dep, Constraints.conflicting constraints dep)
                        | dep <- missing ]
159
160
161
162
163
164
165
      Right pkg' -> case constrainDeps pkg' newDeps constraints [] of
        Left failure       -> Failure failure
        Right (constraints', newDiscarded) ->
          searchSpace configure
            constraints' selected' (newSelected, newDiscarded) next'
        where
          selected' = foldl' (flip PackageIndex.insert) selected newSelected
166
167
168
169
170
171
172
          newSelected =
            case Constraints.isPaired constraints (packageId pkg) of
              Nothing     -> [pkg']
              Just pkgid' -> [pkg', pkg'']
                where
                  Just pkg'' = fmap (\(InstalledOnly p) -> InstalledOnly p)
                    (PackageIndex.lookupPackageId available pkgid')
173
174

          newPkgs   = [ name'
Duncan Coutts's avatar
Duncan Coutts committed
175
                      | dep <- newDeps
176
177
                      , let (Dependency name' _) = untagDependency dep
                      , null (PackageIndex.lookupPackageName selected' name') ]
Duncan Coutts's avatar
Duncan Coutts committed
178
          newDeps   = concatMap packageConstraints newSelected
179
180
          next'     = Set.delete name
                    $ foldl' (flip Set.insert) next newPkgs
181
182
183
184
185
186
187
188

packageConstraints :: SelectedPackage -> [TaggedDependency]
packageConstraints = either installedConstraints availableConstraints
                   . preferAvailable
  where
    preferAvailable (InstalledOnly           pkg) = Left pkg
    preferAvailable (AvailableOnly           pkg) = Right pkg
    preferAvailable (InstalledAndAvailable _ pkg) = Right pkg
189
    installedConstraints (InstalledPackageEx    _ _ deps) =
190
191
192
193
194
195
      [ TaggedDependency InstalledConstraint (thisPackageVersion dep)
      | dep <- deps ]
    availableConstraints (SemiConfiguredPackage _ _ deps) =
      [ TaggedDependency NoInstalledConstraint dep | dep <- deps ]

constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints
196
197
198
              -> [PackageIdentifier]
              -> Either Failure (Constraints, [PackageIdentifier])
constrainDeps pkg []         cs discard =
199
  case addPackageSelectConstraint (packageId pkg) cs of
200
201
202
    Satisfiable cs' discard' -> Right (cs', discard' ++ discard)
    _                        -> impossible
constrainDeps pkg (dep:deps) cs discard =
203
  case addPackageDependencyConstraint (packageId pkg) dep cs of
204
205
206
    Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard)
    Unsatisfiable            -> impossible
    ConflictsWith conflicts  ->
207
208
209
210
211
212
213
      Left (DependencyConflict pkg dep conflicts)

-- ------------------------------------------------------------
-- * The main algorithm
-- ------------------------------------------------------------

search :: ConfigurePackage
214
       -> (PackageName -> PackagePreferences)
215
216
217
       -> Constraints
       -> Set PackageName
       -> Progress Log Failure (SelectedPackages, Constraints)
218
search configure pref constraints =
219
  explore pref . searchSpace configure constraints mempty ([], [])
220
221
222
223
224
225
226
227

-- ------------------------------------------------------------
-- * The top level resolver
-- ------------------------------------------------------------

-- | The main exported resolver, with string logging and failure types to fit
-- the standard 'DependencyResolver' interface.
--
228
topDownResolver :: DependencyResolver
229
topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver'
230
  where
231
    mapMessages :: Progress Log Failure a -> Progress String String a
232
    mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done
233
234
235

-- | The native resolver with detailed structured logging and failure types.
--
236
topDownResolver' :: Platform -> CompilerId
237
                 -> PackageIndex InstalledPackage
238
                 -> PackageIndex AvailablePackage
239
                 -> (PackageName -> PackagePreferences)
240
241
                 -> [PackageConstraint]
                 -> [PackageName]
242
                 -> Progress Log Failure [PlanPackage]
243
topDownResolver' platform comp installed available
244
                 preferences constraints targets =
245
      fmap (uncurry finalise)
246
247
    . (\cs -> search configure preferences cs initialPkgNames)
  =<< addTopLevelConstraints constraints constraintSet
248
249

  where
250
    configure   = configurePackage platform comp
251
    constraintSet :: Constraints
252
253
254
    constraintSet = Constraints.empty
      (annotateInstalledPackages             topSortNumber installed')
      (annotateAvailablePackages constraints topSortNumber available')
255
256
257
    (installed', available') = selectNeededSubset installed available
                                                  initialPkgNames
    topSortNumber = topologicalSortNumbering installed' available'
258

259
    initialPkgNames = Set.fromList targets
260

261
262
263
264
265
    finalise selected' constraints' =
        PackageIndex.allPackages
      . fst . improvePlan installed' constraints'
      . PackageIndex.fromList
      $ finaliseSelectedPackages preferences selected' constraints'
266
267
268
269
270
271
272
273

addTopLevelConstraints :: [PackageConstraint] -> Constraints
                       -> Progress a Failure Constraints
addTopLevelConstraints []                                      cs = Done cs
addTopLevelConstraints (PackageFlagsConstraint   _   _  :deps) cs =
  addTopLevelConstraints deps cs

addTopLevelConstraints (PackageVersionConstraint pkg ver:deps) cs =
274
  case addTopLevelVersionConstraint pkg ver cs of
275
276
277
278
279
280
281
282
    Satisfiable cs' _       ->
      addTopLevelConstraints deps cs'

    Unsatisfiable           ->
      Fail (TopLevelVersionConstraintUnsatisfiable pkg ver)

    ConflictsWith conflicts ->
      Fail (TopLevelVersionConstraintConflict pkg ver conflicts)
283

284
285
286
287
288
289
290
291
292
293
addTopLevelConstraints (PackageInstalledConstraint pkg:deps) cs =
  case addTopLevelInstalledConstraint pkg cs of
    Satisfiable cs' _       -> addTopLevelConstraints deps cs'

    Unsatisfiable           ->
      Fail (TopLevelInstallConstraintUnsatisfiable pkg)

    ConflictsWith conflicts ->
      Fail (TopLevelInstallConstraintConflict pkg conflicts)

294
configurePackage :: Platform -> CompilerId -> ConfigurePackage
295
configurePackage platform comp available spkg = case spkg of
296
297
298
299
300
  InstalledOnly         ipkg      -> Right (InstalledOnly ipkg)
  AvailableOnly              apkg -> fmap AvailableOnly (configure apkg)
  InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg)
                                          (configure apkg)
  where
301
  configure (UnconfiguredPackage apkg@(AvailablePackage _ p _) _ flags) =
302
303
    case finalizePackageDescription flags dependencySatisfiable
                                    platform comp [] p of
304
305
      Left missing        -> Left missing
      Right (pkg, flags') -> Right $
306
        SemiConfiguredPackage apkg flags' (externalBuildDepends pkg)
307

308
309
  dependencySatisfiable = not . null . PackageIndex.lookupDependency available

310
311
-- | Annotate each installed packages with its set of transative dependencies
-- and its topological sort number.
312
--
313
annotateInstalledPackages :: (PackageName -> TopologicalSortNumber)
314
                          -> PackageIndex InstalledPackage
315
                          -> PackageIndex InstalledPackageEx
316
annotateInstalledPackages dfsNumber installed = PackageIndex.fromList
317
  [ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg)
318
  | pkg <- PackageIndex.allPackages installed ]
319
  where
320
    transitiveDepends :: InstalledPackage -> [PackageIdentifier]
321
    transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph
322
                      . fromJust . toVertex . packageId
323
    (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed
324

325

326
327
-- | Annotate each available packages with its topological sort number and any
-- user-supplied partial flag assignment.
328
--
329
annotateAvailablePackages :: [PackageConstraint]
330
                          -> (PackageName -> TopologicalSortNumber)
331
332
                          -> PackageIndex AvailablePackage
                          -> PackageIndex UnconfiguredPackage
333
annotateAvailablePackages constraints dfsNumber available = PackageIndex.fromList
334
335
336
337
338
339
340
  [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name)
  | pkg <- PackageIndex.allPackages available
  , let name = packageName pkg ]
  where
    flagsFor = fromMaybe [] . flip Map.lookup flagsMap
    flagsMap = Map.fromList
      [ (name, flags)
341
      | PackageFlagsConstraint name flags <- constraints ]
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361

-- | One of the heuristics we use when guessing which path to take in the
-- search space is an ordering on the choices we make. It's generally better
-- to make decisions about packages higer in the dep graph first since they
-- place constraints on packages lower in the dep graph.
--
-- To pick them in that order we annotate each package with its topological
-- sort number. So if package A depends on package B then package A will have
-- a lower topological sort number than B and we'll make a choice about which
-- version of A to pick before we make a choice about B (unless there is only
-- one possible choice for B in which case we pick that immediately).
--
-- To construct these topological sort numbers we combine and flatten the
-- installed and available package sets. We consider only dependencies between
-- named packages, not including versions and for not-yet-configured packages
-- we look at all the possible dependencies, not just those under any single
-- flag assignment. This means we can actually get impossible combinations of
-- edges and even cycles, but that doesn't really matter here, it's only a
-- heuristic.
--
362
topologicalSortNumbering :: PackageIndex InstalledPackage
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
                         -> PackageIndex AvailablePackage
                         -> (PackageName -> TopologicalSortNumber)
topologicalSortNumbering installed available =
    \pkgname -> let Just vertex = toVertex pkgname
                 in topologicalSortNumbers Array.! vertex
  where
    topologicalSortNumbers = Array.array (Array.bounds graph)
                                         (zip (Graph.topSort graph) [0..])
    (graph, _, toVertex)   = Graph.graphFromEdges $
         [ ((), packageName pkg, nub deps)
         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installed
         , let deps = [ packageName dep
                      | pkg' <- pkgs
                      , dep  <- depends pkg' ] ]
      ++ [ ((), packageName pkg, nub deps)
         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName available
         , let deps = [ depName
                      | AvailablePackage _ pkg' _ <- pkgs
                      , Dependency depName _ <-
                          buildDepends (flattenPackageDescription pkg') ] ]

384
385
386
387
388
-- | We don't need the entire index (which is rather large and costly if we
-- force it by examining the whole thing). So trace out the maximul subset of
-- each index that we could possibly ever need. Do this by flattening packages
-- and looking at the names of all possible dependencies.
--
389
selectNeededSubset :: PackageIndex InstalledPackage
390
391
                   -> PackageIndex AvailablePackage
                   -> Set PackageName
392
                   -> (PackageIndex InstalledPackage
393
394
395
                      ,PackageIndex AvailablePackage)
selectNeededSubset installed available = select mempty mempty
  where
396
    select :: PackageIndex InstalledPackage
397
398
           -> PackageIndex AvailablePackage
           -> Set PackageName
399
           -> (PackageIndex InstalledPackage
400
401
402
403
404
405
406
407
              ,PackageIndex AvailablePackage)
    select installed' available' remaining
      | Set.null remaining = (installed', available')
      | otherwise = select installed'' available'' remaining''
      where
        (next, remaining') = Set.deleteFindMin remaining
        moreInstalled = PackageIndex.lookupPackageName installed next
        moreAvailable = PackageIndex.lookupPackageName available next
408
409
410
411
        moreRemaining = -- we filter out packages already included in the indexes
                        -- this avoids an infinite loop if a package depends on itself
                        -- like base-3.0.3.0 with base-4.0.0.0
                        filter notAlreadyIncluded
412
413
414
415
416
417
418
                      $ [ packageName dep
                        | pkg <- moreInstalled
                        , dep <- depends pkg ]
                     ++ [ name
                        | AvailablePackage _ pkg _ <- moreAvailable
                        , Dependency name _ <-
                            buildDepends (flattenPackageDescription pkg) ]
419
420
421
422
423
        installed''   = foldl' (flip PackageIndex.insert) installed' moreInstalled
        available''   = foldl' (flip PackageIndex.insert) available' moreAvailable
        remaining''   = foldl' (flip         Set.insert) remaining' moreRemaining
        notAlreadyIncluded name = null (PackageIndex.lookupPackageName installed' name)
                                  && null (PackageIndex.lookupPackageName available' name)
424

425
426
427
428
-- ------------------------------------------------------------
-- * Post processing the solution
-- ------------------------------------------------------------

429
finaliseSelectedPackages :: (PackageName -> PackagePreferences)
430
                         -> SelectedPackages
431
                         -> Constraints
432
                         -> [PlanPackage]
433
finaliseSelectedPackages pref selected constraints =
434
435
436
437
  map finaliseSelected (PackageIndex.allPackages selected)
  where
    remainingChoices = Constraints.choices constraints
    finaliseSelected (InstalledOnly         ipkg     ) = finaliseInstalled ipkg
438
    finaliseSelected (AvailableOnly              apkg) = finaliseAvailable Nothing apkg
439
440
441
442
443
    finaliseSelected (InstalledAndAvailable ipkg apkg) =
      case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of
        Nothing                          -> impossible --picked package not in constraints
        Just (AvailableOnly _)           -> impossible --to constrain to avail only
        Just (InstalledOnly _)           -> finaliseInstalled ipkg
444
        Just (InstalledAndAvailable _ _) -> finaliseAvailable (Just ipkg) apkg
445

446
    finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg
447
    finaliseAvailable mipkg (SemiConfiguredPackage pkg flags deps) =
448
      InstallPlan.Configured (ConfiguredPackage pkg flags deps')
449
      where
450
451
452
        deps' = map (packageId . pickRemaining mipkg) deps

    pickRemaining mipkg dep@(Dependency _name versionRange) =
453
454
455
          case PackageIndex.lookupDependency remainingChoices dep of
            []        -> impossible
            [pkg']    -> pkg'
456
457
            remaining -> assert (checkIsPaired remaining)
                       $ maximumBy bestByPref remaining
458
      where
459
460
461
462
463
464
465
        -- We order candidate packages to pick for a dependency by these
        -- three factors. The last factor is just highest version wins.
        bestByPref =
          comparing (\p -> (isCurrent p, isPreferred p, packageVersion p))
        -- Is the package already used by the installed version of this
        -- package? If so we should pick that first. This stops us from doing
        -- silly things like deciding to rebuild haskell98 against base 3.
466
        isCurrent = case mipkg :: Maybe InstalledPackageEx of
467
468
          Nothing   -> \_ -> False
          Just ipkg -> \p -> packageId p `elem` depends ipkg
469
470
471
472
473
474
475
        -- If there is no upper bound on the version range then we apply a
        -- preferred version acording to the hackage or user's suggested
        -- version constraints. TODO: distinguish hacks from prefs
        bounded = boundedAbove versionRange
        isPreferred p
          | bounded   = True -- any constant will do
          | otherwise = packageVersion p `withinRange` preferredVersions
476
          where (PackagePreferences preferredVersions _) = pref (packageName p)
477

478
479
480
481
482
483
484
        boundedAbove :: VersionRange -> Bool
        boundedAbove vr = case asVersionIntervals vr of
          []        -> True -- this is the inconsistent version range.
          intervals -> case last intervals of
            (_,   UpperBound _ _) -> True
            (_, NoUpperBound    ) -> False

485
486
487
488
489
490
491
492
        -- We really only expect to find more than one choice remaining when
        -- we're finalising a dependency on a paired package.
        checkIsPaired [p1, p2] =
          case Constraints.isPaired constraints (packageId p1) of
            Just p2'   -> packageId p2' == packageId p2
            Nothing    -> False
        checkIsPaired _ = False

Duncan Coutts's avatar
Duncan Coutts committed
493
494
-- | Improve an existing installation plan by, where possible, swapping
-- packages we plan to install with ones that are already installed.
495
496
-- This may add additional constraints due to the dependencies of installed
-- packages on other installed packages.
Duncan Coutts's avatar
Duncan Coutts committed
497
--
498
improvePlan :: PackageIndex InstalledPackage
499
            -> Constraints
500
            -> PackageIndex PlanPackage
501
502
503
            -> (PackageIndex PlanPackage, Constraints)
improvePlan installed constraints0 selected0 =
  foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0)
Duncan Coutts's avatar
Duncan Coutts committed
504
  where
505
506
    improve (selected, constraints) = fromMaybe (selected, constraints)
                                    . improvePkg selected constraints
Duncan Coutts's avatar
Duncan Coutts committed
507
508
509
510
511
512

    -- The idea is to improve the plan by swapping a configured package for
    -- an equivalent installed one. For a particular package the condition is
    -- that the package be in a configured state, that a the same version be
    -- already installed with the exact same dependencies and all the packages
    -- in the plan that it depends on are in the installed state
513
514
    improvePkg selected constraints pkgid = do
      Configured pkg  <- PackageIndex.lookupPackageId selected  pkgid
Duncan Coutts's avatar
Duncan Coutts committed
515
      ipkg            <- PackageIndex.lookupPackageId installed pkgid
516
517
      guard $ all (isInstalled selected) (depends pkg)
      tryInstalled selected constraints [ipkg]
Duncan Coutts's avatar
Duncan Coutts committed
518

519
520
    isInstalled selected pkgid =
      case PackageIndex.lookupPackageId selected pkgid of
521
522
        Just (PreExisting _) -> True
        _                    -> False
Duncan Coutts's avatar
Duncan Coutts committed
523

524
    tryInstalled :: PackageIndex PlanPackage -> Constraints
525
                 -> [InstalledPackage]
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
                 -> Maybe (PackageIndex PlanPackage, Constraints)
    tryInstalled selected constraints [] = Just (selected, constraints)
    tryInstalled selected constraints (pkg:pkgs) =
      case constraintsOk (packageId pkg) (depends pkg) constraints of
        Nothing           -> Nothing
        Just constraints' -> tryInstalled selected' constraints' pkgs'
          where
            selected' = PackageIndex.insert (PreExisting pkg) selected
            pkgs'      = catMaybes (map notSelected (depends pkg)) ++ pkgs
            notSelected pkgid =
              case (PackageIndex.lookupPackageId installed pkgid
                   ,PackageIndex.lookupPackageId selected  pkgid) of
                (Just pkg', Nothing) -> Just pkg'
                _                    -> Nothing

    constraintsOk _     []              constraints = Just constraints
    constraintsOk pkgid (pkgid':pkgids) constraints =
      case addPackageDependencyConstraint pkgid dep constraints of
        Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints'
        _                          -> Nothing
      where
        dep = TaggedDependency InstalledConstraint (thisPackageVersion pkgid')

    reverseTopologicalOrder :: PackageFixedDeps pkg
                            => PackageIndex pkg -> [PackageIdentifier]
551
    reverseTopologicalOrder index = map (packageId . toPkg)
Duncan Coutts's avatar
Duncan Coutts committed
552
553
554
                                  . Graph.topSort
                                  . Graph.transposeG
                                  $ graph
555
      where (graph, toPkg, _) = PackageIndex.dependencyGraph index
Duncan Coutts's avatar
Duncan Coutts committed
556

557
558
559
560
561
-- ------------------------------------------------------------
-- * Adding and recording constraints
-- ------------------------------------------------------------

addPackageSelectConstraint :: PackageIdentifier -> Constraints
562
563
                           -> Satisfiable Constraints
                                [PackageIdentifier] ExclusionReason
564
565
566
567
568
569
570
addPackageSelectConstraint pkgid constraints =
  Constraints.constrain dep reason constraints
  where
    dep    = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid)
    reason = SelectedOther pkgid

addPackageExcludeConstraint :: PackageIdentifier -> Constraints
571
572
                            -> Satisfiable Constraints
                                 [PackageIdentifier] ExclusionReason
573
574
575
576
577
578
579
580
addPackageExcludeConstraint pkgid constraints =
  Constraints.constrain dep reason constraints
  where
    dep    = TaggedDependency NoInstalledConstraint
               (notThisPackageVersion pkgid)
    reason = ExcludedByConfigureFail

addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints
581
582
                               -> Satisfiable Constraints
                                    [PackageIdentifier] ExclusionReason
583
584
585
586
587
addPackageDependencyConstraint pkgid dep constraints =
  Constraints.constrain dep reason constraints
  where
    reason = ExcludedByPackageDependency pkgid dep

588
589
590
591
592
addTopLevelVersionConstraint :: PackageName -> VersionRange
                             -> Constraints
                             -> Satisfiable Constraints
                                  [PackageIdentifier] ExclusionReason
addTopLevelVersionConstraint pkg ver constraints =
593
594
  Constraints.constrain taggedDep reason constraints
  where
595
    dep       = Dependency pkg ver
596
    taggedDep = TaggedDependency NoInstalledConstraint dep
597
    reason    = ExcludedByTopLevelDependency dep
598

599
600
601
602
603
604
605
addTopLevelInstalledConstraint :: PackageName
                               -> Constraints
                               -> Satisfiable Constraints
                                    [PackageIdentifier] ExclusionReason
addTopLevelInstalledConstraint pkg constraints =
  Constraints.constrain taggedDep reason constraints
  where
Duncan Coutts's avatar
Duncan Coutts committed
606
    dep       = Dependency pkg anyVersion
607
608
609
    taggedDep = TaggedDependency InstalledConstraint dep
    reason    = ExcludedByTopLevelDependency dep

610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
-- ------------------------------------------------------------
-- * Reasons for constraints
-- ------------------------------------------------------------

-- | For every constraint we record we also record the reason that constraint
-- is needed. So if we end up failing due to conflicting constraints then we
-- can give an explnanation as to what was conflicting and why.
--
data ExclusionReason =

     -- | We selected this other version of the package. That means we exclude
     -- all the other versions.
     SelectedOther PackageIdentifier

     -- | We excluded this version of the package because it failed to
     -- configure probably because of unsatisfiable deps.
   | ExcludedByConfigureFail

     -- | We excluded this version of the package because another package that
     -- we selected imposed a dependency which this package did not satisfy.
   | ExcludedByPackageDependency PackageIdentifier TaggedDependency

     -- | We excluded this version of the package because it did not satisfy
     -- a dependency given as an original top level input.
     --
   | ExcludedByTopLevelDependency Dependency

-- | Given an excluded package and the reason it was excluded, produce a human
-- readable explanation.
--
showExclusionReason :: PackageIdentifier -> ExclusionReason -> String
showExclusionReason pkgid (SelectedOther pkgid') =
  display pkgid ++ " was excluded because " ++
  display pkgid' ++ " was selected instead"
showExclusionReason pkgid ExcludedByConfigureFail =
  display pkgid ++ " was excluded because it could not be configured"
showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep) =
  display pkgid ++ " was excluded because " ++
648
  display pkgid' ++ " requires " ++ displayDep (untagDependency dep)
649
650
showExclusionReason pkgid (ExcludedByTopLevelDependency dep) =
  display pkgid ++ " was excluded because of the top level dependency " ++
651
  displayDep dep
652

653
654
655
656
657

-- ------------------------------------------------------------
-- * Logging progress and failures
-- ------------------------------------------------------------

658
data Log = Select [SelectedPackage] [PackageIdentifier]
659
660
661
662
663
664
665
data Failure
   = ConfigureFailed
       SelectablePackage
       [(Dependency, [(PackageIdentifier, [ExclusionReason])])]
   | DependencyConflict
       SelectedPackage TaggedDependency
       [(PackageIdentifier, [ExclusionReason])]
666
667
   | TopLevelVersionConstraintConflict
       PackageName VersionRange
668
       [(PackageIdentifier, [ExclusionReason])]
669
670
   | TopLevelVersionConstraintUnsatisfiable
       PackageName VersionRange
671
672
673
674
675
   | TopLevelInstallConstraintConflict
       PackageName
       [(PackageIdentifier, [ExclusionReason])]
   | TopLevelInstallConstraintUnsatisfiable
       PackageName
676
677

showLog :: Log -> String
678
679
680
681
682
showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of
  ("", y) -> y
  (x, "") -> x
  (x,  y) -> x ++ " and " ++ y

683
  where
684
685
686
687
688
689
690
691
    selectedMsg  = "selecting " ++ case selected of
      []     -> ""
      [s]    -> display (packageId s) ++ " " ++ kind s
      (s:ss) -> listOf id
              $ (display (packageId s) ++ " " ++ kind s)
              : [ display (packageVersion s') ++ " " ++ kind s'
                | s' <- ss ]

692
693
694
695
    kind (InstalledOnly _)           = "(installed)"
    kind (AvailableOnly _)           = "(hackage)"
    kind (InstalledAndAvailable _ _) = "(installed or hackage)"

696
697
698
699
700
701
702
    discardedMsg = case discarded of
      []  -> ""
      _   -> "discarding " ++ listOf id
        [ element
        | (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded)
        , element <- display pkgid : map (display . packageVersion) pkgids ]

703
704
705
showFailure :: Failure -> String
showFailure (ConfigureFailed pkg missingDeps) =
     "cannot configure " ++ displayPkg pkg ++ ". It requires "
706
  ++ listOf (displayDep . fst) missingDeps
707
708
709
710
  ++ '\n' : unlines (map (uncurry whyNot) missingDeps)

  where
    whyNot (Dependency name ver) [] =
711
         "There is no available version of " ++ display name
712
      ++ " that satisfies " ++ displayVer ver
713
714

    whyNot dep conflicts =
715
         "For the dependency on " ++ displayDep dep
716
717
718
719
720
721
722
723
724
      ++ " there are these packages: " ++ listOf display pkgs
      ++ ". However none of them are available.\n"
      ++ unlines [ showExclusionReason (packageId pkg') reason
                 | (pkg', reasons) <- conflicts, reason <- reasons ]

      where pkgs = map fst conflicts

showFailure (DependencyConflict pkg (TaggedDependency _ dep) conflicts) =
     "dependencies conflict: "
725
  ++ displayPkg pkg ++ " requires " ++ displayDep dep ++ " however\n"
726
727
728
  ++ unlines [ showExclusionReason (packageId pkg') reason
             | (pkg', reasons) <- conflicts, reason <- reasons ]

729
730
showFailure (TopLevelVersionConstraintConflict name ver conflicts) =
     "constraints conflict: "
731
  ++ "top level constraint " ++ displayDep (Dependency name ver) ++ " however\n"
732
733
734
  ++ unlines [ showExclusionReason (packageId pkg') reason
             | (pkg', reasons) <- conflicts, reason <- reasons ]

735
showFailure (TopLevelVersionConstraintUnsatisfiable name ver) =
736
     "There is no available version of " ++ display name
737
      ++ " that satisfies " ++ displayVer ver
738

739
740
741
742
743
744
745
746
747
showFailure (TopLevelInstallConstraintConflict name conflicts) =
     "constraints conflict: "
  ++ "top level constraint " ++ display name ++ "-installed however\n"
  ++ unlines [ showExclusionReason (packageId pkg') reason
             | (pkg', reasons) <- conflicts, reason <- reasons ]

showFailure (TopLevelInstallConstraintUnsatisfiable name) =
     "There is no installed version of " ++ display name

748
749
750
751
752
753
754
755
756
757
displayVer :: VersionRange -> String
displayVer = display . simplifyVersionRange

displayDep :: Dependency -> String
displayDep = display . simplifyDependency

simplifyDependency :: Dependency -> Dependency
simplifyDependency (Dependency name range) =
  Dependency name (simplifyVersionRange range)

758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
-- ------------------------------------------------------------
-- * Utils
-- ------------------------------------------------------------

impossible :: a
impossible = internalError "impossible"

internalError :: String -> a
internalError msg = error $ "internal error: " ++ msg

displayPkg :: Package pkg => pkg -> String
displayPkg = display . packageId

listOf :: (a -> String) -> [a] -> String
listOf _    []   = []
listOf disp [x0] = disp x0
listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs
  where go x []       = " and " ++ disp x
        go x (x':xs') = ", " ++ disp x ++ go x' xs'