{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}

module GHC.Types.Error
   ( -- * Messages
     Messages
   , WarningMessages
   , ErrorMessages
   , mkMessages
   , emptyMessages
   , isEmptyMessages
   , addMessage
   , unionMessages
   , MsgEnvelope (..)
   , WarnMsg
   , SDoc
   , DecoratedSDoc (unDecorated)
   , Severity (..)
   , RenderableDiagnostic (..)
   , pprMessageBag
   , mkDecorated
   , mkLocMessage
   , mkLocMessageAnn
   , getSeverityColour
   , getCaretDiagnostic
   , makeIntoWarning
   -- * Constructing individual errors
   , mkMsgEnvelope
   , mkPlainMsgEnvelope
   , mkErr
   , mkLongMsgEnvelope
   , mkWarnMsg
   , mkPlainWarnMsg
   , mkLongWarnMsg
   -- * Queries
   , isErrorMessage
   , isWarningMessage
   , getErrorMessages
   , getWarningMessages
   , partitionMessages
   , errorsFound
   )
where

import GHC.Prelude

import GHC.Driver.Flags

import GHC.Data.Bag
import GHC.Utils.Outputable as Outputable
import qualified GHC.Utils.Ppr.Colour as Col
import GHC.Types.SrcLoc as SrcLoc
import GHC.Data.FastString (unpackFS)
import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
import GHC.Utils.Json

import System.IO.Error  ( catchIOError )

{-
Note [Messages]
~~~~~~~~~~~~~~~

We represent the 'Messages' as a single bag of warnings and errors.

The reason behind that is that there is a fluid relationship between errors and warnings and we want to
be able to promote or demote errors and warnings based on certain flags (e.g. -Werror, -fdefer-type-errors
or -XPartialTypeSignatures). For now we rely on the 'Severity' to distinguish between a warning and an
error, although the 'Severity' can be /more/ than just 'SevWarn' and 'SevError', and as such it probably
shouldn't belong to an 'MsgEnvelope' to begin with, as it might potentially lead to the construction of
"impossible states" (e.g. a waning with 'SevInfo', for example).

'WarningMessages' and 'ErrorMessages' are for now simple type aliases to retain backward compatibility, but
in future iterations these can be either parameterised over an 'e' message type (to make type signatures
a bit more declarative) or removed altogether.
-}

-- | A collection of messages emitted by GHC during error reporting. A diagnostic message is typically
-- a warning or an error. See Note [Messages].
newtype Messages e = Messages (Bag (MsgEnvelope e))

instance Functor Messages where
  fmap :: forall a b. (a -> b) -> Messages a -> Messages b
fmap a -> b
f (Messages Bag (MsgEnvelope a)
xs) = forall e. Bag (MsgEnvelope e) -> Messages e
Messages (forall a b. (a -> b) -> Bag a -> Bag b
mapBag (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) Bag (MsgEnvelope a)
xs)

emptyMessages :: Messages e
emptyMessages :: forall e. Messages e
emptyMessages = forall e. Bag (MsgEnvelope e) -> Messages e
Messages forall a. Bag a
emptyBag

mkMessages :: Bag (MsgEnvelope e) -> Messages e
mkMessages :: forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages = forall e. Bag (MsgEnvelope e) -> Messages e
Messages

isEmptyMessages :: Messages e -> Bool
isEmptyMessages :: forall e. Messages e -> Bool
isEmptyMessages (Messages Bag (MsgEnvelope e)
msgs) = forall a. Bag a -> Bool
isEmptyBag Bag (MsgEnvelope e)
msgs

addMessage :: MsgEnvelope e -> Messages e -> Messages e
addMessage :: forall e. MsgEnvelope e -> Messages e -> Messages e
addMessage MsgEnvelope e
x (Messages Bag (MsgEnvelope e)
xs) = forall e. Bag (MsgEnvelope e) -> Messages e
Messages (MsgEnvelope e
x forall a. a -> Bag a -> Bag a
`consBag` Bag (MsgEnvelope e)
xs)

-- | Joins two collections of messages together.
unionMessages :: Messages e -> Messages e -> Messages e
unionMessages :: forall e. Messages e -> Messages e -> Messages e
unionMessages (Messages Bag (MsgEnvelope e)
msgs1) (Messages Bag (MsgEnvelope e)
msgs2) = forall e. Bag (MsgEnvelope e) -> Messages e
Messages (Bag (MsgEnvelope e)
msgs1 forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (MsgEnvelope e)
msgs2)

