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