Introduce putLogMsg
[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'',
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 putLogMsg 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
368 pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
369 pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]
370
371 pprLocErrMsg :: ErrMsg -> SDoc
372 pprLocErrMsg (ErrMsg { errMsgSpan = s
373 , errMsgDoc = doc
374 , errMsgSeverity = sev
375 , errMsgContext = unqual })
376 = sdocWithDynFlags $ \dflags ->
377 withPprStyle (mkErrStyle dflags unqual) $
378 mkLocMessage sev s (formatErrDoc dflags doc)
379
380 sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
381 sortMsgBag dflags = maybeLimit . sortBy (maybeFlip cmp) . bagToList
382 where maybeFlip :: (a -> a -> b) -> (a -> a -> b)
383 maybeFlip
384 | fromMaybe False (fmap reverseErrors dflags) = flip
385 | otherwise = id
386 cmp = comparing errMsgSpan
387 maybeLimit = case join (fmap maxErrors dflags) of
388 Nothing -> id
389 Just err_limit -> take err_limit
390
391 ghcExit :: DynFlags -> Int -> IO ()
392 ghcExit dflags val
393 | val == 0 = exitWith ExitSuccess
394 | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
395 exitWith (ExitFailure val)
396
397 doIfSet :: Bool -> IO () -> IO ()
398 doIfSet flag action | flag = action
399 | otherwise = return ()
400
401 doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
402 doIfSet_dyn dflags flag action | gopt flag dflags = action
403 | otherwise = return ()
404
405 -- -----------------------------------------------------------------------------
406 -- Dumping
407
408 dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
409 dumpIfSet dflags flag hdr doc
410 | not flag = return ()
411 | otherwise = putLogMsg dflags
412 NoReason
413 SevDump
414 noSrcSpan
415 (defaultDumpStyle dflags)
416 (mkDumpDoc hdr doc)
417
418 -- | a wrapper around 'dumpSDoc'.
419 -- First check whether the dump flag is set
420 -- Do nothing if it is unset
421 dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
422 dumpIfSet_dyn dflags flag hdr doc
423 = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc
424
425 -- | a wrapper around 'dumpSDoc'.
426 -- First check whether the dump flag is set
427 -- Do nothing if it is unset
428 --
429 -- Unlike 'dumpIfSet_dyn',
430 -- has a printer argument but no header argument
431 dumpIfSet_dyn_printer :: PrintUnqualified
432 -> DynFlags -> DumpFlag -> SDoc -> IO ()
433 dumpIfSet_dyn_printer printer dflags flag doc
434 = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc
435
436 mkDumpDoc :: String -> SDoc -> SDoc
437 mkDumpDoc hdr doc
438 = vcat [blankLine,
439 line <+> text hdr <+> line,
440 doc,
441 blankLine]
442 where
443 line = text (replicate 20 '=')
444
445
446 -- | Write out a dump.
447 -- If --dump-to-file is set then this goes to a file.
448 -- otherwise emit to stdout.
449 --
450 -- When @hdr@ is empty, we print in a more compact format (no separators and
451 -- blank lines)
452 --
453 -- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@
454 -- is used; it is not used to decide whether to dump the output
455 dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
456 dumpSDoc dflags print_unqual flag hdr doc
457 = do let mFile = chooseDumpFile dflags flag
458 dump_style = mkDumpStyle dflags print_unqual
459 case mFile of
460 Just fileName
461 -> do
462 let gdref = generatedDumps dflags
463 gd <- readIORef gdref
464 let append = Set.member fileName gd
465 mode = if append then AppendMode else WriteMode
466 unless append $
467 writeIORef gdref (Set.insert fileName gd)
468 createDirectoryIfMissing True (takeDirectory fileName)
469 handle <- openFile fileName mode
470
471 -- We do not want the dump file to be affected by
472 -- environment variables, but instead to always use
473 -- UTF8. See:
474 -- https://ghc.haskell.org/trac/ghc/ticket/10762
475 hSetEncoding handle utf8
476
477 doc' <- if null hdr
478 then return doc
479 else do t <- getCurrentTime
480 let d = text (show t)
481 $$ blankLine
482 $$ doc
483 return $ mkDumpDoc hdr d
484 defaultLogActionHPrintDoc dflags handle doc' dump_style
485 hClose handle
486
487 -- write the dump to stdout
488 Nothing -> do
489 let (doc', severity)
490 | null hdr = (doc, SevOutput)
491 | otherwise = (mkDumpDoc hdr doc, SevDump)
492 putLogMsg dflags NoReason severity noSrcSpan dump_style doc'
493
494
495 -- | Choose where to put a dump file based on DynFlags
496 --
497 chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
498 chooseDumpFile dflags flag
499
500 | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file
501 , Just prefix <- getPrefix
502 = Just $ setDir (prefix ++ (beautifyDumpName flag))
503
504 | otherwise
505 = Nothing
506
507 where getPrefix
508 -- dump file location is being forced
509 -- by the --ddump-file-prefix flag.
510 | Just prefix <- dumpPrefixForce dflags
511 = Just prefix
512 -- dump file location chosen by DriverPipeline.runPipeline
513 | Just prefix <- dumpPrefix dflags
514 = Just prefix
515 -- we haven't got a place to put a dump file.
516 | otherwise
517 = Nothing
518 setDir f = case dumpDir dflags of
519 Just d -> d </> f
520 Nothing -> f
521
522 -- | Build a nice file name from name of a 'DumpFlag' constructor
523 beautifyDumpName :: DumpFlag -> String
524 beautifyDumpName Opt_D_th_dec_file = "th.hs"
525 beautifyDumpName flag
526 = let str = show flag
527 suff = case stripPrefix "Opt_D_" str of
528 Just x -> x
529 Nothing -> panic ("Bad flag name: " ++ str)
530 dash = map (\c -> if c == '_' then '-' else c) suff
531 in dash
532
533
534 -- -----------------------------------------------------------------------------
535 -- Outputting messages from the compiler
536
537 -- We want all messages to go through one place, so that we can
538 -- redirect them if necessary. For example, when GHC is used as a
539 -- library we might want to catch all messages that GHC tries to
540 -- output and do something else with them.
541
542 ifVerbose :: DynFlags -> Int -> IO () -> IO ()
543 ifVerbose dflags val act
544 | verbosity dflags >= val = act
545 | otherwise = return ()
546
547 errorMsg :: DynFlags -> MsgDoc -> IO ()
548 errorMsg dflags msg
549 = putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg
550
551 warningMsg :: DynFlags -> MsgDoc -> IO ()
552 warningMsg dflags msg
553 = putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg
554
555 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
556 fatalErrorMsg dflags msg =
557 putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg
558
559 fatalErrorMsg'' :: FatalMessager -> String -> IO ()
560 fatalErrorMsg'' fm msg = fm msg
561
562 compilationProgressMsg :: DynFlags -> String -> IO ()
563 compilationProgressMsg dflags msg
564 = ifVerbose dflags 1 $
565 logOutput dflags (defaultUserStyle dflags) (text msg)
566
567 showPass :: DynFlags -> String -> IO ()
568 showPass dflags what
569 = ifVerbose dflags 2 $
570 logInfo dflags (defaultUserStyle dflags) (text "***" <+> text what <> colon)
571
572 -- | Time a compilation phase.
573 --
574 -- When timings are enabled (e.g. with the @-v2@ flag), the allocations
575 -- and CPU time used by the phase will be reported to stderr. Consider
576 -- a typical usage: @withTiming getDynFlags (text "simplify") force pass@.
577 -- When timings are enabled the following costs are included in the
578 -- produced accounting,
579 --
580 -- - The cost of executing @pass@ to a result @r@ in WHNF
581 -- - The cost of evaluating @force r@ to WHNF (e.g. @()@)
582 --
583 -- The choice of the @force@ function depends upon the amount of forcing
584 -- desired; the goal here is to ensure that the cost of evaluating the result
585 -- is, to the greatest extent possible, included in the accounting provided by
586 -- 'withTiming'. Often the pass already sufficiently forces its result during
587 -- construction; in this case @const ()@ is a reasonable choice.
588 -- In other cases, it is necessary to evaluate the result to normal form, in
589 -- which case something like @Control.DeepSeq.rnf@ is appropriate.
590 --
591 -- To avoid adversely affecting compiler performance when timings are not
592 -- requested, the result is only forced when timings are enabled.
593 withTiming :: MonadIO m
594 => m DynFlags -- ^ A means of getting a 'DynFlags' (often
595 -- 'getDynFlags' will work here)
596 -> SDoc -- ^ The name of the phase
597 -> (a -> ()) -- ^ A function to force the result
598 -- (often either @const ()@ or 'rnf')
599 -> m a -- ^ The body of the phase to be timed
600 -> m a
601 withTiming getDFlags what force_result action
602 = do dflags <- getDFlags
603 if verbosity dflags >= 2
604 then do liftIO $ logInfo dflags (defaultUserStyle dflags)
605 $ text "***" <+> what <> colon
606 alloc0 <- liftIO getAllocationCounter
607 start <- liftIO getCPUTime
608 !r <- action
609 () <- pure $ force_result r
610 end <- liftIO getCPUTime
611 alloc1 <- liftIO getAllocationCounter
612 -- recall that allocation counter counts down
613 let alloc = alloc0 - alloc1
614 liftIO $ logInfo dflags (defaultUserStyle dflags)
615 (text "!!!" <+> what <> colon <+> text "finished in"
616 <+> doublePrec 2 (realToFrac (end - start) * 1e-9)
617 <+> text "milliseconds"
618 <> comma
619 <+> text "allocated"
620 <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
621 <+> text "megabytes")
622 pure r
623 else action
624
625 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
626 debugTraceMsg dflags val msg = ifVerbose dflags val $
627 logInfo dflags (defaultDumpStyle dflags) msg
628 putMsg :: DynFlags -> MsgDoc -> IO ()
629 putMsg dflags msg = logInfo dflags (defaultUserStyle dflags) msg
630
631 printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
632 printInfoForUser dflags print_unqual msg
633 = logInfo dflags (mkUserStyle dflags print_unqual AllTheWay) msg
634
635 printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
636 printOutputForUser dflags print_unqual msg
637 = logOutput dflags (mkUserStyle dflags print_unqual AllTheWay) msg
638
639 logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
640 logInfo dflags sty msg
641 = putLogMsg dflags NoReason SevInfo noSrcSpan sty msg
642
643 logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
644 -- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
645 logOutput dflags sty msg
646 = putLogMsg dflags NoReason SevOutput noSrcSpan sty msg
647
648 prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
649 prettyPrintGhcErrors dflags
650 = ghandle $ \e -> case e of
651 PprPanic str doc ->
652 pprDebugAndThen dflags panic (text str) doc
653 PprSorry str doc ->
654 pprDebugAndThen dflags sorry (text str) doc
655 PprProgramError str doc ->
656 pprDebugAndThen dflags pgmError (text str) doc
657 _ ->
658 liftIO $ throwIO e
659
660 -- | Checks if given 'WarnMsg' is a fatal warning.
661 isWarnMsgFatal :: DynFlags -> WarnMsg -> Bool
662 isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
663 = wopt_fatal wflag dflags
664 isWarnMsgFatal dflags _ = gopt Opt_WarnIsError dflags