type WarningMessages = Bag (MsgEnvelope DecoratedSDoc)
type ErrorMessages   = Bag (MsgEnvelope DecoratedSDoc)

type WarnMsg         = MsgEnvelope DecoratedSDoc

-- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the invariant that the input '[SDoc]'
-- needs to be rendered /decorated/ into its final form, where the typical case would be adding bullets
-- between each elements of the list.
-- The type of decoration depends on the formatting function used, but in practice GHC uses the
-- 'formatBulleted'.
newtype DecoratedSDoc = Decorated { DecoratedSDoc -> [SDoc]
unDecorated :: [SDoc] }

-- | Creates a new 'DecoratedSDoc' out of a list of 'SDoc'.
mkDecorated :: [SDoc] -> DecoratedSDoc
mkDecorated :: [SDoc] -> DecoratedSDoc
mkDecorated = [SDoc] -> DecoratedSDoc
Decorated

{-
Note [Rendering Messages]
~~~~~~~~~~~~~~~~~~~~~~~~~

Turning 'Messages' into something that renders nicely for the user is one of the last steps, and it
happens typically at the application boundaries (i.e. from the 'Driver' upwards).

For now (see #18516) this class is very boring as it has only one instance, but the idea is that as
the more domain-specific types are defined, the more instances we would get. For example, given something like:

data TcRnMessage
  = TcRnOutOfScope ..
  | ..

We could then define how a 'TcRnMessage' is displayed to the user. Rather than scattering pieces of
'SDoc' around the codebase, we would write once for all:

instance RenderableDiagnostic TcRnMessage where
  renderDiagnostic = \case
    TcRnOutOfScope .. -> Decorated [text "Out of scope error ..."]
    ...

This way, we can easily write generic rendering functions for errors that all they care about is the
knowledge that a given type 'e' has a 'RenderableDiagnostic' constraint.

-}

-- | A class for types (typically errors and warnings) which can be \"rendered\" into an opaque 'DecoratedSDoc'.
-- For more information, see Note [Rendering Messages].
class RenderableDiagnostic a where
  renderDiagnostic :: a -> DecoratedSDoc

-- | An envelope for GHC's facts about a running program, parameterised over the
-- /domain-specific/ (i.e. parsing, typecheck-renaming, etc) diagnostics.
--
-- To say things differently, GHC emits /diagnostics/ about the running program, each of which is wrapped
-- into a 'MsgEnvelope' that carries specific information like where the error happened, its severity, etc.
-- Finally, multiple 'MsgEnvelope's are aggregated into 'Messages' that are returned to the user.
data MsgEnvelope e = MsgEnvelope
   { forall e. MsgEnvelope e -> SrcSpan
errMsgSpan        :: SrcSpan
      -- ^ The SrcSpan is used for sorting errors into line-number order
   , forall e. MsgEnvelope e -> PrintUnqualified
errMsgContext     :: PrintUnqualified
   , forall e. MsgEnvelope e -> e
errMsgDiagnostic  :: e
   , forall e. MsgEnvelope e -> Severity
errMsgSeverity    :: Severity
   , forall e. MsgEnvelope e -> WarnReason
errMsgReason      :: WarnReason
   } deriving forall a b. a -> MsgEnvelope b -> MsgEnvelope a
forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> MsgEnvelope b -> MsgEnvelope a
$c<$ :: forall a b. a -> MsgEnvelope b -> MsgEnvelope a
fmap :: forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
$cfmap :: forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
Functor

instance RenderableDiagnostic DecoratedSDoc where
  renderDiagnostic :: DecoratedSDoc -> DecoratedSDoc
renderDiagnostic = forall a. a -> a
id

data Severity
  = SevOutput
  | SevFatal
  | SevInteractive

  | SevDump
    -- ^ Log message intended for compiler developers
    -- No file\/line\/column stuff

  | SevInfo
    -- ^ Log messages intended for end users.
    -- No file\/line\/column stuff.

  | SevWarning
  | SevError
    -- ^ SevWarning and SevError are used for warnings and errors
    --   o The message has a file\/line\/column heading,
    --     plus "warning:" or "error:",
    --     added by mkLocMessags
    --   o Output is intended for end users
  deriving (Severity -> Severity -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Severity -> Severity -> Bool
$c/= :: Severity -> Severity -> Bool
== :: Severity -> Severity -> Bool
$c== :: Severity -> Severity -> Bool
Eq, Int -> Severity -> ShowS
[Severity] -> ShowS
Severity -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Severity] -> ShowS
$cshowList :: [Severity] -> ShowS
show :: Severity -> String
$cshow :: Severity -> String
showsPrec :: Int -> Severity -> ShowS
$cshowsPrec :: Int -> Severity -> ShowS
Show)


