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