{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE StandaloneDeriving   #-}
{-# LANGUAGE UndecidableInstances #-}
-- | 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.DeepSeq           (NFData (..))
import Control.Exception         (Exception (..))
import Data.ByteString           (ByteString)
import Data.Foldable             (for_)
import Data.List.NonEmpty        (NonEmpty)
import Data.Typeable             (Typeable)
import Distribution.Simple.Utils (fromUTF8BS)
import GHC.Generics              (Generic)
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 NonEmpty) a
parseWith :: ([Field Position] -> ParseResult a)
-> FilePath -> ByteString -> Either (ParseError NonEmpty) a
parseWith [Field Position] -> ParseResult a
parser FilePath
fp ByteString
bs = case ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
C.runParseResult ParseResult a
result of
    ([PWarning]
_, Right a
x)       -> a -> Either (ParseError NonEmpty) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
    ([PWarning]
ws, Left (Maybe Version
_, NonEmpty PError
es)) -> ParseError NonEmpty -> Either (ParseError NonEmpty) a
forall a b. a -> Either a b
Left (ParseError NonEmpty -> Either (ParseError NonEmpty) a)
-> ParseError NonEmpty -> Either (ParseError NonEmpty) a
forall a b. (a -> b) -> a -> b
$ FilePath
-> ByteString
-> NonEmpty PError
-> [PWarning]
-> ParseError NonEmpty
forall (f :: * -> *).
FilePath -> ByteString -> f PError -> [PWarning] -> ParseError f
ParseError FilePath
fp ByteString
bs NonEmpty PError
es [PWarning]
ws
  where
    result :: ParseResult a
result = case ByteString -> Either ParseError ([Field Position], [LexWarning])
C.readFields' ByteString
bs of
        Left ParseError
perr -> Position -> FilePath -> ParseResult a
forall a. Position -> FilePath -> ParseResult a
C.parseFatalFailure Position
pos (ParseError -> FilePath
forall a. Show a => a -> FilePath
show ParseError
perr) where
            ppos :: SourcePos
ppos = ParseError -> SourcePos
P.errorPos ParseError
perr
            pos :: Position
pos  = Int -> Int -> Position
C.Position (SourcePos -> Int
P.sourceLine SourcePos
ppos) (SourcePos -> Int
P.sourceColumn SourcePos
ppos)
        Right ([Field Position]
fields, [LexWarning]
lexWarnings) -> do
            [PWarning] -> ParseResult ()
C.parseWarnings ([LexWarning] -> [PWarning]
C.toPWarnings [LexWarning]
lexWarnings)
            Maybe Int -> (Int -> ParseResult ()) -> ParseResult ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (ByteString -> Maybe Int
C.validateUTF8 ByteString
bs) ((Int -> ParseResult ()) -> ParseResult ())
-> (Int -> ParseResult ()) -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ \Int
pos ->
                Position -> PWarnType -> FilePath -> ParseResult ()
C.parseWarning Position
C.zeroPos PWarnType
C.PWTUTF (FilePath -> ParseResult ()) -> FilePath -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ FilePath
"UTF8 encoding problem at byte offset " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
pos
            [Field Position] -> ParseResult a
parser [Field Position]
fields

-- | Parse error.
data ParseError f = ParseError
    { ParseError f -> FilePath
peFilename :: FilePath
    , ParseError f -> ByteString
peContents :: ByteString
    , ParseError f -> f PError
peErrors   :: f C.PError
    , ParseError f -> [PWarning]
peWarnings :: [C.PWarning]
    }
  deriving ((forall x. ParseError f -> Rep (ParseError f) x)
-> (forall x. Rep (ParseError f) x -> ParseError f)
-> Generic (ParseError f)
forall x. Rep (ParseError f) x -> ParseError f
forall x. ParseError f -> Rep (ParseError f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) x. Rep (ParseError f) x -> ParseError f
forall (f :: * -> *) x. ParseError f -> Rep (ParseError f) x
$cto :: forall (f :: * -> *) x. Rep (ParseError f) x -> ParseError f
$cfrom :: forall (f :: * -> *) x. ParseError f -> Rep (ParseError f) x
Generic)

deriving instance (Show (f C.PError)) => Show (ParseError f)

instance (Foldable f, Show (f C.PError), Typeable f) => Exception (ParseError f) where
    displayException :: ParseError f -> FilePath
displayException = ParseError f -> FilePath
forall (f :: * -> *). Foldable f => ParseError f -> FilePath
renderParseError

-- | @since 0.2.1
instance (NFData (f C.PError)) => NFData (ParseError f)

-- | Render parse error highlighting the part of the input file.
renderParseError :: Foldable f => ParseError f -> String
renderParseError :: ParseError f -> FilePath
renderParseError (ParseError FilePath
filepath ByteString
contents f PError
errors [PWarning]
warnings)
    | f PError -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null f PError
errors Bool -> Bool -> Bool
&& [PWarning] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PWarning]
warnings = FilePath
""
    | f PError -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null f PError
errors = [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
        (FilePath
"Warnings encountered when parsing  file " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
filepath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":")
        FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
renderedWarnings
    | Bool
otherwise = [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
        [ FilePath
"Errors encountered when parsing file " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
filepath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":"
        ]
        [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
renderedErrors
        [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
renderedWarnings
  where
    filepath' :: FilePath
filepath' = FilePath -> FilePath
normalise FilePath
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 :: [(FilePath, Int, Bool)]
rows = (ByteString -> Int -> (FilePath, Int, Bool))
-> [ByteString] -> [Int] -> [(FilePath, Int, Bool)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ByteString -> Int -> (FilePath, Int, Bool)
forall b. ByteString -> b -> (FilePath, b, Bool)
f (ByteString -> [ByteString]
BS8.lines ByteString
contents) [Int
1..] where
        f :: ByteString -> b -> (FilePath, b, Bool)
f ByteString
bs b
i = let s :: FilePath
s = ByteString -> FilePath
fromUTF8BS ByteString
bs in (FilePath
s, b
i, FilePath -> Bool
isEmptyOrComment FilePath
s)

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

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

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

    renderError :: C.PError -> [String]
    renderError :: PError -> [FilePath]
renderError (C.PError pos :: Position
pos@(C.Position Int
row Int
col) FilePath
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 = [FilePath]
msgs
        | Bool
otherwise      = [FilePath]
msgs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ Int -> Int -> [FilePath]
formatInput Int
row Int
col
      where
        msgs :: [FilePath]
msgs = [ FilePath
"", FilePath
filepath' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Position -> FilePath
C.showPos Position
pos FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": error:", FilePath -> FilePath
trimLF FilePath
msg, FilePath
"" ]

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

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

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

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

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