{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}

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

   -- * Classifying Messages

   , MessageClass (..)
   , Severity (..)
   , Diagnostic (..)
   , UnknownDiagnostic (..)
   , mkSimpleUnknownDiagnostic
   , mkUnknownDiagnostic
   , embedUnknownDiagnostic
   , DiagnosticMessage (..)
   , DiagnosticReason (WarningWithFlag, ..)
   , ResolvedDiagnosticReason(..)
   , DiagnosticHint (..)
   , mkPlainDiagnostic
   , mkPlainError
   , mkDecoratedDiagnostic
   , mkDecoratedError

   , pprDiagnostic

   , HasDefaultDiagnosticOpts(..)
   , defaultDiagnosticOpts
   , NoDiagnosticOpts(..)

   -- * 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.Types.Hint.Ppr () -- Outputable instance
import GHC.Unit.Module.Warnings (WarningCategory(..))

import GHC.Utils.Json
import GHC.Utils.Panic

import GHC.Version (cProjectVersion)
import Data.Bifunctor
import Data.Foldable    ( fold, toList )
import Data.List.NonEmpty ( NonEmpty (..) )
import qualified Data.List.NonEmpty as NE
import Data.List ( intercalate )
import Data.Maybe ( maybeToList )
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
(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
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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 =
        [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Resolved:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ResolvedDiagnosticReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr (MsgEnvelope e -> ResolvedDiagnosticReason
forall e. MsgEnvelope e -> ResolvedDiagnosticReason
errMsgReason MsgEnvelope e
envelope),
               e -> SDoc
forall e. Diagnostic e => e -> SDoc
pprDiagnostic (MsgEnvelope e -> e
forall e. MsgEnvelope e -> e
errMsgDiagnostic MsgEnvelope e
envelope)
             ]

instance Diagnostic e => ToJson (Messages e) where
  json :: Messages e -> JsonDoc
json Messages e
msgs =  [JsonDoc] -> JsonDoc
JSArray ([JsonDoc] -> JsonDoc)
-> (Bag JsonDoc -> [JsonDoc]) -> Bag JsonDoc -> JsonDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag JsonDoc -> [JsonDoc]
forall a. Bag a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Bag JsonDoc -> JsonDoc) -> Bag JsonDoc -> JsonDoc
forall a b. (a -> b) -> a -> b
$ MsgEnvelope e -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json (MsgEnvelope e -> JsonDoc) -> Bag (MsgEnvelope e) -> Bag JsonDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages e -> Bag (MsgEnvelope e)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages Messages e
msgs

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

filterMessages :: (MsgEnvelope e -> Bool) -> Messages e -> Messages e
filterMessages :: forall e. (MsgEnvelope e -> Bool) -> Messages e -> Messages e
filterMessages MsgEnvelope e -> Bool
f (Messages Bag (MsgEnvelope e)
msgs) =
  Bag (MsgEnvelope e) -> Messages e
forall e. Bag (MsgEnvelope e) -> Messages e
Messages ((MsgEnvelope e -> Bool)
-> Bag (MsgEnvelope e) -> Bag (MsgEnvelope e)
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag MsgEnvelope e -> Bool
f Bag (MsgEnvelope e)
msgs)

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

class HasDefaultDiagnosticOpts opts where
  defaultOpts :: opts


defaultDiagnosticOpts :: forall opts . HasDefaultDiagnosticOpts (DiagnosticOpts opts) => DiagnosticOpts opts
defaultDiagnosticOpts :: forall opts.
HasDefaultDiagnosticOpts (DiagnosticOpts opts) =>
DiagnosticOpts opts
defaultDiagnosticOpts = forall opts. HasDefaultDiagnosticOpts opts => opts
defaultOpts @(DiagnosticOpts opts)




