-- | -- License: GPL-3.0-or-later -- Copyright: Oleg Grenrus module CabalGild.Error (Error (..), renderError) where import Control.Exception (Exception) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Data.List.NonEmpty (NonEmpty) import qualified Distribution.Parsec as C import qualified Distribution.Types.Version as C import qualified Distribution.Utils.Generic as C (fromUTF8BS) import System.FilePath (normalise) import System.IO (hPutStr, hPutStrLn, stderr) import Text.Parsec.Error (ParseError) data Error = SomeError String | CabalParseError FilePath BS.ByteString (NonEmpty C.PError) (Maybe C.Version) [C.PWarning] | PanicCannotParseInput ParseError | WarningError String deriving (Show) instance Exception Error renderError :: Error -> IO () renderError (SomeError err) = hPutStrLn stderr $ "error: " ++ err renderError (PanicCannotParseInput err) = hPutStrLn stderr $ "panic! " ++ show err renderError (CabalParseError filepath contents errors _ warnings) = hPutStr stderr $ renderParseError filepath contents errors warnings renderError (WarningError w) = hPutStrLn stderr $ "error (-Werror): " ++ w ------------------------------------------------------------------------------- -- Rendering of Cabal parser error ------------------------------------------------------------------------------- -- | Render parse error highlighting the part of the input file. renderParseError :: FilePath -> BS.ByteString -> NonEmpty C.PError -> [C.PWarning] -> String renderParseError filepath contents errors warnings = unlines $ [ "Errors encountered when parsing cabal file " <> filepath <> ":" ] ++ renderedErrors ++ renderedWarnings where filepath' = normalise filepath -- 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 :: BS8.ByteString -> b -> (String, b, Bool) f bs i = let s = C.fromUTF8BS bs in (s, i, isEmptyOrComment s) rowsZipper = listToZipper rows isEmptyOrComment :: String -> Bool isEmptyOrComment s = case dropWhile (== ' ') s of "" -> True -- empty ('-' : '-' : _) -> True -- comment _ -> False renderedErrors = concatMap renderError' errors renderedWarnings = concatMap renderWarning warnings renderError' :: C.PError -> [String] renderError' (C.PError pos@(C.Position row col) msg) -- if position is 0:0, then it doesn't make sense to show input -- looks like, Parsec errors have line-feed in them | pos == C.zeroPos = msgs | otherwise = msgs ++ formatInput row col where msgs = ["", filepath' ++ ":" ++ C.showPos pos ++ ": error:", trimLF msg, ""] renderWarning :: C.PWarning -> [String] renderWarning (C.PWarning _ pos@(C.Position row col) msg) | pos == C.zeroPos = msgs | otherwise = msgs ++ formatInput row col where msgs = ["", filepath' ++ ":" ++ C.showPos pos ++ ": warning:", trimLF msg, ""] -- sometimes there are (especially trailing) newlines. trimLF :: String -> String trimLF = dropWhile (== '\n') . reverse . dropWhile (== '\n') . reverse -- format line: prepend the given line number 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. 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'