never executed always true always false
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 packges 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 simultations 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