Disable colors unless printing to stderr
[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 -- | Make an unannotated error message with location info.
172 mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
173 mkLocMessage = mkLocMessageAnn Nothing
174
175 -- | Make a possibly annotated error message with location info.
176 mkLocMessageAnn
177 :: Maybe String -- ^ optional annotation
178 -> Severity -- ^ severity
179 -> SrcSpan -- ^ location
180 -> MsgDoc -- ^ message
181 -> MsgDoc
182 -- Always print the location, even if it is unhelpful. Error messages
183 -- are supposed to be in a standard format, and one without a location
184 -- would look strange. Better to say explicitly "<no location info>".
185 mkLocMessageAnn ann severity locn msg
186 = sdocWithDynFlags $ \dflags ->
187 let locn' = if gopt Opt_ErrorSpans dflags
188 then ppr locn
189 else ppr (srcSpanStart locn)
190 -- Add prefixes, like Foo.hs:34: warning:
191 -- <the warning message>
192 prefix = locn' <> colon <+>
193 coloured (colBold `mappend` sevColor) sevText <> optAnn
194 in bold (hang prefix 4 msg)
195 where
196 (sevText, sevColor) =
197 case severity of
198 SevWarning -> (text "warning:", colMagentaFg)
199 SevError -> (text "error:", colRedFg)
200 SevFatal -> (text "fatal:", colRedFg)
201 _ -> (empty, mempty)
202
203 -- Add optional information
204 optAnn = case ann of
205 Nothing -> text ""
206 Just i -> text " [" <> coloured sevColor (text i) <> text "]"
207
208 makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
209 makeIntoWarning reason err = err
210 { errMsgSeverity = SevWarning
211 , errMsgReason = reason }
212
213 -- -----------------------------------------------------------------------------
214 -- Collecting up messages for later ordering and printing.
215
216 mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
217 mk_err_msg dflags sev locn print_unqual doc
218 = ErrMsg { errMsgSpan = locn
219 , errMsgContext = print_unqual
220 , errMsgDoc = doc
221 , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc))
222 , errMsgSeverity = sev
223 , errMsgReason = NoReason }
224
225 mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
226 mkErrDoc dflags = mk_err_msg dflags SevError
227
228 mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
229 -- ^ A long (multi-line) error message
230 mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg
231 -- ^ A short (one-line) error message
232 mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
233 -- ^ Variant that doesn't care about qualified/unqualified names
234
235 mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [extra])
236 mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [])
237 mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify (ErrDoc [msg] [] [])
238 mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [extra])
239 mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [])
240 mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] [])
241
242 ----------------
243 emptyMessages :: Messages
244 emptyMessages = (emptyBag, emptyBag)
245
246 isEmptyMessages :: Messages -> Bool
247 isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs
248
249 warnIsErrorMsg :: DynFlags -> ErrMsg
250 warnIsErrorMsg dflags
251 = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.")
252
253 errorsFound :: DynFlags -> Messages -> Bool
254 errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
255
256 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
257 printBagOfErrors dflags bag_of_errors
258 = sequence_ [ let style = mkErrStyle dflags unqual
259 in log_action dflags dflags reason sev s style (formatErrDoc dflags doc)
260 | ErrMsg { errMsgSpan = s,
261 errMsgDoc = doc,
262 errMsgSeverity = sev,
263 errMsgReason = reason,
264 errMsgContext = unqual } <- sortMsgBag (Just dflags)
265 bag_of_errors ]
266
267 formatErrDoc :: DynFlags -> ErrDoc -> SDoc
268 formatErrDoc dflags (ErrDoc important context supplementary)
269 = case msgs of
270 [msg] -> vcat msg
271 _ -> vcat $ map starred msgs
272 where
273 msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags))
274 [important, context, supplementary]
275 starred = (bullet<+>) . vcat
276 bullet = text $ if DynFlags.useUnicode dflags then "•" else "*"
277
278 pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
279 pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]
280
281 pprLocErrMsg :: ErrMsg -> SDoc
282 pprLocErrMsg (ErrMsg { errMsgSpan = s
283 , errMsgDoc = doc
284 , errMsgSeverity = sev
285 , errMsgContext = unqual })
286 = sdocWithDynFlags $ \dflags ->
287 withPprStyle (mkErrStyle dflags unqual) $
288 mkLocMessage sev s (formatErrDoc dflags doc)
289
290 sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
291 sortMsgBag dflags = sortBy (maybeFlip $ comparing errMsgSpan) . bagToList
292 where maybeFlip :: (a -> a -> b) -> (a -> a -> b)
293 maybeFlip
294 | fromMaybe False (fmap reverseErrors dflags) = flip
295 | otherwise = id
296
297 ghcExit :: DynFlags -> Int -> IO ()
298 ghcExit dflags val
299 | val == 0 = exitWith ExitSuccess
300 | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
301 exitWith (ExitFailure val)
302
303 doIfSet :: Bool -> IO () -> IO ()
304 doIfSet flag action | flag = action
305 | otherwise = return ()
306
307 doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
308 doIfSet_dyn dflags flag action | gopt flag dflags = action
309 | otherwise = return ()
310
311 -- -----------------------------------------------------------------------------
312 -- Dumping
313
314 dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
315 dumpIfSet dflags flag hdr doc
316 | not flag = return ()
317 | otherwise = log_action dflags
318 dflags
319 NoReason
320 SevDump
321 noSrcSpan
322 defaultDumpStyle
323 (mkDumpDoc hdr doc)
324
325 -- | a wrapper around 'dumpSDoc'.
326 -- First check whether the dump flag is set
327 -- Do nothing if it is unset
328 dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
329 dumpIfSet_dyn dflags flag hdr doc
330 = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc
331
332 -- | a wrapper around 'dumpSDoc'.
333 -- First check whether the dump flag is set
334 -- Do nothing if it is unset
335 --
336 -- Unlike 'dumpIfSet_dyn',
337 -- has a printer argument but no header argument
338 dumpIfSet_dyn_printer :: PrintUnqualified
339 -> DynFlags -> DumpFlag -> SDoc -> IO ()
340 dumpIfSet_dyn_printer printer dflags flag doc
341 = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc
342
343 mkDumpDoc :: String -> SDoc -> SDoc
344 mkDumpDoc hdr doc
345 = vcat [blankLine,
346 line <+> text hdr <+> line,
347 doc,
348 blankLine]
349 where
350 line = text (replicate 20 '=')
351
352
353 -- | Write out a dump.
354 -- If --dump-to-file is set then this goes to a file.
355 -- otherwise emit to stdout.
356 --
357 -- When @hdr@ is empty, we print in a more compact format (no separators and
358 -- blank lines)
359 --
360 -- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@
361 -- is used; it is not used to decide whether to dump the output
362 dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
363 dumpSDoc dflags print_unqual flag hdr doc
364 = do let mFile = chooseDumpFile dflags flag
365 dump_style = mkDumpStyle print_unqual
366 case mFile of
367 Just fileName
368 -> do
369 let gdref = generatedDumps dflags
370 gd <- readIORef gdref
371 let append = Set.member fileName gd
372 mode = if append then AppendMode else WriteMode
373 unless append $
374 writeIORef gdref (Set.insert fileName gd)
375 createDirectoryIfMissing True (takeDirectory fileName)
376 handle <- openFile fileName mode
377
378 -- We do not want the dump file to be affected by
379 -- environment variables, but instead to always use
380 -- UTF8. See:
381 -- https://ghc.haskell.org/trac/ghc/ticket/10762
382 hSetEncoding handle utf8
383
384 doc' <- if null hdr
385 then return doc
386 else do t <- getCurrentTime
387 let d = text (show t)
388 $$ blankLine
389 $$ doc
390 return $ mkDumpDoc hdr d
391 defaultLogActionHPrintDoc dflags handle doc' dump_style
392 hClose handle
393
394 -- write the dump to stdout
395 Nothing -> do
396 let (doc', severity)
397 | null hdr = (doc, SevOutput)
398 | otherwise = (mkDumpDoc hdr doc, SevDump)
399 log_action dflags dflags NoReason severity noSrcSpan dump_style doc'
400
401
402 -- | Choose where to put a dump file based on DynFlags
403 --
404 chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
405 chooseDumpFile dflags flag
406
407 | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file
408 , Just prefix <- getPrefix
409 = Just $ setDir (prefix ++ (beautifyDumpName flag))
410
411 | otherwise
412 = Nothing
413
414 where getPrefix
415 -- dump file location is being forced
416 -- by the --ddump-file-prefix flag.
417 | Just prefix <- dumpPrefixForce dflags
418 = Just prefix
419 -- dump file location chosen by DriverPipeline.runPipeline
420 | Just prefix <- dumpPrefix dflags
421 = Just prefix
422 -- we haven't got a place to put a dump file.
423 | otherwise
424 = Nothing
425 setDir f = case dumpDir dflags of
426 Just d -> d </> f
427 Nothing -> f
428
429 -- | Build a nice file name from name of a 'DumpFlag' constructor
430 beautifyDumpName :: DumpFlag -> String
431 beautifyDumpName Opt_D_th_dec_file = "th.hs"
432 beautifyDumpName flag
433 = let str = show flag
434 suff = case stripPrefix "Opt_D_" str of
435 Just x -> x
436 Nothing -> panic ("Bad flag name: " ++ str)
437 dash = map (\c -> if c == '_' then '-' else c) suff
438 in dash
439
440
441 -- -----------------------------------------------------------------------------
442 -- Outputting messages from the compiler
443
444 -- We want all messages to go through one place, so that we can
445 -- redirect them if necessary. For example, when GHC is used as a
446 -- library we might want to catch all messages that GHC tries to
447 -- output and do something else with them.
448
449 ifVerbose :: DynFlags -> Int -> IO () -> IO ()
450 ifVerbose dflags val act
451 | verbosity dflags >= val = act
452 | otherwise = return ()
453
454 errorMsg :: DynFlags -> MsgDoc -> IO ()
455 errorMsg dflags msg
456 = log_action dflags dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg
457
458 warningMsg :: DynFlags -> MsgDoc -> IO ()
459 warningMsg dflags msg
460 = log_action dflags dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg
461
462 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
463 fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
464
465 fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO ()
466 fatalErrorMsg' la dflags msg =
467 la dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg
468
469 fatalErrorMsg'' :: FatalMessager -> String -> IO ()
470 fatalErrorMsg'' fm msg = fm msg
471
472 compilationProgressMsg :: DynFlags -> String -> IO ()
473 compilationProgressMsg dflags msg
474 = ifVerbose dflags 1 $
475 logOutput dflags defaultUserStyle (text msg)
476
477 showPass :: DynFlags -> String -> IO ()
478 showPass dflags what
479 = ifVerbose dflags 2 $
480 logInfo dflags defaultUserStyle (text "***" <+> text what <> colon)
481
482 -- | Time a compilation phase.
483 --
484 -- When timings are enabled (e.g. with the @-v2@ flag), the allocations
485 -- and CPU time used by the phase will be reported to stderr. Consider
486 -- a typical usage: @withTiming getDynFlags (text "simplify") force pass@.
487 -- When timings are enabled the following costs are included in the
488 -- produced accounting,
489 --
490 -- - The cost of executing @pass@ to a result @r@ in WHNF
491 -- - The cost of evaluating @force r@ to WHNF (e.g. @()@)
492 --
493 -- The choice of the @force@ function depends upon the amount of forcing
494 -- desired; the goal here is to ensure that the cost of evaluating the result
495 -- is, to the greatest extent possible, included in the accounting provided by
496 -- 'withTiming'. Often the pass already sufficiently forces its result during
497 -- construction; in this case @const ()@ is a reasonable choice.
498 -- In other cases, it is necessary to evaluate the result to normal form, in
499 -- which case something like @Control.DeepSeq.rnf@ is appropriate.
500 --
501 -- To avoid adversely affecting compiler performance when timings are not
502 -- requested, the result is only forced when timings are enabled.
503 withTiming :: MonadIO m
504 => m DynFlags -- ^ A means of getting a 'DynFlags' (often
505 -- 'getDynFlags' will work here)
506 -> SDoc -- ^ The name of the phase
507 -> (a -> ()) -- ^ A function to force the result
508 -- (often either @const ()@ or 'rnf')
509 -> m a -- ^ The body of the phase to be timed
510 -> m a
511 withTiming getDFlags what force_result action
512 = do dflags <- getDFlags
513 if verbosity dflags >= 2
514 then do liftIO $ logInfo dflags defaultUserStyle
515 $ text "***" <+> what <> colon
516 alloc0 <- liftIO getAllocationCounter
517 start <- liftIO getCPUTime
518 !r <- action
519 () <- pure $ force_result r
520 end <- liftIO getCPUTime
521 alloc1 <- liftIO getAllocationCounter
522 -- recall that allocation counter counts down
523 let alloc = alloc0 - alloc1
524 liftIO $ logInfo dflags defaultUserStyle
525 (text "!!!" <+> what <> colon <+> text "finished in"
526 <+> doublePrec 2 (realToFrac (end - start) * 1e-9)
527 <+> text "milliseconds"
528 <> comma
529 <+> text "allocated"
530 <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
531 <+> text "megabytes")
532 pure r
533 else action
534
535 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
536 debugTraceMsg dflags val msg = ifVerbose dflags val $
537 logInfo dflags defaultDumpStyle msg
538
539 putMsg :: DynFlags -> MsgDoc -> IO ()
540 putMsg dflags msg = logInfo dflags defaultUserStyle msg
541
542 printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
543 printInfoForUser dflags print_unqual msg
544 = logInfo dflags (mkUserStyle print_unqual AllTheWay) msg
545
546 printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
547 printOutputForUser dflags print_unqual msg
548 = logOutput dflags (mkUserStyle print_unqual AllTheWay) msg
549
550 logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
551 logInfo dflags sty msg
552 = log_action dflags dflags NoReason SevInfo noSrcSpan sty msg
553
554 logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
555 -- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
556 logOutput dflags sty msg
557 = log_action dflags dflags NoReason SevOutput noSrcSpan sty msg
558
559 prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
560 prettyPrintGhcErrors dflags
561 = ghandle $ \e -> case e of
562 PprPanic str doc ->
563 pprDebugAndThen dflags panic (text str) doc
564 PprSorry str doc ->
565 pprDebugAndThen dflags sorry (text str) doc
566 PprProgramError str doc ->
567 pprDebugAndThen dflags pgmError (text str) doc
568 _ ->
569 liftIO $ throwIO e
570
571 -- | Checks if given 'WarnMsg' is a fatal warning.
572 isWarnMsgFatal :: DynFlags -> WarnMsg -> Bool
573 isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
574 = wopt_fatal wflag dflags
575 isWarnMsgFatal dflags _ = gopt Opt_WarnIsError dflags