diff --git a/Cabal-syntax/src/Distribution/Compat/Graph.hs b/Cabal-syntax/src/Distribution/Compat/Graph.hs index ea37af99a77..00e2f5c955c 100644 --- a/Cabal-syntax/src/Distribution/Compat/Graph.hs +++ b/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 diff --git a/Cabal/src/Distribution/Backpack/Configure.hs b/Cabal/src/Distribution/Backpack/Configure.hs index d5e4a1ecaa9..0eda8a8e23d 100644 --- a/Cabal/src/Distribution/Backpack/Configure.hs +++ b/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 diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index 2afca3acaa5..427d8cdd9b1 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/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 ] diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index 73b6a9054e1..fc8b4835b99 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/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 diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 3021e5dfdef..c40fada3f10 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/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 diff --git a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs index 5a58ce0aa9e..9a814d28c7a 100644 --- a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs +++ b/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