refactor: make Graph.broken return NonEmpty missing deps

Cabal-syntax/src/Distribution/Compat/Graph.hs

@@ -100,10 +100,10 @@ import Distribution.Utils.Structured (Structure (..), Structured (..))
 import qualified Data.Array as Array
 import qualified Data.Foldable as Foldable
 import qualified Data.Graph as G
+import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified Data.Tree as Tree
-import qualified Distribution.Compat.Prelude as Prelude
 
 -- | A graph of nodes @a@.  The nodes are expected to have instance
 -- of class 'IsNode'.
@@ -114,7 +114,7 @@ data Graph a = Graph
   , graphAdjoint :: G.Graph
   , graphVertexToNode :: G.Vertex -> a
   , graphKeyToVertex :: Key a -> Maybe G.Vertex
-  , graphBroken :: [(a, [Key a])]
+  , graphBroken :: [(a, NonEmpty (Key a))]
   }
 
 -- NB: Not a Functor! (or Traversable), because you need
@@ -284,7 +284,7 @@ cycles g = [vs | CyclicSCC vs <- stronglyConnComp g]
 -- | /O(1)/.  Return a list of nodes paired with their broken
 -- neighbors (i.e., neighbor keys which are not in the graph).
 -- Requires amortized construction of graph.
-broken :: Graph a -> [(a, [Key a])]
+broken :: Graph a -> [(a, NonEmpty (Key a))]
 broken g = graphBroken g
 
 -- | Lookup the immediate neighbors from a key in the graph.
@@ -343,7 +343,7 @@ revTopSort g = map (graphVertexToNode g) $ G.topSort (graphAdjoint g)
 -- if you can't fulfill this invariant use @'fromList' ('Data.Map.elems' m)@
 -- instead.  The values of the map are assumed to already
 -- be in WHNF.
-fromMap :: IsNode a => Map (Key a) a -> Graph a
+fromMap :: forall a. IsNode a => Map (Key a) a -> Graph a
 fromMap m =
   Graph
     { graphMap = m
@@ -352,17 +352,25 @@ fromMap m =
     , graphAdjoint = G.transposeG g
     , graphVertexToNode = vertex_to_node
     , graphKeyToVertex = key_to_vertex
-    , graphBroken = broke
+    , graphBroken =
+        map (\ns'' -> (fst (NE.head ns''), NE.map snd ns'')) $
+          NE.groupWith (nodeKey . fst) brokenEdges'
     }
   where
-    try_key_to_vertex k = maybe (Left k) Right (key_to_vertex k)
+    brokenEdges' :: [(a, Key a)]
+    brokenEdges' = concat brokenEdges
 
+    brokenEdges :: [[(a, Key a)]]
     (brokenEdges, edges) =
-      unzip $
-        [ partitionEithers (map try_key_to_vertex (nodeNeighbors n))
+      unzip
+        [ partitionEithers
+          [ case key_to_vertex n' of
+            Just v -> Right v
+            Nothing -> Left (n, n')
+          | n' <- nodeNeighbors n
+          ]
         | n <- ns
         ]
-    broke = filter (not . Prelude.null . snd) (zip ns brokenEdges)
 
     g = Array.listArray bounds edges
 

Cabal/src/Distribution/Backpack/Configure.hs

@@ -295,7 +295,7 @@ toComponentLocalBuildInfos
                         (text "installed package" <+> pretty (packageId pkg))
                         4
                         ( text "is broken due to missing package"
-                            <+> hsep (punctuate comma (map pretty deps))
+                            <+> hsep (punctuate comma (map pretty (toList deps)))
                         )
                       | (Left pkg, deps) <- broken
                       ]
@@ -305,7 +305,7 @@ toComponentLocalBuildInfos
                             ( vcat $
                                 text "is broken due to missing package"
                                   : [ nest 2 (dispMissingDep installedPackageSet depPkgMap dep)
-                                    | dep <- deps
+                                    | dep <- toList deps
                                     ]
                             )
                            | (Right pkg, deps) <- broken

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

@@ -717,7 +717,7 @@ pruneInstallPlan pkgSpecifiers =
           ordNub
             [ depid
             | SolverInstallPlan.PackageMissingDeps _ depids <- problems
-            , depid <- depids
+            , depid <- toList depids
             , packageName depid `elem` targetnames
             ]
 

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

@@ -124,6 +124,7 @@ import Control.Exception
   ( assert
   )
 import qualified Data.Foldable as Foldable (all, toList)
+import qualified Data.List.NonEmpty as NE
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Distribution.Compat.Graph (Graph, IsNode (..))
@@ -1023,7 +1024,7 @@ valid loc graph =
     ps -> internalError loc ('\n' : unlines (map showPlanProblem ps))
 
 data PlanProblem ipkg srcpkg
-  = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [UnitId]
+  = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) (NonEmpty UnitId)
   | PackageCycle [GenericPlanPackage ipkg srcpkg]
   | PackageStateInvalid
       (GenericPlanPackage ipkg srcpkg)
