Duplicate project import as a warning only

.typos-srcs.toml

@@ -16,6 +16,7 @@ extend-exclude = [
     ".hlint.yaml",
     "Cabal-tests/tests/ParserTests/errors/common1.cabal", # import: windo doesn't exist
     "Cabal-tests/tests/ParserTests/errors/common1.errors",
+    "cabal-testsuite/PackageTests/ProjectImport/UniquePathDuplicates/www-stackage-org/lts-21.25.config",
 ]
 
 [default]

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

@@ -4,7 +4,10 @@
 module Distribution.Solver.Types.ProjectConfigPath
     (
     -- * Project Config Path Manipulation
-      ProjectConfigPath(..)
+      ProjectFilePath(..)
+    , ProjectConfigPath(..)
+    , compareLexically
+    , compareSegmentally
     , projectConfigPathRoot
     , nullProjectConfigPath
     , consProjectConfigPath
@@ -14,9 +17,6 @@ module Distribution.Solver.Types.ProjectConfigPath
     -- * Messages
     , docProjectConfigPath
     , docProjectImportedBy
-    , docProjectConfigFiles
-    , cyclicalImportMsg
-    , untrimmedUriImportMsg
     , docProjectConfigPathFailReason
     , quoteUntrimmed
 
@@ -27,7 +27,7 @@ module Distribution.Solver.Types.ProjectConfigPath
     , canonicalizeConfigPath
     ) where
 
-import Distribution.Solver.Compat.Prelude hiding (toList, (<>))
+import Distribution.Solver.Compat.Prelude hiding (empty, toList, (<>))
 import qualified Distribution.Solver.Compat.Prelude as P ((<>))
 import Prelude (sequence)
 
@@ -44,9 +44,12 @@ import Distribution.Solver.Modular.Version (VR)
 import Distribution.Pretty (prettyShow, Pretty(..))
 import Distribution.Utils.String (trim)
 import Text.PrettyPrint
-import Distribution.Simple.Utils (ordNub)
 import Distribution.System (OS(Windows), buildOS)
 
+-- | Not just any file path. The project itself.
+newtype ProjectFilePath = ProjectFilePath FilePath
+    deriving (Eq, Generic)
+
 -- | 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@.
@@ -59,10 +62,10 @@ import Distribution.System (OS(Windows), buildOS)
 -- 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, Show, Generic)
+    deriving (Eq, Generic)
 
-instance Pretty ProjectConfigPath where
-  pretty = docProjectConfigPath
+instance Pretty ProjectConfigPath where pretty = docProjectConfigPath
+instance Show ProjectConfigPath where show = prettyShow
 
 -- | 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
@@ -79,43 +82,91 @@ instance Pretty ProjectConfigPath where
 -- >>> let abBwd = ProjectConfigPath $ "a\\b.config" :| []
 -- >>> compare abFwd abBwd
 -- EQ
+--
+-- >>> let abc = ProjectConfigPath $ "a/b/c.config" :| []
+-- >>> let yz = ProjectConfigPath $ "y/z.config" :| []
+-- >>> (compare abc yz, let xs = [abc, yz] in xs == sort xs)
+-- (GT,False)
+--
+-- >>> let abc = ProjectConfigPath $ "C.config" :| ["B.config", "A.project"]
+-- >>> let bcd = ProjectConfigPath $ "D.config" :| ["C.config", "B.project"]
+-- >>> (compare abc bcd, let xs = [abc, bcd] in xs == sort xs)
+-- (LT,True)
+--
+-- >>> let abc = ProjectConfigPath $ "C.config" :| ["B.config", "A.project"]
+-- >>> let yz = ProjectConfigPath $ "Z.config" :| ["Y.project"]
+-- >>> (compare abc yz, let xs = [abc, yz] in xs == sort xs)
+-- (GT,False)
 instance Ord ProjectConfigPath where
