{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}

module GHC.Types.Error
   ( -- * Messages
     Messages
   , mkMessages
   , getMessages
   , emptyMessages
   , isEmptyMessages
   , singleMessage
   , addMessage
   , unionMessages
   , unionManyMessages
   , MsgEnvelope (..)

   -- * Classifying Messages

   , MessageClass (..)
   , Severity (..)
   , Diagnostic (..)
   , DiagnosticMessage (..)
   , DiagnosticReason (..)
   , DiagnosticHint (..)
   , mkPlainDiagnostic
   , mkPlainError
   , mkDecoratedDiagnostic
   , mkDecoratedError

   -- * Hints and refactoring actions
   , GhcHint (..)
   , AvailableBindings(..)
   , LanguageExtensionHint(..)
   , suggestExtension
   , suggestExtensionWithInfo
   , suggestExtensions
   , suggestExtensionsWithInfo
   , suggestAnyExtension
   , suggestAnyExtensionWithInfo
   , useExtensionInOrderTo
   , noHints

    -- * Rendering Messages

   , SDoc
   , DecoratedSDoc (unDecorated)
   , mkDecorated, mkSimpleDecorated
   , unionDecoratedSDoc
   , mapDecoratedSDoc

   , pprMessageBag
   , mkLocMessage
   , mkLocMessageAnn
   , getCaretDiagnostic
   -- * Queries
   , isIntrinsicErrorMessage
   , isExtrinsicErrorMessage
   , isWarningMessage
   , getErrorMessages
   , getWarningMessages
   , partitionMessages
   , errorsFound
   , errorsOrFatalWarningsFound
   )
where

import GHC.Prelude

import GHC.Driver.Flags

import GHC.Data.Bag
import GHC.IO (catchException)
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 Data.Bifunctor
import Data.Foldable    ( fold )
import GHC.Types.Hint

{-
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). More specifically, every diagnostic has a
'DiagnosticReason', but a warning 'DiagnosticReason' might be associated with
'SevError', in the case of -Werror.

We rely on the 'Severity' to distinguish between a warning and an error.

