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