-    compare pa@(ProjectConfigPath (NE.toList -> as)) pb@(ProjectConfigPath (NE.toList -> bs)) =
+    compare = compareSegmentally
+
+-- | A comparison that puts projects first, URLs last and sorts the other paths
+-- lexically.
+compareLexically :: ProjectConfigPath -> ProjectConfigPath -> Ordering
+compareLexically (ProjectConfigPath as) (ProjectConfigPath bs) =
+        case (as, bs) of
+            -- Single element paths are projects, they should always sort first.
+            (a :| [], b :| []) -> compare (splitPath a) (splitPath b)
+            (_ :| [], _) -> LT
+            (_, _ :| []) -> GT
+
+            (a :| aImporters, b :| bImporters) -> 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
+
+-- | A comparison that puts projects first, URLs last and sorts the other paths
+-- by putting longer paths after shorter ones as measured by the number of path
+-- segments. If still equal, then sorting is lexical.
+compareSegmentally:: ProjectConfigPath -> ProjectConfigPath -> Ordering
+compareSegmentally pa@(ProjectConfigPath as) pb@(ProjectConfigPath 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 (splitPath a) (splitPath b)
-            ([_], _) -> LT
-            (_, [_]) -> GT
+            (a :| [], b :| []) ->
+                let aPaths = splitPath a
+                    bPaths = splitPath b
+                in
+                    compare (length aPaths) (length bPaths)
+                    P.<> compare aPaths bPaths
 
-            (a:_, b:_) -> case (parseAbsoluteURI a, parseAbsoluteURI b) of
+            (_ :| [], _) -> 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
+                (Nothing, Nothing) ->
+                    let aPaths = splitPath a
+                        bPaths = splitPath b
+                    in
+                        compare (length as) (length bs)
+                        P.<> compare asPaths bsPaths
+                        P.<> compare (length aPaths) (length bPaths)
+                        P.<> compare aPaths bPaths
+                        P.<> compare aImporters bImporters
         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
+            asPaths = splitPath <$> as
+            bsPaths = splitPath <$> bs
             aImporters = snd $ unconsProjectConfigPath pa
             bImporters = snd $ unconsProjectConfigPath pb
 
+splitPath :: FilePath -> [FilePath]
+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]
+
 instance Binary ProjectConfigPath
 instance NFData ProjectConfigPath
 instance Structured ProjectConfigPath
