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

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