-- |
-- 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 (Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
renderError (PanicCannotParseInput ParseError
err) = Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"panic! " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParseError -> String
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 (String -> IO ()) -> String -> IO ()
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"error (-Werror): " String -> ShowS
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 ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    [ String
"Errors encountered when parsing cabal file " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
filepath String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":"
    ]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
renderedErrors
    [String] -> [String] -> [String]
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 = (ByteString -> Int -> (String, Int, Bool))
-> [ByteString] -> [Int] -> [(String, Int, Bool)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ByteString -> Int -> (String, Int, Bool)
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 = [(String, Int, Bool)] -> Zipper (String, Int, Bool)
forall a. [a] -> Zipper a
listToZipper [(String, Int, Bool)]
rows

    isEmptyOrComment :: String -> Bool
    isEmptyOrComment :: String -> Bool
isEmptyOrComment String
s = case (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
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   = (PError -> [String]) -> NonEmpty PError -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PError -> [String]
renderError' NonEmpty PError
errors
    renderedWarnings :: [String]
renderedWarnings = (PWarning -> [String]) -> [PWarning] -> [String]
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 Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
C.zeroPos = [String]
msgs
        | Bool
otherwise        = [String]
msgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Int -> Int -> [String]
formatInput Int
row Int
col
      where
        msgs :: [String]
msgs = [ String
"", String
filepath' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Position -> String
C.showPos Position
pos String -> ShowS
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 Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
C.zeroPos = [String]
msgs
        | Bool
otherwise        = [String]
msgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Int -> Int -> [String]
formatInput Int
row Int
col
      where
        msgs :: [String]
msgs = [ String
"", String
filepath' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Position -> String
C.showPos Position
pos String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": warning:", ShowS
trimLF String
msg, String
"" ]

    -- sometimes there are (especially trailing) newlines.
    trimLF :: String -> String
    trimLF :: ShowS
trimLF = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
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 Int -> Zipper (String, Int, Bool) -> Zipper (String, Int, Bool)
forall a. Int -> Zipper a -> Zipper a
advance (Int
row Int -> Int -> Int
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 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
after where
            before :: [String]
before = case ((String, Int, Bool) -> Bool)
-> [(String, Int, Bool)]
-> ([(String, Int, Bool)], [(String, Int, Bool)])
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)]
_) -> ((String, Int, Bool) -> String)
-> [(String, Int, Bool)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Int, Bool) -> String
formatInputLine ([(String, Int, Bool)] -> [String])
-> [(String, Int, Bool)] -> [String]
forall a b. (a -> b) -> a -> b
$ (String, Int, Bool)
z (String, Int, Bool)
-> [(String, Int, Bool)] -> [(String, Int, Bool)]
forall a. a -> [a] -> [a]
: [(String, Int, Bool)] -> [(String, Int, Bool)]
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
"      | " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
' ' String -> ShowS
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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" | " String -> ShowS
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 = Int -> String
forall a. Show a => a -> String
show Int
n in Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

data Zipper a = Zipper [a] [a]

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

advance :: Int -> Zipper a -> Zipper a
advance :: Int -> Zipper a -> Zipper a
advance Int
n z :: Zipper a
z@(Zipper [a]
xs [a]
ys)
    | Int
n Int -> Int -> Bool
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') -> Int -> Zipper a -> Zipper a
forall a. Int -> Zipper a -> Zipper a
advance (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Zipper a -> Zipper a) -> Zipper a -> Zipper a
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> Zipper a
forall a. [a] -> [a] -> Zipper a
Zipper (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) [a]
ys'