{-# 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 (..)
   , UnknownDiagnostic (..)
   , 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
   , mkLocMessageWarningGroups
   , getCaretDiagnostic
   -- * Queries
   , isIntrinsicErrorMessage
   , isExtrinsicErrorMessage
   , isWarningMessage
   , getErrorMessages
   , getWarningMessages
   , partitionMessages
   , errorsFound
   , errorsOrFatalWarningsFound

   -- * Diagnostic codes
   , DiagnosticCode(..)
   )
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.Types.Hint
import GHC.Data.FastString (unpackFS)
import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
import GHC.Utils.Json
import GHC.Utils.Panic

import Data.Bifunctor
import Data.Foldable    ( fold )
import qualified Data.List.NonEmpty as NE
import Data.List ( intercalate )
import Data.Typeable ( Typeable )
import Numeric.Natural ( Natural )
import Text.Printf ( printf )

{-
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
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
stimes :: forall b. Integral b => b -> Messages e -> Messages e
$cstimes :: forall e b. Integral b => b -> Messages e -> Messages e
sconcat :: NonEmpty (Messages e) -> Messages e
$csconcat :: forall e. NonEmpty (Messages e) -> Messages e
<> :: Messages e -> Messages e -> Messages e
$c<> :: forall e. Messages e -> Messages e -> Messages e
Semigroup, 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
mconcat :: [Messages e] -> Messages e
$cmconcat :: forall e. [Messages e] -> Messages e
mappend :: Messages e -> Messages e -> Messages e
$cmappend :: forall e. Messages e -> Messages e -> Messages e
mempty :: Messages e
$cmempty :: forall e. Messages e
Monoid)
  deriving stock (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
<$ :: forall a b. a -> Messages b -> Messages a
$c<$ :: forall a b. a -> Messages b -> Messages a
fmap :: forall a b. (a -> b) -> Messages a -> Messages b
$cfmap :: forall a b. (a -> b) -> Messages a -> Messages b
Functor, 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
product :: forall a. Num a => Messages a -> a
$cproduct :: forall a. Num a => Messages a -> a
sum :: forall a. Num a => Messages a -> a
$csum :: forall a. Num a => Messages a -> a
minimum :: forall a. Ord a => Messages a -> a
$cminimum :: forall a. Ord a => Messages a -> a
maximum :: forall a. Ord a => Messages a -> a
$cmaximum :: forall a. Ord a => Messages a -> a
elem :: forall a. Eq a => a -> Messages a -> Bool
$celem :: forall a. Eq a => a -> Messages a -> Bool
length :: forall a. Messages a -> Int
$clength :: forall a. Messages a -> Int
null :: forall a. Messages a -> Bool
$cnull :: forall a. Messages a -> Bool
toList :: forall a. Messages a -> [a]
$ctoList :: forall a. Messages a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Messages a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Messages a -> a
foldr1 :: forall a. (a -> a -> a) -> Messages a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Messages a -> a
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
$cfoldl :: forall b a. (b -> a -> 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
$cfoldr :: forall a b. (a -> b -> b) -> b -> Messages a -> b
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
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Messages a -> m
fold :: forall m. Monoid m => Messages m -> m
$cfold :: forall m. Monoid m => Messages m -> m
Foldable, Functor Messages
Foldable 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)
sequence :: forall (m :: * -> *) a. Monad m => Messages (m a) -> m (Messages a)
$csequence :: forall (m :: * -> *) a. Monad m => Messages (m a) -> m (Messages a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Messages a -> m (Messages b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Messages a -> m (Messages b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Messages (f a) -> f (Messages a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Messages (f a) -> f (Messages a)
traverse :: 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)
Traversable)

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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> Bag a -> Bag a
filterBag forall e. MsgEnvelope e -> Bool
interesting
  where
    interesting :: MsgEnvelope e -> Bool
    interesting :: forall e. MsgEnvelope e -> Bool
interesting = forall a. Eq a => a -> a -> Bool
(/=) Severity
SevIgnore forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. MsgEnvelope e -> Severity
errMsgSeverity

isEmptyMessages :: Messages e -> Bool
isEmptyMessages :: forall a. Messages a -> Bool
isEmptyMessages (Messages Bag (MsgEnvelope e)
msgs) = 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 = forall e. MsgEnvelope e -> Messages e -> Messages e
addMessage MsgEnvelope e
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 (forall a b. (a -> b) -> [a] -> [b]
map MsgEnvelope e -> SDoc
ppr_one (forall a. Bag a -> [a]
bagToList (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 = forall e. Diagnostic e => e -> SDoc
pprDiagnostic (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 <- forall e. MsgEnvelope e -> Severity
errMsgSeverity MsgEnvelope e
x = forall e. Bag (MsgEnvelope e) -> Messages e
Messages Bag (MsgEnvelope e)
xs
  | Bool
otherwise                     = 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.
-- 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) =
  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)

-- | 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 = 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 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 (forall a b. (a -> b) -> [a] -> [b]
map SDoc -> SDoc
f [SDoc]
s1)

-- | 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.
class Diagnostic a where
  -- | Extract the error message text from a 'Diagnostic'.
  diagnosticMessage :: a -> DecoratedSDoc

  -- | Extract the reason for this diagnostic. For warnings,
  -- a 'DiagnosticReason' includes the warning flag
  diagnosticReason  :: a -> DiagnosticReason

  -- | Extract any hints a user might use to repair their
  -- code to avoid this diagnostic.
  diagnosticHints   :: a -> [GhcHint]

  -- | Get the 'DiagnosticCode' associated with this 'Diagnostic'.
  -- This can return 'Nothing' for at least two reasons:
  --
  -- 1. The message might be from a plugin that does not supply codes.
  -- 2. The message might not yet have been assigned a code. See the
  --    'Diagnostic' instance for 'DiagnosticMessage'.
  --
  -- Ideally, case (2) would not happen, but because
  -- some errors in GHC still use the old system of just writing the
  -- error message in-place (instead of using a dedicated error type
  -- and constructor), we do not have error codes for all errors.
  -- #18516 tracks our progress toward this goal.
  diagnosticCode    :: a -> Maybe DiagnosticCode

-- | An existential wrapper around an unknown diagnostic.
data UnknownDiagnostic where
  UnknownDiagnostic :: (Typeable diag, Diagnostic diag) => diag -> UnknownDiagnostic

instance Diagnostic UnknownDiagnostic where
  diagnosticMessage :: UnknownDiagnostic -> DecoratedSDoc
diagnosticMessage (UnknownDiagnostic diag
diag) = forall a. Diagnostic a => a -> DecoratedSDoc
diagnosticMessage diag
diag
  diagnosticReason :: UnknownDiagnostic -> DiagnosticReason
diagnosticReason  (UnknownDiagnostic diag
diag) = forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason  diag
diag
  diagnosticHints :: UnknownDiagnostic -> [GhcHint]
diagnosticHints   (UnknownDiagnostic diag
diag) = forall a. Diagnostic a => a -> [GhcHint]
diagnosticHints   diag
diag
  diagnosticCode :: UnknownDiagnostic -> Maybe DiagnosticCode
diagnosticCode    (UnknownDiagnostic diag
diag) = forall a. Diagnostic a => a -> Maybe DiagnosticCode
diagnosticCode    diag
diag

pprDiagnostic :: Diagnostic e => e -> SDoc
pprDiagnostic :: forall e. Diagnostic e => e -> SDoc
pprDiagnostic e
e = [SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr (forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason e
e)
                       , Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat (DecoratedSDoc -> [SDoc]
unDecorated (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
  diagnosticCode :: DiagnosticMessage -> Maybe DiagnosticCode
diagnosticCode DiagnosticMessage
_  = forall a. Maybe a
Nothing

-- | 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 = 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DiagnosticReason -> DiagnosticReason -> Bool
$c/= :: DiagnosticReason -> DiagnosticReason -> Bool
== :: DiagnosticReason -> DiagnosticReason -> Bool
$c== :: DiagnosticReason -> DiagnosticReason -> Bool
Eq, Int -> DiagnosticReason -> ShowS
[DiagnosticReason] -> ShowS
DiagnosticReason -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DiagnosticReason] -> ShowS
$cshowList :: [DiagnosticReason] -> ShowS
show :: DiagnosticReason -> String
$cshow :: DiagnosticReason -> String
showsPrec :: Int -> DiagnosticReason -> ShowS
$cshowsPrec :: Int -> 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 " forall a. [a] -> [a] -> [a]
++ 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 -> 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, 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
product :: forall a. Num a => MsgEnvelope a -> a
$cproduct :: forall a. Num a => MsgEnvelope a -> a
sum :: forall a. Num a => MsgEnvelope a -> a
$csum :: forall a. Num a => MsgEnvelope a -> a
minimum :: forall a. Ord a => MsgEnvelope a -> a
$cminimum :: forall a. Ord a => MsgEnvelope a -> a
maximum :: forall a. Ord a => MsgEnvelope a -> a
$cmaximum :: forall a. Ord a => MsgEnvelope a -> a
elem :: forall a. Eq a => a -> MsgEnvelope a -> Bool
$celem :: forall a. Eq a => a -> MsgEnvelope a -> Bool
length :: forall a. MsgEnvelope a -> Int
$clength :: forall a. MsgEnvelope a -> Int
null :: forall e. MsgEnvelope e -> Bool
$cnull :: forall e. MsgEnvelope e -> Bool
toList :: forall a. MsgEnvelope a -> [a]
$ctoList :: forall a. MsgEnvelope a -> [a]
foldl1 :: forall a. (a -> a -> a) -> MsgEnvelope a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> MsgEnvelope a -> a
foldr1 :: forall a. (a -> a -> a) -> MsgEnvelope a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> MsgEnvelope a -> a
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
$cfoldl :: forall b a. (b -> a -> 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
$cfoldr :: forall a b. (a -> b -> b) -> b -> MsgEnvelope a -> b
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
$cfoldMap :: forall m a. Monoid m => (a -> m) -> MsgEnvelope a -> m
fold :: forall m. Monoid m => MsgEnvelope m -> m
$cfold :: forall m. Monoid m => MsgEnvelope m -> m
Foldable, Functor MsgEnvelope
Foldable 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)
sequence :: forall (m :: * -> *) a.
Monad m =>
MsgEnvelope (m a) -> m (MsgEnvelope a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
MsgEnvelope (m a) -> m (MsgEnvelope a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MsgEnvelope a -> m (MsgEnvelope b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MsgEnvelope a -> m (MsgEnvelope b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
MsgEnvelope (f a) -> f (MsgEnvelope a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
MsgEnvelope (f a) -> f (MsgEnvelope a)
traverse :: 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)
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 (Maybe DiagnosticCode)
    -- ^ 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.
    --
    -- The @Maybe 'DiagnosticCode'@ field carries a code (if available) for
    -- this diagnostic. If you are creating a message not tied to any
    -- error-message type, then use Nothing. In the long run, this really
    -- should always have a 'DiagnosticCode'. See Note [Diagnostic codes].

{-
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
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 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 (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 Maybe DiagnosticCode
code) =
    String -> JsonDoc
JSString forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"MCDiagnostic" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Severity
sev SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr DiagnosticReason
reason SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Maybe DiagnosticCode
code)

instance Show (MsgEnvelope DiagnosticMessage) where
    show :: MsgEnvelope DiagnosticMessage -> String
show = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Diagnostic a => a -> DecoratedSDoc
diagnosticMessage 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))

mkLocMessage
  :: MessageClass                       -- ^ What kind of message?
  -> SrcSpan                            -- ^ location
  -> SDoc                               -- ^ message
  -> SDoc
mkLocMessage :: MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage = Bool -> MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessageWarningGroups Bool
True

-- | Make an error message with location info, specifying whether to show
-- warning groups (if applicable).
mkLocMessageWarningGroups
  :: Bool                               -- ^ Print warning groups (if applicable)?
  -> 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>".
mkLocMessageWarningGroups :: Bool -> MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessageWarningGroups Bool
show_warn_groups MessageClass
msg_class 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)

          msg_colour :: PprColour
msg_colour = MessageClass -> Scheme -> PprColour
getMessageClassColour MessageClass
msg_class Scheme
col_scheme
          col :: String -> SDoc
col = PprColour -> SDoc -> SDoc
coloured PprColour
msg_colour forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SDoc
text

          msg_title :: SDoc
msg_title = PprColour -> SDoc -> SDoc
coloured PprColour
msg_colour forall a b. (a -> b) -> a -> b
$
            case MessageClass
msg_class of
              MCDiagnostic Severity
SevError   DiagnosticReason
_ Maybe DiagnosticCode
_ -> String -> SDoc
text String
"error"
              MCDiagnostic Severity
SevWarning DiagnosticReason
_ Maybe DiagnosticCode
_ -> String -> SDoc
text String
"warning"
              MessageClass
MCFatal                     -> String -> SDoc
text String
"fatal"
              MessageClass
_                           -> SDoc
empty

          warning_flag_doc :: SDoc
warning_flag_doc =
            case MessageClass
msg_class of
              MCDiagnostic Severity
sev DiagnosticReason
reason Maybe DiagnosticCode
_code
                | Just SDoc
msg <- Severity -> DiagnosticReason -> Maybe SDoc
flag_msg Severity
sev DiagnosticReason
reason -> SDoc -> SDoc
brackets SDoc
msg
              MessageClass
_                                   -> SDoc
empty

          code_doc :: SDoc
code_doc =
            case MessageClass
msg_class of
              MCDiagnostic Severity
_ DiagnosticReason
_ (Just DiagnosticCode
code) -> SDoc -> SDoc
brackets (PprColour -> SDoc -> SDoc
coloured PprColour
msg_colour forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr DiagnosticCode
code)
              MessageClass
_                            -> SDoc
empty

          flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc
          flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc
flag_msg Severity
SevIgnore DiagnosticReason
_                 = forall a. Maybe a
Nothing
            -- The above can happen when displaying an error message
            -- in a log file, e.g. with -ddump-tc-trace. It should not
            -- happen otherwise, though.
          flag_msg Severity
SevError DiagnosticReason
WarningWithoutFlag = forall a. a -> Maybe a
Just (String -> SDoc
col String
"-Werror")
          flag_msg Severity
SevError (WarningWithFlag WarningFlag
wflag) =
            let name :: String
name = forall a. NonEmpty a -> a
NE.head (WarningFlag -> NonEmpty String
warnFlagNames WarningFlag
wflag) in
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> SDoc
col (String
"-W" forall a. [a] -> [a] -> [a]
++ String
name) SDoc -> SDoc -> SDoc
<+> WarningFlag -> SDoc
warn_flag_grp WarningFlag
wflag
                                      SDoc -> SDoc -> SDoc
<> SDoc
comma
                                      SDoc -> SDoc -> SDoc
<+> String -> SDoc
col (String
"Werror=" forall a. [a] -> [a] -> [a]
++ String
name)
          flag_msg Severity
SevError   DiagnosticReason
ErrorWithoutFlag   = forall a. Maybe a
Nothing
          flag_msg Severity
SevWarning DiagnosticReason
WarningWithoutFlag = forall a. Maybe a
Nothing
          flag_msg Severity
SevWarning (WarningWithFlag WarningFlag
wflag) =
            let name :: String
name = forall a. NonEmpty a -> a
NE.head (WarningFlag -> NonEmpty String
warnFlagNames WarningFlag
wflag) in
            forall a. a -> Maybe a
Just (String -> SDoc
col (String
"-W" forall a. [a] -> [a] -> [a]
++ String
name) SDoc -> SDoc -> SDoc
<+> WarningFlag -> SDoc
warn_flag_grp WarningFlag
wflag)
          flag_msg Severity
SevWarning DiagnosticReason
ErrorWithoutFlag =
            forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"SevWarning with ErrorWithoutFlag" forall a b. (a -> b) -> a -> b
$
              [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"locn:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr SrcSpan
locn
                   , String -> SDoc
text String
"msg:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr SDoc
msg ]

          warn_flag_grp :: WarningFlag -> SDoc
warn_flag_grp WarningFlag
flag
              | Bool
show_warn_groups =
                    case WarningFlag -> [String]
smallestWarningGroups WarningFlag
flag of
                        [] -> SDoc
empty
                        [String]
groups -> String -> SDoc
text forall a b. (a -> b) -> a -> b
$ String
"(in " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map (String
"-W"forall a. [a] -> [a] -> [a]
++) [String]
groups) forall a. [a] -> [a] -> [a]
++ String
")"
              | Bool
otherwise = SDoc
empty

          -- Add prefixes, like    Foo.hs:34: warning:
          --                           <the warning message>
          header :: SDoc
header = SDoc
locn' SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+>
                   SDoc
msg_title SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+>
                   SDoc
code_doc SDoc -> SDoc -> SDoc
<+> SDoc
warning_flag_doc

      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)

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

getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc
getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc
getCaretDiagnostic MessageClass
_ (UnhelpfulSpan UnhelpfulSpanReason
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure SDoc
empty
getCaretDiagnostic MessageClass
msg_class (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 e a. Exception e => IO a -> (e -> IO a) -> IO a
`catchException` \(IOError
_ :: 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 = 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
" " 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

--
-- 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 = forall a. Eq a => a -> a -> Bool
(==) DiagnosticReason
ErrorWithoutFlag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. MsgEnvelope e -> e
errMsgDiagnostic

isWarningMessage :: Diagnostic e => MsgEnvelope e -> Bool
isWarningMessage :: forall e. Diagnostic e => MsgEnvelope e -> Bool
isWarningMessage = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any 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 = 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

-- | Are there any errors or -Werror warnings here?
errorsOrFatalWarningsFound :: Messages e -> Bool
errorsOrFatalWarningsFound :: forall a. Messages a -> Bool
errorsOrFatalWarningsFound (Messages Bag (MsgEnvelope e)
msgs) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any 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) = 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. 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) = 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. 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) = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall e. Bag (MsgEnvelope e) -> Messages e
Messages forall e. Bag (MsgEnvelope e) -> Messages e
Messages (forall a. (a -> Bool) -> Bag a -> (Bag a, Bag a)
partitionBag forall e. Diagnostic e => MsgEnvelope e -> Bool
isWarningMessage Bag (MsgEnvelope e)
xs)

----------------------------------------------------------------
--                                                            --
-- Definition of diagnostic codes                             --
--                                                            --
----------------------------------------------------------------

-- | A diagnostic code is a namespaced numeric identifier
-- unique to the given diagnostic (error or warning).
--
-- All diagnostic codes defined within GHC are given the
-- GHC namespace.
--
-- See Note [Diagnostic codes] in GHC.Types.Error.Codes.
data DiagnosticCode =
  DiagnosticCode
    { DiagnosticCode -> String
diagnosticCodeNameSpace :: String
        -- ^ diagnostic code prefix (e.g. "GHC")
    , DiagnosticCode -> Natural
diagnosticCodeNumber    :: Natural
        -- ^ the actual diagnostic code
    }

instance Outputable DiagnosticCode where
  ppr :: DiagnosticCode -> SDoc
ppr (DiagnosticCode String
prefix Natural
c) =
    String -> SDoc
text String
prefix SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"-" SDoc -> SDoc -> SDoc
<> String -> SDoc
text (forall r. PrintfType r => String -> r
printf String
"%05d" Natural
c)
      -- pad the numeric code to have at least 5 digits