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