@@ -140,67 +191,10 @@ docProjectImportedBy (ProjectConfigPath (_ :| [])) = text ""
 docProjectImportedBy (ProjectConfigPath (_ :| ps)) = vcat $
     [ 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
---
---
--- >>> :{
---   do
---     let ps =
---              [ ProjectConfigPath ("cabal.project" :| [])
---              , ProjectConfigPath ("project-cabal/constraints.config" :| ["cabal.project"])
---              , ProjectConfigPath ("project-cabal/ghc-latest.config" :| ["cabal.project"])
---              , ProjectConfigPath ("project-cabal/ghc-options.config" :| ["cabal.project"])
---              , ProjectConfigPath ("project-cabal/pkgs.config" :| ["cabal.project"])
---              , ProjectConfigPath ("project-cabal/pkgs/benchmarks.config" :| ["project-cabal/pkgs.config","cabal.project"])
---              , ProjectConfigPath ("project-cabal/pkgs/buildinfo.config" :| ["project-cabal/pkgs.config","cabal.project"])
---              , ProjectConfigPath ("project-cabal/pkgs/cabal.config" :| ["project-cabal/pkgs.config","cabal.project"])
---              , ProjectConfigPath ("project-cabal/pkgs/install.config" :| ["project-cabal/pkgs.config","cabal.project"])
---              , 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 $ 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"
-docProjectConfigFiles :: [ProjectConfigPath] -> Doc
-docProjectConfigFiles ps = vcat
-    [ text "-" <+> text p
-    | p <- ordNub [ p | ProjectConfigPath (p :| _) <- ps ]
-    ]
-
--- | A message for a cyclical import, a "cyclical import of".
-cyclicalImportMsg :: ProjectConfigPath -> Doc
-cyclicalImportMsg path@(ProjectConfigPath (duplicate :| _)) =
-    vcat
-    [ text "cyclical import of" <+> text duplicate <> semi
-    , 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 =

cabal-install/cabal-install.cabal

@@ -185,6 +185,7 @@ library
         Distribution.Client.ProjectBuilding.Types
         Distribution.Client.ProjectConfig
         Distribution.Client.ProjectConfig.FieldGrammar
+        Distribution.Client.ProjectConfig.Import
         Distribution.Client.ProjectConfig.Legacy
         Distribution.Client.ProjectConfig.Lens
         Distribution.Client.ProjectConfig.Parsec

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
 
@@ -255,6 +256,7 @@ import System.IO
   , withBinaryFile
   )
 
+import Distribution.Client.ProjectConfig.Import
 import Distribution.Deprecated.ProjectParseUtils (ProjectParseError (..), ProjectParseWarning)
 import Distribution.Solver.Types.ProjectConfigPath
 
@@ -854,7 +856,10 @@ readProjectFileSkeletonGen
         then do
           monitorFiles [monitorFileHashed extensionFile]
           pcs <- liftIO $ parseConfig extensionFile
-          monitorFiles $ map monitorFileHashed (projectConfigPathRoot <$> projectSkeletonImports pcs)
+          monitorFiles
+            [ monitorFileHashed (projectConfigPathRoot path)
+            | (Nothing, path) <- projectSkeletonImports pcs
+            ]
           return pcs
         else do
           monitorFiles [monitorNonExistentFile extensionFile]
@@ -893,22 +898,22 @@ readProjectFileSkeletonLegacy :: Verbosity -> HttpTransport -> DistDirLayout ->
 readProjectFileSkeletonLegacy verbosity httpTransport distDirLayout extensionName extensionDescription = do
   readProjectFileSkeletonGen verbosity httpTransport distDirLayout extensionName extensionDescription $ \fp -> do
     debug verbosity "Reading project file using the legacy parser"
-    parseProjectFileSkeletonLegacy verbosity httpTransport distDirLayout extensionName extensionDescription fp
+    parseProjectFileSkeletonLegacy verbosity httpTransport distDirLayout extensionName extensionDescription (ProjectFilePath fp)
       >>= liftIO . reportParseResult verbosity extensionDescription fp
 
 -- | Read a project file using the parsec parser, but if that fails, it falls back to the legacy parser.
 readProjectFileSkeletonFallback :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> Rebuild ProjectConfigSkeleton
 readProjectFileSkeletonFallback verbosity httpTransport distDirLayout extensionName extensionDescription = do
   readProjectFileSkeletonGen verbosity httpTransport distDirLayout extensionName extensionDescription $ \fp -> do
     debug verbosity "Reading project file using the fallback parser"
-    (res, bs) <- parseProjectFileSkeletonParsec verbosity httpTransport distDirLayout extensionName extensionDescription fp
+    (res, bs) <- parseProjectFileSkeletonParsec verbosity httpTransport distDirLayout extensionName extensionDescription (ProjectFilePath fp)
     let (_, pres) = runParseResult res
     case pres of
       -- 1. Successful parse with parsec parser, handle the result as normal.
       Right{} -> liftIO $ reportParseResultParsec verbosity fp bs res
       -- 2. The parse failed with the parsec parser, fallback to the legacy parser.
       Left{} -> do
-        lres <- parseProjectFileSkeletonLegacy verbosity httpTransport distDirLayout extensionName extensionDescription fp
+        lres <- parseProjectFileSkeletonLegacy verbosity httpTransport distDirLayout extensionName extensionDescription (ProjectFilePath fp)
         case lres of
           -- 3a. The legacy parser worked, but the parsec parser failed!
           -- Report a warning to the user that this happened.
@@ -924,15 +929,15 @@ readProjectFileSkeletonParsec :: Verbosity -> HttpTransport -> DistDirLayout ->
 readProjectFileSkeletonParsec verbosity httpTransport distDirLayout extensionName extensionDescription = do
   readProjectFileSkeletonGen verbosity httpTransport distDirLayout extensionName extensionDescription $ \fp -> do
     debug verbosity "Reading project file using the parsec parser"
-    (res, bs) <- parseProjectFileSkeletonParsec verbosity httpTransport distDirLayout extensionName extensionDescription fp
+    (res, bs) <- parseProjectFileSkeletonParsec verbosity httpTransport distDirLayout extensionName extensionDescription (ProjectFilePath fp)
     liftIO $ reportParseResultParsec verbosity fp bs res
 
 readProjectFileSkeletonCompare :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> Rebuild ProjectConfigSkeleton
 readProjectFileSkeletonCompare verbosity httpTransport distDirLayout extensionName extensionDescription = do
   readProjectFileSkeletonGen verbosity httpTransport distDirLayout extensionName extensionDescription $ \fp -> do
     debug verbosity "Reading project file using the comparative parser"
-    (pres, bs) <- parseProjectFileSkeletonParsec verbosity httpTransport distDirLayout extensionName extensionDescription fp
-    lres <- parseProjectFileSkeletonLegacy verbosity httpTransport distDirLayout extensionName extensionDescription fp
+    (pres, bs) <- parseProjectFileSkeletonParsec verbosity httpTransport distDirLayout extensionName extensionDescription (ProjectFilePath fp)
+    lres <- parseProjectFileSkeletonLegacy verbosity httpTransport distDirLayout extensionName extensionDescription (ProjectFilePath fp)
     let (_, ppres) = runParseResult pres
     case (lres, ppres) of
       -- 1. Both succeed, compare the results
@@ -971,16 +976,22 @@ reportParseResultParsec verbosity fpath contents pr = do
       dieWithException verbosity $ ProjectConfigParseFailure $ ProjectConfigParseError errors warnings
 
 -- | Reads a named extended (with imports and conditionals) config file in the given project root dir, or returns empty.
-parseProjectFileSkeletonLegacy :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> FilePath -> IO (OldParser.ProjectParseResult ProjectConfigSkeleton)
-parseProjectFileSkeletonLegacy verbosity httpTransport distDirLayout extensionName extensionDescription extensionFile =
-  parseProject extensionFile (distDownloadSrcDirectory distDirLayout) httpTransport verbosity . ProjectConfigToParse
-    =<< BS.readFile extensionFile
+parseProjectFileSkeletonLegacy :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> ProjectFilePath -> IO (OldParser.ProjectParseResult ProjectConfigSkeleton)
+parseProjectFileSkeletonLegacy verbosity httpTransport distDirLayout extensionName extensionDescription project@(ProjectFilePath extensionFile) = do
+  bs <- BS.readFile extensionFile
+  res <- parseProject project (distDownloadSrcDirectory distDirLayout) httpTransport verbosity $ ProjectConfigToParse bs
+  case res of
+    x@(OldParser.ProjectParseOk _ skeleton) -> reportDuplicateImports verbosity skeleton >> pure x
+    x@OldParser.ProjectParseFailed{} -> pure x
 
-parseProjectFileSkeletonParsec :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> FilePath -> IO (Parsec.ParseResult ProjectFileSource ProjectConfigSkeleton, BS.ByteString)
-parseProjectFileSkeletonParsec verbosity httpTransport distDirLayout extensionName extensionDescription extensionFile = do
+parseProjectFileSkeletonParsec :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> ProjectFilePath -> IO (Parsec.ParseResult ProjectFileSource ProjectConfigSkeleton, BS.ByteString)
+parseProjectFileSkeletonParsec verbosity httpTransport distDirLayout extensionName extensionDescription project@(ProjectFilePath extensionFile) = do
   bs <- BS.readFile extensionFile
-  res <- Parsec.parseProject extensionFile (distDownloadSrcDirectory distDirLayout) httpTransport verbosity $ ProjectConfigToParse bs
-  return (res, bs)
+  res <- Parsec.parseProject project (distDownloadSrcDirectory distDirLayout) httpTransport verbosity $ ProjectConfigToParse bs
+  let (_, ppres) = runParseResult res
+  case ppres of
+    x@(Right skeleton) -> reportDuplicateImports verbosity skeleton >> pure (res, bs)
+    x@Left{} -> pure (res, bs)
 
 -- | Render the 'ProjectConfig' format.
 --