instance ToJson Severity where
  json :: Severity -> JsonDoc
json Severity
s = String -> JsonDoc
JSString (forall a. Show a => a -> String
show Severity
s)

instance Show (MsgEnvelope DecoratedSDoc) where
    show :: MsgEnvelope DecoratedSDoc -> String
show = forall a. RenderableDiagnostic a => MsgEnvelope a -> String
showMsgEnvelope

-- | Shows an 'MsgEnvelope'.
showMsgEnvelope :: RenderableDiagnostic a => MsgEnvelope a -> String
showMsgEnvelope :: forall a. RenderableDiagnostic a => MsgEnvelope a -> String
showMsgEnvelope MsgEnvelope a
err =
  SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext ([SDoc] -> SDoc
vcat (DecoratedSDoc -> [SDoc]
unDecorated forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RenderableDiagnostic a => a -> DecoratedSDoc
renderDiagnostic forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> e
errMsgDiagnostic MsgEnvelope a
err))

pprMessageBag :: Bag SDoc -> SDoc
pprMessageBag :: Bag SDoc -> SDoc
pprMessageBag Bag SDoc
msgs = [SDoc] -> SDoc
vcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
blankLine (forall a. Bag a -> [a]
bagToList Bag SDoc
msgs))

-- | Make an unannotated error message with location info.
mkLocMessage :: Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessage :: Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessage = Maybe String -> Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessageAnn forall a. Maybe a
Nothing

-- | Make a possibly annotated error message with location info.
mkLocMessageAnn
  :: Maybe String                       -- ^ optional annotation
  -> Severity                           -- ^ severity
  -> SrcSpan                            -- ^ location
  -> SDoc                             -- ^ message
  -> SDoc
  -- Always print the location, even if it is unhelpful.  Error messages
  -- are supposed to be in a standard format, and one without a location
  -- would look strange.  Better to say explicitly "<no location info>".
mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessageAnn Maybe String
ann Severity
severity SrcSpan
locn SDoc
msg
    = forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Scheme
sdocColScheme forall a b. (a -> b) -> a -> b
$ \Scheme
col_scheme ->
      let locn' :: SDoc
locn' = forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocErrorSpans forall a b. (a -> b) -> a -> b
$ \case
                     Bool
True  -> forall a. Outputable a => a -> SDoc
ppr SrcSpan
locn
                     Bool
False -> forall a. Outputable a => a -> SDoc
ppr (SrcSpan -> SrcLoc
srcSpanStart SrcSpan
locn)

          sevColour :: PprColour
sevColour = Severity -> Scheme -> PprColour
getSeverityColour Severity
severity Scheme
col_scheme

          -- Add optional information
          optAnn :: SDoc
optAnn = case Maybe String
ann of
            Maybe String
Nothing -> String -> SDoc
text String
""
            Just String
i  -> String -> SDoc
text String
" [" SDoc -> SDoc -> SDoc
<> PprColour -> SDoc -> SDoc
coloured PprColour
sevColour (String -> SDoc
text String
i) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"]"

          -- Add prefixes, like    Foo.hs:34: warning:
          --                           <the warning message>
          header :: SDoc
header = SDoc
locn' SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+>
                   PprColour -> SDoc -> SDoc
coloured PprColour
sevColour SDoc
sevText SDoc -> SDoc -> SDoc
<> SDoc
optAnn

      in PprColour -> SDoc -> SDoc
coloured (Scheme -> PprColour
Col.sMessage Scheme
col_scheme)
                  (SDoc -> Int -> SDoc -> SDoc
hang (PprColour -> SDoc -> SDoc
coloured (Scheme -> PprColour
Col.sHeader Scheme
col_scheme) SDoc
header) Int
4
                        SDoc
msg)

  where
    sevText :: SDoc
