refactor(Cabal-syntax): Improve Graph.broken

If a node has dangling edges, then the list of missing neighbours cannot be empty.

Author: andreabedini

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

@@ -103,8 +103,8 @@ import qualified Data.Graph as G
 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
 import GHC.Stack (HasCallStack)
+import qualified Data.List.NonEmpty as NE
 
 -- | A graph of nodes @a@.  The nodes are expected to have instance
 -- of class 'IsNode'.
@@ -115,7 +115,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
@@ -285,7 +285,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.
@@ -344,7 +344,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, Eq (Key a)) => Map (Key a) a -> Graph a
 fromMap m =
   Graph
     { graphMap = m
@@ -353,18 +353,27 @@ 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))
-        | n <- ns
-        ]
-    broke = filter (not . Prelude.null . snd) (zip ns brokenEdges)
-
+      unzip 
+      [ partitionEithers
+                [ case key_to_vertex n' of
+                    Just v  -> Right v
+                    Nothing -> Left (n, n')
+                | n' <- nodeNeighbors n
+                ]
+      | n <- ns
+      ]
+    
     g = Array.listArray bounds edges
 
     ns = Map.elems m -- sorted ascending

Cabal/src/Distribution/Backpack/Configure.hs

@@ -283,14 +283,14 @@ toComponentLocalBuildInfos
                   [ "installed package "
                     ++ prettyShow (packageId pkg)
                     ++ " is broken due to missing package "
-                    ++ intercalate ", " (map prettyShow deps)
+                    ++ intercalate ", " (map prettyShow $ toList deps)
                   | (Left pkg, deps) <- broken
                   ]
                 ++ unlines
                   [ "planned package "
                     ++ prettyShow (packageId pkg)
                     ++ " is broken due to missing package "
-                    ++ intercalate ", " (map prettyShow deps)
+                    ++ intercalate ", " (map prettyShow $ toList deps)
                   | (Right pkg, deps) <- broken
                   ]
 

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

@@ -501,7 +501,7 @@ renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) =
   where
     -- throw away the details and just list the deps that are needed
     pkgids :: [PackageId]
-    pkgids = nub . map packageId . concatMap snd $ brokenPackages
+    pkgids = nub . map packageId . concatMap (NE.toList . snd) $ brokenPackages
 
 {-
            ++ "Syntax:\n"

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

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

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

@@ -1040,7 +1040,7 @@ data PlanProblem ipkg srcpkg
   = PackageMissingDeps
       (GenericPlanPackage ipkg srcpkg)
       -- ^ The package that is missing dependencies
-      [GraphKey ipkg srcpkg]
+      (NonEmpty (GraphKey ipkg srcpkg))
       -- ^ The missing dependencies
   | PackageCycle
       [GenericPlanPackage ipkg srcpkg]
@@ -1070,7 +1070,7 @@ renderPlanProblem (PackageMissingDeps pkg missingDeps) =
   fsep [ text "Package"
        , pretty (nodeKey pkg)
        , text "depends on the following packages which are missing from the plan:"
-       , fsep (punctuate comma (map pretty missingDeps))
+       , fsep (punctuate comma (map pretty $ NE.toList missingDeps))
        ]
 renderPlanProblem (PackageCycle cycleGroup) =
   fsep [ text "The following packages are involved in a dependency cycle:"
@@ -1111,10 +1111,7 @@ checkForMissingDeps
 checkForMissingDeps graph =
  [ PackageMissingDeps
     pkg
-    ( mapMaybe
-        (fmap nodeKey . flip Graph.lookup graph)
-        missingDeps
-    )
+    missingDeps
   | (pkg, missingDeps) <- Graph.broken graph
   ]
 

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

@@ -3897,7 +3897,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan =
             CannotPruneDependencies
               [ (pkg, missingDeps)
               | (pkg, missingDepIds) <- brokenPackages
-              , let missingDeps = mapMaybe lookupDep missingDepIds
+              , let missingDeps =  NE.map (fromMaybe (error "should not happen") . lookupDep) missingDepIds
               ]
           where
             -- lookup in the original unpruned graph
@@ -3912,7 +3912,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan =
 newtype CannotPruneDependencies
   = CannotPruneDependencies
       [ ( ElaboratedPlanPackage
-        , [ElaboratedPlanPackage]
+        , NonEmpty ElaboratedPlanPackage
         )
       ]
   deriving (Show)

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

@@ -77,6 +77,7 @@ import qualified Data.Map as Map
 import Distribution.Compat.Graph (Graph, IsNode (..))
 import qualified Distribution.Compat.Graph as Graph
 import GHC.Stack (HasCallStack)
+import qualified Data.List.NonEmpty as NE
 
 type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc
 
@@ -171,7 +172,7 @@ valid = null . problems
 data SolverPlanProblem
   = PackageMissingDeps
       SolverPlanPackage
-      [PackageIdentifier]
+      (NE.NonEmpty PackageIdentifier)
   | PackageCycle [SolverPlanPackage]
   | PackageInconsistency QPN [(SolverId, SolverId)]
   | PackageStateInvalid SolverPlanPackage SolverPlanPackage
@@ -181,7 +182,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)
@@ -220,10 +221,11 @@ problems
 problems index =
   [ PackageMissingDeps
     pkg
-    ( mapMaybe
-        (fmap packageId . flip Graph.lookup index)
-        missingDeps
-    )
+    -- ( mapMaybe
+    --     (fmap packageId . flip Graph.lookup index)
+    --     missingDeps
+    -- )
+    (NE.map (packageId . fromMaybe (error "should not happen") . flip Graph.lookup index) missingDeps)
   | (pkg, missingDeps) <- Graph.broken index
   ]
     ++ [ PackageCycle cycleGroup