Merge commit '5229c43ccf77bcbffeced01dccb27398d017fa34'
[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
460 -- | Write out a dump.
461 -- If --dump-to-file is set then this goes to a file.
462 -- otherwise emit to stdout.
463 --
464 -- When @hdr@ is empty, we print in a more compact format (no separators and
465 -- blank lines)
466 --
467 -- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@
468 -- is used; it is not used to decide whether to dump the output
469 dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
470 dumpSDoc dflags print_unqual flag hdr doc
471 = do let mFile = chooseDumpFile dflags flag
472 dump_style = mkDumpStyle dflags print_unqual
473 case mFile of
474 Just fileName
475 -> do
476 let gdref = generatedDumps dflags
477 gd <- readIORef gdref
478 let append = Set.member fileName gd
479 mode = if append then AppendMode else WriteMode
480 unless append $
481 writeIORef gdref (Set.insert fileName gd)
482 createDirectoryIfMissing True (takeDirectory fileName)
483 handle <- openFile fileName mode
484
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://ghc.haskell.org/trac/ghc/ticket/10762
489 hSetEncoding handle utf8
490
491 doc' <- if null hdr
492 then return doc
493 else do t <- getCurrentTime
494 let d = text (show t)
495 $$ blankLine
496 $$ doc
497 return $ mkDumpDoc hdr d
498 defaultLogActionHPrintDoc dflags handle doc' dump_style
499 hClose handle
500
501 -- write the dump to stdout
502 Nothing -> do
503 let (doc', severity)
504 | null hdr = (doc, SevOutput)
505 | otherwise = (mkDumpDoc hdr doc, SevDump)
506 putLogMsg dflags NoReason severity noSrcSpan dump_style doc'
507
508
509 -- | Choose where to put a dump file based on DynFlags
510 --
511 chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
512 chooseDumpFile dflags flag
513
514 | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file
515 , Just prefix <- getPrefix
516 = Just $ setDir (prefix ++ (beautifyDumpName flag))
517
518 | otherwise
519 = Nothing
520
521 where getPrefix
522 -- dump file location is being forced
523 -- by the --ddump-file-prefix flag.
524 | Just prefix <- dumpPrefixForce dflags
525 = Just prefix
526 -- dump file location chosen by DriverPipeline.runPipeline
527 | Just prefix <- dumpPrefix dflags
528 = Just prefix
529 -- we haven't got a place to put a dump file.
530 | otherwise
531 = Nothing
532 setDir f = case dumpDir dflags of
533 Just d -> d </> f
534 Nothing -> f
535
536 -- | Build a nice file name from name of a 'DumpFlag' constructor
537 beautifyDumpName :: DumpFlag -> String
538 beautifyDumpName Opt_D_th_dec_file = "th.hs"
539 beautifyDumpName flag
540 = let str = show flag
541 suff = case stripPrefix "Opt_D_" str of
542 Just x -> x
543 Nothing -> panic ("Bad flag name: " ++ str)
544 dash = map (\c -> if c == '_' then '-' else c) suff
545 in dash
546
547
548 -- -----------------------------------------------------------------------------
549 -- Outputting messages from the compiler
550
551 -- We want all messages to go through one place, so that we can
552 -- redirect them if necessary. For example, when GHC is used as a
553 -- library we might want to catch all messages that GHC tries to
554 -- output and do something else with them.
555
556 ifVerbose :: DynFlags -> Int -> IO () -> IO ()
557 ifVerbose dflags val act
558 | verbosity dflags >= val = act
559 | otherwise = return ()
560
561 errorMsg :: DynFlags -> MsgDoc -> IO ()
562 errorMsg dflags msg
563 = putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg
564
565 warningMsg :: DynFlags -> MsgDoc -> IO ()
566 warningMsg dflags msg
567 = putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg
568
569 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
570 fatalErrorMsg dflags msg =
571 putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg
572
573 fatalErrorMsg'' :: FatalMessager -> String -> IO ()
574 fatalErrorMsg'' fm msg = fm msg
575
576 compilationProgressMsg :: DynFlags -> String -> IO ()
577 compilationProgressMsg dflags msg
578 = ifVerbose dflags 1 $
579 logOutput dflags (defaultUserStyle dflags) (text msg)
580
581 showPass :: DynFlags -> String -> IO ()
582 showPass dflags what
583 = ifVerbose dflags 2 $
584 logInfo dflags (defaultUserStyle dflags) (text "***" <+> text what <> colon)
585
586 -- | Time a compilation phase.
587 --
588 -- When timings are enabled (e.g. with the @-v2@ flag), the allocations
589 -- and CPU time used by the phase will be reported to stderr. Consider
590 -- a typical usage: @withTiming getDynFlags (text "simplify") force pass@.
591 -- When timings are enabled the following costs are included in the
592 -- produced accounting,
593 --
594 -- - The cost of executing @pass@ to a result @r@ in WHNF
595 -- - The cost of evaluating @force r@ to WHNF (e.g. @()@)
596 --
597 -- The choice of the @force@ function depends upon the amount of forcing
598 -- desired; the goal here is to ensure that the cost of evaluating the result
599 -- is, to the greatest extent possible, included in the accounting provided by
600 -- 'withTiming'. Often the pass already sufficiently forces its result during
601 -- construction; in this case @const ()@ is a reasonable choice.
602 -- In other cases, it is necessary to evaluate the result to normal form, in
603 -- which case something like @Control.DeepSeq.rnf@ is appropriate.
604 --
605 -- To avoid adversely affecting compiler performance when timings are not
606 -- requested, the result is only forced when timings are enabled.
607 withTiming :: MonadIO m
608 => m DynFlags -- ^ A means of getting a 'DynFlags' (often
609 -- 'getDynFlags' will work here)
610 -> SDoc -- ^ The name of the phase
611 -> (a -> ()) -- ^ A function to force the result
612 -- (often either @const ()@ or 'rnf')
613 -> m a -- ^ The body of the phase to be timed
614 -> m a
615 withTiming getDFlags what force_result action
616 = do dflags <- getDFlags
617 if verbosity dflags >= 2
618 then do liftIO $ logInfo dflags (defaultUserStyle dflags)
619 $ text "***" <+> what <> colon
620 alloc0 <- liftIO getAllocationCounter
621 start <- liftIO getCPUTime
622 !r <- action
623 () <- pure $ force_result r
624 end <- liftIO getCPUTime
625 alloc1 <- liftIO getAllocationCounter
626 -- recall that allocation counter counts down
627 let alloc = alloc0 - alloc1
628 liftIO $ logInfo dflags (defaultUserStyle dflags)
629 (text "!!!" <+> what <> colon <+> text "finished in"
630 <+> doublePrec 2 (realToFrac (end - start) * 1e-9)
631 <+> text "milliseconds"
632 <> comma
633 <+> text "allocated"
634 <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
635 <+> text "megabytes")
636 pure r
637 else action
638
639 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
640 debugTraceMsg dflags val msg = ifVerbose dflags val $
641 logInfo dflags (defaultDumpStyle dflags) msg
642 putMsg :: DynFlags -> MsgDoc -> IO ()
643 putMsg dflags msg = logInfo dflags (defaultUserStyle dflags) msg
644
645 printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
646 printInfoForUser dflags print_unqual msg
647 = logInfo dflags (mkUserStyle dflags print_unqual AllTheWay) msg
648
649 printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
650 printOutputForUser dflags print_unqual msg
651 = logOutput dflags (mkUserStyle dflags print_unqual AllTheWay) msg
652
653 logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
654 logInfo dflags sty msg
655 = putLogMsg dflags NoReason SevInfo noSrcSpan sty msg
656
657 logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
658 -- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
659 logOutput dflags sty msg
660 = putLogMsg dflags NoReason SevOutput noSrcSpan sty msg
661
662 prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
663 prettyPrintGhcErrors dflags
664 = ghandle $ \e -> case e of
665 PprPanic str doc ->
666 pprDebugAndThen dflags panic (text str) doc
667 PprSorry str doc ->
668 pprDebugAndThen dflags sorry (text str) doc
669 PprProgramError str doc ->
670 pprDebugAndThen dflags pgmError (text str) doc
671 _ ->
672 liftIO $ throwIO e
673
674 -- | Checks if given 'WarnMsg' is a fatal warning.
675 isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)
676 isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
677 = if wopt_fatal wflag dflags
678 then Just (Just wflag)
679 else Nothing
680 isWarnMsgFatal dflags _
681 = if gopt Opt_WarnIsError dflags
682 then Just Nothing
683 else Nothing
684
685 traceCmd :: DynFlags -> String -> String -> IO a -> IO a
686 -- trace the command (at two levels of verbosity)
687 traceCmd dflags phase_name cmd_line action
688 = do { let verb = verbosity dflags
689 ; showPass dflags phase_name
690 ; debugTraceMsg dflags 3 (text cmd_line)
691 ; case flushErr dflags of
692 FlushErr io -> io
693
694 -- And run it!
695 ; action `catchIO` handle_exn verb
696 }
697 where
698 handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
699 ; debugTraceMsg dflags 2
700 (text "Failed:"
701 <+> text cmd_line
702 <+> text (show exn))
703 ; throwGhcExceptionIO (ProgramError (show exn))}