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)