Show provenance of import constraint

With this change to the solver message rendering, I also fix some bugs around project imports, adding tests for those cases. Reviewers asked that the Y-shaped import checks (using IORef) be made on a separate pull request. Removing those lead to cascading deletions.

- Regenerate expected .out files
- Show tree provenance of import constraint
- Add trimmed down PackageTests/VersionPriority
- Add changelog entry
- Use NonEmpty
- Fix check for cyclical import
- Use primes for next iteration
- Remove unused LANGUAGE pragmas
- Rename to projectConfigPathRoot
- Docs for ProjectConfigPath and showProjectConfigPath
- Renaming
- Add cyclical import tests with 1 and 2 hops in cycle
- Use full path for cyclical error message
- Expected output has project with full project path
- Add fullPath local function
- Project directory as FilePath, not Maybe FilePath
- Use (_, projectFileName) binding splitFileName
- Need full path to project parsing legacy
- Inline seenImports conversion
- Add cyclical checks with same file names and hops
- Add noncyclical tests that hop over folders
- Add a project testing skipping in and out of a folder
- Update expectations of cyclical tests
- Use canonicalizePath for collapsing .. when possible
- Capture trace for later
- Add module for ProjectConfigPath
- Move functions for ProjectConfigPath to its module
- Fetch URI is not prefixed with ./https://etc
- Document normaliseConfigPath
- Add doctests for normaliseConfigPath
- Add doctest of canonicalizeConfigPath
- Show an example of canonical paths
- Use importer and importee in canonicalizeConfigPaths
- Add logging
- Use normLocPath, drop -XMultiWayIf
- Remove seenImports parameter from parseProject
- Follow hlint suggestion: Move brackets to avoid $
- Follow hlint warning: Use mapM
- Follow hlint warning: Use traverse_
- Follow hlint suggestion: Use <$>
- Add failing test skipping across folder
- Remove normaliseConfigPath
- Add hasDuplicatesConfigPath
- Remove lengthConfigPath and nubConfigPath
- Mention cabal-install-solver in the changelog
- Left align project import tree with other content
- Rerun tests to generate left-aligned tree output
- Don't show "constraint from project requires ..."
- Regenerate test outputs without (constraint from project ...)
- Move fail reason printing to project config path module
- Minimize diff of showFR
- Show an "imported by: " list instead of a tree
- Update info logging, avoiding leading spaces
- When logging I found leading spaces were trimmed
- Don't log relative location and path
- Use unicode tree symbol in haddocks
- A duplicate importing tests
- Add Y-forking import test
- A test for detecting when the same config is imported via many different paths
- Fix a typo with ../noncyclical-same-filename-b.config
- Add an intercepting cabal-testsuite/cabal.project
- Use IORef to detect seen imports
- Get rid of seenImports
- Use IORef [FilePath] of uniqueImports
- Add consProjectConfigPath
- Expand the haddocks of newtype ProjectConfigPath
- Clarify, it's the project root directory
- Rename a function to makeRelativeConfigPath
- Fix whitespace
- Update output snippet in changelog
- Put the info logging together
- Split cycles and duplicates detection
- Add fixes and duplicate import to the change log
- Better reporting of duplicate imports
- Report cycles and duplicates using unique file name
- This is after canonicalizeConfigPath, relative to the project directory
- Get rid of fullLocPath, use normLocPath only
- Do reporting using paths relative to the directory of the project
- Issue a warning for Y-shaped duplicate imports
- Add duplicateImportMsg
- Use pretty printing for duplicate import message
- Use pretty printing for all ProjectConfigPath printing
- Drop a parameter from duplicateImportMsg
- Correct haddocks on docProjectConfigPath
- Satisfy fourmolu
- Remove the surplus space in "imported by "
- Log project parsing at the debug level, up from info
- Simplify the changelog snippet
- Use normalized paths for solver messages
- Satisfy fourmolu
- Relative to the directory of the project
- Duplicate imports are reported as warnings
- No need to mention v2-build
- Remove IORef
- Subdue a check for duplicate imports
- TODO: Catch duplicates across different import paths. We know how to do this
- Remove check for duplicate imports
- Improve the canonicalizeConfigPath doctests
- Add haddocks, drop configPath from go
- Make importsBy NonEmpty
- Use testDir in doctests
- Use canonical test directory
- Regenerate expected outputs
- Assume head of the path is the duplicate
- Get rid of duplicateImportMsg
- Remove unused imports in ProjectConfigPath
- Follow hlint suggestion: use fewer imports
- Remove fullConfigPathRoot
- Follow hlint suggestion: redundant bracket
- Use the original "source" variable name
- Put the source next to its contents
- Go with the original "seenImports" variable name
- Avoid -XMultiWayIf
- Not needed since we aren't checking for duplicates right now
- Be consistent in naming sources
- Move project dir alongside related params
- Rename to pathRequiresVersion
- Add back "constraint from"
- Talk only of cycles and not duplicates
- Don't report line number for cyclical import
- Remove 2nd example in changelog
- Remove Y-forked duplicate import test
- Add "imported by" to assertOutputContains
- Cull excess doctests of canonicalizeConfigPath
- Add deep path doctest
- Update haddocks of canonicalizeConfigPath
- remove idempotent speculation (it isn't idempotent)
- use "indirection" to describe "." and ".."
- makes the path relative to the given directory
- Remove seenImports
- Use Explicit ProjectConfigPath
- Missed one "constraint from" in changelog example
- Don't check (verbosity >= verbose) separately
- While the same level of verbosity as info, it is clearer to not check the level separately.
- Might calculate the path but not use it.
- Add AbsoluteDir
- Keep provenance normalised for display
- Remove stale REVIEW comment
- Storing provenance normalized avoids this
- Fix whitespace
- Satisfy HLint warning: Redundant flip
- Gut the repo/hashable packages
- Revert AbsoluteDir to FilePath

cabal-install-solver/cabal-install-solver.cabal

@@ -92,6 +92,7 @@ library
     Distribution.Solver.Types.PackagePreferences
     Distribution.Solver.Types.PkgConfigDb
     Distribution.Solver.Types.Progress
+    Distribution.Solver.Types.ProjectConfigPath
     Distribution.Solver.Types.ResolverPackage
     Distribution.Solver.Types.Settings
     Distribution.Solver.Types.SolverId
@@ -107,8 +108,10 @@ library
     , Cabal-syntax  ^>=3.11
     , containers    >=0.5.6.2  && <0.8
     , edit-distance ^>= 0.2.2
+    , directory     >= 1.3.7.0  && < 1.4
     , filepath      ^>=1.4.0.0 || ^>=1.5.0.0
     , mtl           >=2.0      && <2.4
+    , network-uri   >= 2.6.0.2 && < 2.7
     , pretty        ^>=1.1
     , transformers  >=0.4.2.0  && <0.7
     , text          (>= 1.2.3.0  && < 1.3) || (>= 2.0 && < 2.2)

cabal-install-solver/src/Distribution/Solver/Modular/Message.hs

@@ -31,8 +31,10 @@ import Distribution.Solver.Modular.Version
 import Distribution.Solver.Types.ConstraintSource
 import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.Progress
+import Distribution.Solver.Types.ProjectConfigPath (docProjectConfigPathFailReason)
 import Distribution.Types.LibraryName
 import Distribution.Types.UnqualComponentName
+import Text.PrettyPrint (nest, render)
 
 data Message =
     Enter           -- ^ increase indentation level
@@ -311,6 +313,7 @@ showFR _ NotExplicit                      = " (not a user-provided goal nor ment
 showFR _ Shadowed                         = " (shadowed by another installed package with same version)"
 showFR _ (Broken u)                       = " (package is broken, missing dependency " ++ prettyShow u ++ ")"
 showFR _ UnknownPackage                   = " (unknown package)"
+showFR _ (GlobalConstraintVersion vr (ConstraintSourceProjectConfig pc)) = '\n' : (render . nest 6 $ docProjectConfigPathFailReason vr pc)
 showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")"
 showFR _ (GlobalConstraintInstalled src)  = " (" ++ constraintSource src ++ " requires installed instance)"
 showFR _ (GlobalConstraintSource src)     = " (" ++ constraintSource src ++ " requires source instance)"

cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs

@@ -5,7 +5,8 @@ module Distribution.Solver.Types.ConstraintSource
     ) where
 
 import Distribution.Solver.Compat.Prelude