-- | 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 (HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where

  -- | Type of configuration options for the diagnostic.
  type DiagnosticOpts a

  -- | Extract the error message text from a 'Diagnostic'.
  diagnosticMessage :: DiagnosticOpts a -> 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 opts where
  UnknownDiagnostic :: (Diagnostic a, Typeable a)
                    => (opts -> DiagnosticOpts a) -- Inject the options of the outer context
                                                  -- into the options for the wrapped diagnostic.
                    -> a
                    -> UnknownDiagnostic opts

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

-- A fallback 'DiagnosticOpts' which can be used when there are no options
-- for a particular diagnostic.
data NoDiagnosticOpts = NoDiagnosticOpts
instance HasDefaultDiagnosticOpts NoDiagnosticOpts where
  defaultOpts :: NoDiagnosticOpts
defaultOpts = NoDiagnosticOpts
NoDiagnosticOpts

-- | Make a "simple" unknown diagnostic which doesn't have any configuration options.
mkSimpleUnknownDiagnostic :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) => a -> UnknownDiagnostic b
mkSimpleUnknownDiagnostic :: forall a b.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> UnknownDiagnostic b
mkSimpleUnknownDiagnostic = (b -> DiagnosticOpts a) -> a -> UnknownDiagnostic b
forall a opts.
(Diagnostic a, Typeable a) =>
(opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts
UnknownDiagnostic (NoDiagnosticOpts -> b -> NoDiagnosticOpts
forall a b. a -> b -> a
const NoDiagnosticOpts
NoDiagnosticOpts)

-- | Make an unknown diagnostic which uses the same options as the context it will be embedded into.
mkUnknownDiagnostic :: (Typeable a, Diagnostic a) => a -> UnknownDiagnostic (DiagnosticOpts a)
mkUnknownDiagnostic :: forall a.
(Typeable a, Diagnostic a) =>
a -> UnknownDiagnostic (DiagnosticOpts a)
mkUnknownDiagnostic = (DiagnosticOpts a -> DiagnosticOpts a)
-> a -> UnknownDiagnostic (DiagnosticOpts a)
forall a opts.
(Diagnostic a, Typeable a) =>
(opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts
UnknownDiagnostic DiagnosticOpts a -> DiagnosticOpts a
forall a. a -> a
id

-- | Embed a more complicated diagnostic which requires a potentially different options type.
embedUnknownDiagnostic :: (Diagnostic a, Typeable a) => (opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts
embedUnknownDiagnostic :: forall a opts.
(Diagnostic a, Typeable a) =>
(opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts
embedUnknownDiagnostic = (opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts
forall a opts.
(Diagnostic a, Typeable a) =>
(opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts
UnknownDiagnostic

--------------------------------------------------------------------------------

pprDiagnostic :: forall e . Diagnostic e => e -> SDoc
pprDiagnostic :: forall e. Diagnostic e => e -> SDoc
pprDiagnostic e
e = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
forall doc. IsDoc doc => [doc] -> doc
vcat (DecoratedSDoc -> [SDoc]
unDecorated (DiagnosticOpts e -> e -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage DiagnosticOpts e
opts e
e))) ]
  where opts :: DiagnosticOpts e
opts = forall opts.
HasDefaultDiagnosticOpts (DiagnosticOpts opts) =>
DiagnosticOpts opts
defaultDiagnosticOpts @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 interpret 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
  type DiagnosticOpts DiagnosticMessage = NoDiagnosticOpts
  diagnosticMessage :: DiagnosticOpts DiagnosticMessage
-> DiagnosticMessage -> DecoratedSDoc
diagnosticMessage DiagnosticOpts DiagnosticMessage
_ = DiagnosticMessage -> DecoratedSDoc
diagMessage
  diagnosticReason :: DiagnosticMessage -> DiagnosticReason
diagnosticReason  = DiagnosticMessage -> DiagnosticReason
diagReason
  diagnosticHints :: DiagnosticMessage -> [GhcHint]
diagnosticHints   = DiagnosticMessage -> [GhcHint]
diagHints
  diagnosticCode :: DiagnosticMessage -> Maybe DiagnosticCode
diagnosticCode DiagnosticMessage
_  = Maybe DiagnosticCode
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 = [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.
  | WarningWithFlags !(NE.NonEmpty WarningFlag)
  -- ^ Warning was enabled with the flag.
  | WarningWithCategory !WarningCategory
  -- ^ Warning was enabled with a custom category.
  | 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)

-- | Like a 'DiagnosticReason', but resolved against a specific set of `DynFlags` to
-- work out which warning flag actually enabled this warning.
newtype ResolvedDiagnosticReason
          = ResolvedDiagnosticReason { ResolvedDiagnosticReason -> DiagnosticReason
resolvedDiagnosticReason :: DiagnosticReason }

-- | The single warning case 'DiagnosticReason' is very common.
pattern WarningWithFlag :: WarningFlag -> DiagnosticReason
pattern $mWarningWithFlag :: forall {r}.
DiagnosticReason -> (WarningFlag -> r) -> ((# #) -> r) -> r
$bWarningWithFlag :: WarningFlag -> DiagnosticReason
WarningWithFlag w = WarningWithFlags (w :| [])

{- Note [Warnings controlled by multiple flags]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Diagnostics that started life as flag-controlled warnings have a
'diagnosticReason' of 'WarningWithFlags', giving the flags that control the
warning. Usually there is only one flag, but in a few cases multiple flags
apply. Where there are more than one, they are listed highest-priority first.

For example, the same exported binding may give rise to a warning if either
`-Wmissing-signatures` or `-Wmissing-exported-signatures` is enabled. Here
`-Wmissing-signatures` has higher priority, because we want to mention it if
before are enabled.  See `missingSignatureWarningFlags` for the specific logic
in this case.

When reporting such a warning to the user, it is important to mention the
correct flag (e.g. `-Wmissing-signatures` if it is enabled, or
`-Wmissing-exported-signatures` if only the latter is enabled).  Thus
`diag_reason_severity` filters the `DiagnosticReason` based on the currently
active `DiagOpts`. For a `WarningWithFlags` it returns only the flags that are
enabled; it leaves other `DiagnosticReason`s unchanged. This is then wrapped
in a `ResolvedDiagnosticReason` newtype which records that this filtering has
taken place.

If we have `-Wmissing-signatures -Werror=missing-exported-signatures` we want
the error to mention `-Werror=missing-exported-signatures` (even though
`-Wmissing-signatures` would normally take precedence). Thus if there are any
fatal warnings, `diag_reason_severity` returns those alone.

The `MsgEnvelope` stores the filtered `ResolvedDiagnosticReason` listing only the
relevant flags for subsequent display.


Side note: we do not treat `-Wmissing-signatures` as a warning group that
includes `-Wmissing-exported-signatures`, because

  (a) this would require us to provide a flag for the complement, and

  (b) currently, in `-Wmissing-exported-signatures -Wno-missing-signatures`, the
      latter option does not switch off the former.
-}

instance Outputable DiagnosticReason where
  ppr :: DiagnosticReason -> SDoc
ppr = \case
    DiagnosticReason
WarningWithoutFlag  -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"WarningWithoutFlag"
    WarningWithFlags NonEmpty WarningFlag
wf -> String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
"WarningWithFlags " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NonEmpty WarningFlag -> String
forall a. Show a => a -> String
show NonEmpty WarningFlag
wf)
    WarningWithCategory WarningCategory
cat -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"WarningWithCategory" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> WarningCategory -> SDoc
forall a. Outputable a => a -> SDoc
ppr WarningCategory
cat
    DiagnosticReason
ErrorWithoutFlag    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ErrorWithoutFlag"

instance Outputable ResolvedDiagnosticReason where
  ppr :: ResolvedDiagnosticReason -> SDoc
ppr = DiagnosticReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DiagnosticReason -> SDoc)
-> (ResolvedDiagnosticReason -> DiagnosticReason)
-> ResolvedDiagnosticReason
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedDiagnosticReason -> DiagnosticReason
resolvedDiagnosticReason

-- | 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 -> NamePprCtx
errMsgContext     :: NamePprCtx
   , forall e. MsgEnvelope e -> e
errMsgDiagnostic  :: e
   , forall e. MsgEnvelope e -> Severity
errMsgSeverity    :: Severity
   , forall e. MsgEnvelope e -> ResolvedDiagnosticReason
errMsgReason      :: ResolvedDiagnosticReason
      -- ^ The actual reason caused this message
      --
      -- See Note [Warnings controlled by multiple flags]
   } 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 ResolvedDiagnosticReason (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
(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, Eq Severity
Eq Severity =>
(Severity -> Severity -> Ordering)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Severity)
-> (Severity -> Severity -> Severity)
-> Ord Severity
Severity -> Severity -> Bool
Severity -> Severity -> Ordering
Severity -> Severity -> Severity
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Severity -> Severity -> Ordering
compare :: Severity -> Severity -> Ordering
$c< :: Severity -> Severity -> Bool
< :: Severity -> Severity -> Bool
$c<= :: Severity -> Severity -> Bool
<= :: Severity -> Severity -> Bool
$c> :: Severity -> Severity -> Bool
> :: Severity -> Severity -> Bool
$c>= :: Severity -> Severity -> Bool
>= :: Severity -> Severity -> Bool
$cmax :: Severity -> Severity -> Severity
max :: Severity -> Severity -> Severity
$cmin :: Severity -> Severity -> Severity
min :: Severity -> Severity -> Severity
Ord, 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
forall doc. IsLine doc => String -> doc
text String
"SevIgnore"
    Severity
SevWarning -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SevWarning"
    Severity
SevError   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SevError"

instance ToJson Severity where
  json :: Severity -> JsonDoc
json Severity
SevIgnore = String -> JsonDoc
JSString String
"Ignore"
  json Severity
SevWarning = String -> JsonDoc
JSString String
"Warning"
  json Severity
SevError = String -> JsonDoc
JSString String
"Error"

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 ResolvedDiagnosticReason
reason Maybe DiagnosticCode
code) =
    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
forall doc. IsLine doc => String -> doc
text String
"MCDiagnostic" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Severity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Severity
sev SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ResolvedDiagnosticReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr ResolvedDiagnosticReason
reason SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe DiagnosticCode -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe DiagnosticCode
code)

instance ToJson DiagnosticCode where
  json :: DiagnosticCode -> JsonDoc
json DiagnosticCode
c = Int -> JsonDoc
JSInt (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DiagnosticCode -> Natural
diagnosticCodeNumber DiagnosticCode
c))

{- Note [Diagnostic Message JSON Schema]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The below instance of ToJson must conform to the JSON schema
specified in docs/users_guide/diagnostics-as-json-schema-1_1.json.
When the schema is altered, please bump the version.
If the content is altered in a backwards compatible way,
update the minor version (e.g. 1.3 ~> 1.4).
If the content is breaking, update the major version (e.g. 1.3 ~> 2.0).
When updating the schema, replace the above file and name it appropriately with
the version appended, and change the documentation of the -fdiagnostics-as-json
flag to reflect the new schema.
To learn more about JSON schemas, check out the below link:
https://json-schema.org
-}

schemaVersion :: String
schemaVersion :: String
schemaVersion = String
"1.1"
-- See Note [Diagnostic Message JSON Schema] before editing!
instance Diagnostic e => ToJson (MsgEnvelope e) where
  json :: MsgEnvelope e -> JsonDoc
json MsgEnvelope e
m = [(String, JsonDoc)] -> JsonDoc
JSObject ([(String, JsonDoc)] -> JsonDoc) -> [(String, JsonDoc)] -> JsonDoc
forall a b. (a -> b) -> a -> b
$ [
    (String
"version", String -> JsonDoc
JSString String
schemaVersion),
    (String
"ghcVersion", String -> JsonDoc
JSString (String -> JsonDoc) -> String -> JsonDoc
forall a b. (a -> b) -> a -> b
$ String
"ghc-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cProjectVersion),
    (String
"span", SrcSpan -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json (SrcSpan -> JsonDoc) -> SrcSpan -> JsonDoc
forall a b. (a -> b) -> a -> b
$ MsgEnvelope e -> SrcSpan
forall e. MsgEnvelope e -> SrcSpan
errMsgSpan MsgEnvelope e
m),
    (String
"severity", Severity -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json (Severity -> JsonDoc) -> Severity -> JsonDoc
forall a b. (a -> b) -> a -> b
$ MsgEnvelope e -> Severity
forall e. MsgEnvelope e -> Severity
errMsgSeverity MsgEnvelope e
m),
    (String
"code", JsonDoc
-> (DiagnosticCode -> JsonDoc) -> Maybe DiagnosticCode -> JsonDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe JsonDoc
JSNull DiagnosticCode -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json (e -> Maybe DiagnosticCode
forall a. Diagnostic a => a -> Maybe DiagnosticCode
diagnosticCode e
diag)),
    (String
"message", [JsonDoc] -> JsonDoc
JSArray ([JsonDoc] -> JsonDoc) -> [JsonDoc] -> JsonDoc
forall a b. (a -> b) -> a -> b
$ (SDoc -> JsonDoc) -> [SDoc] -> [JsonDoc]
forall a b. (a -> b) -> [a] -> [b]
map SDoc -> JsonDoc
renderToJSString [SDoc]
diagMsg),
    (String
"hints", [JsonDoc] -> JsonDoc
JSArray ([JsonDoc] -> JsonDoc) -> [JsonDoc] -> JsonDoc
forall a b. (a -> b) -> a -> b
$ (GhcHint -> JsonDoc) -> [GhcHint] -> [JsonDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> JsonDoc
renderToJSString (SDoc -> JsonDoc) -> (GhcHint -> SDoc) -> GhcHint -> JsonDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhcHint -> SDoc
forall a. Outputable a => a -> SDoc
ppr) (e -> [GhcHint]
forall a. Diagnostic a => a -> [GhcHint]
diagnosticHints e
diag) ) ]
    [(String, JsonDoc)] -> [(String, JsonDoc)] -> [(String, JsonDoc)]
forall a. [a] -> [a] -> [a]
++ [ (String
"reason", JsonDoc
reasonJson)
       | JsonDoc
reasonJson <- Maybe JsonDoc -> [JsonDoc]
forall a. Maybe a -> [a]
maybeToList (Maybe JsonDoc -> [JsonDoc]) -> Maybe JsonDoc -> [JsonDoc]
forall a b. (a -> b) -> a -> b
$ ResolvedDiagnosticReason -> Maybe JsonDoc
usefulReasonJson_maybe (MsgEnvelope e -> ResolvedDiagnosticReason
forall e. MsgEnvelope e -> ResolvedDiagnosticReason
errMsgReason MsgEnvelope e
m) ]
    where
      diag :: e
diag = MsgEnvelope e -> e
forall e. MsgEnvelope e -> e
errMsgDiagnostic MsgEnvelope e
m
      opts :: DiagnosticOpts e
opts = forall opts.
HasDefaultDiagnosticOpts (DiagnosticOpts opts) =>
DiagnosticOpts opts
defaultDiagnosticOpts @e
      style :: PprStyle
style = NamePprCtx -> PprStyle
mkErrStyle (MsgEnvelope e -> NamePprCtx
forall e. MsgEnvelope e -> NamePprCtx
errMsgContext MsgEnvelope e
m)
      ctx :: SDocContext
ctx = SDocContext
defaultSDocContext {sdocStyle = style }
      diagMsg :: [SDoc]
diagMsg = (SDoc -> Bool) -> [SDoc] -> [SDoc]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (SDoc -> Bool) -> SDoc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext -> SDoc -> Bool
isEmpty SDocContext
ctx) (DecoratedSDoc -> [SDoc]
unDecorated (DiagnosticOpts e -> e -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage (DiagnosticOpts e
opts) e
diag))
      renderToJSString :: SDoc -> JsonDoc
      renderToJSString :: SDoc -> JsonDoc
renderToJSString = String -> JsonDoc
JSString (String -> JsonDoc) -> (SDoc -> String) -> SDoc -> JsonDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SDocContext -> SDoc -> String
renderWithContext SDocContext
ctx)

      usefulReasonJson_maybe :: ResolvedDiagnosticReason -> Maybe JsonDoc
      usefulReasonJson_maybe :: ResolvedDiagnosticReason -> Maybe JsonDoc
