-- |
-- 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.Types.Version as C
import qualified Distribution.Utils.Generic as C (fromUTF8BS)

data Error
    = SomeError String
    | CabalParseError FilePath BS.ByteString (NonEmpty C.PError) (Maybe C.Version) [C.PWarning]
    | PanicCannotParseInput  ParseError
    | WarningError String
  deriving (Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)

instance Exception Error

renderError :: Error -> IO ()
renderError :: Error -> IO ()
renderError (SomeError String
err) = Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"error: " forall a. [a] -> [a] -> [a]
++ String
err
renderError (PanicCannotParseInput ParseError
err) = Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"panic! " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParseError
err
renderError (CabalParseError String
filepath ByteString
contents NonEmpty PError
errors Maybe Version
_ [PWarning]
warnings) =
    Handle -> String -> IO ()
hPutStr Handle
stderr forall a b. (a -> b) -> a -> b
$ String -> ByteString -> NonEmpty PError -> [PWarning] -> String
renderParseError String
filepath ByteString
contents NonEmpty PError
errors [PWarning]
warnings
renderError (WarningError String
w) = Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"error (-Werror): " forall a. [a] -> [a] -> [a]
++ String
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 :: String -> ByteString -> NonEmpty PError -> [PWarning] -> String
renderParseError String
filepath ByteString
contents NonEmpty PError
errors [PWarning]
warnings = [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
    [ String
"Errors encountered when parsing cabal file " forall a. Semigroup a => a -> a -> a
<> String
filepath forall a. Semigroup a => a -> a -> a
<> String
":"
    ]
    forall a. [a] -> [a] -> [a]
++ [String]
renderedErrors
    forall a. [a] -> [a] -> [a]
++ [String]
renderedWarnings
  where
    filepath' :: String
filepath' = ShowS
normalise String
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 :: [(String, Int, Bool)]
rows = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {b}. ByteString -> b -> (String, b, Bool)
f (ByteString -> [ByteString]
BS8.lines ByteString
contents) [Int
1..] where
        f :: ByteString -> b -> (String, b, Bool)
f ByteString
bs b
i = let s :: String
s = ByteString -> String
C.fromUTF8BS ByteString
bs in (String
s, b
i, String -> Bool
isEmptyOrComment String
s)

    rowsZipper :: Zipper (String, Int, Bool)
rowsZipper = forall a. [a] -> Zipper a
listToZipper [(String, Int, Bool)]
rows

    isEmptyOrComment :: String -> Bool
    isEmptyOrComment :: String -> Bool
isEmptyOrComment String
s = case forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
' ') String
s of
        String
""          -> Bool
True   -- empty
        (Char
'-':Char
'-':String
_) -> Bool
True   -- comment
        String
_           -> Bool
False

    renderedErrors :: [String]
renderedErrors   = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PError -> [String]
renderError' NonEmpty PError
errors
    renderedWarnings :: [String]
renderedWarnings = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PWarning -> [String]
renderWarning [PWarning]
warnings

    renderError' :: C.PError -> [String]
    renderError' :: PError -> [String]
renderError' (C.PError pos :: Position
pos@(C.Position Int
row Int
col) String
msg)
        -- if position is 0:0, then it doesn't make sense to show input
        -- looks like, Parsec errors have line-feed in them
        | Position
pos forall a. Eq a => a -> a -> Bool
== Position
C.zeroPos = [String]
msgs
        | Bool
otherwise        = [String]
msgs forall a. [a] -> [a] -> [a]
++ Int -> Int -> [String]
formatInput Int
row Int
col
      where
        msgs :: [String]
msgs = [ String
"", String
filepath' forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ Position -> String
C.showPos Position
pos forall a. [a] -> [a] -> [a]
++ String
": error:", ShowS
trimLF String
msg, String
"" ]

    renderWarning :: C.PWarning -> [String]
    renderWarning :: PWarning -> [String]
