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