-- |
-- License: GPL-3.0-or-later
-- Copyright: Oleg Grenrus
module CabalFmt.Error (Error (..), renderError) where

import Control.Exception  (Exception)
import Data.List.NonEmpty (NonEmpty)
import System.FilePath    (normalise)
import System.IO          (hPutStr, hPutStrLn, stderr)
import Text.Parsec.Error  (ParseError)

import qualified Data.ByteString            as BS
import qualified Data.ByteString.Char8      as BS8
import qualified Distribution.Parsec        as C
import qualified Distribution.Simple.Utils  as C (fromUTF8BS)
import qualified Distribution.Types.Version as C

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