Add source file to project parse errors and warnings

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

@@ -30,12 +30,16 @@ import Data.Coerce (coerce)
 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 Text.PrettyPrint
 import Distribution.Simple.Utils (ordNub)
+import Distribution.System
 
 -- | 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
@@ -58,6 +62,14 @@ newtype ProjectConfigPath = ProjectConfigPath (NonEmpty FilePath)
 -- 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 +78,7 @@ instance Ord ProjectConfigPath where
             -- 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 +92,12 @@ instance Ord ProjectConfigPath where
                 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 c == '/' then '\\' else c| c <- p]
+                        else Posix.joinPath $ Posix.splitDirectories [if c == '\\' then '/' else c| c <- p]
+
             aPaths = splitPath <$> as
             bPaths = splitPath <$> bs
             aImporters = snd $ unconsProjectConfigPath pa

cabal-install/cabal-install.cabal

@@ -77,6 +77,7 @@ library
         -- this modules are moved from Cabal
         -- they are needed for as long until cabal-install moves to parsec parser
         Distribution.Deprecated.ParseUtils
+        Distribution.Deprecated.ProjectParseUtils
         Distribution.Deprecated.ReadP
         Distribution.Deprecated.ViewAsFieldDescr
 

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

@@ -33,6 +33,8 @@ import Distribution.Pretty
 import Distribution.Simple (VersionRange)
 import Distribution.Simple.Utils
 import Network.URI
+import Text.PrettyPrint hiding (render, (<>))
+import qualified Text.PrettyPrint as PP
 import Text.Regex.Posix.ByteString (WrapError)
 
 data CabalInstallException
@@ -112,7 +114,7 @@ data CabalInstallException
   | ParseExtraLinesFailedErr String String
   | ParseExtraLinesOkError [PWarning]
   | FetchPackageErr
-  | ReportParseResult String FilePath String String
+  | ReportParseResult String FilePath String Doc
   | ReportSourceRepoProblems String
   | BenchActionException
   | RenderBenchTargetProblem [String]
@@ -491,13 +493,12 @@ exceptionMessageCabalInstall e = case e of
   ParseExtraLinesOkError ws -> unlines (map (showPWarning "Error parsing additional config lines") ws)
   FetchPackageErr -> "fetchPackage: source repos not supported"
   ReportParseResult filetype filename line msg ->
-    "Error parsing "
-      ++ filetype
-      ++ " "
-      ++ filename
-      ++ line
-      ++ ":\n"
-      ++ msg
+    PP.render $
+      vcat
+        -- NOTE: As given to us, the line number string is prefixed by a colon.
+        [ text "Error parsing" <+> text filetype <+> text filename PP.<> text line PP.<> colon
+        , nest 1 $ text "-" <+> msg
+        ]
   ReportSourceRepoProblems errorStr -> errorStr
   BenchActionException ->
     "The bench command does not support '--only-dependencies'. "

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

@@ -65,8 +65,9 @@ module Distribution.Client.ProjectConfig
   , maxNumFetchJobs
   ) where
 
-import Distribution.Client.Compat.Prelude
-import Text.PrettyPrint (nest, render, text, vcat)
+import Distribution.Client.Compat.Prelude hiding (empty)
+import Distribution.Simple.Utils (ordNub)
+import Text.PrettyPrint (cat, colon, comma, empty, hsep, nest, quotes, render, text, vcat)
 import Prelude ()
 
 import Distribution.Client.Glob
@@ -135,10 +136,12 @@ import Distribution.Client.Utils
   ( determineNumJobs
   )
 import qualified Distribution.Deprecated.ParseUtils as OldParser
