Distribution/Client/Dependency/TopDown.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Distribution.Client.Dependency.Types
   4 -- Copyright   :  (c) Duncan Coutts 2008
   5 -- License     :  BSD-like
   6 --
   7 -- Maintainer  :  cabal-devel@haskell.org
   8 -- Stability   :  provisional
   9 -- Portability :  portable
  10 --
  11 -- Common types for dependency resolution.
  12 -----------------------------------------------------------------------------
  13 module Distribution.Client.Dependency.TopDown (
  14     topDownResolver
  15   ) where
  16
  17 import Distribution.Client.Dependency.TopDown.Types
  18 import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints
  19 import Distribution.Client.Dependency.TopDown.Constraints
  20          ( Satisfiable(..) )
  21 import qualified Distribution.Client.InstallPlan as InstallPlan
  22 import Distribution.Client.InstallPlan
  23          ( PlanPackage(..) )
  24 import Distribution.Client.Types
  25          ( AvailablePackage(..), ConfiguredPackage(..) )
  26 import Distribution.Client.Dependency.Types
  27          ( DependencyResolver, PackageConstraint(..)
  28          , PackagePreferences(..), InstalledPreference(..)
  29          , Progress(..), foldProgress )
  30
  31 import qualified Distribution.Simple.PackageIndex as PackageIndex
  32 import Distribution.Simple.PackageIndex (PackageIndex)
  33 import Distribution.InstalledPackageInfo
  34          ( InstalledPackageInfo )
  35 import Distribution.Package
  36          ( PackageName(..), PackageIdentifier, Package(packageId), packageVersion, packageName
  37          , Dependency(Dependency), thisPackageVersion, notThisPackageVersion
  38          , PackageFixedDeps(depends) )
  39 import Distribution.PackageDescription
  40          ( PackageDescription(buildDepends) )
  41 import Distribution.PackageDescription.Configuration
  42          ( finalizePackageDescription, flattenPackageDescription )
  43 import Distribution.Version
  44          ( VersionRange(AnyVersion), withinRange )
  45 import Distribution.Compiler
  46          ( CompilerId )
  47 import Distribution.System
  48          ( Platform(Platform) )
  49 import Distribution.Simple.Utils
  50          ( equating, comparing )
  51 import Distribution.Text
  52          ( display )
  53
  54 import Data.List
  55          ( foldl', maximumBy, minimumBy, nub, sort, groupBy )
  56 import Data.Maybe
  57          ( fromJust, fromMaybe, catMaybes )
  58 import Data.Monoid
  59          ( Monoid(mempty) )
  60 import Control.Monad
  61          ( guard )
  62 import qualified Data.Set as Set
  63 import Data.Set (Set)
  64 import qualified Data.Map as Map
  65 import qualified Data.Graph as Graph
  66 import qualified Data.Array as Array
  67 import Control.Exception
  68          ( assert )
  69
  70 -- ------------------------------------------------------------
  71 -- * Search state types
  72 -- ------------------------------------------------------------
  73
  74 type Constraints  = Constraints.Constraints
  75                       InstalledPackage UnconfiguredPackage ExclusionReason
  76 type SelectedPackages = PackageIndex SelectedPackage
  77
  78 -- ------------------------------------------------------------
  79 -- * The search tree type
  80 -- ------------------------------------------------------------
  81
  82 data SearchSpace inherited pkg
  83    = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]]
  84    | Failure Failure
  85
  86 -- ------------------------------------------------------------
  87 -- * Traverse a search tree
  88 -- ------------------------------------------------------------
  89
  90 explore :: (PackageName -> PackagePreferences)
  91         -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)
  92                        SelectablePackage
  93         -> Progress Log Failure (SelectedPackages, Constraints)
  94
  95 explore _    (Failure failure)       = Fail failure
  96 explore _    (ChoiceNode (s,c,_) []) = Done (s,c)
  97 explore pref (ChoiceNode _ choices)  =
  98   case [ choice | [choice] <- choices ] of
  99     ((_, node'):_) -> Step (logInfo node') (explore pref node')
 100     []             -> Step (logInfo node') (explore pref node')
 101       where
 102         choice     = minimumBy (comparing topSortNumber) choices
 103         pkgname    = packageName . fst . head $ choice
 104         (_, node') = maximumBy (bestByPref pkgname) choice
 105   where
 106     topSortNumber choice = case fst (head choice) of
 107       InstalledOnly           (InstalledPackage    _ i _) -> i
 108       AvailableOnly           (UnconfiguredPackage _ i _) -> i
 109       InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i
 110
 111     bestByPref pkgname = case packageInstalledPreference of
 112         PreferLatest    ->
 113           comparing (\(p,_) -> (               isPreferred p, packageId p))
 114         PreferInstalled ->
 115           comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p))
 116       where
 117         isInstalled (AvailableOnly _) = False
 118         isInstalled _                 = True
 119         isPreferred p = packageVersion p `withinRange` preferredVersions
 120         (PackagePreferences preferredVersions packageInstalledPreference)
 121           = pref pkgname
 122
 123     logInfo node = Select selected discarded
 124       where (selected, discarded) = case node of
 125               Failure    _               -> ([], [])
 126               ChoiceNode (_,_,changes) _ -> changes
 127
 128 -- ------------------------------------------------------------
 129 -- * Generate a search tree
 130 -- ------------------------------------------------------------
 131
 132 type ConfigurePackage = PackageIndex SelectablePackage
 133                      -> SelectablePackage
 134                      -> Either [Dependency] SelectedPackage
 135
 136 -- | (packages selected, packages discarded)
 137 type SelectionChanges = ([SelectedPackage], [PackageIdentifier])
 138
 139 searchSpace :: ConfigurePackage
 140             -> Constraints
 141             -> SelectedPackages
 142             -> SelectionChanges
 143             -> Set PackageName
 144             -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)
 145                            SelectablePackage
 146 searchSpace configure constraints selected changes next =
 147   ChoiceNode (selected, constraints, changes)
 148     [ [ (pkg, select name pkg)
 149       | pkg <- PackageIndex.lookupPackageName available name ]
 150     | name <- Set.elems next ]
 151   where
 152     available = Constraints.choices constraints
 153
 154     select name pkg = case configure available pkg of
 155       Left missing -> Failure $ ConfigureFailed pkg
 156                         [ (dep, Constraints.conflicting constraints dep)
 157                         | dep <- missing ]
 158       Right pkg' -> case constrainDeps pkg' newDeps constraints [] of
 159         Left failure       -> Failure failure
 160         Right (constraints', newDiscarded) ->
 161           searchSpace configure
 162             constraints' selected' (newSelected, newDiscarded) next'
 163         where
 164           selected' = foldl' (flip PackageIndex.insert) selected newSelected
 165           newSelected =
 166             case Constraints.isPaired constraints (packageId pkg) of
 167               Nothing     -> [pkg']
 168               Just pkgid' -> [pkg', pkg'']
 169                 where
 170                   Just pkg'' = fmap (\(InstalledOnly p) -> InstalledOnly p)
 171                     (PackageIndex.lookupPackageId available pkgid')
 172
 173           newPkgs   = [ name'
 174                       | dep <- newDeps
 175                       , let (Dependency name' _) = untagDependency dep
 176                       , null (PackageIndex.lookupPackageName selected' name') ]
 177           newDeps   = concatMap packageConstraints newSelected
 178           next'     = Set.delete name
 179                     $ foldl' (flip Set.insert) next newPkgs
 180
 181 packageConstraints :: SelectedPackage -> [TaggedDependency]
 182 packageConstraints = either installedConstraints availableConstraints
 183                    . preferAvailable
 184   where
 185     preferAvailable (InstalledOnly           pkg) = Left pkg
 186     preferAvailable (AvailableOnly           pkg) = Right pkg
 187     preferAvailable (InstalledAndAvailable _ pkg) = Right pkg
 188     installedConstraints (InstalledPackage      _ _ deps) =
 189       [ TaggedDependency InstalledConstraint (thisPackageVersion dep)
 190       | dep <- deps ]
 191     availableConstraints (SemiConfiguredPackage _ _ deps) =
 192       [ TaggedDependency NoInstalledConstraint dep | dep <- deps ]
 193
 194 constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints
 195               -> [PackageIdentifier]
 196               -> Either Failure (Constraints, [PackageIdentifier])
 197 constrainDeps pkg []         cs discard =
 198   case addPackageSelectConstraint (packageId pkg) cs of
 199     Satisfiable cs' discard' -> Right (cs', discard' ++ discard)
 200     _                        -> impossible
 201 constrainDeps pkg (dep:deps) cs discard =
 202   case addPackageDependencyConstraint (packageId pkg) dep cs of
 203     Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard)
 204     Unsatisfiable            -> impossible
 205     ConflictsWith conflicts  ->
 206       Left (DependencyConflict pkg dep conflicts)
 207
 208 -- ------------------------------------------------------------
 209 -- * The main algorithm
 210 -- ------------------------------------------------------------
 211
 212 search :: ConfigurePackage
 213        -> (PackageName -> PackagePreferences)
 214        -> Constraints
 215        -> Set PackageName
 216        -> Progress Log Failure (SelectedPackages, Constraints)
 217 search configure pref constraints =
 218   explore pref . searchSpace configure constraints mempty ([], [])
 219
 220 -- ------------------------------------------------------------
 221 -- * The top level resolver
 222 -- ------------------------------------------------------------
 223
 224 -- | The main exported resolver, with string logging and failure types to fit
 225 -- the standard 'DependencyResolver' interface.
 226 --
 227 topDownResolver :: DependencyResolver
 228 topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver'
 229   where
 230     mapMessages :: Progress Log Failure a -> Progress String String a
 231     mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done
 232
 233 -- | The native resolver with detailed structured logging and failure types.
 234 --
 235 topDownResolver' :: Platform -> CompilerId
 236                  -> PackageIndex InstalledPackageInfo
 237                  -> PackageIndex AvailablePackage
 238                  -> (PackageName -> PackagePreferences)
 239                  -> [PackageConstraint]
 240                  -> [PackageName]
 241                  -> Progress Log Failure [PlanPackage]
 242 topDownResolver' platform comp installed available
 243                  preferences constraints targets =
 244       fmap (uncurry finalise)
 245     . (\cs -> search configure preferences cs initialPkgNames)
 246   =<< addTopLevelConstraints constraints constraintSet
 247
 248   where
 249     configure   = configurePackage platform comp
 250     constraintSet = Constraints.empty
 251       (annotateInstalledPackages             topSortNumber installed')
 252       (annotateAvailablePackages constraints topSortNumber available')
 253     (installed', available') = selectNeededSubset installed available
 254                                                   initialPkgNames
 255     topSortNumber = topologicalSortNumbering installed' available'
 256
 257     initialPkgNames = Set.fromList targets
 258
 259     finalise selected' constraints' =
 260         PackageIndex.allPackages
 261       . fst . improvePlan installed' constraints'
 262       . PackageIndex.fromList
 263       $ finaliseSelectedPackages preferences selected' constraints'
 264
 265 addTopLevelConstraints :: [PackageConstraint] -> Constraints
 266                        -> Progress a Failure Constraints
 267 addTopLevelConstraints []                                      cs = Done cs
 268 addTopLevelConstraints (PackageFlagsConstraint   _   _  :deps) cs =
 269   addTopLevelConstraints deps cs
 270
 271 addTopLevelConstraints (PackageVersionConstraint pkg ver:deps) cs =
 272   case addTopLevelVersionConstraint pkg ver cs of
 273     Satisfiable cs' _       ->
 274       addTopLevelConstraints deps cs'
 275
 276     Unsatisfiable           ->
 277       Fail (TopLevelVersionConstraintUnsatisfiable pkg ver)
 278
 279     ConflictsWith conflicts ->
 280       Fail (TopLevelVersionConstraintConflict pkg ver conflicts)
 281
 282 addTopLevelConstraints (PackageInstalledConstraint pkg:deps) cs =
 283   case addTopLevelInstalledConstraint pkg cs of
 284     Satisfiable cs' _       -> addTopLevelConstraints deps cs'
 285
 286     Unsatisfiable           ->
 287       Fail (TopLevelInstallConstraintUnsatisfiable pkg)
 288
 289     ConflictsWith conflicts ->
 290       Fail (TopLevelInstallConstraintConflict pkg conflicts)
 291
 292 configurePackage :: Platform -> CompilerId -> ConfigurePackage
 293 configurePackage (Platform arch os) comp available spkg = case spkg of
 294   InstalledOnly         ipkg      -> Right (InstalledOnly ipkg)
 295   AvailableOnly              apkg -> fmap AvailableOnly (configure apkg)
 296   InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg)
 297                                           (configure apkg)
 298   where
 299   configure (UnconfiguredPackage apkg@(AvailablePackage _ p _) _ flags) =
 300     case finalizePackageDescription flags (Just available) os arch comp [] p of
 301       Left missing        -> Left missing
 302       Right (pkg, flags') -> Right $
 303         SemiConfiguredPackage apkg flags' (buildDepends pkg)
 304
 305 -- | Annotate each installed packages with its set of transative dependencies
 306 -- and its topological sort number.
 307 --
 308 annotateInstalledPackages :: (PackageName -> TopologicalSortNumber)
 309                           -> PackageIndex InstalledPackageInfo
 310                           -> PackageIndex InstalledPackage
 311 annotateInstalledPackages dfsNumber installed = PackageIndex.fromList
 312   [ InstalledPackage pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg)
 313   | pkg <- PackageIndex.allPackages installed ]
 314   where
 315     transitiveDepends :: InstalledPackageInfo -> [PackageIdentifier]
 316     transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph
 317                       . fromJust . toVertex . packageId
 318     (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed
 319
 320
 321 -- | Annotate each available packages with its topological sort number and any
 322 -- user-supplied partial flag assignment.
 323 --
 324 annotateAvailablePackages :: [PackageConstraint]
 325                           -> (PackageName -> TopologicalSortNumber)
 326                           -> PackageIndex AvailablePackage
 327                           -> PackageIndex UnconfiguredPackage
 328 annotateAvailablePackages constraints dfsNumber available = PackageIndex.fromList
 329   [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name)
 330   | pkg <- PackageIndex.allPackages available
 331   , let name = packageName pkg ]
 332   where
 333     flagsFor = fromMaybe [] . flip Map.lookup flagsMap
 334     flagsMap = Map.fromList
 335       [ (name, flags)
 336       | PackageFlagsConstraint name flags <- constraints ]
 337
 338 -- | One of the heuristics we use when guessing which path to take in the
 339 -- search space is an ordering on the choices we make. It's generally better
 340 -- to make decisions about packages higer in the dep graph first since they
 341 -- place constraints on packages lower in the dep graph.
 342 --
 343 -- To pick them in that order we annotate each package with its topological
 344 -- sort number. So if package A depends on package B then package A will have
 345 -- a lower topological sort number than B and we'll make a choice about which
 346 -- version of A to pick before we make a choice about B (unless there is only
 347 -- one possible choice for B in which case we pick that immediately).
 348 --
 349 -- To construct these topological sort numbers we combine and flatten the
 350 -- installed and available package sets. We consider only dependencies between
 351 -- named packages, not including versions and for not-yet-configured packages
 352 -- we look at all the possible dependencies, not just those under any single
 353 -- flag assignment. This means we can actually get impossible combinations of
 354 -- edges and even cycles, but that doesn't really matter here, it's only a
 355 -- heuristic.
 356 --
 357 topologicalSortNumbering :: PackageIndex InstalledPackageInfo
 358                          -> PackageIndex AvailablePackage
 359                          -> (PackageName -> TopologicalSortNumber)
 360 topologicalSortNumbering installed available =
 361     \pkgname -> let Just vertex = toVertex pkgname
 362                  in topologicalSortNumbers Array.! vertex
 363   where
 364     topologicalSortNumbers = Array.array (Array.bounds graph)
 365                                          (zip (Graph.topSort graph) [0..])
 366     (graph, _, toVertex)   = Graph.graphFromEdges $
 367          [ ((), packageName pkg, nub deps)
 368          | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installed
 369          , let deps = [ packageName dep
 370                       | pkg' <- pkgs
 371                       , dep  <- depends pkg' ] ]
 372       ++ [ ((), packageName pkg, nub deps)
 373          | pkgs@(pkg:_) <- PackageIndex.allPackagesByName available
 374          , let deps = [ depName
 375                       | AvailablePackage _ pkg' _ <- pkgs
 376                       , Dependency depName _ <-
 377                           buildDepends (flattenPackageDescription pkg') ] ]
 378
 379 -- | We don't need the entire index (which is rather large and costly if we
 380 -- force it by examining the whole thing). So trace out the maximul subset of
 381 -- each index that we could possibly ever need. Do this by flattening packages
 382 -- and looking at the names of all possible dependencies.
 383 --
 384 selectNeededSubset :: PackageIndex InstalledPackageInfo
 385                    -> PackageIndex AvailablePackage
 386                    -> Set PackageName
 387                    -> (PackageIndex InstalledPackageInfo
 388                       ,PackageIndex AvailablePackage)
 389 selectNeededSubset installed available = select mempty mempty
 390   where
 391     select :: PackageIndex InstalledPackageInfo
 392            -> PackageIndex AvailablePackage
 393            -> Set PackageName
 394            -> (PackageIndex InstalledPackageInfo
 395               ,PackageIndex AvailablePackage)
 396     select installed' available' remaining
 397       | Set.null remaining = (installed', available')
 398       | otherwise = select installed'' available'' remaining''
 399       where
 400         (next, remaining') = Set.deleteFindMin remaining
 401         moreInstalled = PackageIndex.lookupPackageName installed next
 402         moreAvailable = PackageIndex.lookupPackageName available next
 403         moreRemaining = -- we filter out packages already included in the indexes
 404                         -- this avoids an infinite loop if a package depends on itself
 405                         -- like base-3.0.3.0 with base-4.0.0.0
 406                         filter notAlreadyIncluded
 407                       $ [ packageName dep
 408                         | pkg <- moreInstalled
 409                         , dep <- depends pkg ]
 410                      ++ [ name
 411                         | AvailablePackage _ pkg _ <- moreAvailable
 412                         , Dependency name _ <-
 413                             buildDepends (flattenPackageDescription pkg) ]
 414         installed''   = foldl' (flip PackageIndex.insert) installed' moreInstalled
 415         available''   = foldl' (flip PackageIndex.insert) available' moreAvailable
 416         remaining''   = foldl' (flip         Set.insert) remaining' moreRemaining
 417         notAlreadyIncluded name = null (PackageIndex.lookupPackageName installed' name)
 418                                   && null (PackageIndex.lookupPackageName available' name)
 419
 420 -- ------------------------------------------------------------
 421 -- * Post processing the solution
 422 -- ------------------------------------------------------------
 423
 424 finaliseSelectedPackages :: (PackageName -> PackagePreferences)
 425                          -> SelectedPackages
 426                          -> Constraints
 427                          -> [PlanPackage]
 428 finaliseSelectedPackages pref selected constraints =
 429   map finaliseSelected (PackageIndex.allPackages selected)
 430   where
 431     remainingChoices = Constraints.choices constraints
 432     finaliseSelected (InstalledOnly         ipkg     ) = finaliseInstalled ipkg
 433     finaliseSelected (AvailableOnly              apkg) = finaliseAvailable Nothing apkg
 434     finaliseSelected (InstalledAndAvailable ipkg apkg) =
 435       case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of
 436         Nothing                          -> impossible --picked package not in constraints
 437         Just (AvailableOnly _)           -> impossible --to constrain to avail only
 438         Just (InstalledOnly _)           -> finaliseInstalled ipkg
 439         Just (InstalledAndAvailable _ _) -> finaliseAvailable (Just ipkg) apkg
 440
 441     finaliseInstalled (InstalledPackage pkg _ _) = InstallPlan.PreExisting pkg
 442     finaliseAvailable mipkg (SemiConfiguredPackage pkg flags deps) =
 443       InstallPlan.Configured (ConfiguredPackage pkg flags deps')
 444       where
 445         deps' = map (packageId . pickRemaining) deps
 446         pickRemaining dep =
 447           case PackageIndex.lookupDependency remainingChoices dep of
 448             []        -> impossible
 449             [pkg']    -> pkg'
 450             remaining -> assert (checkIsPaired remaining)
 451                        $ maximumBy bestByPref remaining
 452         -- We order candidate packages to pick for a dependency by these
 453         -- three factors. The last factor is just highest version wins.
 454         bestByPref =
 455           comparing (\p -> (isCurrent p, isPreferred p, packageVersion p))
 456         -- Is the package already used by the installed version of this
 457         -- package? If so we should pick that first. This stops us from doing
 458         -- silly things like deciding to rebuild haskell98 against base 3.
 459         isCurrent = case mipkg :: Maybe InstalledPackage of
 460           Nothing   -> \_ -> False
 461           Just ipkg -> \p -> packageId p `elem` depends ipkg
 462         -- Is this package a preferred version acording to the hackage or
 463         -- user's suggested version constraints
 464         isPreferred p = packageVersion p `withinRange` preferredVersions
 465           where (PackagePreferences preferredVersions _) = pref (packageName p)
 466
 467         -- We really only expect to find more than one choice remaining when
 468         -- we're finalising a dependency on a paired package.
 469         checkIsPaired [p1, p2] =
 470           case Constraints.isPaired constraints (packageId p1) of
 471             Just p2'   -> packageId p2' == packageId p2
 472             Nothing    -> False
 473         checkIsPaired _ = False
 474
 475 -- | Improve an existing installation plan by, where possible, swapping
 476 -- packages we plan to install with ones that are already installed.
 477 -- This may add additional constraints due to the dependencies of installed
 478 -- packages on other installed packages.
 479 --
 480 improvePlan :: PackageIndex InstalledPackageInfo
 481             -> Constraints
 482             -> PackageIndex PlanPackage
 483             -> (PackageIndex PlanPackage, Constraints)
 484 improvePlan installed constraints0 selected0 =
 485   foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0)
 486   where
 487     improve (selected, constraints) = fromMaybe (selected, constraints)
 488                                     . improvePkg selected constraints
 489
 490     -- The idea is to improve the plan by swapping a configured package for
 491     -- an equivalent installed one. For a particular package the condition is
 492     -- that the package be in a configured state, that a the same version be
 493     -- already installed with the exact same dependencies and all the packages
 494     -- in the plan that it depends on are in the installed state
 495     improvePkg selected constraints pkgid = do
 496       Configured pkg  <- PackageIndex.lookupPackageId selected  pkgid
 497       ipkg            <- PackageIndex.lookupPackageId installed pkgid
 498       guard $ all (isInstalled selected) (depends pkg)
 499       tryInstalled selected constraints [ipkg]
 500
 501     isInstalled selected pkgid =
 502       case PackageIndex.lookupPackageId selected pkgid of
 503         Just (PreExisting _) -> True
 504         _                    -> False
 505
 506     tryInstalled :: PackageIndex PlanPackage -> Constraints
 507                  -> [InstalledPackageInfo]
 508                  -> Maybe (PackageIndex PlanPackage, Constraints)
 509     tryInstalled selected constraints [] = Just (selected, constraints)
 510     tryInstalled selected constraints (pkg:pkgs) =
 511       case constraintsOk (packageId pkg) (depends pkg) constraints of
 512         Nothing           -> Nothing
 513         Just constraints' -> tryInstalled selected' constraints' pkgs'
 514           where
 515             selected' = PackageIndex.insert (PreExisting pkg) selected
 516             pkgs'      = catMaybes (map notSelected (depends pkg)) ++ pkgs
 517             notSelected pkgid =
 518               case (PackageIndex.lookupPackageId installed pkgid
 519                    ,PackageIndex.lookupPackageId selected  pkgid) of
 520                 (Just pkg', Nothing) -> Just pkg'
 521                 _                    -> Nothing
 522
 523     constraintsOk _     []              constraints = Just constraints
 524     constraintsOk pkgid (pkgid':pkgids) constraints =
 525       case addPackageDependencyConstraint pkgid dep constraints of
 526         Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints'
 527         _                          -> Nothing
 528       where
 529         dep = TaggedDependency InstalledConstraint (thisPackageVersion pkgid')
 530
 531     reverseTopologicalOrder :: PackageFixedDeps pkg
 532                             => PackageIndex pkg -> [PackageIdentifier]
 533     reverseTopologicalOrder index = map (packageId . toPkg)
 534                                   . Graph.topSort
 535                                   . Graph.transposeG
 536                                   $ graph
 537       where (graph, toPkg, _) = PackageIndex.dependencyGraph index
 538
 539 -- ------------------------------------------------------------
 540 -- * Adding and recording constraints
 541 -- ------------------------------------------------------------
 542
 543 addPackageSelectConstraint :: PackageIdentifier -> Constraints
 544                            -> Satisfiable Constraints
 545                                 [PackageIdentifier] ExclusionReason
 546 addPackageSelectConstraint pkgid constraints =
 547   Constraints.constrain dep reason constraints
 548   where
 549     dep    = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid)
 550     reason = SelectedOther pkgid
 551
 552 addPackageExcludeConstraint :: PackageIdentifier -> Constraints
 553                             -> Satisfiable Constraints
 554                                  [PackageIdentifier] ExclusionReason
 555 addPackageExcludeConstraint pkgid constraints =
 556   Constraints.constrain dep reason constraints
 557   where
 558     dep    = TaggedDependency NoInstalledConstraint
 559                (notThisPackageVersion pkgid)
 560     reason = ExcludedByConfigureFail
 561
 562 addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints
 563                                -> Satisfiable Constraints
 564                                     [PackageIdentifier] ExclusionReason
 565 addPackageDependencyConstraint pkgid dep constraints =
 566   Constraints.constrain dep reason constraints
 567   where
 568     reason = ExcludedByPackageDependency pkgid dep
 569
 570 addTopLevelVersionConstraint :: PackageName -> VersionRange
 571                              -> Constraints
 572                              -> Satisfiable Constraints
 573                                   [PackageIdentifier] ExclusionReason
 574 addTopLevelVersionConstraint pkg ver constraints =
 575   Constraints.constrain taggedDep reason constraints
 576   where
 577     dep       = Dependency pkg ver
 578     taggedDep = TaggedDependency NoInstalledConstraint dep
 579     reason    = ExcludedByTopLevelDependency dep
 580
 581 addTopLevelInstalledConstraint :: PackageName
 582                                -> Constraints
 583                                -> Satisfiable Constraints
 584                                     [PackageIdentifier] ExclusionReason
 585 addTopLevelInstalledConstraint pkg constraints =
 586   Constraints.constrain taggedDep reason constraints
 587   where
 588     dep       = Dependency pkg AnyVersion
 589     taggedDep = TaggedDependency InstalledConstraint dep
 590     reason    = ExcludedByTopLevelDependency dep
 591
 592 -- ------------------------------------------------------------
 593 -- * Reasons for constraints
 594 -- ------------------------------------------------------------
 595
 596 -- | For every constraint we record we also record the reason that constraint
 597 -- is needed. So if we end up failing due to conflicting constraints then we
 598 -- can give an explnanation as to what was conflicting and why.
 599 --
 600 data ExclusionReason =
 601
 602      -- | We selected this other version of the package. That means we exclude
 603      -- all the other versions.
 604      SelectedOther PackageIdentifier
 605
 606      -- | We excluded this version of the package because it failed to
 607      -- configure probably because of unsatisfiable deps.
 608    | ExcludedByConfigureFail
 609
 610      -- | We excluded this version of the package because another package that
 611      -- we selected imposed a dependency which this package did not satisfy.
 612    | ExcludedByPackageDependency PackageIdentifier TaggedDependency
 613
 614      -- | We excluded this version of the package because it did not satisfy
 615      -- a dependency given as an original top level input.
 616      --
 617    | ExcludedByTopLevelDependency Dependency
 618
 619 -- | Given an excluded package and the reason it was excluded, produce a human
 620 -- readable explanation.
 621 --
 622 showExclusionReason :: PackageIdentifier -> ExclusionReason -> String
 623 showExclusionReason pkgid (SelectedOther pkgid') =
 624   display pkgid ++ " was excluded because " ++
 625   display pkgid' ++ " was selected instead"
 626 showExclusionReason pkgid ExcludedByConfigureFail =
 627   display pkgid ++ " was excluded because it could not be configured"
 628 showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep) =
 629   display pkgid ++ " was excluded because " ++
 630   display pkgid' ++ " requires " ++ display (untagDependency dep)
 631 showExclusionReason pkgid (ExcludedByTopLevelDependency dep) =
 632   display pkgid ++ " was excluded because of the top level dependency " ++
 633   display dep
 634
 635
 636 -- ------------------------------------------------------------
 637 -- * Logging progress and failures
 638 -- ------------------------------------------------------------
 639
 640 data Log = Select [SelectedPackage] [PackageIdentifier]
 641 data Failure
 642    = ConfigureFailed
 643        SelectablePackage
 644        [(Dependency, [(PackageIdentifier, [ExclusionReason])])]
 645    | DependencyConflict
 646        SelectedPackage TaggedDependency
 647        [(PackageIdentifier, [ExclusionReason])]
 648    | TopLevelVersionConstraintConflict
 649        PackageName VersionRange
 650        [(PackageIdentifier, [ExclusionReason])]
 651    | TopLevelVersionConstraintUnsatisfiable
 652        PackageName VersionRange
 653    | TopLevelInstallConstraintConflict
 654        PackageName
 655        [(PackageIdentifier, [ExclusionReason])]
 656    | TopLevelInstallConstraintUnsatisfiable
 657        PackageName
 658
 659 showLog :: Log -> String
 660 showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of
 661   ("", y) -> y
 662   (x, "") -> x
 663   (x,  y) -> x ++ " and " ++ y
 664
 665   where
 666     selectedMsg  = "selecting " ++ case selected of
 667       []     -> ""
 668       [s]    -> display (packageId s) ++ " " ++ kind s
 669       (s:ss) -> listOf id
 670               $ (display (packageId s) ++ " " ++ kind s)
 671               : [ display (packageVersion s') ++ " " ++ kind s'
 672                 | s' <- ss ]
 673
 674     kind (InstalledOnly _)           = "(installed)"
 675     kind (AvailableOnly _)           = "(hackage)"
 676     kind (InstalledAndAvailable _ _) = "(installed or hackage)"
 677
 678     discardedMsg = case discarded of
 679       []  -> ""
 680       _   -> "discarding " ++ listOf id
 681         [ element
 682         | (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded)
 683         , element <- display pkgid : map (display . packageVersion) pkgids ]
 684
 685 showFailure :: Failure -> String
 686 showFailure (ConfigureFailed pkg missingDeps) =
 687      "cannot configure " ++ displayPkg pkg ++ ". It requires "
 688   ++ listOf (display . fst) missingDeps
 689   ++ '\n' : unlines (map (uncurry whyNot) missingDeps)
 690
 691   where
 692     whyNot (Dependency name ver) [] =
 693          "There is no available version of " ++ display name
 694       ++ " that satisfies " ++ display ver
 695
 696     whyNot dep conflicts =
 697          "For the dependency on " ++ display dep
 698       ++ " there are these packages: " ++ listOf display pkgs
 699       ++ ". However none of them are available.\n"
 700       ++ unlines [ showExclusionReason (packageId pkg') reason
 701                  | (pkg', reasons) <- conflicts, reason <- reasons ]
 702
 703       where pkgs = map fst conflicts
 704
 705 showFailure (DependencyConflict pkg (TaggedDependency _ dep) conflicts) =
 706      "dependencies conflict: "
 707   ++ displayPkg pkg ++ " requires " ++ display dep ++ " however\n"
 708   ++ unlines [ showExclusionReason (packageId pkg') reason
 709              | (pkg', reasons) <- conflicts, reason <- reasons ]
 710
 711 showFailure (TopLevelVersionConstraintConflict name ver conflicts) =
 712      "constraints conflict: "
 713   ++ "top level constraint " ++ display (Dependency name ver) ++ " however\n"
 714   ++ unlines [ showExclusionReason (packageId pkg') reason
 715              | (pkg', reasons) <- conflicts, reason <- reasons ]
 716
 717 showFailure (TopLevelVersionConstraintUnsatisfiable name ver) =
 718      "There is no available version of " ++ display name
 719       ++ " that satisfies " ++ display ver
 720
 721 showFailure (TopLevelInstallConstraintConflict name conflicts) =
 722      "constraints conflict: "
 723   ++ "top level constraint " ++ display name ++ "-installed however\n"
 724   ++ unlines [ showExclusionReason (packageId pkg') reason
 725              | (pkg', reasons) <- conflicts, reason <- reasons ]
 726
 727 showFailure (TopLevelInstallConstraintUnsatisfiable name) =
 728      "There is no installed version of " ++ display name
 729
 730 -- ------------------------------------------------------------
 731 -- * Utils
 732 -- ------------------------------------------------------------
 733
 734 impossible :: a
 735 impossible = internalError "impossible"
 736
 737 internalError :: String -> a
 738 internalError msg = error $ "internal error: " ++ msg
 739
 740 displayPkg :: Package pkg => pkg -> String
 741 displayPkg = display . packageId
 742
 743 listOf :: (a -> String) -> [a] -> String
 744 listOf _    []   = []
 745 listOf disp [x0] = disp x0
 746 listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs
 747   where go x []       = " and " ++ disp x
 748         go x (x':xs') = ", " ++ disp x ++ go x' xs'