'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].
--
-- /INVARIANT/: All the messages in this collection must be relevant, i.e.
-- their 'Severity' should /not/ be 'SevIgnore'. The smart constructor
-- 'mkMessages' will filter out any message which 'Severity' is 'SevIgnore'.
newtype Messages e = Messages { forall e. Messages e -> Bag (MsgEnvelope e)
getMessages :: Bag (MsgEnvelope e) }
  deriving newtype (NonEmpty (Messages e) -> Messages e
Messages e -> Messages e -> Messages e
(Messages e -> Messages e -> Messages e)
-> (NonEmpty (Messages e) -> Messages e)
-> (forall b. Integral b => b -> Messages e -> Messages e)
-> Semigroup (Messages e)
forall b. Integral b => b -> Messages e -> Messages e
forall e. NonEmpty (Messages e) -> Messages e
forall e. Messages e -> Messages e -> Messages e
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall e b. Integral b => b -> Messages e -> Messages e
$c<> :: forall e. Messages e -> Messages e -> Messages e
<> :: Messages e -> Messages e -> Messages e
$csconcat :: forall e. NonEmpty (Messages e) -> Messages e
sconcat :: NonEmpty (Messages e) -> Messages e
$cstimes :: forall e b. Integral b => b -> Messages e -> Messages e
stimes :: forall b. Integral b => b -> Messages e -> Messages e
Semigroup, Semigroup (Messages e)
Messages e
Semigroup (Messages e)
-> Messages e
-> (Messages e -> Messages e -> Messages e)
-> ([Messages e] -> Messages e)
-> Monoid (Messages e)
[Messages e] -> Messages e
Messages e -> Messages e -> Messages e
forall e. Semigroup (Messages e)
forall e. Messages e
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall e. [Messages e] -> Messages e
forall e. Messages e -> Messages e -> Messages e
$cmempty :: forall e. Messages e
mempty :: Messages e
$cmappend :: forall e. Messages e -> Messages e -> Messages e
mappend :: Messages e -> Messages e -> Messages e
$cmconcat :: forall e. [Messages e] -> Messages e
mconcat :: [Messages e] -> Messages e
Monoid)
  deriving stock ((forall a b. (a -> b) -> Messages a -> Messages b)
-> (forall a b. a -> Messages b -> Messages a) -> Functor Messages
forall a b. a -> Messages b -> Messages a
forall a b. (a -> b) -> Messages a -> Messages b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Messages a -> Messages b
fmap :: forall a b. (a -> b) -> Messages a -> Messages b
$c<$ :: forall a b. a -> Messages b -> Messages a
<$ :: forall a b. a -> Messages b -> Messages a
Functor, (forall m. Monoid m => Messages m -> m)
-> (forall m a. Monoid m => (a -> m) -> Messages a -> m)
-> (forall m a. Monoid m => (a -> m) -> Messages a -> m)
-> (forall a b. (a -> b -> b) -> b -> Messages a -> b)
-> (forall a b. (a -> b -> b) -> b -> Messages a -> b)
-> (forall b a. (b -> a -> b) -> b -> Messages a -> b)
-> (forall b a. (b -> a -> b) -> b -> Messages a -> b)
-> (forall a. (a -> a -> a) -> Messages a -> a)
-> (forall a. (a -> a -> a) -> Messages a -> a)
-> (forall a. Messages a -> [a])
-> (forall a. Messages a -> Bool)
-> (forall a. Messages a -> Int)
-> (forall a. Eq a => a -> Messages a -> Bool)
-> (forall a. Ord a => Messages a -> a)
-> (forall a. Ord a => Messages a -> a)
-> (forall a. Num a => Messages a -> a)
-> (forall a. Num a => Messages a -> a)
-> Foldable Messages
forall a. Eq a => a -> Messages a -> Bool
forall a. Num a => Messages a -> a
forall a. Ord a => Messages a -> a
forall m. Monoid m => Messages m -> m
forall a. Messages a -> Bool
forall a. Messages a -> Int
forall a. Messages a -> [a]
forall a. (a -> a -> a) -> Messages a -> a
forall m a. Monoid m => (a -> m) -> Messages a -> m
forall b a. (b -> a -> b) -> b -> Messages a -> b
forall a b. (a -> b -> b) -> b -> Messages a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Messages m -> m
fold :: forall m. Monoid m => Messages m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Messages a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Messages a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Messages a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Messages a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Messages a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Messages a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Messages a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Messages a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Messages a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Messages a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Messages a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Messages a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Messages a -> a
foldr1 :: forall a. (a -> a -> a) -> Messages a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Messages a -> a
foldl1 :: forall a. (a -> a -> a) -> Messages a -> a
$ctoList :: forall a. Messages a -> [a]
toList :: forall a. Messages a -> [a]
$cnull :: forall a. Messages a -> Bool
null :: forall a. Messages a -> Bool
$clength :: forall a. Messages a -> Int
length :: forall a. Messages a -> Int
$celem :: forall a. Eq a => a -> Messages a -> Bool
elem :: forall a. Eq a => a -> Messages a -> Bool
$cmaximum :: forall a. Ord a => Messages a -> a
maximum :: forall a. Ord a => Messages a -> a
$cminimum :: forall a. Ord a => Messages a -> a
minimum :: forall a. Ord a => Messages a -> a
$csum :: forall a. Num a => Messages a -> a
sum :: forall a. Num a => Messages a -> a
$cproduct :: forall a. Num a => Messages a -> a
product :: forall a. Num a => Messages a -> a
Foldable, Functor Messages
Foldable Messages
Functor Messages
-> Foldable Messages
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Messages a -> f (Messages b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Messages (f a) -> f (Messages a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Messages a -> m (Messages b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Messages (m a) -> m (Messages a))
-> Traversable Messages
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Messages (m a) -> m (Messages a)
forall (f :: * -> *) a.
Applicative f =>
Messages (f a) -> f (Messages a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Messages a -> m (Messages b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Messages a -> f (Messages b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Messages a -> f (Messages b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Messages a -> f (Messages b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Messages (f a) -> f (Messages a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Messages (f a) -> f (Messages a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Messages a -> m (Messages b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Messages a -> m (Messages b)
$csequence :: forall (m :: * -> *) a. Monad m => Messages (m a) -> m (Messages a)
sequence :: forall (m :: * -> *) a. Monad m => Messages (m a) -> m (Messages a)
Traversable)

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

mkMessages :: Bag (MsgEnvelope e) -> Messages e
mkMessages :: forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages = Bag (MsgEnvelope e) -> Messages e
forall e. Bag (MsgEnvelope e) -> Messages e
Messages (Bag (MsgEnvelope e) -> Messages e)
-> (Bag (MsgEnvelope e) -> Bag (MsgEnvelope e))
-> Bag (MsgEnvelope e)
-> Messages e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MsgEnvelope e -> Bool)
-> Bag (MsgEnvelope e) -> Bag (MsgEnvelope e)
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag MsgEnvelope e -> Bool
forall e. MsgEnvelope e -> Bool
interesting
  where
    interesting :: MsgEnvelope e -> Bool
    interesting :: forall e. MsgEnvelope e -> Bool
interesting = Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
(/=) Severity
SevIgnore (Severity -> Bool)
-> (MsgEnvelope e -> Severity) -> MsgEnvelope e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope e -> Severity
forall e. MsgEnvelope e -> Severity
errMsgSeverity

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

singleMessage :: MsgEnvelope e -> Messages e
singleMessage :: forall e. MsgEnvelope e -> Messages e
singleMessage MsgEnvelope e
e = MsgEnvelope e -> Messages e -> Messages e
forall e. MsgEnvelope e -> Messages e -> Messages e
addMessage MsgEnvelope e
e Messages e
forall e. Messages e
emptyMessages

instance Diagnostic e => Outputable (Messages e) where
  ppr :: Messages e -> SDoc
ppr Messages e
msgs = SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat ((MsgEnvelope e -> SDoc) -> [MsgEnvelope e] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map MsgEnvelope e -> SDoc
ppr_one (Bag (MsgEnvelope e) -> [MsgEnvelope e]
forall a. Bag a -> [a]
bagToList (Messages e -> Bag (MsgEnvelope e)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages Messages e
msgs))))
     where
       ppr_one :: MsgEnvelope e -> SDoc
       ppr_one :: MsgEnvelope e -> SDoc
ppr_one MsgEnvelope e
envelope = e -> SDoc
forall e. Diagnostic e => e -> SDoc
pprDiagnostic (MsgEnvelope e -> e
forall e. MsgEnvelope e -> e
errMsgDiagnostic MsgEnvelope e
envelope)

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

Discarding a 'SevIgnore' message from 'addMessage' and 'unionMessages' is just
an optimisation, as GHC would /also/ suppress any diagnostic which severity is
'SevIgnore' before printing the message: See for example 'putLogMsg' and
'defaultLogAction'.

-}

-- | Adds a 'Message' to the input collection of messages.
-- See Note [Discarding Messages].
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)
  | Severity
SevIgnore <- MsgEnvelope e -> Severity
forall e. MsgEnvelope e -> Severity
errMsgSeverity MsgEnvelope e
x = Bag (MsgEnvelope e) -> Messages e
forall e. Bag (MsgEnvelope e) -> Messages e
Messages Bag (MsgEnvelope e)
xs
  | Bool
otherwise                     = Bag (MsgEnvelope e) -> Messages e
forall e. Bag (MsgEnvelope e) -> Messages e
Messages (MsgEnvelope e
x MsgEnvelope e -> Bag (MsgEnvelope e) -> Bag (MsgEnvelope e)
forall a. a -> Bag a -> Bag a
`consBag` Bag (MsgEnvelope e)
xs)

-- | Joins two collections of messages together.
-- See Note [Discarding Messages].
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) =
  Bag (MsgEnvelope e) -> Messages e
forall e. Bag (MsgEnvelope e) -> Messages e
Messages (Bag (MsgEnvelope e)
msgs1 Bag (MsgEnvelope e) -> Bag (MsgEnvelope e) -> Bag (MsgEnvelope e)
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (MsgEnvelope e)
msgs2)

-- | Joins many 'Messages's together
unionManyMessages :: Foldable f => f (Messages e) -> Messages e
unionManyMessages :: forall (f :: * -> *) e. Foldable f => f (Messages e) -> Messages e
unionManyMessages = f (Messages e) -> Messages e
forall m. Monoid m => f m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold

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

-- | Creates a new 'DecoratedSDoc' out of a single 'SDoc'
mkSimpleDecorated :: SDoc -> DecoratedSDoc
mkSimpleDecorated :: SDoc -> DecoratedSDoc
mkSimpleDecorated SDoc
doc = [SDoc] -> DecoratedSDoc
Decorated [SDoc
doc]

-- | Joins two 'DecoratedSDoc' together. The resulting 'DecoratedSDoc'
-- will have a number of entries which is the sum of the lengths of
-- the input.
unionDecoratedSDoc :: DecoratedSDoc -> DecoratedSDoc -> DecoratedSDoc
unionDecoratedSDoc :: DecoratedSDoc -> DecoratedSDoc -> DecoratedSDoc
unionDecoratedSDoc (Decorated [SDoc]
s1) (Decorated [SDoc]
s2) =
  [SDoc] -> DecoratedSDoc
Decorated ([SDoc]
s1 [SDoc] -> [SDoc] -> [SDoc]
forall a. Monoid a => a -> a -> a
`mappend` [SDoc]
s2)

-- | Apply a transformation function to all elements of a 'DecoratedSDoc'.
mapDecoratedSDoc :: (SDoc -> SDoc) -> DecoratedSDoc -> DecoratedSDoc
mapDecoratedSDoc :: (SDoc -> SDoc) -> DecoratedSDoc -> DecoratedSDoc
mapDecoratedSDoc SDoc -> SDoc
f (Decorated [SDoc]
s1) =
  [SDoc] -> DecoratedSDoc
Decorated ((SDoc -> SDoc) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map SDoc -> SDoc
f [SDoc]
s1)

{-
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's boundaries (i.e.
from the 'Driver' upwards).

For now (see #18516) this class has few 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 TcRnDiagnostic
    = TcRnOutOfScope ..
    | ..

  newtype TcRnMessage = TcRnMessage (DiagnosticMessage TcRnDiagnostic)

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

  instance Diagnostic TcRnDiagnostic where
    diagnosticMessage (TcRnMessage msg) = case diagMessage msg of
      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 'Diagnostic'
constraint.

-}

-- | A class identifying a diagnostic.
-- Dictionary.com defines a diagnostic as:
--
-- \"a message output by a computer diagnosing an error in a computer program,
-- computer system, or component device\".
--
-- A 'Diagnostic' carries the /actual/ description of the message (which, in
-- GHC's case, it can be an error or a warning) and the /reason/ why such
-- message was generated in the first place. See also Note [Rendering
-- Messages].
class Diagnostic a where
  diagnosticMessage :: a -> DecoratedSDoc
  diagnosticReason  :: a -> DiagnosticReason
  diagnosticHints   :: a -> [GhcHint]

pprDiagnostic :: Diagnostic e => e -> SDoc
pprDiagnostic :: forall e. Diagnostic e => e -> SDoc
pprDiagnostic e
e = [SDoc] -> SDoc
vcat [ DiagnosticReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr (e -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason e
e)
                       , Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat (DecoratedSDoc -> [SDoc]
unDecorated (e -> DecoratedSDoc
forall a. Diagnostic a => a -> DecoratedSDoc
diagnosticMessage e
e))) ]

-- | A generic 'Hint' message, to be used with 'DiagnosticMessage'.
data DiagnosticHint = DiagnosticHint !SDoc

instance Outputable DiagnosticHint where
  ppr :: DiagnosticHint -> SDoc
ppr (DiagnosticHint SDoc
msg) = SDoc
msg

-- | A generic 'Diagnostic' message, without any further classification or
-- provenance: By looking at a 'DiagnosticMessage' we don't know neither
-- /where/ it was generated nor how to intepret its payload (as it's just a
-- structured document). All we can do is to print it out and look at its
-- 'DiagnosticReason'.
data DiagnosticMessage = DiagnosticMessage
  { DiagnosticMessage -> DecoratedSDoc
diagMessage :: !DecoratedSDoc
  , DiagnosticMessage -> DiagnosticReason
diagReason  :: !DiagnosticReason
  , DiagnosticMessage -> [GhcHint]
diagHints   :: [GhcHint]
  }

instance Diagnostic DiagnosticMessage where
  diagnosticMessage :: DiagnosticMessage -> DecoratedSDoc
diagnosticMessage = DiagnosticMessage -> DecoratedSDoc
diagMessage
  diagnosticReason :: DiagnosticMessage -> DiagnosticReason
diagnosticReason  = DiagnosticMessage -> DiagnosticReason
diagReason
  diagnosticHints :: DiagnosticMessage -> [GhcHint]
diagnosticHints   = DiagnosticMessage -> [GhcHint]
diagHints

-- | Helper function to use when no hints can be provided. Currently this function
-- can be used to construct plain 'DiagnosticMessage' and add hints to them, but
-- once #18516 will be fully executed, the main usage of this function would be in
-- the implementation of the 'diagnosticHints' typeclass method, to report the fact
-- that a particular 'Diagnostic' has no hints.
noHints :: [GhcHint]
noHints :: [GhcHint]
noHints = [GhcHint]
forall a. Monoid a => a
mempty

mkPlainDiagnostic :: DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic :: DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
rea [GhcHint]
hints SDoc
doc = DecoratedSDoc -> DiagnosticReason -> [GhcHint] -> DiagnosticMessage
DiagnosticMessage (SDoc -> DecoratedSDoc
mkSimpleDecorated SDoc
doc) DiagnosticReason
rea [GhcHint]
hints

-- | Create an error 'DiagnosticMessage' holding just a single 'SDoc'
mkPlainError :: [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError :: [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
hints SDoc
doc = DecoratedSDoc -> DiagnosticReason -> [GhcHint] -> DiagnosticMessage
DiagnosticMessage (SDoc -> DecoratedSDoc
mkSimpleDecorated SDoc
doc) DiagnosticReason
ErrorWithoutFlag [GhcHint]
hints

-- | Create a 'DiagnosticMessage' from a list of bulleted SDocs and a 'DiagnosticReason'
mkDecoratedDiagnostic :: DiagnosticReason -> [GhcHint] -> [SDoc] -> DiagnosticMessage
mkDecoratedDiagnostic :: DiagnosticReason -> [GhcHint] -> [SDoc] -> DiagnosticMessage
mkDecoratedDiagnostic DiagnosticReason
rea [GhcHint]
hints [SDoc]
docs = DecoratedSDoc -> DiagnosticReason -> [GhcHint] -> DiagnosticMessage
DiagnosticMessage ([SDoc] -> DecoratedSDoc
mkDecorated [SDoc]
docs) DiagnosticReason
rea [GhcHint]
hints

-- | Create an error 'DiagnosticMessage' from a list of bulleted SDocs
mkDecoratedError :: [GhcHint] -> [SDoc] -> DiagnosticMessage
mkDecoratedError :: [GhcHint] -> [SDoc] -> DiagnosticMessage
mkDecoratedError [GhcHint]
hints [SDoc]
docs = DecoratedSDoc -> DiagnosticReason -> [GhcHint] -> DiagnosticMessage
DiagnosticMessage ([SDoc] -> DecoratedSDoc
mkDecorated [SDoc]
docs) DiagnosticReason
ErrorWithoutFlag [GhcHint]
hints

-- | The reason /why/ a 'Diagnostic' was emitted in the first place.
-- Diagnostic messages are born within GHC with a very precise reason, which
-- can be completely statically-computed (i.e. this is an error or a warning
-- no matter what), or influenced by the specific state of the 'DynFlags' at
-- the moment of the creation of a new 'Diagnostic'. For example, a parsing
-- error is /always/ going to be an error, whereas a 'WarningWithoutFlag
-- Opt_WarnUnusedImports' might turn into an error due to '-Werror' or
-- '-Werror=warn-unused-imports'. Interpreting a 'DiagnosticReason' together
-- with its associated 'Severity' gives us the full picture.
data DiagnosticReason
  = WarningWithoutFlag
  -- ^ Born as a warning.
  | WarningWithFlag !WarningFlag
  -- ^ Warning was enabled with the flag.
  | ErrorWithoutFlag
  -- ^ Born as an error.
  deriving (DiagnosticReason -> DiagnosticReason -> Bool
(DiagnosticReason -> DiagnosticReason -> Bool)
-> (DiagnosticReason -> DiagnosticReason -> Bool)
-> Eq DiagnosticReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DiagnosticReason -> DiagnosticReason -> Bool
== :: DiagnosticReason -> DiagnosticReason -> Bool
$c/= :: DiagnosticReason -> DiagnosticReason -> Bool
/= :: DiagnosticReason -> DiagnosticReason -> Bool
Eq, Int -> DiagnosticReason -> ShowS
[DiagnosticReason] -> ShowS
DiagnosticReason -> String
(Int -> DiagnosticReason -> ShowS)
-> (DiagnosticReason -> String)
-> ([DiagnosticReason] -> ShowS)
-> Show DiagnosticReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DiagnosticReason -> ShowS
showsPrec :: Int -> DiagnosticReason -> ShowS
$cshow :: DiagnosticReason -> String
show :: DiagnosticReason -> String
$cshowList :: [DiagnosticReason] -> ShowS
showList :: [DiagnosticReason] -> ShowS
Show)

instance Outputable DiagnosticReason where
  ppr :: DiagnosticReason -> SDoc
ppr = \case
    DiagnosticReason
WarningWithoutFlag  -> String -> SDoc
text String
"WarningWithoutFlag"
    WarningWithFlag WarningFlag
wf  -> String -> SDoc
text (String
"WarningWithFlag " String -> ShowS
forall a. [a] -> [a] -> [a]
++ WarningFlag -> String
forall a. Show a => a -> String
show WarningFlag
wf)
    DiagnosticReason
ErrorWithoutFlag    -> String -> SDoc
text String
"ErrorWithoutFlag"

-- | 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, 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
   } deriving ((forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b)
-> (forall a b. a -> MsgEnvelope b -> MsgEnvelope a)
-> Functor MsgEnvelope
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
$cfmap :: forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
fmap :: forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
$c<$ :: forall a b. a -> MsgEnvelope b -> MsgEnvelope a
<$ :: forall a b. a -> MsgEnvelope b -> MsgEnvelope a
Functor, (forall m. Monoid m => MsgEnvelope m -> m)
-> (forall m a. Monoid m => (a -> m) -> MsgEnvelope a -> m)
-> (forall m a. Monoid m => (a -> m) -> MsgEnvelope a -> m)
-> (forall a b. (a -> b -> b) -> b -> MsgEnvelope a -> b)
-> (forall a b. (a -> b -> b) -> b -> MsgEnvelope a -> b)
-> (forall b a. (b -> a -> b) -> b -> MsgEnvelope a -> b)
-> (forall b a. (b -> a -> b) -> b -> MsgEnvelope a -> b)
-> (forall a. (a -> a -> a) -> MsgEnvelope a -> a)
-> (forall a. (a -> a -> a) -> MsgEnvelope a -> a)
-> (forall a. MsgEnvelope a -> [a])
-> (forall e. MsgEnvelope e -> Bool)
-> (forall a. MsgEnvelope a -> Int)
-> (forall a. Eq a => a -> MsgEnvelope a -> Bool)
-> (forall a. Ord a => MsgEnvelope a -> a)
-> (forall a. Ord a => MsgEnvelope a -> a)
-> (forall a. Num a => MsgEnvelope a -> a)
-> (forall a. Num a => MsgEnvelope a -> a)
-> Foldable MsgEnvelope
forall a. Eq a => a -> MsgEnvelope a -> Bool
forall a. Num a => MsgEnvelope a -> a
forall a. Ord a => MsgEnvelope a -> a
forall m. Monoid m => MsgEnvelope m -> m
forall e. MsgEnvelope e -> Bool
forall a. MsgEnvelope a -> Int
forall a. MsgEnvelope a -> [a]
forall a. (a -> a -> a) -> MsgEnvelope a -> a
forall m a. Monoid m => (a -> m) -> MsgEnvelope a -> m
forall b a. (b -> a -> b) -> b -> MsgEnvelope a -> b
forall a b. (a -> b -> b) -> b -> MsgEnvelope a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => MsgEnvelope m -> m
fold :: forall m. Monoid m => MsgEnvelope m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> MsgEnvelope a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> MsgEnvelope a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> MsgEnvelope a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> MsgEnvelope a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> MsgEnvelope a -> b
foldr :: forall a b. (a -> b -> b) -> b -> MsgEnvelope a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> MsgEnvelope a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> MsgEnvelope a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> MsgEnvelope a -> b
foldl :: forall b a. (b -> a -> b) -> b -> MsgEnvelope a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> MsgEnvelope a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> MsgEnvelope a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> MsgEnvelope a -> a
foldr1 :: forall a. (a -> a -> a) -> MsgEnvelope a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> MsgEnvelope a -> a
foldl1 :: forall a. (a -> a -> a) -> MsgEnvelope a -> a
$ctoList :: forall a. MsgEnvelope a -> [a]
toList :: forall a. MsgEnvelope a -> [a]
$cnull :: forall e. MsgEnvelope e -> Bool
null :: forall e. MsgEnvelope e -> Bool
$clength :: forall a. MsgEnvelope a -> Int
length :: forall a. MsgEnvelope a -> Int
$celem :: forall a. Eq a => a -> MsgEnvelope a -> Bool
elem :: forall a. Eq a => a -> MsgEnvelope a -> Bool
$cmaximum :: forall a. Ord a => MsgEnvelope a -> a
maximum :: forall a. Ord a => MsgEnvelope a -> a
$cminimum :: forall a. Ord a => MsgEnvelope a -> a
minimum :: forall a. Ord a => MsgEnvelope a -> a
$csum :: forall a. Num a => MsgEnvelope a -> a
sum :: forall a. Num a => MsgEnvelope a -> a
$cproduct :: forall a. Num a => MsgEnvelope a -> a
product :: forall a. Num a => MsgEnvelope a -> a
Foldable, Functor MsgEnvelope
Foldable MsgEnvelope
Functor MsgEnvelope
-> Foldable MsgEnvelope
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> MsgEnvelope a -> f (MsgEnvelope b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    MsgEnvelope (f a) -> f (MsgEnvelope a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> MsgEnvelope a -> m (MsgEnvelope b))
-> (forall (m :: * -> *) a.
    Monad m =>
    MsgEnvelope (m a) -> m (MsgEnvelope a))
-> Traversable MsgEnvelope
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
MsgEnvelope (m a) -> m (MsgEnvelope a)
forall (f :: * -> *) a.
Applicative f =>
MsgEnvelope (f a) -> f (MsgEnvelope a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MsgEnvelope a -> m (MsgEnvelope b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MsgEnvelope a -> f (MsgEnvelope b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MsgEnvelope a -> f (MsgEnvelope b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MsgEnvelope a -> f (MsgEnvelope b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
MsgEnvelope (f a) -> f (MsgEnvelope a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
MsgEnvelope (f a) -> f (MsgEnvelope a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MsgEnvelope a -> m (MsgEnvelope b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MsgEnvelope a -> m (MsgEnvelope b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
MsgEnvelope (m a) -> m (MsgEnvelope a)
sequence :: forall (m :: * -> *) a.
Monad m =>
MsgEnvelope (m a) -> m (MsgEnvelope a)
Traversable)

-- | The class for a diagnostic message. The main purpose is to classify a
-- message within GHC, to distinguish it from a debug/dump message vs a proper
-- diagnostic, for which we include a 'DiagnosticReason'.
data MessageClass
  = MCOutput
  | MCFatal
  | MCInteractive

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

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

  | MCDiagnostic Severity DiagnosticReason
    -- ^ Diagnostics from the compiler. This constructor is very powerful as
    -- it allows the construction of a 'MessageClass' with a completely
    -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such,
    -- users are encouraged to use the 'mkMCDiagnostic' smart constructor
    -- instead. Use this constructor directly only if you need to construct
    -- and manipulate diagnostic messages directly, for example inside
    -- 'GHC.Utils.Error'. In all the other circumstances, /especially/ when
    -- emitting compiler diagnostics, use the smart constructor.
  deriving (MessageClass -> MessageClass -> Bool
(MessageClass -> MessageClass -> Bool)
-> (MessageClass -> MessageClass -> Bool) -> Eq MessageClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MessageClass -> MessageClass -> Bool
== :: MessageClass -> MessageClass -> Bool
$c/= :: MessageClass -> MessageClass -> Bool
/= :: MessageClass -> MessageClass -> Bool
Eq, Int -> MessageClass -> ShowS
[MessageClass] -> ShowS
MessageClass -> String
(Int -> MessageClass -> ShowS)
-> (MessageClass -> String)
-> ([MessageClass] -> ShowS)
-> Show MessageClass
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MessageClass -> ShowS
showsPrec :: Int -> MessageClass -> ShowS
$cshow :: MessageClass -> String
show :: MessageClass -> String
$cshowList :: [MessageClass] -> ShowS
showList :: [MessageClass] -> ShowS
Show)

{- Note [Suppressing Messages]

The 'SevIgnore' constructor is used to generate messages for diagnostics which
are meant to be suppressed and not reported to the user: the classic example
are warnings for which the user didn't enable the corresponding 'WarningFlag',
so GHC shouldn't print them.

A different approach would be to extend the zoo of 'mkMsgEnvelope' functions
to return a 'Maybe (MsgEnvelope e)', so that we won't need to even create the
message to begin with. Both approaches have been evaluated, but we settled on
the "SevIgnore one" for a number of reasons:

* It's less invasive to deal with;
* It plays slightly better with deferred diagnostics (see 'GHC.Tc.Errors') as
  for those we need to be able to /always/ produce a message (so that is
  reported at runtime);
* It gives us more freedom: we can still decide to drop a 'SevIgnore' message
  at leisure, or we can decide to keep it around until the last moment. Maybe
  in the future we would need to turn a 'SevIgnore' into something else, for
  example to "unsuppress" diagnostics if a flag is set: with this approach, we
  have more leeway to accommodate new features.

-}


-- | Used to describe warnings and errors
--   o The message has a file\/line\/column heading,
--     plus "warning:" or "error:",
--     added by mkLocMessage
--   o With 'SevIgnore' the message is suppressed
--   o Output is intended for end users
data Severity
  = SevIgnore
  -- ^ Ignore this message, for example in
  -- case of suppression of warnings users
  -- don't want to see. See Note [Suppressing Messages]
  | SevWarning
  | SevError
  deriving (Severity -> Severity -> Bool
(Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool) -> Eq Severity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Severity -> Severity -> Bool
== :: Severity -> Severity -> Bool
$c/= :: Severity -> Severity -> Bool
/= :: Severity -> Severity -> Bool
Eq, Int -> Severity -> ShowS
[Severity] -> ShowS
Severity -> String
(Int -> Severity -> ShowS)
-> (Severity -> String) -> ([Severity] -> ShowS) -> Show Severity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Severity -> ShowS
showsPrec :: Int -> Severity -> ShowS
$cshow :: Severity -> String
show :: Severity -> String
$cshowList :: [Severity] -> ShowS
showList :: [Severity] -> ShowS
Show)

instance Outputable Severity where
  ppr :: Severity -> SDoc
ppr = \case
    Severity
SevIgnore  -> String -> SDoc
text String
"SevIgnore"
    Severity
SevWarning -> String -> SDoc
text String
"SevWarning"
    Severity
SevError   -> String -> SDoc
text String
"SevError"

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

instance ToJson MessageClass where
  json :: MessageClass -> JsonDoc
json MessageClass
MCOutput = String -> JsonDoc
JSString String
"MCOutput"
  json MessageClass
MCFatal  = String -> JsonDoc
JSString String
"MCFatal"
  json MessageClass
MCInteractive = String -> JsonDoc
JSString String
"MCInteractive"
  json MessageClass
MCDump = String -> JsonDoc
JSString String
"MCDump"
  json MessageClass
MCInfo = String -> JsonDoc
JSString String
"MCInfo"
  json (MCDiagnostic Severity
sev DiagnosticReason
reason) =
    String -> JsonDoc
JSString (String -> JsonDoc) -> String -> JsonDoc
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"MCDiagnostic" SDoc -> SDoc -> SDoc
<+> Severity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Severity
sev SDoc -> SDoc -> SDoc
<+> DiagnosticReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr DiagnosticReason
reason)

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

-- | Shows an 'MsgEnvelope'.
showMsgEnvelope :: Diagnostic a => MsgEnvelope a -> String
showMsgEnvelope :: forall a. Diagnostic a => MsgEnvelope a -> String
showMsgEnvelope MsgEnvelope a
err =
  SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext ([SDoc] -> SDoc
vcat (DecoratedSDoc -> [SDoc]
unDecorated (DecoratedSDoc -> [SDoc]) -> (a -> DecoratedSDoc) -> a -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DecoratedSDoc
forall a. Diagnostic a => a -> DecoratedSDoc
diagnosticMessage (a -> [SDoc]) -> a -> [SDoc]
forall a b. (a -> b) -> a -> b
$ MsgEnvelope a -> a
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 (Bag SDoc -> [SDoc]
forall a. Bag a -> [a]
bagToList Bag SDoc
msgs))

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

-- | Make a possibly annotated error message with location info.
mkLocMessageAnn
  :: Maybe String                       -- ^ optional annotation
  -> MessageClass                       -- ^ What kind of message?
  -> 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 -> MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessageAnn Maybe String
ann MessageClass
msg_class SrcSpan
locn SDoc
msg
    = (SDocContext -> Scheme) -> (Scheme -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Scheme
sdocColScheme ((Scheme -> SDoc) -> SDoc) -> (Scheme -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \Scheme
col_scheme ->
      let locn' :: SDoc
locn' = (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocErrorSpans ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \case
                     Bool
True  -> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
locn
                     Bool
False -> SrcLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpan -> SrcLoc
srcSpanStart SrcSpan
locn)

          msgColour :: PprColour
msgColour = MessageClass -> Scheme -> PprColour
getMessageClassColour MessageClass
msg_class 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
msgColour (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
msgColour SDoc
msgText 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
    msgText :: SDoc
msgText =
      case MessageClass
msg_class of
        MCDiagnostic Severity
SevError DiagnosticReason
_reason   -> String -> SDoc
text String
"error:"
        MCDiagnostic Severity
SevWarning DiagnosticReason
_reason -> String -> SDoc
text String
"warning:"
        MessageClass
MCFatal                         -> String -> SDoc
text String
"fatal:"
        MessageClass
_                               -> SDoc
empty

getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour
getMessageClassColour :: MessageClass -> Scheme -> PprColour
getMessageClassColour (MCDiagnostic Severity
SevError DiagnosticReason
_reason)   = Scheme -> PprColour
Col.sError
getMessageClassColour (MCDiagnostic Severity
SevWarning DiagnosticReason
_reason) = Scheme -> PprColour
Col.sWarning
getMessageClassColour MessageClass
MCFatal                           = Scheme -> PprColour
Col.sFatal
getMessageClassColour MessageClass
_                                 = PprColour -> Scheme -> PprColour
forall a b. a -> b -> a
const PprColour
forall a. Monoid a => a
mempty

getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc
getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc
getCaretDiagnostic MessageClass
_ (UnhelpfulSpan UnhelpfulSpanReason
_) = SDoc -> IO SDoc
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SDoc
empty
getCaretDiagnostic MessageClass
msg_class (RealSrcSpan RealSrcSpan
span Maybe BufSpan
_) =
  Maybe String -> SDoc
caretDiagnostic (Maybe String -> SDoc) -> IO (Maybe String) -> IO SDoc
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)
        IO (Maybe String)
-> (IOError -> IO (Maybe String)) -> IO (Maybe String)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catchException` \(IOError
_ :: IOError) ->
          Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
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 -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$
          case String -> [String]
lines (Char -> Char
fix (Char -> Char) -> ShowS
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]
_ -> String -> Maybe String
forall a. a -> Maybe a
Just String
srcLine
            [String]
_           -> Maybe String
forall a. Maybe a
Nothing
        Maybe StringBuffer
_ -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
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 = Int -> String
forall a. Show a => a -> String
show Int
row
    multiline :: Bool
multiline = Int
row Int -> Int -> Bool
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) =
      (SDocContext -> Scheme) -> (Scheme -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Scheme
sdocColScheme((Scheme -> SDoc) -> SDoc) -> (Scheme -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \Scheme
col_scheme ->
      let sevColour :: PprColour
sevColour = MessageClass -> Scheme -> PprColour
getMessageClassColour MessageClass
msg_class 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
" " String -> ShowS
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 String -> ShowS
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
" " String -> ShowS
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 -> Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
effectiveWidth Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         Int -> Int -> ShowS
expandTabs Int
tabWidth (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
effectiveWidth) String
cs
            Char
c    : String
cs -> Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> Int -> ShowS
expandTabs Int
tabWidth (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String
cs
          where effectiveWidth :: Int
effectiveWidth = Int
tabWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
tabWidth

        srcLine :: String
srcLine = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        end :: Int
end | Bool
multiline = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
srcLine
            | Bool
otherwise = RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
span Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        width :: Int
width = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start)

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

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

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

--
-- Queries
--

{- Note [Intrinsic And Extrinsic Failures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We distinguish between /intrinsic/ and /extrinsic/ failures. We classify in
the former category those diagnostics which are /essentially/ failures, and
their nature can't be changed. This is the case for 'ErrorWithoutFlag'. We
classify as /extrinsic/ all those diagnostics (like fatal warnings) which are
born as warnings but which are still failures under particular 'DynFlags'
settings. It's important to be aware of such logic distinction, because when
we are inside the typechecker or the desugarer, we are interested about
intrinsic errors, and to bail out as soon as we find one of them. Conversely,
if we find an /extrinsic/ one, for example because a particular 'WarningFlag'
makes a warning into an error, we /don't/ want to bail out, that's still not the
right time to do so: Rather, we want to first collect all the diagnostics, and
later classify and report them appropriately (in the driver).
-}

-- | Returns 'True' if this is, intrinsically, a failure. See
-- Note [Intrinsic And Extrinsic Failures].
isIntrinsicErrorMessage :: Diagnostic e => MsgEnvelope e -> Bool
isIntrinsicErrorMessage :: forall e. Diagnostic e => MsgEnvelope e -> Bool
isIntrinsicErrorMessage = DiagnosticReason -> DiagnosticReason -> Bool
forall a. Eq a => a -> a -> Bool
(==) DiagnosticReason
ErrorWithoutFlag (DiagnosticReason -> Bool)
-> (MsgEnvelope e -> DiagnosticReason) -> MsgEnvelope e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason (e -> DiagnosticReason)
-> (MsgEnvelope e -> e) -> MsgEnvelope e -> DiagnosticReason
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope e -> e
forall e. MsgEnvelope e -> e
errMsgDiagnostic

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

-- | Are there any hard errors here? -Werror warnings are /not/ detected. If
-- you want to check for -Werror warnings, use 'errorsOrFatalWarningsFound'.
errorsFound :: Diagnostic e => Messages e -> Bool
errorsFound :: forall e. Diagnostic e => Messages e -> Bool
errorsFound (Messages Bag (MsgEnvelope e)
msgs) = (MsgEnvelope e -> Bool) -> Bag (MsgEnvelope e) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any MsgEnvelope e -> Bool
forall e. Diagnostic e => MsgEnvelope e -> Bool
isIntrinsicErrorMessage Bag (MsgEnvelope e)
msgs

-- | Returns 'True' if the envelope contains a message that will stop
-- compilation: either an intrinsic error or a fatal (-Werror) warning
isExtrinsicErrorMessage :: MsgEnvelope e -> Bool
isExtrinsicErrorMessage :: forall e. MsgEnvelope e -> Bool
isExtrinsicErrorMessage = Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
(==) Severity
SevError (Severity -> Bool)
-> (MsgEnvelope e -> Severity) -> MsgEnvelope e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope e -> Severity
forall e. MsgEnvelope e -> Severity
errMsgSeverity

-- | Are there any errors or -Werror warnings here?
errorsOrFatalWarningsFound :: Messages e -> Bool
errorsOrFatalWarningsFound :: forall a. Messages a -> Bool
errorsOrFatalWarningsFound (Messages Bag (MsgEnvelope e)
msgs) = (MsgEnvelope e -> Bool) -> Bag (MsgEnvelope e) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any MsgEnvelope e -> Bool
forall e. MsgEnvelope e -> Bool
isExtrinsicErrorMessage Bag (MsgEnvelope e)
msgs

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

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

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