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

@@ -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
 import GHC.Stack (HasCallStack)
 
 -- | A graph of nodes @a@.  The nodes are expected to have instance
@@ -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,17 +353,26 @@ 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

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

@@ -1048,7 +1048,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
   | -- | The packages involved in a dependency cycle
     PackageCycle
@@ -1079,7 +1079,7 @@ renderPlanProblem (PackageMissingDeps pkg missingDeps) =
     [ 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
@@ -1121,10 +1121,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

@@ -3907,7 +3907,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
@@ -3922,7 +3922,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan =
 newtype CannotPruneDependencies
   = CannotPruneDependencies
       [ ( ElaboratedPlanPackage
-        , [ElaboratedPlanPackage]
+        , NonEmpty ElaboratedPlanPackage
         )
       ]
   deriving (Show)

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

@@ -73,6 +73,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
@@ -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