usefulReasonJson_maybe (ResolvedDiagnosticReason DiagnosticReason
rea) =
        case DiagnosticReason
rea of
          DiagnosticReason
WarningWithoutFlag -> Maybe JsonDoc
forall a. Maybe a
Nothing
          DiagnosticReason
ErrorWithoutFlag   -> Maybe JsonDoc
forall a. Maybe a
Nothing
          WarningWithFlags NonEmpty WarningFlag
flags ->
            JsonDoc -> Maybe JsonDoc
forall a. a -> Maybe a
Just (JsonDoc -> Maybe JsonDoc) -> JsonDoc -> Maybe JsonDoc
forall a b. (a -> b) -> a -> b
$ [(String, JsonDoc)] -> JsonDoc
JSObject
              [ (String
"flags", [JsonDoc] -> JsonDoc
JSArray ([JsonDoc] -> JsonDoc) -> [JsonDoc] -> JsonDoc
forall a b. (a -> b) -> a -> b
$ (WarningFlag -> JsonDoc) -> [WarningFlag] -> [JsonDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> JsonDoc
JSString (String -> JsonDoc)
-> (WarningFlag -> String) -> WarningFlag -> JsonDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty String -> String
forall a. NonEmpty a -> a
NE.head (NonEmpty String -> String)
-> (WarningFlag -> NonEmpty String) -> WarningFlag -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarningFlag -> NonEmpty String
warnFlagNames) (NonEmpty WarningFlag -> [WarningFlag]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty WarningFlag
flags))
              ]
          WarningWithCategory (WarningCategory FastString
cat) ->
            JsonDoc -> Maybe JsonDoc
