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