Duplicate project import as a warning only

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

@@ -14,6 +14,7 @@ module Distribution.Solver.Types.ProjectConfigPath
     , docProjectConfigPath
     , docProjectConfigFiles
     , cyclicalImportMsg
+    , duplicateImportMsg
     , untrimmedUriImportMsg
     , docProjectConfigPathFailReason
 
@@ -174,9 +175,24 @@ docProjectConfigFiles ps = vcat
 -- | A message for a cyclical import, a "cyclical import of".
 cyclicalImportMsg :: ProjectConfigPath -> Doc
 cyclicalImportMsg path@(ProjectConfigPath (duplicate :| _)) =
+    seenImportMsg (text "cyclical import of" <+> text duplicate <> semi) duplicate path []
+
+-- | A message for a duplicate import, a "duplicate import of". If a check for
+-- cyclical imports has already been made then this would report a duplicate
+-- import by two different paths.
+duplicateImportMsg :: Doc -> FilePath -> ProjectConfigPath -> [(FilePath, ProjectConfigPath)] -> Doc
+duplicateImportMsg intro = seenImportMsg intro
+
+seenImportMsg :: Doc -> FilePath -> ProjectConfigPath -> [(FilePath, ProjectConfigPath)] -> Doc
+seenImportMsg intro duplicate path seenImportsBy =
     vcat
-    [ text "cyclical import of" <+> text duplicate <> semi
+    [ intro
     , nest 2 (docProjectConfigPath path)
+    , nest 2 $
+        vcat
+        [ docProjectConfigPath dib
+        | (_, dib) <- filter ((duplicate ==) . fst) seenImportsBy
+        ]
     ]
 
 -- | A message for an import that has leading or trailing spaces.

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

@@ -1,7 +1,6 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -35,6 +34,7 @@ module Distribution.Client.ProjectConfig.Legacy
   ) where
 
 import Data.Coerce (coerce)
+import Data.IORef
 import Distribution.Client.Compat.Prelude
 
 import Distribution.Types.Flag (FlagName, parsecFlagAssignment)
@@ -142,7 +142,8 @@ import Distribution.Types.CondTree
   )
 import Distribution.Types.SourceRepo (RepoType)
 import Distribution.Utils.NubList
-  ( fromNubList
+  ( NubList
+  , fromNubList
   , overNubList
   , toNubList
   )
@@ -194,7 +195,7 @@ import Distribution.Utils.Path hiding
   )
 
 import qualified Data.ByteString.Char8 as BS
