From 63cb8fdb0b27ee0c174a989bcba29d4ca9afcc2a Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Mon, 11 Nov 2024 07:45:55 -0500 Subject: [PATCH] Add Ord instance for ProjectConfigPath - Consider URI in Ord instance - Use <> in Ord instance of ProjectConfigPath - Add unconsProjectConfigPath - Add docProjectConfigFiles - Remove docProjectConfigPaths - Clarify sorting haddocks for Ord ProjectConfigPath --- .../Solver/Types/ProjectConfigPath.hs | 61 ++++++++++++++++--- .../src/Distribution/Client/ProjectConfig.hs | 2 +- changelog.d/pr-10546 | 9 +++ 3 files changed, 62 insertions(+), 10 deletions(-) create mode 100644 changelog.d/pr-10546 diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ProjectConfigPath.hs b/cabal-install-solver/src/Distribution/Solver/Types/ProjectConfigPath.hs index b98d493656c..25de1091d66 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ProjectConfigPath.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ProjectConfigPath.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ViewPatterns #-} module Distribution.Solver.Types.ProjectConfigPath ( @@ -7,10 +8,11 @@ module Distribution.Solver.Types.ProjectConfigPath , projectConfigPathRoot , nullProjectConfigPath , consProjectConfigPath + , unconsProjectConfigPath -- * Messages , docProjectConfigPath - , docProjectConfigPaths + , docProjectConfigFiles , cyclicalImportMsg , docProjectConfigPathFailReason @@ -21,17 +23,19 @@ module Distribution.Solver.Types.ProjectConfigPath ) where import Distribution.Solver.Compat.Prelude hiding (toList, (<>)) +import qualified Distribution.Solver.Compat.Prelude as P ((<>)) import Prelude (sequence) import Data.Coerce (coerce) import Data.List.NonEmpty ((<|)) -import Network.URI (parseURI) +import Network.URI (parseURI, parseAbsoluteURI) import System.Directory import System.FilePath import qualified Data.List.NonEmpty as NE import Distribution.Solver.Modular.Version (VR) import Distribution.Pretty (prettyShow) import Text.PrettyPrint +import Distribution.Simple.Utils (ordNub) -- | Path to a configuration file, either a singleton project root, or a longer -- list representing a path to an import. The path is a non-empty list that we @@ -45,7 +49,41 @@ import Text.PrettyPrint -- List elements are relative to each other but once canonicalized, elements are -- relative to the directory of the project root. newtype ProjectConfigPath = ProjectConfigPath (NonEmpty FilePath) - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Show, Generic) + +-- | Sorts URIs after local file paths and longer file paths after shorter ones +-- as measured by the number of path segments. If still equal, then sorting is +-- lexical. +-- +-- The project itself, a single element root path, compared to any of the +-- configuration paths it imports, should always sort first. Comparing one +-- project root path against another is done lexically. +instance Ord ProjectConfigPath where + compare pa@(ProjectConfigPath (NE.toList -> as)) pb@(ProjectConfigPath (NE.toList -> bs)) = + case (as, bs) of + -- There should only ever be one root project path, only one path + -- with length 1. Comparing it to itself should be EQ. Don't assume + -- this though, do a comparison anyway when both sides have length + -- 1. The root path, the project itself, should always be the first + -- path in a sorted listing. + ([a], [b]) -> compare a b + ([_], _) -> LT + (_, [_]) -> GT + + (a:_, b:_) -> case (parseAbsoluteURI a, parseAbsoluteURI b) of + (Just ua, Just ub) -> compare ua ub P.<> compare aImporters bImporters + (Just _, Nothing) -> GT + (Nothing, Just _) -> LT + (Nothing, Nothing) -> compare (splitPath a) (splitPath b) P.<> compare aImporters bImporters + _ -> + compare (length as) (length bs) + P.<> compare (length aPaths) (length bPaths) + P.<> compare aPaths bPaths + where + aPaths = splitPath <$> as + bPaths = splitPath <$> bs + aImporters = snd $ unconsProjectConfigPath pa + bImporters = snd $ unconsProjectConfigPath pb instance Binary ProjectConfigPath instance Structured ProjectConfigPath @@ -95,15 +133,16 @@ docProjectConfigPath (ProjectConfigPath (p :| ps)) = vcat $ -- , ProjectConfigPath ("project-cabal/pkgs/integration-tests.config" :| ["project-cabal/pkgs.config","cabal.project"]) -- , ProjectConfigPath ("project-cabal/pkgs/tests.config" :| ["project-cabal/pkgs.config","cabal.project"]) -- ] --- return . render $ docProjectConfigPaths ps +-- return . render $ docProjectConfigFiles ps -- :} -- "- cabal.project\n- project-cabal/constraints.config\n- project-cabal/ghc-latest.config\n- project-cabal/ghc-options.config\n- project-cabal/pkgs.config\n- project-cabal/pkgs/benchmarks.config\n- project-cabal/pkgs/buildinfo.config\n- project-cabal/pkgs/cabal.config\n- project-cabal/pkgs/install.config\n- project-cabal/pkgs/integration-tests.config\n- project-cabal/pkgs/tests.config" -docProjectConfigPaths :: [ProjectConfigPath] -> Doc -docProjectConfigPaths ps = vcat - [ text "-" <+> text p | ProjectConfigPath (p :| _) <- ps ] +docProjectConfigFiles :: [ProjectConfigPath] -> Doc +docProjectConfigFiles ps = vcat + [ text "-" <+> text p + | p <- ordNub [ p | ProjectConfigPath (p :| _) <- ps ] + ] --- | A message for a cyclical import, assuming the head of the path is the --- duplicate. +-- | A message for a cyclical import, a "cyclical import of". cyclicalImportMsg :: ProjectConfigPath -> Doc cyclicalImportMsg path@(ProjectConfigPath (duplicate :| _)) = vcat @@ -148,6 +187,10 @@ isTopLevelConfigPath (ProjectConfigPath p) = NE.length p == 1 consProjectConfigPath :: FilePath -> ProjectConfigPath -> ProjectConfigPath consProjectConfigPath p ps = ProjectConfigPath (p <| coerce ps) +-- | Split the path into the importee and the importer path. +unconsProjectConfigPath :: ProjectConfigPath -> (FilePath, Maybe ProjectConfigPath) +unconsProjectConfigPath ps = fmap ProjectConfigPath <$> NE.uncons (coerce ps) + -- | Make paths relative to the directory of the root of the project, not -- relative to the file they were imported from. makeRelativeConfigPath :: FilePath -> ProjectConfigPath -> ProjectConfigPath diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index eea6b958b70..5f31dc0fab5 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -951,7 +951,7 @@ renderBadPackageLocations (BadPackageLocations provenance bpls) renderExplicit = "When using configuration from:\n" - ++ render (nest 2 . docProjectConfigPaths $ mapMaybe getExplicit (Set.toList provenance)) + ++ render (nest 2 . docProjectConfigFiles $ mapMaybe getExplicit (Set.toList provenance)) ++ "\nThe following errors occurred:\n" ++ render (nest 2 $ vcat ((text "-" <+>) . text <$> map renderBadPackageLocation bpls)) diff --git a/changelog.d/pr-10546 b/changelog.d/pr-10546 new file mode 100644 index 00000000000..1851e21c0e4 --- /dev/null +++ b/changelog.d/pr-10546 @@ -0,0 +1,9 @@ +--- +synopsis: Add an Ord instance for ProjectConfigPath +packages: [cabal-install-solver] +prs: 10546 +--- + +Add an `Ord` instance for `ProjectConfigPath` that sorts URIs after local paths +and longer paths after shorter ones. Deduplicate the printing of "Configuration is +affected by the following files" messages.