-import Prelude ()
+import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath, docProjectConfigPath)
+import Text.PrettyPrint (render)
 
 -- | Source of a 'PackageConstraint'.
 data ConstraintSource =
@@ -14,7 +15,7 @@ data ConstraintSource =
   ConstraintSourceMainConfig FilePath
 
   -- | Local cabal.project file
-  | ConstraintSourceProjectConfig FilePath
+  | ConstraintSourceProjectConfig ProjectConfigPath
 
   -- | User config file, which is ./cabal.config by default.
   | ConstraintSourceUserConfig FilePath
@@ -60,7 +61,7 @@ showConstraintSource :: ConstraintSource -> String
 showConstraintSource (ConstraintSourceMainConfig path) =
     "main config " ++ path
 showConstraintSource (ConstraintSourceProjectConfig path) =
-    "project config " ++ path
+    "project config " ++ render (docProjectConfigPath path)
 showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path
 showConstraintSource ConstraintSourceCommandlineFlag = "command line flag"
 showConstraintSource ConstraintSourceUserTarget = "user target"

cabal-install-solver/src/Distribution/Solver/Types/ProjectConfigPath.hs

@@ -0,0 +1,205 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Distribution.Solver.Types.ProjectConfigPath
+    (
+    -- * Project Config Path Manipulation
+      ProjectConfigPath(..)
+    , projectConfigPathRoot
+    , nullProjectConfigPath
+    , consProjectConfigPath
+
+    -- * Messages
+    , docProjectConfigPath
+    , cyclicalImportMsg
+    , docProjectConfigPathFailReason
+
+    -- * Checks and Normalization
+    , isCyclicConfigPath
+    , canonicalizeConfigPath
+    ) where
+
+import Distribution.Solver.Compat.Prelude hiding (toList, (<>))
+import Prelude (sequence)
+
+import Data.Coerce (coerce)
+import Data.List.NonEmpty ((<|))
+import Network.URI (parseURI)
+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
+
+-- | 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
+-- build up by prepending relative imports with @consProjectConfigPath@.
+--
+-- An import can be a URI, such as [a stackage
+-- cabal.config](https://www.stackage.org/nightly/cabal.config), but we do not
+-- support URIs in the middle of the path, URIs that import other URIs, or URIs
+-- that import local files.
+--
+-- 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)
+
+instance Binary ProjectConfigPath
+instance Structured ProjectConfigPath
+
+-- | Renders the path like this;
+-- @
+-- 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 ]
+
+-- | A message for a cyclical import, assuming the head of the path is the
+-- duplicate.
+cyclicalImportMsg :: ProjectConfigPath -> Doc
+cyclicalImportMsg path@(ProjectConfigPath (duplicate :| _)) =
+    vcat
+    [ text "cyclical import of" <+> text duplicate <> semi
+    , nest 2 (docProjectConfigPath path)
+    ]
+
+docProjectConfigPathFailReason :: VR -> ProjectConfigPath -> Doc
+docProjectConfigPathFailReason vr pcp
+    | ProjectConfigPath (p :| []) <- pcp =
+        constraint p
+    | ProjectConfigPath (p :| ps) <- pcp = vcat
+        [ constraint p
+        , cat [nest 2 $ text "imported by:" <+> text l | l <- ps ]
+        ]
+    where
+        pathRequiresVersion p = text p <+> text "requires" <+> text (prettyShow vr)
+        constraint p = parens $ text "constraint from" <+> pathRequiresVersion p
+
+-- | The root of the path, the project itself.
+projectConfigPathRoot :: ProjectConfigPath -> FilePath
+projectConfigPathRoot (ProjectConfigPath xs) = last xs
+
+-- | Used by some tests as a dummy "unused" project root.
+nullProjectConfigPath :: ProjectConfigPath
+nullProjectConfigPath = ProjectConfigPath $ "unused" :| []
+
+-- | Check if the path has duplicates. A cycle of imports is not allowed. This
+-- check should only be done after the path has been canonicalized with
+-- @canonicalizeConfigPath@. This is because the import path may contain paths
+-- that are the same in relation to their importers but different in relation to
+-- the project root directory.
+isCyclicConfigPath :: ProjectConfigPath -> Bool
+isCyclicConfigPath (ProjectConfigPath p) = length p /= length (NE.nub p)
+
+-- | Prepends the path of the importee to the importer path.
+consProjectConfigPath :: FilePath -> ProjectConfigPath -> ProjectConfigPath
+consProjectConfigPath p ps = ProjectConfigPath (p <| 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
+makeRelativeConfigPath dir (ProjectConfigPath p) =
+    ProjectConfigPath
+    $ (\segment -> (if isURI segment then segment else makeRelative dir segment))
+    <$> p
+
+-- | Normalizes and canonicalizes a path removing '.' and '..' indirections.
+-- Makes the path relative to the given directory (typically the project root)
+-- 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
+-- @
+--
+-- 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
+-- @
+--
+-- That way we have @hops-8.config@ instead of
+-- @./hops/../hops/../hops/../hops/../hops-8.config@.
+--
+-- Let's see how @canonicalizePath@ works that is used in the implementation
+-- then we'll see how @canonicalizeConfigPath@ works.
+--
+-- >>> let d = testDir
+-- >>> makeRelative d <$> canonicalizePath (d </> "hops/../hops/../hops/../hops/../hops-8.config")
+-- "hops-8.config"
+--
+-- >>> let d = testDir
+-- >>> p <- canonicalizeConfigPath d (ProjectConfigPath $ (d </> "hops/../hops/../hops/../hops/../hops-8.config") :| [])
+-- >>> render $ docProjectConfigPath p
+-- "hops-8.config"
+--
+-- >>> :{
+--   do
+--     let expected = unlines
+--           [ "hops/hops-9.config"
+--           , "  imported by: hops-8.config"
+--           , "  imported by: hops/hops-7.config"
+--           , "  imported by: hops-6.config"
+--           , "  imported by: hops/hops-5.config"
+--           , "  imported by: hops-4.config"
+--           , "  imported by: hops/hops-3.config"
+--           , "  imported by: hops-2.config"
+--           , "  imported by: hops/hops-1.config"
+--           , "  imported by: hops-0.project"
+--           ]
+--     let d = testDir
+--     let configPath = ProjectConfigPath ("hops/hops-9.config" :|
+--           [ "../hops-8.config"
+--           , "hops/hops-7.config"
+--           , "../hops-6.config"
+--           , "hops/hops-5.config"
+--           , "../hops-4.config"
+--           , "hops/hops-3.config"
+--           , "../hops-2.config"
+--           , "hops/hops-1.config"
+--           , d </> "hops-0.project"])
+--     p <- canonicalizeConfigPath d configPath
+--     return $ expected == render (docProjectConfigPath p) ++ "\n"
+-- :}
+-- True
+canonicalizeConfigPath :: FilePath -> ProjectConfigPath -> IO ProjectConfigPath
+canonicalizeConfigPath d (ProjectConfigPath p) = do
+    xs <- sequence $ NE.scanr (\importee -> (>>= \importer ->
+            if isURI importee
+                then pure importee
+                else canonicalizePath $ d </> takeDirectory importer </> importee))
+            (pure ".") p
+    return . makeRelativeConfigPath d . ProjectConfigPath . NE.fromList $ NE.init xs
+
+isURI :: FilePath -> Bool
+isURI = isJust . parseURI
+
+-- $setup
+-- >>> import Data.List
+-- >>> testDir <- makeAbsolute =<< canonicalizePath "../cabal-testsuite/PackageTests/ConditionalAndImport"

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

@@ -8,6 +8,7 @@
 module Distribution.Client.ProjectConfig
   ( -- * Types for project config
     ProjectConfig (..)
+  , ProjectConfigToParse (..)
   , ProjectConfigBuildOnly (..)
   , ProjectConfigShared (..)
   , ProjectConfigProvenance (..)
@@ -57,6 +58,7 @@ module Distribution.Client.ProjectConfig
   ) where
 
 import Distribution.Client.Compat.Prelude
+import Text.PrettyPrint (render)
 import Prelude ()
 
 import Distribution.Client.Glob
@@ -223,6 +225,8 @@ import System.IO
   , withBinaryFile
   )
 
