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