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