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