{-# 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.Utils.Generic (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 :: forall a.
([Field Position] -> ParseResult a)
-> FilePath -> ByteString -> Either (ParseError NonEmpty) a
parseWith [Field Position] -> ParseResult a
parser FilePath
fp ByteString
bs = case forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
C.runParseResult ParseResult a
result of
    ([PWarning]
_, Right a
x)       -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
    ([PWarning]
ws, Left (Maybe Version
_, NonEmpty PError
es)) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ 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 -> forall a. Position -> FilePath -> ParseResult a
C.parseFatalFailure Position
pos (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)
            forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (ByteString -> Maybe Int
C.validateUTF8 ByteString
bs) forall a b. (a -> b) -> a -> b
$ \Int
pos ->
                Position -> PWarnType -> FilePath -> ParseResult ()
C.parseWarning Position
C.zeroPos PWarnType
C.PWTUTF forall a b. (a -> b) -> a -> b
$ FilePath
"UTF8 encoding problem at byte offset " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
pos
            [Field Position] -> ParseResult a
parser [Field Position]
fields

-- | Parse error.
data ParseError f = ParseError
    { forall (f :: * -> *). ParseError f -> FilePath
peFilename :: FilePath
    , forall (f :: * -> *). ParseError f -> ByteString
peContents :: ByteString
    , forall (f :: * -> *). ParseError f -> f PError
peErrors   :: f C.PError
    , forall (f :: * -> *). ParseError f -> [PWarning]
peWarnings :: [C.PWarning]
    }
  deriving (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 = 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 :: forall (f :: * -> *). Foldable f => ParseError f -> FilePath
renderParseError (ParseError FilePath
filepath ByteString
contents f PError
errors [PWarning]
warnings)
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null f PError
errors Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PWarning]
warnings = FilePath
""
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null f PError
errors = [FilePath] -> FilePath
unlines forall a b. (a -> b) -> a -> b
$
        (FilePath
"Warnings encountered when parsing  file " forall a. [a] -> [a] -> [a]
++ FilePath
filepath forall a. [a] -> [a] -> [a]
++ FilePath
":")
        forall a. a -> [a] -> [a]
: [FilePath]
renderedWarnings
    | Bool
otherwise = [FilePath] -> FilePath
unlines forall a b. (a -> b) -> a -> b
$
        [ FilePath
"Errors encountered when parsing file " forall a. [a] -> [a] -> [a]
++ FilePath
filepath forall a. [a] -> [a] -> [a]
++ FilePath
":"
        ]
        forall a. [a] -> [a] -> [a]
++ [FilePath]
renderedErrors
        forall a. [a] -> [a] -> [a]
++ [FilePath]
renderedWarnings
  where
    filepath' :: FilePath
filepath' = ShowS
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 = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith 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 = forall a. [a] -> Zipper a
listToZipper [(FilePath, Int, Bool)]
rows

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

    -- 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 -> [FilePath]
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 (FilePath, Int, Bool)
rowsZipper of
        Zipper [(FilePath, Int, Bool)]
xs [(FilePath, Int, Bool)]
ys -> [FilePath]
before forall a. [a] -> [a] -> [a]
++ [FilePath]
after where
            before :: [FilePath]
before = case 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)]
_) -> forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Int, Bool) -> FilePath
formatInputLine forall a b. (a -> b) -> a -> b
$ (FilePath, Int, Bool)
z forall a. a -> [a] -> [a]
: 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
"      | " 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]
++ 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 forall a. [a] -> [a] -> [a]
++ 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 = forall a. Show a => a -> FilePath
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 FilePath
s) Char
' ' forall a. [a] -> [a] -> [a]
++ FilePath
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'