-  ( ParseResult (..)
-  , locatedErrorMsg
+  ( locatedErrorMsg
   , showPWarning
   )
+import qualified Distribution.Deprecated.ProjectParseUtils as OldParser
+  ( ProjectParseResult (..)
+  )
 import Distribution.Fields
   ( PError
   , PWarning
@@ -177,6 +180,7 @@ import Distribution.Simple.Utils
   , info
   , maybeExit
   , notice
+  , noticeDoc
   , rawSystemIOWithEnv
   , warn
   )
@@ -240,6 +244,7 @@ import System.IO
   , withBinaryFile
   )
 
+import Distribution.Deprecated.ProjectParseUtils (ProjectParseError (..), ProjectParseWarning)
 import Distribution.Solver.Types.ProjectConfigPath
 
 ----------------------------------------
@@ -874,16 +879,45 @@ readGlobalConfig verbosity configFileFlag = do
   monitorFiles [monitorFileHashed configFile]
   return (convertLegacyGlobalConfig config)
 
-reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult ProjectConfigSkeleton -> IO ProjectConfigSkeleton
-reportParseResult verbosity _filetype filename (OldParser.ParseOk warnings x) = do
+reportProjectParseWarnings :: Verbosity -> FilePath -> [ProjectParseWarning] -> IO ()
+reportProjectParseWarnings verbosity projectFile warnings =
   unless (null warnings) $
-    let msg = unlines (map (OldParser.showPWarning (intercalate ", " $ filename : (projectConfigPathRoot <$> projectSkeletonImports x))) warnings)
-     in warn verbosity msg
+    let msgs =
+          [ OldParser.showPWarning pFilename w
+          | (p, w) <- warnings
+          , let pFilename = fst $ unconsProjectConfigPath p
+          ]
+     in noticeDoc verbosity $
+          vcat
+            [ (text "Warnings found while parsing the project file" <> comma) <+> (text (takeFileName projectFile) <> colon)
+            , cat [nest 1 $ text "-" <+> text m | m <- ordNub msgs]
+            ]
+
+reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ProjectParseResult ProjectConfigSkeleton -> IO ProjectConfigSkeleton
+reportParseResult verbosity _filetype projectFile (OldParser.ProjectParseOk warnings x) = do
+  reportProjectParseWarnings verbosity projectFile warnings
   return x
-reportParseResult verbosity filetype filename (OldParser.ParseFailed err) =
+reportParseResult verbosity filetype projectFile (OldParser.ProjectParseFailed (ProjectParseError snippet rootOrImportee err)) = do
   let (line, msg) = OldParser.locatedErrorMsg err
-      errLineNo = maybe "" (\n -> ':' : show n) line
-   in dieWithException verbosity $ ReportParseResult filetype filename errLineNo msg
+  let errLineNo = maybe "" (\n -> ':' : show n) line
+  let (sourceFile, provenance) =
+        maybe
+          (projectFile, empty)
+          ( \p ->
+              ( fst $ unconsProjectConfigPath p
+              , if isTopLevelConfigPath p then empty else docProjectConfigPath p
+              )
+          )
+          rootOrImportee
+  let doc = case snippet of
+        Nothing -> vcat (text <$> lines msg)
+        Just s ->
+          vcat
+            [ provenance
+            , text "Failed to parse" <+> quotes (text s) <+> (text "with error" <> colon)
+            , nest 2 $ hsep $ text <$> lines msg
+            ]
+  dieWithException verbosity $ ReportParseResult filetype sourceFile errLineNo doc
 
 ---------------------------------------------
 -- Finding packages in the project

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

@@ -1,9 +1,11 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE ViewPatterns #-}
 
 -- | Project configuration, implementation in terms of legacy types.
@@ -159,6 +161,11 @@ import Distribution.Deprecated.ParseUtils
   , syntaxError
   )
 import qualified Distribution.Deprecated.ParseUtils as ParseUtils
+import Distribution.Deprecated.ProjectParseUtils
+  ( ProjectParseResult (..)
+  , projectParse
+  , projectParseFail
+  )
 import Distribution.Deprecated.ReadP
   ( ReadP
   , (+++)
@@ -183,6 +190,7 @@ import Distribution.Utils.Path hiding
   )
 
 import qualified Data.ByteString.Char8 as BS
