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