@@ -1037,7 +1038,7 @@ showPlanProblem (PackageMissingDeps pkg missingDeps) =
   "Package "
     ++ prettyShow (nodeKey pkg)
     ++ " depends on the following packages which are missing from the plan: "
-    ++ intercalate ", " (map prettyShow missingDeps)
+    ++ intercalate ", " (map prettyShow (NE.toList missingDeps))
 showPlanProblem (PackageCycle cycleGroup) =
   "The following packages are involved in a dependency cycle "
     ++ intercalate ", " (map (prettyShow . nodeKey) cycleGroup)
@@ -1062,10 +1063,7 @@ problems
 problems graph =
   [ PackageMissingDeps
     pkg
-    ( mapMaybe
-        (fmap nodeKey . flip Graph.lookup graph)
-        missingDeps
-    )
+    missingDeps
   | (pkg, missingDeps) <- Graph.broken graph
   ]
     ++ [ PackageCycle cycleGroup

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

@@ -3914,7 +3914,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan =
             CannotPruneDependencies
               [ (pkg, missingDeps)
               | (pkg, missingDepIds) <- brokenPackages
-              , let missingDeps = mapMaybe lookupDep missingDepIds
+              , let missingDeps = mapMaybe lookupDep (toList missingDepIds)
               ]
           where
             -- lookup in the original unpruned graph

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

@@ -80,6 +80,7 @@ import Distribution.Solver.Types.SolverPackage
 import Data.Array ((!))
 import qualified Data.Foldable as Foldable
 import qualified Data.Graph as OldGraph
+import qualified Data.List.NonEmpty as NE
 import qualified Data.Map as Map
 import Distribution.Compat.Graph (Graph, IsNode (..))
 import qualified Distribution.Compat.Graph as Graph
@@ -183,7 +184,7 @@ valid indepGoals index =
 data SolverPlanProblem
   = PackageMissingDeps
       SolverPlanPackage
-      [PackageIdentifier]
+      (NonEmpty PackageIdentifier)
   | PackageCycle [SolverPlanPackage]
   | PackageInconsistency PackageName [(PackageIdentifier, Version)]
   | PackageStateInvalid SolverPlanPackage SolverPlanPackage
@@ -193,7 +194,7 @@ showPlanProblem (PackageMissingDeps pkg missingDeps) =
   "Package "
     ++ prettyShow (packageId pkg)
     ++ " depends on the following packages which are missing from the plan: "
-    ++ intercalate ", " (map prettyShow missingDeps)
+    ++ intercalate ", " (map prettyShow (NE.toList missingDeps))
 showPlanProblem (PackageCycle cycleGroup) =
   "The following packages are involved in a dependency cycle "
     ++ intercalate ", " (map (prettyShow . packageId) cycleGroup)
@@ -233,10 +234,10 @@ problems
 problems indepGoals index =
   [ PackageMissingDeps
     pkg
-    ( mapMaybe
-        (fmap packageId . flip Graph.lookup index)
-        missingDeps
-    )
+    -- The missing deps are the neighbour 'SolverId's that are not in the
+    -- index; each 'SolverId' already carries its 'PackageId', so there is
+    -- no need to look it up (it could not be found in the index anyway).
+    (NE.map packageId missingDeps)
   | (pkg, missingDeps) <- Graph.broken index
   ]
     ++ [ PackageCycle cycleGroup