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