Render \t as 8 spaces in 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 {-# 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 qualified PprColour as Col
64 import SrcLoc
65 import DynFlags
66 import FastString (unpackFS)
67 import StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
68 import Json
69
70 import System.Directory
71 import System.Exit ( ExitCode(..), exitWith )
72 import System.FilePath ( takeDirectory, (</>) )
73 import Data.List
74 import qualified Data.Set as Set
75 import Data.IORef
76 import Data.Maybe ( fromMaybe )
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
203 sevColour = getSeverityColour severity (colScheme dflags)
204
205 -- Add optional information
206 optAnn = case ann of
207 Nothing -> text ""
208 Just i -> text " [" <> coloured sevColour (text i) <> text "]"
209
210 -- Add prefixes, like Foo.hs:34: warning:
211 -- <the warning message>
212 prefix = locn' <> colon <+>
213 coloured sevColour sevText <> optAnn
214
215 in coloured (Col.sMessage (colScheme dflags)) (hang prefix 4 msg)
216
217 where
218 sevText =
219 case severity of
220 SevWarning -> text "warning:"
221 SevError -> text "error:"
222 SevFatal -> text "fatal:"
223 _ -> empty
224
225 getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
226 getSeverityColour SevWarning = Col.sWarning
227 getSeverityColour SevError = Col.sError
228 getSeverityColour SevFatal = Col.sFatal
229 getSeverityColour _ = const mempty
230
231 getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
232 getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
233 getCaretDiagnostic severity (RealSrcSpan span) = do
234 caretDiagnostic <$> getSrcLine (srcSpanFile span) row
235
236 where
237 getSrcLine fn i =
238 getLine i (unpackFS fn)
239 `catchIOError` \_ ->
240 pure Nothing
241
242 getLine i fn = do
243 -- StringBuffer has advantages over readFile:
244 -- (a) no lazy IO, otherwise IO exceptions may occur in pure code
245 -- (b) always UTF-8, rather than some system-dependent encoding
246 -- (Haskell source code must be UTF-8 anyway)
247 content <- hGetStringBuffer fn
248 case atLine i content of
249 Just at_line -> pure $
250 case lines (fix <$> lexemeToString at_line (len at_line)) of
251 srcLine : _ -> Just srcLine
252 _ -> Nothing
253 _ -> pure Nothing
254
255 -- allow user to visibly see that their code is incorrectly encoded
256 -- (StringBuffer.nextChar uses \0 to represent undecodable characters)
257 fix '\0' = '\xfffd'
258 fix c = c
259
260 row = srcSpanStartLine span
261 rowStr = show row
262 multiline = row /= srcSpanEndLine span
263
264 caretDiagnostic Nothing = empty
265 caretDiagnostic (Just srcLineWithNewline) =
266 sdocWithDynFlags $ \ dflags ->
267 let sevColour = getSeverityColour severity (colScheme dflags)
268 marginColour = Col.sMargin (colScheme dflags)
269 in
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 fixWhitespace (i, c)
282 | c == '\n' = ""
283 -- show tabs in a device-independent manner #13664
284 | c == '\t' = replicate (8 - i `mod` 8) ' '
285 | otherwise = [c]
286
287 srcLine = concat (map fixWhitespace (zip [0..] srcLineWithNewline))
288
289 start = srcSpanStartCol span - 1
290 end | multiline = length srcLine
291 | otherwise = srcSpanEndCol span - 1
292 width = max 1 (end - start)
293
294 marginWidth = length rowStr
295 marginSpace = replicate marginWidth ' ' ++ " |"
296 marginRow = rowStr ++ " |"
297
298 (srcLinePre, srcLineRest) = splitAt start srcLine
299 (srcLineSpan, srcLinePost) = splitAt width srcLineRest
300
301 caretEllipsis | multiline = "..."
302 | otherwise = ""
303 caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis
304
305 makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
306 makeIntoWarning reason err = err
307 { errMsgSeverity = SevWarning
308 , errMsgReason = reason }
309
310 -- -----------------------------------------------------------------------------
311 -- Collecting up messages for later ordering and printing.
312
313 mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
314 mk_err_msg dflags sev locn print_unqual doc
315 = ErrMsg { errMsgSpan = locn
316 , errMsgContext = print_unqual
317 , errMsgDoc = doc
318 , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc))
319 , errMsgSeverity = sev
320 , errMsgReason = NoReason }
321
322 mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
323 mkErrDoc dflags = mk_err_msg dflags SevError
324
325 mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
326 -- ^ A long (multi-line) error message
327 mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg
328 -- ^ A short (one-line) error message
329 mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
330 -- ^ Variant that doesn't care about qualified/unqualified names
331
332 mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [extra])
333 mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [])
334 mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify (ErrDoc [msg] [] [])
335 mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [extra])
336 mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [])
337 mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] [])
338
339 ----------------
340 emptyMessages :: Messages
341 emptyMessages = (emptyBag, emptyBag)
342
343 isEmptyMessages :: Messages -> Bool
344 isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs
345
346 warnIsErrorMsg :: DynFlags -> ErrMsg
347 warnIsErrorMsg dflags
348 = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.")
349
350 errorsFound :: DynFlags -> Messages -> Bool
351 errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
352
353 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
354 printBagOfErrors dflags bag_of_errors
355 = sequence_ [ let style = mkErrStyle dflags unqual
356 in putLogMsg dflags reason sev s style (formatErrDoc dflags doc)
357 | ErrMsg { errMsgSpan = s,
358 errMsgDoc = doc,
359 errMsgSeverity = sev,
360 errMsgReason = reason,
361 errMsgContext = unqual } <- sortMsgBag (Just dflags)
362 bag_of_errors ]
363
364 formatErrDoc :: DynFlags -> ErrDoc -> SDoc
365 formatErrDoc dflags (ErrDoc important context supplementary)
366 = case msgs of
367 [msg] -> vcat msg
368 _ -> vcat $ map starred msgs
369 where
370 msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags))
371 [important, context, supplementary]
372 starred = (bullet<+>) . vcat
373
374 pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
375 pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]
376
377 pprLocErrMsg :: ErrMsg -> SDoc
378 pprLocErrMsg (ErrMsg { errMsgSpan = s
379 , errMsgDoc = doc
380 , errMsgSeverity = sev
381 , errMsgContext = unqual })
382 = sdocWithDynFlags $ \dflags ->
383 withPprStyle (mkErrStyle dflags unqual) $
384 mkLocMessage sev s (formatErrDoc dflags doc)
385
386 sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
387 sortMsgBag dflags = maybeLimit . sortBy (maybeFlip cmp) . bagToList
388 where maybeFlip :: (a -> a -> b) -> (a -> a -> b)
389 maybeFlip
390 | fromMaybe False (fmap reverseErrors dflags) = flip
391 | otherwise = id
392 cmp = comparing errMsgSpan
393 maybeLimit = case join (fmap maxErrors dflags) of
394 Nothing -> id
395 Just err_limit -> take err_limit
396
397 ghcExit :: DynFlags -> Int -> IO ()
398 ghcExit dflags val
399 | val == 0 = exitWith ExitSuccess
400 | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
401 exitWith (ExitFailure val)
402
403 doIfSet :: Bool -> IO () -> IO ()
404 doIfSet flag action | flag = action
405 | otherwise = return ()
406
407 doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
408 doIfSet_dyn dflags flag action | gopt flag dflags = action
409 | otherwise = return ()
410
411 -- -----------------------------------------------------------------------------
412 -- Dumping
413
414 dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
415 dumpIfSet dflags flag hdr doc
416 | not flag = return ()
417 | otherwise = putLogMsg dflags
418 NoReason
419 SevDump
420 noSrcSpan
421 (defaultDumpStyle dflags)
422 (mkDumpDoc hdr doc)
423
424 -- | a wrapper around 'dumpSDoc'.
425 -- First check whether the dump flag is set
426 -- Do nothing if it is unset
427 dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
428 dumpIfSet_dyn dflags flag hdr doc
429 = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc
430
431 -- | a wrapper around 'dumpSDoc'.
432 -- First check whether the dump flag is set
433 -- Do nothing if it is unset
434 --
435 -- Unlike 'dumpIfSet_dyn',
436 -- has a printer argument but no header argument
437 dumpIfSet_dyn_printer :: PrintUnqualified
438 -> DynFlags -> DumpFlag -> SDoc -> IO ()
439 dumpIfSet_dyn_printer printer dflags flag doc
440 = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc
441
442 mkDumpDoc :: String -> SDoc -> SDoc
443 mkDumpDoc hdr doc
444 = vcat [blankLine,
445 line <+> text hdr <+> line,
446 doc,
447 blankLine]
448 where
449 line = text (replicate 20 '=')
450
451
452 -- | Write out a dump.
453 -- If --dump-to-file is set then this goes to a file.
454 -- otherwise emit to stdout.
455 --
456 -- When @hdr@ is empty, we print in a more compact format (no separators and
457 -- blank lines)
458 --
459 -- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@
460 -- is used; it is not used to decide whether to dump the output
461 dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
462 dumpSDoc dflags print_unqual flag hdr doc
463 = do let mFile = chooseDumpFile dflags flag
464 dump_style = mkDumpStyle dflags print_unqual
465 case mFile of
466 Just fileName
467 -> do
468 let gdref = generatedDumps dflags
469 gd <- readIORef gdref
470 let append = Set.member fileName gd
471 mode = if append then AppendMode else WriteMode
472 unless append $
473 writeIORef gdref (Set.insert fileName gd)
474 createDirectoryIfMissing True (takeDirectory fileName)
475 handle <- openFile fileName mode
476
477 -- We do not want the dump file to be affected by
478 -- environment variables, but instead to always use
479 -- UTF8. See:
480 -- https://ghc.haskell.org/trac/ghc/ticket/10762
481 hSetEncoding handle utf8
482
483 doc' <- if null hdr
484 then return doc
485 else do t <- getCurrentTime
486 let d = text (show t)
487 $$ blankLine
488 $$ doc
489 return $ mkDumpDoc hdr d
490 defaultLogActionHPrintDoc dflags handle doc' dump_style
491 hClose handle
492
493 -- write the dump to stdout
494 Nothing -> do
495 let (doc', severity)
496 | null hdr = (doc, SevOutput)
497 | otherwise = (mkDumpDoc hdr doc, SevDump)
498 putLogMsg dflags NoReason severity noSrcSpan dump_style doc'
499
500
501 -- | Choose where to put a dump file based on DynFlags
502 --
503 chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
504 chooseDumpFile dflags flag
505
506 | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file
507 , Just prefix <- getPrefix
508 = Just $ setDir (prefix ++ (beautifyDumpName flag))
509
510 | otherwise
511 = Nothing
512
513 where getPrefix
514 -- dump file location is being forced
515 -- by the --ddump-file-prefix flag.
516 | Just prefix <- dumpPrefixForce dflags
517 = Just prefix
518 -- dump file location chosen by DriverPipeline.runPipeline
519 | Just prefix <- dumpPrefix dflags
520 = Just prefix
521 -- we haven't got a place to put a dump file.
522 | otherwise
523 = Nothing
524 setDir f = case dumpDir dflags of
525 Just d -> d </> f
526 Nothing -> f
527
528 -- | Build a nice file name from name of a 'DumpFlag' constructor
529 beautifyDumpName :: DumpFlag -> String
530 beautifyDumpName Opt_D_th_dec_file = "th.hs"
531 beautifyDumpName flag
532 = let str = show flag
533 suff = case stripPrefix "Opt_D_" str of
534 Just x -> x
535 Nothing -> panic ("Bad flag name: " ++ str)
536 dash = map (\c -> if c == '_' then '-' else c) suff
537 in dash
538
539
540 -- -----------------------------------------------------------------------------
541 -- Outputting messages from the compiler
542
543 -- We want all messages to go through one place, so that we can
544 -- redirect them if necessary. For example, when GHC is used as a
545 -- library we might want to catch all messages that GHC tries to
546 -- output and do something else with them.
547
548 ifVerbose :: DynFlags -> Int -> IO () -> IO ()
549 ifVerbose dflags val act
550 | verbosity dflags >= val = act
551 | otherwise = return ()
552
553 errorMsg :: DynFlags -> MsgDoc -> IO ()
554 errorMsg dflags msg
555 = putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg
556
557 warningMsg :: DynFlags -> MsgDoc -> IO ()
558 warningMsg dflags msg
559 = putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg
560
561 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
562 fatalErrorMsg dflags msg =
563 putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg
564
565 fatalErrorMsg'' :: FatalMessager -> String -> IO ()
566 fatalErrorMsg'' fm msg = fm msg
567
568 compilationProgressMsg :: DynFlags -> String -> IO ()
569 compilationProgressMsg dflags msg
570 = ifVerbose dflags 1 $
571 logOutput dflags (defaultUserStyle dflags) (text msg)
572
573 showPass :: DynFlags -> String -> IO ()
574 showPass dflags what
575 = ifVerbose dflags 2 $
576 logInfo dflags (defaultUserStyle dflags) (text "***" <+> text what <> colon)
577
578 -- | Time a compilation phase.
579 --
580 -- When timings are enabled (e.g. with the @-v2@ flag), the allocations
581 -- and CPU time used by the phase will be reported to stderr. Consider
582 -- a typical usage: @withTiming getDynFlags (text "simplify") force pass@.
583 -- When timings are enabled the following costs are included in the
584 -- produced accounting,
585 --
586 -- - The cost of executing @pass@ to a result @r@ in WHNF
587 -- - The cost of evaluating @force r@ to WHNF (e.g. @()@)
588 --
589 -- The choice of the @force@ function depends upon the amount of forcing
590 -- desired; the goal here is to ensure that the cost of evaluating the result
591 -- is, to the greatest extent possible, included in the accounting provided by
592 -- 'withTiming'. Often the pass already sufficiently forces its result during
593 -- construction; in this case @const ()@ is a reasonable choice.
594 -- In other cases, it is necessary to evaluate the result to normal form, in
595 -- which case something like @Control.DeepSeq.rnf@ is appropriate.
596 --
597 -- To avoid adversely affecting compiler performance when timings are not
598 -- requested, the result is only forced when timings are enabled.
599 withTiming :: MonadIO m
600 => m DynFlags -- ^ A means of getting a 'DynFlags' (often
601 -- 'getDynFlags' will work here)
602 -> SDoc -- ^ The name of the phase
603 -> (a -> ()) -- ^ A function to force the result
604 -- (often either @const ()@ or 'rnf')
605 -> m a -- ^ The body of the phase to be timed
606 -> m a
607 withTiming getDFlags what force_result action
608 = do dflags <- getDFlags
609 if verbosity dflags >= 2
610 then do liftIO $ logInfo dflags (defaultUserStyle dflags)
611 $ text "***" <+> what <> colon
612 alloc0 <- liftIO getAllocationCounter
613 start <- liftIO getCPUTime
614 !r <- action
615 () <- pure $ force_result r
616 end <- liftIO getCPUTime
617 alloc1 <- liftIO getAllocationCounter
618 -- recall that allocation counter counts down
619 let alloc = alloc0 - alloc1
620 liftIO $ logInfo dflags (defaultUserStyle dflags)
621 (text "!!!" <+> what <> colon <+> text "finished in"
622 <+> doublePrec 2 (realToFrac (end - start) * 1e-9)
623 <+> text "milliseconds"
624 <> comma
625 <+> text "allocated"
626 <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
627 <+> text "megabytes")
628 pure r
629 else action
630
631 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
632 debugTraceMsg dflags val msg = ifVerbose dflags val $
633 logInfo dflags (defaultDumpStyle dflags) msg
634 putMsg :: DynFlags -> MsgDoc -> IO ()
635 putMsg dflags msg = logInfo dflags (defaultUserStyle dflags) msg
636
637 printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
638 printInfoForUser dflags print_unqual msg
639 = logInfo dflags (mkUserStyle dflags print_unqual AllTheWay) msg
640
641 printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
642 printOutputForUser dflags print_unqual msg
643 = logOutput dflags (mkUserStyle dflags print_unqual AllTheWay) msg
644
645 logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
646 logInfo dflags sty msg
647 = putLogMsg dflags NoReason SevInfo noSrcSpan sty msg
648
649 logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
650 -- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
651 logOutput dflags sty msg
652 = putLogMsg dflags NoReason SevOutput noSrcSpan sty msg
653
654 prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
655 prettyPrintGhcErrors dflags
656 = ghandle $ \e -> case e of
657 PprPanic str doc ->
658 pprDebugAndThen dflags panic (text str) doc
659 PprSorry str doc ->
660 pprDebugAndThen dflags sorry (text str) doc
661 PprProgramError str doc ->
662 pprDebugAndThen dflags pgmError (text str) doc
663 _ ->
664 liftIO $ throwIO e
665
666 -- | Checks if given 'WarnMsg' is a fatal warning.
667 isWarnMsgFatal :: DynFlags -> WarnMsg -> Bool
668 isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
669 = wopt_fatal wflag dflags
670 isWarnMsgFatal dflags _ = gopt Opt_WarnIsError dflags