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