-import Data.Functor ((<&>))
+import Data.List (sortOn)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Network.URI (URI (..), nullURIAuth, parseURI)
@@ -203,9 +204,12 @@ import System.FilePath (isAbsolute, isPathSeparator, makeValid, splitFileName, (
 import Text.PrettyPrint
   ( Doc
   , render
+  , semi
+  , text
+  , vcat
   , ($+$)
   )
-import qualified Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp (empty, int, render, text)
 
 ------------------------------------------------------------------
 -- Handle extended project config files with conditionals and imports.
@@ -256,38 +260,66 @@ parseProject
   -> ProjectConfigToParse
   -- ^ The contents of the file to parse
   -> IO (ProjectParseResult ProjectConfigSkeleton)
-parseProject rootPath cacheDir httpTransport verbosity configToParse =
-  do
-    let (dir, projectFileName) = splitFileName rootPath
-    projectDir <- makeAbsolute dir
-    projectPath <- canonicalizeConfigPath projectDir (ProjectConfigPath $ projectFileName :| [])
-    parseProjectSkeleton cacheDir httpTransport verbosity projectDir projectPath configToParse
-    -- NOTE: Reverse the warnings so they are in line number order.
-    <&> \case ProjectParseOk ws x -> ProjectParseOk (reverse ws) x; x -> x
+parseProject rootPath cacheDir httpTransport verbosity configToParse = do
+  let (dir, projectFileName) = splitFileName rootPath
+  projectDir <- makeAbsolute dir
+  projectPath@(ProjectConfigPath (canonicalRoot :| _)) <- canonicalizeConfigPath projectDir (ProjectConfigPath $ projectFileName :| [])
+  importsBy <- newIORef $ toNubList [(canonicalRoot, projectPath)]
+  dupesMap <- newIORef mempty
+  result <- parseProjectSkeleton cacheDir httpTransport verbosity importsBy dupesMap projectDir projectPath configToParse
+  dupes <- Map.filter ((> 1) . length) <$> readIORef dupesMap
+  unless (Map.null dupes) (noticeDoc verbosity $ vcat (dupesMsg <$> Map.toList dupes))
+  return result
+
+data Dupes = Dupes
+  { dupesUniqueImport :: FilePath
+  , dupesNormLocPath :: ProjectConfigPath
+  , dupesSeenImportsBy :: [(FilePath, ProjectConfigPath)]
+  }
+  deriving (Eq)
+
+instance Ord Dupes where
+  compare = compare `on` length . dupesSeenImportsBy
+
+type DupesMap = Map FilePath [Dupes]
+
+dupesMsg :: (FilePath, [Dupes]) -> Doc
+dupesMsg (duplicate, ds@(take 1 . sortOn dupesNormLocPath -> dupes)) =
+  vcat $
+    ((text "Warning:" <+> Disp.int (length ds) <+> text "imports of" <+> text duplicate) <> semi)
+      : ((\Dupes{..} -> duplicateImportMsg Disp.empty dupesUniqueImport dupesNormLocPath dupesSeenImportsBy) <$> dupes)
 
 parseProjectSkeleton
   :: FilePath
   -> HttpTransport
   -> Verbosity
+  -> IORef (NubList (FilePath, ProjectConfigPath))
+  -- ^ The imports seen so far, used to report on cycles and duplicates and to detect duplicates that are not cycles
+  -> IORef DupesMap
+  -- ^ The duplicates seen so far, used to defer reporting on duplicates
   -> FilePath
   -- ^ The directory of the project configuration, typically the directory of cabal.project
   -> ProjectConfigPath
   -- ^ The path of the file being parsed, either the root or an import
   -> ProjectConfigToParse
   -- ^ The contents of the file to parse
   -> IO (ProjectParseResult ProjectConfigSkeleton)
-parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (ProjectConfigToParse bs) =
+parseProjectSkeleton cacheDir httpTransport verbosity importsBy dupesMap projectDir source (ProjectConfigToParse bs) =
   (sanityWalkPCS False =<<) <$> liftPR source (go []) (ParseUtils.readFields bs)
   where
     go :: [ParseUtils.Field] -> [ParseUtils.Field] -> IO (ProjectParseResult ProjectConfigSkeleton)
     go acc (x : xs) = case x of
       (ParseUtils.F _ "import" importLoc) -> do
         let importLocPath = importLoc `consProjectConfigPath` source
 
-        -- Once we canonicalize the import path, we can check for cyclical imports
+        -- Once we canonicalize the import path, we can check for cyclical and duplicate imports
         normSource <- canonicalizeConfigPath projectDir source
-        normLocPath <- canonicalizeConfigPath projectDir importLocPath
+        normLocPath@(ProjectConfigPath (uniqueImport :| _)) <- canonicalizeConfigPath projectDir importLocPath
+        seenImportsBy@(fmap fst -> seenImports) <- fromNubList <$> atomicModifyIORef' importsBy (\ibs -> (toNubList [(uniqueImport, normLocPath)] <> ibs, ibs))
         debug verbosity $ "\nimport path, normalized\n=======================\n" ++ render (docProjectConfigPath normLocPath)
+        debug verbosity "\nseen unique paths\n================="
+        mapM_ (debug verbosity) seenImports
+        debug verbosity "\n"
 
         if isCyclicConfigPath normLocPath
           then pure . projectParseFail Nothing (Just normSource) $ ParseUtils.FromString (render $ cyclicalImportMsg normLocPath) Nothing
@@ -296,8 +328,10 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
               (isUntrimmedUriConfigPath importLocPath)
               (noticeDoc verbosity $ untrimmedUriImportMsg (Disp.text "Warning:") importLocPath)
             let fs = (\z -> CondNode z [normLocPath] mempty) <$> fieldsToConfig normSource (reverse acc)
-            res <- parseProjectSkeleton cacheDir httpTransport verbosity projectDir importLocPath . ProjectConfigToParse =<< fetchImportConfig normLocPath
-            rest <- go [] xs
+            let uniqueFields = if uniqueImport `elem` seenImports then [] else xs
+            atomicModifyIORef' dupesMap $ \dm -> (Map.insertWith (++) uniqueImport [Dupes uniqueImport normLocPath seenImportsBy] dm, ())
+            res <- parseProjectSkeleton cacheDir httpTransport verbosity importsBy dupesMap projectDir importLocPath . ProjectConfigToParse =<< fetchImportConfig normLocPath
+            rest <- go [] uniqueFields
             pure . fmap mconcat . sequence $ [projectParse Nothing normSource fs, res, rest]
       (ParseUtils.Section l "if" p xs') -> do
         normSource <- canonicalizeConfigPath projectDir source