never executed always true always false
    1 {-# LANGUAGE GADTs #-}
    2 {-# LANGUAGE DeriveTraversable #-}
    3 {-# LANGUAGE DerivingStrategies #-}
    4 {-# LANGUAGE FlexibleInstances #-}
    5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    6 {-# LANGUAGE LambdaCase #-}
    7 
    8 module GHC.Types.Error
    9    ( -- * Messages
   10      Messages
   11    , mkMessages
   12    , getMessages
   13    , emptyMessages
   14    , isEmptyMessages
   15    , singleMessage
   16    , addMessage
   17    , unionMessages
   18    , unionManyMessages
   19    , MsgEnvelope (..)
   20 
   21    -- * Classifying Messages
   22 
   23    , MessageClass (..)
   24    , Severity (..)
   25    , Diagnostic (..)
   26    , DiagnosticMessage (..)
   27    , DiagnosticReason (..)
   28    , DiagnosticHint (..)
   29    , mkPlainDiagnostic
   30    , mkPlainError
   31    , mkDecoratedDiagnostic
   32    , mkDecoratedError
   33 
   34    -- * Hints and refactoring actions
   35    , GhcHint (..)
   36    , AvailableBindings(..)
   37    , LanguageExtensionHint(..)
   38    , suggestExtension
   39    , suggestExtensionWithInfo
   40    , suggestExtensions
   41    , suggestExtensionsWithInfo
   42    , suggestAnyExtension
   43    , suggestAnyExtensionWithInfo
   44    , useExtensionInOrderTo
   45    , noHints
   46 
   47     -- * Rendering Messages
   48 
   49    , SDoc
   50    , DecoratedSDoc (unDecorated)
   51    , mkDecorated, mkSimpleDecorated
   52    , unionDecoratedSDoc
   53    , mapDecoratedSDoc
   54 
   55    , pprMessageBag
   56    , mkLocMessage
   57    , mkLocMessageAnn
   58    , getCaretDiagnostic
   59    -- * Queries
   60    , isIntrinsicErrorMessage
   61    , isExtrinsicErrorMessage
   62    , isWarningMessage
   63    , getErrorMessages
   64    , getWarningMessages
   65    , partitionMessages
   66    , errorsFound
   67    , errorsOrFatalWarningsFound
   68    )
   69 where
   70 
   71 import GHC.Prelude
   72 
   73 import GHC.Driver.Flags
   74 
   75 import GHC.Data.Bag
   76 import GHC.IO (catchException)
   77 import GHC.Utils.Outputable as Outputable
   78 import qualified GHC.Utils.Ppr.Colour as Col
   79 import GHC.Types.SrcLoc as SrcLoc
   80 import GHC.Data.FastString (unpackFS)
   81 import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
   82 import GHC.Utils.Json
   83 
   84 import Data.Bifunctor
   85 import Data.Foldable    ( fold )
   86 import GHC.Types.Hint
   87 
   88 {-
   89 Note [Messages]
   90 ~~~~~~~~~~~~~~~
   91 
   92 We represent the 'Messages' as a single bag of warnings and errors.
   93 
   94 The reason behind that is that there is a fluid relationship between errors
   95 and warnings and we want to be able to promote or demote errors and warnings
   96 based on certain flags (e.g. -Werror, -fdefer-type-errors or
   97 -XPartialTypeSignatures). More specifically, every diagnostic has a
   98 'DiagnosticReason', but a warning 'DiagnosticReason' might be associated with
   99 'SevError', in the case of -Werror.
  100 
  101 We rely on the 'Severity' to distinguish between a warning and an error.
  102 
  103 'WarningMessages' and 'ErrorMessages' are for now simple type aliases to
  104 retain backward compatibility, but in future iterations these can be either
  105 parameterised over an 'e' message type (to make type signatures a bit more
  106 declarative) or removed altogether.
  107 -}
  108 
  109 -- | A collection of messages emitted by GHC during error reporting. A
  110 -- diagnostic message is typically a warning or an error. See Note [Messages].
  111 --
  112 -- /INVARIANT/: All the messages in this collection must be relevant, i.e.
  113 -- their 'Severity' should /not/ be 'SevIgnore'. The smart constructor
  114 -- 'mkMessages' will filter out any message which 'Severity' is 'SevIgnore'.
  115 newtype Messages e = Messages { getMessages :: Bag (MsgEnvelope e) }
  116   deriving newtype (Semigroup, Monoid)
  117   deriving stock (Functor, Foldable, Traversable)
  118 
  119 emptyMessages :: Messages e
  120 emptyMessages = Messages emptyBag
  121 
  122 mkMessages :: Bag (MsgEnvelope e) -> Messages e
  123 mkMessages = Messages . filterBag interesting
  124   where
  125     interesting :: MsgEnvelope e -> Bool
  126     interesting = (/=) SevIgnore . errMsgSeverity
  127 
  128 isEmptyMessages :: Messages e -> Bool
  129 isEmptyMessages (Messages msgs) = isEmptyBag msgs
  130 
  131 singleMessage :: MsgEnvelope e -> Messages e
  132 singleMessage e = addMessage e emptyMessages
  133 
  134 {- Note [Discarding Messages]
  135 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  136 
  137 Discarding a 'SevIgnore' message from 'addMessage' and 'unionMessages' is just
  138 an optimisation, as GHC would /also/ suppress any diagnostic which severity is
  139 'SevIgnore' before printing the message: See for example 'putLogMsg' and
  140 'defaultLogAction'.
  141 
  142 -}
  143 
  144 -- | Adds a 'Message' to the input collection of messages.
  145 -- See Note [Discarding Messages].
  146 addMessage :: MsgEnvelope e -> Messages e -> Messages e
  147 addMessage x (Messages xs)
  148   | SevIgnore <- errMsgSeverity x = Messages xs
  149   | otherwise                     = Messages (x `consBag` xs)
  150 
  151 -- | Joins two collections of messages together.
  152 -- See Note [Discarding Messages].
  153 unionMessages :: Messages e -> Messages e -> Messages e
  154 unionMessages (Messages msgs1) (Messages msgs2) =
  155   Messages (msgs1 `unionBags` msgs2)
  156 
  157 -- | Joins many 'Messages's together
  158 unionManyMessages :: Foldable f => f (Messages e) -> Messages e
  159 unionManyMessages = fold
  160 
  161 -- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the
  162 -- invariant that the input '[SDoc]' needs to be rendered /decorated/ into its
  163 -- final form, where the typical case would be adding bullets between each
  164 -- elements of the list. The type of decoration depends on the formatting
  165 -- function used, but in practice GHC uses the 'formatBulleted'.
  166 newtype DecoratedSDoc = Decorated { unDecorated :: [SDoc] }
  167 
  168 -- | Creates a new 'DecoratedSDoc' out of a list of 'SDoc'.
  169 mkDecorated :: [SDoc] -> DecoratedSDoc
  170 mkDecorated = Decorated
  171 
  172 -- | Creates a new 'DecoratedSDoc' out of a single 'SDoc'
  173 mkSimpleDecorated :: SDoc -> DecoratedSDoc
  174 mkSimpleDecorated doc = Decorated [doc]
  175 
  176 -- | Joins two 'DecoratedSDoc' together. The resulting 'DecoratedSDoc'
  177 -- will have a number of entries which is the sum of the lengths of
  178 -- the input.
  179 unionDecoratedSDoc :: DecoratedSDoc -> DecoratedSDoc -> DecoratedSDoc
  180 unionDecoratedSDoc (Decorated s1) (Decorated s2) =
  181   Decorated (s1 `mappend` s2)
  182 
  183 -- | Apply a transformation function to all elements of a 'DecoratedSDoc'.
  184 mapDecoratedSDoc :: (SDoc -> SDoc) -> DecoratedSDoc -> DecoratedSDoc
  185 mapDecoratedSDoc f (Decorated s1) =
  186   Decorated (map f s1)
  187 
  188 {-
  189 Note [Rendering Messages]
  190 ~~~~~~~~~~~~~~~~~~~~~~~~~
  191 
  192 Turning 'Messages' into something that renders nicely for the user is one of
  193 the last steps, and it happens typically at the application's boundaries (i.e.
  194 from the 'Driver' upwards).
  195 
  196 For now (see #18516) this class has few instance, but the idea is that as the
  197 more domain-specific types are defined, the more instances we would get. For
  198 example, given something like:
  199 
  200   data TcRnDiagnostic
  201     = TcRnOutOfScope ..
  202     | ..
  203 
  204   newtype TcRnMessage = TcRnMessage (DiagnosticMessage TcRnDiagnostic)
  205 
  206 We could then define how a 'TcRnDiagnostic' is displayed to the user. Rather
  207 than scattering pieces of 'SDoc' around the codebase, we would write once for
  208 all:
  209 
  210   instance Diagnostic TcRnDiagnostic where
  211     diagnosticMessage (TcRnMessage msg) = case diagMessage msg of
  212       TcRnOutOfScope .. -> Decorated [text "Out of scope error ..."]
  213       ...
  214 
  215 This way, we can easily write generic rendering functions for errors that all
  216 they care about is the knowledge that a given type 'e' has a 'Diagnostic'
  217 constraint.
  218 
  219 -}
  220 
  221 -- | A class identifying a diagnostic.
  222 -- Dictionary.com defines a diagnostic as:
  223 --
  224 -- \"a message output by a computer diagnosing an error in a computer program,
  225 -- computer system, or component device\".
  226 --
  227 -- A 'Diagnostic' carries the /actual/ description of the message (which, in
  228 -- GHC's case, it can be an error or a warning) and the /reason/ why such
  229 -- message was generated in the first place. See also Note [Rendering
  230 -- Messages].
  231 class Diagnostic a where
  232   diagnosticMessage :: a -> DecoratedSDoc
  233   diagnosticReason  :: a -> DiagnosticReason
  234   diagnosticHints   :: a -> [GhcHint]
  235 
  236 -- | A generic 'Hint' message, to be used with 'DiagnosticMessage'.
  237 data DiagnosticHint = DiagnosticHint !SDoc
  238 
  239 instance Outputable DiagnosticHint where
  240   ppr (DiagnosticHint msg) = msg
  241 
  242 -- | A generic 'Diagnostic' message, without any further classification or
  243 -- provenance: By looking at a 'DiagnosticMessage' we don't know neither
  244 -- /where/ it was generated nor how to intepret its payload (as it's just a
  245 -- structured document). All we can do is to print it out and look at its
  246 -- 'DiagnosticReason'.
  247 data DiagnosticMessage = DiagnosticMessage
  248   { diagMessage :: !DecoratedSDoc
  249   , diagReason  :: !DiagnosticReason
  250   , diagHints   :: [GhcHint]
  251   }
  252 
  253 instance Diagnostic DiagnosticMessage where
  254   diagnosticMessage = diagMessage
  255   diagnosticReason  = diagReason
  256   diagnosticHints   = diagHints
  257 
  258 -- | Helper function to use when no hints can be provided. Currently this function
  259 -- can be used to construct plain 'DiagnosticMessage' and add hints to them, but
  260 -- once #18516 will be fully executed, the main usage of this function would be in
  261 -- the implementation of the 'diagnosticHints' typeclass method, to report the fact
  262 -- that a particular 'Diagnostic' has no hints.
  263 noHints :: [GhcHint]
  264 noHints = mempty
  265 
  266 mkPlainDiagnostic :: DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
  267 mkPlainDiagnostic rea hints doc = DiagnosticMessage (mkSimpleDecorated doc) rea hints
  268 
  269 -- | Create an error 'DiagnosticMessage' holding just a single 'SDoc'
  270 mkPlainError :: [GhcHint] -> SDoc -> DiagnosticMessage
  271 mkPlainError hints doc = DiagnosticMessage (mkSimpleDecorated doc) ErrorWithoutFlag hints
  272 
  273 -- | Create a 'DiagnosticMessage' from a list of bulleted SDocs and a 'DiagnosticReason'
  274 mkDecoratedDiagnostic :: DiagnosticReason -> [GhcHint] -> [SDoc] -> DiagnosticMessage
  275 mkDecoratedDiagnostic rea hints docs = DiagnosticMessage (mkDecorated docs) rea hints
  276 
  277 -- | Create an error 'DiagnosticMessage' from a list of bulleted SDocs
  278 mkDecoratedError :: [GhcHint] -> [SDoc] -> DiagnosticMessage
  279 mkDecoratedError hints docs = DiagnosticMessage (mkDecorated docs) ErrorWithoutFlag hints
  280 
  281 -- | The reason /why/ a 'Diagnostic' was emitted in the first place.
  282 -- Diagnostic messages are born within GHC with a very precise reason, which
  283 -- can be completely statically-computed (i.e. this is an error or a warning
  284 -- no matter what), or influenced by the specific state of the 'DynFlags' at
  285 -- the moment of the creation of a new 'Diagnostic'. For example, a parsing
  286 -- error is /always/ going to be an error, whereas a 'WarningWithoutFlag
  287 -- Opt_WarnUnusedImports' might turn into an error due to '-Werror' or
  288 -- '-Werror=warn-unused-imports'. Interpreting a 'DiagnosticReason' together
  289 -- with its associated 'Severity' gives us the full picture.
  290 data DiagnosticReason
  291   = WarningWithoutFlag
  292   -- ^ Born as a warning.
  293   | WarningWithFlag !WarningFlag
  294   -- ^ Warning was enabled with the flag.
  295   | ErrorWithoutFlag
  296   -- ^ Born as an error.
  297   deriving (Eq, Show)
  298 
  299 instance Outputable DiagnosticReason where
  300   ppr = \case
  301     WarningWithoutFlag  -> text "WarningWithoutFlag"
  302     WarningWithFlag wf  -> text ("WarningWithFlag " ++ show wf)
  303     ErrorWithoutFlag    -> text "ErrorWithoutFlag"
  304 
  305 -- | An envelope for GHC's facts about a running program, parameterised over the
  306 -- /domain-specific/ (i.e. parsing, typecheck-renaming, etc) diagnostics.
  307 --
  308 -- To say things differently, GHC emits /diagnostics/ about the running
  309 -- program, each of which is wrapped into a 'MsgEnvelope' that carries
  310 -- specific information like where the error happened, etc. Finally, multiple
  311 -- 'MsgEnvelope's are aggregated into 'Messages' that are returned to the
  312 -- user.
  313 data MsgEnvelope e = MsgEnvelope
  314    { errMsgSpan        :: SrcSpan
  315       -- ^ The SrcSpan is used for sorting errors into line-number order
  316    , errMsgContext     :: PrintUnqualified
  317    , errMsgDiagnostic  :: e
  318    , errMsgSeverity    :: Severity
  319    } deriving (Functor, Foldable, Traversable)
  320 
  321 -- | The class for a diagnostic message. The main purpose is to classify a
  322 -- message within GHC, to distinguish it from a debug/dump message vs a proper
  323 -- diagnostic, for which we include a 'DiagnosticReason'.
  324 data MessageClass
  325   = MCOutput
  326   | MCFatal
  327   | MCInteractive
  328 
  329   | MCDump
  330     -- ^ Log message intended for compiler developers
  331     -- No file\/line\/column stuff
  332 
  333   | MCInfo
  334     -- ^ Log messages intended for end users.
  335     -- No file\/line\/column stuff.
  336 
  337   | MCDiagnostic Severity DiagnosticReason
  338     -- ^ Diagnostics from the compiler. This constructor is very powerful as
  339     -- it allows the construction of a 'MessageClass' with a completely
  340     -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such,
  341     -- users are encouraged to use the 'mkMCDiagnostic' smart constructor
  342     -- instead. Use this constructor directly only if you need to construct
  343     -- and manipulate diagnostic messages directly, for example inside
  344     -- 'GHC.Utils.Error'. In all the other circumstances, /especially/ when
  345     -- emitting compiler diagnostics, use the smart constructor.
  346   deriving (Eq, Show)
  347 
  348 {- Note [Suppressing Messages]
  349 
  350 The 'SevIgnore' constructor is used to generate messages for diagnostics which
  351 are meant to be suppressed and not reported to the user: the classic example
  352 are warnings for which the user didn't enable the corresponding 'WarningFlag',
  353 so GHC shouldn't print them.
  354 
  355 A different approach would be to extend the zoo of 'mkMsgEnvelope' functions
  356 to return a 'Maybe (MsgEnvelope e)', so that we won't need to even create the
  357 message to begin with. Both approaches have been evaluated, but we settled on
  358 the "SevIgnore one" for a number of reasons:
  359 
  360 * It's less invasive to deal with;
  361 * It plays slightly better with deferred diagnostics (see 'GHC.Tc.Errors') as
  362   for those we need to be able to /always/ produce a message (so that is
  363   reported at runtime);
  364 * It gives us more freedom: we can still decide to drop a 'SevIgnore' message
  365   at leisure, or we can decide to keep it around until the last moment. Maybe
  366   in the future we would need to turn a 'SevIgnore' into something else, for
  367   example to "unsuppress" diagnostics if a flag is set: with this approach, we
  368   have more leeway to accommodate new features.
  369 
  370 -}
  371 
  372 
  373 -- | Used to describe warnings and errors
  374 --   o The message has a file\/line\/column heading,
  375 --     plus "warning:" or "error:",
  376 --     added by mkLocMessage
  377 --   o With 'SevIgnore' the message is suppressed
  378 --   o Output is intended for end users
  379 data Severity
  380   = SevIgnore
  381   -- ^ Ignore this message, for example in
  382   -- case of suppression of warnings users
  383   -- don't want to see. See Note [Suppressing Messages]
  384   | SevWarning
  385   | SevError
  386   deriving (Eq, Show)
  387 
  388 instance Outputable Severity where
  389   ppr = \case
  390     SevIgnore  -> text "SevIgnore"
  391     SevWarning -> text "SevWarning"
  392     SevError   -> text "SevError"
  393 
  394 instance ToJson Severity where
  395   json s = JSString (show s)
  396 
  397 instance ToJson MessageClass where
  398   json MCOutput = JSString "MCOutput"
  399   json MCFatal  = JSString "MCFatal"
  400   json MCInteractive = JSString "MCInteractive"
  401   json MCDump = JSString "MCDump"
  402   json MCInfo = JSString "MCInfo"
  403   json (MCDiagnostic sev reason) =
  404     JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason)
  405 
  406 instance Show (MsgEnvelope DiagnosticMessage) where
  407     show = showMsgEnvelope
  408 
  409 -- | Shows an 'MsgEnvelope'.
  410 showMsgEnvelope :: Diagnostic a => MsgEnvelope a -> String
  411 showMsgEnvelope err =
  412   renderWithContext defaultSDocContext (vcat (unDecorated . diagnosticMessage $ errMsgDiagnostic err))
  413 
  414 pprMessageBag :: Bag SDoc -> SDoc
  415 pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
  416 
  417 -- | Make an unannotated error message with location info.
  418 mkLocMessage :: MessageClass -> SrcSpan -> SDoc -> SDoc
  419 mkLocMessage = mkLocMessageAnn Nothing
  420 
  421 -- | Make a possibly annotated error message with location info.
  422 mkLocMessageAnn
  423   :: Maybe String                       -- ^ optional annotation
  424   -> MessageClass                       -- ^ What kind of message?
  425   -> SrcSpan                            -- ^ location
  426   -> SDoc                               -- ^ message
  427   -> SDoc
  428   -- Always print the location, even if it is unhelpful.  Error messages
  429   -- are supposed to be in a standard format, and one without a location
  430   -- would look strange.  Better to say explicitly "<no location info>".
  431 mkLocMessageAnn ann msg_class locn msg
  432     = sdocOption sdocColScheme $ \col_scheme ->
  433       let locn' = sdocOption sdocErrorSpans $ \case
  434                      True  -> ppr locn
  435                      False -> ppr (srcSpanStart locn)
  436 
  437           msgColour = getMessageClassColour msg_class col_scheme
  438 
  439           -- Add optional information
  440           optAnn = case ann of
  441             Nothing -> text ""
  442             Just i  -> text " [" <> coloured msgColour (text i) <> text "]"
  443 
  444           -- Add prefixes, like    Foo.hs:34: warning:
  445           --                           <the warning message>
  446           header = locn' <> colon <+>
  447                    coloured msgColour msgText <> optAnn
  448 
  449       in coloured (Col.sMessage col_scheme)
  450                   (hang (coloured (Col.sHeader col_scheme) header) 4
  451                         msg)
  452 
  453   where
  454     msgText =
  455       case msg_class of
  456         MCDiagnostic SevError _reason   -> text "error:"
  457         MCDiagnostic SevWarning _reason -> text "warning:"
  458         MCFatal                         -> text "fatal:"
  459         _                               -> empty
  460 
  461 getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour
  462 getMessageClassColour (MCDiagnostic SevError _reason)   = Col.sError
  463 getMessageClassColour (MCDiagnostic SevWarning _reason) = Col.sWarning
  464 getMessageClassColour MCFatal                           = Col.sFatal
  465 getMessageClassColour _                                 = const mempty
  466 
  467 getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc
  468 getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
  469 getCaretDiagnostic msg_class (RealSrcSpan span _) =
  470   caretDiagnostic <$> getSrcLine (srcSpanFile span) row
  471   where
  472     getSrcLine fn i =
  473       getLine i (unpackFS fn)
  474         `catchException` \(_ :: IOError) ->
  475           pure Nothing
  476 
  477     getLine i fn = do
  478       -- StringBuffer has advantages over readFile:
  479       -- (a) no lazy IO, otherwise IO exceptions may occur in pure code
  480       -- (b) always UTF-8, rather than some system-dependent encoding
  481       --     (Haskell source code must be UTF-8 anyway)
  482       content <- hGetStringBuffer fn
  483       case atLine i content of
  484         Just at_line -> pure $
  485           case lines (fix <$> lexemeToString at_line (len at_line)) of
  486             srcLine : _ -> Just srcLine
  487             _           -> Nothing
  488         _ -> pure Nothing
  489 
  490     -- allow user to visibly see that their code is incorrectly encoded
  491     -- (StringBuffer.nextChar uses \0 to represent undecodable characters)
  492     fix '\0' = '\xfffd'
  493     fix c    = c
  494 
  495     row = srcSpanStartLine span
  496     rowStr = show row
  497     multiline = row /= srcSpanEndLine span
  498 
  499     caretDiagnostic Nothing = empty
  500     caretDiagnostic (Just srcLineWithNewline) =
  501       sdocOption sdocColScheme$ \col_scheme ->
  502       let sevColour = getMessageClassColour msg_class col_scheme
  503           marginColour = Col.sMargin col_scheme
  504       in
  505       coloured marginColour (text marginSpace) <>
  506       text ("\n") <>
  507       coloured marginColour (text marginRow) <>
  508       text (" " ++ srcLinePre) <>
  509       coloured sevColour (text srcLineSpan) <>
  510       text (srcLinePost ++ "\n") <>
  511       coloured marginColour (text marginSpace) <>
  512       coloured sevColour (text (" " ++ caretLine))
  513 
  514       where
  515 
  516         -- expand tabs in a device-independent manner #13664
  517         expandTabs tabWidth i s =
  518           case s of
  519             ""        -> ""
  520             '\t' : cs -> replicate effectiveWidth ' ' ++
  521                          expandTabs tabWidth (i + effectiveWidth) cs
  522             c    : cs -> c : expandTabs tabWidth (i + 1) cs
  523           where effectiveWidth = tabWidth - i `mod` tabWidth
  524 
  525         srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline)
  526 
  527         start = srcSpanStartCol span - 1
  528         end | multiline = length srcLine
  529             | otherwise = srcSpanEndCol span - 1
  530         width = max 1 (end - start)
  531 
  532         marginWidth = length rowStr
  533         marginSpace = replicate marginWidth ' ' ++ " |"
  534         marginRow   = rowStr ++ " |"
  535 
  536         (srcLinePre,  srcLineRest) = splitAt start srcLine
  537         (srcLineSpan, srcLinePost) = splitAt width srcLineRest
  538 
  539         caretEllipsis | multiline = "..."
  540                       | otherwise = ""
  541         caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis
  542 
  543 --
  544 -- Queries
  545 --
  546 
  547 {- Note [Intrinsic And Extrinsic Failures]
  548 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  549 
  550 We distinguish between /intrinsic/ and /extrinsic/ failures. We classify in
  551 the former category those diagnostics which are /essentially/ failures, and
  552 their nature can't be changed. This is the case for 'ErrorWithoutFlag'. We
  553 classify as /extrinsic/ all those diagnostics (like fatal warnings) which are
  554 born as warnings but which are still failures under particular 'DynFlags'
  555 settings. It's important to be aware of such logic distinction, because when
  556 we are inside the typechecker or the desugarer, we are interested about
  557 intrinsic errors, and to bail out as soon as we find one of them. Conversely,
  558 if we find an /extrinsic/ one, for example because a particular 'WarningFlag'
  559 makes a warning and error, we /don't/ want to bail out, that's still not the
  560 right time to do so: Rather, we want to first collect all the diagnostics, and
  561 later classify and report them appropriately (in the driver).
  562 -}
  563 
  564 -- | Returns 'True' if this is, intrinsically, a failure. See
  565 -- Note [Intrinsic And Extrinsic Failures].
  566 isIntrinsicErrorMessage :: Diagnostic e => MsgEnvelope e -> Bool
  567 isIntrinsicErrorMessage = (==) ErrorWithoutFlag . diagnosticReason . errMsgDiagnostic
  568 
  569 isWarningMessage :: Diagnostic e => MsgEnvelope e -> Bool
  570 isWarningMessage = not . isIntrinsicErrorMessage
  571 
  572 -- | Are there any hard errors here? -Werror warnings are /not/ detected. If
  573 -- you want to check for -Werror warnings, use 'errorsOrFatalWarningsFound'.
  574 errorsFound :: Diagnostic e => Messages e -> Bool
  575 errorsFound (Messages msgs) = any isIntrinsicErrorMessage msgs
  576 
  577 -- | Returns 'True' if the envelope contains a message that will stop
  578 -- compilation: either an intrinsic error or a fatal (-Werror) warning
  579 isExtrinsicErrorMessage :: MsgEnvelope e -> Bool
  580 isExtrinsicErrorMessage = (==) SevError . errMsgSeverity
  581 
  582 -- | Are there any errors or -Werror warnings here?
  583 errorsOrFatalWarningsFound :: Messages e -> Bool
  584 errorsOrFatalWarningsFound (Messages msgs) = any isExtrinsicErrorMessage msgs
  585 
  586 getWarningMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e)
  587 getWarningMessages (Messages xs) = fst $ partitionBag isWarningMessage xs
  588 
  589 getErrorMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e)
  590 getErrorMessages (Messages xs) = fst $ partitionBag isIntrinsicErrorMessage xs
  591 
  592 -- | Partitions the 'Messages' and returns a tuple which first element are the
  593 -- warnings, and the second the errors.
  594 partitionMessages :: Diagnostic e => Messages e -> (Messages e, Messages e)
  595 partitionMessages (Messages xs) = bimap Messages Messages (partitionBag isWarningMessage xs)