+import Data.Functor ((<&>))
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Network.URI (URI (..), parseURI)
@@ -240,12 +248,15 @@ parseProject
   -> Verbosity
   -> ProjectConfigToParse
   -- ^ The contents of the file to parse
-  -> IO (ParseResult 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
+  -> 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
 
 parseProjectSkeleton
   :: FilePath
@@ -257,57 +268,62 @@ parseProjectSkeleton
   -- ^ The path of the file being parsed, either the root or an import
   -> ProjectConfigToParse
   -- ^ The contents of the file to parse
-  -> IO (ParseResult ProjectConfigSkeleton)
+  -> IO (ProjectParseResult ProjectConfigSkeleton)
 parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (ProjectConfigToParse bs) =
-  (sanityWalkPCS False =<<) <$> liftPR (go []) (ParseUtils.readFields bs)
+  (sanityWalkPCS False =<<) <$> liftPR source (go []) (ParseUtils.readFields bs)
   where
-    go :: [ParseUtils.Field] -> [ParseUtils.Field] -> IO (ParseResult ProjectConfigSkeleton)
+    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
+        normSource <- canonicalizeConfigPath projectDir source
         normLocPath <- canonicalizeConfigPath projectDir importLocPath
-
         debug verbosity $ "\nimport path, normalized\n=======================\n" ++ render (docProjectConfigPath normLocPath)
 
         if isCyclicConfigPath normLocPath
-          then pure . parseFail $ ParseUtils.FromString (render $ cyclicalImportMsg normLocPath) Nothing
+          then pure . projectParseFail Nothing (Just normSource) $ ParseUtils.FromString (render $ cyclicalImportMsg normLocPath) Nothing
           else do
-            normSource <- canonicalizeConfigPath projectDir source
             let fs = (\z -> CondNode z [normLocPath] mempty) <$> fieldsToConfig normSource (reverse acc)
             res <- parseProjectSkeleton cacheDir httpTransport verbosity projectDir importLocPath . ProjectConfigToParse =<< fetchImportConfig normLocPath
             rest <- go [] xs
-            pure . fmap mconcat . sequence $ [fs, res, rest]
+            pure . fmap mconcat . sequence $ [projectParse Nothing normSource fs, res, rest]
       (ParseUtils.Section l "if" p xs') -> do
+        normSource <- canonicalizeConfigPath projectDir source
         subpcs <- go [] xs'
         let fs = singletonProjectConfigSkeleton <$> fieldsToConfig source (reverse acc)
         (elseClauses, rest) <- parseElseClauses xs
         let condNode =
               (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e])
                 <$>
                 -- we rewrap as as a section so the readFields lexer of the conditional parser doesn't get confused
-                adaptParseError l (parseConditionConfVarFromClause . BS.pack $ "if(" <> p <> ")")
+                ( let s = "if(" <> p <> ")"
+                   in projectParse (Just s) normSource (adaptParseError l (parseConditionConfVarFromClause $ BS.pack s))
+                )
                 <*> subpcs
                 <*> elseClauses
-        pure . fmap mconcat . sequence $ [fs, condNode, rest]
+        pure . fmap mconcat . sequence $ [projectParse Nothing normSource fs, condNode, rest]
       _ -> go (x : acc) xs
     go acc [] = do
       normSource <- canonicalizeConfigPath projectDir source
-      pure . fmap singletonProjectConfigSkeleton . fieldsToConfig normSource $ reverse acc
+      pure . fmap singletonProjectConfigSkeleton . projectParse Nothing normSource . fieldsToConfig normSource $ reverse acc
 
-    parseElseClauses :: [ParseUtils.Field] -> IO (ParseResult (Maybe ProjectConfigSkeleton), ParseResult ProjectConfigSkeleton)
+    parseElseClauses :: [ParseUtils.Field] -> IO (ProjectParseResult (Maybe ProjectConfigSkeleton), ProjectParseResult ProjectConfigSkeleton)
     parseElseClauses x = case x of
       (ParseUtils.Section _l "else" _p xs' : xs) -> do
         subpcs <- go [] xs'
         rest <- go [] xs
         pure (Just <$> subpcs, rest)
       (ParseUtils.Section l "elif" p xs' : xs) -> do
+        normSource <- canonicalizeConfigPath projectDir source
         subpcs <- go [] xs'
         (elseClauses, rest) <- parseElseClauses xs
         let condNode =
               (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e])
-                <$> adaptParseError l (parseConditionConfVarFromClause . BS.pack $ "else(" <> p <> ")")
+                <$> ( let s = "elif(" <> p <> ")"
+                       in projectParse (Just s) normSource (adaptParseError l (parseConditionConfVarFromClause $ BS.pack s))
+                    )
                 <*> subpcs
                 <*> elseClauses
         pure (Just <$> condNode, rest)
@@ -326,15 +342,16 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
     addProvenance :: ProjectConfigPath -> ProjectConfig -> ProjectConfig
     addProvenance sourcePath x = x{projectConfigProvenance = Set.singleton $ Explicit sourcePath}
 
+    adaptParseError :: Show e => ParseUtils.LineNo -> Either e a -> ParseResult a
     adaptParseError _ (Right x) = pure x
     adaptParseError l (Left e) = parseFail $ ParseUtils.FromString (show e) (Just l)
 
-    liftPR :: (a -> IO (ParseResult b)) -> ParseResult a -> IO (ParseResult b)
-    liftPR f (ParseOk ws x) = addWarnings <$> f x
+    liftPR :: ProjectConfigPath -> (a -> IO (ProjectParseResult b)) -> ParseResult a -> IO (ProjectParseResult b)
+    liftPR p f (ParseOk ws x) = addWarnings <$> f x
       where
-        addWarnings (ParseOk ws' x') = ParseOk (ws' ++ ws) x'
+        addWarnings (ProjectParseOk ws' x') = ProjectParseOk (ws' ++ ((p,) <$> ws)) x'
         addWarnings x' = x'
-    liftPR _ (ParseFailed e) = pure $ ParseFailed e
+    liftPR p _ (ParseFailed e) = pure $ projectParseFail Nothing (Just p) e
 
     fetchImportConfig :: ProjectConfigPath -> IO BS.ByteString
     fetchImportConfig (ProjectConfigPath (pci :| _)) = do
@@ -357,12 +374,14 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
       where
         isSet f = f (projectConfigShared pc) /= NoFlag
 
-    sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ParseResult ProjectConfigSkeleton
-    sanityWalkPCS underConditional t@(CondNode d _c comps)
-      | underConditional && modifiesCompiler d = parseFail $ ParseUtils.FromString "Cannot set compiler in a conditional clause of a cabal project file" Nothing
-      | otherwise = mapM_ sanityWalkBranch comps >> pure t
+    sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ProjectParseResult ProjectConfigSkeleton
+    sanityWalkPCS underConditional t@(CondNode d (listToMaybe -> c) comps)
+      | underConditional && modifiesCompiler d =
+          projectParseFail Nothing c $ ParseUtils.FromString "Cannot set compiler in a conditional clause of a cabal project file" Nothing
+      | otherwise =
+          mapM_ sanityWalkBranch comps >> pure t
 
-    sanityWalkBranch :: CondBranch ConfVar [ProjectConfigPath] ProjectConfig -> ParseResult ()
+    sanityWalkBranch :: CondBranch ConfVar [ProjectConfigPath] ProjectConfig -> ProjectParseResult ()
     sanityWalkBranch (CondBranch _c t f) = traverse_ (sanityWalkPCS True) f >> sanityWalkPCS True t >> pure ()
 
 ------------------------------------------------------------------