sevText =
      case Severity
severity of
        Severity
SevWarning -> String -> SDoc
text String
"warning:"
        Severity
SevError   -> String -> SDoc
text String
"error:"
        Severity
SevFatal   -> String -> SDoc
text String
"fatal:"
        Severity
_          -> SDoc
empty

getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
getSeverityColour :: Severity -> Scheme -> PprColour
getSeverityColour Severity
SevWarning = Scheme -> PprColour
Col.sWarning
getSeverityColour Severity
SevError   = Scheme -> PprColour
Col.sError
getSeverityColour Severity
SevFatal   = Scheme -> PprColour
Col.sFatal
getSeverityColour Severity
_          = forall a b. a -> b -> a
const forall a. Monoid a => a
mempty

getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc
getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc
getCaretDiagnostic Severity
_ (UnhelpfulSpan UnhelpfulSpanReason
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure SDoc
empty
getCaretDiagnostic Severity
severity (RealSrcSpan RealSrcSpan
span Maybe BufSpan
_) =
  Maybe String -> SDoc
caretDiagnostic forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> Int -> IO (Maybe String)
getSrcLine (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
span) Int
row
  where
    getSrcLine :: FastString -> Int -> IO (Maybe String)
getSrcLine FastString
fn Int
i =
      Int -> String -> IO (Maybe String)
getLine Int
i (FastString -> String
unpackFS FastString
fn)
        forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
_ ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

    getLine :: Int -> String -> IO (Maybe String)
getLine Int
i String
fn = do
      -- StringBuffer has advantages over readFile:
      -- (a) no lazy IO, otherwise IO exceptions may occur in pure code
      -- (b) always UTF-8, rather than some system-dependent encoding
      --     (Haskell source code must be UTF-8 anyway)
      StringBuffer
content <- String -> IO StringBuffer
hGetStringBuffer String
fn
      case Int -> StringBuffer -> Maybe StringBuffer
atLine Int
i StringBuffer
content of
        Just StringBuffer
at_line -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          case String -> [String]
lines (Char -> Char
fix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StringBuffer -> Int -> String
lexemeToString StringBuffer
at_line (StringBuffer -> Int
len StringBuffer
at_line)) of
            String
srcLine : [String]
_ -> forall a. a -> Maybe a
Just String
srcLine
            [String]
_           -> forall a. Maybe a
Nothing
        Maybe StringBuffer
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

    -- allow user to visibly see that their code is incorrectly encoded
    -- (StringBuffer.nextChar uses \0 to represent undecodable characters)
    fix :: Char -> Char
fix Char
'\0' = Char
'\xfffd'
    fix Char
c    = Char
c

    row :: Int
row = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span
    rowStr :: String
rowStr = forall a. Show a => a -> String
show Int
row
    multiline :: Bool
multiline = Int
row forall a. Eq a => a -> a -> Bool
/= RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
span

    caretDiagnostic :: Maybe String -> SDoc
caretDiagnostic Maybe String
Nothing = SDoc
empty
    caretDiagnostic (Just String
srcLineWithNewline) =
      forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Scheme
sdocColSchemeforall a b. (a -> b) -> a -> b
$ \Scheme
col_scheme ->
      let sevColour :: PprColour
sevColour = Severity -> Scheme -> PprColour
getSeverityColour Severity
severity Scheme
col_scheme
          marginColour :: PprColour
marginColour = Scheme -> PprColour
Col.sMargin Scheme
col_scheme
      in
      PprColour -> SDoc -> SDoc
coloured PprColour
marginColour (String -> SDoc
text String
marginSpace) SDoc -> SDoc -> SDoc
<>
      String -> SDoc
text (String
"\n") SDoc -> SDoc -> SDoc
<>
      PprColour -> SDoc -> SDoc
coloured PprColour
marginColour (String -> SDoc
text String
marginRow) SDoc -> SDoc -> SDoc
<>
      String -> SDoc
text (String
" " forall a. [a] -> [a] -> [a]
++ String
srcLinePre) SDoc -> SDoc -> SDoc
<>
      PprColour -> SDoc -> SDoc
coloured PprColour
sevColour (String -> SDoc
text String
srcLineSpan) SDoc -> SDoc -> SDoc
<>
      String -> SDoc
text (String
srcLinePost forall a. [a] -> [a] -> [a]
++ String
"\n") SDoc -> SDoc -> SDoc
<>
      PprColour -> SDoc -> SDoc
coloured PprColour
marginColour (String -> SDoc
text String
marginSpace) SDoc -> SDoc -> SDoc
<>
      PprColour -> SDoc -> SDoc
coloured PprColour
sevColour (String -> SDoc
text (String
" " forall a. [a] -> [a] -> [a]
++ String
caretLine))

      where

        -- expand tabs in a device-independent manner #13664
        expandTabs :: Int -> Int -> ShowS
expandTabs Int
tabWidth Int
i String
s =
          case String
s of
            String
""        -> String
""
            Char
'\t' : String
cs -> forall a. Int -> a -> [a]
replicate Int
effectiveWidth Char
' ' forall a. [a] -> [a] -> [a]
++
                         Int -> Int -> ShowS
expandTabs Int
tabWidth (Int
i forall a. Num a => a -> a -> a
+ Int
effectiveWidth) String
cs
            Char
c    : String
cs -> Char
c forall a. a -> [a] -> [a]
: Int -> Int -> ShowS
expandTabs Int
tabWidth (Int
i forall a. Num a => a -> a -> a
+ Int
1) String
cs
          where effectiveWidth :: Int
effectiveWidth = Int
tabWidth forall a. Num a => a -> a -> a
- Int
i forall a. Integral a => a -> a -> a
`mod` Int
tabWidth

        srcLine :: String
srcLine = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Char
'\n') (Int -> Int -> ShowS
expandTabs Int
8 Int
0 String
srcLineWithNewline)

        start :: Int
start = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
span forall a. Num a => a -> a -> a
- Int
1
        end :: Int
end | Bool
multiline = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
srcLine
            | Bool
otherwise = RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
span forall a. Num a => a -> a -> a
- Int
1
        width :: Int
width = forall a. Ord a => a -> a -> a
max Int
1 (Int
end forall a. Num a => a -> a -> a
- Int
start)

        marginWidth :: Int
marginWidth = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
rowStr
        marginSpace :: String
marginSpace = forall a. Int -> a -> [a]
replicate Int
marginWidth Char
' ' forall a. [a] -> [a] -> [a]
++ String
" |"
        marginRow :: String
marginRow   = String
rowStr forall a. [a] -> [a] -> [a]
++ String
" |"

        (String
srcLinePre,  String
srcLineRest) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
start String
srcLine
        (String
srcLineSpan, String
srcLinePost) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
width String
srcLineRest

        caretEllipsis :: String
caretEllipsis | Bool
multiline = String
"..."
                      | Bool
otherwise = String
""
        caretLine :: String
caretLine = forall a. Int -> a -> [a]
replicate Int
start Char
' ' forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate Int
width Char
'^' forall a. [a] -> [a] -> [a]
++ String
caretEllipsis

makeIntoWarning :: WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning :: forall e. WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning WarnReason
reason MsgEnvelope e
err = MsgEnvelope e
err
    { errMsgSeverity :: Severity
errMsgSeverity = Severity
SevWarning
    , errMsgReason :: WarnReason
errMsgReason = WarnReason
reason }

--
-- Creating MsgEnvelope(s)
--

mk_err_msg
  :: Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg :: forall e.
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg Severity
sev SrcSpan
locn PrintUnqualified
print_unqual e
err
 = MsgEnvelope { errMsgSpan :: SrcSpan
errMsgSpan = SrcSpan
locn
               , errMsgContext :: PrintUnqualified
errMsgContext = PrintUnqualified
print_unqual
               , errMsgDiagnostic :: e
errMsgDiagnostic = e
err
               , errMsgSeverity :: Severity
errMsgSeverity = Severity
sev
               , errMsgReason :: WarnReason
errMsgReason = WarnReason
NoReason }

mkErr :: SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkErr :: forall e. SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkErr = forall e.
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg Severity
SevError

mkLongMsgEnvelope, mkLongWarnMsg   :: SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc
-- ^ A long (multi-line) error message
mkMsgEnvelope, mkWarnMsg           :: SrcSpan -> PrintUnqualified -> SDoc         -> MsgEnvelope DecoratedSDoc
-- ^ A short (one-line) error message
mkPlainMsgEnvelope, mkPlainWarnMsg :: SrcSpan ->                     SDoc         -> MsgEnvelope DecoratedSDoc
-- ^ Variant that doesn't care about qualified/unqualified names