forall a. a -> Maybe a
Just (JsonDoc -> Maybe JsonDoc) -> JsonDoc -> Maybe JsonDoc
forall a b. (a -> b) -> a -> b
$ [(String, JsonDoc)] -> JsonDoc
JSObject
              [ (String
"category", String -> JsonDoc
JSString (String -> JsonDoc) -> String -> JsonDoc
forall a b. (a -> b) -> a -> b
$ FastString -> String
unpackFS FastString
cat)
              ]

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

-- | Shows an 'MsgEnvelope'. Only use this for debugging.
showMsgEnvelope :: forall a . 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
forall doc. IsDoc doc => [doc] -> doc
vcat (DecoratedSDoc -> [SDoc]
unDecorated (DecoratedSDoc -> [SDoc]) -> (a -> DecoratedSDoc) -> a -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DiagnosticOpts a -> a -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage (forall opts.
HasDefaultDiagnosticOpts (DiagnosticOpts opts) =>
DiagnosticOpts opts
defaultDiagnosticOpts @a)) (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
forall doc. IsDoc doc => [doc] -> doc
vcat (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
blankLine (Bag SDoc -> [SDoc]
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
    = (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)

          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 (SDoc -> SDoc) -> (String -> SDoc) -> String -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SDoc
forall doc. IsLine doc => String -> doc
text

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

          warning_flag_doc :: SDoc
warning_flag_doc =
            case MessageClass
msg_class of
              MCDiagnostic Severity
sev ResolvedDiagnosticReason
reason Maybe DiagnosticCode
_code
                | Just SDoc
msg <- Severity -> DiagnosticReason -> Maybe SDoc
flag_msg Severity
sev (ResolvedDiagnosticReason -> DiagnosticReason
resolvedDiagnosticReason ResolvedDiagnosticReason
reason)
                  -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets SDoc
msg
              MessageClass
_   -> SDoc
forall doc. IsOutput doc => doc
empty

          ppr_with_hyperlink :: DiagnosticCode -> SDoc
ppr_with_hyperlink DiagnosticCode
code =
            -- this is a bit hacky, but we assume that if the terminal supports colors
            -- then it should also support links
            (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption (\ SDocContext
ctx -> SDocContext -> Bool
sdocPrintErrIndexLinks SDocContext
ctx) ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$
              \ Bool
use_hyperlinks ->
                 if Bool
use_hyperlinks
                 then LinkedDiagCode -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LinkedDiagCode -> SDoc) -> LinkedDiagCode -> SDoc
forall a b. (a -> b) -> a -> b
$ DiagnosticCode -> LinkedDiagCode
LinkedDiagCode DiagnosticCode
code
                 else DiagnosticCode -> SDoc
forall a. Outputable a => a -> SDoc
ppr DiagnosticCode
code

          code_doc :: SDoc
code_doc =
            case MessageClass
msg_class of
              MCDiagnostic Severity
_ ResolvedDiagnosticReason
_ (Just DiagnosticCode
code) -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (DiagnosticCode -> SDoc
ppr_with_hyperlink DiagnosticCode
code)
              MessageClass
_                            -> SDoc
forall doc. IsOutput doc => doc
empty

          flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc
          flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc
flag_msg Severity
SevIgnore DiagnosticReason
_                 = Maybe SDoc
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 = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
col String
"-Werror")
          flag_msg Severity
SevError (WarningWithFlags (WarningFlag
wflag :| [WarningFlag]
_)) =
            let name :: String
name = NonEmpty String -> String
forall a. NonEmpty a -> a
NE.head (WarningFlag -> NonEmpty String
warnFlagNames WarningFlag
wflag) in
            SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
col (String
"-W" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [WarningGroup] -> SDoc
warn_flag_grp (WarningFlag -> [WarningGroup]
smallestWarningGroups WarningFlag
wflag)
                                      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
                                      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
col (String
"Werror=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name)
          flag_msg Severity
SevError   (WarningWithCategory WarningCategory
cat) =
            SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ PprColour -> SDoc -> SDoc
coloured PprColour
msg_colour (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-W" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> WarningCategory -> SDoc
forall a. Outputable a => a -> SDoc
ppr WarningCategory
cat)
                       SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [WarningGroup] -> SDoc
warn_flag_grp [WarningGroup]
smallestWarningGroupsForCategory
                       SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
                       SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> PprColour -> SDoc -> SDoc
coloured PprColour
msg_colour (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-Werror=" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> WarningCategory -> SDoc
forall a. Outputable a => a -> SDoc
ppr WarningCategory
cat)
          flag_msg Severity
SevError   DiagnosticReason
ErrorWithoutFlag   = Maybe SDoc
forall a. Maybe a
Nothing
          flag_msg Severity
SevWarning DiagnosticReason
WarningWithoutFlag = Maybe SDoc
forall a. Maybe a
Nothing
          flag_msg Severity
SevWarning (WarningWithFlags (WarningFlag
wflag :| [WarningFlag]
_)) =
            let name :: String
name = NonEmpty String -> String
forall a. NonEmpty a -> a
NE.head (WarningFlag -> NonEmpty String
warnFlagNames WarningFlag
wflag) in
            SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
col (String
"-W" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [WarningGroup] -> SDoc
warn_flag_grp (WarningFlag -> [WarningGroup]
smallestWarningGroups WarningFlag
wflag))
          flag_msg Severity
SevWarning (WarningWithCategory WarningCategory
cat) =
            SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (PprColour -> SDoc -> SDoc
coloured PprColour
msg_colour (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-W" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> WarningCategory -> SDoc
forall a. Outputable a => a -> SDoc
ppr WarningCategory
cat)
                      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [WarningGroup] -> SDoc
warn_flag_grp [WarningGroup]
smallestWarningGroupsForCategory)
          flag_msg Severity
SevWarning DiagnosticReason
ErrorWithoutFlag =
            String -> SDoc -> Maybe SDoc
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"SevWarning with ErrorWithoutFlag" (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$
              [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"locn:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
locn
                   , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"msg:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SDoc
msg ]

          warn_flag_grp :: [WarningGroup] -> SDoc
warn_flag_grp [WarningGroup]
groups
              | Bool
show_warn_groups, Bool -> Bool
not ([WarningGroup] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [WarningGroup]
groups)
                          = String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"(in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((WarningGroup -> String) -> [WarningGroup] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"-W"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (WarningGroup -> String) -> WarningGroup -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarningGroup -> String
warningGroupName) [WarningGroup]
groups) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
              | Bool
otherwise = SDoc
forall doc. IsOutput doc => doc
empty

          -- Add prefixes, like    Foo.hs:34: warning:
          --                           <the warning message>
          header :: SDoc
header = SDoc
locn' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                   SDoc
msg_title SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                   SDoc
code_doc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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 ResolvedDiagnosticReason
_reason Maybe DiagnosticCode
_code)   = Scheme -> PprColour
Col.sError
getMessageClassColour (MCDiagnostic Severity
SevWarning ResolvedDiagnosticReason
_reason Maybe DiagnosticCode
_code) = 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
forall doc. IsOutput doc => doc
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)
      content <- String -> IO StringBuffer
hGetStringBuffer String
fn
      case atLine i 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
forall doc. IsOutput doc => doc
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
forall doc. IsLine doc => String -> doc
text String
marginSpace) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
      String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
