diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,1 +1,1 @@ -Please see https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.14.2.0.md +Please see https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.16.0.0.md diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2024, Cabal Development Team. +Copyright (c) 2003-2025, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. See */LICENSE for the copyright holders of the subcomponents. diff --git a/cabal-install-solver.cabal b/cabal-install-solver.cabal --- a/cabal-install-solver.cabal +++ b/cabal-install-solver.cabal @@ -1,6 +1,6 @@ -cabal-version: 2.2 +cabal-version: 3.6 name: cabal-install-solver -version: 3.14.2.0 +version: 3.16.0.0 synopsis: The solver component of cabal-install description: The solver component used in the cabal-install command-line program. @@ -11,7 +11,7 @@ license-file: LICENSE author: Cabal Development Team (see AUTHORS file) maintainer: Cabal Development Team -copyright: 2003-2024, Cabal Development Team +copyright: 2003-2025, Cabal Development Team category: Distribution build-type: Simple extra-doc-files: @@ -38,7 +38,7 @@ hs-source-dirs: src-assertion ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances - -fwarn-tabs -fwarn-incomplete-uni-patterns + -Wtabs -Wincomplete-uni-patterns if impl(ghc < 8.8) ghc-options: -Wnoncanonical-monadfail-instances @@ -101,9 +101,9 @@ , array >=0.4 && <0.6 , base >=4.13 && <4.22 , bytestring >=0.10.6.0 && <0.13 - , Cabal ^>=3.14 - , Cabal-syntax ^>=3.14 - , containers >=0.5.6.2 && <0.8 + , Cabal ^>=3.16 + , Cabal-syntax ^>=3.16 + , containers >=0.5.6.2 && <0.9 , edit-distance ^>= 0.2.2 , directory >= 1.3.7.0 && < 1.4 , filepath ^>=1.4.0.0 || ^>=1.5.0.0 @@ -118,7 +118,8 @@ if flag(debug-tracetree) cpp-options: -DDEBUG_TRACETREE - build-depends: tracetree ^>=0.1 + build-depends: + , tracetree ^>=0.1 Test-Suite unit-tests default-language: Haskell2010 diff --git a/src/Distribution/Solver/Compat/Prelude.hs b/src/Distribution/Solver/Compat/Prelude.hs --- a/src/Distribution/Solver/Compat/Prelude.hs +++ b/src/Distribution/Solver/Compat/Prelude.hs @@ -1,5 +1,5 @@ -- to suppress WARNING in "Distribution.Compat.Prelude.Internal" -{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# OPTIONS_GHC -Wno-deprecations #-} -- | This module does two things: -- diff --git a/src/Distribution/Solver/Modular/Linking.hs b/src/Distribution/Solver/Modular/Linking.hs --- a/src/Distribution/Solver/Modular/Linking.hs +++ b/src/Distribution/Solver/Modular/Linking.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} -- TODO: remove this -{-# OPTIONS -fno-warn-incomplete-uni-patterns #-} +{-# OPTIONS -Wno-incomplete-uni-patterns #-} module Distribution.Solver.Modular.Linking ( validateLinking ) where diff --git a/src/Distribution/Solver/Modular/Message.hs b/src/Distribution/Solver/Modular/Message.hs --- a/src/Distribution/Solver/Modular/Message.hs +++ b/src/Distribution/Solver/Modular/Message.hs @@ -1,6 +1,5 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ViewPatterns #-} module Distribution.Solver.Modular.Message ( Message(..), diff --git a/src/Distribution/Solver/Modular/PSQ.hs b/src/Distribution/Solver/Modular/PSQ.hs --- a/src/Distribution/Solver/Modular/PSQ.hs +++ b/src/Distribution/Solver/Modular/PSQ.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE DeriveTraversable #-} module Distribution.Solver.Modular.PSQ ( PSQ(..) -- Unit test needs constructor access , casePSQ diff --git a/src/Distribution/Solver/Modular/Solver.hs b/src/Distribution/Solver/Modular/Solver.hs --- a/src/Distribution/Solver/Modular/Solver.hs +++ b/src/Distribution/Solver/Modular/Solver.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} #ifdef DEBUG_TRACETREE {-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-orphans #-} #endif module Distribution.Solver.Modular.Solver ( SolverConfig(..) @@ -171,6 +171,7 @@ -- -- This only does something if the @debug-tracetree@ configure argument was -- given; otherwise this is just the identity function. +{- FOURMOLU_DISABLE -} traceTree :: #ifdef DEBUG_TRACETREE GSimpleTree a => @@ -183,6 +184,7 @@ #else traceTree _ _ = id #endif +{- FOURMOLU_ENABLE -} #ifdef DEBUG_TRACETREE instance GSimpleTree (Tree d c) where diff --git a/src/Distribution/Solver/Modular/Tree.hs b/src/Distribution/Solver/Modular/Tree.hs --- a/src/Distribution/Solver/Modular/Tree.hs +++ b/src/Distribution/Solver/Modular/Tree.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE DeriveTraversable #-} module Distribution.Solver.Modular.Tree ( POption(..) , Tree(..) diff --git a/src/Distribution/Solver/Modular/WeightedPSQ.hs b/src/Distribution/Solver/Modular/WeightedPSQ.hs --- a/src/Distribution/Solver/Modular/WeightedPSQ.hs +++ b/src/Distribution/Solver/Modular/WeightedPSQ.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Distribution.Solver.Modular.WeightedPSQ ( diff --git a/src/Distribution/Solver/Types/ConstraintSource.hs b/src/Distribution/Solver/Types/ConstraintSource.hs --- a/src/Distribution/Solver/Types/ConstraintSource.hs +++ b/src/Distribution/Solver/Types/ConstraintSource.hs @@ -6,7 +6,8 @@ import Distribution.Solver.Compat.Prelude import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath, docProjectConfigPath) -import Text.PrettyPrint (render) +import Distribution.Pretty (Pretty(pretty), prettyShow) +import Text.PrettyPrint (text) -- | Source of a 'PackageConstraint'. data ConstraintSource = @@ -41,6 +42,10 @@ -- from Cabal >= 3.11 | ConstraintSourceMultiRepl + -- | Constraint introduced by --with-repl, which requires features + -- from Cabal >= 3.15 + | ConstraintSourceWithRepl + -- | Constraint introduced by --enable-profiling-shared, which requires features -- from Cabal >= 3.13 | ConstraintSourceProfiledDynamic @@ -55,31 +60,37 @@ -- | An internal constraint due to compatibility issues with the Setup.hs -- command line interface requires a maximum upper bound on Cabal | ConstraintSetupCabalMaxVersion - deriving (Eq, Show, Generic) + deriving (Show, Eq, Generic) instance Binary ConstraintSource instance Structured ConstraintSource -- | Description of a 'ConstraintSource'. showConstraintSource :: ConstraintSource -> String -showConstraintSource (ConstraintSourceMainConfig path) = - "main config " ++ path -showConstraintSource (ConstraintSourceProjectConfig path) = - "project config " ++ render (docProjectConfigPath path) -showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path -showConstraintSource ConstraintSourceCommandlineFlag = "command line flag" -showConstraintSource ConstraintSourceUserTarget = "user target" -showConstraintSource ConstraintSourceNonReinstallablePackage = - "non-reinstallable package" -showConstraintSource ConstraintSourceFreeze = "cabal freeze" -showConstraintSource ConstraintSourceConfigFlagOrTarget = - "config file, command line flag, or user target" -showConstraintSource ConstraintSourceMultiRepl = - "--enable-multi-repl" -showConstraintSource ConstraintSourceProfiledDynamic = - "--enable-profiling-shared" -showConstraintSource ConstraintSourceUnknown = "unknown source" -showConstraintSource ConstraintSetupCabalMinVersion = - "minimum version of Cabal used by Setup.hs" -showConstraintSource ConstraintSetupCabalMaxVersion = - "maximum version of Cabal used by Setup.hs" +showConstraintSource = prettyShow + +instance Pretty ConstraintSource where + pretty constraintSource = case constraintSource of + (ConstraintSourceMainConfig path) -> + text "main config" <+> text path + (ConstraintSourceProjectConfig path) -> + text "project config" <+> docProjectConfigPath path + (ConstraintSourceUserConfig path)-> text "user config " <+> text path + ConstraintSourceCommandlineFlag -> text "command line flag" + ConstraintSourceUserTarget -> text "user target" + ConstraintSourceNonReinstallablePackage -> + text "non-reinstallable package" + ConstraintSourceFreeze -> text "cabal freeze" + ConstraintSourceConfigFlagOrTarget -> + text "config file, command line flag, or user target" + ConstraintSourceMultiRepl -> + text "--enable-multi-repl" + ConstraintSourceWithRepl -> + text "--with-repl" + ConstraintSourceProfiledDynamic -> + text "--enable-profiling-shared" + ConstraintSourceUnknown -> text "unknown source" + ConstraintSetupCabalMinVersion -> + text "minimum version of Cabal used by Setup.hs" + ConstraintSetupCabalMaxVersion -> + text "maximum version of Cabal used by Setup.hs" diff --git a/src/Distribution/Solver/Types/PackageConstraint.hs b/src/Distribution/Solver/Types/PackageConstraint.hs --- a/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/src/Distribution/Solver/Types/PackageConstraint.hs @@ -11,9 +11,7 @@ scopeToPackageName, constraintScopeMatches, PackageProperty(..), - dispPackageProperty, PackageConstraint(..), - dispPackageConstraint, showPackageConstraint, packageConstraintToDependency ) where @@ -23,7 +21,7 @@ import Distribution.Package (PackageName) import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) -import Distribution.Pretty (flatStyle, pretty) +import Distribution.Pretty (flatStyle, Pretty(pretty)) import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..)) import Distribution.Version (VersionRange, simplifyVersionRange) @@ -82,12 +80,11 @@ in setup pp && pn == pn' constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn' --- | Pretty-prints a constraint scope. -dispConstraintScope :: ConstraintScope -> Disp.Doc -dispConstraintScope (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn -dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> pretty pn -dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn -dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn +instance Pretty ConstraintScope where + pretty (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn + pretty (ScopeQualified q pn) = dispQualifier q <<>> pretty pn + pretty (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn + pretty (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn -- | A package property is a logical predicate on packages. data PackageProperty @@ -101,24 +98,22 @@ instance Binary PackageProperty instance Structured PackageProperty --- | Pretty-prints a package property. -dispPackageProperty :: PackageProperty -> Disp.Doc -dispPackageProperty (PackagePropertyVersion verrange) = pretty verrange -dispPackageProperty PackagePropertyInstalled = Disp.text "installed" -dispPackageProperty PackagePropertySource = Disp.text "source" -dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags -dispPackageProperty (PackagePropertyStanzas stanzas) = - Disp.hsep $ map (Disp.text . showStanza) stanzas +instance Pretty PackageProperty where + pretty (PackagePropertyVersion verrange) = pretty verrange + pretty PackagePropertyInstalled = Disp.text "installed" + pretty PackagePropertySource = Disp.text "source" + pretty (PackagePropertyFlags flags) = dispFlagAssignment flags + pretty (PackagePropertyStanzas stanzas) = + Disp.hsep $ map (Disp.text . showStanza) stanzas -- | A package constraint consists of a scope plus a property -- that must hold for all packages within that scope. data PackageConstraint = PackageConstraint ConstraintScope PackageProperty deriving (Eq, Show) --- | Pretty-prints a package constraint. -dispPackageConstraint :: PackageConstraint -> Disp.Doc -dispPackageConstraint (PackageConstraint scope prop) = - dispConstraintScope scope <+> dispPackageProperty prop +instance Pretty PackageConstraint where + pretty (PackageConstraint scope prop) = + pretty scope <+> pretty prop -- | Alternative textual representation of a package constraint -- for debugging purposes (slightly more verbose than that @@ -126,7 +121,7 @@ -- showPackageConstraint :: PackageConstraint -> String showPackageConstraint pc@(PackageConstraint scope prop) = - Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2 + Disp.renderStyle flatStyle . postprocess $ pretty pc2 where pc2 = case prop of PackagePropertyVersion vr -> diff --git a/src/Distribution/Solver/Types/PkgConfigDb.hs b/src/Distribution/Solver/Types/PkgConfigDb.hs --- a/src/Distribution/Solver/Types/PkgConfigDb.hs +++ b/src/Distribution/Solver/Types/PkgConfigDb.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Solver.Types.PkgConfigDb diff --git a/src/Distribution/Solver/Types/ProjectConfigPath.hs b/src/Distribution/Solver/Types/ProjectConfigPath.hs --- a/src/Distribution/Solver/Types/ProjectConfigPath.hs +++ b/src/Distribution/Solver/Types/ProjectConfigPath.hs @@ -12,13 +12,16 @@ -- * Messages , docProjectConfigPath - , docProjectConfigPaths + , docProjectConfigFiles , cyclicalImportMsg + , untrimmedUriImportMsg , docProjectConfigPathFailReason + , quoteUntrimmed -- * Checks and Normalization , isCyclicConfigPath , isTopLevelConfigPath + , isUntrimmedUriConfigPath , canonicalizeConfigPath ) where @@ -30,12 +33,17 @@ import Data.List.NonEmpty ((<|)) import Network.URI (parseURI, parseAbsoluteURI) import System.Directory -import System.FilePath +import System.FilePath hiding (splitPath) +import qualified System.FilePath as FP (splitPath) +import qualified System.FilePath.Posix as Posix +import qualified System.FilePath.Windows as Windows import qualified Data.List.NonEmpty as NE import Distribution.Solver.Modular.Version (VR) -import Distribution.Pretty (prettyShow) +import Distribution.Pretty (prettyShow, Pretty(..)) +import Distribution.Utils.String (trim) import Text.PrettyPrint import Distribution.Simple.Utils (ordNub) +import Distribution.System (OS(Windows), buildOS) -- | 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 @@ -51,6 +59,9 @@ newtype ProjectConfigPath = ProjectConfigPath (NonEmpty FilePath) deriving (Eq, Show, Generic) +instance Pretty ProjectConfigPath where + pretty = docProjectConfigPath + -- | 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. @@ -58,6 +69,14 @@ -- 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. +-- +-- For comparison purposes, path separators are normalized to the @buildOS@ +-- platform's path separator. +-- +-- >>> let abFwd = ProjectConfigPath $ "a/b.config" :| [] +-- >>> let abBwd = ProjectConfigPath $ "a\\b.config" :| [] +-- >>> compare abFwd abBwd +-- EQ instance Ord ProjectConfigPath where compare pa@(ProjectConfigPath (NE.toList -> as)) pb@(ProjectConfigPath (NE.toList -> bs)) = case (as, bs) of @@ -66,7 +85,7 @@ -- 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 + ([a], [b]) -> compare (splitPath a) (splitPath b) ([_], _) -> LT (_, [_]) -> GT @@ -80,6 +99,16 @@ P.<> compare (length aPaths) (length bPaths) P.<> compare aPaths bPaths where + splitPath = FP.splitPath . normSep where + normSep p = + if buildOS == Windows + then + Windows.joinPath $ Windows.splitDirectories + [if Posix.isPathSeparator c then Windows.pathSeparator else c| c <- p] + else + Posix.joinPath $ Posix.splitDirectories + [if Windows.isPathSeparator c then Posix.pathSeparator else c| c <- p] + aPaths = splitPath <$> as bPaths = splitPath <$> bs aImporters = snd $ unconsProjectConfigPath pa @@ -89,35 +118,39 @@ instance Structured ProjectConfigPath -- | Renders the path like this; --- @ --- D.config --- imported by: C.config --- imported by: B.config --- imported by: A.project --- @ +-- +-- >D.config +-- > imported by: C.config +-- > imported by: B.config +-- > imported by: A.project +-- -- >>> render . docProjectConfigPath $ ProjectConfigPath $ "D.config" :| ["C.config", "B.config", "A.project"] -- "D.config\n imported by: C.config\n imported by: B.config\n imported by: A.project" docProjectConfigPath :: ProjectConfigPath -> Doc -docProjectConfigPath (ProjectConfigPath (p :| [])) = text p -docProjectConfigPath (ProjectConfigPath (p :| ps)) = vcat $ - text p : [ text " " <+> text "imported by:" <+> text l | l <- ps ] +docProjectConfigPath (ProjectConfigPath (p :| [])) = quoteUntrimmed p +docProjectConfigPath (ProjectConfigPath (p :| ps)) = vcat $ quoteUntrimmed p : + [ text " " <+> text "imported by:" <+> quoteUntrimmed l | l <- ps ] +-- | If the path has leading or trailing spaces then show it quoted. +quoteUntrimmed :: FilePath -> Doc +quoteUntrimmed s = if trim s /= s then quotes (text s) else text s + -- | Renders the paths as a list without showing which path imports another, -- like this; --- @ --- - cabal.project --- - project-cabal/constraints.config --- - project-cabal/ghc-latest.config --- - project-cabal/ghc-options.config --- - project-cabal/pkgs.config --- - project-cabal/pkgs/benchmarks.config --- - project-cabal/pkgs/buildinfo.config --- - project-cabal/pkgs/cabal.config --- - project-cabal/pkgs/install.config --- - project-cabal/pkgs/integration-tests.config --- - project-cabal/pkgs/tests.config --- @ -- +-- >- cabal.project +-- >- project-cabal/constraints.config +-- >- project-cabal/ghc-latest.config +-- >- project-cabal/ghc-options.config +-- >- project-cabal/pkgs.config +-- >- project-cabal/pkgs/benchmarks.config +-- >- project-cabal/pkgs/buildinfo.config +-- >- project-cabal/pkgs/cabal.config +-- >- project-cabal/pkgs/install.config +-- >- project-cabal/pkgs/integration-tests.config +-- >- project-cabal/pkgs/tests.config +-- +-- -- >>> :{ -- do -- let ps = @@ -133,11 +166,11 @@ -- , 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 +docProjectConfigFiles :: [ProjectConfigPath] -> Doc +docProjectConfigFiles ps = vcat [ text "-" <+> text p | p <- ordNub [ p | ProjectConfigPath (p :| _) <- ps ] ] @@ -150,6 +183,14 @@ , nest 2 (docProjectConfigPath path) ] +-- | A message for an import that has leading or trailing spaces. +untrimmedUriImportMsg :: Doc -> ProjectConfigPath -> Doc +untrimmedUriImportMsg intro path = + vcat + [ intro <+> text "import has leading or trailing whitespace" <> semi + , nest 2 (docProjectConfigPath path) + ] + docProjectConfigPathFailReason :: VR -> ProjectConfigPath -> Doc docProjectConfigPathFailReason vr pcp | ProjectConfigPath (p :| []) <- pcp = @@ -178,6 +219,11 @@ isCyclicConfigPath :: ProjectConfigPath -> Bool isCyclicConfigPath (ProjectConfigPath p) = length p /= length (NE.nub p) +-- | Check if the last segment of the path (root or importee) is a URI that has +-- leading or trailing spaces. +isUntrimmedUriConfigPath :: ProjectConfigPath -> Bool +isUntrimmedUriConfigPath (ProjectConfigPath (p :| _)) = let p' = trim p in p' /= p && isURI p' + -- | Check if the project config path is top-level, meaning it was not included by -- some other project config. isTopLevelConfigPath :: ProjectConfigPath -> Bool @@ -196,7 +242,7 @@ makeRelativeConfigPath :: FilePath -> ProjectConfigPath -> ProjectConfigPath makeRelativeConfigPath dir (ProjectConfigPath p) = ProjectConfigPath - $ (\segment -> (if isURI segment then segment else makeRelative dir segment)) + $ (\segment@(trim -> trimSegment) -> (if isURI trimSegment then trimSegment else makeRelative dir segment)) <$> p -- | Normalizes and canonicalizes a path removing '.' and '..' indirections. @@ -204,33 +250,31 @@ -- instead of relative to the file it was imported from. -- -- It converts paths like this: --- @ --- └─ hops-0.project --- └─ hops/hops-1.config --- └─ ../hops-2.config --- └─ hops/hops-3.config --- └─ ../hops-4.config --- └─ hops/hops-5.config --- └─ ../hops-6.config --- └─ hops/hops-7.config --- └─ ../hops-8.config --- └─ hops/hops-9.config --- @ -- +-- > hops-0.project +-- > └─ hops/hops-1.config +-- > └─ ../hops-2.config +-- > └─ hops/hops-3.config +-- > └─ ../hops-4.config +-- > └─ hops/hops-5.config +-- > └─ ../hops-6.config +-- > └─ hops/hops-7.config +-- > └─ ../hops-8.config +-- > └─ hops/hops-9.config +-- -- Into paths like this: --- @ --- └─ hops-0.project --- └─ hops/hops-1.config --- └─ hops-2.config --- └─ hops/hops-3.config --- └─ hops-4.config --- └─ hops/hops-5.config --- └─ hops-6.config --- └─ hops/hops-7.config --- └─ hops-8.config --- └─ hops/hops-9.config --- @ -- +-- > hops-0.project +-- > └─ hops/hops-1.config +-- > └─ hops-2.config +-- > └─ hops/hops-3.config +-- > └─ hops-4.config +-- > └─ hops/hops-5.config +-- > └─ hops-6.config +-- > └─ hops/hops-7.config +-- > └─ hops-8.config +-- > └─ hops/hops-9.config +-- -- That way we have @hops-8.config@ instead of -- @./hops/../hops/../hops/../hops/../hops-8.config@. -- @@ -275,11 +319,25 @@ -- return $ expected == render (docProjectConfigPath p) ++ "\n" -- :} -- True +-- +-- "A string is a valid URL potentially surrounded by spaces if, after stripping leading and trailing whitespace from it, it is a valid URL." +-- [W3C/HTML5/URLs](https://www.w3.org/TR/2010/WD-html5-20100624/urls.html) +-- +-- Trailing spaces for @ProjectConfigPath@ URLs are trimmed. +-- +-- >>> p <- canonicalizeConfigPath "" (ProjectConfigPath $ ("https://www.stackage.org/nightly-2024-12-05/cabal.config ") :| []) +-- >>> render $ docProjectConfigPath p +-- "https://www.stackage.org/nightly-2024-12-05/cabal.config" +-- +-- >>> let d = testDir +-- >>> p <- canonicalizeConfigPath d (ProjectConfigPath $ ("https://www.stackage.org/nightly-2024-12-05/cabal.config ") :| [d "cabal.project"]) +-- >>> render $ docProjectConfigPath p +-- "https://www.stackage.org/nightly-2024-12-05/cabal.config\n imported by: cabal.project" canonicalizeConfigPath :: FilePath -> ProjectConfigPath -> IO ProjectConfigPath canonicalizeConfigPath d (ProjectConfigPath p) = do - xs <- sequence $ NE.scanr (\importee -> (>>= \importer -> - if isURI importee - then pure importee + xs <- sequence $ NE.scanr (\importee@(trim -> trimImportee) -> (>>= \importer@(trim -> trimImporter) -> + if isURI trimImportee || isURI trimImporter + then pure trimImportee else canonicalizePath $ d takeDirectory importer importee)) (pure ".") p return . makeRelativeConfigPath d . ProjectConfigPath . NE.fromList $ NE.init xs diff --git a/tests/UnitTests/Distribution/Solver/Modular/MessageUtils.hs b/tests/UnitTests/Distribution/Solver/Modular/MessageUtils.hs --- a/tests/UnitTests/Distribution/Solver/Modular/MessageUtils.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/MessageUtils.hs @@ -58,9 +58,9 @@ isOutOfBounds range a b = not $ withinRange range a b testRange :: Int -> [String] -> String -> Assertion -testRange range elems erronousElement = assertBool "String should be out of bounds to make a spelling suggestion" (isOutOfBounds range erronousElement suggestion) +testRange range elems erroneousElement = assertBool "String should be out of bounds to make a spelling suggestion" (isOutOfBounds range erroneousElement suggestion) where - suggestion = mostSimilarElement erronousElement elems + suggestion = mostSimilarElement erroneousElement elems outOfBounds :: [String] outOfBounds =