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