"\n") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
      PprColour -> SDoc -> SDoc
coloured PprColour
marginColour (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
marginRow) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
      String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
srcLinePre) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
      PprColour -> SDoc -> SDoc
coloured PprColour
sevColour (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
srcLineSpan) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
      String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
srcLinePost String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
      PprColour -> SDoc -> SDoc
coloured PprColour
marginColour (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
marginSpace) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
      PprColour -> SDoc -> SDoc
coloured PprColour
sevColour (String -> SDoc
forall doc. IsLine doc => String -> doc
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
. ResolvedDiagnosticReason -> DiagnosticReason
resolvedDiagnosticReason (ResolvedDiagnosticReason -> DiagnosticReason)
-> (MsgEnvelope e -> ResolvedDiagnosticReason)
-> MsgEnvelope e
-> DiagnosticReason
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope e -> ResolvedDiagnosticReason
forall e. MsgEnvelope e -> ResolvedDiagnosticReason
errMsgReason

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)

----------------------------------------------------------------
--                                                            --
-- 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
    }
  deriving ( DiagnosticCode -> DiagnosticCode -> Bool
(DiagnosticCode -> DiagnosticCode -> Bool)
-> (DiagnosticCode -> DiagnosticCode -> Bool) -> Eq DiagnosticCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DiagnosticCode -> DiagnosticCode -> Bool
== :: DiagnosticCode -> DiagnosticCode -> Bool
$c/= :: DiagnosticCode -> DiagnosticCode -> Bool
/= :: DiagnosticCode -> DiagnosticCode -> Bool
Eq, Eq DiagnosticCode
Eq DiagnosticCode =>
(DiagnosticCode -> DiagnosticCode -> Ordering)
-> (DiagnosticCode -> DiagnosticCode -> Bool)
-> (DiagnosticCode -> DiagnosticCode -> Bool)
-> (DiagnosticCode -> DiagnosticCode -> Bool)
-> (DiagnosticCode -> DiagnosticCode -> Bool)
-> (DiagnosticCode -> DiagnosticCode -> DiagnosticCode)
-> (DiagnosticCode -> DiagnosticCode -> DiagnosticCode)
-> Ord DiagnosticCode
DiagnosticCode -> DiagnosticCode -> Bool
DiagnosticCode -> DiagnosticCode -> Ordering
DiagnosticCode -> DiagnosticCode -> DiagnosticCode
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DiagnosticCode -> DiagnosticCode -> Ordering
compare :: DiagnosticCode -> DiagnosticCode -> Ordering
$c< :: DiagnosticCode -> DiagnosticCode -> Bool
< :: DiagnosticCode -> DiagnosticCode -> Bool
$c<= :: DiagnosticCode -> DiagnosticCode -> Bool
<= :: DiagnosticCode -> DiagnosticCode -> Bool
$c> :: DiagnosticCode -> DiagnosticCode -> Bool
> :: DiagnosticCode -> DiagnosticCode -> Bool
$c>= :: DiagnosticCode -> DiagnosticCode -> Bool
>= :: DiagnosticCode -> DiagnosticCode -> Bool
$cmax :: DiagnosticCode -> DiagnosticCode -> DiagnosticCode
max :: DiagnosticCode -> DiagnosticCode -> DiagnosticCode
$cmin :: DiagnosticCode -> DiagnosticCode -> DiagnosticCode
min :: DiagnosticCode -> DiagnosticCode -> DiagnosticCode
Ord )

