Commit 2ccfce17 authored by Edward Z. Yang's avatar Edward Z. Yang Committed by GitHub
Browse files

Merge pull request #3901 from dcoutts/installplan-fixes

InstallPlan fixes and misc housekeeping
parents 4c730f58 9b40b06c
......@@ -46,6 +46,7 @@ module Distribution.Compat.Graph (
-- * Query
null,
size,
member,
lookup,
-- * Construction
empty,
......@@ -73,6 +74,8 @@ module Distribution.Compat.Graph (
fromList,
toList,
keys,
-- ** Sets
keysSet,
-- ** Graphs
toGraph,
-- * Node type
......@@ -87,6 +90,7 @@ import Distribution.Compat.Prelude hiding (lookup, null, empty)
import Data.Graph (SCC(..))
import qualified Data.Graph as G
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Array as Array
import Data.Array ((!))
import qualified Data.Tree as Tree
......@@ -207,6 +211,10 @@ null = Map.null . toMap
size :: Graph a -> Int
size = Map.size . toMap
-- | /O(log V)/. Check if the key is in the graph.
member :: IsNode a => Key a -> Graph a -> Bool
member k g = Map.member k (toMap g)
-- | /O(log V)/. Lookup the node at a key in the graph.
lookup :: IsNode a => Key a -> Graph a -> Maybe a
lookup k g = Map.lookup k (toMap g)
......@@ -377,6 +385,10 @@ toList g = Map.elems (toMap g)
keys :: Graph a -> [Key a]
keys g = Map.keys (toMap g)
-- | /O(V)/. Convert a graph into a set of keys.
keysSet :: Graph a -> Set.Set (Key a)
keysSet g = Map.keysSet (toMap g)
-- | /O(1)/. Convert a graph into a map from keys to nodes.
-- The resulting map @m@ is guaranteed to have the property that
-- @'Prelude.all' (\(k,n) -> k == 'nodeKey' n) ('Data.Map.toList' m)@.
......
......@@ -26,7 +26,11 @@ module Distribution.Client.InstallPlan (
-- * Operations on 'InstallPlan's
new,
toGraph,
toList,
toMap,
keys,
keysSet,
planIndepGoals,
depends,
......@@ -51,7 +55,7 @@ module Distribution.Client.InstallPlan (
failed,
-- * Display
showPlanIndex,
showPlanGraph,
showInstallPlan,
-- * Graph-like operations
......@@ -86,8 +90,9 @@ import Distribution.Solver.Types.InstSolverPackage
import Data.List
( foldl' )
import qualified Data.Foldable as Foldable (all)
import Data.Maybe
( fromMaybe, isJust )
( fromMaybe )
import qualified Distribution.Compat.Graph as Graph
import Distribution.Compat.Graph (Graph, IsNode(..))
import Distribution.Compat.Binary (Binary(..))
......@@ -205,7 +210,7 @@ instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) =>
configuredId (Installed spkg) = configuredId spkg
data GenericInstallPlan ipkg srcpkg = GenericInstallPlan {
planIndex :: !(PlanIndex ipkg srcpkg),
planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg)),
planIndepGoals :: !IndependentGoals
}
......@@ -213,17 +218,14 @@ data GenericInstallPlan ipkg srcpkg = GenericInstallPlan {
type InstallPlan = GenericInstallPlan
InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)
type PlanIndex ipkg srcpkg =
Graph (GenericPlanPackage ipkg srcpkg)
-- | Smart constructor that deals with caching the 'Graph' representation.
--
mkInstallPlan :: PlanIndex ipkg srcpkg
mkInstallPlan :: Graph (GenericPlanPackage ipkg srcpkg)
-> IndependentGoals
-> GenericInstallPlan ipkg srcpkg
mkInstallPlan index indepGoals =
mkInstallPlan graph indepGoals =
GenericInstallPlan {
planIndex = index,
planGraph = graph,
planIndepGoals = indepGoals
}
......@@ -234,19 +236,19 @@ instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId,
Binary ipkg, Binary srcpkg)
=> Binary (GenericInstallPlan ipkg srcpkg) where
put GenericInstallPlan {
planIndex = index,
planGraph = graph,
planIndepGoals = indepGoals
} = put (index, indepGoals)
} = put (graph, indepGoals)
get = do
(index, indepGoals) <- get
return $! mkInstallPlan index indepGoals
showPlanIndex :: (Package ipkg, Package srcpkg,
showPlanGraph :: (Package ipkg, Package srcpkg,
IsUnit ipkg, IsUnit srcpkg)
=> PlanIndex ipkg srcpkg -> String
showPlanIndex index = renderStyle defaultStyle $
vcat (map dispPlanPackage (Graph.toList index))
=> Graph (GenericPlanPackage ipkg srcpkg) -> String
showPlanGraph graph = renderStyle defaultStyle $
vcat (map dispPlanPackage (Graph.toList graph))
where dispPlanPackage p =
hang (hsep [ text (showPlanPackageTag p)
, disp (packageId p)
......@@ -256,7 +258,7 @@ showPlanIndex index = renderStyle defaultStyle $
showInstallPlan :: (Package ipkg, Package srcpkg,
IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg -> String
showInstallPlan = showPlanIndex . planIndex
showInstallPlan = showPlanGraph . planGraph
showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String
showPlanPackageTag (PreExisting _) = "PreExisting"
......@@ -266,13 +268,27 @@ showPlanPackageTag (Installed _) = "Installed"
-- | Build an installation plan from a valid set of resolved packages.
--
new :: IndependentGoals
-> PlanIndex ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
-> GenericInstallPlan ipkg srcpkg
new indepGoals index = mkInstallPlan index indepGoals
toGraph :: GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
toGraph = planGraph
toList :: GenericInstallPlan ipkg srcpkg
-> [GenericPlanPackage ipkg srcpkg]
toList = Graph.toList . planIndex
toList = Graph.toList . planGraph
toMap :: GenericInstallPlan ipkg srcpkg
-> Map UnitId (GenericPlanPackage ipkg srcpkg)
toMap = Graph.toMap . planGraph
keys :: GenericInstallPlan ipkg srcpkg -> [UnitId]
keys = Graph.keys . planGraph
keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId
keysSet = Graph.keysSet . planGraph
-- | Remove packages from the install plan. This will result in an
-- error if there are remaining packages that depend on any matching
......@@ -309,7 +325,7 @@ installed shouldBeInstalled installPlan =
markInstalled plan pkg =
assert (all isInstalled (directDeps plan (nodeKey pkg))) $
plan {
planIndex = Graph.insert (Installed pkg) (planIndex plan)
planGraph = Graph.insert (Installed pkg) (planGraph plan)
}
-- | Lookup a package in the plan.
......@@ -318,7 +334,7 @@ lookup :: (IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg
-> UnitId
-> Maybe (GenericPlanPackage ipkg srcpkg)
lookup plan pkgid = Graph.lookup pkgid (planIndex plan)
lookup plan pkgid = Graph.lookup pkgid (planGraph plan)
-- | Find all the direct dependencies of the given package.
--
......@@ -328,7 +344,7 @@ directDeps :: GenericInstallPlan ipkg srcpkg
-> UnitId
-> [GenericPlanPackage ipkg srcpkg]
directDeps plan pkgid =
case Graph.neighbors (planIndex plan) pkgid of
case Graph.neighbors (planGraph plan) pkgid of
Just deps -> deps
Nothing -> internalError "directDeps: package not in graph"
......@@ -340,7 +356,7 @@ revDirectDeps :: GenericInstallPlan ipkg srcpkg
-> UnitId
-> [GenericPlanPackage ipkg srcpkg]
revDirectDeps plan pkgid =
case Graph.revNeighbors (planIndex plan) pkgid of
case Graph.revNeighbors (planGraph plan) pkgid of
Just deps -> deps
Nothing -> internalError "revDirectDeps: package not in graph"
......@@ -360,7 +376,7 @@ revDirectDeps plan pkgid =
--
reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg
-> [GenericPlanPackage ipkg srcpkg]
reverseTopologicalOrder plan = Graph.revTopSort (planIndex plan)
reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan)
-- | Return the packages in the plan that depend directly or indirectly on the
......@@ -370,7 +386,7 @@ reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg
-> [UnitId]
-> [GenericPlanPackage ipkg srcpkg]
reverseDependencyClosure plan = fromMaybe []
. Graph.revClosure (planIndex plan)
. Graph.revClosure (planGraph plan)
-- Alert alert! Why does SolverId map to a LIST of plan packages?
......@@ -571,7 +587,9 @@ failed plan (Processing processingSet completedSet failedSet) pkgid =
assert (pkgid `Set.member` processingSet) $
assert (all (`Set.notMember` processingSet) (tail newlyFailedIds)) $
assert (all (`Set.notMember` completedSet) (tail newlyFailedIds)) $
assert (all (`Set.notMember` failedSet) (tail newlyFailedIds)) $
-- but note that some newlyFailed may already be in the failed set
-- since one package can depend on two packages that both fail and
-- so would be in the rev-dep closure for both.
assert (processingInvariant plan processing') $
( map asConfiguredPackage (tail newlyFailed)
......@@ -581,7 +599,7 @@ failed plan (Processing processingSet completedSet failedSet) pkgid =
failedSet' = failedSet `Set.union` Set.fromList newlyFailedIds
newlyFailedIds = map nodeKey newlyFailed
newlyFailed = fromMaybe (internalError "package not in graph")
$ Graph.revClosure (planIndex plan) [pkgid]
$ Graph.revClosure (planGraph plan) [pkgid]
processing' = Processing processingSet' completedSet failedSet'
asConfiguredPackage (Configured pkg) = pkg
......@@ -591,27 +609,57 @@ processingInvariant :: (IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg
-> Processing -> Bool
processingInvariant plan (Processing processingSet completedSet failedSet) =
all (isJust . flip Graph.lookup (planIndex plan)) (Set.toList processingSet)
&& all (isJust . flip Graph.lookup (planIndex plan)) (Set.toList completedSet)
&& all (isJust . flip Graph.lookup (planIndex plan)) (Set.toList failedSet)
&& noIntersection processingSet completedSet
&& noIntersection processingSet failedSet
&& noIntersection failedSet completedSet
&& noIntersection processingClosure completedSet
&& noIntersection processingClosure failedSet
&& and [ case Graph.lookup pkgid (planIndex plan) of
Just (Configured _) -> True
Just (PreExisting _) -> False
Just (Installed _) -> False
Nothing -> False
| pkgid <- Set.toList processingSet ++ Set.toList failedSet ]
-- All the packages in the three sets are actually in the graph
assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet) $
assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet) $
assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet) $
-- The processing, completed and failed sets are disjoint from each other
assert (noIntersection processingSet completedSet) $
assert (noIntersection processingSet failedSet) $
assert (noIntersection failedSet completedSet) $
-- Packages that depend on a package that's still processing cannot be
-- completed
assert (noIntersection (reverseClosure processingSet) completedSet) $
-- On the other hand, packages that depend on a package that's still
-- processing /can/ have failed (since they may have depended on multiple
-- packages that were processing, but it only takes one to fail to cause
-- knock-on failures) so it is quite possible to have an
-- intersection (reverseClosure processingSet) failedSet
-- The failed set is upwards closed, i.e. equal to its own rev dep closure
assert (failedSet == reverseClosure failedSet) $
-- All immediate reverse deps of packges that are currently processing
-- are not currently being processed (ie not in the processing set).
assert (and [ rdeppkgid `Set.notMember` processingSet
| pkgid <- Set.toList processingSet
, rdeppkgid <- maybe (internalError "processingInvariant")
(map nodeKey)
(Graph.revNeighbors (planGraph plan) pkgid)
]) $
-- Packages from the processing or failed sets are only ever in the
-- configured state.
assert (and [ case Graph.lookup pkgid (planGraph plan) of
Just (Configured _) -> True
Just (PreExisting _) -> False
Just (Installed _) -> False
Nothing -> False
| pkgid <- Set.toList processingSet ++ Set.toList failedSet ])
-- We use asserts rather than returning False so that on failure we get
-- better details on which bit of the invariant was violated.
True
where
processingClosure = Set.fromList
reverseClosure = Set.fromList
. map nodeKey
. fromMaybe (internalError "processingClosure")
. Graph.revClosure (planIndex plan)
. fromMaybe (internalError "processingInvariant")
. Graph.revClosure (planGraph plan)
. Set.toList
$ processingSet
noIntersection a b = Set.null (Set.intersection a b)
......
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