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