Mention which -Werror promoted a warning to an error
[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, errMsgSeverity, errMsgReason,
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 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 traceCmd
56 ) where
57
58 #include "HsVersions.h"
59
60 import Bag
61 import Exception
62 import Outputable
63 import Panic
64 import qualified PprColour as Col
65 import SrcLoc
66 import DynFlags
67 import FastString (unpackFS)
68 import StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
69 import Json
70
71 import System.Directory
72 import System.Exit ( ExitCode(..), exitWith )
73 import System.FilePath ( takeDirectory, (</>) )
74 import Data.List
75 import qualified Data.Set as Set
76 import Data.IORef
77 import Data.Maybe ( fromMaybe )
78 import Data.Ord
79 import Data.Time
80 import Control.Monad
81 import Control.Monad.IO.Class
82 import System.IO
83 import System.IO.Error ( catchIOError )
84 import GHC.Conc ( getAllocationCounter )
85 import System.CPUTime
86
87 -------------------------
88 type MsgDoc = SDoc
89
90 -------------------------
91 data Validity
92 = IsValid -- ^ Everything is fine
93 | NotValid MsgDoc -- ^ A problem, and some indication of why
94
95 isValid :: Validity -> Bool
96 isValid IsValid = True
97 isValid (NotValid {}) = False
98
99 andValid :: Validity -> Validity -> Validity
100 andValid IsValid v = v
101 andValid v _ = v
102
103 -- | If they aren't all valid, return the first
104 allValid :: [Validity] -> Validity
105 allValid [] = IsValid
106 allValid (v : vs) = v `andValid` allValid vs
107
108 getInvalids :: [Validity] -> [MsgDoc]
109 getInvalids vs = [d | NotValid d <- vs]
110
111 -- -----------------------------------------------------------------------------
112 -- Basic error messages: just render a message with a source location.
113
114 type Messages = (WarningMessages, ErrorMessages)
115 type WarningMessages = Bag WarnMsg
116 type ErrorMessages = Bag ErrMsg
117
118 unionMessages :: Messages -> Messages -> Messages
119 unionMessages (warns1, errs1) (warns2, errs2) =
120 (warns1 `unionBags` warns2, errs1 `unionBags` errs2)
121
122 data ErrMsg = ErrMsg {
123 errMsgSpan :: SrcSpan,
124 errMsgContext :: PrintUnqualified,
125 errMsgDoc :: ErrDoc,
126 -- | This has the same text as errDocImportant . errMsgDoc.
127 errMsgShortString :: String,
128 errMsgSeverity :: Severity,
129 errMsgReason :: WarnReason
130 }
131 -- The SrcSpan is used for sorting errors into line-number order
132
133
134 -- | Categorise error msgs by their importance. This is so each section can
135 -- be rendered visually distinct. See Note [Error report] for where these come
136 -- from.
137 data ErrDoc = ErrDoc {
138 -- | Primary error msg.
139 errDocImportant :: [MsgDoc],
140 -- | Context e.g. \"In the second argument of ...\".
141 errDocContext :: [MsgDoc],
142 -- | Supplementary information, e.g. \"Relevant bindings include ...\".
143 errDocSupplementary :: [MsgDoc]
144 }
145
146 errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
147 errDoc = ErrDoc
148
149 type WarnMsg = ErrMsg
150
151 data Severity
152 = SevOutput
153 | SevFatal
154 | SevInteractive
155
156 | SevDump
157 -- ^ Log message intended for compiler developers
158 -- No file/line/column stuff
159
160 | SevInfo
161 -- ^ Log messages intended for end users.
162 -- No file/line/column stuff.
163
164 | SevWarning
165 | SevError
166 -- ^ SevWarning and SevError are used for warnings and errors
167 -- o The message has a file/line/column heading,
168 -- plus "warning:" or "error:",
169 -- added by mkLocMessags
170 -- o Output is intended for end users
171 deriving Show
172
173
174 instance ToJson Severity where
175 json s = JSString (show s)
176
177
178 instance Show ErrMsg where
179 show em = errMsgShortString em
180
181 pprMessageBag :: Bag MsgDoc -> SDoc
182 pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
183
184 -- | Make an unannotated error message with location info.
185 mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
186 mkLocMessage = mkLocMessageAnn Nothing
187
188 -- | Make a possibly annotated error message with location info.
189 mkLocMessageAnn
190 :: Maybe String -- ^ optional annotation
191 -> Severity -- ^ severity
192 -> SrcSpan -- ^ location
193 -> MsgDoc -- ^ message
194 -> MsgDoc
195 -- Always print the location, even if it is unhelpful. Error messages
196 -- are supposed to be in a standard format, and one without a location
197 -- would look strange. Better to say explicitly "<no location info>".
198 mkLocMessageAnn ann severity locn msg
199 = sdocWithDynFlags $ \dflags ->
200 let locn' = if gopt Opt_ErrorSpans dflags
201 then ppr locn
202 else ppr (srcSpanStart locn)
203
204 sevColour = getSeverityColour severity (colScheme dflags)
205
206 -- Add optional information
207 optAnn = case ann of
208 Nothing -> text ""
209 Just i -> text " [" <> coloured sevColour (text i) <> text "]"
210
211 -- Add prefixes, like Foo.hs:34: warning:
212 -- <the warning message>
213 header = locn' <> colon <+>
214 coloured sevColour sevText <> optAnn
215
216 in coloured (Col.sMessage (colScheme dflags))
217 (hang (coloured (Col.sHeader (colScheme dflags)) header) 4
218 msg)
219
220 where
221 sevText =
222 case severity of
223 SevWarning -> text "warning:"
224 SevError -> text "error:"
225 SevFatal -> text "fatal:"
226 _ -> empty
227
228 getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
229 getSeverityColour SevWarning = Col.sWarning
230 getSeverityColour SevError = Col.sError
231 getSeverityColour SevFatal = Col.sFatal
232 getSeverityColour _ = const mempty
233
234 getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
235 getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
236 getCaretDiagnostic severity (RealSrcSpan span) = do
237 caretDiagnostic <$> getSrcLine (srcSpanFile span) row
238
239 where
240 getSrcLine fn i =
241 getLine i (unpackFS fn)
242 `catchIOError` \_ ->
243 pure Nothing
244
245 getLine i fn = do
246 -- StringBuffer has advantages over readFile:
247 -- (a) no lazy IO, otherwise IO exceptions may occur in pure code
248 -- (b) always UTF-8, rather than some system-dependent encoding
249 -- (Haskell source code must be UTF-8 anyway)
250 content <- hGetStringBuffer fn
251 case atLine i content of
252 Just at_line -> pure $
253 case lines (fix <$> lexemeToString at_line (len at_line)) of
254 srcLine : _ -> Just srcLine
255 _ -> Nothing
256 _ -> pure Nothing
257
258 -- allow user to visibly see that their code is incorrectly encoded
259 -- (StringBuffer.nextChar uses \0 to represent undecodable characters)
260 fix '\0' = '\xfffd'
261 fix c = c
262
263 row = srcSpanStartLine span
264 rowStr = show row
265 multiline = row /= srcSpanEndLine span
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 -- expand tabs in a device-independent manner #13664
285 expandTabs tabWidth i s =
286 case s of
287 "" -> ""
288 '\t' : cs -> replicate effectiveWidth ' ' ++
289 expandTabs tabWidth (i + effectiveWidth) cs
290 c : cs -> c : expandTabs tabWidth (i + 1) cs
291 where effectiveWidth = tabWidth - i `mod` tabWidth
292
293 srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline)
294
295 start = srcSpanStartCol span - 1
296 end | multiline = length srcLine
297 | otherwise = srcSpanEndCol span - 1
298 width = max 1 (end - start)
299
300 marginWidth = length rowStr
301 marginSpace = replicate marginWidth ' ' ++ " |"
302 marginRow = rowStr ++ " |"
303
304 (srcLinePre, srcLineRest) = splitAt start srcLine
305 (srcLineSpan, srcLinePost) = splitAt width srcLineRest
306
307 caretEllipsis | multiline = "..."
308 | otherwise = ""
309 caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis
310
311 makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
312 makeIntoWarning reason err = err
313 { errMsgSeverity = SevWarning
314 , errMsgReason = reason }
315
316 -- -----------------------------------------------------------------------------
317 -- Collecting up messages for later ordering and printing.
318
319 mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
320 mk_err_msg dflags sev locn print_unqual doc
321 = ErrMsg { errMsgSpan = locn
322 , errMsgContext = print_unqual
323 , errMsgDoc = doc
324 , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc))
325 , errMsgSeverity = sev
326 , errMsgReason = NoReason }
327
328 mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
329 mkErrDoc dflags = mk_err_msg dflags SevError
330
331 mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
332 -- ^ A long (multi-line) error message
333 mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg
334 -- ^ A short (one-line) error message
335 mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
336 -- ^ Variant that doesn't care about qualified/unqualified names
337
338 mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [extra])
339 mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [])
340 mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify (ErrDoc [msg] [] [])
341 mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [extra])
342 mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [])
343 mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] [])
344
345 ----------------
346 emptyMessages :: Messages
347 emptyMessages = (emptyBag, emptyBag)
348
349 isEmptyMessages :: Messages -> Bool
350 isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs
351
352 errorsFound :: DynFlags -> Messages -> Bool
353 errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
354
355 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
356 printBagOfErrors dflags bag_of_errors
357 = sequence_ [ let style = mkErrStyle dflags unqual
358 in putLogMsg dflags reason sev s style (formatErrDoc dflags doc)
359 | ErrMsg { errMsgSpan = s,
360 errMsgDoc = doc,
361 errMsgSeverity = sev,
362 errMsgReason = reason,
363 errMsgContext = unqual } <- sortMsgBag (Just dflags)
364 bag_of_errors ]
365
366 formatErrDoc :: DynFlags -> ErrDoc -> SDoc
367 formatErrDoc dflags (ErrDoc important context supplementary)
368 = case msgs of
369 [msg] -> vcat msg
370 _ -> vcat $ map starred msgs
371 where
372 msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags))
373 [important, context, supplementary]
374 starred = (bullet<+>) . vcat
375
376 pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
377 pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]
378
379 pprLocErrMsg :: ErrMsg -> SDoc
380 pprLocErrMsg (ErrMsg { errMsgSpan = s
381 , errMsgDoc = doc
382 , errMsgSeverity = sev
383 , errMsgContext = unqual })
384 = sdocWithDynFlags $ \dflags ->
385 withPprStyle (mkErrStyle dflags unqual) $
386 mkLocMessage sev s (formatErrDoc dflags doc)
387
388 sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
389 sortMsgBag dflags = maybeLimit . sortBy (maybeFlip cmp) . bagToList
390 where maybeFlip :: (a -> a -> b) -> (a -> a -> b)
391 maybeFlip
392 | fromMaybe False (fmap reverseErrors dflags) = flip
393 | otherwise = id
394 cmp = comparing errMsgSpan
395 maybeLimit = case join (fmap maxErrors dflags) of
396 Nothing -> id
397 Just err_limit -> take err_limit
398
399 ghcExit :: DynFlags -> Int -> IO ()
400 ghcExit dflags val
401 | val == 0 = exitWith ExitSuccess
402 | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
403 exitWith (ExitFailure val)
404
405 doIfSet :: Bool -> IO () -> IO ()
406 doIfSet flag action | flag = action
407 | otherwise = return ()
408
409 doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
410 doIfSet_dyn dflags flag action | gopt flag dflags = action
411 | otherwise = return ()
412
413 -- -----------------------------------------------------------------------------
414 -- Dumping
415
416 dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
417 dumpIfSet dflags flag hdr doc
418 | not flag = return ()
419 | otherwise = putLogMsg dflags
420 NoReason
421 SevDump
422 noSrcSpan
423 (defaultDumpStyle dflags)
424 (mkDumpDoc hdr doc)
425
426 -- | a wrapper around 'dumpSDoc'.
427 -- First check whether the dump flag is set
428 -- Do nothing if it is unset
429 dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
430 dumpIfSet_dyn dflags flag hdr doc
431 = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc
432
433 -- | a wrapper around 'dumpSDoc'.
434 -- First check whether the dump flag is set
435 -- Do nothing if it is unset
436 --
437 -- Unlike 'dumpIfSet_dyn',
438 -- has a printer argument but no header argument
439 dumpIfSet_dyn_printer :: PrintUnqualified
440 -> DynFlags -> DumpFlag -> SDoc -> IO ()
441 dumpIfSet_dyn_printer printer dflags flag doc
442 = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc
443
444 mkDumpDoc :: String -> SDoc -> SDoc
445 mkDumpDoc hdr doc
446 = vcat [blankLine,
447 line <+> text hdr <+> line,
448 doc,
449 blankLine]
450 where
451 line = text (replicate 20 '=')
452
453
454 -- | Write out a dump.
455 -- If --dump-to-file is set then this goes to a file.
456 -- otherwise emit to stdout.
457 --
458 -- When @hdr@ is empty, we print in a more compact format (no separators and
459 -- blank lines)
460 --
461 -- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@
462 -- is used; it is not used to decide whether to dump the output
463 dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
464 dumpSDoc dflags print_unqual flag hdr doc
465 = do let mFile = chooseDumpFile dflags flag
466 dump_style = mkDumpStyle dflags print_unqual
467 case mFile of
468 Just fileName
469 -> do
470 let gdref = generatedDumps dflags
471 gd <- readIORef gdref
472 let append = Set.member fileName gd
473 mode = if append then AppendMode else WriteMode
474 unless append $
475 writeIORef gdref (Set.insert fileName gd)
476 createDirectoryIfMissing True (takeDirectory fileName)
477 handle <- openFile fileName mode
478
479 -- We do not want the dump file to be affected by
480 -- environment variables, but instead to always use
481 -- UTF8. See:
482 -- https://ghc.haskell.org/trac/ghc/ticket/10762
483 hSetEncoding handle utf8
484
485 doc' <- if null hdr
486 then return doc
487 else do t <- getCurrentTime
488 let d = text (show t)
489 $$ blankLine
490 $$ doc
491 return $ mkDumpDoc hdr d
492 defaultLogActionHPrintDoc dflags handle doc' dump_style
493 hClose handle
494
495 -- write the dump to stdout
496 Nothing -> do
497 let (doc', severity)
498 | null hdr = (doc, SevOutput)
499 | otherwise = (mkDumpDoc hdr doc, SevDump)
500 putLogMsg dflags NoReason severity noSrcSpan dump_style doc'
501
502
503 -- | Choose where to put a dump file based on DynFlags
504 --
505 chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
506 chooseDumpFile dflags flag
507
508 | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file
509 , Just prefix <- getPrefix
510 = Just $ setDir (prefix ++ (beautifyDumpName flag))
511
512 | otherwise
513 = Nothing
514
515 where getPrefix
516 -- dump file location is being forced
517 -- by the --ddump-file-prefix flag.
518 | Just prefix <- dumpPrefixForce dflags
519 = Just prefix
520 -- dump file location chosen by DriverPipeline.runPipeline
521 | Just prefix <- dumpPrefix dflags
522 = Just prefix
523 -- we haven't got a place to put a dump file.
524 | otherwise
525 = Nothing
526 setDir f = case dumpDir dflags of
527 Just d -> d </> f
528 Nothing -> f
529
530 -- | Build a nice file name from name of a 'DumpFlag' constructor
531 beautifyDumpName :: DumpFlag -> String
532 beautifyDumpName Opt_D_th_dec_file = "th.hs"
533 beautifyDumpName flag
534 = let str = show flag
535 suff = case stripPrefix "Opt_D_" str of
536 Just x -> x
537 Nothing -> panic ("Bad flag name: " ++ str)
538 dash = map (\c -> if c == '_' then '-' else c) suff
539 in dash
540
541
542 -- -----------------------------------------------------------------------------
543 -- Outputting messages from the compiler
544
545 -- We want all messages to go through one place, so that we can
546 -- redirect them if necessary. For example, when GHC is used as a
547 -- library we might want to catch all messages that GHC tries to
548 -- output and do something else with them.
549
550 ifVerbose :: DynFlags -> Int -> IO () -> IO ()
551 ifVerbose dflags val act
552 | verbosity dflags >= val = act
553 | otherwise = return ()
554
555 errorMsg :: DynFlags -> MsgDoc -> IO ()
556 errorMsg dflags msg
557 = putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg
558
559 warningMsg :: DynFlags -> MsgDoc -> IO ()
560 warningMsg dflags msg
561 = putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg
562
563 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
564 fatalErrorMsg dflags msg =
565 putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg
566
567 fatalErrorMsg'' :: FatalMessager -> String -> IO ()
568 fatalErrorMsg'' fm msg = fm msg
569
570 compilationProgressMsg :: DynFlags -> String -> IO ()
571 compilationProgressMsg dflags msg
572 = ifVerbose dflags 1 $
573 logOutput dflags (defaultUserStyle dflags) (text msg)
574
575 showPass :: DynFlags -> String -> IO ()
576 showPass dflags what
577 = ifVerbose dflags 2 $
578 logInfo dflags (defaultUserStyle dflags) (text "***" <+> text what <> colon)
579
580 -- | Time a compilation phase.
581 --
582 -- When timings are enabled (e.g. with the @-v2@ flag), the allocations
583 -- and CPU time used by the phase will be reported to stderr. Consider
584 -- a typical usage: @withTiming getDynFlags (text "simplify") force pass@.
585 -- When timings are enabled the following costs are included in the
586 -- produced accounting,
587 --
588 -- - The cost of executing @pass@ to a result @r@ in WHNF
589 -- - The cost of evaluating @force r@ to WHNF (e.g. @()@)
590 --
591 -- The choice of the @force@ function depends upon the amount of forcing
592 -- desired; the goal here is to ensure that the cost of evaluating the result
593 -- is, to the greatest extent possible, included in the accounting provided by
594 -- 'withTiming'. Often the pass already sufficiently forces its result during
595 -- construction; in this case @const ()@ is a reasonable choice.
596 -- In other cases, it is necessary to evaluate the result to normal form, in
597 -- which case something like @Control.DeepSeq.rnf@ is appropriate.
598 --
599 -- To avoid adversely affecting compiler performance when timings are not
600 -- requested, the result is only forced when timings are enabled.
601 withTiming :: MonadIO m
602 => m DynFlags -- ^ A means of getting a 'DynFlags' (often
603 -- 'getDynFlags' will work here)
604 -> SDoc -- ^ The name of the phase
605 -> (a -> ()) -- ^ A function to force the result
606 -- (often either @const ()@ or 'rnf')
607 -> m a -- ^ The body of the phase to be timed
608 -> m a
609 withTiming getDFlags what force_result action
610 = do dflags <- getDFlags
611 if verbosity dflags >= 2
612 then do liftIO $ logInfo dflags (defaultUserStyle dflags)
613 $ text "***" <+> what <> colon
614 alloc0 <- liftIO getAllocationCounter
615 start <- liftIO getCPUTime
616 !r <- action
617 () <- pure $ force_result r
618 end <- liftIO getCPUTime
619 alloc1 <- liftIO getAllocationCounter
620 -- recall that allocation counter counts down
621 let alloc = alloc0 - alloc1
622 liftIO $ logInfo dflags (defaultUserStyle dflags)
623 (text "!!!" <+> what <> colon <+> text "finished in"
624 <+> doublePrec 2 (realToFrac (end - start) * 1e-9)
625 <+> text "milliseconds"
626 <> comma
627 <+> text "allocated"
628 <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
629 <+> text "megabytes")
630 pure r
631 else action
632
633 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
634 debugTraceMsg dflags val msg = ifVerbose dflags val $
635 logInfo dflags (defaultDumpStyle dflags) msg
636 putMsg :: DynFlags -> MsgDoc -> IO ()
637 putMsg dflags msg = logInfo dflags (defaultUserStyle dflags) msg
638
639 printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
640 printInfoForUser dflags print_unqual msg
641 = logInfo dflags (mkUserStyle dflags print_unqual AllTheWay) msg
642
643 printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
644 printOutputForUser dflags print_unqual msg
645 = logOutput dflags (mkUserStyle dflags print_unqual AllTheWay) msg
646
647 logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
648 logInfo dflags sty msg
649 = putLogMsg dflags NoReason SevInfo noSrcSpan sty msg
650
651 logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
652 -- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
653 logOutput dflags sty msg
654 = putLogMsg dflags NoReason SevOutput noSrcSpan sty msg
655
656 prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
657 prettyPrintGhcErrors dflags
658 = ghandle $ \e -> case e of
659 PprPanic str doc ->
660 pprDebugAndThen dflags panic (text str) doc
661 PprSorry str doc ->
662 pprDebugAndThen dflags sorry (text str) doc
663 PprProgramError str doc ->
664 pprDebugAndThen dflags pgmError (text str) doc
665 _ ->
666 liftIO $ throwIO e
667
668 -- | Checks if given 'WarnMsg' is a fatal warning.
669 isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)
670 isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
671 = if wopt_fatal wflag dflags
672 then Just (Just wflag)
673 else Nothing
674 isWarnMsgFatal dflags _
675 = if gopt Opt_WarnIsError dflags
676 then Just Nothing
677 else Nothing
678
679 traceCmd :: DynFlags -> String -> String -> IO a -> IO a
680 -- trace the command (at two levels of verbosity)
681 traceCmd dflags phase_name cmd_line action
682 = do { let verb = verbosity dflags
683 ; showPass dflags phase_name
684 ; debugTraceMsg dflags 3 (text cmd_line)
685 ; case flushErr dflags of
686 FlushErr io -> io
687
688 -- And run it!
689 ; action `catchIO` handle_exn verb
690 }
691 where
692 handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
693 ; debugTraceMsg dflags 2
694 (text "Failed:"
695 <+> text cmd_line
696 <+> text (show exn))
697 ; throwGhcExceptionIO (ProgramError (show exn))}