Commit 5044bceb authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Add InstallPlan invariant assertion checking

It turns out that the install plan elaboration is constructing cyclic
plans in some cases. The effect is that executing the plan simply misses
out anything that depends on the packages involved in the cycle. This is
probably the cause of #3996

With this patch such cases will fail with an assertion such as:

internal error in InstallPlan.fromSolverInstallPlanWithProgress:
The following packages are involved in a dependency cycle
hspec-discover-2.3.1-da63d0b4e952e7949a113646e4af0aac925a4d864a1db650..

The cause is clearly in the caller of fromSolverInstallPlanWithProgress
and the only caller of that is ProjectPlanning.elaborateInstallPlan.
The problem appears to be to do with the intra-package dependencies.
parent b97578f8
......@@ -92,10 +92,10 @@ import Distribution.Utils.LogProgress
-- import qualified Distribution.Simple.Configure as Configure
import Data.List
( foldl' )
( foldl', intercalate )
import qualified Data.Foldable as Foldable (all)
import Data.Maybe
( fromMaybe )
( fromMaybe, catMaybes )
import qualified Distribution.Compat.Graph as Graph
import Distribution.Compat.Graph (Graph, IsNode(..))
import Distribution.Compat.Binary (Binary(..))
......@@ -223,10 +223,13 @@ type InstallPlan = GenericInstallPlan
-- | Smart constructor that deals with caching the 'Graph' representation.
--
mkInstallPlan :: Graph (GenericPlanPackage ipkg srcpkg)
mkInstallPlan :: (IsUnit ipkg, IsUnit srcpkg)
=> String
-> Graph (GenericPlanPackage ipkg srcpkg)
-> IndependentGoals
-> GenericInstallPlan ipkg srcpkg
mkInstallPlan graph indepGoals =
mkInstallPlan loc graph indepGoals =
assert (valid loc graph)
GenericInstallPlan {
planGraph = graph,
planIndepGoals = indepGoals
......@@ -246,7 +249,7 @@ instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId,
get = do
(graph, indepGoals) <- get
return $! mkInstallPlan graph indepGoals
return $! mkInstallPlan "(instance Binary)" graph indepGoals
showPlanGraph :: (Package ipkg, Package srcpkg,
IsUnit ipkg, IsUnit srcpkg)
......@@ -271,10 +274,11 @@ showPlanPackageTag (Installed _) = "Installed"
-- | Build an installation plan from a valid set of resolved packages.
--
new :: IndependentGoals
new :: (IsUnit ipkg, IsUnit srcpkg)
=> IndependentGoals
-> Graph (GenericPlanPackage ipkg srcpkg)
-> GenericInstallPlan ipkg srcpkg
new indepGoals graph = mkInstallPlan graph indepGoals
new indepGoals graph = mkInstallPlan "new" graph indepGoals
toGraph :: GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
......@@ -305,7 +309,7 @@ remove :: (IsUnit ipkg, IsUnit srcpkg)
-> GenericInstallPlan ipkg srcpkg
-> GenericInstallPlan ipkg srcpkg
remove shouldRemove plan =
mkInstallPlan newGraph (planIndepGoals plan)
mkInstallPlan "remove" newGraph (planIndepGoals plan)
where
newGraph = Graph.fromList $
filter (not . shouldRemove) (toList plan)
......@@ -408,8 +412,9 @@ fromSolverInstallPlan ::
-> SolverInstallPlan
-> GenericInstallPlan ipkg srcpkg
fromSolverInstallPlan f plan =
mkInstallPlan (Graph.fromList pkgs'')
(SolverInstallPlan.planIndepGoals plan)
mkInstallPlan "fromSolverInstallPlan"
(Graph.fromList pkgs'')
(SolverInstallPlan.planIndepGoals plan)
where
(_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, [])
(SolverInstallPlan.reverseTopologicalOrder plan)
......@@ -444,8 +449,9 @@ fromSolverInstallPlanWithProgress ::
fromSolverInstallPlanWithProgress f plan = do
(_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, [])
(SolverInstallPlan.reverseTopologicalOrder plan)
return $ mkInstallPlan (Graph.fromList pkgs'')
(SolverInstallPlan.planIndepGoals plan)
return $ mkInstallPlan "fromSolverInstallPlanWithProgress"
(Graph.fromList pkgs'')
(SolverInstallPlan.planIndepGoals plan)
where
f' (pidMap, ipiMap, pkgs) pkg = do
pkgs' <- f (mapDep pidMap ipiMap) pkg
......@@ -825,3 +831,89 @@ execute jobCtl keepGoing depFailure plan installPkg =
depResults = Map.fromList
[ (nodeKey deppkg, Left (depFailure deppkg))
| deppkg <- depsfailed ]
-- ------------------------------------------------------------
-- * Checking validity of plans
-- ------------------------------------------------------------
-- | A valid installation plan is a set of packages that is closed, acyclic
-- and respects the package state relation.
--
-- * if the result is @False@ use 'problems' to get a detailed list.
--
valid :: (IsUnit ipkg, IsUnit srcpkg)
=> String -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool
valid loc graph =
case problems graph of
[] -> True
ps -> internalError loc ('\n' : unlines (map showPlanProblem ps))
data PlanProblem ipkg srcpkg =
PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [UnitId]
| PackageCycle [GenericPlanPackage ipkg srcpkg]
| PackageStateInvalid (GenericPlanPackage ipkg srcpkg)
(GenericPlanPackage ipkg srcpkg)
showPlanProblem :: (IsUnit ipkg, IsUnit srcpkg)
=> PlanProblem ipkg srcpkg -> String
showPlanProblem (PackageMissingDeps pkg missingDeps) =
"Package " ++ display (nodeKey pkg)
++ " depends on the following packages which are missing from the plan: "
++ intercalate ", " (map display missingDeps)
showPlanProblem (PackageCycle cycleGroup) =
"The following packages are involved in a dependency cycle "
++ intercalate ", " (map (display . nodeKey) cycleGroup)
showPlanProblem (PackageStateInvalid pkg pkg') =
"Package " ++ display (nodeKey pkg)
++ " is in the " ++ showPlanPackageTag pkg
++ " state but it depends on package " ++ display (nodeKey pkg')
++ " which is in the " ++ showPlanPackageTag pkg'
++ " state"
-- | For an invalid plan, produce a detailed list of problems as human readable
-- error messages. This is mainly intended for debugging purposes.
-- Use 'showPlanProblem' for a human readable explanation.
--
problems :: (IsUnit ipkg, IsUnit srcpkg)
=> Graph (GenericPlanPackage ipkg srcpkg)
-> [PlanProblem ipkg srcpkg]
problems graph =
[ PackageMissingDeps pkg
(catMaybes
(map
(fmap nodeKey . flip Graph.lookup graph)
missingDeps))
| (pkg, missingDeps) <- Graph.broken graph ]
++ [ PackageCycle cycleGroup
| cycleGroup <- Graph.cycles graph ]
{-
++ [ PackageInconsistency name inconsistencies
| (name, inconsistencies) <-
dependencyInconsistencies indepGoals graph ]
--TODO: consider re-enabling this one, see SolverInstallPlan
-}
++ [ PackageStateInvalid pkg pkg'
| pkg <- Graph.toList graph
, Just pkg' <- map (flip Graph.lookup graph)
(nodeNeighbors pkg)
, not (stateDependencyRelation pkg pkg') ]
-- | The states of packages have that depend on each other must respect
-- this relation. That is for very case where package @a@ depends on
-- package @b@ we require that @stateDependencyRelation a b = True@.
--
stateDependencyRelation :: GenericPlanPackage ipkg srcpkg
-> GenericPlanPackage ipkg srcpkg -> Bool
stateDependencyRelation PreExisting{} PreExisting{} = True
stateDependencyRelation Installed{} PreExisting{} = True
stateDependencyRelation Installed{} Installed{} = True
stateDependencyRelation Configured{} PreExisting{} = True
stateDependencyRelation Configured{} Installed{} = True
stateDependencyRelation Configured{} Configured{} = True
stateDependencyRelation _ _ = False
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment