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