diff --git a/Cabal/Distribution/FieldGrammar/Parsec.hs b/Cabal/Distribution/FieldGrammar/Parsec.hs
index 13231f5d33baebdcd6db18828bb1391981a7a170..916403f0741c6aa6c80c80f540ebeb8c6ac2b1f5 100644
--- a/Cabal/Distribution/FieldGrammar/Parsec.hs
+++ b/Cabal/Distribution/FieldGrammar/Parsec.hs
@@ -262,31 +262,33 @@ instance FieldGrammar ParsecFieldGrammar where
-- Parsec
-------------------------------------------------------------------------------
-runFieldParser' :: Position -> ParsecParser a -> CabalSpecVersion -> FieldLineStream -> ParseResult a
-runFieldParser' (Position row col) p v str = case P.runParser p' [] "<field>" str of
+runFieldParser' :: [Position] -> ParsecParser a -> CabalSpecVersion -> FieldLineStream -> ParseResult a
+runFieldParser' inputPoss p v str = case P.runParser p' [] "<field>" str of
Right (pok, ws) -> do
- -- TODO: map pos
- traverse_ (\(PWarning t pos w) -> parseWarning pos t w) ws
+ traverse_ (\(PWarning t pos w) -> parseWarning (mapPosition pos) t w) ws
pure pok
Left err -> do
let ppos = P.errorPos err
- -- Positions start from 1:1, not 0:0
- let epos = Position (row - 1 + P.sourceLine ppos) (col - 1 + P.sourceColumn ppos)
+ let epos = mapPosition $ Position (P.sourceLine ppos) (P.sourceColumn ppos)
+
let msg = P.showErrorMessages
"or" "unknown parse error" "expecting" "unexpected" "end of input"
(P.errorMessages err)
parseFatalFailure epos $ msg ++ "\n"
-
where
p' = (,) <$ P.spaces <*> unPP p v <* P.spaces <* P.eof <*> P.getState
+ -- Positions start from 1:1, not 0:0
+ mapPosition (Position prow pcol) = go (prow - 1) inputPoss where
+ go _ [] = zeroPos
+ go _ [Position row col] = Position row (col + pcol - 1)
+ go n (Position row col:_) | n <= 0 = Position row (col + pcol - 1)
+ go n (_:ps) = go (n - 1) ps
+
runFieldParser :: Position -> ParsecParser a -> CabalSpecVersion -> [FieldLine Position] -> ParseResult a
-runFieldParser pp p v ls = runFieldParser' pos p v (fieldLinesToStream ls)
+runFieldParser pp p v ls = runFieldParser' poss p v (fieldLinesToStream ls)
where
- -- TODO: make per line lookup
- pos = case ls of
- [] -> pp
- (FieldLine pos' _ : _) -> pos'
+ poss = map (\(FieldLine pos _) -> pos) ls ++ [pp] -- add "default" position
fieldlinesToBS :: [FieldLine ann] -> BS.ByteString
fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs)
diff --git a/Cabal/Distribution/PackageDescription/Parsec.hs b/Cabal/Distribution/PackageDescription/Parsec.hs
index 3ea4f7975e2dc2e3caaccc5ced8fb49c08f49eed..a3387eb9e5fea1ecef4e23271a9c83af6b10ba6c 100644
--- a/Cabal/Distribution/PackageDescription/Parsec.hs
+++ b/Cabal/Distribution/PackageDescription/Parsec.hs
@@ -343,7 +343,7 @@ goSections specVer = traverse_ process
| name == "flag" = do
name' <- parseNameBS pos args
- name'' <- lift $ runFieldParser' pos parsec specVer (fieldLineStreamFromBS name') `recoverWith` mkFlagName ""
+ name'' <- lift $ runFieldParser' [pos] parsec specVer (fieldLineStreamFromBS name') `recoverWith` mkFlagName ""
flag <- lift $ parseFields specVer fields (flagFieldGrammar name'')
-- Check default flag
stateGpd . L.genPackageFlags %= snoc flag
@@ -355,7 +355,7 @@ goSections specVer = traverse_ process
| name == "source-repository" = do
kind <- lift $ case args of
[SecArgName spos secName] ->
- runFieldParser' spos parsec specVer (fieldLineStreamFromBS secName) `recoverWith` RepoHead
+ runFieldParser' [spos] parsec specVer (fieldLineStreamFromBS secName) `recoverWith` RepoHead
[] -> do
parseFailure pos "'source-repository' requires exactly one argument"
pure RepoHead
diff --git a/Cabal/Distribution/Parsec/Class.hs b/Cabal/Distribution/Parsec/Class.hs
index d65ea54eeccdee3e6271edd9da7e4e6771f675b0..b08658c8d09d94115ba0e1a17e860fe46fb4155c 100644
--- a/Cabal/Distribution/Parsec/Class.hs
+++ b/Cabal/Distribution/Parsec/Class.hs
@@ -142,7 +142,10 @@ instance P.CharParsing ParsecParser where
string = liftParsec . P.string
instance CabalParsing ParsecParser where
- parsecWarning t w = liftParsec $ Parsec.modifyState (PWarning t (Position 0 0) w :)
+ parsecWarning t w = liftParsec $ do
+ spos <- Parsec.getPosition
+ Parsec.modifyState
+ (PWarning t (Position (Parsec.sourceLine spos) (Parsec.sourceColumn spos)) w :)
askCabalSpecVersion = PP pure
-- | Parse a 'String' with 'lexemeParsec'.
diff --git a/Cabal/tests/ParserTests/regressions/MiniAgda.check b/Cabal/tests/ParserTests/regressions/MiniAgda.check
index b482da3202e152d019eaa314640f27e9051a7691..37b642163e1494d99c8060216dc25d45a41a7219 100644
--- a/Cabal/tests/ParserTests/regressions/MiniAgda.check
+++ b/Cabal/tests/ParserTests/regressions/MiniAgda.check
@@ -1 +1 @@
-MiniAgda.cabal:0:0: Version digit with leading zero. Use cabal-version: 2.0 or later to write such versions. For more information see https://github.com/haskell/cabal/issues/5092
+MiniAgda.cabal:2:27: Version digit with leading zero. Use cabal-version: 2.0 or later to write such versions. For more information see https://github.com/haskell/cabal/issues/5092
diff --git a/cabal-install/Distribution/Client/Utils/Parsec.hs b/cabal-install/Distribution/Client/Utils/Parsec.hs
index 8d866d328397d77838a40338839dd6c8ea78e52a..13851efe6c4c9d1711c80042ac891d45d6d1efb3 100644
--- a/cabal-install/Distribution/Client/Utils/Parsec.hs
+++ b/cabal-install/Distribution/Client/Utils/Parsec.hs
@@ -25,41 +25,75 @@ renderParseError filepath contents errors warnings = unlines $
++ renderedErrors
++ renderedWarnings
where
- -- lines of the input file.
- ls = BS8.lines contents
+ -- lines of the input file. 'lines' is taken, so they are called rows
+ -- contents, line number, whether it's empty line
+ rows :: [(String, Int, Bool)]
+ rows = zipWith f (BS8.lines contents) [1..] where
+ f bs i = let s = fromUTF8BS bs in (s, i, isEmptyOrComment s)
- nths :: Int -> [a] -> [a]
- nths n | n <= 0 = take 2
- nths n = take 3 . drop (n - 1)
+ rowsZipper = listToZipper rows
- -- empty line before each error and warning
- renderedErrors = concatMap (prepend . renderError) errors
- renderedWarnings = concatMap (prepend . renderWarning) warnings
+ isEmptyOrComment :: String -> Bool
+ isEmptyOrComment s = case dropWhile (== ' ') s of
+ "" -> True -- empty
+ ('-':'-':_) -> True -- comment
+ _ -> False
- prepend = ("" :)
+ -- empty line before each error and warning
+ renderedErrors = concatMap (("" :) . renderError) errors
+ renderedWarnings = concatMap (("" :) . renderWarning) warnings
renderError :: PError -> [String]
- renderError e@(PError pos@(Position row _col) _)
+ renderError e@(PError pos@(Position row col) _)
-- if position is 0:0, then it doesn't make sense to show input
-- looks like, Parsec errors have line-feed in them
- | pos == zeroPos = [trim $ showPError filepath e]
- | otherwise = [trim $ showPError filepath e, ""] ++
- zipWith formatInputLine (nths (row - 1) ls) [row - 1 ..]
+ | pos == zeroPos = [trimLF $ showPError filepath e]
+ | otherwise = [trimLF $ showPError filepath e, ""] ++
+ formatInput row col
-- sometimes there are (especially trailing) newlines.
- trim = dropWhile (== '\n') . reverse . dropWhile (== '\n') . reverse
+ trimLF :: String -> String
+ trimLF = dropWhile (== '\n') . reverse . dropWhile (== '\n') . reverse
renderWarning :: PWarning -> [String]
- renderWarning w@(PWarning _ pos@(Position row _col) _)
+ renderWarning w@(PWarning _ pos@(Position row col) _)
| pos == zeroPos = [showPWarning filepath w]
| otherwise = [showPWarning filepath w, ""] ++
- zipWith formatInputLine (nths (row - 1) ls) [row - 1 ..]
+ formatInput row col
-- format line: prepend the given line number
- formatInputLine :: BS.ByteString -> Int -> String
- formatInputLine bs l =
- showN l ++ " | " ++ fromUTF8BS bs
+ formatInput :: Int -> Int -> [String]
+ formatInput row col = case advance (row - 1) rowsZipper of
+ Zipper xs ys -> before ++ after where
+ before = case span (\(_, _, b) -> b) xs of
+ (_, []) -> []
+ (zs, z : _) -> map formatInputLine $ z : reverse zs
+
+ after = case ys of
+ [] -> []
+ (z : _zs) ->
+ [ formatInputLine z -- error line
+ , " | " ++ replicate (col - 1) ' ' ++ "^" -- pointer: ^
+ ]
+ -- do we need rows after?
+ -- ++ map formatInputLine (take 1 zs) -- one row after
+
+ formatInputLine :: (String, Int, Bool) -> String
+ formatInputLine (str, row, _) = leftPadShow row ++ " | " ++ str
-- hopefully we don't need to work with over 99999 lines .cabal files
-- at that point small glitches in error messages are hopefully fine.
- showN n = let s = show n in replicate (5 - length s) ' ' ++ s
+ leftPadShow :: Int -> String
+ leftPadShow n = let s = show n in replicate (5 - length s) ' ' ++ s
+
+data Zipper a = Zipper [a] [a]
+
+listToZipper :: [a] -> Zipper a
+listToZipper = Zipper []
+
+advance :: Int -> Zipper a -> Zipper a
+advance n z@(Zipper xs ys)
+ | n <= 0 = z
+ | otherwise = case ys of
+ [] -> z
+ (y:ys') -> advance (n - 1) $ Zipper (y:xs) ys'