{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
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
parseWith
:: ([C.Field C.Position] -> C.ParseResult a)
-> FilePath
-> ByteString
-> 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
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
instance (NFData (f C.PError)) => NFData (ParseError f)
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
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
(Char
'-':Char
'-':FilePath
_) -> Bool
True
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)
| 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
"" ]
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
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
, 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
"^"
]
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
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'