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