mkLongMsgEnvelope :: SrcSpan
-> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc
mkLongMsgEnvelope   SrcSpan
locn PrintUnqualified
unqual SDoc
msg SDoc
extra = forall e.
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg Severity
SevError   SrcSpan
locn PrintUnqualified
unqual        ([SDoc] -> DecoratedSDoc
mkDecorated [SDoc
msg,SDoc
extra])
mkMsgEnvelope :: SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc
mkMsgEnvelope       SrcSpan
locn PrintUnqualified
unqual SDoc
msg       = forall e.
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg Severity
SevError   SrcSpan
locn PrintUnqualified
unqual        ([SDoc] -> DecoratedSDoc
mkDecorated [SDoc
msg])
mkPlainMsgEnvelope :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope  SrcSpan
locn        SDoc
msg       = forall e.
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg Severity
SevError   SrcSpan
locn PrintUnqualified
alwaysQualify ([SDoc] -> DecoratedSDoc
mkDecorated [SDoc
msg])
mkLongWarnMsg :: SrcSpan
-> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc
mkLongWarnMsg       SrcSpan
locn PrintUnqualified
unqual SDoc
msg SDoc
extra = forall e.
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg Severity
SevWarning SrcSpan
locn PrintUnqualified
unqual        ([SDoc] -> DecoratedSDoc
mkDecorated [SDoc
msg,SDoc
extra])
mkWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc
mkWarnMsg           SrcSpan
locn PrintUnqualified
unqual SDoc
msg       = forall e.
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg Severity
SevWarning SrcSpan
locn PrintUnqualified
unqual        ([SDoc] -> DecoratedSDoc
mkDecorated [SDoc
msg])
mkPlainWarnMsg :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainWarnMsg      SrcSpan
locn        SDoc
msg       = forall e.
Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg Severity
SevWarning SrcSpan
locn PrintUnqualified
alwaysQualify ([SDoc] -> DecoratedSDoc
mkDecorated [SDoc
msg])

--
-- Queries
--

isErrorMessage :: MsgEnvelope e -> Bool
isErrorMessage :: forall e. MsgEnvelope e -> Bool
isErrorMessage = (forall a. Eq a => a -> a -> Bool
== Severity
SevError) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. MsgEnvelope e -> Severity
errMsgSeverity

isWarningMessage :: MsgEnvelope e -> Bool
isWarningMessage :: forall e. MsgEnvelope e -> Bool
isWarningMessage = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. MsgEnvelope e -> Bool
isErrorMessage

errorsFound :: Messages e -> Bool
errorsFound :: forall e. Messages e -> Bool
errorsFound (Messages Bag (MsgEnvelope e)
msgs) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall e. MsgEnvelope e -> Bool
isErrorMessage Bag (MsgEnvelope e)
msgs

getWarningMessages :: Messages e -> Bag (MsgEnvelope e)
getWarningMessages :: forall e. Messages e -> Bag (MsgEnvelope e)
getWarningMessages (Messages Bag (MsgEnvelope e)
xs) = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> Bag a -> (Bag a, Bag a)
partitionBag forall e. MsgEnvelope e -> Bool
isWarningMessage Bag (MsgEnvelope e)
xs

getErrorMessages :: Messages e -> Bag (MsgEnvelope e)
getErrorMessages :: forall e. Messages e -> Bag (MsgEnvelope e)
getErrorMessages (Messages Bag (MsgEnvelope e)
xs) = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> Bag a -> (Bag a, Bag a)
partitionBag forall e. MsgEnvelope e -> Bool
isErrorMessage Bag (MsgEnvelope e)
xs

-- | Partitions the 'Messages' and returns a tuple which first element are the warnings, and the
-- second the errors.
partitionMessages :: Messages e -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))
partitionMessages :: forall e. Messages e -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))
partitionMessages (Messages Bag (MsgEnvelope e)
xs) = forall a. (a -> Bool) -> Bag a -> (Bag a, Bag a)
partitionBag forall e. MsgEnvelope e -> Bool
isWarningMessage Bag (MsgEnvelope e)
xs