cabal-install/src/Distribution/Client/InstallPlan.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE ConstraintKinds #-}
   3 {-# LANGUAGE DeriveDataTypeable #-}
   4 {-# LANGUAGE DeriveGeneric #-}
   5 {-# LANGUAGE FlexibleContexts #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8
   9 -----------------------------------------------------------------------------
  10
  11 -----------------------------------------------------------------------------
  12
  13 -- |
  14 -- Module      :  Distribution.Client.InstallPlan
  15 -- Copyright   :  (c) Duncan Coutts 2008
  16 -- License     :  BSD-like
  17 --
  18 -- Maintainer  :  duncan@community.haskell.org
  19 -- Stability   :  provisional
  20 -- Portability :  portable
  21 --
  22 -- Package installation plan
  23 module Distribution.Client.InstallPlan
  24   ( InstallPlan
  25   , GenericInstallPlan
  26   , PlanPackage
  27   , GenericPlanPackage (..)
  28   , foldPlanPackage
  29   , IsUnit
  30
  31     -- * Operations on 'InstallPlan's
  32   , new
  33   , toGraph
  34   , toList
  35   , toMap
  36   , keys
  37   , keysSet
  38   , planIndepGoals
  39   , depends
  40   , fromSolverInstallPlan
  41   , fromSolverInstallPlanWithProgress
  42   , configureInstallPlan
  43   , remove
  44   , installed
  45   , lookup
  46   , directDeps
  47   , revDirectDeps
  48
  49     -- * Traversal
  50   , executionOrder
  51   , execute
  52   , BuildOutcomes
  53   , lookupBuildOutcome
  54
  55     -- ** Traversal helpers
  56     -- $traversal
  57   , Processing
  58   , ready
  59   , completed
  60   , failed
  61
  62     -- * Display
  63   , showPlanGraph
  64   , ShowPlanNode (..)
  65   , showInstallPlan
  66   , showInstallPlan_gen
  67   , showPlanPackageTag
  68
  69     -- * Graph-like operations
  70   , dependencyClosure
  71   , reverseTopologicalOrder
  72   , reverseDependencyClosure
  73   ) where
  74
  75 import Distribution.Client.Compat.Prelude hiding (lookup, toList)
  76 import Distribution.Compat.Stack (WithCallStack)
  77 import Prelude ()
  78
  79 import Distribution.Client.Types hiding (BuildOutcomes)
  80 import qualified Distribution.PackageDescription as PD
  81 import qualified Distribution.Simple.Configure as Configure
  82 import qualified Distribution.Simple.Setup as Cabal
  83
  84 import Distribution.Client.JobControl
  85 import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
  86 import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
  87 import Distribution.InstalledPackageInfo
  88   ( InstalledPackageInfo
  89   )
  90 import Distribution.Package
  91   ( HasMungedPackageId (..)
  92   , HasUnitId (..)
  93   , Package (..)
  94   , UnitId
  95   )
  96 import Distribution.Pretty (defaultStyle)
  97 import Distribution.Solver.Types.SolverPackage
  98 import Text.PrettyPrint
  99
 100 import qualified Distribution.Solver.Types.ComponentDeps as CD
 101 import Distribution.Solver.Types.InstSolverPackage
 102 import Distribution.Solver.Types.Settings
 103 import Distribution.Solver.Types.SolverId
 104
 105 import Distribution.Utils.LogProgress
 106 import Distribution.Utils.Structured (Structure (Nominal), Structured (..))
 107
 108 -- TODO: Need this when we compute final UnitIds
 109 -- import qualified Distribution.Simple.Configure as Configure
 110
 111 import Control.Exception
 112   ( assert
 113   )
 114 import qualified Data.Foldable as Foldable (all, toList)
 115 import qualified Data.Map as Map
 116 import qualified Data.Set as Set
 117 import Distribution.Compat.Graph (Graph, IsNode (..))
 118 import qualified Distribution.Compat.Graph as Graph
 119
 120 -- When cabal tries to install a number of packages, including all their
 121 -- dependencies it has a non-trivial problem to solve.
 122 --
 123 -- The Problem:
 124 --
 125 -- In general we start with a set of installed packages and a set of source
 126 -- packages.
 127 --
 128 -- Installed packages have fixed dependencies. They have already been built and
 129 -- we know exactly what packages they were built against, including their exact
 130 -- versions.
 131 --
 132 -- Source package have somewhat flexible dependencies. They are specified as
 133 -- version ranges, though really they're predicates. To make matters worse they
 134 -- have conditional flexible dependencies. Configuration flags can affect which
 135 -- packages are required and can place additional constraints on their
 136 -- versions.
 137 --
 138 -- These two sets of package can and usually do overlap. There can be installed
 139 -- packages that are also available as source packages which means they could
 140 -- be re-installed if required, though there will also be packages which are
 141 -- not available as source and cannot be re-installed. Very often there will be
 142 -- extra versions available than are installed. Sometimes we may like to prefer
 143 -- installed packages over source ones or perhaps always prefer the latest
 144 -- available version whether installed or not.
 145 --
 146 -- The goal is to calculate an installation plan that is closed, acyclic and
 147 -- consistent and where every configured package is valid.
 148 --
 149 -- An installation plan is a set of packages that are going to be used
 150 -- together. It will consist of a mixture of installed packages and source
 151 -- packages along with their exact version dependencies. An installation plan
 152 -- is closed if for every package in the set, all of its dependencies are
 153 -- also in the set. It is consistent if for every package in the set, all
 154 -- dependencies which target that package have the same version.
 155
 156 -- Note that plans do not necessarily compose. You might have a valid plan for
 157 -- package A and a valid plan for package B. That does not mean the composition
 158 -- is simultaneously valid for A and B. In particular you're most likely to
 159 -- have problems with inconsistent dependencies.
 160 -- On the other hand it is true that every closed sub plan is valid.
 161
 162 -- | Packages in an install plan
 163 --
 164 -- NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage'
 165 -- intentionally have no 'PackageInstalled' instance. `This is important:
 166 -- PackageInstalled returns only library dependencies, but for package that
 167 -- aren't yet installed we know many more kinds of dependencies (setup
 168 -- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on
 169 -- dependencies in cabal-install should consider what to do with these
 170 -- dependencies; if we give a 'PackageInstalled' instance it would be too easy
 171 -- to get this wrong (and, for instance, call graph traversal functions from
 172 -- Cabal rather than from cabal-install). Instead, see 'PackageInstalled'.
 173 data GenericPlanPackage ipkg srcpkg
 174   = PreExisting ipkg
 175   | Configured srcpkg
 176   | Installed srcpkg
 177   deriving (Eq, Show, Generic)
 178
 179 displayGenericPlanPackage :: (IsUnit ipkg, IsUnit srcpkg) => GenericPlanPackage ipkg srcpkg -> String
 180 displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg)
 181 displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg)
 182 displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey pkg)
 183
 184 -- | Convenience combinator for destructing 'GenericPlanPackage'.
 185 -- This is handy because if you case manually, you have to handle
 186 -- 'Configured' and 'Installed' separately (where often you want
 187 -- them to be the same.)
 188 foldPlanPackage
 189   :: (ipkg -> a)
 190   -> (srcpkg -> a)
 191   -> GenericPlanPackage ipkg srcpkg
 192   -> a
 193 foldPlanPackage f _ (PreExisting ipkg) = f ipkg
 194 foldPlanPackage _ g (Configured srcpkg) = g srcpkg
 195 foldPlanPackage _ g (Installed srcpkg) = g srcpkg
 196
 197 type IsUnit a = (IsNode a, Key a ~ UnitId)
 198
 199 depends :: IsUnit a => a -> [UnitId]
 200 depends = nodeNeighbors
 201
 202 -- NB: Expanded constraint synonym here to avoid undecidable
 203 -- instance errors in GHC 7.8 and earlier.
 204 instance
 205   (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId)
 206   => IsNode (GenericPlanPackage ipkg srcpkg)
 207   where
 208   type Key (GenericPlanPackage ipkg srcpkg) = UnitId
 209   nodeKey (PreExisting ipkg) = nodeKey ipkg
 210   nodeKey (Configured spkg) = nodeKey spkg
 211   nodeKey (Installed spkg) = nodeKey spkg
 212   nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg
 213   nodeNeighbors (Configured spkg) = nodeNeighbors spkg
 214   nodeNeighbors (Installed spkg) = nodeNeighbors spkg
 215
 216 instance (Binary ipkg, Binary srcpkg) => Binary (GenericPlanPackage ipkg srcpkg)
 217 instance (Structured ipkg, Structured srcpkg) => Structured (GenericPlanPackage ipkg srcpkg)
 218
 219 type PlanPackage =
 220   GenericPlanPackage
 221     InstalledPackageInfo
 222     (ConfiguredPackage UnresolvedPkgLoc)
 223
 224 instance
 225   (Package ipkg, Package srcpkg)
 226   => Package (GenericPlanPackage ipkg srcpkg)
 227   where
 228   packageId (PreExisting ipkg) = packageId ipkg
 229   packageId (Configured spkg) = packageId spkg
 230   packageId (Installed spkg) = packageId spkg
 231
 232 instance
 233   (HasMungedPackageId ipkg, HasMungedPackageId srcpkg)
 234   => HasMungedPackageId (GenericPlanPackage ipkg srcpkg)
 235   where
 236   mungedId (PreExisting ipkg) = mungedId ipkg
 237   mungedId (Configured spkg) = mungedId spkg
 238   mungedId (Installed spkg) = mungedId spkg
 239
 240 instance
 241   (HasUnitId ipkg, HasUnitId srcpkg)
 242   => HasUnitId
 243       (GenericPlanPackage ipkg srcpkg)
 244   where
 245   installedUnitId (PreExisting ipkg) = installedUnitId ipkg
 246   installedUnitId (Configured spkg) = installedUnitId spkg
 247   installedUnitId (Installed spkg) = installedUnitId spkg
 248
 249 instance
 250   (HasConfiguredId ipkg, HasConfiguredId srcpkg)
 251   => HasConfiguredId (GenericPlanPackage ipkg srcpkg)
 252   where
 253   configuredId (PreExisting ipkg) = configuredId ipkg
 254   configuredId (Configured spkg) = configuredId spkg
 255   configuredId (Installed spkg) = configuredId spkg
 256
 257 data GenericInstallPlan ipkg srcpkg = GenericInstallPlan
 258   { planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg))
 259   , planIndepGoals :: !IndependentGoals
 260   }
 261   deriving (Typeable)
 262
 263 -- | 'GenericInstallPlan' specialised to most commonly used types.
 264 type InstallPlan =
 265   GenericInstallPlan
 266     InstalledPackageInfo
 267     (ConfiguredPackage UnresolvedPkgLoc)
 268
 269 -- | Smart constructor that deals with caching the 'Graph' representation.
 270 mkInstallPlan
 271   :: (IsUnit ipkg, IsUnit srcpkg)
 272   => String
 273   -> Graph (GenericPlanPackage ipkg srcpkg)
 274   -> IndependentGoals
 275   -> GenericInstallPlan ipkg srcpkg
 276 mkInstallPlan loc graph indepGoals =
 277   assert
 278     (valid loc graph)
 279     GenericInstallPlan
 280       { planGraph = graph
 281       , planIndepGoals = indepGoals
 282       }
 283
 284 internalError :: WithCallStack (String -> String -> a)
 285 internalError loc msg =
 286   error $
 287     "internal error in InstallPlan."
 288       ++ loc
 289       ++ if null msg then "" else ": " ++ msg
 290
 291 instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ipkg srcpkg) where
 292   structure p =
 293     Nominal
 294       (typeRep p)
 295       0
 296       "GenericInstallPlan"
 297       [ structure (Proxy :: Proxy ipkg)
 298       , structure (Proxy :: Proxy srcpkg)
 299       ]
 300
 301 instance
 302   ( IsNode ipkg
 303   , Key ipkg ~ UnitId
 304   , IsNode srcpkg
 305   , Key srcpkg ~ UnitId
 306   , Binary ipkg
 307   , Binary srcpkg
 308   )
 309   => Binary (GenericInstallPlan ipkg srcpkg)
 310   where
 311   put
 312     GenericInstallPlan
 313       { planGraph = graph
 314       , planIndepGoals = indepGoals
 315       } = put graph >> put indepGoals
 316
 317   get = do
 318     graph <- get
 319     indepGoals <- get
 320     return $! mkInstallPlan "(instance Binary)" graph indepGoals
 321
 322 data ShowPlanNode = ShowPlanNode
 323   { showPlanHerald :: Doc
 324   , showPlanNeighbours :: [Doc]
 325   }
 326
 327 showPlanGraph :: [ShowPlanNode] -> String
 328 showPlanGraph graph =
 329   renderStyle defaultStyle $
 330     vcat (map dispPlanPackage graph)
 331   where
 332     dispPlanPackage (ShowPlanNode herald neighbours) =
 333       hang herald 2 (vcat neighbours)
 334
 335 -- | Generic way to show a 'GenericInstallPlan' which elicits quite a lot of information
 336 showInstallPlan_gen
 337   :: forall ipkg srcpkg
 338    . (GenericPlanPackage ipkg srcpkg -> ShowPlanNode)
 339   -> GenericInstallPlan ipkg srcpkg
 340   -> String
 341 showInstallPlan_gen toShow = showPlanGraph . fmap toShow . Foldable.toList . planGraph
 342
 343 showInstallPlan
 344   :: forall ipkg srcpkg
 345    . (Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg)
 346   => GenericInstallPlan ipkg srcpkg
 347   -> String
 348 showInstallPlan = showInstallPlan_gen toShow
 349   where
 350     toShow :: GenericPlanPackage ipkg srcpkg -> ShowPlanNode
 351     toShow p =
 352       ShowPlanNode
 353         ( hsep
 354             [ text (showPlanPackageTag p)
 355             , pretty (packageId p)
 356             , parens (pretty (nodeKey p))
 357             ]
 358         )
 359         (map pretty (nodeNeighbors p))
 360
 361 showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String
 362 showPlanPackageTag (PreExisting _) = "PreExisting"
 363 showPlanPackageTag (Configured _) = "Configured"
 364 showPlanPackageTag (Installed _) = "Installed"
 365
 366 -- | Build an installation plan from a valid set of resolved packages.
 367 new
 368   :: (IsUnit ipkg, IsUnit srcpkg)
 369   => IndependentGoals
 370   -> Graph (GenericPlanPackage ipkg srcpkg)
 371   -> GenericInstallPlan ipkg srcpkg
 372 new indepGoals graph = mkInstallPlan "new" graph indepGoals
 373
 374 toGraph
 375   :: GenericInstallPlan ipkg srcpkg
 376   -> Graph (GenericPlanPackage ipkg srcpkg)
 377 toGraph = planGraph
 378
 379 toList
 380   :: GenericInstallPlan ipkg srcpkg
 381   -> [GenericPlanPackage ipkg srcpkg]
 382 toList = Foldable.toList . planGraph
 383
 384 toMap
 385   :: GenericInstallPlan ipkg srcpkg
 386   -> Map UnitId (GenericPlanPackage ipkg srcpkg)
 387 toMap = Graph.toMap . planGraph
 388
 389 keys :: GenericInstallPlan ipkg srcpkg -> [UnitId]
 390 keys = Graph.keys . planGraph
 391
 392 keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId
 393 keysSet = Graph.keysSet . planGraph
 394
 395 -- | Remove packages from the install plan. This will result in an
 396 -- error if there are remaining packages that depend on any matching
 397 -- package. This is primarily useful for obtaining an install plan for
 398 -- the dependencies of a package or set of packages without actually
 399 -- installing the package itself, as when doing development.
 400 remove
 401   :: (IsUnit ipkg, IsUnit srcpkg)
 402   => (GenericPlanPackage ipkg srcpkg -> Bool)
 403   -> GenericInstallPlan ipkg srcpkg
 404   -> GenericInstallPlan ipkg srcpkg
 405 remove shouldRemove plan =
 406   mkInstallPlan "remove" newGraph (planIndepGoals plan)
 407   where
 408     newGraph =
 409       Graph.fromDistinctList $
 410         filter (not . shouldRemove) (toList plan)
 411
 412 -- | Change a number of packages in the 'Configured' state to the 'Installed'
 413 -- state.
 414 --
 415 -- To preserve invariants, the package must have all of its dependencies
 416 -- already installed too (that is 'PreExisting' or 'Installed').
 417 installed
 418   :: (IsUnit ipkg, IsUnit srcpkg)
 419   => (srcpkg -> Bool)
 420   -> GenericInstallPlan ipkg srcpkg
 421   -> GenericInstallPlan ipkg srcpkg
 422 installed shouldBeInstalled installPlan =
 423   foldl'
 424     markInstalled
 425     installPlan
 426     [ pkg
 427     | Configured pkg <- reverseTopologicalOrder installPlan
 428     , shouldBeInstalled pkg
 429     ]
 430   where
 431     markInstalled plan pkg =
 432       assert (all isInstalled (directDeps plan (nodeKey pkg))) $
 433         plan
 434           { planGraph = Graph.insert (Installed pkg) (planGraph plan)
 435           }
 436
 437 -- | Lookup a package in the plan.
 438 lookup
 439   :: (IsUnit ipkg, IsUnit srcpkg)
 440   => GenericInstallPlan ipkg srcpkg
 441   -> UnitId
 442   -> Maybe (GenericPlanPackage ipkg srcpkg)
 443 lookup plan pkgid = Graph.lookup pkgid (planGraph plan)
 444
 445 -- | Find all the direct dependencies of the given package.
 446 --
 447 -- Note that the package must exist in the plan or it is an error.
 448 directDeps
 449   :: GenericInstallPlan ipkg srcpkg
 450   -> UnitId
 451   -> [GenericPlanPackage ipkg srcpkg]
 452 directDeps plan pkgid =
 453   case Graph.neighbors (planGraph plan) pkgid of
 454     Just deps -> deps
 455     Nothing -> internalError "directDeps" "package not in graph"
 456
 457 -- | Find all the direct reverse dependencies of the given package.
 458 --
 459 -- Note that the package must exist in the plan or it is an error.
 460 revDirectDeps
 461   :: GenericInstallPlan ipkg srcpkg
 462   -> UnitId
 463   -> [GenericPlanPackage ipkg srcpkg]
 464 revDirectDeps plan pkgid =
 465   case Graph.revNeighbors (planGraph plan) pkgid of
 466     Just deps -> deps
 467     Nothing -> internalError "revDirectDeps" "package not in graph"
 468
 469 -- | Return all the packages in the 'InstallPlan' in reverse topological order.
 470 -- That is, for each package, all dependencies of the package appear first.
 471 --
 472 -- Compared to 'executionOrder', this function returns all the installed and
 473 -- source packages rather than just the source ones. Also, while both this
 474 -- and 'executionOrder' produce reverse topological orderings of the package
 475 -- dependency graph, it is not necessarily exactly the same order.
 476 reverseTopologicalOrder
 477   :: GenericInstallPlan ipkg srcpkg
 478   -> [GenericPlanPackage ipkg srcpkg]
 479 reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan)
 480
 481 -- | Return the packages in the plan that are direct or indirect dependencies of
 482 -- the given packages.
 483 dependencyClosure
 484   :: GenericInstallPlan ipkg srcpkg
 485   -> [UnitId]
 486   -> [GenericPlanPackage ipkg srcpkg]
 487 dependencyClosure plan =
 488   fromMaybe []
 489     . Graph.closure (planGraph plan)
 490
 491 -- | Return the packages in the plan that depend directly or indirectly on the
 492 -- given packages.
 493 reverseDependencyClosure
 494   :: GenericInstallPlan ipkg srcpkg
 495   -> [UnitId]
 496   -> [GenericPlanPackage ipkg srcpkg]
 497 reverseDependencyClosure plan =
 498   fromMaybe []
 499     . Graph.revClosure (planGraph plan)
 500
 501 -- Alert alert!   Why does SolverId map to a LIST of plan packages?
 502 -- The sordid story has to do with 'build-depends' on a package
 503 -- with libraries and executables.  In an ideal world, we would
 504 -- ONLY depend on the library in this situation.  But c.f. #3661
 505 -- some people rely on the build-depends to ALSO implicitly
 506 -- depend on an executable.
 507 --
 508 -- I don't want to commit to a strategy yet, so the only possible
 509 -- thing you can do in this case is return EVERYTHING and let
 510 -- the client filter out what they want (executables? libraries?
 511 -- etc).  This similarly implies we can't return a 'ConfiguredId'
 512 -- because that's not enough information.
 513
 514 fromSolverInstallPlan
 515   :: (IsUnit ipkg, IsUnit srcpkg)
 516   => ( (SolverId -> [GenericPlanPackage ipkg srcpkg])
 517        -> SolverInstallPlan.SolverPlanPackage
 518        -> [GenericPlanPackage ipkg srcpkg]
 519      )
 520   -> SolverInstallPlan
 521   -> GenericInstallPlan ipkg srcpkg
 522 fromSolverInstallPlan f plan =
 523   mkInstallPlan
 524     "fromSolverInstallPlan"
 525     (Graph.fromDistinctList pkgs'')
 526     (SolverInstallPlan.planIndepGoals plan)
 527   where
 528     (_, _, pkgs'') =
 529       foldl'
 530         f'
 531         (Map.empty, Map.empty, [])
 532         (SolverInstallPlan.reverseTopologicalOrder plan)
 533
 534     f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs)
 535       where
 536         pkgs' = f (mapDep pidMap ipiMap) pkg
 537
 538         (pidMap', ipiMap') =
 539           case nodeKey pkg of
 540             PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)
 541             PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap)
 542
 543     mapDep _ ipiMap (PreExistingId _pid uid)
 544       | Just pkgs <- Map.lookup uid ipiMap = pkgs
 545       | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid)
 546     mapDep pidMap _ (PlannedId pid)
 547       | Just pkgs <- Map.lookup pid pidMap = pkgs
 548       | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid)
 549
 550 -- This shouldn't happen, since mapDep should only be called
 551 -- on neighbor SolverId, which must have all been done already
 552 -- by the reverse top-sort (we assume the graph is not broken).
 553
 554 fromSolverInstallPlanWithProgress
 555   :: (IsUnit ipkg, IsUnit srcpkg)
 556   => ( (SolverId -> [GenericPlanPackage ipkg srcpkg])
 557        -> SolverInstallPlan.SolverPlanPackage
 558        -> LogProgress [GenericPlanPackage ipkg srcpkg]
 559      )
 560   -> SolverInstallPlan
 561   -> LogProgress (GenericInstallPlan ipkg srcpkg)
 562 fromSolverInstallPlanWithProgress f plan = do
 563   (_, _, pkgs'') <-
 564     foldM
 565       f'
 566       (Map.empty, Map.empty, [])
 567       (SolverInstallPlan.reverseTopologicalOrder plan)
 568   return $
 569     mkInstallPlan
 570       "fromSolverInstallPlanWithProgress"
 571       (Graph.fromDistinctList pkgs'')
 572       (SolverInstallPlan.planIndepGoals plan)
 573   where
 574     f' (pidMap, ipiMap, pkgs) pkg = do
 575       pkgs' <- f (mapDep pidMap ipiMap) pkg
 576       let (pidMap', ipiMap') =
 577             case nodeKey pkg of
 578               PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)
 579               PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap)
 580       return (pidMap', ipiMap', pkgs' ++ pkgs)
 581
 582     mapDep _ ipiMap (PreExistingId _pid uid)
 583       | Just pkgs <- Map.lookup uid ipiMap = pkgs
 584       | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid)
 585     mapDep pidMap _ (PlannedId pid)
 586       | Just pkgs <- Map.lookup pid pidMap = pkgs
 587       | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid)
 588
 589 -- This shouldn't happen, since mapDep should only be called
 590 -- on neighbor SolverId, which must have all been done already
 591 -- by the reverse top-sort (we assume the graph is not broken).
 592
 593 -- | Conversion of 'SolverInstallPlan' to 'InstallPlan'.
 594 -- Similar to 'elaboratedInstallPlan'
 595 configureInstallPlan :: Cabal.ConfigFlags -> SolverInstallPlan -> InstallPlan
 596 configureInstallPlan configFlags solverPlan =
 597   flip fromSolverInstallPlan solverPlan $ \mapDep planpkg ->
 598     [ case planpkg of
 599         SolverInstallPlan.PreExisting pkg ->
 600           PreExisting (instSolverPkgIPI pkg)
 601         SolverInstallPlan.Configured pkg ->
 602           Configured (configureSolverPackage mapDep pkg)
 603     ]
 604   where
 605     configureSolverPackage
 606       :: (SolverId -> [PlanPackage])
 607       -> SolverPackage UnresolvedPkgLoc
 608       -> ConfiguredPackage UnresolvedPkgLoc
 609     configureSolverPackage mapDep spkg =
 610       ConfiguredPackage
 611         { confPkgId =
 612             Configure.computeComponentId
 613               ( Cabal.fromFlagOrDefault
 614                   False
 615                   (Cabal.configDeterministic configFlags)
 616               )
 617               Cabal.NoFlag
 618               Cabal.NoFlag
 619               (packageId spkg)
 620               (PD.CLibName PD.LMainLibName)
 621               ( Just
 622                   ( map confInstId (CD.libraryDeps deps)
 623                   , solverPkgFlags spkg
 624                   )
 625               )
 626         , confPkgSource = solverPkgSource spkg
 627         , confPkgFlags = solverPkgFlags spkg
 628         , confPkgStanzas = solverPkgStanzas spkg
 629         , confPkgDeps = deps
 630         -- NB: no support for executable dependencies
 631         }
 632       where
 633         deps = fmap (concatMap (map configuredId . mapDep)) (solverPkgLibDeps spkg)
 634
 635 -- ------------------------------------------------------------
 636
 637 -- * Primitives for traversing plans
 638
 639 -- ------------------------------------------------------------
 640
 641 -- $traversal
 642 --
 643 -- Algorithms to traverse or execute an 'InstallPlan', especially in parallel,
 644 -- may make use of the 'Processing' type and the associated operations
 645 -- 'ready', 'completed' and 'failed'.
 646 --
 647 -- The 'Processing' type is used to keep track of the state of a traversal and
 648 -- includes the set of packages that are in the processing state, e.g. in the
 649 -- process of being installed, plus those that have been completed and those
 650 -- where processing failed.
 651 --
 652 -- Traversal algorithms start with an 'InstallPlan':
 653 --
 654 -- * Initially there will be certain packages that can be processed immediately
 655 --   (since they are configured source packages and have all their dependencies
 656 --   installed already). The function 'ready' returns these packages plus a
 657 --   'Processing' state that marks these same packages as being in the
 658 --   processing state.
 659 --
 660 -- * The algorithm must now arrange for these packages to be processed
 661 --   (possibly in parallel). When a package has completed processing, the
 662 --   algorithm needs to know which other packages (if any) are now ready to
 663 --   process as a result. The 'completed' function marks a package as completed
 664 --   and returns any packages that are newly in the processing state (ie ready
 665 --   to process), along with the updated 'Processing' state.
 666 --
 667 -- * If failure is possible then when processing a package fails, the algorithm
 668 --   needs to know which other packages have also failed as a result. The
 669 --   'failed' function marks the given package as failed as well as all the
 670 --   other packages that depend on the failed package. In addition it returns
 671 --   the other failed packages.
 672
 673 -- | The 'Processing' type is used to keep track of the state of a traversal
 674 -- and includes the set of packages that are in the processing state, e.g. in
 675 -- the process of being installed, plus those that have been completed and
 676 -- those where processing failed.
 677 data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId)
 678
 679 -- processing,   completed,    failed
 680
 681 -- | The packages in the plan that are initially ready to be installed.
 682 -- That is they are in the configured state and have all their dependencies
 683 -- installed already.
 684 --
 685 -- The result is both the packages that are now ready to be installed and also
 686 -- a 'Processing' state containing those same packages. The assumption is that
 687 -- all the packages that are ready will now be processed and so we can consider
 688 -- them to be in the processing state.
 689 ready
 690   :: (IsUnit ipkg, IsUnit srcpkg)
 691   => GenericInstallPlan ipkg srcpkg
 692   -> ([GenericReadyPackage srcpkg], Processing)
 693 ready plan =
 694   assert (processingInvariant plan processing) $
 695     (readyPackages, processing)
 696   where
 697     !processing =
 698       Processing
 699         (Set.fromList [nodeKey pkg | pkg <- readyPackages])
 700         (Set.fromList [nodeKey pkg | pkg <- toList plan, isInstalled pkg])
 701         Set.empty
 702     readyPackages =
 703       [ ReadyPackage pkg
 704       | Configured pkg <- toList plan
 705       , all isInstalled (directDeps plan (nodeKey pkg))
 706       ]
 707
 708 isInstalled :: GenericPlanPackage a b -> Bool
 709 isInstalled (PreExisting{}) = True
 710 isInstalled (Installed{}) = True
 711 isInstalled _ = False
 712
 713 -- | Given a package in the processing state, mark the package as completed
 714 -- and return any packages that are newly in the processing state (ie ready to
 715 -- process), along with the updated 'Processing' state.
 716 completed
 717   :: forall ipkg srcpkg
 718    . (IsUnit ipkg, IsUnit srcpkg)
 719   => GenericInstallPlan ipkg srcpkg
 720   -> Processing
 721   -> UnitId
 722   -> ([GenericReadyPackage srcpkg], Processing)
 723 completed plan (Processing processingSet completedSet failedSet) pkgid =
 724   assert (pkgid `Set.member` processingSet) $
 725     assert (processingInvariant plan processing') $
 726       ( map asReadyPackage newlyReady
 727       , processing'
 728       )
 729   where
 730     completedSet' = Set.insert pkgid completedSet
 731
 732     -- each direct reverse dep where all direct deps are completed
 733     newlyReady =
 734       [ dep
 735       | dep <- revDirectDeps plan pkgid
 736       , all
 737           ((`Set.member` completedSet') . nodeKey)
 738           (directDeps plan (nodeKey dep))
 739       ]
 740
 741     processingSet' =
 742       foldl'
 743         (flip Set.insert)
 744         (Set.delete pkgid processingSet)
 745         (map nodeKey newlyReady)
 746     processing' = Processing processingSet' completedSet' failedSet
 747
 748     asReadyPackage :: GenericPlanPackage ipkg srcpkg -> GenericReadyPackage srcpkg
 749     asReadyPackage (Configured pkg) = ReadyPackage pkg
 750     asReadyPackage pkg = internalError "completed" $ "not in configured state: " ++ displayGenericPlanPackage pkg
 751
 752 failed
 753   :: (IsUnit ipkg, IsUnit srcpkg)
 754   => GenericInstallPlan ipkg srcpkg
 755   -> Processing
 756   -> UnitId
 757   -> ([srcpkg], Processing)
 758 failed plan (Processing processingSet completedSet failedSet) pkgid =
 759   assert (pkgid `Set.member` processingSet) $
 760     assert (all (`Set.notMember` processingSet) (drop 1 newlyFailedIds)) $
 761       assert (all (`Set.notMember` completedSet) (drop 1 newlyFailedIds)) $
 762         -- but note that some newlyFailed may already be in the failed set
 763         -- since one package can depend on two packages that both fail and
 764         -- so would be in the rev-dep closure for both.
 765         assert (processingInvariant plan processing') $
 766           ( map asConfiguredPackage (drop 1 newlyFailed)
 767           , processing'
 768           )
 769   where
 770     processingSet' = Set.delete pkgid processingSet
 771     failedSet' = failedSet `Set.union` Set.fromList newlyFailedIds
 772     newlyFailedIds = map nodeKey newlyFailed
 773     newlyFailed =
 774       fromMaybe (internalError "failed" "package not in graph") $
 775         Graph.revClosure (planGraph plan) [pkgid]
 776     processing' = Processing processingSet' completedSet failedSet'
 777
 778     asConfiguredPackage (Configured pkg) = pkg
 779     asConfiguredPackage pkg = internalError "failed" $ "not in configured state: " ++ displayGenericPlanPackage pkg
 780
 781 processingInvariant
 782   :: (IsUnit ipkg, IsUnit srcpkg)
 783   => GenericInstallPlan ipkg srcpkg
 784   -> Processing
 785   -> Bool
 786 processingInvariant plan (Processing processingSet completedSet failedSet) =
 787   -- All the packages in the three sets are actually in the graph
 788   assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet)
 789     $ assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet)
 790     $ assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet)
 791     $
 792     -- The processing, completed and failed sets are disjoint from each other
 793     assert (noIntersection processingSet completedSet)
 794     $ assert (noIntersection processingSet failedSet)
 795     $ assert (noIntersection failedSet completedSet)
 796     $
 797     -- Packages that depend on a package that's still processing cannot be
 798     -- completed
 799     assert (noIntersection (reverseClosure processingSet) completedSet)
 800     $
 801     -- On the other hand, packages that depend on a package that's still
 802     -- processing /can/ have failed (since they may have depended on multiple
 803     -- packages that were processing, but it only takes one to fail to cause
 804     -- knock-on failures) so it is quite possible to have an
 805     -- intersection (reverseClosure processingSet) failedSet
 806
 807     -- The failed set is upwards closed, i.e. equal to its own rev dep closure
 808     assert (failedSet == reverseClosure failedSet)
 809     $
 810     -- All immediate reverse deps of packages that are currently processing
 811     -- are not currently being processed (ie not in the processing set).
 812     assert
 813       ( and
 814           [ rdeppkgid `Set.notMember` processingSet
 815           | pkgid <- Set.toList processingSet
 816           , rdeppkgid <-
 817               maybe
 818                 (internalError "processingInvariant" "")
 819                 (map nodeKey)
 820                 (Graph.revNeighbors (planGraph plan) pkgid)
 821           ]
 822       )
 823     $
 824     -- Packages from the processing or failed sets are only ever in the
 825     -- configured state.
 826     assert
 827       ( and
 828           [ case Graph.lookup pkgid (planGraph plan) of
 829             Just (Configured _) -> True
 830             Just (PreExisting _) -> False
 831             Just (Installed _) -> False
 832             Nothing -> False
 833           | pkgid <- Set.toList processingSet ++ Set.toList failedSet
 834           ]
 835       )
 836       -- We use asserts rather than returning False so that on failure we get
 837       -- better details on which bit of the invariant was violated.
 838       True
 839   where
 840     reverseClosure =
 841       Set.fromList
 842         . map nodeKey
 843         . fromMaybe (internalError "processingInvariant" "")
 844         . Graph.revClosure (planGraph plan)
 845         . Set.toList
 846     noIntersection a b = Set.null (Set.intersection a b)
 847
 848 -- ------------------------------------------------------------
 849
 850 -- * Traversing plans
 851
 852 -- ------------------------------------------------------------
 853
 854 -- | Flatten an 'InstallPlan', producing the sequence of source packages in
 855 -- the order in which they would be processed when the plan is executed. This
 856 -- can be used for simulations or presenting execution dry-runs.
 857 --
 858 -- It is guaranteed to give the same order as using 'execute' (with a serial
 859 -- in-order 'JobControl'), which is a reverse topological orderings of the
 860 -- source packages in the dependency graph, albeit not necessarily exactly the
 861 -- same ordering as that produced by 'reverseTopologicalOrder'.
 862 executionOrder
 863   :: (IsUnit ipkg, IsUnit srcpkg)
 864   => GenericInstallPlan ipkg srcpkg
 865   -> [GenericReadyPackage srcpkg]
 866 executionOrder plan =
 867   let (newpkgs, processing) = ready plan
 868    in tryNewTasks processing newpkgs
 869   where
 870     tryNewTasks _processing [] = []
 871     tryNewTasks processing (p : todo) = waitForTasks processing p todo
 872
 873     waitForTasks processing p todo =
 874       p : tryNewTasks processing' (todo ++ nextpkgs)
 875       where
 876         (nextpkgs, processing') = completed plan processing (nodeKey p)
 877
 878 -- ------------------------------------------------------------
 879
 880 -- * Executing plans
 881
 882 -- ------------------------------------------------------------
 883
 884 -- | The set of results we get from executing an install plan.
 885 type BuildOutcomes failure result = Map UnitId (Either failure result)
 886
 887 -- | Lookup the build result for a single package.
 888 lookupBuildOutcome
 889   :: HasUnitId pkg
 890   => pkg
 891   -> BuildOutcomes failure result
 892   -> Maybe (Either failure result)
 893 lookupBuildOutcome = Map.lookup . installedUnitId
 894
 895 -- | Execute an install plan. This traverses the plan in dependency order.
 896 --
 897 -- Executing each individual package can fail and if so all dependents fail
 898 -- too. The result for each package is collected as a 'BuildOutcomes' map.
 899 --
 900 -- Visiting each package happens with optional parallelism, as determined by
 901 -- the 'JobControl'. By default, after any failure we stop as soon as possible
 902 -- (using the 'JobControl' to try to cancel in-progress tasks). This behaviour
 903 -- can be reversed to keep going and build as many packages as possible.
 904 --
 905 -- Note that the 'BuildOutcomes' is /not/ guaranteed to cover all the packages
 906 -- in the plan. In particular in the default mode where we stop as soon as
 907 -- possible after a failure then there may be packages which are skipped and
 908 -- these will have no 'BuildOutcome'.
 909 execute
 910   :: forall m ipkg srcpkg result failure
 911    . ( IsUnit ipkg
 912      , IsUnit srcpkg
 913      , Monad m
 914      )
 915   => JobControl m (UnitId, Either failure result)
 916   -> Bool
 917   -- ^ Keep going after failure
 918   -> (srcpkg -> failure)
 919   -- ^ Value for dependents of failed packages
 920   -> GenericInstallPlan ipkg srcpkg
 921   -> (GenericReadyPackage srcpkg -> m (Either failure result))
 922   -> m (BuildOutcomes failure result)
 923 execute jobCtl keepGoing depFailure plan installPkg =
 924   let (newpkgs, processing) = ready plan
 925    in tryNewTasks Map.empty False False processing newpkgs
 926   where
 927     tryNewTasks
 928       :: BuildOutcomes failure result
 929       -> Bool
 930       -> Bool
 931       -> Processing
 932       -> [GenericReadyPackage srcpkg]
 933       -> m (BuildOutcomes failure result)
 934
 935     tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs
 936       -- we were in the process of cancelling and now we're finished
 937       | tasksFailed && not keepGoing && not tasksRemaining =
 938           return results
 939       -- we are still in the process of cancelling, wait for remaining tasks
 940       | tasksFailed && not keepGoing && tasksRemaining =
 941           waitForTasks results tasksFailed processing
 942       -- no new tasks to do and all tasks are done so we're finished
 943       | null newpkgs && not tasksRemaining =
 944           return results
 945       -- no new tasks to do, remaining tasks to wait for
 946       | null newpkgs =
 947           waitForTasks results tasksFailed processing
 948       -- new tasks to do, spawn them, then wait for tasks to complete
 949       | otherwise =
 950           do
 951             sequence_
 952               [ spawnJob jobCtl $ do
 953                 result <- installPkg pkg
 954                 return (nodeKey pkg, result)
 955               | pkg <- newpkgs
 956               ]
 957             waitForTasks results tasksFailed processing
 958
 959     waitForTasks
 960       :: BuildOutcomes failure result
 961       -> Bool
 962       -> Processing
 963       -> m (BuildOutcomes failure result)
 964     waitForTasks !results tasksFailed !processing = do
 965       (pkgid, result) <- collectJob jobCtl
 966
 967       case result of
 968         Right _success -> do
 969           tasksRemaining <- remainingJobs jobCtl
 970           tryNewTasks
 971             results'
 972             tasksFailed
 973             tasksRemaining
 974             processing'
 975             nextpkgs
 976           where
 977             results' = Map.insert pkgid result results
 978             (nextpkgs, processing') = completed plan processing pkgid
 979         Left _failure -> do
 980           -- if this is the first failure and we're not trying to keep going
 981           -- then try to cancel as many of the remaining jobs as possible
 982           when (not tasksFailed && not keepGoing) $
 983             cancelJobs jobCtl
 984
 985           tasksRemaining <- remainingJobs jobCtl
 986           tryNewTasks results' True tasksRemaining processing' []
 987           where
 988             (depsfailed, processing') = failed plan processing pkgid
 989             results' = Map.insert pkgid result results `Map.union` depResults
 990             depResults =
 991               Map.fromList
 992                 [ (nodeKey deppkg, Left (depFailure deppkg))
 993                 | deppkg <- depsfailed
 994                 ]
 995
 996 -- ------------------------------------------------------------
 997
 998 -- * Checking validity of plans
 999
1000 -- ------------------------------------------------------------
1001
1002 -- | A valid installation plan is a set of packages that is closed, acyclic
1003 -- and respects the package state relation.
1004 --
1005 -- * if the result is @False@ use 'problems' to get a detailed list.
1006 valid
1007   :: (IsUnit ipkg, IsUnit srcpkg)
1008   => String
1009   -> Graph (GenericPlanPackage ipkg srcpkg)
1010   -> Bool
1011 valid loc graph =
1012   case problems graph of
1013     [] -> True
1014     ps -> internalError loc ('\n' : unlines (map showPlanProblem ps))
1015
1016 data PlanProblem ipkg srcpkg
1017   = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [UnitId]
1018   | PackageCycle [GenericPlanPackage ipkg srcpkg]
1019   | PackageStateInvalid
1020       (GenericPlanPackage ipkg srcpkg)
1021       (GenericPlanPackage ipkg srcpkg)
1022
1023 showPlanProblem
1024   :: (IsUnit ipkg, IsUnit srcpkg)
1025   => PlanProblem ipkg srcpkg
1026   -> String
1027 showPlanProblem (PackageMissingDeps pkg missingDeps) =
1028   "Package "
1029     ++ prettyShow (nodeKey pkg)
1030     ++ " depends on the following packages which are missing from the plan: "
1031     ++ intercalate ", " (map prettyShow missingDeps)
1032 showPlanProblem (PackageCycle cycleGroup) =
1033   "The following packages are involved in a dependency cycle "
1034     ++ intercalate ", " (map (prettyShow . nodeKey) cycleGroup)
1035 showPlanProblem (PackageStateInvalid pkg pkg') =
1036   "Package "
1037     ++ prettyShow (nodeKey pkg)
1038     ++ " is in the "
1039     ++ showPlanPackageTag pkg
1040     ++ " state but it depends on package "
1041     ++ prettyShow (nodeKey pkg')
1042     ++ " which is in the "
1043     ++ showPlanPackageTag pkg'
1044     ++ " state"
1045
1046 -- | For an invalid plan, produce a detailed list of problems as human readable
1047 -- error messages. This is mainly intended for debugging purposes.
1048 -- Use 'showPlanProblem' for a human readable explanation.
1049 problems
1050   :: (IsUnit ipkg, IsUnit srcpkg)
1051   => Graph (GenericPlanPackage ipkg srcpkg)
1052   -> [PlanProblem ipkg srcpkg]
1053 problems graph =
1054   [ PackageMissingDeps
1055     pkg
1056     ( mapMaybe
1057         (fmap nodeKey . flip Graph.lookup graph)
1058         missingDeps
1059     )
1060   | (pkg, missingDeps) <- Graph.broken graph
1061   ]
1062     ++ [ PackageCycle cycleGroup
1063        | cycleGroup <- Graph.cycles graph
1064        ]
1065     {-
1066       ++ [ PackageInconsistency name inconsistencies
1067          | (name, inconsistencies) <-
1068            dependencyInconsistencies indepGoals graph ]
1069          --TODO: consider re-enabling this one, see SolverInstallPlan
1070     -}
1071     ++ [ PackageStateInvalid pkg pkg'
1072        | pkg <- Foldable.toList graph
1073        , Just pkg' <-
1074           map
1075             (flip Graph.lookup graph)
1076             (nodeNeighbors pkg)
1077        , not (stateDependencyRelation pkg pkg')
1078        ]
1079
1080 -- | The states of packages have that depend on each other must respect
1081 -- this relation. That is for very case where package @a@ depends on
1082 -- package @b@ we require that @stateDependencyRelation a b = True@.
1083 stateDependencyRelation
1084   :: GenericPlanPackage ipkg srcpkg
1085   -> GenericPlanPackage ipkg srcpkg
1086   -> Bool
1087 stateDependencyRelation PreExisting{} PreExisting{} = True
1088 stateDependencyRelation Installed{} PreExisting{} = True
1089 stateDependencyRelation Installed{} Installed{} = True
1090 stateDependencyRelation Configured{} PreExisting{} = True
1091 stateDependencyRelation Configured{} Installed{} = True
1092 stateDependencyRelation Configured{} Configured{} = True
1093 stateDependencyRelation _ _ = False