instance Show DiagnosticCode where
  show :: DiagnosticCode -> String
show (DiagnosticCode String
prefix Natural
c) =
    String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> Natural -> String
forall r. PrintfType r => String -> r
printf String
"%05d" Natural
c
      -- pad the numeric code to have at least 5 digits

instance Outputable DiagnosticCode where
  ppr :: DiagnosticCode -> SDoc
ppr DiagnosticCode
code = String -> SDoc
forall doc. IsLine doc => String -> doc
text (DiagnosticCode -> String
forall a. Show a => a -> String
show DiagnosticCode
code)

-- | A newtype that is a witness to the `-fprint-error-index-links` flag. It
-- alters the @Outputable@ instance to emit @DiagnosticCode@ as ANSI hyperlinks
-- to the HF error index
newtype LinkedDiagCode = LinkedDiagCode DiagnosticCode

instance Outputable LinkedDiagCode where
  ppr :: LinkedDiagCode -> SDoc
ppr (LinkedDiagCode d :: DiagnosticCode
d@DiagnosticCode{}) = DiagnosticCode -> SDoc
linkEscapeCode DiagnosticCode
d

-- | Wrap the link in terminal escape codes specified by OSC 8.
linkEscapeCode :: DiagnosticCode -> SDoc
linkEscapeCode :: DiagnosticCode -> SDoc
linkEscapeCode DiagnosticCode
d = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"\ESC]8;;" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> DiagnosticCode -> SDoc
hfErrorLink DiagnosticCode
d -- make the actual link
                   SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"\ESC\\" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> DiagnosticCode -> SDoc
forall a. Outputable a => a -> SDoc
ppr DiagnosticCode
d SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"\ESC]8;;\ESC\\" -- the rest is the visible text

-- | create a link to the HF error index given an error code.
hfErrorLink :: DiagnosticCode -> SDoc
hfErrorLink :: DiagnosticCode -> SDoc
hfErrorLink DiagnosticCode
errorCode = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"https://errors.haskell.org/messages/" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> DiagnosticCode -> SDoc
forall a. Outputable a => a -> SDoc
ppr DiagnosticCode
errorCode