{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Distribution.Client.Errors.Parser where

import Distribution.Client.Compat.Prelude
import System.FilePath (normalise)
import Prelude ()

import qualified Data.ByteString.Char8 as BS8
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Map.Merge.Strict as Map
import Distribution.Parsec
import Distribution.Parsec.Source
import Distribution.Simple.Utils (fromUTF8BS)
import Distribution.Solver.Types.ProjectConfigPath
import Distribution.Version (Version)
import Text.PrettyPrint (render)

-- Error when parsing a .cabal file

-- | Errors reported upon failing to parse a @.cabal@ file.
data CabalFileParseError
  = CabalFileParseError
      FilePath
      -- ^ @.cabal@ file path
      BS8.ByteString
      -- ^ @.cabal@ file contents
      (NonEmpty (PErrorWithSource CabalFileSource))
      -- ^ errors
      (Maybe Version)
      -- ^ We might discover the spec version the package needs
      [PWarningWithSource CabalFileSource]
      -- ^ warnings

-- | Manual instance which skips file contents
instance Show CabalFileParseError where
  showsPrec :: Int -> CabalFileParseError -> ShowS
showsPrec Int
d (CabalFileParseError String
fp ByteString
_ NonEmpty (PErrorWithSource CabalFileSource)
es Maybe Version
mv [PWarningWithSource CabalFileSource]
ws) =
    Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"CabalFileParseError"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 String
fp
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 (String
"" :: String)
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> NonEmpty (PErrorWithSource CabalFileSource) -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 NonEmpty (PErrorWithSource CabalFileSource)
es
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Version -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Maybe Version
mv
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [PWarningWithSource CabalFileSource] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 [PWarningWithSource CabalFileSource]
ws

instance Exception CabalFileParseError where
  displayException :: CabalFileParseError -> String
displayException = CabalFileParseError -> String
renderCabalFileParseError

renderCabalFileParseError :: CabalFileParseError -> String
renderCabalFileParseError :: CabalFileParseError -> String
renderCabalFileParseError (CabalFileParseError String
_filePath ByteString
_contents NonEmpty (PErrorWithSource CabalFileSource)
errors Maybe Version
_ [PWarningWithSource CabalFileSource]
warnings) =
  NonEmpty (PErrorWithSource CabalFileSource)
-> [PWarningWithSource CabalFileSource] -> String
renderParseErrorCabalFile NonEmpty (PErrorWithSource CabalFileSource)
errors [PWarningWithSource CabalFileSource]
warnings

-- Error when parsing a project file

-- | Errors reported upon failing to parse a @cabal.project@ file.
data ProjectConfigParseError
  = ProjectConfigParseError
      (NonEmpty (PErrorWithSource ProjectFileSource))
      -- ^ errors
      [PWarningWithSource ProjectFileSource]
      -- ^ warnings

-- | Manual instance which skips file contents
instance Show ProjectConfigParseError where
  showsPrec :: Int -> ProjectConfigParseError -> ShowS
showsPrec Int
d (ProjectConfigParseError NonEmpty (PErrorWithSource ProjectFileSource)
es [PWarningWithSource ProjectFileSource]
ws) =
    Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"ProjectConfigParseError"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> NonEmpty (PErrorWithSource ProjectFileSource) -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 NonEmpty (PErrorWithSource ProjectFileSource)
es
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [PWarningWithSource ProjectFileSource] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 [PWarningWithSource ProjectFileSource]
ws

instance Exception ProjectConfigParseError where
  displayException :: ProjectConfigParseError -> String
displayException = ProjectConfigParseError -> String
renderProjectConfigParseError

renderProjectConfigParseError :: ProjectConfigParseError -> String
renderProjectConfigParseError :: ProjectConfigParseError -> String
renderProjectConfigParseError (ProjectConfigParseError NonEmpty (PErrorWithSource ProjectFileSource)
errors [PWarningWithSource ProjectFileSource]
warnings) =
  (ProjectFileSource -> ([PError], [PWarning]) -> String)
-> NonEmpty (PErrorWithSource ProjectFileSource)
-> [PWarningWithSource ProjectFileSource]
-> String
forall src.
Ord src =>
(src -> ([PError], [PWarning]) -> String)
-> NonEmpty (PErrorWithSource src)
-> [PWarningWithSource src]
-> String
renderParseError ProjectFileSource -> ([PError], [PWarning]) -> String
displayProjectFileSource NonEmpty (PErrorWithSource ProjectFileSource)
errors [PWarningWithSource ProjectFileSource]
warnings
  where
    displayProjectFileSource :: ProjectFileSource -> ([PError], [PWarning]) -> String
displayProjectFileSource (ProjectFileSource (ProjectConfigPath
path, ByteString
contents)) =
      String
-> String
-> Maybe String
-> ByteString
-> ([PError], [PWarning])
-> String
renderParseErrorFile String
"project" (ProjectConfigPath -> String
currentProjectConfigPath ProjectConfigPath
path) (if ProjectConfigPath -> Bool
isTopLevelConfigPath ProjectConfigPath
path then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Doc -> String
render (ProjectConfigPath -> Doc
docProjectImportedBy ProjectConfigPath
path)) ByteString
contents

data ProjectFileSource = ProjectFileSource (ProjectConfigPath, BS8.ByteString) deriving (Int -> ProjectFileSource -> ShowS
[ProjectFileSource] -> ShowS
ProjectFileSource -> String
(Int -> ProjectFileSource -> ShowS)
-> (ProjectFileSource -> String)
-> ([ProjectFileSource] -> ShowS)
-> Show ProjectFileSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProjectFileSource -> ShowS
showsPrec :: Int -> ProjectFileSource -> ShowS
$cshow :: ProjectFileSource -> String
show :: ProjectFileSource -> String
$cshowList :: [ProjectFileSource] -> ShowS
showList :: [ProjectFileSource] -> ShowS
Show, (forall x. ProjectFileSource -> Rep ProjectFileSource x)
-> (forall x. Rep ProjectFileSource x -> ProjectFileSource)
-> Generic ProjectFileSource
forall x. Rep ProjectFileSource x -> ProjectFileSource
forall x. ProjectFileSource -> Rep ProjectFileSource x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ProjectFileSource -> Rep ProjectFileSource x
from :: forall x. ProjectFileSource -> Rep ProjectFileSource x
$cto :: forall x. Rep ProjectFileSource x -> ProjectFileSource
to :: forall x. Rep ProjectFileSource x -> ProjectFileSource
Generic)

instance Eq ProjectFileSource where
  (ProjectFileSource (ProjectConfigPath
path1, ByteString
_)) == :: ProjectFileSource -> ProjectFileSource -> Bool
== (ProjectFileSource (ProjectConfigPath
path2, ByteString
_)) = ProjectConfigPath
path1 ProjectConfigPath -> ProjectConfigPath -> Bool
forall a. Eq a => a -> a -> Bool
== ProjectConfigPath
path2

instance Ord ProjectFileSource where
  (ProjectFileSource (ProjectConfigPath
path1, ByteString
_)) compare :: ProjectFileSource -> ProjectFileSource -> Ordering
`compare` (ProjectFileSource (ProjectConfigPath
path2, ByteString
_)) = ProjectConfigPath
path1 ProjectConfigPath -> ProjectConfigPath -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` ProjectConfigPath
path2

renderProjectFileSource :: ProjectFileSource -> String
renderProjectFileSource :: ProjectFileSource -> String
renderProjectFileSource (ProjectFileSource (ProjectConfigPath
path, ByteString
_contents)) =
  ProjectConfigPath -> String
currentProjectConfigPath ProjectConfigPath
path

renderParseErrorCabalFile :: NonEmpty (PErrorWithSource CabalFileSource) -> [PWarningWithSource CabalFileSource] -> String
renderParseErrorCabalFile :: NonEmpty (PErrorWithSource CabalFileSource)
-> [PWarningWithSource CabalFileSource] -> String
renderParseErrorCabalFile NonEmpty (PErrorWithSource CabalFileSource)
errors [PWarningWithSource CabalFileSource]
warnings =
  (CabalFileSource -> ([PError], [PWarning]) -> String)
-> NonEmpty (PErrorWithSource CabalFileSource)
-> [PWarningWithSource CabalFileSource]
-> String
forall src.
Ord src =>
(src -> ([PError], [PWarning]) -> String)
-> NonEmpty (PErrorWithSource src)
-> [PWarningWithSource src]
-> String
renderParseError CabalFileSource -> ([PError], [PWarning]) -> String
renderCabalFileSourceMsgs NonEmpty (PErrorWithSource CabalFileSource)
errors [PWarningWithSource CabalFileSource]
warnings

-- | Render parse error highlighting the part of the input file.
renderParseError
  :: forall src
   . Ord src
  => (src -> ([PError], [PWarning]) -> String)
  -> NonEmpty (PErrorWithSource src)
  -> [PWarningWithSource src]
  -> String
renderParseError :: forall src.
Ord src =>
(src -> ([PError], [PWarning]) -> String)
-> NonEmpty (PErrorWithSource src)
-> [PWarningWithSource src]
-> String
renderParseError src -> ([PError], [PWarning]) -> String
display NonEmpty (PErrorWithSource src)
errors [PWarningWithSource src]
warnings =
  [String] -> String
unlines [PSource (([PError], [PWarning]) -> String)
-> ([PError], [PWarning]) -> String
renderParseErrorsWarnings ((src -> ([PError], [PWarning]) -> String)
-> PSource src -> PSource (([PError], [PWarning]) -> String)
forall a b. (a -> b) -> PSource a -> PSource b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap src -> ([PError], [PWarning]) -> String
display PSource src
source) ([PError], [PWarning])
ws | (PSource src
source, ([PError], [PWarning])
ws) <- [(PSource src, ([PError], [PWarning]))]
joinedErrorsWarningsList]
  where
    mkErrorGroup :: NonEmpty (PErrorWithSource src) -> (PSource src, [PError])
    mkErrorGroup :: NonEmpty (PErrorWithSource src) -> (PSource src, [PError])
mkErrorGroup (PErrorWithSource src
x :| [PErrorWithSource src]
xs) = (PErrorWithSource src -> PSource src
forall src. PErrorWithSource src -> PSource src
perrorSource PErrorWithSource src
x, PErrorWithSource src -> PError
forall src. PErrorWithSource src -> PError
perror PErrorWithSource src
x PError -> [PError] -> [PError]
forall a. a -> [a] -> [a]
: (PErrorWithSource src -> PError)
-> [PErrorWithSource src] -> [PError]
forall a b. (a -> b) -> [a] -> [b]
map PErrorWithSource src -> PError
forall src. PErrorWithSource src -> PError
perror [PErrorWithSource src]
xs)

    mkWarningGroup :: NonEmpty (PWarningWithSource src) -> (PSource src, [PWarning])
    mkWarningGroup :: NonEmpty (PWarningWithSource src) -> (PSource src, [PWarning])
mkWarningGroup (PWarningWithSource src
x :| [PWarningWithSource src]
xs) = (PWarningWithSource src -> PSource src
forall src. PWarningWithSource src -> PSource src
pwarningSource PWarningWithSource src
x, PWarningWithSource src -> PWarning
forall src. PWarningWithSource src -> PWarning
pwarning PWarningWithSource src
x PWarning -> [PWarning] -> [PWarning]
forall a. a -> [a] -> [a]
: (PWarningWithSource src -> PWarning)
-> [PWarningWithSource src] -> [PWarning]
forall a b. (a -> b) -> [a] -> [b]
map PWarningWithSource src -> PWarning
forall src. PWarningWithSource src -> PWarning
pwarning [PWarningWithSource src]
xs)

    groupedErrors :: Map (PSource src) [PError]
groupedErrors =
      ([PError] -> [PError] -> [PError])
-> [(PSource src, [PError])] -> Map (PSource src) [PError]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [PError] -> [PError] -> [PError]
forall a. [a] -> [a] -> [a]
(++) ([(PSource src, [PError])] -> Map (PSource src) [PError])
-> [(PSource src, [PError])] -> Map (PSource src) [PError]
forall a b. (a -> b) -> a -> b
$
        (NonEmpty (PErrorWithSource src) -> (PSource src, [PError]))
-> [NonEmpty (PErrorWithSource src)] -> [(PSource src, [PError])]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty (PErrorWithSource src) -> (PSource src, [PError])
mkErrorGroup ([NonEmpty (PErrorWithSource src)] -> [(PSource src, [PError])])
-> [NonEmpty (PErrorWithSource src)] -> [(PSource src, [PError])]
forall a b. (a -> b) -> a -> b
$
          (PErrorWithSource src -> PErrorWithSource src -> Bool)
-> NonEmpty (PErrorWithSource src)
-> [NonEmpty (PErrorWithSource src)]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
NE.groupBy
            (\PErrorWithSource src
a PErrorWithSource src
b -> PErrorWithSource src -> PSource src
forall src. PErrorWithSource src -> PSource src
perrorSource PErrorWithSource src
a PSource src -> PSource src -> Bool
forall a. Eq a => a -> a -> Bool
== PErrorWithSource src -> PSource src
forall src. PErrorWithSource src -> PSource src
perrorSource PErrorWithSource src
b)
            NonEmpty (PErrorWithSource src)
errors
    groupedWarnings :: Map (PSource src) [PWarning]
groupedWarnings =
      ([PWarning] -> [PWarning] -> [PWarning])
-> [(PSource src, [PWarning])] -> Map (PSource src) [PWarning]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [PWarning] -> [PWarning] -> [PWarning]
forall a. [a] -> [a] -> [a]
(++) ([(PSource src, [PWarning])] -> Map (PSource src) [PWarning])
-> [(PSource src, [PWarning])] -> Map (PSource src) [PWarning]
forall a b. (a -> b) -> a -> b
$
        (NonEmpty (PWarningWithSource src) -> (PSource src, [PWarning]))
-> [NonEmpty (PWarningWithSource src)]
-> [(PSource src, [PWarning])]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty (PWarningWithSource src) -> (PSource src, [PWarning])
mkWarningGroup ([NonEmpty (PWarningWithSource src)]
 -> [(PSource src, [PWarning])])
-> [NonEmpty (PWarningWithSource src)]
-> [(PSource src, [PWarning])]
forall a b. (a -> b) -> a -> b
$
          (PWarningWithSource src -> PWarningWithSource src -> Bool)
-> [PWarningWithSource src] -> [NonEmpty (PWarningWithSource src)]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
NE.groupBy
            (\PWarningWithSource src
a PWarningWithSource src
b -> PWarningWithSource src -> PSource src
forall src. PWarningWithSource src -> PSource src
pwarningSource PWarningWithSource src
a PSource src -> PSource src -> Bool
forall a. Eq a => a -> a -> Bool
== PWarningWithSource src -> PSource src
forall src. PWarningWithSource src -> PSource src
pwarningSource PWarningWithSource src
b)
            [PWarningWithSource src]
warnings

    joinedErrorsWarnings :: Map.Map (PSource src) ([PError], [PWarning])
    joinedErrorsWarnings :: Map (PSource src) ([PError], [PWarning])
joinedErrorsWarnings = SimpleWhenMissing (PSource src) [PError] ([PError], [PWarning])
-> SimpleWhenMissing
     (PSource src) [PWarning] ([PError], [PWarning])
-> SimpleWhenMatched
     (PSource src) [PError] [PWarning] ([PError], [PWarning])
-> Map (PSource src) [PError]
-> Map (PSource src) [PWarning]
-> Map (PSource src) ([PError], [PWarning])
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge ((PSource src -> [PError] -> ([PError], [PWarning]))
-> SimpleWhenMissing (PSource src) [PError] ([PError], [PWarning])
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing (\PSource src
_ [PError]
es -> ([PError]
es, []))) ((PSource src -> [PWarning] -> ([PError], [PWarning]))
-> SimpleWhenMissing
     (PSource src) [PWarning] ([PError], [PWarning])
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing (\PSource src
_ [PWarning]
ps -> ([], [PWarning]
ps))) ((PSource src -> [PError] -> [PWarning] -> ([PError], [PWarning]))
-> SimpleWhenMatched
     (PSource src) [PError] [PWarning] ([PError], [PWarning])
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
Map.zipWithMatched (\PSource src
_ [PError]
es [PWarning]
ps -> ([PError]
es, [PWarning]
ps))) Map (PSource src) [PError]
groupedErrors Map (PSource src) [PWarning]
groupedWarnings

    joinedErrorsWarningsList :: [(PSource src, ([PError], [PWarning]))]
joinedErrorsWarningsList = Map (PSource src) ([PError], [PWarning])
-> [(PSource src, ([PError], [PWarning]))]
forall k a. Map k a -> [(k, a)]
Map.toList Map (PSource src) ([PError], [PWarning])
joinedErrorsWarnings

renderParseErrorsWarnings :: PSource (([PError], [PWarning]) -> String) -> ([PError], [PWarning]) -> String
renderParseErrorsWarnings :: PSource (([PError], [PWarning]) -> String)
-> ([PError], [PWarning]) -> String
renderParseErrorsWarnings PSource (([PError], [PWarning]) -> String)
source ([PError]
errors, [PWarning]
warnings) =
  case PSource (([PError], [PWarning]) -> String)
source of
    PKnownSource ([PError], [PWarning]) -> String
src -> ([PError], [PWarning]) -> String
src ([PError]
errors, [PWarning]
warnings)
    PSource (([PError], [PWarning]) -> String)
PUnknownSource -> String -> [PError] -> [PWarning] -> String
renderParseErrorNoFile String
"" [PError]
errors [PWarning]
warnings

renderCabalFileSourceMsgs :: CabalFileSource -> ([PError], [PWarning]) -> String
renderCabalFileSourceMsgs :: CabalFileSource -> ([PError], [PWarning]) -> String
renderCabalFileSourceMsgs (PCabalFile (String
fpath, ByteString
contents)) ([PError]
errors, [PWarning]
warnings) =
  String
-> String
-> Maybe String
-> ByteString
-> ([PError], [PWarning])
-> String
renderParseErrorFile String
"cabal" String
fpath Maybe String
forall a. Maybe a
Nothing ByteString
contents ([PError]
errors, [PWarning]
warnings)

renderInstalledPackageInfoSourceMsgs :: InstalledPackageInfoSource -> ([PError], [PWarning]) -> String
renderInstalledPackageInfoSourceMsgs :: InstalledPackageInfoSource -> ([PError], [PWarning]) -> String
renderInstalledPackageInfoSourceMsgs InstalledPackageInfoSource
PInstalledPackageInfo ([PError]
errors, [PWarning]
warnings) =
  String -> [PError] -> [PWarning] -> String
renderParseErrorNoFile String
"installed package info" [PError]
errors [PWarning]
warnings

renderParseErrorNoFile :: String -> [PError] -> [PWarning] -> String
renderParseErrorNoFile :: String -> [PError] -> [PWarning] -> String
renderParseErrorNoFile String
herald [PError]
errors [PWarning]
warnings =
  String
-> Maybe String
-> Maybe String
-> (Position -> [String])
-> [PError]
-> [PWarning]
-> String
renderParseErrorGeneral String
herald Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing ([String] -> Position -> [String]
forall a b. a -> b -> a
const []) [PError]
errors [PWarning]
warnings

-- | Render a parse error which resulted from a file on disk
renderParseErrorFile
  :: String
  -- ^ Human name for the kind of file (i.e. cabal, project "file")
  -> FilePath
  -- ^ Path to the file
  -> Maybe String
  -- ^ Provenance, any additional contextual info to print
  -> BS8.ByteString
  -- ^ Contents of the file
  -> ([PError], [PWarning])
  -> String
renderParseErrorFile :: String
-> String
-> Maybe String
-> ByteString
-> ([PError], [PWarning])
-> String
renderParseErrorFile String
herald String
filepath Maybe String
provenance ByteString
contents ([PError]
errors, [PWarning]
warnings) =
  String
-> Maybe String
-> Maybe String
-> (Position -> [String])
-> [PError]
-> [PWarning]
-> String
renderParseErrorGeneral (String
herald String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" file " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
filepath) (String -> Maybe String
forall a. a -> Maybe a
Just (String
filepath' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":")) Maybe String
provenance Position -> [String]
formatInput [PError]
errors [PWarning]
warnings
  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
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

    -- format line: prepend the given line number
    formatInput :: Position -> [String]
    formatInput :: Position -> [String]
formatInput (Position 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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

-- | A generic rendering function which can render from many sources.
renderParseErrorGeneral
  :: String
  -- ^ What we were parsing when the error occurred.
  -> Maybe String
  -- ^ A simpler/shorter header to display when displaying each error (normally a filepath)
  -> Maybe String
  -- ^ Provenance, used to print additional context about what file failed (used to print the import path of a project
  -- file which failed to parse)
  -> (Position -> [String])
  -- ^ Extra information to render based on the position
  -> [PError]
  -> [PWarning]
  -> String
renderParseErrorGeneral :: String
-> Maybe String
-> Maybe String
-> (Position -> [String])
-> [PError]
-> [PWarning]
-> String
renderParseErrorGeneral String
header Maybe String
err_header Maybe String
provenance Position -> [String]
extra_info [PError]
errors [PWarning]
warnings =
  [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    [ String
warningsOrErrors String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" parsing" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
header' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":"
    ]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Maybe String
provenance]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
""] -- Place a newline between the header and the errors/warnings
      -- Place a newline between each error and warning
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"" ([String]
renderedWarnings [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
renderedErrors)
  where
    warningsOrErrors :: String
warningsOrErrors = case [PError]
errors of
      [] -> case [PWarning]
warnings of
        [PWarning
_] -> String
"Warning"
        [PWarning]
_ -> String
"Warnings"
      [PError
_] -> String
"Error"
      [PError]
_ -> String
"Errors"

    header' :: String
header' = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
header then String
"" else String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
header

    renderedErrors :: [String]
renderedErrors = (PError -> String) -> [PError] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PError -> String
renderError ((PError -> PError -> Ordering) -> [PError] -> [PError]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((PError -> Position) -> PError -> PError -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing PError -> Position
perrorPosition) [PError]
errors)
    renderedWarnings :: [String]
renderedWarnings = (PWarning -> String) -> [PWarning] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PWarning -> String
renderWarning ((PWarning -> PWarning -> Ordering) -> [PWarning] -> [PWarning]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((PWarning -> Position) -> PWarning -> PWarning -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing PWarning -> Position
pwarningPosition) [PWarning]
warnings)

    renderErrorOrWarning :: String -> Position -> String -> String
    renderErrorOrWarning :: String -> Position -> ShowS
renderErrorOrWarning String
err_type Position
pos 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
zeroPos = [String] -> String
unlines (String
herald String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
indent [String]
user_msg)
      | Bool
otherwise = [String] -> String
unlines (String
herald String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
indent ([String]
user_msg [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Position -> [String]
extra_info Position
pos))
      where
        herald :: String
herald = Position -> String
renderErrorHerald Position
pos String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err_type String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":"
        user_msg :: [String]
user_msg = String -> [String]
lines (ShowS
trimLF String
msg)

    indent :: String -> String
    indent :: ShowS
indent String
s = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
2 Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

    -- Don't render the 0:0 position
    renderErrorHerald :: Position -> String
    renderErrorHerald :: Position -> String
renderErrorHerald Position
pos =
      case (Maybe String
err_header, Position
pos Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
zeroPos) of
        (Maybe String
Nothing, Bool
True) -> String
""
        (Maybe String
Nothing, Bool
False) -> Position -> String
showPos Position
pos String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": "
        (Just String
herald, Bool
True) -> String
herald String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" "
        (Just String
herald, Bool
False) -> String
herald String -> ShowS
forall a. [a] -> [a] -> [a]
++ Position -> String
showPos Position
pos String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": "

    renderError :: PError -> String
    renderError :: PError -> String
renderError (PError Position
pos String
msg) = String -> Position -> ShowS
renderErrorOrWarning String
"error" Position
pos String
msg

    renderWarning :: PWarning -> String
    renderWarning :: PWarning -> String
renderWarning (PWarning PWarnType
_ Position
pos String
msg) = String -> Position -> ShowS
renderErrorOrWarning String
"warning" Position
pos String
msg

    -- 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

data Zipper a = Zipper [a] [a]

listToZipper :: [a] -> Zipper a
listToZipper :: forall a. [a] -> Zipper a
listToZipper = [a] -> [a] -> Zipper a
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 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
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs) [a]
ys'