-- | License: GPL-3.0-or-later AND BSD-3-Clause
--
-- @.cabal@ and a like file parsing helpers.
module Cabal.Parse (
    parseWith,
    ParseError (..),
    renderParseError,
    ) where

import Control.Exception         (Exception (..))
import Data.ByteString           (ByteString)
import Data.Foldable             (for_)
import Distribution.Simple.Utils (fromUTF8BS)
import System.FilePath           (normalise)

import qualified Data.ByteString.Char8          as BS8
import qualified Distribution.Fields            as C
import qualified Distribution.Fields.LexerMonad as C
import qualified Distribution.Parsec            as C
import qualified Distribution.Utils.Generic     as C
import qualified Text.Parsec                    as P

-- | Parse the contents using provided parser from 'C.Field' list.
--
-- This variant doesn't return any warnings in the successful case.
--
parseWith
    :: ([C.Field C.Position] -> C.ParseResult a)  -- ^ parse
    -> FilePath                                   -- ^ filename
    -> ByteString                                 -- ^ contents
    -> Either ParseError a
parseWith parser fp bs = case C.runParseResult result of
    (_, Right x)       -> return x
    (ws, Left (_, es)) -> Left $ ParseError fp bs es ws
  where
    result = case C.readFields' bs of
        Left perr -> C.parseFatalFailure pos (show perr) where
            ppos = P.errorPos perr
            pos  = C.Position (P.sourceLine ppos) (P.sourceColumn ppos)
        Right (fields, lexWarnings) -> do
            C.parseWarnings (C.toPWarnings lexWarnings)
            for_ (C.validateUTF8 bs) $ \pos ->
                C.parseWarning C.zeroPos C.PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos
            parser fields

-- | Parse error.
data ParseError = ParseError
    { peFilename :: FilePath
    , peContents :: ByteString
    , peErrors   :: [C.PError]
    , peWarnings :: [C.PWarning]
    }
  deriving (Show)

instance Exception ParseError where
    displayException = renderParseError

-- | Render parse error highlighting the part of the input file.
renderParseError :: ParseError -> String
renderParseError (ParseError filepath contents errors warnings)
    | null errors && null warnings = ""
    | null errors = unlines $
        ("Warnings encountered when parsing  file " ++ filepath ++ ":")
        : renderedWarnings
    | otherwise = unlines $
        [ "Errors encountered when parsing 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 = 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'