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