Show import tree provenance

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
@@ -230,6 +232,8 @@ import System.IO
   , withBinaryFile
   )
 
+import Distribution.Solver.Types.ProjectConfigPath
+
 ----------------------------------------
 -- Resolving configuration to settings
 --
@@ -748,7 +752,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]
@@ -758,7 +762,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.
@@ -795,7 +799,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) =
@@ -879,7 +883,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