Make diagnostics slightly more colorful
[ghc.git] / compiler / main / ErrUtils.hs
1 {-
2 (c) The AQUA Project, Glasgow University, 1994-1998
3
4 \section[ErrsUtils]{Utilities for error reporting}
5 -}
6
7 {-# LANGUAGE CPP #-}
8 {-# LANGUAGE BangPatterns #-}
9
10 module ErrUtils (
11 -- * Basic types
12 Validity(..), andValid, allValid, isValid, getInvalids,
13 Severity(..),
14
15 -- * Messages
16 ErrMsg, errMsgDoc,
17 ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary,
18 WarnMsg, MsgDoc,
19 Messages, ErrorMessages, WarningMessages,
20 unionMessages,
21 errMsgSpan, errMsgContext,
22 errorsFound, isEmptyMessages,
23 isWarnMsgFatal,
24
25 -- ** Formatting
26 pprMessageBag, pprErrMsgBagWithLoc,
27 pprLocErrMsg, printBagOfErrors,
28 formatErrDoc,
29
30 -- ** Construction
31 emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
32 mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,
33 mkPlainWarnMsg,
34 warnIsErrorMsg, mkLongWarnMsg,
35
36 -- * Utilities
37 doIfSet, doIfSet_dyn,
38
39 -- * Dump files
40 dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
41 mkDumpDoc, dumpSDoc,
42
43 -- * Issuing messages during compilation
44 putMsg, printInfoForUser, printOutputForUser,
45 logInfo, logOutput,
46 errorMsg, warningMsg,
47 fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
48 compilationProgressMsg,
49 showPass, withTiming,
50 debugTraceMsg,
51 ghcExit,
52 prettyPrintGhcErrors,
53 ) where
54
55 #include "HsVersions.h"
56
57 import Bag
58 import Exception
59 import Outputable
60 import Panic
61 import SrcLoc
62 import DynFlags
63
64 import System.Directory
65 import System.Exit ( ExitCode(..), exitWith )
66 import System.FilePath ( takeDirectory, (</>) )
67 import Data.List
68 import qualified Data.Set as Set
69 import Data.IORef
70 import Data.Maybe ( fromMaybe )
71 import Data.Monoid ( mappend )
72 import Data.Ord
73 import Data.Time
74 import Control.Monad
75 import Control.Monad.IO.Class
76 import System.IO
77 import GHC.Conc ( getAllocationCounter )
78 import System.CPUTime
79
80 -------------------------
81 type MsgDoc = SDoc
82
83 -------------------------
84 data Validity
85 = IsValid -- ^ Everything is fine
86 | NotValid MsgDoc -- ^ A problem, and some indication of why
87
88 isValid :: Validity -> Bool
89 isValid IsValid = True
90 isValid (NotValid {}) = False
91
92 andValid :: Validity -> Validity -> Validity
93 andValid IsValid v = v
94 andValid v _ = v
95
96 -- | If they aren't all valid, return the first
97 allValid :: [Validity] -> Validity
98 allValid [] = IsValid
99 allValid (v : vs) = v `andValid` allValid vs
100
101 getInvalids :: [Validity] -> [MsgDoc]
102 getInvalids vs = [d | NotValid d <- vs]
103
104 -- -----------------------------------------------------------------------------
105 -- Basic error messages: just render a message with a source location.
106
107 type Messages = (WarningMessages, ErrorMessages)
108 type WarningMessages = Bag WarnMsg
109 type ErrorMessages = Bag ErrMsg
110
111 unionMessages :: Messages -> Messages -> Messages
112 unionMessages (warns1, errs1) (warns2, errs2) =
113 (warns1 `unionBags` warns2, errs1 `unionBags` errs2)
114
115 data ErrMsg = ErrMsg {
116 errMsgSpan :: SrcSpan,
117 errMsgContext :: PrintUnqualified,
118 errMsgDoc :: ErrDoc,
119 -- | This has the same text as errDocImportant . errMsgDoc.
120 errMsgShortString :: String,
121 errMsgSeverity :: Severity,
122 errMsgReason :: WarnReason
123 }
124 -- The SrcSpan is used for sorting errors into line-number order
125
126 -- | Categorise error msgs by their importance. This is so each section can
127 -- be rendered visually distinct. See Note [Error report] for where these come
128 -- from.
129 data ErrDoc = ErrDoc {
130 -- | Primary error msg.
131 errDocImportant :: [MsgDoc],
132 -- | Context e.g. \"In the second argument of ...\".
133 errDocContext :: [MsgDoc],
134 -- | Supplementary information, e.g. \"Relevant bindings include ...\".
135 errDocSupplementary :: [MsgDoc]
136 }
137
138 errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
139 errDoc = ErrDoc
140
141 type WarnMsg = ErrMsg
142
143 data Severity
144 = SevOutput
145 | SevFatal
146 | SevInteractive
147
148 | SevDump
149 -- ^ Log messagse intended for compiler developers
150 -- No file/line/column stuff
151
152 | SevInfo
153 -- ^ Log messages intended for end users.
154 -- No file/line/column stuff.
155
156 | SevWarning
157 | SevError
158 -- ^ SevWarning and SevError are used for warnings and errors
159 -- o The message has a file/line/column heading,
160 -- plus "warning:" or "error:",
161 -- added by mkLocMessags
162 -- o Output is intended for end users
163
164
165 instance Show ErrMsg where
166 show em = errMsgShortString em
167
168 pprMessageBag :: Bag MsgDoc -> SDoc
169 pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
170
171 mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
172 mkLocMessage = mkLocMessageAnn Nothing
173
174 mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
175 -- Always print the location, even if it is unhelpful. Error messages
176 -- are supposed to be in a standard format, and one without a location
177 -- would look strange. Better to say explicitly "<no location info>".
178 mkLocMessageAnn ann severity locn msg
179 = sdocWithDynFlags $ \dflags ->
180 let locn' = if gopt Opt_ErrorSpans dflags
181 then ppr locn
182 else ppr (srcSpanStart locn)
183 in bold (hang (locn' <> colon <+> sevInfo <> optAnn) 4 msg)
184 where
185 -- Add prefixes, like Foo.hs:34: warning:
186 -- <the warning message>
187 (sevInfo, sevColor) =
188 case severity of
189 SevWarning ->
190 (coloured sevColor (text "warning:"), colBold `mappend` colMagentaFg)
191 SevError ->
192 (coloured sevColor (text "error:"), colBold `mappend` colRedFg)
193 SevFatal ->
194 (coloured sevColor (text "fatal:"), colBold `mappend` colRedFg)
195 _ ->
196 (empty, mempty)
197
198 -- Add optional information
199 optAnn = case ann of
200 Nothing -> text ""
201 Just i -> text " [" <> coloured sevColor (text i) <> text "]"
202
203 makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
204 makeIntoWarning reason err = err
205 { errMsgSeverity = SevWarning
206 , errMsgReason = reason }
207
208 -- -----------------------------------------------------------------------------
209 -- Collecting up messages for later ordering and printing.
210
211 mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
212 mk_err_msg dflags sev locn print_unqual doc
213 = ErrMsg { errMsgSpan = locn
214 , errMsgContext = print_unqual
215 , errMsgDoc = doc
216 , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc))
217 , errMsgSeverity = sev
218 , errMsgReason = NoReason }
219
220 mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
221 mkErrDoc dflags = mk_err_msg dflags SevError
222
223 mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
224 -- ^ A long (multi-line) error message
225 mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg
226 -- ^ A short (one-line) error message
227 mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
228 -- ^ Variant that doesn't care about qualified/unqualified names
229
230 mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [extra])
231 mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [])
232 mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify (ErrDoc [msg] [] [])
233 mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [extra])
234 mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [])
235 mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] [])
236
237 ----------------
238 emptyMessages :: Messages
239 emptyMessages = (emptyBag, emptyBag)
240
241 isEmptyMessages :: Messages -> Bool
242 isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs
243
244 warnIsErrorMsg :: DynFlags -> ErrMsg
245 warnIsErrorMsg dflags
246 = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.")
247
248 errorsFound :: DynFlags -> Messages -> Bool
249 errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
250
251 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
252 printBagOfErrors dflags bag_of_errors
253 = sequence_ [ let style = mkErrStyle dflags unqual
254 in log_action dflags dflags reason sev s style (formatErrDoc dflags doc)
255 | ErrMsg { errMsgSpan = s,
256 errMsgDoc = doc,
257 errMsgSeverity = sev,
258 errMsgReason = reason,
259 errMsgContext = unqual } <- sortMsgBag (Just dflags)
260 bag_of_errors ]
261
262 formatErrDoc :: DynFlags -> ErrDoc -> SDoc
263 formatErrDoc dflags (ErrDoc important context supplementary)
264 = case msgs of
265 [msg] -> vcat msg
266 _ -> vcat $ map starred msgs
267 where
268 msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags))
269 [important, context, supplementary]
270 starred = (bullet<+>) . vcat
271 bullet = text $ if DynFlags.useUnicode dflags then "•" else "*"
272
273 pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
274 pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]
275
276 pprLocErrMsg :: ErrMsg -> SDoc
277 pprLocErrMsg (ErrMsg { errMsgSpan = s
278 , errMsgDoc = doc
279 , errMsgSeverity = sev
280 , errMsgContext = unqual })
281 = sdocWithDynFlags $ \dflags ->
282 withPprStyle (mkErrStyle dflags unqual) $
283 mkLocMessage sev s (formatErrDoc dflags doc)
284
285 sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
286 sortMsgBag dflags = sortBy (maybeFlip $ comparing errMsgSpan) . bagToList
287 where maybeFlip :: (a -> a -> b) -> (a -> a -> b)
288 maybeFlip
289 | fromMaybe False (fmap reverseErrors dflags) = flip
290 | otherwise = id
291
292 ghcExit :: DynFlags -> Int -> IO ()
293 ghcExit dflags val
294 | val == 0 = exitWith ExitSuccess
295 | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
296 exitWith (ExitFailure val)
297
298 doIfSet :: Bool -> IO () -> IO ()
299 doIfSet flag action | flag = action
300 | otherwise = return ()
301
302 doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
303 doIfSet_dyn dflags flag action | gopt flag dflags = action
304 | otherwise = return ()
305
306 -- -----------------------------------------------------------------------------
307 -- Dumping
308
309 dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
310 dumpIfSet dflags flag hdr doc
311 | not flag = return ()
312 | otherwise = log_action dflags
313 dflags
314 NoReason
315 SevDump
316 noSrcSpan
317 defaultDumpStyle
318 (mkDumpDoc hdr doc)
319
320 -- | a wrapper around 'dumpSDoc'.
321 -- First check whether the dump flag is set
322 -- Do nothing if it is unset
323 dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
324 dumpIfSet_dyn dflags flag hdr doc
325 = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc
326
327 -- | a wrapper around 'dumpSDoc'.
328 -- First check whether the dump flag is set
329 -- Do nothing if it is unset
330 --
331 -- Unlike 'dumpIfSet_dyn',
332 -- has a printer argument but no header argument
333 dumpIfSet_dyn_printer :: PrintUnqualified
334 -> DynFlags -> DumpFlag -> SDoc -> IO ()
335 dumpIfSet_dyn_printer printer dflags flag doc
336 = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc
337
338 mkDumpDoc :: String -> SDoc -> SDoc
339 mkDumpDoc hdr doc
340 = vcat [blankLine,
341 line <+> text hdr <+> line,
342 doc,
343 blankLine]
344 where
345 line = text (replicate 20 '=')
346
347
348 -- | Write out a dump.
349 -- If --dump-to-file is set then this goes to a file.
350 -- otherwise emit to stdout.
351 --
352 -- When @hdr@ is empty, we print in a more compact format (no separators and
353 -- blank lines)
354 --
355 -- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@
356 -- is used; it is not used to decide whether to dump the output
357 dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
358 dumpSDoc dflags print_unqual flag hdr doc
359 = do let mFile = chooseDumpFile dflags flag
360 dump_style = mkDumpStyle print_unqual
361 case mFile of
362 Just fileName
363 -> do
364 let gdref = generatedDumps dflags
365 gd <- readIORef gdref
366 let append = Set.member fileName gd
367 mode = if append then AppendMode else WriteMode
368 unless append $
369 writeIORef gdref (Set.insert fileName gd)
370 createDirectoryIfMissing True (takeDirectory fileName)
371 handle <- openFile fileName mode
372
373 -- We do not want the dump file to be affected by
374 -- environment variables, but instead to always use
375 -- UTF8. See:
376 -- https://ghc.haskell.org/trac/ghc/ticket/10762
377 hSetEncoding handle utf8
378
379 doc' <- if null hdr
380 then return doc
381 else do t <- getCurrentTime
382 let d = text (show t)
383 $$ blankLine
384 $$ doc
385 return $ mkDumpDoc hdr d
386 defaultLogActionHPrintDoc dflags handle doc' dump_style
387 hClose handle
388
389 -- write the dump to stdout
390 Nothing -> do
391 let (doc', severity)
392 | null hdr = (doc, SevOutput)
393 | otherwise = (mkDumpDoc hdr doc, SevDump)
394 log_action dflags dflags NoReason severity noSrcSpan dump_style doc'
395
396
397 -- | Choose where to put a dump file based on DynFlags
398 --
399 chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
400 chooseDumpFile dflags flag
401
402 | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file
403 , Just prefix <- getPrefix
404 = Just $ setDir (prefix ++ (beautifyDumpName flag))
405
406 | otherwise
407 = Nothing
408
409 where getPrefix
410 -- dump file location is being forced
411 -- by the --ddump-file-prefix flag.
412 | Just prefix <- dumpPrefixForce dflags
413 = Just prefix
414 -- dump file location chosen by DriverPipeline.runPipeline
415 | Just prefix <- dumpPrefix dflags
416 = Just prefix
417 -- we haven't got a place to put a dump file.
418 | otherwise
419 = Nothing
420 setDir f = case dumpDir dflags of
421 Just d -> d </> f
422 Nothing -> f
423
424 -- | Build a nice file name from name of a 'DumpFlag' constructor
425 beautifyDumpName :: DumpFlag -> String
426 beautifyDumpName Opt_D_th_dec_file = "th.hs"
427 beautifyDumpName flag
428 = let str = show flag
429 suff = case stripPrefix "Opt_D_" str of
430 Just x -> x
431 Nothing -> panic ("Bad flag name: " ++ str)
432 dash = map (\c -> if c == '_' then '-' else c) suff
433 in dash
434
435
436 -- -----------------------------------------------------------------------------
437 -- Outputting messages from the compiler
438
439 -- We want all messages to go through one place, so that we can
440 -- redirect them if necessary. For example, when GHC is used as a
441 -- library we might want to catch all messages that GHC tries to
442 -- output and do something else with them.
443
444 ifVerbose :: DynFlags -> Int -> IO () -> IO ()
445 ifVerbose dflags val act
446 | verbosity dflags >= val = act
447 | otherwise = return ()
448
449 errorMsg :: DynFlags -> MsgDoc -> IO ()
450 errorMsg dflags msg
451 = log_action dflags dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg
452
453 warningMsg :: DynFlags -> MsgDoc -> IO ()
454 warningMsg dflags msg
455 = log_action dflags dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg
456
457 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
458 fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
459
460 fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO ()
461 fatalErrorMsg' la dflags msg =
462 la dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg
463
464 fatalErrorMsg'' :: FatalMessager -> String -> IO ()
465 fatalErrorMsg'' fm msg = fm msg
466
467 compilationProgressMsg :: DynFlags -> String -> IO ()
468 compilationProgressMsg dflags msg
469 = ifVerbose dflags 1 $
470 logOutput dflags defaultUserStyle (text msg)
471
472 showPass :: DynFlags -> String -> IO ()
473 showPass dflags what
474 = ifVerbose dflags 2 $
475 logInfo dflags defaultUserStyle (text "***" <+> text what <> colon)
476
477 -- | Time a compilation phase.
478 --
479 -- When timings are enabled (e.g. with the @-v2@ flag), the allocations
480 -- and CPU time used by the phase will be reported to stderr. Consider
481 -- a typical usage: @withTiming getDynFlags (text "simplify") force pass@.
482 -- When timings are enabled the following costs are included in the
483 -- produced accounting,
484 --
485 -- - The cost of executing @pass@ to a result @r@ in WHNF
486 -- - The cost of evaluating @force r@ to WHNF (e.g. @()@)
487 --
488 -- The choice of the @force@ function depends upon the amount of forcing
489 -- desired; the goal here is to ensure that the cost of evaluating the result
490 -- is, to the greatest extent possible, included in the accounting provided by
491 -- 'withTiming'. Often the pass already sufficiently forces its result during
492 -- construction; in this case @const ()@ is a reasonable choice.
493 -- In other cases, it is necessary to evaluate the result to normal form, in
494 -- which case something like @Control.DeepSeq.rnf@ is appropriate.
495 --
496 -- To avoid adversely affecting compiler performance when timings are not
497 -- requested, the result is only forced when timings are enabled.
498 withTiming :: MonadIO m
499 => m DynFlags -- ^ A means of getting a 'DynFlags' (often
500 -- 'getDynFlags' will work here)
501 -> SDoc -- ^ The name of the phase
502 -> (a -> ()) -- ^ A function to force the result
503 -- (often either @const ()@ or 'rnf')
504 -> m a -- ^ The body of the phase to be timed
505 -> m a
506 withTiming getDFlags what force_result action
507 = do dflags <- getDFlags
508 if verbosity dflags >= 2
509 then do liftIO $ logInfo dflags defaultUserStyle
510 $ text "***" <+> what <> colon
511 alloc0 <- liftIO getAllocationCounter
512 start <- liftIO getCPUTime
513 !r <- action
514 () <- pure $ force_result r
515 end <- liftIO getCPUTime
516 alloc1 <- liftIO getAllocationCounter
517 -- recall that allocation counter counts down
518 let alloc = alloc0 - alloc1
519 liftIO $ logInfo dflags defaultUserStyle
520 (text "!!!" <+> what <> colon <+> text "finished in"
521 <+> doublePrec 2 (realToFrac (end - start) * 1e-9)
522 <+> text "milliseconds"
523 <> comma
524 <+> text "allocated"
525 <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
526 <+> text "megabytes")
527 pure r
528 else action
529
530 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
531 debugTraceMsg dflags val msg = ifVerbose dflags val $
532 logInfo dflags defaultDumpStyle msg
533
534 putMsg :: DynFlags -> MsgDoc -> IO ()
535 putMsg dflags msg = logInfo dflags defaultUserStyle msg
536
537 printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
538 printInfoForUser dflags print_unqual msg
539 = logInfo dflags (mkUserStyle print_unqual AllTheWay) msg
540
541 printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
542 printOutputForUser dflags print_unqual msg
543 = logOutput dflags (mkUserStyle print_unqual AllTheWay) msg
544
545 logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
546 logInfo dflags sty msg
547 = log_action dflags dflags NoReason SevInfo noSrcSpan sty msg
548
549 logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
550 -- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
551 logOutput dflags sty msg
552 = log_action dflags dflags NoReason SevOutput noSrcSpan sty msg
553
554 prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
555 prettyPrintGhcErrors dflags
556 = ghandle $ \e -> case e of
557 PprPanic str doc ->
558 pprDebugAndThen dflags panic (text str) doc
559 PprSorry str doc ->
560 pprDebugAndThen dflags sorry (text str) doc
561 PprProgramError str doc ->
562 pprDebugAndThen dflags pgmError (text str) doc
563 _ ->
564 liftIO $ throwIO e
565
566 -- | Checks if given 'WarnMsg' is a fatal warning.
567 isWarnMsgFatal :: DynFlags -> WarnMsg -> Bool
568 isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
569 = wopt_fatal wflag dflags
570 isWarnMsgFatal dflags _ = gopt Opt_WarnIsError dflags