Typos in comments
[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
10 module ErrUtils (
11 -- * Basic types
12 Validity(..), andValid, allValid, isValid, getInvalids,
13 Severity(..),
14
15 -- * Messages
16 ErrMsg, errMsgDoc,
17 ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary,
18 WarnMsg, MsgDoc,
19 Messages, ErrorMessages, WarningMessages,
20 unionMessages,
21 errMsgSpan, errMsgContext,
22 errorsFound, isEmptyMessages,
23 isWarnMsgFatal,
24
25 -- ** Formatting
26 pprMessageBag, pprErrMsgBagWithLoc,
27 pprLocErrMsg, printBagOfErrors,
28 formatErrDoc,
29
30 -- ** Construction
31 emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
32 mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,
33 mkPlainWarnMsg,
34 warnIsErrorMsg, mkLongWarnMsg,
35
36 -- * Utilities
37 doIfSet, doIfSet_dyn,
38
39 -- * Dump files
40 dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
41 mkDumpDoc, dumpSDoc,
42
43 -- * Issuing messages during compilation
44 putMsg, printInfoForUser, printOutputForUser,
45 logInfo, logOutput,
46 errorMsg, warningMsg,
47 fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
48 compilationProgressMsg,
49 showPass, withTiming,
50 debugTraceMsg,
51 ghcExit,
52 prettyPrintGhcErrors,
53 ) where
54
55 #include "HsVersions.h"
56
57 import Bag
58 import Exception
59 import Outputable
60 import Panic
61 import SrcLoc
62 import DynFlags
63
64 import System.Directory
65 import System.Exit ( ExitCode(..), exitWith )
66 import System.FilePath ( takeDirectory, (</>) )
67 import Data.List
68 import qualified Data.Set as Set
69 import Data.IORef
70 import Data.Maybe ( fromMaybe )
71 import Data.Ord
72 import Data.Time
73 import Control.Monad
74 import Control.Monad.IO.Class
75 import System.IO
76 import GHC.Conc ( getAllocationCounter )
77 import System.CPUTime
78
79 -------------------------
80 type MsgDoc = SDoc
81
82 -------------------------
83 data Validity
84 = IsValid -- ^ Everything is fine
85 | NotValid MsgDoc -- ^ A problem, and some indication of why
86
87 isValid :: Validity -> Bool
88 isValid IsValid = True
89 isValid (NotValid {}) = False
90
91 andValid :: Validity -> Validity -> Validity
92 andValid IsValid v = v
93 andValid v _ = v
94
95 -- | If they aren't all valid, return the first
96 allValid :: [Validity] -> Validity
97 allValid [] = IsValid
98 allValid (v : vs) = v `andValid` allValid vs
99
100 getInvalids :: [Validity] -> [MsgDoc]
101 getInvalids vs = [d | NotValid d <- vs]
102
103 -- -----------------------------------------------------------------------------
104 -- Basic error messages: just render a message with a source location.
105
106 type Messages = (WarningMessages, ErrorMessages)
107 type WarningMessages = Bag WarnMsg
108 type ErrorMessages = Bag ErrMsg
109
110 unionMessages :: Messages -> Messages -> Messages
111 unionMessages (warns1, errs1) (warns2, errs2) =
112 (warns1 `unionBags` warns2, errs1 `unionBags` errs2)
113
114 data ErrMsg = ErrMsg {
115 errMsgSpan :: SrcSpan,
116 errMsgContext :: PrintUnqualified,
117 errMsgDoc :: ErrDoc,
118 -- | This has the same text as errDocImportant . errMsgDoc.
119 errMsgShortString :: String,
120 errMsgSeverity :: Severity,
121 errMsgReason :: WarnReason
122 }
123 -- The SrcSpan is used for sorting errors into line-number order
124
125 -- | Categorise error msgs by their importance. This is so each section can
126 -- be rendered visually distinct. See Note [Error report] for where these come
127 -- from.
128 data ErrDoc = ErrDoc {
129 -- | Primary error msg.
130 errDocImportant :: [MsgDoc],
131 -- | Context e.g. \"In the second argument of ...\".
132 errDocContext :: [MsgDoc],
133 -- | Supplementary information, e.g. \"Relevant bindings include ...\".
134 errDocSupplementary :: [MsgDoc]
135 }
136
137 errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
138 errDoc = ErrDoc
139
140 type WarnMsg = ErrMsg
141
142 data Severity
143 = SevOutput
144 | SevFatal
145 | SevInteractive
146
147 | SevDump
148 -- ^ Log messagse intended for compiler developers
149 -- No file/line/column stuff
150
151 | SevInfo
152 -- ^ Log messages intended for end users.
153 -- No file/line/column stuff.
154
155 | SevWarning
156 | SevError
157 -- ^ SevWarning and SevError are used for warnings and errors
158 -- o The message has a file/line/column heading,
159 -- plus "warning:" or "error:",
160 -- added by mkLocMessags
161 -- o Output is intended for end users
162
163
164 instance Show ErrMsg where
165 show em = errMsgShortString em
166
167 pprMessageBag :: Bag MsgDoc -> SDoc
168 pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
169
170 mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
171 mkLocMessage = mkLocMessageAnn Nothing
172
173 mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
174 -- Always print the location, even if it is unhelpful. Error messages
175 -- are supposed to be in a standard format, and one without a location
176 -- would look strange. Better to say explicitly "<no location info>".
177 mkLocMessageAnn ann severity locn msg
178 = sdocWithDynFlags $ \dflags ->
179 let locn' = if gopt Opt_ErrorSpans dflags
180 then ppr locn
181 else ppr (srcSpanStart locn)
182 in hang (locn' <> colon <+> sev_info <> opt_ann) 4 msg
183 where
184 -- Add prefixes, like Foo.hs:34: warning:
185 -- <the warning message>
186 sev_info = case severity of
187 SevWarning -> text "warning:"
188 SevError -> text "error:"
189 SevFatal -> text "fatal:"
190 _ -> empty
191
192 -- Add optional information
193 opt_ann = text $ maybe "" (\i -> " ["++i++"]") ann
194
195 makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
196 makeIntoWarning reason err = err
197 { errMsgSeverity = SevWarning
198 , errMsgReason = reason }
199
200 -- -----------------------------------------------------------------------------
201 -- Collecting up messages for later ordering and printing.
202
203 mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
204 mk_err_msg dflags sev locn print_unqual doc
205 = ErrMsg { errMsgSpan = locn
206 , errMsgContext = print_unqual
207 , errMsgDoc = doc
208 , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc))
209 , errMsgSeverity = sev
210 , errMsgReason = NoReason }
211
212 mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
213 mkErrDoc dflags = mk_err_msg dflags SevError
214
215 mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
216 -- ^ A long (multi-line) error message
217 mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg
218 -- ^ A short (one-line) error message
219 mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
220 -- ^ Variant that doesn't care about qualified/unqualified names
221
222 mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [extra])
223 mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [])
224 mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify (ErrDoc [msg] [] [])
225 mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [extra])
226 mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [])
227 mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] [])
228
229 ----------------
230 emptyMessages :: Messages
231 emptyMessages = (emptyBag, emptyBag)
232
233 isEmptyMessages :: Messages -> Bool
234 isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs
235
236 warnIsErrorMsg :: DynFlags -> ErrMsg
237 warnIsErrorMsg dflags
238 = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.")
239
240 errorsFound :: DynFlags -> Messages -> Bool
241 errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
242
243 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
244 printBagOfErrors dflags bag_of_errors
245 = sequence_ [ let style = mkErrStyle dflags unqual
246 in log_action dflags dflags reason sev s style (formatErrDoc dflags doc)
247 | ErrMsg { errMsgSpan = s,
248 errMsgDoc = doc,
249 errMsgSeverity = sev,
250 errMsgReason = reason,
251 errMsgContext = unqual } <- sortMsgBag (Just dflags)
252 bag_of_errors ]
253
254 formatErrDoc :: DynFlags -> ErrDoc -> SDoc
255 formatErrDoc dflags (ErrDoc important context supplementary)
256 = case msgs of
257 [msg] -> vcat msg
258 _ -> vcat $ map starred msgs
259 where
260 msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags))
261 [important, context, supplementary]
262 starred = (bullet<+>) . vcat
263 bullet = text $ if DynFlags.useUnicode dflags then "•" else "*"
264
265 pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
266 pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]
267
268 pprLocErrMsg :: ErrMsg -> SDoc
269 pprLocErrMsg (ErrMsg { errMsgSpan = s
270 , errMsgDoc = doc
271 , errMsgSeverity = sev
272 , errMsgContext = unqual })
273 = sdocWithDynFlags $ \dflags ->
274 withPprStyle (mkErrStyle dflags unqual) $
275 mkLocMessage sev s (formatErrDoc dflags doc)
276
277 sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
278 sortMsgBag dflags = sortBy (maybeFlip $ comparing errMsgSpan) . bagToList
279 where maybeFlip :: (a -> a -> b) -> (a -> a -> b)
280 maybeFlip
281 | fromMaybe False (fmap reverseErrors dflags) = flip
282 | otherwise = id
283
284 ghcExit :: DynFlags -> Int -> IO ()
285 ghcExit dflags val
286 | val == 0 = exitWith ExitSuccess
287 | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
288 exitWith (ExitFailure val)
289
290 doIfSet :: Bool -> IO () -> IO ()
291 doIfSet flag action | flag = action
292 | otherwise = return ()
293
294 doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
295 doIfSet_dyn dflags flag action | gopt flag dflags = action
296 | otherwise = return ()
297
298 -- -----------------------------------------------------------------------------
299 -- Dumping
300
301 dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
302 dumpIfSet dflags flag hdr doc
303 | not flag = return ()
304 | otherwise = log_action dflags
305 dflags
306 NoReason
307 SevDump
308 noSrcSpan
309 defaultDumpStyle
310 (mkDumpDoc hdr doc)
311
312 -- | a wrapper around 'dumpSDoc'.
313 -- First check whether the dump flag is set
314 -- Do nothing if it is unset
315 dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
316 dumpIfSet_dyn dflags flag hdr doc
317 = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc
318
319 -- | a wrapper around 'dumpSDoc'.
320 -- First check whether the dump flag is set
321 -- Do nothing if it is unset
322 --
323 -- Unlike 'dumpIfSet_dyn',
324 -- has a printer argument but no header argument
325 dumpIfSet_dyn_printer :: PrintUnqualified
326 -> DynFlags -> DumpFlag -> SDoc -> IO ()
327 dumpIfSet_dyn_printer printer dflags flag doc
328 = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc
329
330 mkDumpDoc :: String -> SDoc -> SDoc
331 mkDumpDoc hdr doc
332 = vcat [blankLine,
333 line <+> text hdr <+> line,
334 doc,
335 blankLine]
336 where
337 line = text (replicate 20 '=')
338
339
340 -- | Write out a dump.
341 -- If --dump-to-file is set then this goes to a file.
342 -- otherwise emit to stdout.
343 --
344 -- When @hdr@ is empty, we print in a more compact format (no separators and
345 -- blank lines)
346 --
347 -- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@
348 -- is used; it is not used to decide whether to dump the output
349 dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
350 dumpSDoc dflags print_unqual flag hdr doc
351 = do let mFile = chooseDumpFile dflags flag
352 dump_style = mkDumpStyle print_unqual
353 case mFile of
354 Just fileName
355 -> do
356 let gdref = generatedDumps dflags
357 gd <- readIORef gdref
358 let append = Set.member fileName gd
359 mode = if append then AppendMode else WriteMode
360 unless append $
361 writeIORef gdref (Set.insert fileName gd)
362 createDirectoryIfMissing True (takeDirectory fileName)
363 handle <- openFile fileName mode
364
365 -- We do not want the dump file to be affected by
366 -- environment variables, but instead to always use
367 -- UTF8. See:
368 -- https://ghc.haskell.org/trac/ghc/ticket/10762
369 hSetEncoding handle utf8
370
371 doc' <- if null hdr
372 then return doc
373 else do t <- getCurrentTime
374 let d = text (show t)
375 $$ blankLine
376 $$ doc
377 return $ mkDumpDoc hdr d
378 defaultLogActionHPrintDoc dflags handle doc' dump_style
379 hClose handle
380
381 -- write the dump to stdout
382 Nothing -> do
383 let (doc', severity)
384 | null hdr = (doc, SevOutput)
385 | otherwise = (mkDumpDoc hdr doc, SevDump)
386 log_action dflags dflags NoReason severity noSrcSpan dump_style doc'
387
388
389 -- | Choose where to put a dump file based on DynFlags
390 --
391 chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
392 chooseDumpFile dflags flag
393
394 | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file
395 , Just prefix <- getPrefix
396 = Just $ setDir (prefix ++ (beautifyDumpName flag))
397
398 | otherwise
399 = Nothing
400
401 where getPrefix
402 -- dump file location is being forced
403 -- by the --ddump-file-prefix flag.
404 | Just prefix <- dumpPrefixForce dflags
405 = Just prefix
406 -- dump file location chosen by DriverPipeline.runPipeline
407 | Just prefix <- dumpPrefix dflags
408 = Just prefix
409 -- we haven't got a place to put a dump file.
410 | otherwise
411 = Nothing
412 setDir f = case dumpDir dflags of
413 Just d -> d </> f
414 Nothing -> f
415
416 -- | Build a nice file name from name of a 'DumpFlag' constructor
417 beautifyDumpName :: DumpFlag -> String
418 beautifyDumpName Opt_D_th_dec_file = "th.hs"
419 beautifyDumpName flag
420 = let str = show flag
421 suff = case stripPrefix "Opt_D_" str of
422 Just x -> x
423 Nothing -> panic ("Bad flag name: " ++ str)
424 dash = map (\c -> if c == '_' then '-' else c) suff
425 in dash
426
427
428 -- -----------------------------------------------------------------------------
429 -- Outputting messages from the compiler
430
431 -- We want all messages to go through one place, so that we can
432 -- redirect them if necessary. For example, when GHC is used as a
433 -- library we might want to catch all messages that GHC tries to
434 -- output and do something else with them.
435
436 ifVerbose :: DynFlags -> Int -> IO () -> IO ()
437 ifVerbose dflags val act
438 | verbosity dflags >= val = act
439 | otherwise = return ()
440
441 errorMsg :: DynFlags -> MsgDoc -> IO ()
442 errorMsg dflags msg
443 = log_action dflags dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg
444
445 warningMsg :: DynFlags -> MsgDoc -> IO ()
446 warningMsg dflags msg
447 = log_action dflags dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg
448
449 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
450 fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
451
452 fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO ()
453 fatalErrorMsg' la dflags msg =
454 la dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg
455
456 fatalErrorMsg'' :: FatalMessager -> String -> IO ()
457 fatalErrorMsg'' fm msg = fm msg
458
459 compilationProgressMsg :: DynFlags -> String -> IO ()
460 compilationProgressMsg dflags msg
461 = ifVerbose dflags 1 $
462 logOutput dflags defaultUserStyle (text msg)
463
464 showPass :: DynFlags -> String -> IO ()
465 showPass dflags what
466 = ifVerbose dflags 2 $
467 logInfo dflags defaultUserStyle (text "***" <+> text what <> colon)
468
469 -- | Time a compilation phase.
470 --
471 -- When timings are enabled (e.g. with the @-v2@ flag), the allocations
472 -- and CPU time used by the phase will be reported to stderr. Consider
473 -- a typical usage: @withTiming getDynFlags (text "simplify") force pass@.
474 -- When timings are enabled the following costs are included in the
475 -- produced accounting,
476 --
477 -- - The cost of executing @pass@ to a result @r@ in WHNF
478 -- - The cost of evaluating @force r@ to WHNF (e.g. @()@)
479 --
480 -- The choice of the @force@ function depends upon the amount of forcing
481 -- desired; the goal here is to ensure that the cost of evaluating the result
482 -- is, to the greatest extent possible, included in the accounting provided by
483 -- 'withTiming'. Often the pass already sufficiently forces its result during
484 -- construction; in this case @const ()@ is a reasonable choice.
485 -- In other cases, it is necessary to evaluate the result to normal form, in
486 -- which case something like @Control.DeepSeq.rnf@ is appropriate.
487 --
488 -- To avoid adversely affecting compiler performance when timings are not
489 -- requested, the result is only forced when timings are enabled.
490 withTiming :: MonadIO m
491 => m DynFlags -- ^ A means of getting a 'DynFlags' (often
492 -- 'getDynFlags' will work here)
493 -> SDoc -- ^ The name of the phase
494 -> (a -> ()) -- ^ A function to force the result
495 -- (often either @const ()@ or 'rnf')
496 -> m a -- ^ The body of the phase to be timed
497 -> m a
498 withTiming getDFlags what force_result action
499 = do dflags <- getDFlags
500 if verbosity dflags >= 2
501 then do liftIO $ logInfo dflags defaultUserStyle
502 $ text "***" <+> what <> colon
503 alloc0 <- liftIO getAllocationCounter
504 start <- liftIO getCPUTime
505 !r <- action
506 () <- pure $ force_result r
507 end <- liftIO getCPUTime
508 alloc1 <- liftIO getAllocationCounter
509 -- recall that allocation counter counts down
510 let alloc = alloc0 - alloc1
511 liftIO $ logInfo dflags defaultUserStyle
512 (text "!!!" <+> what <> colon <+> text "finished in"
513 <+> doublePrec 2 (realToFrac (end - start) * 1e-9)
514 <+> text "milliseconds"
515 <> comma
516 <+> text "allocated"
517 <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
518 <+> text "megabytes")
519 pure r
520 else action
521
522 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
523 debugTraceMsg dflags val msg = ifVerbose dflags val $
524 logInfo dflags defaultDumpStyle msg
525
526 putMsg :: DynFlags -> MsgDoc -> IO ()
527 putMsg dflags msg = logInfo dflags defaultUserStyle msg
528
529 printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
530 printInfoForUser dflags print_unqual msg
531 = logInfo dflags (mkUserStyle print_unqual AllTheWay) msg
532
533 printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
534 printOutputForUser dflags print_unqual msg
535 = logOutput dflags (mkUserStyle print_unqual AllTheWay) msg
536
537 logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
538 logInfo dflags sty msg
539 = log_action dflags dflags NoReason SevInfo noSrcSpan sty msg
540
541 logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
542 -- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
543 logOutput dflags sty msg
544 = log_action dflags dflags NoReason SevOutput noSrcSpan sty msg
545
546 prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
547 prettyPrintGhcErrors dflags
548 = ghandle $ \e -> case e of
549 PprPanic str doc ->
550 pprDebugAndThen dflags panic (text str) doc
551 PprSorry str doc ->
552 pprDebugAndThen dflags sorry (text str) doc
553 PprProgramError str doc ->
554 pprDebugAndThen dflags pgmError (text str) doc
555 _ ->
556 liftIO $ throwIO e
557
558 -- | Checks if given 'WarnMsg' is a fatal warning.
559 isWarnMsgFatal :: DynFlags -> WarnMsg -> Bool
560 isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
561 = wopt_fatal wflag dflags
562 isWarnMsgFatal dflags _ = gopt Opt_WarnIsError dflags