Merge pull request #3901 from dcoutts/installplan-fixes

InstallPlan fixes and misc housekeeping

Cabal/Distribution/Compat/Graph.hs

@@ -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)@.

cabal-install/Distribution/Client/InstallPlan.hs

@@ -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)