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