Error.hs

-- |
-- 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'