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