ErrUtils: Spruce up Haddocks
[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
9 module ErrUtils (
10 -- * Basic types
11 Validity(..), andValid, allValid, isValid, getInvalids,
12 Severity(..),
13
14 -- * Messages
15 MsgDoc, ErrMsg, ErrDoc, errDoc, WarnMsg,
16 Messages, ErrorMessages, WarningMessages,
17 errMsgSpan, errMsgContext,
18 errorsFound, isEmptyMessages,
19
20 -- ** Formatting
21 pprMessageBag, pprErrMsgBagWithLoc,
22 pprLocErrMsg, printBagOfErrors,
23
24 -- ** Construction
25 emptyMessages, mkLocMessage, makeIntoWarning,
26 mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,
27 mkPlainWarnMsg,
28 warnIsErrorMsg, mkLongWarnMsg,
29
30 -- * Utilities
31 doIfSet, doIfSet_dyn,
32
33 -- * Dump files
34 dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
35 mkDumpDoc, dumpSDoc,
36 openDumpFiles, closeDumpFiles,
37
38 -- * Issuing messages during compilation
39 putMsg, printInfoForUser, printOutputForUser,
40 logInfo, logOutput,
41 errorMsg, warningMsg,
42 fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
43 compilationProgressMsg,
44 showPass,
45 debugTraceMsg,
46 ghcExit,
47 prettyPrintGhcErrors,
48 ) where
49
50 #include "HsVersions.h"
51
52 import Bag ( Bag, bagToList, isEmptyBag, emptyBag )
53 import Exception
54 import Outputable
55 import Panic
56 import FastString
57 import SrcLoc
58 import DynFlags
59
60 import System.Directory
61 import System.Exit ( ExitCode(..), exitWith )
62 import System.FilePath ( takeDirectory, (</>) )
63 import Data.List
64 import qualified Data.Map as Map
65 import Data.IORef
66 import Data.Maybe ( fromMaybe )
67 import Data.Ord
68 import Data.Time
69 import Control.Monad
70 import Control.Monad.IO.Class
71 import System.IO
72
73 -------------------------
74 type MsgDoc = SDoc
75
76 -------------------------
77 data Validity
78 = IsValid -- ^ Everything is fine
79 | NotValid MsgDoc -- ^ A problem, and some indication of why
80
81 isValid :: Validity -> Bool
82 isValid IsValid = True
83 isValid (NotValid {}) = False
84
85 andValid :: Validity -> Validity -> Validity
86 andValid IsValid v = v
87 andValid v _ = v
88
89 -- | If they aren't all valid, return the first
90 allValid :: [Validity] -> Validity
91 allValid [] = IsValid
92 allValid (v : vs) = v `andValid` allValid vs
93
94 getInvalids :: [Validity] -> [MsgDoc]
95 getInvalids vs = [d | NotValid d <- vs]
96
97 -- -----------------------------------------------------------------------------
98 -- Basic error messages: just render a message with a source location.
99
100 type Messages = (WarningMessages, ErrorMessages)
101 type WarningMessages = Bag WarnMsg
102 type ErrorMessages = Bag ErrMsg
103
104 data ErrMsg = ErrMsg {
105 errMsgSpan :: SrcSpan,
106 errMsgContext :: PrintUnqualified,
107 errMsgDoc :: ErrDoc,
108 -- | This has the same text as errDocImportant . errMsgDoc.
109 errMsgShortString :: String,
110 errMsgSeverity :: Severity
111 }
112 -- The SrcSpan is used for sorting errors into line-number order
113
114 -- | Categorise error msgs by their importance. This is so each section can
115 -- be rendered visually distinct. See Note [Error report] for where these come
116 -- from.
117 data ErrDoc = ErrDoc {
118 -- | Primary error msg.
119 errDocImportant :: [MsgDoc],
120 -- | Context e.g. \"In the second argument of ...\".
121 _errDocContext :: [MsgDoc],
122 -- | Supplementary information, e.g. \"Relevant bindings include ...\".
123 _errDocSupplementary :: [MsgDoc]
124 }
125
126 errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
127 errDoc = ErrDoc
128
129 type WarnMsg = ErrMsg
130
131 data Severity
132 = SevOutput
133 | SevFatal
134 | SevInteractive
135
136 | SevDump
137 -- ^ Log messagse intended for compiler developers
138 -- No file/line/column stuff
139
140 | SevInfo
141 -- ^ Log messages intended for end users.
142 -- No file/line/column stuff.
143
144 | SevWarning
145 | SevError
146 -- ^ SevWarning and SevError are used for warnings and errors
147 -- o The message has a file/line/column heading,
148 -- plus "warning:" or "error:",
149 -- added by mkLocMessags
150 -- o Output is intended for end users
151
152
153 instance Show ErrMsg where
154 show em = errMsgShortString em
155
156 pprMessageBag :: Bag MsgDoc -> SDoc
157 pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
158
159 mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
160 -- Always print the location, even if it is unhelpful. Error messages
161 -- are supposed to be in a standard format, and one without a location
162 -- would look strange. Better to say explicitly "<no location info>".
163 mkLocMessage severity locn msg
164 = sdocWithDynFlags $ \dflags ->
165 let locn' = if gopt Opt_ErrorSpans dflags
166 then ppr locn
167 else ppr (srcSpanStart locn)
168 in hang (locn' <> colon <+> sev_info) 4 msg
169 where
170 -- Add prefixes, like Foo.hs:34: warning:
171 -- <the warning message>
172 sev_info = case severity of
173 SevWarning -> ptext (sLit "warning:")
174 SevError -> ptext (sLit "error:")
175 SevFatal -> ptext (sLit "fatal:")
176 _ -> empty
177
178 makeIntoWarning :: ErrMsg -> ErrMsg
179 makeIntoWarning err = err { errMsgSeverity = SevWarning }
180
181 -- -----------------------------------------------------------------------------
182 -- Collecting up messages for later ordering and printing.
183
184 mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
185 mk_err_msg dflags sev locn print_unqual doc
186 = ErrMsg { errMsgSpan = locn
187 , errMsgContext = print_unqual
188 , errMsgDoc = doc
189 , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc))
190 , errMsgSeverity = sev }
191
192 mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
193 mkErrDoc dflags = mk_err_msg dflags SevError
194
195 mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
196 -- ^ A long (multi-line) error message
197 mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg
198 -- ^ A short (one-line) error message
199 mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
200 -- ^ Variant that doesn't care about qualified/unqualified names
201
202 mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [extra])
203 mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [])
204 mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify (ErrDoc [msg] [] [])
205 mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [extra])
206 mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [])
207 mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] [])
208
209 ----------------
210 emptyMessages :: Messages
211 emptyMessages = (emptyBag, emptyBag)
212
213 isEmptyMessages :: Messages -> Bool
214 isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs
215
216 warnIsErrorMsg :: DynFlags -> ErrMsg
217 warnIsErrorMsg dflags
218 = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.")
219
220 errorsFound :: DynFlags -> Messages -> Bool
221 errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
222
223 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
224 printBagOfErrors dflags bag_of_errors
225 = sequence_ [ let style = mkErrStyle dflags unqual
226 in log_action dflags dflags sev s style (formatErrDoc dflags doc)
227 | ErrMsg { errMsgSpan = s,
228 errMsgDoc = doc,
229 errMsgSeverity = sev,
230 errMsgContext = unqual } <- sortMsgBag (Just dflags)
231 bag_of_errors ]
232
233 formatErrDoc :: DynFlags -> ErrDoc -> SDoc
234 formatErrDoc dflags (ErrDoc important context supplementary)
235 = case msgs of
236 [msg] -> vcat msg
237 _ -> vcat $ map starred msgs
238 where
239 msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags))
240 [important, context, supplementary]
241 starred = (bullet<+>) . vcat
242 bullet = text $ if DynFlags.useUnicode dflags then "•" else "*"
243
244 pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
245 pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]
246
247 pprLocErrMsg :: ErrMsg -> SDoc
248 pprLocErrMsg (ErrMsg { errMsgSpan = s
249 , errMsgDoc = doc
250 , errMsgSeverity = sev
251 , errMsgContext = unqual })
252 = sdocWithDynFlags $ \dflags ->
253 withPprStyle (mkErrStyle dflags unqual) $
254 mkLocMessage sev s (formatErrDoc dflags doc)
255
256 sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
257 sortMsgBag dflags = sortBy (maybeFlip $ comparing errMsgSpan) . bagToList
258 where maybeFlip :: (a -> a -> b) -> (a -> a -> b)
259 maybeFlip
260 | fromMaybe False (fmap reverseErrors dflags) = flip
261 | otherwise = id
262
263 ghcExit :: DynFlags -> Int -> IO ()
264 ghcExit dflags val
265 | val == 0 = exitWith ExitSuccess
266 | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
267 exitWith (ExitFailure val)
268
269 doIfSet :: Bool -> IO () -> IO ()
270 doIfSet flag action | flag = action
271 | otherwise = return ()
272
273 doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
274 doIfSet_dyn dflags flag action | gopt flag dflags = action
275 | otherwise = return ()
276
277 -- -----------------------------------------------------------------------------
278 -- Dumping
279
280 dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
281 dumpIfSet dflags flag hdr doc
282 | not flag = return ()
283 | otherwise = log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
284
285 -- | a wrapper around 'dumpSDoc'.
286 -- First check whether the dump flag is set
287 -- Do nothing if it is unset
288 dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
289 dumpIfSet_dyn dflags flag hdr doc
290 = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc
291
292 -- | a wrapper around 'dumpSDoc'.
293 -- First check whether the dump flag is set
294 -- Do nothing if it is unset
295 --
296 -- Unlike 'dumpIfSet_dyn',
297 -- has a printer argument but no header argument
298 dumpIfSet_dyn_printer :: PrintUnqualified
299 -> DynFlags -> DumpFlag -> SDoc -> IO ()
300 dumpIfSet_dyn_printer printer dflags flag doc
301 = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc
302
303 -- | a wrapper around 'dumpSDoc'.
304 -- First check whether the dump flag is set
305 -- Do nothing if it is unset
306 --
307 -- Makes a dummy write operation into the dump
308 dumpIfSet_dyn_empty :: DynFlags -> DumpFlag -> IO ()
309 dumpIfSet_dyn_empty dflags flag
310 = when (dopt flag dflags) $ dumpSDoc dflags neverQualify flag "" empty
311
312 mkDumpDoc :: String -> SDoc -> SDoc
313 mkDumpDoc hdr doc
314 = vcat [blankLine,
315 line <+> text hdr <+> line,
316 doc,
317 blankLine]
318 where
319 line = text (replicate 20 '=')
320
321 -- | Open dump files from DynFlags for writing
322 --
323 -- #10320: This function should be called once before the pipe line
324 -- is started. It writes empty data into all requested dumps to initiate
325 -- their creation.
326 openDumpFiles :: DynFlags -> IO ()
327 openDumpFiles dflags
328 = let flags = enumFrom (toEnum 0 :: DumpFlag)
329 in mapM_ (dumpIfSet_dyn_empty dflags) flags
330
331
332 -- | Close all opened dump files
333 --
334 closeDumpFiles :: DynFlags -> IO ()
335 closeDumpFiles dflags
336 = do gd <- readIORef $ generatedDumps dflags
337 mapM_ hClose $ Map.elems gd
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 -> do
354 handle <- getDumpFileHandle dflags fileName
355 doc' <- if null hdr
356 then return doc
357 else do t <- getCurrentTime
358 let d = text (show t)
359 $$ blankLine
360 $$ doc
361 return $ mkDumpDoc hdr d
362 defaultLogActionHPrintDoc dflags handle doc' dump_style
363
364 -- write the dump to stdout
365 Nothing -> do
366 let (doc', severity)
367 | null hdr = (doc, SevOutput)
368 | otherwise = (mkDumpDoc hdr doc, SevDump)
369 log_action dflags dflags severity noSrcSpan dump_style doc'
370
371 -- | Return a handle assigned to the given filename.
372 --
373 -- If the requested file doesn't exist the new one will be created
374 getDumpFileHandle :: DynFlags -> FilePath -> IO Handle
375 getDumpFileHandle dflags fileName
376 = do
377 let gdref = generatedDumps dflags
378 gd <- readIORef gdref
379
380 let mHandle = Map.lookup fileName gd
381 case mHandle of
382 Just handle -> return handle
383
384 Nothing -> do
385 createDirectoryIfMissing True (takeDirectory fileName)
386 handle <- openFile fileName WriteMode
387
388 -- We do not want the dump file to be affected by
389 -- environment variables, but instead to always use
390 -- UTF8. See:
391 -- https://ghc.haskell.org/trac/ghc/ticket/10762
392 hSetEncoding handle utf8
393 writeIORef gdref (Map.insert fileName handle gd)
394
395 return handle
396
397 -- | Choose where to put a dump file based on DynFlags
398 --
399 chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
400 chooseDumpFile dflags flag
401
402 | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file
403 , Just prefix <- getPrefix
404 = Just $ setDir (prefix ++ (beautifyDumpName flag))
405
406 | otherwise
407 = Nothing
408
409 where getPrefix
410 -- dump file location is being forced
411 -- by the --ddump-file-prefix flag.
412 | Just prefix <- dumpPrefixForce dflags
413 = Just prefix
414 -- dump file location chosen by DriverPipeline.runPipeline
415 | Just prefix <- dumpPrefix dflags
416 = Just prefix
417 -- we haven't got a place to put a dump file.
418 | otherwise
419 = Nothing
420 setDir f = case dumpDir dflags of
421 Just d -> d </> f
422 Nothing -> f
423
424 -- | Build a nice file name from name of a 'DumpFlag' constructor
425 beautifyDumpName :: DumpFlag -> String
426 beautifyDumpName Opt_D_th_dec_file = "th.hs"
427 beautifyDumpName flag
428 = let str = show flag
429 suff = case stripPrefix "Opt_D_" str of
430 Just x -> x
431 Nothing -> panic ("Bad flag name: " ++ str)
432 dash = map (\c -> if c == '_' then '-' else c) suff
433 in dash
434
435
436 -- -----------------------------------------------------------------------------
437 -- Outputting messages from the compiler
438
439 -- We want all messages to go through one place, so that we can
440 -- redirect them if necessary. For example, when GHC is used as a
441 -- library we might want to catch all messages that GHC tries to
442 -- output and do something else with them.
443
444 ifVerbose :: DynFlags -> Int -> IO () -> IO ()
445 ifVerbose dflags val act
446 | verbosity dflags >= val = act
447 | otherwise = return ()
448
449 errorMsg :: DynFlags -> MsgDoc -> IO ()
450 errorMsg dflags msg
451 = log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
452
453 warningMsg :: DynFlags -> MsgDoc -> IO ()
454 warningMsg dflags msg
455 = log_action dflags dflags SevWarning noSrcSpan (defaultErrStyle dflags) msg
456
457 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
458 fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
459
460 fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO ()
461 fatalErrorMsg' la dflags msg =
462 la dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg
463
464 fatalErrorMsg'' :: FatalMessager -> String -> IO ()
465 fatalErrorMsg'' fm msg = fm msg
466
467 compilationProgressMsg :: DynFlags -> String -> IO ()
468 compilationProgressMsg dflags msg
469 = ifVerbose dflags 1 $
470 logOutput dflags defaultUserStyle (text msg)
471
472 showPass :: DynFlags -> String -> IO ()
473 showPass dflags what
474 = ifVerbose dflags 2 $
475 logInfo dflags defaultUserStyle (text "***" <+> text what <> colon)
476
477 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
478 debugTraceMsg dflags val msg = ifVerbose dflags val $
479 logInfo dflags defaultDumpStyle msg
480
481 putMsg :: DynFlags -> MsgDoc -> IO ()
482 putMsg dflags msg = logInfo dflags defaultUserStyle msg
483
484 printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
485 printInfoForUser dflags print_unqual msg
486 = logInfo dflags (mkUserStyle print_unqual AllTheWay) msg
487
488 printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
489 printOutputForUser dflags print_unqual msg
490 = logOutput dflags (mkUserStyle print_unqual AllTheWay) msg
491
492 logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
493 logInfo dflags sty msg = log_action dflags dflags SevInfo noSrcSpan sty msg
494
495 logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
496 -- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
497 logOutput dflags sty msg = log_action dflags dflags SevOutput noSrcSpan sty msg
498
499 prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
500 prettyPrintGhcErrors dflags
501 = ghandle $ \e -> case e of
502 PprPanic str doc ->
503 pprDebugAndThen dflags panic (text str) doc
504 PprSorry str doc ->
505 pprDebugAndThen dflags sorry (text str) doc
506 PprProgramError str doc ->
507 pprDebugAndThen dflags pgmError (text str) doc
508 _ ->
509 liftIO $ throwIO e