+import Distribution.Solver.Types.ProjectConfigPath
+
 ----------------------------------------
 -- Resolving configuration to settings
 --
@@ -741,7 +745,7 @@ readProjectFileSkeleton
       then do
         monitorFiles [monitorFileHashed extensionFile]
         pcs <- liftIO readExtensionFile
-        monitorFiles $ map monitorFileHashed (projectSkeletonImports pcs)
+        monitorFiles $ map monitorFileHashed (projectConfigPathRoot <$> projectSkeletonImports pcs)
         pure pcs
       else do
         monitorFiles [monitorNonExistentFile extensionFile]
@@ -751,7 +755,7 @@ readProjectFileSkeleton
 
       readExtensionFile =
         reportParseResult verbosity extensionDescription extensionFile
-          =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] extensionFile
+          =<< parseProject extensionFile distDownloadSrcDirectory httpTransport verbosity . ProjectConfigToParse
           =<< BS.readFile extensionFile
 
 -- | Render the 'ProjectConfig' format.
@@ -788,7 +792,7 @@ readGlobalConfig verbosity configFileFlag = do
 reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult ProjectConfigSkeleton -> IO ProjectConfigSkeleton
 reportParseResult verbosity _filetype filename (OldParser.ParseOk warnings x) = do
   unless (null warnings) $
-    let msg = unlines (map (OldParser.showPWarning (intercalate ", " $ filename : projectSkeletonImports x)) warnings)
+    let msg = unlines (map (OldParser.showPWarning (intercalate ", " $ filename : (projectConfigPathRoot <$> projectSkeletonImports x))) warnings)
      in warn verbosity msg
   return x
 reportParseResult verbosity filetype filename (OldParser.ParseFailed err) =
@@ -872,7 +876,7 @@ renderBadPackageLocations (BadPackageLocations provenance bpls)
 
     renderExplicit =
       "When using configuration(s) from "
-        ++ intercalate ", " (mapMaybe getExplicit (Set.toList provenance))
+        ++ intercalate ", " (render . docProjectConfigPath <$> mapMaybe getExplicit (Set.toList provenance))
         ++ ", the following errors occurred:\n"
         ++ renderErrors renderBadPackageLocation