renderWarning (C.PWarning PWarnType
_ pos :: Position
pos@(C.Position Int
row Int
col) String
msg)
        | Position
pos forall a. Eq a => a -> a -> Bool
== Position
C.zeroPos = [String]
msgs
        | Bool
otherwise        = [String]
msgs forall a. [a] -> [a] -> [a]
++ Int -> Int -> [String]
formatInput Int
row Int
col
      where
        msgs :: [String]
msgs = [ String
"", String
filepath' forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ Position -> String
C.showPos Position
pos forall a. [a] -> [a] -> [a]
++ String
": warning:", ShowS
trimLF String
msg, String
"" ]

    -- sometimes there are (especially trailing) newlines.
    trimLF :: String -> String
    trimLF :: ShowS
trimLF = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'\n') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'\n') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

    -- format line: prepend the given line number
    formatInput :: Int -> Int -> [String]
    formatInput :: Int -> Int -> [String]
formatInput Int
row Int
col = case forall a. Int -> Zipper a -> Zipper a
advance (Int
row forall a. Num a => a -> a -> a
- Int
1) Zipper (String, Int, Bool)
rowsZipper of
        Zipper [(String, Int, Bool)]
xs [(String, Int, Bool)]
ys -> [String]
before forall a. [a] -> [a] -> [a]
++ [String]
after where
            before :: [String]
before = case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\(String
_, Int
_, Bool
b) -> Bool
b) [(String, Int, Bool)]
xs of
                ([(String, Int, Bool)]
_, [])     -> []
                ([(String, Int, Bool)]
zs, (String, Int, Bool)
z : [(String, Int, Bool)]
_) -> forall a b. (a -> b) -> [a] -> [b]
map (String, Int, Bool) -> String
formatInputLine forall a b. (a -> b) -> a -> b
$ (String, Int, Bool)
z forall a. a -> [a] -> [a]
: forall a. [a] -> [a]
reverse [(String, Int, Bool)]
zs

            after :: [String]
after  = case [(String, Int, Bool)]
ys of
                []        -> []
                ((String, Int, Bool)
z : [(String, Int, Bool)]
_zs) ->
                    [ (String, Int, Bool) -> String
formatInputLine (String, Int, Bool)
z                             -- error line
                    , String
"      | " forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
col forall a. Num a => a -> a -> a
- Int
1) Char
' ' forall a. [a] -> [a] -> [a]
++ String
"^"  -- pointer: ^
                    ]
                    -- do we need rows after?
                    -- ++ map formatInputLine (take 1 zs)           -- one row after

    formatInputLine :: (String, Int, Bool) -> String
    formatInputLine :: (String, Int, Bool) -> String
formatInputLine (String
str, Int
row, Bool
_) = Int -> String
leftPadShow Int
row forall a. [a] -> [a] -> [a]
++ String
" | " forall a. [a] -> [a] -> [a]
++ String
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 :: Int -> String
leftPadShow Int
n = let s :: String
s = forall a. Show a => a -> String
show Int
n in forall a. Int -> a -> [a]
replicate (Int
5 forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
' ' forall a. [a] -> [a] -> [a]
++ String
s

data Zipper a = Zipper [a] [a]

listToZipper :: [a] -> Zipper a
listToZipper :: forall a. [a] -> Zipper a
listToZipper = forall a. [a] -> [a] -> Zipper a
Zipper []

advance :: Int -> Zipper a -> Zipper a
advance :: forall a. Int -> Zipper a -> Zipper a
advance Int
n z :: Zipper a
z@(Zipper [a]
xs [a]
ys)
    | Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 = Zipper a
z
    | Bool
otherwise = case [a]
ys of
        []      -> Zipper a
z
        (a
y:[a]
ys') -> forall a. Int -> Zipper a -> Zipper a
advance (Int
n forall a. Num a => a -> a -> a
- Int
1) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a] -> Zipper a
Zipper (a
yforall a. a -> [a] -> [a]
:[a]
xs) [a]
ys'