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