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